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

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

db4
Doug Coleman 2008-05-02 17:12:31 -05:00
parent a77ba70706 5a29b2e273
commit 50d02a2bc5
178 changed files with 3815 additions and 936 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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 )
[

16
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<=>-cache
class-not-cache classes-intersect-cache class-and-cache
class-or-cache
} [ dup get swap bootstrap-word set ] each
] H{ } make-assoc

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
{

4
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

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" } ;

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

50
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,40 @@ 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." }
}
"These difficulties are resolved by imposing a linear order on classes, computed as follows for two classes A and B:"
{ $list
"If A and B are the same class (not just equal as sets), then comparison stops."
"If A is a proper subset of B, or B is a proper subset of A, then comparison stops."
{ "Next, the metaclasses of A and B are compared, with intrinsic meta-class order, from most-specific to least-specific:"
{ $list
"Built-in classes and tuple classes"
"Predicate classes"
"Union classes"
"Mixin classes"
}
"If this yields an unambiguous answer, comparison stops."
}
"If the metaclasses of A and B occupy the same position in the order, then the vocabularies of A and B are compared lexicographically. If this yields an unambiguous answer, comparison stops."
"If A and B belong to the same vocabulary, their names are compared lexicographically. This must yield an unambiguous result, since if the names equal they must be the same class and this case was already handled in the first step."
}
"Some examples:"
{ $list
{ { $link integer } " precedes " { $link number } " because it is a strict subset" }
{ { $link number } " precedes " { $link sequence } " because the " { $vocab-link "math" } " vocabulary precedes the " { $vocab-link "sequences" } " vocabulary" }
{ { $link crc32 } " precedes " { $link checksum } ", even if it were the only instance, because " { $link crc32 } " is a singleton class which is more specific than a mixin class" }
}
"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 +63,16 @@ 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." } ;
{ sort-classes class<=> } related-words
HELP: class-or
{ $values { "first" class } { "second" class } { "class" class } }
@ -53,3 +89,7 @@ HELP: classes-intersect?
HELP: min-class
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
HELP: class<=>
{ $values { "first" class } { "second" class } { "n" symbol } }
{ $description "Compares two classes with the class linearization order." } ;

91
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,14 @@ 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 integer ratio } ] [ { ratio number integer } sort-classes ] unit-test
[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
[ +lt+ ] [ \ real sequence class<=> ] unit-test

93
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,22 +180,43 @@ C: <anonymous-complement> anonymous-complement
[ <anonymous-complement> ]
} 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* ;
: class< ( first second -- ? )
{
{ [ 2dup class<= not ] [ 2drop f ] }
{ [ 2dup swap class<= not ] [ 2drop t ] }
[ [ rank-class ] bi@ < ]
} cond ;
: class-tie-breaker ( first second -- n )
2dup [ rank-class ] compare {
{ +lt+ [ 2drop +lt+ ] }
{ +gt+ [ 2drop +gt+ ] }
{ +eq+ [ <=> ] }
} case ;
: (class<=>) ( first second -- n )
{
{ [ 2dup class<= ] [
2dup swap class<=
[ class-tie-breaker ] [ 2drop +lt+ ] if
] }
{ [ 2dup swap class<= ] [
2dup class<=
[ class-tie-breaker ] [ 2drop +gt+ ] if
] }
[ class-tie-breaker ]
} cond ;
: class<=> ( first second -- n )
class<=>-cache get [ (class<=>) ] 2cache ;
: sort-classes ( seq -- newseq )
>vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;
[ class<=> invert-comparison ] sort ;
: 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 +233,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

11
core/classes/classes.factor
View File

@ -5,21 +5,24 @@ slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs ;
IN: classes
SYMBOL: class<-cache
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<=>-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<=>-cache get clear-assoc
class-not-cache get clear-assoc
classes-intersect-cache get clear-assoc
class-and-cache get clear-assoc
@ -57,6 +60,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 ;

18
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

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

@ -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 ;

19
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)
@ -100,3 +100,20 @@ 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

5
core/continuations/continuations.factor
View File

@ -138,6 +138,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/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/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

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

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?

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/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 ;

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

