automatic decompiling of definitions, cross reference database, cleaned up bootstrap

TODO.FACTOR.txt

@@ -10,9 +10,7 @@
 - unix ffi i/o
 - make-image: use a list not a vector
 - powerpc has weird callstack residue
-- make see work with union, builtin, predicate
 - make-vector and make-string should not need a reverse step
-- automatically recompiling defs
 - faster completion
 - console with presentations
 - ui browser
@@ -50,6 +48,7 @@
 
 + kernel:
 
+- unify unparse and prettyprint
 - condition system with restarts
 - nicer way to combine two paths
 - vectors: ensure its ok with bignum indices

library/bootstrap/boot-stage1.factor

@@ -4,9 +4,11 @@ IN: image
 USING: lists parser namespaces stdio kernel vectors words
 hashtables ;
 
+"Bootstrap stage 1..." print
+
 "/library/bootstrap/primitives.factor" run-resource
 
-: pull-in ( list -- ) [ parse-resource append, ] each ;
+: pull-in ( list -- ) [ dup print parse-resource append, ] each ;
 
 ! The make-list form creates a boot quotation
 [
@@ -27,8 +29,9 @@ hashtables ;
         "/library/vectors.factor"
         "/library/strings.factor"
         "/library/hashtables.factor"
-        "/library/words.factor"
         "/library/namespaces.factor"
+        "/library/words.factor"
+        "/library/vocabularies.factor"
         "/library/sbuf.factor"
         "/library/errors.factor"
         "/library/continuations.factor"
@@ -37,7 +40,6 @@ hashtables ;
         "/library/io/stdio.factor"
         "/library/io/io-internals.factor"
         "/library/io/stream-impl.factor"
-        "/library/vocabularies.factor"
         "/library/syntax/unparser.factor"
         "/library/syntax/parse-numbers.factor"
         "/library/syntax/parse-words.factor"

library/bootstrap/boot-stage2.factor

@@ -1,17 +1,13 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-USING: command-line kernel lists namespaces parser stdio
+USING: command-line command-line kernel lists parser stdio words ;
-unparser words ;
 
-"Cold boot in progress..." print
+"Bootstrap stage 2..." print
 
+recrossref
 default-cli-args
 parse-command-line
 
-! Dummy defs for mini bootstrap
-IN: compiler : compile-all ; : compile drop ; : supported-cpu? f ;
-IN: assembler : init-assembler ;
-
 : pull-in ( ? list -- )
     swap [
         [
@@ -59,112 +55,4 @@ cpu "ppc" = [
     "/library/compiler/ppc/generator.factor"
 ] pull-in
 
-"compile" get supported-cpu? and [
+"/library/bootstrap/boot-stage3.factor" run-resource
-    init-assembler
-    \ car compile
-    \ = compile
-    \ unparse compile
-    \ scan compile
-] when
-
-t [
-    "/library/math/constants.factor"
-    "/library/math/pow.factor"
-    "/library/math/trig-hyp.factor"
-    "/library/math/arc-trig-hyp.factor"
-
-    "/library/in-thread.factor"
-    "/library/random.factor"
-
-    "/library/io/network.factor"
-    "/library/io/logging.factor"
-    "/library/io/stdio-binary.factor"
-    
-    "/library/syntax/see.factor"
-    
-    "/library/eval-catch.factor"
-    "/library/tools/memory.factor"
-    "/library/tools/listener.factor"
-    "/library/io/ansi.factor"
-    "/library/tools/word-tools.factor"
-    "/library/test/test.factor"
-    "/library/inference/test.factor"
-    "/library/tools/telnetd.factor"
-    "/library/tools/jedit-wire.factor"
-    "/library/tools/profiler.factor"
-    "/library/tools/walker.factor"
-    "/library/tools/annotations.factor"
-    "/library/tools/jedit.factor"
-    "/library/bootstrap/image.factor"
-
-    "/library/httpd/url-encoding.factor"
-    "/library/httpd/mime.factor"
-    "/library/httpd/html-tags.factor"
-    "/library/httpd/html.factor"
-    "/library/httpd/http-common.factor"
-    "/library/httpd/responder.factor"
-    "/library/httpd/httpd.factor"
-    "/library/httpd/file-responder.factor"
-    "/library/httpd/test-responder.factor"
-    "/library/httpd/quit-responder.factor"
-    "/library/httpd/resource-responder.factor"
-    "/library/httpd/cont-responder.factor"
-    "/library/httpd/browser-responder.factor"
-    "/library/httpd/default-responders.factor"
-
-    "/library/sdl/sdl.factor"
-    "/library/sdl/sdl-video.factor"
-    "/library/sdl/sdl-event.factor"
-    "/library/sdl/sdl-gfx.factor"
-    "/library/sdl/sdl-keysym.factor"
-    "/library/sdl/sdl-keyboard.factor"
-    "/library/sdl/sdl-ttf.factor"
-    "/library/sdl/sdl-utils.factor"
-    "/library/ui/shapes.factor"
-    "/library/ui/points.factor"
-    "/library/ui/rectangles.factor"
-    "/library/ui/lines.factor"
-    "/library/ui/ellipses.factor"
-    "/library/ui/gadgets.factor"
-    "/library/ui/hierarchy.factor"
-    "/library/ui/paint.factor"
-    "/library/ui/text.factor"
-    "/library/ui/gestures.factor"
-    "/library/ui/hand.factor"
-    "/library/ui/layouts.factor"
-    "/library/ui/piles.factor"
-    "/library/ui/shelves.factor"
-    "/library/ui/borders.factor"
-    "/library/ui/stacks.factor"
-    "/library/ui/frames.factor"
-    "/library/ui/world.factor"
-    "/library/ui/labels.factor"
-    "/library/ui/buttons.factor"
-    "/library/ui/checkboxes.factor"
-    "/library/ui/line-editor.factor"
-    "/library/ui/events.factor"
-    "/library/ui/scrolling.factor"
-    "/library/ui/editors.factor"
-    "/library/ui/menus.factor"
-    "/library/ui/presentations.factor"
-    "/library/ui/panes.factor"
-    "/library/ui/tiles.factor"
-    "/library/ui/dialogs.factor"
-    "/library/ui/inspector.factor"
-    "/library/ui/init-world.factor"
-    "/library/ui/tool-menus.factor"
-] pull-in
-
-os "win32" = [
-    "/library/io/buffer.factor"
-    "/library/win32/win32-io.factor"
-    "/library/win32/win32-errors.factor"
-    "/library/win32/winsock.factor"
-    "/library/io/win32-io-internals.factor"
-    "/library/io/win32-stream.factor"
-    "/library/io/win32-server.factor"
-] pull-in
-
-FORGET: pull-in
-
-"/library/bootstrap/init-stage2.factor" dup print run-resource

library/bootstrap/boot-stage3.factor

@@ -0,0 +1,116 @@
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+USING: assembler compiler kernel lists namespaces parser stdio
+unparser ;
+
+"Bootstrap stage 3..." print
+
+"compile" get supported-cpu? and [
+    init-assembler
+    \ car compile
+    \ = compile
+    \ unparse compile
+    \ scan compile
+] when
+
+t [
+    "/library/math/constants.factor"
+    "/library/math/pow.factor"
+    "/library/math/trig-hyp.factor"
+    "/library/math/arc-trig-hyp.factor"
+
+    "/library/in-thread.factor"
+    "/library/random.factor"
+
+    "/library/io/network.factor"
+    "/library/io/logging.factor"
+    "/library/io/stdio-binary.factor"
+    
+    "/library/syntax/see.factor"
+    
+    "/library/eval-catch.factor"
+    "/library/tools/memory.factor"
+    "/library/tools/listener.factor"
+    "/library/io/ansi.factor"
+    "/library/tools/word-tools.factor"
+    "/library/test/test.factor"
+    "/library/inference/test.factor"
+    "/library/tools/telnetd.factor"
+    "/library/tools/jedit-wire.factor"
+    "/library/tools/profiler.factor"
+    "/library/tools/walker.factor"
+    "/library/tools/annotations.factor"
+    "/library/tools/jedit.factor"
+    "/library/bootstrap/image.factor"
+
+    "/library/httpd/url-encoding.factor"
+    "/library/httpd/mime.factor"
+    "/library/httpd/html-tags.factor"
+    "/library/httpd/html.factor"
+    "/library/httpd/http-common.factor"
+    "/library/httpd/responder.factor"
+    "/library/httpd/httpd.factor"
+    "/library/httpd/file-responder.factor"
+    "/library/httpd/test-responder.factor"
+    "/library/httpd/quit-responder.factor"
+    "/library/httpd/resource-responder.factor"
+    "/library/httpd/cont-responder.factor"
+    "/library/httpd/browser-responder.factor"
+    "/library/httpd/default-responders.factor"
+
+    "/library/sdl/sdl.factor"
+    "/library/sdl/sdl-video.factor"
+    "/library/sdl/sdl-event.factor"
+    "/library/sdl/sdl-gfx.factor"
+    "/library/sdl/sdl-keysym.factor"
+    "/library/sdl/sdl-keyboard.factor"
+    "/library/sdl/sdl-ttf.factor"
+    "/library/sdl/sdl-utils.factor"
+    "/library/ui/shapes.factor"
+    "/library/ui/points.factor"
+    "/library/ui/rectangles.factor"
+    "/library/ui/lines.factor"
+    "/library/ui/ellipses.factor"
+    "/library/ui/gadgets.factor"
+    "/library/ui/hierarchy.factor"
+    "/library/ui/paint.factor"
+    "/library/ui/text.factor"
+    "/library/ui/gestures.factor"
+    "/library/ui/hand.factor"
+    "/library/ui/layouts.factor"
+    "/library/ui/piles.factor"
+    "/library/ui/shelves.factor"
+    "/library/ui/borders.factor"
+    "/library/ui/stacks.factor"
+    "/library/ui/frames.factor"
+    "/library/ui/world.factor"
+    "/library/ui/labels.factor"
+    "/library/ui/buttons.factor"
+    "/library/ui/checkboxes.factor"
+    "/library/ui/line-editor.factor"
+    "/library/ui/events.factor"
+    "/library/ui/scrolling.factor"
+    "/library/ui/editors.factor"
+    "/library/ui/menus.factor"
+    "/library/ui/presentations.factor"
+    "/library/ui/panes.factor"
+    "/library/ui/tiles.factor"
+    "/library/ui/dialogs.factor"
+    "/library/ui/inspector.factor"
+    "/library/ui/init-world.factor"
+    "/library/ui/tool-menus.factor"
+] pull-in
+
+os "win32" = [
+    "/library/io/buffer.factor"
+    "/library/win32/win32-io.factor"
+    "/library/win32/win32-errors.factor"
+    "/library/win32/winsock.factor"
+    "/library/io/win32-io-internals.factor"
+    "/library/io/win32-stream.factor"
+    "/library/io/win32-server.factor"
+] pull-in
+
+FORGET: pull-in
+
+"/library/bootstrap/boot-stage4.factor" dup print run-resource

library/bootstrap/boot-stage4.factor

@@ -6,6 +6,8 @@ generic inference kernel-internals listener lists math memory
 namespaces parser presentation random stdio streams unparser
 words ;
 
+"Bootstrap stage 4..." print
+
 : warm-boot ( -- )
     #! A fully bootstrapped image has this as the boot
     #! quotation.

library/bootstrap/image.factor

@@ -378,7 +378,7 @@ M: hashtable ' ( hashtable -- pointer )
     #! Make an image for the C interpreter.
     [
         boot-quot off
-        "/library/bootstrap/boot.factor" run-resource
+        "/library/bootstrap/boot-stage1.factor" run-resource
     ] with-image
 
     swap write-image ;

library/compiler/alien.factor

@@ -1,11 +1,20 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: assembler compiler errors generic inference interpreter
+USING: assembler compiler errors generic hashtables inference
-kernel lists math namespaces parser words hashtables strings
+interpreter kernel lists math namespaces parser stdio strings
-unparser ;
+unparser words ;
 
-! Command line parameters specify libraries to load.
+! ! ! WARNING ! ! !
+! Reloading this file into a running Factor instance on Win32
+! or Unix with FFI I/O will bomb the runtime, since I/O words
+! would become uncompiled, and FFI calls can only be made from
+! compiled code.
+
+! USAGE:
+! 
+! Command line parameters given to the runtime specify libraries
+! to load.
 !
 ! -libraries:<foo>:name=<soname> -- define a library <foo>, to be
 ! loaded from the <soname> DLL.
@@ -134,16 +143,24 @@ SYMBOL: alien-parameters
 
 #alien-invoke [ linearize-alien ] "linearizer" set-word-prop
 
+TUPLE: alien-error lib ;
+
+C: alien-error ( lib -- ) [ set-alien-error-lib ] keep ;
+
+M: alien-error error. ( error -- )
+    [
+        "alien-invoke cannot be interpreted. " ,
+        "Either the compiler is disabled, " ,
+        "or the ``" , alien-error-lib ,
+        "'' library is missing." ,
+    ] make-string print ;
+
 : alien-invoke ( ... returns library function parameters -- ... )
     #! Call a C library function.
     #! 'returns' is a type spec, and 'parameters' is a list of
     #! type specs. 'library' is an entry in the "libraries"
     #! namespace.
-    [
+    rot <alien-error> throw ;
-        "alien-invoke cannot be interpreted. " ,
-        "Either the compiler is disabled, " ,
-        "or the ``" , rot , "'' library is missing. " ,
-    ] make-string throw ;
 
 \ alien-invoke [ [ object object object object ] [ ] ]
 "infer-effect" set-word-prop

library/compiler/compiler.factor

@@ -59,5 +59,7 @@ M: compound (compile) ( word -- )
 : decompile ( word -- )
     [ word-primitive ] keep set-word-primitive ;
 
+M: compound (undefine) decompile ;
+
 : recompile ( word -- )
     dup decompile compile ;

library/generic/builtin.factor

@@ -46,3 +46,5 @@ builtin [ 2drop t ] "class<" set-word-prop
 
 : builtin-type ( n -- symbol )
     unit classes get hash ;
+
+PREDICATE: word builtin metaclass builtin = ;

library/generic/complement.factor

@@ -39,3 +39,5 @@ complement [
     2dup "complement" set-word-prop
     dupd complement-predicate "predicate" set-word-prop
     complement define-class ;
+
+PREDICATE: word complement metaclass complement = ;

library/generic/predicate.factor

@@ -42,7 +42,10 @@ predicate [
 ] "class<" set-word-prop
 
 : define-predicate ( class predicate definition -- )
+    pick over "definition" set-word-prop
     pick "superclass" word-prop "predicate" word-prop
     [ \ dup , append, , [ drop f ] , \ ifte , ] make-list
     define-compound
     predicate "metaclass" set-word-prop ;
+
+PREDICATE: word predicate metaclass predicate = ;

library/generic/tuple.factor

@@ -75,6 +75,7 @@ UNION: arrayed array tuple ;
     ] ifte ;
 
 : tuple-slots ( tuple slots -- )
+    2dup "slot-names" set-word-prop
     2dup length 2 + "tuple-size" set-word-prop
     4 -rot simple-slots ;
 
@@ -202,3 +203,5 @@ tuple [
 tuple 10 "priority" set-word-prop
 
 tuple [ 2drop t ] "class<" set-word-prop
+
+PREDICATE: word tuple-class metaclass tuple = ;

library/generic/union.factor

@@ -48,3 +48,5 @@ union [ 2drop t ] "class<" set-word-prop
     [ union-predicate define-compound ] keep
     dupd "members" set-word-prop
     union define-class ;
+
+PREDICATE: word union metaclass union = ;

library/lists.factor

@@ -54,28 +54,6 @@ IN: lists USING: generic kernel math ;
         drop
     ] ifte ; inline
 
-! Redefined below
-DEFER: tree-contains?
-
-: =-or-contains? ( element obj -- ? )
-    dup cons? [ tree-contains? ] [ = ] ifte ;
-
-: tree-contains? ( element tree -- ? )
-    dup [
-        2dup car =-or-contains? [
-            nip
-        ] [
-            cdr dup cons? [
-                tree-contains?
-            ] [
-                ! don't bomb on dotted pairs
-                =-or-contains?
-            ] ifte
-        ] ifte
-    ] [
-        2drop f
-    ] ifte ;
-
 : unique ( elem list -- list )
     #! Prepend an element to a list if it does not occur in the
     #! list.

library/math/complex.factor

@@ -1,10 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: errors
-DEFER: throw
-
 IN: math-internals
-USING: generic kernel kernel-internals math ;
+USING: errors generic kernel kernel-internals math ;
 
 : (rect>) ( xr xi -- x )
     #! Does not perform a check that the arguments are reals.

library/namespaces.factor

@@ -158,3 +158,32 @@ SYMBOL: list-buffer
     #! Append some code that pushes the word on the stack. Used
     #! when building quotations.
     unit , \ car , ;
+
+! Building hashtables, and computing a transitive closure.
+SYMBOL: hash-buffer
+
+: make-hash ( quot -- hash )
+    [
+        <namespace> hash-buffer set
+        call
+        hash-buffer get
+    ] with-scope ; inline
+
+: hash, ( value key -- ? )
+    hash-buffer get [ hash swap ] 2keep set-hash ;
+
+: (closure) ( key hash -- )
+    tuck hash dup [
+        hash-keys [
+            dup dup hash, [
+                2drop
+            ] [
+                swap (closure)
+            ] ifte
+        ] each-with
+    ] [
+        2drop
+    ] ifte ;
+
+: closure ( key hash -- list )
+    [ (closure) ] make-hash hash-keys ;

library/syntax/prettyprint.factor

@@ -51,14 +51,11 @@ M: object prettyprint* ( indent obj -- indent )
         drop [ ]
     ] ifte ;
 
-: prettyprint-word ( word -- )
+: word. ( word -- ) dup word-name swap word-attrs write-attr ;
-    dup word-name swap word-attrs write-attr ;
+: word-bl word. " " write ;
 
 M: word prettyprint* ( indent word -- indent )
-    dup parsing? [
+    dup parsing? [ \ POSTPONE: word-bl ] when word. ;
-        \ POSTPONE: prettyprint-word " " write
-    ] when
-    prettyprint-word ;
 
 : indent ( indent -- )
     #! Print the given number of spaces.
@@ -100,14 +97,11 @@ M: word prettyprint* ( indent word -- indent )
     #! or { }, or << >>. The body of the list is indented,
     #! unless the list is empty.
     over [
-        >r
+        >r >r word. <prettyprint
-        >r prettyprint-word <prettyprint
         r> prettyprint-elements
-        prettyprint> r> prettyprint-word
+        prettyprint> r> word.
     ] [
-        >r >r prettyprint-word " " write
+        >r >r word. " " write r> drop r> word.
-        r> drop
-        r> prettyprint-word
     ] ifte ;
 
 M: list prettyprint* ( indent list -- indent )

library/syntax/see.factor

@@ -17,19 +17,14 @@ presentation streams unparser words ;
     #! popup.
     unparse vocab-actions <actions> "actions" swons unit ;
 
-: prettyprint-vocab ( vocab -- )
+: vocab. ( vocab -- ) dup vocab-attrs write-attr ;
-    dup vocab-attrs write-attr ;
 
 : prettyprint-IN: ( word -- )
-    \ IN: prettyprint-word " " write
+    \ IN: word-bl word-vocabulary vocab. terpri ;
-    word-vocabulary prettyprint-vocab " " write ;
-
-: prettyprint-; ( indent -- indent )
-    \ ; prettyprint-word tab-size get - ;
 
 : prettyprint-prop ( word prop -- )
     tuck word-name word-prop [
-        " " write prettyprint-word
+        " " write word.
     ] [
         drop
     ] ifte ;
@@ -80,39 +75,79 @@ presentation streams unparser words ;
         ] each
     ] when* ;
 
