some progress towards self hosting

TODO.FACTOR.txt

@@ -1,5 +1,8 @@
 + native:
 
+ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable" ]
+
+- decide if overflow is a fatal error
 - f >n: crashes
 - typecases: type error reporting bad
 - image output
@@ -13,7 +16,6 @@
 - inspector: sort
 - index of str
 - accept: return socket, instead of printing msg
-- crash: [ primitives, ] with-image .
 - enforce bottom-up in native bootstrap
 
 + interactive:

build.sh

@@ -6,3 +6,8 @@ export CFLAGS="-pedantic -Wall -Winline -Os -march=pentium4 -fomit-frame-pointer
 $CC $CFLAGS -o f native/*.c
 
 strip f
+
+#export CC=gcc
+#export CFLAGS="-pedantic -Wall -g"
+#
+#$CC $CFLAGS -o f-debug native/*.c

library/image.factor

@@ -69,7 +69,6 @@ USE: words
 : object-tag BIN: 011 ;
 : header-tag BIN: 100 ;
 
-: fixnum-mask HEX: 1fffffff ;
 : immediate ( x tag -- tagged ) swap tag-bits shift< bitor ;
 : >header ( id -- tagged ) header-tag immediate ;
 
@@ -137,7 +136,7 @@ USE: words
     dup pooled-object dup [
         nip swap fixup
     ] [
-        drop "Not in image: " swap cat2 throw
+        drop "Not in image: " swap word-name cat2 throw
     ] ifte ;
 
 : fixup-words ( -- )
@@ -184,7 +183,7 @@ DEFER: '
     object-tag here-as swap
     11 >header emit
     dup str-length emit
-    dup hashcode ( fixnum-mask bitand ) emit
+    dup hashcode emit
     pack-string
     pad ;
 

library/lists.factor

@@ -31,6 +31,7 @@ USE: combinators
 USE: kernel
 USE: logic
 USE: stack
+USE: vectors
 
 : 2list ( a b -- [ a b ] )
     #! Construct a proper list of 2 elements.
@@ -338,3 +339,12 @@ DEFER: tree-contains?
         cons-hashcode r>
         xor
     ] ifte ;
+
+: list>vector ( list -- vector )
+    dup length <vector> swap [ over vector-push ] each ;
+
+: stack>list ( vector -- list )
+    [ ] swap [ swons ] vector-each ;
+
+: vector>list ( vector -- list )
+    stack>list nreverse ;

library/platform/jvm/vectors.factor

@@ -41,17 +41,6 @@ USE: stack
 : set-vector-length ( vector -- length )
     "factor.FactorArray" "top" jvar-set ;
 
-: vector>list ( vector -- list )
-    #! Turns a vector into a list.
-    [ ] "factor.FactorArray" "toList" jinvoke ;
-
-: stack>list ( vector -- list )
-    #! Turns a vector into a list.
-    vector>list ;
-
-: list>vector ( list -- vector )
-    [ "factor.Cons" ] "factor.FactorArray" jnew ;
-
 : vector-nth ( index vector -- )
     [ "int" ] "factor.FactorArray" "get" jinvoke ;
 

library/platform/native/boot.factor

@@ -92,7 +92,6 @@ primitives,
     "/library/platform/native/prettyprint.factor"
     "/library/platform/native/stack.factor"
     "/library/platform/native/words.factor"
-    "/library/platform/native/vectors.factor"
     "/library/platform/native/vocabularies.factor"
     "/library/platform/native/unparser.factor"
     "/library/platform/native/cross-compiler.factor"

library/platform/native/errors.factor

@@ -63,6 +63,7 @@ USE: vectors
         "Bad primitive: "
         "Incompatible handle: "
         "I/O error: "
+        "Overflow"
     ] ?nth ;
 
 : ?kernel-error ( cons -- error# param )

library/platform/native/parse-numbers.factor

@@ -79,3 +79,6 @@ USE: unparser
             drop (str>fixnum)
         ] ifte
     ] ifte ;
+
+: parse-number ( str -- num/f )
+    [ str>fixnum ] [ [ drop f ] when ] catch ;

library/platform/native/parse-syntax.factor

@@ -36,6 +36,7 @@ USE: namespaces
 USE: stack
 USE: strings
 USE: words
+USE: vectors
 USE: vocabularies
 USE: unparser
 
@@ -49,7 +50,7 @@ IN: builtins
 : f f parsed ; parsing
 
 ! Lists
-: [ f ; parsing
+: [ [ ] ; parsing
 : ] nreverse parsed ; parsing
 
 : | ( syntax: | cdr ] )
@@ -57,17 +58,23 @@ IN: builtins
     #! 'parsed' acts accordingly.
     "|" ; parsing
 
+! Vectors
+: { f ; parsing
+: } nreverse list>vector parsed ; parsing
+
 ! Colon defs
+: CREATE: scan "in" get create ;
+
 : :
     #! Begin a word definition. Word name follows.
-    scan "in" get create f ; parsing
+    CREATE: [ ] ; parsing
 
 : ;
     #! End a word definition.
     nreverse define ; parsing
 
 ! Vocabularies
-: DEFER: scan "in" get create drop ; parsing
+: DEFER: CREATE: drop ; parsing
 : USE: scan "use" cons@ ; parsing
 : IN: scan dup "use" cons@ "in" set ; parsing
 

library/platform/native/vectors.factor

@@ -1,36 +0,0 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-! 
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: vectors
-USE: lists
-USE: stack
-
-: stack>list ( vector -- list )
-    [ ] swap [ swons ] vector-each ;
-
-: vector>list ( vector -- list )
-    stack>list nreverse ;

library/vectors.factor

@@ -28,6 +28,7 @@
 IN: vectors
 USE: arithmetic
 USE: kernel
+USE: lists
 USE: stack
 
 : vector-empty? ( obj -- ? )

native/error.c

@@ -15,9 +15,9 @@ void critical_error(char* msg, CELL tagged)
 
 void fix_stacks(void)
 {
-	if(env.ds < env.ds_bot + sizeof(ARRAY))
+	if(UNDERFLOW(env.ds,env.ds_bot) || OVERFLOW(env.ds,env.ds_bot))
 		reset_datastack();
-	if(env.cs <= env.cs_bot + sizeof(ARRAY))
+	if(UNDERFLOW(env.cs,env.cs_bot) || OVERFLOW(env.cs,env.cs_bot))
 		reset_callstack();
 }
 

native/error.h

@@ -6,6 +6,7 @@
 #define ERROR_BAD_PRIMITIVE (5<<3)
 #define ERROR_HANDLE_INCOMPAT (6<<3)
 #define ERROR_IO (7<<3)
+#define ERROR_OVERFLOW (8<<3)
 
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);

native/gc.c

@@ -31,15 +31,16 @@ void copy_object(CELL* handle)
 	CELL tag = TAG(pointer);
 	CELL header, newpointer;
 
-	if(in_zone(active,pointer))
-		critical_error("copy_object given newspace ptr",pointer);
-
 	if(tag == FIXNUM_TYPE)
 	{
 		/* convinience */
