diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index d15bbf0162..6506c2c6b0 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -35,8 +35,7 @@ + listener/plugin: -- unterminated ; -- NPE -- no USE:'s wrong place +- sidekick: still parsing too much - errors don't always disappear - console: wrong history - listener: if too many things popped off the stack, complain diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index dd3a5730fd..4d0afde88c 100644 --- a/library/bootstrap/image.factor +++ b/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 ; -: 1, 1 emit-bignum drop ; -: -1, -1 emit-bignum drop ; +M: t ' ( obj -- ptr ) drop "t" get ; +M: f ' ( obj -- ptr ) + #! 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: ' - -: emit-cons ( c -- tagged ) +M: 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, ( -- ) diff --git a/library/generic.factor b/library/generic.factor index fd4c7d8a84..5d2620bcf5 100644 --- a/library/generic.factor +++ b/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 -- ) 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: @@ -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 , 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 ] - 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 ] + 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 diff --git a/library/hashtables.factor b/library/hashtables.factor index 34a6690a75..63238063be 100644 --- a/library/hashtables.factor +++ b/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 -- ? ) - dup vector? [ [ assoc? ] vector-all? ] [ drop f ] ifte ; +PREDICATE: vector hashtable ( obj -- ? ) + [ assoc? ] vector-all? ; : ( buckets -- ) #! A hashtable is implemented as an array of buckets. The diff --git a/library/strings.factor b/library/strings.factor index 5b55ff9d08..683f3630ea 100644 --- a/library/strings.factor +++ b/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 diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 9ab7e29f77..d93117058f 100644 --- a/library/syntax/prettyprint.factor +++ b/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-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-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-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 ; diff --git a/library/syntax/see.factor b/library/syntax/see.factor index f97cf973d6..fde6db2df0 100644 --- a/library/syntax/see.factor +++ b/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 -- ) - \ 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 ; diff --git a/library/test/compiler/generic.factor b/library/test/compiler/generic.factor index ba99f779c5..9a91e84209 100644 --- a/library/test/compiler/generic.factor +++ b/library/test/compiler/generic.factor @@ -7,23 +7,23 @@ USE: words : 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 @@ -32,46 +32,46 @@ USE: words : 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 @@ -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-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 diff --git a/library/test/dataflow.factor b/library/test/dataflow.factor index c6d1caa481..143e241222 100644 --- a/library/test/dataflow.factor +++ b/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? diff --git a/library/test/generic.factor b/library/test/generic.factor index 801035b794..012f2bf3e3 100644 --- a/library/test/generic.factor +++ b/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 diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor index eedc2df07a..e539095b9f 100644 --- a/library/test/lists/namespaces.factor +++ b/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 ] ] [ diff --git a/library/test/strings.factor b/library/test/strings.factor index 6d4664110f..602351a11b 100644 --- a/library/test/strings.factor +++ b/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 diff --git a/library/test/test.factor b/library/test/test.factor index 3a59d823a6..480aaaa601 100644 --- a/library/test/test.factor +++ b/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" diff --git a/library/test/words.factor b/library/test/words.factor index 675277054c..783b571b23 100644 --- a/library/test/words.factor +++ b/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 diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 3597e15a56..66846fc2ae 100644 --- a/library/tools/debugger.factor +++ b/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 diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index b7e1b7ba54..541598e89a 100644 --- a/library/tools/interpreter.factor +++ b/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 - \ (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. diff --git a/library/words.factor b/library/words.factor index 337d373bcd..f834a23f64 100644 --- a/library/words.factor +++ b/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 ) - 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 ;