diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index de62ccd878..68be9c9b06 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -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" } "." } ; diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 19e323bdae..30f2ec23c4 100755 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -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 [ diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index e68c311836..92db38573a 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -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 ) [ diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index b3be0c41e7..cb73dc387e 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -305,12 +305,12 @@ M: wrapper ' [ emit ] emit-object ; ! Strings -: emit-chars ( seq -- ) +: emit-bytes ( seq -- ) bootstrap-cell 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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index bcd75e9854..6149e83893 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -59,6 +59,7 @@ num-types get f 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 { diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 8e4108866f..3247832d52 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -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 diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 4b74804749..7d703d3093 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -16,6 +16,7 @@ IN: bootstrap.syntax "?{" "BIN:" "B{" + "BV{" "C:" "CHAR:" "DEFER:" diff --git a/extra/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor similarity index 100% rename from extra/byte-vectors/byte-vectors-docs.factor rename to core/byte-vectors/byte-vectors-docs.factor diff --git a/extra/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor similarity index 100% rename from extra/byte-vectors/byte-vectors-tests.factor rename to core/byte-vectors/byte-vectors-tests.factor diff --git a/extra/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor similarity index 61% rename from extra/byte-vectors/byte-vectors.factor rename to core/byte-vectors/byte-vectors.factor index a8351dc781..e80b797a8d 100755 --- a/extra/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -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) ; - vector ( byte-array length -- byte-vector ) @@ -43,9 +32,3 @@ M: byte-vector equal? M: byte-array new-resizable drop ; INSTANCE: byte-vector growable - -: BV{ \ } [ >byte-vector ] parse-literal ; parsing - -M: byte-vector >pprint-sequence ; - -M: byte-vector pprint-delims drop \ BV{ \ } ; diff --git a/extra/byte-vectors/summary.txt b/core/byte-vectors/summary.txt similarity index 100% rename from extra/byte-vectors/summary.txt rename to core/byte-vectors/summary.txt diff --git a/extra/byte-vectors/tags.txt b/core/byte-vectors/tags.txt similarity index 100% rename from extra/byte-vectors/tags.txt rename to core/byte-vectors/tags.txt diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor new file mode 100644 index 0000000000..c352f02af4 --- /dev/null +++ b/core/checksums/checksums-docs.factor @@ -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" } ; diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor new file mode 100644 index 0000000000..08a13297d1 --- /dev/null +++ b/core/checksums/checksums.factor @@ -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 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 r> checksum-stream ; + +: hex-string ( seq -- str ) + [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ; diff --git a/core/io/crc32/authors.txt b/core/checksums/crc32/authors.txt similarity index 100% rename from core/io/crc32/authors.txt rename to core/checksums/crc32/authors.txt diff --git a/core/checksums/crc32/crc32-docs.factor b/core/checksums/crc32/crc32-docs.factor new file mode 100644 index 0000000000..0f277bcd16 --- /dev/null +++ b/core/checksums/crc32/crc32-docs.factor @@ -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" diff --git a/core/checksums/crc32/crc32-tests.factor b/core/checksums/crc32/crc32-tests.factor new file mode 100644 index 0000000000..6fe4b995ee --- /dev/null +++ b/core/checksums/crc32/crc32-tests.factor @@ -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 + diff --git a/core/io/crc32/crc32.factor b/core/checksums/crc32/crc32.factor similarity index 59% rename from core/io/crc32/crc32.factor rename to core/checksums/crc32/crc32.factor index afe7e4bfb7..e1f0b9417b 100755 --- a/core/io/crc32/crc32.factor +++ b/core/checksums/crc32/crc32.factor @@ -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 ; diff --git a/core/io/crc32/summary.txt b/core/checksums/crc32/summary.txt similarity index 100% rename from core/io/crc32/summary.txt rename to core/checksums/crc32/summary.txt diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 87c72048f4..3903da1ebc 100755 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -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." } ; diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index dba97c16f5..7387b8ae3a 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -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 diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 6a286e3204..8c910a1f8c 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -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 -: 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 { [ 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 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 { { [ 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 : (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 : (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 ] @@ -180,22 +180,43 @@ C: 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 : 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 ) diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 1c2871b031..8e992b852e 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -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 ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 5971ffd9fa..744944c281 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -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" diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index ae19f38d14..bb9fbd0167 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -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 diff --git a/core/classes/classes.factor b/core/classes/classes.factor index c998a1b155..53840c0027 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -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 ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index ca2547bacf..6f888ceca1 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -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 ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 4729a6dd5e..4e4d1701e4 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -30,3 +30,5 @@ M: predicate-class reset-class "predicate-definition" "superclass" } reset-props ; + +M: predicate-class rank-class drop 1 ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 41776c4eec..0cde687f16 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -233,8 +233,8 @@ TUPLE: laptop < computer battery ; C: 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" set ] unit-test @@ -266,8 +266,8 @@ TUPLE: server < computer rackmount ; C: 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" 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 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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 8bcf023131..ee7ff8c608 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 09f8f88ced..760844afb9 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -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 ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 8b396763e1..b0c216e82f 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -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 diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index cf67280cca..3e675b1f0f 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -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 diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index e0fd7bd457..c5e1ea54a6 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -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 diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 1024c377a8..39293bfec9 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -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" diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 82bab475b3..d35ba01e52 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -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 ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 90590fe565..1c1368a6c2 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -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 ; diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index c09f1abfd4..20e22fde82 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -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? [ diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index e4643b2f3d..b1bfc659df 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -11,7 +11,7 @@ C: 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' ) { diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 9d0c55afeb..933710aaca 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -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 diff --git a/core/io/crc32/crc32-docs.factor b/core/io/crc32/crc32-docs.factor deleted file mode 100644 index 7f85ee2b4e..0000000000 --- a/core/io/crc32/crc32-docs.factor +++ /dev/null @@ -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" diff --git a/core/io/crc32/crc32-tests.factor b/core/io/crc32/crc32-tests.factor deleted file mode 100644 index 5eafae23cb..0000000000 --- a/core/io/crc32/crc32-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: io.crc32 kernel math tools.test namespaces ; - -[ 0 ] [ "" crc32 ] unit-test -[ HEX: cbf43926 ] [ "123456789" crc32 ] unit-test - diff --git a/core/math/math.factor b/core/math/math.factor index d5040757d4..0218ded6ff 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -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? diff --git a/core/math/order/order.factor b/core/math/order/order.factor index 7cbef68dcc..76fe058ffa 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -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 -- ? ) diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index de7aec2bb1..7ab0ffc806 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -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 ; diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index 914018437a..ef829da9f2 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -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 diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 33c8244b4c..393264e459 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -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 diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 6e1aacff44..d1dbefe26b 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -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 diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index ab8a1f3eda..72e64d5b95 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -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 ] diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor index 5beb2555f0..51fa254a25 100755 --- a/core/optimizer/pattern-match/pattern-match.factor +++ b/core/optimizer/pattern-match/pattern-match.factor @@ -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 -- ? ) { diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 20d51f3461..9c3c1d9f6c 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 23c0c0a1a5..76c831cf13 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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? diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index e13a991e2b..f992b9ca01 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -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 ; diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 55ef3ccddd..f4e2557a71 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -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." } ; diff --git a/core/sets/sets.factor b/core/sets/sets.factor index 78a92155fc..b0d26e0f30 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -29,3 +29,9 @@ IN: sets : union ( seq1 seq2 -- newseq ) append prune ; + +: subset? ( seq1 seq2 -- ? ) + unique [ key? ] curry all? ; + +: set= ( seq1 seq2 -- ? ) + [ unique ] bi@ = ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 5ef2d46790..36a1806e12 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -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 diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index b2f063ddf1..2e1c46fac1 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -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 diff --git a/extra/bank/authors.txt b/extra/bank/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/bank/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/bank/bank-tests.factor b/extra/bank/bank-tests.factor new file mode 100644 index 0000000000..2aa31f1e85 --- /dev/null +++ b/extra/bank/bank-tests.factor @@ -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 6101.94 open-account my-account set + [ 6137 ] [ my-account get 2007 12 2 process-to-date balance>> round >integer ] unit-test + [ 6137 ] [ my-account get 2007 12 2 process-to-date balance>> round >integer ] unit-test +] with-scope + +[ + "Petty Cash" 0.07 1 2006 12 1 10962.18 open-account my-account set + [ 11027 ] [ my-account get 2007 1 2 process-to-date balance>> round >integer ] unit-test +] with-scope + +[ + "Saving to buy a pony" 0.0725 1 2008 3 3 11106.24 open-account my-account set + [ 8416 ] [ + my-account get [ + 2008 3 11 -750 "Need to buy food" , + 2008 3 25 -500 "Going to a party" , + 2008 4 8 -800 "Losing interest in the pony..." , + 2008 4 8 -700 "Buying a rocking horse" , + ] { } make inserting-transactions balance>> round >integer + ] unit-test +] with-scope + +[ + [ 6781 ] [ + "..." 0.07 1 2007 4 10 4398.50 open-account + 2007 10 26 2000 "..." 1array inserting-transactions + 2008 4 10 process-to-date dup balance>> swap unpaid-interest>> + round >integer + ] unit-test +] with-scope diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor new file mode 100644 index 0000000000..35d1337afc --- /dev/null +++ b/extra/bank/bank.factor @@ -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 ; + +: ( name interest-rate interest-payment-day opening-date -- account ) + V{ } clone 0 pick account boa ; + +TUPLE: transaction date amount description ; +C: 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 [ ] keep r> "Account Opened" >>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 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 ; diff --git a/extra/bank/summary.txt b/extra/bank/summary.txt new file mode 100644 index 0000000000..efd88787a5 --- /dev/null +++ b/extra/bank/summary.txt @@ -0,0 +1 @@ +Bank account simulator for compound interest calculated daily and paid monthly diff --git a/extra/benchmark/crc32/crc32.factor b/extra/benchmark/crc32/crc32.factor index ec424e89c9..0e5482da30 100755 --- a/extra/benchmark/crc32/crc32.factor +++ b/extra/benchmark/crc32/crc32.factor @@ -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 diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor index 3043725acd..8a259c1217 100644 --- a/extra/benchmark/md5/md5.factor +++ b/extra/benchmark/md5/md5.factor @@ -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 diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor index c66de87cb5..883124105b 100755 --- a/extra/benchmark/reverse-complement/reverse-complement-tests.factor +++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor @@ -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 diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor index 897d83ea0e..d5ff5673c2 100644 --- a/extra/benchmark/sha1/sha1.factor +++ b/extra/benchmark/sha1/sha1.factor @@ -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 diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index a186954ef0..46aca6cc6b 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -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 -- ) diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index ab26a4ff13..30d0428744 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -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 ( -- ) diff --git a/extra/crypto/md5/authors.txt b/extra/checksums/md5/authors.txt similarity index 100% rename from extra/crypto/md5/authors.txt rename to extra/checksums/md5/authors.txt diff --git a/extra/checksums/md5/md5-docs.factor b/extra/checksums/md5/md5-docs.factor new file mode 100755 index 0000000000..dca039d1d3 --- /dev/null +++ b/extra/checksums/md5/md5-docs.factor @@ -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" diff --git a/extra/checksums/md5/md5-tests.factor b/extra/checksums/md5/md5-tests.factor new file mode 100755 index 0000000000..8e314f7c28 --- /dev/null +++ b/extra/checksums/md5/md5-tests.factor @@ -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 + diff --git a/extra/crypto/md5/md5.factor b/extra/checksums/md5/md5.factor similarity index 88% rename from extra/crypto/md5/md5.factor rename to extra/checksums/md5/md5.factor index 45e10da74d..78494a40c0 100755 --- a/extra/crypto/md5/md5.factor +++ b/extra/checksums/md5/md5.factor @@ -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 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 stream>md5 ; +INSTANCE: md5 checksum -: byte-array>md5str ( byte-array -- md5-string ) - byte-array>md5 hex-string ; - -: file>md5 ( path -- byte-array ) - binary 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 ; diff --git a/extra/checksums/null/null.factor b/extra/checksums/null/null.factor new file mode 100644 index 0000000000..d2dc305ac2 --- /dev/null +++ b/extra/checksums/null/null.factor @@ -0,0 +1,8 @@ +USING: checksums ; +IN: checksums.null + +SINGLETON: null + +INSTANCE: null checksum + +M: null checksum-bytes ; diff --git a/extra/crypto/sha1/authors.txt b/extra/checksums/sha1/authors.txt similarity index 100% rename from extra/crypto/sha1/authors.txt rename to extra/checksums/sha1/authors.txt diff --git a/extra/checksums/sha1/sha1-docs.factor b/extra/checksums/sha1/sha1-docs.factor new file mode 100644 index 0000000000..8b8bf1cfa9 --- /dev/null +++ b/extra/checksums/sha1/sha1-docs.factor @@ -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" diff --git a/extra/crypto/sha1/sha1-tests.factor b/extra/checksums/sha1/sha1-tests.factor similarity index 69% rename from extra/crypto/sha1/sha1-tests.factor rename to extra/checksums/sha1/sha1-tests.factor index 14307355c2..808d37d1e4 100755 --- a/extra/crypto/sha1/sha1-tests.factor +++ b/extra/checksums/sha1/sha1-tests.factor @@ -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 concat byte-array>sha1str ] unit-test +10 swap 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 diff --git a/extra/crypto/sha1/sha1.factor b/extra/checksums/sha1/sha1.factor similarity index 83% rename from extra/crypto/sha1/sha1.factor rename to extra/checksums/sha1/sha1.factor index 3a74d1f5db..2efab873bc 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/checksums/sha1/sha1.factor @@ -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 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 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 ; diff --git a/extra/crypto/sha2/authors.txt b/extra/checksums/sha2/authors.txt similarity index 100% rename from extra/crypto/sha2/authors.txt rename to extra/checksums/sha2/authors.txt diff --git a/extra/checksums/sha2/sha2-docs.factor b/extra/checksums/sha2/sha2-docs.factor new file mode 100644 index 0000000000..c39831b266 --- /dev/null +++ b/extra/checksums/sha2/sha2-docs.factor @@ -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" diff --git a/extra/crypto/sha2/sha2-tests.factor b/extra/checksums/sha2/sha2-tests.factor similarity index 51% rename from extra/crypto/sha2/sha2-tests.factor rename to extra/checksums/sha2/sha2-tests.factor index 8fe655f205..2f4e3c51c4 100755 --- a/extra/crypto/sha2/sha2-tests.factor +++ b/extra/checksums/sha2/sha2-tests.factor @@ -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 diff --git a/extra/crypto/sha2/sha2.factor b/extra/checksums/sha2/sha2.factor similarity index 94% rename from extra/crypto/sha2/sha2.factor rename to extra/checksums/sha2/sha2.factor index 0acc5c1388..e5f16c9c11 100755 --- a/extra/crypto/sha2/sha2.factor +++ b/extra/checksums/sha2/sha2.factor @@ -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 -: 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 ; diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor deleted file mode 100644 index 559c7934d0..0000000000 --- a/extra/crypto/common/common-docs.factor +++ /dev/null @@ -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." } ; - - diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index a714727ad9..efe4653eba 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -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> 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 diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 91d404aead..fe77aa8969 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -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 ; diff --git a/extra/crypto/md5/md5-docs.factor b/extra/crypto/md5/md5-docs.factor deleted file mode 100755 index 667e0449ae..0000000000 --- a/extra/crypto/md5/md5-docs.factor +++ /dev/null @@ -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." } ; diff --git a/extra/crypto/md5/md5-tests.factor b/extra/crypto/md5/md5-tests.factor deleted file mode 100755 index 73bd240455..0000000000 --- a/extra/crypto/md5/md5-tests.factor +++ /dev/null @@ -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 - diff --git a/extra/csv/csv-tests.factor b/extra/csv/csv-tests.factor index 6ab26c7e40..7e96dbc0a6 100644 --- a/extra/csv/csv-tests.factor +++ b/extra/csv/csv-tests.factor @@ -46,9 +46,7 @@ IN: csv.tests [ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar" 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" CHAR: \t [ csv ] with-delimiter ] named-unit-test + +"Quoted field followed immediately by newline" +[ { { "foo" "bar" } + { "1" "2" } } ] +[ "foo,\"bar\"\n1,2" csv ] named-unit-test diff --git a/extra/csv/csv.factor b/extra/csv/csv.factor index 3953ce057b..b1953f5b57 100644 --- a/extra/csv/csv.factor +++ b/extra/csv/csv.factor @@ -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 ; diff --git a/extra/db/pooling/pooling-tests.factor b/extra/db/pooling/pooling-tests.factor new file mode 100644 index 0000000000..7b0de65ac4 --- /dev/null +++ b/extra/db/pooling/pooling-tests.factor @@ -0,0 +1,8 @@ +IN: db.pooling.tests +USING: db.pooling tools.test ; + +\ must-infer + +{ 2 0 } [ [ ] with-db-pool ] must-infer-as + +{ 1 0 } [ [ ] with-pooled-connection ] must-infer-as diff --git a/extra/db/pooling/pooling.factor b/extra/db/pooling/pooling.factor new file mode 100644 index 0000000000..83820294d6 --- /dev/null +++ b/extra/db/pooling/pooling.factor @@ -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 ; + +: ( db params -- pool ) + V{ } clone pool boa ; + +M: pool dispose [ dispose-each f ] change-connections drop ; + +: with-db-pool ( db params quot -- ) + >r 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 ; diff --git a/extra/delegate/delegate-docs.factor b/extra/delegate/delegate-docs.factor index f123c3a802..e6a2ad7bf4 100644 --- a/extra/delegate/delegate-docs.factor +++ b/extra/delegate/delegate-docs.factor @@ -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" } diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index 5e0abcd5ba..6aa015a74d 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -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 @@ -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 [ foo ] [ bar ] bi ] unit-test [ { t 1 0 } ] [ 1 0 bing ] unit-test [ 1 ] [ 1 0 f foo ] unit-test [ { t 1 0 } ] [ 1 0 f bar ] unit-test -! [ { f 1 0 } ] [ f 1 0 bing ] unit-test [ 3 ] [ 1 0 2 whoa ] unit-test [ 3 ] [ 1 0 f 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 diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 0ae8592e66..39eccfd194 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -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 ; diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 87b5740786..c3914e9c93 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -26,14 +26,11 @@ M: destructor dispose : add-always-destructor ( obj -- ) always-destructors get push ; -: dispose-each ( seq -- ) - [ dispose ] each ; - : do-always-destructors ( -- ) - always-destructors get dispose-each ; + always-destructors get dispose-each ; : do-error-destructors ( -- ) - error-destructors get dispose-each ; + error-destructors get dispose-each ; : with-destructors ( quot -- ) [ diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index 527ba8b4fa..15b7b4b72c 100755 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -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 diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index ce875b32d1..a9e94466c4 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -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" } diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 41e29fc712..49782fa305 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -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 diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 39e708c879..831becd264 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -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 - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display + [ stop-server [ "Goodbye" write ] ] >>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 [ [ ] [ [ - + f "" add-responder diff --git a/extra/http/http.factor b/extra/http/http.factor index 9729542ea4..315250692b 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 ) read-method @@ -377,6 +403,8 @@ code message header cookies +content-type +content-charset body ; : @@ -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 ) @@ -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 diff --git a/extra/http/server/auth/admin/admin.factor b/extra/http/server/auth/admin/admin.factor index c9d2769292..e762103d7b 100644 --- a/extra/http/server/auth/admin/admin.factor +++ b/extra/http/server/auth/admin/admin.factor @@ -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 ; +: words>strings ( seq -- seq' ) + [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ; + +: strings>words ( seq -- seq' ) + [ ":" split1 swap lookup ] map ; + +: ( id -- component ) + capabilities get words>strings ; + : ( -- form ) "user"
"new-user" admin-template >>edit-template @@ -27,7 +38,8 @@ IN: http.server.auth.admin "realname" add-field "new-password" t >>required add-field "verify-password" t >>required add-field - "email" add-field ; + "email" add-field + "capabilities" add-field ; : ( -- form ) "user" @@ -38,7 +50,8 @@ IN: http.server.auth.admin "new-password" add-field "verify-password" add-field "email" add-field - "profile" add-field ; + "profile" add-field + "capabilities" add-field ; : ( -- form ) "user-list" @@ -77,7 +90,7 @@ IN: http.server.auth.admin "username" value "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 @@ -139,6 +158,10 @@ IN: http.server.auth.admin TUPLE: user-admin < dispatcher ; +SYMBOL: can-administer-users? + +can-administer-users? define-capability + :: ( -- responder ) [let | ctor [ [ ] ] | user-admin new-dispatcher @@ -148,5 +171,11 @@ TUPLE: user-admin < dispatcher ; ctor "$user-admin" "delete" add-responder "admin" admin-template >>template - + { can-administer-users? } ] ; + +: make-admin ( username -- ) + + select-tuple + [ can-administer-users? suffix ] change-capabilities + update-tuple ; diff --git a/extra/http/server/auth/admin/admin.xml b/extra/http/server/auth/admin/admin.xml index d3c0ff4c90..1864c3c4bf 100644 --- a/extra/http/server/auth/admin/admin.xml +++ b/extra/http/server/auth/admin/admin.xml @@ -2,7 +2,7 @@ - +
List Users diff --git a/extra/http/server/auth/admin/edit-user.xml b/extra/http/server/auth/admin/edit-user.xml index 71feda82f8..b8c235532b 100644 --- a/extra/http/server/auth/admin/edit-user.xml +++ b/extra/http/server/auth/admin/edit-user.xml @@ -35,6 +35,11 @@ + + Capabilities: + + + Profile: diff --git a/extra/http/server/auth/admin/new-user.xml b/extra/http/server/auth/admin/new-user.xml index 6b5b2523d7..072e0c95bd 100644 --- a/extra/http/server/auth/admin/new-user.xml +++ b/extra/http/server/auth/admin/new-user.xml @@ -32,6 +32,11 @@ E-mail: + + + Capabilities: + + diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor index a25baf3ed2..36fcff4b2e 100755 --- a/extra/http/server/auth/auth.factor +++ b/extra/http/server/auth/auth.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs namespaces kernel +USING: accessors assocs namespaces kernel sequences http.server http.server.sessions http.server.auth.providers ; @@ -33,3 +33,9 @@ M: filter-responder init-user-profile : uchange ( quot key -- ) profile swap change-at user-changed ; inline + +SYMBOL: capabilities + +V{ } clone capabilities set-global + +: define-capability ( word -- ) capabilities get push-new ; diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor index daf6e30eae..ff071b34e3 100755 --- a/extra/http/server/auth/basic/basic.factor +++ b/extra/http/server/auth/basic/basic.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting base64 html.elements io combinators http.server -http.server.auth.providers http.server.auth.providers.null +http.server.auth.providers http.server.auth.login http sequences ; IN: http.server.auth.basic diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 453f4cc4d6..28486f3362 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -1,16 +1,23 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting -base64 io combinators sequences io.files namespaces hashtables -fry io.sockets arrays threads locals qualified continuations +combinators sequences namespaces hashtables sets +fry arrays threads locals qualified random +io +io.sockets +io.encodings.utf8 +io.encodings.string +io.binary +continuations destructors - +checksums +checksums.sha2 html.elements http http.server http.server.auth http.server.auth.providers -http.server.auth.providers.null +http.server.auth.providers.db http.server.actions http.server.components http.server.flows @@ -25,9 +32,24 @@ QUALIFIED: smtp SYMBOL: login-failed? -TUPLE: login < dispatcher users ; +TUPLE: login < dispatcher users checksum ; -: users login get users>> ; +: users ( -- provider ) + login get users>> ; + +: encode-password ( string salt -- bytes ) + [ utf8 encode ] [ 4 >be ] bi* append + login get checksum>> checksum-bytes ; + +: >>encoded-password ( user string -- user ) + 32 random-bits [ encode-password ] keep + [ >>password ] [ >>salt ] bi* ; inline + +: valid-login? ( password user -- ? ) + [ salt>> encode-password ] [ password>> ] bi = ; + +: check-login ( password username -- user/f ) + users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ; ! Destructor TUPLE: user-saver user ; @@ -72,8 +94,7 @@ M: user-saver dispose form validate-form - "password" value "username" value - users check-login [ + "password" value "username" value check-login [ successful-login ] [ login-failed? on @@ -125,7 +146,7 @@ SYMBOL: user-exists? "username" value "realname" value >>realname - "new-password" value >>password + "new-password" value >>encoded-password "email" value >>email H{ } clone >>profile @@ -179,10 +200,10 @@ SYMBOL: user-exists? [ value empty? ] all? [ same-password-twice - "password" value uid users check-login + "password" value uid check-login [ login-failed? on validation-failed ] unless - "new-password" value >>password + "new-password" value >>encoded-password ] unless "realname" value >>realname @@ -314,7 +335,7 @@ SYMBOL: lost-password-from "ticket" value "username" value users claim-ticket [ - "new-password" value >>password + "new-password" value >>encoded-password users update-user "recover-4" login-template serve-template @@ -334,7 +355,7 @@ SYMBOL: lost-password-from ! ! ! Authentication logic -TUPLE: protected < filter-responder ; +TUPLE: protected < filter-responder capabilities ; C: protected @@ -342,11 +363,17 @@ C: protected begin-flow "$login/login" f ; +: check-capabilities ( responder user -- ? ) + [ capabilities>> ] bi@ subset? ; + M: protected call-responder* ( path responder -- response ) uid dup [ - users get-user - [ logged-in-user set ] [ save-user-after ] bi - call-next-method + users get-user 2dup check-capabilities [ + [ logged-in-user set ] [ save-user-after ] bi + call-next-method + ] [ + 3drop show-login-page + ] if ] [ 3drop show-login-page ] if ; @@ -364,12 +391,13 @@ M: login call-responder* ( path responder -- response ) swap >>default "login" add-responder "logout" add-responder - no-users >>users ; + users-in-db >>users + sha-256 >>checksum ; ! ! ! Configuration : allow-edit-profile ( login -- login ) - + f "edit-profile" add-responder ; : allow-registration ( login -- login ) diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index 82a2b54b0e..91e802b91c 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -1,33 +1,35 @@ IN: http.server.auth.providers.assoc.tests -USING: http.server.auth.providers -http.server.auth.providers.assoc tools.test -namespaces accessors kernel ; +USING: http.server.actions http.server.auth.providers +http.server.auth.providers.assoc http.server.auth.login +tools.test namespaces accessors kernel ; - "provider" set + + >>users +login set [ t ] [ "slava" - "foobar" >>password + "foobar" >>encoded-password "slava@factorcode.org" >>email H{ } clone >>profile - "provider" get new-user + users new-user username>> "slava" = ] unit-test [ f ] [ "slava" H{ } clone >>profile - "provider" get new-user + users new-user ] unit-test -[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test +[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test -[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test +[ ] [ "foobar" "slava" check-login "user" set ] unit-test [ t ] [ "user" get >boolean ] unit-test -[ ] [ "user" get "fdasf" >>password drop ] unit-test +[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test -[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test +[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test -[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test +[ f ] [ "foobar" "slava" check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 1a5298f050..a6a92356b6 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -1,10 +1,14 @@ IN: http.server.auth.providers.db.tests -USING: http.server.auth.providers +USING: http.server.actions +http.server.auth.login +http.server.auth.providers http.server.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations io.files accessors kernel ; -users-in-db "provider" set + + users-in-db >>users +login set [ "auth-test.db" temp-file delete-file ] ignore-errors @@ -14,30 +18,30 @@ users-in-db "provider" set [ t ] [ "slava" - "foobar" >>password + "foobar" >>encoded-password "slava@factorcode.org" >>email H{ } clone >>profile - "provider" get new-user + users new-user username>> "slava" = ] unit-test [ f ] [ "slava" H{ } clone >>profile - "provider" get new-user + users new-user ] unit-test - [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test - [ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test + [ ] [ "foobar" "slava" check-login "user" set ] unit-test [ t ] [ "user" get >boolean ] unit-test - [ ] [ "user" get "fdasf" >>password drop ] unit-test + [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test - [ ] [ "user" get "provider" get update-user ] unit-test + [ ] [ "user" get users update-user ] unit-test - [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test - [ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test + [ f ] [ "foobar" "slava" check-login >boolean ] unit-test ] with-db diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index 66d3a00a42..3ed4845609 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -9,9 +9,11 @@ user "USERS" { { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ } { "realname" "REALNAME" { VARCHAR 256 } } - { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } + { "password" "PASSWORD" BLOB +not-null+ } + { "salt" "SALT" INTEGER +not-null+ } { "email" "EMAIL" { VARCHAR 256 } } { "ticket" "TICKET" { VARCHAR 256 } } + { "capabilities" "CAPABILITIES" FACTOR-BLOB } { "profile" "PROFILE" FACTOR-BLOB } { "deleted" "DELETED" INTEGER +not-null+ } } define-persistent diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index 512ddc5f5b..a51c4da1b9 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -1,10 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors random math.parser locals -sequences math crypto.sha2 ; +sequences math ; IN: http.server.auth.providers -TUPLE: user username realname password email ticket profile deleted changed? ; +TUPLE: user +username realname +password salt +email ticket capabilities profile deleted changed? ; : ( username -- user ) user new @@ -17,9 +20,6 @@ GENERIC: update-user ( user provider -- ) GENERIC: new-user ( user provider -- user/f ) -: check-login ( password username provider -- user/f ) - get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; - ! Password recovery support :: issue-ticket ( email username provider -- user/f ) diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index 1dc5effbe2..e0a4037e31 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces boxes sequences strings -io io.streams.string arrays +io io.streams.string arrays locals html.elements http http.server @@ -47,7 +47,7 @@ SYMBOL: nested-template? SYMBOL: next-template : call-next-template ( -- ) - next-template get write ; + next-template get write-html ; M: f call-template* drop call-next-template ; @@ -68,9 +68,10 @@ M: f call-template* drop call-next-template ; bi* ] with-scope ; inline -M: boilerplate call-responder* - tuck call-next-method - dup "content-type" header "text/html" = [ - clone swap template>> - [ [ with-boilerplate ] 2curry ] curry change-body - ] [ nip ] if ; +M:: boilerplate call-responder* ( path responder -- ) + path responder call-next-method + dup content-type>> "text/html" = [ + clone [| body | + [ body responder template>> with-boilerplate ] + ] change-body + ] when ; diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor index cca5942328..31ea164a58 100755 --- a/extra/http/server/callbacks/callbacks-tests.factor +++ b/extra/http/server/callbacks/callbacks-tests.factor @@ -24,7 +24,7 @@ splitting kernel hashtables continuations ; [ [ "hello" print - "text/html" swap '[ , write ] >>body + '[ , write ] ] show-page "byebye" print [ 123 ] show-final diff --git a/extra/http/server/components/code/code.factor b/extra/http/server/components/code/code.factor index 90b70c7bcc..8bf07700e8 100644 --- a/extra/http/server/components/code/code.factor +++ b/extra/http/server/components/code/code.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: splitting kernel io sequences xmode.code2html accessors -http.server.components ; +http.server.components xml.entities ; IN: http.server.components.code TUPLE: code-renderer < text-renderer mode ; diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index cb109fc847..c0bac1fb99 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces kernel io math.parser assocs classes words classes.tuple arrays sequences splitting mirrors -hashtables fry combinators continuations math -calendar.format html.elements +hashtables fry locals combinators continuations math +calendar.format html.elements xml.entities http.server.validators ; IN: http.server.components @@ -18,13 +18,14 @@ TUPLE: field type ; C: field -M: field render-view* drop write ; +M: field render-view* + drop escape-string write ; M: field render-edit* - > =type [ =id ] [ =name ] bi =value input/> ; + > =type =name =value input/> ; : render-error ( message -- ) - write ; + escape-string write ; TUPLE: hidden < field ; @@ -232,7 +233,7 @@ TUPLE: text-renderer rows cols ; text-renderer new-text-renderer ; M: text-renderer render-view* - drop write ; + drop escape-string write ; M: text-renderer render-edit* ; TUPLE: text < string ; @@ -261,7 +262,7 @@ TUPLE: html-text-renderer < text-renderer ; html-text-renderer new-text-renderer ; M: html-text-renderer render-view* - drop write ; + drop escape-string write ; TUPLE: html-text < text ; @@ -286,7 +287,7 @@ GENERIC: link-href ( obj -- url ) SINGLETON: link-renderer M: link-renderer render-view* - drop link-title write ; + drop link-title escape-string write ; TUPLE: link < string ; @@ -341,15 +342,19 @@ TUPLE: choice-renderer choices ; C: choice-renderer M: choice-renderer render-view* - drop write ; + drop escape-string write ; + +: render-option ( text selected? -- ) + ; + +: render-options ( options selected -- ) + '[ dup , member? render-option ] each ; M: choice-renderer render-edit* ; TUPLE: choice < string ; @@ -357,3 +362,43 @@ TUPLE: choice < string ; : ( id choices -- component ) swap choice new-string swap >>renderer ; + +! Menu +TUPLE: menu-renderer choices size ; + +: ( choices -- renderer ) + 5 menu-renderer boa ; + +M:: menu-renderer render-edit* ( value id renderer -- ) + ; + +TUPLE: menu < string ; + +: ( id choices -- component ) + swap menu new-string + swap >>renderer ; + +! Checkboxes +TUPLE: checkbox-renderer label ; + +C: checkbox-renderer + +M: checkbox-renderer render-edit* + + label>> escape-string write + ; + +TUPLE: checkbox < string ; + +: ( id label -- component ) + checkbox swap new-component ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor index a8d320f82f..87b7170bbf 100755 --- a/extra/http/server/components/farkup/farkup.factor +++ b/extra/http/server/components/farkup/farkup.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: splitting kernel io sequences farkup accessors -http.server.components ; +http.server.components xml.entities ; IN: http.server.components.farkup TUPLE: farkup-renderer < text-renderer ; diff --git a/extra/http/server/components/inspector/inspector.factor b/extra/http/server/components/inspector/inspector.factor index 25ee631a06..42366b57e4 100644 --- a/extra/http/server/components/inspector/inspector.factor +++ b/extra/http/server/components/inspector/inspector.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: splitting kernel io sequences inspector accessors -http.server.components ; +http.server.components xml.entities html ; IN: http.server.components.inspector SINGLETON: inspector-renderer M: inspector-renderer render-view* - drop describe ; + drop [ describe ] with-html-stream ; TUPLE: inspector < component ; diff --git a/extra/http/server/db/db-tests.factor b/extra/http/server/db/db-tests.factor new file mode 100644 index 0000000000..0c34745c00 --- /dev/null +++ b/extra/http/server/db/db-tests.factor @@ -0,0 +1,4 @@ +IN: http.server.db.tests +USING: tools.test http.server.db ; + +\ must-infer diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 047af3f4ac..3d8f78fbdd 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,16 +1,17 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db http.server http.server.sessions kernel accessors -continuations namespaces destructors ; +USING: db db.pooling http.server http.server.sessions kernel +accessors continuations namespaces destructors ; IN: http.server.db -TUPLE: db-persistence < filter-responder db params ; +TUPLE: db-persistence < filter-responder pool ; -C: db-persistence - -: connect-db ( db-persistence -- ) - [ db>> ] [ params>> ] bi make-db db-open - [ db set ] [ add-always-destructor ] bi ; +: ( responder db params -- responder' ) + db-persistence boa ; M: db-persistence call-responder* - [ connect-db ] [ call-next-method ] bi ; + [ + pool>> [ acquire-connection ] keep + [ return-connection-later ] [ drop db set ] 2bi + ] + [ call-next-method ] bi ; diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor index 60f3da25b6..92fb25bb16 100644 --- a/extra/http/server/forms/forms.factor +++ b/extra/http/server/forms/forms.factor @@ -37,9 +37,7 @@ M: form init V{ } clone >>components ; ] with-form ; : ( form template -- response ) - [ components>> components set ] - [ "text/html" swap >>body ] - bi* ; + [ components>> components set ] [ ] bi* ; : view-form ( form -- response ) dup view-template>> ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index ad04812c63..f6dd6c57bb 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting -threads http sequences prettyprint io.server logging calendar -html.elements accessors math.parser combinators.lib -tools.vocabs debugger html continuations random combinators +threads sequences prettyprint io.server logging calendar +http html html.elements accessors math.parser combinators.lib +tools.vocabs debugger continuations random combinators destructors io.encodings.8-bit fry classes words ; IN: http.server @@ -22,7 +22,10 @@ GENERIC: call-responder* ( path responder -- response ) 200 >>code "Document follows" >>message - swap set-content-type ; + swap >>content-type ; + +: ( quot -- response ) + "text/html" swap >>body ; TUPLE: trivial-responder response ; @@ -38,9 +41,7 @@ M: trivial-responder call-responder* nip response>> call ; ; : ( code message -- response ) - 2dup '[ , , trivial-response-body ] - "text/html" - swap >>body + 2dup '[ , , trivial-response-body ] swap >>message swap >>code ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index b4cf0bd679..0d98bf2150 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -143,7 +143,7 @@ M: foo call-responder* ] with-destructors response set ] unit-test - [ "text/plain" ] [ response get "content-type" header ] unit-test + [ "text/plain" ] [ response get content-type>> ] unit-test [ f ] [ response get cookies>> empty? ] unit-test ] with-scope diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index af6018fbdc..2ecc347d76 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -1,41 +1,47 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: calendar html io io.files kernel math math.parser http -http.server namespaces parser sequences strings assocs -hashtables debugger http.mime sorting html.elements logging -calendar.format accessors io.encodings.binary fry ; +USING: calendar html io io.files kernel math math.order +math.parser http http.server namespaces parser sequences strings +assocs hashtables debugger http.mime sorting html.elements +logging calendar.format accessors io.encodings.binary fry ; IN: http.server.static ! special maps mime types to quots with effect ( path -- ) -TUPLE: file-responder root hook special ; +TUPLE: file-responder root hook special allow-listings ; -: file-http-date ( filename -- string ) - file-info modified>> timestamp>http-string ; - -: last-modified-matches? ( filename -- ? ) - file-http-date dup [ - request get "if-modified-since" header = - ] when ; +: modified-since? ( filename -- ? ) + request get "if-modified-since" header dup [ + [ file-info modified>> ] [ rfc822>timestamp ] bi* after? + ] [ + 2drop t + ] if ; : <304> ( -- response ) 304 "Not modified" ; +: <403> ( -- response ) + 403 "Forbidden" ; + : ( root hook -- responder ) - H{ } clone file-responder boa ; + file-responder new + swap >>hook + swap >>root + H{ } clone >>special ; : ( root -- responder ) [ - swap - [ file-info size>> "content-length" set-header ] - [ file-http-date "last-modified" set-header ] - [ '[ , binary stdio get stream-copy ] >>body ] - tri + swap [ + file-info + [ size>> "content-length" set-header ] + [ modified>> "last-modified" set-header ] bi + ] + [ '[ , binary stdio get stream-copy ] >>body ] bi ] ; : serve-static ( filename mime-type -- response ) - over last-modified-matches? - [ 2drop <304> ] [ file-responder get hook>> call ] if ; + over modified-since? + [ file-responder get hook>> call ] [ 2drop <304> ] if ; : serving-path ( filename -- filename ) file-responder get root>> right-trim-separators @@ -65,8 +71,11 @@ TUPLE: file-responder root hook special ; ] simple-html-document ; : list-directory ( directory -- response ) - "text/html" - swap '[ , directory. ] >>body ; + file-responder get allow-listings>> [ + '[ , directory. ] + ] [ + drop <403> + ] if ; : find-index ( filename -- path ) "index.html" append-path dup exists? [ drop f ] unless ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 610ec78fed..73f6095eae 100644 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -24,5 +24,4 @@ M: template write-response-body* call-template ; ! responder integration : serve-template ( template -- response ) - "text/html" - swap '[ , call-template ] >>body ; + '[ , call-template ] ; diff --git a/extra/io/encodings/iana/authors.txt b/extra/io/encodings/iana/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/io/encodings/iana/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/io/encodings/iana/character-sets b/extra/io/encodings/iana/character-sets new file mode 100644 index 0000000000..253c471544 --- /dev/null +++ b/extra/io/encodings/iana/character-sets @@ -0,0 +1,1697 @@ +Name: ANSI_X3.4-1968 [RFC1345,KXS2] +MIBenum: 3 +Source: ECMA registry +Alias: iso-ir-6 +Alias: ANSI_X3.4-1986 +Alias: ISO_646.irv:1991 +Alias: ASCII +Alias: ISO646-US +Alias: US-ASCII (preferred MIME name) +Alias: us +Alias: IBM367 +Alias: cp367 +Alias: csASCII + +Name: ISO_8859-1:1987 [RFC1345,KXS2] +MIBenum: 4 +Source: ECMA registry +Alias: iso-ir-100 +Alias: ISO_8859-1 +Alias: ISO-8859-1 (preferred MIME name) +Alias: latin1 +Alias: l1 +Alias: IBM819 +Alias: CP819 +Alias: csISOLatin1 + +Name: ISO_8859-2:1987 [RFC1345,KXS2] +MIBenum: 5 +Source: ECMA registry +Alias: iso-ir-101 +Alias: ISO_8859-2 +Alias: ISO-8859-2 (preferred MIME name) +Alias: latin2 +Alias: l2 +Alias: csISOLatin2 + +Name: ISO_8859-3:1988 [RFC1345,KXS2] +MIBenum: 6 +Source: ECMA registry +Alias: iso-ir-109 +Alias: ISO_8859-3 +Alias: ISO-8859-3 (preferred MIME name) +Alias: latin3 +Alias: l3 +Alias: csISOLatin3 + +Name: ISO_8859-4:1988 [RFC1345,KXS2] +MIBenum: 7 +Source: ECMA registry +Alias: iso-ir-110 +Alias: ISO_8859-4 +Alias: ISO-8859-4 (preferred MIME name) +Alias: latin4 +Alias: l4 +Alias: csISOLatin4 + +Name: ISO_8859-5:1988 [RFC1345,KXS2] +MIBenum: 8 +Source: ECMA registry +Alias: iso-ir-144 +Alias: ISO_8859-5 +Alias: ISO-8859-5 (preferred MIME name) +Alias: cyrillic +Alias: csISOLatinCyrillic + +Name: ISO_8859-6:1987 [RFC1345,KXS2] +MIBenum: 9 +Source: ECMA registry +Alias: iso-ir-127 +Alias: ISO_8859-6 +Alias: ISO-8859-6 (preferred MIME name) +Alias: ECMA-114 +Alias: ASMO-708 +Alias: arabic +Alias: csISOLatinArabic + +Name: ISO_8859-7:1987 [RFC1947,RFC1345,KXS2] +MIBenum: 10 +Source: ECMA registry +Alias: iso-ir-126 +Alias: ISO_8859-7 +Alias: ISO-8859-7 (preferred MIME name) +Alias: ELOT_928 +Alias: ECMA-118 +Alias: greek +Alias: greek8 +Alias: csISOLatinGreek + +Name: ISO_8859-8:1988 [RFC1345,KXS2] +MIBenum: 11 +Source: ECMA registry +Alias: iso-ir-138 +Alias: ISO_8859-8 +Alias: ISO-8859-8 (preferred MIME name) +Alias: hebrew +Alias: csISOLatinHebrew + +Name: ISO_8859-9:1989 [RFC1345,KXS2] +MIBenum: 12 +Source: ECMA registry +Alias: iso-ir-148 +Alias: ISO_8859-9 +Alias: ISO-8859-9 (preferred MIME name) +Alias: latin5 +Alias: l5 +Alias: csISOLatin5 + +Name: ISO-8859-10 (preferred MIME name) [RFC1345,KXS2] +MIBenum: 13 +Source: ECMA registry +Alias: iso-ir-157 +Alias: l6 +Alias: ISO_8859-10:1992 +Alias: csISOLatin6 +Alias: latin6 + +Name: ISO_6937-2-add [RFC1345,KXS2] +MIBenum: 14 +Source: ECMA registry and ISO 6937-2:1983 +Alias: iso-ir-142 +Alias: csISOTextComm + +Name: JIS_X0201 [RFC1345,KXS2] +MIBenum: 15 +Source: JIS X 0201-1976. One byte only, this is equivalent to + JIS/Roman (similar to ASCII) plus eight-bit half-width + Katakana +Alias: X0201 +Alias: csHalfWidthKatakana + +Name: JIS_Encoding +MIBenum: 16 +Source: JIS X 0202-1991. Uses ISO 2022 escape sequences to + shift code sets as documented in JIS X 0202-1991. +Alias: csJISEncoding + +Name: Shift_JIS (preferred MIME name) +MIBenum: 17 +Source: This charset is an extension of csHalfWidthKatakana by + adding graphic characters in JIS X 0208. The CCS's are + JIS X0201:1997 and JIS X0208:1997. The + complete definition is shown in Appendix 1 of JIS + X0208:1997. + This charset can be used for the top-level media type "text". +Alias: MS_Kanji +Alias: csShiftJIS + +Name: Extended_UNIX_Code_Packed_Format_for_Japanese +MIBenum: 18 +Source: Standardized by OSF, UNIX International, and UNIX Systems + Laboratories Pacific. Uses ISO 2022 rules to select + code set 0: US-ASCII (a single 7-bit byte set) + code set 1: JIS X0208-1990 (a double 8-bit byte set) + restricted to A0-FF in both bytes + code set 2: Half Width Katakana (a single 7-bit byte set) + requiring SS2 as the character prefix + code set 3: JIS X0212-1990 (a double 7-bit byte set) + restricted to A0-FF in both bytes + requiring SS3 as the character prefix +Alias: csEUCPkdFmtJapanese +Alias: EUC-JP (preferred MIME name) + +Name: Extended_UNIX_Code_Fixed_Width_for_Japanese +MIBenum: 19 +Source: Used in Japan. Each character is 2 octets. + code set 0: US-ASCII (a single 7-bit byte set) + 1st byte = 00 + 2nd byte = 20-7E + code set 1: JIS X0208-1990 (a double 7-bit byte set) + restricted to A0-FF in both bytes + code set 2: Half Width Katakana (a single 7-bit byte set) + 1st byte = 00 + 2nd byte = A0-FF + code set 3: JIS X0212-1990 (a double 7-bit byte set) + restricted to A0-FF in + the first byte + and 21-7E in the second byte +Alias: csEUCFixWidJapanese + +Name: BS_4730 [RFC1345,KXS2] +MIBenum: 20 +Source: ECMA registry +Alias: iso-ir-4 +Alias: ISO646-GB +Alias: gb +Alias: uk +Alias: csISO4UnitedKingdom + +Name: SEN_850200_C [RFC1345,KXS2] +MIBenum: 21 +Source: ECMA registry +Alias: iso-ir-11 +Alias: ISO646-SE2 +Alias: se2 +Alias: csISO11SwedishForNames + +Name: IT [RFC1345,KXS2] +MIBenum: 22 +Source: ECMA registry +Alias: iso-ir-15 +Alias: ISO646-IT +Alias: csISO15Italian + +Name: ES [RFC1345,KXS2] +MIBenum: 23 +Source: ECMA registry +Alias: iso-ir-17 +Alias: ISO646-ES +Alias: csISO17Spanish + +Name: DIN_66003 [RFC1345,KXS2] +MIBenum: 24 +Source: ECMA registry +Alias: iso-ir-21 +Alias: de +Alias: ISO646-DE +Alias: csISO21German + +Name: NS_4551-1 [RFC1345,KXS2] +MIBenum: 25 +Source: ECMA registry +Alias: iso-ir-60 +Alias: ISO646-NO +Alias: no +Alias: csISO60DanishNorwegian +Alias: csISO60Norwegian1 + +Name: NF_Z_62-010 [RFC1345,KXS2] +MIBenum: 26 +Source: ECMA registry +Alias: iso-ir-69 +Alias: ISO646-FR +Alias: fr +Alias: csISO69French + +Name: ISO-10646-UTF-1 +MIBenum: 27 +Source: Universal Transfer Format (1), this is the multibyte + encoding, that subsets ASCII-7. It does not have byte + ordering issues. +Alias: csISO10646UTF1 + +Name: ISO_646.basic:1983 [RFC1345,KXS2] +MIBenum: 28 +Source: ECMA registry +Alias: ref +Alias: csISO646basic1983 + +Name: INVARIANT [RFC1345,KXS2] +MIBenum: 29 +Alias: csINVARIANT + +Name: ISO_646.irv:1983 [RFC1345,KXS2] +MIBenum: 30 +Source: ECMA registry +Alias: iso-ir-2 +Alias: irv +Alias: csISO2IntlRefVersion + +Name: NATS-SEFI [RFC1345,KXS2] +MIBenum: 31 +Source: ECMA registry +Alias: iso-ir-8-1 +Alias: csNATSSEFI + +Name: NATS-SEFI-ADD [RFC1345,KXS2] +MIBenum: 32 +Source: ECMA registry +Alias: iso-ir-8-2 +Alias: csNATSSEFIADD + +Name: NATS-DANO [RFC1345,KXS2] +MIBenum: 33 +Source: ECMA registry +Alias: iso-ir-9-1 +Alias: csNATSDANO + +Name: NATS-DANO-ADD [RFC1345,KXS2] +MIBenum: 34 +Source: ECMA registry +Alias: iso-ir-9-2 +Alias: csNATSDANOADD + +Name: SEN_850200_B [RFC1345,KXS2] +MIBenum: 35 +Source: ECMA registry +Alias: iso-ir-10 +Alias: FI +Alias: ISO646-FI +Alias: ISO646-SE +Alias: se +Alias: csISO10Swedish + +Name: KS_C_5601-1987 [RFC1345,KXS2] +MIBenum: 36 +Source: ECMA registry +Alias: iso-ir-149 +Alias: KS_C_5601-1989 +Alias: KSC_5601 +Alias: korean +Alias: csKSC56011987 + +Name: ISO-2022-KR (preferred MIME name) [RFC1557,Choi] +MIBenum: 37 +Source: RFC-1557 (see also KS_C_5601-1987) +Alias: csISO2022KR + +Name: EUC-KR (preferred MIME name) [RFC1557,Choi] +MIBenum: 38 +Source: RFC-1557 (see also KS_C_5861-1992) +Alias: csEUCKR + +Name: ISO-2022-JP (preferred MIME name) [RFC1468,Murai] +MIBenum: 39 +Source: RFC-1468 (see also RFC-2237) +Alias: csISO2022JP + +Name: ISO-2022-JP-2 (preferred MIME name) [RFC1554,Ohta] +MIBenum: 40 +Source: RFC-1554 +Alias: csISO2022JP2 + +Name: JIS_C6220-1969-jp [RFC1345,KXS2] +MIBenum: 41 +Source: ECMA registry +Alias: JIS_C6220-1969 +Alias: iso-ir-13 +Alias: katakana +Alias: x0201-7 +Alias: csISO13JISC6220jp + +Name: JIS_C6220-1969-ro [RFC1345,KXS2] +MIBenum: 42 +Source: ECMA registry +Alias: iso-ir-14 +Alias: jp +Alias: ISO646-JP +Alias: csISO14JISC6220ro + +Name: PT [RFC1345,KXS2] +MIBenum: 43 +Source: ECMA registry +Alias: iso-ir-16 +Alias: ISO646-PT +Alias: csISO16Portuguese + +Name: greek7-old [RFC1345,KXS2] +MIBenum: 44 +Source: ECMA registry +Alias: iso-ir-18 +Alias: csISO18Greek7Old + +Name: latin-greek [RFC1345,KXS2] +MIBenum: 45 +Source: ECMA registry +Alias: iso-ir-19 +Alias: csISO19LatinGreek + +Name: NF_Z_62-010_(1973) [RFC1345,KXS2] +MIBenum: 46 +Source: ECMA registry +Alias: iso-ir-25 +Alias: ISO646-FR1 +Alias: csISO25French + +Name: Latin-greek-1 [RFC1345,KXS2] +MIBenum: 47 +Source: ECMA registry +Alias: iso-ir-27 +Alias: csISO27LatinGreek1 + +Name: ISO_5427 [RFC1345,KXS2] +MIBenum: 48 +Source: ECMA registry +Alias: iso-ir-37 +Alias: csISO5427Cyrillic + +Name: JIS_C6226-1978 [RFC1345,KXS2] +MIBenum: 49 +Source: ECMA registry +Alias: iso-ir-42 +Alias: csISO42JISC62261978 + +Name: BS_viewdata [RFC1345,KXS2] +MIBenum: 50 +Source: ECMA registry +Alias: iso-ir-47 +Alias: csISO47BSViewdata + +Name: INIS [RFC1345,KXS2] +MIBenum: 51 +Source: ECMA registry +Alias: iso-ir-49 +Alias: csISO49INIS + +Name: INIS-8 [RFC1345,KXS2] +MIBenum: 52 +Source: ECMA registry +Alias: iso-ir-50 +Alias: csISO50INIS8 + +Name: INIS-cyrillic [RFC1345,KXS2] +MIBenum: 53 +Source: ECMA registry +Alias: iso-ir-51 +Alias: csISO51INISCyrillic + +Name: ISO_5427:1981 [RFC1345,KXS2] +MIBenum: 54 +Source: ECMA registry +Alias: iso-ir-54 +Alias: ISO5427Cyrillic1981 + +Name: ISO_5428:1980 [RFC1345,KXS2] +MIBenum: 55 +Source: ECMA registry +Alias: iso-ir-55 +Alias: csISO5428Greek + +Name: GB_1988-80 [RFC1345,KXS2] +MIBenum: 56 +Source: ECMA registry +Alias: iso-ir-57 +Alias: cn +Alias: ISO646-CN +Alias: csISO57GB1988 + +Name: GB_2312-80 [RFC1345,KXS2] +MIBenum: 57 +Source: ECMA registry +Alias: iso-ir-58 +Alias: chinese +Alias: csISO58GB231280 + +Name: NS_4551-2 [RFC1345,KXS2] +MIBenum: 58 +Source: ECMA registry +Alias: ISO646-NO2 +Alias: iso-ir-61 +Alias: no2 +Alias: csISO61Norwegian2 + +Name: videotex-suppl [RFC1345,KXS2] +MIBenum: 59 +Source: ECMA registry +Alias: iso-ir-70 +Alias: csISO70VideotexSupp1 + +Name: PT2 [RFC1345,KXS2] +MIBenum: 60 +Source: ECMA registry +Alias: iso-ir-84 +Alias: ISO646-PT2 +Alias: csISO84Portuguese2 + +Name: ES2 [RFC1345,KXS2] +MIBenum: 61 +Source: ECMA registry +Alias: iso-ir-85 +Alias: ISO646-ES2 +Alias: csISO85Spanish2 + +Name: MSZ_7795.3 [RFC1345,KXS2] +MIBenum: 62 +Source: ECMA registry +Alias: iso-ir-86 +Alias: ISO646-HU +Alias: hu +Alias: csISO86Hungarian + +Name: JIS_C6226-1983 [RFC1345,KXS2] +MIBenum: 63 +Source: ECMA registry +Alias: iso-ir-87 +Alias: x0208 +Alias: JIS_X0208-1983 +Alias: csISO87JISX0208 + +Name: greek7 [RFC1345,KXS2] +MIBenum: 64 +Source: ECMA registry +Alias: iso-ir-88 +Alias: csISO88Greek7 + +Name: ASMO_449 [RFC1345,KXS2] +MIBenum: 65 +Source: ECMA registry +Alias: ISO_9036 +Alias: arabic7 +Alias: iso-ir-89 +Alias: csISO89ASMO449 + +Name: iso-ir-90 [RFC1345,KXS2] +MIBenum: 66 +Source: ECMA registry +Alias: csISO90 + +Name: JIS_C6229-1984-a [RFC1345,KXS2] +MIBenum: 67 +Source: ECMA registry +Alias: iso-ir-91 +Alias: jp-ocr-a +Alias: csISO91JISC62291984a + +Name: JIS_C6229-1984-b [RFC1345,KXS2] +MIBenum: 68 +Source: ECMA registry +Alias: iso-ir-92 +Alias: ISO646-JP-OCR-B +Alias: jp-ocr-b +Alias: csISO92JISC62991984b + +Name: JIS_C6229-1984-b-add [RFC1345,KXS2] +MIBenum: 69 +Source: ECMA registry +Alias: iso-ir-93 +Alias: jp-ocr-b-add +Alias: csISO93JIS62291984badd + +Name: JIS_C6229-1984-hand [RFC1345,KXS2] +MIBenum: 70 +Source: ECMA registry +Alias: iso-ir-94 +Alias: jp-ocr-hand +Alias: csISO94JIS62291984hand + +Name: JIS_C6229-1984-hand-add [RFC1345,KXS2] +MIBenum: 71 +Source: ECMA registry +Alias: iso-ir-95 +Alias: jp-ocr-hand-add +Alias: csISO95JIS62291984handadd + +Name: JIS_C6229-1984-kana [RFC1345,KXS2] +MIBenum: 72 +Source: ECMA registry +Alias: iso-ir-96 +Alias: csISO96JISC62291984kana + +Name: ISO_2033-1983 [RFC1345,KXS2] +MIBenum: 73 +Source: ECMA registry +Alias: iso-ir-98 +Alias: e13b +Alias: csISO2033 + +Name: ANSI_X3.110-1983 [RFC1345,KXS2] +MIBenum: 74 +Source: ECMA registry +Alias: iso-ir-99 +Alias: CSA_T500-1983 +Alias: NAPLPS +Alias: csISO99NAPLPS + +Name: T.61-7bit [RFC1345,KXS2] +MIBenum: 75 +Source: ECMA registry +Alias: iso-ir-102 +Alias: csISO102T617bit + +Name: T.61-8bit [RFC1345,KXS2] +MIBenum: 76 +Alias: T.61 +Source: ECMA registry +Alias: iso-ir-103 +Alias: csISO103T618bit + +Name: ECMA-cyrillic +MIBenum: 77 +Source: ISO registry (formerly ECMA registry) + http://www.itscj.ipsj.jp/ISO-IR/111.pdf +Alias: iso-ir-111 +Alias: KOI8-E +Alias: csISO111ECMACyrillic + +Name: CSA_Z243.4-1985-1 [RFC1345,KXS2] +MIBenum: 78 +Source: ECMA registry +Alias: iso-ir-121 +Alias: ISO646-CA +Alias: csa7-1 +Alias: ca +Alias: csISO121Canadian1 + +Name: CSA_Z243.4-1985-2 [RFC1345,KXS2] +MIBenum: 79 +Source: ECMA registry +Alias: iso-ir-122 +Alias: ISO646-CA2 +Alias: csa7-2 +Alias: csISO122Canadian2 + +Name: CSA_Z243.4-1985-gr [RFC1345,KXS2] +MIBenum: 80 +Source: ECMA registry +Alias: iso-ir-123 +Alias: csISO123CSAZ24341985gr + +Name: ISO_8859-6-E [RFC1556,IANA] +MIBenum: 81 +Source: RFC1556 +Alias: csISO88596E +Alias: ISO-8859-6-E (preferred MIME name) + +Name: ISO_8859-6-I [RFC1556,IANA] +MIBenum: 82 +Source: RFC1556 +Alias: csISO88596I +Alias: ISO-8859-6-I (preferred MIME name) + +Name: T.101-G2 [RFC1345,KXS2] +MIBenum: 83 +Source: ECMA registry +Alias: iso-ir-128 +Alias: csISO128T101G2 + +Name: ISO_8859-8-E [RFC1556,Nussbacher] +MIBenum: 84 +Source: RFC1556 +Alias: csISO88598E +Alias: ISO-8859-8-E (preferred MIME name) + +Name: ISO_8859-8-I [RFC1556,Nussbacher] +MIBenum: 85 +Source: RFC1556 +Alias: csISO88598I +Alias: ISO-8859-8-I (preferred MIME name) + +Name: CSN_369103 [RFC1345,KXS2] +MIBenum: 86 +Source: ECMA registry +Alias: iso-ir-139 +Alias: csISO139CSN369103 + +Name: JUS_I.B1.002 [RFC1345,KXS2] +MIBenum: 87 +Source: ECMA registry +Alias: iso-ir-141 +Alias: ISO646-YU +Alias: js +Alias: yu +Alias: csISO141JUSIB1002 + +Name: IEC_P27-1 [RFC1345,KXS2] +MIBenum: 88 +Source: ECMA registry +Alias: iso-ir-143 +Alias: csISO143IECP271 + +Name: JUS_I.B1.003-serb [RFC1345,KXS2] +MIBenum: 89 +Source: ECMA registry +Alias: iso-ir-146 +Alias: serbian +Alias: csISO146Serbian + +Name: JUS_I.B1.003-mac [RFC1345,KXS2] +MIBenum: 90 +Source: ECMA registry +Alias: macedonian +Alias: iso-ir-147 +Alias: csISO147Macedonian + +Name: greek-ccitt [RFC1345,KXS2] +MIBenum: 91 +Source: ECMA registry +Alias: iso-ir-150 +Alias: csISO150 +Alias: csISO150GreekCCITT + +Name: NC_NC00-10:81 [RFC1345,KXS2] +MIBenum: 92 +Source: ECMA registry +Alias: cuba +Alias: iso-ir-151 +Alias: ISO646-CU +Alias: csISO151Cuba + +Name: ISO_6937-2-25 [RFC1345,KXS2] +MIBenum: 93 +Source: ECMA registry +Alias: iso-ir-152 +Alias: csISO6937Add + +Name: GOST_19768-74 [RFC1345,KXS2] +MIBenum: 94 +Source: ECMA registry +Alias: ST_SEV_358-88 +Alias: iso-ir-153 +Alias: csISO153GOST1976874 + +Name: ISO_8859-supp [RFC1345,KXS2] +MIBenum: 95 +Source: ECMA registry +Alias: iso-ir-154 +Alias: latin1-2-5 +Alias: csISO8859Supp + +Name: ISO_10367-box [RFC1345,KXS2] +MIBenum: 96 +Source: ECMA registry +Alias: iso-ir-155 +Alias: csISO10367Box + +Name: latin-lap [RFC1345,KXS2] +MIBenum: 97 +Source: ECMA registry +Alias: lap +Alias: iso-ir-158 +Alias: csISO158Lap + +Name: JIS_X0212-1990 [RFC1345,KXS2] +MIBenum: 98 +Source: ECMA registry +Alias: x0212 +Alias: iso-ir-159 +Alias: csISO159JISX02121990 + +Name: DS_2089 [RFC1345,KXS2] +MIBenum: 99 +Source: Danish Standard, DS 2089, February 1974 +Alias: DS2089 +Alias: ISO646-DK +Alias: dk +Alias: csISO646Danish + +Name: us-dk [RFC1345,KXS2] +MIBenum: 100 +Alias: csUSDK + +Name: dk-us [RFC1345,KXS2] +MIBenum: 101 +Alias: csDKUS + +Name: KSC5636 [RFC1345,KXS2] +MIBenum: 102 +Alias: ISO646-KR +Alias: csKSC5636 + +Name: UNICODE-1-1-UTF-7 [RFC1642] +MIBenum: 103 +Source: RFC 1642 +Alias: csUnicode11UTF7 + +Name: ISO-2022-CN [RFC1922] +MIBenum: 104 +Source: RFC-1922 + +Name: ISO-2022-CN-EXT [RFC1922] +MIBenum: 105 +Source: RFC-1922 + +Name: UTF-8 [RFC3629] +MIBenum: 106 +Source: RFC 3629 +Alias: None + +Name: ISO-8859-13 +MIBenum: 109 +Source: ISO See (http://www.iana.org/assignments/charset-reg/ISO-8859-13)[Tumasonis] +Alias: None + +Name: ISO-8859-14 +MIBenum: 110 +Source: ISO See (http://www.iana.org/assignments/charset-reg/ISO-8859-14) [Simonsen] +Alias: iso-ir-199 +Alias: ISO_8859-14:1998 +Alias: ISO_8859-14 +Alias: latin8 +Alias: iso-celtic +Alias: l8 + +Name: ISO-8859-15 +MIBenum: 111 +Source: ISO + Please see: +Alias: ISO_8859-15 +Alias: Latin-9 + +Name: ISO-8859-16 +MIBenum: 112 +Source: ISO +Alias: iso-ir-226 +Alias: ISO_8859-16:2001 +Alias: ISO_8859-16 +Alias: latin10 +Alias: l10 + +Name: GBK +MIBenum: 113 +Source: Chinese IT Standardization Technical Committee + Please see: +Alias: CP936 +Alias: MS936 +Alias: windows-936 + +Name: GB18030 +MIBenum: 114 +Source: Chinese IT Standardization Technical Committee + Please see: +Alias: None + +Name: OSD_EBCDIC_DF04_15 +MIBenum: 115 +Source: Fujitsu-Siemens standard mainframe EBCDIC encoding + Please see: +Alias: None + +Name: OSD_EBCDIC_DF03_IRV +MIBenum: 116 +Source: Fujitsu-Siemens standard mainframe EBCDIC encoding + Please see: +Alias: None + +Name: OSD_EBCDIC_DF04_1 +MIBenum: 117 +Source: Fujitsu-Siemens standard mainframe EBCDIC encoding + Please see: +Alias: None + +Name: ISO-11548-1 +MIBenum: 118 +Source: See [Thibault] +Alias: ISO_11548-1 +Alias: ISO_TR_11548-1 +Alias: csISO115481 + +Name: KZ-1048 +MIBenum: 119 +Source: See [Veremeev, Kikkarin] +Alias: STRK1048-2002 +Alias: RK1048 +Alias: csKZ1048 + +Name: ISO-10646-UCS-2 +MIBenum: 1000 +Source: the 2-octet Basic Multilingual Plane, aka Unicode + this needs to specify network byte order: the standard + does not specify (it is a 16-bit integer space) +Alias: csUnicode + +Name: ISO-10646-UCS-4 +MIBenum: 1001 +Source: the full code space. (same comment about byte order, + these are 31-bit numbers. +Alias: csUCS4 + +Name: ISO-10646-UCS-Basic +MIBenum: 1002 +Source: ASCII subset of Unicode. Basic Latin = collection 1 + See ISO 10646, Appendix A +Alias: csUnicodeASCII + +Name: ISO-10646-Unicode-Latin1 +MIBenum: 1003 +Source: ISO Latin-1 subset of Unicode. Basic Latin and Latin-1 + Supplement = collections 1 and 2. See ISO 10646, + Appendix A. See RFC 1815. +Alias: csUnicodeLatin1 +Alias: ISO-10646 + +Name: ISO-10646-J-1 +Source: ISO 10646 Japanese, see RFC 1815. + +Name: ISO-Unicode-IBM-1261 +MIBenum: 1005 +Source: IBM Latin-2, -3, -5, Extended Presentation Set, GCSGID: 1261 +Alias: csUnicodeIBM1261 + +Name: ISO-Unicode-IBM-1268 +MIBenum: 1006 +Source: IBM Latin-4 Extended Presentation Set, GCSGID: 1268 +Alias: csUnicodeIBM1268 + +Name: ISO-Unicode-IBM-1276 +MIBenum: 1007 +Source: IBM Cyrillic Greek Extended Presentation Set, GCSGID: 1276 +Alias: csUnicodeIBM1276 + +Name: ISO-Unicode-IBM-1264 +MIBenum: 1008 +Source: IBM Arabic Presentation Set, GCSGID: 1264 +Alias: csUnicodeIBM1264 + +Name: ISO-Unicode-IBM-1265 +MIBenum: 1009 +Source: IBM Hebrew Presentation Set, GCSGID: 1265 +Alias: csUnicodeIBM1265 + +Name: UNICODE-1-1 [RFC1641] +MIBenum: 1010 +Source: RFC 1641 +Alias: csUnicode11 + +Name: SCSU +MIBenum: 1011 +Source: SCSU See (http://www.iana.org/assignments/charset-reg/SCSU) [Scherer] +Alias: None + +Name: UTF-7 [RFC2152] +MIBenum: 1012 +Source: RFC 2152 +Alias: None + +Name: UTF-16BE [RFC2781] +MIBenum: 1013 +Source: RFC 2781 +Alias: None + +Name: UTF-16LE [RFC2781] +MIBenum: 1014 +Source: RFC 2781 +Alias: None + +Name: UTF-16 [RFC2781] +MIBenum: 1015 +Source: RFC 2781 +Alias: None + +Name: CESU-8 [Phipps] +MIBenum: 1016 +Source: +Alias: csCESU-8 + +Name: UTF-32 [Davis] +MIBenum: 1017 +Source: +Alias: None + +Name: UTF-32BE [Davis] +MIBenum: 1018 +Source: +Alias: None + +Name: UTF-32LE [Davis] +MIBenum: 1019 +Source: +Alias: None + +Name: BOCU-1 [Scherer] +MIBenum: 1020 +Source: http://www.unicode.org/notes/tn6/ +Alias: csBOCU-1 + +Name: ISO-8859-1-Windows-3.0-Latin-1 [HP-PCL5] +MIBenum: 2000 +Source: Extended ISO 8859-1 Latin-1 for Windows 3.0. + PCL Symbol Set id: 9U +Alias: csWindows30Latin1 + +Name: ISO-8859-1-Windows-3.1-Latin-1 [HP-PCL5] +MIBenum: 2001 +Source: Extended ISO 8859-1 Latin-1 for Windows 3.1. + PCL Symbol Set id: 19U +Alias: csWindows31Latin1 + +Name: ISO-8859-2-Windows-Latin-2 [HP-PCL5] +MIBenum: 2002 +Source: Extended ISO 8859-2. Latin-2 for Windows 3.1. + PCL Symbol Set id: 9E +Alias: csWindows31Latin2 + +Name: ISO-8859-9-Windows-Latin-5 [HP-PCL5] +MIBenum: 2003 +Source: Extended ISO 8859-9. Latin-5 for Windows 3.1 + PCL Symbol Set id: 5T +Alias: csWindows31Latin5 + +Name: hp-roman8 [HP-PCL5,RFC1345,KXS2] +MIBenum: 2004 +Source: LaserJet IIP Printer User's Manual, + HP part no 33471-90901, Hewlet-Packard, June 1989. +Alias: roman8 +Alias: r8 +Alias: csHPRoman8 + +Name: Adobe-Standard-Encoding [Adobe] +MIBenum: 2005 +Source: PostScript Language Reference Manual + PCL Symbol Set id: 10J +Alias: csAdobeStandardEncoding + +Name: Ventura-US [HP-PCL5] +MIBenum: 2006 +Source: Ventura US. ASCII plus characters typically used in + publishing, like pilcrow, copyright, registered, trade mark, + section, dagger, and double dagger in the range A0 (hex) + to FF (hex). + PCL Symbol Set id: 14J +Alias: csVenturaUS + +Name: Ventura-International [HP-PCL5] +MIBenum: 2007 +Source: Ventura International. ASCII plus coded characters similar + to Roman8. + PCL Symbol Set id: 13J +Alias: csVenturaInternational + +Name: DEC-MCS [RFC1345,KXS2] +MIBenum: 2008 +Source: VAX/VMS User's Manual, + Order Number: AI-Y517A-TE, April 1986. +Alias: dec +Alias: csDECMCS + +Name: IBM850 [RFC1345,KXS2] +MIBenum: 2009 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp850 +Alias: 850 +Alias: csPC850Multilingual + +Name: PC8-Danish-Norwegian [HP-PCL5] +MIBenum: 2012 +Source: PC Danish Norwegian + 8-bit PC set for Danish Norwegian + PCL Symbol Set id: 11U +Alias: csPC8DanishNorwegian + +Name: IBM862 [RFC1345,KXS2] +MIBenum: 2013 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp862 +Alias: 862 +Alias: csPC862LatinHebrew + +Name: PC8-Turkish [HP-PCL5] +MIBenum: 2014 +Source: PC Latin Turkish. PCL Symbol Set id: 9T +Alias: csPC8Turkish + +Name: IBM-Symbols [IBM-CIDT] +MIBenum: 2015 +Source: Presentation Set, CPGID: 259 +Alias: csIBMSymbols + +Name: IBM-Thai [IBM-CIDT] +MIBenum: 2016 +Source: Presentation Set, CPGID: 838 +Alias: csIBMThai + +Name: HP-Legal [HP-PCL5] +MIBenum: 2017 +Source: PCL 5 Comparison Guide, Hewlett-Packard, + HP part number 5961-0510, October 1992 + PCL Symbol Set id: 1U +Alias: csHPLegal + +Name: HP-Pi-font [HP-PCL5] +MIBenum: 2018 +Source: PCL 5 Comparison Guide, Hewlett-Packard, + HP part number 5961-0510, October 1992 + PCL Symbol Set id: 15U +Alias: csHPPiFont + +Name: HP-Math8 [HP-PCL5] +MIBenum: 2019 +Source: PCL 5 Comparison Guide, Hewlett-Packard, + HP part number 5961-0510, October 1992 + PCL Symbol Set id: 8M +Alias: csHPMath8 + +Name: Adobe-Symbol-Encoding [Adobe] +MIBenum: 2020 +Source: PostScript Language Reference Manual + PCL Symbol Set id: 5M +Alias: csHPPSMath + +Name: HP-DeskTop [HP-PCL5] +MIBenum: 2021 +Source: PCL 5 Comparison Guide, Hewlett-Packard, + HP part number 5961-0510, October 1992 + PCL Symbol Set id: 7J +Alias: csHPDesktop + +Name: Ventura-Math [HP-PCL5] +MIBenum: 2022 +Source: PCL 5 Comparison Guide, Hewlett-Packard, + HP part number 5961-0510, October 1992 + PCL Symbol Set id: 6M +Alias: csVenturaMath + +Name: Microsoft-Publishing [HP-PCL5] +MIBenum: 2023 +Source: PCL 5 Comparison Guide, Hewlett-Packard, + HP part number 5961-0510, October 1992 + PCL Symbol Set id: 6J +Alias: csMicrosoftPublishing + +Name: Windows-31J +MIBenum: 2024 +Source: Windows Japanese. A further extension of Shift_JIS + to include NEC special characters (Row 13), NEC + selection of IBM extensions (Rows 89 to 92), and IBM + extensions (Rows 115 to 119). The CCS's are + JIS X0201:1997, JIS X0208:1997, and these extensions. + This charset can be used for the top-level media type "text", + but it is of limited or specialized use (see RFC2278). + PCL Symbol Set id: 19K +Alias: csWindows31J + +Name: GB2312 (preferred MIME name) +MIBenum: 2025 +Source: Chinese for People's Republic of China (PRC) mixed one byte, + two byte set: + 20-7E = one byte ASCII + A1-FE = two byte PRC Kanji + See GB 2312-80 + PCL Symbol Set Id: 18C +Alias: csGB2312 + +Name: Big5 (preferred MIME name) +MIBenum: 2026 +Source: Chinese for Taiwan Multi-byte set. + PCL Symbol Set Id: 18T +Alias: csBig5 + +Name: macintosh [RFC1345,KXS2] +MIBenum: 2027 +Source: The Unicode Standard ver1.0, ISBN 0-201-56788-1, Oct 1991 +Alias: mac +Alias: csMacintosh + +Name: IBM037 [RFC1345,KXS2] +MIBenum: 2028 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp037 +Alias: ebcdic-cp-us +Alias: ebcdic-cp-ca +Alias: ebcdic-cp-wt +Alias: ebcdic-cp-nl +Alias: csIBM037 + +Name: IBM038 [RFC1345,KXS2] +MIBenum: 2029 +Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990 +Alias: EBCDIC-INT +Alias: cp038 +Alias: csIBM038 + +Name: IBM273 [RFC1345,KXS2] +MIBenum: 2030 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP273 +Alias: csIBM273 + +Name: IBM274 [RFC1345,KXS2] +MIBenum: 2031 +Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990 +Alias: EBCDIC-BE +Alias: CP274 +Alias: csIBM274 + +Name: IBM275 [RFC1345,KXS2] +MIBenum: 2032 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: EBCDIC-BR +Alias: cp275 +Alias: csIBM275 + +Name: IBM277 [RFC1345,KXS2] +MIBenum: 2033 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: EBCDIC-CP-DK +Alias: EBCDIC-CP-NO +Alias: csIBM277 + +Name: IBM278 [RFC1345,KXS2] +MIBenum: 2034 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP278 +Alias: ebcdic-cp-fi +Alias: ebcdic-cp-se +Alias: csIBM278 + +Name: IBM280 [RFC1345,KXS2] +MIBenum: 2035 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP280 +Alias: ebcdic-cp-it +Alias: csIBM280 + +Name: IBM281 [RFC1345,KXS2] +MIBenum: 2036 +Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990 +Alias: EBCDIC-JP-E +Alias: cp281 +Alias: csIBM281 + +Name: IBM284 [RFC1345,KXS2] +MIBenum: 2037 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP284 +Alias: ebcdic-cp-es +Alias: csIBM284 + +Name: IBM285 [RFC1345,KXS2] +MIBenum: 2038 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP285 +Alias: ebcdic-cp-gb +Alias: csIBM285 + +Name: IBM290 [RFC1345,KXS2] +MIBenum: 2039 +Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990 +Alias: cp290 +Alias: EBCDIC-JP-kana +Alias: csIBM290 + +Name: IBM297 [RFC1345,KXS2] +MIBenum: 2040 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp297 +Alias: ebcdic-cp-fr +Alias: csIBM297 + +Name: IBM420 [RFC1345,KXS2] +MIBenum: 2041 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990, + IBM NLS RM p 11-11 +Alias: cp420 +Alias: ebcdic-cp-ar1 +Alias: csIBM420 + +Name: IBM423 [RFC1345,KXS2] +MIBenum: 2042 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp423 +Alias: ebcdic-cp-gr +Alias: csIBM423 + +Name: IBM424 [RFC1345,KXS2] +MIBenum: 2043 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp424 +Alias: ebcdic-cp-he +Alias: csIBM424 + +Name: IBM437 [RFC1345,KXS2] +MIBenum: 2011 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp437 +Alias: 437 +Alias: csPC8CodePage437 + +Name: IBM500 [RFC1345,KXS2] +MIBenum: 2044 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP500 +Alias: ebcdic-cp-be +Alias: ebcdic-cp-ch +Alias: csIBM500 + +Name: IBM851 [RFC1345,KXS2] +MIBenum: 2045 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp851 +Alias: 851 +Alias: csIBM851 + +Name: IBM852 [RFC1345,KXS2] +MIBenum: 2010 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp852 +Alias: 852 +Alias: csPCp852 + +Name: IBM855 [RFC1345,KXS2] +MIBenum: 2046 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp855 +Alias: 855 +Alias: csIBM855 + +Name: IBM857 [RFC1345,KXS2] +MIBenum: 2047 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp857 +Alias: 857 +Alias: csIBM857 + +Name: IBM860 [RFC1345,KXS2] +MIBenum: 2048 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp860 +Alias: 860 +Alias: csIBM860 + +Name: IBM861 [RFC1345,KXS2] +MIBenum: 2049 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp861 +Alias: 861 +Alias: cp-is +Alias: csIBM861 + +Name: IBM863 [RFC1345,KXS2] +MIBenum: 2050 +Source: IBM Keyboard layouts and code pages, PN 07G4586 June 1991 +Alias: cp863 +Alias: 863 +Alias: csIBM863 + +Name: IBM864 [RFC1345,KXS2] +MIBenum: 2051 +Source: IBM Keyboard layouts and code pages, PN 07G4586 June 1991 +Alias: cp864 +Alias: csIBM864 + +Name: IBM865 [RFC1345,KXS2] +MIBenum: 2052 +Source: IBM DOS 3.3 Ref (Abridged), 94X9575 (Feb 1987) +Alias: cp865 +Alias: 865 +Alias: csIBM865 + +Name: IBM868 [RFC1345,KXS2] +MIBenum: 2053 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP868 +Alias: cp-ar +Alias: csIBM868 + +Name: IBM869 [RFC1345,KXS2] +MIBenum: 2054 +Source: IBM Keyboard layouts and code pages, PN 07G4586 June 1991 +Alias: cp869 +Alias: 869 +Alias: cp-gr +Alias: csIBM869 + +Name: IBM870 [RFC1345,KXS2] +MIBenum: 2055 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP870 +Alias: ebcdic-cp-roece +Alias: ebcdic-cp-yu +Alias: csIBM870 + +Name: IBM871 [RFC1345,KXS2] +MIBenum: 2056 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP871 +Alias: ebcdic-cp-is +Alias: csIBM871 + +Name: IBM880 [RFC1345,KXS2] +MIBenum: 2057 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp880 +Alias: EBCDIC-Cyrillic +Alias: csIBM880 + +Name: IBM891 [RFC1345,KXS2] +MIBenum: 2058 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp891 +Alias: csIBM891 + +Name: IBM903 [RFC1345,KXS2] +MIBenum: 2059 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp903 +Alias: csIBM903 + +Name: IBM904 [RFC1345,KXS2] +MIBenum: 2060 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: cp904 +Alias: 904 +Alias: csIBBM904 + +Name: IBM905 [RFC1345,KXS2] +MIBenum: 2061 +Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990 +Alias: CP905 +Alias: ebcdic-cp-tr +Alias: csIBM905 + +Name: IBM918 [RFC1345,KXS2] +MIBenum: 2062 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP918 +Alias: ebcdic-cp-ar2 +Alias: csIBM918 + +Name: IBM1026 [RFC1345,KXS2] +MIBenum: 2063 +Source: IBM NLS RM Vol2 SE09-8002-01, March 1990 +Alias: CP1026 +Alias: csIBM1026 + +Name: EBCDIC-AT-DE [RFC1345,KXS2] +MIBenum: 2064 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csIBMEBCDICATDE + +Name: EBCDIC-AT-DE-A [RFC1345,KXS2] +MIBenum: 2065 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICATDEA + +Name: EBCDIC-CA-FR [RFC1345,KXS2] +MIBenum: 2066 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICCAFR + +Name: EBCDIC-DK-NO [RFC1345,KXS2] +MIBenum: 2067 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICDKNO + +Name: EBCDIC-DK-NO-A [RFC1345,KXS2] +MIBenum: 2068 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICDKNOA + +Name: EBCDIC-FI-SE [RFC1345,KXS2] +MIBenum: 2069 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICFISE + +Name: EBCDIC-FI-SE-A [RFC1345,KXS2] +MIBenum: 2070 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICFISEA + +Name: EBCDIC-FR [RFC1345,KXS2] +MIBenum: 2071 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICFR + +Name: EBCDIC-IT [RFC1345,KXS2] +MIBenum: 2072 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICIT + +Name: EBCDIC-PT [RFC1345,KXS2] +MIBenum: 2073 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICPT + +Name: EBCDIC-ES [RFC1345,KXS2] +MIBenum: 2074 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICES + +Name: EBCDIC-ES-A [RFC1345,KXS2] +MIBenum: 2075 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICESA + +Name: EBCDIC-ES-S [RFC1345,KXS2] +MIBenum: 2076 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICESS + +Name: EBCDIC-UK [RFC1345,KXS2] +MIBenum: 2077 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICUK + +Name: EBCDIC-US [RFC1345,KXS2] +MIBenum: 2078 +Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987 +Alias: csEBCDICUS + +Name: UNKNOWN-8BIT [RFC1428] +MIBenum: 2079 +Alias: csUnknown8BiT + +Name: MNEMONIC [RFC1345,KXS2] +MIBenum: 2080 +Source: RFC 1345, also known as "mnemonic+ascii+38" +Alias: csMnemonic + +Name: MNEM [RFC1345,KXS2] +MIBenum: 2081 +Source: RFC 1345, also known as "mnemonic+ascii+8200" +Alias: csMnem + +Name: VISCII [RFC1456] +MIBenum: 2082 +Source: RFC 1456 +Alias: csVISCII + +Name: VIQR [RFC1456] +MIBenum: 2083 +Source: RFC 1456 +Alias: csVIQR + +Name: KOI8-R (preferred MIME name) [RFC1489] +MIBenum: 2084 +Source: RFC 1489, based on GOST-19768-74, ISO-6937/8, + INIS-Cyrillic, ISO-5427. +Alias: csKOI8R + +Name: HZ-GB-2312 +MIBenum: 2085 +Source: RFC 1842, RFC 1843 [RFC1842, RFC1843] + +Name: IBM866 [Pond] +MIBenum: 2086 +Source: IBM NLDG Volume 2 (SE09-8002-03) August 1994 +Alias: cp866 +Alias: 866 +Alias: csIBM866 + +Name: IBM775 [HP-PCL5] +MIBenum: 2087 +Source: HP PCL 5 Comparison Guide (P/N 5021-0329) pp B-13, 1996 +Alias: cp775 +Alias: csPC775Baltic + +Name: KOI8-U [RFC2319] +MIBenum: 2088 +Source: RFC 2319 + +Name: IBM00858 +MIBenum: 2089 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM00858) [Mahdi] +Alias: CCSID00858 +Alias: CP00858 +Alias: PC-Multilingual-850+euro + +Name: IBM00924 +MIBenum: 2090 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM00924) [Mahdi] +Alias: CCSID00924 +Alias: CP00924 +Alias: ebcdic-Latin9--euro + +Name: IBM01140 +MIBenum: 2091 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01140) [Mahdi] +Alias: CCSID01140 +Alias: CP01140 +Alias: ebcdic-us-37+euro + +Name: IBM01141 +MIBenum: 2092 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01141) [Mahdi] +Alias: CCSID01141 +Alias: CP01141 +Alias: ebcdic-de-273+euro + +Name: IBM01142 +MIBenum: 2093 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01142) [Mahdi] +Alias: CCSID01142 +Alias: CP01142 +Alias: ebcdic-dk-277+euro +Alias: ebcdic-no-277+euro + +Name: IBM01143 +MIBenum: 2094 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01143) [Mahdi] +Alias: CCSID01143 +Alias: CP01143 +Alias: ebcdic-fi-278+euro +Alias: ebcdic-se-278+euro + +Name: IBM01144 +MIBenum: 2095 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01144) [Mahdi] +Alias: CCSID01144 +Alias: CP01144 +Alias: ebcdic-it-280+euro + +Name: IBM01145 +MIBenum: 2096 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01145) [Mahdi] +Alias: CCSID01145 +Alias: CP01145 +Alias: ebcdic-es-284+euro + +Name: IBM01146 +MIBenum: 2097 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01146) [Mahdi] +Alias: CCSID01146 +Alias: CP01146 +Alias: ebcdic-gb-285+euro + +Name: IBM01147 +MIBenum: 2098 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01147) [Mahdi] +Alias: CCSID01147 +Alias: CP01147 +Alias: ebcdic-fr-297+euro + +Name: IBM01148 +MIBenum: 2099 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01148) [Mahdi] +Alias: CCSID01148 +Alias: CP01148 +Alias: ebcdic-international-500+euro + +Name: IBM01149 +MIBenum: 2100 +Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01149) [Mahdi] +Alias: CCSID01149 +Alias: CP01149 +Alias: ebcdic-is-871+euro + +Name: Big5-HKSCS [Yick] +MIBenum: 2101 +Source: See (http://www.iana.org/assignments/charset-reg/Big5-HKSCS) +Alias: None + +Name: IBM1047 [Robrigado] +MIBenum: 2102 +Source: IBM1047 (EBCDIC Latin 1/Open Systems) +http://www-1.ibm.com/servers/eserver/iseries/software/globalization/pdf/cp01047z.pdf +Alias: IBM-1047 + +Name: PTCP154 [Uskov] +MIBenum: 2103 +Source: See (http://www.iana.org/assignments/charset-reg/PTCP154) +Alias: csPTCP154 +Alias: PT154 +Alias: CP154 +Alias: Cyrillic-Asian + +Name: Amiga-1251 +MIBenum: 2104 +Source: See (http://www.amiga.ultranet.ru/Amiga-1251.html) +Alias: Ami1251 +Alias: Amiga1251 +Alias: Ami-1251 +(Aliases are provided for historical reasons and should not be used) + [Malyshev] + +Name: KOI7-switched +MIBenum: 2105 +Source: See +Aliases: None + +Name: BRF +MIBenum: 2106 +Source: See [Thibault] +Alias: csBRF + +Name: TSCII +MIBenum: 2107 +Source: See [Kalyanasundaram] +Alias: csTSCII + +Name: windows-1250 +MIBenum: 2250 +Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1250) [Lazhintseva] +Alias: None + +Name: windows-1251 +MIBenum: 2251 +Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1251) [Lazhintseva] +Alias: None + +Name: windows-1252 +MIBenum: 2252 +Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1252) [Wendt] +Alias: None + +Name: windows-1253 +MIBenum: 2253 +Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1253) [Lazhintseva] +Alias: None + +Name: windows-1254 +MIBenum: 2254 +Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1254) [Lazhintseva] +Alias: None + +Name: windows-1255 +MIBenum: 2255 +Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1255) [Lazhintseva] +Alias: None + +Name: windows-1256 +MIBenum: 2256 +Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1256) [Lazhintseva] +Alias: None + +Name: windows-1257 +MIBenum: 2257 +Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1257) [Lazhintseva] +Alias: None + +Name: windows-1258 +MIBenum: 2258 +Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1258) [Lazhintseva] +Alias: None + +Name: TIS-620 +MIBenum: 2259 +Source: Thai Industrial Standards Institute (TISI) [Tantsetthi] + diff --git a/extra/io/encodings/iana/iana-docs.factor b/extra/io/encodings/iana/iana-docs.factor new file mode 100644 index 0000000000..d4a7a65797 --- /dev/null +++ b/extra/io/encodings/iana/iana-docs.factor @@ -0,0 +1,12 @@ +USING: help.syntax help.markup ; +IN: io.encodings.iana + +HELP: name>encoding +{ $values { "name" "an encoding name" } { "encoding" "an encoding descriptor" } } +{ "Given an IANA-registered encoding name, find the encoding descriptor that represents it, or " { $code f } " if it is not found (either not implemented in Factor or not registered)." } ; + +HELP: encoding>name +{ $values { "encoding" "an encoding descriptor" } { "name" "an encoding name" } } +{ "Given an encoding descriptor, return the preferred IANA name." } ; + +{ name>encoding encoding>name } related-words diff --git a/extra/io/encodings/iana/iana-tests.factor b/extra/io/encodings/iana/iana-tests.factor new file mode 100644 index 0000000000..8cee07b984 --- /dev/null +++ b/extra/io/encodings/iana/iana-tests.factor @@ -0,0 +1,5 @@ +USING: io.encodings.iana io.encodings.ascii tools.test ; + +[ ascii ] [ "US-ASCII" name>encoding ] unit-test +[ ascii ] [ "ASCII" name>encoding ] unit-test +[ "US-ASCII" ] [ ascii encoding>name ] unit-test diff --git a/extra/io/encodings/iana/iana.factor b/extra/io/encodings/iana/iana.factor new file mode 100644 index 0000000000..24badaf683 --- /dev/null +++ b/extra/io/encodings/iana/iana.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel strings unicode.syntax.backend io.files assocs +splitting sequences io namespaces sets +io.encodings.ascii io.encodings.utf8 io.encodings.utf16 io.encodings.8-bit ; +IN: io.encodings.iana + +e-table + +: e>n-table H{ + { ascii "US-ASCII" } + { utf8 "UTF-8" } + { utf16 "UTF-16" } + { utf16be "UTF-16BE" } + { utf16le "UTF-16LE" } + { latin1 "ISO-8859-1" } + { latin2 "ISO-8859-2" } + { latin3 "ISO-8859-3" } + { latin4 "ISO-8859-4" } + { latin/cyrillic "ISO-8859-5" } + { latin/arabic "ISO-8859-6" } + { latin/greek "ISO-8859-7" } + { latin/hebrew "ISO-8859-8" } + { latin5 "ISO-8859-9" } + { latin6 "ISO-8859-10" } +} ; +PRIVATE> + +: name>encoding ( name -- encoding ) + n>e-table at ; + +: encoding>name ( encoding -- name ) + e>n-table at ; + +e ( stream -- n>e ) + parse-iana [ [ + dup [ + e>n-table value-at + [ swap [ set ] with each ] + [ drop ] if* + ] with each + ] each ] H{ } make-assoc ; +PRIVATE> + +"resource:extra/io/encodings/iana/character-sets" +ascii make-n>e \ n>e-table set-value diff --git a/extra/io/encodings/iana/summary.txt b/extra/io/encodings/iana/summary.txt new file mode 100644 index 0000000000..c95d76344c --- /dev/null +++ b/extra/io/encodings/iana/summary.txt @@ -0,0 +1 @@ +Tables for IANA encoding names diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 1d5ed16dc5..45e3b1de66 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -47,7 +47,7 @@ PRIVATE> ] with-variable ; inline : stop-server ( -- ) - servers get [ dispose ] each ; + servers get dispose-each ; string write ; -! sequence and number overlap, we provide an explicit -! disambiguation method -M: integer json-print ( num -- ) - number>string write ; - M: sequence json-print ( array -- ) CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ; diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index c13be40c8f..bb2fd9893c 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -230,3 +230,10 @@ DEFER: xyzzy [ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test +GENERIC: next-method-test ( a -- b ) + +M: integer next-method-test 3 + ; + +M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; + +[ 5 ] [ 1 next-method-test ] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 8c8fa96fa5..d18017f69b 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -279,7 +279,9 @@ M: wlet local-rewrite* : (::) CREATE-WORD parse-locals-definition ; -: (M::) CREATE-METHOD parse-locals-definition ; +: (M::) + CREATE-METHOD + [ parse-locals-definition ] with-method-definition ; PRIVATE> diff --git a/extra/morse/authors.txt b/extra/morse/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/morse/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/morse/morse-docs.factor b/extra/morse/morse-docs.factor index c11ba23db7..f31b741c85 100644 --- a/extra/morse/morse-docs.factor +++ b/extra/morse/morse-docs.factor @@ -23,3 +23,7 @@ HELP: morse> { $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } } { $description "Translates morse code into ASCII text" } { $see-also >morse morse>ch } ; + +HELP: play-as-morse +{ $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } } +{ $description "Plays a string as morse code" } ; diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index 97efe1afb4..dabb93579d 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -9,3 +9,5 @@ USING: arrays morse strings tools.test ; [ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test [ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test [ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test +[ ] [ "sos" 0.075 play-as-morse ] unit-test +[ ] [ "Factor rocks!" play-as-morse ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index f493951ed5..ecade14cdb 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: assocs hashtables kernel lazy-lists namespaces openal -parser-combinators promises sequences strings unicode.case ; +USING: assocs combinators hashtables kernel lazy-lists math namespaces +openal openal.waves parser-combinators promises sequences strings symbols +unicode.case ; IN: morse <+> ; @@ -123,3 +124,53 @@ PRIVATE> ] map >string ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ; +r 8 22000 880 r> send-buffer* ; + +: silent-buffer ( seconds -- id ) + 8 22000 rot send-buffer* ; + +: make-buffers ( unit-length -- ) + { + [ sine-buffer dot-buffer set ] + [ 3 * sine-buffer dash-buffer set ] + [ silent-buffer intra-char-gap-buffer set ] + [ 3 * silent-buffer letter-gap-buffer set ] + } cleave ; + +: playing-morse ( quot unit-length -- ) + [ + init-openal 1 gen-sources first source set make-buffers + call + source get source-play + ] with-scope ; + +: play-char ( ch -- ) + [ intra-char-gap ] [ + { + { dot-char [ dot ] } + { dash-char [ dash ] } + { word-gap-char [ intra-char-gap ] } + } case + ] interleave ; + +PRIVATE> + +: play-as-morse* ( str unit-length -- ) + [ + [ letter-gap ] [ ch>morse play-char ] interleave + ] swap playing-morse ; + +: play-as-morse ( str -- ) + 0.05 play-as-morse* ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index d5a698f5f8..59e8049232 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -86,12 +86,12 @@ SYMBOL: total [ { { [ 2dup eq? ] [ +eq+ ] } - { [ 2dup [ class< ] 2keep swap class< and ] [ +eq+ ] } - { [ 2dup class< ] [ +lt+ ] } - { [ 2dup swap class< ] [ +gt+ ] } + { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] } + { [ 2dup class<= ] [ +lt+ ] } + { [ 2dup swap class<= ] [ +gt+ ] } [ +eq+ ] } cond 2nip - ] 2map [ zero? not ] find nip +eq+ or ; + ] 2map [ +eq+ eq? not ] find nip +eq+ or ; : sort-methods ( alist -- alist' ) [ [ first ] bi@ classes< ] topological-sort ; diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor index ff67a30ea3..c0a79d8353 100644 --- a/extra/openal/openal.factor +++ b/extra/openal/openal.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel alien system combinators alien.syntax namespaces +USING: kernel arrays alien system combinators alien.syntax namespaces alien.c-types sequences vocabs.loader shuffle combinators.lib openal.backend ; IN: openal @@ -266,6 +266,12 @@ os macosx? "openal.macosx" "openal.other" ? require gen-buffer dup rot load-wav-file [ alBufferData ] 4keep alutUnloadWAV ; +: queue-buffers ( source buffers -- ) + [ length ] [ >c-uint-array ] bi alSourceQueueBuffers ; + +: queue-buffer ( source buffer -- ) + 1array queue-buffers ; + : set-source-param ( source param value -- ) alSourcei ; diff --git a/extra/openal/waves/waves-tests.factor b/extra/openal/waves/waves-tests.factor new file mode 100644 index 0000000000..b295283aac --- /dev/null +++ b/extra/openal/waves/waves-tests.factor @@ -0,0 +1,5 @@ +USING: kernel openal openal.waves sequences tools.test ; +IN: openal.waves.tests + + +[ ] [ 8 22000 440 1 play-sine-wave ] unit-test diff --git a/extra/openal/waves/waves.factor b/extra/openal/waves/waves.factor new file mode 100644 index 0000000000..abe9f8fb69 --- /dev/null +++ b/extra/openal/waves/waves.factor @@ -0,0 +1,53 @@ +USING: accessors alien.c-types combinators kernel locals math +math.constants math.functions math.ranges openal sequences ; +IN: openal.waves + +TUPLE: buffer bits channels sample-freq seq id ; + +: ( bits sample-freq seq -- buffer ) + ! defaults to 1 channel + 1 -rot gen-buffer buffer boa ; + +: buffer-format ( buffer -- format ) + dup buffer-channels 1 = swap buffer-bits 8 = [ + AL_FORMAT_MONO8 AL_FORMAT_STEREO8 + ] [ + AL_FORMAT_MONO16 AL_FORMAT_STEREO16 + ] if ? ; + +: buffer-data ( buffer -- data size ) + #! 8 bit data is integers between 0 and 255, + #! 16 bit data is integers between -32768 and 32768 + #! size is in bytes + [ seq>> ] [ bits>> ] bi 8 = [ + [ 128 * >integer 128 + ] map [ >c-uchar-array ] [ length ] bi + ] [ + [ 32768 * >integer ] map [ >c-short-array ] [ length 2 * ] bi + ] if ; + +: send-buffer ( buffer -- ) + { [ id>> ] [ buffer-format ] [ buffer-data ] [ sample-freq>> ] } cleave + alBufferData ; + +: send-buffer* ( buffer -- id ) + [ send-buffer ] [ id>> ] bi ; + +: (sine-wave-seq) ( samples/wave n-samples -- seq ) + pi 2 * rot / [ * sin ] curry map ; + +: sine-wave-seq ( sample-freq freq seconds -- seq ) + pick * >integer [ / ] dip (sine-wave-seq) ; + +: ( bits sample-freq freq seconds -- buffer ) + >r dupd r> sine-wave-seq ; + +: ( bits sample-freq seconds -- buffer ) + dupd * >integer [ drop 0 ] map ; + +: play-sine-wave ( bits sample-freq freq seconds -- ) + init-openal + send-buffer* + 1 gen-sources first + [ AL_BUFFER rot set-source-param ] [ source-play ] bi + check-error ; + diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index ab9ae38ac1..ee58a4e345 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -87,7 +87,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) : adjust-points [ [ 1 + 0.5 * ] map ] bi@ ; -: scale-points 2array flip [ v* ] with map [ v+ ] with map ; +: scale-points zip [ v* ] with map [ v+ ] with map ; : circle-points ( loc dim steps -- points ) circle-steps unit-circle adjust-points scale-points ; diff --git a/extra/semantic-db/authors.txt b/extra/semantic-db/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/semantic-db/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/semantic-db/context/context.factor b/extra/semantic-db/context/context.factor deleted file mode 100644 index 777c481ebb..0000000000 --- a/extra/semantic-db/context/context.factor +++ /dev/null @@ -1,16 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces semantic-db ; -IN: semantic-db.context - -: create-context* ( context-name -- context-id ) create-node* ; -: create-context ( context-name -- ) create-context* drop ; - -: context ( -- context-id ) - \ context get ; - -: set-context ( context-id -- ) - \ context set ; - -: with-context ( context-id quot -- ) - >r \ context r> with-variable ; diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor deleted file mode 100755 index 0b2421c757..0000000000 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ /dev/null @@ -1,45 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: accessors db.tuples hashtables kernel sets -semantic-db semantic-db.relations sequences sequences.deep ; -IN: semantic-db.hierarchy - -TUPLE: tree id children ; -C: tree - -: has-parent-relation ( -- relation-id ) - "has parent" relation-id ; - -: parent-child* ( parent child -- arc-id ) - has-parent-relation spin create-arc* ; - -: parent-child ( parent child -- ) - parent-child* drop ; - -: un-parent-child ( parent child -- ) - has-parent-relation spin select-tuples [ id>> delete-arc ] each ; - -: child-arcs ( node-id -- child-arcs ) - has-parent-relation f rot select-tuples ; - -: children ( node-id -- children ) - child-arcs [ subject>> ] map ; - -: parent-arcs ( node-id -- parent-arcs ) - has-parent-relation swap f select-tuples ; - -: parents ( node-id -- parents ) - parent-arcs [ object>> ] map ; - -: get-node-hierarchy ( node-id -- tree ) - dup children [ get-node-hierarchy ] map ; - -: (get-root-nodes) ( node-id -- root-nodes/node-id ) - dup parents dup empty? [ - drop - ] [ - nip [ (get-root-nodes) ] map - ] if ; - -: get-root-nodes ( node-id -- root-nodes ) - (get-root-nodes) flatten prune ; diff --git a/extra/semantic-db/relations/relations.factor b/extra/semantic-db/relations/relations.factor deleted file mode 100644 index 17c335c4ae..0000000000 --- a/extra/semantic-db/relations/relations.factor +++ /dev/null @@ -1,26 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: db.types kernel namespaces semantic-db semantic-db.context -sequences.lib ; -IN: semantic-db.relations - -! relations: -! - have a context in context 'semantic-db' - -: create-relation* ( context-id relation-name -- relation-id ) - create-node* tuck has-context-relation spin create-arc ; - -: create-relation ( context-id relation-name -- ) - create-relation* drop ; - -: get-relation ( context-id relation-name -- relation-id/f ) - [ - ":name" TEXT param , - ":context" INTEGER param , - has-context-relation ":has_context" INTEGER param , - ] { } make - "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.relation = :has_context and a.object = :context" - single-int-results ?first ; - -: relation-id ( relation-name -- relation-id ) - context swap [ get-relation ] [ create-relation* ] ensure2 ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index c523053740..484af741aa 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,10 +1,10 @@ -USING: accessors arrays continuations db db.sqlite -db.tuples io.files kernel math namespaces semantic-db -semantic-db.context semantic-db.hierarchy -semantic-db.relations sequences sorting tools.test +USING: accessors arrays continuations db db.sqlite db.tuples io.files +kernel math namespaces semantic-db sequences sorting tools.test tools.walker ; IN: semantic-db.tests +SYMBOL: context + : db-path "semantic-db-test.db" temp-file ; : test-db db-path sqlite-db ; : delete-db [ db-path delete-file ] ignore-errors ; @@ -12,61 +12,56 @@ IN: semantic-db.tests delete-db test-db [ - create-node-table create-arc-table - [ 1 ] [ "first node" create-node* ] unit-test - [ 2 ] [ "second node" create-node* ] unit-test - [ 3 ] [ "third node" create-node* ] unit-test - [ 4 ] [ f create-node* ] unit-test - [ 5 ] [ 1 2 3 create-arc* ] unit-test -] with-db + node create-table arc create-table + [ 1 ] [ "first node" create-node id>> ] unit-test + [ 2 ] [ "second node" create-node id>> ] unit-test + [ 3 ] [ "third node" create-node id>> ] unit-test + [ 4 ] [ f create-node id>> ] unit-test + [ ] [ 1 f 2 f 3 f create-arc ] unit-test + [ { 1 2 3 4 } ] [ all-node-ids ] unit-test +] with-db delete-db -delete-db - -test-db [ - init-semantic-db - "test content" create-context* [ - [ 4 ] [ context ] unit-test - [ 5 ] [ context "is test content" create-relation* ] unit-test - [ 5 ] [ context "is test content" get-relation ] unit-test - [ 5 ] [ "is test content" relation-id ] unit-test - [ 7 ] [ "has parent" relation-id ] unit-test - [ 7 ] [ "has parent" relation-id ] unit-test - [ "has parent" ] [ "has parent" relation-id node-content ] unit-test - [ "test content" ] [ context node-content ] unit-test - ] with-context - ! type-type 1array [ "type" ensure-type ] unit-test - ! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test - ! [ 1 ] [ type-type select-node-of-type ] unit-test - ! [ t ] [ "content" ensure-type integer? ] unit-test - ! [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test - ! [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test - ! [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test - ! [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test - ! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test - ! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test - ! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test -] with-db - -delete-db - -! test hierarchy -test-db [ - init-semantic-db - "family tree" create-context* [ - "adam" create-node* "adam" set - "eve" create-node* "eve" set - "bob" create-node* "bob" set - "fran" create-node* "fran" set - "charlie" create-node* "charlie" set - "gertrude" create-node* "gertrude" set - [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test - { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] bi@ parent-child ] each - [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test - [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test - [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test - [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map natural-sort >array ] unit-test - [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test - ] with-context -] with-db - -delete-db + test-db [ + init-semantic-db + "test content" create-context context set + [ T{ node f 3 "test content" } ] [ context get ] unit-test + [ T{ node f 4 "is test content" } ] [ "is test content" context get create-relation ] unit-test + [ T{ node f 4 "is test content" } ] [ "is test content" context get get-relation ] unit-test + [ T{ node f 4 "is test content" } ] [ "is test content" context get ensure-relation ] unit-test + [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test + [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test + [ "has parent" ] [ "has parent" context get ensure-relation node-content ] unit-test + [ "test content" ] [ context get node-content ] unit-test + ] with-db delete-db + + ! "test1" "test1-relation-id-word" f f f f define-relation + ! "test2" t t t t t define-relation + RELATION: test3 + test-db [ + init-semantic-db + ! [ T{ node f 3 "test1" } ] [ test1-relation-id-word ] unit-test + ! [ T{ node f 4 "test2" } ] [ test2-relation ] unit-test + [ T{ node f 4 "test3" } ] [ test3-relation ] unit-test + ] with-db delete-db + + ! test hierarchy + RELATION: has-parent + test-db [ + init-semantic-db + "adam" create-node "adam" set + "eve" create-node "eve" set + "bob" create-node "bob" set + "fran" create-node "fran" set + "charlie" create-node "charlie" set + "gertrude" create-node "gertrude" set + [ ] [ "bob" get "adam" get has-parent ] unit-test + { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] bi@ has-parent ] each + [ { "bob" "fran" } ] [ "eve" get has-parent-relation children [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "bob" get has-parent-relation parents [ node-content ] map ] unit-test + [ "fran" { "charlie" } ] [ "fran" get has-parent-relation get-node-tree-s dup node>> node-content swap children>> [ node>> node-content ] map ] unit-test + [ { "adam" "eve" } ] [ "charlie" get has-parent-relation get-root-nodes [ node-content ] map natural-sort >array ] unit-test + [ { } ] [ "charlie" get dup "fran" get !has-parent has-parent-relation parents [ node-content ] map ] unit-test + [ { "adam" "eve" } ] [ has-parent-relation ultimate-objects node-results [ node-content ] map ] unit-test + [ { "fran" "gertrude" } ] [ has-parent-relation ultimate-subjects node-results [ node-content ] map ] unit-test + ] with-db delete-db + diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 8953281359..3044c8872f 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser sequences ; +USING: accessors arrays combinators combinators.cleave combinators.lib +continuations db db.tuples db.types db.sqlite kernel math +math.parser namespaces parser sets sequences sequences.deep +sequences.lib strings words ; IN: semantic-db TUPLE: node id content ; -: ( content -- node ) - node new swap >>content ; - -: ( id -- node ) - node new swap >>id ; +C: node node "node" { @@ -16,74 +15,271 @@ node "node" { "content" "content" TEXT } } define-persistent -: create-node-table ( -- ) - node create-table ; +: delete-node ( node -- ) delete-tuples ; +: create-node ( content -- node ) f swap dup insert-tuple ; +: load-node ( id -- node ) f select-tuple ; -: delete-node ( node-id -- ) - delete-tuples ; +: node-content ( node -- content ) + dup content>> [ nip ] [ select-tuple content>> ] if* ; -: create-node* ( str -- node-id ) - dup insert-tuple id>> ; +: node= ( node node -- ? ) [ id>> ] bi@ = ; -: create-node ( str -- ) - create-node* drop ; +! TODO: get rid of arc id and write our own sql +TUPLE: arc id subject object relation ; -: node-content ( id -- str ) - f swap >>id select-tuple content>> ; - -TUPLE: arc id relation subject object ; - -: ( relation subject object -- arc ) - arc new swap >>object swap >>subject swap >>relation ; +: ( subject object relation -- arc ) + arc new swap >>relation swap >>object swap >>subject ; : ( id -- arc ) arc new swap >>id ; -: insert-arc ( arc -- ) - f dup insert-tuple id>> >>id insert-tuple ; +: delete-arc ( arc -- ) delete-tuples ; -: delete-arc ( arc-id -- ) - dup delete-node delete-tuples ; +: create-arc ( subject object relation -- ) + [ id>> ] 3apply insert-tuple ; -: create-arc* ( relation subject object -- arc-id ) - dup insert-arc id>> ; +: nodes>arc ( subject object relation -- arc ) + [ [ id>> ] [ f ] if* ] 3apply ; -: create-arc ( relation subject object -- ) - create-arc* drop ; +: select-arcs ( subject object relation -- arcs ) + nodes>arc select-tuples ; + +: has-arc? ( subject object relation -- ? ) + select-arcs length 0 > ; + +: select-arc-subjects ( subject object relation -- subjects ) + select-arcs [ subject>> f ] map ; + +: select-arc-subject ( subject object relation -- subject ) + select-arcs ?first [ subject>> f ] [ f ] if* ; + +: select-subjects ( object relation -- subjects ) + f -rot select-arc-subjects ; + +: select-subject ( object relation -- subject ) + f -rot select-arc-subject ; + +: select-arc-objects ( subject object relation -- objects ) + select-arcs [ object>> f ] map ; + +: select-arc-object ( subject object relation -- object ) + select-arcs ?first [ object>> f ] [ f ] if* ; + +: select-objects ( subject relation -- objects ) + f swap select-arc-objects ; + +: select-object ( subject relation -- object ) + f swap select-arc-object ; + +: delete-arcs ( subject object relation -- ) + select-arcs [ delete-arc ] each ; arc "arc" { - { "id" "id" INTEGER +user-assigned-id+ } ! foreign key to node table? + { "id" "id" +db-assigned-id+ +autoincrement+ } { "relation" "relation" INTEGER +not-null+ } { "subject" "subject" INTEGER +not-null+ } { "object" "object" INTEGER +not-null+ } } define-persistent -: create-arc-table ( -- ) - arc create-table ; - : create-bootstrap-nodes ( -- ) - "semantic-db" create-node - "has context" create-node ; + "semantic-db" create-node drop + "has-context" create-node drop ; -: semantic-db-context 1 ; -: has-context-relation 2 ; +: semantic-db-context T{ node f 1 "semantic-db" } ; +: has-context-relation T{ node f 2 "has-context" } ; : create-bootstrap-arcs ( -- ) - has-context-relation has-context-relation semantic-db-context create-arc ; + has-context-relation semantic-db-context has-context-relation create-arc ; : init-semantic-db ( -- ) - create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; + node create-table arc create-table + create-bootstrap-nodes create-bootstrap-arcs ; + +! db utilities +: results ( bindings sql -- array ) + f f [ do-bound-query ] with-disposal ; + +: node-result ( result -- node ) + dup first string>number swap second ; + +: ?1node-result ( results -- node ) + ?first [ node-result ] [ f ] if* ; + +: node-results ( results -- nodes ) + [ node-result ] map ; : param ( value key type -- param ) swapd ; -: single-int-results ( bindings sql -- array ) - f f [ do-bound-query ] with-disposal - [ first string>number ] map ; +: all-node-ids ( -- seq ) + f "select n.id from node n" results [ first string>number ] map ; -: ensure2 ( x y quot1 quot2 -- z ) - #! quot1 ( x y -- z/f ) finds an existing z - #! quot2 ( x y -- z ) creates a new z if quot1 returns f - >r >r 2dup r> call [ 2nip ] r> if* ; +: subjects-with-cor ( content object relation -- sql-results ) + [ id>> ] bi@ + [ + ":relation" INTEGER param , + ":object" INTEGER param , + ":content" TEXT param , + ] { } make + "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.subject and a.relation = :relation and a.object = :object" results ; + +: objects-with-csr ( content subject relation -- sql-results ) + [ id>> ] bi@ + [ + ":relation" INTEGER param , + ":subject" INTEGER param , + ":content" TEXT param , + ] { } make + "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.object and a.relation = :relation and a.subject = :subject" results ; + +: (with-relation) ( content relation -- bindings sql ) + id>> [ ":relation" INTEGER param , ":content" TEXT param , ] { } make + "select distinct n.id, n.content from node n, arc a where n.content = :content and a.relation = :relation" ; + +: subjects-with-relation ( content relation -- sql-results ) + (with-relation) " and a.object = n.id" append results ; + +: objects-with-relation ( content relation -- sql-results ) + (with-relation) " and a.subject = n.id" append results ; + +: (ultimate) ( relation b a -- sql-results ) + [ + "select distinct n.id, n.content from node n, arc a where a.relation = :relation and n.id = a." % % " and n.id not in (select b." % % " from arc b where b.relation = :relation)" % + ] "" make [ id>> ":relation" INTEGER param 1array ] dip results ; + +: ultimate-objects ( relation -- sql-results ) + "subject" "object" (ultimate) ; + +: ultimate-subjects ( relation -- sql-results ) + "object" "subject" (ultimate) ; + +! contexts: +! - a node n is a context iff there exists a relation r such that r has context n +: create-context ( context-name -- context ) create-node ; + +: get-context ( context-name -- context/f ) + has-context-relation subjects-with-relation ?1node-result ; + +: ensure-context ( context-name -- context ) + dup get-context [ + nip + ] [ + create-context + ] if* ; + +! relations: +! - have a context in context 'semantic-db' + +: create-relation ( relation-name context -- relation ) + [ create-node dup ] dip has-context-relation create-arc ; + +: get-relation ( relation-name context -- relation/f ) + has-context-relation subjects-with-cor ?1node-result ; + +: ensure-relation ( relation-name context -- relation ) + 2dup get-relation [ + 2nip + ] [ + create-relation + ] if* ; + +TUPLE: relation-definition relate id-word unrelate related? subjects objects ; +C: relation-definition + +> ] dip default-word-name + ] if ; + +: (define-relation-word) ( id-word word-name definition -- id-word ) + >r create-in over [ execute ] curry r> compose define ; + +: define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word ) + >r >r [ + pick swap r> choose-word-name r> (define-relation-word) + ] [ + r> r> 2drop + ] if* ; + +: define-relation-words ( relation-definition id-word -- ) + over relate>> "relate" [ create-arc ] define-relation-word + over unrelate>> "unrelate" [ delete-arcs ] define-relation-word + over related?>> "related?" [ has-arc? ] define-relation-word + over subjects>> "subjects" [ select-subjects ] define-relation-word + over objects>> "objects" [ select-objects ] define-relation-word + 2drop ; + +: define-id-word ( relation-definition id-word -- ) + [ relate>> ] dip tuck word-vocabulary + [ ensure-context ensure-relation ] 2curry define ; + +: create-id-word ( relation-definition -- id-word ) + dup id-word>> "id-word" choose-word-name create-in ; + +PRIVATE> + +: define-relation ( relation-definition -- ) + dup create-id-word 2dup define-id-word define-relation-words ; + +: RELATION: + scan t t t t t define-relation ; parsing + +! hierarchy +TUPLE: node-tree node children ; +C: node-tree + +: children ( node has-parent-relation -- children ) select-subjects ; +: parents ( node has-parent-relation -- parents ) select-objects ; + +: get-node-tree ( node child-selector -- node-tree ) + 2dup call >r [ get-node-tree ] curry r> swap map ; + +! : get-node-tree ( node has-parent-relation -- node-tree ) +! 2dup children >r [ get-node-tree ] curry r> swap map ; +: get-node-tree-s ( node has-parent-relation -- tree ) + [ select-subjects ] curry get-node-tree ; + +: get-node-tree-o ( node has-child-relation -- tree ) + [ select-objects ] curry get-node-tree ; + +: (get-node-chain) ( node next-selector seq -- seq ) + pick [ + over push >r [ call ] keep r> (get-node-chain) + ] [ + 2nip + ] if* ; + +: get-node-chain ( node next-selector -- seq ) + V{ } clone (get-node-chain) ; + +: get-node-chain-o ( node relation -- seq ) + [ select-object ] curry get-node-chain ; + +: get-node-chain-s ( node relation -- seq ) + [ select-subject ] curry get-node-chain ; + +: (get-root-nodes) ( node has-parent-relation -- root-nodes/node ) + 2dup parents dup empty? [ + 2drop + ] [ + >r nip [ (get-root-nodes) ] curry r> swap map + ] if ; + +: get-root-nodes ( node has-parent-relation -- root-nodes ) + (get-root-nodes) flatten prune ; diff --git a/extra/tangle/authors.txt b/extra/tangle/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tangle/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tangle/html/html-tests.factor b/extra/tangle/html/html-tests.factor new file mode 100644 index 0000000000..8e7d8c24e1 --- /dev/null +++ b/extra/tangle/html/html-tests.factor @@ -0,0 +1,7 @@ +USING: html kernel semantic-db tangle.html tools.test ; +IN: tangle.html.tests + +[ "test" ] [ "test" >html ] unit-test +[ "
  • An Item
" ] [ { "An Item" } >html ] unit-test +[ "
  • One
  • Two
  • Three, ah ah ah
" ] [ { "One" "Two" "Three, ah ah ah" } >html ] unit-test +[ "some link" ] [ "foo/bar" "some link" >html ] unit-test diff --git a/extra/tangle/html/html.factor b/extra/tangle/html/html.factor new file mode 100644 index 0000000000..fc604f4d46 --- /dev/null +++ b/extra/tangle/html/html.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors html html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ; +IN: tangle.html + +TUPLE: element attributes ; + +TUPLE: ulist < element items ; +: ( items -- element ) + H{ } clone swap ulist boa ; + +TUPLE: link < element href text ; +: ( href text -- element ) + H{ } clone -rot link boa ; + +GENERIC: >html ( element -- str ) + +M: string >html ( str -- str ) ; + +M: link >html ( link -- str ) + [ > =href a> text>> write ] with-string-writer ; + +M: node >html ( node -- str ) + dup node>path [ + swap node-content >html + ] [ + node-content + ] if* ; + +M: ulist >html ( ulist -- str ) + [ +
    items>> [
  • >html write
    • ] each
+ ] with-string-writer ; diff --git a/extra/tangle/menu/menu.factor b/extra/tangle/menu/menu.factor new file mode 100644 index 0000000000..9740acee1c --- /dev/null +++ b/extra/tangle/menu/menu.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel semantic-db sequences tangle.html ; +IN: tangle.menu + +RELATION: subitem-of +RELATION: before + +: get-menus ( -- nodes ) + subitem-of-relation ultimate-objects node-results ; + +: get-menu ( name -- node ) + get-menus [ node-content = ] with find nip ; + +: ensure-menu ( name -- node ) + dup get-menu [ nip ] [ create-node ] if* ; + +: load-menu ( name -- menu ) + get-menu subitem-of-relation get-node-tree-s ; + +: menu>ulist ( menu -- str ) children>> ; +: menu>html ( menu -- str ) menu>ulist >html ; diff --git a/extra/tangle/page/page.factor b/extra/tangle/page/page.factor new file mode 100644 index 0000000000..db3d58d5f3 --- /dev/null +++ b/extra/tangle/page/page.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel semantic-db sequences sequences.lib ; +IN: tangle.page + +RELATION: has-abbreviation +RELATION: has-content +RELATION: has-subsection +RELATION: before +RELATION: authored-by +RELATION: authored-on + +TUPLE: page name abbreviation author created content ; +C: page + +: load-page-content ( node -- content ) + has-content-objects [ node-content ] map concat ; + +: load-page ( node -- page ) + dup [ has-abbreviation-objects ?first ] keep + [ authored-by-objects ?first ] keep + [ authored-on-objects ?first ] keep + load-page-content ; diff --git a/extra/tangle/path/path.factor b/extra/tangle/path/path.factor new file mode 100644 index 0000000000..b4151ce1c2 --- /dev/null +++ b/extra/tangle/path/path.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: kernel semantic-db sequences sequences.lib splitting ; +IN: tangle.path + +RELATION: has-filename +RELATION: in-directory + +: create-root ( -- node ) "" create-node ; + +: get-root ( -- node ) + in-directory-relation ultimate-objects ?1node-result ; + +: ensure-root ( -- node ) get-root [ create-root ] unless* ; + +: create-file ( parent name -- node ) + create-node swap dupd in-directory ; + +: files-in-directory ( node -- nodes ) in-directory-subjects ; + +: file-in-directory ( name node -- node ) + in-directory-relation subjects-with-cor ?1node-result ; + +: parent-directory ( file-node -- dir-node ) + in-directory-objects ?first ; + +: (path>node) ( node name -- node ) + swap [ file-in-directory ] [ drop f ] if* ; + +: path>node ( path -- node ) + ensure-root swap [ (path>node) ] each ; + +: path>file ( path -- file ) + path>node [ has-filename-subjects ?first ] [ f ] if* ; + +: (node>path) ( root seq node -- seq ) + pick over node= [ + drop nip + ] [ + dup node-content pick push + parent-directory [ + (node>path) + ] [ + 2drop f + ] if* + ] if ; + +: node>path* ( root node -- path ) + V{ } clone swap (node>path) dup empty? + [ drop f ] [ ] if ; + +: node>path ( node -- path ) + ensure-root swap node>path* ; + +: file>path ( node -- path ) + has-filename-objects ?first [ node>path ] [ f ] if* ; diff --git a/extra/tangle/resources/jquery-1.2.3.min.js b/extra/tangle/resources/jquery-1.2.3.min.js new file mode 100644 index 0000000000..3747929d8b --- /dev/null +++ b/extra/tangle/resources/jquery-1.2.3.min.js @@ -0,0 +1,32 @@ +/* + * jQuery 1.2.3 - New Wave Javascript + * + * Copyright (c) 2008 John Resig (jquery.com) + * Dual licensed under the MIT (MIT-LICENSE.txt) + * and GPL (GPL-LICENSE.txt) licenses. + * + * $Date: 2008-02-06 00:21:25 -0500 (Wed, 06 Feb 2008) $ + * $Rev: 4663 $ + */ +(function(){if(window.jQuery)var _jQuery=window.jQuery;var jQuery=window.jQuery=function(selector,context){return new jQuery.prototype.init(selector,context);};if(window.$)var _$=window.$;window.$=jQuery;var quickExpr=/^[^<]*(<(.|\s)+>)[^>]*$|^#(\w+)$/;var isSimple=/^.[^:#\[\.]*$/;jQuery.fn=jQuery.prototype={init:function(selector,context){selector=selector||document;if(selector.nodeType){this[0]=selector;this.length=1;return this;}else if(typeof selector=="string"){var match=quickExpr.exec(selector);if(match&&(match[1]||!context)){if(match[1])selector=jQuery.clean([match[1]],context);else{var elem=document.getElementById(match[3]);if(elem)if(elem.id!=match[3])return jQuery().find(selector);else{this[0]=elem;this.length=1;return this;}else +selector=[];}}else +return new jQuery(context).find(selector);}else if(jQuery.isFunction(selector))return new jQuery(document)[jQuery.fn.ready?"ready":"load"](selector);return this.setArray(selector.constructor==Array&&selector||(selector.jquery||selector.length&&selector!=window&&!selector.nodeType&&selector[0]!=undefined&&selector[0].nodeType)&&jQuery.makeArray(selector)||[selector]);},jquery:"1.2.3",size:function(){return this.length;},length:0,get:function(num){return num==undefined?jQuery.makeArray(this):this[num];},pushStack:function(elems){var ret=jQuery(elems);ret.prevObject=this;return ret;},setArray:function(elems){this.length=0;Array.prototype.push.apply(this,elems);return this;},each:function(callback,args){return jQuery.each(this,callback,args);},index:function(elem){var ret=-1;this.each(function(i){if(this==elem)ret=i;});return ret;},attr:function(name,value,type){var options=name;if(name.constructor==String)if(value==undefined)return this.length&&jQuery[type||"attr"](this[0],name)||undefined;else{options={};options[name]=value;}return this.each(function(i){for(name in options)jQuery.attr(type?this.style:this,name,jQuery.prop(this,options[name],type,i,name));});},css:function(key,value){if((key=='width'||key=='height')&&parseFloat(value)<0)value=undefined;return this.attr(key,value,"curCSS");},text:function(text){if(typeof text!="object"&&text!=null)return this.empty().append((this[0]&&this[0].ownerDocument||document).createTextNode(text));var ret="";jQuery.each(text||this,function(){jQuery.each(this.childNodes,function(){if(this.nodeType!=8)ret+=this.nodeType!=1?this.nodeValue:jQuery.fn.text([this]);});});return ret;},wrapAll:function(html){if(this[0])jQuery(html,this[0].ownerDocument).clone().insertBefore(this[0]).map(function(){var elem=this;while(elem.firstChild)elem=elem.firstChild;return elem;}).append(this);return this;},wrapInner:function(html){return this.each(function(){jQuery(this).contents().wrapAll(html);});},wrap:function(html){return this.each(function(){jQuery(this).wrapAll(html);});},append:function(){return this.domManip(arguments,true,false,function(elem){if(this.nodeType==1)this.appendChild(elem);});},prepend:function(){return this.domManip(arguments,true,true,function(elem){if(this.nodeType==1)this.insertBefore(elem,this.firstChild);});},before:function(){return this.domManip(arguments,false,false,function(elem){this.parentNode.insertBefore(elem,this);});},after:function(){return this.domManip(arguments,false,true,function(elem){this.parentNode.insertBefore(elem,this.nextSibling);});},end:function(){return this.prevObject||jQuery([]);},find:function(selector){var elems=jQuery.map(this,function(elem){return jQuery.find(selector,elem);});return this.pushStack(/[^+>] [^+>]/.test(selector)||selector.indexOf("..")>-1?jQuery.unique(elems):elems);},clone:function(events){var ret=this.map(function(){if(jQuery.browser.msie&&!jQuery.isXMLDoc(this)){var clone=this.cloneNode(true),container=document.createElement("div");container.appendChild(clone);return jQuery.clean([container.innerHTML])[0];}else +return this.cloneNode(true);});var clone=ret.find("*").andSelf().each(function(){if(this[expando]!=undefined)this[expando]=null;});if(events===true)this.find("*").andSelf().each(function(i){if(this.nodeType==3)return;var events=jQuery.data(this,"events");for(var type in events)for(var handler in events[type])jQuery.event.add(clone[i],type,events[type][handler],events[type][handler].data);});return ret;},filter:function(selector){return this.pushStack(jQuery.isFunction(selector)&&jQuery.grep(this,function(elem,i){return selector.call(elem,i);})||jQuery.multiFilter(selector,this));},not:function(selector){if(selector.constructor==String)if(isSimple.test(selector))return this.pushStack(jQuery.multiFilter(selector,this,true));else +selector=jQuery.multiFilter(selector,this);var isArrayLike=selector.length&&selector[selector.length-1]!==undefined&&!selector.nodeType;return this.filter(function(){return isArrayLike?jQuery.inArray(this,selector)<0:this!=selector;});},add:function(selector){return!selector?this:this.pushStack(jQuery.merge(this.get(),selector.constructor==String?jQuery(selector).get():selector.length!=undefined&&(!selector.nodeName||jQuery.nodeName(selector,"form"))?selector:[selector]));},is:function(selector){return selector?jQuery.multiFilter(selector,this).length>0:false;},hasClass:function(selector){return this.is("."+selector);},val:function(value){if(value==undefined){if(this.length){var elem=this[0];if(jQuery.nodeName(elem,"select")){var index=elem.selectedIndex,values=[],options=elem.options,one=elem.type=="select-one";if(index<0)return null;for(var i=one?index:0,max=one?index+1:options.length;i=0||jQuery.inArray(this.name,value)>=0);else if(jQuery.nodeName(this,"select")){var values=value.constructor==Array?value:[value];jQuery("option",this).each(function(){this.selected=(jQuery.inArray(this.value,values)>=0||jQuery.inArray(this.text,values)>=0);});if(!values.length)this.selectedIndex=-1;}else +this.value=value;});},html:function(value){return value==undefined?(this.length?this[0].innerHTML:null):this.empty().append(value);},replaceWith:function(value){return this.after(value).remove();},eq:function(i){return this.slice(i,i+1);},slice:function(){return this.pushStack(Array.prototype.slice.apply(this,arguments));},map:function(callback){return this.pushStack(jQuery.map(this,function(elem,i){return callback.call(elem,i,elem);}));},andSelf:function(){return this.add(this.prevObject);},data:function(key,value){var parts=key.split(".");parts[1]=parts[1]?"."+parts[1]:"";if(value==null){var data=this.triggerHandler("getData"+parts[1]+"!",[parts[0]]);if(data==undefined&&this.length)data=jQuery.data(this[0],key);return data==null&&parts[1]?this.data(parts[0]):data;}else +return this.trigger("setData"+parts[1]+"!",[parts[0],value]).each(function(){jQuery.data(this,key,value);});},removeData:function(key){return this.each(function(){jQuery.removeData(this,key);});},domManip:function(args,table,reverse,callback){var clone=this.length>1,elems;return this.each(function(){if(!elems){elems=jQuery.clean(args,this.ownerDocument);if(reverse)elems.reverse();}var obj=this;if(table&&jQuery.nodeName(this,"table")&&jQuery.nodeName(elems[0],"tr"))obj=this.getElementsByTagName("tbody")[0]||this.appendChild(this.ownerDocument.createElement("tbody"));var scripts=jQuery([]);jQuery.each(elems,function(){var elem=clone?jQuery(this).clone(true)[0]:this;if(jQuery.nodeName(elem,"script")){scripts=scripts.add(elem);}else{if(elem.nodeType==1)scripts=scripts.add(jQuery("script",elem).remove());callback.call(obj,elem);}});scripts.each(evalScript);});}};jQuery.prototype.init.prototype=jQuery.prototype;function evalScript(i,elem){if(elem.src)jQuery.ajax({url:elem.src,async:false,dataType:"script"});else +jQuery.globalEval(elem.text||elem.textContent||elem.innerHTML||"");if(elem.parentNode)elem.parentNode.removeChild(elem);}jQuery.extend=jQuery.fn.extend=function(){var target=arguments[0]||{},i=1,length=arguments.length,deep=false,options;if(target.constructor==Boolean){deep=target;target=arguments[1]||{};i=2;}if(typeof target!="object"&&typeof target!="function")target={};if(length==1){target=this;i=0;}for(;i-1;}},swap:function(elem,options,callback){var old={};for(var name in options){old[name]=elem.style[name];elem.style[name]=options[name];}callback.call(elem);for(var name in options)elem.style[name]=old[name];},css:function(elem,name,force){if(name=="width"||name=="height"){var val,props={position:"absolute",visibility:"hidden",display:"block"},which=name=="width"?["Left","Right"]:["Top","Bottom"];function getWH(){val=name=="width"?elem.offsetWidth:elem.offsetHeight;var padding=0,border=0;jQuery.each(which,function(){padding+=parseFloat(jQuery.curCSS(elem,"padding"+this,true))||0;border+=parseFloat(jQuery.curCSS(elem,"border"+this+"Width",true))||0;});val-=Math.round(padding+border);}if(jQuery(elem).is(":visible"))getWH();else +jQuery.swap(elem,props,getWH);return Math.max(0,val);}return jQuery.curCSS(elem,name,force);},curCSS:function(elem,name,force){var ret;function color(elem){if(!jQuery.browser.safari)return false;var ret=document.defaultView.getComputedStyle(elem,null);return!ret||ret.getPropertyValue("color")=="";}if(name=="opacity"&&jQuery.browser.msie){ret=jQuery.attr(elem.style,"opacity");return ret==""?"1":ret;}if(jQuery.browser.opera&&name=="display"){var save=elem.style.outline;elem.style.outline="0 solid black";elem.style.outline=save;}if(name.match(/float/i))name=styleFloat;if(!force&&elem.style&&elem.style[name])ret=elem.style[name];else if(document.defaultView&&document.defaultView.getComputedStyle){if(name.match(/float/i))name="float";name=name.replace(/([A-Z])/g,"-$1").toLowerCase();var getComputedStyle=document.defaultView.getComputedStyle(elem,null);if(getComputedStyle&&!color(elem))ret=getComputedStyle.getPropertyValue(name);else{var swap=[],stack=[];for(var a=elem;a&&color(a);a=a.parentNode)stack.unshift(a);for(var i=0;i]*?)\/>/g,function(all,front,tag){return tag.match(/^(abbr|br|col|img|input|link|meta|param|hr|area|embed)$/i)?all:front+">";});var tags=jQuery.trim(elem).toLowerCase(),div=context.createElement("div");var wrap=!tags.indexOf("",""]||!tags.indexOf("",""]||tags.match(/^<(thead|tbody|tfoot|colg|cap)/)&&[1,"","
"]||!tags.indexOf("",""]||(!tags.indexOf("",""]||!tags.indexOf("",""]||jQuery.browser.msie&&[1,"div
","
"]||[0,"",""];div.innerHTML=wrap[1]+elem+wrap[2];while(wrap[0]--)div=div.lastChild;if(jQuery.browser.msie){var tbody=!tags.indexOf(""&&tags.indexOf("=0;--j)if(jQuery.nodeName(tbody[j],"tbody")&&!tbody[j].childNodes.length)tbody[j].parentNode.removeChild(tbody[j]);if(/^\s/.test(elem))div.insertBefore(context.createTextNode(elem.match(/^\s*/)[0]),div.firstChild);}elem=jQuery.makeArray(div.childNodes);}if(elem.length===0&&(!jQuery.nodeName(elem,"form")&&!jQuery.nodeName(elem,"select")))return;if(elem[0]==undefined||jQuery.nodeName(elem,"form")||elem.options)ret.push(elem);else +ret=jQuery.merge(ret,elem);});return ret;},attr:function(elem,name,value){if(!elem||elem.nodeType==3||elem.nodeType==8)return undefined;var fix=jQuery.isXMLDoc(elem)?{}:jQuery.props;if(name=="selected"&&jQuery.browser.safari)elem.parentNode.selectedIndex;if(fix[name]){if(value!=undefined)elem[fix[name]]=value;return elem[fix[name]];}else if(jQuery.browser.msie&&name=="style")return jQuery.attr(elem.style,"cssText",value);else if(value==undefined&&jQuery.browser.msie&&jQuery.nodeName(elem,"form")&&(name=="action"||name=="method"))return elem.getAttributeNode(name).nodeValue;else if(elem.tagName){if(value!=undefined){if(name=="type"&&jQuery.nodeName(elem,"input")&&elem.parentNode)throw"type property can't be changed";elem.setAttribute(name,""+value);}if(jQuery.browser.msie&&/href|src/.test(name)&&!jQuery.isXMLDoc(elem))return elem.getAttribute(name,2);return elem.getAttribute(name);}else{if(name=="opacity"&&jQuery.browser.msie){if(value!=undefined){elem.zoom=1;elem.filter=(elem.filter||"").replace(/alpha\([^)]*\)/,"")+(parseFloat(value).toString()=="NaN"?"":"alpha(opacity="+value*100+")");}return elem.filter&&elem.filter.indexOf("opacity=")>=0?(parseFloat(elem.filter.match(/opacity=([^)]*)/)[1])/100).toString():"";}name=name.replace(/-([a-z])/ig,function(all,letter){return letter.toUpperCase();});if(value!=undefined)elem[name]=value;return elem[name];}},trim:function(text){return(text||"").replace(/^\s+|\s+$/g,"");},makeArray:function(array){var ret=[];if(typeof array!="array")for(var i=0,length=array.length;i*",this).remove();while(this.firstChild)this.removeChild(this.firstChild);}},function(name,fn){jQuery.fn[name]=function(){return this.each(fn,arguments);};});jQuery.each(["Height","Width"],function(i,name){var type=name.toLowerCase();jQuery.fn[type]=function(size){return this[0]==window?jQuery.browser.opera&&document.body["client"+name]||jQuery.browser.safari&&window["inner"+name]||document.compatMode=="CSS1Compat"&&document.documentElement["client"+name]||document.body["client"+name]:this[0]==document?Math.max(Math.max(document.body["scroll"+name],document.documentElement["scroll"+name]),Math.max(document.body["offset"+name],document.documentElement["offset"+name])):size==undefined?(this.length?jQuery.css(this[0],type):null):this.css(type,size.constructor==String?size:size+"px");};});var chars=jQuery.browser.safari&&parseInt(jQuery.browser.version)<417?"(?:[\\w*_-]|\\\\.)":"(?:[\\w\u0128-\uFFFF*_-]|\\\\.)",quickChild=new RegExp("^>\\s*("+chars+"+)"),quickID=new RegExp("^("+chars+"+)(#)("+chars+"+)"),quickClass=new RegExp("^([#.]?)("+chars+"*)");jQuery.extend({expr:{"":function(a,i,m){return m[2]=="*"||jQuery.nodeName(a,m[2]);},"#":function(a,i,m){return a.getAttribute("id")==m[2];},":":{lt:function(a,i,m){return im[3]-0;},nth:function(a,i,m){return m[3]-0==i;},eq:function(a,i,m){return m[3]-0==i;},first:function(a,i){return i==0;},last:function(a,i,m,r){return i==r.length-1;},even:function(a,i){return i%2==0;},odd:function(a,i){return i%2;},"first-child":function(a){return a.parentNode.getElementsByTagName("*")[0]==a;},"last-child":function(a){return jQuery.nth(a.parentNode.lastChild,1,"previousSibling")==a;},"only-child":function(a){return!jQuery.nth(a.parentNode.lastChild,2,"previousSibling");},parent:function(a){return a.firstChild;},empty:function(a){return!a.firstChild;},contains:function(a,i,m){return(a.textContent||a.innerText||jQuery(a).text()||"").indexOf(m[3])>=0;},visible:function(a){return"hidden"!=a.type&&jQuery.css(a,"display")!="none"&&jQuery.css(a,"visibility")!="hidden";},hidden:function(a){return"hidden"==a.type||jQuery.css(a,"display")=="none"||jQuery.css(a,"visibility")=="hidden";},enabled:function(a){return!a.disabled;},disabled:function(a){return a.disabled;},checked:function(a){return a.checked;},selected:function(a){return a.selected||jQuery.attr(a,"selected");},text:function(a){return"text"==a.type;},radio:function(a){return"radio"==a.type;},checkbox:function(a){return"checkbox"==a.type;},file:function(a){return"file"==a.type;},password:function(a){return"password"==a.type;},submit:function(a){return"submit"==a.type;},image:function(a){return"image"==a.type;},reset:function(a){return"reset"==a.type;},button:function(a){return"button"==a.type||jQuery.nodeName(a,"button");},input:function(a){return/input|select|textarea|button/i.test(a.nodeName);},has:function(a,i,m){return jQuery.find(m[3],a).length;},header:function(a){return/h\d/i.test(a.nodeName);},animated:function(a){return jQuery.grep(jQuery.timers,function(fn){return a==fn.elem;}).length;}}},parse:[/^(\[) *@?([\w-]+) *([!*$^~=]*) *('?"?)(.*?)\4 *\]/,/^(:)([\w-]+)\("?'?(.*?(\(.*?\))?[^(]*?)"?'?\)/,new RegExp("^([:.#]*)("+chars+"+)")],multiFilter:function(expr,elems,not){var old,cur=[];while(expr&&expr!=old){old=expr;var f=jQuery.filter(expr,elems,not);expr=f.t.replace(/^\s*,\s*/,"");cur=not?elems=f.r:jQuery.merge(cur,f.r);}return cur;},find:function(t,context){if(typeof t!="string")return[t];if(context&&context.nodeType!=1&&context.nodeType!=9)return[];context=context||document;var ret=[context],done=[],last,nodeName;while(t&&last!=t){var r=[];last=t;t=jQuery.trim(t);var foundToken=false;var re=quickChild;var m=re.exec(t);if(m){nodeName=m[1].toUpperCase();for(var i=0;ret[i];i++)for(var c=ret[i].firstChild;c;c=c.nextSibling)if(c.nodeType==1&&(nodeName=="*"||c.nodeName.toUpperCase()==nodeName))r.push(c);ret=r;t=t.replace(re,"");if(t.indexOf(" ")==0)continue;foundToken=true;}else{re=/^([>+~])\s*(\w*)/i;if((m=re.exec(t))!=null){r=[];var merge={};nodeName=m[2].toUpperCase();m=m[1];for(var j=0,rl=ret.length;j=0;if(!not&&pass||not&&!pass)tmp.push(r[i]);}return tmp;},filter:function(t,r,not){var last;while(t&&t!=last){last=t;var p=jQuery.parse,m;for(var i=0;p[i];i++){m=p[i].exec(t);if(m){t=t.substring(m[0].length);m[2]=m[2].replace(/\\/g,"");break;}}if(!m)break;if(m[1]==":"&&m[2]=="not")r=isSimple.test(m[3])?jQuery.filter(m[3],r,true).r:jQuery(r).not(m[3]);else if(m[1]==".")r=jQuery.classFilter(r,m[2],not);else if(m[1]=="["){var tmp=[],type=m[3];for(var i=0,rl=r.length;i=0)^not)tmp.push(a);}r=tmp;}else if(m[1]==":"&&m[2]=="nth-child"){var merge={},tmp=[],test=/(-?)(\d*)n((?:\+|-)?\d*)/.exec(m[3]=="even"&&"2n"||m[3]=="odd"&&"2n+1"||!/\D/.test(m[3])&&"0n+"+m[3]||m[3]),first=(test[1]+(test[2]||1))-0,last=test[3]-0;for(var i=0,rl=r.length;i=0)add=true;if(add^not)tmp.push(node);}r=tmp;}else{var fn=jQuery.expr[m[1]];if(typeof fn=="object")fn=fn[m[2]];if(typeof fn=="string")fn=eval("false||function(a,i){return "+fn+";}");r=jQuery.grep(r,function(elem,i){return fn(elem,i,m,r);},not);}}return{r:r,t:t};},dir:function(elem,dir){var matched=[];var cur=elem[dir];while(cur&&cur!=document){if(cur.nodeType==1)matched.push(cur);cur=cur[dir];}return matched;},nth:function(cur,result,dir,elem){result=result||1;var num=0;for(;cur;cur=cur[dir])if(cur.nodeType==1&&++num==result)break;return cur;},sibling:function(n,elem){var r=[];for(;n;n=n.nextSibling){if(n.nodeType==1&&(!elem||n!=elem))r.push(n);}return r;}});jQuery.event={add:function(elem,types,handler,data){if(elem.nodeType==3||elem.nodeType==8)return;if(jQuery.browser.msie&&elem.setInterval!=undefined)elem=window;if(!handler.guid)handler.guid=this.guid++;if(data!=undefined){var fn=handler;handler=function(){return fn.apply(this,arguments);};handler.data=data;handler.guid=fn.guid;}var events=jQuery.data(elem,"events")||jQuery.data(elem,"events",{}),handle=jQuery.data(elem,"handle")||jQuery.data(elem,"handle",function(){var val;if(typeof jQuery=="undefined"||jQuery.event.triggered)return val;val=jQuery.event.handle.apply(arguments.callee.elem,arguments);return val;});handle.elem=elem;jQuery.each(types.split(/\s+/),function(index,type){var parts=type.split(".");type=parts[0];handler.type=parts[1];var handlers=events[type];if(!handlers){handlers=events[type]={};if(!jQuery.event.special[type]||jQuery.event.special[type].setup.call(elem)===false){if(elem.addEventListener)elem.addEventListener(type,handle,false);else if(elem.attachEvent)elem.attachEvent("on"+type,handle);}}handlers[handler.guid]=handler;jQuery.event.global[type]=true;});elem=null;},guid:1,global:{},remove:function(elem,types,handler){if(elem.nodeType==3||elem.nodeType==8)return;var events=jQuery.data(elem,"events"),ret,index;if(events){if(types==undefined||(typeof types=="string"&&types.charAt(0)=="."))for(var type in events)this.remove(elem,type+(types||""));else{if(types.type){handler=types.handler;types=types.type;}jQuery.each(types.split(/\s+/),function(index,type){var parts=type.split(".");type=parts[0];if(events[type]){if(handler)delete events[type][handler.guid];else +for(handler in events[type])if(!parts[1]||events[type][handler].type==parts[1])delete events[type][handler];for(ret in events[type])break;if(!ret){if(!jQuery.event.special[type]||jQuery.event.special[type].teardown.call(elem)===false){if(elem.removeEventListener)elem.removeEventListener(type,jQuery.data(elem,"handle"),false);else if(elem.detachEvent)elem.detachEvent("on"+type,jQuery.data(elem,"handle"));}ret=null;delete events[type];}}});}for(ret in events)break;if(!ret){var handle=jQuery.data(elem,"handle");if(handle)handle.elem=null;jQuery.removeData(elem,"events");jQuery.removeData(elem,"handle");}}},trigger:function(type,data,elem,donative,extra){data=jQuery.makeArray(data||[]);if(type.indexOf("!")>=0){type=type.slice(0,-1);var exclusive=true;}if(!elem){if(this.global[type])jQuery("*").add([window,document]).trigger(type,data);}else{if(elem.nodeType==3||elem.nodeType==8)return undefined;var val,ret,fn=jQuery.isFunction(elem[type]||null),event=!data[0]||!data[0].preventDefault;if(event)data.unshift(this.fix({type:type,target:elem}));data[0].type=type;if(exclusive)data[0].exclusive=true;if(jQuery.isFunction(jQuery.data(elem,"handle")))val=jQuery.data(elem,"handle").apply(elem,data);if(!fn&&elem["on"+type]&&elem["on"+type].apply(elem,data)===false)val=false;if(event)data.shift();if(extra&&jQuery.isFunction(extra)){ret=extra.apply(elem,val==null?data:data.concat(val));if(ret!==undefined)val=ret;}if(fn&&donative!==false&&val!==false&&!(jQuery.nodeName(elem,'a')&&type=="click")){this.triggered=true;try{elem[type]();}catch(e){}}this.triggered=false;}return val;},handle:function(event){var val;event=jQuery.event.fix(event||window.event||{});var parts=event.type.split(".");event.type=parts[0];var handlers=jQuery.data(this,"events")&&jQuery.data(this,"events")[event.type],args=Array.prototype.slice.call(arguments,1);args.unshift(event);for(var j in handlers){var handler=handlers[j];args[0].handler=handler;args[0].data=handler.data;if(!parts[1]&&!event.exclusive||handler.type==parts[1]){var ret=handler.apply(this,args);if(val!==false)val=ret;if(ret===false){event.preventDefault();event.stopPropagation();}}}if(jQuery.browser.msie)event.target=event.preventDefault=event.stopPropagation=event.handler=event.data=null;return val;},fix:function(event){var originalEvent=event;event=jQuery.extend({},originalEvent);event.preventDefault=function(){if(originalEvent.preventDefault)originalEvent.preventDefault();originalEvent.returnValue=false;};event.stopPropagation=function(){if(originalEvent.stopPropagation)originalEvent.stopPropagation();originalEvent.cancelBubble=true;};if(!event.target)event.target=event.srcElement||document;if(event.target.nodeType==3)event.target=originalEvent.target.parentNode;if(!event.relatedTarget&&event.fromElement)event.relatedTarget=event.fromElement==event.target?event.toElement:event.fromElement;if(event.pageX==null&&event.clientX!=null){var doc=document.documentElement,body=document.body;event.pageX=event.clientX+(doc&&doc.scrollLeft||body&&body.scrollLeft||0)-(doc.clientLeft||0);event.pageY=event.clientY+(doc&&doc.scrollTop||body&&body.scrollTop||0)-(doc.clientTop||0);}if(!event.which&&((event.charCode||event.charCode===0)?event.charCode:event.keyCode))event.which=event.charCode||event.keyCode;if(!event.metaKey&&event.ctrlKey)event.metaKey=event.ctrlKey;if(!event.which&&event.button)event.which=(event.button&1?1:(event.button&2?3:(event.button&4?2:0)));return event;},special:{ready:{setup:function(){bindReady();return;},teardown:function(){return;}},mouseenter:{setup:function(){if(jQuery.browser.msie)return false;jQuery(this).bind("mouseover",jQuery.event.special.mouseenter.handler);return true;},teardown:function(){if(jQuery.browser.msie)return false;jQuery(this).unbind("mouseover",jQuery.event.special.mouseenter.handler);return true;},handler:function(event){if(withinElement(event,this))return true;arguments[0].type="mouseenter";return jQuery.event.handle.apply(this,arguments);}},mouseleave:{setup:function(){if(jQuery.browser.msie)return false;jQuery(this).bind("mouseout",jQuery.event.special.mouseleave.handler);return true;},teardown:function(){if(jQuery.browser.msie)return false;jQuery(this).unbind("mouseout",jQuery.event.special.mouseleave.handler);return true;},handler:function(event){if(withinElement(event,this))return true;arguments[0].type="mouseleave";return jQuery.event.handle.apply(this,arguments);}}}};jQuery.fn.extend({bind:function(type,data,fn){return type=="unload"?this.one(type,data,fn):this.each(function(){jQuery.event.add(this,type,fn||data,fn&&data);});},one:function(type,data,fn){return this.each(function(){jQuery.event.add(this,type,function(event){jQuery(this).unbind(event);return(fn||data).apply(this,arguments);},fn&&data);});},unbind:function(type,fn){return this.each(function(){jQuery.event.remove(this,type,fn);});},trigger:function(type,data,fn){return this.each(function(){jQuery.event.trigger(type,data,this,true,fn);});},triggerHandler:function(type,data,fn){if(this[0])return jQuery.event.trigger(type,data,this[0],false,fn);return undefined;},toggle:function(){var args=arguments;return this.click(function(event){this.lastToggle=0==this.lastToggle?1:0;event.preventDefault();return args[this.lastToggle].apply(this,arguments)||false;});},hover:function(fnOver,fnOut){return this.bind('mouseenter',fnOver).bind('mouseleave',fnOut);},ready:function(fn){bindReady();if(jQuery.isReady)fn.call(document,jQuery);else +jQuery.readyList.push(function(){return fn.call(this,jQuery);});return this;}});jQuery.extend({isReady:false,readyList:[],ready:function(){if(!jQuery.isReady){jQuery.isReady=true;if(jQuery.readyList){jQuery.each(jQuery.readyList,function(){this.apply(document);});jQuery.readyList=null;}jQuery(document).triggerHandler("ready");}}});var readyBound=false;function bindReady(){if(readyBound)return;readyBound=true;if(document.addEventListener&&!jQuery.browser.opera)document.addEventListener("DOMContentLoaded",jQuery.ready,false);if(jQuery.browser.msie&&window==top)(function(){if(jQuery.isReady)return;try{document.documentElement.doScroll("left");}catch(error){setTimeout(arguments.callee,0);return;}jQuery.ready();})();if(jQuery.browser.opera)document.addEventListener("DOMContentLoaded",function(){if(jQuery.isReady)return;for(var i=0;i=0){var selector=url.slice(off,url.length);url=url.slice(0,off);}callback=callback||function(){};var type="GET";if(params)if(jQuery.isFunction(params)){callback=params;params=null;}else{params=jQuery.param(params);type="POST";}var self=this;jQuery.ajax({url:url,type:type,dataType:"html",data:params,complete:function(res,status){if(status=="success"||status=="notmodified")self.html(selector?jQuery("
").append(res.responseText.replace(//g,"")).find(selector):res.responseText);self.each(callback,[res.responseText,status,res]);}});return this;},serialize:function(){return jQuery.param(this.serializeArray());},serializeArray:function(){return this.map(function(){return jQuery.nodeName(this,"form")?jQuery.makeArray(this.elements):this;}).filter(function(){return this.name&&!this.disabled&&(this.checked||/select|textarea/i.test(this.nodeName)||/text|hidden|password/i.test(this.type));}).map(function(i,elem){var val=jQuery(this).val();return val==null?null:val.constructor==Array?jQuery.map(val,function(val,i){return{name:elem.name,value:val};}):{name:elem.name,value:val};}).get();}});jQuery.each("ajaxStart,ajaxStop,ajaxComplete,ajaxError,ajaxSuccess,ajaxSend".split(","),function(i,o){jQuery.fn[o]=function(f){return this.bind(o,f);};});var jsc=(new Date).getTime();jQuery.extend({get:function(url,data,callback,type){if(jQuery.isFunction(data)){callback=data;data=null;}return jQuery.ajax({type:"GET",url:url,data:data,success:callback,dataType:type});},getScript:function(url,callback){return jQuery.get(url,null,callback,"script");},getJSON:function(url,data,callback){return jQuery.get(url,data,callback,"json");},post:function(url,data,callback,type){if(jQuery.isFunction(data)){callback=data;data={};}return jQuery.ajax({type:"POST",url:url,data:data,success:callback,dataType:type});},ajaxSetup:function(settings){jQuery.extend(jQuery.ajaxSettings,settings);},ajaxSettings:{global:true,type:"GET",timeout:0,contentType:"application/x-www-form-urlencoded",processData:true,async:true,data:null,username:null,password:null,accepts:{xml:"application/xml, text/xml",html:"text/html",script:"text/javascript, application/javascript",json:"application/json, text/javascript",text:"text/plain",_default:"*/*"}},lastModified:{},ajax:function(s){var jsonp,jsre=/=\?(&|$)/g,status,data;s=jQuery.extend(true,s,jQuery.extend(true,{},jQuery.ajaxSettings,s));if(s.data&&s.processData&&typeof s.data!="string")s.data=jQuery.param(s.data);if(s.dataType=="jsonp"){if(s.type.toLowerCase()=="get"){if(!s.url.match(jsre))s.url+=(s.url.match(/\?/)?"&":"?")+(s.jsonp||"callback")+"=?";}else if(!s.data||!s.data.match(jsre))s.data=(s.data?s.data+"&":"")+(s.jsonp||"callback")+"=?";s.dataType="json";}if(s.dataType=="json"&&(s.data&&s.data.match(jsre)||s.url.match(jsre))){jsonp="jsonp"+jsc++;if(s.data)s.data=(s.data+"").replace(jsre,"="+jsonp+"$1");s.url=s.url.replace(jsre,"="+jsonp+"$1");s.dataType="script";window[jsonp]=function(tmp){data=tmp;success();complete();window[jsonp]=undefined;try{delete window[jsonp];}catch(e){}if(head)head.removeChild(script);};}if(s.dataType=="script"&&s.cache==null)s.cache=false;if(s.cache===false&&s.type.toLowerCase()=="get"){var ts=(new Date()).getTime();var ret=s.url.replace(/(\?|&)_=.*?(&|$)/,"$1_="+ts+"$2");s.url=ret+((ret==s.url)?(s.url.match(/\?/)?"&":"?")+"_="+ts:"");}if(s.data&&s.type.toLowerCase()=="get"){s.url+=(s.url.match(/\?/)?"&":"?")+s.data;s.data=null;}if(s.global&&!jQuery.active++)jQuery.event.trigger("ajaxStart");if((!s.url.indexOf("http")||!s.url.indexOf("//"))&&s.dataType=="script"&&s.type.toLowerCase()=="get"){var head=document.getElementsByTagName("head")[0];var script=document.createElement("script");script.src=s.url;if(s.scriptCharset)script.charset=s.scriptCharset;if(!jsonp){var done=false;script.onload=script.onreadystatechange=function(){if(!done&&(!this.readyState||this.readyState=="loaded"||this.readyState=="complete")){done=true;success();complete();head.removeChild(script);}};}head.appendChild(script);return undefined;}var requestDone=false;var xml=window.ActiveXObject?new ActiveXObject("Microsoft.XMLHTTP"):new XMLHttpRequest();xml.open(s.type,s.url,s.async,s.username,s.password);try{if(s.data)xml.setRequestHeader("Content-Type",s.contentType);if(s.ifModified)xml.setRequestHeader("If-Modified-Since",jQuery.lastModified[s.url]||"Thu, 01 Jan 1970 00:00:00 GMT");xml.setRequestHeader("X-Requested-With","XMLHttpRequest");xml.setRequestHeader("Accept",s.dataType&&s.accepts[s.dataType]?s.accepts[s.dataType]+", */*":s.accepts._default);}catch(e){}if(s.beforeSend)s.beforeSend(xml);if(s.global)jQuery.event.trigger("ajaxSend",[xml,s]);var onreadystatechange=function(isTimeout){if(!requestDone&&xml&&(xml.readyState==4||isTimeout=="timeout")){requestDone=true;if(ival){clearInterval(ival);ival=null;}status=isTimeout=="timeout"&&"timeout"||!jQuery.httpSuccess(xml)&&"error"||s.ifModified&&jQuery.httpNotModified(xml,s.url)&&"notmodified"||"success";if(status=="success"){try{data=jQuery.httpData(xml,s.dataType);}catch(e){status="parsererror";}}if(status=="success"){var modRes;try{modRes=xml.getResponseHeader("Last-Modified");}catch(e){}if(s.ifModified&&modRes)jQuery.lastModified[s.url]=modRes;if(!jsonp)success();}else +jQuery.handleError(s,xml,status);complete();if(s.async)xml=null;}};if(s.async){var ival=setInterval(onreadystatechange,13);if(s.timeout>0)setTimeout(function(){if(xml){xml.abort();if(!requestDone)onreadystatechange("timeout");}},s.timeout);}try{xml.send(s.data);}catch(e){jQuery.handleError(s,xml,null,e);}if(!s.async)onreadystatechange();function success(){if(s.success)s.success(data,status);if(s.global)jQuery.event.trigger("ajaxSuccess",[xml,s]);}function complete(){if(s.complete)s.complete(xml,status);if(s.global)jQuery.event.trigger("ajaxComplete",[xml,s]);if(s.global&&!--jQuery.active)jQuery.event.trigger("ajaxStop");}return xml;},handleError:function(s,xml,status,e){if(s.error)s.error(xml,status,e);if(s.global)jQuery.event.trigger("ajaxError",[xml,s,e]);},active:0,httpSuccess:function(r){try{return!r.status&&location.protocol=="file:"||(r.status>=200&&r.status<300)||r.status==304||r.status==1223||jQuery.browser.safari&&r.status==undefined;}catch(e){}return false;},httpNotModified:function(xml,url){try{var xmlRes=xml.getResponseHeader("Last-Modified");return xml.status==304||xmlRes==jQuery.lastModified[url]||jQuery.browser.safari&&xml.status==undefined;}catch(e){}return false;},httpData:function(r,type){var ct=r.getResponseHeader("content-type");var xml=type=="xml"||!type&&ct&&ct.indexOf("xml")>=0;var data=xml?r.responseXML:r.responseText;if(xml&&data.documentElement.tagName=="parsererror")throw"parsererror";if(type=="script")jQuery.globalEval(data);if(type=="json")data=eval("("+data+")");return data;},param:function(a){var s=[];if(a.constructor==Array||a.jquery)jQuery.each(a,function(){s.push(encodeURIComponent(this.name)+"="+encodeURIComponent(this.value));});else +for(var j in a)if(a[j]&&a[j].constructor==Array)jQuery.each(a[j],function(){s.push(encodeURIComponent(j)+"="+encodeURIComponent(this));});else +s.push(encodeURIComponent(j)+"="+encodeURIComponent(a[j]));return s.join("&").replace(/%20/g,"+");}});jQuery.fn.extend({show:function(speed,callback){return speed?this.animate({height:"show",width:"show",opacity:"show"},speed,callback):this.filter(":hidden").each(function(){this.style.display=this.oldblock||"";if(jQuery.css(this,"display")=="none"){var elem=jQuery("<"+this.tagName+" />").appendTo("body");this.style.display=elem.css("display");if(this.style.display=="none")this.style.display="block";elem.remove();}}).end();},hide:function(speed,callback){return speed?this.animate({height:"hide",width:"hide",opacity:"hide"},speed,callback):this.filter(":visible").each(function(){this.oldblock=this.oldblock||jQuery.css(this,"display");this.style.display="none";}).end();},_toggle:jQuery.fn.toggle,toggle:function(fn,fn2){return jQuery.isFunction(fn)&&jQuery.isFunction(fn2)?this._toggle(fn,fn2):fn?this.animate({height:"toggle",width:"toggle",opacity:"toggle"},fn,fn2):this.each(function(){jQuery(this)[jQuery(this).is(":hidden")?"show":"hide"]();});},slideDown:function(speed,callback){return this.animate({height:"show"},speed,callback);},slideUp:function(speed,callback){return this.animate({height:"hide"},speed,callback);},slideToggle:function(speed,callback){return this.animate({height:"toggle"},speed,callback);},fadeIn:function(speed,callback){return this.animate({opacity:"show"},speed,callback);},fadeOut:function(speed,callback){return this.animate({opacity:"hide"},speed,callback);},fadeTo:function(speed,to,callback){return this.animate({opacity:to},speed,callback);},animate:function(prop,speed,easing,callback){var optall=jQuery.speed(speed,easing,callback);return this[optall.queue===false?"each":"queue"](function(){if(this.nodeType!=1)return false;var opt=jQuery.extend({},optall);var hidden=jQuery(this).is(":hidden"),self=this;for(var p in prop){if(prop[p]=="hide"&&hidden||prop[p]=="show"&&!hidden)return jQuery.isFunction(opt.complete)&&opt.complete.apply(this);if(p=="height"||p=="width"){opt.display=jQuery.css(this,"display");opt.overflow=this.style.overflow;}}if(opt.overflow!=null)this.style.overflow="hidden";opt.curAnim=jQuery.extend({},prop);jQuery.each(prop,function(name,val){var e=new jQuery.fx(self,opt,name);if(/toggle|show|hide/.test(val))e[val=="toggle"?hidden?"show":"hide":val](prop);else{var parts=val.toString().match(/^([+-]=)?([\d+-.]+)(.*)$/),start=e.cur(true)||0;if(parts){var end=parseFloat(parts[2]),unit=parts[3]||"px";if(unit!="px"){self.style[name]=(end||1)+unit;start=((end||1)/e.cur(true))*start;self.style[name]=start+unit;}if(parts[1])end=((parts[1]=="-="?-1:1)*end)+start;e.custom(start,end,unit);}else +e.custom(start,val,"");}});return true;});},queue:function(type,fn){if(jQuery.isFunction(type)||(type&&type.constructor==Array)){fn=type;type="fx";}if(!type||(typeof type=="string"&&!fn))return queue(this[0],type);return this.each(function(){if(fn.constructor==Array)queue(this,type,fn);else{queue(this,type).push(fn);if(queue(this,type).length==1)fn.apply(this);}});},stop:function(clearQueue,gotoEnd){var timers=jQuery.timers;if(clearQueue)this.queue([]);this.each(function(){for(var i=timers.length-1;i>=0;i--)if(timers[i].elem==this){if(gotoEnd)timers[i](true);timers.splice(i,1);}});if(!gotoEnd)this.dequeue();return this;}});var queue=function(elem,type,array){if(!elem)return undefined;type=type||"fx";var q=jQuery.data(elem,type+"queue");if(!q||array)q=jQuery.data(elem,type+"queue",array?jQuery.makeArray(array):[]);return q;};jQuery.fn.dequeue=function(type){type=type||"fx";return this.each(function(){var q=queue(this,type);q.shift();if(q.length)q[0].apply(this);});};jQuery.extend({speed:function(speed,easing,fn){var opt=speed&&speed.constructor==Object?speed:{complete:fn||!fn&&easing||jQuery.isFunction(speed)&&speed,duration:speed,easing:fn&&easing||easing&&easing.constructor!=Function&&easing};opt.duration=(opt.duration&&opt.duration.constructor==Number?opt.duration:{slow:600,fast:200}[opt.duration])||400;opt.old=opt.complete;opt.complete=function(){if(opt.queue!==false)jQuery(this).dequeue();if(jQuery.isFunction(opt.old))opt.old.apply(this);};return opt;},easing:{linear:function(p,n,firstNum,diff){return firstNum+diff*p;},swing:function(p,n,firstNum,diff){return((-Math.cos(p*Math.PI)/2)+0.5)*diff+firstNum;}},timers:[],timerId:null,fx:function(elem,options,prop){this.options=options;this.elem=elem;this.prop=prop;if(!options.orig)options.orig={};}});jQuery.fx.prototype={update:function(){if(this.options.step)this.options.step.apply(this.elem,[this.now,this]);(jQuery.fx.step[this.prop]||jQuery.fx.step._default)(this);if(this.prop=="height"||this.prop=="width")this.elem.style.display="block";},cur:function(force){if(this.elem[this.prop]!=null&&this.elem.style[this.prop]==null)return this.elem[this.prop];var r=parseFloat(jQuery.css(this.elem,this.prop,force));return r&&r>-10000?r:parseFloat(jQuery.curCSS(this.elem,this.prop))||0;},custom:function(from,to,unit){this.startTime=(new Date()).getTime();this.start=from;this.end=to;this.unit=unit||this.unit||"px";this.now=this.start;this.pos=this.state=0;this.update();var self=this;function t(gotoEnd){return self.step(gotoEnd);}t.elem=this.elem;jQuery.timers.push(t);if(jQuery.timerId==null){jQuery.timerId=setInterval(function(){var timers=jQuery.timers;for(var i=0;ithis.options.duration+this.startTime){this.now=this.end;this.pos=this.state=1;this.update();this.options.curAnim[this.prop]=true;var done=true;for(var i in this.options.curAnim)if(this.options.curAnim[i]!==true)done=false;if(done){if(this.options.display!=null){this.elem.style.overflow=this.options.overflow;this.elem.style.display=this.options.display;if(jQuery.css(this.elem,"display")=="none")this.elem.style.display="block";}if(this.options.hide)this.elem.style.display="none";if(this.options.hide||this.options.show)for(var p in this.options.curAnim)jQuery.attr(this.elem.style,p,this.options.orig[p]);}if(done&&jQuery.isFunction(this.options.complete))this.options.complete.apply(this.elem);return false;}else{var n=t-this.startTime;this.state=n/this.options.duration;this.pos=jQuery.easing[this.options.easing||(jQuery.easing.swing?"swing":"linear")](this.state,n,0,1,this.options.duration);this.now=this.start+((this.end-this.start)*this.pos);this.update();}return true;}};jQuery.fx.step={scrollLeft:function(fx){fx.elem.scrollLeft=fx.now;},scrollTop:function(fx){fx.elem.scrollTop=fx.now;},opacity:function(fx){jQuery.attr(fx.elem.style,"opacity",fx.now);},_default:function(fx){fx.elem.style[fx.prop]=fx.now+fx.unit;}};jQuery.fn.offset=function(){var left=0,top=0,elem=this[0],results;if(elem)with(jQuery.browser){var parent=elem.parentNode,offsetChild=elem,offsetParent=elem.offsetParent,doc=elem.ownerDocument,safari2=safari&&parseInt(version)<522&&!/adobeair/i.test(userAgent),fixed=jQuery.css(elem,"position")=="fixed";if(elem.getBoundingClientRect){var box=elem.getBoundingClientRect();add(box.left+Math.max(doc.documentElement.scrollLeft,doc.body.scrollLeft),box.top+Math.max(doc.documentElement.scrollTop,doc.body.scrollTop));add(-doc.documentElement.clientLeft,-doc.documentElement.clientTop);}else{add(elem.offsetLeft,elem.offsetTop);while(offsetParent){add(offsetParent.offsetLeft,offsetParent.offsetTop);if(mozilla&&!/^t(able|d|h)$/i.test(offsetParent.tagName)||safari&&!safari2)border(offsetParent);if(!fixed&&jQuery.css(offsetParent,"position")=="fixed")fixed=true;offsetChild=/^body$/i.test(offsetParent.tagName)?offsetChild:offsetParent;offsetParent=offsetParent.offsetParent;}while(parent&&parent.tagName&&!/^body|html$/i.test(parent.tagName)){if(!/^inline|table.*$/i.test(jQuery.css(parent,"display")))add(-parent.scrollLeft,-parent.scrollTop);if(mozilla&&jQuery.css(parent,"overflow")!="visible")border(parent);parent=parent.parentNode;}if((safari2&&(fixed||jQuery.css(offsetChild,"position")=="absolute"))||(mozilla&&jQuery.css(offsetChild,"position")!="absolute"))add(-doc.body.offsetLeft,-doc.body.offsetTop);if(fixed)add(Math.max(doc.documentElement.scrollLeft,doc.body.scrollLeft),Math.max(doc.documentElement.scrollTop,doc.body.scrollTop));}results={top:top,left:left};}function border(elem){add(jQuery.curCSS(elem,"borderLeftWidth",true),jQuery.curCSS(elem,"borderTopWidth",true));}function add(l,t){left+=parseInt(l)||0;top+=parseInt(t)||0;}return results;};})(); \ No newline at end of file diff --git a/extra/tangle/resources/weave.html b/extra/tangle/resources/weave.html new file mode 100644 index 0000000000..6f9296e31f --- /dev/null +++ b/extra/tangle/resources/weave.html @@ -0,0 +1,18 @@ + + + + + + + + + +
+ + +
+ + + diff --git a/extra/tangle/resources/weave.js b/extra/tangle/resources/weave.js new file mode 100644 index 0000000000..2b36982451 --- /dev/null +++ b/extra/tangle/resources/weave.js @@ -0,0 +1,27 @@ +$(function() { $.getJSON("/all", false, function(json) { + var nodes = $('#nodes'); + for (node in json) { + nodes.append(""); + } + nodes.change(function(){ + if (this.value == 'new') { + $('#node-content').hide(); + $('#edit-wrapper').show(); + } else { + $('#node-content').show(); + $('#edit-wrapper').hide(); + $.get('/node', { node_id: this.value }, function(data){ + $('#node-content').text(data); + }); + } + }); + $('#node-submit').click(function(){ + $.post('/node', { node_content: $('#node-content-edit').val() }, function(data){ + nodes.append(""); + var option = nodes.get(0).options[data]; + option.selected = true; + nodes.change(); + }); + return false; + }); +});}) diff --git a/extra/tangle/sandbox/sandbox.factor b/extra/tangle/sandbox/sandbox.factor new file mode 100644 index 0000000000..b6e110ada5 --- /dev/null +++ b/extra/tangle/sandbox/sandbox.factor @@ -0,0 +1,18 @@ +USING: continuations db db.sqlite http.server io.files kernel namespaces semantic-db tangle tangle.path ; +IN: tangle.sandbox + +: db-path "tangle-sandbox.db" temp-file ; +: sandbox-db db-path sqlite-db ; +: delete-db [ db-path delete-file ] ignore-errors ; + +: make-sandbox ( tangle -- ) + [ + init-semantic-db + ensure-root "foo" create-file "First Page" create-node swap has-filename + ] with-tangle ; + +: new-sandbox ( -- ) + development-mode on + delete-db sandbox-db f + [ make-sandbox ] [ ] bi + main-responder set ; diff --git a/extra/tangle/summary.txt b/extra/tangle/summary.txt new file mode 100644 index 0000000000..26f0a3e9af --- /dev/null +++ b/extra/tangle/summary.txt @@ -0,0 +1 @@ +A web framework using semantic-db as a backend diff --git a/extra/tangle/tangle-tests.factor b/extra/tangle/tangle-tests.factor new file mode 100644 index 0000000000..c7e9f2d79a --- /dev/null +++ b/extra/tangle/tangle-tests.factor @@ -0,0 +1,26 @@ +USING: accessors arrays continuations db db.sqlite io.files kernel semantic-db sequences tangle tangle.html tangle.menu tangle.page tangle.path tools.test tools.walker tuple-syntax ; +IN: tangle.tests + +: db-path "tangle-test.db" temp-file ; +: test-db db-path sqlite-db ; +: delete-db [ db-path delete-file ] ignore-errors ; + +: test-tangle ( -- ) + ensure-root "foo" create-file "bar" create-file "pluck_eggs" create-file + "How to Pluck Eggs" create-node swap has-filename + "Main Menu" ensure-menu "home" create-node swap subitem-of ; + +test-db [ + init-semantic-db test-tangle + [ "pluck_eggs" ] [ { "foo" "bar" "pluck_eggs" } path>node [ node-content ] when* ] unit-test + [ "How to Pluck Eggs" ] [ { "foo" "bar" "pluck_eggs" } path>node [ has-filename-subjects first node-content ] when* ] unit-test + [ { "foo" "bar" "pluck_eggs" } ] [ { "foo" "bar" "pluck_eggs" } path>node node>path >array ] unit-test + [ f ] [ TUPLE{ node id: 666 content: "some content" } parent-directory ] unit-test + [ f ] [ TUPLE{ node id: 666 content: "some content" } node>path ] unit-test + [ "Main Menu" ] [ "Main Menu" ensure-menu node-content ] unit-test + [ t ] [ "Main Menu" ensure-menu "Main Menu" ensure-menu node= ] unit-test + [ "Main Menu" { "home" } ] [ "Main Menu" load-menu dup node>> node-content swap children>> [ node>> node-content ] map >array ] unit-test + [ { "home" } ] [ "Main Menu" load-menu menu>ulist items>> [ node>> node-content ] map >array ] unit-test + [ f ] [ TUPLE{ node id: 666 content: "node text" } node>path ] unit-test + [ "node text" ] [ TUPLE{ node id: 666 content: "node text" } >html ] unit-test +] with-db delete-db diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor new file mode 100644 index 0000000000..afaf3da3cd --- /dev/null +++ b/extra/tangle/tangle.factor @@ -0,0 +1,75 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ; +IN: tangle + +GENERIC: render* ( content templater -- output ) +GENERIC: render ( content templater -- ) + +TUPLE: echo-template ; +C: echo-template + +M: echo-template render* drop ; +! METHOD: render* { string echo-template } drop ; +M: object render render* write ; + +TUPLE: tangle db seq templater ; +C: tangle + +: with-tangle ( tangle quot -- ) + [ [ db>> ] [ seq>> ] bi ] dip with-db ; + +: ( text -- response ) + "text/plain" swap >>body ; + +: node-response ( id -- response ) + load-node [ node-content ] [ <404> ] if* ; + +: display-node ( params -- response ) + [ + "node_id" swap at* [ + string>number node-response + ] [ + drop <400> + ] if + ] [ + <400> + ] if* ; + +: submit-node ( params -- response ) + [ + "node_content" swap at* [ + create-node id>> number>string + ] [ + drop <400> + ] if + ] [ + <400> + ] if* ; + +: ( -- responder ) + [ params get display-node ] >>display + [ params get submit-node ] >>submit ; + +TUPLE: path-responder ; +C: path-responder + +M: path-responder call-responder* ( path responder -- response ) + drop path>file [ node-content ] [ <404> ] if* ; + +: ( obj -- response ) + "application/json" swap >json >>body ; + +TUPLE: tangle-dispatcher < dispatcher tangle ; + +: ( tangle -- dispatcher ) + tangle-dispatcher new-dispatcher swap >>tangle + >>default + "extra/tangle/resources" resource-path "resources" add-responder + "node" add-responder + [ all-node-ids ] >>display "all" add-responder ; + +M: tangle-dispatcher call-responder* ( path dispatcher -- response ) + dup tangle>> [ + find-responder call-responder + ] with-tangle ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index f95b83467a..1ad9957cc9 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -144,7 +144,8 @@ IN: tools.deploy.shaker classes:class-and-cache classes:class-not-cache classes:class-or-cache - classes:class<-cache + classes:class<=-cache + classes:class<=>-cache classes:classes-intersect-cache classes:update-map command-line:main-vocab-hook diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index e265f233e3..effa17c179 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -3,8 +3,8 @@ USING: io.files kernel io.encodings.utf8 vocabs.loader vocabs sequences namespaces math.parser arrays hashtables assocs memoize inspector sorting splitting combinators source-files -io debugger continuations compiler.errors init io.crc32 -sets ; +io debugger continuations compiler.errors init +checksums checksums.crc32 sets ; IN: tools.vocabs : vocab-tests-file ( vocab -- path ) @@ -63,7 +63,7 @@ SYMBOL: failures dup source-files get at [ dup source-file-path dup exists? [ - utf8 file-lines lines-crc32 + utf8 file-lines crc32 checksum-lines swap source-file-checksum = not ] [ 2drop f diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 5ab997470a..d8e4f8c24e 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -1,6 +1,6 @@ USING: unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces -math.ranges unicode.normalize +math.ranges unicode.normalize unicode.syntax.backend unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ; IN: unicode.breaks diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 5e1d30d529..85ce50acb9 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,17 +1,9 @@ USING: assocs math kernel sequences io.files hashtables quotations splitting arrays math.parser hash2 math.order byte-arrays words namespaces words compiler.units parser -io.encodings.ascii ; +io.encodings.ascii unicode.syntax.backend ; IN: unicode.data -<< -: VALUE: - CREATE-WORD { f } clone [ first ] curry define ; parsing - -: set-value ( value word -- ) - word-def first set-first ; ->> - ! Convenience functions : ?between? ( n/f from to -- ? ) pick [ between? ] [ 3drop f ] if ; diff --git a/extra/unicode/syntax/backend/backend.factor b/extra/unicode/syntax/backend/backend.factor new file mode 100644 index 0000000000..5c463e8fc4 --- /dev/null +++ b/extra/unicode/syntax/backend/backend.factor @@ -0,0 +1,8 @@ +USING: kernel parser sequences words ; +IN: unicode.syntax.backend + +: VALUE: + CREATE-WORD { f } clone [ first ] curry define ; parsing + +: set-value ( value word -- ) + word-def first set-first ; diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 37b4c8e5e1..3cc1eb567b 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,5 +1,6 @@ USING: math kernel accessors http.server http.server.actions -http.server.sessions http.server.templating.fhtml locals ; +http.server.sessions http.server.templating +http.server.templating.fhtml locals ; IN: webapps.counter SYMBOL: count @@ -15,11 +16,11 @@ M: counter-app init-session* "" f ] >>display ; +: counter-template ( -- template ) + "resource:extra/webapps/counter/counter.fhtml" ; + : ( -- action ) - [ - "text/html" - "resource:extra/webapps/counter/counter.fhtml" >>body - ] >>display ; + [ counter-template serve-template ] >>display ; : ( -- responder ) counter-app new-dispatcher diff --git a/extra/webapps/factor-website/page.css b/extra/webapps/factor-website/page.css new file mode 100644 index 0000000000..9846e7b20c --- /dev/null +++ b/extra/webapps/factor-website/page.css @@ -0,0 +1,48 @@ +body, button { + font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; + color:#444; +} + +.link-button { + padding: 0px; + background: none; + border: none; +} + +a, .link { + color: #222; + border-bottom:1px dotted #666; + text-decoration:none; +} + +a:hover, .link:hover { + border-bottom:1px solid #66a; +} + +.error { color: #a00; } + +.field-label { + text-align: right; +} + +.inline { + display: inline; +} + +.navbar { + background-color: #eee; + padding: 5px; + border: 1px solid #ccc; +} + +.big-field-label { + vertical-align: top; +} + +.description { + border: 1px dashed #ccc; + background-color: #f5f5f5; + padding: 5px; + font-size: 150%; + color: #000000; +} diff --git a/extra/webapps/factor-website/page.xml b/extra/webapps/factor-website/page.xml index 3e2f43845a..f7080643b4 100644 --- a/extra/webapps/factor-website/page.xml +++ b/extra/webapps/factor-website/page.xml @@ -12,56 +12,7 @@ - - body, button { - font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif; - color:#444; - } - - .link-button { - padding: 0px; - background: none; - border: none; - } - - a, .link { - color: #222; - border-bottom:1px dotted #666; - text-decoration:none; - } - - a:hover, .link:hover { - border-bottom:1px solid #66a; - } - - .error { color: #a00; } - - .field-label { - text-align: right; - } - - .inline { - display: inline; - } - - .navbar { - background-color: #eee; - padding: 5px; - border: 1px solid #ccc; - } - - .big-field-label { - vertical-align: top; - } - - .description { - border: 1px dashed #ccc; - background-color: #f5f5f5; - padding: 5px; - font-size: 150%; - color: #000000; - } - + diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 76e7a1464a..144900d6ec 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -8,6 +8,7 @@ http.server.actions http.server.components http.server.components.code http.server.templating.chloe +http.server.auth http.server.auth.login http.server.boilerplate http.server.validators @@ -236,13 +237,17 @@ annotation "ANNOTATION" TUPLE: pastebin < dispatcher ; +SYMBOL: can-delete-pastes? + +can-delete-pastes? define-capability + : ( -- responder ) pastebin new-dispatcher "list" add-main-responder "feed.xml" add-responder [ ] "view-paste" add-responder - [ ] "$pastebin/list" "delete-paste" add-responder - [ ] "$pastebin/view-paste" "delete-annotation" add-responder + [ ] "$pastebin/list" { can-delete-pastes? } "delete-paste" add-responder + [ ] "$pastebin/view-paste" { can-delete-pastes? } "delete-annotation" add-responder [ ] "$pastebin/view-paste" add-responder [ now >>date ] "$pastebin/view-paste" "new-paste" add-responder [ now >>date ] "$pastebin/view-paste" "annotate" add-responder diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index d3260e1c70..c8aeab35a8 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -11,7 +11,8 @@ http.server.actions http.server.boilerplate http.server.templating.chloe http.server.components -http.server.auth.login ; +http.server.auth.login +http.server.auth ; IN: webapps.planet TUPLE: planet-factor < dispatcher postings ; @@ -159,11 +160,15 @@ blog "BLOGS" blog-form blog-ctor "$planet-factor/admin" "edit-blog" add-responder ] ; +SYMBOL: can-administer-planet-factor? + +can-administer-planet-factor? define-capability + : ( -- responder ) planet-factor new-dispatcher dup "list" add-main-responder dup "feed.xml" add-responder - dup "admin" add-responder + dup { can-administer-planet-factor? } "admin" add-responder "planet" planet-template >>template ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index abdc535274..7f2b034366 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -2,10 +2,7 @@ - - - - +
Front Page diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml index ef1e1fd26a..9b7e9e667a 100644 --- a/extra/webapps/todo/edit-todo.xml +++ b/extra/webapps/todo/edit-todo.xml @@ -4,22 +4,22 @@ Edit Item - - + + - - - + + +
Summary:
Priority:
Description:
Summary:
Priority:
Description:
 - View + View | - - + + diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index e1ebc65bb5..8bfda1aad5 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -76,5 +76,5 @@ TUPLE: todo-list < dispatcher ; ctor "$todo-list/list" "delete" add-responder "todo" todo-template >>template - + f ] ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index ff58b27df2..3e6d3cfd44 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -2,7 +2,7 @@ - +
List Items diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml index f77396c73c..1bd73f48e1 100644 --- a/extra/webapps/todo/view-todo.xml +++ b/extra/webapps/todo/view-todo.xml @@ -5,8 +5,8 @@ View Item - - + +
Summary:
Priority:
Summary:
Priority:
diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor index 5fabe2b17d..7b2bdd992a 100755 --- a/extra/xmode/code2html/responder/responder.factor +++ b/extra/xmode/code2html/responder/responder.factor @@ -9,7 +9,7 @@ IN: xmode.code2html.responder [ drop "text/html" swap - [ file-http-date "last-modified" set-header ] + [ "last-modified" set-header ] [ '[ , diff --git a/misc/factor.vim b/misc/factor.vim index 93ce3d6bd5..d1c46cee0b 100644 --- a/misc/factor.vim +++ b/misc/factor.vim @@ -1,7 +1,7 @@ " Vim syntax file " Language: factor " Maintainer: Alex Chapman -" Last Change: 2007 Jan 18 +" Last Change: 2008 Apr 28 " For version 5.x: Clear all syntax items " For version 6.x: Quit when a syntax file was already loaded @@ -48,17 +48,17 @@ syn keyword factorCompileDirective inline foldable parsing " kernel vocab keywords -syn keyword factorKeyword or construct-delegate set-slots tuck while wrapper nip hashcode wrapper? both? callstack>array die dupd set-delegate callstack callstack? 3dup pick curry build >boolean ?if clone eq? = ? swapd call-clear 2over 2keep 3keep construct general-t clear 2dup when not tuple? 3compose dup call object wrapped unless* if* 2apply >r curry-quot drop when* retainstack -rot delegate with 3slip construct-boa slip compose-first compose-second 3drop construct-empty either? curry? datastack compare curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if <=> unless compose? tuple keep 2curry object? equal? set-datastack 2slip 2drop most null r> set-callstack dip xor rot -roll -syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc union search-alist assoc-like key? update at* assoc-empty? at+ set-at assoc-all? assoc-hashcode intersect change-at assoc-each assoc-subset values rename-at value-at (assoc-stack) at cache assoc>map assoc-contains? assoc assoc-map assoc-pusher diff (assoc>map) assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute delete-at assoc-find keys -syn keyword factorKeyword case dispatch-case-quot with-datastack alist>quot dispatch-case hash-case-table hash-case-quot no-cond no-case? cond distribute-buckets (distribute-buckets) contiguous-range? cond>quot no-cond? no-case recursive-hashcode linear-case-quot hash-dispatch-quot case>quot -syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 before? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? after? fixnum before=? bignum sq neg denominator [-] (all-integers?) times find-last-integer (each-integer) bit? * + - / >= bitand find-integer complex < real > log2 integer? max number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift between? float 1+ 1- min fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator after=? /f -syn keyword factorKeyword slice-to append left-trim clone-like 3sequence set-column-seq map-as reversed pad-left cut* nth sequence slice? tail-slice empty? tail* member? unclip virtual-sequence? set-length last-index* drop-prefix bounds-error? set-slice-seq set-column-col seq-diff map start open-slice midpoint@ add* set-immutable-seq move-forward fourth delete set-slice-to all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) column? reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice index* move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right concat find* set-slice-from flip sum find-last* immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice column-seq sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find column remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth second change-each join set-repetition-len all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index seq-intersect push-if 2all? lengthen column-col joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first bounds-error add bounds-error-seq bounds-error-index unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice sum-lengths new 2each head* infimum subset slice-error subseq replace-slice repetition push trim sequence-hashcode mismatch +syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple +syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-contains? assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys +syn keyword factorKeyword case dispatch-case-quot with-datastack no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot +syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f +syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth second change-each join set-repetition-len all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc syn keyword factorKeyword 3array >array 4array pair? array pair 2array 1array resize-array array? syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln syn keyword factorKeyword resize-string >string 1string string string? syn keyword factorKeyword vector? ?push vector >vector 1vector -syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation ifcc continuation-name set-restart-continuation ignore-errors continuation-retain continue restart-continuation with-disposal set-continuation-catch restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts +syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation ifcc continuation-name condition-error set-restart-continuation ignore-errors continuation-retain continue restart-continuation with-disposal set-continuation-catch set-condition-error restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal diff --git a/misc/factor.vim.fgen b/misc/factor.vim.fgen index 7bcba78cde..b0d61b8dd0 100644 --- a/misc/factor.vim.fgen +++ b/misc/factor.vim.fgen @@ -2,7 +2,7 @@ %>" Vim syntax file " Language: factor " Maintainer: Alex Chapman -" Last Change: 2007 Jan 18 +" Last Change: 2008 Apr 28 " For version 5.x: Clear all syntax items " For version 6.x: Quit when a syntax file was already loaded