steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Aaron Schaefer 2008-03-06 21:12:36 -05:00
parent 5c62133688 68f1b9432f
commit 82cb257118
531 changed files with 6321 additions and 5295 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/alien-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: alien.tests
USING: alien alien.accessors byte-arrays arrays kernel
kernel.private namespaces tools.test sequences libc math system
prettyprint ;

2
core/alien/c-types/c-types-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc ;

5
core/alien/c-types/c-types.factor
View File

@ -4,7 +4,7 @@ USING: bit-arrays byte-arrays float-arrays arrays
generator.registers assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
system compiler.units ;
system compiler.units io.files io.encodings.binary ;
IN: alien.c-types
DEFER: <int>
@ -273,6 +273,9 @@ M: long-long-type box-return ( type -- )
r> add*
] when ;
: malloc-file-contents ( path -- alien )
binary file-contents >byte-array malloc-byte-array ;
[
[ alien-cell ]
[ set-alien-cell ]

2
core/alien/compiler/compiler-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: alien.compiler.tests
USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects

2
core/alien/structs/structs-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces ;

2
core/arrays/arrays-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays kernel sequences sequences.private growable
tools.test vectors layouts system math vectors.private ;
IN: temporary
IN: arrays.tests
[ -2 { "a" "b" "c" } nth ] must-fail
[ 10 { "a" "b" "c" } nth ] must-fail

2
core/assocs/assocs-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: assocs.tests
USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;

2
core/bit-arrays/bit-arrays-tests.factor
View File

@ -1,6 +1,6 @@
USING: sequences arrays bit-arrays kernel tools.test math
random ;
IN: temporary
IN: bit-arrays.tests
[ 100 ] [ 100 <bit-array> length ] unit-test

2
core/bit-vectors/bit-vectors-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: bit-vectors.tests
USING: tools.test bit-vectors vectors sequences kernel math ;
[ 0 ] [ 123 <bit-vector> length ] unit-test

2
core/bootstrap/image/image-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test ;
\ ' must-infer

4
core/bootstrap/image/image.factor
View File

@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts
splitting growable classes tuples words.private
io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private
sequences.private combinators ;
sequences.private combinators io.encodings.binary ;
IN: bootstrap.image
: my-arch ( -- arch )
@ -416,7 +416,7 @@ M: curry '
"Writing image to " write
architecture get boot-image-name resource-path
dup write "..." print flush
[ (write-image) ] with-file-writer ;
binary <file-writer> [ (write-image) ] with-stream ;
PRIVATE>

1
core/bootstrap/primitives.factor
View File

@ -623,6 +623,7 @@ builtins get num-tags get tail f union-class define-class
{ "fopen" "io.streams.c" }
{ "fgetc" "io.streams.c" }
{ "fread" "io.streams.c" }
{ "fputc" "io.streams.c" }
{ "fwrite" "io.streams.c" }
{ "fflush" "io.streams.c" }
{ "fclose" "io.streams.c" }

2
core/boxes/boxes-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: boxes.tests
USING: boxes namespaces tools.test ;
[ ] [ <box> "b" set ] unit-test

3
core/boxes/boxes.factor
View File

@ -19,3 +19,6 @@ TUPLE: box value full? ;
: ?box ( box -- value/f ? )
dup box-full? [ box> t ] [ drop f f ] if ;
: if-box? ( box quot -- )
>r ?box r> [ drop ] if ; inline

2
core/byte-arrays/byte-arrays-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: byte-arrays.tests
USING: tools.test byte-arrays ;
[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test

2
core/byte-vectors/byte-vectors-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: byte-vectors.tests
USING: tools.test byte-vectors vectors sequences kernel ;
[ 0 ] [ 123 <byte-vector> length ] unit-test

20
core/classes/classes-tests.factor
View File

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes io.streams.string
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units ;
IN: temporary
IN: classes.tests
H{ } "s" set
@ -56,13 +56,13 @@ UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
DEFER: bah
FORGET: bah
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
! Test generic see and parsing
[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ]
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test
! Test redefinition of classes
@ -78,7 +78,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ union-1 ] [ fixnum float class-or ] unit-test
"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test
@ -86,7 +86,7 @@ M: union-1 generic-update-test drop "union-1" ;
[ object ] [ fixnum float class-or ] unit-test
"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval
"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
@ -126,7 +126,7 @@ INSTANCE: integer mx1
[ t ] [ mx1 integer class< ] unit-test
[ t ] [ mx1 number class< ] unit-test
"IN: temporary USE: arrays INSTANCE: array mx1" eval
"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
[ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test
@ -157,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ quotation redefine-bug-2 class< ] unit-test
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
@ -185,7 +185,7 @@ DEFER: mixin-forget-test-g
[ ] [
{
"USING: sequences ;"
"IN: temporary"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
@ -200,7 +200,7 @@ DEFER: mixin-forget-test-g
[ ] [
{
"USING: hashtables ;"
"IN: temporary"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"

2
core/combinators/combinators-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: combinators.tests
USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words ;

2
core/command-line/command-line-tests.factor
View File

@ -1,5 +1,5 @@
USING: namespaces tools.test kernel command-line ;
IN: temporary
IN: command-line.tests
[
[ f ] [ "-no-user-init" cli-arg ] unit-test

2
core/compiler/tests/curry.factor
View File

@ -1,6 +1,6 @@
USING: tools.test quotations math kernel sequences
assocs namespaces compiler.units ;
IN: temporary
IN: compiler.tests
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test

2
core/compiler/tests/float.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: compiler.tests
USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ;

2
core/compiler/tests/intrinsics.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: compiler.tests
USING: arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays

2
core/compiler/tests/simple.factor
View File

@ -1,7 +1,7 @@
USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
alien arrays memory ;
IN: temporary
IN: compiler.tests
! Test empty word
[ ] [ [ ] compile-call ] unit-test

2
core/compiler/tests/stack-trace.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: compiler.tests
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting sorting ;

2
core/compiler/tests/templates-early.factor
View File

@ -1,5 +1,5 @@
! Testing templates machinery without compiling anything
IN: temporary
IN: compiler.tests
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units ;

2
core/compiler/tests/templates.factor
View File

@ -4,7 +4,7 @@ hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators ;
IN: temporary
IN: compiler.tests
! Oops!
[ 5000 ] [ [ 5000 ] compile-call ] unit-test

2
core/compiler/tests/tuples.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: compiler.tests
USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ;

2
core/continuations/continuations-tests.factor
View File

@ -1,7 +1,7 @@
USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays words
kernel.private ;
IN: temporary
IN: continuations.tests
: (callcc1-test)
swap 1- tuck swap ?push

2
core/cpu/arm/assembler/assembler-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: cpu.arm.assembler.tests
USING: assembler-arm math test namespaces sequences kernel
quotations ;

2
core/cpu/x86/assembler/assembler-tests.factor
View File

@ -1,5 +1,5 @@
USING: cpu.x86.assembler kernel tools.test namespaces ;
IN: temporary
IN: cpu.x86.assembler.tests
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test

2
core/debugger/debugger-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: debugger.tests
USING: debugger kernel continuations tools.test ;
[ ] [ [ drop ] [ error. ] recover ] unit-test

2
core/definitions/definitions-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: definitions.tests
USING: tools.test generic kernel definitions sequences
compiler.units ;

2
core/dlists/dlists-tests.factor
View File

@ -1,7 +1,7 @@
USING: dlists dlists.private kernel tools.test random assocs
hashtables sequences namespaces sorting debugger io prettyprint
math ;
IN: temporary
IN: dlists.tests
[ t ] [ <dlist> dlist-empty? ] unit-test

2
core/effects/effects-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: effects.tests
USING: effects tools.test ;
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test

2
core/float-arrays/float-arrays-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: float-arrays.tests
USING: float-arrays tools.test ;
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test

2
core/float-vectors/float-vectors-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: float-vectors.tests
USING: tools.test float-vectors vectors sequences kernel ;
[ 0 ] [ 123 <float-vector> length ] unit-test

10
core/generic/generic-docs.factor
View File

@ -116,16 +116,18 @@ HELP: method-spec
{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
HELP: method-body
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } }
{ $description "Looks up a method definition." }
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } ;
{ method define-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
{ $description "Creates a new "{ $link method } " instance." } ;
{ $description "Creates a new method." } ;
HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }

12
core/generic/generic-tests.factor
View File

@ -3,7 +3,7 @@ generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
quotations classes continuations layouts classes.union sorting
compiler.units ;
IN: temporary
IN: generic.tests
GENERIC: foobar ( x -- y )
M: object foobar drop "Hello world" ;
@ -87,11 +87,11 @@ M: number union-containment drop 2 ;
[ 2 ] [ 1.0 union-containment ] unit-test
! Testing recovery from bad method definitions
"IN: temporary GENERIC: unhappy ( x -- x )" eval
"IN: generic.tests GENERIC: unhappy ( x -- x )" eval
[
"IN: temporary M: dictionary unhappy ;" eval
"IN: generic.tests M: dictionary unhappy ;" eval
] must-fail
[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test
[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ;
@ -192,12 +192,12 @@ SYMBOL: redefinition-test-generic
TUPLE: redefinition-test-tuple ;
"IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval
"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
[ t ] [
[
redefinition-test-generic ,
"IN: temporary TUPLE: redefinition-test-tuple ;" eval
"IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
redefinition-test-generic ,
] { } make all-equal?
] unit-test

54
core/generic/generic.factor
View File

@ -25,16 +25,12 @@ GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
M: generic definer drop f f ;
M: generic definition drop f ;
: make-generic ( word -- )
dup { "unannotated-def" } reset-props
dup dup "combination" word-prop perform-combination define ;
TUPLE: method word def specializer generic loc ;
: method ( class generic -- method/f )
"methods" word-prop at ;
@ -47,7 +43,7 @@ PREDICATE: pair method-spec
: methods ( word -- assoc )
"methods" word-prop
[ keys sort-classes ] keep
[ dupd at method-word ] curry { } map>assoc ;
[ dupd at ] curry { } map>assoc ;
TUPLE: check-method class generic ;
@ -63,29 +59,33 @@ TUPLE: check-method class generic ;
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
: make-method-def ( quot word combination -- quot )
: make-method-def ( quot class generic -- quot )
"combination" word-prop method-prologue swap append ;
PREDICATE: word method-body "method" word-prop >boolean ;
PREDICATE: word method-body "method-def" word-prop >boolean ;
M: method-body stack-effect
"method" word-prop method-generic stack-effect ;
"method-generic" word-prop stack-effect ;
: <method-word> ( quot class generic -- word )
[ make-method-def ] 2keep
method-word-name f <word>
dup rot define
dup xref ;
: method-word-props ( quot class generic -- assoc )
[
"method-generic" set
"method-class" set
"method-def" set
] H{ } make-assoc ;
: <method> ( quot class generic -- method )
: <method> ( quot class generic -- word )
check-method
[ <method-word> ] 3keep f \ method construct-boa
dup method-word over "method" set-word-prop ;
[ make-method-def ] 3keep
[ method-word-props ] 2keep
method-word-name f <word>
tuck set-word-props
dup rot define ;
: redefine-method ( quot class generic -- )
[ method set-method-def ] 3keep
[ method swap "method-def" set-word-prop ] 3keep
[ make-method-def ] 2keep
method method-word swap define ;
method swap define ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
@ -102,21 +102,22 @@ M: method-body stack-effect
! Definition protocol
M: method-spec where
dup first2 method [ method-word ] [ second ] ?if where ;
dup first2 method [ ] [ second ] ?if where ;
M: method-spec set-where
first2 method method-word set-where ;
first2 method set-where ;
M: method-spec definer
drop \ M: \ ; ;
M: method-spec definition
first2 method dup [ method-def ] when ;
first2 method dup
[ "method-def" word-prop ] when ;
: forget-method ( class generic -- )
check-method
[ delete-at* ] with-methods
[ method-word forget-word ] [ drop ] if ;
[ forget-word ] [ drop ] if ;
M: method-spec forget*
first2 forget-method ;
@ -125,11 +126,11 @@ M: method-body definer
drop \ M: \ ; ;
M: method-body definition
"method" word-prop method-def ;
"method-def" word-prop ;
M: method-body forget*
"method" word-prop
{ method-specializer method-generic } get-slots
dup "method-class" word-prop
swap "method-generic" word-prop
forget-method ;
: implementors* ( classes -- words )
@ -168,8 +169,7 @@ M: word subwords drop f ;
M: generic subwords
dup "methods" word-prop values
swap "default-method" word-prop add
[ method-word ] map ;
swap "default-method" word-prop add ;
M: generic forget-word
dup subwords [ forget-word ] each (forget-word) ;

2
core/generic/math/math.factor
View File

@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
: applicable-method ( generic class -- quot )
over method
[ method-word word-def ]
[ word-def ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot )

2
core/generic/standard/standard.factor
View File

@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
] if ;
: default-method ( word -- pair )
"default-method" word-prop method-word
"default-method" word-prop
object bootstrap-word swap 2array ;
: method-alist>quot ( alist base-class -- quot )

2
core/growable/growable-tests.factor
View File

@ -1,6 +1,6 @@
USING: math sequences classes growable tools.test kernel
layouts ;
IN: temporary
IN: growable.tests
! erg found this one
[ fixnum ] [

2
core/hashtables/hashtables-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: hashtables.tests
USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;

21
core/hashtables/hashtables.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
math.private sequences sequences.private vectors ;
math.private sequences sequences.private vectors ;
IN: hashtables
<PRIVATE
@ -16,15 +16,16 @@ IN: hashtables
2 fixnum+fast over wrap ; inline
: (key@) ( key keys i -- array n ? )
3dup swap array-nth dup ((tombstone)) eq? [
2drop probe (key@)
] [
dup ((empty)) eq? [
3drop nip f f
] [
= [ rot drop t ] [ probe (key@) ] if
] if
] if ; inline
3dup swap array-nth
dup ((empty)) eq?
[ 3drop nip f f ]
[
=
[ rot drop t ]
[ probe (key@) ]
if
]
if ; inline
: key@ ( key hash -- array n ? )
hash-array 2dup hash@ (key@) ; inline

2
core/heaps/heaps-tests.factor
View File

@ -3,7 +3,7 @@
USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting ;
IN: temporary
IN: heaps.tests
[ <min-heap> heap-pop ] must-fail
[ <max-heap> heap-pop ] must-fail

3
core/inference/backend/backend.factor
View File

@ -10,8 +10,7 @@ IN: inference.backend
recursive-state get at ;
: inline? ( word -- ? )
dup "method" word-prop
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
dup "method-generic" word-prop swap or "inline" word-prop ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys

2
core/inference/class/class-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: inference.class.tests
USING: arrays math.private kernel math compiler inference
inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien

2
core/inference/inference-tests.factor
View File

@ -6,7 +6,7 @@ continuations generic.standard sorting assocs definitions
prettyprint io inspector tuples classes.union classes.predicate
debugger threads.private io.streams.string io.timeouts
io.thread sequences.private ;
IN: temporary
IN: inference.tests
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as

2
core/inference/known-words/known-words.factor
View File

@ -538,6 +538,8 @@ set-primitive-effect
\ fwrite { string alien } { } <effect> set-primitive-effect
\ fputc { object alien } { } <effect> set-primitive-effect
\ fread { integer string } { object } <effect> set-primitive-effect
\ fflush { alien } { } <effect> set-primitive-effect

2
core/inference/state/state-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: inference.state.tests
USING: tools.test inference.state words ;
SYMBOL: a

2
core/inference/transforms/transforms-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel
quotations inference ;

2
core/init/init-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: init.tests
USING: init namespaces sequences math tools.test kernel ;
[ t ] [

2
core/inspector/inspector-tests.factor
View File

@ -1,6 +1,6 @@
USING: kernel tools.test math namespaces prettyprint
sequences inspector io.streams.string ;
IN: temporary
IN: inspector.tests
[ 1 2 3 ] describe
f describe

2
core/io/backend/backend-tests.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: io.backend.tests
USING: tools.test io.backend kernel ;
[ ] [ "a" normalize-pathname drop ] unit-test

10
core/io/backend/backend.factor
View File

@ -1,13 +1,17 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces ;
USING: init kernel system namespaces io io.encodings io.encodings.utf8 ;
IN: io.backend
SYMBOL: io-backend
HOOK: init-io io-backend ( -- )
HOOK: init-stdio io-backend ( -- )
HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
: init-stdio ( -- )
(init-stdio) utf8 <encoder> stderr set-global
utf8 <encoder-duplex> stdio set-global ;
HOOK: io-multiplex io-backend ( ms -- )
@ -19,7 +23,7 @@ HOOK: normalize-pathname io-backend ( str -- newstr )
M: object normalize-pathname ;
: set-io-backend ( backend -- )
: set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio ;
[ init-io embedded? [ init-stdio ] unless ]

2
core/io/binary/binary-tests.factor
View File

@ -1,5 +1,5 @@
USING: io.binary tools.test ;
IN: temporary
IN: io.binary.tests
[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test

2
core/io/binary/binary.factor Normal file → Executable file
View File

@ -10,7 +10,7 @@ IN: io.binary
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
: >le ( x n -- str ) [ nth-byte ] with "" map-as ;
: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ;
: >be ( x n -- str ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )

2
core/io/encodings/binary/binary-docs.factor
View File

@ -2,4 +2,4 @@ USING: help.syntax help.markup ;
IN: io.encodings.binary
HELP: binary
{ $class-description "This is the encoding descriptor for binary I/O." } ;
{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } ;

6
core/io/encodings/binary/binary.factor
View File

@ -1,3 +1,3 @@
USING: kernel io.encodings ;
TUPLE: binary ;
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
IN: io.encodings.binary SYMBOL: binary

68
core/io/encodings/encodings-docs.factor Normal file
View File

@ -0,0 +1,68 @@
USING: help.markup help.syntax ;
IN: io.encodings
ABOUT: "encodings"
ARTICLE: "io.encodings" "I/O encodings"
"Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream."
{ $subsection "encodings-constructors" }
{ $subsection "encodings-descriptors" }
{ $subsection "encodings-protocol" } ;
ARTICLE: "encodings-constructors" "Constructing an encoded stream"
{ $subsection <encoder> }
{ $subsection <decoder> }
{ $subsection <encoder-duplex> } ;
HELP: <encoder> ( stream encoding -- newstream )
{ $values { "stream" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
HELP: <decoder> ( stream encoding -- newstream )
{ $values { "stream" "an input stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
HELP: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
{ $values { "stream-in" "an input stream" }
{ "stream-out" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "duplex" "an encoded duplex stream" } }
{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." } ;
{ <encoder> <decoder> <encoder-duplex> } related-words
ARTICLE: "encodings-descriptors" "Encoding descriptors"
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
$nl { $vocab-link "io.encodings.utf8" }
$nl { $vocab-link "io.encodings.ascii" }
$nl { $vocab-link "io.encodings.binary" }
$nl { $vocab-link "io.encodings.utf16" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"
"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
{ $subsection decode-step }
{ $subsection init-decoder }
{ $subsection stream-write-encoded } ;
HELP: decode-step ( buf char encoding -- )
{ $values { "buf" "A string buffer which characters can be pushed to" }
{ "char" "An octet which is read from a stream" }
{ "encoding" "An encoding descriptor tuple" } }
{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ;
HELP: stream-write-encoded ( string stream encoding -- )
{ $values { "string" "a string" }
{ "stream" "an output stream" }
{ "encoding" "an encoding descriptor" } }
{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ;
HELP: init-decoder ( stream encoding -- encoding )
{ $values { "stream" "an input stream" }
{ "encoding" "an encoding descriptor" } }
{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ;
{ init-decoder decode-step stream-write-encoded } related-words

8
core/io/streams/lines/lines-tests.factor → core/io/encodings/encodings-tests.factor
View File

@ -1,9 +1,9 @@
USING: io.streams.lines io.files io.streams.string io
tools.test kernel ;
IN: temporary
USING: io.files io.streams.string io
tools.test kernel io.encodings.ascii ;
IN: io.streams.encodings.tests
: <resource-reader> ( resource -- stream )
resource-path <file-reader> ;
resource-path ascii <file-reader> ;
[ { } ]
[ "/core/io/test/empty-file.txt" <resource-reader> lines ]

160
core/io/encodings/encodings.factor
View File

@ -1,13 +1,24 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
namespaces unicode growable strings io classes io.streams.c
continuations ;
USING: math kernel sequences sbufs vectors namespaces
growable strings io classes continuations combinators
io.styles io.streams.plain io.encodings.binary splitting
io.streams.duplex byte-arrays ;
IN: io.encodings
TUPLE: encode-error ;
! The encoding descriptor protocol
: encode-error ( -- * ) \ encode-error construct-empty throw ;
GENERIC: decode-step ( buf char encoding -- )
M: object decode-step drop swap push ;
GENERIC: init-decoder ( stream encoding -- encoding )
M: tuple-class init-decoder construct-empty init-decoder ;
M: object init-decoder nip ;
GENERIC: stream-write-encoded ( string stream encoding -- byte-array )
M: object stream-write-encoded drop stream-write ;
! Decoding
TUPLE: decode-error ;
@ -15,24 +26,12 @@ TUPLE: decode-error ;
SYMBOL: begin
: decoded ( buf ch -- buf ch state )
: push-decoded ( buf ch -- buf ch state )
over push 0 begin ;
: push-replacement ( buf -- buf ch state )
CHAR: replacement-character decoded ;
: finish-decoding ( buf ch state -- str )
begin eq? [ decode-error ] unless drop "" like ;
: start-decoding ( seq length -- buf ch state seq )
<sbuf> 0 begin roll ;
GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
: decode ( seq quot -- string )
>r dup length start-decoding r>
[ -rot ] swap compose each
finish-decoding ; inline
! This is the replacement character
HEX: fffd push-decoded ;
: space ( resizable -- room-left )
dup underlying swap [ length ] 2apply - ;
@ -42,54 +41,113 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
: end-read-loop ( buf ch state stream quot -- string/f )
2drop 2drop >string f like ;
: decode-read-loop ( buf ch state stream encoding -- string/f )
>r >r pick r> r> rot full? [ end-read-loop ] [
: decode-read-loop ( buf stream encoding -- string/f )
pick full? [ 2drop >string ] [
over stream-read1 [
-rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop
] [ end-read-loop ] if*
-rot tuck >r >r >r dupd r> decode-step r> r>
decode-read-loop
] [ 2drop >string f like ] if*
] if ;
: decode-read ( length stream encoding -- string )
>r swap start-decoding r>
decode-read-loop ;
rot <sbuf> -rot decode-read-loop ;
: <decoding> ( stream decoding-class -- decoded-stream )
construct-delegate <line-reader> ;
TUPLE: decoder code cr ;
: <decoder> ( stream encoding -- newstream )
dup binary eq? [ drop ] [
dupd init-decoder { set-delegate set-decoder-code }
decoder construct
] if ;
: <encoding> ( stream encoding-class -- encoded-stream )
construct-delegate <plain-writer> ;
: cr+ t swap set-decoder-cr ; inline
GENERIC: encode-string ( string encoding -- byte-array )
M: tuple-class encode-string construct-empty encode-string ;
: cr- f swap set-decoder-cr ; inline
MIXIN: encoding-stream
: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
M: encoding-stream stream-read1 1 swap stream-read ;
: line-ends\r ( stream str -- str ) swap cr+ ; inline
M: encoding-stream stream-read
[ delegate ] keep decode-read ;
: line-ends\n ( stream str -- str )
over decoder-cr over empty? and
[ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
M: encoding-stream stream-read-partial stream-read ;
: handle-readln ( stream str ch -- str )
{
{ f [ line-ends/eof ] }
{ CHAR: \r [ line-ends\r ] }
{ CHAR: \n [ line-ends\n ] }
} case ;
M: encoding-stream stream-read-until
: fix-read ( stream string -- string )
over decoder-cr [
over cr-
"\n" ?head [
swap stream-read1 [ add ] when*
] [ nip ] if
] [ nip ] if ;
M: decoder stream-read
tuck { delegate decoder-code } get-slots decode-read fix-read ;
M: decoder stream-read-partial stream-read ;
: decoder-read-until ( stream delim -- ch )
! Copied from { c-reader stream-read-until }!!!
[ swap read-until-loop ] "" make
over stream-read1 dup [
dup pick memq? [ 2nip ] [ , decoder-read-until ] if
] [
2nip
] if ;
M: decoder stream-read-until
! Copied from { c-reader stream-read-until }!!!
[ swap decoder-read-until ] "" make
swap over empty? over not and [ 2drop f f ] when ;
M: encoding-stream stream-write1
: fix-read1 ( stream char -- char )
over decoder-cr [
over cr-
dup CHAR: \n = [
drop stream-read1
] [ nip ] if
] [ nip ] if ;
M: decoder stream-read1
1 swap stream-read f like [ first ] [ f ] if* ;
M: decoder stream-readln ( stream -- str )
"\r\n" over stream-read-until handle-readln ;
! Encoding
TUPLE: encode-error ;
: encode-error ( -- * ) \ encode-error construct-empty throw ;
TUPLE: encoder code ;
: <encoder> ( stream encoding -- newstream )
dup binary eq? [ drop ] [
construct-empty { set-delegate set-encoder-code }
encoder construct
] if ;
M: encoder stream-write1
>r 1string r> stream-write ;
M: encoding-stream stream-write
[ encode-string ] keep delegate stream-write ;
M: encoder stream-write
{ delegate encoder-code } get-slots stream-write-encoded ;
M: encoding-stream dispose delegate dispose ;
M: encoder dispose delegate dispose ;
GENERIC: underlying-stream ( encoded-stream -- delegate )
M: encoding-stream underlying-stream delegate ;
INSTANCE: encoder plain-writer
GENERIC: set-underlying-stream ( new-underlying stream -- )
M: encoding-stream set-underlying-stream set-delegate ;
! Rebinding duplex streams which have not read anything yet
: set-encoding ( encoding stream -- ) ! This doesn't work now
[ underlying-stream swap construct-delegate ] keep
set-underlying-stream ;
: reencode ( stream encoding -- newstream )
over encoder? [ >r delegate r> ] when <encoder> ;
: redecode ( stream encoding -- newstream )
over decoder? [ >r delegate r> ] when <decoder> ;
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck reencode >r redecode r> <duplex-stream> ;

10
core/io/encodings/latin1/latin1.factor
View File

@ -1,10 +0,0 @@
USING: io io.encodings strings kernel ;
IN: io.encodings.latin1
TUPLE: latin1 ;
M: latin1 stream-read delegate stream-read >string ;
M: latin1 stream-read-until delegate stream-read-until >string ;
M: latin1 stream-read-partial delegate stream-read-partial >string ;

0
core/io/encodings/latin1/authors.txt → core/io/encodings/string/authors.txt
View File

18
core/io/encodings/string/string-docs.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax byte-arrays strings ;
IN: io.encodings.string
ARTICLE: "io.encodings.string" "Encoding and decoding strings"
"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:"
{ $subsection encode }
{ $subsection decode } ;
HELP: decode
{ $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" }
{ "string" string } }
{ $description "Decodes the byte array using the given encoding, outputting a string" } ;
HELP: encode
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Encodes the given string into a byte array with the given encoding." } ;

11
core/io/encodings/string/string-tests.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: strings io.encodings.utf8 io.encodings.utf16
io.encodings.string tools.test ;
IN: io.encodings.string.tests
[ "hello" ] [ "hello" utf8 decode ] unit-test
[ "he" ] [ "\0h\0e" utf16be decode ] unit-test
[ "hello" ] [ "hello" utf8 encode >string ] unit-test
[ "\0h\0e" ] [ "he" utf16be encode >string ] unit-test

10
core/io/encodings/string/string.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.streams.byte-array ;
IN: io.encodings.string
: decode ( byte-array encoding -- string )
<byte-reader> contents ;
: encode ( string encoding -- byte-array )
[ write ] with-byte-writer ;

1
core/io/encodings/string/summary.txt Normal file
View File

@ -0,0 +1 @@
Encoding and decoding strings

0
core/io/encodings/latin1/tags.txt → core/io/encodings/string/tags.factor
View File

45
core/io/encodings/utf16/utf16-docs.factor
View File

@ -1,45 +0,0 @@
USING: help.markup help.syntax io.encodings strings ;
IN: io.encodings.utf16
ARTICLE: "io.utf16" "Working with UTF16-encoded data"
"The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences."
{ $subsection encode-utf16le }
{ $subsection encode-utf16be }
{ $subsection decode-utf16le }
{ $subsection decode-utf16be }
"Support for UTF16 data with a byte order mark:"
{ $subsection encode-utf16 }
{ $subsection decode-utf16 } ;
ABOUT: "io.utf16"
HELP: decode-utf16
{ $values { "seq" "a sequence of bytes" } { "str" string } }
{ $description "Decodes a sequence of bytes representing a Unicode string in UTF16 format. The bytes must begin with a UTF16 byte order mark, which determines if the input is in little or big endian. To decode data without a byte order mark, use " { $link decode-utf16le } " or " { $link decode-utf16be } "." }
{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ;
HELP: decode-utf16be
{ $values { "seq" "a sequence of bytes" } { "str" string } }
{ $description "Decodes a sequence of bytes representing a Unicode string in big endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." }
{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ;
HELP: decode-utf16le
{ $values { "seq" "a sequence of bytes" } { "str" string } }
{ $description "Decodes a sequence of bytes representing a Unicode string in little endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." }
{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ;
{ decode-utf16 decode-utf16le decode-utf16be } related-words
HELP: encode-utf16be
{ $values { "str" string } { "seq" "a sequence of bytes" } }
{ $description "Encodes a Unicode string as a sequence of bytes in big endian UTF16 format." } ;
HELP: encode-utf16le
{ $values { "str" string } { "seq" "a sequence of bytes" } }
{ $description "Encodes a Unicode string as a sequence of bytes in little endian UTF16 format." } ;
HELP: encode-utf16
{ $values { "str" string } { "seq" "a sequence of bytes" } }
{ $description "Encodes a Unicode string as a sequence of bytes in UTF16 format with a byte order mark." } ;
{ encode-utf16 encode-utf16be encode-utf16le } related-words

28
core/io/encodings/utf16/utf16-tests.factor
View File

@ -1,28 +0,0 @@
USING: kernel tools.test io.encodings.utf16 arrays sbufs sequences io.encodings
io unicode ;
: decode-w/stream ( array encoding -- newarray )
>r >sbuf dup reverse-here r> <decoding> contents >array ;
: encode-w/stream ( array encoding -- newarray )
>r SBUF" " clone tuck r> <encoding> stream-write >array ;
[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode-w/stream ] unit-test
[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode-w/stream ] unit-test
[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode-w/stream ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode-w/stream ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode-w/stream ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode-w/stream ] unit-test
[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode-w/stream ] unit-test
[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode-w/stream ] unit-test
[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode-w/stream ] unit-test

19
core/io/encodings/utf8/utf8-docs.factor
View File

@ -1,18 +1,11 @@
USING: help.markup help.syntax io.encodings strings ;
USING: help.markup help.syntax io.encodings strings io.files ;
IN: io.encodings.utf8
ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences."
{ $subsection encode-utf8 }
{ $subsection decode-utf8 } ;
"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences. The encoding descriptor for UTF-8:"
{ $subsection utf8 } ;
HELP: utf8
{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. This conforms to the " { $link "encodings-protocol" } "." } ;
ABOUT: "io.encodings.utf8"
HELP: decode-utf8
{ $values { "seq" "a sequence of bytes" } { "str" string } }
{ $description "Decodes a sequence of bytes representing a Unicode string in UTF8 format." }
{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ;
HELP: encode-utf8
{ $values { "str" string } { "seq" "a sequence of bytes" } }
{ $description "Encodes a Unicode string as a sequence of bytes in UTF8 format." } ;

13
core/io/encodings/utf8/utf8-tests.factor
View File

@ -1,21 +1,20 @@
USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings
sequences strings arrays unicode ;
USING: io.encodings.utf8 tools.test io.encodings.string strings arrays ;
: decode-utf8-w/stream ( array -- newarray )
>sbuf dup reverse-here utf8 <decoding> contents ;
utf8 decode >array ;
: encode-utf8-w/stream ( array -- newarray )
SBUF" " clone tuck utf8 <encoding> stream-write >array ;
utf8 encode >array ;
[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream ] unit-test
[ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream ] unit-test
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test

46
core/io/encodings/utf8/utf8.factor
View File

@ -1,11 +1,13 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! Copyright (C) 2006, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors growable io continuations
namespaces io.encodings combinators strings io.streams.c ;
namespaces io.encodings combinators strings ;
IN: io.encodings.utf8
! Decoding UTF-8
TUPLE: utf8 ch state ;
SYMBOL: double
SYMBOL: triple
SYMBOL: triple2
@ -23,7 +25,7 @@ SYMBOL: quad3
: begin-utf8 ( buf byte -- buf ch state )
{
{ [ dup -7 shift zero? ] [ decoded ] }
{ [ dup -7 shift zero? ] [ push-decoded ] }
{ [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
{ [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
@ -31,7 +33,7 @@ SYMBOL: quad3
} cond ;
: end-multibyte ( buf byte ch -- buf ch state )
f append-nums [ decoded ] unless* ;
f append-nums [ push-decoded ] unless* ;
: decode-utf8-step ( buf byte ch state -- buf ch state )
{
@ -44,42 +46,42 @@ SYMBOL: quad3
{ quad3 [ end-multibyte ] }
} case ;
: decode-utf8 ( seq -- str )
[ decode-utf8-step ] decode ;
: unpack-state ( encoding -- ch state )
{ utf8-ch utf8-state } get-slots ;
: pack-state ( ch state encoding -- )
{ set-utf8-ch set-utf8-state } set-slots ;
M: utf8 decode-step ( buf char encoding -- )
[ unpack-state decode-utf8-step ] keep pack-state drop ;
M: utf8 init-decoder nip begin over set-utf8-state ;
! Encoding UTF-8
: encoded ( char -- )
BIN: 111111 bitand BIN: 10000000 bitor , ;
BIN: 111111 bitand BIN: 10000000 bitor write1 ;
: char>utf8 ( char -- )
{
{ [ dup -7 shift zero? ] [ , ] }
{ [ dup -7 shift zero? ] [ write1 ] }
{ [ dup -11 shift zero? ] [
dup -6 shift BIN: 11000000 bitor ,
dup -6 shift BIN: 11000000 bitor write1
encoded
] }
{ [ dup -16 shift zero? ] [
dup -12 shift BIN: 11100000 bitor ,
dup -12 shift BIN: 11100000 bitor write1
dup -6 shift encoded
encoded
] }
{ [ t ] [
dup -18 shift BIN: 11110000 bitor ,
dup -18 shift BIN: 11110000 bitor write1
dup -12 shift encoded
dup -6 shift encoded
encoded
] }
} cond ;
: encode-utf8 ( str -- seq )
[ [ char>utf8 ] each ] B{ } make ;
! Interface for streams
TUPLE: utf8 ;
INSTANCE: utf8 encoding-stream
M: utf8 encode-string drop encode-utf8 ;
M: utf8 decode-step drop decode-utf8-step ;
! In the future, this should detect and ignore a BOM at the beginning
M: utf8 stream-write-encoded
! For efficiency, this should be modified to avoid variable reads
drop [ [ char>utf8 ] each ] with-stream* ;

1
core/io/files/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov
Daniel Ehrenberg

66
core/io/files/files-docs.factor
View File

@ -10,7 +10,9 @@ ARTICLE: "file-streams" "Reading and writing files"
"Utility combinators:"
{ $subsection with-file-reader }
{ $subsection with-file-writer }
{ $subsection with-file-appender } ;
{ $subsection with-file-appender }
{ $subsection file-contents }
{ $subsection file-lines } ;
ARTICLE: "pathnames" "Pathname manipulation"
"Pathname manipulation:"
@ -57,8 +59,8 @@ ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
"The operations for moving and copying files come in three flavors:"
{ $list
{ "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." }
{ "A word named " { $snippet { $emphasis "operation" } "-to" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." }
{ "A word named " { $snippet { $emphasis "operation" } "s-to" } " which takes a sequence of source paths and destination directory." }
{ "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." }
{ "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." }
}
"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file."
$nl
@ -68,16 +70,16 @@ $nl
{ $subsection delete-tree }
"Moving files:"
{ $subsection move-file }
{ $subsection move-file-to }
{ $subsection move-files-to }
{ $subsection move-file-into }
{ $subsection move-files-into }
"Copying files:"
{ $subsection copy-file }
{ $subsection copy-file-to }
{ $subsection copy-files-to }
{ $subsection copy-file-into }
{ $subsection copy-files-into }
"Copying directory trees recursively:"
{ $subsection copy-tree }
{ $subsection copy-tree-to }
{ $subsection copy-trees-to }
{ $subsection copy-tree-into }
{ $subsection copy-trees-into }
"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ;
ARTICLE: "io.files" "Basic file operations"
@ -87,7 +89,6 @@ ARTICLE: "io.files" "Basic file operations"
{ $subsection "fs-meta" }
{ $subsection "directories" }
{ $subsection "delete-move-copy" }
{ $subsection "unique" }
{ $see-also "os" } ;
ABOUT: "io.files"
@ -114,33 +115,44 @@ HELP: file-name
} ;
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "stream" "an input stream" } }
{ $description "Outputs an input stream for reading from the specified pathname." }
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptors" }
{ "stream" "an input stream" } }
{ $description "Outputs an input stream for reading from the specified pathname using the given encoding." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: <file-writer>
{ $values { "path" "a pathname string" } { "stream" "an output stream" } }
{ $description "Outputs an output stream for writing to the specified pathname. The file's length is truncated to zero." }
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } }
{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: <file-appender>
{ $values { "path" "a pathname string" } { "stream" "an output stream" } }
{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } }
{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-reader
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: with-file-writer
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-appender
{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." }
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: file-lines
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } }
{ $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: file-contents
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } }
{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: cwd
@ -267,12 +279,12 @@ HELP: move-file
{ $description "Moves or renames a file." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
HELP: move-file-to
HELP: move-file-into
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Moves a file to another directory without renaming it." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
HELP: move-files-to
HELP: move-files-into
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Moves a set of files to another directory." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
@ -283,12 +295,12 @@ HELP: copy-file
{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
HELP: copy-file-to
HELP: copy-file-into
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a file to another directory." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
HELP: copy-files-to
HELP: copy-files-into
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of files to another directory." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
@ -299,12 +311,12 @@ HELP: copy-tree
{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." }
{ $errors "Throws an error if the copy operation fails." } ;
HELP: copy-tree-to
HELP: copy-tree-into
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a directory tree to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ;
HELP: copy-trees-to
HELP: copy-trees-into
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of directory trees to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ;

40
core/io/files/files-tests.factor
View File

@ -1,34 +1,34 @@
IN: temporary
USING: tools.test io.files io threads kernel continuations ;
IN: io.files.tests
USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ ] [
"test-foo.txt" temp-file [
"test-foo.txt" temp-file ascii [
"Hello world." print
] with-file-writer
] unit-test
[ ] [
"test-foo.txt" temp-file <file-appender> [
"test-foo.txt" temp-file ascii [
"Hello appender." print
] with-stream
] with-file-appender
] unit-test
[ ] [
"test-bar.txt" temp-file <file-appender> [
"test-bar.txt" temp-file ascii [
"Hello appender." print
] with-stream
] with-file-appender
] unit-test
[ "Hello world.\nHello appender.\n" ] [
"test-foo.txt" temp-file file-contents
"test-foo.txt" temp-file ascii file-contents
] unit-test
[ "Hello appender.\n" ] [
"test-bar.txt" temp-file file-contents
"test-bar.txt" temp-file ascii file-contents
] unit-test
[ ] [ "test-foo.txt" temp-file delete-file ] unit-test
@ -42,7 +42,7 @@ USING: tools.test io.files io threads kernel continuations ;
[ ] [ "test-blah" temp-file make-directory ] unit-test
[ ] [
"test-blah/fooz" temp-file <file-writer> dispose
"test-blah/fooz" temp-file ascii <file-writer> dispose
] unit-test
[ t ] [
@ -55,11 +55,11 @@ USING: tools.test io.files io threads kernel continuations ;
[ f ] [ "test-blah" temp-file exists? ] unit-test
[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" temp-file delete-file ] unit-test
[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
@ -70,7 +70,7 @@ USING: tools.test io.files io threads kernel continuations ;
[ ] [
"delete-tree-test/a/b/c/d" temp-file
[ "Hi" print ] with-file-writer
ascii [ "Hi" print ] with-file-writer
] unit-test
[ ] [
@ -83,7 +83,7 @@ USING: tools.test io.files io threads kernel continuations ;
[ ] [
"copy-tree-test/a/b/c/d" temp-file
[ "Foobar" write ] with-file-writer
ascii [ "Foobar" write ] with-file-writer
] unit-test
[ ] [
@ -92,7 +92,7 @@ USING: tools.test io.files io threads kernel continuations ;
] unit-test
[ "Foobar" ] [
"copy-destination/a/b/c/d" temp-file file-contents
"copy-destination/a/b/c/d" temp-file ascii file-contents
] unit-test
[ ] [
@ -101,19 +101,19 @@ USING: tools.test io.files io threads kernel continuations ;
[ ] [
"copy-tree-test" temp-file
"copy-destination" temp-file copy-tree-to
"copy-destination" temp-file copy-tree-into
] unit-test
[ "Foobar" ] [
"copy-destination/copy-tree-test/a/b/c/d" temp-file file-contents
"copy-destination/copy-tree-test/a/b/c/d" temp-file ascii file-contents
] unit-test
[ ] [
"copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-to
"copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into
] unit-test
[ "Foobar" ] [
"d" temp-file file-contents
"d" temp-file ascii file-contents
] unit-test
[ ] [ "d" temp-file delete-file ] unit-test
@ -121,3 +121,5 @@ USING: tools.test io.files io threads kernel continuations ;
[ ] [ "copy-destination" temp-file delete-tree ] unit-test
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test

109
core/io/files/files.factor
View File

@ -1,11 +1,28 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations ;
system combinators splitting sbufs continuations io.encodings
io.encodings.binary ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
HOOK: (file-writer) io-backend ( path -- stream )
HOOK: (file-appender) io-backend ( path -- stream )
: <file-reader> ( path encoding -- stream )
swap (file-reader) swap <decoder> ;
: <file-writer> ( path encoding -- stream )
swap (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream )
swap (file-appender) swap <encoder> ;
HOOK: rename-file io-backend ( from to -- )
! Pathnames
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
@ -54,6 +71,7 @@ TUPLE: no-parent-directory path ;
TUPLE: file-info type size permissions modified ;
HOOK: file-info io-backend ( path -- info )
HOOK: link-info io-backend ( path -- info )
SYMBOL: +regular-file+
SYMBOL: +directory+
@ -84,7 +102,7 @@ HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
: with-directory ( path quot -- )
swap cd cwd [ cd ] curry [ ] cleanup ; inline
cwd [ cd ] curry rot cd [ ] cleanup ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
@ -137,37 +155,45 @@ HOOK: delete-directory io-backend ( path -- )
! Moving and renaming files
HOOK: move-file io-backend ( from to -- )
: move-file-to ( from to -- )
: move-file-into ( from to -- )
to-directory move-file ;
: move-files-to ( files to -- )
[ move-file-to ] curry each ;
: move-files-into ( files to -- )
[ move-file-into ] curry each ;
! Copying files
HOOK: copy-file io-backend ( from to -- )
: copy-file-to ( from to -- )
M: object copy-file
dup parent-directory make-directories
binary <file-writer> [
swap binary <file-reader> [
swap stream-copy
] with-disposal
] with-disposal ;
: copy-file-into ( from to -- )
to-directory copy-file ;
: copy-files-to ( files to -- )
[ copy-file-to ] curry each ;
: copy-files-into ( files to -- )
[ copy-file-into ] curry each ;
DEFER: copy-tree-to
DEFER: copy-tree-into
: copy-tree ( from to -- )
over directory? [
>r dup directory swap r> [
>r swap first path+ r> copy-tree-to
>r swap first path+ r> copy-tree-into
] 2curry each
] [
copy-file
] if ;
: copy-tree-to ( from to -- )
: copy-tree-into ( from to -- )
to-directory copy-tree ;
: copy-trees-to ( files to -- )
[ copy-tree-to ] curry each ;
: copy-trees-into ( files to -- )
[ copy-tree-into ] curry each ;
! Special paths
: resource-path ( path -- newpath )
@ -180,6 +206,28 @@ DEFER: copy-tree-to
: resource-exists? ( path -- ? )
?resource-path exists? ;
! Pathname presentations
TUPLE: pathname string ;
C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
: file-lines ( path encoding -- seq ) <file-reader> lines ;
: file-contents ( path encoding -- str )
dupd <file-reader> swap file-length <sbuf>
[ stream-copy ] keep >string ;
: with-file-reader ( path encoding quot -- )
>r <file-reader> r> with-stream ; inline
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline
: with-file-appender ( path encoding quot -- )
>r <file-appender> r> with-stream ; inline
: temp-directory ( -- path )
"temp" resource-path
dup exists? not
@ -188,39 +236,10 @@ DEFER: copy-tree-to
: temp-file ( name -- path ) temp-directory swap path+ ;
! Pathname presentations
TUPLE: pathname string ;
C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
! Streams
HOOK: <file-reader> io-backend ( path -- stream )
HOOK: <file-writer> io-backend ( path -- stream )
HOOK: <file-appender> io-backend ( path -- stream )
: file-lines ( path -- seq ) <file-reader> lines ;
: file-contents ( path -- str )
dup <file-reader> swap file-length <sbuf>
[ stream-copy ] keep >string ;
: with-file-reader ( path quot -- )
>r <file-reader> r> with-stream ; inline
: with-file-writer ( path quot -- )
>r <file-writer> r> with-stream ; inline
: with-file-appender ( path quot -- )
>r <file-appender> r> with-stream ; inline
! Home directory
: home ( -- dir )
{
{ [ winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] }
} cond ;
} cond ;

2
core/io/io-docs.factor
View File

@ -100,7 +100,7 @@ $nl
{ $subsection "stream-protocol" }
{ $subsection "stdio" }
{ $subsection "stream-utils" }
{ $see-also "io.streams.string" "io.streams.lines" "io.streams.plain" "io.streams.duplex" } ;
{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ;
ABOUT: "streams"

15
core/io/io-tests.factor Normal file → Executable file
View File

@ -1,14 +1,15 @@
USING: arrays io io.files kernel math parser strings system
tools.test words namespaces ;
IN: temporary
tools.test words namespaces io.encodings.latin1
io.encodings.binary ;
IN: io.tests
[ f ] [
"resource:/core/io/test/no-trailing-eol.factor" run-file
"foo" "temporary" lookup
"foo" "io.tests" lookup
] unit-test
: <resource-reader> ( resource -- stream )
resource-path <file-reader> ;
resource-path latin1 <file-reader> ;
[
"This is a line.\rThis is another line.\r"
@ -31,10 +32,10 @@ IN: temporary
! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
[ "" ] [
[
"/core/io/test/binary.txt" <resource-reader>
[ 0.2 read ] with-stream
] unit-test
] must-fail
[
{
@ -53,7 +54,7 @@ IN: temporary
] unit-test
[ ] [
image [
image binary [
10 [ 65536 read drop ] times
] with-file-reader
] unit-test

33
core/io/streams/byte-array/byte-array-docs.factor Normal file
View File

@ -0,0 +1,33 @@
USING: help.syntax help.markup io byte-arrays quotations ;
IN: io.streams.byte-array
ABOUT: "io.streams.byte-array"
ARTICLE: "io.streams.byte-array" "Byte-array streams"
"Byte array streams:"
{ $subsection <byte-reader> }
{ $subsection <byte-writer> }
"Utility combinators:"
{ $subsection with-byte-reader }
{ $subsection with-byte-writer } ;
HELP: <byte-reader>
{ $values { "byte-array" byte-array }
{ "encoding" "an encoding descriptor" } }
{ $description "Provides an input stream reading off the given byte array using the given encoding." } ;
HELP: <byte-writer>
{ $values { "encoding" "an encoding descriptor" }
{ "stream" "an output stream" } }
{ $description "Provides an output stream, putting things in the given encoding, storing everything written to it in a byte-array." } ;
HELP: with-byte-reader
{ $values { "encoding" "an encoding descriptor" }
{ "quot" quotation } { "byte-array" byte-array } }
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading the byte array in the given encoding from beginning to end." } ;
HELP: with-byte-writer
{ $values { "encoding" "an encoding descriptor" }
{ "quot" quotation }
{ "byte-array" byte-array } }
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new byte array writer, putting things in the given encoding. The accumulated byte array is output when the quotation returns." } ;

4
core/io/streams/byte-array/byte-array.factor
View File

@ -3,14 +3,14 @@ sequences io namespaces ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
512 <byte-vector> swap <encoding> ;
512 <byte-vector> swap <encoder> ;
: with-byte-writer ( encoding quot -- byte-array )
>r <byte-writer> r> [ stdio get ] compose with-stream*
>byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream )
>r >byte-vector dup reverse-here r> <decoding> ;
>r >byte-vector dup reverse-here r> <decoder> ;
: with-byte-reader ( byte-array encoding quot -- )
>r <byte-reader> r> with-stream ; inline

5
core/io/streams/c/c-docs.factor
View File

@ -6,7 +6,6 @@ ARTICLE: "io.streams.c" "ANSI C streams"
"C streams are found in the " { $vocab-link "io.streams.c" } " vocabulary; they are " { $link "stream-protocol" } " implementations which read and write C " { $snippet "FILE*" } " handles."
{ $subsection <c-reader> }
{ $subsection <c-writer> }
{ $subsection <duplex-c-stream> }
"Underlying primitives used to implement the above:"
{ $subsection fopen }
{ $subsection fwrite }
@ -31,10 +30,6 @@ HELP: <c-writer> ( out -- stream )
{ $description "Creates a stream which writes data by calling C standard library functions." }
{ $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ;
HELP: <duplex-c-stream>
{ $values { "in" "a C FILE* handle" } { "out" "a C FILE* handle" } { "stream" "a new stream" } }
{ $description "Creates a stream which reads and writes data by calling C standard library functions, wrapping the input portion in a " { $link line-reader } " and the output portion in a " { $link plain-writer } "." } ;
HELP: fopen ( path mode -- alien )
{ $values { "path" "a pathname string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } }
{ $description "Opens a file named by " { $snippet "path" } ". The " { $snippet "mode" } " parameter should be something like " { $snippet "\"r\"" } " or " { $snippet "\"rw\"" } "; consult the " { $snippet "fopen(3)" } " manual page for details." }

8
core/io/streams/c/c-tests.factor
View File

@ -1,10 +1,12 @@
USING: tools.test io.files io io.streams.c ;
IN: temporary
USING: tools.test io.files io io.streams.c
io.encodings.ascii strings ;
IN: io.streams.c.tests
[ "hello world" ] [
"test.txt" temp-file [
"test.txt" temp-file ascii [
"hello world" write
] with-file-writer
"test.txt" temp-file "rb" fopen <c-reader> contents
>string
] unit-test

41
core/io/streams/c/c.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces io
strings sequences math generic threads.private classes
io.backend io.streams.lines io.streams.plain io.streams.duplex
io.files continuations ;
USING: kernel kernel.private namespaces io io.encodings
sequences math generic threads.private classes io.backend
io.streams.duplex io.files continuations byte-arrays ;
IN: io.streams.c
TUPLE: c-writer handle ;
@ -11,7 +10,7 @@ TUPLE: c-writer handle ;
C: <c-writer> c-writer
M: c-writer stream-write1
>r 1string r> stream-write ;
c-writer-handle fputc ;
M: c-writer stream-write
c-writer-handle fwrite ;
@ -27,7 +26,7 @@ TUPLE: c-reader handle ;
C: <c-reader> c-reader
M: c-reader stream-read
>r >fixnum r> c-reader-handle fread ;
c-reader-handle fread ;
M: c-reader stream-read-partial
stream-read ;
@ -43,41 +42,39 @@ M: c-reader stream-read1
] if ;
M: c-reader stream-read-until
[ swap read-until-loop ] "" make swap
[ swap read-until-loop ] B{ } make swap
over empty? over not and [ 2drop f f ] when ;
M: c-reader dispose
c-reader-handle fclose ;
: <duplex-c-stream> ( in out -- stream )
>r <c-reader> <line-reader> r>
<c-writer> <plain-writer>
<duplex-stream> ;
M: object init-io ;
: stdin-handle 11 getenv ;
: stdout-handle 12 getenv ;
: stderr-handle 38 getenv ;
M: object init-stdio
stdin-handle stdout-handle <duplex-c-stream> stdio set-global
stderr-handle <c-writer> <plain-writer> stderr set-global ;
M: object (init-stdio)
stdin-handle <c-reader>
stdout-handle <c-writer>
stderr-handle <c-writer> ;
M: object io-multiplex 60 60 * 1000 * or (sleep) ;
M: object <file-reader>
"rb" fopen <c-reader> <line-reader> ;
M: object (file-reader)
"rb" fopen <c-reader> ;
M: object <file-writer>
"wb" fopen <c-writer> <plain-writer> ;
M: object (file-writer)
"wb" fopen <c-writer> ;
M: object <file-appender>
"ab" fopen <c-writer> <plain-writer> ;
M: object (file-appender)
"ab" fopen <c-writer> ;
: show ( msg -- )
#! A word which directly calls primitives. It is used to
#! print stuff from contexts where the I/O system would
#! otherwise not work (tools.deploy.shaker, the I/O
#! multiplexer thread).
"\r\n" append stdout-handle fwrite stdout-handle fflush ;
"\r\n" append >byte-array
stdout-handle fwrite
stdout-handle fflush ;

2
core/io/streams/duplex/duplex-tests.factor
View File

@ -1,5 +1,5 @@
USING: io.streams.duplex io kernel continuations tools.test ;
IN: temporary
IN: io.streams.duplex.tests
! Test duplex stream close behavior
TUPLE: closing-stream closed? ;

1
core/io/streams/lines/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

17
core/io/streams/lines/lines-docs.factor
View File

@ -1,17 +0,0 @@
USING: help.markup help.syntax io strings ;
IN: io.streams.lines
ARTICLE: "io.streams.lines" "Line reader streams"
"Line reader streams wrap an underlying stream and provide a default implementation of " { $link stream-readln } "."
{ $subsection line-reader }
{ $subsection <line-reader> } ;
ABOUT: "io.streams.lines"
HELP: line-reader
{ $class-description "An input stream which delegates to an underlying stream while providing an implementation of the " { $link stream-readln } " word in terms of the underlying stream's " { $link stream-read-until } ". Line readers are created by calling " { $link <line-reader> } "." } ;
HELP: <line-reader>
{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } }
{ $description "Creates a new " { $link line-reader } "." }
{ $notes "Stream constructors should call this word to wrap streams that do not natively support reading lines. Unix (" { $snippet "\\n" } "), Windows (" { $snippet "\\r\\n" } ") and MacOS (" { $snippet "\\r" } ") line endings are supported." } ;

57
core/io/streams/lines/lines.factor
View File

@ -1,57 +0,0 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.lines
USING: arrays generic io kernel math namespaces sequences
vectors combinators splitting ;
TUPLE: line-reader cr ;
: <line-reader> ( stream -- new-stream )
line-reader construct-delegate ;
: cr+ t swap set-line-reader-cr ; inline
: cr- f swap set-line-reader-cr ; inline
: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
: line-ends\r ( stream str -- str ) swap cr+ ; inline
: line-ends\n ( stream str -- str )
over line-reader-cr over empty? and
[ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
: handle-readln ( stream str ch -- str )
{
{ f [ line-ends/eof ] }
{ CHAR: \r [ line-ends\r ] }
{ CHAR: \n [ line-ends\n ] }
} case ;
M: line-reader stream-readln ( stream -- str )
"\r\n" over delegate stream-read-until handle-readln ;
: fix-read ( stream string -- string )
over line-reader-cr [
over cr-
"\n" ?head [
swap stream-read1 [ add ] when*
] [ nip ] if
] [ nip ] if ;
M: line-reader stream-read
tuck delegate stream-read fix-read ;
M: line-reader stream-read-partial
tuck delegate stream-read-partial fix-read ;
: fix-read1 ( stream char -- char )
over line-reader-cr [
over cr-
dup CHAR: \n = [
drop stream-read1
] [ nip ] if
] [ nip ] if ;
M: line-reader stream-read1 ( stream -- char )
dup delegate stream-read1 fix-read1 ;

1
core/io/streams/lines/summary.txt
View File

@ -1 +0,0 @@
Read lines of text from a character-oriented stream

2
core/io/streams/nested/nested-tests.factor
View File

@ -1,3 +1,3 @@
USING: io io.streams.string io.streams.nested kernel math
namespaces io.styles tools.test ;
IN: temporary
IN: io.streams.nested.tests

11
core/io/streams/plain/plain-docs.factor
View File

@ -8,17 +8,10 @@ ARTICLE: "io.streams.plain" "Plain writer streams"
{ $link make-span-stream } ", "
{ $link make-block-stream } " and "
{ $link make-cell-stream } "."
{ $subsection plain-writer }
{ $subsection <plain-writer> } ;
{ $subsection plain-writer } ;
ABOUT: "io.streams.plain"
HELP: plain-writer
{ $class-description "An output stream which delegates to an underlying stream while providing an implementation of the extended stream output protocol in a trivial way. Plain writers are created by calling " { $link <plain-writer> } "." }
{ $see-also "stream-protocol" } ;
HELP: <plain-writer>
{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } }
{ $description "Creates a new " { $link plain-writer } "." }
{ $notes "Stream constructors should call this word to wrap streams that do not natively support the extended stream output protocol." }
{ $class-description "An output stream mixin providing an implementation of the extended stream output protocol in a trivial way." }
{ $see-also "stream-protocol" } ;

8
core/io/streams/plain/plain.factor
View File

@ -1,13 +1,9 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.streams.nested ;
IN: io.streams.plain
USING: generic assocs kernel math namespaces sequences
io.styles io io.streams.nested ;
TUPLE: plain-writer ;
: <plain-writer> ( stream -- new-stream )
plain-writer construct-delegate ;
MIXIN: plain-writer
M: plain-writer stream-nl
CHAR: \n swap stream-write1 ;

2
core/io/streams/string/string-docs.factor
View File

@ -26,4 +26,4 @@ HELP: <string-reader>
HELP: with-string-reader
{ $values { "str" string } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end. The accumulated string is output when the quotation returns." } ;
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ;

2
core/io/streams/string/string-tests.factor
View File

@ -1,5 +1,5 @@
USING: io.streams.string io kernel arrays namespaces tools.test ;
IN: temporary
IN: io.streams.string.tests
[ "line 1" CHAR: l ]
[

53
core/io/streams/string/string.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.string
USING: io kernel math namespaces sequences sbufs strings
generic splitting io.streams.plain io.streams.lines growable
continuations ;
generic splitting growable continuations io.streams.plain
io.encodings ;
M: growable dispose drop ;
@ -12,38 +12,19 @@ M: growable stream-write push-all ;
M: growable stream-flush drop ;
: <string-writer> ( -- stream )
512 <sbuf> <plain-writer> ;
512 <sbuf> ;
: with-string-writer ( quot -- str )
<string-writer> swap [ stdio get ] compose with-stream*
>string ; inline
: format-column ( seq ? -- seq )
[
[ 0 [ length max ] reduce ] keep
swap [ CHAR: \s pad-right ] curry map
] unless ;
: map-last ( seq quot -- seq )
swap dup length <reversed>
[ zero? rot [ call ] keep swap ] 2map nip ; inline
: format-table ( table -- seq )
flip [ format-column ] map-last
flip [ " " join ] map ;
M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
: harden-as ( seq growble-exemplar -- newseq )
underlying like ;
: growable-read-until ( growable n -- str )
dupd tail-slice swap harden-as dup reverse-here ;
>fixnum dupd tail-slice swap harden-as dup reverse-here ;
: find-last-sep swap [ memq? ] curry find-last drop ;
@ -69,7 +50,31 @@ M: growable stream-read-partial
stream-read ;
: <string-reader> ( str -- stream )
>sbuf dup reverse-here <line-reader> ;
>sbuf dup reverse-here f <decoder> ;
: with-string-reader ( str quot -- )
>r <string-reader> r> with-stream ; inline
INSTANCE: growable plain-writer
: format-column ( seq ? -- seq )
[
[ 0 [ length max ] reduce ] keep
swap [ CHAR: \s pad-right ] curry map
] unless ;
: map-last ( seq quot -- seq )
swap dup length <reversed>
[ zero? rot [ call ] keep swap ] 2map nip ; inline
: format-table ( table -- seq )
flip [ format-column ] map-last
flip [ " " join ] map ;
M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
M: growable stream-readln ( stream -- str )
"\r\n" over stream-read-until handle-readln ;

2
core/io/test/no-trailing-eol.factor
View File

@ -1,4 +1,4 @@
IN: temporary
IN: io.tests
USE: math
: foo 2 2 + ;
FORGET: foo

2
core/kernel/kernel-tests.factor
View File

@ -1,7 +1,7 @@
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs ;
IN: temporary
IN: kernel.tests
[ 0 ] [ f size ] unit-test
[ t ] [ [ \ = \ = ] all-equal? ] unit-test

6
core/listener/listener-tests.factor
View File

@ -1,7 +1,7 @@
USING: io io.streams.string io.streams.duplex listener
tools.test parser math namespaces continuations vocabs kernel
compiler.units ;
IN: temporary
IN: listener.tests
: hello "Hi" print ; parsing
@ -9,7 +9,7 @@ IN: temporary
<string-reader> stream-read-quot ;
[ [ ] ] [
"USE: temporary hello" parse-interactive
"USE: listener.tests hello" parse-interactive
] unit-test
[
@ -45,6 +45,6 @@ IN: temporary
] unit-test
[ ] [
"IN: temporary : hello\n\"world\" ;" parse-interactive
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
drop
] unit-test

4
core/listener/listener.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles io.streams.lines
namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators
tuples continuations debugger definitions compiler.units ;
IN: listener
@ -32,7 +32,7 @@ GENERIC: stream-read-quot ( stream -- quot/f )
3drop f
] if ;
M: line-reader stream-read-quot
M: object stream-read-quot
V{ } clone read-quot-loop ;
M: duplex-stream stream-read-quot

Some files were not shown because too many files have changed in this diff Show More