more compiler work, a few java factor fixes

TODO.FACTOR.txt

@@ -4,11 +4,16 @@
 - plugin should not exit jEdit on fatal errors
 - wordpreview: don't show for string literals and comments
 - alist -vs- assoc terminology
+- NPE in activate()/deactivate()
+- write-icon kind of messy; " " should be output by the listener
+- f usages. --> don't print all words
+- file responder: don't show full path in title
+
 - clean up listener's action popups
 - jedit ==> jedit-word, jedit takes a file name
 - introduce ifte* and ?str-head/?str-tail where appropriate
 - namespace clone drops static var bindings
-<kc5tja> The binary register ordering, from 0 to 7, is EAX, ECX, EDX, EBX, ESP, EBP, ESI, EDI.
+- when running (inf, .factor-rc not loaded
 
 + bignums:
 
@@ -44,7 +49,6 @@
 
 + listener/plugin:
 
-- NPE in activate()/deactivate()
 - NPE in ErrorHighlight
 - some way to not have previous definitions from a source file
   clutter the namespace
@@ -82,11 +86,6 @@
 
 + misc:
 
-- write-icon kind of messy; " " should be output by the listener
-- f usages. --> don't print all words
-- pipe support
-- telnetd: init-history
-- str-reverse primitive
 - some way to run httpd from command line
 - don't rehash strings on every startup
 - 'cascading' styles

factor/FactorLib.java

@@ -216,6 +216,11 @@ public class FactorLib
 				break;
 			buf.append((char)b);
 		}
+
+		/* EOF? */
+		if(b == -1 && buf.length() == 0)
+			return null;
+		else
 			return buf.toString();
 	} //}}}
 

factor/compiler/FlowObject.java

@@ -173,11 +173,25 @@ implements Constants, FactorExternalizable, PublicCloneable
 		}
 		else
 		{
-			mw.visitMethodInsn(INVOKESTATIC,
+			String signature;
-				"factor/FactorJava",
+			if(type.isArray())
-				methodName,
+			{
-				"(Ljava/lang/Object;)"
+				signature = "(Ljava/lang/Object;)"
-				+ FactorJava.javaClassToVMClass(type));
+					+ "[Ljava/lang/Object;";
+			}
+			else
+			{
+				signature = "(Ljava/lang/Object;)"
+					+ FactorJava.javaClassToVMClass(type);
+			}
+			mw.visitMethodInsn(INVOKESTATIC,"factor/FactorJava",
+				methodName,signature);
+			/* if(type.isArray())
+			{
+				mw.visitTypeInsn(CHECKCAST,
+					type.getName()
+					.replace('.','/'));
+			} */
 		}
 	} //}}}
 

factor/jedit/FactorPlugin.java

@@ -309,6 +309,7 @@ public class FactorPlugin extends EditPlugin
 
 		Buffer buffer = view.getBuffer();
 		int lastUseOffset = 0;
+		boolean trailingNewline = false;
 
 		for(int i = 0; i < buffer.getLineCount(); i++)
 		{
@@ -325,12 +326,17 @@ public class FactorPlugin extends EditPlugin
 					lastUseOffset = buffer.getLineEndOffset(i-1) - 1;
 			}
 			else
+			{
+				trailingNewline = true;
 				break;
 			}
+		}
 
 		String decl = "USE: " + vocab;
 		if(lastUseOffset != 0)
 			decl = "\n" + decl;
+		if(trailingNewline)
+			decl = decl + "\n";
 		buffer.insert(lastUseOffset,decl);
 		showStatus(view,"inserted-use",decl);
 	} //}}}

library/compiler/assembler.factor

