(yield) renamed to stop
parent
4f7d80af74
commit
8b61c03fa1
|
@ -218,7 +218,7 @@ END-STRUCT
|
|||
over sqlite3_step step-complete? [
|
||||
2drop
|
||||
] [
|
||||
2dup 2slip sqlite-each
|
||||
[ call ] 2keep sqlite-each
|
||||
] ifte ;
|
||||
|
||||
! For comparison, here is the linrec implementation of sqlite-each
|
||||
|
|
|
@ -79,7 +79,7 @@ Some macros for working with tagged cells are provided:
|
|||
|
||||
- RETAG(cell,tag) -- set the tag of a cell
|
||||
|
||||
- untag_fixnum_fast(cell) -- shift the cell to the left by three bits,
|
||||
- untag_fixnum_fast(cell) -- shift the cell to the right by three bits,
|
||||
without actually checking that the tag is FIXNUM_TYPE. If it is not
|
||||
FIXNUM_TYPE, a meaningless value is returned.
|
||||
|
||||
|
|
|
@ -32,7 +32,7 @@ USE: kernel
|
|||
USE: win32-io-internals
|
||||
USE: win32-api
|
||||
|
||||
: (yield) ( -- )
|
||||
: stop ( -- )
|
||||
next-thread [
|
||||
call
|
||||
] [
|
||||
|
|
|
@ -75,7 +75,7 @@ PREDICATE: general-list list ( list -- ? )
|
|||
swap [ with rot ] all? 2nip ; inline
|
||||
|
||||
: (each) ( list quot -- list quot )
|
||||
>r uncons r> tuck 2slip ; inline
|
||||
[ >r car r> call ] 2keep >r cdr r> ; inline
|
||||
|
||||
: each ( list quot -- )
|
||||
#! Push each element of a proper list in turn, and apply a
|
||||
|
|
|
@ -5,13 +5,10 @@ IN: kernel
|
|||
: slip ( quot x -- x | quot: -- )
|
||||
>r call r> ; inline
|
||||
|
||||
: 2slip ( quot x y -- x y : quot: -- )
|
||||
>r >r call r> r> ; inline
|
||||
|
||||
: keep ( a quot -- a | quot: a -- )
|
||||
: keep ( x quot -- x | quot: x -- )
|
||||
over >r call r> ; inline
|
||||
|
||||
: 2keep ( a b quot -- a b | quot: a b -- )
|
||||
: 2keep ( x y quot -- x y | quot: x y -- )
|
||||
over >r pick >r call r> r> ; inline
|
||||
|
||||
: while ( quot generator -- )
|
||||
|
@ -23,7 +20,7 @@ IN: kernel
|
|||
r> 2drop r> r> 2drop
|
||||
] ifte ; inline
|
||||
|
||||
: ifte* ( cond true false -- )
|
||||
: ifte* ( cond true false -- | true: cond -- | false: -- )
|
||||
#! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte
|
||||
pick [ drop call ] [ 2nip call ] ifte ; inline
|
||||
|
||||
|
@ -35,35 +32,23 @@ IN: kernel
|
|||
drop r> drop r> call
|
||||
] ifte ; inline
|
||||
|
||||
: unless ( cond quot -- )
|
||||
: unless ( cond quot -- | quot: -- )
|
||||
#! Execute a quotation only when the condition is f. The
|
||||
#! condition is popped off the stack.
|
||||
#!
|
||||
#! In order to compile, the quotation must consume as many
|
||||
#! values as it produces.
|
||||
[ ] swap ifte ; inline
|
||||
|
||||
: unless* ( cond quot -- )
|
||||
: unless* ( cond quot -- | quot: -- )
|
||||
#! If cond is f, pop it off the stack and evaluate the
|
||||
#! quotation. Otherwise, leave cond on the stack.
|
||||
#!
|
||||
#! In order to compile, the quotation must consume one less
|
||||
#! value than it produces.
|
||||
over [ drop ] [ nip call ] ifte ; inline
|
||||
|
||||
: when ( cond quot -- )
|
||||
: when ( cond quot -- | quot: -- )
|
||||
#! Execute a quotation only when the condition is not f. The
|
||||
#! condition is popped off the stack.
|
||||
#!
|
||||
#! In order to compile, the quotation must consume as many
|
||||
#! values as it produces.
|
||||
[ ] ifte ; inline
|
||||
|
||||
: when* ( cond quot -- )
|
||||
: when* ( cond quot -- | quot: cond -- )
|
||||
#! If the condition is true, it is left on the stack, and
|
||||
#! the quotation is evaluated. Otherwise, the condition is
|
||||
#! popped off the stack.
|
||||
#!
|
||||
#! In order to compile, the quotation must consume one more
|
||||
#! value than it produces.
|
||||
dupd [ drop ] ifte ; inline
|
||||
|
|
|
@ -14,5 +14,5 @@ IN: threads USING: errors io-internals kernel lists ;
|
|||
[ ] set-catchstack
|
||||
{ } set-callstack
|
||||
try
|
||||
(yield)
|
||||
stop
|
||||
] callcc0 drop ;
|
||||
|
|
|
@ -9,7 +9,7 @@ BUILTIN: port 14 ;
|
|||
: stdout 1 getenv ;
|
||||
|
||||
: blocking-flush ( port -- )
|
||||
[ add-write-io-task (yield) ] callcc0 drop ;
|
||||
[ add-write-io-task stop ] callcc0 drop ;
|
||||
|
||||
: wait-to-write ( len port -- )
|
||||
tuck can-write? [ drop ] [ blocking-flush ] ifte ;
|
||||
|
@ -20,7 +20,7 @@ BUILTIN: port 14 ;
|
|||
over wait-to-write write-fd-8 ;
|
||||
|
||||
: blocking-fill ( port -- )
|
||||
[ add-read-line-io-task (yield) ] callcc0 drop ;
|
||||
[ add-read-line-io-task stop ] callcc0 drop ;
|
||||
|
||||
: wait-to-read-line ( port -- )
|
||||
dup can-read-line? [ drop ] [ blocking-fill ] ifte ;
|
||||
|
@ -29,7 +29,7 @@ BUILTIN: port 14 ;
|
|||
dup wait-to-read-line read-line-fd-8 dup [ sbuf>string ] when ;
|
||||
|
||||
: fill-fd ( count port -- )
|
||||
[ add-read-count-io-task (yield) ] callcc0 2drop ;
|
||||
[ add-read-count-io-task stop ] callcc0 2drop ;
|
||||
|
||||
: wait-to-read ( count port -- )
|
||||
2dup can-read-count? [ 2drop ] [ fill-fd ] ifte ;
|
||||
|
@ -38,11 +38,11 @@ BUILTIN: port 14 ;
|
|||
2dup wait-to-read read-count-fd-8 dup [ sbuf>string ] when ;
|
||||
|
||||
: wait-to-accept ( socket -- )
|
||||
[ add-accept-io-task (yield) ] callcc0 drop ;
|
||||
[ add-accept-io-task stop ] callcc0 drop ;
|
||||
|
||||
: blocking-accept ( socket -- host port in out )
|
||||
dup wait-to-accept accept-fd ;
|
||||
|
||||
: blocking-copy ( in out -- )
|
||||
[ add-copy-io-task (yield) ] callcc0
|
||||
[ add-copy-io-task stop ] callcc0
|
||||
pending-io-error pending-io-error ;
|
||||
|
|
|
@ -36,8 +36,8 @@ M: object clone ;
|
|||
rot [ drop ] [ nip ] ifte ; inline
|
||||
|
||||
: >boolean t f ? ; inline
|
||||
: not ( a -- ~a ) f t ? ; inline
|
||||
|
||||
: and ( a b -- a&b ) f ? ; inline
|
||||
: not ( a -- ~a ) f t ? ; inline
|
||||
: or ( a b -- a|b ) t swap ? ; inline
|
||||
: xor ( a b -- a^b ) dup not swap ? ; inline
|
||||
|
|
|
@ -20,23 +20,18 @@ USING: io-internals kernel kernel-internals lists namespaces ;
|
|||
|
||||
: schedule-thread ( quot -- ) run-queue enque set-run-queue ;
|
||||
|
||||
: (yield) ( -- )
|
||||
: stop ( -- )
|
||||
#! If there is a quotation in the run queue, call it,
|
||||
#! otherwise wait for I/O. The currently executing
|
||||
#! continuation is suspended. Use yield instead.
|
||||
#! otherwise wait for I/O.
|
||||
next-thread [
|
||||
call
|
||||
] [
|
||||
next-io-task [
|
||||
call
|
||||
] [
|
||||
(yield)
|
||||
] ifte*
|
||||
next-io-task [ call ] [ stop ] ifte*
|
||||
] ifte* ;
|
||||
|
||||
: yield ( -- )
|
||||
#! Add the current continuation to the run queue, and yield
|
||||
#! to the next quotation. The current continuation will
|
||||
#! eventually be restored by a future call to (yield) or
|
||||
#! eventually be restored by a future call to stop or
|
||||
#! yield.
|
||||
[ schedule-thread (yield) ] callcc0 ;
|
||||
[ schedule-thread stop ] callcc0 ;
|
||||
|
|
|
@ -38,7 +38,17 @@ parser ;
|
|||
#! specializing on this class.
|
||||
[
|
||||
"methods" word-prop [ dupd hash ] [ f ] ifte*
|
||||
] word-subset word-sort nip ;
|
||||
] word-subset nip ;
|
||||
|
||||
: classes ( -- list )
|
||||
[ metaclass ] word-subset ;
|
||||
|
||||
: constructors ( -- list )
|
||||
[
|
||||
word-name dup "<" string-head? swap ">" string-tail? and
|
||||
] word-subset ;
|
||||
|
||||
: predicates ( -- list )
|
||||
[
|
||||
word-name dup "?" = not swap "?" string-tail? and
|
||||
] word-subset ;
|
||||
|
|
|
@ -48,6 +48,5 @@ C: dialog ( content -- gadget )
|
|||
#! when the user clicks OK or Cancel. If they click Cancel,
|
||||
#! push f.
|
||||
[
|
||||
<input-dialog> "Input" <tile> world get add-gadget
|
||||
(yield)
|
||||
<input-dialog> "Input" <tile> world get add-gadget stop
|
||||
] callcc1 ;
|
||||
|
|
|
@ -69,7 +69,7 @@ M: pane stream-flush ( stream -- ) relayout ;
|
|||
M: pane stream-auto-flush ( stream -- ) relayout ;
|
||||
|
||||
M: pane stream-readln ( stream -- line )
|
||||
[ swap set-pane-continuation (yield) ] callcc1 nip ;
|
||||
[ swap set-pane-continuation stop ] callcc1 nip ;
|
||||
|
||||
M: pane stream-write-attr ( string style stream -- )
|
||||
[ nip swap "\n" split pane-write ] keep scroll>bottom ;
|
||||
|
|
|
@ -29,7 +29,7 @@ SYMBOL: vocabularies
|
|||
|
||||
: word-subset ( pred -- list | pred: word -- ? )
|
||||
#! A list of words matching the predicate.
|
||||
all-words swap subset ; inline
|
||||
all-words swap subset word-sort ; inline
|
||||
|
||||
: word-subset-with ( obj pred -- list | pred: obj word -- ? )
|
||||
all-words swap subset-with ; inline
|
||||
|
|
|
@ -93,7 +93,7 @@ M: win32-server accept ( server -- client )
|
|||
[
|
||||
alloc-io-task init-overlapped >r >r >r socket get r> r>
|
||||
buffer-ptr <alien> 0 32 32 NULL r> AcceptEx
|
||||
[ handle-socket-error ] unless (yield)
|
||||
[ handle-socket-error ] unless stop
|
||||
] callcc1 pending-error drop
|
||||
swap dup add-completion <win32-stream> dupd <win32-client-stream>
|
||||
swap buffer-free
|
||||
|
|
|
@ -55,7 +55,7 @@ SYMBOL: file-size
|
|||
[
|
||||
alloc-io-task init-overlapped >r
|
||||
handle get out-buffer get [ buffer@ ] keep buffer-length
|
||||
NULL r> WriteFile [ handle-io-error ] unless (yield)
|
||||
NULL r> WriteFile [ handle-io-error ] unless stop
|
||||
] callcc1 pending-error
|
||||
|
||||
dup update-file-pointer
|
||||
|
@ -84,7 +84,7 @@ M: string do-write ( str -- )
|
|||
handle get in-buffer get [ buffer@ ] keep
|
||||
buffer-capacity file-size get [ fileptr get - min ] when*
|
||||
NULL r>
|
||||
ReadFile [ handle-io-error ] unless (yield)
|
||||
ReadFile [ handle-io-error ] unless stop
|
||||
] callcc1 pending-error
|
||||
|
||||
dup in-buffer get >buffer update-file-pointer ;
|
||||
|
|
Loading…
Reference in New Issue