new accessors
parent
eb5e72c7d3
commit
b839f608d0
|
@ -35,8 +35,8 @@ HELP: buffer
|
||||||
$nl
|
$nl
|
||||||
"Buffers have two internal pointers:"
|
"Buffers have two internal pointers:"
|
||||||
{ $list
|
{ $list
|
||||||
{ { $link buffer-fill } " - the fill pointer, a write index where new data is added" }
|
{ { $snippet "fill" } " - the fill pointer, a write index where new data is added" }
|
||||||
{ { $link buffer-pos } " - the position, a read index where data is consumed" }
|
{ { $snippet "pos" } " - the position, a read index where data is consumed" }
|
||||||
} } ;
|
} } ;
|
||||||
|
|
||||||
HELP: <buffer>
|
HELP: <buffer>
|
||||||
|
|
|
@ -53,7 +53,7 @@ SYMBOL: +realtime-priority+
|
||||||
dup handle>> swap status>> or ;
|
dup handle>> swap status>> or ;
|
||||||
|
|
||||||
: process-running? ( process -- ? )
|
: process-running? ( process -- ? )
|
||||||
process-handle >boolean ;
|
handle>> >boolean ;
|
||||||
|
|
||||||
! Non-blocking process exit notification facility
|
! Non-blocking process exit notification facility
|
||||||
SYMBOL: processes
|
SYMBOL: processes
|
||||||
|
@ -80,7 +80,7 @@ SYMBOL: wait-flag
|
||||||
V{ } clone swap processes get set-at
|
V{ } clone swap processes get set-at
|
||||||
wait-flag get-global raise-flag ;
|
wait-flag get-global raise-flag ;
|
||||||
|
|
||||||
M: process hashcode* process-handle hashcode* ;
|
M: process hashcode* handle>> hashcode* ;
|
||||||
|
|
||||||
: pass-environment? ( process -- ? )
|
: pass-environment? ( process -- ? )
|
||||||
dup environment>> assoc-empty? not
|
dup environment>> assoc-empty? not
|
||||||
|
@ -99,9 +99,14 @@ M: process hashcode* process-handle hashcode* ;
|
||||||
|
|
||||||
GENERIC: >process ( obj -- process )
|
GENERIC: >process ( obj -- process )
|
||||||
|
|
||||||
|
ERROR: process-already-started ;
|
||||||
|
|
||||||
|
M: process-already-started summary
|
||||||
|
drop "Process has already been started once" ;
|
||||||
|
|
||||||
M: process >process
|
M: process >process
|
||||||
dup process-started? [
|
dup process-started? [
|
||||||
"Process has already been started once" throw
|
process-already-started
|
||||||
] when
|
] when
|
||||||
clone ;
|
clone ;
|
||||||
|
|
||||||
|
@ -111,6 +116,8 @@ HOOK: current-process-handle io-backend ( -- handle )
|
||||||
|
|
||||||
HOOK: run-process* io-backend ( process -- handle )
|
HOOK: run-process* io-backend ( process -- handle )
|
||||||
|
|
||||||
|
ERROR: process-was-killed ;
|
||||||
|
|
||||||
: wait-for-process ( process -- status )
|
: wait-for-process ( process -- status )
|
||||||
[
|
[
|
||||||
dup handle>>
|
dup handle>>
|
||||||
|
@ -119,7 +126,7 @@ HOOK: run-process* io-backend ( process -- handle )
|
||||||
"process" suspend drop
|
"process" suspend drop
|
||||||
] when
|
] when
|
||||||
dup killed>>
|
dup killed>>
|
||||||
[ "Process was killed" throw ] [ status>> ] if
|
[ process-was-killed ] [ status>> ] if
|
||||||
] with-timeout ;
|
] with-timeout ;
|
||||||
|
|
||||||
: run-detached ( desc -- process )
|
: run-detached ( desc -- process )
|
||||||
|
@ -150,7 +157,7 @@ HOOK: kill-process* io-backend ( handle -- )
|
||||||
|
|
||||||
M: process timeout timeout>> ;
|
M: process timeout timeout>> ;
|
||||||
|
|
||||||
M: process set-timeout set-process-timeout ;
|
M: process set-timeout swap >>timeout drop ;
|
||||||
|
|
||||||
M: process cancel-operation kill-process ;
|
M: process cancel-operation kill-process ;
|
||||||
|
|
||||||
|
@ -222,10 +229,12 @@ GENERIC: underlying-handle ( stream -- handle )
|
||||||
|
|
||||||
M: port underlying-handle handle>> ;
|
M: port underlying-handle handle>> ;
|
||||||
|
|
||||||
|
ERROR: invalid-duplex-stream ;
|
||||||
|
|
||||||
M: duplex-stream underlying-handle
|
M: duplex-stream underlying-handle
|
||||||
[ in>> underlying-handle ]
|
[ in>> underlying-handle ]
|
||||||
[ out>> underlying-handle ] bi
|
[ out>> underlying-handle ] bi
|
||||||
[ = [ "Invalid duplex stream" throw ] when ] keep ;
|
[ = [ invalid-duplex-stream ] when ] keep ;
|
||||||
|
|
||||||
M: encoder underlying-handle
|
M: encoder underlying-handle
|
||||||
stream>> underlying-handle ;
|
stream>> underlying-handle ;
|
||||||
|
|
|
@ -2,14 +2,14 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser kernel sequences words effects
|
USING: parser kernel sequences words effects
|
||||||
stack-checker.transforms combinators assocs definitions
|
stack-checker.transforms combinators assocs definitions
|
||||||
quotations namespaces memoize ;
|
quotations namespaces memoize accessors ;
|
||||||
IN: macros
|
IN: macros
|
||||||
|
|
||||||
: real-macro-effect ( word -- effect' )
|
: real-macro-effect ( word -- effect' )
|
||||||
"declared-effect" word-prop effect-in 1 <effect> ;
|
"declared-effect" word-prop in>> 1 <effect> ;
|
||||||
|
|
||||||
: define-macro ( word definition -- )
|
: define-macro ( word definition -- )
|
||||||
over "declared-effect" word-prop effect-in length >r
|
over "declared-effect" word-prop in>> length >r
|
||||||
2dup "macro" set-word-prop
|
2dup "macro" set-word-prop
|
||||||
2dup over real-macro-effect memoize-quot [ call ] append define
|
2dup over real-macro-effect memoize-quot [ call ] append define
|
||||||
r> define-transform ;
|
r> define-transform ;
|
||||||
|
|
|
@ -2,7 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex
|
||||||
kernel math namespaces parser prettyprint prettyprint.config
|
kernel math namespaces parser prettyprint prettyprint.config
|
||||||
prettyprint.sections sequences tools.test vectors words
|
prettyprint.sections sequences tools.test vectors words
|
||||||
effects splitting generic.standard prettyprint.private
|
effects splitting generic.standard prettyprint.private
|
||||||
continuations generic compiler.units tools.walker eval ;
|
continuations generic compiler.units tools.walker eval
|
||||||
|
accessors ;
|
||||||
IN: prettyprint.tests
|
IN: prettyprint.tests
|
||||||
|
|
||||||
[ "4" ] [ 4 unparse ] unit-test
|
[ "4" ] [ 4 unparse ] unit-test
|
||||||
|
@ -296,7 +297,7 @@ M: class-see-layout class-see-layout ;
|
||||||
[ \ class-see-layout see-methods ] with-string-writer "\n" split
|
[ \ class-see-layout see-methods ] with-string-writer "\n" split
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [ \ effect-in synopsis drop ] unit-test
|
[ ] [ \ in>> synopsis drop ] unit-test
|
||||||
|
|
||||||
! Regression
|
! Regression
|
||||||
[ t ] [
|
[ t ] [
|
||||||
|
|
Loading…
Reference in New Issue