-GENERIC: see ( word -- )
+: definer. ( word -- ) dup definer word-bl word-bl ;
 
-M: compound see ( word -- )
+: (see) ( word -- )
-    dup (see)
+    dup prettyprint-IN: dup definer. stack-effect. terpri ;
+
+GENERIC: (see) ( word -- )
+
+M: compound (see) ( word -- )
     tab-size get dup indent swap
     [ documentation. ] keep
-    [ word-def prettyprint-elements prettyprint-; ] keep
+    [ word-def prettyprint-elements \ ; word. ] keep
-    prettyprint-plist prettyprint-newline ;
+    prettyprint-plist terpri drop ;
 
 : prettyprint-M: ( indent -- indent )
-    \ M: prettyprint-word " " write tab-size get + ;
+    \ M: word-bl tab-size get + ;
+
+: prettyprint-; \ ; word. terpri ;
 
 : see-method ( indent word class method -- indent )
     >r >r >r prettyprint-M:
-    r> r> prettyprint-word " " write
+    r> r> word-bl
-    prettyprint-word " " write
+    word-bl
     dup prettyprint-newline
     r> prettyprint-elements
-    prettyprint-;
+    prettyprint-; tab-size get - ;
-    terpri ;
-
-: definer. ( word -- ) definer prettyprint-word " " write ;
-
-: (see) ( word -- )
-    dup prettyprint-IN: dup definer. dup prettyprint-word
-    stack-effect. terpri ;
 
 : see-generic ( word -- )