+		gc_debug("FIXNUM",pointer);
 		return;
 	}
 	
+	if(in_zone(active,pointer))
+		critical_error("copy_object given newspace ptr",pointer);
+
 	header = get(UNTAG(pointer));
 	
 	if(TAG(header) == GC_COLLECTED)
@@ -83,6 +84,7 @@ void collect_object(void)
 		break;
 	case HANDLE_TYPE:
 		collect_handle((HANDLE*)scan);
+		break;
 	}
 	
 	scan += size;

native/stack.h

@@ -1,5 +1,6 @@
 #define UNDERFLOW_CHECKING
 
+#define UNDERFLOW(stack,bot) ((stack) < UNTAG(bot) + sizeof(ARRAY))
 #define OVERFLOW(stack,bot) ((stack) >= UNTAG(bot) + object_size(bot))
 
 INLINE void check_stacks(void)
@@ -7,9 +8,9 @@ INLINE void check_stacks(void)
 
 #ifdef UNDERFLOW_CHECKING
 	if(OVERFLOW(env.ds,env.ds_bot))
-		fatal_error("datastack overflow",env.ds);
+		general_error(ERROR_OVERFLOW,F);
 	if(OVERFLOW(env.cs,env.cs_bot))
-		fatal_error("callstack overflow",env.ds);
+		general_error(ERROR_OVERFLOW,F);
 #endif
 
 }

native/types.c

@@ -99,6 +99,9 @@ CELL untagged_object_size(CELL pointer)
 	case SBUF_TYPE:
 		size = sizeof(SBUF);
 		break;
+	case BIGNUM_TYPE:
+		size = sizeof(BIGNUM);
+		break;
 	case HANDLE_TYPE:
 		size = sizeof(HANDLE);
 		break;

native/vector.c

@@ -46,7 +46,7 @@ void primitive_vector_nth(void)
 	env.dt = array_nth(vector->array,index);
 }
 
-void vector_ensure_capacity(VECTOR* vector, int index)
+void vector_ensure_capacity(VECTOR* vector, CELL index)
 {
 	ARRAY* array = vector->array;
 	CELL capacity = array->capacity;

native/vector.h

@@ -20,7 +20,7 @@ void primitive_vector(void);
 void primitive_vector_length(void);
 void primitive_set_vector_length(void);
 void primitive_vector_nth(void);
-void vector_ensure_capacity(VECTOR* vector, int index);
+void vector_ensure_capacity(VECTOR* vector, CELL index);
 void primitive_set_vector_nth(void);
 void fixup_vector(VECTOR* vector);
 void collect_vector(VECTOR* vector);