Merge branch 'new_walker' of git://factorcode.org/git/factor
Slava Pestov
commit
614d78ae98
|
|
@ -199,6 +199,3 @@ $low-level-note ;
|
|||
|
||||
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." } ;
|
||||
|
||||
HELP: break
|
||||
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
|
||||
|
|
|
|||
|
|
@ -91,14 +91,8 @@ C: <continuation> continuation
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: set-walker-hook ( quot -- ) 3 setenv ; inline
|
||||
|
||||
: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
|
||||
|
||||
: continue-with ( obj continuation -- )
|
||||
[
|
||||
walker-hook [ >r 2array r> ] when* (continue-with)
|
||||
] 2 (throw) ;
|
||||
[ (continue-with) ] 2 (throw) ;
|
||||
|
||||
: continue ( continuation -- )
|
||||
f swap continue-with ;
|
||||
|
|
@ -185,20 +179,3 @@ M: condition compute-restarts
|
|||
"kernel-error" 6 setenv ;
|
||||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -95,42 +95,42 @@ SYMBOL: ->
|
|||
"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 )
|
||||
[
|
||||
[
|
||||
{
|
||||
{ break [ ] }
|
||||
{ (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
|
||||
! 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 ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: callstack. ( callstack -- )
|
||||
callstack>array 2 <groups> [
|
||||
remove-breakpoints
|
||||
! remove-breakpoints
|
||||
2 nesting-limit [ . ] with-variable
|
||||
] assoc-each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -29,14 +29,14 @@ MATCH-VARS: ?from ?tag ?id ?value ;
|
|||
SYMBOL: no-channel
|
||||
|
||||
: channel-process ( -- )
|
||||
receive [
|
||||
[
|
||||
{
|
||||
{ { to ?id ?value }
|
||||
[ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
|
||||
{ { from ?id }
|
||||
[ ?id get-channel [ from ] [ no-channel ] if* ] }
|
||||
} match-cond
|
||||
] keep reply-synchronous ;
|
||||
] handle-synchronous ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -97,7 +97,7 @@ M: thread send ( message thread -- )
|
|||
mailbox mailbox-get? ?linked ; inline
|
||||
|
||||
: 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 )
|
||||
[ >r <linked> r> mailbox-put ] curry <thread>
|
||||
|
|
@ -117,17 +117,26 @@ TUPLE: reply data tag ;
|
|||
synchronous-tag \ reply construct-boa ;
|
||||
|
||||
: send-synchronous ( message thread -- reply )
|
||||
>r <synchronous> dup r> send [
|
||||
over reply? [
|
||||
>r reply-tag r> synchronous-tag =
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] curry receive-if reply-data ;
|
||||
dup self eq? [
|
||||
"Cannot synchronous send to myself" throw
|
||||
] [
|
||||
>r <synchronous> dup r> send [
|
||||
over reply? [
|
||||
>r reply-tag r> synchronous-tag =
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] curry receive-if reply-data
|
||||
] if ;
|
||||
|
||||
: reply-synchronous ( message synchronous -- )
|
||||
[ <reply> ] keep synchronous-sender send ;
|
||||
|
||||
: handle-synchronous ( quot -- )
|
||||
receive [
|
||||
synchronous-data swap call
|
||||
] keep reply-synchronous ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: remote-processes ( -- hash )
|
||||
|
|
|
|||
Loading…
Reference in New Issue