compiling mutually recursive words

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/)
 

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.

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 )

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 [ <namespace> "libraries" set ] bind
 
 [ alien-call compile-alien-call ]
-unswons "compiling" swap set-word-property
+unswons "compiling" set-word-property

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 )
+: JE ( -- fixup )
-    HEX: 0f compile-byte HEX: 84 compile-byte (JUMP) ;
+    HEX: 0f compile-byte HEX: 84 compile-byte  (JUMP) ;
 
 : RET ( -- )
     HEX: c3 compile-byte ;

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? ( word -- ? )
-    "compiled-xt" over word-property dup [
+    #! This is a hack.
-        nip
+    dup "compiled" word-property swap primitive? or ;
-    ] [
-        drop word-xt
-    ] ifte ;
 
 : compile-simple-word ( word -- )
     #! Compile a JMP at the end (tail call optimization)
-    commit-literals compiled-xt
+    dup compiled? [ dup postpone-word ] unless
-    tail? [ JUMP ] [ CALL ] ifte drop ;
+    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 <vector> "compile-datastack" set
+        10 <vector> compile-datastack set
-        10 <vector> "compile-callstack" set
+        10 <vector> compile-callstack set
         call
+        fixup-deferred-xts
+        commit-xts
     ] with-scope ;
 
-: begin-compiling ( word -- )
+: (compile) ( word -- )
-    cell compile-aligned
+    #! Should be called inside the with-compiler scope.
-    compiled-offset "compiled-xt" rot set-word-property ;
+    intern dup save-xt word-parameter compile-quot RET ;
 
-: end-compiling ( word -- xt )
+: compile-postponed ( -- )
-    "compiled-xt" over word-property over set-word-xt
+    compile-words get [
-    f "compiled-xt" rot set-word-property ;
+        uncons compile-words set (compile) compile-postponed
+    ] when* ;
 
 : compile ( word -- )
-    intern dup
+    [ postpone-word compile-postponed ] with-compiler ;
-    begin-compiling
-    dup word-parameter [ compile-quot RET ] with-compiler
-    end-compiling ;
 
 : compiled word compile ; parsing

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

library/cross-compiler.factor

@@ -190,7 +190,7 @@ DEFER: unparse-float
 IN: image
 
 : primitives, ( -- )
-    1 [
+    2 [
         execute
         call
         ifte

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
+    dup "line" word-property swap "file" word-property
-    "file" swap word-property word-file ;
+    word-file ;
 
 : jedit ( word -- )
     intern dup [

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.

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 = [

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"

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 over "documentation" set-word-property
-    f "stack-effect" pick set-word-property ;
+    f over "stack-effect" set-word-property ;
 
 : remember-where ( word -- )
-    "line-number" get "line" pick set-word-property
+    "line-number" get over "line" set-word-property
-    "col"         get "col"  pick set-word-property
+    "col"         get over "col"  set-word-property
-    "file"        get "file" pick 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? [

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

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

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 eq? [
-        2dup vector-length= [
+        2drop t
-            0 -rot (vector=)
+    ] [
+        over vector? [
+            2dup vector-length= [
+                0 -rot (vector=)
+            ] [
+                2drop f
+            ] ifte
         ] [
             2drop f
         ] ifte
-    ] [
-        2drop f
     ] ifte ;
 
 : ?vector-nth ( n vec -- obj/f )

library/platform/native/words.factor

@@ -33,11 +33,11 @@ USE: logic
 USE: namespaces
 USE: stack
 
-: word-property ( pname word -- pvalue )
+: word-property ( word pname -- pvalue )
-    word-plist assoc ;
+    swap word-plist assoc ;
 
-: set-word-property ( pvalue pname word -- )
+: set-word-property ( pvalue word pname -- )
-    dup >r word-plist set-assoc r> set-word-plist ;
+    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 ;

library/prettyprint.factor

@@ -199,9 +199,8 @@ DEFER: prettyprint*
     tab-size - ;
 
 : prettyprint-plist ( word -- )
-    "parsing" over word-property [ " parsing" write ] when
+    dup "parsing" word-property [ " parsing" write ] when
-    "inline" over word-property [ " inline" write ] when
+    "inline" word-property [ " inline" write ] when ;
-    drop ;
 
 : . ( obj -- )
     [

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

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

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

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

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.

native/primitives.c

@@ -3,6 +3,7 @@
 XT primitives[] = {
 	undefined,
 	docol,
+	dosym,
 	primitive_execute,
 	primitive_call,
 	primitive_ifte,

native/primitives.h

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

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());

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);