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

Merge git://factorcode.org/git/factor

release
U-C4\Administrator 2007-10-04 19:33:41 -05:00
parent d3f637abf0 deb1406f83
commit cd3a354d91
10 changed files with 132 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/hashtables/hashtables-docs.factor
View File

@ -70,7 +70,7 @@ HELP: nth-pair
{ nth-pair set-nth-pair } related-words { nth-pair set-nth-pair } related-words
HELP: set-nth-pair HELP: set-nth-pair
{ $values { "value" "the second element of the pair" } { "key" "the first element of the pair" } { "n" "an index in the sequence" } { "seq" "a sequence" } } { $values { "value" "the second element of the pair" } { "key" "the first element of the pair" } { "seq" "a sequence" } { "n" "an index in the sequence" } }
{ $description "Stores a pair of values into the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." } { $description "Stores a pair of values into the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." } { $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." }
{ $side-effects "seq" } ; { $side-effects "seq" } ;

7
core/hashtables/hashtables.factor
View File

@ -59,8 +59,7 @@ IN: hashtables
swap 2 fixnum+fast 2dup slot -rot 1 fixnum+fast slot ; swap 2 fixnum+fast 2dup slot -rot 1 fixnum+fast slot ;
inline inline
: set-nth-pair ( value key n seq -- ) : set-nth-pair ( value key seq n -- )
swap
2 fixnum+fast [ set-slot ] 2keep 2 fixnum+fast [ set-slot ] 2keep
1 fixnum+fast set-slot ; inline 1 fixnum+fast set-slot ; inline
@ -73,7 +72,7 @@ IN: hashtables
: (set-hash) ( value key hash -- ) : (set-hash) ( value key hash -- )
2dup new-key@ 2dup new-key@
[ rot hash-count+ ] [ rot drop ] if [ rot hash-count+ ] [ rot drop ] if
swap set-nth-pair ; inline set-nth-pair ; inline
: find-pair-next >r 2 fixnum+fast r> ; inline : find-pair-next >r 2 fixnum+fast r> ; inline
@ -133,7 +132,7 @@ M: hashtable clear-assoc ( hash -- )
M: hashtable delete-at ( key hash -- ) M: hashtable delete-at ( key hash -- )
tuck key@ [ tuck key@ [
>r >r ((tombstone)) dup r> r> swap set-nth-pair >r >r ((tombstone)) dup r> r> set-nth-pair
hash-deleted+ hash-deleted+
] [ ] [
3drop 3drop

33
extra/tools/interpreter/debug/debug.factor
View File

@ -1,18 +1,31 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.interpreter namespaces kernel arrays continuations USING: tools.interpreter kernel arrays continuations threads
threads sequences ; sequences namespaces ;
IN: tools.interpreter.debug IN: tools.interpreter.debug
: run-interpreter ( -- ) : run-interpreter ( interpreter -- )
interpreter get [ step-into run-interpreter ] when ; dup interpreter-continuation [
dup step-into run-interpreter
] [
drop
] if ;
: init-interpreter ( quot -- ) : quot>cont ( quot -- cont )
[ [
"out" set swap [
[ f swap 2array restore "out" get continue ] callcc0 continue-with
] swap [ datastack "datastack" set stop ] ] curry callcc0 call stop
3append callcc0 ; ] curry callcc1 ;
: init-interpreter ( quot interpreter -- )
>r
[ datastack "datastack" set ] compose quot>cont
f swap 2array
r> restore ;
: test-interpreter ( quot -- ) : test-interpreter ( quot -- )
init-interpreter run-interpreter "datastack" get ; <interpreter>
[ init-interpreter ] keep
run-interpreter
"datastack" get ;

42
extra/tools/interpreter/interpreter-docs.factor
View File

@ -2,7 +2,13 @@ USING: help.markup help.syntax kernel generic
math hashtables quotations classes continuations ; math hashtables quotations classes continuations ;
IN: tools.interpreter IN: tools.interpreter
ARTICLE: "meta-interp-step" "Single-stepping words" ARTICLE: "meta-interpreter" "Meta-circular interpreter"
"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "."
$nl
"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section."
$nl
"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary."
$nl
"Breakpoints can be inserted in user code:" "Breakpoints can be inserted in user code:"
{ $subsection break } { $subsection break }
"Breakpoints invoke a hook:" "Breakpoints invoke a hook:"
@ -13,40 +19,16 @@ ARTICLE: "meta-interp-step" "Single-stepping words"
{ $subsection step-out } { $subsection step-out }
{ $subsection step-all } ; { $subsection step-all } ;
ARTICLE: "meta-interp-travel" "Backwards time travel"
"Backwards time travel is implemented by capturing the continuation after every step. Since this consumes additional memory, it must be explicitly enabled by storing an empty vector into a variable:"
{ $subsection history }
"If this variable holds a vector, the interpreter state is automatically saved after every step. It can be saved at other points manually:"
{ $subsection save-interpreter }
"Or restore the most recently saved state:"
{ $subsection step-back } ;
ARTICLE: "meta-interpreter" "Meta-circular interpreter"
"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "."
$nl
"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section."
$nl
"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary."
$nl
"The current interpreter state is stored in the " { $link interpreter } " variable."
{ $subsection "meta-interp-step" }
{ $subsection "meta-interp-travel" } ;
ABOUT: "meta-interpreter" ABOUT: "meta-interpreter"
HELP: interpreter HELP: interpreter
{ $var-description "Variable holding a " { $link continuation } " instance for the single-stepper." } ; { $class-description "An interpreter instance." } ;
HELP: break HELP: break
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ; { $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
HELP: history
{ $var-description "A sequence of continuations, captured at every stage of single-stepping. Used by " { $link step-back } " to implement backwards time travel." } ;
HELP: save-interpreter
{ $description "Snapshots the single stepper state and saves it in " { $link history } "." } ;
HELP: step HELP: step
{ $values { "interpreter" interpreter } }
{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:" { $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
{ $list { $list
{ "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" } { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
@ -56,6 +38,7 @@ HELP: step
} ; } ;
HELP: step-into HELP: step-into
{ $values { "interpreter" interpreter } }
{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:" { $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
{ $list { $list
{ "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" } { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
@ -66,10 +49,9 @@ HELP: step-into
} ; } ;
HELP: step-out HELP: step-out
{ $values { "interpreter" interpreter } }
{ $description "Evaluates the remainder of the current quotation in the single stepper." } ; { $description "Evaluates the remainder of the current quotation in the single stepper." } ;
HELP: step-back
{ $description "Steps back to the most recently saved snapshot of the single stepper continuation in " { $link history } "." } ;
HELP: step-all HELP: step-all
{ $values { "interpreter" interpreter } }
{ $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ; { $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ;

54
extra/tools/interpreter/interpreter-tests.factor
View File

@ -105,54 +105,6 @@ IN: temporary
[ [ { 1 2 3 } . ] string-out ] test-interpreter [ [ { 1 2 3 } . ] string-out ] test-interpreter
] unit-test ] unit-test
: meta-catch interpreter get continuation-catch ; [ { } ] [
[ "a" "b" set "c" "d" set [ ] test-interpreter ] with-scope
! Step back test ] unit-test
! [
! init-interpreter
! V{ } clone meta-history set
!
! V{ f } clone
! V{ } clone
! V{ [ 1 2 3 ] 0 3 } clone
! V{ } clone
! V{ } clone
! f <continuation>
! meta-catch push
!
! [ ] [ [ 2 2 + throw ] (meta-call) ] unit-test
!
! [ ] [ step ] unit-test
!
! [ ] [ step ] unit-test
!
! [ { 2 2 } ] [ meta-d ] unit-test
!
! [ ] [ step ] unit-test
!
! [ { 4 } ] [ meta-d ] unit-test
! [ 3 ] [ callframe-scan get ] unit-test
!
! [ ] [ step-back ] unit-test
! [ 2 ] [ callframe-scan get ] unit-test
!
! [ { 2 2 } ] [ meta-d ] unit-test
!
! [ ] [ step ] unit-test
!
! [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
!
! [ ] [ step ] unit-test
!
! [ [ 1 2 3 ] ] [ callframe get ] unit-test
! [ ] [ step-back ] unit-test
!
! [ { 4 } ] [ meta-d ] unit-test
!
! [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
!
! [ ] [ step ] unit-test
!
! [ [ 1 2 3 ] ] [ callframe get ] unit-test
!
! ] with-scope

93
extra/tools/interpreter/interpreter.factor
View File

@ -6,7 +6,9 @@ kernel.private math namespaces namespaces.private prettyprint
quotations sequences splitting strings threads vectors words ; quotations sequences splitting strings threads vectors words ;
IN: tools.interpreter IN: tools.interpreter
SYMBOL: interpreter TUPLE: interpreter continuation ;
: <interpreter> interpreter construct-empty ;
SYMBOL: break-hook SYMBOL: break-hook
@ -15,22 +17,25 @@ SYMBOL: break-hook
over set-continuation-call over set-continuation-call
walker-hook [ continue-with ] [ break-hook get call ] if* ; walker-hook [ continue-with ] [ break-hook get call ] if* ;
: with-interpreter-datastack ( quot -- ) GENERIC# restore 1 ( obj interpreter -- )
interpreter get continuation-data
swap with-datastack
interpreter get set-continuation-data ; inline
GENERIC: restore ( obj -- )
M: continuation restore
clone interpreter set ;
M: pair restore
first2 clone interpreter set
[ nip f ] curry with-interpreter-datastack ;
M: f restore M: f restore
drop interpreter off ; set-interpreter-continuation ;
M: continuation restore
>r clone r> set-interpreter-continuation ;
: with-interpreter-datastack ( quot interpreter -- )
interpreter-continuation [
continuation-data
swap with-datastack
] keep set-continuation-data ; inline
M: pair restore
>r first2 r> [ restore ] keep
>r [ nip f ] curry r> with-interpreter-datastack ;
<PRIVATE
: (step-into-call) \ break add* call ; : (step-into-call) \ break add* call ;
@ -71,19 +76,6 @@ M: f restore
"step-into" set-word-prop "step-into" set-word-prop
] each ] each
! Time travel
SYMBOL: history
: save-interpreter ( -- )
history get [ interpreter get clone swap push ] when* ;
: restore-interpreter ( interp -- )
clone interpreter set ;
: step-back ( -- )
history get dup empty?
[ drop ] [ pop restore-interpreter ] if ;
: (continue) ( continuation -- ) : (continue) ( continuation -- )
>continuation< >continuation<
set-catchstack set-catchstack
@ -93,26 +85,34 @@ SYMBOL: history
set-callstack ; set-callstack ;
! Stepping ! Stepping
: step-all ( -- ) : change-innermost-frame ( quot interpreter -- )
[ interpreter get (continue) ] in-thread ; interpreter-continuation [
continuation-call clone
: change-innermost-frame ( quot -- )
interpreter get continuation-call clone
[ [
dup innermost-frame-scan 1+ dup innermost-frame-scan 1+
swap innermost-frame-quot swap innermost-frame-quot
rot call rot call
] keep ] keep
[ set-innermost-frame-quot ] keep [ set-innermost-frame-quot ] keep
interpreter get set-continuation-call ; inline ] keep set-continuation-call ; inline
: (step) ( quot -- ) : (step) ( interpreter quot -- )
save-interpreter swap
change-innermost-frame [ change-innermost-frame ] keep
[ set-walker-hook interpreter get (continue) ] callcc1 [
restore ; set-walker-hook
interpreter-continuation (continue)
] callcc1 swap restore ;
: step ( n -- ) GENERIC: (step-into) ( obj -- )
M: word (step-into) (step-into-execute) ;
M: wrapper (step-into) wrapped break ;
M: object (step-into) break ;
PRIVATE>
: step ( interpreter -- )
[ [
2dup nth \ break = [ 2dup nth \ break = [
nip nip
@ -121,18 +121,15 @@ SYMBOL: history
] if ] if
] (step) ; ] (step) ;
: step-out ( -- ) : step-out ( interpreter -- )
[ nip \ break add ] (step) ; [ nip \ break add ] (step) ;
GENERIC: (step-into) ( obj -- ) : step-into ( interpreter -- )
M: word (step-into) (step-into-execute) ;
M: wrapper (step-into) wrapped break ;
M: object (step-into) break ;
: step-into ( -- )
[ [
cut [ cut [
swap % unclip literalize , \ (step-into) , % swap % unclip literalize , \ (step-into) , %
] [ ] make ] [ ] make
] (step) ; ] (step) ;
: step-all ( interpreter -- )
interpreter-continuation [ (continue) ] curry in-thread ;

6
extra/ui/tools/tools-docs.factor
View File

@ -58,9 +58,9 @@ ARTICLE: "ui-walker" "UI walker"
"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "." "The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."
$nl $nl
"The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code." "The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."
{ $command-map walker-gadget "toolbar" } { $command-map walker "toolbar" }
{ $command-map walker-gadget "other" } { $command-map walker "other" }
"Walkers are instances of " { $link walker-gadget } "." ; "Walkers are instances of " { $link walker } "." ;
ARTICLE: "ui-profiler" "UI profiler" ARTICLE: "ui-profiler" "UI profiler"
"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results." "The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."

4
extra/ui/tools/tools.factor
View File

@ -17,7 +17,7 @@ IN: ui.tools
<stack-display> <stack-display>
<browser-gadget> <browser-gadget>
<inspector-gadget> <inspector-gadget>
<walker-gadget> <walker>
<profiler-gadget> <profiler-gadget>
} ; } ;
@ -65,7 +65,7 @@ M: workspace model-changed
: com-inspector inspector-gadget select-tool ; : com-inspector inspector-gadget select-tool ;
: com-walker walker-gadget select-tool ; : com-walker walker select-tool ;
: com-profiler profiler-gadget select-tool ; : com-profiler profiler-gadget select-tool ;

4
extra/ui/tools/walker/walker-tests.factor
View File

@ -4,7 +4,7 @@ listener tools.test ui ui.gadgets ui.gadgets.worlds
ui.gadgets.packs vectors ui.tools ; ui.gadgets.packs vectors ui.tools ;
IN: temporary IN: temporary
[ ] [ <walker-gadget> "walker" set ] unit-test [ ] [ <walker "walker" set ] unit-test
! Make sure the toolbar buttons don't throw if we're ! Make sure the toolbar buttons don't throw if we're
! not actually walking. ! not actually walking.
@ -37,7 +37,7 @@ IN: temporary
[ t ] [ "ok" get ] unit-test [ t ] [ "ok" get ] unit-test
[ ] [ <walker-gadget> "w" set ] unit-test [ ] [ <walker> "w" set ] unit-test
continuation "c" set continuation "c" set
[ ] [ "c" get "w" get call-tool* ] unit-test [ ] [ "c" get "w" get call-tool* ] unit-test

59
extra/ui/tools/walker/walker.factor
View File

@ -8,61 +8,70 @@ ui.gestures ui.gadgets.buttons ui.gadgets.panes
prettyprint.config prettyprint.backend ; prettyprint.config prettyprint.backend ;
IN: ui.tools.walker IN: ui.tools.walker
TUPLE: walker-gadget model ns ; TUPLE: walker model interpreter history ;
: update-stacks ( walker -- ) : update-stacks ( walker -- )
interpreter get swap walker-gadget-model set-model ; dup walker-interpreter interpreter-continuation
swap walker-model set-model ;
: with-walker ( gadget quot -- ) : with-walker ( walker quot -- )
swap dup walker-gadget-ns [ slip update-stacks ] bind ; over >r >r walker-interpreter r> call r>
inline update-stacks ; inline
: walker-active? ( walker -- ? ) : walker-active? ( walker -- ? )
interpreter swap walker-gadget-ns key? ; walker-interpreter interpreter-continuation >boolean ;
: walker-command ( gadget quot -- ) : walker-command ( gadget quot -- )
over walker-active? [ with-walker ] [ 2drop ] if ; inline over walker-active? [ with-walker ] [ 2drop ] if ; inline
: com-step [ step ] walker-command ; : save-interpreter ( walker -- )
: com-into [ step-into ] walker-command ; dup walker-interpreter interpreter-continuation clone
: com-out [ step-out ] walker-command ; swap walker-history push ;
: com-back [ step-back ] walker-command ;
: init-walker-models ( walker -- ) : com-step ( walker -- )
f <model> over set-walker-gadget-model dup save-interpreter [ step ] walker-command ;
H{ } clone swap set-walker-gadget-ns ;
: com-into ( walker -- )
dup save-interpreter [ step-into ] walker-command ;
: com-out ( walker -- )
dup save-interpreter [ step-out ] walker-command ;
: com-back ( walker -- )
dup walker-history
dup empty? [ drop ] [ pop swap call-tool* ] if ;
: reset-walker ( walker -- ) : reset-walker ( walker -- )
dup walker-gadget-ns clear-assoc <interpreter> over set-walker-interpreter
[ V{ } clone history set ] with-walker ; V{ } clone over set-walker-history
update-stacks ;
: <walker-gadget> ( -- gadget ) : <walker> ( -- gadget )
walker-gadget construct-empty f <model> f f walker construct-boa [
dup init-walker-models [
toolbar, toolbar,
g walker-gadget-model <traceback-gadget> 1 track, g walker-model <traceback-gadget> 1 track,
] { 0 1 } build-track ] { 0 1 } build-track
dup reset-walker ; dup reset-walker ;
M: walker-gadget call-tool* ( continuation walker -- ) M: walker call-tool* ( continuation walker -- )
[ restore ] with-walker ; [ restore ] with-walker ;
: com-inspect ( walker -- ) : com-inspect ( walker -- )
dup walker-active? [ dup walker-active? [
interpreter swap walker-gadget-ns at walker-interpreter interpreter-continuation
[ inspect ] curry call-listener [ inspect ] curry call-listener
] [ ] [
drop drop
] if ; ] if ;
: com-continue ( walker -- ) : com-continue ( walker -- )
dup [ step-all ] walker-command reset-walker ; dup walker-interpreter step-all reset-walker ;
: walker-help "ui-walker" help-window ; : walker-help "ui-walker" help-window ;
\ walker-help H{ { +nullary+ t } } define-command \ walker-help H{ { +nullary+ t } } define-command
walker-gadget "toolbar" f { walker "toolbar" f {
{ T{ key-down f { A+ } "s" } com-step } { T{ key-down f { A+ } "s" } com-step }
{ T{ key-down f { A+ } "i" } com-into } { T{ key-down f { A+ } "i" } com-into }
{ T{ key-down f { A+ } "o" } com-out } { T{ key-down f { A+ } "o" } com-out }
@ -71,8 +80,8 @@ walker-gadget "toolbar" f {
{ T{ key-down f f "F1" } walker-help } { T{ key-down f f "F1" } walker-help }
} define-command-map } define-command-map
walker-gadget "other" f { walker "other" f {
{ T{ key-down f { A+ } "n" } com-inspect } { T{ key-down f { A+ } "n" } com-inspect }
} define-command-map } define-command-map
[ walker-gadget call-tool stop ] break-hook set-global [ walker call-tool stop ] break-hook set-global