\r
+ listener/plugin:\r
\r
-- unterminated ; -- NPE\r
-- no USE:'s wrong place\r
+- sidekick: still parsing too much\r
- errors don't always disappear\r
- console: wrong history\r
- listener: if too many things popped off the stack, complain\r
IN: image
USE: errors
+USE: generic
USE: hashtables
USE: kernel
USE: lists
: heap-size-offset 5 ;
: header-size 6 ;
+GENERIC: ' ( obj -- ptr )
+#! Write an object to the image.
+
( Allocator )
: here ( -- size )
( Fixnums )
-: emit-fixnum ( n -- tagged ) fixnum-tag immediate ;
+M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
( Bignums )
-: emit-bignum ( bignum -- tagged )
+M: bignum ' ( bignum -- tagged )
#! This can only emit 0, -1 and 1.
object-tag here-as >r
bignum-type >header emit
: t,
object-tag here-as "t" set
t-type >header emit
- 0 emit-fixnum emit ;
+ 0 ' emit ;
+
+M: t ' ( obj -- ptr ) drop "t" get ;
+M: f ' ( obj -- ptr )
+ #! f is #define F RETAG(0,OBJECT_TYPE)
+ drop object-tag ;
-: 0, 0 emit-bignum drop ;
-: 1, 1 emit-bignum drop ;
-: -1, -1 emit-bignum drop ;
+: 0, 0 >bignum ' drop ;
+: 1, 1 >bignum ' drop ;
+: -1, -1 >bignum ' drop ;
( Beginning of the image )
! The image proper begins with the header, then T,
dup word? [ fixup-word ] when
] vector-map image set ;
-: emit-word ( word -- pointer )
+M: word ' ( word -- pointer )
dup pooled-object dup [ nip ] [ drop ] ifte ;
( Conses )
-DEFER: '
-
-: emit-cons ( c -- tagged )
+M: cons ' ( c -- tagged )
uncons ' swap '
cons-tag here-as
-rot emit emit ;
: pack-string ( string -- )
char tuck swap split-n (pack-string) ;
-: (emit-string) ( string -- )
+: emit-string ( string -- )
object-tag here-as swap
string-type >header emit
dup str-length emit
pack-string
pad ;
-: emit-string ( string -- pointer )
+M: string ' ( string -- pointer )
#! We pool strings so that each string is only written once
#! to the image
dup pooled-object dup [
nip
] [
- drop dup (emit-string) dup >r pool-object r>
+ drop dup emit-string dup >r pool-object r>
] ifte ;
( Word definitions )
( elements -- ) [ emit ] each
pad r> ;
-: emit-vector ( vector -- pointer )
+M: vector ' ( vector -- pointer )
dup vector>list emit-array swap vector-length
object-tag here-as >r
vector-type >header emit
emit ( array ptr )
pad r> ;
-( Cross-compile a reference to an object )
-
-: ' ( obj -- pointer )
- [
- [ fixnum? ] [ emit-fixnum ]
- [ bignum? ] [ emit-bignum ]
- [ word? ] [ emit-word ]
- [ cons? ] [ emit-cons ]
- [ string? ] [ emit-string ]
- [ vector? ] [ emit-vector ]
- [ t = ] [ drop "t" get ]
- ! f is #define F RETAG(0,OBJECT_TYPE)
- [ f = ] [ drop object-tag ]
- [ drop t ] [ "Cannot cross-compile: " swap cat2 throw ]
- ] cond ;
-
( End of the image )
: vocabularies, ( -- )
USE: strings
USE: words
USE: vectors
+USE: math
! A simple single-dispatch generic word system.
+: predicate-word ( word -- word )
+ word-name "?" cat2 "in" get create ;
+
+! Terminology:
+! - type: a datatype built in to the runtime, eg fixnum, word
+! cons. All objects have exactly one type, new types cannot be
+! defined, and types are disjoint.
+! - class: a user defined way of differentiating objects, either
+! based on type, or some combination of type, predicate, or
+! method map.
+! - traits: a hashtable has traits of its traits slot is set to
+! a hashtable mapping selector names to method definitions.
+! The class of an object with traits is determined by the object
+! identity of the traits method map.
+! - metaclass: a metaclass is a symbol with a handful of word
+! properties: "define-method" "builtin-types"
+
+: metaclass ( class -- metaclass )
+ "metaclass" word-property ;
+
+: builtin-supertypes ( class -- list )
+ #! A list of builtin supertypes of the class.
+ dup metaclass "builtin-supertypes" word-property call ;
+
! Catch-all metaclass for providing a default method.
SYMBOL: object
: define-object ( generic definition -- )
<vtable> define-generic drop ;
-object [ define-object ] "define-method" set-word-property
+object object "metaclass" set-word-property
-: predicate-word ( word -- word )
- word-name "?" cat2 "in" get create ;
+object [
+ define-object
+] "define-method" set-word-property
-: builtin-predicate ( type# symbol -- )
- predicate-word swap [ swap type eq? ] cons define-compound ;
+object [
+ drop num-types count
+] "builtin-supertypes" set-word-property
+
+! Builtin metaclass for builtin types: fixnum, word, cons, etc.
+SYMBOL: builtin
: add-method ( definition type vtable -- )
>r "builtin-type" word-property r> set-vector-nth ;
-: define-builtin ( type generic definition -- )
+: builtin-method ( type generic definition -- )
-rot "vtable" word-property add-method ;
+builtin [ builtin-method ] "define-method" set-word-property
+
+builtin [
+ "builtin-type" word-property unit
+] "builtin-supertypes" set-word-property
+
+: builtin-predicate ( type# symbol -- word )
+ predicate-word [
+ swap [ swap type eq? ] cons define-compound
+ ] keep ;
+
: builtin-class ( number type -- )
dup undefined? [ dup define-symbol ] when
2dup builtin-predicate
- dup [ define-builtin ] "define-method" set-word-property
+ dupd "predicate" set-word-property
+ dup builtin "metaclass" set-word-property
swap "builtin-type" set-word-property ;
: BUILTIN:
: builtin-type ( symbol -- n )
"builtin-type" word-property ;
+! Predicate metaclass for generalized predicate dispatch.
+SYMBOL: predicate
+
+: predicate-dispatch ( class definition existing -- dispatch )
+ [
+ \ dup ,
+ rot "predicate" word-property ,
+ swap , , \ ifte ,
+ ] make-list ;
+
+: (predicate-method) ( class generic definition type# -- )
+ rot "vtable" word-property
+ [ vector-nth predicate-dispatch ] 2keep
+ set-vector-nth ;
+
+: predicate-method ( class generic definition -- )
+ pick builtin-supertypes [
+ >r 3dup r> (predicate-method)
+ ] each 3drop ;
+
+predicate [
+ predicate-method
+] "define-method" set-word-property
+
+predicate [
+ "superclass" word-property builtin-supertypes
+] "builtin-supertypes" set-word-property
+
+: define-predicate ( class predicate definition -- )
+ rot "superclass" word-property "predicate" word-property
+ [ \ dup , , , [ drop f ] , \ ifte , ] make-list
+ define-compound ;
+
+: PREDICATE: ( -- class predicate definition )
+ #! Followed by a superclass name, then a class name.
+ scan-word
+ CREATE
+ dup rot "superclass" set-word-property
+ dup predicate "metaclass" set-word-property
+ dup predicate-word
+ [ dupd "predicate" set-word-property ] keep
+ [ define-predicate ] [ ] ; parsing
+
+! Traits metaclass for user-defined classes based on hashtables
+
! Hashtable slot holding a selector->method map.
SYMBOL: traits
+: traits-map ( class -- hash )
+ #! The method map word property maps selector words to
+ #! definitions.
+ "traits-map" word-property ;
+
+: traits-method ( class generic definition -- )
+ swap rot traits-map set-hash ;
+
+traits [ traits-method ] "define-method" set-word-property
+
+traits [
+ \ vector "builtin-type" word-property unique,
+] "builtin-supertypes" set-word-property
+
! Hashtable slot holding an optional delegate. Any undefined
! methods are called on the delegate. The object can also
! manually pass any methods on to the delegate.
SYMBOL: delegate
-: traits-map ( type -- hash )
- #! The method map word property maps selector words to
- #! definitions.
- "traits-map" word-property ;
-
: object-map ( obj -- hash )
#! Get the method map for an object.
#! We will use hashtable? here when its a first-class type.
: undefined-method
"No applicable method." throw ;
-: traits-method ( selector traits -- traits quot )
+: traits-dispatch ( selector traits -- traits quot )
#! Look up the method with the traits object on the stack.
#! Returns the traits to call the method on; either the
#! original object, or one of the delegates.
rot drop cdr ( method is defined )
] [
drop delegate swap hash* dup [
- cdr traits-method ( check delegate )
+ cdr traits-dispatch ( check delegate )
] [
drop [ undefined-method ] ( no delegate )
] ifte
traits-map [ swap object-map eq? ] cons
define-compound ;
-: define-traits ( type generic definition -- )
- swap rot traits-map set-hash ;
-
: TRAITS:
#! TRAITS: foo creates a new traits type. Instances can be
#! created with <foo>, and tested with foo?.
CREATE
dup define-symbol
dup init-traits-map
- dup [ define-traits ] "define-method" set-word-property
+ dup traits "metaclass" set-word-property
traits-predicate ; parsing
: add-traits-dispatch ( word vtable -- )
- >r unit [ car swap traits-method call ] cons \ vector r>
+ >r unit [ car swap traits-dispatch call ] cons \ vector r>
add-method ;
-: GENERIC:
- #! GENERIC: bar creates a generic word bar that calls the
- #! bar method on the traits object, with the traits object
- #! on the stack.
- CREATE [ undefined-method ] <vtable>
- 2dup add-traits-dispatch
- define-generic ; parsing
-
: constructor-word ( word -- word )
word-name "<" swap ">" cat3 "in" get create ;
scan-word [ constructor-word ] keep
[ define-constructor ] [ ] ; parsing
-: define-method ( type -- quotation )
+! Defining generic words
+
+: GENERIC:
+ #! GENERIC: bar creates a generic word bar that calls the
+ #! bar method on the traits object, with the traits object
+ #! on the stack.
+ CREATE [ undefined-method ] <vtable>
+ 2dup add-traits-dispatch
+ define-generic ; parsing
+
+: define-method ( class -- quotation )
#! In a vain attempt at something resembling a "meta object
#! protocol", we call the "define-method" word property with
- #! stack ( type generic definition -- ).
- "define-method" word-property
+ #! stack ( class generic definition -- ).
+ metaclass "define-method" word-property
[ [ undefined-method ] ] unless* ;
-: M: ( -- type generic [ ] )
+: M: ( -- class generic [ ] )
#! M: foo bar begins a definition of the bar generic word
#! specialized to the foo type.
scan-word dup define-method scan-word swap [ ] ; parsing
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: hashtables
+USE: generic
USE: kernel
USE: lists
USE: math
! for the lifetime of the hashtable, otherwise problems will
! occur. Do not use vector words with hashtables.
-: hashtable? ( obj -- ? )
- dup vector? [ [ assoc? ] vector-all? ] [ drop f ] ifte ;
+PREDICATE: vector hashtable ( obj -- ? )
+ [ assoc? ] vector-all? ;
: <hashtable> ( buckets -- )
#! A hashtable is implemented as an array of buckets. The
: =? ( x y z -- z/f )
#! Push z if x = y, otherwise f.
- -rot = [ drop f ] unless ;
+ >r = r> f ? ;
: str-head? ( str begin -- str )
#! If the string starts with begin, return the rest of the
IN: prettyprint
USE: errors
USE: format
+USE: generic
USE: kernel
USE: lists
USE: math
USE: words
USE: hashtables
+GENERIC: prettyprint* ( indent obj -- indent )
+
+M: object prettyprint* ( indent obj -- indent )
+ unparse write ;
+
: tab-size
#! Change this to suit your tastes.
4 ;
: prettyprint-space ( -- )
" " write ;
-! Real definition follows
-DEFER: prettyprint*
-
: prettyprint-element ( indent obj -- indent )
- prettyprint* prettyprint-space ;
+ over prettyprint-limit >= [
+ unparse write
+ ] [
+ prettyprint*
+ ] ifte prettyprint-space ;
: <prettyprint ( indent -- indent )
tab-size +
drop [ ]
] ifte ;
-: prettyprint-word ( word -- )
+M: word prettyprint* ( indent word -- indent )
dup word-name
swap dup word-attrs swap word-style append
write-attr ;
: prettyprint-[ ( indent -- indent )
- \ [ prettyprint-word <prettyprint ;
+ \ [ prettyprint* <prettyprint ;
: prettyprint-] ( indent -- indent )
- prettyprint> \ ] prettyprint-word ;
+ prettyprint> \ ] prettyprint* ;
: prettyprint-list ( indent list -- indent )
#! Pretty-print a list, without [ and ].
prettyprint-list
] [
[
- \ | prettyprint-word
+ \ | prettyprint*
prettyprint-space prettyprint-element
] when*
] ifte
] when* ;
-: prettyprint-[] ( indent list -- indent )
+M: cons prettyprint* ( indent list -- indent )
swap prettyprint-[ swap prettyprint-list prettyprint-] ;
: prettyprint-{ ( indent -- indent )
- \ { prettyprint-word <prettyprint ;
+ \ { prettyprint* <prettyprint ;
: prettyprint-} ( indent -- indent )
- prettyprint> \ } prettyprint-word ;
+ prettyprint> \ } prettyprint* ;
: prettyprint-vector ( indent list -- indent )
#! Pretty-print a vector, without { and }.
[ prettyprint-element ] vector-each ;
-: prettyprint-{} ( indent vector -- indent )
+M: vector prettyprint* ( indent vector -- indent )
dup vector-length 0 = [
drop
- \ { prettyprint-word
+ \ { prettyprint*
prettyprint-space
- \ } prettyprint-word
+ \ } prettyprint*
] [
swap prettyprint-{ swap prettyprint-vector prettyprint-}
] ifte ;
: prettyprint-{{ ( indent -- indent )
- \ {{ prettyprint-word <prettyprint ;
+ \ {{ prettyprint* <prettyprint ;
: prettyprint-}} ( indent -- indent )
- prettyprint> \ }} prettyprint-word ;
+ prettyprint> \ }} prettyprint* ;
-: prettyprint-{{}} ( indent hashtable -- indent )
+M: hashtable prettyprint* ( indent hashtable -- indent )
hash>alist dup length 0 = [
drop
- \ {{ prettyprint-word
+ \ {{ prettyprint*
prettyprint-space
- \ }} prettyprint-word
+ \ }} prettyprint*
] [
swap prettyprint-{{ swap prettyprint-list prettyprint-}}
] ifte ;
-: prettyprint-object ( indent obj -- indent )
- unparse write ;
-
-: prettyprint* ( indent obj -- indent )
- over prettyprint-limit >= [
- prettyprint-object
- ] [
- [
- [ f = ] [ prettyprint-object ]
- [ cons? ] [ prettyprint-[] ]
- [ hashtable? ] [ prettyprint-{{}} ]
- [ vector? ] [ prettyprint-{} ]
- [ word? ] [ prettyprint-word ]
- [ drop t ] [ prettyprint-object ]
- ] cond
- ] ifte ;
+: prettyprint-1 ( obj -- )
+ 0 swap prettyprint* drop ;
: prettyprint ( obj -- )
- 0 swap prettyprint* drop terpri ;
+ prettyprint-1 terpri ;
: vocab-link ( vocab -- link )
"vocabularies'" swap cat2 ;
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: prettyprint
+USE: generic
USE: kernel
USE: lists
USE: math
dup vocab-attrs write-attr ;
: prettyprint-IN: ( indent word -- )
- \ IN: prettyprint-word prettyprint-space
+ \ IN: prettyprint* prettyprint-space
word-vocabulary prettyprint-vocab prettyprint-newline ;
: prettyprint-: ( indent -- indent )
- \ : prettyprint-word prettyprint-space
+ \ : prettyprint* prettyprint-space
tab-size + ;
: prettyprint-; ( indent -- indent )
- \ ; prettyprint-word
+ \ ; prettyprint*
tab-size - ;
: prettyprint-prop ( word prop -- )
tuck word-name word-property [
- prettyprint-space prettyprint-word
+ prettyprint-space prettyprint-1
] [
drop
] ifte ;
stack-effect. dup prettyprint-newline
] keep documentation. ;
-: see-compound ( word -- )
+GENERIC: see ( word -- )
+
+M: object see ( obj -- )
+ "Not a word: " write . ;
+
+M: compound see ( word -- )
0 swap
[ dupd prettyprint-IN: prettyprint-: ] keep
- [ prettyprint-word ] keep
+ [ prettyprint-1 ] keep
[ prettyprint-docs ] keep
[ word-parameter prettyprint-list prettyprint-; ] keep
prettyprint-plist prettyprint-newline ;
-: see-primitive ( word -- )
+M: primitive see ( word -- )
"PRIMITIVE: " write dup unparse write stack-effect. terpri ;
-: see-symbol ( word -- )
- \ SYMBOL: prettyprint-word prettyprint-space . ;
+M: symbol see ( word -- )
+ 0 over prettyprint-IN:
+ \ SYMBOL: prettyprint-1 prettyprint-space . ;
-: see-undefined ( word -- )
+M: undefined see ( word -- )
drop "Not defined" print ;
-
-: see ( name -- )
- #! Show a word definition.
- [
- [ compound? ] [ see-compound ]
- [ symbol? ] [ see-symbol ]
- [ primitive? ] [ see-primitive ]
- [ word? ] [ see-undefined ]
- [ drop t ] [ "Not a word: " write . ]
- ] cond ;
: generic-test
{
- drop
- drop
- drop
- drop
- drop
- drop
- nip
- drop
- drop
- drop
- drop
- drop
- drop
- drop
- drop
- drop
- drop
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ nip ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
} generic ; compiled
[ 2 3 ] [ 2 3 t generic-test ] unit-test
: generic-literal-test
4 {
- drop
- nip
- nip
- nip
- nip
- nip
- nip
- nip
- nip
- nip
- nip
- nip
- nip
- nip
- nip
- nip
- nip
+ [ drop ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
+ [ nip ]
} generic ; compiled
[ ] [ generic-literal-test ] unit-test
: generic-test-alt
{
- drop
- drop
- drop
- drop
- nip
- drop
- drop
- drop
- drop
- drop
- drop
- drop
- drop
- drop
- drop
- drop
- drop
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ nip ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
+ [ drop ]
} generic + ; compiled
[ 5 ] [ 2 3 4 generic-test-alt ] unit-test
: generic-test-2
{
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-4
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
- generic-test-3
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-4 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
+ [ generic-test-3 ]
} generic ;
[ 3 ] [ t generic-test-2 ] unit-test
] unit-test
[ t ] [
- [ { drop undefined-method drop undefined-method } generic ] dataflow
+ [ { [ drop ] [ undefined-method ] [ drop ] [ undefined-method ] } generic ] dataflow
#generic swap dataflow-contains-op? car [
node-param get [
[ [ node-param get \ undefined-method = ] bind ] some?
[ t ] [ t bool>str str>bool ] unit-test
[ f ] [ f bool>str str>bool ] unit-test
+
+PREDICATE: cons nonempty-list list? ;
+
+GENERIC: funny-length
+M: cons funny-length drop 0 ;
+M: nonempty-list funny-length length ;
+
+[ 0 ] [ [ 1 2 | 3 ] funny-length ] unit-test
+[ 3 ] [ [ 1 2 3 ] funny-length ] unit-test
+[ "hello" funny-length ] unit-test-fails
[ [ 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
+ "x" off 2 1 "x" [ acons ] change 3 2 "x" [ acons ] change "x" get
] unit-test
[ [ 5 4 3 1 ] ] [
USE: strings
USE: test
+[ f ] [ "a" "b" "c" =? ] unit-test
+[ "c" ] [ "a" "a" "c" =? ] unit-test
+
[ f ] [ "A string." f-or-"" ] unit-test
[ t ] [ "" f-or-"" ] unit-test
[ t ] [ f f-or-"" ] unit-test
"math/float"
"math/complex"
"math/irrational"
- "math/namespaces"
"httpd/url-encoding"
"httpd/html"
"httpd/httpd"
[ t ] [ vocabs [ words [ word? ] all? ] all? ] unit-test
[ f ] [ gensym gensym = ] unit-test
+
+[ f ] [ 123 compound? ] unit-test
+
+: colon-def ;
+[ t ] [ \ colon-def compound? ] unit-test
+
+SYMBOL: a-symbol
+[ f ] [ \ a-symbol compound? ] unit-test
+[ t ] [ \ a-symbol symbol? ] unit-test
[
in-parser? [ parse-dump ] [ standard-dump ] ifte
- [ :s :r :n :c ] [ prettyprint-word " " write ] each
+ [ :s :r :n :c ] [ prettyprint-1 " " write ] each
"show stacks at time of error." print
- \ :get prettyprint-word
+ \ :get prettyprint-1
" ( var -- value ) inspects the error namestack." print
] [
flush-error-handler
: walk-banner ( -- )
"The following words control the single-stepper:" print
- [ &s &r &n &c ] [ prettyprint-word " " write ] each
+ [ &s &r &n &c ] [ prettyprint-1 " " write ] each
"show stepper stacks." print
- \ &get prettyprint-word
+ \ &get prettyprint-1
" ( var -- value ) inspects the stepper namestack." print
- \ step prettyprint-word " -- single step" print
- \ (trace) prettyprint-word " -- trace until end" print
- \ (run) prettyprint-word " -- run until end" print
- \ exit prettyprint-word " -- exit single-stepper" print ;
+ \ step prettyprint-1 " -- single step" print
+ \ (trace) prettyprint-1 " -- trace until end" print
+ \ (run) prettyprint-1 " -- run until end" print
+ \ exit prettyprint-1 " -- exit single-stepper" print ;
: walk ( quot -- )
#! Single-step through execution of a quotation.
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: words
+USE: generic
USE: hashtables
USE: kernel
USE: lists
pick [ set-assoc ] [ remove-assoc nip ] ifte
swap set-word-plist ;
-: ?word-primitive ( obj -- prim/0 )
- dup word? [ word-primitive ] [ drop -1 ] ifte ;
-
-: compound? ( obj -- ? ) ?word-primitive 1 = ;
-: primitive? ( obj -- ? ) ?word-primitive 2 > ;
-: symbol? ( obj -- ? ) ?word-primitive 2 = ;
-: undefined? ( obj -- ? ) ?word-primitive 0 = ;
+PREDICATE: word compound ( obj -- ? ) word-primitive 1 = ;
+PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;
+PREDICATE: word symbol ( obj -- ? ) word-primitive 2 = ;
+PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
: word ( -- word ) global [ "last-word" get ] bind ;
: set-word ( word -- ) global [ "last-word" set ] bind ;