-    dup (see) 0 swap
+    0 swap dup methods [
-    dup methods [ over >r uncons see-method r> ] each 2drop ;
+        over >r uncons see-method r>
+    ] each 2drop ;
 
-M: generic see ( word -- ) see-generic ;
+M: generic (see) ( word -- ) see-generic ;
 
-M: 2generic see ( word -- ) see-generic ;
+M: 2generic (see) ( word -- ) see-generic ;
 
-M: word see (see) ;
+M: word (see) drop ;
+
+GENERIC: class.
+
+M: union class.
+    \ UNION: word-bl
+    dup word-bl
+    0 swap "members" word-prop prettyprint-elements drop
+    prettyprint-; ;
+
+M: complement class.
+    \ COMPLEMENT: word-bl
+    dup word-bl
+    "complement" word-prop word. terpri ;
+
+M: builtin class.
+    \ BUILTIN: word-bl
+    dup word-bl
+    dup "builtin-type" word-prop unparse write " " write
+    0 swap "slots" word-prop prettyprint-elements drop
+    prettyprint-; ;
+
+M: predicate class.
+    \ PREDICATE: word-bl
+    dup "superclass" word-prop word-bl
+    dup word-bl
+    tab-size get dup prettyprint-newline swap
+    "definition" word-prop prettyprint-elements drop
+    prettyprint-; ;
+
+M: tuple-class class.
+    \ TUPLE: word-bl
+    dup word-bl
+    "slot-names" word-prop [ write " " write ] each
+    prettyprint-; ;
+
+M: word class. drop ;
+
+: see ( word -- )
+    dup prettyprint-IN: dup definer. dup word.
+    dup stack-effect. terpri dup (see) class. ;