@ -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 -- ? )
{

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 ;

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>

3
core/syntax/syntax.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays bit-arrays byte-arrays
USING: alien arrays bit-arrays byte-arrays byte-vectors
definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
@ -79,6 +79,7 @@ IN: bootstrap.syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax

1
extra/bank/authors.txt Normal file
View File

@ -0,0 +1 @@
Alex Chapman

34
extra/bank/bank-tests.factor Normal file
View File

@ -0,0 +1,34 @@
USING: accessors arrays bank calendar kernel math math.functions namespaces tools.test tools.walker ;
IN: bank.tests
SYMBOL: my-account
[
"Alex's Take Over the World Fund" 0.07 1 2007 11 1 <date> 6101.94 open-account my-account set
[ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
[ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
] with-scope
[
"Petty Cash" 0.07 1 2006 12 1 <date> 10962.18 open-account my-account set
[ 11027 ] [ my-account get 2007 1 2 <date> process-to-date balance>> round >integer ] unit-test
] with-scope
[
"Saving to buy a pony" 0.0725 1 2008 3 3 <date> 11106.24 open-account my-account set
[ 8416 ] [
my-account get [
2008 3 11 <date> -750 "Need to buy food" <transaction> ,
2008 3 25 <date> -500 "Going to a party" <transaction> ,
2008 4 8 <date> -800 "Losing interest in the pony..." <transaction> ,
2008 4 8 <date> -700 "Buying a rocking horse" <transaction> ,
] { } make inserting-transactions balance>> round >integer
] unit-test
] with-scope
[
[ 6781 ] [
"..." 0.07 1 2007 4 10 <date> 4398.50 open-account
2007 10 26 <date> 2000 "..." <transaction> 1array inserting-transactions
2008 4 10 <date> process-to-date dup balance>> swap unpaid-interest>> + round >integer
] unit-test
] with-scope

69
extra/bank/bank.factor Normal file
View File

@ -0,0 +1,69 @@
USING: accessors calendar kernel math math.order money sequences ;
IN: bank
TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ;
: <account> ( name interest-rate interest-payment-day opening-date -- account )
V{ } clone 0 pick account boa ;
TUPLE: transaction date amount description ;
C: <transaction> transaction
: >>transaction ( account transaction -- account )
over transactions>> push ;
: total ( transactions -- balance )
0 [ amount>> + ] reduce ;
: balance>> ( account -- balance ) transactions>> total ;
: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
>r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
: daily-rate ( yearly-rate day -- daily-rate )
days-in-year / ;
: daily-rate>> ( account date -- rate )
[ interest-rate>> ] dip daily-rate ;
: before? ( date date -- ? ) <=> 0 < ;
: transactions-on-date ( account date -- transactions )
[ before? ] curry filter ;
: balance-on-date ( account date -- balance )
transactions-on-date total ;
: pay-interest ( account date -- )
over unpaid-interest>> "Interest Credit" <transaction>
>>transaction 0 >>unpaid-interest drop ;
: interest-payment-day? ( account date -- ? )
day>> swap interest-payment-day>> = ;
: ?pay-interest ( account date -- )
2dup interest-payment-day? [ pay-interest ] [ 2drop ] if ;
: unpaid-interest+ ( account amount -- account )
over unpaid-interest>> + >>unpaid-interest ;
: accumulate-interest ( account date -- )
[ dupd daily-rate>> over balance>> * unpaid-interest+ ] keep
>>interest-last-paid drop ;
: process-day ( account date -- )
2dup accumulate-interest ?pay-interest ;
: each-day ( quot start end -- )
2dup before? [
>r dup >r over >r swap call r> r> 1 days time+ r> each-day
] [
3drop
] if ;
: process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+
[ dupd process-day ] spin each-day ;
: inserting-transactions ( account transactions -- account )
[ [ date>> process-to-date ] keep >>transaction ] each ;

1
extra/bank/summary.txt Normal file
View File

@ -0,0 +1 @@
Bank account simulator for compound interest calculated daily and paid monthly

6
extra/benchmark/crc32/crc32.factor
View File

@ -1,10 +1,10 @@
USING: io.crc32 io.encodings.ascii io.files kernel math ;
USING: checksums checksums.crc32 io.encodings.ascii io.files kernel math ;
IN: benchmark.crc32
: crc32-primes-list ( -- )
10 [
"extra/math/primes/list/list.factor" resource-path
ascii file-contents crc32 drop
"resource:extra/math/primes/list/list.factor"
crc32 checksum-file drop
] times ;
MAIN: crc32-primes-list

4
extra/benchmark/md5/md5.factor
View File

@ -1,7 +1,7 @@
USING: crypto.md5 io.files kernel ;
USING: checksums checksums.md5 io.files kernel ;
IN: benchmark.md5
: md5-primes-list ( -- )
"extra/math/primes/list/list.factor" resource-path file>md5 drop ;
"resource:extra/math/primes/list/list.factor" md5 checksum-file drop ;
MAIN: md5-primes-list

12
extra/benchmark/reverse-complement/reverse-complement-tests.factor
View File

@ -1,13 +1,13 @@
IN: benchmark.reverse-complement.tests
USING: tools.test benchmark.reverse-complement crypto.md5
USING: tools.test benchmark.reverse-complement
checksums checksums.md5
io.files kernel ;
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
[ resource-path ] bi@
"resource:extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
"resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
reverse-complement
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
resource-path file>md5str
"resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
md5 checksum-file hex-string
] unit-test

4
extra/benchmark/sha1/sha1.factor
View File

@ -1,7 +1,7 @@
USING: crypto.sha1 io.files kernel ;
USING: checksums checksums.sha1 io.files kernel ;
IN: benchmark.sha1
: sha1-primes-list ( -- )
"extra/math/primes/list/list.factor" resource-path file>sha1 drop ;
"resource:extra/math/primes/list/list.factor" sha1 checksum-file drop ;
MAIN: sha1-primes-list

6
extra/bootstrap/image/download/download.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.download
USING: http.client crypto.md5 splitting assocs kernel io.files
bootstrap.image sequences io ;
USING: http.client checksums checksums.md5 splitting assocs
kernel io.files bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ;
@ -12,7 +12,7 @@ bootstrap.image sequences io ;
: need-new-image? ( image -- ? )
dup exists?
[ dup file>md5str swap download-checksums at = not ]
[ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ]
[ drop t ] if ;
: download-image ( arch -- )

9
extra/bootstrap/image/upload/upload.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.md5 splitting assocs
kernel io.files bootstrap.image sequences io namespaces
io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload
USING: http.client crypto.md5 splitting assocs kernel io.files
bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ;
SYMBOL: upload-images-destination
@ -17,7 +18,9 @@ SYMBOL: upload-images-destination
: compute-checksums ( -- )
checksums ascii [
boot-image-names [ dup write bl file>md5str print ] each
boot-image-names [
[ write bl ] [ md5 checksum-file hex-string print ] bi
] each
] with-file-writer ;
: upload-images ( -- )

0
extra/crypto/md5/authors.txt → extra/checksums/md5/authors.txt
View File

11
extra/checksums/md5/md5-docs.factor Executable file
View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax ;
IN: checksums.md5
HELP: md5
{ $description "MD5 checksum algorithm." } ;
ARTICLE: "checksums.md5" "MD5 checksum"
"The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")."
{ $subsection md5 } ;
ABOUT: "checksums.md5"

10
extra/checksums/md5/md5-tests.factor Executable file
View File

@ -0,0 +1,10 @@
USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test

24
extra/crypto/md5/md5.factor → extra/checksums/md5/md5.factor
View File

@ -3,8 +3,8 @@
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting strings
sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary symbols math.bitfields.lib ;
IN: crypto.md5
io.encodings.binary symbols math.bitfields.lib checksums ;
IN: checksums.md5
<PRIVATE
@ -166,26 +166,18 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
[ (process-md5-block) ] each
] if ;
: (stream>md5) ( -- )
: stream>md5 ( -- )
64 read [ process-md5-block ] keep
length 64 = [ (stream>md5) ] when ;
length 64 = [ stream>md5 ] when ;
: get-md5 ( -- str )
[ a b c d ] [ get 4 >le ] map concat >byte-array ;
PRIVATE>
: stream>md5 ( stream -- byte-array )
[ initialize-md5 (stream>md5) get-md5 ] with-stream ;
SINGLETON: md5
: byte-array>md5 ( byte-array -- checksum )
binary <byte-reader> stream>md5 ;
INSTANCE: md5 checksum
: byte-array>md5str ( byte-array -- md5-string )
byte-array>md5 hex-string ;
: file>md5 ( path -- byte-array )
binary <file-reader> stream>md5 ;
: file>md5str ( path -- md5-string )
file>md5 hex-string ;
M: md5 checksum-stream ( stream -- byte-array )
drop [ initialize-md5 stream>md5 get-md5 ] with-stream ;

