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

New walker

db4
Slava Pestov 2008-02-20 23:13:31 -06:00
parent 27656fe0e3
commit b60dac99b9
28 changed files with 268 additions and 273 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
core/continuations/continuations-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private
continuations.private parser vectors arrays namespaces
threads assocs words quotations ;
assocs words quotations ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
@ -44,11 +44,7 @@ ARTICLE: "continuations.private" "Continuation implementation details"
{ $subsection namestack }
{ $subsection set-namestack }
{ $subsection catchstack }
{ $subsection set-catchstack }
"The continuations implementation has hooks for single-steppers:"
{ $subsection walker-hook }
{ $subsection set-walker-hook }
{ $subsection (continue-with) } ;
{ $subsection set-catchstack } ;
ARTICLE: "continuations" "Continuations"
"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
@ -110,10 +106,6 @@ HELP: callcc1
{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
HELP: (continue-with)
{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ;
HELP: continue
{ $values { "continuation" continuation } }
{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;

2
core/hashtables/hashtables.factor
View File

@ -16,7 +16,6 @@ IN: hashtables
2 fixnum+fast over wrap ; inline
: (key@) ( key keys i -- array n ? )
#! cond form expanded by hand for better interpreter speed
3dup swap array-nth dup ((tombstone)) eq? [
2drop probe (key@)
] [
@ -40,7 +39,6 @@ IN: hashtables
swap <hash-array> over set-hash-array init-hash ;
: (new-key@) ( key keys i -- keys n empty? )
#! cond form expanded by hand for better interpreter speed
3dup swap array-nth dup ((empty)) eq? [
2drop rot drop t
] [

55
core/prettyprint/prettyprint.factor
View File

@ -94,43 +94,34 @@ SYMBOL: ->
{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
"word-style" set-word-prop
! This code is ugly and could probably be simplified
! : remove-step-into
! building get dup empty? [
! drop \ (step-into) ,
! ] [
! pop dup wrapper? [
! wrapped dup \ break eq?
! [ drop ] [ , ] if
! ] [
! ,
! ] if
! ] if ;
!
! : (remove-breakpoints) ( quot -- newquot )
! [
! [
! dup {
! { break [ drop ] }
! { (step-into) [ remove-step-into ] }
! [ , ]
! } case
! ] each
! ] [ ] make ;
!
! : remove-breakpoints ( quot pos -- quot' )
! over quotation? [
! 1+ cut [ (remove-breakpoints) ] 2apply
! [ -> ] swap 3append
! ] [
! drop
! ] if ;
: remove-step-into ( word -- )
building get dup empty? [ drop ] [ nip pop wrapped ] if , ;
: (remove-breakpoints) ( quot -- newquot )
[
[
{
{ [ dup word? not ] [ , ] }
{ [ dup "break?" word-prop ] [ drop ] }
{ [ dup "step-into?" word-prop ] [ remove-step-into ] }
{ [ t ] [ , ] }
} cond
] each
] [ ] make ;
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
1+ cut [ (remove-breakpoints) ] 2apply
[ -> ] swap 3append
] [
drop
] if ;
PRIVATE>
: callstack. ( callstack -- )
callstack>array 2 <groups> [
! remove-breakpoints
remove-breakpoints
2 nesting-limit [ . ] with-variable
] assoc-each ;

1
core/threads/threads-docs.factor
View File

@ -62,7 +62,6 @@ HELP: thread
{ { $link thread-name } " - the name passed to " { $link spawn } "." }
{ { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." }
{ { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
{ { $link thread-registered? } " - a boolean indicating whether the thread is eligible to run or not. Spawning a thread with " { $link (spawn) } " sets this flag and " { $link stop } " clears it." }
}
} ;

70
core/threads/threads.factor
View File

@ -10,8 +10,8 @@ boxes ;
SYMBOL: initial-thread
TUPLE: thread
name quot error-handler
id registered?
name quot error-handler exit-handler
id
continuation state
mailbox variables ;
@ -37,37 +37,37 @@ threads global [ H{ } assoc-like ] change-at
: thread ( id -- thread ) threads at ;
<PRIVATE
: thread-registered? ( thread -- ? )
thread-id threads key? ;
: check-unregistered
dup thread-registered?
[ "Registering a thread twice" throw ] when ;
[ "Thread already stopped" throw ] when ;
: check-registered
dup thread-registered?
[ "Unregistering a thread twice" throw ] unless ;
[ "Thread is not running" throw ] unless ;
<PRIVATE
: register-thread ( thread -- )
check-unregistered
t over set-thread-registered?
dup thread-id threads set-at ;
check-unregistered dup thread-id threads set-at ;
: unregister-thread ( thread -- )
check-registered
f over set-thread-registered?
thread-id threads delete-at ;
check-registered thread-id threads delete-at ;
: set-self ( thread -- ) 40 setenv ; inline
PRIVATE>
: <thread> ( quot name error-handler -- thread )
\ thread counter <box> {
\ thread counter <box> [ ] {
set-thread-quot
set-thread-name
set-thread-error-handler
set-thread-id
set-thread-continuation
set-thread-exit-handler
} \ thread construct ;
: run-queue 42 getenv ;
@ -95,16 +95,12 @@ PRIVATE>
drop ;
: next ( -- )
walker-hook [
continue
] [
wake-up
run-queue pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with
] if* ;
wake-up
run-queue pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with ;
PRIVATE>
@ -116,7 +112,8 @@ PRIVATE>
} cond ;
: stop ( -- )
self unregister-thread next ;
self dup thread-exit-handler call
unregister-thread next ;
: suspend ( quot state -- obj )
[
@ -145,20 +142,20 @@ PRIVATE>
] 1 (throw)
] "spawn" suspend 2drop ;
: default-thread-error-handler ( error thread -- )
global [
"Error in thread " write
dup thread-id pprint
" (" write
dup thread-name pprint ")" print
"spawned to call " write
thread-quot short.
nl
print-error flush
] bind ;
: spawn ( quot name -- thread )
[
global [
"Error in thread " write
dup thread-id pprint
" (" write
dup thread-name pprint ")" print
"spawned to call " write
thread-quot short.
nl
print-error flush
] bind
] <thread>
[ (spawn) ] keep ;
[ default-thread-error-handler ] <thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
>r [ [ ] [ ] while ] curry r> spawn ;
@ -177,7 +174,6 @@ PRIVATE>
initial-thread global
[ drop f "Initial" [ die ] <thread> ] cache
<box> over set-thread-continuation
f over set-thread-registered?
dup register-thread
set-self ;

2
extra/bootstrap/ui/tools/tools.factor Normal file → Executable file
View File

@ -7,4 +7,6 @@ USING: kernel vocabs vocabs.loader sequences system ;
"ui.cocoa" vocab [
"ui.cocoa.tools" require
] when
"ui.tools.walker" require
] when

2
extra/concurrency/exchangers/exchangers.factor
View File

@ -17,5 +17,5 @@ TUPLE: exchanger thread object ;
>r exchanger-thread box> resume-with r>
] [
[ exchanger-object >box ] keep
[ exchanger-thread >box ] curry "Exchange wait" suspend
[ exchanger-thread >box ] curry "exchange" suspend
] if ;

4
extra/concurrency/messaging/messaging.factor
View File

@ -84,7 +84,7 @@ GENERIC: send ( message process -- )
] ?if ;
M: thread send ( message thread -- )
mailbox-of mailbox-put ;
check-registered mailbox-of mailbox-put ;
: ?linked dup linked? [ rethrow ] when ;
@ -97,7 +97,7 @@ M: thread send ( message thread -- )
mailbox mailbox-get? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
pick thread-death? [ 3drop ] [ >r <linked> r> send ] if ;
>r <linked> r> send ;
: spawn-linked-to ( quot name mailbox -- thread )
[ >r <linked> r> mailbox-put ] curry <thread>

4
extra/help/handbook/handbook.factor
View File

@ -66,8 +66,7 @@ ARTICLE: "evaluator" "Evaluation semantics"
{ "All other types of objects are pushed on the data stack." }
}
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage."
$nl
"There are various ways of implementing these evaluation semantics. See " { $link "compiler" } " and " { $link "meta-interpreter" } "." ;
{ $see-also "compiler" } ;
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
@ -196,7 +195,6 @@ ARTICLE: "tools" "Developer tools"
"Debugging tools:"
{ $subsection "tools.annotations" }
{ $subsection "tools.test" }
{ $subsection "meta-interpreter" }
"Performance tools:"
{ $subsection "tools.memory" }
{ $subsection "profiling" }

2
extra/tar/tar.factor
View File

@ -1,7 +1,7 @@
USING: combinators io io.files io.streams.duplex
io.streams.string kernel math math.parser continuations
namespaces pack prettyprint sequences strings system
hexdump tools.interpreter ;
hexdump ;
IN: tar
: zero-checksum 256 ;

6
extra/tools/annotations/annotations.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
prettyprint continuations effects definitions compiler.units
namespaces assocs ;
namespaces assocs tools.walker ;
IN: tools.annotations
: reset ( word -- )
@ -61,7 +61,7 @@ IN: tools.annotations
dupd [ (watch-vars) ] 2curry annotate ;
: breakpoint ( word -- )
[ \ break add* ] annotate ;
[ add-breakpoint ] annotate ;
: breakpoint-if ( word quot -- )
[ [ [ break ] when ] rot 3append ] curry annotate ;

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

@ -7,13 +7,13 @@ io io.styles sequences assocs namespaces sorting boxes ;
: thread. ( thread -- )
dup thread-id pprint-cell
dup thread-name pprint-cell
thread-state [ "Waiting for " swap append ] [ "Running" ] if*
thread-state "running" or
[ write ] with-cell ;
: threads. ( -- )
standard-table-style [
[
{ "ID" "Name" "State" }
{ "ID" "Name" "Waiting on" }
[ [ write ] with-cell ] each
] with-row

5
extra/tools/walker/debug/debug.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises models tools.walker kernel
sequences concurrency.messaging locals ;
sequences concurrency.messaging locals continuations
threads ;
IN: tools.walker.debug
:: test-walker | quot |
@ -9,7 +10,7 @@ IN: tools.walker.debug
s [ f <model> ]
c [ f <model> ] |
[ s c start-walker-thread p fulfill break ]
quot compose
quot compose "Walker test" spawn drop
step-into-all
p ?promise

2
extra/tools/walker/summary.txt
View File

@ -1 +1 @@
Meta-circular interpreter and single-stepper support
Single-stepper for walking through code

168
extra/tools/walker/walker.factor
View File

@ -6,29 +6,56 @@ concurrency.messaging quotations kernel.private words
sequences.private assocs models ;
IN: tools.walker
SYMBOL: walker-hook
SYMBOL: new-walker-hook
SYMBOL: show-walker-hook
! Thread local
SYMBOL: walker-thread
SYMBOL: walking-thread
: get-walker-thread ( -- thread )
walker-thread tget [
walker-hook get [ "No walker hook" throw ] or call
dup show-walker-hook get call
] [
new-walker-hook get call
walker-thread tget
] unless* ;
] if* ;
: break ( -- )
callstack [
over set-continuation-call
continuation callstack over set-continuation-call
get-walker-thread send-synchronous {
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ "Single stepping abandoned" throw ] }
} cond
] curry callcc0 ;
get-walker-thread send-synchronous {
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ "Single stepping abandoned" throw ] }
} cond ;
: walk ( quot -- ) \ break add* call ;
\ break t "break?" set-word-prop
: add-breakpoint ( quot -- quot' )
dup [ break ] head? [ \ break add* ] unless ;
: walk ( quot -- ) add-breakpoint call ;
: (step-into-if) ? walk ;
: (step-into-dispatch) nth walk ;
: (step-into-execute) ( word -- )
dup "step-into" word-prop [
call
] [
dup primitive? [
execute break
] [
word-def walk
] if
] ?if ;
\ (step-into-execute) t "step-into?" set-word-prop
: (step-into-continuation)
continuation callstack over set-continuation-call break ;
! Messages sent to walker thread
SYMBOL: step
@ -49,10 +76,12 @@ SYMBOL: walker-history
SYMBOL: +running+
SYMBOL: +suspended+
SYMBOL: +stopped+
SYMBOL: +detached+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
>r clone r>
over continuation-call clone
[
dup innermost-frame-scan 1+
@ -74,32 +103,6 @@ SYMBOL: +stopped+
: step-out-msg ( continuation -- continuation' )
[ nip \ break add ] change-frame ;
GENERIC: (step-into) ( obj -- )
M: wrapper (step-into) wrapped break ;
M: object (step-into) break ;
M: callable (step-into) \ break add* break ;
: (step-into-if) ? walk ;
: (step-into-dispatch) nth walk ;
: (step-into-execute) ( word -- )
dup "step-into" word-prop [
call
] [
dup primitive? [
execute break
] [
word-def walk
] if
] ?if ;
: (step-into-continuation)
continuation callstack over set-continuation-call break ;
M: word (step-into) (step-into-execute) ;
{
{ call [ walk ] }
{ (throw) [ drop walk ] }
@ -124,7 +127,12 @@ M: word (step-into) (step-into-execute) ;
: step-into-msg ( continuation -- continuation' )
[
swap cut [
swap % unclip literalize , \ (step-into) , %
swap % unclip {
{ [ dup \ break eq? ] [ , ] }
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
{ [ t ] [ , \ break , ] }
} cond %
] [ ] make
] change-frame ;
@ -134,44 +142,55 @@ M: word (step-into) (step-into-execute) ;
: set-status ( symbol -- )
walker-status tget set-model ;
: detach-msg ( -- f )
+stopped+ set-status ;
: unassociate-thread ( -- )
walker-thread walking-thread tget thread-variables delete-at
[ ] walking-thread tget set-thread-exit-handler ;
: keep-running ( continuation -- continuation )
+running+ set-status
dup continuation? [ dup walker-history tget push ] when ;
: detach-msg ( -- )
+detached+ set-status
unassociate-thread ;
: keep-running ( -- )
+running+ set-status ;
: walker-stopped ( -- )
+stopped+ set-status
[
{
{ detach [ detach-msg ] }
[ drop f ]
} case
] handle-synchronous
walker-stopped ;
: step-into-all-loop ( -- )
+running+ set-status
[ status +stopped+ eq? not ] [
[ status +stopped+ eq? ] [
[
{
{ detach [ detach-msg ] }
{ step [ f ] }
{ step-out [ f ] }
{ step-into [ f ] }
{ step-all [ f ] }
{ step-into-all [ f ] }
{ step-back [ f ] }
{ f [ walker-stopped ] }
[ step-into-msg ]
} case
[ drop ]
} case f
] handle-synchronous
] [ ] while ;
: step-into-all-loop ( -- )
+running+ set-status
[ status +running+ eq? ] [
[
{
{ detach [ detach-msg ] }
{ step [ ] }
{ step-out [ ] }
{ step-into [ ] }
{ step-all [ ] }
{ step-into-all [ ] }
{ step-back [ ] }
{ f [ walker-stopped ] }
[ step-into-msg ]
} case f
] handle-synchronous
] [ ] while ;
: step-back-msg ( continuation -- continuation' )
walker-history tget dup pop*
empty? [ drop walker-history tget pop ] unless ;
: walker-suspended ( continuation -- continuation' )
+suspended+ set-status
[ status +suspended+ eq? ] [
dup walker-history tget push
dup walker-continuation tget set-model
[
{
! These are sent by the walker tool. We reply
@ -189,25 +208,26 @@ M: word (step-into) (step-into-execute) ;
! Pass quotation to debugged thread
{ call-in [ nip keep-running ] }
! Pass previous continuation to debugged thread
{ step-back [ drop walker-history tget pop f ] }
} case
{ step-back [ step-back-msg ] }
} case f
] handle-synchronous
] [ ] while ;
: walker-loop ( -- )
+running+ set-status
[ status +stopped+ eq? not ] [
[ status +detached+ eq? not ] [
[
{
{ detach [ detach-msg ] }
{ detach [ detach-msg f ] }
! ignore these commands while the thread is
! running
{ step [ f ] }
{ step-out [ f ] }
{ step-into [ f ] }
{ step-all [ f ] }
{ step-into-all [ step-into-all-loop ] }
{ step-into-all [ step-into-all-loop f ] }
{ step-back [ f ] }
{ abandon [ f ] }
{ f [ walker-stopped f ] }
! thread hit a breakpoint and sent us the
! continuation, so we modify it and send it
@ -218,15 +238,17 @@ M: word (step-into) (step-into-execute) ;
] [ ] while ;
: associate-thread ( walker -- )
dup walker-thread tset
[ f swap send ] curry self set-thread-exit-handler ;
walker-thread tset
[ f walker-thread tget send-synchronous drop ]
self set-thread-exit-handler ;
: start-walker-thread ( status continuation -- thread' )
[
self [
walking-thread tset
walker-continuation tset
walker-status tset
V{ } clone walker-history tset
walker-loop
] 2curry
] 3curry
"Walker on " self thread-name append spawn
[ associate-thread ] keep ;

2
extra/ui/backend/backend.factor
View File

@ -15,7 +15,7 @@ HOOK: (open-window) ui-backend ( world -- )
HOOK: (close-window) ui-backend ( handle -- )
HOOK: raise-window ui-backend ( world -- )
HOOK: raise-window* ui-backend ( world -- )
HOOK: select-gl-context ui-backend ( handle -- )

2
extra/ui/cocoa/cocoa.factor
View File

@ -85,7 +85,7 @@ M: cocoa-ui-backend close-window ( gadget -- )
world-handle second f -> performClose:
] when* ;
M: cocoa-ui-backend raise-window ( world -- )
M: cocoa-ui-backend raise-window* ( world -- )
world-handle [
second dup f -> orderFront: -> makeKeyWindow
NSApp 1 -> activateIgnoringOtherApps:

5
extra/ui/gadgets/worlds/worlds-docs.factor
View File

@ -13,11 +13,6 @@ HELP: set-title
{ $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
HELP: raise-window
{ $values { "world" world } }
{ $description "Makes the native window containing the given world the front-most window." }
{ $notes "To raise the window containing a specific gadget, use " { $link find-world } " to find the world containing the gadget first." } ;
HELP: select-gl-context
{ $values { "handle" "a backend-specific handle" } }
{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;

2
extra/ui/tools/operations/operations.factor
View File

@ -5,7 +5,7 @@ ui.tools.interactor ui.tools.listener ui.tools.profiler
ui.tools.search ui.tools.traceback ui.tools.workspace generic
help.topics inference inspector io.files io.styles kernel
namespaces parser prettyprint quotations tools.annotations
editors tools.profiler tools.test tools.time tools.interpreter
editors tools.profiler tools.test tools.time tools.walker
ui.commands ui.gadgets.editors ui.gestures ui.operations
ui.tools.deploy vocabs vocabs.loader words sequences
tools.browser classes compiler.units ;

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

@ -1,5 +1,5 @@
USING: editors help.markup help.syntax inspector io listener
parser prettyprint tools.profiler tools.interpreter ui.commands
parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.slots ui.operations ui.tools.browser
ui.tools.interactor ui.tools.listener ui.tools.operations
@ -54,14 +54,6 @@ ARTICLE: "ui-browser" "UI browser"
{ $command-map browser-gadget "toolbar" }
"Browsers are instances of " { $link browser-gadget } "." ;
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 } "."
$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."
{ $command-map walker "toolbar" }
{ $command-map walker "other" }
"Walkers are instances of " { $link walker } "." ;
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."
$nl
@ -134,9 +126,9 @@ $nl
{ $subsection "ui-listener" }
{ $subsection "ui-browser" }
{ $subsection "ui-inspector" }
{ $subsection "ui-walker" }
{ $subsection "ui-profiler" }
"Additional tools:"
{ $subsection "ui-walker" }
{ $subsection "ui.tools.deploy" }
"Platform-specific features:"
{ $subsection "ui-cocoa" } ;

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs debugger ui.tools.workspace
ui.tools.operations ui.tools.browser ui.tools.inspector
ui.tools.listener ui.tools.profiler ui.tools.walker
ui.tools.listener ui.tools.profiler
ui.tools.operations inspector io kernel math models namespaces
prettyprint quotations sequences ui ui.commands ui.gadgets
ui.gadgets.books ui.gadgets.buttons
@ -23,7 +23,6 @@ IN: ui.tools
<stack-display> ,
<browser-gadget> ,
<inspector-gadget> ,
<walker> ,
<profiler-gadget> ,
] { } make g gadget-model <book> ;
@ -62,15 +61,12 @@ M: workspace model-changed
: com-inspector inspector-gadget select-tool ;
: com-walker walker select-tool ;
: com-profiler profiler-gadget select-tool ;
workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener }
{ T{ key-down f { A+ } "2" } com-browser }
{ T{ key-down f { A+ } "3" } com-inspector }
{ T{ key-down f { A+ } "4" } com-walker }
{ T{ key-down f { A+ } "5" } com-profiler }
} define-command-map

11
extra/ui/tools/walker/walker-docs.factor Executable file
View File

@ -0,0 +1,11 @@
IN: ui.tools.walker
USING: help.markup help.syntax ui.commands ui.operations
tools.walker ;
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 } "."
$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."
{ $command-map walker-gadget "toolbar" }
{ $command-map walker-gadget "other" }
"Walkers are instances of " { $link walker-gadget } "." ;

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

@ -1,8 +1,8 @@
USING: arrays continuations ui.tools.listener ui.tools.walker
ui.tools.workspace inspector kernel namespaces sequences threads
listener tools.test ui ui.gadgets ui.gadgets.worlds
ui.gadgets.packs vectors ui.tools tools.interpreter
tools.interpreter.debug tools.test.ui ;
ui.gadgets.packs vectors ui.tools tools.walker
tools.walker.debug tools.test.ui ;
IN: temporary
\ <walker> must-infer

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

@ -1,95 +1,92 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs ui.tools.listener ui.tools.traceback
ui.tools.workspace inspector kernel models namespaces
prettyprint quotations sequences threads
tools.interpreter ui.commands ui.gadgets ui.gadgets.labelled
ui.gadgets.tracks ui.gestures ui.gadgets.buttons
ui.gadgets.panes prettyprint.config prettyprint.backend
continuations ;
USING: kernel concurrency.messaging inspector ui.tools.listener
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
ui.gadgets.tracks ui.commands ui.gadgets models
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
namespaces tools.walker assocs ;
IN: ui.tools.walker
TUPLE: walker model interpreter history ;
TUPLE: walker-gadget status continuation thread ;
: update-stacks ( walker -- )
dup walker-interpreter interpreter-continuation
swap walker-model set-model ;
: walker-command ( walker msg -- )
over walker-gadget-thread thread-registered?
[ swap walker-gadget-thread send-synchronous drop ]
[ 2drop ] if ;
: with-walker ( walker quot -- )
over >r >r walker-interpreter r> call r>
update-stacks ; inline
: com-step ( walker -- ) step walker-command ;
: walker-active? ( walker -- ? )
walker-interpreter interpreter-continuation >boolean ;
: com-into ( walker -- ) step-into walker-command ;
: save-interpreter ( walker -- )
dup walker-interpreter interpreter-continuation clone
swap walker-history push ;
: com-out ( walker -- ) step-out walker-command ;
: walker-command ( gadget quot -- )
over walker-active? [
over save-interpreter
with-walker
] [ 2drop ] if ; inline
: com-back ( walker -- ) step-back walker-command ;
: com-step ( walker -- ) [ step ] walker-command ;
: com-continue ( walker -- ) step-all walker-command ;
: com-into ( walker -- ) [ step-into ] walker-command ;
: com-out ( walker -- ) [ step-out ] walker-command ;
: com-back ( walker -- )
dup walker-history
dup empty? [ 2drop ] [ pop swap call-tool* ] if ;
: reset-walker ( walker -- )
<interpreter> over set-walker-interpreter
V{ } clone over set-walker-history
update-stacks ;
M: walker graft* dup delegate graft* reset-walker ;
: <walker> ( -- gadget )
f <model> f f walker construct-boa [
toolbar,
g walker-model <traceback-gadget> 1 track,
] { 0 1 } build-track ;
M: walker call-tool* ( continuation walker -- )
[ restore ] with-walker ;
: com-abandon ( walker -- ) abandon walker-command ;
: com-inspect ( walker -- )
dup walker-active? [
walker-interpreter interpreter-continuation
[ inspect ] curry call-listener
] [
drop
] if ;
walker-continuation model-value
[ inspect ] curry call-listener ;
: com-continue ( walker -- )
#! Reset walker first, in case step-all ends up calling
#! the walker again.
dup walker-active? [
dup walker-interpreter swap reset-walker step-all
] [
M: walker-gadget ungraft*
dup delegate ungraft* detach walker-command ;
: walker-state-string ( status thread -- string )
[
"Thread: " %
dup thread-name %
" (" %
swap {
{ +stopped+ "Stopped" }
{ +suspended+ "Suspended" }
{ +running+ "Running" }
{ +detached+ "Detached" }
} at %
")" %
drop
] if ;
] "" make ;
: <thread-status> ( model thread -- gadget )
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
walker-gadget construct-boa [
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-continuation <traceback-gadget> 1 track,
] { 0 1 } build-track ;
: walker-help "ui-walker" help-window ;
\ walker-help H{ { +nullary+ t } } define-command
walker "toolbar" f {
{ T{ key-down f { A+ } "s" } com-step }
{ T{ key-down f { A+ } "i" } com-into }
{ T{ key-down f { A+ } "o" } com-out }
{ T{ key-down f { A+ } "b" } com-back }
{ T{ key-down f { A+ } "c" } com-continue }
walker-gadget "toolbar" f {
{ T{ key-down f f "s" } com-step }
{ T{ key-down f f "i" } com-into }
{ T{ key-down f f "o" } com-out }
{ T{ key-down f f "b" } com-back }
{ T{ key-down f f "c" } com-continue }
{ T{ key-down f f "a" } com-abandon }
{ T{ key-down f f "F1" } walker-help }
} define-command-map
walker "other" f {
{ T{ key-down f { A+ } "n" } com-inspect }
walker-gadget "other" f {
{ T{ key-down f f "n" } com-inspect }
{ T{ key-down f f "d" } close-window }
} define-command-map
[ walker call-tool stop ] break-hook set-global
: walker-window ( -- )
f <model> f <model> 2dup start-walker-thread
[ <walker-gadget> ] keep thread-name open-status-window ;
[ [ walker-window ] with-ui ] new-walker-hook set-global
[
[
>r dup walker-gadget?
[ walker-gadget-thread r> eq? ]
[ r> 2drop f ] if
] curry find-window raise-window
] show-walker-hook set-global

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

@ -26,7 +26,7 @@ HELP: fullscreen?
HELP: find-window
{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
{ $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ;
{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
HELP: register-window
{ $values { "world" world } { "handle" "a baackend-specific handle" } }
@ -185,6 +185,10 @@ ARTICLE: "ui-backend-windows" "UI backend window management"
"If the user clicks the window's close box, you must call the following word:"
{ $subsection close-window } ;
HELP: raise-window
{ $values { "gadget" gadget } }
{ $description "Makes the native window containing the given gadget the front-most window." } ;
ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
"A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."
{ $subsection "ui-layout-basics" }

9
extra/ui/ui.factor
View File

@ -131,10 +131,8 @@ SYMBOL: ui-hook
graft-queue [ notify ] dlist-slurp ;
: ui-step ( -- )
[ do-timers ] assert-depth
[ notify-queued ] assert-depth
[ layout-queued "a" set ] assert-depth
[ "a" get redraw-worlds ] assert-depth ;
[ do-timers notify-queued layout-queued redraw-worlds ]
assert-depth ;
: open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
@ -149,6 +147,9 @@ SYMBOL: ui-hook
: fullscreen? ( gadget -- ? )
find-world fullscreen* ;
: raise-window ( gadget -- )
find-world raise-window* ;
HOOK: close-window ui-backend ( gadget -- )
M: object close-window

2
extra/ui/windows/windows.factor
View File

@ -438,7 +438,7 @@ M: windows-ui-backend flush-gl-context ( handle -- )
win-hDC SwapBuffers win32-error=0/f ;
! Move window to front
M: windows-ui-backend raise-window ( world -- )
M: windows-ui-backend raise-window* ( world -- )
world-handle [
win-hWnd SetFocus drop
] when* ;

2
extra/ui/x11/x11.factor
View File

@ -235,7 +235,7 @@ M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
world-handle x11-handle-window dup set-closable map-window ;
M: x11-ui-backend raise-window ( world -- )
M: x11-ui-backend raise-window* ( world -- )
world-handle [
dpy get swap x11-handle-window XRaiseWindow drop
] when* ;