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

Merge branch 'new_walker' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-02-19 23:23:22 -06:00
parent 6281e0a95d f2e9b80784
commit 614d78ae98
5 changed files with 51 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -199,6 +199,3 @@ $low-level-note ;
HELP: init-error-handler HELP: init-error-handler
{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ; { $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;
HELP: break
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;

25
core/continuations/continuations.factor
View File

@ -91,14 +91,8 @@ C: <continuation> continuation
PRIVATE> PRIVATE>
: set-walker-hook ( quot -- ) 3 setenv ; inline
: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
: continue-with ( obj continuation -- ) : continue-with ( obj continuation -- )
[ [ (continue-with) ] 2 (throw) ;
walker-hook [ >r 2array r> ] when* (continue-with)
] 2 (throw) ;
: continue ( continuation -- ) : continue ( continuation -- )
f swap continue-with ; f swap continue-with ;
@ -185,20 +179,3 @@ M: condition compute-restarts
"kernel-error" 6 setenv ; "kernel-error" 6 setenv ;
PRIVATE> PRIVATE>
! Debugging support
: with-walker-hook ( continuation -- )
[ swap set-walker-hook (continue) ] curry callcc1 ;
SYMBOL: break-hook
: break ( -- )
continuation callstack
over set-continuation-call
walker-hook [ (continue-with) ] [ break-hook get call ] if* ;
GENERIC: (step-into) ( obj -- )
M: wrapper (step-into) wrapped break ;
M: object (step-into) break ;
M: callable (step-into) \ break add* break ;

62
core/prettyprint/prettyprint.factor
View File

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

4
extra/channels/remote/remote.factor
View File

@ -29,14 +29,14 @@ MATCH-VARS: ?from ?tag ?id ?value ;
SYMBOL: no-channel SYMBOL: no-channel
: channel-process ( -- ) : channel-process ( -- )
receive [ [
{ {
{ { to ?id ?value } { { to ?id ?value }
[ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] } [ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
{ { from ?id } { { from ?id }
[ ?id get-channel [ from ] [ no-channel ] if* ] } [ ?id get-channel [ from ] [ no-channel ] if* ] }
} match-cond } match-cond
] keep reply-synchronous ; ] handle-synchronous ;
PRIVATE> PRIVATE>

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

@ -97,7 +97,7 @@ M: thread send ( message thread -- )
mailbox mailbox-get? ?linked ; inline mailbox mailbox-get? ?linked ; inline
: rethrow-linked ( error process supervisor -- ) : rethrow-linked ( error process supervisor -- )
>r <linked> r> send ; pick thread-death? [ 3drop ] [ >r <linked> r> send ] if ;
: spawn-linked-to ( quot name mailbox -- thread ) : spawn-linked-to ( quot name mailbox -- thread )
[ >r <linked> r> mailbox-put ] curry <thread> [ >r <linked> r> mailbox-put ] curry <thread>
@ -117,17 +117,26 @@ TUPLE: reply data tag ;
synchronous-tag \ reply construct-boa ; synchronous-tag \ reply construct-boa ;
: send-synchronous ( message thread -- reply ) : send-synchronous ( message thread -- reply )
dup self eq? [
"Cannot synchronous send to myself" throw
] [
>r <synchronous> dup r> send [ >r <synchronous> dup r> send [
over reply? [ over reply? [
>r reply-tag r> synchronous-tag = >r reply-tag r> synchronous-tag =
] [ ] [
2drop f 2drop f
] if ] if
] curry receive-if reply-data ; ] curry receive-if reply-data
] if ;
: reply-synchronous ( message synchronous -- ) : reply-synchronous ( message synchronous -- )
[ <reply> ] keep synchronous-sender send ; [ <reply> ] keep synchronous-sender send ;
: handle-synchronous ( quot -- )
receive [
synchronous-data swap call
] keep reply-synchronous ; inline
<PRIVATE <PRIVATE
: remote-processes ( -- hash ) : remote-processes ( -- hash )