From 286813e99283884b8b1fe1196c821413377a5acf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Mar 2005 01:12:14 +0000 Subject: [PATCH] automatic decompiling of definitions, cross reference database, cleaned up bootstrap --- TODO.FACTOR.txt | 3 +- .../{boot.factor => boot-stage1.factor} | 8 +- library/bootstrap/boot-stage2.factor | 120 +----------------- library/bootstrap/boot-stage3.factor | 116 +++++++++++++++++ ...{init-stage2.factor => boot-stage4.factor} | 2 + library/bootstrap/image.factor | 2 +- library/compiler/alien.factor | 35 +++-- library/compiler/compiler.factor | 2 + library/generic/builtin.factor | 2 + library/generic/complement.factor | 2 + library/generic/predicate.factor | 3 + library/generic/tuple.factor | 3 + library/generic/union.factor | 2 + library/lists.factor | 22 ---- library/math/complex.factor | 5 +- library/namespaces.factor | 29 +++++ library/syntax/prettyprint.factor | 18 +-- library/syntax/see.factor | 93 +++++++++----- library/test/generic.factor | 18 +++ library/test/inference.factor | 1 - library/test/lists/lists.factor | 6 - library/tools/annotations.factor | 2 +- library/tools/debugger.factor | 8 +- library/tools/walker.factor | 16 ++- library/tools/word-tools.factor | 41 ++---- library/vectors.factor | 3 + library/vocabularies.factor | 7 + library/words.factor | 108 ++++++++++++---- 28 files changed, 406 insertions(+), 271 deletions(-) rename library/bootstrap/{boot.factor => boot-stage1.factor} (96%) create mode 100644 library/bootstrap/boot-stage3.factor rename library/bootstrap/{init-stage2.factor => boot-stage4.factor} (98%) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 961edc70d3..e96ed10086 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot-stage1.factor similarity index 96% rename from library/bootstrap/boot.factor rename to library/bootstrap/boot-stage1.factor index 1aa5797a54..0f6c029214 100644 --- a/library/bootstrap/boot.factor +++ b/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" diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 8f0f17ccb2..e8b7a2d347 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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 -unparser words ; +USING: command-line command-line kernel lists parser stdio 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 [ - 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" run-resource diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor new file mode 100644 index 0000000000..757f707cf8 --- /dev/null +++ b/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 diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/boot-stage4.factor similarity index 98% rename from library/bootstrap/init-stage2.factor rename to library/bootstrap/boot-stage4.factor index b31fdcbf99..e787d3d898 100644 --- a/library/bootstrap/init-stage2.factor +++ b/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. diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 39c0fcc7be..27c4509ad9 100644 --- a/library/bootstrap/image.factor +++ b/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 ; diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 025afb2bb6..4c84d92cf0 100644 --- a/library/compiler/alien.factor +++ b/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 -kernel lists math namespaces parser words hashtables strings -unparser ; +USING: assembler compiler errors generic hashtables inference +interpreter kernel lists math namespaces parser stdio strings +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::name= -- define a library , to be ! loaded from the 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. - [ - "alien-invoke cannot be interpreted. " , - "Either the compiler is disabled, " , - "or the ``" , rot , "'' library is missing. " , - ] make-string throw ; + rot throw ; \ alien-invoke [ [ object object object object ] [ ] ] "infer-effect" set-word-prop diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index c7834b4732..32e98a5991 100644 --- a/library/compiler/compiler.factor +++ b/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 ; diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index 000f56db30..603bbdd084 100644 --- a/library/generic/builtin.factor +++ b/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 = ; diff --git a/library/generic/complement.factor b/library/generic/complement.factor index 57bce337b6..0fc7ec193c 100644 --- a/library/generic/complement.factor +++ b/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 = ; diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor index 9f28c1e790..50f973e2af 100644 --- a/library/generic/predicate.factor +++ b/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 = ; diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index f4f9591d2f..c0fd43afde 100644 --- a/library/generic/tuple.factor +++ b/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 = ; diff --git a/library/generic/union.factor b/library/generic/union.factor index 65f88af109..2fa9ba25a6 100644 --- a/library/generic/union.factor +++ b/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 = ; diff --git a/library/lists.factor b/library/lists.factor index e4d42d6d52..54e3e5083d 100644 --- a/library/lists.factor +++ b/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. diff --git a/library/math/complex.factor b/library/math/complex.factor index 539c506277..cd580106cd 100644 --- a/library/math/complex.factor +++ b/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. diff --git a/library/namespaces.factor b/library/namespaces.factor index f6c946632e..03f0fea4dc 100644 --- a/library/namespaces.factor +++ b/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 ) + [ + 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 ; diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 0d2a970ce5..16916900a5 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -51,14 +51,11 @@ M: object prettyprint* ( indent obj -- indent ) drop [ ] ] ifte ; -: prettyprint-word ( word -- ) - dup word-name swap word-attrs write-attr ; +: word. ( word -- ) dup word-name swap word-attrs write-attr ; +: word-bl word. " " write ; M: word prettyprint* ( indent word -- indent ) - dup parsing? [ - \ POSTPONE: prettyprint-word " " write - ] when - prettyprint-word ; + dup parsing? [ \ POSTPONE: word-bl ] when 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 prettyprint-word r >r word. prettyprint-elements - prettyprint> r> prettyprint-word + prettyprint> r> word. ] [ - >r >r prettyprint-word " " write - r> drop - r> prettyprint-word + >r >r word. " " write r> drop r> word. ] ifte ; M: list prettyprint* ( indent list -- indent ) diff --git a/library/syntax/see.factor b/library/syntax/see.factor index ce728884a0..428022cf1b 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -17,19 +17,14 @@ presentation streams unparser words ; #! popup. unparse vocab-actions "actions" swons unit ; -: prettyprint-vocab ( vocab -- ) - dup vocab-attrs write-attr ; +: vocab. ( vocab -- ) dup vocab-attrs write-attr ; : prettyprint-IN: ( word -- ) - \ IN: prettyprint-word " " write - word-vocabulary prettyprint-vocab " " write ; - -: prettyprint-; ( indent -- indent ) - \ ; prettyprint-word tab-size get - ; + \ IN: word-bl word-vocabulary vocab. terpri ; : 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 -- ) - dup (see) +: (see) ( word -- ) + 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 - prettyprint-plist prettyprint-newline ; + [ word-def prettyprint-elements \ ; word. ] keep + 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 - prettyprint-word " " write + r> r> word-bl + word-bl dup prettyprint-newline r> prettyprint-elements - prettyprint-; - terpri ; - -: definer. ( word -- ) definer prettyprint-word " " write ; - -: (see) ( word -- ) - dup prettyprint-IN: dup definer. dup prettyprint-word - stack-effect. terpri ; + prettyprint-; tab-size get - ; : see-generic ( word -- ) - dup (see) 0 swap - dup methods [ over >r uncons see-method r> ] each 2drop ; + 0 swap dup methods [ + 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. ; diff --git a/library/test/generic.factor b/library/test/generic.factor index 8be778fa4c..1a13aa5d23 100644 --- a/library/test/generic.factor +++ b/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" ] [ empty-method-test empty-method-test ] unit-test [ << another-one f >> ] [ 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 ; diff --git a/library/test/inference.factor b/library/test/inference.factor index e028f79d22..3b83355e60 100644 --- a/library/test/inference.factor +++ b/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 diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index ce5cc45e58..3d8c44494c 100644 --- a/library/test/lists/lists.factor +++ b/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 diff --git a/library/tools/annotations.factor b/library/tools/annotations.factor index 8602d8baad..28fb547a30 100644 --- a/library/tools/annotations.factor +++ b/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 ; diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index f93fa1f53e..0b30ff9752 100644 --- a/library/tools/debugger.factor +++ b/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 - "Expected type: " write builtin-type prettyprint-word terpri ; + "Object type: " write class 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 -- ) diff --git a/library/tools/walker.factor b/library/tools/walker.factor index 53a39d3828..2f70f3430a 100644 --- a/library/tools/walker.factor +++ b/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 - \ into prettyprint-word " -- single step into" print - \ continue prettyprint-word " -- continue execution" print - \ bye prettyprint-word " -- exit single-stepper" print + \ step word. " -- single step over" print + \ into word. " -- single step into" print + \ continue word. " -- continue execution" print + \ bye word. " -- exit single-stepper" print report ; : walk-listener walk-banner "walk" listener-prompt set listener ; diff --git a/library/tools/word-tools.factor b/library/tools/word-tools.factor index 513690686e..e480cd821f 100644 --- a/library/tools/word-tools.factor +++ b/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. - vocabs [ usages-in-vocab. ] each-with ; + #! List all usages of a word. + 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 diff --git a/library/vectors.factor b/library/vectors.factor index b4d42d9946..fbb7b5e396 100644 --- a/library/vectors.factor +++ b/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 swap [ over vector-push ] each ; diff --git a/library/vocabularies.factor b/library/vocabularies.factor index b729f77537..7e351a9c14 100644 --- a/library/vocabularies.factor +++ b/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 ; diff --git a/library/words.factor b/library/words.factor index 97ae3dc328..d869c9ac60 100644 --- a/library/words.factor +++ b/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 ; -: set-word-prop ( word value name -- ) rot word-props set-hash ; +global [ crossref set ] bind -GENERIC: definer ( word -- word ) -#! Return the parsing word that defined this word. +: (add-crossref) + dup word? [ + crossref get [ dupd nest set-hash ] bind + ] [ + 2drop + ] ifte ; -PREDICATE: word compound ( obj -- ? ) word-primitive 1 = ; -M: compound definer drop \ : ; +: add-crossref ( word -- ) + #! 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 > ; -M: primitive definer drop \ PRIMITIVE: ; +: (remove-crossref) + dup word? [ + crossref get [ nest remove-hash ] bind + ] [ + 2drop + ] ifte ; -PREDICATE: word symbol ( obj -- ? ) word-primitive 2 = ; -M: symbol definer drop \ SYMBOL: ; +: remove-crossref ( word -- ) + #! 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 = ; -M: undefined definer drop \ DEFER: ; +: usages ( word -- deps ) + #! 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 ;