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 USING: alien alien.accessors byte-arrays arrays kernel
kernel.private namespaces tools.test sequences libc math system kernel.private namespaces tools.test sequences libc math system
prettyprint ; 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 USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc ; 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 generator.registers assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations math.parser cpu.architecture alien alien.accessors quotations
system compiler.units ; system compiler.units io.files io.encodings.binary ;
IN: alien.c-types IN: alien.c-types
DEFER: <int> DEFER: <int>
@ -273,6 +273,9 @@ M: long-long-type box-return ( type -- )
r> add* r> add*
] when ; ] when ;
: malloc-file-contents ( path -- alien )
binary file-contents >byte-array malloc-byte-array ;
[ [
[ alien-cell ] [ alien-cell ]
[ set-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 USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects 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 USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces ; 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 USING: arrays kernel sequences sequences.private growable
tools.test vectors layouts system math vectors.private ; tools.test vectors layouts system math vectors.private ;
IN: temporary IN: arrays.tests
[ -2 { "a" "b" "c" } nth ] must-fail [ -2 { "a" "b" "c" } nth ] must-fail
[ 10 { "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 USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs sequences.private hashtables io prettyprint assocs
continuations ; continuations ;

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

@ -1,6 +1,6 @@
USING: sequences arrays bit-arrays kernel tools.test math USING: sequences arrays bit-arrays kernel tools.test math
random ; random ;
IN: temporary IN: bit-arrays.tests
[ 100 ] [ 100 <bit-array> length ] unit-test [ 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 ; USING: tools.test bit-vectors vectors sequences kernel math ;
[ 0 ] [ 123 <bit-vector> length ] unit-test [ 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 ; USING: bootstrap.image bootstrap.image.private tools.test ;
\ ' must-infer \ ' 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 splitting growable classes tuples words.private
io.binary io.files vocabs vocabs.loader source-files io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private definitions debugger float-arrays quotations.private
sequences.private combinators ; sequences.private combinators io.encodings.binary ;
IN: bootstrap.image IN: bootstrap.image
: my-arch ( -- arch ) : my-arch ( -- arch )
@ -416,7 +416,7 @@ M: curry '
"Writing image to " write "Writing image to " write
architecture get boot-image-name resource-path architecture get boot-image-name resource-path
dup write "..." print flush dup write "..." print flush
[ (write-image) ] with-file-writer ; binary <file-writer> [ (write-image) ] with-stream ;
PRIVATE> 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" } { "fopen" "io.streams.c" }
{ "fgetc" "io.streams.c" } { "fgetc" "io.streams.c" }
{ "fread" "io.streams.c" } { "fread" "io.streams.c" }
{ "fputc" "io.streams.c" }
{ "fwrite" "io.streams.c" } { "fwrite" "io.streams.c" }
{ "fflush" "io.streams.c" } { "fflush" "io.streams.c" }
{ "fclose" "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 ; USING: boxes namespaces tools.test ;
[ ] [ <box> "b" set ] unit-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 ? ) : ?box ( box -- value/f ? )
dup box-full? [ box> t ] [ drop f f ] if ; 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 ; USING: tools.test byte-arrays ;
[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test [ 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 ; USING: tools.test byte-vectors vectors sequences kernel ;
[ 0 ] [ 123 <byte-vector> length ] unit-test [ 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 tools.test vectors words quotations classes io.streams.string
classes.private classes.union classes.mixin classes.predicate classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units ; vectors definitions source-files compiler.units ;
IN: temporary IN: classes.tests
H{ } "s" set H{ } "s" set
@ -56,13 +56,13 @@ UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test [ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test [ f ] [ \ tuple \ c class< ] unit-test
DEFER: bah ! DEFER: bah
FORGET: bah ! FORGET: bah
UNION: bah fixnum alien ; UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test [ bah ] [ \ bah? "predicating" word-prop ] unit-test
! Test generic see and parsing ! 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 [ [ \ bah see ] with-string-writer ] unit-test
! Test redefinition of classes ! 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 [ 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 [ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number 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 [ 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 [ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-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 integer class< ] unit-test
[ t ] [ mx1 number 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 [ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number 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 [ t ] [ quotation redefine-bug-2 class< ] unit-test
[ redefine-bug-2 ] [ fixnum quotation class-or ] 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 [ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test [ f ] [ fixnum redefine-bug-2 class< ] unit-test
@ -185,7 +185,7 @@ DEFER: mixin-forget-test-g
[ ] [ [ ] [
{ {
"USING: sequences ;" "USING: sequences ;"
"IN: temporary" "IN: classes.tests"
"MIXIN: mixin-forget-test" "MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test" "INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )" "GENERIC: mixin-forget-test-g ( x -- y )"
@ -200,7 +200,7 @@ DEFER: mixin-forget-test-g
[ ] [ [ ] [
{ {
"USING: hashtables ;" "USING: hashtables ;"
"IN: temporary" "IN: classes.tests"
"MIXIN: mixin-forget-test" "MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test" "INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )" "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 USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words ; namespaces combinators words ;

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

@ -1,5 +1,5 @@
USING: namespaces tools.test kernel command-line ; USING: namespaces tools.test kernel command-line ;
IN: temporary IN: command-line.tests
[ [
[ f ] [ "-no-user-init" cli-arg ] unit-test [ 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 USING: tools.test quotations math kernel sequences
assocs namespaces compiler.units ; 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
[ 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 USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ; 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 USING: arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays 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 USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings sequences.private math.private math combinators strings
alien arrays memory ; alien arrays memory ;
IN: temporary IN: compiler.tests
! Test empty word ! Test empty word
[ ] [ [ ] compile-call ] unit-test [ ] [ [ ] 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 USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private kernel.private kernel math continuations continuations.private
words splitting sorting ; words splitting sorting ;

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

@ -1,5 +1,5 @@
! Testing templates machinery without compiling anything ! Testing templates machinery without compiling anything
IN: temporary IN: compiler.tests
USING: compiler generator generator.registers USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units ; 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 tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators ; words definitions compiler.units io combinators ;
IN: temporary IN: compiler.tests
! Oops! ! Oops!
[ 5000 ] [ [ 5000 ] compile-call ] unit-test [ 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 ; USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ; 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 USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays words continuations debugger parser memory arrays words
kernel.private ; kernel.private ;
IN: temporary IN: continuations.tests
: (callcc1-test) : (callcc1-test)
swap 1- tuck swap ?push 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 USING: assembler-arm math test namespaces sequences kernel
quotations ; quotations ;

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

@ -1,5 +1,5 @@
USING: cpu.x86.assembler kernel tools.test namespaces ; 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: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] 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 ; USING: debugger kernel continuations tools.test ;
[ ] [ [ drop ] [ error. ] recover ] unit-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 USING: tools.test generic kernel definitions sequences
compiler.units ; compiler.units ;

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

@ -1,7 +1,7 @@
USING: dlists dlists.private kernel tools.test random assocs USING: dlists dlists.private kernel tools.test random assocs
hashtables sequences namespaces sorting debugger io prettyprint hashtables sequences namespaces sorting debugger io prettyprint
math ; math ;
IN: temporary IN: dlists.tests
[ t ] [ <dlist> dlist-empty? ] unit-test [ 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 ; USING: effects tools.test ;
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-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 ; USING: float-arrays tools.test ;
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-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 ; USING: tools.test float-vectors vectors sequences kernel ;
[ 0 ] [ 123 <float-vector> length ] unit-test [ 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." } { $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* }" } } ; { $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 HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } } { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } { $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." } ;
{ method define-method POSTPONE: M: } related-words { method define-method POSTPONE: M: } related-words
HELP: <method> HELP: <method>
{ $values { "def" "a quotation" } { "method" "a new method definition" } } { $values { "def" "a quotation" } { "method" "a new method definition" } }
{ $description "Creates a new "{ $link method } " instance." } ; { $description "Creates a new method." } ;
HELP: methods HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } { $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 prettyprint sequences strings tools.test vectors words
quotations classes continuations layouts classes.union sorting quotations classes continuations layouts classes.union sorting
compiler.units ; compiler.units ;
IN: temporary IN: generic.tests
GENERIC: foobar ( x -- y ) GENERIC: foobar ( x -- y )
M: object foobar drop "Hello world" ; M: object foobar drop "Hello world" ;
@ -87,11 +87,11 @@ M: number union-containment drop 2 ;
[ 2 ] [ 1.0 union-containment ] unit-test [ 2 ] [ 1.0 union-containment ] unit-test
! Testing recovery from bad method definitions ! 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 ] 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 ) GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ; M: string complex-combination drop ;
@ -192,12 +192,12 @@ SYMBOL: redefinition-test-generic
TUPLE: redefinition-test-tuple ; 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 ] [ [ t ] [
[ [
redefinition-test-generic , redefinition-test-generic ,
"IN: temporary TUPLE: redefinition-test-tuple ;" eval "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
redefinition-test-generic , redefinition-test-generic ,
] { } make all-equal? ] { } make all-equal?
] unit-test ] 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 ; PREDICATE: word generic "combination" word-prop >boolean ;
M: generic definer drop f f ;
M: generic definition drop f ; M: generic definition drop f ;
: make-generic ( word -- ) : make-generic ( word -- )
dup { "unannotated-def" } reset-props dup { "unannotated-def" } reset-props
dup dup "combination" word-prop perform-combination define ; dup dup "combination" word-prop perform-combination define ;
TUPLE: method word def specializer generic loc ;
: method ( class generic -- method/f ) : method ( class generic -- method/f )
"methods" word-prop at ; "methods" word-prop at ;
@ -47,7 +43,7 @@ PREDICATE: pair method-spec
: methods ( word -- assoc ) : methods ( word -- assoc )
"methods" word-prop "methods" word-prop
[ keys sort-classes ] keep [ keys sort-classes ] keep
[ dupd at method-word ] curry { } map>assoc ; [ dupd at ] curry { } map>assoc ;
TUPLE: check-method class generic ; TUPLE: check-method class generic ;
@ -63,29 +59,33 @@ TUPLE: check-method class generic ;
: method-word-name ( class word -- string ) : method-word-name ( class word -- string )
word-name "/" rot word-name 3append ; 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 ; "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 M: method-body stack-effect
"method" word-prop method-generic stack-effect ; "method-generic" word-prop stack-effect ;
: <method-word> ( quot class generic -- word ) : method-word-props ( quot class generic -- assoc )
[ make-method-def ] 2keep [
method-word-name f <word> "method-generic" set
dup rot define "method-class" set
dup xref ; "method-def" set
] H{ } make-assoc ;
: <method> ( quot class generic -- method ) : <method> ( quot class generic -- word )
check-method check-method
[ <method-word> ] 3keep f \ method construct-boa [ make-method-def ] 3keep
dup method-word over "method" set-word-prop ; [ method-word-props ] 2keep
method-word-name f <word>
tuck set-word-props
dup rot define ;
: redefine-method ( quot class generic -- ) : redefine-method ( quot class generic -- )
[ method set-method-def ] 3keep [ method swap "method-def" set-word-prop ] 3keep
[ make-method-def ] 2keep [ make-method-def ] 2keep
method method-word swap define ; method swap define ;
: define-method ( quot class generic -- ) : define-method ( quot class generic -- )
>r bootstrap-word r> >r bootstrap-word r>
@ -102,21 +102,22 @@ M: method-body stack-effect
! Definition protocol ! Definition protocol
M: method-spec where M: method-spec where
dup first2 method [ method-word ] [ second ] ?if where ; dup first2 method [ ] [ second ] ?if where ;
M: method-spec set-where M: method-spec set-where
first2 method method-word set-where ; first2 method set-where ;
M: method-spec definer M: method-spec definer
drop \ M: \ ; ; drop \ M: \ ; ;
M: method-spec definition M: method-spec definition
first2 method dup [ method-def ] when ; first2 method dup
[ "method-def" word-prop ] when ;
: forget-method ( class generic -- ) : forget-method ( class generic -- )
check-method check-method
[ delete-at* ] with-methods [ delete-at* ] with-methods
[ method-word forget-word ] [ drop ] if ; [ forget-word ] [ drop ] if ;
M: method-spec forget* M: method-spec forget*
first2 forget-method ; first2 forget-method ;
@ -125,11 +126,11 @@ M: method-body definer
drop \ M: \ ; ; drop \ M: \ ; ;
M: method-body definition M: method-body definition
"method" word-prop method-def ; "method-def" word-prop ;
M: method-body forget* M: method-body forget*
"method" word-prop dup "method-class" word-prop
{ method-specializer method-generic } get-slots swap "method-generic" word-prop
forget-method ; forget-method ;
: implementors* ( classes -- words ) : implementors* ( classes -- words )
@ -168,8 +169,7 @@ M: word subwords drop f ;
M: generic subwords M: generic subwords
dup "methods" word-prop values dup "methods" word-prop values
swap "default-method" word-prop add swap "default-method" word-prop add ;
[ method-word ] map ;
M: generic forget-word M: generic forget-word
dup subwords [ forget-word ] each (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 ) : applicable-method ( generic class -- quot )
over method over method
[ method-word word-def ] [ word-def ]
[ default-math-method ] ?if ; [ default-math-method ] ?if ;
: object-method ( generic -- quot ) : object-method ( generic -- quot )

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

@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
] if ; ] if ;
: default-method ( word -- pair ) : default-method ( word -- pair )
"default-method" word-prop method-word "default-method" word-prop
object bootstrap-word swap 2array ; object bootstrap-word swap 2array ;
: method-alist>quot ( alist base-class -- quot ) : 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 USING: math sequences classes growable tools.test kernel
layouts ; layouts ;
IN: temporary IN: growable.tests
! erg found this one ! erg found this one
[ fixnum ] [ [ 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 USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs sequences.private hashtables io prettyprint assocs
continuations ; continuations ;

21
core/hashtables/hashtables.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs USING: arrays kernel kernel.private slots.private math assocs
math.private sequences sequences.private vectors ; math.private sequences sequences.private vectors ;
IN: hashtables IN: hashtables
<PRIVATE <PRIVATE
@ -16,15 +16,16 @@ IN: hashtables
2 fixnum+fast over wrap ; inline 2 fixnum+fast over wrap ; inline
: (key@) ( key keys i -- array n ? ) : (key@) ( key keys i -- array n ? )
3dup swap array-nth dup ((tombstone)) eq? [ 3dup swap array-nth
2drop probe (key@) dup ((empty)) eq?
] [ [ 3drop nip f f ]
dup ((empty)) eq? [ [
3drop nip f f =
] [ [ rot drop t ]
= [ rot drop t ] [ probe (key@) ] if [ probe (key@) ]
] if if
] if ; inline ]
if ; inline
: key@ ( key hash -- array n ? ) : key@ ( key hash -- array n ? )
hash-array 2dup hash@ (key@) ; inline 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 USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting ; heaps heaps.private math.parser random assocs sequences sorting ;
IN: temporary IN: heaps.tests
[ <min-heap> heap-pop ] must-fail [ <min-heap> heap-pop ] must-fail
[ <max-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 ; recursive-state get at ;
: inline? ( word -- ? ) : inline? ( word -- ? )
dup "method" word-prop dup "method-generic" word-prop swap or "inline" word-prop ;
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
: local-recursive-state ( -- assoc ) : local-recursive-state ( -- assoc )
recursive-state get dup keys 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 USING: arrays math.private kernel math compiler inference
inference.dataflow optimizer tools.test kernel.private generic inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien 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 prettyprint io inspector tuples classes.union classes.predicate
debugger threads.private io.streams.string io.timeouts debugger threads.private io.streams.string io.timeouts
io.thread sequences.private ; io.thread sequences.private ;
IN: temporary IN: inference.tests
{ 0 2 } [ 2 "Hello" ] must-infer-as { 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] 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 \ fwrite { string alien } { } <effect> set-primitive-effect
\ fputc { object alien } { } <effect> set-primitive-effect
\ fread { integer string } { object } <effect> set-primitive-effect \ fread { integer string } { object } <effect> set-primitive-effect
\ fflush { alien } { } <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 ; USING: tools.test inference.state words ;
SYMBOL: a 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 USING: sequences inference.transforms tools.test math kernel
quotations inference ; 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 ; USING: init namespaces sequences math tools.test kernel ;
[ t ] [ [ t ] [

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

@ -1,6 +1,6 @@
USING: kernel tools.test math namespaces prettyprint USING: kernel tools.test math namespaces prettyprint
sequences inspector io.streams.string ; sequences inspector io.streams.string ;
IN: temporary IN: inspector.tests
[ 1 2 3 ] describe [ 1 2 3 ] describe
f 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 ; USING: tools.test io.backend kernel ;
[ ] [ "a" normalize-pathname drop ] unit-test [ ] [ "a" normalize-pathname drop ] unit-test

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

@ -1,13 +1,17 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: io.backend
SYMBOL: io-backend SYMBOL: io-backend
HOOK: init-io 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 -- ) HOOK: io-multiplex io-backend ( ms -- )
@ -19,7 +23,7 @@ HOOK: normalize-pathname io-backend ( str -- newstr )
M: object normalize-pathname ; M: object normalize-pathname ;
: set-io-backend ( backend -- ) : set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio ; io-backend set-global init-io init-stdio ;
[ init-io embedded? [ init-stdio ] unless ] [ init-io embedded? [ init-stdio ] unless ]

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

@ -1,5 +1,5 @@
USING: io.binary tools.test ; USING: io.binary tools.test ;
IN: temporary IN: io.binary.tests
[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test [ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] 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 : 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 ; : >be ( x n -- str ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 ) : 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 IN: io.encodings.binary
HELP: 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 ; ! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
TUPLE: binary ; 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 USING: io.files io.streams.string io
tools.test kernel ; tools.test kernel io.encodings.ascii ;
IN: temporary IN: io.streams.encodings.tests
: <resource-reader> ( resource -- stream ) : <resource-reader> ( resource -- stream )
resource-path <file-reader> ; resource-path ascii <file-reader> ;
[ { } ] [ { } ]
[ "/core/io/test/empty-file.txt" <resource-reader> lines ] [ "/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. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain USING: math kernel sequences sbufs vectors namespaces
namespaces unicode growable strings io classes io.streams.c growable strings io classes continuations combinators
continuations ; io.styles io.streams.plain io.encodings.binary splitting
io.streams.duplex byte-arrays ;
IN: io.encodings 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 ; TUPLE: decode-error ;
@ -15,24 +26,12 @@ TUPLE: decode-error ;
SYMBOL: begin SYMBOL: begin
: decoded ( buf ch -- buf ch state ) : push-decoded ( buf ch -- buf ch state )
over push 0 begin ; over push 0 begin ;
: push-replacement ( buf -- buf ch state ) : push-replacement ( buf -- buf ch state )
CHAR: replacement-character decoded ; ! This is the replacement character
HEX: fffd push-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
: space ( resizable -- room-left ) : space ( resizable -- room-left )
dup underlying swap [ length ] 2apply - ; 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 ) : end-read-loop ( buf ch state stream quot -- string/f )
2drop 2drop >string f like ; 2drop 2drop >string f like ;
: decode-read-loop ( buf ch state stream encoding -- string/f ) : decode-read-loop ( buf stream encoding -- string/f )
>r >r pick r> r> rot full? [ end-read-loop ] [ pick full? [ 2drop >string ] [
over stream-read1 [ over stream-read1 [
-rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop -rot tuck >r >r >r dupd r> decode-step r> r>
] [ end-read-loop ] if* decode-read-loop
] [ 2drop >string f like ] if*
] if ; ] if ;
: decode-read ( length stream encoding -- string ) : decode-read ( length stream encoding -- string )
>r swap start-decoding r> rot <sbuf> -rot decode-read-loop ;
decode-read-loop ;
: <decoding> ( stream decoding-class -- decoded-stream ) TUPLE: decoder code cr ;
construct-delegate <line-reader> ; : <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 ) : cr+ t swap set-decoder-cr ; inline
construct-delegate <plain-writer> ;
GENERIC: encode-string ( string encoding -- byte-array ) : cr- f swap set-decoder-cr ; inline
M: tuple-class encode-string construct-empty encode-string ;
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 : line-ends\n ( stream str -- str )
[ delegate ] keep decode-read ; 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 }!!! ! 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 ; 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 ; >r 1string r> stream-write ;
M: encoding-stream stream-write M: encoder stream-write
[ encode-string ] keep delegate 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 ) INSTANCE: encoder plain-writer
M: encoding-stream underlying-stream delegate ;
GENERIC: set-underlying-stream ( new-underlying stream -- ) ! Rebinding duplex streams which have not read anything yet
M: encoding-stream set-underlying-stream set-delegate ;
: set-encoding ( encoding stream -- ) ! This doesn't work now : reencode ( stream encoding -- newstream )
[ underlying-stream swap construct-delegate ] keep over encoder? [ >r delegate r> ] when <encoder> ;
set-underlying-stream ;
: 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 IN: io.encodings.utf8
ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data" 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." "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 encode-utf8 } { $subsection utf8 } ;
{ $subsection decode-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" 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 USING: io.encodings.utf8 tools.test io.encodings.string strings arrays ;
sequences strings arrays unicode ;
: decode-utf8-w/stream ( array -- newarray ) : decode-utf8-w/stream ( array -- newarray )
>sbuf dup reverse-here utf8 <decoding> contents ; utf8 decode >array ;
: encode-utf8-w/stream ( array -- newarray ) : 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 [ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] 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 [ { 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. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors growable io continuations 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 IN: io.encodings.utf8
! Decoding UTF-8 ! Decoding UTF-8
TUPLE: utf8 ch state ;
SYMBOL: double SYMBOL: double
SYMBOL: triple SYMBOL: triple
SYMBOL: triple2 SYMBOL: triple2
@ -23,7 +25,7 @@ SYMBOL: quad3
: begin-utf8 ( buf byte -- buf ch state ) : 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 -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
{ [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] } { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] } { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
@ -31,7 +33,7 @@ SYMBOL: quad3
} cond ; } cond ;
: end-multibyte ( buf byte ch -- buf ch state ) : 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 ) : decode-utf8-step ( buf byte ch state -- buf ch state )
{ {
@ -44,42 +46,42 @@ SYMBOL: quad3
{ quad3 [ end-multibyte ] } { quad3 [ end-multibyte ] }
} case ; } case ;
: decode-utf8 ( seq -- str ) : unpack-state ( encoding -- ch state )
[ decode-utf8-step ] decode ; { 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 ! Encoding UTF-8
: encoded ( char -- ) : encoded ( char -- )
BIN: 111111 bitand BIN: 10000000 bitor , ; BIN: 111111 bitand BIN: 10000000 bitor write1 ;
: char>utf8 ( char -- ) : char>utf8 ( char -- )
{ {
{ [ dup -7 shift zero? ] [ , ] } { [ dup -7 shift zero? ] [ write1 ] }
{ [ dup -11 shift zero? ] [ { [ dup -11 shift zero? ] [
dup -6 shift BIN: 11000000 bitor , dup -6 shift BIN: 11000000 bitor write1
encoded encoded
] } ] }
{ [ dup -16 shift zero? ] [ { [ dup -16 shift zero? ] [
dup -12 shift BIN: 11100000 bitor , dup -12 shift BIN: 11100000 bitor write1
dup -6 shift encoded dup -6 shift encoded
encoded encoded
] } ] }
{ [ t ] [ { [ t ] [
dup -18 shift BIN: 11110000 bitor , dup -18 shift BIN: 11110000 bitor write1
dup -12 shift encoded dup -12 shift encoded
dup -6 shift encoded dup -6 shift encoded
encoded encoded
] } ] }
} cond ; } cond ;
: encode-utf8 ( str -- seq ) M: utf8 stream-write-encoded
[ [ char>utf8 ] each ] B{ } make ; ! For efficiency, this should be modified to avoid variable reads
drop [ [ char>utf8 ] each ] with-stream* ;
! 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

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

@ -1 +1,2 @@
Slava Pestov 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:" "Utility combinators:"
{ $subsection with-file-reader } { $subsection with-file-reader }
{ $subsection with-file-writer } { $subsection with-file-writer }
{ $subsection with-file-appender } ; { $subsection with-file-appender }
{ $subsection file-contents }
{ $subsection file-lines } ;
ARTICLE: "pathnames" "Pathname manipulation" ARTICLE: "pathnames" "Pathname manipulation"
"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:" "The operations for moving and copying files come in three flavors:"
{ $list { $list
{ "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." } { "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" } "-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-to" } " which takes a sequence of source paths and destination directory." } { "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." "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 $nl
@ -68,16 +70,16 @@ $nl
{ $subsection delete-tree } { $subsection delete-tree }
"Moving files:" "Moving files:"
{ $subsection move-file } { $subsection move-file }
{ $subsection move-file-to } { $subsection move-file-into }
{ $subsection move-files-to } { $subsection move-files-into }
"Copying files:" "Copying files:"
{ $subsection copy-file } { $subsection copy-file }
{ $subsection copy-file-to } { $subsection copy-file-into }
{ $subsection copy-files-to } { $subsection copy-files-into }
"Copying directory trees recursively:" "Copying directory trees recursively:"
{ $subsection copy-tree } { $subsection copy-tree }
{ $subsection copy-tree-to } { $subsection copy-tree-into }
{ $subsection copy-trees-to } { $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." ; "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" ARTICLE: "io.files" "Basic file operations"
@ -87,7 +89,6 @@ ARTICLE: "io.files" "Basic file operations"
{ $subsection "fs-meta" } { $subsection "fs-meta" }
{ $subsection "directories" } { $subsection "directories" }
{ $subsection "delete-move-copy" } { $subsection "delete-move-copy" }
{ $subsection "unique" }
{ $see-also "os" } ; { $see-also "os" } ;
ABOUT: "io.files" ABOUT: "io.files"
@ -114,33 +115,44 @@ HELP: file-name
} ; } ;
HELP: <file-reader> HELP: <file-reader>
{ $values { "path" "a pathname string" } { "stream" "an input stream" } } { $values { "path" "a pathname string" } { "encoding" "an encoding descriptors" }
{ $description "Outputs an input stream for reading from the specified pathname." } { "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." } ; { $errors "Throws an error if the file is unreadable." } ;
HELP: <file-writer> HELP: <file-writer>
{ $values { "path" "a pathname string" } { "stream" "an output stream" } } { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } }
{ $description "Outputs an output stream for writing to the specified pathname. The file's length is truncated to zero." } { $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." } ; { $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: <file-appender> HELP: <file-appender>
{ $values { "path" "a pathname string" } { "stream" "an output stream" } } { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "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." } { $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." } ; { $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-reader 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 } "." } { $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file is unreadable." } ; { $errors "Throws an error if the file is unreadable." } ;
HELP: with-file-writer HELP: with-file-writer
{ $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 writing and calls the quotation using " { $link with-stream } "." } { $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." } ; { $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-appender HELP: with-file-appender
{ $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 appending and calls the quotation using " { $link with-stream } "." } { $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." } ; { $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: cwd HELP: cwd
@ -267,12 +279,12 @@ HELP: move-file
{ $description "Moves or renames a file." } { $description "Moves or renames a file." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; { $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" } } { $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Moves a file to another directory without renaming it." } { $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." } ; { $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" } } { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Moves a set of files to another directory." } { $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." } ; { $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." } { $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." } ; { $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" } } { $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a file to another directory." } { $description "Copies a file to another directory." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; { $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" } } { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of files to another directory." } { $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." } ; { $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." } { $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." } ; { $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" } } { $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a directory tree to another directory, recursively." } { $description "Copies a directory tree to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ; { $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" } } { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of directory trees to another directory, recursively." } { $description "Copies a set of directory trees to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ; { $errors "Throws an error if the copy operation fails." } ;

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

@ -1,34 +1,34 @@
IN: temporary IN: io.files.tests
USING: tools.test io.files io threads kernel continuations ; USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk/" 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 "Hello world." print
] with-file-writer ] with-file-writer
] unit-test ] unit-test
[ ] [ [ ] [
"test-foo.txt" temp-file <file-appender> [ "test-foo.txt" temp-file ascii [
"Hello appender." print "Hello appender." print
] with-stream ] with-file-appender
] unit-test ] unit-test
[ ] [ [ ] [
"test-bar.txt" temp-file <file-appender> [ "test-bar.txt" temp-file ascii [
"Hello appender." print "Hello appender." print
] with-stream ] with-file-appender
] unit-test ] unit-test
[ "Hello world.\nHello appender.\n" ] [ [ "Hello world.\nHello appender.\n" ] [
"test-foo.txt" temp-file file-contents "test-foo.txt" temp-file ascii file-contents
] unit-test ] unit-test
[ "Hello appender.\n" ] [ [ "Hello appender.\n" ] [
"test-bar.txt" temp-file file-contents "test-bar.txt" temp-file ascii file-contents
] unit-test ] unit-test
[ ] [ "test-foo.txt" temp-file delete-file ] 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" 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 ] unit-test
[ t ] [ [ t ] [
@ -55,11 +55,11 @@ USING: tools.test io.files io threads kernel continuations ;
[ f ] [ "test-blah" temp-file exists? ] unit-test [ 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 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 [ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test
[ t ] [ "quux-test.txt" temp-file exists? ] 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 "delete-tree-test/a/b/c/d" temp-file
[ "Hi" print ] with-file-writer ascii [ "Hi" print ] with-file-writer
] unit-test ] unit-test
[ ] [ [ ] [
@ -83,7 +83,7 @@ USING: tools.test io.files io threads kernel continuations ;
[ ] [ [ ] [
"copy-tree-test/a/b/c/d" temp-file "copy-tree-test/a/b/c/d" temp-file
[ "Foobar" write ] with-file-writer ascii [ "Foobar" write ] with-file-writer
] unit-test ] unit-test
[ ] [ [ ] [
@ -92,7 +92,7 @@ USING: tools.test io.files io threads kernel continuations ;
] unit-test ] unit-test
[ "Foobar" ] [ [ "Foobar" ] [
"copy-destination/a/b/c/d" temp-file file-contents "copy-destination/a/b/c/d" temp-file ascii file-contents
] unit-test ] unit-test
[ ] [ [ ] [
@ -101,19 +101,19 @@ USING: tools.test io.files io threads kernel continuations ;
[ ] [ [ ] [
"copy-tree-test" temp-file "copy-tree-test" temp-file
"copy-destination" temp-file copy-tree-to "copy-destination" temp-file copy-tree-into
] unit-test ] unit-test
[ "Foobar" ] [ [ "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 ] 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 ] unit-test
[ "Foobar" ] [ [ "Foobar" ] [
"d" temp-file file-contents "d" temp-file ascii file-contents
] unit-test ] unit-test
[ ] [ "d" temp-file delete-file ] 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-destination" temp-file delete-tree ] unit-test
[ ] [ "copy-tree-test" 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

107
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. ! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.files.private io hashtables kernel math USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions 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 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 ! Pathnames
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; : path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
@ -54,6 +71,7 @@ TUPLE: no-parent-directory path ;
TUPLE: file-info type size permissions modified ; TUPLE: file-info type size permissions modified ;
HOOK: file-info io-backend ( path -- info ) HOOK: file-info io-backend ( path -- info )
HOOK: link-info io-backend ( path -- info )
SYMBOL: +regular-file+ SYMBOL: +regular-file+
SYMBOL: +directory+ SYMBOL: +directory+
@ -84,7 +102,7 @@ HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path ) HOOK: cwd io-backend ( -- path )
: with-directory ( path quot -- ) : with-directory ( path quot -- )
swap cd cwd [ cd ] curry [ ] cleanup ; inline cwd [ cd ] curry rot cd [ ] cleanup ; inline
! Creating directories ! Creating directories
HOOK: make-directory io-backend ( path -- ) HOOK: make-directory io-backend ( path -- )
@ -137,37 +155,45 @@ HOOK: delete-directory io-backend ( path -- )
! Moving and renaming files ! Moving and renaming files
HOOK: move-file io-backend ( from to -- ) HOOK: move-file io-backend ( from to -- )
: move-file-to ( from to -- ) : move-file-into ( from to -- )
to-directory move-file ; to-directory move-file ;
: move-files-to ( files to -- ) : move-files-into ( files to -- )
[ move-file-to ] curry each ; [ move-file-into ] curry each ;
! Copying files ! Copying files
HOOK: copy-file io-backend ( from to -- ) 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 ; to-directory copy-file ;
: copy-files-to ( files to -- ) : copy-files-into ( files to -- )
[ copy-file-to ] curry each ; [ copy-file-into ] curry each ;
DEFER: copy-tree-to DEFER: copy-tree-into
: copy-tree ( from to -- ) : copy-tree ( from to -- )
over directory? [ over directory? [
>r dup directory swap r> [ >r dup directory swap r> [
>r swap first path+ r> copy-tree-to >r swap first path+ r> copy-tree-into
] 2curry each ] 2curry each
] [ ] [
copy-file copy-file
] if ; ] if ;
: copy-tree-to ( from to -- ) : copy-tree-into ( from to -- )
to-directory copy-tree ; to-directory copy-tree ;
: copy-trees-to ( files to -- ) : copy-trees-into ( files to -- )
[ copy-tree-to ] curry each ; [ copy-tree-into ] curry each ;
! Special paths ! Special paths
: resource-path ( path -- newpath ) : resource-path ( path -- newpath )
@ -180,6 +206,28 @@ DEFER: copy-tree-to
: resource-exists? ( path -- ? ) : resource-exists? ( path -- ? )
?resource-path exists? ; ?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-directory ( -- path )
"temp" resource-path "temp" resource-path
dup exists? not dup exists? not
@ -188,35 +236,6 @@ DEFER: copy-tree-to
: temp-file ( name -- path ) temp-directory swap path+ ; : 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 directory
: home ( -- dir ) : home ( -- dir )
{ {

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

@ -100,7 +100,7 @@ $nl
{ $subsection "stream-protocol" } { $subsection "stream-protocol" }
{ $subsection "stdio" } { $subsection "stdio" }
{ $subsection "stream-utils" } { $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" 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 USING: arrays io io.files kernel math parser strings system
tools.test words namespaces ; tools.test words namespaces io.encodings.latin1
IN: temporary io.encodings.binary ;
IN: io.tests
[ f ] [ [ f ] [
"resource:/core/io/test/no-trailing-eol.factor" run-file "resource:/core/io/test/no-trailing-eol.factor" run-file
"foo" "temporary" lookup "foo" "io.tests" lookup
] unit-test ] unit-test
: <resource-reader> ( resource -- stream ) : <resource-reader> ( resource -- stream )
resource-path <file-reader> ; resource-path latin1 <file-reader> ;
[ [
"This is a line.\rThis is another line.\r" "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 ! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
[ "" ] [ [
"/core/io/test/binary.txt" <resource-reader> "/core/io/test/binary.txt" <resource-reader>
[ 0.2 read ] with-stream [ 0.2 read ] with-stream
] unit-test ] must-fail
[ [
{ {
@ -53,7 +54,7 @@ IN: temporary
] unit-test ] unit-test
[ ] [ [ ] [
image [ image binary [
10 [ 65536 read drop ] times 10 [ 65536 read drop ] times
] with-file-reader ] with-file-reader
] unit-test ] 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 IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream ) : <byte-writer> ( encoding -- stream )
512 <byte-vector> swap <encoding> ; 512 <byte-vector> swap <encoder> ;
: with-byte-writer ( encoding quot -- byte-array ) : with-byte-writer ( encoding quot -- byte-array )
>r <byte-writer> r> [ stdio get ] compose with-stream* >r <byte-writer> r> [ stdio get ] compose with-stream*
>byte-array ; inline >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream ) : <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 -- ) : with-byte-reader ( byte-array encoding quot -- )
>r <byte-reader> r> with-stream ; inline >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." "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-reader> }
{ $subsection <c-writer> } { $subsection <c-writer> }
{ $subsection <duplex-c-stream> }
"Underlying primitives used to implement the above:" "Underlying primitives used to implement the above:"
{ $subsection fopen } { $subsection fopen }
{ $subsection fwrite } { $subsection fwrite }
@ -31,10 +30,6 @@ HELP: <c-writer> ( out -- stream )
{ $description "Creates a stream which writes data by calling C standard library functions." } { $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." } ; { $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 ) HELP: fopen ( path mode -- alien )
{ $values { "path" "a pathname string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } } { $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." } { $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 ; USING: tools.test io.files io io.streams.c
IN: temporary io.encodings.ascii strings ;
IN: io.streams.c.tests
[ "hello world" ] [ [ "hello world" ] [
"test.txt" temp-file [ "test.txt" temp-file ascii [
"hello world" write "hello world" write
] with-file-writer ] with-file-writer
"test.txt" temp-file "rb" fopen <c-reader> contents "test.txt" temp-file "rb" fopen <c-reader> contents
>string
] unit-test ] unit-test

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

@ -1,9 +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: kernel kernel.private namespaces io USING: kernel kernel.private namespaces io io.encodings
strings sequences math generic threads.private classes sequences math generic threads.private classes io.backend
io.backend io.streams.lines io.streams.plain io.streams.duplex io.streams.duplex io.files continuations byte-arrays ;
io.files continuations ;
IN: io.streams.c IN: io.streams.c
TUPLE: c-writer handle ; TUPLE: c-writer handle ;
@ -11,7 +10,7 @@ TUPLE: c-writer handle ;
C: <c-writer> c-writer C: <c-writer> c-writer
M: c-writer stream-write1 M: c-writer stream-write1
>r 1string r> stream-write ; c-writer-handle fputc ;
M: c-writer stream-write M: c-writer stream-write
c-writer-handle fwrite ; c-writer-handle fwrite ;
@ -27,7 +26,7 @@ TUPLE: c-reader handle ;
C: <c-reader> c-reader C: <c-reader> c-reader
M: c-reader stream-read M: c-reader stream-read
>r >fixnum r> c-reader-handle fread ; c-reader-handle fread ;
M: c-reader stream-read-partial M: c-reader stream-read-partial
stream-read ; stream-read ;
@ -43,41 +42,39 @@ M: c-reader stream-read1
] if ; ] if ;
M: c-reader stream-read-until 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 ; over empty? over not and [ 2drop f f ] when ;
M: c-reader dispose M: c-reader dispose
c-reader-handle fclose ; 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 ; M: object init-io ;
: stdin-handle 11 getenv ; : stdin-handle 11 getenv ;
: stdout-handle 12 getenv ; : stdout-handle 12 getenv ;
: stderr-handle 38 getenv ; : stderr-handle 38 getenv ;
M: object init-stdio M: object (init-stdio)
stdin-handle stdout-handle <duplex-c-stream> stdio set-global stdin-handle <c-reader>
stderr-handle <c-writer> <plain-writer> stderr set-global ; stdout-handle <c-writer>
stderr-handle <c-writer> ;
M: object io-multiplex 60 60 * 1000 * or (sleep) ; M: object io-multiplex 60 60 * 1000 * or (sleep) ;
M: object <file-reader> M: object (file-reader)
"rb" fopen <c-reader> <line-reader> ; "rb" fopen <c-reader> ;
M: object <file-writer> M: object (file-writer)
"wb" fopen <c-writer> <plain-writer> ; "wb" fopen <c-writer> ;
M: object <file-appender> M: object (file-appender)
"ab" fopen <c-writer> <plain-writer> ; "ab" fopen <c-writer> ;
: show ( msg -- ) : show ( msg -- )
#! A word which directly calls primitives. It is used to #! A word which directly calls primitives. It is used to
#! print stuff from contexts where the I/O system would #! print stuff from contexts where the I/O system would
#! otherwise not work (tools.deploy.shaker, the I/O #! otherwise not work (tools.deploy.shaker, the I/O
#! multiplexer thread). #! 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 ; USING: io.streams.duplex io kernel continuations tools.test ;
IN: temporary IN: io.streams.duplex.tests
! Test duplex stream close behavior ! Test duplex stream close behavior
TUPLE: closing-stream closed? ; 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 USING: io io.streams.string io.streams.nested kernel math
namespaces io.styles tools.test ; 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-span-stream } ", "
{ $link make-block-stream } " and " { $link make-block-stream } " and "
{ $link make-cell-stream } "." { $link make-cell-stream } "."
{ $subsection plain-writer } { $subsection plain-writer } ;
{ $subsection <plain-writer> } ;
ABOUT: "io.streams.plain" ABOUT: "io.streams.plain"
HELP: plain-writer 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> } "." } { $class-description "An output stream mixin providing an implementation of the extended stream output protocol in a trivial way." }
{ $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." }
{ $see-also "stream-protocol" } ; { $see-also "stream-protocol" } ;

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

@ -1,13 +1,9 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.streams.nested ;
IN: io.streams.plain IN: io.streams.plain
USING: generic assocs kernel math namespaces sequences
io.styles io io.streams.nested ;
TUPLE: plain-writer ; MIXIN: plain-writer
: <plain-writer> ( stream -- new-stream )
plain-writer construct-delegate ;
M: plain-writer stream-nl M: plain-writer stream-nl
CHAR: \n swap stream-write1 ; 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 HELP: with-string-reader
{ $values { "str" string } { "quot" quotation } } { $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 ; USING: io.streams.string io kernel arrays namespaces tools.test ;
IN: temporary IN: io.streams.string.tests
[ "line 1" CHAR: l ] [ "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. ! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.string IN: io.streams.string
USING: io kernel math namespaces sequences sbufs strings USING: io kernel math namespaces sequences sbufs strings
generic splitting io.streams.plain io.streams.lines growable generic splitting growable continuations io.streams.plain
continuations ; io.encodings ;
M: growable dispose drop ; M: growable dispose drop ;
@ -12,38 +12,19 @@ M: growable stream-write push-all ;
M: growable stream-flush drop ; M: growable stream-flush drop ;
: <string-writer> ( -- stream ) : <string-writer> ( -- stream )
512 <sbuf> <plain-writer> ; 512 <sbuf> ;
: with-string-writer ( quot -- str ) : with-string-writer ( quot -- str )
<string-writer> swap [ stdio get ] compose with-stream* <string-writer> swap [ stdio get ] compose with-stream*
>string ; inline >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 ; M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
: harden-as ( seq growble-exemplar -- newseq ) : harden-as ( seq growble-exemplar -- newseq )
underlying like ; underlying like ;
: growable-read-until ( growable n -- str ) : 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 ; : find-last-sep swap [ memq? ] curry find-last drop ;
@ -69,7 +50,31 @@ M: growable stream-read-partial
stream-read ; stream-read ;
: <string-reader> ( str -- stream ) : <string-reader> ( str -- stream )
>sbuf dup reverse-here <line-reader> ; >sbuf dup reverse-here f <decoder> ;
: with-string-reader ( str quot -- ) : with-string-reader ( str quot -- )
>r <string-reader> r> with-stream ; inline >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 USE: math
: foo 2 2 + ; : foo 2 2 + ;
FORGET: foo FORGET: foo

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

@ -1,7 +1,7 @@
USING: arrays byte-arrays kernel kernel.private math memory USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs ; continuations prettyprint io.streams.string debugger assocs ;
IN: temporary IN: kernel.tests
[ 0 ] [ f size ] unit-test [ 0 ] [ f size ] unit-test
[ t ] [ [ \ = \ = ] all-equal? ] 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 USING: io io.streams.string io.streams.duplex listener
tools.test parser math namespaces continuations vocabs kernel tools.test parser math namespaces continuations vocabs kernel
compiler.units ; compiler.units ;
IN: temporary IN: listener.tests
: hello "Hi" print ; parsing : hello "Hi" print ; parsing
@ -9,7 +9,7 @@ IN: temporary
<string-reader> stream-read-quot ; <string-reader> stream-read-quot ;
[ [ ] ] [ [ [ ] ] [
"USE: temporary hello" parse-interactive "USE: listener.tests hello" parse-interactive
] unit-test ] unit-test
[ [
@ -45,6 +45,6 @@ IN: temporary
] unit-test ] unit-test
[ ] [ [ ] [
"IN: temporary : hello\n\"world\" ;" parse-interactive "IN: listener.tests : hello\n\"world\" ;" parse-interactive
drop drop
] unit-test ] unit-test

4
core/listener/listener.factor
View File

@ -1,7 +1,7 @@
! 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 hashtables io kernel math math.parser memory 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 io.streams.duplex vectors words generic system combinators
tuples continuations debugger definitions compiler.units ; tuples continuations debugger definitions compiler.units ;
IN: listener IN: listener
@ -32,7 +32,7 @@ GENERIC: stream-read-quot ( stream -- quot/f )
3drop f 3drop f
] if ; ] if ;
M: line-reader stream-read-quot M: object stream-read-quot
V{ } clone read-quot-loop ; V{ } clone read-quot-loop ;
M: duplex-stream stream-read-quot M: duplex-stream stream-read-quot

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