@@ -0,0 +1,58 @@
+! :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: compiler
+USE: math
+USE: kernel
+USE: stack
+
+: cell 4 ;
+: literal-table 1024 cell * ;
+
+: init-assembler ( -- )
+    compiled-offset literal-table + set-compiled-offset ;
+
+: intern-literal ( obj -- lit# )
+    address-of
+    literal-top set-compiled-cell
+    literal-top dup cell + set-literal-top ;
+
+: compile-byte ( n -- )
+    compiled-offset set-compiled-byte
+    compiled-offset 1 + set-compiled-offset ;
+
+: compile-cell ( n -- )
+    compiled-offset set-compiled-cell
+    compiled-offset cell + set-compiled-offset ;
+
+: DATASTACK ( -- ptr )
+    #! A pointer to a pointer to the datastack top.
+    11 getenv ;
+
+: CALLSTACK ( -- ptr )
+    #! A pointer to a pointer to the callstack top.
+    12 getenv ;

library/compiler/assembly-x86.factor

@@ -0,0 +1,106 @@
+! :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: compiler
+USE: kernel
+USE: compiler
+USE: math
+USE: stack
+
+: EAX 0 ;
+: ECX 1 ;
+: EDX 2 ;
+: EBX 3 ;
+: ESP 4 ;
+: EBP 5 ;
+: ESI 6 ;
+: EDI 7 ;
+
+: PUSH ( reg -- )
+    HEX: 50 + compile-byte ;
+
+: POP ( reg -- )
+    HEX: 58 + compile-byte ;
+
+: I>R ( imm reg -- )
+    #! MOV <imm> TO <reg>
+    HEX: b8 + compile-byte  compile-cell ;
+
+: [I]>R ( imm reg -- )
+    #! MOV INDIRECT <imm> TO <reg>
+    HEX: a1 + compile-byte  compile-cell ;
+
+: I>[R] ( imm reg -- )
+    #! MOV <imm> TO INDIRECT <reg>
+    HEX: c7 compile-byte  compile-byte  compile-cell ;
+
+: [R]>R ( reg reg -- )
+    #! MOV INDIRECT <reg> TO <reg>.
+    HEX: 8b compile-byte  swap 3 shift bitor compile-byte ;
+
+: R>[R] ( reg reg -- )
+    #! MOV <reg> TO INDIRECT <reg>.
+    HEX: 89 compile-byte  swap 3 shift bitor compile-byte ;
+
+: I+[I] ( imm addr -- )
+    #! ADD <imm> TO ADDRESS <addr>
+    HEX: 81 compile-byte
+    HEX: 05 compile-byte
+    compile-cell
+    compile-cell ;
+
+: LITERAL ( cell -- )
+    #! Push literal on data stack.
+    #! Assume that it is ok to clobber EAX without saving.
+    DATASTACK EAX [I]>R
+    EAX I>[R]
+    4 DATASTACK I+[I] ;
+
+: [LITERAL] ( cell -- )
+    #! Push literal on data stack by following an indirect
+    #! pointer.
+    ECX PUSH
+    ( cell -- ) ECX I>R
+    ECX ECX [R]>R
+    DATASTACK EAX [I]>R
+    ECX EAX R>[R]
+    4 DATASTACK I+[I]
+    ECX POP ;
+
+: (JMP) ( xt opcode -- )
+    #! JMP, CALL insn is 5 bytes long
+    #! addr is relative to *after* insn
+    compile-byte  compiled-offset 4 + - compile-cell ;
+
+: JMP ( -- )
+    HEX: e9 (JMP) ;
+
+: CALL ( -- )
+    HEX: e8 (JMP) ;
+
+: RET ( -- )
+    HEX: c3 compile-byte ;

library/compiler/compiler.factor

@@ -0,0 +1,88 @@
+! :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: compiler
+USE: math
+USE: stack
+USE: lists
+USE: combinators
+USE: words
+USE: namespaces
+USE: unparser
+USE: errors
+USE: strings
+USE: logic
+USE: kernel
+USE: vectors
+
+: compile-word ( word -- )
+    #! Compile a JMP at the end (tail call optimization)
+    word-xt "compile-last" get [ JMP ] [ CALL ] ifte ;
+
+: compile-literal ( obj -- )
+    dup fixnum? [
+        address-of LITERAL
+    ] [
+        intern-literal [LITERAL]
+    ] ifte ;
+
+: commit-literals ( -- )
+    "compile-datastack" get dup [ compile-literal ] vector-each
+    0 swap set-vector-length ;
+
+: postpone ( obj -- )
+    "compile-datastack" get vector-push ;
+
+: compile-atom ( obj -- )
+    [
+        [ word? ] [ commit-literals compile-word ]
+        [ drop t ] [ postpone ]
+    ] cond ;
+
+: compile-loop ( quot -- )
+    dup [
+        unswons
+        over not "compile-last" set
+        compile-atom
+        compile-loop
+    ] [
+        commit-literals drop RET
+    ] ifte ;
+
+: compile-quot ( quot -- xt )
+    [
+        "compile-last" off
+        10 <vector> "compile-datastack" set
+        compiled-offset swap compile-loop
+    ] with-scope ;
+
+: compile ( word -- )
+    intern dup word-parameter compile-quot swap set-word-xt ;
+
+: call-xt ( xt -- )
+    #! For testing.
+    0 f f <word> [ set-word-xt ] keep execute ;

library/cross-compiler.factor

@@ -42,9 +42,12 @@ USE: vectors
 USE: words
 
 IN: compiler
-DEFER: compile-byte
+DEFER: set-compiled-byte
-DEFER: compile-cell
+DEFER: set-compiled-cell
-DEFER: compile-offset
+DEFER: compiled-offset
+DEFER: set-compiled-offset
+DEFER: literal-top
+DEFER: set-literal-top
 
 IN: kernel
 DEFER: getenv
@@ -54,6 +57,7 @@ DEFER: room
 DEFER: os-env
 DEFER: type-of
 DEFER: size-of
+DEFER: address-of
 DEFER: dump
 
 IN: strings
@@ -150,6 +154,7 @@ IN: cross-compiler
         str-hashcode
         index-of*
         substring
+        str-reverse
         sbuf?
         <sbuf>
         sbuf-length
@@ -277,9 +282,13 @@ IN: cross-compiler
         dump
         cwd
         cd
-        compile-byte
+        set-compiled-byte
-        compile-cell
+        set-compiled-cell
-        compile-offset
+        compiled-offset
+        set-compiled-offset
+        literal-top
+        set-literal-top
+        address-of
     ] [
         swap succ tuck primitive,
     ] each drop ;

