Phasing out get-slots and cleaning up some code
Slava Pestov
parent
2aafe074b2
commit
aec04edbda
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.union words kernel sequences
|
||||
definitions combinators arrays ;
|
||||
definitions combinators arrays accessors ;
|
||||
IN: classes.mixin
|
||||
|
||||
PREDICATE: mixin-class < union-class "mixin" word-prop ;
|
||||
|
|
@ -53,8 +53,7 @@ M: mixin-instance equal?
|
|||
} cond 2nip ;
|
||||
|
||||
M: mixin-instance hashcode*
|
||||
{ mixin-instance-class mixin-instance-mixin } get-slots
|
||||
2array hashcode* ;
|
||||
[ class>> ] [ mixin>> ] bi 2array hashcode* ;
|
||||
|
||||
: <mixin-instance> ( class mixin -- definition )
|
||||
{ set-mixin-instance-class set-mixin-instance-mixin }
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ hashtables sorting ;
|
|||
: spread>quot ( seq -- quot )
|
||||
[ length [ >r ] <repetition> concat ]
|
||||
[ [ [ r> ] prepend ] map concat ] bi
|
||||
compose ;
|
||||
append ;
|
||||
|
||||
: spread ( seq -- )
|
||||
spread>quot call ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays vectors kernel kernel.private sequences
|
||||
namespaces math splitting sorting quotations assocs ;
|
||||
namespaces math splitting sorting quotations assocs
|
||||
combinators accessors ;
|
||||
IN: continuations
|
||||
|
||||
SYMBOL: error
|
||||
|
|
@ -43,12 +44,12 @@ C: <continuation> continuation
|
|||
|
||||
: >continuation< ( continuation -- data call retain name catch )
|
||||
{
|
||||
continuation-data
|
||||
continuation-call
|
||||
continuation-retain
|
||||
continuation-name
|
||||
continuation-catch
|
||||
} get-slots ;
|
||||
[ data>> ]
|
||||
[ call>> ]
|
||||
[ retain>> ]
|
||||
[ name>> ]
|
||||
[ catch>> ]
|
||||
} cleave ;
|
||||
|
||||
: ifcc ( capture restore -- )
|
||||
#! After continuation is being captured, the stacks looks
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences arrays assocs sequences.private
|
||||
growable ;
|
||||
growable accessors ;
|
||||
IN: heaps
|
||||
|
||||
MIXIN: priority-queue
|
||||
|
|
@ -161,7 +161,7 @@ M: priority-queue heap-push* ( value key heap -- entry )
|
|||
[ swapd heap-push ] curry assoc-each ;
|
||||
|
||||
: >entry< ( entry -- key value )
|
||||
{ entry-value entry-key } get-slots ;
|
||||
[ value>> ] [ key>> ] bi ;
|
||||
|
||||
M: priority-queue heap-peek ( heap -- value key )
|
||||
data-first >entry< ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: inference.transforms.tests
|
||||
USING: sequences inference.transforms tools.test math kernel
|
||||
quotations inference ;
|
||||
quotations inference accessors combinators words arrays ;
|
||||
|
||||
: compose-n-quot <repetition> >quotation ;
|
||||
: compose-n compose-n-quot call ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel sequences sbufs vectors namespaces
|
||||
growable strings io classes continuations combinators
|
||||
io.styles io.streams.plain splitting
|
||||
io.streams.duplex byte-arrays sequences.private ;
|
||||
USING: math kernel sequences sbufs vectors namespaces growable
|
||||
strings io classes continuations combinators io.styles
|
||||
io.streams.plain splitting io.streams.duplex byte-arrays
|
||||
sequences.private accessors ;
|
||||
IN: io.encodings
|
||||
|
||||
! The encoding descriptor protocol
|
||||
|
|
@ -34,7 +34,7 @@ M: tuple-class <decoder> construct-empty <decoder> ;
|
|||
M: tuple <decoder> f decoder construct-boa ;
|
||||
|
||||
: >decoder< ( decoder -- stream encoding )
|
||||
{ decoder-stream decoder-code } get-slots ;
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
|
||||
: cr+ t swap set-decoder-cr ; inline
|
||||
|
||||
|
|
@ -108,7 +108,7 @@ M: tuple-class <encoder> construct-empty <encoder> ;
|
|||
M: tuple <encoder> encoder construct-boa ;
|
||||
|
||||
: >encoder< ( encoder -- stream encoding )
|
||||
{ encoder-stream encoder-code } get-slots ;
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
|
||||
M: encoder stream-write1
|
||||
>encoder< encode-char ;
|
||||
|
|
|
|||
|
|
@ -5,16 +5,18 @@ namespaces prettyprint sequences strings vectors words
|
|||
quotations inspector io.styles io combinators sorting
|
||||
splitting math.parser effects continuations debugger
|
||||
io.files io.streams.string vocabs io.encodings.utf8
|
||||
source-files classes hashtables compiler.errors compiler.units ;
|
||||
source-files classes hashtables compiler.errors compiler.units
|
||||
accessors ;
|
||||
IN: parser
|
||||
|
||||
TUPLE: lexer text line line-text line-length column ;
|
||||
|
||||
: next-line ( lexer -- )
|
||||
0 over set-lexer-column
|
||||
dup lexer-line over lexer-text ?nth over set-lexer-line-text
|
||||
dup lexer-line-text length over set-lexer-line-length
|
||||
dup lexer-line 1+ swap set-lexer-line ;
|
||||
dup [ line>> ] [ text>> ] bi ?nth >>line-text
|
||||
dup line-text>> length >>line-length
|
||||
[ 1+ ] change-line
|
||||
0 >>column
|
||||
drop ;
|
||||
|
||||
: <lexer> ( text -- lexer )
|
||||
0 { set-lexer-text set-lexer-line } lexer construct
|
||||
|
|
@ -159,8 +161,7 @@ TUPLE: parse-error file line col text ;
|
|||
|
||||
: <parse-error> ( msg -- error )
|
||||
file get
|
||||
lexer get
|
||||
{ lexer-line lexer-column lexer-line-text } get-slots
|
||||
lexer get [ line>> ] [ column>> ] [ line-text>> ] tri
|
||||
parse-error construct-boa
|
||||
[ set-delegate ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -84,10 +84,10 @@ PRIVATE>
|
|||
] ;
|
||||
|
||||
: >date< ( timestamp -- year month day )
|
||||
{ year>> month>> day>> } get-slots ;
|
||||
[ year>> ] [ month>> ] [ day>> ] tri ;
|
||||
|
||||
: >time< ( timestamp -- hour minute second )
|
||||
{ hour>> minute>> second>> } get-slots ;
|
||||
[ hour>> ] [ minute>> ] [ second>> ] tri ;
|
||||
|
||||
: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
|
||||
: years ( n -- dt ) instant swap >>year ;
|
||||
|
|
|
|||
|
|
@ -1,108 +0,0 @@
|
|||
|
||||
USING: kernel quotations help.syntax help.markup ;
|
||||
|
||||
IN: combinators.cleave
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "cleave-combinators" "Cleave Combinators"
|
||||
|
||||
"Basic cleavers:"
|
||||
|
||||
{ $subsection bi }
|
||||
{ $subsection tri }
|
||||
|
||||
"General cleave: "
|
||||
{ $subsection cleave }
|
||||
|
||||
"Cleave combinators for quotations with arity 2:"
|
||||
{ $subsection 2bi }
|
||||
{ $subsection 2tri }
|
||||
|
||||
{ $notes
|
||||
"From the Merriam-Webster Dictionary: "
|
||||
$nl
|
||||
{ $strong "cleave" }
|
||||
{ $list
|
||||
{ $emphasis "To divide by or as if by a cutting blow" }
|
||||
{ $emphasis "To separate into distinct parts and especially into "
|
||||
"groups having divergent views" } }
|
||||
$nl
|
||||
"The Joy programming language has a " { $emphasis "cleave" } " combinator." }
|
||||
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: bi
|
||||
|
||||
{ $values { "x" object }
|
||||
{ "p" quotation }
|
||||
{ "q" quotation }
|
||||
|
||||
{ "p(x)" "p applied to x" }
|
||||
{ "q(x)" "q applied to x" } } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: tri
|
||||
|
||||
{ $values { "x" object }
|
||||
{ "p" quotation }
|
||||
{ "q" quotation }
|
||||
{ "r" quotation }
|
||||
|
||||
{ "p(x)" "p applied to x" }
|
||||
{ "q(x)" "q applied to x" }
|
||||
{ "r(x)" "r applied to x" } } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: cleave
|
||||
|
||||
{ $code "( obj { q1 q2 ... qN } -- q1(obj) q2(obj) ... qN(obj) )" } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
{ bi tri cleave 2bi 2tri } related-words
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "spread-combinators" "Spread Combinators"
|
||||
|
||||
{ $subsection bi* }
|
||||
{ $subsection tri* }
|
||||
{ $subsection spread } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: bi*
|
||||
|
||||
{ $values { "x" object }
|
||||
{ "y" object }
|
||||
{ "p" quotation }
|
||||
{ "q" quotation }
|
||||
|
||||
{ "p(x)" "p applied to x" }
|
||||
{ "q(y)" "q applied to y" } } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: tri*
|
||||
|
||||
{ $values { "x" object }
|
||||
{ "y" object }
|
||||
{ "z" object }
|
||||
{ "p" quotation }
|
||||
{ "q" quotation }
|
||||
{ "r" quotation }
|
||||
|
||||
{ "p(x)" "p applied to x" }
|
||||
{ "q(y)" "q applied to y" }
|
||||
{ "r(z)" "r applied to z" } } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: spread
|
||||
|
||||
{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ;
|
||||
|
|
@ -18,9 +18,7 @@ $nl
|
|||
"Reading from the buffer:"
|
||||
{ $subsection buffer-peek }
|
||||
{ $subsection buffer-pop }
|
||||
{ $subsection buffer> }
|
||||
{ $subsection buffer>> }
|
||||
{ $subsection buffer-until }
|
||||
{ $subsection buffer-read }
|
||||
"Writing to the buffer:"
|
||||
{ $subsection extend-buffer }
|
||||
{ $subsection byte>buffer }
|
||||
|
|
@ -47,10 +45,6 @@ HELP: buffer-free
|
|||
{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." }
|
||||
{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
|
||||
|
||||
HELP: (buffer>>)
|
||||
{ $values { "buffer" buffer } { "byte-array" byte-array } }
|
||||
{ $description "Collects the entire contents of the buffer into a string." } ;
|
||||
|
||||
HELP: buffer-reset
|
||||
{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
|
||||
{ $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ;
|
||||
|
|
@ -67,17 +61,13 @@ HELP: buffer-end
|
|||
{ $values { "buffer" buffer } { "alien" alien } }
|
||||
{ $description "Outputs the memory address of the current fill-pointer." } ;
|
||||
|
||||
HELP: (buffer>)
|
||||
HELP: (buffer-read)
|
||||
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
|
||||
{ $description "Outputs a string of the first " { $snippet "n" } " characters at the buffer's current position. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
|
||||
{ $description "Outputs a byte array of the first " { $snippet "n" } " bytes at the buffer's current position. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;
|
||||
|
||||
HELP: buffer>
|
||||
HELP: buffer-read
|
||||
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
|
||||
{ $description "Collects a string of " { $snippet "n" } " characters starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
|
||||
|
||||
HELP: buffer>>
|
||||
{ $values { "buffer" buffer } { "byte-array" byte-array } }
|
||||
{ $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ;
|
||||
{ $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;
|
||||
|
||||
HELP: buffer-length
|
||||
{ $values { "buffer" buffer } { "n" "a non-negative integer" } }
|
||||
|
|
@ -103,7 +93,7 @@ HELP: check-overflow
|
|||
|
||||
HELP: >buffer
|
||||
{ $values { "byte-array" byte-array } { "buffer" buffer } }
|
||||
{ $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ;
|
||||
{ $description "Copies a byte array to the buffer's fill pointer, and advances it accordingly." } ;
|
||||
|
||||
HELP: byte>buffer
|
||||
{ $values { "byte" "a byte" } { "buffer" buffer } }
|
||||
|
|
@ -121,7 +111,3 @@ HELP: buffer-peek
|
|||
HELP: buffer-pop
|
||||
{ $values { "buffer" buffer } { "byte" "a byte" } }
|
||||
{ $description "Outputs the byte at the buffer position and advances the position." } ;
|
||||
|
||||
HELP: buffer-until
|
||||
{ $values { "separators" "a sequence of bytes" } { "buffer" buffer } { "byte-array" byte-array } { "separator" "a byte or " { $link f } } }
|
||||
{ $description "Searches the buffer for a byte appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: io.buffers.tests
|
||||
USING: alien alien.c-types io.buffers kernel kernel.private libc
|
||||
sequences tools.test namespaces byte-arrays strings ;
|
||||
sequences tools.test namespaces byte-arrays strings accessors ;
|
||||
|
||||
: buffer-set ( string buffer -- )
|
||||
over >byte-array over buffer-ptr byte-array>memory
|
||||
|
|
@ -9,24 +9,29 @@ sequences tools.test namespaces byte-arrays strings ;
|
|||
: string>buffer ( string -- buffer )
|
||||
dup length <buffer> tuck buffer-set ;
|
||||
|
||||
: buffer-read-all ( buffer -- byte-array )
|
||||
[ [ pos>> ] [ ptr>> ] bi <displaced-alien> ]
|
||||
[ buffer-length ] bi
|
||||
memory>byte-array ;
|
||||
|
||||
[ B{ } 65536 ] [
|
||||
65536 <buffer>
|
||||
dup (buffer>>)
|
||||
dup buffer-read-all
|
||||
over buffer-capacity
|
||||
rot buffer-free
|
||||
] unit-test
|
||||
|
||||
[ "hello world" "" ] [
|
||||
"hello world" string>buffer
|
||||
dup (buffer>>) >string
|
||||
dup buffer-read-all >string
|
||||
0 pick buffer-reset
|
||||
over (buffer>>) >string
|
||||
over buffer-read-all >string
|
||||
rot buffer-free
|
||||
] unit-test
|
||||
|
||||
[ "hello" ] [
|
||||
"hello world" string>buffer
|
||||
5 over buffer> >string swap buffer-free
|
||||
5 over buffer-read >string swap buffer-free
|
||||
] unit-test
|
||||
|
||||
[ 11 ] [
|
||||
|
|
@ -37,7 +42,7 @@ sequences tools.test namespaces byte-arrays strings ;
|
|||
[ "hello world" ] [
|
||||
"hello" 1024 <buffer> [ buffer-set ] keep
|
||||
" world" >byte-array over >buffer
|
||||
dup (buffer>>) >string swap buffer-free
|
||||
dup buffer-read-all >string swap buffer-free
|
||||
] unit-test
|
||||
|
||||
[ CHAR: e ] [
|
||||
|
|
@ -45,33 +50,8 @@ sequences tools.test namespaces byte-arrays strings ;
|
|||
1 over buffer-consume [ buffer-pop ] keep buffer-free
|
||||
] unit-test
|
||||
|
||||
[ "hello" CHAR: \r ] [
|
||||
"hello\rworld" string>buffer
|
||||
"\r" over buffer-until >r >string r>
|
||||
rot buffer-free
|
||||
] unit-test
|
||||
|
||||
[ "hello" CHAR: \r ] [
|
||||
"hello\rworld" string>buffer
|
||||
"\n\r" over buffer-until >r >string r>
|
||||
rot buffer-free
|
||||
] unit-test
|
||||
|
||||
[ "hello\rworld" f ] [
|
||||
"hello\rworld" string>buffer
|
||||
"X" over buffer-until >r >string r>
|
||||
rot buffer-free
|
||||
] unit-test
|
||||
|
||||
[ "hello" CHAR: \r "world" CHAR: \n ] [
|
||||
"hello\rworld\n" string>buffer
|
||||
[ "\r\n" swap buffer-until >r >string r> ] keep
|
||||
[ "\r\n" swap buffer-until >r >string r> ] keep
|
||||
buffer-free
|
||||
] unit-test
|
||||
|
||||
"hello world" string>buffer "b" set
|
||||
[ "hello world" ] [ 1000 "b" get buffer> >string ] unit-test
|
||||
[ "hello world" ] [ 1000 "b" get buffer-read >string ] unit-test
|
||||
"b" get buffer-free
|
||||
|
||||
100 <buffer> "b" set
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.buffers
|
||||
USING: alien alien.accessors alien.c-types alien.syntax kernel
|
||||
kernel.private libc math sequences byte-arrays strings hints ;
|
||||
kernel.private libc math sequences byte-arrays strings hints
|
||||
accessors ;
|
||||
|
||||
TUPLE: buffer size ptr fill pos ;
|
||||
|
||||
|
|
@ -37,46 +38,21 @@ TUPLE: buffer size ptr fill pos ;
|
|||
: buffer-pop ( buffer -- byte )
|
||||
dup buffer-peek 1 rot buffer-consume ;
|
||||
|
||||
: (buffer>) ( n buffer -- byte-array )
|
||||
[ dup buffer-fill swap buffer-pos - min ] keep
|
||||
: (buffer-read) ( n buffer -- byte-array )
|
||||
[ [ fill>> ] [ pos>> ] bi - min ] keep
|
||||
buffer@ swap memory>byte-array ;
|
||||
|
||||
: buffer> ( n buffer -- byte-array )
|
||||
[ (buffer>) ] 2keep buffer-consume ;
|
||||
|
||||
: (buffer>>) ( buffer -- byte-array )
|
||||
dup buffer-pos over buffer-ptr <displaced-alien>
|
||||
over buffer-fill rot buffer-pos - memory>byte-array ;
|
||||
|
||||
: buffer>> ( buffer -- byte-array )
|
||||
dup (buffer>>) 0 rot buffer-reset ;
|
||||
|
||||
: search-buffer-until ( start end alien separators -- n )
|
||||
[ >r swap alien-unsigned-1 r> memq? ] 2curry find* drop ;
|
||||
|
||||
HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
|
||||
|
||||
: finish-buffer-until ( buffer n -- byte-array separator )
|
||||
[
|
||||
over buffer-pos -
|
||||
over buffer>
|
||||
swap buffer-pop
|
||||
] [
|
||||
buffer>> f
|
||||
] if* ;
|
||||
|
||||
: buffer-until ( separators buffer -- byte-array separator )
|
||||
tuck { buffer-pos buffer-fill buffer-ptr } get-slots roll
|
||||
search-buffer-until finish-buffer-until ;
|
||||
: buffer-read ( n buffer -- byte-array )
|
||||
[ (buffer-read) ] [ buffer-consume ] 2bi ;
|
||||
|
||||
: buffer-length ( buffer -- n )
|
||||
dup buffer-fill swap buffer-pos - ;
|
||||
[ fill>> ] [ pos>> ] bi - ;
|
||||
|
||||
: buffer-capacity ( buffer -- n )
|
||||
dup buffer-size swap buffer-fill - ;
|
||||
[ size>> ] [ fill>> ] bi - ;
|
||||
|
||||
: buffer-empty? ( buffer -- ? )
|
||||
buffer-fill zero? ;
|
||||
fill>> zero? ;
|
||||
|
||||
: extend-buffer ( n buffer -- )
|
||||
2dup buffer-ptr swap realloc
|
||||
|
|
@ -93,7 +69,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
|
|||
: byte>buffer ( byte buffer -- )
|
||||
1 over check-overflow
|
||||
[ buffer-end 0 set-alien-unsigned-1 ] keep
|
||||
[ buffer-fill 1+ ] keep set-buffer-fill ;
|
||||
[ 1+ ] change-fill drop ;
|
||||
|
||||
: n>buffer ( n buffer -- )
|
||||
[ buffer-fill + ] keep
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ M: input-port stream-read1
|
|||
|
||||
: read-step ( count port -- byte-array/f )
|
||||
[ wait-to-read ] 2keep
|
||||
[ dupd buffer> ] unless-eof nip ;
|
||||
[ dupd buffer-read ] unless-eof nip ;
|
||||
|
||||
: read-loop ( count port accum -- )
|
||||
pick over length - dup 0 > [
|
||||
|
|
@ -101,38 +101,6 @@ M: input-port stream-read
|
|||
2nip
|
||||
] if ;
|
||||
|
||||
: read-until-step ( separators port -- byte-array/f separator/f )
|
||||
dup wait-to-read1
|
||||
dup port-eof? [
|
||||
f swap set-port-eof? drop f f
|
||||
] [
|
||||
buffer-until
|
||||
] if ;
|
||||
|
||||
: read-until-loop ( seps port accum -- separator/f )
|
||||
2over read-until-step over [
|
||||
>r over push-all r> dup [
|
||||
>r 3drop r>
|
||||
] [
|
||||
drop read-until-loop
|
||||
] if
|
||||
] [
|
||||
>r 2drop 2drop r>
|
||||
] if ;
|
||||
|
||||
M: input-port stream-read-until ( seps port -- byte-array/f sep/f )
|
||||
2dup read-until-step dup [
|
||||
>r 2nip r>
|
||||
] [
|
||||
over [
|
||||
drop BV{ } like
|
||||
[ read-until-loop ] keep
|
||||
B{ } like swap
|
||||
] [
|
||||
>r 2nip r>
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: input-port stream-read-partial ( max stream -- byte-array/f )
|
||||
>r 0 max >fixnum r> read-step ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: alien generic assocs kernel kernel.private math
|
|||
io.nonblocking sequences strings structs sbufs
|
||||
threads unix vectors io.buffers io.backend io.encodings
|
||||
io.streams.duplex math.parser continuations system libc
|
||||
qualified namespaces io.timeouts io.encodings.utf8 ;
|
||||
qualified namespaces io.timeouts io.encodings.utf8 accessors ;
|
||||
QUALIFIED: io
|
||||
IN: io.unix.backend
|
||||
|
||||
|
|
@ -13,7 +13,7 @@ MIXIN: unix-io
|
|||
! I/O tasks
|
||||
TUPLE: io-task port callbacks ;
|
||||
|
||||
: io-task-fd io-task-port port-handle ;
|
||||
: io-task-fd port>> handle>> ;
|
||||
|
||||
: <io-task> ( port continuation/f class -- task )
|
||||
>r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
|
||||
|
|
@ -35,9 +35,9 @@ GENERIC: io-task-container ( mx task -- hashtable )
|
|||
! I/O multiplexers
|
||||
TUPLE: mx fd reads writes ;
|
||||
|
||||
M: input-task io-task-container drop mx-reads ;
|
||||
M: input-task io-task-container drop reads>> ;
|
||||
|
||||
M: output-task io-task-container drop mx-writes ;
|
||||
M: output-task io-task-container drop writes>> ;
|
||||
|
||||
: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
|
||||
|
||||
|
|
@ -90,11 +90,11 @@ M: integer close-handle ( fd -- )
|
|||
close ;
|
||||
|
||||
: report-error ( error port -- )
|
||||
[ "Error on fd " % dup port-handle # ": " % swap % ] "" make
|
||||
swap set-port-error ;
|
||||
[ "Error on fd " % dup handle>> # ": " % swap % ] "" make
|
||||
>>error drop ;
|
||||
|
||||
: ignorable-error? ( n -- ? )
|
||||
dup EAGAIN number= swap EINTR number= or ;
|
||||
[ EAGAIN number= ] [ EINTR number= ] bi or ;
|
||||
|
||||
: defer-error ( port -- ? )
|
||||
#! Return t if it is an unrecoverable error.
|
||||
|
|
@ -110,26 +110,25 @@ M: integer close-handle ( fd -- )
|
|||
|
||||
: handle-timeout ( port mx assoc -- )
|
||||
>r swap port-handle r> delete-at* [
|
||||
"I/O operation cancelled" over io-task-port report-error
|
||||
"I/O operation cancelled" over port>> report-error
|
||||
pop-callbacks
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: cancel-io-tasks ( port mx -- )
|
||||
2dup
|
||||
dup mx-reads handle-timeout
|
||||
dup mx-writes handle-timeout ;
|
||||
[ dup reads>> handle-timeout ]
|
||||
[ dup writes>> handle-timeout ] 2bi ;
|
||||
|
||||
M: unix-io cancel-io ( port -- )
|
||||
mx get-global cancel-io-tasks ;
|
||||
|
||||
! Readers
|
||||
: reader-eof ( reader -- )
|
||||
dup buffer-empty? [ t over set-port-eof? ] when drop ;
|
||||
dup buffer-empty? [ t >>eof? ] when drop ;
|
||||
|
||||
: (refill) ( port -- n )
|
||||
dup port-handle over buffer-end rot buffer-capacity read ;
|
||||
[ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ;
|
||||
|
||||
: refill ( port -- ? )
|
||||
#! Return f if there is a recoverable error
|
||||
|
|
@ -158,7 +157,7 @@ M: input-port (wait-to-read)
|
|||
|
||||
! Writers
|
||||
: write-step ( port -- ? )
|
||||
dup port-handle over buffer@ pick buffer-length write
|
||||
dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write
|
||||
dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ;
|
||||
|
||||
TUPLE: write-task ;
|
||||
|
|
@ -167,7 +166,7 @@ TUPLE: write-task ;
|
|||
write-task <output-task> ;
|
||||
|
||||
M: write-task do-io-task
|
||||
io-task-port dup buffer-empty? over port-error or
|
||||
io-task-port dup [ buffer-empty? ] [ port-error ] bi or
|
||||
[ 0 swap buffer-reset t ] [ write-step ] if ;
|
||||
|
||||
: add-write-io-task ( port continuation -- )
|
||||
|
|
@ -193,7 +192,7 @@ M: unix-io (init-stdio) ( -- )
|
|||
TUPLE: mx-port mx ;
|
||||
|
||||
: <mx-port> ( mx -- port )
|
||||
dup mx-fd f mx-port <port>
|
||||
dup fd>> f mx-port <port>
|
||||
{ set-mx-port-mx set-delegate } mx-port construct ;
|
||||
|
||||
TUPLE: mx-task ;
|
||||
|
|
@ -202,7 +201,7 @@ TUPLE: mx-task ;
|
|||
f mx-task <io-task> ;
|
||||
|
||||
M: mx-task do-io-task
|
||||
io-task-port mx-port-mx 0 swap wait-for-events f ;
|
||||
port>> mx>> 0 swap wait-for-events f ;
|
||||
|
||||
: multiplexer-error ( n -- )
|
||||
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
bit-arrays sequences assocs unix math namespaces structs ;
|
||||
bit-arrays sequences assocs unix math namespaces structs
|
||||
accessors ;
|
||||
IN: io.unix.select
|
||||
|
||||
TUPLE: select-mx read-fdset write-fdset ;
|
||||
|
|
@ -14,11 +15,11 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
|
||||
: <select-mx> ( -- mx )
|
||||
select-mx construct-mx
|
||||
FD_SETSIZE 8 * <bit-array> over set-select-mx-read-fdset
|
||||
FD_SETSIZE 8 * <bit-array> over set-select-mx-write-fdset ;
|
||||
FD_SETSIZE 8 * <bit-array> >>read-fdset
|
||||
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
|
||||
|
||||
: clear-nth ( n seq -- ? )
|
||||
[ nth ] 2keep f -rot set-nth ;
|
||||
[ nth ] [ f -rot set-nth ] 2bi ;
|
||||
|
||||
: handle-fd ( fd task fdset mx -- )
|
||||
roll munge rot clear-nth
|
||||
|
|
@ -32,15 +33,16 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
{ mx-reads select-mx-read-fdset } get-slots ;
|
||||
[ reads>> ] [ read-fdset>> ] bi ;
|
||||
|
||||
: write-fdset/tasks
|
||||
{ mx-writes select-mx-write-fdset } get-slots ;
|
||||
[ writes>> ] [ write-fdset>> ] bi ;
|
||||
|
||||
: max-fd dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
|
||||
: max-fd ( assoc -- n )
|
||||
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
|
||||
|
||||
: num-fds ( mx -- n )
|
||||
dup mx-reads max-fd swap mx-writes max-fd max 1+ ;
|
||||
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
|
||||
|
||||
: init-fdsets ( mx -- nfds read write except )
|
||||
[ num-fds ] keep
|
||||
|
|
|
|||
|
|
@ -266,13 +266,13 @@ M: object local-rewrite* , ;
|
|||
] assoc-each local-rewrite* \ call , ;
|
||||
|
||||
M: let local-rewrite*
|
||||
{ body>> bindings>> } get-slots let-rewrite ;
|
||||
[ body>> ] [ bindings>> ] bi let-rewrite ;
|
||||
|
||||
M: let* local-rewrite*
|
||||
{ body>> bindings>> } get-slots let-rewrite ;
|
||||
[ body>> ] [ bindings>> ] bi let-rewrite ;
|
||||
|
||||
M: wlet local-rewrite*
|
||||
{ body>> bindings>> } get-slots
|
||||
[ body>> ] [ bindings>> ] bi
|
||||
[ [ ] curry ] assoc-map
|
||||
let-rewrite ;
|
||||
|
||||
|
|
@ -340,7 +340,7 @@ M: lambda pprint*
|
|||
|
||||
: pprint-let ( let word -- )
|
||||
pprint-word
|
||||
{ body>> bindings>> } get-slots
|
||||
[ body>> ] [ bindings>> ] bi
|
||||
\ | pprint-word
|
||||
t <inset
|
||||
<block
|
||||
|
|
|
|||
Loading…
Reference in New Issue