predicate metaclass; prettyprint, see, unparse, ' and other words are now generic

TODO.FACTOR.txt

@@ -35,8 +35,7 @@
 
 + listener/plugin:
 
-- unterminated ; -- NPE
+- sidekick: still parsing too much
-- no USE:'s wrong place
 - errors don't always disappear
 - console: wrong history
 - listener: if too many things popped off the stack, complain

library/bootstrap/image.factor

@@ -40,6 +40,7 @@
 
 IN: image
 USE: errors
+USE: generic
 USE: hashtables
 USE: kernel
 USE: lists
@@ -128,6 +129,9 @@ SYMBOL: boot-quot
 : heap-size-offset 5 ;
 : header-size      6 ;
 
+GENERIC: ' ( obj -- ptr )
+#! Write an object to the image.
+
 ( Allocator )
 
 : here ( -- size ) 
@@ -149,11 +153,11 @@ SYMBOL: boot-quot
 
 ( 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
@@ -170,11 +174,16 @@ SYMBOL: boot-quot
 : t,
     object-tag here-as "t" set
     t-type >header emit
-    0 emit-fixnum emit ;
+    0 ' emit ;
 
-:  0,  0 emit-bignum drop ;
+M: t ' ( obj -- ptr ) drop "t" get ;
-:  1,  1 emit-bignum drop ;
+M: f ' ( obj -- ptr )
-: -1, -1 emit-bignum drop ;
+    #! f is #define F RETAG(0,OBJECT_TYPE)
+    drop object-tag ;
+
+:  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,
@@ -209,14 +218,12 @@ SYMBOL: boot-quot
         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: '
+M: cons ' ( c -- tagged )
-
-: emit-cons ( c -- tagged )
     uncons ' swap '
     cons-tag here-as
     -rot emit emit ;
@@ -239,7 +246,7 @@ DEFER: '
 : 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
@@ -247,13 +254,13 @@ DEFER: '
     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 )
@@ -300,7 +307,7 @@ DEFER: '
     ( 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
@@ -308,22 +315,6 @@ DEFER: '
     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, ( -- )

library/generic.factor

@@ -35,9 +35,34 @@ USE: parser
 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
 
@@ -51,24 +76,41 @@ 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 )
+object [
-    word-name "?" cat2 "in" get create ;
+    define-object
+] "define-method" set-word-property
 
-: builtin-predicate ( type# symbol -- )
+object [
-    predicate-word swap [ swap type eq? ] cons define-compound ;
+    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:
@@ -79,19 +121,73 @@ object [ define-object ] "define-method" set-word-property
 : 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.
@@ -103,7 +199,7 @@ SYMBOL: delegate
 : 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.
@@ -111,7 +207,7 @@ SYMBOL: delegate
         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
@@ -124,30 +220,19 @@ SYMBOL: delegate
     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 ;
 
@@ -162,14 +247,24 @@ SYMBOL: delegate
     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 -- ).
+    #! stack ( class generic definition -- ).
-    "define-method" word-property
+    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

library/hashtables.factor

@@ -26,6 +26,7 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: hashtables
+USE: generic
 USE: kernel
 USE: lists
 USE: math
@@ -35,8 +36,8 @@ USE: vectors
 ! for the lifetime of the hashtable, otherwise problems will
 ! occur. Do not use vector words with hashtables.
 
-: hashtable? ( obj -- ? )
+PREDICATE: vector hashtable ( obj -- ? )
-    dup vector? [ [ assoc? ] vector-all? ] [ drop f ] ifte ;
+    [ assoc? ] vector-all? ;
 
 : <hashtable> ( buckets -- )
     #! A hashtable is implemented as an array of buckets. The

library/strings.factor

@@ -91,7 +91,7 @@ USE: math
 
 : =? ( 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

library/syntax/prettyprint.factor

@@ -28,6 +28,7 @@
 IN: prettyprint
 USE: errors
 USE: format
+USE: generic
 USE: kernel
 USE: lists
 USE: math
@@ -40,6 +41,11 @@ USE: vectors
 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 ;
@@ -58,11 +64,12 @@ USE: hashtables
 : 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 +
@@ -107,16 +114,16 @@ DEFER: prettyprint*
         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 ].
@@ -126,70 +133,56 @@ DEFER: prettyprint*
             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 )