library/platform/jvm/sbuf.factor

@@ -58,3 +58,7 @@ USE: stack
 : sbuf-reverse ( sbuf -- )
     #! Destructively reverse a string buffer.
     [ ] "java.lang.StringBuffer" "reverse" jinvoke drop ;
+
+DEFER: str>sbuf
+: str-reverse ( str -- str )
+    str>sbuf dup sbuf-reverse sbuf>str ;

library/platform/jvm/stream.factor

@@ -112,8 +112,8 @@ USE: strings
     #! java.io.OutputStream out. The streams are wrapped in
     #! buffered streams.
     <stream> [
-        <bout> "out" set
+        "out" set
-        <bin> "in" set
+        "in" set
         ( -- string )
         [ <byte-stream>/freadln ] "freadln" set
         ( count -- string )
@@ -191,12 +191,12 @@ USE: strings
     <char-stream> ;
 
 : <filebr> ( path -- stream )
-    [ "java.lang.String" ] "java.io.FileInputStream" jnew
+    [ "java.lang.String" ] "java.io.FileInputStream" jnew <bin>
     f
     <byte-stream> ;
 
 : <filebw> ( path -- stream )
-    [ "java.lang.String" ] "java.io.FileOutputStream" jnew
+    [ "java.lang.String" ] "java.io.FileOutputStream" jnew <bout>
     f swap
     <byte-stream> ;
 
@@ -232,8 +232,8 @@ USE: strings
 : <socket-stream> ( socket -- stream )
     #! Wraps a socket inside a byte-stream.
     dup
-    [ [ ] "java.net.Socket" "getInputStream"  jinvoke ]
+    [ [ ] "java.net.Socket" "getInputStream"  jinvoke <bin> ]
-    [ [ ] "java.net.Socket" "getOutputStream" jinvoke ]
+    [ [ ] "java.net.Socket" "getOutputStream" jinvoke <bout> ]
     cleave
     <byte-stream> [
         dup >str "client" set "socket" set

library/platform/native/boot-stage2.factor

@@ -109,7 +109,6 @@ USE: stdio
     "/library/telnetd.factor"
     "/library/inferior.factor"
     "/library/platform/native/profiler.factor"
-    "/library/platform/native/compiler.factor"
 
     "/library/image.factor"
     "/library/cross-compiler.factor"
@@ -132,6 +131,10 @@ USE: stdio
     "/library/jedit/jedit-remote.factor"
     "/library/jedit/jedit.factor"
 
+    "/library/compiler/assembler.factor"
+    "/library/compiler/assembly-x86.factor"
+    "/library/compiler/compiler.factor"
+
     "/library/platform/native/primitives.factor"
 
     "/library/init.factor"

library/platform/native/compiler.factor

@@ -1,90 +0,0 @@
-IN: compiler
-USE: math
-USE: stack
-USE: lists
-USE: combinators
-USE: words
-USE: namespaces
-USE: unparser
-USE: errors
-USE: strings
-USE: logic
-USE: kernel
-
-: DATASTACK
-    #! A pointer to a pointer to the datastack top.
-    11 getenv ;
-
-: EAX 0 ;
-: ECX 1 ;
-: EDX 2 ;
-: EBX 3 ;
-: ESP 4 ;
-: EBP 5 ;
-: ESI 6 ;
-: EDI 7 ;
-
-: I>R ( imm reg -- )
-    #! MOV <imm> TO <reg>
-    HEX: a1 + compile-byte  compile-cell ;
-
-: I>[R] ( imm reg -- )
-    #! MOV <imm> TO ADDRESS <reg>
-    HEX: c7 compile-byte  compile-byte  compile-cell ;
-
-: I+[I] ( imm addr -- )
-    #! ADD <imm> TO ADDRESS <addr>
-    HEX: 81 compile-byte
-    HEX: 05 compile-byte
-    compile-cell
-    compile-cell ;
-
-: LITERAL ( cell -- )
-    #! Push literal on data stack.
-    DATASTACK EAX I>R  EAX I>[R] 4 DATASTACK I+[I] ;
-
-: (JMP) ( xt opcode -- )
-    #! JMP, CALL insn is 5 bytes long
-    #! addr is relative to *after* insn
-    compile-byte  compile-offset 4 + - compile-cell ;
-
-: JMP HEX: e9 (JMP) ;
-: CALL HEX: e8 (JMP) ;
-: RET HEX: c3 compile-byte ;
-
-: compile-word ( word -- )
-    #! Compile a JMP at the end (tail call optimization)
-    word-xt "compile-last" get [ JMP ] [ CALL ] ifte ;
-
-: compile-fixnum ( n -- )
-    3 shift 7 bitnot bitand  LITERAL ;
-
-: compile-atom ( obj -- )
-    [
-        [ fixnum? ] [ compile-fixnum ]
-        [ word? ] [ compile-word ]
-        [ drop t ] [ "Cannot compile " swap unparse cat2 throw ]
-    ] cond ;
-
-: compile-loop ( quot -- )
-    dup [
-        unswons
-        over not "compile-last" set
-        compile-atom
-        compile-loop
-    ] [
-        drop RET
-    ] ifte ;
-
-: compile-quot ( quot -- xt )
-    [
-        "compile-last" off
-        compile-offset swap compile-loop
-    ] with-scope ;
-
-: compile ( word -- )
-    intern dup word-parameter compile-quot swap set-word-xt ;
-
-: call-xt ( xt -- )
-    #! For testing.
-    0 f f <word> [ set-word-xt ] keep execute ;

library/platform/native/debugger.factor

@@ -92,6 +92,9 @@ USE: words
 : bad-primitive-error ( obj -- )
     "Bad primitive number: " write . ;
 
+: c-string-error ( obj -- )
+    "Cannot convert to C string: " write . ;
+
 : kernel-error. ( obj n -- str )
     {
         expired-port-error
@@ -108,6 +111,7 @@ USE: words
         profiling-disabled-error
         negative-array-size-error
         bad-primitive-error
+        c-string-error
     } vector-nth execute ;
 
 : kernel-error? ( obj -- ? )

library/platform/native/init.factor

@@ -27,6 +27,7 @@
 
 IN: init
 USE: combinators
+USE: compiler
 USE: errors
 USE: kernel
 USE: namespaces

library/platform/native/primitives.factor

@@ -40,6 +40,7 @@ USE: stack
 USE: vectors
 USE: words
 USE: unparser
+USE: compiler
 
 [
     [ execute                | " word -- " ]
@@ -189,6 +190,12 @@ USE: unparser
     [ dump                   | " obj -- " ]
     [ cwd                    | " -- dir " ]
     [ cd                     | " dir -- " ]
+    [ set-compiled-byte      | " n ptr -- " ]
+    [ set-compiled-cell      | " n ptr -- " ]
+    [ compiled-offset        | " -- ptr " ]
+    [ set-compiled-offset    | " ptr -- " ]
+    [ literal-top            | " -- ptr " ]
+    [ set-literal-top        | " ptr -- " ]
 ] [
     unswons "stack-effect" swap set-word-property
 ] each

library/platform/native/words.factor

@@ -58,7 +58,6 @@ USE: stack
     global [ "last-word" set ] bind ;
 
 : define-compound ( word def -- )
-    #! Define a compound word at runtime.
     over set-word-parameter
     1 swap set-word-primitive ;
 

library/sbuf.factor

@@ -101,6 +101,3 @@ USE: stack
 : split-n ( n str -- list )
     #! Split a string into n-character chunks.
     [, 0 -rot (split-n) ,] ;
-
-: str-reverse ( str -- str )
-    str>sbuf dup sbuf-reverse sbuf>str ;

library/strings.factor

@@ -124,9 +124,6 @@ USE: stack
     dupd str-tail? dup [ nip t ] [ drop f ] ifte ;
 
 : split1 ( string split -- before after )
-    #! The car of the pair is the string up to the first
-    #! occurrence of split; the cdr is the remainder of
-    #! the string.
     2dup index-of dup -1 = [
         2drop f
     ] [

native/arithmetic.c

@@ -27,6 +27,7 @@ CELL to_cell(CELL x)
 		return s48_bignum_to_long(untag_bignum(x));
 	default:
 		type_error(INTEGER_TYPE,x);
+		return 0;
 	}
 }
 

native/compiler.c

@@ -3,21 +3,61 @@
 void init_compiler(void)
 {
 	init_zone(&compiling,COMPILE_ZONE_SIZE);
+	literal_top = compiling.base;
 }
 
-void primitive_compile_byte(void)
+void check_compiled_offset(CELL offset)
 {
-	bput(compiling.here,to_fixnum(dpop()));
+	if(offset < compiling.base || offset >= compiling.limit)
-	compiling.here++;
+		range_error(F,offset,compiling.limit);
 }
 
-void primitive_compile_cell(void)
+void primitive_set_compiled_byte(void)
 {
-	put(compiling.here,to_cell(dpop()));
+	CELL offset = to_cell(dpop());
-	compiling.here += sizeof(CELL);
+	BYTE b = to_fixnum(dpop());
+	check_compiled_offset(offset);
+	bput(offset,b);
 }
 
-void primitive_compile_offset(void)
+void primitive_set_compiled_cell(void)
+{
+	CELL offset = to_cell(dpop());
+	CELL c = to_fixnum(dpop());
+	check_compiled_offset(offset);
+	put(offset,c);
+}
+
+void primitive_compiled_offset(void)
 {
 	dpush(tag_integer(compiling.here));
 }
+
+void primitive_set_compiled_offset(void)
+{
+	CELL offset = to_cell(dpop());
+	check_compiled_offset(offset);
+	compiling.here = offset;
+}
+
+void primitive_literal_top(void)
+{
+	dpush(tag_integer(literal_top));
+}
+
+void primitive_set_literal_top(void)
+{
+	CELL offset = to_cell(dpop());
+	check_compiled_offset(offset);
+	literal_top = offset;
+}
+
+void collect_literals(void)
+{
+	CELL i = compiling.base;
+	while(i < literal_top)
+	{
+		copy_object((CELL*)i);
+		i += CELLS;
+	}
+}

native/compiler.h

@@ -1,6 +1,11 @@
 ZONE compiling;
+CELL literal_top;
 
 void init_compiler(void);
-void primitive_compile_byte(void);
+void primitive_set_compiled_byte(void);
-void primitive_compile_cell(void);
+void primitive_set_compiled_cell(void);
-void primitive_compile_offset(void);
+void primitive_compiled_offset(void);
+void primitive_set_compiled_offset(void);
+void primitive_literal_top(void);
+void primitive_set_literal_top(void);
+void collect_literals(void);

native/error.c

@@ -50,6 +50,7 @@ void general_error(CELL error, CELL tagged)
 			fprintf(stderr,"Got type #%ld\n",type_of(
 				untag_cons(tagged)->cdr));
 		}
