steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

cvs
Slava Pestov 2004-12-13 04:49:44 +00:00
parent 24ea465e4b
commit 7a31260d23
17 changed files with 303 additions and 208 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
TODO.FACTOR.txt
View File

@ -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

51
library/bootstrap/image.factor
View File

@ -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, ( -- )

157
library/generic.factor
View File

@ -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 )
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 <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 -- ).
"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

5
library/hashtables.factor
View File

@ -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? ;
: <hashtable> ( buckets -- )
#! A hashtable is implemented as an array of buckets. The

2
library/strings.factor
View File

@ -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

65
library/syntax/prettyprint.factor
View File

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

37
library/syntax/see.factor
View File

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

136
library/test/compiler/generic.factor
View File

@ -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

2
library/test/dataflow.factor
View File

@ -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?

10
library/test/generic.factor
View File

@ -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

2
library/test/lists/namespaces.factor
View File

@ -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 ] ] [

3
library/test/strings.factor
View File

@ -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

1
library/test/test.factor
View File

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

9
library/test/words.factor
View File

@ -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

4
library/tools/debugger.factor
View File

@ -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

12
library/tools/interpreter.factor
View File

@ -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.

12
library/words.factor
View File

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