From 564a8ad46c9bc688093745041e6411bbc2bc4ebf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Sep 2004 04:24:36 +0000 Subject: [PATCH] compiling mutually recursive words --- TODO.FACTOR.txt | 2 + doc/alien.txt | 56 +++++++++ library/compiler/alien-macros.factor | 4 +- library/compiler/alien.factor | 6 +- library/compiler/assembly-x86.factor | 12 +- library/compiler/compiler.factor | 119 +++++++++++++----- library/compiler/words.factor | 9 +- library/cross-compiler.factor | 2 +- library/jedit/jedit.factor | 4 +- library/list-namespaces.factor | 9 ++ library/lists.factor | 6 +- library/platform/native/boot-stage2.factor | 4 +- library/platform/native/parse-syntax.factor | 19 +-- library/platform/native/parser.factor | 6 +- library/platform/native/primitives.factor | 2 +- library/platform/native/vectors.factor | 14 ++- library/platform/native/words.factor | 19 ++- library/prettyprint.factor | 5 +- .../test/jvm-compiler/miscellaneous.factor | 14 --- library/test/lists/namespaces.factor | 7 ++ library/test/words.factor | 15 +++ library/test/x86-compiler/compiler.factor | 23 +++- library/words.factor | 8 +- native/primitives.c | 1 + native/primitives.h | 2 +- native/run.c | 6 + native/run.h | 1 + 27 files changed, 275 insertions(+), 100 deletions(-) create mode 100644 doc/alien.txt diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 4e0b1a6c55..c016dff5d2 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,6 +1,8 @@ FFI: - is signed -vs- unsigned pointers an issue? +- symbols are not primitives + [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/) [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/) diff --git a/doc/alien.txt b/doc/alien.txt new file mode 100644 index 0000000000..0e6d6b7d93 --- /dev/null +++ b/doc/alien.txt @@ -0,0 +1,56 @@ +SOME NOTES ON FACTOR'S FFI + +The FFI is quite a neat design and I think it is better than JNI and +similar approaches. Also, it offers better performance than libffi et +al. Of course, both of those technologies are great and Factor FFI has +its drawbacks -- namely, its not portable. + +All FFI words are in the "alien" vocabulary. + +The basic principle is generating machine stubs from C function +prototypes. The main entry point is the 'alien-call' word, which is +defined as simply throwing an error. However, it is given special +compilation behavior. This means it can only be used in compiled words. + +Here is an example from sdl-video.factor: + +: SDL_LockSurface ( surface -- ) + "int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ; compiled + +The parameters are: + +"int" - return type. later it will be surface* +"sdl" - library +"SDL_LockSurface" - function +[ "surface*" ] - parameters + +Note the word ends with 'compiled'. This is a hack and won't be needed +later. + +Parameters and return values are C type names. C types include the +following: + +- char - 1 byte signed +- short - 2 bytes signed +- int - 4 bytes signed +- void* - word-size width field, can only be used as a parameter + +Structs can be defined in this fashion: + +BEGIN-STRUCT: point + FIELD: int x + FIELD: int y +END-STRUCT + +And then referred to in parameter type specifiers as "point*". Struct +return values are not yet supported. + +Enumerations can be defined; they simply become words that push +integers: + +BEGIN-ENUM: 0 + ENUM: int xuzzy + ENUM: int bax +END-ENUM + +The parameter to BEGIN-ENUM specifies the starting index. diff --git a/library/compiler/alien-macros.factor b/library/compiler/alien-macros.factor index 329f1e9ea1..b9bc5984e6 100644 --- a/library/compiler/alien-macros.factor +++ b/library/compiler/alien-macros.factor @@ -36,14 +36,14 @@ USE: stack : UNBOX ( name -- ) #! Move top of datastack to C stack. - dlsym-self CALL drop + dlsym-self CALL JUMP-FIXUP EAX PUSH-R ; : BOX ( name -- ) #! Move EAX to datastack. 24 ESP R-I EAX PUSH-R - dlsym-self CALL drop + dlsym-self CALL JUMP-FIXUP 28 ESP R+I ; : PARAMETERS ( params -- count ) diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 21d015dc18..776367fc1c 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -36,7 +36,7 @@ USE: stack USE: words : BEGIN-ENUM: - #! C-style enumartions. Their use is not encouraged unless + #! C-style enumerations. Their use is not encouraged unless #! it is for C library interfaces. Used like this: #! #! BEGIN-ENUM 0 @@ -69,11 +69,11 @@ USE: words : compile-alien-call pop-literal reverse PARAMETERS >r - pop-literal pop-literal alien-function CALL drop + pop-literal pop-literal alien-function CALL JUMP-FIXUP r> CLEANUP pop-literal RETURNS ; global [ "libraries" set ] bind [ alien-call compile-alien-call ] -unswons "compiling" swap set-word-property +unswons "compiling" set-word-property diff --git a/library/compiler/assembly-x86.factor b/library/compiler/assembly-x86.factor index 0b71d35977..08b4eaa067 100644 --- a/library/compiler/assembly-x86.factor +++ b/library/compiler/assembly-x86.factor @@ -147,24 +147,24 @@ USE: combinators compile-cell ] ifte ; -: fixup ( addr where -- ) +: JUMP-FIXUP ( addr where -- ) #! Encode a relative offset to addr from where at where. #! Add 4 because addr is relative to *after* insn. dup >r 4 + - r> set-compiled-cell ; : (JUMP) ( xt -- fixup ) #! addr is relative to *after* insn - compiled-offset dup >r 4 + - compile-cell r> ; + compiled-offset 0 compile-cell ; -: JUMP ( xt -- fixup ) +: JUMP ( -- fixup ) #! Push address of branch for fixup HEX: e9 compile-byte (JUMP) ; -: CALL ( xt -- fixup ) +: CALL ( -- fixup ) HEX: e8 compile-byte (JUMP) ; -: JE ( xt -- fixup ) - HEX: 0f compile-byte HEX: 84 compile-byte (JUMP) ; +: JE ( -- fixup ) + HEX: 0f compile-byte HEX: 84 compile-byte (JUMP) ; : RET ( -- ) HEX: c3 compile-byte ; diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index 83562f4906..552a0b3e73 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -28,6 +28,7 @@ IN: compiler USE: combinators USE: errors +USE: hashtables USE: kernel USE: lists USE: logic @@ -40,8 +41,69 @@ USE: unparser USE: vectors USE: words +! We use a hashtable "compiled-xts" that maps words to +! xt's that are currently being compiled. The commit-xt's word +! sets the xt of each word in the hashtable to the value in the +! hastable. +! +! This has the advantage that we can compile a word before the +! words it depends on and perform a fixup later; among other +! things this enables mutually recursive words. + +SYMBOL: compiled-xts + +: save-xt ( word -- ) + cell compile-aligned + compiled-offset swap compiled-xts acons@ ; + +: commit-xts ( -- ) + compiled-xts get [ unswons set-word-xt ] each + compiled-xts off ; + +: compiled-xt ( word -- xt ) + dup compiled-xts get assoc dup [ + nip + ] [ + drop word-xt + ] ifte ; + +! "fixup-xts" is a list of [ where | word ] pairs; the xt of +! word when its done compiling will be written to the offset. + +SYMBOL: deferred-xts + +: defer-xt ( word where -- ) + #! After word is compiled, put a call to it at offset. + deferred-xts acons@ ; + +: fixup-deferred-xt ( where word -- ) + compiled-xt swap JUMP-FIXUP ; + +: fixup-deferred-xts ( -- ) + deferred-xts get [ uncons fixup-deferred-xt ] each + deferred-xts off ; + +! Words being compiled are consed onto this list. When a word +! is encountered that has not been previously compiled, it is +! consed onto this list. Compilation stops when the list is +! empty. + +SYMBOL: compile-words + +: postpone-word ( word -- ) + t over "compiled" set-word-property + compile-words cons@ ; + +! During compilation, these two variables store pending +! literals. Literals are either consumed at compile-time by +! words with special compilation behavior, or otherwise they are +! compiled into code that pushes them. + +SYMBOL: compile-datastack +SYMBOL: compile-callstack + : pop-literal ( -- obj ) - "compile-datastack" get vector-pop ; + compile-datastack get vector-pop ; : immediate? ( obj -- ? ) #! fixnums and f have a pointerless representation, and @@ -57,7 +119,7 @@ USE: words ] ifte ; : commit-literals ( -- ) - "compile-datastack" get + compile-datastack get dup vector-empty? [ drop ] [ @@ -65,46 +127,43 @@ USE: words 0 swap set-vector-length ] ifte ; -: postpone ( obj -- ) +: postpone-literal ( obj -- ) #! Literals are not compiled immediately, so that words like #! ifte with special compilation behavior can work. - "compile-datastack" get vector-push ; + compile-datastack get vector-push ; : tail? ( -- ? ) - "compile-callstack" get vector-empty? ; + compile-callstack get vector-empty? ; -: compiled-xt ( word -- xt ) - "compiled-xt" over word-property dup [ - nip - ] [ - drop word-xt - ] ifte ; +: compiled? ( word -- ? ) + #! This is a hack. + dup "compiled" word-property swap primitive? or ; : compile-simple-word ( word -- ) #! Compile a JMP at the end (tail call optimization) - commit-literals compiled-xt - tail? [ JUMP ] [ CALL ] ifte drop ; + dup compiled? [ dup postpone-word ] unless + commit-literals tail? [ JUMP ] [ CALL ] ifte defer-xt ; : compile-word ( word -- ) #! If a word has a compiling property, then it has special #! compilation behavior. - "compiling" over word-property dup [ + dup "compiling" word-property dup [ nip call ] [ drop compile-simple-word ] ifte ; : begin-compiling-quot ( quot -- ) - "compile-callstack" get vector-push ; + compile-callstack get vector-push ; : end-compiling-quot ( -- ) - "compile-callstack" get vector-pop drop ; + compile-callstack get vector-pop drop ; : compiling ( quot -- ) #! Called on each iteration of compile-loop, with the #! remaining quotation. [ - "compile-callstack" get + compile-callstack get dup vector-length pred swap set-vector-nth ] [ @@ -112,7 +171,7 @@ USE: words ] ifte* ; : compile-atom ( obj -- ) - dup word? [ compile-word ] [ postpone ] ifte ; + dup word? [ compile-word ] [ postpone-literal ] ifte ; : compile-loop ( quot -- ) [ @@ -126,23 +185,23 @@ USE: words : with-compiler ( quot -- ) [ - 10 "compile-datastack" set - 10 "compile-callstack" set + 10 compile-datastack set + 10 compile-callstack set call + fixup-deferred-xts + commit-xts ] with-scope ; -: begin-compiling ( word -- ) - cell compile-aligned - compiled-offset "compiled-xt" rot set-word-property ; +: (compile) ( word -- ) + #! Should be called inside the with-compiler scope. + intern dup save-xt word-parameter compile-quot RET ; -: end-compiling ( word -- xt ) - "compiled-xt" over word-property over set-word-xt - f "compiled-xt" rot set-word-property ; +: compile-postponed ( -- ) + compile-words get [ + uncons compile-words set (compile) compile-postponed + ] when* ; : compile ( word -- ) - intern dup - begin-compiling - dup word-parameter [ compile-quot RET ] with-compiler - end-compiling ; + [ postpone-word compile-postponed ] with-compiler ; : compiled word compile ; parsing diff --git a/library/compiler/words.factor b/library/compiler/words.factor index 95a08cee95..b70cbe744b 100644 --- a/library/compiler/words.factor +++ b/library/compiler/words.factor @@ -38,16 +38,17 @@ USE: lists POP-DS ! ptr to condition is now in EAX f address EAX CMP-I-[R] - compiled-offset JE ; + ! jump w/ address added later + JE ; : branch-target ( fixup -- ) - cell compile-aligned compiled-offset swap fixup ; + cell compile-aligned compiled-offset swap JUMP-FIXUP ; : compile-else ( fixup -- fixup ) #! Push addr where we write the branch target address, #! and fixup branch target address from compile-f-test. #! Push f for the fixup if we're tail position. - tail? [ RET f ] [ 0 JUMP ] ifte swap branch-target ; + tail? [ RET f ] [ JUMP ] ifte swap branch-target ; : compile-end-if ( fixup -- ) tail? [ drop RET ] [ branch-target ] ifte ; @@ -63,5 +64,5 @@ USE: lists [ [ ifte compile-ifte ] ] [ - unswons "compiling" swap set-word-property + unswons "compiling" set-word-property ] each diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index 2b64d12c85..cae355d0c8 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -190,7 +190,7 @@ DEFER: unparse-float IN: image : primitives, ( -- ) - 1 [ + 2 [ execute call ifte diff --git a/library/jedit/jedit.factor b/library/jedit/jedit.factor index d374b14bd4..beb2580b36 100644 --- a/library/jedit/jedit.factor +++ b/library/jedit/jedit.factor @@ -63,8 +63,8 @@ USE: words : word-line/file ( word -- line dir file ) #! Note that line numbers here start from 1 - "line" over word-property swap - "file" swap word-property word-file ; + dup "line" word-property swap "file" word-property + word-file ; : jedit ( word -- ) intern dup [ diff --git a/library/list-namespaces.factor b/library/list-namespaces.factor index 8cdd0e4438..78bb33c2d4 100644 --- a/library/list-namespaces.factor +++ b/library/list-namespaces.factor @@ -46,6 +46,15 @@ USE: stack #! Prepend x to the list stored in var. tuck get cons put ; +: acons@ ( value key var -- ) + #! Prepend [ key | value ] to the alist stored in var. + [ get acons ] keep set ; + +: uncons@ ( var -- car ) + #! Push the car of the list in var, and set the var to the + #! cdr. + dup get uncons rot set ; + : remove@ ( obj var -- ) #! Remove all occurrences of the object from the list #! stored in the variable. diff --git a/library/lists.factor b/library/lists.factor index 0fa4764999..96468aa9ee 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -374,7 +374,11 @@ DEFER: tree-contains? : cdr= swap cdr swap cdr = ; : cons= ( obj cons -- ? ) - over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte ; + 2dup eq? [ + 2drop t + ] [ + over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte + ] ifte ; : cons-hashcode ( cons count -- hash ) dup 0 = [ diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor index 6f716402a1..dd4bf4f13e 100644 --- a/library/platform/native/boot-stage2.factor +++ b/library/platform/native/boot-stage2.factor @@ -26,14 +26,16 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: init +USE: combinators +USE: errors USE: kernel USE: lists USE: parser USE: stack +USE: strings USE: stdio "Cold boot in progress..." print - [ "/library/platform/native/kernel.factor" "/library/platform/native/stack.factor" diff --git a/library/platform/native/parse-syntax.factor b/library/platform/native/parse-syntax.factor index 5b4e332adc..0cc2ac58d8 100644 --- a/library/platform/native/parse-syntax.factor +++ b/library/platform/native/parse-syntax.factor @@ -68,13 +68,13 @@ USE: unparser ! Colon defs : CREATE ( -- word ) scan "in" get create dup set-word - f "documentation" pick set-word-property - f "stack-effect" pick set-word-property ; + f over "documentation" set-word-property + f over "stack-effect" set-word-property ; : remember-where ( word -- ) - "line-number" get "line" pick set-word-property - "col" get "col" pick set-word-property - "file" get "file" pick set-word-property + "line-number" get over "line" set-word-property + "col" get over "col" set-word-property + "file" get over "file" set-word-property drop ; : : @@ -91,6 +91,9 @@ USE: unparser nreverse ;-hook ; parsing +! Symbols +: SYMBOL: CREATE define-symbol ; parsing + ! Vocabularies : DEFER: CREATE drop ; parsing : USE: scan "use" cons@ ; parsing @@ -157,7 +160,7 @@ USE: unparser : parsed-stack-effect ( parsed str -- parsed ) over doc-comment-here? [ - "stack-effect" word set-word-property + word "stack-effect" set-word-property ] [ drop ] ifte ; @@ -168,11 +171,11 @@ USE: unparser : documentation+ ( str word -- ) [ - "documentation" swap word-property [ + "documentation" word-property [ swap "\n" swap cat3 ] when* ] keep - "documentation" swap set-word-property ; + "documentation" set-word-property ; : parsed-documentation ( parsed str -- parsed ) over doc-comment-here? [ diff --git a/library/platform/native/parser.factor b/library/platform/native/parser.factor index 1a91594c9f..01f07436e1 100644 --- a/library/platform/native/parser.factor +++ b/library/platform/native/parser.factor @@ -50,7 +50,7 @@ USE: unparser : parsing? ( word -- ? ) dup word? [ - "parsing" swap word-property + "parsing" word-property ] [ drop f ] ifte ; @@ -59,7 +59,7 @@ USE: unparser #! Mark the most recently defined word to execute at parse #! time, rather than run time. The word can use 'scan' to #! read ahead in the input stream. - t "parsing" word set-word-property ; + t word "parsing" set-word-property ; : end? ( -- ? ) "col" get "line" get str-length >= ; @@ -185,4 +185,4 @@ USE: unparser ! Once this file has loaded, we can use 'parsing' normally. ! This hack is needed because in Java Factor, 'parsing' is ! not parsing, but in CFactor, it is. -t "parsing" "parsing" [ "parser" ] search set-word-property +t "parsing" [ "parser" ] search "parsing" set-word-property diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor index 9c80ae3ba3..63d719254c 100644 --- a/library/platform/native/primitives.factor +++ b/library/platform/native/primitives.factor @@ -236,5 +236,5 @@ USE: words [ set-alien-1 | " n alien off -- " ] [ heap-stats | " -- instances bytes " ] ] [ - unswons "stack-effect" swap set-word-property + unswons "stack-effect" set-word-property ] each diff --git a/library/platform/native/vectors.factor b/library/platform/native/vectors.factor index 5fead95f81..25c3d352c5 100644 --- a/library/platform/native/vectors.factor +++ b/library/platform/native/vectors.factor @@ -57,14 +57,18 @@ USE: stack #! Check if two vectors are equal. Two vectors are #! considered equal if they have the same length and contain #! equal elements. - over vector? [ - 2dup vector-length= [ - 0 -rot (vector=) + 2dup eq? [ + 2drop t + ] [ + over vector? [ + 2dup vector-length= [ + 0 -rot (vector=) + ] [ + 2drop f + ] ifte ] [ 2drop f ] ifte - ] [ - 2drop f ] ifte ; : ?vector-nth ( n vec -- obj/f ) diff --git a/library/platform/native/words.factor b/library/platform/native/words.factor index c25f0a6f1d..61df6a0652 100644 --- a/library/platform/native/words.factor +++ b/library/platform/native/words.factor @@ -33,11 +33,11 @@ USE: logic USE: namespaces USE: stack -: word-property ( pname word -- pvalue ) - word-plist assoc ; +: word-property ( word pname -- pvalue ) + swap word-plist assoc ; -: set-word-property ( pvalue pname word -- ) - dup >r word-plist set-assoc r> set-word-plist ; +: set-word-property ( pvalue word pname -- ) + swap [ word-plist set-assoc ] keep set-word-plist ; : defined? ( obj -- ? ) dup word? [ word-primitive 0 = not ] [ drop f ] ifte ; @@ -48,6 +48,9 @@ USE: stack : primitive? ( obj -- ? ) dup word? [ word-primitive 1 = not ] [ drop f ] ifte ; +: symbol? ( obj -- ? ) + dup word? [ word-primitive 2 = ] [ drop f ] ifte ; + ! Various features not supported by native Factor. : comment? drop f ; @@ -61,8 +64,12 @@ USE: stack over set-word-parameter 1 swap set-word-primitive ; +: define-symbol ( word -- ) + dup dup set-word-parameter + 2 swap set-word-primitive ; + : stack-effect ( word -- str ) - "stack-effect" swap word-property ; + "stack-effect" word-property ; : documentation ( word -- str ) - "documentation" swap word-property ; + "documentation" word-property ; diff --git a/library/prettyprint.factor b/library/prettyprint.factor index 8f430e1359..ef46dba232 100644 --- a/library/prettyprint.factor +++ b/library/prettyprint.factor @@ -199,9 +199,8 @@ DEFER: prettyprint* tab-size - ; : prettyprint-plist ( word -- ) - "parsing" over word-property [ " parsing" write ] when - "inline" over word-property [ " inline" write ] when - drop ; + dup "parsing" word-property [ " parsing" write ] when + "inline" word-property [ " inline" write ] when ; : . ( obj -- ) [ diff --git a/library/test/jvm-compiler/miscellaneous.factor b/library/test/jvm-compiler/miscellaneous.factor index a632147879..6ecce2f2f2 100644 --- a/library/test/jvm-compiler/miscellaneous.factor +++ b/library/test/jvm-compiler/miscellaneous.factor @@ -40,11 +40,6 @@ USE: words [ t ] [ ] [ word-parameter-test ] test-word -: words-test ( -- ? ) - t vocabs [ words [ word? and ] each ] each ; - -[ t ] [ ] [ words-test ] test-word - ! At one time we had a bug in FactorShuffleDefinition.toList() ~<< test-shuffle-1 A r:B -- A r:B >>~ @@ -95,15 +90,6 @@ test-word [ [ 1 1 0 0 ] ] [ [ system-property ] ] [ balance>list ] test-word -: test-last ( -- ) - nop ; -word >str "last-word-test" set - -[ "test-last" ] [ ] [ "last-word-test" get ] test-word -[ f ] [ 5 ] [ compound? ] test-word -[ f ] [ 5 ] [ compiled? ] test-word -[ f ] [ 5 ] [ shuffle? ] test-word - ! Make sure callstack only clones callframes, and not ! everything on the callstack. [ ] [ ] [ f unit dup dup set-cdr >r callstack r> 2drop ] test-word diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor index 2a1e4bdcdc..838d23c28b 100644 --- a/library/test/lists/namespaces.factor +++ b/library/test/lists/namespaces.factor @@ -8,3 +8,10 @@ USE: test [ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word [ [ 1 | 2 ] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word [ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word + +[ [ [ 2 | 3 ] [ 1 | 2 ] ] ] [ + "x" off 2 1 "x" acons@ 3 2 "x" acons@ "x" get +] unit-test + +[ [ 2 | 3 ] ] [ "x" uncons@ ] unit-test +[ [ 1 | 2 ] ] [ "x" uncons@ ] unit-test diff --git a/library/test/words.factor b/library/test/words.factor index 3332f175d0..0425914725 100644 --- a/library/test/words.factor +++ b/library/test/words.factor @@ -2,8 +2,23 @@ IN: scratchpad USE: math USE: test USE: words +USE: namespaces +USE: logic +USE: lists [ 4 ] [ "poo" "scratchpad" create [ 2 2 + ] define-compound "poo" [ "scratchpad" ] search execute ] unit-test + +: words-test ( -- ? ) + t vocabs [ words [ word? and ] each ] each ; + +[ t ] [ ] [ words-test ] test-word + + +: test-last ( -- ) ; +word word-name "last-word-test" set + +[ "test-last" ] [ ] [ "last-word-test" get ] test-word +[ f ] [ 5 ] [ compound? ] test-word diff --git a/library/test/x86-compiler/compiler.factor b/library/test/x86-compiler/compiler.factor index 5624ed9e86..f8fc00c3bb 100644 --- a/library/test/x86-compiler/compiler.factor +++ b/library/test/x86-compiler/compiler.factor @@ -7,23 +7,29 @@ USE: kernel USE: combinators USE: words +"Hi." USE: stdio print + : no-op ; compiled [ ] [ no-op ] unit-test : literals 3 5 ; compiled +: tail-call fixnum+ ; compiled + +[ 4 ] [ 1 3 tail-call ] unit-test + [ 3 5 ] [ literals ] unit-test -: literals&tail-call 3 5 + ; compiled +: literals&tail-call 3 5 fixnum+ ; compiled [ 8 ] [ literals&tail-call ] unit-test -: two-calls dup * ; compiled +: two-calls dup fixnum* ; compiled [ 25 ] [ 5 two-calls ] unit-test -: mix-test 3 5 + 6 * ; compiled +: mix-test 3 5 fixnum+ 6 fixnum* ; compiled [ 48 ] [ mix-test ] unit-test @@ -50,7 +56,7 @@ garbage-collection [ 2 ] [ dummy-ifte-4 ] unit-test -: dummy-ifte-5 0 dup 1 <= [ drop 1 ] [ ] ifte ; compiled +: dummy-ifte-5 0 dup 1 fixnum<= [ drop 1 ] [ ] ifte ; compiled [ 1 ] [ dummy-ifte-5 ] unit-test @@ -58,7 +64,7 @@ garbage-collection dup 1 <= [ drop 1 ] [ - 1 - dup swap 1 - + + 1 fixnum- dup swap 1 fixnum- fixnum+ ] ifte ; [ 17 ] [ 10 dummy-ifte-6 ] unit-test @@ -80,3 +86,10 @@ garbage-collection t [ ] [ ] ifte 5 ; compiled [ 5 ] [ after-ifte-test ] unit-test + +DEFER: countdown-b + +: countdown-a ( n -- ) dup 0 eq? [ drop ] [ pred countdown-b ] ifte ; +: countdown-b ( n -- ) dup 0 eq? [ drop ] [ pred countdown-a ] ifte ; compiled + +[ ] [ 10 countdown-b ] unit-test diff --git a/library/words.factor b/library/words.factor index dfdbaa49d9..35fc4cec68 100644 --- a/library/words.factor +++ b/library/words.factor @@ -34,16 +34,16 @@ USE: namespaces USE: stack : word-name ( word -- name ) - "name" swap word-property ; + "name" word-property ; : set-word-name ( word name -- ) - "name" swap set-word-property ; + "name" set-word-property ; : word-vocabulary ( word -- vocab ) - "vocabulary" swap word-property ; + "vocabulary" word-property ; : set-word-vocabulary ( word vocab -- ) - "vocabulary" swap set-word-property ; + "vocabulary" set-word-property ; : each-word ( quot -- ) #! Apply a quotation to each word in the image. diff --git a/native/primitives.c b/native/primitives.c index de8e9fb4ca..9d9fea979d 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -3,6 +3,7 @@ XT primitives[] = { undefined, docol, + dosym, primitive_execute, primitive_call, primitive_ifte, diff --git a/native/primitives.h b/native/primitives.h index bf3cca526c..fcaddc66ee 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 193 +#define PRIMITIVE_COUNT 194 CELL primitive_to_xt(CELL primitive); diff --git a/native/run.c b/native/run.c index 92f2a3979d..9c547662b1 100644 --- a/native/run.c +++ b/native/run.c @@ -91,6 +91,12 @@ void docol(void) call(executing->parameter); } +/* pushes word parameter */ +void dosym(void) +{ + dpush(executing->parameter); +} + void primitive_execute(void) { executing = untag_word(dpop()); diff --git a/native/run.h b/native/run.h index f2d883fe09..79959bee61 100644 --- a/native/run.h +++ b/native/run.h @@ -103,6 +103,7 @@ void clear_environment(void); void run(void); void undefined(void); void docol(void); +void dosym(void); void primitive_execute(void); void primitive_call(void); void primitive_ifte(void);