+		fflush(stderr);
 		exit(1);
 	}
 	throw_error(c);

native/error.h

@@ -12,6 +12,7 @@
 #define ERROR_PROFILING_DISABLED (11<<3)
 #define ERROR_NEGATIVE_ARRAY_SIZE (12<<3)
 #define ERROR_BAD_PRIMITIVE (13<<3)
+#define ERROR_C_STRING (14<<3)
 
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);

native/gc.c

@@ -143,6 +143,8 @@ void primitive_gc(void)
 	scan = active.here = active.base;
 	collect_roots();
 	collect_io_tasks();
+	/* collect literal objects referenced from compiled code */
+	collect_literals();
 	while(scan < active.here)
 	{
 		gc_debug("scan loop",scan);

native/image.c

@@ -6,7 +6,7 @@ void load_image(char* filename)
 	HEADER h;
 	CELL size;
 	
-	fprintf(stderr,"Loading %s...",filename);
+	printf("Loading %s...",filename);
 
 	file = fopen(filename,"rb");
 	if(file == NULL)
@@ -30,7 +30,7 @@ void load_image(char* filename)
 	active.here = active.base + h.size;
 	fclose(file);
 
-	fprintf(stderr," relocating...");
+	printf(" relocating...");
 	fflush(stdout);
 
 	clear_environment();
@@ -40,7 +40,8 @@ void load_image(char* filename)
 
 	relocate(h.relocation_base);
 
-	fprintf(stderr," done\n");
+	printf(" done\n");
+	fflush(stdout);
 }
 
 bool save_image(char* filename)

