Phasing out get-slots and cleaning up some code
parent
2aafe074b2
commit
aec04edbda
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: classes classes.union words kernel sequences
|
USING: classes classes.union words kernel sequences
|
||||||
definitions combinators arrays ;
|
definitions combinators arrays accessors ;
|
||||||
IN: classes.mixin
|
IN: classes.mixin
|
||||||
|
|
||||||
PREDICATE: mixin-class < union-class "mixin" word-prop ;
|
PREDICATE: mixin-class < union-class "mixin" word-prop ;
|
||||||
|
@ -53,8 +53,7 @@ M: mixin-instance equal?
|
||||||
} cond 2nip ;
|
} cond 2nip ;
|
||||||
|
|
||||||
M: mixin-instance hashcode*
|
M: mixin-instance hashcode*
|
||||||
{ mixin-instance-class mixin-instance-mixin } get-slots
|
[ class>> ] [ mixin>> ] bi 2array hashcode* ;
|
||||||
2array hashcode* ;
|
|
||||||
|
|
||||||
: <mixin-instance> ( class mixin -- definition )
|
: <mixin-instance> ( class mixin -- definition )
|
||||||
{ set-mixin-instance-class set-mixin-instance-mixin }
|
{ set-mixin-instance-class set-mixin-instance-mixin }
|
||||||
|
|
|
@ -20,7 +20,7 @@ hashtables sorting ;
|
||||||
: spread>quot ( seq -- quot )
|
: spread>quot ( seq -- quot )
|
||||||
[ length [ >r ] <repetition> concat ]
|
[ length [ >r ] <repetition> concat ]
|
||||||
[ [ [ r> ] prepend ] map concat ] bi
|
[ [ [ r> ] prepend ] map concat ] bi
|
||||||
compose ;
|
append ;
|
||||||
|
|
||||||
: spread ( seq -- )
|
: spread ( seq -- )
|
||||||
spread>quot call ;
|
spread>quot call ;
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2003, 2008 Slava Pestov.
|
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays vectors kernel kernel.private sequences
|
USING: arrays vectors kernel kernel.private sequences
|
||||||
namespaces math splitting sorting quotations assocs ;
|
namespaces math splitting sorting quotations assocs
|
||||||
|
combinators accessors ;
|
||||||
IN: continuations
|
IN: continuations
|
||||||
|
|
||||||
SYMBOL: error
|
SYMBOL: error
|
||||||
|
@ -43,12 +44,12 @@ C: <continuation> continuation
|
||||||
|
|
||||||
: >continuation< ( continuation -- data call retain name catch )
|
: >continuation< ( continuation -- data call retain name catch )
|
||||||
{
|
{
|
||||||
continuation-data
|
[ data>> ]
|
||||||
continuation-call
|
[ call>> ]
|
||||||
continuation-retain
|
[ retain>> ]
|
||||||
continuation-name
|
[ name>> ]
|
||||||
continuation-catch
|
[ catch>> ]
|
||||||
} get-slots ;
|
} cleave ;
|
||||||
|
|
||||||
: ifcc ( capture restore -- )
|
: ifcc ( capture restore -- )
|
||||||
#! After continuation is being captured, the stacks looks
|
#! After continuation is being captured, the stacks looks
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! Slava Pestov.
|
! Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel math sequences arrays assocs sequences.private
|
USING: kernel math sequences arrays assocs sequences.private
|
||||||
growable ;
|
growable accessors ;
|
||||||
IN: heaps
|
IN: heaps
|
||||||
|
|
||||||
MIXIN: priority-queue
|
MIXIN: priority-queue
|
||||||
|
@ -161,7 +161,7 @@ M: priority-queue heap-push* ( value key heap -- entry )
|
||||||
[ swapd heap-push ] curry assoc-each ;
|
[ swapd heap-push ] curry assoc-each ;
|
||||||
|
|
||||||
: >entry< ( entry -- key value )
|
: >entry< ( entry -- key value )
|
||||||
{ entry-value entry-key } get-slots ;
|
[ value>> ] [ key>> ] bi ;
|
||||||
|
|
||||||
M: priority-queue heap-peek ( heap -- value key )
|
M: priority-queue heap-peek ( heap -- value key )
|
||||||
data-first >entry< ;
|
data-first >entry< ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
IN: inference.transforms.tests
|
IN: inference.transforms.tests
|
||||||
USING: sequences inference.transforms tools.test math kernel
|
USING: sequences inference.transforms tools.test math kernel
|
||||||
quotations inference ;
|
quotations inference accessors combinators words arrays ;
|
||||||
|
|
||||||
: compose-n-quot <repetition> >quotation ;
|
: compose-n-quot <repetition> >quotation ;
|
||||||
: compose-n compose-n-quot call ;
|
: compose-n compose-n-quot call ;
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
! Copyright (C) 2008 Daniel Ehrenberg.
|
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: math kernel sequences sbufs vectors namespaces
|
USING: math kernel sequences sbufs vectors namespaces growable
|
||||||
growable strings io classes continuations combinators
|
strings io classes continuations combinators io.styles
|
||||||
io.styles io.streams.plain splitting
|
io.streams.plain splitting io.streams.duplex byte-arrays
|
||||||
io.streams.duplex byte-arrays sequences.private ;
|
sequences.private accessors ;
|
||||||
IN: io.encodings
|
IN: io.encodings
|
||||||
|
|
||||||
! The encoding descriptor protocol
|
! The encoding descriptor protocol
|
||||||
|
@ -34,7 +34,7 @@ M: tuple-class <decoder> construct-empty <decoder> ;
|
||||||
M: tuple <decoder> f decoder construct-boa ;
|
M: tuple <decoder> f decoder construct-boa ;
|
||||||
|
|
||||||
: >decoder< ( decoder -- stream encoding )
|
: >decoder< ( decoder -- stream encoding )
|
||||||
{ decoder-stream decoder-code } get-slots ;
|
[ stream>> ] [ code>> ] bi ;
|
||||||
|
|
||||||
: cr+ t swap set-decoder-cr ; inline
|
: cr+ t swap set-decoder-cr ; inline
|
||||||
|
|
||||||
|
@ -108,7 +108,7 @@ M: tuple-class <encoder> construct-empty <encoder> ;
|
||||||
M: tuple <encoder> encoder construct-boa ;
|
M: tuple <encoder> encoder construct-boa ;
|
||||||
|
|
||||||
: >encoder< ( encoder -- stream encoding )
|
: >encoder< ( encoder -- stream encoding )
|
||||||
{ encoder-stream encoder-code } get-slots ;
|
[ stream>> ] [ code>> ] bi ;
|
||||||
|
|
||||||
M: encoder stream-write1
|
M: encoder stream-write1
|
||||||
>encoder< encode-char ;
|
>encoder< encode-char ;
|
||||||
|
|
|
@ -5,16 +5,18 @@ namespaces prettyprint sequences strings vectors words
|
||||||
quotations inspector io.styles io combinators sorting
|
quotations inspector io.styles io combinators sorting
|
||||||
splitting math.parser effects continuations debugger
|
splitting math.parser effects continuations debugger
|
||||||
io.files io.streams.string vocabs io.encodings.utf8
|
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
|
IN: parser
|
||||||
|
|
||||||
TUPLE: lexer text line line-text line-length column ;
|
TUPLE: lexer text line line-text line-length column ;
|
||||||
|
|
||||||
: next-line ( lexer -- )
|
: next-line ( lexer -- )
|
||||||
0 over set-lexer-column
|
dup [ line>> ] [ text>> ] bi ?nth >>line-text
|
||||||
dup lexer-line over lexer-text ?nth over set-lexer-line-text
|
dup line-text>> length >>line-length
|
||||||
dup lexer-line-text length over set-lexer-line-length
|
[ 1+ ] change-line
|
||||||
dup lexer-line 1+ swap set-lexer-line ;
|
0 >>column
|
||||||
|
drop ;
|
||||||
|
|
||||||
: <lexer> ( text -- lexer )
|
: <lexer> ( text -- lexer )
|
||||||
0 { set-lexer-text set-lexer-line } lexer construct
|
0 { set-lexer-text set-lexer-line } lexer construct
|
||||||
|
@ -159,8 +161,7 @@ TUPLE: parse-error file line col text ;
|
||||||
|
|
||||||
: <parse-error> ( msg -- error )
|
: <parse-error> ( msg -- error )
|
||||||
file get
|
file get
|
||||||
lexer get
|
lexer get [ line>> ] [ column>> ] [ line-text>> ] tri
|
||||||
{ lexer-line lexer-column lexer-line-text } get-slots
|
|
||||||
parse-error construct-boa
|
parse-error construct-boa
|
||||||
[ set-delegate ] keep ;
|
[ set-delegate ] keep ;
|
||||||
|
|
||||||
|
|
|
@ -84,10 +84,10 @@ PRIVATE>
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
: >date< ( timestamp -- year month day )
|
: >date< ( timestamp -- year month day )
|
||||||
{ year>> month>> day>> } get-slots ;
|
[ year>> ] [ month>> ] [ day>> ] tri ;
|
||||||
|
|
||||||
: >time< ( timestamp -- hour minute second )
|
: >time< ( timestamp -- hour minute second )
|
||||||
{ hour>> minute>> second>> } get-slots ;
|
[ hour>> ] [ minute>> ] [ second>> ] tri ;
|
||||||
|
|
||||||
: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
|
: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
|
||||||
: years ( n -- dt ) instant swap >>year ;
|
: 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:"
|
"Reading from the buffer:"
|
||||||
{ $subsection buffer-peek }
|
{ $subsection buffer-peek }
|
||||||
{ $subsection buffer-pop }
|
{ $subsection buffer-pop }
|
||||||
{ $subsection buffer> }
|
{ $subsection buffer-read }
|
||||||
{ $subsection buffer>> }
|
|
||||||
{ $subsection buffer-until }
|
|
||||||
"Writing to the buffer:"
|
"Writing to the buffer:"
|
||||||
{ $subsection extend-buffer }
|
{ $subsection extend-buffer }
|
||||||
{ $subsection byte>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." }
|
{ $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." } ;
|
{ $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
|
HELP: buffer-reset
|
||||||
{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
|
{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
|
||||||
{ $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ;
|
{ $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 } }
|
{ $values { "buffer" buffer } { "alien" alien } }
|
||||||
{ $description "Outputs the memory address of the current fill-pointer." } ;
|
{ $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 } }
|
{ $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 } }
|
{ $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." } ;
|
{ $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>>
|
|
||||||
{ $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." } ;
|
|
||||||
|
|
||||||
HELP: buffer-length
|
HELP: buffer-length
|
||||||
{ $values { "buffer" buffer } { "n" "a non-negative integer" } }
|
{ $values { "buffer" buffer } { "n" "a non-negative integer" } }
|
||||||
|
@ -103,7 +93,7 @@ HELP: check-overflow
|
||||||
|
|
||||||
HELP: >buffer
|
HELP: >buffer
|
||||||
{ $values { "byte-array" byte-array } { "buffer" 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
|
HELP: byte>buffer
|
||||||
{ $values { "byte" "a byte" } { "buffer" buffer } }
|
{ $values { "byte" "a byte" } { "buffer" buffer } }
|
||||||
|
@ -121,7 +111,3 @@ HELP: buffer-peek
|
||||||
HELP: buffer-pop
|
HELP: buffer-pop
|
||||||
{ $values { "buffer" buffer } { "byte" "a byte" } }
|
{ $values { "buffer" buffer } { "byte" "a byte" } }
|
||||||
{ $description "Outputs the byte at the buffer position and advances the position." } ;
|
{ $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
|
IN: io.buffers.tests
|
||||||
USING: alien alien.c-types io.buffers kernel kernel.private libc
|
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 -- )
|
: buffer-set ( string buffer -- )
|
||||||
over >byte-array over buffer-ptr byte-array>memory
|
over >byte-array over buffer-ptr byte-array>memory
|
||||||
|
@ -9,24 +9,29 @@ sequences tools.test namespaces byte-arrays strings ;
|
||||||
: string>buffer ( string -- buffer )
|
: string>buffer ( string -- buffer )
|
||||||
dup length <buffer> tuck buffer-set ;
|
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 ] [
|
[ B{ } 65536 ] [
|
||||||
65536 <buffer>
|
65536 <buffer>
|
||||||
dup (buffer>>)
|
dup buffer-read-all
|
||||||
over buffer-capacity
|
over buffer-capacity
|
||||||
rot buffer-free
|
rot buffer-free
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "hello world" "" ] [
|
[ "hello world" "" ] [
|
||||||
"hello world" string>buffer
|
"hello world" string>buffer
|
||||||
dup (buffer>>) >string
|
dup buffer-read-all >string
|
||||||
0 pick buffer-reset
|
0 pick buffer-reset
|
||||||
over (buffer>>) >string
|
over buffer-read-all >string
|
||||||
rot buffer-free
|
rot buffer-free
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "hello" ] [
|
[ "hello" ] [
|
||||||
"hello world" string>buffer
|
"hello world" string>buffer
|
||||||
5 over buffer> >string swap buffer-free
|
5 over buffer-read >string swap buffer-free
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ 11 ] [
|
[ 11 ] [
|
||||||
|
@ -37,7 +42,7 @@ sequences tools.test namespaces byte-arrays strings ;
|
||||||
[ "hello world" ] [
|
[ "hello world" ] [
|
||||||
"hello" 1024 <buffer> [ buffer-set ] keep
|
"hello" 1024 <buffer> [ buffer-set ] keep
|
||||||
" world" >byte-array over >buffer
|
" world" >byte-array over >buffer
|
||||||
dup (buffer>>) >string swap buffer-free
|
dup buffer-read-all >string swap buffer-free
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ CHAR: e ] [
|
[ CHAR: e ] [
|
||||||
|
@ -45,33 +50,8 @@ sequences tools.test namespaces byte-arrays strings ;
|
||||||
1 over buffer-consume [ buffer-pop ] keep buffer-free
|
1 over buffer-consume [ buffer-pop ] keep buffer-free
|
||||||
] unit-test
|
] 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" 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
|
"b" get buffer-free
|
||||||
|
|
||||||
100 <buffer> "b" set
|
100 <buffer> "b" set
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: io.buffers
|
IN: io.buffers
|
||||||
USING: alien alien.accessors alien.c-types alien.syntax kernel
|
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 ;
|
TUPLE: buffer size ptr fill pos ;
|
||||||
|
|
||||||
|
@ -37,46 +38,21 @@ TUPLE: buffer size ptr fill pos ;
|
||||||
: buffer-pop ( buffer -- byte )
|
: buffer-pop ( buffer -- byte )
|
||||||
dup buffer-peek 1 rot buffer-consume ;
|
dup buffer-peek 1 rot buffer-consume ;
|
||||||
|
|
||||||
: (buffer>) ( n buffer -- byte-array )
|
: (buffer-read) ( n buffer -- byte-array )
|
||||||
[ dup buffer-fill swap buffer-pos - min ] keep
|
[ [ fill>> ] [ pos>> ] bi - min ] keep
|
||||||
buffer@ swap memory>byte-array ;
|
buffer@ swap memory>byte-array ;
|
||||||
|
|
||||||
: buffer> ( n buffer -- byte-array )
|
: buffer-read ( n buffer -- byte-array )
|
||||||
[ (buffer>) ] 2keep buffer-consume ;
|
[ (buffer-read) ] [ buffer-consume ] 2bi ;
|
||||||
|
|
||||||
: (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-length ( buffer -- n )
|
: buffer-length ( buffer -- n )
|
||||||
dup buffer-fill swap buffer-pos - ;
|
[ fill>> ] [ pos>> ] bi - ;
|
||||||
|
|
||||||
: buffer-capacity ( buffer -- n )
|
: buffer-capacity ( buffer -- n )
|
||||||
dup buffer-size swap buffer-fill - ;
|
[ size>> ] [ fill>> ] bi - ;
|
||||||
|
|
||||||
: buffer-empty? ( buffer -- ? )
|
: buffer-empty? ( buffer -- ? )
|
||||||
buffer-fill zero? ;
|
fill>> zero? ;
|
||||||
|
|
||||||
: extend-buffer ( n buffer -- )
|
: extend-buffer ( n buffer -- )
|
||||||
2dup buffer-ptr swap realloc
|
2dup buffer-ptr swap realloc
|
||||||
|
@ -93,7 +69,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
|
||||||
: byte>buffer ( byte buffer -- )
|
: byte>buffer ( byte buffer -- )
|
||||||
1 over check-overflow
|
1 over check-overflow
|
||||||
[ buffer-end 0 set-alien-unsigned-1 ] keep
|
[ buffer-end 0 set-alien-unsigned-1 ] keep
|
||||||
[ buffer-fill 1+ ] keep set-buffer-fill ;
|
[ 1+ ] change-fill drop ;
|
||||||
|
|
||||||
: n>buffer ( n buffer -- )
|
: n>buffer ( n buffer -- )
|
||||||
[ buffer-fill + ] keep
|
[ buffer-fill + ] keep
|
||||||
|
|
|
@ -73,7 +73,7 @@ M: input-port stream-read1
|
||||||
|
|
||||||
: read-step ( count port -- byte-array/f )
|
: read-step ( count port -- byte-array/f )
|
||||||
[ wait-to-read ] 2keep
|
[ wait-to-read ] 2keep
|
||||||
[ dupd buffer> ] unless-eof nip ;
|
[ dupd buffer-read ] unless-eof nip ;
|
||||||
|
|
||||||
: read-loop ( count port accum -- )
|
: read-loop ( count port accum -- )
|
||||||
pick over length - dup 0 > [
|
pick over length - dup 0 > [
|
||||||
|
@ -101,38 +101,6 @@ M: input-port stream-read
|
||||||
2nip
|
2nip
|
||||||
] if ;
|
] 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 )
|
M: input-port stream-read-partial ( max stream -- byte-array/f )
|
||||||
>r 0 max >fixnum r> read-step ;
|
>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
|
io.nonblocking sequences strings structs sbufs
|
||||||
threads unix vectors io.buffers io.backend io.encodings
|
threads unix vectors io.buffers io.backend io.encodings
|
||||||
io.streams.duplex math.parser continuations system libc
|
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
|
QUALIFIED: io
|
||||||
IN: io.unix.backend
|
IN: io.unix.backend
|
||||||
|
|
||||||
|
@ -13,7 +13,7 @@ MIXIN: unix-io
|
||||||
! I/O tasks
|
! I/O tasks
|
||||||
TUPLE: io-task port callbacks ;
|
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 )
|
: <io-task> ( port continuation/f class -- task )
|
||||||
>r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
|
>r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
|
||||||
|
@ -35,9 +35,9 @@ GENERIC: io-task-container ( mx task -- hashtable )
|
||||||
! I/O multiplexers
|
! I/O multiplexers
|
||||||
TUPLE: mx fd reads writes ;
|
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 ;
|
: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
|
||||||
|
|
||||||
|
@ -90,11 +90,11 @@ M: integer close-handle ( fd -- )
|
||||||
close ;
|
close ;
|
||||||
|
|
||||||
: report-error ( error port -- )
|
: report-error ( error port -- )
|
||||||
[ "Error on fd " % dup port-handle # ": " % swap % ] "" make
|
[ "Error on fd " % dup handle>> # ": " % swap % ] "" make
|
||||||
swap set-port-error ;
|
>>error drop ;
|
||||||
|
|
||||||
: ignorable-error? ( n -- ? )
|
: ignorable-error? ( n -- ? )
|
||||||
dup EAGAIN number= swap EINTR number= or ;
|
[ EAGAIN number= ] [ EINTR number= ] bi or ;
|
||||||
|
|
||||||
: defer-error ( port -- ? )
|
: defer-error ( port -- ? )
|
||||||
#! Return t if it is an unrecoverable error.
|
#! Return t if it is an unrecoverable error.
|
||||||
|
@ -110,26 +110,25 @@ M: integer close-handle ( fd -- )
|
||||||
|
|
||||||
: handle-timeout ( port mx assoc -- )
|
: handle-timeout ( port mx assoc -- )
|
||||||
>r swap port-handle r> delete-at* [
|
>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
|
pop-callbacks
|
||||||
] [
|
] [
|
||||||
2drop
|
2drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: cancel-io-tasks ( port mx -- )
|
: cancel-io-tasks ( port mx -- )
|
||||||
2dup
|
[ dup reads>> handle-timeout ]
|
||||||
dup mx-reads handle-timeout
|
[ dup writes>> handle-timeout ] 2bi ;
|
||||||
dup mx-writes handle-timeout ;
|
|
||||||
|
|
||||||
M: unix-io cancel-io ( port -- )
|
M: unix-io cancel-io ( port -- )
|
||||||
mx get-global cancel-io-tasks ;
|
mx get-global cancel-io-tasks ;
|
||||||
|
|
||||||
! Readers
|
! Readers
|
||||||
: reader-eof ( reader -- )
|
: reader-eof ( reader -- )
|
||||||
dup buffer-empty? [ t over set-port-eof? ] when drop ;
|
dup buffer-empty? [ t >>eof? ] when drop ;
|
||||||
|
|
||||||
: (refill) ( port -- n )
|
: (refill) ( port -- n )
|
||||||
dup port-handle over buffer-end rot buffer-capacity read ;
|
[ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ;
|
||||||
|
|
||||||
: refill ( port -- ? )
|
: refill ( port -- ? )
|
||||||
#! Return f if there is a recoverable error
|
#! Return f if there is a recoverable error
|
||||||
|
@ -158,7 +157,7 @@ M: input-port (wait-to-read)
|
||||||
|
|
||||||
! Writers
|
! Writers
|
||||||
: write-step ( port -- ? )
|
: 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 ;
|
dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ;
|
||||||
|
|
||||||
TUPLE: write-task ;
|
TUPLE: write-task ;
|
||||||
|
@ -167,7 +166,7 @@ TUPLE: write-task ;
|
||||||
write-task <output-task> ;
|
write-task <output-task> ;
|
||||||
|
|
||||||
M: write-task do-io-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 ;
|
[ 0 swap buffer-reset t ] [ write-step ] if ;
|
||||||
|
|
||||||
: add-write-io-task ( port continuation -- )
|
: add-write-io-task ( port continuation -- )
|
||||||
|
@ -193,7 +192,7 @@ M: unix-io (init-stdio) ( -- )
|
||||||
TUPLE: mx-port mx ;
|
TUPLE: mx-port mx ;
|
||||||
|
|
||||||
: <mx-port> ( mx -- port )
|
: <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 ;
|
{ set-mx-port-mx set-delegate } mx-port construct ;
|
||||||
|
|
||||||
TUPLE: mx-task ;
|
TUPLE: mx-task ;
|
||||||
|
@ -202,7 +201,7 @@ TUPLE: mx-task ;
|
||||||
f mx-task <io-task> ;
|
f mx-task <io-task> ;
|
||||||
|
|
||||||
M: mx-task do-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 -- )
|
: multiplexer-error ( n -- )
|
||||||
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
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
|
IN: io.unix.select
|
||||||
|
|
||||||
TUPLE: select-mx read-fdset write-fdset ;
|
TUPLE: select-mx read-fdset write-fdset ;
|
||||||
|
@ -14,11 +15,11 @@ TUPLE: select-mx read-fdset write-fdset ;
|
||||||
|
|
||||||
: <select-mx> ( -- mx )
|
: <select-mx> ( -- mx )
|
||||||
select-mx construct-mx
|
select-mx construct-mx
|
||||||
FD_SETSIZE 8 * <bit-array> over set-select-mx-read-fdset
|
FD_SETSIZE 8 * <bit-array> >>read-fdset
|
||||||
FD_SETSIZE 8 * <bit-array> over set-select-mx-write-fdset ;
|
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
|
||||||
|
|
||||||
: clear-nth ( n seq -- ? )
|
: clear-nth ( n seq -- ? )
|
||||||
[ nth ] 2keep f -rot set-nth ;
|
[ nth ] [ f -rot set-nth ] 2bi ;
|
||||||
|
|
||||||
: handle-fd ( fd task fdset mx -- )
|
: handle-fd ( fd task fdset mx -- )
|
||||||
roll munge rot clear-nth
|
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 ;
|
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||||
|
|
||||||
: read-fdset/tasks
|
: read-fdset/tasks
|
||||||
{ mx-reads select-mx-read-fdset } get-slots ;
|
[ reads>> ] [ read-fdset>> ] bi ;
|
||||||
|
|
||||||
: write-fdset/tasks
|
: 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 )
|
: 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 )
|
: init-fdsets ( mx -- nfds read write except )
|
||||||
[ num-fds ] keep
|
[ num-fds ] keep
|
||||||
|
|
|
@ -266,13 +266,13 @@ M: object local-rewrite* , ;
|
||||||
] assoc-each local-rewrite* \ call , ;
|
] assoc-each local-rewrite* \ call , ;
|
||||||
|
|
||||||
M: let local-rewrite*
|
M: let local-rewrite*
|
||||||
{ body>> bindings>> } get-slots let-rewrite ;
|
[ body>> ] [ bindings>> ] bi let-rewrite ;
|
||||||
|
|
||||||
M: let* local-rewrite*
|
M: let* local-rewrite*
|
||||||
{ body>> bindings>> } get-slots let-rewrite ;
|
[ body>> ] [ bindings>> ] bi let-rewrite ;
|
||||||
|
|
||||||
M: wlet local-rewrite*
|
M: wlet local-rewrite*
|
||||||
{ body>> bindings>> } get-slots
|
[ body>> ] [ bindings>> ] bi
|
||||||
[ [ ] curry ] assoc-map
|
[ [ ] curry ] assoc-map
|
||||||
let-rewrite ;
|
let-rewrite ;
|
||||||
|
|
||||||
|
@ -340,7 +340,7 @@ M: lambda pprint*
|
||||||
|
|
||||||
: pprint-let ( let word -- )
|
: pprint-let ( let word -- )
|
||||||
pprint-word
|
pprint-word
|
||||||
{ body>> bindings>> } get-slots
|
[ body>> ] [ bindings>> ] bi
|
||||||
\ | pprint-word
|
\ | pprint-word
|
||||||
t <inset
|
t <inset
|
||||||
<block
|
<block
|
||||||
|
|
Loading…
Reference in New Issue