get cont-responder working with continuation word changes
parent
989a330f67
commit
cd6977e979
|
@ -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.
|
||||||
|
|
Loading…
Reference in New Issue