native/memory.c

@@ -111,3 +111,8 @@ void primitive_allot_profiling(void)
 	}
 #endif
 }
+
+void primitive_address_of(void)
+{
+	dpush(tag_object(s48_ulong_to_bignum(dpop())));
+}

native/memory.h

@@ -69,3 +69,4 @@ bool in_zone(ZONE* z, CELL pointer);
 
 void primitive_room(void);
 void primitive_allot_profiling(void);
+void primitive_address_of(void);

native/primitives.c

@@ -26,6 +26,7 @@ XT primitives[] = {
 	primitive_string_hashcode,
 	primitive_index_of,
 	primitive_substring,
+	primitive_string_reverse,
 	primitive_sbufp,
 	primitive_sbuf,
 	primitive_sbuf_length,
@@ -153,9 +154,13 @@ XT primitives[] = {
 	primitive_dump,
 	primitive_cwd,
 	primitive_cd,
-	primitive_compile_byte,
+	primitive_set_compiled_byte,
-	primitive_compile_cell,
+	primitive_set_compiled_cell,
-	primitive_compile_offset
+	primitive_compiled_offset,
+	primitive_set_compiled_offset,
+	primitive_literal_top,
+	primitive_set_literal_top,
+	primitive_address_of
 };
 
 CELL primitive_to_xt(CELL primitive)

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 155
+#define PRIMITIVE_COUNT 160
 
 CELL primitive_to_xt(CELL primitive);

native/sbuf.c

@@ -101,32 +101,18 @@ void primitive_sbuf_append(void)
 	}
 }
 
