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

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

db4
Bruno Deferrari 2008-05-07 17:09:07 -03:00
parent 671e084f5b cd8f20aa88
commit cbc9978466
419 changed files with 8298 additions and 2511 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Factor.app/Contents/Info.plist
View File

@ -32,7 +32,7 @@
<key>CFBundlePackageType</key>
<string>APPL</string>
<key>NSHumanReadableCopyright</key>
<string>Copyright © 2003-2007, Slava Pestov and friends</string>
<string>Copyright © 2003-2008, Slava Pestov and friends</string>
<key>NSServices</key>
<array>
<dict>

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

@ -265,7 +265,7 @@ ARTICLE: "embedding-restrictions" "Embedding API restrictions"
ARTICLE: "embedding-factor" "What embedding looks like from Factor"
"Factor code will run inside an embedded instance in the same way it would run in a stand-alone instance."
$nl
"One exception is the global " { $link stdio } " stream, which is by default not bound to the terminal where the process is running, to avoid conflicting with any I/O the host process might perform. To initialize the terminal stream, " { $link init-stdio } " must be called explicitly."
"One exception is that the global " { $link input-stream } " and " { $link output-stream } " streams are not bound by default, to avoid conflicting with any I/O the host process might perform. The " { $link init-stdio } " words must be called explicitly to initialize terminal streams."
$nl
"There is a word which can detect when Factor is embedded:"
{ $subsection embedded? }

