automatic decompiling of definitions, cross reference database, cleaned up bootstrap
Slava Pestov
parent
9630a01168
commit
286813e992
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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:<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.
|
||||
[
|
||||
"alien-invoke cannot be interpreted. " ,
|
||||
"Either the compiler is disabled, " ,
|
||||
"or the ``" , rot , "'' library is missing. " ,
|
||||
] make-string throw ;
|
||||
rot <alien-error> throw ;
|
||||
|
||||
\ alien-invoke [ [ object object object object ] [ ] ]
|
||||
"infer-effect" set-word-prop
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -46,3 +46,5 @@ builtin [ 2drop t ] "class<" set-word-prop
|
|||
|
||||
: builtin-type ( n -- symbol )
|
||||
unit classes get hash ;
|
||||
|
||||
PREDICATE: word builtin metaclass builtin = ;
|
||||
|
|
|
|||
|
|
@ -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 = ;
|
||||
|
|
|
|||
|
|
@ -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 = ;
|
||||
|
|
|
|||
|
|
@ -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 = ;
|
||||
|
|
|
|||
|
|
@ -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 = ;
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 <prettyprint
|
||||
>r >r word. <prettyprint
|
||||
r> 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 )
|
||||
|
|
|
|||
|
|
@ -17,19 +17,14 @@ presentation streams unparser words ;
|
|||
#! popup.
|
||||
unparse vocab-actions <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. ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 [ <namespace> 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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue