From de95f233de8d8524cecc6946e960f09a3551ad8b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 31 Jul 2004 18:58:16 +0000
Subject: [PATCH] some progress towards self hosting

---
 TODO.FACTOR.txt                              |  4 ++-
 build.sh                                     |  5 +++
 library/image.factor                         |  5 ++-
 library/lists.factor                         | 10 ++++++
 library/platform/jvm/vectors.factor          | 11 ------
 library/platform/native/boot.factor          |  1 -
 library/platform/native/errors.factor        |  1 +
 library/platform/native/parse-numbers.factor |  3 ++
 library/platform/native/parse-syntax.factor  | 13 +++++--
 library/platform/native/vectors.factor       | 36 --------------------
 library/vectors.factor                       |  1 +
 native/error.c                               |  4 +--
 native/error.h                               |  1 +
 native/gc.c                                  |  8 +++--
 native/stack.h                               |  5 +--
 native/types.c                               |  3 ++
 native/vector.c                              |  2 +-
 native/vector.h                              |  2 +-
 18 files changed, 51 insertions(+), 64 deletions(-)
 delete mode 100644 library/platform/native/vectors.factor

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index da7819cfb4..1d50330c55 100644
--- a/TODO.FACTOR.txt
+++ b/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:
diff --git a/build.sh b/build.sh
index cb1bece2dc..335db6cef2 100644
--- a/build.sh
+++ b/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
diff --git a/library/image.factor b/library/image.factor
index 0693086ced..f174ee51b6 100644
--- a/library/image.factor
+++ b/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 ;
 
diff --git a/library/lists.factor b/library/lists.factor
index 1f5bd9cfa4..415c079c6a 100644
--- a/library/lists.factor
+++ b/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 ;
diff --git a/library/platform/jvm/vectors.factor b/library/platform/jvm/vectors.factor
index b154c85bd6..ecf149320e 100644
--- a/library/platform/jvm/vectors.factor
+++ b/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 ;
 
diff --git a/library/platform/native/boot.factor b/library/platform/native/boot.factor
index 79b5e8877f..ce6de3d482 100644
--- a/library/platform/native/boot.factor
+++ b/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"
diff --git a/library/platform/native/errors.factor b/library/platform/native/errors.factor
index 344cfdf963..19c08005e4 100644
--- a/library/platform/native/errors.factor
+++ b/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 )
diff --git a/library/platform/native/parse-numbers.factor b/library/platform/native/parse-numbers.factor
index 906559c588..6348d4cbe8 100644
--- a/library/platform/native/parse-numbers.factor
+++ b/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 ;
diff --git a/library/platform/native/parse-syntax.factor b/library/platform/native/parse-syntax.factor
index b30ea49cb7..1cd207f350 100644
--- a/library/platform/native/parse-syntax.factor
+++ b/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
 
diff --git a/library/platform/native/vectors.factor b/library/platform/native/vectors.factor
deleted file mode 100644
index 06ce9c7f3d..0000000000
--- a/library/platform/native/vectors.factor
+++ /dev/null
@@ -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 ;
diff --git a/library/vectors.factor b/library/vectors.factor
index ba4d48db99..8ddbb8f299 100644
--- a/library/vectors.factor
+++ b/library/vectors.factor
@@ -28,6 +28,7 @@
 IN: vectors
 USE: arithmetic
 USE: kernel
+USE: lists
 USE: stack
 
 : vector-empty? ( obj -- ? )
diff --git a/native/error.c b/native/error.c
index a85b7d31b0..a7a83cf0ab 100644
--- a/native/error.c
+++ b/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();
 }
 
diff --git a/native/error.h b/native/error.h
index 74677341aa..57d3be328b 100644
--- a/native/error.h
+++ b/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);
diff --git a/native/gc.c b/native/gc.c
index ec4039f60a..13f64d9e22 100644
--- a/native/gc.c
+++ b/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;
diff --git a/native/stack.h b/native/stack.h
index ee24960203..f2734f1cbd 100644
--- a/native/stack.h
+++ b/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
 
 }
diff --git a/native/types.c b/native/types.c
index 2e86963092..cc86afa567 100644
--- a/native/types.c
+++ b/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;
diff --git a/native/vector.c b/native/vector.c
index a2ea50409b..880e8e32ec 100644
--- a/native/vector.c
+++ b/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;
diff --git a/native/vector.h b/native/vector.h
index 8683dbf076..074bb36bb2 100644
--- a/native/vector.h
+++ b/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);
-- 
2.34.1