6
core/assocs/assocs-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences
sequences.private namespaces classes math ;
sequences.private namespaces math ;
IN: assocs
ARTICLE: "alists" "Association lists"
@ -68,7 +68,7 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
{ $subsection subassoc? }
{ $subsection assoc-subset? }
{ $subsection assoc-intersect }
{ $subsection update }
{ $subsection assoc-union }
@ -215,7 +215,7 @@ HELP: assoc-all?
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: subassoc?
HELP: assoc-subset?
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
{ $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ;

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

@ -3,13 +3,13 @@ USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;
[ t ] [ H{ } dup subassoc? ] unit-test
[ f ] [ H{ { 1 3 } } H{ } subassoc? ] unit-test
[ t ] [ H{ } H{ { 1 3 } } subassoc? ] unit-test
[ t ] [ H{ { 1 3 } } H{ { 1 3 } } subassoc? ] unit-test
[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subassoc? ] unit-test
[ f ] [ H{ { 1 f } } H{ } subassoc? ] unit-test
[ t ] [ H{ { 1 f } } H{ { 1 f } } subassoc? ] unit-test
[ t ] [ H{ } dup assoc-subset? ] unit-test
[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
[ t ] [ H{ } H{ { 1 3 } } assoc-subset? ] unit-test
[ t ] [ H{ { 1 3 } } H{ { 1 3 } } assoc-subset? ] unit-test
[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } assoc-subset? ] unit-test
[ f ] [ H{ { 1 f } } H{ } assoc-subset? ] unit-test
[ t ] [ H{ { 1 f } } H{ { 1 f } } assoc-subset? ] unit-test
! Test some combinators
[

4
core/assocs/assocs.factor
View File

@ -98,11 +98,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: assoc-stack ( key seq -- value )
dup length 1- swap (assoc-stack) ;
: subassoc? ( assoc1 assoc2 -- ? )
: assoc-subset? ( assoc1 assoc2 -- ? )
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
: assoc= ( assoc1 assoc2 -- ? )
2dup subassoc? >r swap subassoc? r> and ;
[ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
: assoc-hashcode ( n assoc -- code )
[

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

@ -305,12 +305,12 @@ M: wrapper '
[ emit ] emit-object ;
! Strings
: emit-chars ( seq -- )
: emit-bytes ( seq -- )
bootstrap-cell <groups>
big-endian get [ [ be> ] map ] [ [ le> ] map ] if
emit-seq ;
: pack-string ( string -- newstr )
: pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ;
: emit-string ( string -- ptr )
@ -318,7 +318,7 @@ M: wrapper '
dup length emit-fixnum
f ' emit
f ' emit
pack-string emit-chars
pad-bytes emit-bytes
] emit-object ;
M: string '
@ -335,7 +335,11 @@ M: string '
[ 0 emit-fixnum ] emit-object
] bi* ;
M: byte-array ' byte-array emit-dummy-array ;
M: byte-array '
byte-array type-number object tag-number [
dup length emit-fixnum
pad-bytes emit-bytes
] emit-object ;
M: bit-array ' bit-array emit-dummy-array ;
@ -400,8 +404,8 @@ M: quotation '
[
{
dictionary source-files builtins
update-map class<-cache class-not-cache
classes-intersect-cache class-and-cache
update-map class<=-cache
class-not-cache classes-intersect-cache class-and-cache
class-or-cache
} [ dup get swap bootstrap-word set ] each
] H{ } make-assoc
@ -471,7 +475,7 @@ M: quotation '
"Writing image to " write
architecture get boot-image-name resource-path
[ write "..." print flush ]
[ binary <file-writer> [ (write-image) ] with-stream ] bi ;
[ binary [ (write-image) ] with-file-writer ] bi ;
PRIVATE>

17
core/bootstrap/primitives.factor
View File

@ -59,6 +59,7 @@ num-types get f <array> builtins set
"arrays"
"bit-arrays"
"byte-arrays"
"byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
@ -452,6 +453,22 @@ tuple
}
} define-tuple-class
"byte-vector" "byte-vectors" create
tuple
{
{
{ "byte-array" "byte-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"curry" "kernel" create
tuple
{

6
core/bootstrap/stage2.factor
View File

@ -44,10 +44,6 @@ SYMBOL: bootstrap-time
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ;
! Wrap everything in a catch which starts a listener so
! you can see what went wrong, instead of dealing with a
! fep
! We time bootstrap
millis >r
@ -91,7 +87,7 @@ f error-continuation set-global
parse-command-line
run-user-init
"run" get run
stdio get [ stream-flush ] when*
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover
] set-boot-quot

1
core/bootstrap/syntax.factor
View File

@ -16,6 +16,7 @@ IN: bootstrap.syntax
"?{"
"BIN:"
"B{"
"BV{"
"C:"
"CHAR:"
"DEFER:"

0
extra/byte-vectors/byte-vectors-docs.factor → core/byte-vectors/byte-vectors-docs.factor
View File

0
extra/byte-vectors/byte-vectors-tests.factor → core/byte-vectors/byte-vectors-tests.factor
View File

19
extra/byte-vectors/byte-vectors.factor → core/byte-vectors/byte-vectors.factor
View File

@ -1,20 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays prettyprint.backend
parser accessors ;
sequences.private growable byte-arrays ;
IN: byte-vectors
TUPLE: byte-vector underlying fill ;
M: byte-vector underlying underlying>> { byte-array } declare ;
M: byte-vector set-underlying (>>underlying) ;
M: byte-vector length fill>> { array-capacity } declare ;
M: byte-vector set-fill (>>fill) ;
<PRIVATE
: byte-array>vector ( byte-array length -- byte-vector )
@ -43,9 +32,3 @@ M: byte-vector equal?
M: byte-array new-resizable drop <byte-vector> ;
INSTANCE: byte-vector growable
: BV{ \ } [ >byte-vector ] parse-literal ; parsing
M: byte-vector >pprint-sequence ;
M: byte-vector pprint-delims drop \ BV{ \ } ;

0
extra/byte-vectors/summary.txt → core/byte-vectors/summary.txt
View File

0
extra/byte-vectors/tags.txt → core/byte-vectors/tags.txt
View File

51
core/checksums/checksums-docs.factor Normal file
View File

@ -0,0 +1,51 @@
USING: help.markup help.syntax kernel math sequences quotations
math.private byte-arrays strings ;
IN: checksums
HELP: checksum
{ $class-description "The class of checksum algorithms." } ;
HELP: hex-string
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
{ $examples
{ $example "USING: checksums io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
}
{ $notes "Numbers are zero-padded on the left." } ;
HELP: checksum-stream
{ $values { "stream" "an input stream" } { "checksum" "a checksum specifier" } { "value" byte-array } }
{ $contract "Computes the checksum of all data read from the stream." }
{ $side-effects "stream" } ;
HELP: checksum-bytes
{ $values { "bytes" "a sequence of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
{ $contract "Computes the checksum of all data in a sequence." } ;
HELP: checksum-lines
{ $values { "lines" "a sequence of sequences of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
{ $contract "Computes the checksum of all data in a sequence." } ;
HELP: checksum-file
{ $values { "path" "a pathname specifier" } { "checksum" "a checksum specifier" } { "value" byte-array } }
{ $contract "Computes the checksum of all data in a file." } ;
ARTICLE: "checksums" "Checksums"
"A " { $emphasis "checksum" } " is a function mapping sequences of bytes to fixed-length strings. While checksums are not one-to-one, a good checksum should have a low probability of collision. Additionally, some checksum algorithms are designed to be hard to reverse, in the sense that finding an input string which hashes to a given checksum string requires a brute-force search."
$nl
"Checksums are instances of a class:"
{ $subsection checksum }
"Operations on checksums:"
{ $subsection checksum-bytes }
{ $subsection checksum-stream }
{ $subsection checksum-lines }
"Checksums should implement at least one of " { $link checksum-bytes } " and " { $link checksum-stream } ". Implementing " { $link checksum-lines } " is optional."
$nl
"Utilities:"
{ $subsection checksum-file }
{ $subsection hex-string }
"Checksum implementations:"
{ $subsection "checksums.crc32" }
{ $vocab-subsection "MD5 checksum" "checksums.md5" }
{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } ;

7
core/checksums/checksums-tests.factor Normal file
View File

@ -0,0 +1,7 @@
IN: checksums.tests
USING: checksums tools.test ;
\ checksum-bytes must-infer
\ checksum-stream must-infer
\ checksum-lines must-infer
\ checksum-file must-infer

25
core/checksums/checksums.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: sequences math.parser io io.streams.byte-array
io.encodings.binary io.files kernel ;
IN: checksums
MIXIN: checksum
GENERIC: checksum-bytes ( bytes checksum -- value )
GENERIC: checksum-stream ( stream checksum -- value )
GENERIC: checksum-lines ( lines checksum -- value )
M: checksum checksum-bytes >r binary <byte-reader> r> checksum-stream ;
M: checksum checksum-stream >r contents r> checksum-bytes ;
M: checksum checksum-lines >r B{ CHAR: \n } join r> checksum-bytes ;
: checksum-file ( path checksum -- value )
>r binary <file-reader> r> checksum-stream ;
: hex-string ( seq -- str )
[ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;

0
core/io/crc32/authors.txt → core/checksums/crc32/authors.txt
View File

11
core/checksums/crc32/crc32-docs.factor Normal file
View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax math ;
IN: checksums.crc32
HELP: crc32
{ $class-description "The CRC32 checksum algorithm." } ;
ARTICLE: "checksums.crc32" "CRC32 checksum"
"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
{ $subsection crc32 } ;
ABOUT: "checksums.crc32"

6
core/checksums/crc32/crc32-tests.factor Normal file
View File

@ -0,0 +1,6 @@
USING: checksums checksums.crc32 kernel math tools.test namespaces ;
[ B{ 0 0 0 0 } ] [ "" crc32 checksum-bytes ] unit-test
[ B{ HEX: cb HEX: f4 HEX: 39 HEX: 26 } ] [ "123456789" crc32 checksum-bytes ] unit-test

26
core/io/crc32/crc32.factor → core/checksums/crc32/crc32.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences sequences.private namespaces
words io io.binary io.files io.streams.string quotations
definitions ;
IN: io.crc32
definitions checksums ;
IN: checksums.crc32
: crc32-polynomial HEX: edb88320 ; inline
@ -20,10 +20,20 @@ IN: io.crc32
mask-byte crc32-table nth-unsafe >bignum
swap -8 shift bitxor ; inline
: crc32 ( seq -- n )
>r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
SINGLETON: crc32
: lines-crc32 ( seq -- n )
HEX: ffffffff tuck [
[ (crc32) ] each CHAR: \n (crc32)
] reduce bitxor ;
INSTANCE: crc32 checksum
: init-crc32 drop >r HEX: ffffffff dup r> ; inline
: finish-crc32 bitxor 4 >be ; inline
M: crc32 checksum-bytes
init-crc32
[ (crc32) ] each
finish-crc32 ;
M: crc32 checksum-lines
init-crc32
[ [ (crc32) ] each CHAR: \n (crc32) ] each
finish-crc32 ;

0
core/io/crc32/summary.txt → core/checksums/crc32/summary.txt
View File

33
core/classes/algebra/algebra-docs.factor
View File

@ -1,14 +1,14 @@
USING: help.markup help.syntax kernel classes ;
USING: help.markup help.syntax kernel classes words
checksums checksums.crc32 sequences math ;
IN: classes.algebra
ARTICLE: "class-operations" "Class operations"
"Set-theoretic operations on classes:"
{ $subsection class< }
{ $subsection class<= }
{ $subsection class-and }
{ $subsection class-or }
{ $subsection classes-intersect? }
"Topological sort:"
{ $subsection sort-classes }
{ $subsection min-class }
"Low-level implementation detail:"
{ $subsection class-types }
@ -17,6 +17,29 @@ ARTICLE: "class-operations" "Class operations"
{ $subsection class-types }
{ $subsection class-tags } ;
ARTICLE: "class-linearization" "Class linearization"
"Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:"
{ $list
"If a generic word defines a method on a mixin class A and another class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both."
{ "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." }
}
"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:"
{ $list
"Built-in classes and tuple classes"
"Predicate classes"
"Union classes"
"Mixin classes"
}
"This means that in the above example, the generic word with methods on a mixin and its sole instance will always call the method for the sole instance, since it is more specific than a mixin class."
$nl
"The second problem is resolved with another tie-breaker. When performing the topological sort of classes, if there are multiple candidates at any given step of the sort, lexicographical order on the class name is used."
$nl
"Operations:"
{ $subsection class< }
{ $subsection sort-classes }
"Metaclass order:"
{ $subsection rank-class } ;
HELP: flatten-builtin-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
@ -29,14 +52,14 @@ HELP: class-types
{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
HELP: class<
HELP: class<=
{ $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
HELP: sort-classes
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;
HELP: class-or
{ $values { "first" class } { "second" class } { "class" class } }

100
core/classes/algebra/algebra-tests.factor
View File

@ -4,9 +4,9 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects kernel.private sbufs ;
random inference effects kernel.private sbufs math.order ;
: class= [ class< ] 2keep swap class< and ;
: class= [ class<= ] [ swap class<= ] 2bi and ;
: class-and* >r class-and r> class= ;
@ -38,43 +38,43 @@ UNION: both first-one union-class ;
[ f ] [ number vector class-and sequence classes-intersect? ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ fixnum \ integer class<= ] unit-test
[ t ] [ \ fixnum \ fixnum class<= ] unit-test
[ f ] [ \ integer \ fixnum class<= ] unit-test
[ t ] [ \ integer \ object class<= ] unit-test
[ f ] [ \ integer \ null class<= ] unit-test
[ t ] [ \ null \ object class<= ] unit-test
[ t ] [ \ generic \ word class< ] unit-test
[ f ] [ \ word \ generic class< ] unit-test
[ t ] [ \ generic \ word class<= ] unit-test
[ f ] [ \ word \ generic class<= ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
[ f ] [ \ reversed \ slice class<= ] unit-test
[ f ] [ \ slice \ reversed class<= ] unit-test
PREDICATE: no-docs < word "documentation" word-prop not ;
UNION: no-docs-union no-docs integer ;
[ t ] [ no-docs no-docs-union class< ] unit-test
[ f ] [ no-docs-union no-docs class< ] unit-test
[ t ] [ no-docs no-docs-union class<= ] unit-test
[ f ] [ no-docs-union no-docs class<= ] unit-test
TUPLE: a ;
TUPLE: b ;
UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
[ t ] [ \ c \ tuple class<= ] unit-test
[ f ] [ \ tuple \ c class<= ] unit-test
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
[ t ] [ \ tuple-class \ class class<= ] unit-test
[ f ] [ \ class \ tuple-class class<= ] unit-test
TUPLE: tuple-example ;
[ t ] [ \ null \ tuple-example class< ] unit-test
[ f ] [ \ object \ tuple-example class< ] unit-test
[ f ] [ \ object \ tuple-example class< ] unit-test
[ t ] [ \ tuple-example \ tuple class< ] unit-test
[ f ] [ \ tuple \ tuple-example class< ] unit-test
[ t ] [ \ null \ tuple-example class<= ] unit-test
[ f ] [ \ object \ tuple-example class<= ] unit-test
[ f ] [ \ object \ tuple-example class<= ] unit-test
[ t ] [ \ tuple-example \ tuple class<= ] unit-test
[ f ] [ \ tuple \ tuple-example class<= ] unit-test
TUPLE: a1 ;
TUPLE: b1 ;
@ -84,57 +84,57 @@ UNION: x1 a1 b1 ;
UNION: y1 a1 c1 ;
UNION: z1 b1 c1 ;
[ f ] [ z1 x1 y1 class-and class< ] unit-test
[ f ] [ z1 x1 y1 class-and class<= ] unit-test
[ t ] [ x1 y1 class-and a1 class< ] unit-test
[ t ] [ x1 y1 class-and a1 class<= ] unit-test
[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test
[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
[ t ] [
growable tuple sequence class-and class<
growable tuple sequence class-and class<=
] unit-test
[ t ] [
growable assoc class-and tuple class<
growable assoc class-and tuple class<=
] unit-test
[ t ] [ object \ f \ f class-not class-or class< ] unit-test
[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
[ f ] [ integer integer class-not classes-intersect? ] unit-test
[ t ] [ array number class-not class< ] unit-test
[ t ] [ array number class-not class<= ] unit-test
[ f ] [ bignum number class-not class< ] unit-test
[ f ] [ bignum number class-not class<= ] unit-test
[ vector ] [ vector class-not class-not ] unit-test
[ t ] [ fixnum fixnum bignum class-or class< ] unit-test
[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
[ f ] [ fixnum class-not integer class-and array class< ] unit-test
[ f ] [ fixnum class-not integer class-and array class<= ] unit-test
[ f ] [ fixnum class-not integer class< ] unit-test
[ f ] [ fixnum class-not integer class<= ] unit-test
[ f ] [ number class-not array class< ] unit-test
[ f ] [ number class-not array class<= ] unit-test
[ f ] [ fixnum class-not array class< ] unit-test
[ f ] [ fixnum class-not array class<= ] unit-test
[ t ] [ number class-not integer class-not class< ] unit-test
[ t ] [ number class-not integer class-not class<= ] unit-test
[ t ] [ vector array class-not class-and vector class= ] unit-test
[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
[ f ] [ fixnum class-not integer class< ] unit-test
[ f ] [ fixnum class-not integer class<= ] unit-test
[ t ] [ null class-not object class= ] unit-test
@ -147,7 +147,7 @@ UNION: z1 b1 c1 ;
[ t ] [
fixnum class-not
fixnum fixnum class-not class-or
class<
class<=
] unit-test
! Test method inlining
@ -241,3 +241,23 @@ UNION: z1 b1 c1 ;
=
] unit-test
] times
SINGLETON: xxx
UNION: yyy xxx ;
[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test
[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
TUPLE: xa ;
TUPLE: xb ;
TUPLE: xc < xa ;
TUPLE: xd < xb ;
TUPLE: xe ;
TUPLE: xf < xb ;
TUPLE: xg < xb ;
TUPLE: xh < xb ;
[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test

69
core/classes/algebra/algebra.factor
View File

@ -2,16 +2,16 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes classes.builtin combinators accessors
sequences arrays vectors assocs namespaces words sorting layouts
math hashtables kernel.private sets ;
math hashtables kernel.private sets math.order ;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
DEFER: (class<)
DEFER: (class<=)
: class< ( first second -- ? )
class<-cache get [ (class<) ] 2cache ;
: class<= ( first second -- ? )
class<=-cache get [ (class<=) ] 2cache ;
DEFER: (class-not)
@ -45,31 +45,31 @@ TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: superclass< ( first second -- ? )
>r superclass r> class< ;
: superclass<= ( first second -- ? )
>r superclass r> class<= ;
: left-union-class< ( first second -- ? )
>r members r> [ class< ] curry all? ;
: left-union-class<= ( first second -- ? )
>r members r> [ class<= ] curry all? ;
: right-union-class< ( first second -- ? )
members [ class< ] with contains? ;
: right-union-class<= ( first second -- ? )
members [ class<= ] with contains? ;
: left-anonymous-union< ( first second -- ? )
>r members>> r> [ class< ] curry all? ;
>r members>> r> [ class<= ] curry all? ;
: right-anonymous-union< ( first second -- ? )
members>> [ class< ] with contains? ;
members>> [ class<= ] with contains? ;
: left-anonymous-intersection< ( first second -- ? )
>r members>> r> [ class< ] curry contains? ;
>r members>> r> [ class<= ] curry contains? ;
: right-anonymous-intersection< ( first second -- ? )
members>> [ class< ] with all? ;
members>> [ class<= ] with all? ;
: anonymous-complement< ( first second -- ? )
[ class>> ] bi@ swap class< ;
[ class>> ] bi@ swap class<= ;
: (class<) ( first second -- -1/0/1 )
: (class<=) ( first second -- -1/0/1 )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup object eq? ] [ 2drop t ] }
@ -77,13 +77,13 @@ C: <anonymous-complement> anonymous-complement
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ over members ] [ left-union-class< ] }
{ [ over members ] [ left-union-class<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class< ] }
{ [ over superclass ] [ superclass< ] }
{ [ dup members ] [ right-union-class<= ] }
{ [ over superclass ] [ superclass<= ] }
[ 2drop f ]
} cond ;
@ -94,7 +94,7 @@ C: <anonymous-complement> anonymous-complement
members>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
class>> class< not ;
class>> class<= not ;
: union-class-intersect? ( first second -- ? )
members [ classes-intersect? ] with contains? ;
@ -103,7 +103,7 @@ C: <anonymous-complement> anonymous-complement
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
{ [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
[ swap classes-intersect? ]
} cond ;
@ -145,8 +145,8 @@ C: <anonymous-complement> anonymous-complement
: (class-and) ( first second -- class )
{
{ [ 2dup class< ] [ drop ] }
{ [ 2dup swap class< ] [ nip ] }
{ [ 2dup class<= ] [ drop ] }
{ [ 2dup swap class<= ] [ nip ] }
{ [ 2dup classes-intersect? not ] [ 2drop null ] }
{ [ dup members ] [ right-union-and ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-and ] }
@ -165,8 +165,8 @@ C: <anonymous-complement> anonymous-complement
: (class-or) ( first second -- class )
{
{ [ 2dup class< ] [ nip ] }
{ [ 2dup swap class< ] [ drop ] }
{ [ 2dup class<= ] [ nip ] }
{ [ 2dup swap class<= ] [ drop ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }
[ 2array <anonymous-union> ]
@ -180,14 +180,19 @@ C: <anonymous-complement> anonymous-complement
[ <anonymous-complement> ]
} cond ;
: class< ( first second -- ? )
{
{ [ 2dup class<= not ] [ 2drop f ] }
{ [ 2dup swap class<= not ] [ 2drop t ] }
[ [ rank-class ] bi@ < ]
} cond ;
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
with filter empty?
] curry find [ "Topological sort failed" throw ] unless* ;
dup [ [ class< ] with contains? not ] curry find-last
[ "Topological sort failed" throw ] unless* ;
: sort-classes ( seq -- newseq )
>vector
[ [ word-name ] compare ] sort >vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;
@ -195,7 +200,7 @@ C: <anonymous-complement> anonymous-complement
: min-class ( class seq -- class/f )
over [ classes-intersect? ] curry filter
dup empty? [ 2drop f ] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
: (flatten-class) ( class -- )
@ -212,7 +217,7 @@ C: <anonymous-complement> anonymous-complement
: flatten-builtin-class ( class -- assoc )
flatten-class [
dup tuple class< [ 2drop tuple tuple ] when
dup tuple class<= [ 2drop tuple tuple ] when
] assoc-map ;
: class-types ( class -- seq )

2
core/classes/builtin/builtin.factor
View File

@ -16,3 +16,5 @@ PREDICATE: builtin-class < class
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;
M: builtin-class rank-class drop 0 ;

1
core/classes/classes-docs.factor
View File

@ -47,6 +47,7 @@ $nl
$nl
"Classes can be inspected and operated upon:"
{ $subsection "class-operations" }
{ $subsection "class-linearization" }
{ $see-also "class-index" } ;
ABOUT: "classes"

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

@ -18,14 +18,14 @@ GENERIC: generic-update-test ( x -- y )
M: union-1 generic-update-test drop "union-1" ;
[ f ] [ bignum union-1 class< ] unit-test
[ t ] [ union-1 number class< ] unit-test
[ f ] [ bignum union-1 class<= ] unit-test
[ t ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test
[ t ] [ bignum union-1 class<= ] unit-test
[ f ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
@ -52,7 +52,7 @@ M: sequence-mixin collection-size length ;
M: assoc-mixin collection-size assoc-size ;
[ t ] [ array sequence-mixin class< ] unit-test
[ t ] [ array sequence-mixin class<= ] unit-test
[ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
[ 3 ] [ { 1 2 3 } collection-size ] unit-test
[ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
@ -67,14 +67,14 @@ MIXIN: mx1
INSTANCE: integer mx1
[ t ] [ integer mx1 class< ] unit-test
[ t ] [ mx1 integer class< ] unit-test
[ t ] [ mx1 number class< ] unit-test
[ t ] [ integer mx1 class<= ] unit-test
[ t ] [ mx1 integer class<= ] unit-test
[ t ] [ mx1 number class<= ] unit-test
"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
[ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test
[ t ] [ array mx1 class<= ] unit-test
[ f ] [ mx1 number class<= ] unit-test
[ \ mx1 forget ] with-compilation-unit
@ -94,14 +94,14 @@ UNION: redefine-bug-1 fixnum ;
UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ quotation redefine-bug-2 class< ] unit-test
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ quotation redefine-bug-2 class<= ] unit-test
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ bignum redefine-bug-2 class< ] unit-test
[ t ] [ bignum redefine-bug-1 class<= ] unit-test
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ bignum redefine-bug-2 class<= ] unit-test
USE: io.streams.string

8
core/classes/classes.factor
View File

@ -5,21 +5,21 @@ slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs ;
IN: classes
SYMBOL: class<-cache
SYMBOL: class<=-cache
SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache
SYMBOL: class-and-cache
SYMBOL: class-or-cache
: init-caches ( -- )
H{ } clone class<-cache set
H{ } clone class<=-cache set
H{ } clone class-not-cache set
H{ } clone classes-intersect-cache set
H{ } clone class-and-cache set
H{ } clone class-or-cache set ;
: reset-caches ( -- )
class<-cache get clear-assoc
class<=-cache get clear-assoc
class-not-cache get clear-assoc
classes-intersect-cache get clear-assoc
class-and-cache get clear-assoc
@ -57,6 +57,8 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
#! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
M: word reset-class drop ;

2
core/classes/mixin/mixin.factor
View File

@ -9,6 +9,8 @@ PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
{ "class" "metaclass" "members" "mixin" } reset-props ;
M: mixin-class rank-class drop 3 ;
: redefine-mixin-class ( class members -- )
dupd define-union-class
t "mixin" set-word-prop ;

2
core/classes/predicate/predicate.factor
View File

@ -30,3 +30,5 @@ M: predicate-class reset-class
"predicate-definition"
"superclass"
} reset-props ;
M: predicate-class rank-class drop 1 ;

30
core/classes/tuple/tuple-tests.factor
View File

@ -233,8 +233,8 @@ TUPLE: laptop < computer battery ;
C: <laptop> laptop
[ t ] [ laptop tuple-class? ] unit-test
[ t ] [ laptop tuple class< ] unit-test
[ t ] [ laptop computer class< ] unit-test
[ t ] [ laptop tuple class<= ] unit-test
[ t ] [ laptop computer class<= ] unit-test
[ t ] [ laptop computer classes-intersect? ] unit-test
[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
@ -266,8 +266,8 @@ TUPLE: server < computer rackmount ;
C: <server> server
[ t ] [ server tuple-class? ] unit-test
[ t ] [ server tuple class< ] unit-test
[ t ] [ server computer class< ] unit-test
[ t ] [ server tuple class<= ] unit-test
[ t ] [ server computer class<= ] unit-test
[ t ] [ server computer classes-intersect? ] unit-test
[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
@ -286,8 +286,8 @@ test-server-slot-values
[ f ] [ "server" get laptop? ] unit-test
[ f ] [ "laptop" get server? ] unit-test
[ f ] [ server laptop class< ] unit-test
[ f ] [ laptop server class< ] unit-test
[ f ] [ server laptop class<= ] unit-test
[ f ] [ laptop server class<= ] unit-test
[ f ] [ laptop server classes-intersect? ] unit-test
[ f ] [ 1 2 <computer> laptop? ] unit-test
@ -306,9 +306,9 @@ TUPLE: electronic-device ;
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
[ f ] [ electronic-device laptop class< ] unit-test
[ t ] [ server electronic-device class< ] unit-test
[ t ] [ laptop server class-or electronic-device class< ] unit-test
[ f ] [ electronic-device laptop class<= ] unit-test
[ t ] [ server electronic-device class<= ] unit-test
[ t ] [ laptop server class-or electronic-device class<= ] unit-test
[ t ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
@ -542,3 +542,15 @@ TUPLE: another-forget-accessors-test ;
! Missing error check
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
TUPLE: subclass-forget-test ;
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
TUPLE: subclass-forget-test-2 < subclass-forget-test ;
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail

4
core/classes/tuple/tuple.factor
View File

@ -102,7 +102,7 @@ ERROR: bad-superclass class ;
dup tuple-predicate-quot define-predicate ;
: superclass-size ( class -- n )
superclasses 1 head-slice*
superclasses but-last-slice
[ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs )
@ -226,6 +226,8 @@ M: tuple-class reset-class
} reset-props
] bi ;
M: tuple-class rank-class drop 0 ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;

2
core/classes/union/union.factor
View File

@ -30,3 +30,5 @@ M: union-class update-class define-union-predicate ;
M: union-class reset-class
{ "class" "metaclass" "members" } reset-props ;
M: union-class rank-class drop 2 ;

59
core/compiler/compiler.factor
View File

@ -4,38 +4,55 @@ USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger words compiler.units
continuations vocabs assocs alien.compiler dlists optimizer
definitions math compiler.errors threads graphs generic
inference ;
inference combinators ;
IN: compiler
: ripple-up ( word -- )
compiled-usage [ drop queue-compile ] assoc-each ;
: save-effect ( word effect -- )
over "compiled-uses" word-prop [
2dup swap "compiled-effect" word-prop =
[ over ripple-up ] unless
] when
"compiled-effect" set-word-prop ;
: finish-compile ( word effect dependencies -- )
>r dupd save-effect r>
over compiled-unxref
over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[
[ word-dataflow optimize ] keep dup generate
] computing-dependencies ;
over "compiled-effect" word-prop = [
dup "compiled-uses" word-prop
[ dup ripple-up ] when
] unless drop
]
[ "compiled-effect" set-word-prop ] 2bi ;
: compile-begins ( word -- )
f swap compiler-error ;
: compile-failed ( word error -- )
f pick compiled get set-at
swap compiler-error ;
[ swap compiler-error ]
[
drop
[ f swap compiled get set-at ]
[ f save-effect ]
bi
] 2bi ;
: compile-succeeded ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
dup compiled-crossref?
[ dependencies get compiled-xref ] [ drop ] if
] tri ;
: (compile) ( word -- )
f over compiler-error
[ dup compile-succeeded finish-compile ]
[ dupd compile-failed f save-effect ]
recover ;
[
H{ } clone dependencies set
{
[ compile-begins ]
[
[ word-dataflow ] [ compile-failed return ] recover
optimize
]
[ dup generate ]
[ compile-succeeded ]
} cleave
] curry with-return ;
: compile-loop ( assoc -- )
dup assoc-empty? [ drop ] [

10
core/compiler/errors/errors-docs.factor
View File

@ -21,19 +21,19 @@ HELP: compiler-error
HELP: compiler-error.
{ $values { "error" "an error" } { "word" word } }
{ $description "Prints a compiler error to the " { $link stdio } " stream." } ;
{ $description "Prints a compiler error to " { $link output-stream } "." } ;
HELP: compiler-errors.
{ $values { "type" symbol } }
{ $description "Prints compiler errors to the " { $link stdio } " stream. The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
HELP: :linkage
{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
{ :errors :warnings } related-words

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

@ -34,7 +34,7 @@ $nl
{ $code
"<external-resource> ... do stuff ... dispose"
}
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."

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

@ -1,6 +1,6 @@
USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays words
kernel.private ;
kernel.private accessors ;
IN: continuations.tests
: (callcc1-test)
@ -39,7 +39,7 @@ IN: continuations.tests
"!!! The following error is part of the test" print
[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test
[ ] [ [ [ "2 car" ] eval ] try ] unit-test
[ f throw ] must-fail
@ -100,3 +100,22 @@ SYMBOL: error-counter
[ 3 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test
] with-scope
TUPLE: dispose-error ;
M: dispose-error dispose 3 throw ;
TUPLE: dispose-dummy disposed? ;
M: dispose-dummy dispose t >>disposed? drop ;
T{ dispose-error } "a" set
T{ dispose-dummy } "b" set
[ f ] [ "b" get disposed?>> ] unit-test
[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
[ t ] [ "b" get disposed?>> ] unit-test
[ ] [ [ return ] with-return ] unit-test

13
core/continuations/continuations.factor
View File

@ -101,6 +101,14 @@ PRIVATE>
: continue ( continuation -- )
f swap continue-with ;
SYMBOL: return-continuation
: with-return ( quot -- )
[ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
: return ( -- )
return-continuation get continue ;
GENERIC: compute-restarts ( error -- seq )
<PRIVATE
@ -138,6 +146,11 @@ SYMBOL: thread-error-hook
GENERIC: dispose ( object -- )
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
] { } make dup empty? [ drop ] [ peek rethrow ] if ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline

14
core/debugger/debugger-docs.factor
View File

@ -1,7 +1,7 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations system debugger.private
io.files.private ;
io.files.private listener ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"
@ -64,7 +64,7 @@ HELP: :3
HELP: error.
{ $values { "error" "an error" } }
{ $contract "Print an error to the " { $link stdio } " stream. You can define methods on this generic word to print human-readable messages for custom errors." }
{ $contract "Print an error to " { $link output-stream } ". You can define methods on this generic word to print human-readable messages for custom errors." }
{ $notes "Code should call " { $link print-error } " instead, which handles the case where the printing of the error itself throws an error." } ;
HELP: error-help
@ -75,19 +75,15 @@ HELP: error-help
HELP: print-error
{ $values { "error" "an error" } }
{ $description "Print an error to the " { $link stdio } " stream." }
{ $description "Print an error to " { $link output-stream } "." }
{ $notes "This word is called by the listener and other tools which report caught errors to the user." } ;
HELP: restarts.
{ $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
HELP: error-hook
{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
HELP: try
{ $values { "quot" "a quotation" } }
{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
{ $description "Attempts to call a quotation; if it throws an error, the error is printed to " { $link output-stream } ", stacks are restored, and execution continues after the call to " { $link try } "." }
{ $examples
"The following example prints an error and keeps going:"
{ $code

40
core/debugger/debugger.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators
generic.math io.streams.duplex classes.builtin classes
compiler.units generic.standard vocabs threads threads.private
init kernel.private libc io.encodings mirrors accessors
math.order ;
math namespaces prettyprint prettyprint.config sequences assocs
sequences.private strings io.styles vectors words system
splitting math.parser classes.tuple continuations
continuations.private combinators generic.math
classes.builtin classes compiler.units generic.standard vocabs
threads threads.private init kernel.private libc io.encodings
mirrors accessors math.order ;
IN: debugger
GENERIC: error. ( error -- )
@ -64,17 +64,14 @@ M: string error. print ;
[ global [ "Error in print-error!" print drop ] bind ]
recover ;
SYMBOL: error-hook
[
: print-error-and-restarts ( error -- )
print-error
restarts.
nl
"Type :help for debugging help." print flush
] error-hook set-global
"Type :help for debugging help." print flush ;
: try ( quot -- )
[ error-hook get call ] recover ;
[ print-error-and-restarts ] recover ;
ERROR: assert got expect ;
@ -209,9 +206,6 @@ M: no-next-method summary
M: inconsistent-next-method summary
drop "Executing call-next-method with inconsistent parameters" ;
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
drop "Invalid parameters for create-method" ;
@ -241,6 +235,15 @@ M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ;
M: assert error.
"Assertion failed" print
standard-table-style [
15 length-limit set
5 line-limit set
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
] tabular-output ;
M: immutable summary drop "Sequence is immutable" ;
M: redefine-error error.
@ -267,8 +270,7 @@ M: double-free summary
M: realloc-error summary
drop "Memory reallocation failed" ;
: error-in-thread. ( -- )
error-thread get-global
: error-in-thread. ( thread -- )
"Error in thread " write
[
dup thread-id #
@ -282,7 +284,7 @@ M: thread error-in-thread ( error thread -- )
die drop
] [
global [
error-in-thread. print-error flush
error-thread get-global error-in-thread. print-error flush
] bind
] if ;

14
core/generator/registers/registers.factor
View File

@ -181,11 +181,11 @@ INSTANCE: constant value
: %unbox-c-ptr ( dst src -- )
dup operand-class {
{ [ dup \ f class< ] [ drop %unbox-f ] }
{ [ dup simple-alien class< ] [ drop %unbox-alien ] }
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
{ [ dup \ f class<= ] [ drop %unbox-f ] }
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class<= ] [ drop %unbox-byte-array ] }
{ [ dup float-array class<= ] [ drop %unbox-byte-array ] }
[ drop %unbox-any-c-ptr ]
} cond ; inline
@ -569,7 +569,7 @@ M: loc lazy-store
{
{ f [ drop t ] }
{ known-tag [ class-tag >boolean ] }
[ class< ]
[ class<= ]
} case ;
: spec-matches? ( value spec -- ? )
@ -644,7 +644,7 @@ PRIVATE>
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
operand-class immediate class< ;
operand-class immediate class<= ;
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom

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

@ -4,22 +4,22 @@ generic.standard generic.math combinators ;
IN: generic
ARTICLE: "method-order" "Method precedence"
"Consider the case where a generic word has methods on two classes, say A and B, which share a non-empty intersection. If the generic word is called on an object which is an instance of both A and B, a choice of method must be made. If A is a subclass of B, the method for A to be called; this makes sense, because we're defining general behavior for instances of B, and refining it for instances of A. Conversely, if B is a subclass of A, then we expect B's method to be called. However, if neither is a subclass of the other, we have an ambiguous situation and undefined behavior will result. Either the method for A or B will be called, and there is no way to predict ahead of time."
$nl
"The generic word system linearly orders all the methods on a generic word by their class. Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in order. If methods are defined on overlapping classes, this order will fail to be unique and the problem described above can occur."
"Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in linear order (" { $link "class-linearization" } ")."
$nl
"Here is an example:"
{ $code
"GENERIC: explain"
"M: number explain drop \"an integer\" print ;"
"M: sequence explain drop \"a sequence\" print ;"
"M: object explain drop \"an object\" print ;"
"M: number explain drop \"a number\" print ;"
"M: sequence explain drop \"a sequence\" print ;"
}
"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. As a result, the outcome of calling " { $snippet "bar" } " with an " { $link integer } " on the stack is undefined - either one of the two methods may be called. This situation can lead to subtle bugs. To avoid it, explicitly disambiguate the method order by defining a method on the intersection. If in this case we want integers to behave like numbers, we would also define:"
{ $code "M: integer explain drop \"an integer\" print ;" }
"On the other hand, if we want integers to behave like sequences here, we could define:"
"The linear order is the following, from least-specific to most-specific:"
{ $code "{ object sequence number }" }
"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. Calling " { $snippet "explain" } " with an integer on the stack will print " { $snippet "a number" } " because " { $link number } " precedes " { $link sequence } " in the class linearization order. If this was not the desired outcome, define a method on the intersection:"
{ $code "M: integer explain drop \"a sequence\" print ;" }
"The " { $link order } " word can be useful to clarify method dispatch order."
"Now, the linear order is the following, from least-specific to most-specific:"
{ $code "{ object sequence number integer }" }
"The " { $link order } " word can be useful to clarify method dispatch order:"
{ $subsection order } ;
ARTICLE: "generic-introspection" "Generic word introspection"

2
core/generic/generic.factor
View File

@ -35,7 +35,7 @@ PREDICATE: method-spec < pair
GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f )
order [ class< ] with filter reverse dup length 1 =
order [ class<= ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ;
: next-method ( class generic -- class/f )

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

@ -10,14 +10,14 @@ PREDICATE: math-class < class
dup null bootstrap-word eq? [
drop f
] [
number bootstrap-word class<
number bootstrap-word class<=
] if ;
: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
: math-precedence ( class -- pair )
{
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup null class<= ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
[ drop { 100 100 } ]
} cond ;

4
core/generic/standard/engines/engines.factor
View File

@ -26,8 +26,8 @@ M: method-body engine>quot 1quotation ;
alist>quot ;
: split-methods ( assoc class -- first second )
[ [ nip class< not ] curry assoc-filter ]
[ [ nip class< ] curry assoc-filter ] 2bi ;
[ [ nip class<= not ] curry assoc-filter ]
[ [ nip class<= ] curry assoc-filter ] 2bi ;
: convert-methods ( assoc class word -- assoc' )
over >r >r split-methods dup assoc-empty? [

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

@ -11,7 +11,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
[ >r "predicate" word-prop picker prepend r> ] assoc-map ;
: keep-going? ( assoc -- ? )
assumed get swap second first class< ;
assumed get swap second first class<= ;
: prune-redundant-predicates ( assoc -- default assoc' )
{

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

@ -127,8 +127,6 @@ M: echelon-dispatch-engine engine>quot
1 slot { tuple-layout } declare
5 slot ; inline
: unclip-last [ 1 head* ] [ peek ] bi ;
M: tuple-dispatch-engine engine>quot
[
picker %

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

@ -143,7 +143,7 @@ M: literal-constraint constraint-satisfied?
[ swap literal>> eql? ] [ 2drop f ] if ;
M: class-constraint constraint-satisfied?
[ value>> value-class* ] [ class>> ] bi class< ;
[ value>> value-class* ] [ class>> ] bi class<= ;
M: pair apply-constraint
first2 2dup constraints get set-at

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

@ -135,7 +135,7 @@ HELP: infer
HELP: infer.
{ $values { "quot" "a quotation" } }
{ $description "Attempts to infer the quotation's stack effect, and prints this data to the " { $link stdio } " stream." }
{ $description "Attempts to infer the quotation's stack effect, and prints this data to " { $link output-stream } "." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
{ infer infer. } related-words

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

@ -1,5 +1,9 @@
IN: inference.state.tests
USING: tools.test inference.state words ;
USING: tools.test inference.state words kernel namespaces ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep ;
inline
SYMBOL: a
SYMBOL: b

4
core/inference/state/state.factor
View File

@ -36,10 +36,6 @@ SYMBOL: dependencies
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
] [ 3drop ] if ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep ;
inline
! Did the current control-flow path throw an error?
SYMBOL: terminated?

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

@ -32,7 +32,7 @@ IN: inference.transforms
drop [ no-case ]
] [
dup peek quotation? [
dup peek swap 1 head*
dup peek swap but-last
] [
[ no-case ] swap
] if case>quot

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

@ -108,4 +108,4 @@ HELP: me
HELP: inspector-hook
{ $var-description "A quotation with stack effect " { $snippet "( obj -- )" } ", called by the inspector to display an overview of an object."
$nl
"The default implementation calls " { $link describe } " which outputs on the " { $link stdio } " stream, but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;
"The default implementation calls " { $link describe } " which outputs on " { $link output-stream } ", but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;

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

@ -9,4 +9,4 @@ HELP: init-io
{ $contract "Initializes the I/O system. Called on startup." } ;
HELP: init-stdio
{ $contract "Initializes the global " { $link stdio } " stream. Called on startup." } ;
{ $contract "Initializes the global " { $link input-stream } " and " { $link output-stream } ". Called on startup." } ;

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

@ -11,8 +11,10 @@ HOOK: init-io 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 ;
(init-stdio)
[ utf8 <decoder> input-stream set-global ]
[ utf8 <encoder> output-stream set-global ]
[ utf8 <encoder> error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( ms -- )

17
core/io/crc32/crc32-docs.factor
View File

@ -1,17 +0,0 @@
USING: help.markup help.syntax math ;
IN: io.crc32
HELP: crc32
{ $values { "seq" "a sequence of bytes" } { "n" integer } }
{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
HELP: lines-crc32
{ $values { "seq" "a sequence of strings" } { "n" integer } }
{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
ARTICLE: "io.crc32" "CRC32 checksum calculation"
"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
{ $subsection crc32 }
{ $subsection lines-crc32 } ;
ABOUT: "io.crc32"

5
core/io/crc32/crc32-tests.factor
View File

@ -1,5 +0,0 @@
USING: io.crc32 kernel math tools.test namespaces ;
[ 0 ] [ "" crc32 ] unit-test
[ HEX: cbf43926 ] [ "123456789" crc32 ] unit-test

13
core/io/encodings/encodings-docs.factor
View File

@ -12,8 +12,7 @@ ARTICLE: "io.encodings" "I/O encodings"
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
"The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors."
{ $subsection <encoder> }
{ $subsection <decoder> }
{ $subsection <encoder-duplex> } ;
{ $subsection <decoder> } ;
HELP: <encoder>
{ $values { "stream" "an output stream" }
@ -29,16 +28,6 @@ HELP: <decoder>
{ $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" } "." }
$low-level-note ;
HELP: <encoder-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" } "." }
$low-level-note ;
{ <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:"
{ $subsection "io.encodings.binary" }

16
core/io/encodings/encodings-tests.factor
View File

@ -2,35 +2,35 @@ USING: io.files io.streams.string io
tools.test kernel io.encodings.ascii ;
IN: io.streams.encodings.tests
: <resource-reader> ( resource -- stream )
resource-path ascii <file-reader> ;
[ { } ]
[ "core/io/test/empty-file.txt" <resource-reader> lines ]
[ "resource:core/io/test/empty-file.txt" ascii <file-reader> lines ]
unit-test
: lines-test ( stream -- line1 line2 )
[ readln readln ] with-stream ;
[ readln readln ] with-input-stream ;
[
"This is a line."
"This is another line."
] [
"core/io/test/windows-eol.txt" <resource-reader> lines-test
"resource:core/io/test/windows-eol.txt"
ascii <file-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
"core/io/test/mac-os-eol.txt" <resource-reader> lines-test
"resource:core/io/test/mac-os-eol.txt"
ascii <file-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
"core/io/test/unix-eol.txt" <resource-reader> lines-test
"resource:core/io/test/unix-eol.txt"
ascii <file-reader> lines-test
] unit-test
[

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

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces growable
strings io classes continuations combinators io.styles
io.streams.plain splitting io.streams.duplex byte-arrays
sequences.private accessors ;
io.streams.plain splitting byte-arrays sequences.private
accessors ;
IN: io.encodings
! The encoding descriptor protocol
@ -131,6 +131,3 @@ INSTANCE: encoder plain-writer
over decoder? [ >r decoder-stream r> ] when <decoder> ;
PRIVATE>
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck reencode >r redecode r> <duplex-stream> ;

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

@ -184,8 +184,12 @@ HELP: +unknown+
{ $description "A unknown file type." } ;
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
{ "stream" "an input stream" } }
{
$values
{ "path" "a pathname string" }
{ "encoding" "an encoding descriptor" }
{ "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." } ;
@ -201,17 +205,17 @@ HELP: <file-appender>
HELP: with-file-reader
{ $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-input-stream } "." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: with-file-writer
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-stream } "." }
{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-output-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-appender
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." }
{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-output-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: set-file-lines

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

@ -25,13 +25,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
<file-reader> lines ;
: with-file-reader ( path encoding quot -- )
>r <file-reader> r> with-stream ; inline
>r <file-reader> r> with-input-stream ; inline
: file-contents ( path encoding -- str )
<file-reader> contents ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline
>r <file-writer> r> with-output-stream ; inline
: set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ;
@ -40,7 +40,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
[ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- )
>r <file-appender> r> with-stream ; inline
>r <file-appender> r> with-output-stream ; inline
! Pathnames
: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;

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

@ -5,7 +5,7 @@ IN: io
ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional."
$nl
"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in a " { $link with-stream } ". This leads more simpler, more reusable and more robust code."
"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "."
$nl
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
$nl
@ -26,24 +26,24 @@ $nl
{ $subsection stream-write-table }
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "The default stream"
"Most I/O code only operates on one stream at a time. The " { $emphasis "default stream" } " is an implicit parameter used by many I/O words designed for this particular use-case. Using this idiom improves code in three ways:"
ARTICLE: "stdio" "Default input and output streams"
"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:"
{ $list
{ "Code becomes simpler because there is no need to keep a stream around on the stack." }
{ "Code becomes more robust because " { $link with-stream } " automatically closes the stream if there is an error." }
{ "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-stream } " to specify the source or destination for I/O operations." }
{ "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." }
{ "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." }
}
"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" <file-reader>"
"\"data.txt\" utf8 <file-reader>"
"dup stream-readln number>string over stream-read 16 group"
"swap dispose"
}
"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" <file-reader> ["
"\"data.txt\" utf8 <file-reader> ["
" dup stream-readln number>string over stream-read"
" 16 group"
"] with-disposal"
@ -51,17 +51,34 @@ ARTICLE: "stdio" "The default stream"
"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" <file-reader> ["
"\"data.txt\" utf8 <file-reader> ["
" readln number>string read 16 group"
"] with-stream"
"] with-input-stream"
}
"The default stream is stored in a dynamically-scoped variable:"
{ $subsection stdio }
"Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user."
"An even better implementation that takes advantage of a utility word:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 ["
" readln number>string read 16 group"
"] with-file-reader"
}
"The default input stream is stored in a dynamically-scoped variable:"
{ $subsection input-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
$nl
"Words reading from the default input stream:"
{ $subsection read1 }
{ $subsection read }
{ $subsection read-until }
{ $subsection readln }
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
{ $subsection with-input-stream }
{ $subsection with-input-stream* }
"The default output stream is stored in a dynamically-scoped variable:"
{ $subsection output-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
$nl
"Words writing to the default input stream:"
{ $subsection flush }
{ $subsection write1 }
{ $subsection write }
@ -78,9 +95,12 @@ ARTICLE: "stdio" "The default stream"
{ $subsection with-row }
{ $subsection with-cell }
{ $subsection write-cell }
"A pair of combinators support rebinding the " { $link stdio } " variable:"
{ $subsection with-stream }
{ $subsection with-stream* } ;
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }
"A pair of combinators for rebinding both default streams at once:"
{ $subsection with-streams }
{ $subsection with-streams* } ;
ARTICLE: "stream-utils" "Stream utilities"
"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
@ -204,62 +224,65 @@ HELP: stream-copy
{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;
HELP: stdio
{ $var-description "Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ;
HELP: input-stream
{ $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
HELP: output-stream
{ $var-description "Holds an output stream for various implicit stream operations. Rebound using " { $link with-output-stream } " and " { $link with-output-stream* } "." } ;
HELP: readln
{ $values { "str/f" "a string or " { $link f } } }
{ $description "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
{ $description "Reads a line of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read1
{ $values { "ch/f" "a character or " { $link f } } }
{ $description "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
{ $description "Reads a character of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read
{ $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } }
{ $description "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
{ $description "Reads " { $snippet "n" } " characters of input from " { $link input-stream } ". Outputs a truncated string or " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read-until
{ $values { "seps" string } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } }
{ $contract "Reads characters from the " { $link stdio } " stream. until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
{ $contract "Reads characters from " { $link input-stream } ". until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
$io-error ;
HELP: write1
{ $values { "ch" "a character" } }
{ $contract "Writes a character of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: write
{ $values { "str" string } }
{ $description "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $description "Writes a string of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: flush
{ $description "Waits for any pending output to the " { $link stdio } " stream to complete." }
{ $description "Waits for any pending output on " { $link output-stream } " to complete." }
$io-error ;
HELP: nl
{ $description "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $description "Writes a line terminator to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: format
{ $values { "str" string } { "style" "a hashtable" } }
{ $description "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ;
HELP: with-nesting
{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." }
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ;
HELP: tabular-output
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on the " { $link stdio } " stream."
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
{ $examples
@ -279,7 +302,7 @@ $io-error ;
HELP: with-cell
{ $values { "quot" quotation } }
{ $description "Calls a quotation in a new scope with the " { $link stdio } " stream rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
$io-error ;
HELP: write-cell
@ -288,34 +311,54 @@ HELP: write-cell
$io-error ;
HELP: with-style
{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
$io-error ;
HELP: print
{ $values { "string" string } }
{ $description "Writes a newline-terminated string to the " { $link stdio } " stream." }
{ $description "Writes a newline-terminated string to " { $link output-stream } "." }
$io-error ;
HELP: with-stream
{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
HELP: with-input-stream
{ $values { "stream" "an input stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
{ with-stream with-stream* } related-words
HELP: with-output-stream
{ $values { "stream" "an output stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
HELP: with-stream*
{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-stream } "." } ;
HELP: with-streams
{ $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } ". The stream is closed if the quotation returns or throws an error." } ;
HELP: with-streams*
{ $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-streams } "." } ;
{ with-input-stream with-input-stream* } related-words
{ with-output-stream with-output-stream* } related-words
HELP: with-input-stream*
{ $values { "stream" "an input stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-input-stream } "." } ;
HELP: with-output-stream*
{ $values { "stream" "an output stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-output-stream } "." } ;
HELP: bl
{ $description "Outputs a space character (" { $snippet "\" \"" } ")." }
{ $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." }
$io-error ;
HELP: write-object
{ $values { "str" string } { "obj" "an object" } }
{ $description "Writes a string to the " { $link stdio } " stream, associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." }
{ $description "Writes a string to " { $link output-stream } ", associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." }
$io-error ;
HELP: lines

25
core/io/io-tests.factor
View File

@ -8,21 +8,18 @@ IN: io.tests
"foo" "io.tests" lookup
] unit-test
: <resource-reader> ( resource -- stream )
resource-path latin1 <file-reader> ;
[
"This is a line.\rThis is another line.\r"
] [
"core/io/test/mac-os-eol.txt" <resource-reader>
[ 500 read ] with-stream
"resource:core/io/test/mac-os-eol.txt" latin1 <file-reader>
[ 500 read ] with-input-stream
] unit-test
[
255
] [
"core/io/test/binary.txt" <resource-reader>
[ read1 ] with-stream >fixnum
"resource:core/io/test/binary.txt" latin1 <file-reader>
[ read1 ] with-input-stream >fixnum
] unit-test
! Make sure we use correct to_c_string form when writing
@ -36,11 +33,12 @@ IN: io.tests
}
] [
[
"core/io/test/separator-test.txt" <resource-reader> [
"resource:core/io/test/separator-test.txt"
latin1 <file-reader> [
"J" read-until 2array ,
"i" read-until 2array ,
"X" read-until 2array ,
] with-stream
] with-input-stream
] { } make
] unit-test
@ -49,12 +47,3 @@ IN: io.tests
10 [ 65536 read drop ] times
] with-file-reader
] unit-test
! [ "" ] [ 0 read ] unit-test
! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
! [
! "/core/io/test/binary.txt" <resource-reader>
! [ 0.2 read ] with-stream
! ] must-fail

64
core/io/io.factor
View File

@ -30,39 +30,52 @@ GENERIC: stream-write-table ( table-cells style stream -- )
[ 2dup (stream-copy) ] [ dispose dispose ] [ ]
cleanup ;
! Default stream
SYMBOL: stdio
! Default streams
SYMBOL: input-stream
SYMBOL: output-stream
SYMBOL: error-stream
! Default error stream
SYMBOL: stderr
: readln ( -- str/f ) input-stream get stream-readln ;
: read1 ( -- ch/f ) input-stream get stream-read1 ;
: read ( n -- str/f ) input-stream get stream-read ;
: read-until ( seps -- str/f sep/f ) input-stream get stream-read-until ;
: readln ( -- str/f ) stdio get stream-readln ;
: read1 ( -- ch/f ) stdio get stream-read1 ;
: read ( n -- str/f ) stdio get stream-read ;
: read-until ( seps -- str/f sep/f ) stdio get stream-read-until ;
: write1 ( ch -- ) output-stream get stream-write1 ;
: write ( str -- ) output-stream get stream-write ;
: flush ( -- ) output-stream get stream-flush ;
: write1 ( ch -- ) stdio get stream-write1 ;
: write ( str -- ) stdio get stream-write ;
: flush ( -- ) stdio get stream-flush ;
: nl ( -- ) output-stream get stream-nl ;
: format ( str style -- ) output-stream get stream-format ;
: nl ( -- ) stdio get stream-nl ;
: format ( str style -- ) stdio get stream-format ;
: with-input-stream* ( stream quot -- )
input-stream swap with-variable ; inline
: with-stream* ( stream quot -- )
stdio swap with-variable ; inline
: with-input-stream ( stream quot -- )
[ with-input-stream* ] curry with-disposal ; inline
: with-stream ( stream quot -- )
[ with-stream* ] curry with-disposal ; inline
: with-output-stream* ( stream quot -- )
output-stream swap with-variable ; inline
: with-output-stream ( stream quot -- )
[ with-output-stream* ] curry with-disposal ; inline
: with-streams* ( input output quot -- )
[ output-stream set input-stream set ] prepose with-scope ; inline
: with-streams ( input output quot -- )
[ [ with-streams* ] 3curry ]
[ [ drop dispose dispose ] 3curry ] 3bi
[ ] cleanup ; inline
: tabular-output ( style quot -- )
swap >r { } make r> stdio get stream-write-table ; inline
swap >r { } make r> output-stream get stream-write-table ; inline
: with-row ( quot -- )
{ } make , ; inline
: with-cell ( quot -- )
H{ } stdio get make-cell-stream
[ swap with-stream ] keep , ; inline
H{ } output-stream get make-cell-stream
[ swap with-output-stream ] keep , ; inline
: write-cell ( str -- )
[ write ] with-cell ; inline
@ -71,13 +84,14 @@ SYMBOL: stderr
swap dup assoc-empty? [
drop call
] [
stdio get make-span-stream swap with-stream
output-stream get make-span-stream swap with-output-stream
] if ; inline
: with-nesting ( style quot -- )
>r stdio get make-block-stream r> with-stream ; inline
>r output-stream get make-block-stream
r> with-output-stream ; inline
: print ( string -- ) stdio get stream-print ;
: print ( string -- ) output-stream get stream-print ;
: bl ( -- ) " " write ;
@ -85,9 +99,9 @@ SYMBOL: stderr
presented associate format ;
: lines ( stream -- seq )
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
[ [ readln dup ] [ ] [ drop ] unfold ] with-input-stream ;
: contents ( stream -- str )
[
[ 65536 read dup ] [ ] [ drop ] unfold concat f like
] with-stream ;
] with-input-stream ;

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

@ -25,10 +25,10 @@ HELP: <byte-writer>
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 for reading from a byte array using an encoding." } ;
{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
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 an output stream writing data to a byte array using an encoding." } ;
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;

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

@ -1,16 +1,16 @@
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
sequences io namespaces io.encodings.private ;
sequences io namespaces io.encodings.private accessors ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
512 <byte-vector> swap <encoder> ;
: with-byte-writer ( encoding quot -- byte-array )
>r <byte-writer> r> [ stdio get ] compose with-stream*
dup encoder? [ encoder-stream ] when >byte-array ; inline
>r <byte-writer> r> [ output-stream get ] compose with-output-stream*
dup encoder? [ stream>> ] when >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream )
>r >byte-vector dup reverse-here r> <decoder> ;
: with-byte-reader ( byte-array encoding quot -- )
>r <byte-reader> r> with-stream ; inline
>r <byte-reader> r> with-input-stream* ; inline

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces io io.encodings
sequences math generic threads.private classes io.backend
io.streams.duplex io.files continuations byte-arrays ;
io.files continuations byte-arrays ;
IN: io.streams.c
TUPLE: c-writer handle ;

19
core/io/streams/duplex/duplex-docs.factor
View File

@ -1,19 +0,0 @@
USING: help.markup help.syntax io continuations ;
IN: io.streams.duplex
ARTICLE: "io.streams.duplex" "Duplex streams"
"Duplex streams combine an input stream and an output stream into a bidirectional stream."
{ $subsection duplex-stream }
{ $subsection <duplex-stream> } ;
ABOUT: "io.streams.duplex"
HELP: duplex-stream
{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
HELP: stream-closed-twice
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;

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

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

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

@ -35,7 +35,7 @@ unit-test
"J" read-until 2array ,
"i" read-until 2array ,
"X" read-until 2array ,
] with-stream
] with-input-stream
] { } make
] unit-test

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

@ -15,7 +15,7 @@ M: growable stream-flush drop ;
512 <sbuf> ;
: with-string-writer ( quot -- str )
<string-writer> swap [ stdio get ] compose with-stream*
<string-writer> swap [ output-stream get ] compose with-output-stream*
>string ; inline
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
@ -56,7 +56,7 @@ M: null decode-char drop stream-read1 ;
>sbuf dup reverse-here null <decoder> ;
: with-string-reader ( str quot -- )
>r <string-reader> r> with-stream ; inline
>r <string-reader> r> with-input-stream ; inline
INSTANCE: growable plain-writer
@ -67,15 +67,14 @@ INSTANCE: growable plain-writer
] unless ;
: map-last ( seq quot -- seq )
swap dup length <reversed>
[ zero? rot [ call ] keep swap ] 2map nip ; inline
>r dup length <reversed> [ zero? ] r> compose 2map ; 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* ;
[ drop format-table [ print ] each ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;

8
core/listener/listener-docs.factor
View File

@ -32,14 +32,14 @@ HELP: listener-hook
HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link stdio } " stream. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
HELP: listen
{ $description "Prompts for an expression on the " { $link stdio } " stream and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
{ $errors "If the expression input by the user throws an error, the error is printed to the " { $link stdio } " stream and the word returns normally." } ;
{ $description "Prompts for an expression on " { $link input-stream } " and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
{ $errors "If the expression input by the user throws an error, the error is printed to " { $link output-stream } " and the word returns normally." } ;
HELP: listener
{ $description "Prompts for expressions on the " { $link stdio } " stream and evaluates them until end of file is reached." } ;
{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
HELP: bye
{ $description "Exits the current listener." }

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

@ -51,6 +51,6 @@ IN: listener.tests
[
[ ] [
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
drop
drop
] unit-test
] with-file-vocabs

15
core/listener/listener.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators
continuations debugger definitions compiler.units accessors ;
vectors words generic system combinators continuations debugger
definitions compiler.units accessors ;
IN: listener
SYMBOL: quit-flag
@ -35,10 +35,7 @@ GENERIC: stream-read-quot ( stream -- quot/f )
M: object stream-read-quot
V{ } clone read-quot-loop ;
M: duplex-stream stream-read-quot
duplex-stream-in stream-read-quot ;
: read-quot ( -- quot/f ) stdio get stream-read-quot ;
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
: bye ( -- ) quit-flag on ;
@ -46,9 +43,13 @@ M: duplex-stream stream-read-quot
"( " in get " )" 3append
H{ { background { 1 0.7 0.7 1 } } } format bl flush ;
SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global
: listen ( -- )
listener-hook get call prompt.
[ read-quot [ try ] [ bye ] if* ]
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
dup parse-error? [
error-hook get call

3
core/math/math.factor
View File

@ -80,9 +80,6 @@ M: number equal? number= ;
M: real hashcode* nip >fixnum ;
! real and sequence overlap. we disambiguate:
M: integer hashcode* nip >fixnum ;
GENERIC: fp-nan? ( x -- ? )
M: object fp-nan?

4
core/math/order/order-docs.factor
View File

@ -25,8 +25,8 @@ HELP: +gt+
{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
HELP: invert-comparison
{ $values { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" }
{ "new-symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
{ $values { "symbol" symbol }
{ "new-symbol" symbol } }
{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
{ $examples
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;

10
core/math/order/order.factor
View File

@ -7,17 +7,13 @@ SYMBOL: +lt+
SYMBOL: +eq+
SYMBOL: +gt+
GENERIC: <=> ( obj1 obj2 -- symbol )
: (<=>) ( a b -- symbol )
2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
: invert-comparison ( symbol -- new-symbol )
#! Can't use case, index or nth here
dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
M: real <=> (<=>) ;
M: integer <=> (<=>) ;
GENERIC: <=> ( obj1 obj2 -- symbol )
M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
GENERIC: before? ( obj1 obj2 -- ? )
GENERIC: after? ( obj1 obj2 -- ? )

6
core/math/parser/parser-tests.factor
View File

@ -98,3 +98,9 @@ unit-test
[ 1 1 >base ] must-fail
[ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail
[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test

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

@ -140,9 +140,9 @@ M: ratio >base
M: float >base
drop {
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
[ float>string fix-float ]
} cond ;

6
core/optimizer/control/control.factor
View File

@ -154,9 +154,9 @@ SYMBOL: potential-loops
node-literal t
] [
node-class {
{ [ dup null class< ] [ drop f f ] }
{ [ dup \ f class-not class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
{ [ dup null class<= ] [ drop f f ] }
{ [ dup \ f class-not class<= ] [ drop t t ] }
{ [ dup \ f class<= ] [ drop f t ] }
[ drop f f ]
} cond
] if ;

6
core/optimizer/def-use/def-use-tests.factor
View File

@ -1,6 +1,6 @@
IN: optimizer.def-use.tests
USING: inference inference.dataflow optimizer optimizer.def-use
namespaces assocs kernel sequences math tools.test words ;
namespaces assocs kernel sequences math tools.test words sets ;
[ 3 { 1 1 1 } ] [
[ 1 2 3 ] dataflow compute-def-use drop
@ -11,10 +11,6 @@ namespaces assocs kernel sequences math tools.test words ;
dataflow compute-def-use drop compute-dead-literals keys
[ value-literal ] map ;
: subset? [ member? ] curry all? ;
: set= 2dup subset? >r swap subset? r> and ;
[ { [ + ] } ] [
[ [ 1 2 3 ] [ + ] over drop drop ] kill-set
] unit-test

6
core/optimizer/inlining/inlining.factor
View File

@ -77,7 +77,7 @@ DEFER: (flat-length)
float real
complex number
object
} [ class< ] with find nip ;
} [ class<= ] with find nip ;
: inlining-math-method ( #call word -- quot/f )
swap node-input-classes
@ -111,7 +111,7 @@ DEFER: (flat-length)
: comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes
#! are disjoint, return t.
2dup class< >r classes-intersect? not r> or ;
2dup class<= >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [
@ -132,7 +132,7 @@ DEFER: (flat-length)
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
node-class-first r> class< ;
node-class-first r> class<= ;
: optimize-predicate ( #call -- node )
#! If the predicate is followed by a branch we fold it

4
core/optimizer/known-words/known-words.factor
View File

@ -4,7 +4,7 @@ IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
inference.class kernel assocs math math.private kernel.private
sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary io.crc32
assocs quotations sequences.private io.binary
io.streams.string layouts splitting math.intervals
math.floats.private classes.tuple classes.tuple.private classes
classes.algebra optimizer.def-use optimizer.backend
@ -126,8 +126,6 @@ sequences.private combinators ;
\ >sbuf { string } "specializer" set-word-prop
\ crc32 { string } "specializer" set-word-prop
\ split, { string string } "specializer" set-word-prop
\ memq? { array } "specializer" set-word-prop

12
core/optimizer/math/math.factor
View File

@ -96,7 +96,7 @@ optimizer.math.partial generic.standard system accessors ;
: math-closure ( class -- newclass )
{ null fixnum bignum integer rational float real number }
[ class< ] with find nip number or ;
[ class<= ] with find nip number or ;
: fits? ( interval class -- ? )
"interval" word-prop dup
@ -108,7 +108,7 @@ optimizer.math.partial generic.standard system accessors ;
dup r> at swap or ;
: won't-overflow? ( interval node -- ? )
node-in-d [ value-class* fixnum class< ] all?
node-in-d [ value-class* fixnum class<= ] all?
swap fixnum fits? and ;
: post-process ( class interval node -- classes intervals )
@ -214,7 +214,7 @@ optimizer.math.partial generic.standard system accessors ;
: twiddle-interval ( i1 -- i2 )
dup [
node get node-in-d
[ value-class* integer class< ] all?
[ value-class* integer class<= ] all?
[ integral-closure ] when
] when ;
@ -293,7 +293,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
! Removing overflow checks
: remove-overflow-check? ( #call -- ? )
dup out-d>> first node-class
[ fixnum class< ] [ null eq? not ] bi and ;
[ fixnum class<= ] [ null eq? not ] bi and ;
{
{ + [ fixnum+fast ] }
@ -356,7 +356,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
dup #call? [ node-param eq? ] [ 2drop f ] if ;
: coerced-to-fixnum? ( #call -- ? )
dup dup node-in-d [ node-class integer class< ] with all?
dup dup node-in-d [ node-class integer class<= ] with all?
[ \ >fixnum consumed-by? ] [ drop f ] if ;
{
@ -377,7 +377,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
: convert-rem-to-and? ( #call -- ? )
dup node-in-d {
{ [ 2dup first node-class integer class< not ] [ f ] }
{ [ 2dup first node-class integer class<= not ] [ f ] }
{ [ 2dup second node-literal integer? not ] [ f ] }
{ [ 2dup second node-literal power-of-2? not ] [ f ] }
[ t ]

2
core/optimizer/pattern-match/pattern-match.factor
View File

@ -12,7 +12,7 @@ SYMBOL: @
@ get [ eq? ] [ @ set t ] if* ;
: match-class ( value spec -- ? )
>r node get swap node-class r> class< ;
>r node get swap node-class r> class<= ;
: value-match? ( value spec -- ? )
{

21
core/parser/parser-docs.factor
View File

@ -5,7 +5,7 @@ quotations namespaces compiler.units assocs ;
IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, a message is printed to the " { $link stdio } " stream. Except when debugging suspected name clashes, these messages can be ignored."
"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, we say that the old word has been " { $emphasis "shadowed" } "."
$nl
"Here is an example where shadowing occurs:"
{ $code
@ -13,18 +13,18 @@ $nl
"USING: sequences io ;"
""
": append"
" \"foe::append calls sequences::append\" print append ;"
" \"foe::append calls sequences:append\" print append ;"
""
"IN: fee"
""
": append"
" \"fee::append calls fee::append\" print append ;"
" \"fee::append calls fee:append\" print append ;"
""
"IN: fox"
"USE: foe"
""
": append"
" \"fox::append calls foe::append\" print append ;"
" \"fox::append calls foe:append\" print append ;"
""
"\"1234\" \"5678\" append print"
""
@ -33,12 +33,13 @@ $nl
}
"When placed in a source file and run, the above code produces the following output:"
{ $code
"foe::append calls sequences::append"
"foe:append calls sequences:append"
"12345678"
"fee::append calls foe::append"
"foe::append calls sequences::append"
"fee:append calls foe:append"
"foe:append calls sequences:append"
"12345678"
} ;
}
"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
@ -215,7 +216,7 @@ HELP: save-location
{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
HELP: parser-notes
{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on the " { $link stdio } " stream, this variable should be switched off, to prevent parser notes from polluting the output." } ;
{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
HELP: parser-notes?
{ $values { "?" "a boolean" } }
@ -506,7 +507,7 @@ HELP: bootstrap-file
HELP: eval>string
{ $values { "str" string } { "output" string } }
{ $description "Evaluates the Factor code in " { $snippet "str" } " with the " { $link stdio } " stream rebound to a string output stream, then outputs the resulting string." } ;
{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
HELP: staging-violation
{ $values { "word" word } }

3
core/parser/parser-tests.factor
View File

@ -432,3 +432,6 @@ must-fail-with
] must-fail
[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with
[ 92 ] [ "CHAR: \\" eval ] unit-test
[ 92 ] [ "CHAR: \\\\" eval ] unit-test

11
core/parser/parser.factor
View File

@ -421,14 +421,17 @@ ERROR: bad-number ;
SYMBOL: current-class
SYMBOL: current-generic
: (M:)
CREATE-METHOD
: with-method-definition ( quot -- parsed )
[
>r
[ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ]
[ ] tri
parse-definition
] with-scope ;
r> call
] with-scope ; inline
: (M:)
CREATE-METHOD [ parse-definition ] with-method-definition ;
: scan-object ( -- object )
scan-word dup parsing?

13
core/prettyprint/backend/backend.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays bit-arrays generic hashtables io
assocs kernel math namespaces sequences strings sbufs io.styles
vectors words prettyprint.config prettyprint.sections quotations
io io.files math.parser effects classes.tuple math.order
classes.tuple.private classes float-arrays ;
USING: arrays byte-arrays byte-vectors bit-arrays generic
hashtables io assocs kernel math namespaces sequences strings
sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
float-arrays ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
@ -140,6 +141,7 @@ M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
M: bit-array pprint-delims drop \ ?{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: float-array pprint-delims drop \ F{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
@ -152,6 +154,7 @@ GENERIC: >pprint-sequence ( obj -- seq )
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
M: byte-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;

12
core/prettyprint/prettyprint-docs.factor
View File

@ -135,7 +135,7 @@ ARTICLE: "prettyprint" "The prettyprinter"
$nl
"Prettyprinter words are found in the " { $vocab-link "prettyprint" } " vocabulary."
$nl
"The key words to print an object to the " { $link stdio } " stream; the first two emit a trailing newline, the second two do not:"
"The key words to print an object to " { $link output-stream } "; the first two emit a trailing newline, the second two do not:"
{ $subsection . }
{ $subsection short. }
{ $subsection pprint }
@ -161,17 +161,17 @@ ABOUT: "prettyprint"
HELP: with-pprint
{ $values { "obj" object } { "quot" quotation } }
{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to the " { $link stdio } " stream." } ;
{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to " { $link output-stream } "." } ;
HELP: pprint
{ $values { "obj" object } }
{ $description "Prettyprints an object to the " { $link stdio } " stream. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
{ pprint pprint* with-pprint } related-words
HELP: .
{ $values { "obj" object } }
{ $description "Prettyprints an object to the " { $link stdio } " stream with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
HELP: unparse
{ $values { "obj" object } { "str" "Factor source string" } }
@ -179,11 +179,11 @@ HELP: unparse
HELP: pprint-short
{ $values { "obj" object } }
{ $description "Prettyprints an object to the " { $link stdio } " stream. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
{ $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
HELP: short.
{ $values { "obj" object } }
{ $description "Prettyprints an object to the " { $link stdio } " stream with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
HELP: .b
{ $values { "n" "an integer" } }

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

@ -114,7 +114,7 @@ unit-test
[ parse-fresh drop ] with-compilation-unit
[
"prettyprint.tests" lookup see
] with-string-writer "\n" split 1 head*
] with-string-writer "\n" split but-last
] keep =
] with-scope ;

2
core/prettyprint/sections/sections-docs.factor
View File

@ -15,7 +15,7 @@ HELP: line-limit?
HELP: do-indent
{ $description "Outputs the current indent nesting to the " { $link stdio } " stream." } ;
{ $description "Outputs the current indent nesting to " { $link output-stream } "." } ;
HELP: fresh-line
{ $values { "n" "the current column position" } }

11
core/prettyprint/sections/sections.factor
View File

@ -15,9 +15,9 @@ SYMBOL: pprinter-stack
SYMBOL: pprinter-in
SYMBOL: pprinter-use
TUPLE: pprinter last-newline line-count end-printing indent ;
TUPLE: pprinter last-newline line-count indent ;
: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter boa ;
: <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
@ -34,7 +34,7 @@ TUPLE: pprinter last-newline line-count end-printing indent ;
] [
pprinter get (>>last-newline)
line-limit? [
"..." write pprinter get end-printing>> continue
"..." write pprinter get return
] when
pprinter get [ 1+ ] change-line-count drop
nl do-indent
@ -275,16 +275,15 @@ M: colon unindent-first-line? drop t ;
[
dup style>> [
[
>r pprinter get (>>end-printing) r>
short-section
] curry callcc0
] curry with-return
] with-nesting
] if-nonempty
] with-variable ;
! Long section layout algorithm
: chop-break ( seq -- seq )
dup peek line-break? [ 1 head-slice* chop-break ] when ;
dup peek line-break? [ but-last-slice chop-break ] when ;
SYMBOL: prev
SYMBOL: next

17
core/sequences/sequences-docs.factor
View File

@ -92,9 +92,11 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection subseq }
{ $subsection head }
{ $subsection tail }
{ $subsection rest }
{ $subsection head* }
{ $subsection tail* }
"Removing the first or last element:"
{ $subsection rest }
{ $subsection but-last }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip }
{ $subsection cut }
@ -106,6 +108,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
{ $subsection but-last-slice }
{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
@ -836,11 +839,16 @@ HELP: tail-slice
{ $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: but-last-slice
{ $values { "seq" sequence } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all but the last element of the input sequence." }
{ $errors "Throws an error on an empty sequence." } ;
HELP: rest-slice
{ $values { "seq" sequence } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements from the 1st index until the end of the input sequence." }
{ $notes "Equivalent to " { $snippet "1 tail" } }
{ $errors "Throws an error if the index is out of bounds." } ;
{ $errors "Throws an error on an empty sequence." } ;
HELP: head-slice*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } }
@ -862,6 +870,11 @@ HELP: tail
{ $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: but-last
{ $values { "seq" sequence } { "headseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the last item removed." }
{ $errors "Throws an error on an empty sequence." } ;
HELP: rest
{ $values { "seq" sequence } { "tailseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the first item removed." }

10
core/sequences/sequences.factor
View File

@ -216,6 +216,8 @@ M: slice length dup slice-to swap slice-from - ;
: tail-slice* ( seq n -- slice ) from-end tail-slice ;
: but-last-slice ( seq -- slice ) 1 head-slice* ;
INSTANCE: slice virtual-sequence
! One element repeated many times
@ -263,6 +265,8 @@ PRIVATE>
: tail* ( seq n -- tailseq ) from-end tail ;
: but-last ( seq -- headseq ) 1 head* ;
: copy ( src i dst -- )
pick length >r 3dup check-copy spin 0 r>
(copy) drop ; inline
@ -670,9 +674,15 @@ PRIVATE>
: unclip ( seq -- rest first )
[ rest ] [ first ] bi ;
: unclip-last ( seq -- butfirst last )
[ but-last ] [ peek ] bi ;
: unclip-slice ( seq -- rest first )
[ rest-slice ] [ first ] bi ;
: unclip-last-slice ( seq -- butfirst last )
[ but-last-slice ] [ peek ] bi ;
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ;
inline

16
core/sets/sets-docs.factor
View File

@ -2,7 +2,7 @@ USING: kernel help.markup help.syntax sequences ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time."
"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. All of these operations use hashtables internally to achieve linear running time."
$nl
"Remove duplicates:"
{ $subsection prune }
@ -12,8 +12,14 @@ $nl
{ $subsection diff }
{ $subsection intersect }
{ $subsection union }
{ $subsection subset? }
{ $subsection set= }
"A word used to implement the above:"
{ $subsection unique }
{ $see-also member? memq? contains? all? "assocs-sets" } ;
ABOUT: "sets"
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." }
@ -59,3 +65,11 @@ HELP: union
} ;
{ diff intersect union } related-words
HELP: subset?
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
HELP: set=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;

6
core/sets/sets.factor
View File

@ -29,3 +29,9 @@ IN: sets
: union ( seq1 seq2 -- newseq )
append prune ;
: subset? ( seq1 seq2 -- ? )
unique [ key? ] curry all? ;
: set= ( seq1 seq2 -- ? )
[ unique ] bi@ = ;

6
core/source-files/source-files.factor
View File

@ -3,8 +3,8 @@
USING: arrays definitions generic assocs kernel math namespaces
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.crc32 vocabs hashtables
graphs compiler.units io.encodings.utf8 accessors ;
continuations debugger io.files checksums checksums.crc32 vocabs
hashtables graphs compiler.units io.encodings.utf8 accessors ;
IN: source-files
SYMBOL: source-files
@ -15,7 +15,7 @@ checksum
uses definitions ;
: record-checksum ( lines source-file -- )
>r lines-crc32 r> set-source-file-checksum ;
>r crc32 checksum-lines r> set-source-file-checksum ;
: (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname>

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