get cont-responder working with continuation word changes

cvs
Chris Double 2005-09-18 05:36:59 +00:00
parent 989a330f67
commit cd6977e979
1 changed files with 19 additions and 27 deletions

View File

@ -43,16 +43,13 @@ SYMBOL: post-refresh-get?
[ 32 [ 0 9 random-int CHAR: 0 + , ] times ] "" make [ 32 [ 0 9 random-int CHAR: 0 + , ] times ] "" make
string>number 36 >base ; string>number 36 >base ;
#! Name of variable holding the table of continuations. : continuation-table ( -- <hashtable> )
SYMBOL: table
: continuation-table ( -- <namespace> )
#! Return the global table of continuations #! Return the global table of continuations
table get ; {{ }} ;
: reset-continuation-table ( -- ) : reset-continuation-table ( -- )
#! Create the initial global table #! Create the initial global table
{{ }} clone table set ; continuation-table hash-clear ;
#! Tuple for holding data related to a continuation. #! Tuple for holding data related to a continuation.
TUPLE: item expire? quot id time-added ; TUPLE: item expire? quot id time-added ;
@ -75,22 +72,17 @@ TUPLE: item expire? quot id time-added ;
#! timeout milliseconds ago). #! timeout milliseconds ago).
[ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ; [ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
: continuation-items ( -- alist )
#! Return an alist of all continuation items in the continuation
#! table with the car as the id and the cdr as the item.
continuation-table hash>alist ;
: expire-continuations ( timeout-seconds -- ) : expire-continuations ( timeout-seconds -- )
#! Expire all continuations in the continuation table #! Expire all continuations in the continuation table
#! if they are 'timeout-seconds' old (ie. were added #! if they are 'timeout-seconds' old (ie. were added
#! more than 'timeout-seconds' ago. #! more than 'timeout-seconds' ago.
continuation-items [ continuation-table clone [ ( timeout-seconds [[ id item ]] -- )
uncons pick swap expired? [ uncons swapd expired? [
continuation-table remove-hash continuation-table remove-hash
] [ ] [
drop drop
] ifte ] ifte
] each drop ; ] hash-each-with ;
: expirable ( quot -- t quot ) : expirable ( quot -- t quot )
#! Set the stack up for a register-continuation call #! Set the stack up for a register-continuation call
@ -108,7 +100,9 @@ TUPLE: item expire? quot id time-added ;
#! Store a continuation in the table and associate it with #! Store a continuation in the table and associate it with
#! a random id. That continuation will be expired after #! a random id. That continuation will be expired after
#! a certain period of time if 'expire?' is true. #! a certain period of time if 'expire?' is true.
get-random-id -rot pick continuation-item over continuation-table set-hash ; get-random-id
[ continuation-item ] keep ( item id -- )
[ continuation-table set-hash ] keep ;
: register-continuation* ( expire? quots -- id ) : register-continuation* ( expire? quots -- id )
#! Like register-continuation but registers a quotation #! Like register-continuation but registers a quotation
@ -140,6 +134,11 @@ DEFER: show
</html> </html>
] show-final ; ] show-final ;
: >callable ( quot|interp|f -- interp )
dup interp? [
[ continue-with ] cons
] when ;
: get-registered-continuation ( id -- cont ) : get-registered-continuation ( id -- cont )
#! Return the continuation or quotation #! Return the continuation or quotation
#! associated with the given id. #! associated with the given id.
@ -149,7 +148,7 @@ DEFER: show
item-quot item-quot
] [ ] [
[ expired-page-handler ] [ expired-page-handler ]
] ifte* ; ] ifte* >callable ;
: resume-continuation ( value id -- ) : resume-continuation ( value id -- )
#! Call the continuation associated with the given id, #! Call the continuation associated with the given id,
@ -167,7 +166,7 @@ SYMBOL: exit-cc
: call-exit-continuation ( value -- ) : call-exit-continuation ( value -- )
#! Call the exit continuation, passing it the given value on the #! Call the exit continuation, passing it the given value on the
#! top of the stack. #! top of the stack.
exit-cc get call ; exit-cc get continue-with ;
: with-exit-continuation ( quot -- ) : with-exit-continuation ( quot -- )
#! Call the quotation with the variable exit-cc bound such that when #! Call the quotation with the variable exit-cc bound such that when
@ -188,10 +187,10 @@ SYMBOL: callback-cc
[ ( 0 -- ) [ ( 0 -- )
[ ( 0 1 -- ) [ ( 0 1 -- )
callback-cc set ( 0 -- ) callback-cc set ( 0 -- )
call continue
] callcc1 ( 0 [ ] == ) ] callcc1 ( 0 [ ] == )
nip nip
call continue
store-callback-cc store-callback-cc
] callcc0 ; ] callcc0 ;
@ -275,7 +274,7 @@ SYMBOL: root-continuation
#! Convert the given quotation so it works as a callback #! Convert the given quotation so it works as a callback
#! by returning a quotation that will pass the original #! by returning a quotation that will pass the original
#! quotation to the callback continuation. #! quotation to the callback continuation.
[ , callback-cc get , \ call , ] [ ] make ; [ , callback-cc get , \ continue-with , ] [ ] make ;
: quot-href ( text quot -- ) : quot-href ( text quot -- )
#! Write to standard output an HTML HREF where the href, #! Write to standard output an HTML HREF where the href,
@ -305,16 +304,9 @@ SYMBOL: root-continuation
[ cont-get/post-responder ] "get" set [ cont-get/post-responder ] "get" set
[ cont-get/post-responder ] "post" set [ cont-get/post-responder ] "post" set
swap "responder" set swap "responder" set
reset-continuation-table
permanent register-continuation root-continuation set permanent register-continuation root-continuation set
] make-responder ; ] make-responder ;
: responder-items ( name -- items )
#! Return the table of continuation items for a given responder.
#! Useful for debugging.
responders get hash [ continuation-table ] bind ;
: simple-page ( title quot -- ) : simple-page ( title quot -- )
#! Call the quotation, with all output going to the #! Call the quotation, with all output going to the
#! body of an html page with the given title. #! body of an html page with the given title.