+: prettyprint-1 ( obj -- )
-    unparse write ;
+    0 swap prettyprint* drop ;
-
-: 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 ( obj -- )
-    0 swap prettyprint* drop terpri ;
+    prettyprint-1 terpri ;
 
 : vocab-link ( vocab -- link )
     "vocabularies'" swap cat2 ;

library/syntax/see.factor

@@ -26,6 +26,7 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: prettyprint
+USE: generic
 USE: kernel
 USE: lists
 USE: math
@@ -43,20 +44,20 @@ USE: words
     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 ;
@@ -88,29 +89,25 @@ USE: words
         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 -- )
+M: symbol see ( word -- )
-    \ SYMBOL: prettyprint-word prettyprint-space . ;
+    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 ;

library/test/compiler/generic.factor

@@ -7,23 +7,23 @@ USE: words
 
 : generic-test
     {
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        nip
+        [ nip  ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
     } generic ; compiled
 
 [ 2 3 ] [ 2 3 t generic-test ] unit-test
@@ -32,46 +32,46 @@ USE: words
 
 : generic-literal-test
     4 {
-        drop
+        [ drop ]
-        nip
+        [ nip  ]
-        nip
+        [ nip  ]
-        nip
+        [ nip  ]
-        nip
+        [ nip  ]
-        nip
+        [ nip  ]
-        nip
+        [ nip  ]
-        nip
+        [ nip  ]
-        nip
+        [ nip  ]
-        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 ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        nip
+        [ nip  ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
-        drop
+        [ drop ]
     } generic + ; compiled
 
 [ 5 ] [ 2 3 4 generic-test-alt ] unit-test
@@ -87,23 +87,23 @@ DEFER: generic-test-2
 
 : generic-test-2
     {
-        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-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-3
+        [ generic-test-3 ]
-        generic-test-3
+        [ generic-test-3 ]
     } generic ;
 
 [ 3 ] [ t generic-test-2 ] unit-test

library/test/dataflow.factor

@@ -62,7 +62,7 @@ USE: generic
 ] 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?

library/test/generic.factor

@@ -90,3 +90,13 @@ M: f bool>str drop "false" ;
 
 [ 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

library/test/lists/namespaces.factor

@@ -8,7 +8,7 @@ USE: test
 [ [ 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 ] ] [

library/test/strings.factor

@@ -6,6 +6,9 @@ USE: namespaces
 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

library/test/test.factor

@@ -100,7 +100,6 @@ USE: unparser
         "math/float"
         "math/complex"
         "math/irrational"
-        "math/namespaces"
         "httpd/url-encoding"
         "httpd/html"
         "httpd/httpd"

library/test/words.factor

@@ -55,3 +55,12 @@ word word-name "last-word-test" set
 [ 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

library/tools/debugger.factor

@@ -156,9 +156,9 @@ USE: math
     [
         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

library/tools/interpreter.factor

@@ -187,14 +187,14 @@ SYMBOL: meta-cf
 
 : 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
+    \ step prettyprint-1 " -- single step" print
-    \ (trace) prettyprint-word " -- trace until end" print
+    \ (trace) prettyprint-1 " -- trace until end" print
-    \ (run) prettyprint-word " -- run until end" print
+    \ (run) prettyprint-1 " -- run until end" print
-    \ exit prettyprint-word " -- exit single-stepper" print ;
+    \ exit prettyprint-1 " -- exit single-stepper" print ;
 
 : walk ( quot -- )
     #! Single-step through execution of a quotation.

library/words.factor

@@ -26,6 +26,7 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: words
+USE: generic
 USE: hashtables
 USE: kernel
 USE: lists
@@ -41,13 +42,10 @@ USE: strings
     pick [ set-assoc ] [ remove-assoc nip ] ifte
     swap set-word-plist ;
 
-: ?word-primitive ( obj -- prim/0 )
+PREDICATE: word compound  ( obj -- ? ) word-primitive 1 = ;
-    dup word? [ word-primitive ] [ drop -1 ] ifte ;
+PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;
-
+PREDICATE: word symbol    ( obj -- ? ) word-primitive 2 = ;
-: compound?  ( obj -- ? ) ?word-primitive 1 = ;
+PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
-: primitive? ( obj -- ? ) ?word-primitive 2 > ;
-: symbol?    ( obj -- ? ) ?word-primitive 2 = ;
-: undefined? ( obj -- ? ) ?word-primitive 0 = ;
 
 : word ( -- word ) global [ "last-word" get ] bind ;
 : set-word ( word -- ) global [ "last-word" set ] bind ;