diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 9083cd685f..acf294b0c5 100644 --- a/TODO.FACTOR.txt +++ b/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 - 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 diff --git a/factor/FactorLib.java b/factor/FactorLib.java index 03ae9fe3c8..59dfda749b 100644 --- a/factor/FactorLib.java +++ b/factor/FactorLib.java @@ -216,7 +216,12 @@ public class FactorLib break; buf.append((char)b); } - return buf.toString(); + + /* EOF? */ + if(b == -1 && buf.length() == 0) + return null; + else + return buf.toString(); } //}}} //{{{ readCount() method diff --git a/factor/compiler/FlowObject.java b/factor/compiler/FlowObject.java index 6b47f99044..a92b78eeaf 100644 --- a/factor/compiler/FlowObject.java +++ b/factor/compiler/FlowObject.java @@ -173,11 +173,25 @@ implements Constants, FactorExternalizable, PublicCloneable } else { - mw.visitMethodInsn(INVOKESTATIC, - "factor/FactorJava", - methodName, - "(Ljava/lang/Object;)" - + FactorJava.javaClassToVMClass(type)); + String signature; + if(type.isArray()) + { + signature = "(Ljava/lang/Object;)" + + "[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('.','/')); + } */ } } //}}} diff --git a/factor/jedit/FactorPlugin.java b/factor/jedit/FactorPlugin.java index cffd7927d8..6f47c65905 100644 --- a/factor/jedit/FactorPlugin.java +++ b/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); } //}}} diff --git a/library/compiler/assembler.factor b/library/compiler/assembler.factor new file mode 100644 index 0000000000..6411bf076d --- /dev/null +++ b/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 ; diff --git a/library/compiler/assembly-x86.factor b/library/compiler/assembly-x86.factor new file mode 100644 index 0000000000..01beb90a71 --- /dev/null +++ b/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 TO + HEX: b8 + compile-byte compile-cell ; + +: [I]>R ( imm reg -- ) + #! MOV INDIRECT TO + HEX: a1 + compile-byte compile-cell ; + +: I>[R] ( imm reg -- ) + #! MOV TO INDIRECT + HEX: c7 compile-byte compile-byte compile-cell ; + +: [R]>R ( reg reg -- ) + #! MOV INDIRECT TO . + HEX: 8b compile-byte swap 3 shift bitor compile-byte ; + +: R>[R] ( reg reg -- ) + #! MOV TO INDIRECT . + HEX: 89 compile-byte swap 3 shift bitor compile-byte ; + +: I+[I] ( imm addr -- ) + #! ADD TO ADDRESS + 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 ; diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor new file mode 100644 index 0000000000..14fde7ddb1 --- /dev/null +++ b/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 "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 [ set-word-xt ] keep execute ; diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index 390976ecbb..def7a9f474 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -42,9 +42,12 @@ USE: vectors USE: words IN: compiler -DEFER: compile-byte -DEFER: compile-cell -DEFER: compile-offset +DEFER: set-compiled-byte +DEFER: set-compiled-cell +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-length @@ -277,9 +282,13 @@ IN: cross-compiler dump cwd cd - compile-byte - compile-cell - compile-offset + set-compiled-byte + set-compiled-cell + compiled-offset + set-compiled-offset + literal-top + set-literal-top + address-of ] [ swap succ tuck primitive, ] each drop ; diff --git a/library/platform/jvm/sbuf.factor b/library/platform/jvm/sbuf.factor index ea12ab098e..e82c0e9acc 100644 --- a/library/platform/jvm/sbuf.factor +++ b/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 ; diff --git a/library/platform/jvm/stream.factor b/library/platform/jvm/stream.factor index 12eac0509c..4f21d9c3f9 100644 --- a/library/platform/jvm/stream.factor +++ b/library/platform/jvm/stream.factor @@ -112,8 +112,8 @@ USE: strings #! java.io.OutputStream out. The streams are wrapped in #! buffered streams. [ - "out" set - "in" set + "out" set + "in" set ( -- string ) [ /freadln ] "freadln" set ( count -- string ) @@ -191,12 +191,12 @@ USE: strings ; : ( path -- stream ) - [ "java.lang.String" ] "java.io.FileInputStream" jnew + [ "java.lang.String" ] "java.io.FileInputStream" jnew f ; : ( path -- stream ) - [ "java.lang.String" ] "java.io.FileOutputStream" jnew + [ "java.lang.String" ] "java.io.FileOutputStream" jnew f swap ; @@ -232,8 +232,8 @@ USE: strings : ( socket -- stream ) #! Wraps a socket inside a byte-stream. dup - [ [ ] "java.net.Socket" "getInputStream" jinvoke ] - [ [ ] "java.net.Socket" "getOutputStream" jinvoke ] + [ [ ] "java.net.Socket" "getInputStream" jinvoke ] + [ [ ] "java.net.Socket" "getOutputStream" jinvoke ] cleave [ dup >str "client" set "socket" set diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor index 07448c7ff7..201b516025 100644 --- a/library/platform/native/boot-stage2.factor +++ b/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" diff --git a/library/platform/native/compiler.factor b/library/platform/native/compiler.factor deleted file mode 100644 index ba0286e20a..0000000000 --- a/library/platform/native/compiler.factor +++ /dev/null @@ -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 TO - HEX: a1 + compile-byte compile-cell ; - -: I>[R] ( imm reg -- ) - #! MOV TO ADDRESS - HEX: c7 compile-byte compile-byte compile-cell ; - -: I+[I] ( imm addr -- ) - #! ADD TO ADDRESS - 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 [ set-word-xt ] keep execute ; diff --git a/library/platform/native/debugger.factor b/library/platform/native/debugger.factor index 09a17db0d5..5b43b6344d 100644 --- a/library/platform/native/debugger.factor +++ b/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 -- ? ) diff --git a/library/platform/native/init.factor b/library/platform/native/init.factor index b5629fd0bc..5014a752a0 100644 --- a/library/platform/native/init.factor +++ b/library/platform/native/init.factor @@ -27,6 +27,7 @@ IN: init USE: combinators +USE: compiler USE: errors USE: kernel USE: namespaces diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor index ddec07aa65..1f7c881bea 100644 --- a/library/platform/native/primitives.factor +++ b/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 diff --git a/library/platform/native/words.factor b/library/platform/native/words.factor index f2a62c326a..c25f0a6f1d 100644 --- a/library/platform/native/words.factor +++ b/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 ; diff --git a/library/sbuf.factor b/library/sbuf.factor index 9e724952ea..145ca7255e 100644 --- a/library/sbuf.factor +++ b/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 ; diff --git a/library/strings.factor b/library/strings.factor index 902fcd8afc..501d1750a1 100644 --- a/library/strings.factor +++ b/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 ] [ diff --git a/native/arithmetic.c b/native/arithmetic.c index f729f7c265..c1d2a6c1dd 100644 --- a/native/arithmetic.c +++ b/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; } } diff --git a/native/compiler.c b/native/compiler.c index 7497565095..13b088802c 100644 --- a/native/compiler.c +++ b/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())); - compiling.here++; + if(offset < compiling.base || offset >= compiling.limit) + range_error(F,offset,compiling.limit); } -void primitive_compile_cell(void) +void primitive_set_compiled_byte(void) { - put(compiling.here,to_cell(dpop())); - compiling.here += sizeof(CELL); + CELL offset = to_cell(dpop()); + 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; + } +} diff --git a/native/compiler.h b/native/compiler.h index 58beb1bd97..539b53aa96 100644 --- a/native/compiler.h +++ b/native/compiler.h @@ -1,6 +1,11 @@ ZONE compiling; +CELL literal_top; void init_compiler(void); -void primitive_compile_byte(void); -void primitive_compile_cell(void); -void primitive_compile_offset(void); +void primitive_set_compiled_byte(void); +void primitive_set_compiled_cell(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); diff --git a/native/error.c b/native/error.c index f6f6507517..f0a77ee833 100644 --- a/native/error.c +++ b/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); diff --git a/native/error.h b/native/error.h index 71be1c7202..5718d1414b 100644 --- a/native/error.h +++ b/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); diff --git a/native/gc.c b/native/gc.c index a7e5e13575..7401d72b15 100644 --- a/native/gc.c +++ b/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); diff --git a/native/image.c b/native/image.c index 7a585f13ac..f526352ed8 100644 --- a/native/image.c +++ b/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) diff --git a/native/memory.c b/native/memory.c index a73d28eea6..38da000eae 100644 --- a/native/memory.c +++ b/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()))); +} diff --git a/native/memory.h b/native/memory.h index 74a2ead409..8af98fcd0f 100644 --- a/native/memory.h +++ b/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); diff --git a/native/primitives.c b/native/primitives.c index d41bce9b2d..7effab30c6 100644 --- a/native/primitives.c +++ b/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_compile_cell, - primitive_compile_offset + primitive_set_compiled_byte, + primitive_set_compiled_cell, + primitive_compiled_offset, + primitive_set_compiled_offset, + primitive_literal_top, + primitive_set_literal_top, + primitive_address_of }; CELL primitive_to_xt(CELL primitive) diff --git a/native/primitives.h b/native/primitives.h index 0171be5678..5543503c54 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 155 +#define PRIMITIVE_COUNT 160 CELL primitive_to_xt(CELL primitive); diff --git a/native/sbuf.c b/native/sbuf.c index 3642124c38..d21eca9c08 100644 --- a/native/sbuf.c +++ b/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; - 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); - } + string_reverse(sbuf->string,sbuf->top); } void primitive_sbuf_clone(void) diff --git a/native/sbuf.h b/native/sbuf.h index 149cf0eec6..1da90fc4c8 100644 --- a/native/sbuf.h +++ b/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); diff --git a/native/string.c b/native/string.c index c116430104..294a7ade58 100644 --- a/native/string.c +++ b/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)); +} diff --git a/native/string.h b/native/string.h index 308cd69dfc..9e53c9e2d4 100644 --- a/native/string.h +++ b/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); - -INLINE STRING* fixup_untagged_string(STRING* str) -{ - return (STRING*)((CELL)str + (active.base - relocation_base)); -} - -INLINE STRING* copy_untagged_string(STRING* str) -{ - return copy_untagged_object(str,SSIZE(str)); -} +void string_reverse(STRING* s, int len); +STRING* string_clone(STRING* s, int len); +void primitive_string_reverse(void); +STRING* fixup_untagged_string(STRING* str); +STRING* copy_untagged_string(STRING* str);