-STRING* sbuf_to_string(SBUF* sbuf)
-{
-	STRING* string = allot_string(sbuf->top);
-	memcpy(string + 1,sbuf->string + 1,sbuf->top * CHARS);
-	hash_string(string);
-	return string;
-}
-
 void primitive_sbuf_to_string(void)
 {
-	drepl(tag_object(sbuf_to_string(untag_sbuf(dpeek()))));
+	SBUF* sbuf = untag_sbuf(dpeek());
+	STRING* s = string_clone(sbuf->string,sbuf->top);
+	hash_string(s);
+	drepl(tag_object(s));
 }
 
 void primitive_sbuf_reverse(void)
 {
 	SBUF* sbuf = untag_sbuf(dpop());
-	int i, j;
+	string_reverse(sbuf->string,sbuf->top);
-	CHAR ch1, ch2;
-	for(i = 0; i < sbuf->top / 2; i++)
-	{
-		j = sbuf->top - i - 1;
-		ch1 = string_nth(sbuf->string,i);
-		ch2 = string_nth(sbuf->string,j);
-		set_string_nth(sbuf->string,j,ch1);
-		set_string_nth(sbuf->string,i,ch2);
-	}
 }
 
 void primitive_sbuf_clone(void)

native/sbuf.h

@@ -25,7 +25,6 @@ void set_sbuf_nth(SBUF* sbuf, CELL index, CHAR value);
 void primitive_set_sbuf_nth(void);
 void sbuf_append_string(SBUF* sbuf, STRING* string);
 void primitive_sbuf_append(void);