8
extra/checksums/null/null.factor Normal file
View File

@ -0,0 +1,8 @@
USING: checksums ;
IN: checksums.null
SINGLETON: null
INSTANCE: null checksum
M: null checksum-bytes ;

0
extra/crypto/sha1/authors.txt → extra/checksums/sha1/authors.txt
View File

11
extra/checksums/sha1/sha1-docs.factor Normal file
View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax ;
IN: checksums.sha1
HELP: sha1
{ $description "SHA1 checksum algorithm." } ;
ARTICLE: "checksums.sha1" "SHA1 checksum"
"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."
{ $subsection sha1 } ;
ABOUT: "checksums.sha1"

10
extra/crypto/sha1/sha1-tests.factor → extra/checksums/sha1/sha1-tests.factor
View File

@ -1,14 +1,14 @@
USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ;
USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ;
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
10 swap <array> concat byte-array>sha1str ] unit-test
10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
[
";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
] [
"\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
byte-array>sha1-interleave
sha1-interleave
] unit-test

28
extra/crypto/sha1/sha1.factor → extra/checksums/sha1/sha1.factor
View File

@ -1,8 +1,8 @@
USING: arrays combinators crypto.common kernel io
io.encodings.binary io.files io.streams.byte-array math.vectors
strings sequences namespaces math parser sequences vectors
io.binary hashtables symbols math.bitfields.lib ;
IN: crypto.sha1
io.binary hashtables symbols math.bitfields.lib checksums ;
IN: checksums.sha1
! Implemented according to RFC 3174.
@ -99,30 +99,22 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
[ (process-sha1-block) ] each
] if ;
: (stream>sha1) ( -- )
: stream>sha1 ( -- )
64 read [ process-sha1-block ] keep
length 64 = [ (stream>sha1) ] when ;
length 64 = [ stream>sha1 ] when ;
: get-sha1 ( -- str )
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
: stream>sha1 ( stream -- sha1 )
[ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ;
SINGLETON: sha1
: byte-array>sha1 ( string -- sha1 )
binary <byte-reader> stream>sha1 ;
INSTANCE: sha1 checksum
: byte-array>sha1str ( string -- str )
byte-array>sha1 hex-string ;
M: sha1 checksum-stream ( stream -- sha1 )
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-stream ;
: byte-array>sha1-bignum ( string -- n )
byte-array>sha1 be> ;
: file>sha1 ( file -- sha1 )
binary <file-reader> stream>sha1 ;
: byte-array>sha1-interleave ( string -- seq )
: sha1-interleave ( string -- seq )
[ zero? ] left-trim
dup length odd? [ rest ] when
seq>2seq [ byte-array>sha1 ] bi@
seq>2seq [ sha1 checksum-bytes ] bi@
2seq>seq ;

0
extra/crypto/sha2/authors.txt → extra/checksums/sha2/authors.txt
View File

11
extra/checksums/sha2/sha2-docs.factor Normal file
View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax ;
IN: checksums.sha2
HELP: sha-256
{ $description "SHA-256 checksum algorithm." } ;
ARTICLE: "checksums.sha2" "SHA2 checksum"
"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."
{ $subsection sha-256 } ;
ABOUT: "checksums.sha2"

14
extra/crypto/sha2/sha2-tests.factor → extra/checksums/sha2/sha2-tests.factor
View File

@ -1,7 +1,7 @@
USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ;
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test
USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test

15
extra/crypto/sha2/sha2.factor → extra/checksums/sha2/sha2.factor
View File

@ -1,6 +1,6 @@
USING: crypto.common kernel splitting math sequences namespaces
io.binary symbols math.bitfields.lib ;
IN: crypto.sha2
io.binary symbols math.bitfields.lib checksums ;
IN: checksums.sha2
<PRIVATE
@ -118,14 +118,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
PRIVATE>
: byte-array>sha-256 ( string -- string )
[
SINGLETON: sha-256
INSTANCE: sha-256 checksum
M: sha-256 checksum-bytes
drop [
K-256 K set
initial-H-256 H set
4 word-size set
64 block-size set
byte-array>sha2
] with-scope ;
: byte-array>sha-256-string ( string -- hexstring )
byte-array>sha-256 hex-string ;

13
extra/crypto/common/common-docs.factor
View File

@ -1,13 +0,0 @@
USING: help.markup help.syntax kernel math sequences quotations
math.private ;
IN: crypto.common
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: crypto.common io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
}
{ $notes "Numbers are zero-padded on the left." } ;

8
extra/crypto/common/common.factor
View File

@ -1,5 +1,6 @@
USING: arrays kernel io io.binary sbufs splitting strings sequences
namespaces math math.parser parser hints math.bitfields.lib ;
namespaces math math.parser parser hints math.bitfields.lib
assocs ;
IN: crypto.common
: w+ ( int int -- int ) + 32 bits ; inline
@ -39,9 +40,6 @@ SYMBOL: big-endian?
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
: hex-string ( seq -- str )
[ [ >hex 2 48 pad-left % ] each ] "" make ;
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ;
: seq>2seq ( seq -- seq1 seq2 )
@ -50,7 +48,7 @@ SYMBOL: big-endian?
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
[ 2array flip concat ] keep like ;
[ zip concat ] keep like ;
: mod-nth ( n seq -- elt )
#! 5 "abcd" -> b

11
extra/crypto/hmac/hmac.factor
View File

@ -1,18 +1,19 @@
USING: arrays combinators crypto.common crypto.md5 crypto.sha1
crypto.md5.private io io.binary io.files io.streams.byte-array
kernel math math.vectors memoize sequences io.encodings.binary ;
USING: arrays combinators crypto.common checksums checksums.md5
checksums.sha1 checksums.md5.private io io.binary io.files
io.streams.byte-array kernel math math.vectors memoize sequences
io.encodings.binary ;
IN: crypto.hmac
: sha1-hmac ( Ko Ki -- hmac )
initialize-sha1 process-sha1-block
(stream>sha1) get-sha1
stream>sha1 get-sha1
initialize-sha1
>r process-sha1-block r>
process-sha1-block get-sha1 ;
: md5-hmac ( Ko Ki -- hmac )
initialize-md5 process-md5-block
(stream>md5) get-md5
stream>md5 get-md5
initialize-md5
>r process-md5-block r>
process-md5-block get-md5 ;

18
extra/crypto/md5/md5-docs.factor
View File

@ -1,18 +0,0 @@
USING: help.markup help.syntax kernel math sequences quotations
crypto.common byte-arrays ;
IN: crypto.md5
HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } }
{ $description "Take the MD5 hash until end of stream." }
{ $notes "Used to implement " { $link byte-array>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ;
HELP: byte-array>md5
{ $values { "byte-array" byte-array } { "checksum" "an md5 hash" } }
{ $description "Outputs the MD5 hash of a byte array." }
{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;
HELP: file>md5
{ $values { "path" "a path" } { "byte-array" "byte-array md5 hash" } }
{ $description "Outputs the MD5 hash of a file." }
{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;

10
extra/crypto/md5/md5-tests.factor
View File

@ -1,10 +0,0 @@
USING: kernel math namespaces crypto.md5 tools.test byte-arrays ;
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test
[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test
[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test
[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test

7
extra/csv/csv-tests.factor
View File

@ -46,9 +46,7 @@ IN: csv.tests
[ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar"
<string-reader> csv ] named-unit-test
! !!!!!!!! other tests
[ { { "Phil Dawes" } } ]
@ -65,3 +63,8 @@ IN: csv.tests
"allows setting of delimiting character"
[ { { "foo" "bah" "baz" } } ]
[ "foo\tbah\tbaz\n" <string-reader> CHAR: \t [ csv ] with-delimiter ] named-unit-test
"Quoted field followed immediately by newline"
[ { { "foo" "bar" }
{ "1" "2" } } ]
[ "foo,\"bar\"\n1,2" <string-reader> csv ] named-unit-test

1
extra/csv/csv.factor
View File

@ -31,6 +31,7 @@ VAR: delimiter
read1 dup
{ { CHAR: " [ , quoted-field ] } ! " is an escaped quote
{ delimiter> [ ] } ! end of quoted field
{ CHAR: \n [ ] }
[ 2drop skip-to-field-end ] ! end of quoted field + padding
} case ;

8
extra/db/pooling/pooling-tests.factor Normal file
View File

@ -0,0 +1,8 @@
IN: db.pooling.tests
USING: db.pooling tools.test ;
\ <pool> must-infer
{ 2 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-connection ] must-infer-as

43
extra/db/pooling/pooling.factor Normal file
View File

@ -0,0 +1,43 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays namespaces sequences continuations
destructors db ;
IN: db.pooling
TUPLE: pool db params connections ;
: <pool> ( db params -- pool )
V{ } clone pool boa ;
M: pool dispose [ dispose-each f ] change-connections drop ;
: with-db-pool ( db params quot -- )
>r <pool> r> [ pool swap with-variable ] curry with-disposal ; inline
TUPLE: return-connection db pool ;
: return-connection ( db pool -- )
connections>> push ;
: new-connection ( pool -- )
[ [ db>> ] [ params>> ] bi make-db db-open ] keep
return-connection ;
: acquire-connection ( pool -- db )
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;
: (with-pooled-connection) ( db pool quot -- )
[ >r drop db r> with-variable ]
[ drop return-connection ]
3bi ; inline
: with-pooled-connection ( pool quot -- )
>r [ acquire-connection ] keep r>
[ (with-pooled-connection) ] [ ] [ 2drop dispose ] cleanup ; inline
M: return-connection dispose
[ db>> ] [ pool>> ] bi return-connection ;
: return-connection-later ( db pool -- )
\ return-connection boa add-always-destructor ;

19
extra/delegate/delegate-docs.factor
View File

@ -24,30 +24,17 @@ HELP: CONSULT:
{ define-consult POSTPONE: CONSULT: } related-words
HELP: define-mimic
{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." }
{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ;
HELP: MIMIC:
{ $syntax "MIMIC: group mimicker mimicked" }
{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ;
HELP: group-words
{ $values { "group" "a group" } { "words" "an array of words" } }
{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ;
{ $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ;
ARTICLE: { "delegate" "intro" } "Delegation module"
"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use"
"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". One type of group is a tuple, which consists of the slot words. To define a group as a set of words, use"
{ $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol }
"One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are"
{ $subsection POSTPONE: CONSULT: }
{ $subsection define-consult }
"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are"
{ $subsection POSTPONE: MIMIC: }
{ $subsection define-mimic } ;
{ $subsection define-consult } ;
IN: delegate
ABOUT: { "delegate" "intro" }

13
extra/delegate/delegate-tests.factor
View File

@ -2,11 +2,6 @@ USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string ;
IN: delegate.tests
DEFER: example
[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
[ 2 ] [ \ example "prop" word-prop ] unit-test
TUPLE: hello this that ;
C: <hello> hello
@ -30,21 +25,19 @@ GENERIC: bing ( c -- d )
PROTOCOL: bee bing ;
CONSULT: hello goodbye goodbye-those ;
M: hello bing hello-test ;
MIMIC: bee goodbye hello
[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
! [ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ V{ goodbye } ] [ baz protocol-users ] unit-test
[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
! [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
! [ [ baz see ] with-string-writer ] unit-test
[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
! [ f ] [ goodbye baz method ] unit-test

124
extra/delegate/delegate.factor
View File

@ -1,9 +1,44 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
vectors definitions prettyprint combinators.lib math sets ;
vectors definitions prettyprint combinators.lib math hashtables sets ;
IN: delegate
: protocol-words ( protocol -- words )
\ protocol-words word-prop ;
: protocol-consult ( protocol -- consulters )
\ protocol-consult word-prop ;
GENERIC: group-words ( group -- words )
M: tuple-class group-words
"slot-names" word-prop [
[ reader-word ] [ writer-word ] bi
2array [ 0 2array ] map
] map concat ;
! Consultation
: consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
: change-word-prop ( word prop quot -- )
rot word-props swap change-at ; inline
: register-protocol ( group class quot -- )
rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
: define-consult ( group class quot -- )
[ register-protocol ] [
rot group-words -rot
[ consult-method ] 2curry each
] 3bi ;
: CONSULT:
scan-word scan-word parse-definition define-consult ; parsing
! Protocols
: cross-2each ( seq1 seq2 quot -- )
@ -12,36 +47,46 @@ IN: delegate
: forget-all-methods ( classes words -- )
[ 2array forget ] cross-2each ;
: protocol-words ( protocol -- words )
"protocol-words" word-prop ;
: protocol-users ( protocol -- users )
"protocol-users" word-prop ;
protocol-consult keys ;
: users-and-words ( protocol -- users words )
[ protocol-users ] [ protocol-words ] bi ;
: lost-words ( protocol wordlist -- lost-words )
>r protocol-words r> diff ;
: forget-old-definitions ( protocol new-wordlist -- )
>r users-and-words r>
>r [ protocol-users ] [ protocol-words ] bi r>
swap diff forget-all-methods ;
: define-protocol ( protocol wordlist -- )
! 2dup forget-old-definitions
{ } like "protocol-words" set-word-prop ;
: added-words ( protocol wordlist -- added-words )
swap protocol-words swap diff ;
: add-new-definitions ( protocol wordlist -- )
dupd added-words >r protocol-consult >alist r>
[ first2 consult-method ] cross-2each ;
: initialize-protocol-props ( protocol wordlist -- )
[ drop H{ } clone \ protocol-consult set-word-prop ]
[ { } like \ protocol-words set-word-prop ] 2bi ;
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;
: define-protocol ( protocol wordlist -- )
fill-in-depth
[ forget-old-definitions ]
[ add-new-definitions ]
[ initialize-protocol-props ] 2tri ;
: PROTOCOL:
CREATE-WORD
dup define-symbol
dup f "inline" set-word-prop
parse-definition fill-in-depth define-protocol ; parsing
[ define-symbol ]
[ f "inline" set-word-prop ]
[ parse-definition define-protocol ] tri ; parsing
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol forget*
[ users-and-words forget-all-methods ] [ call-next-method ] bi ;
[ f forget-old-definitions ] [ call-next-method ] bi ;
: show-words ( wordlist' -- wordlist )
[ dup second zero? [ first ] when ] map ;
@ -52,51 +97,4 @@ M: protocol definer drop \ PROTOCOL: \ ; ;
M: protocol synopsis* word-synopsis ; ! Necessary?
GENERIC: group-words ( group -- words )
M: protocol group-words
"protocol-words" word-prop ;
M: tuple-class group-words
"slot-names" word-prop [
[ reader-word ] [ writer-word ] bi
2array [ 0 2array ] map
] map concat ;
! Consultation
: define-consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
: change-word-prop ( word prop quot -- )
>r swap word-props r> change-at ; inline
: add ( item vector/f -- vector )
2dup member? [ nip ] [ ?push ] if ;
: use-protocol ( class group -- )
"protocol-users" [ add ] change-word-prop ;
: define-consult ( group class quot -- )
swapd >r 2dup use-protocol group-words swap r>
[ define-consult-method ] 2curry each ;
: CONSULT:
scan-word scan-word parse-definition define-consult ; parsing
! Mimic still needs to be updated
: mimic-method ( mimicker mimicked generic -- )
tuck method
[ [ create-method-in ] [ word-def ] bi* define ]
[ 2drop ] if* ;
: define-mimic ( group mimicker mimicked -- )
[ drop swap use-protocol ] [
rot group-words -rot
[ rot first mimic-method ] 2curry each
] 3bi ;
: MIMIC:
scan-word scan-word scan-word define-mimic ; parsing
M: protocol group-words protocol-words ;

7
extra/destructors/destructors.factor
View File

@ -26,14 +26,11 @@ M: destructor dispose
: add-always-destructor ( obj -- )
<destructor> always-destructors get push ;
: dispose-each ( seq -- )
<reversed> [ dispose ] each ;
: do-always-destructors ( -- )
always-destructors get dispose-each ;
always-destructors get <reversed> dispose-each ;
: do-error-destructors ( -- )
error-destructors get dispose-each ;
error-destructors get <reversed> dispose-each ;
: with-destructors ( quot -- )
[

8
extra/farkup/farkup.factor
View File

@ -63,8 +63,14 @@ MEMO: eq ( -- parser )
] with-html-stream
] with-string-writer ;
: check-url ( href -- href' )
CHAR: : over member? [
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
[ drop "/" ] unless
] when ;
: escape-link ( href text -- href-esc text-esc )
>r escape-quoted-string r> escape-string ;
>r check-url escape-quoted-string r> escape-string ;
: make-link ( href text -- seq )
escape-link

3
extra/help/handbook/handbook.factor
View File

@ -204,7 +204,8 @@ ARTICLE: "io" "Input and output"
{ $heading "Other features" }
{ $subsection "network-streams" }
{ $subsection "io.launcher" }
{ $subsection "io.timeouts" } ;
{ $subsection "io.timeouts" }
{ $subsection "checksums" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }

4
extra/html/elements/elements.factor
View File

@ -143,7 +143,7 @@ SYMBOL: html
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style"
"script" "div" "span" "select" "option" "style" "input"
] [ define-closed-html-word ] each
! Define some open HTML tags
@ -161,6 +161,6 @@ SYMBOL: html
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title"
"media" "title" "multiple"
] [ define-attribute-word ] each
] with-compilation-unit

22
extra/http/http-tests.factor
View File

@ -1,6 +1,6 @@
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences
assocs io.sockets db db.sqlite ;
assocs io.sockets db db.sqlite continuations ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
@ -24,6 +24,12 @@ IN: http.tests
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
@ -93,7 +99,7 @@ Host: www.sex.com
STRING: read-response-test-1
HTTP/1.1 404 not found
Content-Type: text/html
Content-Type: text/html; charset=UTF8
blah
;
@ -103,8 +109,10 @@ blah
version: "1.1"
code: 404
message: "not found"
header: H{ { "content-type" "text/html" } }
header: H{ { "content-type" "text/html; charset=UTF8" } }
cookies: V{ }
content-type: "text/html"
content-charset: "UTF8"
}
] [
read-response-test-1 lf>crlf
@ -114,7 +122,7 @@ blah
STRING: read-response-test-1'
HTTP/1.1 404 not found
content-type: text/html
content-type: text/html; charset=UTF8
;
@ -140,11 +148,13 @@ accessors namespaces threads ;
: add-quit-action
<action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
[ stop-server [ "Goodbye" write ] <html-content> ] >>display
"quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ;
[ test-db drop delete-file ] ignore-errors
test-db [
init-sessions-table
] with-db
@ -191,7 +201,7 @@ test-db [
[ ] [
[
<dispatcher>
<action> <protected>
<action> f <protected>
<login>
<sessions>
"" add-responder

65
extra/http/http.factor
View File

@ -119,21 +119,41 @@ IN: http
header-value>string check-header-string write crlf
] assoc-each crlf ;
: add-query-param ( value key assoc -- )
[
at [
{
{ [ dup string? ] [ swap 2array ] }
{ [ dup array? ] [ swap suffix ] }
{ [ dup not ] [ drop ] }
} cond
] when*
] 2keep set-at ;
: query>assoc ( query -- assoc )
dup [
"&" split [
"=" split1 [ dup [ url-decode ] when ] bi@
] H{ } map>assoc
"&" split H{ } clone [
[
>r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
add-query-param
] curry each
] keep
] when ;
: assoc>query ( hash -- str )
[
[ url-encode ]
[ dup number? [ number>string ] when url-encode ]
bi*
"=" swap 3append
] { } assoc>map
"&" join ;
{
{ [ dup number? ] [ number>string ] }
{ [ dup string? ] [ 1array ] }
{ [ dup sequence? ] [ ] }
} cond
] assoc-map
[
[
>r url-encode r>
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
TUPLE: cookie name value path domain expires max-age http-only ;
@ -291,6 +311,12 @@ SYMBOL: max-post-request
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
" " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
: read-request ( -- request )
<request>
read-method
@ -377,6 +403,8 @@ code
message
header
cookies
content-type
content-charset
body ;
: <response>
@ -403,7 +431,10 @@ body ;
: read-response-header
read-header >>header
dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
extract-cookies
dup "content-type" header [
parse-content-type [ >>content-type ] [ >>content-charset ] bi*
] when* ;
: read-response ( -- response )
<response>
@ -422,10 +453,15 @@ body ;
: write-response-message ( response -- response )
dup message>> write crlf ;
: unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ]
[ content-charset>> ] bi
[ "; charset=" swap 3append ] when* ;
: write-response-header ( response -- response )
dup header>> clone
over cookies>> f like
[ unparse-cookies "set-cookie" pick set-at ] when*
over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
over unparse-content-type "content-type" pick set-at
write-header ;
GENERIC: write-response-body* ( body -- )
@ -453,9 +489,6 @@ M: response write-full-response ( request response -- )
dup write-response
swap method>> "HEAD" = [ write-response-body ] unless ;
: set-content-type ( request/response content-type -- request/response )
"content-type" set-header ;
: get-cookie ( request/response name -- cookie/f )
>r cookies>> r> '[ , _ name>> = ] find nip ;
@ -466,7 +499,7 @@ M: response write-full-response ( request response -- )
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
over cookies>> push ;
TUPLE: raw-response
TUPLE: raw-response
version
code
message

45
extra/http/server/auth/admin/admin.factor
View File

@ -1,25 +1,36 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators
locals db.tuples
USING: kernel sequences accessors namespaces combinators words
assocs locals db.tuples arrays splitting strings qualified
http.server.templating.chloe
http.server.boilerplate
http.server.auth.providers
http.server.auth.providers.db
http.server.auth.login
http.server.auth
http.server.forms
http.server.components.inspector
http.server.components
http.server.validators
http.server.sessions
http.server.actions
http.server.crud
http.server ;
EXCLUDE: http.server.components => string? number? ;
IN: http.server.auth.admin
: admin-template ( name -- template )
"resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
: words>strings ( seq -- seq' )
[ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
: strings>words ( seq -- seq' )
[ ":" split1 swap lookup ] map ;
: <capabilities> ( id -- component )
capabilities get words>strings <menu> ;
: <new-user-form> ( -- form )
"user" <form>
"new-user" admin-template >>edit-template
@ -27,7 +38,8 @@ IN: http.server.auth.admin
"realname" <string> add-field
"new-password" <password> t >>required add-field
"verify-password" <password> t >>required add-field
"email" <email> add-field ;
"email" <email> add-field
"capabilities" <capabilities> add-field ;
: <edit-user-form> ( -- form )
"user" <form>
@ -38,7 +50,8 @@ IN: http.server.auth.admin
"new-password" <password> add-field
"verify-password" <password> add-field
"email" <email> add-field
"profile" <inspector> add-field ;
"profile" <inspector> add-field
"capabilities" <capabilities> add-field ;
: <user-list-form> ( -- form )
"user-list" <form>
@ -77,7 +90,7 @@ IN: http.server.auth.admin
"username" value <user>
"realname" value >>realname
"email" value >>email
"new-password" value >>password
"new-password" value >>encoded-password
H{ } clone >>profile
insert-tuple
@ -99,6 +112,7 @@ IN: http.server.auth.admin
[ realname>> "realname" set-value ]
[ email>> "email" set-value ]
[ profile>> "profile" set-value ]
[ capabilities>> words>strings "capabilities" set-value ]
} cleave
] >>init
@ -116,9 +130,14 @@ IN: http.server.auth.admin
{ "new-password" "verify-password" }
[ value empty? ] all? [
same-password-twice
"new-password" value >>password
"new-password" value >>encoded-password
] unless
"capabilities" value {
{ [ dup string? ] [ 1array ] }
{ [ dup array? ] [ ] }
} cond strings>words >>capabilities
update-tuple
next f <standard-redirect>
@ -139,6 +158,10 @@ IN: http.server.auth.admin
TUPLE: user-admin < dispatcher ;
SYMBOL: can-administer-users?
can-administer-users? define-capability
:: <user-admin> ( -- responder )
[let | ctor [ [ <user> ] ] |
user-admin new-dispatcher
@ -148,5 +171,11 @@ TUPLE: user-admin < dispatcher ;
ctor "$user-admin" <delete-user-action> "delete" add-responder
<boilerplate>
"admin" admin-template >>template
<protected>
{ can-administer-users? } <protected>
] ;
: make-admin ( username -- )
<user>
select-tuple
[ can-administer-users? suffix ] change-capabilities
update-tuple ;

2
extra/http/server/auth/admin/admin.xml
View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:style include="resource:extra/http/server/auth/admin/admin.css" />
<t:style t:include="resource:extra/http/server/auth/admin/admin.css" />
<div class="navbar">
<t:a t:href="$user-admin">List Users</t:a>

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