library/test/generic.factor

@@ -1,4 +1,6 @@
 IN: scratchpad
+USING: parser prettyprint stdio ;
+
 USE: hashtables
 USE: namespaces
 USE: generic
@@ -118,3 +120,19 @@ TUPLE: another-one ;
 
 [ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
 [ << another-one f >> ] [ <another-one> empty-method-test ] unit-test
+
+! Test generic see and parsing
+[ "IN: scratchpad\nSYMBOL: bah\nUNION: bah fixnum alien ;\n" ]
+[ [ \ bah see ] with-string ] unit-test
+
+[ t ] [
+    DEFER: not-fixnum
+    "IN: scratchpad\nSYMBOL: not-fixnum\nCOMPLEMENT: not-fixnum fixnum\n"
+    dup eval
+    [ \ not-fixnum see ] with-string =
+] unit-test
+
+! Weird bug
+GENERIC: stack-underflow
+M: object stack-underflow 2drop ;
+M: word stack-underflow 2drop ;

library/test/inference.factor

@@ -172,7 +172,6 @@ SYMBOL: sym-test
 [ [[ 1 1 ]] ] [ [ length ] infer old-effect ] unit-test
 [ [[ 1 1 ]] ] [ [ reverse ] infer old-effect ] unit-test
 [ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test
-[ [[ 2 1 ]] ] [ [ tree-contains? ] infer old-effect ] unit-test
 [ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test
 [ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test
 

library/test/lists/lists.factor

@@ -45,12 +45,6 @@ USE: strings
 [ [ 1 2 3 ] ] [ 1 [ 1 2 3 ] unique ] unit-test
 [ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] unique ] unit-test
 
-[ f ] [ 3 [ ]             tree-contains?     ] unit-test
-[ f ] [ 3 [ 1 [ 3 ] 2 ]   tree-contains? not ] unit-test
-[ f ] [ 1 [ [ [ 1 ] ] 2 ] tree-contains? not ] unit-test
-[ f ] [ 2 [ 1 2 ]         tree-contains? not ] unit-test
-[ f ] [ 3 [[ 1 [[ 2 3 ]] ]] tree-contains? not ] unit-test
-
 [ [ ]         ] [ 0   count ] unit-test
 [ [ ]         ] [ -10 count ] unit-test
 [ [ 0 1 2 3 ] ] [ 4   count ] unit-test

library/tools/annotations.factor

@@ -9,7 +9,7 @@ IN: words
 USING: interpreter kernel lists stdio strings ;
 
 : annotate ( word quot -- ) #! Quotation: ( word def -- def )
-    over [ word-def swap call ] keep set-word-def ;
+    over [ word-def swap call ] keep (define-compound) ;
 
 : (watch) >r "==> " swap word-name cat2 \ print r> cons cons ;
 

library/tools/debugger.factor

@@ -26,8 +26,8 @@ parser prettyprint stdio streams strings unparser vectors words ;
 : type-check-error ( list -- )
     "Type check error" print
     uncons car dup "Object: " write .
-    "Object type: " write class prettyprint-word terpri
+    "Object type: " write class word. terpri
-    "Expected type: " write builtin-type prettyprint-word terpri ;
+    "Expected type: " write builtin-type word. terpri ;
 
 : range-error ( list -- )
     "Range check error" print
@@ -104,9 +104,9 @@ M: object error. ( error -- ) . ;
 : :get ( var -- value ) "error-namestack" get (get) ;
 
 : debug-help ( -- )
-    [ :s :r :n :c ] [ prettyprint-word " " write ] each
+    [ :s :r :n :c ] [ word. " " write ] each
     "show stacks at time of error." print
-    \ :get prettyprint-word
+    \ :get word.
     " ( var -- value ) inspects the error namestack." print ;
 
 : flush-error-handler ( error -- )

library/tools/walker.factor

@@ -4,6 +4,10 @@ IN: interpreter
 USING: errors kernel listener lists math namespaces prettyprint
 stdio strings vectors words ;
 
+! The single-stepper simulates Factor in Factor to allow
+! single-stepping through the execution of a quotation. It can
+! transfer the continuation to and from the primary interpreter.
+
 : &s
     #! Print stepper data stack.
     meta-d get {.} ;
@@ -46,14 +50,14 @@ stdio strings vectors words ;
     set-callstack call ;
 
 : walk-banner ( -- )
-    [ &s &r &n &c ] [ prettyprint-word " " write ] each
+    [ &s &r &n &c ] [ word. " " write ] each
     "show stepper stacks." print
-    \ &get prettyprint-word
+    \ &get word.
     " ( var -- value ) inspects the stepper namestack." print
-    \ step prettyprint-word " -- single step over" print
+    \ step word. " -- single step over" print
-    \ into prettyprint-word " -- single step into" print
+    \ into word. " -- single step into" print
-    \ continue prettyprint-word " -- continue execution" print
+    \ continue word. " -- continue execution" print
-    \ bye prettyprint-word " -- exit single-stepper" print
+    \ bye word. " -- exit single-stepper" print
     report ;
 
 : walk-listener walk-banner "walk" listener-prompt set listener ;

library/tools/word-tools.factor

@@ -5,39 +5,16 @@ USING: files generic inspector lists kernel namespaces
 prettyprint stdio streams strings unparser math hashtables
 parser ;
 
-GENERIC: word-uses? ( of in -- ? )
-M: word word-uses? 2drop f ;
-M: compound word-uses? ( of in -- ? )
-    #! Don't say that a word uses itself.
-    2dup = [ 2drop f  ] [ word-def tree-contains? ] ifte ;
-
-: generic-uses? ( of in -- ? )
-    "methods" word-prop hash>alist tree-contains? ;
-
-M: generic word-uses? ( of in -- ? ) generic-uses? ;
-M: 2generic word-uses? ( of in -- ? ) generic-uses? ;
-
-: usages-in-vocab ( of vocab -- usages )
-    #! Push a list of all usages of a word in a vocabulary.
-    words [
-        dup compound? [
-            dupd word-uses?
-        ] [
-            drop f ! Ignore words without a definition
-        ] ifte
-    ] subset nip ;
-
-: usages-in-vocab. ( of vocab -- )
-    #! List all usages of a word in a vocabulary.
-    tuck usages-in-vocab dup [
-        swap "IN: " write print [.]
-    ] [
-        2drop
-    ] ifte ;
-
 : usages. ( word -- )
-    #! List all usages of a word in all vocabularies.
+    #! List all usages of a word.
-    vocabs [ usages-in-vocab. ] each-with ;
+    usages word-sort [.] ;
+
+: usage ( word -- list )
+    crossref get hash dup [ hash-keys ] when ;
+
+: usage. ( word -- )
+    #! List all direct usages of a word.
+    usage word-sort [.] ;
 
 : vocab-apropos ( substring vocab -- list )
     #! Push a list of all words in a vocabulary whose names

library/vectors.factor

@@ -90,6 +90,9 @@ IN: vectors
     #! pushed onto the stack.
     >r vector>list r> each ; inline
 
+: vector-each-with ( obj vector quot -- )
+    swap [ with ] vector-each 2drop ; inline
+
 : list>vector ( list -- vector )
     dup length <vector> swap [ over vector-push ] each ;
 

library/vocabularies.factor

@@ -2,6 +2,8 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: words USING: hashtables kernel lists namespaces strings ;
 
+SYMBOL: vocabularies
+
 : word ( -- word ) global [ "last-word" get ] bind ;
 : set-word ( word -- ) global [ "last-word" set ] bind ;
 
@@ -27,6 +29,11 @@ IN: words USING: hashtables kernel lists namespaces strings ;
     vocabs [ words [ swap dup >r call r> ] each ] each drop ;
     inline
 
+: recrossref ( -- )
+    #! Update word cross referencing information.
+    [ f "usages" set-word-prop ] each-word
+    [ add-crossref ] each-word ;
+
 : (search) ( name vocab -- word )
     vocab dup [ hash ] [ 2drop f ] ifte ;
 

library/words.factor

@@ -2,24 +2,44 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: words
 USING: generic hashtables kernel kernel-internals lists math
-namespaces strings ;
+namespaces strings vectors ;
 
+! Utility
+GENERIC: (tree-each) ( quot obj -- ) inline
+M: object (tree-each) swap call ;
+M: cons (tree-each) [ car (tree-each) ] 2keep cdr (tree-each) ;
+M: vector (tree-each) [ swap call ] vector-each-with ;
+: tree-each swap (tree-each) ; inline
+: tree-each-with ( obj vector quot -- )
+    swap [ with ] tree-each 2drop ; inline
+
+! The basic word type. Words can be named and compared using
+! identity. They hold a property map.
 BUILTIN: word 17
     [ 1 hashcode f ]
     [ 4 "word-def" "set-word-def" ]
     [ 5 "word-props" "set-word-props" ] ;
 
+: word-prop ( word name -- value ) swap word-props hash ;
+: set-word-prop ( word value name -- ) rot word-props set-hash ;
+
+: word-name ( word -- str ) "name" word-prop ;
+: word-vocabulary ( word -- str ) "vocabulary" word-prop ;
+
+! Pointer to executable native code
 GENERIC: word-xt
 M: word word-xt ( w -- xt ) 2 integer-slot ;
 GENERIC: set-word-xt
 M: word set-word-xt ( xt w -- ) 2 set-integer-slot ;
 
+! Primitive number; some are magic, see below.
 GENERIC: word-primitive
 M: word word-primitive ( w -- n ) 3 integer-slot ;
 GENERIC: set-word-primitive
 M: word set-word-primitive ( n w -- )
     [ 3 set-integer-slot ] keep update-xt ;
 
+! For the profiler
 GENERIC: call-count
 M: word call-count ( w -- n ) 6 integer-slot ;
 GENERIC: set-call-count
@@ -30,32 +50,82 @@ M: word allot-count ( w -- n ) 7 integer-slot ;
 GENERIC: set-allot-count
 M: word set-allot-count ( n w -- ) 7 set-integer-slot ;
 
-SYMBOL: vocabularies
+! The cross-referencer keeps track of word dependencies, so that
+! words can be recompiled when redefined.
+SYMBOL: crossref
 
-: word-prop ( word name -- value ) swap word-props hash ;
+global [ <namespace> crossref set ] bind
-: set-word-prop ( word value name -- ) rot word-props set-hash ;
 
-GENERIC: definer ( word -- word )
+: (add-crossref)
-#! Return the parsing word that defined this word.
+    dup word? [
+        crossref get [ dupd nest set-hash ] bind
+    ] [
+        2drop
+    ] ifte ;
 
-PREDICATE: word compound  ( obj -- ? ) word-primitive 1 = ;
+: add-crossref ( word -- )
-M: compound definer drop \ : ;
+    #! Marks each word in the quotation as being a dependency
+    #! of the word.
+    dup word-def [ (add-crossref) ] tree-each-with ;
 
-PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;
+: (remove-crossref)
-M: primitive definer drop \ PRIMITIVE: ;
+    dup word? [
+        crossref get [ nest remove-hash ] bind
+    ] [
+        2drop
+    ] ifte ;
 
-PREDICATE: word symbol    ( obj -- ? ) word-primitive 2 = ;
+: remove-crossref ( word -- )
-M: symbol definer drop \ SYMBOL: ;
+    #! Marks each word in the quotation as not being a
+    #! dependency of the word.
+    dup word-def [ (remove-crossref) ] tree-each-with ;
 
-PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
+: usages ( word -- deps )
-M: undefined definer drop \ DEFER: ;
+    #! The transitive closure over the relation specified in
+    #! the crossref hash.
+    crossref get closure  ;
+
+GENERIC: (undefine) ( word -- )
+M: word (undefine) drop ;
+
+: undefine ( word -- )
+    usages [ (undefine) ] each ;
+
+! The word primitive combined with the word def specify what the
+! word does when invoked.
 
 : define ( word primitive parameter -- )
+    pick undefine
     pick set-word-def
     over set-word-primitive
     f "parsing" set-word-prop ;
 
-: (define-compound) ( word def -- ) 1 swap define ;
+GENERIC: definer ( word -- word )
+#! Return the parsing word that defined this word.
+
+! Undefined words raise an error when invoked.
+PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
+M: undefined definer drop \ DEFER: ;
+
+! Primitives are defined in the runtime.
+PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;
+M: primitive definer drop \ PRIMITIVE: ;
+
+! Symbols push themselves when executed.
+PREDICATE: word symbol    ( obj -- ? ) word-primitive 2 = ;
+M: symbol definer drop \ SYMBOL: ;
+
+: define-symbol ( word -- ) 2 over define ;
+
+: intern-symbol ( word -- )
+    dup undefined? [ define-symbol ] [ drop ] ifte ;
+
+! Compound words invoke a quotation when executed.
+PREDICATE: word compound  ( obj -- ? ) word-primitive 1 = ;
+M: compound definer drop \ : ;
+
+: (define-compound) ( word def -- )
+    >r dup dup remove-crossref r> 1 swap define add-crossref ;
 
 : define-compound ( word def -- )
     #! If the word is a generic word, clear the properties 
@@ -63,11 +133,3 @@ M: undefined definer drop \ DEFER: ;
     over f "methods" set-word-prop
     over f "combination" set-word-prop
     (define-compound) ;
-
-: define-symbol ( word -- ) 2 over define ;
-
-: intern-symbol ( word -- )
-    dup undefined? [ define-symbol ] [ drop ] ifte ;
-
-: word-name ( word -- str ) "name" word-prop ;
-: word-vocabulary ( word -- str ) "vocabulary" word-prop ;