-STRING* sbuf_to_string(SBUF* sbuf);
 void primitive_sbuf_to_string(void);
 void primitive_sbuf_reverse(void);
 void primitive_sbuf_clone(void);

native/string.c

@@ -80,7 +80,12 @@ BYTE* to_c_string(STRING* s)
 	BYTE* c_str = (BYTE*)(_c_str + 1);
 	
 	for(i = 0; i < s->capacity; i++)
+	{
+		CHAR ch = string_nth(s,i);
+		if(ch == '\0' || ch > 255)
+			general_error(ERROR_C_STRING,tag_object(s));
 		c_str[i] = string_nth(s,i);
+	}
 
 	c_str[s->capacity] = '\0';
 
@@ -259,3 +264,45 @@ void primitive_substring(void)
 	CELL start = to_fixnum(dpop());
 	dpush(tag_object(substring(start,end,string)));
 }
+
+/* DESTRUCTIVE - don't use with user-visible strings */
+void string_reverse(STRING* s, int len)
+{
+	int i, j;
+	CHAR ch1, ch2;
+	for(i = 0; i < len / 2; i++)
+	{
+		j = len - i - 1;
+		ch1 = string_nth(s,i);
+		ch2 = string_nth(s,j);
+		set_string_nth(s,j,ch1);
+		set_string_nth(s,i,ch2);
+	}
+}
+
+/* Doesn't rehash the string! */
+STRING* string_clone(STRING* s, int len)
+{
+	STRING* copy = allot_string(len);
+	memcpy(copy + 1,s + 1,len * CHARS);
+	return copy;
+}
+
+void primitive_string_reverse(void)
+{
+	STRING* s = untag_string(dpeek());
+	s = string_clone(s,s->capacity);
+	string_reverse(s,s->capacity);
+	hash_string(s);
+	drepl(tag_object(s));
+}
+
+STRING* fixup_untagged_string(STRING* str)
+{
+	return (STRING*)((CELL)str + (active.base - relocation_base));
+}
+
+STRING* copy_untagged_string(STRING* str)
+{
+	return copy_untagged_object(str,SSIZE(str));
+}

native/string.h

@@ -46,13 +46,8 @@ void primitive_string_eq(void);
 void primitive_string_hashcode(void);
 void primitive_index_of(void);
 void primitive_substring(void);
-
+void string_reverse(STRING* s, int len);
-INLINE STRING* fixup_untagged_string(STRING* str)
+STRING* string_clone(STRING* s, int len);
-{
+void primitive_string_reverse(void);
-	return (STRING*)((CELL)str + (active.base - relocation_base));
+STRING* fixup_untagged_string(STRING* str);
-}
+STRING* copy_untagged_string(STRING* str);
-
-INLINE STRING* copy_untagged_string(STRING* str)
-{
-	return copy_untagged_object(str,SSIZE(str));
-}