diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 72feca27cd..5f7b9fff21 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,7 +1,7 @@ IN: alien.tests USING: alien alien.accessors byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math system -prettyprint ; +prettyprint layouts ; [ t ] [ -1 alien-address 0 > ] unit-test diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index 1fd8cafdcf..fe6873ac3a 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -84,11 +84,11 @@ HELP: alien>u16-string ( c-ptr -- string ) { $values { "c-ptr" c-ptr } { "string" string } } { $description "Reads a null-terminated UCS-2 string from the specified address." } ; -HELP: memory>byte-array ( base len -- string ) -{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } +HELP: memory>byte-array +{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; -HELP: byte-array>memory ( string base -- ) +HELP: byte-array>memory { $values { "byte-array" byte-array } { "base" c-ptr } } { $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." } { $warning "This word is unsafe. Improper use can corrupt memory." } ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 91089a8278..c3f5c64b29 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: bit-arrays byte-arrays float-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations -system compiler.units io.files io.encodings.binary ; +layouts system compiler.units io.files io.encodings.binary ; IN: alien.c-types DEFER: diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index baab72036d..fb7d50e882 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -6,7 +6,7 @@ inference.state inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs alien.syntax cpu.architecture alien inspector quotations assocs kernel.private threads continuations.private libc combinators -compiler.errors continuations ; +compiler.errors continuations layouts ; IN: alien.compiler ! Common protocol for alien-invoke/alien-callback/alien-indirect diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 716ac64c9b..b6326e1c10 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -162,6 +162,7 @@ HELP: assoc-each { $description "Applies a quotation to each entry in the assoc." } { $examples { $example + "USING: assocs kernel math prettyprint ;" "H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }" "0 swap [ nip + ] assoc-each ." "64" diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 241511c00d..f5f4d70d14 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -191,7 +191,9 @@ M: bignum ' M: fixnum ' #! When generating a 32-bit image on a 64-bit system, #! some fixnums should be bignums. - dup most-negative-fixnum most-positive-fixnum between? + dup + bootstrap-most-negative-fixnum + bootstrap-most-positive-fixnum between? [ tag-fixnum ] [ >bignum ' ] if ; ! Floats diff --git a/core/boxes/boxes-docs.factor b/core/boxes/boxes-docs.factor index b3b91d06d9..3b8caaca1b 100755 --- a/core/boxes/boxes-docs.factor +++ b/core/boxes/boxes-docs.factor @@ -19,7 +19,7 @@ HELP: box> { $errors "Throws an error if the box is empty." } ; HELP: ?box -{ $values { "box" box } { "value" "the value of the box or " { $link f } } { "?" "a boolean" } } +{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" "a boolean" } } { $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ; ARTICLE: "boxes" "Boxes" diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index 0acf06c0c1..6a08f657a2 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -6,7 +6,7 @@ IN: byte-vectors vector ( byte-array capacity -- byte-vector ) +: byte-array>vector ( byte-array length -- byte-vector ) byte-vector construct-boa ; inline PRIVATE> diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 56dda6f904..df97a3eff5 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -1,4 +1,4 @@ -USING: generic help.markup help.syntax kernel kernel.private +USING: help.markup help.syntax kernel kernel.private namespaces sequences words arrays layouts help effects math layouts classes.private classes.union classes.mixin classes.predicate ; @@ -7,11 +7,6 @@ IN: classes ARTICLE: "builtin-classes" "Built-in classes" "Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior." $nl -"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:" -{ $subsection type } -"Built-in type numbers can be converted to classes, and vice versa:" -{ $subsection type>class } -{ $subsection type-number } "The set of built-in classes is a class:" { $subsection builtin-class } { $subsection builtin-class? } @@ -79,7 +74,7 @@ HELP: class { $values { "object" object } { "class" class } } { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." } { $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." } -{ $examples { $example "USE: classes" "1.0 class ." "float" } { $example "USE: classes" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ; +{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ; HELP: classes { $values { "seq" "a sequence of class words" } } @@ -89,14 +84,14 @@ HELP: builtin-class { $class-description "The class of built-in classes." } { $examples "The class of arrays is a built-in class:" - { $example "USE: classes" "array builtin-class? ." "t" } - "However, a literal array is not a built-in class; it is not even a class:" - { $example "USE: classes" "{ 1 2 3 } builtin-class? ." "f" } + { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" } + "However, an instance of the array class is not a built-in class; it is not even a class:" + { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" } } ; HELP: tuple-class { $class-description "The class of tuple class words." } -{ $examples { $example "USE: classes\nTUPLE: name title first last ;\nname tuple-class? ." "t" } } ; +{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; HELP: typemap { $var-description "Hashtable mapping unions to class words, used to implement " { $link class-and } " and " { $link class-or } "." } ; @@ -167,7 +162,7 @@ HELP: types HELP: class-empty? { $values { "class" "a class" } { "?" "a boolean" } } { $description "Tests if a class is a union class with no members." } -{ $examples { $example "USE: classes" "null class-empty? ." "t" } } ; +{ $examples { $example "USING: classes kernel prettyprint ;" "null class-empty? ." "t" } } ; HELP: (class<) { $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } } @@ -182,8 +177,6 @@ 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." } ; -{ sort-classes methods order } related-words - HELP: lookup-union { $values { "classes" "a hashtable mapping class words to themselves" } { "class" class } } { $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." } ; diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 5b87297b0c..f5d4470bde 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -82,7 +82,7 @@ HELP: with-datastack { $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } { $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $examples - { $example "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } + { $example "USING: combinators math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; HELP: recursive-hashcode diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor index 678face309..dd71eb704f 100755 --- a/core/compiler/errors/errors-docs.factor +++ b/core/compiler/errors/errors-docs.factor @@ -9,7 +9,7 @@ ARTICLE: "compiler-errors" "Compiler warnings and errors" { $subsection :errors } { $subsection :warnings } { $subsection :linkage } -"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:" +"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:" { $link with-compiler-errors } ; HELP: compiler-errors @@ -24,8 +24,8 @@ HELP: compiler-error. { $description "Prints a compiler error to the " { $link stdio } " stream." } ; HELP: compiler-errors. -{ $values { "errors" "an assoc mapping words to errors" } } -{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ; +{ $values { "type" symbol } } +{ $description "Prints compiler errors to the " { $link stdio } " stream. The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ; HELP: :errors { $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ; diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index d30c5457d5..74dac17be8 100755 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -63,7 +63,7 @@ HELP: modify-code-heap ( alist -- ) { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; HELP: compile -{ $values { "seq" "a sequence of words" } } +{ $values { "words" "a sequence of words" } } { $description "Compiles a set of words." } ; HELP: compile-call diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 9a26dbc67e..81063031f9 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -150,7 +150,7 @@ HELP: recover { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; HELP: ignore-errors -{ $values { "try" quotation } } +{ $values { "quot" quotation } } { $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; HELP: rethrow diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 649cfbabab..19b913541c 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -3,7 +3,7 @@ USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences -generator.registers generator.fixup generator system +generator.registers generator.fixup generator system layouts alien.compiler combinators command-line compiler compiler.units io vocabs.loader ; IN: cpu.x86.32 diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 2996a3feeb..25e32225d4 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup system -alien alien.accessors alien.compiler alien.structs slots +layouts alien alien.accessors alien.compiler alien.structs slots splitting assocs ; IN: cpu.x86.64 diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 2d7ffb762d..65caec412e 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator.fixup io.binary kernel combinators kernel.private math namespaces parser sequences -words system ; +words system layouts ; IN: cpu.x86.assembler ! A postfix assembler for x86 and AMD64. diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index f473eb58c8..9e37ba4c85 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -58,7 +58,7 @@ HELP: effect>string { $values { "effect" effect } { "string" string } } { $description "Turns a stack effect object into a string mnemonic." } { $examples - { $example "USE: effects" "1 2 effect>string print" "( object -- object object )" } + { $example "USING: effects io ;" "1 2 effect>string print" "( object -- object object )" } } ; HELP: stack-effect diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 3ee93ba4a5..7581377a6a 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs hashtables kernel kernel.private math namespaces sequences words -quotations strings alien system combinators math.bitfields -words.private cpu.architecture ; +quotations strings alien layouts system combinators +math.bitfields words.private cpu.architecture ; IN: generator.fixup : no-stack-frame -1 ; inline diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index 4473df7277..432a2a0008 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -57,7 +57,7 @@ HELP: generate { $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ; HELP: word-dataflow -{ $values { "word" word } { "effect" effect } { "dependencies" sequence } { "dataflow" "a dataflow graph" } } +{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } } { $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ; HELP: define-intrinsics diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index b2fba47d3a..9b799d9143 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -1,6 +1,6 @@ -USING: help.markup help.syntax generic.math generic.standard -words classes definitions kernel alien combinators sequences -math quotations ; +USING: help.markup help.syntax words classes definitions kernel +alien sequences math quotations generic.standard generic.math +combinators ; IN: generic ARTICLE: "method-order" "Method precedence" @@ -33,8 +33,6 @@ $nl "New generic words can be defined:" { $subsection define-generic } { $subsection define-simple-generic } -"Methods are tuples:" -{ $subsection } "Methods can be added to existing generic words:" { $subsection define-method } "Method definitions can be looked up:" @@ -42,8 +40,10 @@ $nl { $subsection methods } "A generic word contains methods; the list of methods specializing on a class can also be obtained:" { $subsection implementors } -"Low-level words which rebuilds the generic word after methods are added or removed, or the method combination is changed:" +"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:" { $subsection make-generic } +"Low-level method constructor:" +{ $subsection } "A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":" { $subsection method-spec } ; @@ -126,7 +126,7 @@ HELP: method { method define-method POSTPONE: M: } related-words HELP: -{ $values { "def" "a quotation" } { "method" "a new method definition" } } +{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } } { $description "Creates a new method." } ; HELP: methods @@ -148,7 +148,7 @@ HELP: with-methods $low-level-note ; HELP: define-method -{ $values { "method" quotation } { "class" class } { "generic" generic } } +{ $values { "quot" quotation } { "class" class } { "generic" generic } } { $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ; HELP: implementors @@ -158,3 +158,5 @@ HELP: implementors HELP: forget-methods { $values { "class" class } } { $description "Remove all method definitions which specialize on the class." } ; + +{ sort-classes methods order } related-words diff --git a/core/generic/generic.factor b/core/generic/generic.factor index f73579661d..3c83b87d49 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -74,7 +74,7 @@ M: method-body stack-effect "method-def" set ] H{ } make-assoc ; -: ( quot class generic -- word ) +: ( quot class generic -- method ) check-method [ make-method-def ] 3keep [ method-word-props ] 2keep diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor index b1148bb34e..cbbf070398 100644 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -1,26 +1,27 @@ USING: kernel generic help.markup help.syntax math classes -generic.math ; +sequences quotations ; +IN: generic.math HELP: math-upgrade -{ $values { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } } +{ $values { "class1" class } { "class2" class } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } } { $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." } -{ $examples { $example "USE: generic.math" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ; +{ $examples { $example "USING: generic.math math kernel prettyprint ;" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ; HELP: no-math-method -{ $values { "left" "an object" } { "right" "an object" } { "generic" "a generic word" } } +{ $values { "left" "an object" } { "right" "an object" } { "generic" generic } } { $description "Throws a " { $link no-math-method } " error." } { $error-description "Thrown by generic words using the " { $link math-combination } " method combination if there is no suitable method defined for the two inputs." } ; HELP: math-method -{ $values { "word" "a generic word" } { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation" } } +{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } } { $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." } -{ $examples { $example "USE: generic.math" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ; +{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ; HELP: math-class { $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ; HELP: math-combination -{ $values { "word" "a generic word" } { "quot" "a quotation" } } +{ $values { "word" generic } { "quot" quotation } } { $description "Generates a double-dispatching word definition. Only methods defined on numerical classes and " { $link object } " take effect in the math combination. Methods defined on numerical classes are guaranteed to have their two inputs upgraded to the highest priority type of the two." $nl "The math method combination is used for binary operators such as " { $link + } " and " { $link * } "." @@ -40,5 +41,5 @@ HELP: math-generic { $class-description "The class of generic words using " { $link math-combination } "." } ; HELP: last/first -{ $values { "seq" "a sequence" } { "pair" "a two-element array" } } +{ $values { "seq" sequence } { "pair" "a two-element array" } } { $description "Creates an array holding the first and last element of the sequence." } ; diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index 820a027d10..a6a65bb62f 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,5 +1,5 @@ -USING: generic help.markup help.syntax sequences -generic.standard ; +USING: generic help.markup help.syntax sequences ; +IN: generic.standard HELP: no-method { $values { "object" "an object" } { "generic" "a generic word" } } diff --git a/core/growable/growable-docs.factor b/core/growable/growable-docs.factor index 02f6292001..9de3c8ab24 100755 --- a/core/growable/growable-docs.factor +++ b/core/growable/growable-docs.factor @@ -18,19 +18,19 @@ $nl ABOUT: "growable" HELP: set-fill -{ $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } } +{ $values { "n" "a new fill pointer" } { "seq" growable } } { $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." } { $side-effects "seq" } -{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; +{ $warning "This word is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; HELP: underlying -{ $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } } +{ $values { "seq" growable } { "underlying" "the underlying sequence" } } { $contract "Outputs the underlying storage of a resizable sequence." } ; HELP: set-underlying -{ $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } } +{ $values { "underlying" sequence } { "seq" growable } } { $contract "Modifies the underlying storage of a resizable sequence." } -{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; +{ $warning "This word is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; HELP: capacity { $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } } @@ -41,7 +41,7 @@ HELP: new-size { $description "Computes the new size of a resizable sequence." } ; HELP: ensure -{ $values { "n" "a positive integer" } { "seq" "a resizable sequence" } } +{ $values { "n" "a positive integer" } { "seq" growable } } { $description "If " { $snippet "n" } " is less than the length of the sequence, does nothing. Otherwise, if " { $snippet "n" } " also exceeds the capacity of the underlying storage, the underlying storage is grown, and the fill pointer is reset. Finally, if " { $snippet "n" } " is greater than or equal to the length but less than the capacity of the underlying storage, the fill pointer is moved and nothing else is done." $nl "This word is used in the implementation of the " { $link set-nth } " generic for sequences supporting the resizable sequence protocol (see " { $link "growable" } ")." diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index 563a59d20f..d62afdffb5 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -128,14 +128,14 @@ HELP: prune { $values { "seq" "a sequence" } { "newseq" "a sequence" } } { $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." } { $examples - { $example "USE: hashtables" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" } + { $example "USING: hashtables prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" } } ; HELP: all-unique? { $values { "seq" sequence } { "?" "a boolean" } } { $description "Tests whether a sequence contains any repeated elements." } { $example - "USE: combinators.lib" + "USING: hashtables prettyprint ;" "{ 0 1 1 2 3 5 } all-unique? ." "f" } ; diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index 1c641662a9..f9224eafeb 100755 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -77,6 +77,7 @@ HELP: heap-size { $description "Returns the number of key/value pairs in the heap." } ; HELP: heap-delete -{ $values { "heap" "a heap" } { "key" object } { "value" object } } -{ $description "Output and remove the first element in the heap." } +{ $values { "entry" entry } { "heap" "a heap" } } +{ $description "Remove the specified entry from the heap." } +{ $errors "Throws an error if the entry is from another heap or if it has already been deleted." } { $side-effects "heap" } ; diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index df90ac2291..17197db667 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units -system ; +system layouts ; ! Make sure these compile even though this is invalid code [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test diff --git a/core/io/crc32/crc32-docs.factor b/core/io/crc32/crc32-docs.factor index 3855c77cd8..7f85ee2b4e 100644 --- a/core/io/crc32/crc32-docs.factor +++ b/core/io/crc32/crc32-docs.factor @@ -6,7 +6,7 @@ HELP: crc32 { $description "Computes the CRC32 checksum of a sequence of bytes." } ; HELP: lines-crc32 -{ $values { "lines" "a sequence of strings" } { "n" integer } } +{ $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" diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 9609cd123b..df9c78fe47 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.styles strings -io.backend io.files.private quotations ; + io.backend io.files.private quotations ; IN: io.files ARTICLE: "file-streams" "Reading and writing files" @@ -43,11 +43,19 @@ ARTICLE: "directories" "Directories" { $subsection make-directory } { $subsection make-directories } ; +! ARTICLE: "file-types" "File Types" + +! { $table { +directory+ "" } } + +! ; + ARTICLE: "fs-meta" "File meta-data" + +{ $subsection file-info } +{ $subsection link-info } { $subsection exists? } { $subsection directory? } -{ $subsection file-length } -{ $subsection file-modified } +! { $subsection file-modified } { $subsection stat } ; ARTICLE: "delete-move-copy" "Deleting, moving, copying files" @@ -104,18 +112,54 @@ HELP: path-separator? HELP: parent-directory { $values { "path" "a pathname string" } { "parent" "a pathname string" } } { $description "Strips the last component off a pathname." } -{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ; +{ $examples { $example "USING: io io.files ;" "\"/etc/passwd\" parent-directory print" "/etc/" } } ; HELP: file-name { $values { "path" "a pathname string" } { "string" string } } { $description "Outputs the last component of a pathname string." } { $examples - { "\"/usr/bin/gcc\" file-name ." "\"gcc\"" } - { "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } + { $example "USING: io.files prettyprint ;" "\"/usr/bin/gcc\" file-name ." "\"gcc\"" } + { $example "USING: io.files prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } } ; +! need a $class-description file-info + +HELP: file-info + + { $values { "path" "a pathname string" } + { "info" file-info } } + { $description "Queries the file system for meta data. " + "If path refers to a symbolic link, it is followed." + "If the file does not exist, an exception is thrown." } + + { $class-description "File meta data" } + + { $table + { "type" { "One of the following:" + { $list { $link +regular-file+ } + { $link +directory+ } + { $link +symbolic-link+ } } } } + + { "size" "Size of the file in bytes" } + { "modified" "Last modification timestamp." } } + + ; + +! need a see also to link-info + +HELP: link-info + { $values { "path" "a pathname string" } + { "info" "a file-info tuple" } } + { $description "Queries the file system for meta data. " + "If path refers to a symbolic link, information about " + "the symbolic link itself is returned." + "If the file does not exist, an exception is thrown." } ; +! need a see also to file-info + +{ file-info link-info } related-words + HELP: -{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptors" } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } } { "stream" "an input stream" } } { $description "Outputs an input stream for reading from the specified pathname using the given encoding." } { $errors "Throws an error if the file is unreadable." } ; @@ -178,7 +222,7 @@ HELP: stat ( path -- directory? permissions length modified ) "Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values." } ; -{ stat exists? directory? file-length file-modified } related-words +{ stat exists? directory? } related-words HELP: path+ { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } @@ -206,13 +250,9 @@ HELP: directory* { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } { $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ; -HELP: file-length -{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } -{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ; - -HELP: file-modified -{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } -{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ; +! HELP: file-modified +! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } +! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ; HELP: resource-path { $values { "path" "a pathname string" } { "newpath" "a pathname string" } } diff --git a/core/io/files/files.factor b/core/io/files/files.factor index cbb6e77ff9..8a81bb1972 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -219,6 +219,9 @@ M: pathname <=> [ pathname-string ] compare ; : with-file-reader ( path encoding quot -- ) >r r> with-stream ; inline +! : file-contents ( path encoding -- str ) +! dupd [ file-info file-info-size read ] with-file-reader ; + : file-contents ( path encoding -- str ) dupd [ file-length read ] with-file-reader ; diff --git a/core/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor index 8e0b97e06b..741725af41 100644 --- a/core/io/streams/byte-array/byte-array-docs.factor +++ b/core/io/streams/byte-array/byte-array-docs.factor @@ -13,21 +13,22 @@ ARTICLE: "io.streams.byte-array" "Byte-array streams" HELP: { $values { "byte-array" byte-array } - { "encoding" "an encoding descriptor" } } -{ $description "Provides an input stream reading off the given byte array using the given encoding." } ; + { "encoding" "an encoding descriptor" } + { "stream" "a new byte reader" } } +{ $description "Creates an input stream reading from a byte array using an encoding." } ; HELP: { $values { "encoding" "an encoding descriptor" } - { "stream" "an output stream" } } -{ $description "Provides an output stream, putting things in the given encoding, storing everything written to it in a byte-array." } ; + { "stream" "a new byte writer" } } +{ $description "Creates an output stream writing data to a byte array using an encoding." } ; HELP: with-byte-reader { $values { "encoding" "an encoding descriptor" } { "quot" quotation } { "byte-array" byte-array } } -{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading the byte array in the given encoding from beginning to end." } ; +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream for reading from a byte array using an encoding." } ; HELP: with-byte-writer { $values { "encoding" "an encoding descriptor" } { "quot" quotation } { "byte-array" byte-array } } -{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new byte array writer, putting things in the given encoding. The accumulated byte array is output when the quotation returns." } ; +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an output stream writing data to a byte array using an encoding." } ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 2f80e3c368..8e107975bb 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -127,12 +127,22 @@ ARTICLE: "conditionals" "Conditionals and logic" { $see-also "booleans" "bitwise-arithmetic" both? either? } ; ARTICLE: "equality" "Equality and comparison testing" -"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object, or you can test if two objects are equal in some sense, usually by being instances of the same class, and having equal slot values. Both notions of equality are equality relations in the mathematical sense." +"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense." +$nl +"Identity comparison:" { $subsection eq? } +"Value comparison:" { $subsection = } +"Generic words for custom value comparison methods:" +{ $subsection equal? } "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":" { $subsection <=> } { $subsection compare } +"Utilities for comparing objects:" +{ $subsection after? } +{ $subsection before? } +{ $subsection after=? } +{ $subsection before=? } "An object can be cloned; the clone has distinct identity but equal value:" { $subsection clone } ; @@ -225,21 +235,18 @@ HELP: equal? { $contract "Tests if two objects are equal." $nl - "Method definitions should ensure that this is an equality relation:" + "User code should call " { $link = } " instead; that word first tests the case where the objects are " { $link eq? } ", and so by extension, methods defined on " { $link equal? } " assume they are never called on " { $link eq? } " objects." + $nl + "Method definitions should ensure that this is an equality relation, modulo the assumption that the two objects are not " { $link eq? } ". That is, for any three non-" { $link eq? } " objects " { $snippet "a" } ", " { $snippet "b" } " and " { $snippet "c" } ", we must have:" { $list - { $snippet "a = a" } { { $snippet "a = b" } " implies " { $snippet "b = a" } } { { $snippet "a = b" } " and " { $snippet "b = c" } " implies " { $snippet "a = c" } } } - "While user code can define methods for this generic word, it should not call it directly, since it does not handle the case where the two references point to the same object." } { $examples - "The most common reason for defining a method for this generic word to ensure that instances of a specific tuple class are only ever equal to themselves, overriding the default implementation which checks slot values for equality." + "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:" { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" } - "Note that with the above definition, calling " { $link equal? } " directly will give unexpected results:" - { $unchecked-example "T{ foo } dup equal? ." "f" } - { $unchecked-example "T{ foo } dup clone equal? ." "f" } - "As documented above, " { $link = } " should be called instead:" + "By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:" { $unchecked-example "T{ foo } dup = ." "t" } { $unchecked-example "T{ foo } dup clone = ." "f" } } ; @@ -264,7 +271,7 @@ HELP: compare { $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "n" integer } } { $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." } { $examples - { $example "\"hello\" \"hi\" [ length ] compare ." "3" } + { $example "USING: kernel prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "3" } } ; HELP: clone @@ -296,9 +303,9 @@ HELP: and { $notes "This word implements boolean and, so applying it to integers will not yield useful results (all integers have a true value). Bitwise and is the " { $link bitand } " word." } { $examples "Usually only the boolean value of the result is used, however you can also explicitly rely on the behavior that if both inputs are true, the second is output:" - { $example "t f and ." "f" } - { $example "t 7 and ." "7" } - { $example "\"hi\" 12.0 and ." "12.0" } + { $example "USING: kernel prettyprint ;" "t f and ." "f" } + { $example "USING: kernel prettyprint ;" "t 7 and ." "7" } + { $example "USING: kernel prettyprint ;" "\"hi\" 12.0 and ." "12.0" } } ; HELP: or @@ -307,8 +314,8 @@ HELP: or { $notes "This word implements boolean inclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise inclusive or is the " { $link bitor } " word." } { $examples "Usually only the boolean value of the result is used, however you can also explicitly rely on the behavior that the result will be the first true input:" - { $example "t f or ." "t" } - { $example "\"hi\" 12.0 or ." "\"hi\"" } + { $example "USING: kernel prettyprint ;" "t f or ." "t" } + { $example "USING: kernel prettyprint ;" "\"hi\" 12.0 or ." "\"hi\"" } } ; HELP: xor @@ -320,23 +327,21 @@ HELP: both? { $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." } { $examples - { $example "3 5 [ odd? ] both? ." "t" } - { $example "12 7 [ even? ] both? ." "f" } + { $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" } + { $example "USING: kernel math prettyprint ;" "12 7 [ even? ] both? ." "f" } } ; HELP: either? { $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." } { $examples - { $example "3 6 [ odd? ] either? ." "t" } - { $example "5 7 [ even? ] either? ." "f" } + { $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" } + { $example "USING: kernel math prettyprint ;" "5 7 [ even? ] either? ." "f" } } ; -HELP: call ( callable -- ) -{ $values { "quot" callable } } -{ $description "Calls a quotation." -$nl -"Under the covers, pushes the current call frame on the call stack, and set the call frame to the given quotation." } +HELP: call +{ $values { "callable" callable } } +{ $description "Calls a quotation." } { $examples "The following two lines are equivalent:" { $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" } @@ -489,9 +494,9 @@ HELP: curry ( obj quot -- curry ) $nl "This operation is efficient and does not copy the quotation." } { $examples - { $example "5 [ . ] curry ." "[ 5 . ]" } - { $example "\\ = [ see ] curry ." "[ \\ = see ]" } - { $example "{ 1 2 3 } 2 [ - ] curry map ." "{ -1 0 1 }" } + { $example "USING: kernel prettyprint ;" "5 [ . ] curry ." "[ 5 . ]" } + { $example "USING: kernel prettyprint ;" "\\ = [ see ] curry ." "[ \\ = see ]" } + { $example "USING: kernel math prettyprint sequences ;" "{ 1 2 3 } 2 [ - ] curry map ." "{ -1 0 1 }" } } ; HELP: 2curry @@ -499,7 +504,7 @@ HELP: 2curry { $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } " and " { $snippet "obj2" } " and then calls " { $snippet "quot" } "." } { $notes "This operation is efficient and does not copy the quotation." } { $examples - { $example "5 4 [ + ] 2curry ." "[ 5 4 + ]" } + { $example "USING: kernel math prettyprint ;" "5 4 [ + ] 2curry ." "[ 5 4 + ]" } } ; HELP: 3curry @@ -516,7 +521,7 @@ HELP: with } { $notes "This operation is efficient and does not copy the quotation." } { $examples - { $example "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" } + { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" } } ; HELP: compose diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor index 0ce4c9bb73..d4188dd3b6 100755 --- a/core/layouts/layouts-docs.factor +++ b/core/layouts/layouts-docs.factor @@ -1,5 +1,7 @@ -USING: layouts generic help.markup help.syntax kernel math -memory namespaces sequences kernel.private classes ; +USING: generic help.markup help.syntax kernel math +memory namespaces sequences kernel.private classes +sequences.private ; +IN: layouts HELP: tag-bits { $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." } @@ -35,3 +37,88 @@ HELP: most-positive-fixnum HELP: most-negative-fixnum { $values { "n" "smallest negative integer representable by a fixnum" } } ; + +HELP: bootstrap-first-bignum +{ $values { "n" "smallest positive integer not representable by a fixnum" } } +{ $description "Outputs the value for the target architecture when bootstrapping." } ; + +HELP: bootstrap-most-positive-fixnum +{ $values { "n" "largest positive integer representable by a fixnum" } } +{ $description "Outputs the value for the target architecture when bootstrapping." } ; + +HELP: bootstrap-most-negative-fixnum +{ $values { "n" "smallest negative integer representable by a fixnum" } } +{ $description "Outputs the value for the target architecture when bootstrapping." } ; + +HELP: cell +{ $values { "n" "a positive integer" } } +{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ; + +HELP: cells +{ $values { "m" integer } { "n" integer } } +{ $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ; + +HELP: cell-bits +{ $values { "n" integer } } +{ $description "Outputs the number of bits in one CPU operand-sized cell." } ; + +HELP: bootstrap-cell +{ $values { "n" "a positive integer" } } +{ $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; + +HELP: bootstrap-cells +{ $values { "m" integer } { "n" integer } } +{ $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; + +HELP: bootstrap-cell-bits +{ $values { "n" integer } } +{ $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; + +ARTICLE: "layouts-types" "Type numbers" +"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:" +{ $subsection type } +"Built-in type numbers can be converted to classes, and vice versa:" +{ $subsection type>class } +{ $subsection type-number } +{ $subsection num-types } +{ $see-also "builtin-classes" } ; + +ARTICLE: "layouts-tags" "Tagged pointers" +"Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag." +$nl +"Getting the tag of an object:" +{ $link tag } +"Words for working with tagged pointers:" +{ $subsection tag-bits } +{ $subsection num-tags } +{ $subsection tag-mask } +{ $subsection tag-number } +"The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ; + +ARTICLE: "layouts-limits" "Sizes and limits" +"Processor cell size:" +{ $subsection cell } +{ $subsection cells } +{ $subsection cell-bits } +"Range of integers representable by " { $link fixnum } "s:" +{ $subsection most-negative-fixnum } +{ $subsection most-positive-fixnum } +"Maximum array size:" +{ $subsection max-array-capacity } ; + +ARTICLE: "layouts-bootstrap" "Bootstrap support" +"Bootstrap support:" +{ $subsection bootstrap-cell } +{ $subsection bootstrap-cells } +{ $subsection bootstrap-cell-bits } +{ $subsection bootstrap-most-negative-fixnum } +{ $subsection bootstrap-most-positive-fixnum } ; + +ARTICLE: "layouts" "VM memory layouts" +"The words documented in this section do not ever need to be called by user code. They are documented for the benefit of those wishing to explore the internals of Factor's implementation." +{ $subsection "layouts-types" } +{ $subsection "layouts-tags" } +{ $subsection "layouts-limits" } +{ $subsection "layouts-bootstrap" } ; + +ABOUT: "layouts" diff --git a/core/layouts/layouts-tests.factor b/core/layouts/layouts-tests.factor new file mode 100755 index 0000000000..cf50356f76 --- /dev/null +++ b/core/layouts/layouts-tests.factor @@ -0,0 +1,5 @@ +IN: system.tests +USING: layouts math tools.test ; + +[ t ] [ cell integer? ] unit-test +[ t ] [ bootstrap-cell integer? ] unit-test diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index db23bf03d0..879862c926 100755 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces math words kernel assocs system classes ; +USING: namespaces math words kernel assocs classes +kernel.private ; IN: layouts SYMBOL: tag-mask @@ -24,8 +25,23 @@ SYMBOL: type-numbers : tag-fixnum ( n -- tagged ) tag-bits get shift ; +: cell ( -- n ) 7 getenv ; foldable + +: cells ( m -- n ) cell * ; inline + +: cell-bits ( -- n ) 8 cells ; inline + +: bootstrap-cell \ cell get cell or ; inline + +: bootstrap-cells bootstrap-cell * ; inline + +: bootstrap-cell-bits 8 bootstrap-cells ; inline + +: (first-bignum) ( m -- n ) + tag-bits get - 1 - 2^ ; + : first-bignum ( -- n ) - bootstrap-cell-bits tag-bits get - 1 - 2^ ; + cell-bits (first-bignum) ; : most-positive-fixnum ( -- n ) first-bignum 1- ; @@ -33,6 +49,15 @@ SYMBOL: type-numbers : most-negative-fixnum ( -- n ) first-bignum neg ; +: bootstrap-first-bignum ( -- n ) + bootstrap-cell-bits (first-bignum) ; + +: bootstrap-most-positive-fixnum ( -- n ) + bootstrap-first-bignum 1- ; + +: bootstrap-most-negative-fixnum ( -- n ) + bootstrap-first-bignum neg ; + M: bignum >integer dup most-negative-fixnum most-positive-fixnum between? [ >fixnum ] when ; diff --git a/core/listener/listener-docs.factor b/core/listener/listener-docs.factor index ca1027dbc5..755c79ac68 100755 --- a/core/listener/listener-docs.factor +++ b/core/listener/listener-docs.factor @@ -31,8 +31,8 @@ HELP: listener-hook { $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ; HELP: read-quot -{ $values { "stream" "an input stream" } { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } } -{ $description "Reads a Factor expression from the stream, possibly spanning more than line. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ; +{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } } +{ $description "Reads a Factor expression which possibly spans more than one line from " { $link stdio } " stream. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ; HELP: listen { $description "Prompts for an expression on the " { $link stdio } " stream and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." } diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 61d3f9836d..16ee2705fe 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -38,7 +38,7 @@ M: object stream-read-quot M: duplex-stream stream-read-quot duplex-stream-in stream-read-quot ; -: read-quot ( -- quot ) stdio get stream-read-quot ; +: read-quot ( -- quot/f ) stdio get stream-read-quot ; : bye ( -- ) quit-flag on ; diff --git a/core/math/intervals/intervals-docs.factor b/core/math/intervals/intervals-docs.factor index 09afded43c..7eb20090ab 100644 --- a/core/math/intervals/intervals-docs.factor +++ b/core/math/intervals/intervals-docs.factor @@ -213,41 +213,41 @@ HELP: incomparable { $description "Output value from " { $link interval<= } ", " { $link interval< } ", " { $link interval>= } " and " { $link interval> } " in the case where the result of the comparison is ambiguous." } ; HELP: interval<= -{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } } -{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:" +{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } } +{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:" { $list - { { $link t } " if every point in " { $snippet "int" } " is less than or equal to " { $snippet "n" } } - { { $link f } " if every point in " { $snippet "int" } " is greater than " { $snippet "n" } } + { { $link t } " if every point in " { $snippet "i1" } " is less than or equal to every point in " { $snippet "i2" } } + { { $link f } " if every point in " { $snippet "i1" } " is greater than every point in " { $snippet "i2" } } { { $link incomparable } " if neither of the above conditions hold" } } } ; HELP: interval< -{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } } -{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:" +{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } } +{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:" { $list - { { $link t } " if every point in " { $snippet "int" } " is less than " { $snippet "n" } } - { { $link f } " if every point in " { $snippet "int" } " is greater than or equal to " { $snippet "n" } } + { { $link t } " if every point in " { $snippet "i1" } " is less than every point in " { $snippet "i2" } } + { { $link f } " if every point in " { $snippet "i1" } " is greater than or equal to every point in " { $snippet "i2" } } { { $link incomparable } " if neither of the above conditions hold" } } } ; HELP: interval>= -{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } } -{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:" +{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } } +{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:" { $list - { { $link t } " if every point in " { $snippet "int" } " is greater than or equal to " { $snippet "n" } } - { { $link f } " if every point in " { $snippet "int" } " is less than " { $snippet "n" } } + { { $link t } " if every point in " { $snippet "i1" } " is greater than or equal to every point in " { $snippet "i2" } } + { { $link f } " if every point in " { $snippet "i1" } " is less than every point in " { $snippet "i2" } } { { $link incomparable } " if neither of the above conditions hold" } } } ; HELP: interval> -{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } } -{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:" +{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } } +{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:" { $list - { { $link t } " if every point in " { $snippet "int" } " is greater than " { $snippet "n" } } - { { $link f } " if every point in " { $snippet "int" } " is less than or equal to " { $snippet "n" } } + { { $link t } " if every point in " { $snippet "i1" } " is greater than every point in " { $snippet "i2" } } + { { $link f } " if every point in " { $snippet "i1" } " is less than or equal to every point in " { $snippet "i2" } } { { $link incomparable } " if neither of the above conditions hold" } } } ; diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 1ec3592c79..6ec1c5790f 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -184,8 +184,8 @@ HELP: bitand { $values { "x" integer } { "y" integer } { "z" integer } } { $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in both inputs." } { $examples - { $example "BIN: 101 BIN: 10 bitand .b" "0" } - { $example "BIN: 110 BIN: 10 bitand .b" "10" } + { $example "USING: math prettyprint ;" "BIN: 101 BIN: 10 bitand .b" "0" } + { $example "USING: math prettyprint ;" "BIN: 110 BIN: 10 bitand .b" "10" } } { $notes "This word implements bitwise and, so applying it to booleans will throw an error. Boolean and is the " { $link and } " word." } ; @@ -193,8 +193,8 @@ HELP: bitor { $values { "x" integer } { "y" integer } { "z" integer } } { $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in at least one of the inputs." } { $examples - { $example "BIN: 101 BIN: 10 bitor .b" "111" } - { $example "BIN: 110 BIN: 10 bitor .b" "110" } + { $example "USING: math prettyprint ;" "BIN: 101 BIN: 10 bitor .b" "111" } + { $example "USING: math prettyprint ;" "BIN: 110 BIN: 10 bitor .b" "110" } } { $notes "This word implements bitwise inclusive or, so applying it to booleans will throw an error. Boolean inclusive or is the " { $link and } " word." } ; @@ -202,15 +202,15 @@ HELP: bitxor { $values { "x" integer } { "y" integer } { "z" integer } } { $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in exactly one of the inputs." } { $examples - { $example "BIN: 101 BIN: 10 bitxor .b" "111" } - { $example "BIN: 110 BIN: 10 bitxor .b" "100" } + { $example "USING: math prettyprint ;" "BIN: 101 BIN: 10 bitxor .b" "111" } + { $example "USING: math prettyprint ;" "BIN: 110 BIN: 10 bitxor .b" "100" } } { $notes "This word implements bitwise exclusive or, so applying it to booleans will throw an error. Boolean exclusive or is the " { $link xor } " word." } ; HELP: shift { $values { "x" integer } { "n" integer } { "y" integer } } { $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." } -{ $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ; +{ $examples { $example "USING: math prettyprint ;" "BIN: 101 5 shift .b" "10100000" } { $example "USING: math prettyprint ;" "BIN: 11111 -2 shift .b" "111" } } ; HELP: bitnot { $values { "x" integer } { "y" integer } } @@ -222,7 +222,7 @@ $nl HELP: bit? { $values { "x" integer } { "n" integer } { "?" "a boolean" } } { $description "Tests if the " { $snippet "n" } "th bit of " { $snippet "x" } " is set." } -{ $examples { $example "BIN: 101 2 bit? ." "t" } } ; +{ $examples { $example "USING: math prettyprint ;" "BIN: 101 2 bit? ." "t" } } ; HELP: log2 { $values { "x" "a positive integer" } { "n" integer } } @@ -295,9 +295,9 @@ HELP: 2/ { $values { "x" integer } { "y" integer } } { $description "Shifts " { $snippet "x" } " to the right by one bit." } { $examples - { $example "14 2/ ." "7" } - { $example "17 2/ ." "8" } - { $example "-17 2/ ." "-9" } + { $example "USING: math prettyprint ;" "14 2/ ." "7" } + { $example "USING: math prettyprint ;" "17 2/ ." "8" } + { $example "USING: math prettyprint ;" "-17 2/ ." "-9" } } { $notes "This word is not equivalent to " { $snippet "2 /" } " or " { $snippet "2 /i" } "; the name is historic and originates from the Forth programming language." } ; diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor index 8da9e9dd69..140f92567b 100755 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -29,7 +29,7 @@ HELP: { $description "Creates a " { $link mirror } " reflecting an object." } { $examples { $example - "USING: assocs mirrors ;" + "USING: assocs mirrors prettyprint ;" "TUPLE: circle center radius ;" "C: circle" "{ 100 50 } 15 >alist ." diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index 2d4b9a03b2..971477cd4d 100755 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -87,7 +87,7 @@ HELP: +@ { $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." } { $side-effects "variable" } { $examples - { $example "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" } + { $example "USING: namespaces prettyprint ;" "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" } } ; HELP: inc @@ -168,7 +168,7 @@ HELP: building HELP: make { $values { "quot" quotation } { "exemplar" "a sequence" } { "seq" "a new sequence" } } { $description "Calls the quotation in a new " { $emphasis "dynamic scope" } ". The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." } -{ $examples { $example "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ; +{ $examples { $example "USING: namespaces prettyprint ;" "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ; HELP: , { $values { "elt" object } } diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index ce6a119e32..48f929b836 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -221,8 +221,8 @@ HELP: { $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ; HELP: skip -{ $values { "i" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "n" integer } } -{ $description "Variant of " { $link find* } " that outputs the length of the sequence instead of " { $link f } " if no elements satisfy the predicate." } ; +{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } +{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; HELP: change-column { $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } } @@ -264,7 +264,7 @@ HELP: bad-number HELP: escape { $values { "escape" "a single-character escape" } { "ch" "a character" } } { $description "Converts from a single-character escape code and the corresponding character." } -{ $examples { $example "CHAR: n escape CHAR: \\n = ." "t" } } ; +{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ; HELP: parse-string { $values { "str" "a new " { $link string } } } @@ -340,8 +340,8 @@ HELP: no-word { $notes "Apart from a missing " { $link POSTPONE: USE: } ", this error can also indicate an ordering issue. In Factor, words must be defined before they can be called. Mutual recursion can be implemented via " { $link POSTPONE: DEFER: } "." } ; HELP: search -{ $values { "str" string } { "word" word } } -{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, throws a " { $link no-word } " error. If the search path does not contain a word with this name but other vocabularies do, the error will have restarts offering to add vocabularies to the search path." } +{ $values { "str" string } { "word/f" "a word or " { $link f } } } +{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, outputs " { $link f } "." } $parsing-note ; HELP: scan-word @@ -459,7 +459,7 @@ HELP: forget-smudged { $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ; HELP: finish-parsing -{ $values { "quot" "the quotation just parsed" } } +{ $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } } { $description "Records information to the current " { $link file } " and prints warnings about any removed definitions which are still in use." } { $notes "This is one of the factors of " { $link parse-stream } "." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 89783d1b3c..a69e28ab97 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -430,3 +430,20 @@ IN: parser.tests [ "resource:core/parser/test/assert-depth.factor" run-file ] [ relative-overflow-stack { 1 2 3 } sequence= ] must-fail-with + +2 [ + [ ] [ + "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s" + "d-f-s-test" parse-stream drop + ] unit-test + + [ ] [ + "IN: parser.tests DEFER: d-f-s d-f-s FORGET: d-f-s SYMBOL: d-f-s d-f-s" + "d-f-s-test" parse-stream drop + ] unit-test + + [ ] [ + "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s" + "d-f-s-test" parse-stream drop + ] unit-test +] times diff --git a/core/parser/parser.factor b/core/parser/parser.factor index cc84084258..50f8f582d3 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -240,13 +240,13 @@ PREDICATE: unexpected unexpected-eof : CREATE ( -- word ) scan create-in ; -: create-class ( word vocab -- word ) - create +: create-class-in ( word -- word ) + in get create dup save-class-location dup predicate-word dup set-word save-location ; : CREATE-CLASS ( -- word ) - scan in get create-class ; + scan create-class-in ; : word-restarts ( possibilities -- restarts ) natural-sort [ @@ -416,6 +416,7 @@ SYMBOL: interactive-vocabs "tools.test" "tools.threads" "tools.time" + "tools.vocabs" "vocabs" "vocabs.loader" "words" @@ -483,7 +484,6 @@ SYMBOL: interactive-vocabs : finish-parsing ( lines quot -- ) file get [ record-form ] keep - [ record-modified ] keep [ record-definitions ] keep record-checksum ; diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor index 69400d2527..7ea0f5c412 100755 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -242,8 +242,8 @@ HELP: definer { $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } } { $contract "Outputs the parsing words which delimit the definition." } { $examples - { $example ": foo ; \\ foo definer . ." ";\nPOSTPONE: :" } - { $example "SYMBOL: foo \\ foo definer . ." "f\nPOSTPONE: SYMBOL:" } + { $example "USING: definitions prettyprint ;" ": foo ; \\ foo definer . ." ";\nPOSTPONE: :" } + { $example "USING: definitions prettyprint ;" "SYMBOL: foo \\ foo definer . ." "f\nPOSTPONE: SYMBOL:" } } { $notes "This word is used in the implementation of " { $link see } "." } ; @@ -251,6 +251,6 @@ HELP: definition { $values { "defspec" "a definition specifier" } { "seq" "a sequence" } } { $contract "Outputs the body of a definition." } { $examples - { $example "USE: math" "\\ sq definition ." "[ dup * ]" } + { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" } } { $notes "This word is used in the implementation of " { $link see } "." } ; diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index c30db0a4b8..74c296d94c 100755 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -51,8 +51,8 @@ HELP: literalize { $values { "obj" object } { "wrapped" object } } { $description "Outputs an object which evaluates to " { $snippet "obj" } " when placed in a quotation. If " { $snippet "obj" } " is not self-evaluating (for example, it is a word), then it will be wrapped." } { $examples - { $example "USE: quotations" "5 literalize ." "5" } - { $example "USE: quotations" "[ + ] [ literalize ] map ." "[ \\ + ]" } + { $example "USING: prettyprint quotations ;" "5 literalize ." "5" } + { $example "USING: math prettyprint quotations sequences ;" "[ + ] [ literalize ] map ." "[ \\ + ]" } } ; { literalize curry POSTPONE: \ POSTPONE: W{ } related-words diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 6e39bced07..9e8dcd6559 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -288,8 +288,8 @@ HELP: new-resizable { $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } } { $contract "Outputs a resizable mutable sequence with an initial capacity of " { $snippet "n" } " elements and zero length, which can hold the elements of " { $snippet "seq" } "." } { $examples - { $example "300 V{ } new-resizable ." "V{ }" } - { $example "300 SBUF\" \" new-resizable ." "SBUF\" \"" } + { $example "USING: prettyprint sequences ;" "300 V{ } new-resizable ." "V{ }" } + { $example "USING: prettyprint sequences ;" "300 SBUF\" \" new-resizable ." "SBUF\" \"" } } ; HELP: like @@ -435,14 +435,16 @@ HELP: reduce { $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." } { $examples - { $example "{ 1 5 3 } 0 [ + ] reduce ." "9" } + { $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" } } ; HELP: accumulate { $values { "identity" object } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } } -{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence. Given the empty sequence, outputs a one-element sequence consisting of " { $snippet "identity" } "." } +{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." +$nl +"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } { $examples - { $example "{ 2 2 2 2 2 } 0 [ + ] accumulate . ." "{ 0 2 4 6 8 }\n10" } + { $example "USING: math prettyprint sequences ;" "{ 2 2 2 2 2 } 0 [ + ] accumulate . ." "{ 0 2 4 6 8 }\n10" } } ; HELP: map @@ -546,9 +548,9 @@ HELP: monotonic? { $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." } { $examples "Testing if a sequence is non-decreasing:" - { $example "{ 1 1 2 } [ <= ] monotonic? ." "t" } + { $example "USING: math prettyprint sequences ;" "{ 1 1 2 } [ <= ] monotonic? ." "t" } "Testing if a sequence is decreasing:" - { $example "{ 9 8 6 7 } [ < ] monotonic? ." "f" } + { $example "USING: math prettyprint sequences ;" "{ 9 8 6 7 } [ < ] monotonic? ." "f" } } ; { monotonic? all-eq? all-equal? } related-words @@ -556,7 +558,7 @@ HELP: monotonic? HELP: interleave { $values { "seq" sequence } { "between" "a quotation" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } { $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." } -{ $example "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ; +{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ; HELP: cache-nth { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( i -- elt )" } } { "elt" object } } @@ -590,7 +592,7 @@ HELP: memq? { $description "Tests if the sequence contains the object." } { $examples "This word uses identity comparison, so the following will most likely print " { $link f } ":" - { $example "\"hello\" { \"hello\" } memq? ." "f" } + { $example "USING: prettyprint sequences ;" "\"hello\" { \"hello\" } memq? ." "f" } } ; HELP: remove @@ -629,6 +631,7 @@ HELP: push-new { $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." } { $examples { $example + "USING: namespaces prettyprint sequences ;" "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set" "\"nachos\" \"v\" get push-new" "\"salsa\" \"v\" get push-new" @@ -645,7 +648,7 @@ HELP: add { $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." } { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." } { $examples - { $example "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" } + { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" } } ; HELP: add* @@ -653,7 +656,7 @@ HELP: add* { $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." } { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." } { $examples - { $example "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" } +{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" } } ; HELP: seq-diff @@ -710,7 +713,7 @@ HELP: mismatch HELP: flip { $values { "matrix" "a sequence of equal-length sequences" } { "newmatrix" "a sequence of equal-length sequences" } } { $description "Transposes the matrix; that is, rows become columns and columns become rows." } -{ $examples { $example "{ { 1 2 3 } { 4 5 6 } } flip ." "{ { 1 4 } { 2 5 } { 3 6 } }" } } ; +{ $examples { $example "USING: prettyprint sequences ;" "{ { 1 2 3 } { 4 5 6 } } flip ." "{ { 1 4 } { 2 5 } { 3 6 } }" } } ; HELP: exchange { $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } } @@ -728,12 +731,12 @@ HELP: padding HELP: pad-left { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } } { $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the left with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." } -{ $examples { $example "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ; +{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ; HELP: pad-right { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } } { $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the right with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." } -{ $examples { $example "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ; +{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ; HELP: sequence= { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } @@ -798,6 +801,7 @@ HELP: ( seq n -- column ) { $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } { $examples { $example + "USING: arrays prettyprint sequences ;" "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 >array ." "{ 1 4 7 }" } @@ -813,8 +817,8 @@ HELP: ( len elt -- repetition ) { $values { "len" "a non-negative integer" } { "elt" object } { "repetition" repetition } } { $description "Creates a new " { $link repetition } "." } { $examples - { $example "10 \"X\" >array ." "{ \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" }" } - { $example "10 \"X\" >array concat ." "\"XXXXXXXXXX\"" } + { $example "USING: arrays prettyprint sequences ;" "10 \"X\" >array ." "{ \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" }" } + { $example "USING: prettyprint sequences ;" "10 \"X\" concat ." "\"XXXXXXXXXX\"" } } ; HELP: copy { $values { "src" sequence } { "i" "an index in " { $snippet "dest" } } { "dst" "a mutable sequence" } } @@ -936,7 +940,7 @@ HELP: unclip { $values { "seq" sequence } { "rest" sequence } { "first" object } } { $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." } { $examples - { $example "{ 1 2 3 } unclip add ." "{ 2 3 1 }" } + { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip add ." "{ 2 3 1 }" } } ; HELP: unclip-slice @@ -966,7 +970,7 @@ HELP: unfold { $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." } { $examples "The following example divides a number by two until we reach zero, and accumulates intermediate results:" - { $example "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" } + { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" } "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:" - { $unchecked-example "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" } + { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" } } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 7208e05af0..9fc5264440 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -441,6 +441,9 @@ PRIVATE> : memq? ( obj seq -- ? ) [ eq? ] with contains? ; +: seq-intersect ( seq1 seq2 -- seq1/\seq2 ) + swap [ member? ] curry subset ; + : remove ( obj seq -- newseq ) [ = not ] with subset ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index d8c8f5fbba..d57c4053e6 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -68,7 +68,7 @@ HELP: reader-quot HELP: slot-reader { $class-description "The class of slot reader words." } { $examples - { $example "USING: classes slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" } + { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" } } ; HELP: define-reader @@ -83,7 +83,7 @@ HELP: writer-effect HELP: slot-writer { $class-description "The class of slot writer words." } { $examples - { $example "USING: classes slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" } + { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" } } ; HELP: define-writer diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 36a7ae67bb..2f2f8fd0c0 100755 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -3,16 +3,13 @@ definitions quotations compiler.units ; IN: source-files ARTICLE: "source-files" "Source files" -"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement features such as " { $link refresh-all } "." +"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "." $nl "The source file database:" { $subsection source-files } "The class of source files:" { $subsection source-file } -"Testing if a source file has been changed on disk:" -{ $subsection source-modified? } "Words intended for the parser:" -{ $subsection record-modified } { $subsection record-checksum } { $subsection record-form } { $subsection xref-source } @@ -34,24 +31,14 @@ HELP: source-file { $class-description "Instances retain information about loaded source files, and have the following slots:" { $list { { $link source-file-path } " - a pathname string." } - { { $link source-file-modified } " - the result of " { $link file-modified } " at the time the source file was most recently loaded." } { { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." } { { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." } { { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" } } } ; -HELP: source-modified? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's modification time and CRC32 checksum of the file's contents against previously-recorded values." } ; - -HELP: record-modified -{ $values { "source-file" source-file } } -{ $description "Records the modification time of the source file." } -$low-level-note ; - HELP: record-checksum -{ $values { "source-file" source-file } { "contents" string } } +{ $values { "source-file" source-file } { "lines" "a sequence of strings" } } { $description "Records the CRC32 checksm of the source file's contents." } $low-level-note ; @@ -75,7 +62,7 @@ HELP: record-form $low-level-note ; HELP: reset-checksums -{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link refresh } "." } ; +{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ; HELP: forget-source { $values { "path" "a pathname string" } } diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 55300a3c29..f4428e4e8b 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -1,44 +1,25 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -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 io.streams.string vocabs -hashtables graphs compiler.units io.encodings.utf8 ; +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 ; IN: source-files SYMBOL: source-files TUPLE: source-file path -modified checksum +checksum uses definitions ; -: (source-modified?) ( path modified checksum -- ? ) - pick file-modified rot [ 0 or ] 2apply > - [ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ; - -: source-modified? ( path -- ? ) - dup source-files get at [ - dup source-file-path ?resource-path - over source-file-modified - rot source-file-checksum - (source-modified?) - ] [ - resource-exists? - ] ?if ; - -: record-modified ( source-file -- ) - dup source-file-path ?resource-path file-modified - swap set-source-file-modified ; - : record-checksum ( lines source-file -- ) - swap lines-crc32 swap set-source-file-checksum ; + >r lines-crc32 r> set-source-file-checksum ; : (xref-source) ( source-file -- pathname uses ) - dup source-file-path swap source-file-uses - [ crossref? ] subset ; + dup source-file-path + swap source-file-uses [ crossref? ] subset ; : xref-source ( source-file -- ) (xref-source) crossref get add-vertex ; @@ -67,9 +48,7 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ - swap ?resource-path dup exists? - [ - over record-modified + swap ?resource-path dup exists? [ utf8 file-lines swap record-checksum ] [ 2drop ] if ] assoc-each ; @@ -85,7 +64,7 @@ M: pathname where pathname-string 1 2array ; M: pathname forget* pathname-string forget-source ; -: rollback-source-file ( source-file -- ) +: rollback-source-file ( file -- ) dup source-file-definitions new-definitions get [ union ] 2map swap set-source-file-definitions ; diff --git a/core/splitting/splitting-docs.factor b/core/splitting/splitting-docs.factor index 2535f98524..5000dbf5fd 100644 --- a/core/splitting/splitting-docs.factor +++ b/core/splitting/splitting-docs.factor @@ -33,7 +33,7 @@ HELP: last-split1 HELP: split { $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } } { $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." } -{ $examples { $example "USE: splitting" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ; +{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ; HELP: groups { $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively." @@ -51,7 +51,7 @@ HELP: { $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example - "USE: splitting" + "USING: arrays kernel prettyprint sequences splitting ;" "9 >array 3 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" } } ; @@ -61,7 +61,7 @@ HELP: { $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example - "USE: splitting" + "USING: arrays kernel prettyprint sequences splitting ;" "9 >array 3 " "dup [ reverse-here ] each concat >array ." "{ 2 1 0 5 4 3 8 7 6 }" @@ -90,5 +90,5 @@ HELP: string-lines { $values { "str" string } { "seq" "a sequence of strings" } } { $description "Splits a string along line breaks." } { $examples - { $example "USE: splitting" "\"Hello\\r\\nworld\\n\" string-lines ." "{ \"Hello\" \"world\" \"\" }" } + { $example "USING: prettyprint splitting ;" "\"Hello\\r\\nworld\\n\" string-lines ." "{ \"Hello\" \"world\" \"\" }" } } ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor old mode 100644 new mode 100755 index c6230ebe16..6416e27eaf --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -69,12 +69,12 @@ INSTANCE: groups sequence : split ( seq separators -- pieces ) [ split, ] { } make ; : string-lines ( str -- seq ) - dup [ "\r\n" member? ] contains? [ + dup "\r\n" seq-intersect empty? [ + 1array + ] [ "\n" split [ 1 head-slice* [ "\r" ?tail drop "\r" split ] map ] keep peek "\r" split add concat - ] [ - 1array ] if ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index eeb3f85962..dc06a239de 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -204,7 +204,7 @@ HELP: delimiter HELP: parsing { $syntax ": foo ... ; parsing" } { $description "Declares the most recently defined word as a parsing word." } -{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example ": hello \"Hello parser!\" print ; parsing\n: world hello ;" "Hello parser!" } } ; +{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example "USE: io" "<< : hello \"Hello parser!\" print ; parsing >>\n: world hello ;" "Hello parser!" } } ; HELP: inline { $syntax ": foo ... ; inline" } @@ -367,7 +367,7 @@ HELP: SYMBOL: { $syntax "SYMBOL: word" } { $values { "word" "a new word to define" } } { $description "Defines a new symbol word in the current vocabulary. Symbols push themselves on the stack when executed, and are used to identify variables (see " { $link "namespaces" } ") as well as for storing crufties in word properties (see " { $link "word-props" } ")." } -{ $examples { $example "SYMBOL: foo\nfoo ." "foo" } } ; +{ $examples { $example "USE: prettyprint" "SYMBOL: foo\nfoo ." "foo" } } ; { define-symbol POSTPONE: SYMBOL: } related-words @@ -424,19 +424,19 @@ HELP: " { $syntax "\"string...\"" } { $values { "string" "literal and escaped characters" } } { $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", and appends the resulting string to the parse tree. String literals cannot span multiple lines. Strings containing the " { $link POSTPONE: " } " character and various other special characters can be read by inserting escape sequences." } -{ $examples { $example "\"Hello\\nworld\" print" "Hello\nworld" } } ; +{ $examples { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" } } ; HELP: SBUF" { $syntax "SBUF\" string... \"" } { $values { "string" "literal and escaped characters" } } { $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", converts the string to a string buffer, and appends it to the parse tree." } -{ $examples { $example "SBUF\" Hello world\" >string print" "Hello world" } } ; +{ $examples { $example "USING: io strings ;" "SBUF\" Hello world\" >string print" "Hello world" } } ; HELP: P" { $syntax "P\" pathname\"" } { $values { "pathname" "a pathname string" } } { $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", creates a new " { $link pathname } ", and appends it to the parse tree." } -{ $examples { $example "USE: io.files" "P\" foo.txt\" pathname-string print" "foo.txt" } } ; +{ $examples { $example "USING: io io.files ;" "P\" foo.txt\" pathname-string print" "foo.txt" } } ; HELP: ( { $syntax "( inputs -- outputs )" } @@ -460,19 +460,19 @@ HELP: HEX: { $syntax "HEX: integer" } { $values { "integer" "hexadecimal digits (0-9, a-f, A-F)" } } { $description "Adds an integer read from a hexadecimal literal to the parse tree." } -{ $examples { $example "HEX: ff ." "255" } } ; +{ $examples { $example "USE: prettyprint" "HEX: ff ." "255" } } ; HELP: OCT: { $syntax "OCT: integer" } { $values { "integer" "octal digits (0-7)" } } { $description "Adds an integer read from an octal literal to the parse tree." } -{ $examples { $example "OCT: 31337 ." "13023" } } ; +{ $examples { $example "USE: prettyprint" "OCT: 31337 ." "13023" } } ; HELP: BIN: { $syntax "BIN: integer" } { $values { "integer" "binary digits (0 and 1)" } } { $description "Adds an integer read from an binary literal to the parse tree." } -{ $examples { $example "BIN: 100 ." "4" } } ; +{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ; HELP: GENERIC: { $syntax "GENERIC: word" } @@ -500,6 +500,7 @@ HELP: HOOK: { $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." } { $examples { $example + "USING: io namespaces ;" "SYMBOL: transport" "TUPLE: land-transport ;" "TUPLE: air-transport ;" diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index c5c7791a35..7e7a5ff215 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -15,10 +15,6 @@ ARTICLE: "os" "System interface" { $subsection wince? } "Processor detection:" { $subsection cpu } -"Processor cell size:" -{ $subsection cell } -{ $subsection cells } -{ $subsection cell-bits } "Reading environment variables:" { $subsection os-env } { $subsection os-envs } @@ -114,7 +110,15 @@ HELP: os-envs } { $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; -{ os-env os-envs } related-words +HELP: set-os-envs +{ $values { "assoc" "an association mapping strings to strings" } } +{ $description "Replaces the current set of environment variables." } +{ $notes + "Names and values of environment variables are operating system-specific." +} +{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; + +{ os-env os-envs set-os-envs } related-words HELP: win32? { $values { "?" "a boolean" } } @@ -135,27 +139,3 @@ HELP: vm HELP: unix? { $values { "?" "a boolean" } } { $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ; - -HELP: cell -{ $values { "n" "a positive integer" } } -{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ; - -HELP: cells -{ $values { "m" integer } { "n" integer } } -{ $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ; - -HELP: cell-bits -{ $values { "n" integer } } -{ $description "Outputs the number of bits in one CPU operand-sized cell." } ; - -HELP: bootstrap-cell -{ $values { "n" "a positive integer" } } -{ $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; - -HELP: bootstrap-cells -{ $values { "m" integer } { "n" integer } } -{ $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; - -HELP: bootstrap-cell-bits -{ $values { "n" integer } } -{ $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ; diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index ad0e5e07cb..4b074ed7aa 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -1,9 +1,6 @@ USING: math tools.test system prettyprint namespaces kernel ; IN: system.tests -[ t ] [ cell integer? ] unit-test -[ t ] [ bootstrap-cell integer? ] unit-test - wince? [ [ ] [ os-envs . ] unit-test ] unless diff --git a/core/system/system.factor b/core/system/system.factor index 58abd4be2f..87bbcfdc3f 100755 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -2,13 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: system USING: kernel kernel.private sequences math namespaces -splitting assocs system.private ; - -: cell ( -- n ) 7 getenv ; foldable - -: cells ( m -- n ) cell * ; inline - -: cell-bits ( -- n ) 8 cells ; inline +splitting assocs system.private layouts ; : cpu ( -- cpu ) 8 getenv ; foldable @@ -51,12 +45,6 @@ splitting assocs system.private ; : solaris? ( -- ? ) os "solaris" = ; -: bootstrap-cell \ cell get cell or ; inline - -: bootstrap-cells bootstrap-cell * ; inline - -: bootstrap-cell-bits 8 bootstrap-cells ; inline - : os-envs ( -- assoc ) (os-envs) [ "=" split1 ] H{ } map>assoc ; diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index d157907cc2..a2c50346df 100755 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -73,8 +73,10 @@ HELP: self { $description "Pushes the currently-running thread." } ; HELP: -{ $values { "quot" quotation } { "name" string } { "error-handler" quotation } } -{ $description "Low-level thread constructor. The thread runs the quotation when spawned; the name is simply used to identify the thread for debugging purposes. The error handler is called if the thread's quotation throws an unhandled error; it should either print the error or notify another thread." } +{ $values { "quot" quotation } { "name" string } { "thread" thread } } +{ $description "Low-level thread constructor. The thread runs the quotation when spawned." +$nl +"The name is used to identify the thread for debugging purposes; see " { $link "tools.threads" } "." } { $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link } " then passed to " { $link (spawn) } "." } ; HELP: run-queue @@ -96,7 +98,7 @@ HELP: sleep-queue { $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ; HELP: sleep-time -{ $values { "ms" "a non-negative integer or " { $link f } } } +{ $values { "ms/f" "a non-negative integer or " { $link f } } } { $description "Outputs the time until the next sleeping thread is scheduled to wake up, which could be zero if there are threads in the run queue, or threads which need to wake up right now. If there are no runnable or sleeping threads, outputs " { $link f } "." } ; HELP: stop @@ -122,11 +124,15 @@ HELP: interrupt { $description "Interrupts a sleeping thread." } ; HELP: suspend -{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } } -{ $description "Suspends the current thread and passes it to the quotation. After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "." } ; +{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "state" string } { "obj" object } } +{ $description "Suspends the current thread and passes it to the quotation." +$nl +"After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "." +$nl +"The status string is for debugging purposes; see " { $link "tools.threads" } "." } ; HELP: spawn -{ $values { "quot" quotation } { "name" string } } +{ $values { "quot" quotation } { "name" string } { "thread" thread } } { $description "Spawns a new thread. The thread begins executing the given quotation; the name is for debugging purposes. The new thread begins running immediately and the current thread is added to the end of the run queue." $nl "The new thread begins with an empty data stack, an empty retain stack, and an empty catch stack. The name stack is inherited from the parent thread but may be cleared with " { $link init-namespaces } "." } @@ -138,7 +144,7 @@ $nl } ; HELP: spawn-server -{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } } +{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } { "thread" thread } } { $description "Convenience wrapper around " { $link spawn } " which repeatedly calls the quotation in a new thread until it outputs " { $link f } "." } { $examples "A thread that runs forever:" diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index a4fe3265fc..c03b9784ee 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -180,6 +180,7 @@ HELP: construct-empty { $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." } { $examples { $example + "USING: kernel prettyprint ;" "TUPLE: employee number name department ;" "employee construct-empty ." "T{ employee f f f f }" diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index ed97bcc0c4..1820c62ff4 100755 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -5,7 +5,7 @@ IN: vectors vector ( byte-array capacity -- byte-vector ) +: array>vector ( array length -- vector ) vector construct-boa ; inline PRIVATE> diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index a306efbd68..c7652c34c7 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -23,9 +23,6 @@ $nl "Application vocabularies can define a main entry point, giving the user a convenient way to run the application:" { $subsection POSTPONE: MAIN: } { $subsection run } -"Reloading source files changed on disk:" -{ $subsection refresh } -{ $subsection refresh-all } { $see-also "vocabularies" "parser-files" "source-files" } ; ABOUT: "vocabs.loader" @@ -42,20 +39,12 @@ HELP: vocab-main HELP: vocab-roots { $var-description "A sequence of pathname strings to search for vocabularies." } ; -HELP: vocab-tests -{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; - HELP: find-vocab-root { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } } { $description "Searches for a vocabulary in the vocabulary roots." } ; { vocab-root find-vocab-root } related-words -HELP: vocab-files -{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; - HELP: no-vocab { $values { "name" "a vocabulary name" } } { $description "Throws a " { $link no-vocab } "." } @@ -65,12 +54,12 @@ HELP: load-help? { $var-description "If set to a true value, documentation will be automatically loaded when vocabularies are loaded. This variable is usually on, except when Factor has been bootstrapped without the help system." } ; HELP: load-source -{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } } -{ $description "Loads a vocabulary's source code from the specified vocabulary root." } ; +{ $values { "vocab" "a vocabulary specifier" } } +{ $description "Loads a vocabulary's source code." } ; HELP: load-docs -{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } } -{ $description "If " { $link load-help? } " is on, loads a vocabulary's documentation from the specified vocabulary root." } ; +{ $values { "vocab" "a vocabulary specifier" } } +{ $description "If " { $link load-help? } " is on, loads a vocabulary's documentation." } ; HELP: reload { $values { "name" "a vocabulary name" } } @@ -80,7 +69,7 @@ HELP: reload HELP: require { $values { "vocab" "a vocabulary specifier" } } { $description "Loads a vocabulary if it has not already been loaded." } -{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files, use " { $link refresh } " or " { $link refresh-all } "." } ; +{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ; HELP: run { $values { "vocab" "a vocabulary specifier" } } @@ -93,12 +82,3 @@ HELP: vocab-source-path HELP: vocab-docs-path { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } } { $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ; - -HELP: refresh -{ $values { "prefix" string } } -{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; - -HELP: refresh-all -{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; - -{ refresh refresh-all } related-words diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index f99bf94aa4..514e45f10f 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -3,7 +3,7 @@ IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs tuples definitions -debugger compiler.units ; +debugger compiler.units tools.vocabs ; ! This vocab should not exist, but just in case... [ ] [ diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index b21329de9c..fa9ff5b504 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -48,34 +48,13 @@ M: string vocab-root M: vocab-link vocab-root vocab-link-root ; -: vocab-tests ( vocab -- tests ) - dup vocab-root [ - [ - f >vocab-link dup - - dup "-tests.factor" vocab-dir+ vocab-path+ - dup resource-exists? [ , ] [ drop ] if - - dup vocab-dir "tests" path+ vocab-path+ dup - ?resource-path directory keys [ ".factor" tail? ] subset - [ path+ , ] with each - ] { } make - ] [ drop f ] if ; - -: vocab-files ( vocab -- seq ) - f >vocab-link [ - dup vocab-source-path [ , ] when* - dup vocab-docs-path [ , ] when* - vocab-tests % - ] { } make ; - SYMBOL: load-help? : source-was-loaded t swap set-vocab-source-loaded? ; : source-wasn't-loaded f swap set-vocab-source-loaded? ; -: load-source ( vocab-link -- ) +: load-source ( vocab -- ) [ source-wasn't-loaded ] keep [ vocab-source-path bootstrap-file ] keep source-was-loaded ; @@ -84,7 +63,7 @@ SYMBOL: load-help? : docs-weren't-loaded f swap set-vocab-docs-loaded? ; -: load-docs ( vocab-link -- ) +: load-docs ( vocab -- ) load-help? get [ [ docs-weren't-loaded ] keep [ vocab-docs-path ?run-file ] keep @@ -119,68 +98,7 @@ SYMBOL: load-help? "To define one, refer to \\ MAIN: help" print ] ?if ; -: modified ( seq quot -- seq ) - [ dup ] swap compose { } map>assoc - [ nip ] assoc-subset - [ nip source-modified? ] assoc-subset keys ; inline - -: modified-sources ( vocabs -- seq ) - [ vocab-source-path ] modified ; - -: modified-docs ( vocabs -- seq ) - [ vocab-docs-path ] modified ; - -: update-roots ( vocabs -- ) - [ dup find-vocab-root swap vocab set-vocab-root ] each ; - -: to-refresh ( prefix -- modified-sources modified-docs ) - child-vocabs - dup update-roots - dup modified-sources swap modified-docs ; - -: vocab-heading. ( vocab -- ) - nl - "==== " write - dup vocab-name swap vocab write-object ":" print - nl ; - -: load-error. ( triple -- ) - dup first vocab-heading. - dup second print-error - drop ; - -: load-failures. ( failures -- ) - [ load-error. nl ] each ; - SYMBOL: blacklist -SYMBOL: failures - -: require-all ( vocabs -- failures ) - [ - V{ } clone blacklist set - V{ } clone failures set - [ - [ require ] - [ swap vocab-name failures get set-at ] - recover - ] each - failures get - ] with-compiler-errors ; - -: do-refresh ( modified-sources modified-docs -- ) - 2dup - [ f swap set-vocab-docs-loaded? ] each - [ f swap set-vocab-source-loaded? ] each - append prune require-all load-failures. ; - -: refresh ( prefix -- ) to-refresh do-refresh ; - -SYMBOL: sources-changed? - -[ t sources-changed? set-global ] "vocabs.loader" add-init-hook - -: refresh-all ( -- ) - "" refresh f sources-changed? set-global ; GENERIC: (load-vocab) ( name -- vocab ) diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 4903f8933b..eb1bd0908a 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -197,7 +197,7 @@ HELP: execute ( word -- ) { $values { "word" word } } { $description "Executes a word." } { $examples - { $example ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } + { $example "USING: kernel io words ;" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; HELP: word-props ( word -- props ) @@ -322,7 +322,7 @@ HELP: create HELP: constructor-word { $values { "name" string } { "vocab" string } { "word" word } } { $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." } -{ $examples { $example "\"salmon\" \"scratchpad\" constructor-word ." "" } } ; +{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "" } } ; HELP: forget-word { $values { "word" word } } diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor index fcb2de8b6b..80a0c14079 100755 --- a/extra/alarms/alarms-docs.factor +++ b/extra/alarms/alarms-docs.factor @@ -9,7 +9,7 @@ HELP: add-alarm { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; HELP: later -{ $values { "quot" quotation } { "time" duration } { "alarm" alarm } } +{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } } { $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ; HELP: cancel-alarm diff --git a/extra/alarms/alarms-tests.factor b/extra/alarms/alarms-tests.factor index 1af851c9c6..d1161e4cee 100755 --- a/extra/alarms/alarms-tests.factor +++ b/extra/alarms/alarms-tests.factor @@ -1,6 +1,6 @@ IN: alarms.tests -USING: alarms kernel calendar sequences tools.test threads -concurrency.count-downs ; +USING: alarms alarms.private kernel calendar sequences +tools.test threads concurrency.count-downs ; [ ] [ 1 @@ -15,3 +15,5 @@ concurrency.count-downs ; [ resume ] curry instant later drop ] "test" suspend drop ] unit-test + +\ alarm-thread-loop must-infer diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 55a66c5231..adf79c84c9 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -38,7 +38,7 @@ SYMBOL: alarm-thread : call-alarm ( alarm -- ) dup alarm-entry box> drop - dup alarm-quot try + dup alarm-quot "Alarm execution" spawn drop dup alarm-interval [ reschedule-alarm ] [ drop ] if ; : (trigger-alarms) ( alarms now -- ) @@ -62,8 +62,7 @@ SYMBOL: alarm-thread : alarm-thread-loop ( -- ) alarms get-global dup next-alarm sleep-until - dup trigger-alarms - alarm-thread-loop ; + trigger-alarms ; : cancel-alarms ( alarms -- ) [ @@ -72,7 +71,7 @@ SYMBOL: alarm-thread : init-alarms ( -- ) alarms global [ cancel-alarms ] change-at - [ alarm-thread-loop ] "Alarms" spawn + [ alarm-thread-loop t ] "Alarms" spawn-server alarm-thread set-global ; [ init-alarms ] "alarms" add-init-hook diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 231c6edf50..26f1a9e96d 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -1,28 +1,28 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel vocabs vocabs.loader tools.time tools.browser +USING: kernel vocabs vocabs.loader tools.time tools.vocabs arrays assocs io.styles io help.markup prettyprint sequences -continuations debugger ; +continuations debugger combinators.cleave ; IN: benchmark : run-benchmark ( vocab -- result ) - [ dup require [ run ] benchmark ] [ error. drop f f ] recover 2array ; + [ [ require ] [ [ run ] benchmark nip ] bi ] curry + [ error. f ] recover ; : run-benchmarks ( -- assoc ) - "benchmark" all-child-vocabs values concat [ vocab-name ] map + "benchmark" all-child-vocabs-seq [ dup run-benchmark ] { } map>assoc ; : benchmarks. ( assoc -- ) standard-table-style [ [ [ "Benchmark" write ] with-cell - [ "Run time (ms)" write ] with-cell - [ "GC time (ms)" write ] with-cell + [ "Time (ms)" write ] with-cell ] with-row [ [ - swap [ dup ($vocab-link) ] with-cell - first2 pprint-cell pprint-cell + [ [ 1array $vocab-link ] with-cell ] + [ pprint-cell ] bi* ] with-row ] assoc-each ] tabular-output ; diff --git a/extra/benchmark/crc32/crc32.factor b/extra/benchmark/crc32/crc32.factor old mode 100644 new mode 100755 index 7dad272296..ec424e89c9 --- a/extra/benchmark/crc32/crc32.factor +++ b/extra/benchmark/crc32/crc32.factor @@ -1,10 +1,10 @@ -USING: io.crc32 io.files kernel math ; +USING: io.crc32 io.encodings.ascii io.files kernel math ; IN: benchmark.crc32 : crc32-primes-list ( -- ) 10 [ "extra/math/primes/list/list.factor" resource-path - file-contents crc32 drop + ascii file-contents crc32 drop ] times ; MAIN: crc32-primes-list diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor old mode 100644 new mode 100755 index 3c9c78d358..30c3beb1ef --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -51,7 +51,7 @@ HINTS: random fixnum ; dup keys >byte-array swap values >float-array unclip [ + ] accumulate swap add ; -:: select-random ( seed chars floats -- elt ) +:: select-random ( seed chars floats -- seed elt ) floats seed random -rot [ >= ] curry find drop chars nth-unsafe ; inline @@ -71,7 +71,7 @@ HINTS: random fixnum ; write-description [ make-random-fasta ] 2curry split-lines ; inline -:: make-repeat-fasta ( k len alu -- ) +:: make-repeat-fasta ( k len alu -- k' ) [let | kn [ alu length ] | len [ k + kn mod alu nth-unsafe ] B{ } map-as print k len + diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 0f8c81da75..b890fdc8e8 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,7 +1,7 @@ IN: benchmark.mandel -USING: arrays io kernel math namespaces sequences strings sbufs -math.functions math.parser io.files colors.hsv -io.encodings.ascii ; +USING: arrays io kernel math namespaces sequences +byte-arrays byte-vectors math.functions math.parser io.files +colors.hsv io.encodings.binary ; : max-color 360 ; inline : zoom-fact 0.8 ; inline @@ -54,18 +54,18 @@ SYMBOL: cols : ppm-header ( w h -- ) "P6\n" % swap # " " % # "\n255\n" % ; -: sbuf-size width height * 3 * 100 + ; +: buf-size width height * 3 * 100 + ; -: mandel ( -- string ) +: mandel ( -- data ) [ - sbuf-size building set + buf-size building set width height ppm-header nb-iter max-color min cols set render - building get >string + building get >byte-array ] with-scope ; : mandel-main ( -- ) - mandel "mandel.ppm" temp-file ascii set-file-contents ; + mandel "mandel.ppm" temp-file binary set-file-contents ; MAIN: mandel-main diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor old mode 100644 new mode 100755 index 95c797cddd..775595709a --- a/extra/benchmark/random/random.factor +++ b/extra/benchmark/random/random.factor @@ -1,10 +1,10 @@ -USING: io.files random math.parser io math ; +USING: io.files io.encodings.ascii random math.parser io math ; IN: benchmark.random : random-numbers-path "random-numbers.txt" temp-file ; : write-random-numbers ( n -- ) - random-numbers-path [ + random-numbers-path ascii [ [ 200 random 100 - number>string print ] times ] with-file-writer ; diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor old mode 100644 new mode 100755 index 4bb8c30383..dbd1f5131b --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -3,7 +3,7 @@ USING: float-arrays compiler generic io io.files kernel math math.functions math.vectors math.parser namespaces sequences -sequences.private words io.encodings.ascii ; +sequences.private words io.encodings.binary ; IN: benchmark.raytracer ! parameters @@ -167,9 +167,9 @@ DEFER: create ( level c r -- scene ) levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [ size size pgm-header [ [ oversampling sq / pgm-pixel ] each ] each - ] "" make ; + ] B{ } make ; : raytracer-main - run "raytracer.pnm" temp-file ascii set-file-contents ; + run "raytracer.pnm" temp-file binary set-file-contents ; MAIN: raytracer-main diff --git a/extra/benchmark/sort/sort.factor b/extra/benchmark/sort/sort.factor old mode 100644 new mode 100755 index a54480692a..cd6189fe22 --- a/extra/benchmark/sort/sort.factor +++ b/extra/benchmark/sort/sort.factor @@ -1,8 +1,10 @@ USING: kernel sequences sorting benchmark.random math.parser -io.files ; +io.files io.encodings.ascii ; IN: benchmark.sort : sort-benchmark - random-numbers-path file-lines [ string>number ] map natural-sort drop ; + random-numbers-path + ascii file-lines [ string>number ] map + natural-sort drop ; MAIN: sort-benchmark diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index 718f73308c..0bf7a032ee 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -11,5 +11,7 @@ USING: vocabs.loader sequences ; "tools.test" "tools.time" "tools.threads" + "tools.vocabs" + "tools.vocabs.browser" "editors" } [ require ] each diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100644 new mode 100755 index 68f525ec6c..da96e51dd4 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -164,7 +164,7 @@ SYMBOL: builder-recipients builder-recipients get >>to subject >>subject "./report" file>string >>body - send ; + send-email ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor old mode 100644 new mode 100755 index dd3c640a84..409d0db11c --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -4,7 +4,7 @@ USING: kernel namespaces sequences assocs builder continuations io io.files prettyprint - tools.browser + tools.vocabs tools.test io.encodings.utf8 combinators.cleave diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor index 12aaffc19c..a3f6174726 100755 --- a/extra/bunny/deploy.factor +++ b/extra/bunny/deploy.factor @@ -1,12 +1,14 @@ USING: tools.deploy.config ; -V{ +H{ + { deploy-math? t } + { deploy-reflection 1 } + { deploy-name "Bunny" } + { deploy-threads? t } + { deploy-word-props? f } + { "stop-after-last-window?" t } { deploy-ui? t } { deploy-io 3 } - { deploy-reflection 1 } { deploy-compiler? t } - { deploy-math? t } - { deploy-word-props? f } + { deploy-word-defs? f } { deploy-c-types? f } - { "stop-after-last-window?" t } - { deploy-name "Bunny" } } diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor old mode 100644 new mode 100755 index d7064ebdde..012aa1fd78 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,7 +1,7 @@ USING: arrays bunny.model bunny.cel-shaded combinators.lib continuations kernel math multiline opengl opengl.shaders opengl.framebuffers opengl.gl -opengl.capabilities sequences ui.gadgets ; +opengl.capabilities sequences ui.gadgets combinators.cleave ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source @@ -177,7 +177,7 @@ TUPLE: bunny-outlined [ bunny-outlined-normal-texture [ delete-texture ] when* ] [ bunny-outlined-depth-texture [ delete-texture ] when* ] [ f swap set-bunny-outlined-framebuffer-dim ] - } call-with + } cleave ] [ drop ] if ; : remake-framebuffer-if-needed ( draw -- ) @@ -237,4 +237,4 @@ M: bunny-outlined dispose [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] [ dispose-framebuffer ] - } call-with ; + } cleave ; diff --git a/extra/combinators/cleave/cleave-docs.factor b/extra/combinators/cleave/cleave-docs.factor new file mode 100644 index 0000000000..0c491b88b1 --- /dev/null +++ b/extra/combinators/cleave/cleave-docs.factor @@ -0,0 +1,82 @@ + +USING: kernel quotations help.syntax help.markup ; + +IN: combinators.cleave + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ARTICLE: "cleave-combinators" "Cleave Combinators" + +{ $subsection bi } +{ $subsection tri } + +{ $notes + "From the Merriam-Webster Dictionary: " + $nl + { $strong "cleave" } + { $list + { $emphasis "To divide by or as if by a cutting blow" } + { $emphasis "To separate into distinct parts and especially into " + "groups having divergent views" } } + $nl + "The Joy programming language has a " { $emphasis "cleave" } " combinator." } + +; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: bi + + { $values { "x" object } + { "p" quotation } + { "q" quotation } + + { "p(x)" "p applied to x" } + { "q(x)" "q applied to x" } } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: tri + + { $values { "x" object } + { "p" quotation } + { "q" quotation } + { "r" quotation } + + { "p(x)" "p applied to x" } + { "q(x)" "q applied to x" } + { "r(x)" "r applied to x" } } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +ARTICLE: "spread-combinators" "Spread Combinators" + +{ $subsection bi* } +{ $subsection tri* } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: bi* + + { $values { "x" object } + { "y" object } + { "p" quotation } + { "q" quotation } + + { "p(x)" "p applied to x" } + { "q(y)" "q applied to y" } } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +HELP: tri* + + { $values { "x" object } + { "y" object } + { "z" object } + { "p" quotation } + { "q" quotation } + { "r" quotation } + + { "p(x)" "p applied to x" } + { "q(y)" "q applied to y" } + { "r(z)" "r applied to z" } } ; diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor old mode 100644 new mode 100755 index 44555f7b1e..383d5ca9ac --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -7,10 +7,8 @@ IN: combinators.cleave ! The cleaver family ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: bi ( obj quot quot -- val val ) >r keep r> call ; inline - -: tri ( obj quot quot quot -- val val val ) - >r pick >r bi r> r> call ; inline +: bi ( x p q -- p(x) q(x) ) >r keep r> call ; inline +: tri ( x p q r -- p(x) q(x) r(x) ) >r pick >r bi r> r> call ; inline : tetra ( obj quot quot quot quot -- val val val val ) >r >r pick >r bi r> r> r> bi ; inline @@ -19,6 +17,9 @@ IN: combinators.cleave : 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline +: 2tri ( obj obj quot quot quot -- val val val ) + >r >r 2keep r> 2keep r> call ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! General cleave @@ -39,9 +40,9 @@ MACRO: cleave ( seq -- ) ! The spread family ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: bi* ( obj obj quot quot -- val val ) >r swap slip r> call ; inline +: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline -: tri* ( obj obj obj quot quot quot -- val val val ) +: tri* ( x y z p q r -- p(x) q(y) r(z) ) >r rot >r bi* r> r> call ; inline : tetra* ( obj obj obj obj quot quot quot quot -- val val val val ) diff --git a/extra/combinators/lib/lib-docs.factor b/extra/combinators/lib/lib-docs.factor index d850243bd0..c88ce8d9f9 100755 --- a/extra/combinators/lib/lib-docs.factor +++ b/extra/combinators/lib/lib-docs.factor @@ -7,7 +7,7 @@ HELP: generate { $description "Loop until the generator quotation generates an object that satisfies predicate quotation." } { $unchecked-example "! Generate a random 20-bit prime number congruent to 3 (mod 4)" - "USE: math.miller-rabin" + "USING: combinators.lib math math.miller-rabin prettyprint ;" "[ 20 random-prime ] [ 4 mod 3 = ] generate ." "526367" } ; @@ -20,8 +20,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USE: combinators.lib" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } - { $example "USE: combinators.lib" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } + { $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } + { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } } { $see-also dip dipd } ; @@ -32,7 +32,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USE: combinators.lib" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: combinators.lib prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } } { $see-also slip nkeep } ; @@ -43,7 +43,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USE: combinators.lib" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } } { $see-also keep nslip } ; diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index f65b94dc11..7c93f805cd 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -133,9 +133,6 @@ MACRO: parallel-call ( quots -- ) : (make-call-with) ( quots -- quot ) [ [ keep ] curry ] map concat [ drop ] append ; -MACRO: call-with ( quots -- ) - (make-call-with) ; - MACRO: map-call-with ( quots -- ) [ (make-call-with) ] keep length [ narray ] curry compose ; @@ -143,9 +140,6 @@ MACRO: map-call-with ( quots -- ) [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat [ 2drop ] append ; -MACRO: call-with2 ( quots -- ) - (make-call-with2) ; - MACRO: map-call-with2 ( quots -- ) [ (make-call-with2) ] keep length [ narray ] curry append ; diff --git a/extra/concurrency/distributed/distributed-docs.factor b/extra/concurrency/distributed/distributed-docs.factor index 4fae6ddbcc..b3f3b633cd 100755 --- a/extra/concurrency/distributed/distributed-docs.factor +++ b/extra/concurrency/distributed/distributed-docs.factor @@ -2,9 +2,7 @@ USING: help.markup help.syntax concurrency.messaging threads ; IN: concurrency.distributed HELP: local-node -{ $values { "addrspec" "an address specifier" } -} -{ $description "Return the node the current thread is running on." } ; +{ $var-description "A variable containing the node the current thread is running on." } ; HELP: start-node { $values { "port" "a port number between 0 and 65535" } } diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor new file mode 100755 index 0000000000..0941eb4251 --- /dev/null +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -0,0 +1,31 @@ +IN: concurrency.distributed.tests +USING: tools.test concurrency.distributed kernel io.files +arrays io.sockets system combinators threads math sequences +concurrency.messaging ; + +: test-node + { + { [ unix? ] [ "distributed-concurrency-test" temp-file ] } + { [ windows? ] [ "127.0.0.1" 1238 ] } + } cond ; + +[ ] [ test-node dup 1array swap (start-node) ] unit-test + +[ ] [ yield ] unit-test + +[ ] [ + [ + receive first2 >r 3 + r> send + "thread-a" unregister-process + ] "Thread A" spawn + "thread-a" swap register-process +] unit-test + +[ 8 ] [ + 5 self 2array + "thread-a" test-node send + + receive +] unit-test + +[ ] [ test-node stop-node ] unit-test diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index f09c441d26..c0787a96a2 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -2,35 +2,46 @@ ! See http://factorcode.org/license.txt for BSD license. USING: serialize sequences concurrency.messaging threads io io.server qualified arrays -namespaces kernel io.encodings.binary ; +namespaces kernel io.encodings.binary combinators.cleave +new-slots accessors ; QUALIFIED: io.sockets IN: concurrency.distributed -SYMBOL: local-node ( -- addrspec ) +SYMBOL: local-node : handle-node-client ( -- ) - deserialize first2 get-process send ; + deserialize + [ first2 get-process send ] + [ stop-server ] if* ; : (start-node) ( addrspecs addrspec -- ) + local-node set-global [ - local-node set-global "concurrency.distributed" - binary [ handle-node-client ] with-server - ] 2curry f spawn drop ; + binary + [ handle-node-client ] with-server + ] curry "Distributed concurrency server" spawn drop ; : start-node ( port -- ) - dup internet-server io.sockets:host-name - rot io.sockets: (start-node) ; + [ internet-server ] + [ io.sockets:host-name swap io.sockets: ] bi + (start-node) ; TUPLE: remote-process id node ; C: remote-process +: send-remote-message ( message node -- ) + binary io.sockets: + [ serialize ] with-stream ; + M: remote-process send ( message thread -- ) - { remote-process-id remote-process-node } get-slots - binary io.sockets: [ 2array serialize ] with-stream ; + [ id>> 2array ] [ node>> ] bi + send-remote-message ; M: thread (serialize) ( obj -- ) - thread-id local-node get-global - + thread-id local-node get-global (serialize) ; + +: stop-node ( node -- ) + f swap send-remote-message ; diff --git a/extra/concurrency/locks/locks-docs.factor b/extra/concurrency/locks/locks-docs.factor index 3a89af5ba0..a3cf2fc782 100755 --- a/extra/concurrency/locks/locks-docs.factor +++ b/extra/concurrency/locks/locks-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax sequences kernel quotations ; +USING: help.markup help.syntax sequences kernel quotations +calendar ; IN: concurrency.locks HELP: lock @@ -12,11 +13,15 @@ HELP: { $values { "lock" lock } } { $description "Creates a reentrant lock." } ; -HELP: with-lock -{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +HELP: with-lock-timeout +{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } { $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } { $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; +HELP: with-lock +{ $values { "lock" lock } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } ; + ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks" "A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads." $nl @@ -24,21 +29,30 @@ $nl { $subsection lock } { $subsection } { $subsection } -{ $subsection with-lock } ; +{ $subsection with-lock } +{ $subsection with-lock-timeout } ; HELP: rw-lock { $class-description "The class of reader/writer locks." } ; -HELP: with-read-lock -{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +HELP: with-read-lock-timeout +{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } { $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } { $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; -HELP: with-write-lock -{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } } +HELP: with-read-lock +{ $values { "lock" lock } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ; + +HELP: with-write-lock-timeout +{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } { $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } { $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ; +HELP: with-write-lock +{ $values { "lock" lock } { "quot" quotation } } +{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } ; + ARTICLE: "concurrency.locks.rw" "Read-write locks" "A read-write lock encapsulates a common pattern in the implementation of concurrent data structures, where one wishes to ensure that a thread is able to see a consistent view of the structure for a period of time, during which no other thread modifies the structure." $nl @@ -50,7 +64,10 @@ $nl { $subsection rw-lock } { $subsection } { $subsection with-read-lock } -{ $subsection with-write-lock } ; +{ $subsection with-write-lock } +"Versions of the above that take a timeout duration:" +{ $subsection with-read-lock-timeout } +{ $subsection with-write-lock-timeout } ; ARTICLE: "concurrency.locks" "Locks" "A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:" diff --git a/extra/concurrency/messaging/messaging-docs.factor b/extra/concurrency/messaging/messaging-docs.factor index bee80fd357..e7aa5d1a7e 100755 --- a/extra/concurrency/messaging/messaging-docs.factor +++ b/extra/concurrency/messaging/messaging-docs.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: help.syntax help.markup concurrency.messaging.private -threads kernel arrays quotations ; +threads kernel arrays quotations threads strings ; IN: concurrency.messaging HELP: send { $values { "message" object } - { "thread" "a thread object" } + { "thread" thread } } { $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." } { $see-also receive receive-if } ; @@ -26,7 +26,8 @@ HELP: receive-if HELP: spawn-linked { $values { "quot" quotation } - { "thread" "a thread object" } + { "name" string } + { "thread" thread } } { $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } { $see-also spawn } ; diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index 6915653eb4..cfa2aea30d 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -7,7 +7,7 @@ USING: kernel threads concurrency.mailboxes continuations namespaces assocs random ; IN: concurrency.messaging -GENERIC: send ( message process -- ) +GENERIC: send ( message thread -- ) : mailbox-of ( thread -- mailbox ) dup thread-mailbox [ ] [ diff --git a/extra/concurrency/promises/promises-docs.factor b/extra/concurrency/promises/promises-docs.factor index a4d79d8a47..6a4a2bf8d6 100755 --- a/extra/concurrency/promises/promises-docs.factor +++ b/extra/concurrency/promises/promises-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.messaging kernel arrays -continuations help.markup help.syntax quotations ; +continuations help.markup help.syntax quotations calendar ; IN: concurrency.promises HELP: promise @@ -12,12 +12,12 @@ HELP: promise-fulfilled? { $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ; HELP: ?promise-timeout -{ $values { "promise" promise } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } +{ $values { "promise" promise } { "timeout" "a " { $link duration } " or " { $link f } } { "result" object } } { $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." } { $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ; HELP: ?promise -{ $values { "promise" promise } { "value" object } } +{ $values { "promise" promise } { "result" object } } { $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled." } ; HELP: fulfill diff --git a/extra/concurrency/semaphores/semaphores-docs.factor b/extra/concurrency/semaphores/semaphores-docs.factor index 76a87f2077..33f4de8783 100755 --- a/extra/concurrency/semaphores/semaphores-docs.factor +++ b/extra/concurrency/semaphores/semaphores-docs.factor @@ -9,12 +9,12 @@ HELP: { $description "Creates a counting semaphore with the specified initial count." } ; HELP: acquire-timeout -{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "value" object } } +{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } } { $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." } { $errors "Throws an error if the timeout expires before the semaphore is released." } ; HELP: acquire -{ $values { "semaphore" semaphore } { "value" object } } +{ $values { "semaphore" semaphore } } { $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ; HELP: release diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor index 032e174eb1..b53ecaac3c 100644 --- a/extra/crypto/common/common-docs.factor +++ b/extra/crypto/common/common-docs.factor @@ -3,19 +3,19 @@ math.private ; IN: crypto.common HELP: >32-bit -{ $values { "x" "an integer" } { "y" "an integer" } } +{ $values { "x" integer } { "y" integer } } { $description "Used to implement 32-bit integer overflow." } ; HELP: >64-bit -{ $values { "x" "an integer" } { "y" "an integer" } } +{ $values { "x" integer } { "y" integer } } { $description "Used to implement 64-bit integer overflow." } ; HELP: bitroll -{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" "an integer" } } +{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } { $description "Roll n by s bits to the left, wrapping around after w bits." } { $examples - { $example "USE: crypto.common" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } - { $example "USE: crypto.common" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } + { $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } + { $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } } ; @@ -23,7 +23,7 @@ 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 "USE: crypto.common" "B{ 1 2 3 4 } hex-string print" "01020304" } + { $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/rc4/authors.txt b/extra/crypto/rc4/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/crypto/rc4/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/crypto/rc4/rc4.factor b/extra/crypto/rc4/rc4.factor deleted file mode 100644 index b730c4b7fe..0000000000 --- a/extra/crypto/rc4/rc4.factor +++ /dev/null @@ -1,39 +0,0 @@ -USING: kernel math sequences namespaces ; -IN: crypto.rc4 - -! http://en.wikipedia.org/wiki/RC4_%28cipher%29 - - - -: rc4 ( key -- ) - [ - [ key set ] keep - length l set - ksa - 0 i set - 0 j set - ] with-scope ; - diff --git a/extra/db/db.factor b/extra/db/db.factor index 170d9a60f1..309847209f 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -20,8 +20,7 @@ GENERIC: db-open ( db -- ) HOOK: db-close db ( handle -- ) : make-db ( seq class -- db ) construct-empty make-db* ; -: dispose-statements ( seq -- ) - [ dispose drop ] assoc-each ; +: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ; : dispose-db ( db -- ) dup db [ @@ -46,8 +45,8 @@ GENERIC: bind-tuple ( tuple statement -- ) GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) GENERIC: #columns ( result-set -- n ) -GENERIC# row-column 1 ( result-set n -- obj ) -GENERIC# row-column-typed 1 ( result-set n -- sql ) +GENERIC# row-column 1 ( result-set column -- obj ) +GENERIC# row-column-typed 1 ( result-set column -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index d14ec13ff8..be491b8c85 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -6,7 +6,7 @@ IN: db.postgresql.ffi << "postgresql" { { [ win32? ] [ "libpq.dll" ] } - { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] } + { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } { [ unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> @@ -270,7 +270,8 @@ FUNCTION: char* PQcmdStatus ( PGresult* res ) ; FUNCTION: char* PQoidStatus ( PGresult* res ) ; FUNCTION: Oid PQoidValue ( PGresult* res ) ; FUNCTION: char* PQcmdTuples ( PGresult* res ) ; -FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ; +! FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ; +FUNCTION: void* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ; FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ; FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ; @@ -297,8 +298,8 @@ FUNCTION: size_t PQescapeStringConn ( PGconn* conn, FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn, char* from, size_t length, size_t* to_length ) ; -FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, - size_t* retbuflen ) ; +FUNCTION: void* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ; +! FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ; ! These forms are deprecated! FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ; FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen, @@ -346,3 +347,23 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ; ! Get encoding id from environment variable PGCLIENTENCODING FUNCTION: int PQenv2encoding ( ) ; + +! From git, include/catalog/pg_type.h +: BOOL-OID 16 ; inline +: BYTEA-OID 17 ; inline +: CHAR-OID 18 ; inline +: NAME-OID 19 ; inline +: INT8-OID 20 ; inline +: INT2-OID 21 ; inline +: INT4-OID 23 ; inline +: TEXT-OID 23 ; inline +: OID-OID 26 ; inline +: FLOAT4-OID 700 ; inline +: FLOAT8-OID 701 ; inline +: VARCHAR-OID 1043 ; inline +: DATE-OID 1082 ; inline +: TIME-OID 1083 ; inline +: TIMESTAMP-OID 1114 ; inline +: TIMESTAMPTZ-OID 1184 ; inline +: INTERVAL-OID 1186 ; inline +: NUMERIC-OID 1700 ; inline diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 25b3a6d2cf..b48c87f0ca 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -2,7 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types -db.types tools.walker ascii splitting ; +db.types tools.walker ascii splitting math.parser +combinators combinators.cleave libc shuffle calendar.format +byte-arrays destructors prettyprint new-slots accessors +strings serialize io.encodings.binary io.streams.byte-array ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -38,13 +41,130 @@ IN: db.postgresql.lib dup postgresql-result-error-message swap PQclear throw ] unless ; +: type>oid ( symbol -- n ) + dup array? [ first ] when + { + { BLOB [ BYTEA-OID ] } + { FACTOR-BLOB [ BYTEA-OID ] } + [ drop 0 ] + } case ; + +: type>param-format ( symbol -- n ) + dup array? [ first ] when + { + { BLOB [ 1 ] } + { FACTOR-BLOB [ 1 ] } + [ drop 0 ] + } case ; + +: param-types ( statement -- seq ) + statement-in-params + [ sql-spec-type type>oid ] map + >c-uint-array ; + +: malloc-byte-array/length + [ malloc-byte-array dup free-always ] [ length ] bi ; + + +: param-values ( statement -- seq seq2 ) + [ statement-bind-params ] + [ statement-in-params ] bi + [ + sql-spec-type { + { FACTOR-BLOB [ + dup [ + binary [ serialize ] with-byte-writer + malloc-byte-array/length ] [ 0 ] if ] } + { BLOB [ + dup [ malloc-byte-array/length ] [ 0 ] if ] } + [ + drop number>string* dup [ + malloc-char-string dup free-always + ] when 0 + ] + } case 2array + ] 2map flip dup empty? [ + drop f f + ] [ + first2 [ >c-void*-array ] [ >c-uint-array ] bi* + ] if ; + +: param-formats ( statement -- seq ) + statement-in-params + [ sql-spec-type type>param-format ] map + >c-uint-array ; + : do-postgresql-bound-statement ( statement -- res ) - >r db get db-handle r> - [ statement-sql ] keep - [ statement-bind-params length f ] keep - statement-bind-params - [ number>string* malloc-char-string ] map >c-void*-array - f f 0 PQexecParams - dup postgresql-result-ok? [ - dup postgresql-result-error-message swap PQclear throw - ] unless ; + [ + >r db get db-handle r> + { + [ statement-sql ] + [ statement-bind-params length ] + [ param-types ] + [ param-values ] + [ param-formats ] + } cleave + 0 PQexecParams dup postgresql-result-ok? [ + dup postgresql-result-error-message swap PQclear throw + ] unless + ] with-destructors ; + +: pq-get-is-null ( handle row column -- ? ) + PQgetisnull 1 = ; + +: pq-get-string ( handle row column -- obj ) + 3dup PQgetvalue alien>char-string + dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; + +: pq-get-number ( handle row column -- obj ) + pq-get-string dup [ string>number ] when ; + +TUPLE: postgresql-malloc-destructor alien ; +C: postgresql-malloc-destructor + +M: postgresql-malloc-destructor dispose ( obj -- ) + alien>> PQfreemem ; + +: postgresql-free-always ( alien -- ) + add-always-destructor ; + +: pq-get-blob ( handle row column -- obj/f ) + [ PQgetvalue ] 3keep 3dup PQgetlength + dup 0 > [ + 3nip + [ + memory>byte-array >string + 0 + [ + PQunescapeBytea dup zero? [ + postgresql-result-error-message throw + ] [ + dup postgresql-free-always + ] if + ] keep + *uint memory>byte-array + ] with-destructors + ] [ + drop pq-get-is-null nip [ f ] [ B{ } clone ] if + ] if ; + +: postgresql-column-typed ( handle row column type -- obj ) + dup array? [ first ] when + { + { +native-id+ [ pq-get-number ] } + { INTEGER [ pq-get-number ] } + { BIG-INTEGER [ pq-get-number ] } + { DOUBLE [ pq-get-number ] } + { TEXT [ pq-get-string ] } + { VARCHAR [ pq-get-string ] } + { DATE [ pq-get-string dup [ ymd>timestamp ] when ] } + { TIME [ pq-get-string dup [ hms>timestamp ] when ] } + { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] } + { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] } + { BLOB [ pq-get-blob ] } + { FACTOR-BLOB [ + pq-get-blob + dup [ binary [ deserialize ] with-byte-reader ] when ] } + [ no-sql-type ] + } case ; + ! PQgetlength PQgetisnull diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index a6c2975c89..65b75a63dc 100755 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -7,7 +7,7 @@ db.tuples db.types unicode.case ; IN: db.postgresql.tests : test-db ( -- postgresql-db ) - { "localhost" "postgres" "" "factor-test" } postgresql-db ; + { "localhost" "postgres" "foob" "factor-test" } postgresql-db ; [ ] [ test-db [ ] with-db ] unit-test diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 9383a9290c..26b6cbe75c 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -4,7 +4,8 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges -combinators sequences.lib classes locals words tools.walker ; +combinators sequences.lib classes locals words tools.walker +combinators.cleave namespaces.lib ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; @@ -53,11 +54,12 @@ M: postgresql-result-set #rows ( result-set -- n ) M: postgresql-result-set #columns ( result-set -- n ) result-set-handle PQnfields ; -M: postgresql-result-set row-column ( result-set n -- obj ) - >r dup result-set-handle swap result-set-n r> PQgetvalue ; +M: postgresql-result-set row-column ( result-set column -- obj ) + >r dup result-set-handle swap result-set-n r> pq-get-string ; -M: postgresql-result-set row-column-typed ( result-set n type -- obj ) - >r row-column r> sql-type>factor-type ; +M: postgresql-result-set row-column-typed ( result-set column -- obj ) + dup pick result-set-out-params nth sql-spec-type + >r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ; M: postgresql-statement query-results ( query -- result-set ) dup statement-bind-params [ @@ -236,10 +238,13 @@ M: postgresql-db ( tuple class -- statement ) " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset - " where " 0% - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ";" 0% + dup empty? [ + drop + ] [ + " where " 0% + [ " and " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ] if ";" 0% ] postgresql-make ; M: postgresql-db type-table ( -- hash ) @@ -249,7 +254,12 @@ M: postgresql-db type-table ( -- hash ) { VARCHAR "varchar" } { INTEGER "integer" } { DOUBLE "real" } + { DATE "date" } + { TIME "time" } + { DATETIME "timestamp" } { TIMESTAMP "timestamp" } + { BLOB "bytea" } + { FACTOR-BLOB "bytea" } } ; M: postgresql-db create-type-table ( -- hash ) diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index 2133b0e36c..c490ace770 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -1,4 +1,4 @@ -USING: kernel db.sql ; +USING: kernel namespaces db.sql sequences math ; IN: db.sql.tests TUPLE: person name age ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 9bf9ede895..dbada854fb 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -3,7 +3,8 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize -io.streams.byte-array byte-arrays io.encodings.binary ; +io.streams.byte-array byte-arrays io.encodings.binary +tools.walker ; IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -127,9 +128,9 @@ IN: db.sqlite.lib { +native-id+ [ sqlite3_column_int64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } + { DOUBLE [ sqlite3_column_double ] } { TEXT [ sqlite3_column_text ] } { VARCHAR [ sqlite3_column_text ] } - { DOUBLE [ sqlite3_column_double ] } { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] } { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] } { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } @@ -137,7 +138,7 @@ IN: db.sqlite.lib { BLOB [ sqlite-column-blob ] } { FACTOR-BLOB [ sqlite-column-blob - binary [ deserialize ] with-byte-reader + dup [ binary [ deserialize ] with-byte-reader ] when ] } ! { NULL [ 2drop f ] } [ no-sql-type ] diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 5913f053da..4c47066d35 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -3,10 +3,12 @@ USING: io.files kernel tools.test db db.tuples db.types continuations namespaces math prettyprint tools.walker db.sqlite calendar -math.intervals ; +math.intervals db.postgresql ; IN: db.tuples.tests -TUPLE: person the-id the-name the-number the-real ts date time blob ; +TUPLE: person the-id the-name the-number the-real +ts date time blob factor-blob ; + : ( name age real ts date time blob -- person ) { set-person-the-name @@ -16,9 +18,10 @@ TUPLE: person the-id the-name the-number the-real ts date time blob ; set-person-date set-person-time set-person-blob + set-person-factor-blob } person construct ; -: ( id name age real ts date time blob -- person ) +: ( id name age real ts date time blob factor-blob -- person ) [ set-person-the-id ] keep ; SYMBOL: person1 @@ -27,9 +30,11 @@ SYMBOL: person3 SYMBOL: person4 : test-tuples ( -- ) - [ person drop-table ] [ drop ] recover + [ ] [ person ensure-table ] unit-test + [ ] [ person drop-table ] unit-test [ ] [ person create-table ] unit-test [ person create-table ] must-fail + [ ] [ person ensure-table ] unit-test [ ] [ person1 get insert-tuple ] unit-test @@ -82,6 +87,23 @@ SYMBOL: person4 } ] [ T{ person f 3 } select-tuple ] unit-test + [ ] [ person4 get insert-tuple ] unit-test + [ + T{ + person + f + 4 + "eddie" + 10 + 3.14 + T{ timestamp f 2008 3 5 16 24 11 0 } + T{ timestamp f 2008 11 22 f f f f } + T{ timestamp f f f f 12 34 56 f } + f + H{ { 1 2 } { 3 4 } { 5 "lol" } } + } + ] [ T{ person f 4 } select-tuple ] unit-test + [ ] [ person drop-table ] unit-test ; : make-native-person-table ( -- ) @@ -102,10 +124,12 @@ SYMBOL: person4 { "date" "D" DATE } { "time" "T" TIME } { "blob" "B" BLOB } + { "factor-blob" "FB" FACTOR-BLOB } } define-persistent - "billy" 10 3.14 f f f f person1 set - "johnny" 10 3.14 f f f f person2 set - "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 set ; + "billy" 10 3.14 f f f f f person1 set + "johnny" 10 3.14 f f f f f person2 set + "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set + "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; : assigned-person-schema ( -- ) person "PERSON" @@ -118,10 +142,12 @@ SYMBOL: person4 { "date" "D" DATE } { "time" "T" TIME } { "blob" "B" BLOB } + { "factor-blob" "FB" FACTOR-BLOB } } define-persistent - 1 "billy" 10 3.14 f f f f person1 set - 2 "johnny" 10 3.14 f f f f person2 set - 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 set ; + 1 "billy" 10 3.14 f f f f f person1 set + 2 "johnny" 10 3.14 f f f f f person2 set + 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set + 4 "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; @@ -161,12 +187,15 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-sqlite ( quot -- ) >r "tuples-test.db" temp-file sqlite-db r> with-db ; -! : test-postgresql ( -- ) -! >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; +: test-postgresql ( -- ) +>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite +! [ native-person-schema test-tuples ] test-postgresql +! [ assigned-person-schema test-tuples ] test-postgresql + TUPLE: serialize-me id data ; : test-serialize ( -- ) @@ -183,7 +212,8 @@ TUPLE: serialize-me id data ; { T{ serialize-me f 1 H{ { 1 2 } } } } ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; -! [ test-serialize ] test-sqlite +[ test-serialize ] test-sqlite +! [ test-serialize ] test-postgresql TUPLE: exam id name score ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 32055ccedc..82147a2efa 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -3,7 +3,8 @@ USING: arrays assocs classes db kernel namespaces tuples words sequences slots math math.parser io prettyprint db.types continuations -mirrors sequences.lib tools.walker combinators.lib ; +mirrors sequences.lib tools.walker combinators.lib +combinators.cleave ; IN: db.tuples : define-persistent ( class table columns -- ) @@ -73,6 +74,9 @@ HOOK: insert-tuple* db ( tuple statement -- ) : drop-table ( class -- ) drop-sql-statement [ execute-statement ] with-disposals ; +: ensure-table ( class -- ) + [ dup drop-table ] ignore-errors create-table ; + : insert-native ( tuple -- ) dup class db get db-insert-statements [ ] cache diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 3b65466225..4ee906bccb 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser kernel namespaces sequences definitions io.files -inspector continuations tuples tools.crossref tools.browser +inspector continuations tuples tools.crossref tools.vocabs io prettyprint source-files assocs vocabs vocabs.loader ; IN: editors @@ -13,8 +13,7 @@ M: no-edit-hook summary SYMBOL: edit-hook : available-editors ( -- seq ) - "editors" all-child-vocabs - values concat [ vocab-name ] map ; + "editors" all-child-vocabs-seq [ vocab-name ] map ; : editor-restarts ( -- alist ) available-editors diff --git a/extra/editors/vim/generate-syntax/generate-syntax.factor b/extra/editors/vim/generate-syntax/generate-syntax.factor new file mode 100644 index 0000000000..178a1b3b8b --- /dev/null +++ b/extra/editors/vim/generate-syntax/generate-syntax.factor @@ -0,0 +1,10 @@ +! Generate a new factor.vim file for syntax highlighting +USING: http.server.templating.fhtml io.files ; +IN: editors.vim.generate-syntax + +: generate-vim-syntax ( -- ) + "misc/factor.vim.fgen" resource-path + "misc/factor.vim" resource-path + template-convert ; + +MAIN: generate-vim-syntax diff --git a/extra/editors/vim/generate-vim-syntax.factor b/extra/editors/vim/generate-vim-syntax.factor deleted file mode 100644 index 23bd49cdb8..0000000000 --- a/extra/editors/vim/generate-vim-syntax.factor +++ /dev/null @@ -1,10 +0,0 @@ -! Generate a new factor.vim file for syntax highlighting -REQUIRES: apps/http-server ; - -IN: vim - -USING: embedded io ; - -"extras/factor.vim.fgen" resource-path -"extras/factor.vim" resource-path -embedded-convert diff --git a/extra/farkup/farkup-docs.factor b/extra/farkup/farkup-docs.factor index 5d59a093af..b2b662db82 100644 --- a/extra/farkup/farkup-docs.factor +++ b/extra/farkup/farkup-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax ; IN: farkup -HELP: parse-farkup +HELP: convert-farkup { $values { "string" "a string" } { "string'" "a string" } } { $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ; diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index f4b3025fcd..af4ddd8839 100755 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -43,6 +43,21 @@ IN: farkup.tests [ "

foo\n

aheading

\n

adfasd

" ] [ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test -[ "

=foo\n

" ] [ "=foo\n" convert-farkup ] unit-test [ "

foo

\n" ] [ "=foo=\n" convert-farkup ] unit-test [ "

lol

foo

\n" ] [ "lol=foo=\n" convert-farkup ] unit-test +[ "

=foo\n

" ] [ "=foo\n" convert-farkup ] unit-test +[ "

=foo

" ] [ "=foo" convert-farkup ] unit-test +[ "

==foo

" ] [ "==foo" convert-farkup ] unit-test +[ "

=

foo

" ] [ "==foo=" convert-farkup ] unit-test +[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test +[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test +[ "

=

foo

" ] [ "===foo==" convert-farkup ] unit-test +[ "

foo

=

" ] [ "=foo==" convert-farkup ] unit-test + +[ "int main()
" ] +[ "[c{int main()}]" convert-farkup ] unit-test + +[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test +[ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test +[ "

" ] [ "[[lol.com]]" convert-farkup ] unit-test +[ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index dac4359d90..142fc5de6c 100755 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -42,14 +42,44 @@ MEMO: h2 ( -- parser ) "==" "h2" delimited ; MEMO: h3 ( -- parser ) "===" "h3" delimited ; MEMO: h4 ( -- parser ) "====" "h4" delimited ; +MEMO: eq ( -- parser ) + [ + h1 ensure-not , + h2 ensure-not , + h3 ensure-not , + h4 ensure-not , + "=" token , + ] seq* ; + : render-code ( string mode -- string' ) >r string-lines r> [ [ htmlize-lines ] with-html-stream ] with-string-writer ; +: escape-link ( href text -- href-esc text-esc ) + >r escape-quoted-string r> escape-string ; + : make-link ( href text -- seq ) - >r escape-quoted-string r> escape-string + escape-link [ "r , r> "\">" , [ , ] when* "" , ] { } make ; +: make-image-link ( href alt -- seq ) + escape-link + [ + "\""" , ] + { } make ; + +MEMO: image-link ( -- parser ) + [ + "[[image:" token hide , + [ "|]" member? not ] satisfy repeat1 [ >string ] action , + "|" token hide + [ CHAR: ] = not ] satisfy repeat0 2seq + [ first >string ] action optional , + "]]" token hide , + ] seq* [ first2 make-image-link ] action ; + MEMO: simple-link ( -- parser ) [ "[[" token hide , @@ -66,7 +96,7 @@ MEMO: labelled-link ( -- parser ) "]]" token hide , ] seq* [ first2 make-link ] action ; -MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ; +MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ; DEFER: line MEMO: list-item ( -- parser ) @@ -92,20 +122,17 @@ MEMO: table ( -- parser ) MEMO: code ( -- parser ) [ "[" token hide , - [ "{" member? not ] satisfy repeat1 optional [ >string ] action , + [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action , "{" token hide , - [ - [ any-char , "}]" token ensure-not , ] seq* - repeat1 [ concat >string ] action , - [ any-char , "}]" token hide , ] seq* optional [ >string ] action , - ] seq* [ concat ] action , + "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action , + "}]" token hide , ] seq* [ first2 swap render-code ] action ; MEMO: line ( -- parser ) [ text , strong , emphasis , link , superscript , subscript , inline-code , - escaped-char , delimiter , + escaped-char , delimiter , eq , ] choice* repeat1 ; MEMO: paragraph ( -- parser ) diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index f8d49af163..490ce992ab 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences combinators parser splitting -quotations arrays namespaces ; +quotations arrays namespaces qualified ; +QUALIFIED: namespaces IN: fry : , "Only valid inside a fry" throw ; @@ -23,6 +24,10 @@ DEFER: (fry) unclip { { , [ [ curry ] ((fry)) ] } { @ [ [ compose ] ((fry)) ] } + + ! to avoid confusion, remove if fry goes core + { namespaces:, [ [ curry ] ((fry)) ] } + [ swap >r add r> (fry) ] } case ] if ; diff --git a/extra/gap-buffer/cursortree/cursortree-tests.factor b/extra/gap-buffer/cursortree/cursortree-tests.factor index 36b5efd7fa..2b3ff69c97 100644 --- a/extra/gap-buffer/cursortree/cursortree-tests.factor +++ b/extra/gap-buffer/cursortree/cursortree-tests.factor @@ -1,4 +1,6 @@ -USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ; +USING: assocs kernel gap-buffer.cursortree tools.test sequences trees +arrays strings ; +IN: gap-buffer.cursortree.tests [ t ] [ "this is a test string" 0 at-beginning? ] unit-test [ t ] [ "this is a test string" dup length at-end? ] unit-test @@ -6,7 +8,8 @@ USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ; [ CHAR: i ] [ "this is a test string" 3 element< ] unit-test [ CHAR: s ] [ "this is a test string" 3 element> ] unit-test [ t ] [ "this is a test string" 3 CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test -[ t ] [ "this is a test string" 3 8 over set-cursor-pos dup 1array swap cursor-tree cursortree-cursors tree-values sequence= ] unit-test +[ 0 ] [ "this is a test string" dup dup 3 remove-cursor cursors length ] unit-test +[ t ] [ "this is a test string" 3 8 over set-cursor-pos dup 1array swap cursor-tree cursors sequence= ] unit-test [ "this is no longer a test string" ] [ "this is a test string" 8 "no longer " over insert cursor-tree >string ] unit-test [ "refactor" ] [ "factor" 0 CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test [ "refactor" ] [ "factor" 0 CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test diff --git a/extra/gap-buffer/cursortree/cursortree.factor b/extra/gap-buffer/cursortree/cursortree.factor index e056cc8dee..fb2abf1c3d 100644 --- a/extra/gap-buffer/cursortree/cursortree.factor +++ b/extra/gap-buffer/cursortree/cursortree.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Alex Chapman All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel gap-buffer generic trees trees.avl math sequences quotations ; +USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math +sequences quotations ; IN: gap-buffer.cursortree TUPLE: cursortree cursors ; @@ -18,13 +19,12 @@ TUPLE: cursor i tree ; TUPLE: left-cursor ; TUPLE: right-cursor ; -: cursor-index ( cursor -- i ) cursor-i ; inline +: cursor-index ( cursor -- i ) cursor-i ; -: add-cursor ( cursortree cursor -- ) dup cursor-index rot avl-insert ; +: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ; : remove-cursor ( cursortree cursor -- ) - cursor-index swap delete-at ; - ! dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ; + tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ; : set-cursor-index ( index cursor -- ) dup cursor-tree over remove-cursor tuck set-cursor-i @@ -49,14 +49,17 @@ M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] ke : ( cursortree pos -- right-cursor ) right-cursor construct-empty make-cursor ; +: cursors ( cursortree -- seq ) + cursortree-cursors values concat ; + : cursor-positions ( cursortree -- seq ) - cursortree-cursors tree-values [ cursor-pos ] map ; + cursors [ cursor-pos ] map ; M: cursortree move-gap ( n cursortree -- ) #! Get the position of each cursor before the move, then re-set the #! position afterwards. This will update any changed cursor indices. dup cursor-positions >r tuck cursortree-gb move-gap - cursortree-cursors tree-values r> swap [ set-cursor-pos ] 2each ; + cursors r> swap [ set-cursor-pos ] 2each ; : element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ; : element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ; @@ -81,7 +84,7 @@ M: right-cursor fix-cursor ( cursortree cursor -- ) >r gb-gap-end r> set-cursor-index ; : fix-cursors ( old-gap-end cursortree -- ) - tuck cursortree-cursors tree-get-all [ fix-cursor ] curry* each ; + tuck cursortree-cursors at [ fix-cursor ] with each ; M: cursortree delete* ( pos cursortree -- ) tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ; diff --git a/extra/gap-buffer/gap-buffer.factor b/extra/gap-buffer/gap-buffer.factor index 99051ea678..3d78204d3f 100644 --- a/extra/gap-buffer/gap-buffer.factor +++ b/extra/gap-buffer/gap-buffer.factor @@ -44,15 +44,36 @@ M: gb like ( seq gb -- seq ) drop ; M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ; +: valid-position? ( pos gb -- ? ) + #! one element past the end of the buffer is a valid position when we're inserting + length -1 swap between? ; + +: valid-index? ( i gb -- ? ) + buffer-length -1 swap between? ; + +TUPLE: position-out-of-bounds position gap-buffer ; +C: position-out-of-bounds + : position>index ( pos gb -- i ) - 2dup gb-gap-start >= [ - gap-length + - ] [ drop ] if ; + 2dup valid-position? [ + 2dup gb-gap-start >= [ + gap-length + + ] [ drop ] if + ] [ + throw + ] if ; + +TUPLE: index-out-of-bounds index gap-buffer ; +C: index-out-of-bounds : index>position ( i gb -- pos ) - 2dup gb-gap-end >= [ - gap-length - - ] [ drop ] if ; + 2dup valid-index? [ + 2dup gb-gap-end >= [ + gap-length - + ] [ drop ] if + ] [ + throw + ] if ; M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ; @@ -159,6 +180,7 @@ INSTANCE: gb virtual-sequence : fix-gap ( n gb -- ) 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ; +! moving the gap to position 5 means that the element in position 5 will be immediately after the gap GENERIC: move-gap ( n gb -- ) M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ; diff --git a/extra/help/crossref/crossref-docs.factor b/extra/help/crossref/crossref-docs.factor index 5c1f687d05..4331a45490 100644 --- a/extra/help/crossref/crossref-docs.factor +++ b/extra/help/crossref/crossref-docs.factor @@ -1,4 +1,5 @@ -USING: help.crossref help.topics help.syntax help.markup ; +USING: help.topics help.syntax help.markup ; +IN: help.crossref HELP: article-children { $values { "topic" "an article name or a word" } { "seq" "a new sequence" } } @@ -12,7 +13,7 @@ HELP: help-path { $values { "topic" "an article name or a word" } { "seq" "a new sequence" } } { $description "Outputs a sequence of all help articles which contain " { $snippet "topic" } " as a subsection, traversing all the way up to the root." } { $examples - { $example "USE: help.crossref" "\"sequences\" help-path ." "{ \"collections\" \"handbook\" }" } + { $example "USING: help.crossref prettyprint ;" "\"sequences\" help-path ." "{ \"collections\" \"handbook\" }" } } ; HELP: xref-article diff --git a/extra/help/handbook/handbook-tests.factor b/extra/help/handbook/handbook-tests.factor new file mode 100644 index 0000000000..ae6c7d55f4 --- /dev/null +++ b/extra/help/handbook/handbook-tests.factor @@ -0,0 +1,8 @@ +IN: help.handbook.tests +USING: help tools.test ; + +[ ] [ "article-index" help ] unit-test +[ ] [ "primitive-index" help ] unit-test +[ ] [ "error-index" help ] unit-test +[ ] [ "type-index" help ] unit-test +[ ] [ "class-index" help ] unit-test diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 84108a1db6..1310b58133 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -116,6 +116,7 @@ ARTICLE: "objects" "Objects" { $subsection "classes" } { $subsection "tuples" } { $subsection "generic" } +{ $subsection "slots" } { $subsection "mirrors" } ; USE: random @@ -195,6 +196,7 @@ ARTICLE: "io" "Input and output" { $subsection "io.timeouts" } ; ARTICLE: "tools" "Developer tools" +{ $subsection "tools.vocabs" } "Exploratory tools:" { $subsection "editor" } { $subsection "tools.crossref" } @@ -235,7 +237,7 @@ ARTICLE: "program-org" "Program organization" USING: help.cookbook help.tutorial ; ARTICLE: "handbook" "Factor documentation" -"Welcome to Factor. Factor is dynamically-typed, stack-based, and very expressive. It is one of the most powerful and flexible programming languages ever invented. Have fun with Factor!" +"Welcome to Factor." { $heading "Starting points" } { $subsection "cookbook" } { $subsection "first-program" } @@ -261,6 +263,7 @@ ARTICLE: "handbook" "Factor documentation" { $subsection "help" } { $subsection "inference" } { $subsection "compiler" } +{ $subsection "layouts" } { $heading "User interface" } { $about "ui" } { $about "ui.tools" } diff --git a/extra/help/help-docs.factor b/extra/help/help-docs.factor index fc795572fb..1d2af5fb39 100755 --- a/extra/help/help-docs.factor +++ b/extra/help/help-docs.factor @@ -230,17 +230,17 @@ HELP: $examples { $values { "element" "a markup element" } } { $description "Prints a heading followed by some examples. Word documentation should include examples, at least if the usage of the word is not entirely obvious." } { $examples - { $markup-example { $examples { $example "2 2 + ." "4" } } } + { $markup-example { $examples { $example "USING: math prettyprint ;" "2 2 + ." "4" } } } } ; HELP: $example { $values { "element" "a markup element of the form " { $snippet "{ inputs... output }" } } } { $description "Prints a clickable example with sample output. The markup element must be an array of strings. All but the last string are joined by newlines and taken as the input text, and the last string is the output. The example becomes clickable if the output stream supports it, and clicking it opens a listener window with the input text inserted at the input prompt." } { $examples - "The output text should be a string of what the input prints when executed, not the final stack contents or anything like that. So the following is an incorrect example:" + "The input text must contain a correct " { $link POSTPONE: USING: } " declaration, and output text should be a string of what the input prints when executed, not the final stack contents or anything like that. So the following is an incorrect example:" { $markup-example { $unchecked-example "2 2 +" "4" } } "However the following is right:" - { $markup-example { $example "2 2 + ." "4" } } + { $markup-example { $example "USING: math prettyprint ;" "2 2 + ." "4" } } "Examples can incorporate a call to " { $link .s } " to show multiple output values; the convention is that you may assume the stack is empty before the example evaluates." } ; @@ -270,7 +270,7 @@ HELP: textual-list { $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } { $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." } { $examples - { $example "USE: help.markup" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" } + { $example "USING: help.markup io ;" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" } } ; HELP: $links @@ -344,7 +344,7 @@ HELP: $side-effects HELP: $notes { $values { "element" "a markup element" } } -{ $description "Prints the errors subheading found on the help page of some words. This section should usage tips and pitfalls." } ; +{ $description "Prints the notes subheading found on the help page of some words. This section should document usage tips and pitfalls." } ; HELP: $see { $values { "element" "a markup element of the form " { $snippet "{ word }" } } } diff --git a/extra/help/help.factor b/extra/help/help.factor index 9332e6aff8..85f5a35a5c 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -109,9 +109,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ] ?if ; : ($index) ( articles -- ) - subsection-style get [ - sort-articles [ nl ] [ ($subsection) ] interleave - ] with-style ; + sort-articles [ \ $subsection swap 2array ] map print-element ; : $index ( element -- ) first call dup empty? diff --git a/extra/help/lint/lint-docs.factor b/extra/help/lint/lint-docs.factor index 6aa3310bf9..0c0fcf92d2 100644 --- a/extra/help/lint/lint-docs.factor +++ b/extra/help/lint/lint-docs.factor @@ -5,7 +5,7 @@ HELP: help-lint-all { $description "Checks all word help and articles in all loaded vocabularies." } ; HELP: help-lint -{ $values { "vocab" "a vocabulary specifier" } } +{ $values { "prefix" "a vocabulary specifier" } } { $description "Checks all word help and articles in the given vocabulary and all child vocabularies." } ; ARTICLE: "help.lint" "Help lint tool" diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor old mode 100644 new mode 100755 index 4b97499a4c..d8a4f83169 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences parser kernel help help.markup help.topics -words strings classes tools.browser namespaces io +words strings classes tools.vocabs namespaces io io.streams.string prettyprint definitions arrays vectors combinators splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate -macros combinators.lib sequences.lib ; +macros combinators.lib sequences.lib math ; IN: help.lint : check-example ( element -- ) @@ -27,8 +27,13 @@ IN: help.lint ] unless ; : effect-values ( word -- seq ) - stack-effect dup effect-in swap effect-out - append [ string? ] subset prune natural-sort ; + stack-effect dup effect-in swap effect-out append [ + { + { [ dup word? ] [ word-name ] } + { [ dup integer? ] [ drop "object" ] } + { [ dup string? ] [ ] } + } cond + ] map prune natural-sort ; : contains-funky-elements? ( element -- ? ) { diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index d81e9cd81e..710671857e 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -169,7 +169,8 @@ M: f print-element drop ; ] if ] ($subsection) ; -: $vocab-link ( element -- ) first dup ($vocab-link) ; +: $vocab-link ( element -- ) + first dup vocab-name swap ($vocab-link) ; : $vocabulary ( element -- ) first word-vocabulary [ diff --git a/extra/help/topics/topics.factor b/extra/help/topics/topics.factor old mode 100644 new mode 100755 index c5abc195cf..4a86d49a28 --- a/extra/help/topics/topics.factor +++ b/extra/help/topics/topics.factor @@ -7,6 +7,10 @@ IN: help.topics TUPLE: link name ; +MIXIN: topic +INSTANCE: link topic +INSTANCE: word topic + GENERIC: >link ( obj -- obj ) M: link >link ; M: vocab-spec >link ; diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor index f6b1faf385..f01840d927 100755 --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax ui.commands ui.operations ui.tools.search ui.tools.workspace editors vocabs.loader -kernel sequences prettyprint tools.test strings +kernel sequences prettyprint tools.test tools.vocabs strings unicode.categories unicode.case ; IN: help.tutorial diff --git a/extra/hooks/hooks-tests.factor b/extra/hooks/hooks-tests.factor deleted file mode 100644 index 683109f795..0000000000 --- a/extra/hooks/hooks-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: hooks kernel tools.test ; -IN: hooks.tests - -SYMBOL: test-hook -test-hook reset-hook -: add-test-hook test-hook add-hook ; -[ ] [ test-hook call-hook ] unit-test -[ "op called" ] [ "op" [ "op called" ] add-test-hook test-hook call-hook ] unit-test -[ "first called" "second called" ] [ - test-hook reset-hook - "second op" [ "second called" ] add-test-hook - "first op" [ "first called" ] add-test-hook - test-hook call-hook -] unit-test diff --git a/extra/hooks/hooks.factor b/extra/hooks/hooks.factor deleted file mode 100644 index 65e310f268..0000000000 --- a/extra/hooks/hooks.factor +++ /dev/null @@ -1,28 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: assocs digraphs kernel namespaces sequences ; -IN: hooks - -: hooks ( -- hooks ) - \ hooks global [ drop H{ } clone ] cache ; - -: hook-graph ( hook -- graph ) - hooks [ drop ] cache ; - -: reset-hook ( hook -- ) - swap hooks set-at ; - -: add-hook ( key quot hook -- ) - #! hook should be a symbol. Note that symbols with the same name but - #! different vocab are not equal - hook-graph add-vertex ; - -: before ( key1 key2 hook -- ) - hook-graph add-edge ; - -: after ( key1 key2 hook -- ) - swapd before ; - -: call-hook ( hook -- ) - hook-graph topological-sorted-values [ call ] each ; - diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 0d733ba97d..ee0d5f7f3b 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting calendar continuations accessors vectors io.encodings.latin1 -io.encodings.binary ; +splitting calendar continuations accessors vectors +io.encodings.latin1 io.encodings.binary fry ; IN: http.client DEFER: http-request @@ -46,8 +46,7 @@ DEFER: http-request dup host>> swap port>> ; : close-on-error ( stream quot -- ) - [ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ; - inline + '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline PRIVATE> diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 16be0d026d..66182b10ae 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -137,10 +137,10 @@ io.encodings.ascii ; [ - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>get + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display "quit" add-responder "extra/http/test" resource-path >>default - default-host set + main-responder set [ 1237 httpd ] "HTTPD test" spawn drop ] with-scope diff --git a/extra/http/http.factor b/extra/http/http.factor index 849b9e2fc9..c72a631d16 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io io.streams.string kernel math namespaces -math.parser assocs sequences strings splitting ascii -io.encodings.utf8 io.encodings.string namespaces -unicode.case combinators vectors sorting new-slots accessors -calendar calendar.format quotations arrays ; +USING: fry hashtables io io.streams.string kernel math +namespaces math.parser assocs sequences strings splitting ascii +io.encodings.utf8 io.encodings.string namespaces unicode.case +combinators vectors sorting new-slots accessors calendar +calendar.format quotations arrays ; IN: http : http-port 80 ; inline @@ -91,8 +91,8 @@ IN: http : check-header-string ( str -- str ) #! http://en.wikipedia.org/wiki/HTTP_Header_Injection - dup [ "\r\n" member? ] contains? - [ "Header injection attack" throw ] when ; + dup "\r\n" seq-intersect empty? + [ "Header injection attack" throw ] unless ; : write-header ( assoc -- ) >alist sort-keys [ @@ -396,13 +396,13 @@ M: response write-full-response ( request response -- ) "content-type" set-header ; : get-cookie ( request/response name -- cookie/f ) - >r cookies>> r> [ swap name>> = ] curry find nip ; + >r cookies>> r> '[ , _ name>> = ] find nip ; : delete-cookie ( request/response name -- ) over cookies>> >r get-cookie r> delete ; : put-cookie ( request/response cookie -- request/response ) - [ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep + [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep over cookies>> push ; TUPLE: raw-response diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor old mode 100644 new mode 100755 index 13089ae6e8..98a92e083a --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -4,7 +4,7 @@ multiline namespaces http io.streams.string http.server sequences accessors ; - [ "a" get "b" get + ] >>get + [ "a" get "b" get + ] >>display { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params "action-1" set @@ -16,12 +16,13 @@ blah [ 25 ] [ action-request-test-1 [ read-request ] with-string-reader + request set "/blah" "action-1" get call-responder ] unit-test - [ +path+ get "xxx" get "X" concat append ] >>post + [ +path+ get "xxx" get "X" concat append ] >>submit { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params "action-2" set @@ -34,6 +35,7 @@ xxx=4 [ "/blahXXXX" ] [ action-request-test-2 [ read-request ] with-string-reader + request set "/blah" "action-2" get call-responder ] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 5e5b7a9563..bab55eef0c 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,41 +1,61 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors new-slots sequences kernel assocs combinators -http.server http.server.validators http hashtables namespaces ; +http.server http.server.validators http hashtables namespaces +combinators.cleave fry continuations ; IN: http.server.actions SYMBOL: +path+ -TUPLE: action get get-params post post-params revalidate ; +SYMBOL: params + +TUPLE: action init display submit get-params post-params ; : action construct-empty - [ <400> ] >>get - [ <400> ] >>post - [ <400> ] >>revalidate ; + [ ] >>init + [ <400> ] >>display + [ <400> ] >>submit ; -: extract-params ( request path -- assoc ) - >r dup method>> { +: extract-params ( path -- assoc ) + +path+ associate + request get dup method>> { { "GET" [ query>> ] } + { "HEAD" [ query>> ] } { "POST" [ post-data>> query>assoc ] } - } case r> +path+ associate union ; + } case union ; -: action-params ( request path param -- error? ) - -rot extract-params validate-params ; +: with-validator ( string quot -- result error? ) + '[ , @ f ] [ + dup validation-error? [ t ] [ rethrow ] if + ] recover ; inline -: get-action ( request path -- response ) - action get get-params>> action-params - [ <400> ] [ action get get>> call ] if ; +: validate-param ( name validator assoc -- error? ) + swap pick + >r >r at r> with-validator swap r> set ; -: post-action ( request path -- response ) +: action-params ( validators -- error? ) + [ params get validate-param ] { } assoc>map [ ] contains? ; + +: handle-get ( -- response ) + action get get-params>> action-params [ <400> ] [ + action get [ init>> call ] [ display>> call ] bi + ] if ; + +: handle-post ( -- response ) action get post-params>> action-params - [ action get revalidate>> ] [ action get post>> ] if call ; + [ <400> ] [ action get submit>> call ] if ; -M: action call-responder ( request path action -- response ) - action set - over request set - over method>> - { - { "GET" [ get-action ] } - { "POST" [ post-action ] } - } case ; +: validation-failed ( -- * ) + action get display>> call exit-with ; + +M: action call-responder ( path action -- response ) + [ extract-params params set ] + [ + action set + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] bi* ; diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor new file mode 100755 index 0000000000..1b1534b85e --- /dev/null +++ b/extra/http/server/auth/auth.factor @@ -0,0 +1,9 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: http.server.sessions accessors +http.server.auth.providers ; +IN: http.server.auth + +SYMBOL: logged-in-user + +: uid ( -- string ) logged-in-user sget username>> ; diff --git a/extra/http/server/auth/login/login-tests.factor b/extra/http/server/auth/login/login-tests.factor new file mode 100755 index 0000000000..b69630a930 --- /dev/null +++ b/extra/http/server/auth/login/login-tests.factor @@ -0,0 +1,6 @@ +IN: http.server.auth.login.tests +USING: tools.test http.server.auth.login ; + +\ must-infer +\ allow-registration must-infer +\ allow-password-recovery must-infer diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index e2f9a3608a..7d92c727c6 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -2,68 +2,299 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors new-slots quotations assocs kernel splitting base64 html.elements io combinators http.server -http.server.auth.providers http.server.actions -http.server.sessions http.server.templating.fhtml http sequences -io.files namespaces ; +http.server.auth.providers http.server.auth.providers.null +http.server.actions http.server.components http.server.sessions +http.server.templating.fhtml http.server.validators +http.server.auth http sequences io.files namespaces hashtables +fry io.sockets combinators.cleave arrays threads locals +qualified ; IN: http.server.auth.login +QUALIFIED: smtp -TUPLE: login-auth responder provider ; +TUPLE: login users ; -C: (login-auth) login-auth - -SYMBOL: logged-in? -SYMBOL: provider SYMBOL: post-login-url +SYMBOL: login-failed? -: login-page ( -- response ) - "text/html" [ - "extra/http/server/auth/login/login.fhtml" - resource-path run-template-file - ] >>body ; +! ! ! Login -: - - [ login-page ] >>get +: + "login"
+ "resource:extra/http/server/auth/login/login.fhtml" >>edit-template + "username" + t >>required + add-field + "password" + t >>required + add-field ; - { - { "name" [ ] } - { "password" [ ] } - } >>post-params +: successful-login ( user -- response ) + logged-in-user sset + post-login-url sget f ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + "password" value "username" value + login get users>> check-login [ + successful-login + ] [ + login-failed? on + validation-failed + ] if* + ] >>submit + ] ; + +! ! ! New user registration + +: ( -- form ) + "register" + "resource:extra/http/server/auth/login/register.fhtml" >>edit-template + "username" + t >>required + add-field + "realname" add-field + "password" + t >>required + add-field + "verify-password" + t >>required + add-field + "email" add-field + "captcha" add-field ; + +SYMBOL: password-mismatch? +SYMBOL: user-exists? + +: same-password-twice ( -- ) + "password" value "verify-password" value = [ + password-mismatch? on + validation-failed + ] unless ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + same-password-twice + + values get [ + "username" get >>username + "realname" get >>realname + "password" get >>password + "email" get >>email + ] bind + + login get users>> new-user [ + user-exists? on + validation-failed + ] unless* + + successful-login + ] >>submit + ] ; + +! ! ! Password recovery + +SYMBOL: lost-password-from + +: current-host ( -- string ) + request get host>> host-name or ; + +: new-password-url ( user -- url ) + "new-password" + swap [ + [ username>> "username" set ] + [ ticket>> "ticket" set ] + bi + ] H{ } make-assoc + derive-url ; + +: password-email ( user -- email ) + smtp: + [ "[ " % current-host % " ] password recovery" % ] "" make >>subject + lost-password-from get >>from + over email>> 1array >>to [ - "password" get - "name" get - provider sget check-login [ - t logged-in? sset - post-login-url sget - ] [ - login-page - ] if - ] >>post ; + "This e-mail was sent by the application server on " % current-host % "\n" % + "because somebody, maybe you, clicked on a ``recover password'' link in the\n" % + "login form, and requested a new password for the user named ``" % + over username>> % "''.\n" % + "\n" % + "If you believe that this request was legitimate, you may click the below link in\n" % + "your browser to set a new password for your account:\n" % + "\n" % + swap new-password-url % + "\n\n" % + "Love,\n" % + "\n" % + " FactorBot\n" % + ] "" make >>body ; -: +: send-password-email ( user -- ) + '[ , password-email smtp:send-email ] + "E-mail send thread" spawn drop ; + +: ( -- form ) + "register" + "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template + "username" + t >>required + add-field + "email" + t >>required + add-field + "captcha" add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ blank-values ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + "email" value "username" value + login get users>> issue-ticket [ + send-password-email + ] when* + + "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template + ] >>submit + ] ; + +: + "new-password" + "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template + "username" + t >>required + add-field + "password" + t >>required + add-field + "verify-password" + t >>required + add-field + "ticket" + t >>required + add-field ; + +:: ( -- action ) + [let | form [ ] | + + [ + { "username" [ v-required ] } + { "ticket" [ v-required ] } + ] >>get-params + + [ + [ + "username" [ get ] keep set + "ticket" [ get ] keep set + ] H{ } make-assoc values set + ] >>init + + [ + "text/html" + [ edit-form ] >>body + ] >>display + + [ + blank-values + + form validate-form + + same-password-twice + + "ticket" value + "username" value + login get users>> claim-ticket [ + "password" value >>password + login get users>> update-user + + "resource:extra/http/server/auth/login/recover-4.fhtml" + serve-template + ] [ + <400> + ] if* + ] >>submit + ] ; + +! ! ! Logout +: ( -- action ) [ - f logged-in? sset - request get "login" - ] >>post ; + f logged-in-user sset + "login" f + ] >>submit ; -M: login-auth call-responder ( request path responder -- response ) - logged-in? sget - [ responder>> call-responder ] [ - pick method>> "GET" = [ - nip - provider>> provider sset - dup request-url post-login-url sset - "login" f session-link - ] [ - 3drop <400> - ] if +! ! ! Authentication logic + +TUPLE: protected responder ; + +C: protected + +M: protected call-responder ( path responder -- response ) + logged-in-user sget [ responder>> call-responder ] [ + 2drop + request get method>> { "GET" "HEAD" } member? [ + request get request-url post-login-url sset + "login" f + ] [ <400> ] if ] if ; -: ( responder provider -- auth ) - (login-auth) - - swap >>default - "login" add-responder - "logout" add-responder - ; +M: login call-responder ( path responder -- response ) + dup login set + delegate call-responder ; + +: ( responder -- auth ) + login + swap >>default + "login" add-responder + "logout" add-responder + no >>users ; + +! ! ! Configuration + +: allow-registration ( login -- login ) + "register" add-responder ; + +: allow-password-recovery ( login -- login ) + "recover-password" add-responder + "new-password" add-responder ; + +: allow-registration? ( -- ? ) + login get responders>> "register" swap key? ; + +: allow-password-recovery? ( -- ? ) + login get responders>> "recover-password" swap key? ; diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml index 9bb1438588..8e879420a9 100755 --- a/extra/http/server/auth/login/login.fhtml +++ b/extra/http/server/auth/login/login.fhtml @@ -1,3 +1,5 @@ +<% USING: http.server.auth.login http.server.components kernel +namespaces ; %>

Login required

@@ -7,19 +9,33 @@ User name: - +<% "username" component render-edit %> Password: - +<% "password" component render-edit %> - +

+<% +login-failed? get +[ "Invalid username or password" render-error ] when +%> +

+

+<% allow-registration? [ %> + Register +<% ] when %> +<% allow-password-recovery? [ %> + Recover Password +<% ] when %> +

+ diff --git a/extra/http/server/auth/login/recover-1.fhtml b/extra/http/server/auth/login/recover-1.fhtml new file mode 100755 index 0000000000..3e8448f64b --- /dev/null +++ b/extra/http/server/auth/login/recover-1.fhtml @@ -0,0 +1,38 @@ +<% USING: http.server.components ; %> + + +

Recover lost password: step 1 of 4

+ +

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

+ +
+ + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-edit %>
E-mail:<% "email" component render-edit %>
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
+ + + +
+ + + diff --git a/extra/http/server/auth/login/recover-2.fhtml b/extra/http/server/auth/login/recover-2.fhtml new file mode 100755 index 0000000000..9b13734273 --- /dev/null +++ b/extra/http/server/auth/login/recover-2.fhtml @@ -0,0 +1,9 @@ +<% USING: http.server.components ; %> + + +

Recover lost password: step 2 of 4

+ +

If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.

+ + + diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml new file mode 100755 index 0000000000..b220cc4f75 --- /dev/null +++ b/extra/http/server/auth/login/recover-3.fhtml @@ -0,0 +1,43 @@ +<% USING: http.server.components http.server.auth.login +namespaces kernel combinators ; %> + + +

Recover lost password: step 3 of 4

+ +

Choose a new password for your account.

+ +
+ + +<% "username" component render-edit %> +<% "ticket" component render-edit %> + + + + + + + + + + + + + + + + +
Password:<% "password" component render-edit %>
Verify password:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
+ +

+ +<% password-mismatch? get [ +"passwords do not match" render-error +] when %> + +

+ +
+ + + diff --git a/extra/http/server/auth/login/recover-4.fhtml b/extra/http/server/auth/login/recover-4.fhtml new file mode 100755 index 0000000000..dec7a5404f --- /dev/null +++ b/extra/http/server/auth/login/recover-4.fhtml @@ -0,0 +1,10 @@ +<% USING: http.server.components http.server.auth.login +namespaces kernel combinators ; %> + + +

Recover lost password: step 4 of 4

+ +

Your password has been reset. You may now log in.

+ + + diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml new file mode 100755 index 0000000000..c7e274e626 --- /dev/null +++ b/extra/http/server/auth/login/register.fhtml @@ -0,0 +1,75 @@ +<% USING: http.server.components http.server.auth.login +namespaces kernel combinators ; %> + + +

New user registration

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-edit %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Password:<% "password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
+ +

+ +<% { + { [ password-mismatch? get ] [ "passwords do not match" render-error ] } + { [ user-exists? get ] [ "username taken" render-error ] } + { [ t ] [ ] } +} cond %> + +

+ +
+ + + diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index 3270fe06e3..12c799816d 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -1,18 +1,33 @@ IN: http.server.auth.providers.assoc.tests USING: http.server.auth.providers http.server.auth.providers.assoc tools.test -namespaces ; +namespaces accessors kernel ; - "provider" set + "provider" set -"slava" "provider" get new-user +[ t ] [ + + "slava" >>username + "foobar" >>password + "slava@factorcode.org" >>email + "provider" get new-user + username>> "slava" = +] unit-test -[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with +[ f ] [ + + "slava" >>username + "provider" get new-user +] unit-test -[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test +[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test -[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with +[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test -"fdasf" "slava" "provider" get set-password +[ f ] [ "xx" "blah" "provider" get set-password ] unit-test -[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test +[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test + +[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + +[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor index d57be622c7..8433e54fda 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -4,20 +4,16 @@ IN: http.server.auth.providers.assoc USING: new-slots accessors assocs kernel http.server.auth.providers ; -TUPLE: assoc-auth-provider assoc ; +TUPLE: in-memory assoc ; -: ( -- provider ) - H{ } clone assoc-auth-provider construct-boa ; +: ( -- provider ) + H{ } clone in-memory construct-boa ; -M: assoc-auth-provider check-login - assoc>> at = ; +M: in-memory get-user ( username provider -- user/f ) + assoc>> at ; -M: assoc-auth-provider new-user - assoc>> - 2dup key? [ drop user-exists ] when - t -rot set-at ; +M: in-memory update-user ( user provider -- ) 2drop ; -M: assoc-auth-provider set-password - assoc>> - 2dup key? [ drop no-such-user ] unless - set-at ; +M: in-memory new-user ( user provider -- user/f ) + >r dup username>> r> assoc>> + 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index c4682c2051..247359aea4 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -2,24 +2,39 @@ IN: http.server.auth.providers.db.tests USING: http.server.auth.providers http.server.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations -io.files ; +io.files accessors kernel ; -db-auth-provider "provider" set +from-db "provider" set "auth-test.db" temp-file sqlite-db [ - + [ user drop-table ] ignore-errors [ user create-table ] ignore-errors - "slava" "provider" get new-user + [ t ] [ + + "slava" >>username + "foobar" >>password + "slava@factorcode.org" >>email + "provider" get new-user + username>> "slava" = + ] unit-test - [ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + [ f ] [ + + "slava" >>username + "provider" get new-user + ] unit-test - [ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test - [ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + [ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test - "fdasf" "slava" "provider" get set-password + [ f ] [ "xx" "blah" "provider" get set-password ] unit-test - [ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test + [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test + + [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test + + [ f ] [ "foobar" "slava" "provider" get 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 9583122875..e9e79ff82f 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -1,53 +1,45 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db db.tuples db.types new-slots accessors -http.server.auth.providers kernel ; +http.server.auth.providers kernel continuations ; IN: http.server.auth.providers.db -TUPLE: user name password ; - -: user construct-empty ; - user "USERS" { - { "name" "NAME" { VARCHAR 256 } +assigned-id+ } + { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ } + { "realname" "REALNAME" { VARCHAR 256 } } { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } + { "email" "EMAIL" { VARCHAR 256 } } + { "ticket" "TICKET" { VARCHAR 256 } } + { "profile" "PROFILE" FACTOR-BLOB } } define-persistent : init-users-table ( -- ) + [ user drop-table ] ignore-errors user create-table ; -TUPLE: db-auth-provider ; +TUPLE: from-db ; -: db-auth-provider T{ db-auth-provider } ; +: from-db T{ from-db } ; -M: db-auth-provider check-login - drop +: find-user ( username -- user ) - swap >>name - swap >>password - select-tuple >boolean ; + swap >>username + select-tuple ; -M: db-auth-provider new-user +M: from-db get-user + drop + find-user ; + +M: from-db new-user drop [ - - swap >>name - - dup select-tuple [ name>> user-exists ] when - - "unassigned" >>password - - insert-tuple + dup username>> find-user [ + drop f + ] [ + dup insert-tuple + ] if ] with-transaction ; -M: db-auth-provider set-password - drop - [ - - swap >>name - - dup select-tuple [ ] [ no-such-user ] ?if - - swap >>password update-tuple - ] with-transaction ; +M: from-db update-user + drop update-tuple ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor index 702111972e..7b8bfc627c 100755 --- a/extra/http/server/auth/providers/null/null.factor +++ b/extra/http/server/auth/providers/null/null.factor @@ -3,12 +3,14 @@ USING: http.server.auth.providers kernel ; IN: http.server.auth.providers.null -TUPLE: null-auth-provider ; +! Named "no" because we can say no >>users -: null-auth-provider T{ null-auth-provider } ; +TUPLE: no ; -M: null-auth-provider check-login 3drop f ; +: no T{ no } ; -M: null-auth-provider new-user 3drop f ; +M: no get-user 2drop f ; -M: null-auth-provider set-password 3drop f ; +M: no new-user 2drop f ; + +M: no update-user 2drop ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index 1e0fd33a67..0aa27f870d 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -1,18 +1,56 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ; +USING: kernel new-slots accessors random math.parser locals +sequences math ; IN: http.server.auth.providers -GENERIC: check-login ( password user provider -- ? ) +TUPLE: user username realname password email ticket profile ; -GENERIC: new-user ( user provider -- ) +: user construct-empty H{ } clone >>profile ; -GENERIC: set-password ( password user provider -- ) +GENERIC: get-user ( username provider -- user/f ) -TUPLE: user-exists name ; +GENERIC: update-user ( user provider -- ) -: user-exists ( name -- * ) \ user-exists construct-boa throw ; +GENERIC: new-user ( user provider -- user/f ) -TUPLE: no-such-user name ; +: check-login ( password username provider -- user/f ) + get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; -: no-such-user ( name -- * ) \ no-such-user construct-boa throw ; +:: set-password ( password username provider -- ? ) + [let | user [ username provider get-user ] | + user [ + user + password >>password + provider update-user t + ] [ f ] if + ] ; + +! Password recovery support + +:: issue-ticket ( email username provider -- user/f ) + [let | user [ username provider get-user ] | + user [ + user email>> length 0 > [ + user email>> email = [ + user + random-256 >hex >>ticket + dup provider update-user + ] [ f ] if + ] [ f ] if + ] [ f ] if + ] ; + +:: claim-ticket ( ticket username provider -- user/f ) + [let | user [ username provider get-user ] | + user [ + user ticket>> ticket = [ + user f >>ticket dup provider update-user + ] [ f ] if + ] [ f ] if + ] ; + +! For configuration + +: add-user ( provider user -- provider ) + over new-user [ "User exists" throw ] when ; diff --git a/extra/http/server/callbacks/callbacks-tests.factor b/extra/http/server/callbacks/callbacks-tests.factor new file mode 100755 index 0000000000..4cad097cf5 --- /dev/null +++ b/extra/http/server/callbacks/callbacks-tests.factor @@ -0,0 +1,64 @@ +IN: http.server.callbacks +USING: http.server.actions http.server.callbacks accessors +http.server http tools.test namespaces io fry sequences +splitting kernel hashtables continuations ; + +[ 123 ] [ + [ + "GET" >>method request set + [ + exit-continuation set + "xxx" + [ [ "hello" print 123 ] show-final ] >>display + + call-responder + ] callcc1 + ] with-scope +] unit-test + +[ + [ + [ + "hello" print + "text/html" swap '[ , write ] >>body + ] show-page + "byebye" print + [ 123 ] show-final + ] >>display + "r" set + + [ 123 ] [ + [ + exit-continuation set + "GET" >>method request set + "" "r" get call-responder + ] callcc1 + + body>> first + + + "GET" >>method + swap cont-id associate >>query + "/" >>path + request set + + [ + exit-continuation set + "/" + "r" get call-responder + ] callcc1 + + ! get-post-get + + "GET" >>method + swap "location" header "=" last-split1 nip cont-id associate >>query + "/" >>path + request set + + [ + exit-continuation set + "/" + "r" get call-responder + ] callcc1 + ] unit-test +] with-scope diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index fd2e8f8ad7..ac03e0efc8 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -3,7 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: html http http.server io kernel math namespaces continuations calendar sequences assocs new-slots hashtables -accessors arrays alarms quotations combinators ; +accessors arrays alarms quotations combinators +combinators.cleave fry ; IN: http.server.callbacks SYMBOL: responder @@ -21,57 +22,45 @@ TUPLE: callback cont quot expires alarm responder ; : timeout 20 minutes ; : timeout-callback ( callback -- ) - dup alarm>> cancel-alarm - dup responder>> callbacks>> delete-at ; + [ alarm>> cancel-alarm ] + [ dup responder>> callbacks>> delete-at ] + bi ; : touch-callback ( callback -- ) dup expires>> [ dup alarm>> [ cancel-alarm ] when* - dup [ timeout-callback ] curry timeout later >>alarm + dup '[ , timeout-callback ] timeout later >>alarm ] when drop ; : ( cont quot expires? -- callback ) - [ f responder get callback construct-boa ] keep - [ dup touch-callback ] when ; + f callback-responder get callback construct-boa + dup touch-callback ; -: invoke-callback ( request exit-cont callback -- response ) - [ quot>> 3array ] keep cont>> continue-with ; +: invoke-callback ( callback -- response ) + [ touch-callback ] + [ quot>> request get exit-continuation get 3array ] + [ cont>> continue-with ] + tri ; : register-callback ( cont quot expires? -- id ) - - responder get callbacks>> generate-key - [ responder get callbacks>> set-at ] keep ; + callback-responder get callbacks>> set-at-unique ; -SYMBOL: exit-continuation - -: exit-with exit-continuation get continue-with ; - -: forward-to-url ( url -- * ) +: forward-to-url ( url query -- * ) #! When executed inside a 'show' call, this will force a #! HTTP 302 to occur to instruct the browser to forward to #! the request URL. - request get swap exit-with ; + exit-with ; : cont-id "factorcontid" ; -: id>url ( id -- url ) - request get - swap cont-id associate >>query - request-url ; - : forward-to-id ( id -- * ) #! When executed inside a 'show' call, this will force a #! HTTP 302 to occur to instruct the browser to forward to #! the request URL. - id>url forward-to-url ; + f swap cont-id associate forward-to-url ; : restore-request ( pair -- ) - first3 >r exit-continuation set request set r> call ; - -: resume-page ( request page responder callback -- * ) - dup touch-callback - >r 2drop exit-continuation get - r> invoke-callback ; + first3 exit-continuation set request set call ; SYMBOL: post-refresh-get? @@ -102,34 +91,27 @@ SYMBOL: current-show [ restore-request store-current-show ] when* ; : show-final ( quot -- * ) - >r redirect-to-here store-current-show - r> call exit-with ; inline + >r redirect-to-here store-current-show r> + call exit-with ; inline -M: callback-responder call-responder - [ - [ - exit-continuation set - dup responder set - pick request set - pick cont-id query-param over callbacks>> at [ - resume-page - ] [ - responder>> call-responder - "Continuation responder pages must use show-final" throw - ] if* - ] with-scope - ] callcc1 >r 3drop r> ; +: resuming-callback ( responder request -- id ) + cont-id query-param swap callbacks>> at ; + +M: callback-responder call-responder ( path responder -- response ) + [ callback-responder set ] + [ request get resuming-callback ] bi + + [ invoke-callback ] + [ callback-responder get responder>> call-responder ] ?if ; : show-page ( quot -- ) >r redirect-to-here store-current-show r> [ - [ ] register-callback - with-scope - exit-with + [ ] t register-callback swap call exit-with ] callcc1 restore-request ; inline : quot-id ( quot -- id ) current-show get swap t register-callback ; : quot-url ( quot -- url ) - quot-id id>url ; + quot-id f swap cont-id associate derive-url ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index cce3e5402d..509943faa8 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs io.files combinators arrays io.launcher io http.server.static http.server -http accessors sequences strings math.parser ; +http accessors sequences strings math.parser fry ; IN: http.server.cgi : post? request get method>> "POST" = ; @@ -45,19 +45,17 @@ IN: http.server.cgi over 1array >>command swap cgi-variables >>environment ; - + : serve-cgi ( name -- response ) 200 >>code "CGI output follows" >>message - swap [ - stdio get swap [ - post? [ - request get post-data>> write flush - ] when + swap '[ + , stdio get swap [ + post? [ request get post-data>> write flush ] when stdio get swap (stream-copy) ] with-stream - ] curry >>body ; + ] >>body ; : enable-cgi ( responder -- responder ) [ serve-cgi ] "application/x-cgi-script" diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor new file mode 100755 index 0000000000..2a507e6416 --- /dev/null +++ b/extra/http/server/components/components-tests.factor @@ -0,0 +1,88 @@ +IN: http.server.components.tests +USING: http.server.components http.server.validators +namespaces tools.test kernel accessors new-slots +tuple-syntax mirrors http.server.actions ; + +validation-failed? off + +[ 3 ] [ "3" "n" validate ] unit-test + +[ 123 ] [ + "" + "n" + 123 >>default + validate +] unit-test + +[ f ] [ validation-failed? get ] unit-test + +[ t ] [ "3x" "n" validate validation-error? ] unit-test + +[ t ] [ validation-failed? get ] unit-test + +[ "" ] [ "" "email" validate ] unit-test + +[ "slava@jedit.org" ] [ "slava@jedit.org" "email" validate ] unit-test + +[ "slava@jedit.org" ] [ + "slava@jedit.org" + "email" + t >>required + validate +] unit-test + +[ t ] [ + "a" + "email" + t >>required + validate validation-error? +] unit-test + +[ t ] [ "a" "email" validate validation-error? ] unit-test + +TUPLE: test-tuple text number more-text ; + +: test-tuple construct-empty ; + +: ( -- form ) + "test"
+ "resource:extra/http/server/components/test/form.fhtml" >>view-template + "resource:extra/http/server/components/test/form.fhtml" >>edit-template + "text" + t >>required + add-field + "number" + 123 >>default + t >>required + 0 >>min-value + 10 >>max-value + add-field + "more-text" + "hi" >>default + add-field ; + +[ ] [ values set view-form ] unit-test + +[ ] [ values set edit-form ] unit-test + +[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [ + from-tuple + set-defaults + values-tuple +] unit-test + +[ + H{ + { "text" "fdafsa" } + { "number" "xxx" } + { "more-text" "" } + } params set + + H{ } clone values set + + [ t ] [ (validate-form) ] unit-test + + [ "fdafsa" ] [ "text" value ] unit-test + + [ t ] [ "number" value validation-error? ] unit-test +] with-scope diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index f14b766910..bb0fc4b3dd 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,20 +1,23 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: new-slots html.elements http.server.validators -accessors namespaces kernel io farkup math.parser assocs -classes words tuples arrays sequences io.files -http.server.templating.fhtml splitting mirrors ; +USING: new-slots html.elements http.server.validators accessors +namespaces kernel io math.parser assocs classes words tuples +arrays sequences io.files http.server.templating.fhtml +http.server.actions splitting mirrors hashtables +combinators.cleave fry continuations math ; IN: http.server.components +SYMBOL: validation-failed? + SYMBOL: components -TUPLE: component id ; +TUPLE: component id required default ; : component ( name -- component ) dup components get at [ ] [ "No such component: " swap append throw ] ?if ; -GENERIC: validate* ( string component -- result ) +GENERIC: validate* ( value component -- result ) GENERIC: render-view* ( value component -- ) GENERIC: render-edit* ( value component -- ) GENERIC: render-error* ( reason value component -- ) @@ -23,47 +26,203 @@ SYMBOL: values : value values get at ; +: set-value values get set-at ; + +: validate ( value component -- result ) + '[ + , , + over empty? [ + [ default>> [ v-default ] when* ] + [ required>> [ v-required ] when ] + bi + ] [ validate* ] if + ] [ + dup validation-error? + [ validation-failed? on ] [ rethrow ] if + ] recover ; + : render-view ( component -- ) - dup id>> value swap render-view* ; + [ id>> value ] [ render-view* ] bi ; : render-error ( error -- ) write ; : render-edit ( component -- ) dup id>> value dup validation-error? [ - dup reason>> swap value>> rot render-error* + [ reason>> ] [ value>> ] bi rot render-error* ] [ - swap render-edit* + swap [ default>> or ] keep render-edit* ] if ; -: ( id string -- component ) - >r \ component construct-boa r> construct-delegate ; inline +: ( id class -- component ) + \ component construct-empty + swap construct-delegate + swap >>id ; inline -TUPLE: string min max ; +! Forms +TUPLE: form view-template edit-template components ; + +: ( id -- form ) + form + V{ } clone >>components ; + +: add-field ( form component -- form ) + dup id>> pick components>> set-at ; + +: with-form ( form quot -- ) + >r components>> components r> with-variable ; inline + +: set-defaults ( form -- ) + [ + components get [ + swap values get [ + swap default>> or + ] change-at + ] assoc-each + ] with-form ; + +: view-form ( form -- ) + dup view-template>> '[ , run-template ] with-form ; + +: edit-form ( form -- ) + dup edit-template>> '[ , run-template ] with-form ; + +: validate-param ( id component -- ) + [ [ params get at ] [ validate ] bi* ] + [ drop set-value ] 2bi ; + +: (validate-form) ( form -- error? ) + [ + validation-failed? off + components get [ validate-param ] assoc-each + validation-failed? get + ] with-form ; + +: validate-form ( form -- ) + (validate-form) [ validation-failed ] when ; + +: blank-values H{ } clone values set ; + +: from-tuple values set ; + +: values-tuple values get mirror-object ; + +! ! ! +! Canned components: for simple applications and prototyping +! ! ! + +: render-input ( value component type -- ) + > [ =id ] [ =name ] bi + =value + input/> ; + +! Hidden fields +TUPLE: hidden ; + +: ( component -- component ) + hidden construct-delegate ; + +M: hidden render-view* + 2drop ; + +M: hidden render-edit* + >r dup number? [ number>string ] when r> + "hidden" render-input ; + +! String input fields +TUPLE: string min-length max-length ; : ( id -- component ) string ; M: string validate* - [ min>> v-min-length ] keep max>> v-max-length ; + [ v-one-line ] [ + [ min-length>> [ v-min-length ] when* ] + [ max-length>> [ v-max-length ] when* ] + bi + ] bi* ; M: string render-view* drop write ; -: render-input - > dup =id =name =value input/> ; - M: string render-edit* - render-input ; + "text" render-input ; M: string render-error* - render-input render-error ; + "text" render-input render-error ; +! Username fields +TUPLE: username ; + +: ( id -- component ) + username construct-delegate + 2 >>min-length + 20 >>max-length ; + +M: username validate* + delegate validate* v-one-word ; + +! E-mail fields +TUPLE: email ; + +: ( id -- component ) + email construct-delegate + 5 >>min-length + 60 >>max-length ; + +M: email validate* + delegate validate* dup empty? [ v-email ] unless ; + +! Password fields +TUPLE: password ; + +: ( id -- component ) + password construct-delegate + 6 >>min-length + 60 >>max-length ; + +M: password validate* + delegate validate* v-one-word ; + +M: password render-edit* + >r drop f r> "password" render-input ; + +M: password render-error* + render-edit* render-error ; + +! Number fields +TUPLE: number min-value max-value ; + +: ( id -- component ) number ; + +M: number validate* + [ v-number ] [ + [ min-value>> [ v-min-value ] when* ] + [ max-value>> [ v-max-value ] when* ] + bi + ] bi* ; + +M: number render-view* + drop number>string write ; + +M: number render-edit* + >r number>string r> "text" render-input ; + +M: number render-error* + "text" render-input render-error ; + +! Text areas TUPLE: text ; : ( id -- component ) text construct-delegate ; : render-textarea - ; + ; M: text render-edit* render-textarea ; @@ -71,55 +230,11 @@ M: text render-edit* M: text render-error* render-textarea render-error ; -TUPLE: farkup ; +! Simple captchas +TUPLE: captcha ; -: ( id -- component ) farkup construct-delegate ; +: ( id -- component ) + captcha construct-delegate ; -M: farkup render-view* - drop string-lines "\n" join convert-farkup write ; - -TUPLE: number min max ; - -: ( id -- component ) number ; - -M: number validate* - >r v-number r> [ min>> v-min-value ] keep max>> v-max-value ; - -M: number render-view* - drop number>string write ; - -M: number render-edit* - >r number>string r> render-input ; - -M: number render-error* - render-input render-error ; - -: with-components ( tuple components quot -- ) - [ - >r components set - dup make-mirror values set - tuple set - r> call - ] with-scope ; inline - -TUPLE: form view-template edit-template components ; - -: ( id view-template edit-template -- form ) - V{ } clone form construct-boa - swap \ component construct-boa - over set-delegate ; - -: add-field ( form component -- form ) - dup id>> pick components>> set-at ; - -M: form render-view* ( value form -- ) - dup components>> - swap view-template>> - [ resource-path run-template-file ] curry - with-components ; - -M: form render-edit* ( value form -- ) - dup components>> - swap edit-template>> - [ resource-path run-template-file ] curry - with-components ; +M: captcha validate* + drop v-captcha ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor new file mode 100755 index 0000000000..09c8471905 --- /dev/null +++ b/extra/http/server/components/farkup/farkup.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: splitting http.server.components kernel io sequences +farkup ; +IN: http.server.components.farkup + +TUPLE: farkup ; + +: ( id -- component ) + farkup construct-delegate ; + +M: farkup render-view* + drop string-lines "\n" join convert-farkup write ; diff --git a/extra/http/server/components/test/form.fhtml b/extra/http/server/components/test/form.fhtml new file mode 100755 index 0000000000..d3f5a12faa --- /dev/null +++ b/extra/http/server/components/test/form.fhtml @@ -0,0 +1 @@ + diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor old mode 100644 new mode 100755 index 099ded2f7f..4893977f76 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -1,13 +1,69 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: http.server.crud -USING: kernel namespaces db.tuples math.parser -http.server.actions accessors ; +USING: kernel namespaces db.tuples math.parser http.server +http.server.actions http.server.components +http.server.validators accessors fry locals hashtables ; -: by-id ( class -- tuple ) - construct-empty "id" get >>id ; - -: ( class -- action ) +:: ( form ctor -- action ) - { { "id" [ string>number ] } } >>post-params - swap [ by-id delete-tuple f ] curry >>post ; + { { "id" [ v-number ] } } >>get-params + + [ "id" get ctor call select-tuple from-tuple ] >>init + + [ + "text/html" + [ form view-form ] >>body + ] >>display ; + +: ( id next -- response ) + swap number>string "id" associate ; + +:: ( form ctor next -- action ) + + [ f ctor call from-tuple form set-defaults ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple insert-tuple + + "id" value next + ] >>submit ; + +:: ( form ctor next -- action ) + + { { "id" [ v-number ] } } >>get-params + [ "id" get ctor call select-tuple from-tuple ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + f ctor call from-tuple + + form validate-form + + values-tuple update-tuple + + "id" value next + ] >>submit ; + +:: ( ctor next -- action ) + + { { "id" [ v-number ] } } >>post-params + + [ + "id" get ctor call delete-tuple + + next f + ] >>submit ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 511921ce06..4a2315b4fd 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db http.server kernel new-slots accessors -continuations namespaces destructors ; +continuations namespaces destructors combinators.cleave ; IN: http.server.db TUPLE: db-persistence responder db params ; @@ -9,10 +9,8 @@ TUPLE: db-persistence responder db params ; C: db-persistence : connect-db ( db-persistence -- ) - dup db>> swap params>> make-db - dup db set - dup db-open - add-always-destructor ; + [ db>> ] [ params>> ] bi make-db + [ db set ] [ db-open ] [ add-always-destructor ] tri ; M: db-persistence call-responder - dup connect-db responder>> call-responder ; + [ connect-db ] [ responder>> call-responder ] bi ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 0635e1f895..e992a1b6fa 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -2,18 +2,35 @@ USING: http.server tools.test kernel namespaces accessors new-slots io http math sequences assocs ; IN: http.server.tests +[ + + "www.apple.com" >>host + "/xxx/bar" >>path + { { "a" "b" } } >>query + request set + + [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test + [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test + [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test + [ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test + [ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test + [ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test + [ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test + [ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test +] with-scope + TUPLE: mock-responder path ; C: mock-responder M: mock-responder call-responder - 2nip + nip path>> on "text/plain" ; : check-dispatch ( tag path -- ? ) over off - swap default-host get call-responder + main-responder get call-responder write-response get ; [ @@ -24,14 +41,14 @@ M: mock-responder call-responder "123" "123" add-responder "default" >>default "baz" add-responder - default-host set + main-responder set [ "foo" ] [ - "foo" default-host get find-responder path>> nip + "foo" main-responder get find-responder path>> nip ] unit-test [ "bar" ] [ - "bar" default-host get find-responder path>> nip + "bar" main-responder get find-responder path>> nip ] unit-test [ t ] [ "foo" "foo" check-dispatch ] unit-test @@ -46,7 +63,8 @@ M: mock-responder call-responder [ t ] [ "baz" >>path - "baz" default-host get call-responder + request set + "baz" main-responder get call-responder dup code>> 300 399 between? >r header>> "location" swap at "baz/" tail? r> and ] unit-test @@ -55,7 +73,7 @@ M: mock-responder call-responder [ "default" >>default - default-host set + main-responder set - [ "/default" ] [ "/default" default-host get find-responder drop ] unit-test + [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test ] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 133783114d..b3fafc543f 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -3,11 +3,17 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib -vocabs.loader debugger html continuations random combinators -destructors io.encodings.latin1 ; +tools.vocabs debugger html continuations random combinators +destructors io.encodings.latin1 fry combinators.cleave ; IN: http.server -GENERIC: call-responder ( request path responder -- response ) +GENERIC: call-responder ( path responder -- response ) + +: ( content-type -- response ) + + 200 >>code + "Document follows" >>message + swap set-content-type ; TUPLE: trivial-responder response ; @@ -18,16 +24,16 @@ M: trivial-responder call-responder nip response>> call ; : trivial-response-body ( code message -- ) -

swap number>string write bl write

+

[ number>string write bl ] [ write ] bi*

; : ( code message -- response ) - - 2over [ trivial-response-body ] 2curry >>body - "text/html" set-content-type - swap >>message - swap >>code ; + 2dup '[ , , trivial-response-body ] + "text/html" + swap >>body + swap >>message + swap >>code ; : <400> ( -- response ) 400 "Bad request" ; @@ -37,41 +43,58 @@ M: trivial-responder call-responder nip response>> call ; SYMBOL: 404-responder -[ drop <404> ] 404-responder set-global +[ <404> ] 404-responder set-global -: modify-for-redirect ( request to -- url ) +: url-redirect ( to query -- url ) + #! Different host. + dup assoc-empty? [ + drop + ] [ + assoc>query "?" swap 3append + ] if ; + +: absolute-redirect ( to query -- url ) + #! Same host. + request get clone + swap [ >>query ] when* + swap >>path + request-url ; + +: replace-last-component ( path with -- path' ) + >r "/" last-split1 drop "/" r> 3append ; + +: relative-redirect ( to query -- url ) + request get clone + swap [ >>query ] when* + swap [ '[ , replace-last-component ] change-path ] when* + request-url ; + +: derive-url ( to query -- url ) { - { [ dup "http://" head? ] [ nip ] } - { [ dup "/" head? ] [ >>path request-url ] } - { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] } + { [ over "http://" head? ] [ url-redirect ] } + { [ over "/" head? ] [ absolute-redirect ] } + { [ t ] [ relative-redirect ] } } cond ; -: ( request to code message -- response ) - - -rot modify-for-redirect - "location" set-header ; +: ( to query code message -- response ) + -rot derive-url "location" set-header ; \ DEBUG add-input-logging -: ( request to -- response ) +: ( to query -- response ) 301 "Moved Permanently" ; -: ( request to -- response ) +: ( to query -- response ) 307 "Temporary Redirect" ; -: ( content-type -- response ) - - 200 >>code - swap set-content-type ; - TUPLE: dispatcher default responders ; : ( -- dispatcher ) - 404-responder H{ } clone dispatcher construct-boa ; + 404-responder get H{ } clone dispatcher construct-boa ; : set-main ( dispatcher name -- dispatcher ) - [ ] curry - >>default ; + '[ , f ] + >>default ; : split-path ( path -- rest first ) [ CHAR: / = ] left-trim "/" split1 swap ; @@ -80,18 +103,18 @@ TUPLE: dispatcher default responders ; over split-path pick responders>> at* [ >r >r 2drop r> r> ] [ 2drop default>> ] if ; -: redirect-with-/ ( request -- response ) - dup path>> "/" append ; +: redirect-with-/ ( -- response ) + request get path>> "/" append f ; -M: dispatcher call-responder +M: dispatcher call-responder ( path dispatcher -- response ) over [ - 3dup find-responder call-responder [ - >r 3drop r> + 2dup find-responder call-responder [ + 2nip ] [ default>> [ call-responder ] [ - 3drop f + drop f ] if* ] if* ] [ @@ -107,21 +130,18 @@ M: dispatcher call-responder : ( class -- dispatcher ) swap construct-delegate ; inline -SYMBOL: virtual-hosts -SYMBOL: default-host +SYMBOL: main-responder -virtual-hosts global [ drop H{ } clone ] cache drop -default-host global [ drop 404-responder get-global ] cache drop - -: find-virtual-host ( host -- responder ) - virtual-hosts get at [ default-host get ] unless* ; +main-responder global +[ drop 404-responder get-global ] cache +drop SYMBOL: development-mode : <500> ( error -- response ) 500 "Internal server error" - swap [ - "Internal server error" [ + swap '[ + , "Internal server error" [ development-mode get [ [ print-error nl :c ] with-html-stream ] [ @@ -129,27 +149,40 @@ SYMBOL: development-mode trivial-response-body ] if ] simple-page - ] curry >>body ; + ] >>body ; -: do-response ( request response -- ) +: do-response ( response -- ) dup write-response - swap method>> "HEAD" = + request get method>> "HEAD" = [ drop ] [ write-response-body ] if ; -: do-request ( request -- response ) - [ - dup dup path>> over host>> - find-virtual-host call-responder - [ <404> ] unless* - ] [ dup \ do-request log-error <500> ] recover ; - -: default-timeout 1 minutes stdio get set-timeout ; - LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; +SYMBOL: exit-continuation + +: exit-with exit-continuation get continue-with ; + +: do-request ( request -- response ) + '[ + exit-continuation set , + [ + [ log-request ] + [ request set ] + [ path>> main-responder get call-responder ] tri + [ <404> ] unless* + ] [ + [ \ do-request log-error ] + [ <500> ] + bi + ] recover + ] callcc1 + exit-continuation off ; + +: default-timeout 1 minutes stdio get set-timeout ; + : ?refresh-all ( -- ) development-mode get-global [ global [ refresh-all ] bind ] when ; @@ -159,8 +192,8 @@ LOG: httpd-hit NOTICE default-timeout ?refresh-all read-request - dup log-request - do-request do-response + do-request + do-response ] with-destructors ; : httpd ( port -- ) @@ -171,6 +204,10 @@ LOG: httpd-hit NOTICE MAIN: httpd-main +! Utility : generate-key ( assoc -- str ) - 4 big-random >hex dup pick key? - [ drop generate-key ] [ nip ] if ; + >r random-256 >hex r> + 2dup key? [ nip generate-key ] [ drop ] if ; + +: set-at-unique ( value assoc -- key ) + dup generate-key [ swap set-at ] keep ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index d771737c73..5c2d3a57cd 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -8,9 +8,9 @@ TUPLE: foo ; C: foo -M: foo init-session drop 0 "x" sset ; +M: foo init-session* drop 0 "x" sset ; -"1234" f [ +f [ [ ] [ 3 "x" sset ] unit-test [ 9 ] [ "x" sget sq ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index d7fed6bb64..1d90a32faf 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -2,16 +2,16 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs calendar kernel math.parser namespaces random boxes alarms new-slots accessors http http.server -quotations hashtables sequences ; +quotations hashtables sequences fry combinators.cleave ; IN: http.server.sessions ! ! ! ! ! ! ! WARNING: this session manager is vulnerable to XSRF attacks ! ! ! ! ! ! -GENERIC: init-session ( responder -- ) +GENERIC: init-session* ( responder -- ) -M: dispatcher init-session drop ; +M: dispatcher init-session* drop ; TUPLE: session-manager responder sessions ; @@ -19,10 +19,10 @@ TUPLE: session-manager responder sessions ; >r H{ } clone session-manager construct-boa r> construct-delegate ; inline -TUPLE: session id manager namespace alarm ; +TUPLE: session manager id namespace alarm ; -: ( id manager -- session ) - H{ } clone \ session construct-boa ; +: ( manager -- session ) + f H{ } clone \ session construct-boa ; : timeout ( -- dt ) 20 minutes ; @@ -30,13 +30,15 @@ TUPLE: session id manager namespace alarm ; alarm>> [ cancel-alarm ] if-box? ; : delete-session ( session -- ) - dup cancel-timeout - dup manager>> sessions>> delete-at ; + [ cancel-timeout ] + [ dup manager>> sessions>> delete-at ] + bi ; -: touch-session ( session -- ) - dup cancel-timeout - dup [ delete-session ] curry timeout later - swap session-alarm >box ; +: touch-session ( session -- session ) + [ cancel-timeout ] + [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ] + [ ] + tri ; : session ( -- assoc ) \ session get namespace>> ; @@ -46,20 +48,20 @@ TUPLE: session id manager namespace alarm ; : schange ( key quot -- ) session swap change-at ; inline +: init-session ( session -- session ) + dup dup \ session [ + manager>> responder>> init-session* + ] with-variable ; + : new-session ( responder -- id ) - [ sessions>> generate-key dup ] keep - [ dup touch-session ] keep - [ swap \ session [ responder>> init-session ] with-variable ] 2keep - >r over r> sessions>> set-at ; + [ init-session touch-session ] + [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ] + bi id>> ; -: get-session ( id responder -- session ) - sessions>> tuck at* [ - nip dup touch-session - ] [ - 2drop f - ] if ; +: get-session ( id responder -- session/f ) + sessions>> at* [ touch-session ] when ; -: call-responder/session ( request path responder session -- response ) +: call-responder/session ( path responder session -- response ) \ session set responder>> call-responder ; : sessions ( -- manager/f ) @@ -71,6 +73,14 @@ M: object session-link* 2drop url-encode ; : session-link ( url query -- string ) sessions session-link* ; +TUPLE: null-sessions ; + +: + null-sessions ; + +M: null-sessions call-responder ( path responder -- response ) + dup call-responder/session ; + TUPLE: url-sessions ; : ( responder -- responder' ) @@ -78,18 +88,21 @@ TUPLE: url-sessions ; : sess-id "factorsessid" ; -M: url-sessions call-responder ( request path responder -- response ) - pick sess-id query-param over get-session [ +: current-session ( responder request -- session ) + sess-id query-param swap get-session ; + +M: url-sessions call-responder ( path responder -- response ) + dup request get current-session [ call-responder/session ] [ - new-session nip sess-id set-query-param - dup request-url + nip + f swap new-session sess-id associate ] if* ; M: url-sessions session-link* drop + url-encode \ session get id>> sess-id associate union assoc>query - >r url-encode r> dup assoc-empty? [ drop ] [ "?" swap 3append ] if ; TUPLE: cookie-sessions ; @@ -97,15 +110,15 @@ TUPLE: cookie-sessions ; : ( responder -- responder' ) cookie-sessions ; -: get-session-cookie ( request responder -- cookie ) - >r sess-id get-cookie dup - [ value>> r> get-session ] [ r> 2drop f ] if ; +: get-session-cookie ( responder -- cookie ) + request get sess-id get-cookie + [ value>> swap get-session ] [ drop f ] if* ; : ( id -- cookie ) sess-id ; -M: cookie-sessions call-responder ( request path responder -- response ) - 3dup nip get-session-cookie [ +M: cookie-sessions call-responder ( path responder -- response ) + dup get-session-cookie [ call-responder/session ] [ dup new-session diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 93eb51ce4e..18870a993f 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -3,11 +3,10 @@ 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 new-slots accessors io.encodings.binary ; +calendar.format new-slots accessors io.encodings.binary +combinators.cleave fry ; IN: http.server.static -SYMBOL: responder - ! special maps mime types to quots with effect ( path -- ) TUPLE: file-responder root hook special ; @@ -31,21 +30,23 @@ TUPLE: file-responder root hook special ; : ( root -- responder ) [ - over file-length "content-length" set-header - over file-http-date "last-modified" set-header - swap [ binary stdio get stream-copy ] curry >>body + swap + [ file-length "content-length" set-header ] + [ file-http-date "last-modified" set-header ] + [ '[ , binary stdio get stream-copy ] >>body ] + tri ] ; : serve-static ( filename mime-type -- response ) over last-modified-matches? - [ 2drop <304> ] [ responder get hook>> call ] if ; + [ 2drop <304> ] [ file-responder get hook>> call ] if ; : serving-path ( filename -- filename ) - "" or responder get root>> swap path+ ; + "" or file-responder get root>> swap path+ ; : serve-file ( filename -- response ) dup mime-type - dup responder get special>> at + dup file-responder get special>> at [ call ] [ serve-static ] ?if ; \ serve-file NOTICE add-input-logging @@ -56,21 +57,22 @@ TUPLE: file-responder root hook special ; : directory. ( path -- ) dup file-name [ -

dup file-name write

-
    - directory sort-keys - [
  • file.
    • ] assoc-each -
+ [

file-name write

] + [ +
    + directory sort-keys + [
  • file.
    • ] assoc-each +
+ ] bi ] simple-html-document ; : list-directory ( directory -- response ) "text/html" - swap [ directory. ] curry >>body ; + swap '[ , directory. ] >>body ; : find-index ( filename -- path ) - { "index.html" "index.fhtml" } - [ dupd path+ exists? ] find nip - dup [ path+ ] [ nip ] if ; + { "index.html" "index.fhtml" } [ path+ ] with map + [ exists? ] find nip ; : serve-directory ( filename -- response ) dup "/" tail? [ @@ -87,15 +89,14 @@ TUPLE: file-responder root hook special ; drop <404> ] if ; -M: file-responder call-responder ( request path responder -- response ) - over [ - ".." pick subseq? [ - 3drop <400> +M: file-responder call-responder ( path responder -- response ) + file-responder set + dup [ + ".." over subseq? [ + drop <400> ] [ - responder set - swap request set serve-object ] if ] [ - 2drop redirect-with-/ + drop redirect-with-/ ] if ; diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index e655bf9001..9774e4c1f2 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -4,12 +4,12 @@ parser ; IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) - "extra/http/server/templating/fhtml/test/" swap append + "resource:extra/http/server/templating/fhtml/test/" + swap append [ - ".fhtml" append resource-path - [ run-template-file ] with-string-writer + ".fhtml" append [ run-template ] with-string-writer ] keep - ".html" append resource-path utf8 file-contents = ; + ".html" append ?resource-path utf8 file-contents = ; [ t ] [ "example" test-template ] unit-test [ t ] [ "bug" test-template ] unit-test diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 3dcd23b99f..8567524217 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -2,10 +2,10 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel parser namespaces io -io.files io.streams.string html html.elements -source-files debugger combinators math quotations generic -strings splitting accessors http.server.static http.server -assocs io.encodings.utf8 ; +io.files io.streams.string html html.elements source-files +debugger combinators math quotations generic strings splitting +accessors http.server.static http.server assocs +io.encodings.utf8 fry ; IN: http.server.templating.fhtml @@ -75,9 +75,9 @@ DEFER: <% delimiter : html-error. ( error -- ) 
 error.
; -: run-template-file ( filename -- ) - [ - [ +: run-template ( filename -- ) + '[ + , [ "quiet" on parser-notes off templating-vocab use+ @@ -86,21 +86,18 @@ DEFER: <% delimiter ?resource-path utf8 file-contents [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs - ] curry assert-depth ; - -: run-relative-template-file ( filename -- ) - file get source-file-path parent-directory - swap path+ run-template-file ; + ] assert-depth ; : template-convert ( infile outfile -- ) - utf8 [ run-template-file ] with-file-writer ; + utf8 [ run-template ] with-file-writer ; + +! responder integration +: serve-template ( name -- response ) + "text/html" + swap '[ , run-template ] >>body ; ! file responder integration -: serve-fhtml ( filename -- response ) - "text/html" - swap [ run-template-file ] curry >>body ; - : enable-fhtml ( responder -- responder ) - [ serve-fhtml ] + [ serve-template ] "application/x-factor-server-page" pick special>> set-at ; diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor old mode 100644 new mode 100755 index ff68dcfc64..3ef2b6c863 --- a/extra/http/server/validators/validators-tests.factor +++ b/extra/http/server/validators/validators-tests.factor @@ -1,4 +1,22 @@ IN: http.server.validators.tests -USING: kernel sequences tools.test http.server.validators ; +USING: kernel sequences tools.test http.server.validators +accessors ; -[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test +[ "foo" v-number ] [ validation-error? ] must-fail-with + +[ "slava@factorcode.org" ] [ + "slava@factorcode.org" v-email +] unit-test + +[ "slava+foo@factorcode.org" ] [ + "slava+foo@factorcode.org" v-email +] unit-test + +[ "slava@factorcode.o" v-email ] +[ reason>> "invalid e-mail" = ] must-fail-with + +[ "sla@@factorcode.o" v-email ] +[ reason>> "invalid e-mail" = ] must-fail-with + +[ "slava@factorcodeorg" v-email ] +[ reason>> "invalid e-mail" = ] must-fail-with diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor old mode 100644 new mode 100755 index 03beb8c3ff..7eb5163d33 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences math namespaces -math.parser assocs new-slots ; +math.parser assocs new-slots regexp fry unicode.categories +combinators.cleave sequences ; IN: http.server.validators TUPLE: validation-error value reason ; @@ -9,17 +10,6 @@ TUPLE: validation-error value reason ; : validation-error ( value reason -- * ) \ validation-error construct-boa throw ; -: with-validator ( string quot -- result error? ) - [ f ] compose curry - [ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline - -: validate-param ( name validator assoc -- error? ) - swap pick - >r >r at r> with-validator swap r> set ; - -: validate-params ( validators assoc -- error? ) - [ validate-param ] curry { } assoc>map [ ] contains? ; - : v-default ( str def -- str ) over empty? spin ? ; @@ -47,7 +37,7 @@ TUPLE: validation-error value reason ; "must be a number" validation-error ] ?if ; -: v-min-value ( str n -- str ) +: v-min-value ( x n -- x ) 2dup < [ [ "must be at least " % # ] "" make validation-error @@ -55,10 +45,31 @@ TUPLE: validation-error value reason ; drop ] if ; -: v-max-value ( str n -- str ) +: v-max-value ( x n -- x ) 2dup > [ [ "must be no more than " % # ] "" make validation-error ] [ drop ] if ; + +: v-regexp ( str what regexp -- str ) + >r over r> matches? + [ drop ] [ "invalid " swap append validation-error ] if ; + +: v-email ( str -- str ) + #! From http://www.regular-expressions.info/email.html + "e-mail" + R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i + v-regexp ; + +: v-captcha ( str -- str ) + dup empty? [ "must remain blank" validation-error ] unless ; + +: v-one-line ( str -- str ) + dup "\r\n" seq-intersect empty? + [ "must be a single line" validation-error ] unless ; + +: v-one-word ( str -- str ) + dup [ alpha? ] all? + [ "must be a single word" validation-error ] unless ; diff --git a/extra/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor index dbd05eaf2f..5ce9b71427 100755 --- a/extra/io/buffers/buffers-docs.factor +++ b/extra/io/buffers/buffers-docs.factor @@ -115,11 +115,11 @@ HELP: n>buffer { $errors "Throws an error if the buffer does not contain " { $snippet "n" } " bytes of data." } ; HELP: buffer-peek -{ $values { "buffer" buffer } { "ch" "a character" } } +{ $values { "buffer" buffer } { "byte" "a byte" } } { $description "Outputs the byte at the buffer position." } ; HELP: buffer-pop -{ $values { "buffer" buffer } { "ch" "a character" } } +{ $values { "buffer" buffer } { "byte" "a byte" } } { $description "Outputs the byte at the buffer position and advances the position." } ; HELP: buffer-until diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index a2ecfe3f3e..7d51d04d7b 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -31,10 +31,10 @@ TUPLE: buffer size ptr fill pos ; : buffer-end ( buffer -- alien ) dup buffer-fill swap buffer-ptr ; -: buffer-peek ( buffer -- ch ) +: buffer-peek ( buffer -- byte ) buffer@ 0 alien-unsigned-1 ; -: buffer-pop ( buffer -- ch ) +: buffer-pop ( buffer -- byte ) dup buffer-peek 1 rot buffer-consume ; : (buffer>) ( n buffer -- byte-array ) @@ -90,7 +90,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; [ buffer-end byte-array>memory ] 2keep [ buffer-fill swap length + ] keep set-buffer-fill ; -: byte>buffer ( ch buffer -- ) +: byte>buffer ( byte buffer -- ) 1 over check-overflow [ buffer-end 0 set-alien-unsigned-1 ] keep [ buffer-fill 1+ ] keep set-buffer-fill ; diff --git a/extra/io/files/tmp/tmp-tests.factor b/extra/io/files/tmp/tmp-tests.factor deleted file mode 100644 index ba2ff7046c..0000000000 --- a/extra/io/files/tmp/tmp-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: io.files io.files.tmp kernel strings tools.test ; -IN: temporary - -[ t ] [ tmpdir string? ] unit-test -[ t f ] [ ".tmp" [ dup exists? swap ] with-tmpfile exists? ] unit-test diff --git a/extra/io/files/tmp/tmp.factor b/extra/io/files/tmp/tmp.factor deleted file mode 100644 index a859cfdc91..0000000000 --- a/extra/io/files/tmp/tmp.factor +++ /dev/null @@ -1,22 +0,0 @@ -USING: continuations io io.files kernel sequences strings.lib ; -IN: io.files.tmp - -: tmpdir ( -- dirname ) - #! ensure that a tmp dir exists and return its name - #! I'm using a sub-directory of factor for crossplatconformity (windows doesn't have /tmp) - "tmp" resource-path dup directory? [ dup make-directory ] unless ; - -: touch ( filename -- ) - dispose ; - -: tmpfile ( extension -- filename ) - 16 random-alphanumeric-string over append - tmpdir swap path+ dup exists? [ - drop tmpfile - ] [ - nip dup touch - ] if ; - -: with-tmpfile ( extension quot -- ) - #! quot should have stack effect ( filename -- ) - swap tmpfile tuck swap curry swap [ delete-file ] curry [ ] cleanup ; diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 01da3bf64f..7fdd22c8a5 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -75,8 +75,8 @@ HELP: current-process-handle { $description "Returns the handle of the current process." } ; HELP: run-process* -{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } } -{ $contract "Launches a process using the launch descriptor." } +{ $values { "process" process } { "handle" "a process handle" } } +{ $contract "Launches a process." } { $notes "User code should call " { $link run-process } " instead." } ; HELP: run-process diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 08f5160a61..e133416101 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -115,7 +115,7 @@ TUPLE: process-failed code ; : process-failed ( code -- * ) \ process-failed construct-boa throw ; -: try-process ( command/process -- ) +: try-process ( desc -- ) run-process wait-for-process dup zero? [ drop ] [ process-failed ] if ; diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index 9d985ff3fb..76a354b0bd 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -2,13 +2,13 @@ IN: io.monitors USING: help.markup help.syntax continuations ; HELP: -{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } } +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } } { $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." $nl "Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; HELP: next-change -{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } } +{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } } { $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; HELP: with-monitor diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor index e1cb6425ff..ae69553b53 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -58,17 +58,17 @@ HELP: $low-level-note ; HELP: -{ $values { "handle" "a native handle identifying an I/O resource" } { "port" "a new " { $link port } } } +{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } } { $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." } $low-level-note ; HELP: -{ $values { "handle" "a native handle identifying an I/O resource" } { "stream" "a new " { $link input-port } } } +{ $values { "handle" "a native handle identifying an I/O resource" } { "input-port" "a new " { $link input-port } } } { $description "Creates a new " { $link input-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; HELP: -{ $values { "handle" "a native handle identifying an I/O resource" } { "stream" "a new " { $link output-port } } } +{ $values { "handle" "a native handle identifying an I/O resource" } { "output-port" "a new " { $link output-port } } } { $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 1cd8658355..8f5babeff7 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -109,7 +109,7 @@ M: input-port stream-read buffer-until ] if ; -: read-until-loop ( seps port byte-vector -- separator/f ) +: read-until-loop ( seps port accum -- separator/f ) 2over read-until-step over [ >r over push-all r> dup [ >r 3drop r> @@ -125,7 +125,7 @@ M: input-port stream-read-until ( seps port -- byte-array/f sep/f ) >r 2nip r> ] [ over [ - drop >byte-vector + drop BV{ } like [ read-until-loop ] keep B{ } like swap ] [ diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor index cbcaae9569..7eda48f747 100755 --- a/extra/io/server/server-docs.factor +++ b/extra/io/server/server-docs.factor @@ -2,7 +2,7 @@ USING: help help.syntax help.markup io ; IN: io.server HELP: with-server -{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } } +{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } } { $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being the " { $link stdio } " stream. Client connections are logged to the " { $link stdio } " stream at the time the server was started." } ; HELP: with-datagrams diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 73090ea724..bdcd0b985d 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- ) ] with-disposal ; M: unix-io copy-file ( from to -- ) - [ (copy-file) ] 2keep swap file-permissions chmod io-error ; + [ (copy-file) ] 2keep swap file-info file-info-permissions io-error ; : stat>type ( stat -- type ) stat-st_mode { diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 64e2cc3c3d..01e29866eb 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -4,4 +4,4 @@ combinators namespaces system vocabs.loader sequences ; "io.unix." os append require -"vocabs.monitor" require +"tools.vocabs.monitor" require diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor old mode 100644 new mode 100755 index 3d51e65116..2180ff7901 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -3,7 +3,7 @@ USING: alien.c-types io.files io.windows kernel math windows windows.kernel32 combinators.cleave windows.time calendar combinators math.functions -sequences combinators.lib namespaces words symbols ; +sequences namespaces words symbols ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ @@ -11,34 +11,27 @@ SYMBOLS: +read-only+ +hidden+ +system+ +sparse-file+ +reparse-point+ +compressed+ +offline+ +not-content-indexed+ +encrypted+ ; -: expand-constants ( word/obj -- obj'/obj ) - dup word? [ execute ] when ; - -: get-flags ( n seq -- seq' ) - [ - [ - first2 expand-constants - [ swapd mask? [ , ] [ drop ] if ] 2curry - ] map call-with - ] { } make ; +: win32-file-attribute ( n attr symbol -- n ) + >r dupd mask? [ r> , ] [ r> drop ] if ; : win32-file-attributes ( n -- seq ) - { - { +read-only+ FILE_ATTRIBUTE_READONLY } - { +hidden+ FILE_ATTRIBUTE_HIDDEN } - { +system+ FILE_ATTRIBUTE_SYSTEM } - { +directory+ FILE_ATTRIBUTE_DIRECTORY } - { +archive+ FILE_ATTRIBUTE_ARCHIVE } - { +device+ FILE_ATTRIBUTE_DEVICE } - { +normal+ FILE_ATTRIBUTE_NORMAL } - { +temporary+ FILE_ATTRIBUTE_TEMPORARY } - { +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE } - { +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT } - { +compressed+ FILE_ATTRIBUTE_COMPRESSED } - { +offline+ FILE_ATTRIBUTE_OFFLINE } - { +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED } - { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED } - } get-flags ; + [ + FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute + FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute + FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute + FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute + FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute + FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute + FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute + FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute + FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute + FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute + FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute + FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute + FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute + FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute + drop + ] { } make ; : win32-file-type ( n -- symbol ) FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index b09d867e10..3e49f1dc10 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system threads init strings combinators -io.backend new-slots accessors ; +io.backend new-slots accessors concurrency.flags ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -137,18 +137,18 @@ M: windows-io kill-process* ( handle -- ) dup HEX: ffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; +SYMBOL: wait-flag + : wait-loop ( -- ) processes get dup assoc-empty? - [ drop f sleep-until ] + [ drop wait-flag get-global lower-flag ] [ wait-for-processes [ 100 sleep ] when ] if ; -SYMBOL: wait-thread - : start-wait-thread ( -- ) - [ wait-loop t ] "Process wait" spawn-server - wait-thread set-global ; + wait-flag set-global + [ wait-loop t ] "Process wait" spawn-server drop ; M: windows-io register-process - drop wait-thread get-global interrupt ; + drop wait-flag get-global raise-flag ; [ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 9bc587e00e..319acc35f8 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -14,4 +14,4 @@ USE: io.backend T{ windows-nt-io } set-io-backend -"vocabs.monitor" require +"tools.vocabs.monitor" require diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor old mode 100644 new mode 100755 index 8beecc955c..42414b9893 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -59,7 +59,7 @@ M: jamshred-gadget ungraft* ( gadget -- ) USE: vocabs.loader jamshred-gadget H{ - { T{ key-down f f "r" } [ jamshred-restart refresh-all ] } + { T{ key-down f f "r" } [ jamshred-restart ] } { T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] } { T{ motion } [ handle-mouse-motion ] } } set-gestures diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lazy-lists/lazy-lists-docs.factor index 11afc9b6b5..ebacea03d8 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lazy-lists/lazy-lists-docs.factor @@ -26,7 +26,7 @@ HELP: nil? { $values { "cons" "a cons object" } { "?" "a boolean" } } { $description "Return true if the cons object is the nil cons." } ; -HELP: list? +HELP: list? ( object -- ? ) { $values { "object" "an object" } { "?" "a boolean" } } { $description "Returns true if the object conforms to the list protocol." } ; @@ -175,7 +175,7 @@ HELP: lmerge { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } } { $description "Return the result of merging the two lists in a lazy manner." } { $examples - { $example "USE: lazy-lists" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } + { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } } ; HELP: lcontents diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lazy-lists/lazy-lists-tests.factor index 0424a5d069..302299b452 100644 --- a/extra/lazy-lists/lazy-lists-tests.factor +++ b/extra/lazy-lists/lazy-lists-tests.factor @@ -23,3 +23,7 @@ IN: lazy-lists.tests [ { 5 6 7 8 } ] [ { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array ] unit-test + +[ { 4 5 6 } ] [ + 3 { 1 2 3 } >list [ + ] lmap-with list>array +] unit-test diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index e3e7b14917..07cd34b4df 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -144,25 +144,8 @@ M: lazy-map cdr ( lazy-map -- cdr ) M: lazy-map nil? ( lazy-map -- bool ) lazy-map-cons nil? ; -TUPLE: lazy-map-with value cons quot ; - -C: lazy-map-with - : lmap-with ( value list quot -- result ) - over nil? [ 3drop nil ] [ ] if ; - -M: lazy-map-with car ( lazy-map-with -- car ) - [ lazy-map-with-value ] keep - [ lazy-map-with-cons car ] keep - lazy-map-with-quot call ; - -M: lazy-map-with cdr ( lazy-map-with -- cdr ) - [ lazy-map-with-value ] keep - [ lazy-map-with-cons cdr ] keep - lazy-map-with-quot lmap-with ; - -M: lazy-map-with nil? ( lazy-map-with -- bool ) - lazy-map-with-cons nil? ; + with lmap ; TUPLE: lazy-take n cons ; @@ -453,7 +436,6 @@ INSTANCE: lazy-io list INSTANCE: lazy-concat list INSTANCE: lazy-cons list INSTANCE: lazy-map list -INSTANCE: lazy-map-with list INSTANCE: lazy-take list INSTANCE: lazy-append list INSTANCE: lazy-from-by list diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor index b8d836ecc1..62f2eac513 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -15,7 +15,7 @@ HELP: [| { $description "A lambda abstraction. When called, reads stack values into the bindings from left to right; the body may then refer to these bindings." } { $examples { $example - "USE: locals" + "USING: kernel locals math prettyprint ;" ":: adder ( n -- quot ) [| m | m n + ] ;" "3 5 adder call ." "8" @@ -28,7 +28,7 @@ HELP: [let { $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." } { $examples { $example - "USING: locals math.functions ;" + "USING: kernel locals math math.functions prettyprint sequences ;" ":: frobnicate ( n seq -- newseq )" " [let | n' [ n 6 * ] |" " seq [ n' gcd nip ] map ] ;" @@ -43,7 +43,7 @@ HELP: [wlet { $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." } { $examples { $example - "USE: locals" + "USING: locals math prettyprint sequences ;" ":: quuxify ( n seq -- newseq )" " [wlet | add-n [| m | m n + ] |" " seq [ add-n ] map ] ;" diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor old mode 100644 new mode 100755 index e48f9f4061..b4f1b0a61e --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -116,6 +116,12 @@ write-test-2 "q" set [ ] [ 5 write-test-4 drop ] unit-test +! Not really a write test; just enforcing consistency +:: write-test-5 ( x -- y ) + [wlet | fun! [ x + ] | 5 fun! ] ; + +[ 9 ] [ 4 write-test-5 ] unit-test + SYMBOL: a :: use-test ( a b c -- a b c ) @@ -160,3 +166,15 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; [ ] [ \ lambda-generic-2 see ] unit-test [ ] [ \ lambda-generic see ] unit-test + +[ "[let | a! [ ] | ]" ] [ + [let | a! [ ] | ] unparse +] unit-test + +[ "[wlet | a! [ ] | ]" ] [ + [wlet | a! [ ] | ] unparse +] unit-test + +[ "[| a! | ]" ] [ + [| a! | ] unparse +] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 5f58f1464a..9819e65e37 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables combinators.lib prettyprint.sections sequences.private effects generic -compiler.units ; +compiler.units combinators.cleave ; IN: locals ! Inspired by @@ -108,8 +108,8 @@ UNION: special local quote local-word local-reader local-writer ; if ; : (point-free) ( quot args -- newquot ) - { [ load-locals ] [ point-free-body ] [ point-free-end ] } - map-call-with2 concat >quotation ; + [ load-locals ] [ point-free-body ] [ point-free-end ] + 2tri 3append >quotation ; : point-free ( quot args -- newquot ) over empty? [ drop ] [ (point-free) ] if ; @@ -317,7 +317,7 @@ M: lambda pprint* \ | pprint-word t r pprint-word r> pprint* block> ] 2each + values [ r pprint-var r> pprint* block> ] 2each block> \ | pprint-word @@ -329,7 +329,7 @@ M: let pprint* \ ] pprint-word ; M: wlet pprint* - \ [let pprint-word + \ [wlet pprint-word { wlet-body wlet-vars wlet-bindings } get-slots pprint-let \ ] pprint-word ; diff --git a/extra/logging/analysis/analysis-docs.factor b/extra/logging/analysis/analysis-docs.factor index 2919f2bcd4..10b6924b52 100644 --- a/extra/logging/analysis/analysis-docs.factor +++ b/extra/logging/analysis/analysis-docs.factor @@ -16,7 +16,7 @@ HELP: analysis. { $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ; HELP: analyze-log -{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } } +{ $values { "lines" "a parsed log file" } { "word-names" "a sequence of strings" } } { $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; ARTICLE: "logging.analysis" "Log analysis" diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor index 93485e4c7c..c86a675698 100755 --- a/extra/logging/insomniac/insomniac-docs.factor +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -2,12 +2,6 @@ USING: help.markup help.syntax assocs strings logging logging.analysis smtp ; IN: logging.insomniac -HELP: insomniac-smtp-host -{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ; - -HELP: insomniac-smtp-port -{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ; - HELP: insomniac-sender { $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; @@ -15,16 +9,16 @@ HELP: insomniac-recipients { $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; HELP: ?analyze-log -{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } } +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string/f" string } } { $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." } { $see-also analyze-log } ; HELP: email-log-report { $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } -{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; +{ $description "E-mails a log report for the given log service. The " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; HELP: schedule-insomniac -{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } { $description "Starts a thread which e-mails log reports and rotates logs daily." } ; ARTICLE: "logging.insomniac" "Automated log analysis" @@ -33,9 +27,6 @@ $nl "Required configuration parameters:" { $subsection insomniac-sender } { $subsection insomniac-recipients } -"Optional configuration parameters:" -{ $subsection insomniac-smtp-host } -{ $subsection insomniac-smtp-port } "E-mailing a one-off report:" { $subsection email-log-report } "E-mailing reports and rotating logs on a daily basis:" diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index dfd7f430d2..c7d1faf42e 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -6,8 +6,6 @@ io.encodings.utf8 accessors calendar qualified ; QUALIFIED: io.sockets IN: logging.insomniac -SYMBOL: insomniac-smtp-host -SYMBOL: insomniac-smtp-port SYMBOL: insomniac-sender SYMBOL: insomniac-recipients @@ -18,29 +16,20 @@ SYMBOL: insomniac-recipients r> 2drop f ] if ; -: with-insomniac-smtp ( quot -- ) - [ - insomniac-smtp-host get [ smtp-host set ] when* - insomniac-smtp-port get [ smtp-port set ] when* - call - ] with-scope ; inline - : email-subject ( service -- string ) [ "[INSOMNIAC] " % % " on " % io.sockets:host-name % ] "" make ; : (email-log-report) ( service word-names -- ) - [ - dupd ?analyze-log dup [ - - swap >>body - insomniac-recipients get >>to - insomniac-sender get >>from - swap email-subject >>subject - send - ] [ 2drop ] if - ] with-insomniac-smtp ; + dupd ?analyze-log dup [ + + swap >>body + insomniac-recipients get >>to + insomniac-sender get >>from + swap email-subject >>subject + send-email + ] [ 2drop ] if ; \ (email-log-report) NOTICE add-error-logging diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor index a7750fe388..df0b132ac8 100755 --- a/extra/logging/logging-docs.factor +++ b/extra/logging/logging-docs.factor @@ -39,19 +39,19 @@ HELP: log-message { $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; HELP: add-logging -{ $values { "word" word } } +{ $values { "level" "a log level" } { "word" word } } { $description "Causes the word to log a message every time it is called." } ; HELP: add-input-logging -{ $values { "word" word } } +{ $values { "level" "a log level" } { "word" word } } { $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ; HELP: add-output-logging -{ $values { "word" word } } +{ $values { "level" "a log level" } { "word" word } } { $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ; HELP: add-error-logging -{ $values { "word" word } } +{ $values { "level" "a log level" } { "word" word } } { $description "Causes the word to log its input values and any errors it throws." $nl "If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller." @@ -63,7 +63,7 @@ HELP: log-error { $description "Logs an error." } ; HELP: log-critical -{ $values { "critical" "an critical" } { "word" word } } +{ $values { "error" "an error" } { "word" word } } { $description "Logs a critical error." } ; HELP: LOG: diff --git a/extra/logging/parser/parser-docs.factor b/extra/logging/parser/parser-docs.factor index ee995749be..dc80f9e87f 100644 --- a/extra/logging/parser/parser-docs.factor +++ b/extra/logging/parser/parser-docs.factor @@ -6,7 +6,7 @@ HELP: parse-log { $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where" { $list { { $snippet "timestamp" } " is a " { $link timestamp } } - { { $snippet "level" } " is a log level; see " { $link "logger.levels" } } + { { $snippet "level" } " is a log level; see " { $link "logging.levels" } } { { $snippet "word-name" } " is a string" } { { $snippet "message" } " is a string" } } diff --git a/extra/match/match-docs.factor b/extra/match/match-docs.factor index 96d2ea98de..4ac59bb0cc 100644 --- a/extra/match/match-docs.factor +++ b/extra/match/match-docs.factor @@ -41,7 +41,7 @@ HELP: match-replace { $description "Matches the " { $snippet "object" } " against " { $snippet "pattern1" } ". The pattern match variables in " { $snippet "pattern1" } " are assigned the values from the matching " { $snippet "object" } ". These are then replaced into the " { $snippet "pattern2" } " pattern match variables." } { $examples { $example - "USE: match" + "USING: match prettyprint ;" "MATCH-VARS: ?a ?b ;" "{ 1 2 } { ?a ?b } { ?b ?a } match-replace ." "{ 2 1 }" diff --git a/extra/math/combinatorics/combinatorics-docs.factor b/extra/math/combinatorics/combinatorics-docs.factor index c763cc32cf..355898a8bd 100644 --- a/extra/math/combinatorics/combinatorics-docs.factor +++ b/extra/math/combinatorics/combinatorics-docs.factor @@ -4,46 +4,46 @@ IN: math.combinatorics HELP: factorial { $values { "n" "a non-negative integer" } { "n!" integer } } { $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } -{ $examples { $example "4 factorial ." "24" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ; HELP: nPk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } { $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." } -{ $examples { $example "10 4 nPk ." "5040" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ; HELP: nCk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } { $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." } -{ $examples { $example "10 4 nCk ." "210" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ; HELP: permutation { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } -{ $examples { $example "1 3 permutation ." "{ 0 2 1 }" } { $example "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\"}" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ; HELP: all-permutations { $values { "seq" sequence } { "seq" sequence } } { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } -{ $examples { $example "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; HELP: inverse-permutation { $values { "seq" sequence } { "permutation" sequence } } { $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } { $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } -{ $examples { $example "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; +{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; IN: math.combinatorics.private HELP: factoradic -{ $values { "n" integer } { "seq" sequence } } +{ $values { "n" integer } { "factoradic" sequence } } { $description "Converts a positive integer " { $snippet "n" } " to factoradic form. The factoradic of an integer is its representation based on a mixed radix numerical system that corresponds to the values of " { $snippet "n" } " factorial." } -{ $examples { $example "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ; +{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ; HELP: >permutation { $values { "factoradic" sequence } { "permutation" sequence } } { $description "Converts an integer represented in factoradic form into its corresponding unique permutation (0-based)." } { $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } } -{ $examples { $example "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ; +{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ; diff --git a/extra/math/constants/constants-docs.factor b/extra/math/constants/constants-docs.factor index 42cdf0e8f1..4fdd975202 100755 --- a/extra/math/constants/constants-docs.factor +++ b/extra/math/constants/constants-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel layouts ; +USING: help.markup help.syntax kernel ; IN: math.constants ARTICLE: "math-constants" "Constants" @@ -7,9 +7,6 @@ ARTICLE: "math-constants" "Constants" { $subsection euler } { $subsection phi } { $subsection pi } -"Various limits:" -{ $subsection most-positive-fixnum } -{ $subsection most-negative-fixnum } { $subsection epsilon } ; ABOUT: "math-constants" diff --git a/extra/math/erato/erato-docs.factor b/extra/math/erato/erato-docs.factor index 6e84c84057..29bd3020f3 100644 --- a/extra/math/erato/erato-docs.factor +++ b/extra/math/erato/erato-docs.factor @@ -3,4 +3,4 @@ IN: math.erato HELP: lerato { $values { "n" "a positive number" } { "lazy-list" "a lazy prime numbers generator" } } -{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive). Lazy lists are described in " { $link "lazy-lists" } "." } ; +{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive)." } ; diff --git a/extra/math/functions/functions-docs.factor b/extra/math/functions/functions-docs.factor index d3a81566b9..f0819fb03e 100755 --- a/extra/math/functions/functions-docs.factor +++ b/extra/math/functions/functions-docs.factor @@ -273,16 +273,16 @@ HELP: mod-inv { $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." } { $errors "Throws an error if " { $snippet "n" } " is not invertible modulo " { $snippet "n" } "." } { $examples - { $example "USE: math.functions" "173 1119 mod-inv ." "815" } - { $example "USE: math.functions" "173 815 * 1119 mod ." "1" } + { $example "USING: math.functions prettyprint ;" "173 1119 mod-inv ." "815" } + { $example "USING: math prettyprint ;" "173 815 * 1119 mod ." "1" } } ; HELP: each-bit { $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( ? -- )" } } } { $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." } { $examples - { $example "USE: math.functions" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" } - { $example "USE: math.functions" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" } + { $example "USING: math.functions namespaces prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" } + { $example "USING: math.functions namespaces prettyprint ;" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" } } ; HELP: ~ diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor old mode 100644 new mode 100755 index df9a87fb40..e74ffc64d2 --- a/extra/math/matrices/matrices.factor +++ b/extra/math/matrices/matrices.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel sequences math math.functions -math.vectors ; +math.vectors combinators.cleave ; IN: math.matrices ! Matrices @@ -33,23 +33,22 @@ IN: math.matrices : mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ; : mnorm ( m -- n ) dup mmax abs m/n ; -: cross-i ( vec1 vec2 -- i ) - over third over second * >r - swap second swap third * r> - ; +r - swap third swap first * r> - ; +: x first ; inline +: y second ; inline +: z third ; inline -: cross-k ( vec1 vec2 -- k ) - over first over second * >r - swap second swap first * r> - ; +: i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ; +: j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ; +: k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ; -: cross ( vec1 vec2 -- vec3 ) - [ cross-i ] 2keep [ cross-j ] 2keep cross-k 3array ; +PRIVATE> + +: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ; : proj ( v u -- w ) - [ [ v. ] keep norm-sq / ] keep n*v ; + [ [ v. ] [ norm-sq ] bi / ] keep n*v ; : (gram-schmidt) ( v seq -- newseq ) [ dupd proj v- ] each ; diff --git a/extra/math/primes/factors/factors-docs.factor b/extra/math/primes/factors/factors-docs.factor index f5b14b5a5a..f9fe4d5dcb 100644 --- a/extra/math/primes/factors/factors-docs.factor +++ b/extra/math/primes/factors/factors-docs.factor @@ -6,17 +6,17 @@ IN: math.primes.factors HELP: factors { $values { "n" "a positive integer" } { "seq" sequence } } { $description { "Return an ordered list of a number's prime factors, possibly repeated." } } -{ $examples { $example "300 factors ." "{ 2 2 3 5 5 }" } } ; +{ $examples { $example "USING: math.primes.factors prettyprint ;" "300 factors ." "{ 2 2 3 5 5 }" } } ; HELP: group-factors { $values { "n" "a positive integer" } { "seq" sequence } } { $description { "Return a sequence of pairs representing each prime factor in the number and its corresponding power (multiplicity)." } } -{ $examples { $example "300 group-factors ." "{ { 2 2 } { 3 1 } { 5 2 } }" } } ; +{ $examples { $example "USING: math.primes.factors prettyprint ;" "300 group-factors ." "{ { 2 2 } { 3 1 } { 5 2 } }" } } ; HELP: unique-factors { $values { "n" "a positive integer" } { "seq" sequence } } { $description { "Return an ordered list of a number's unique prime factors." } } -{ $examples { $example "300 unique-factors ." "{ 2 3 5 }" } } ; +{ $examples { $example "USING: math.primes.factors prettyprint ;" "300 unique-factors ." "{ 2 3 5 }" } } ; HELP: totient { $values { "n" "a positive integer" } { "t" integer } } diff --git a/extra/math/statistics/statistics-docs.factor b/extra/math/statistics/statistics-docs.factor index 4787a85aed..695834b554 100644 --- a/extra/math/statistics/statistics-docs.factor +++ b/extra/math/statistics/statistics-docs.factor @@ -4,56 +4,56 @@ IN: math.statistics HELP: geometric-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } -{ $examples { $example "USE: math.statistics" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } +{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; HELP: harmonic-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } -{ $examples { $example "USE: math.statistics" "{ 1 2 3 } harmonic-mean ." "6/11" } } +{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." } -{ $examples { $example "USE: math.statistics" "{ 1 2 3 } mean ." "2" } } +{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: median { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." } { $examples - { $example "USE: math.statistics" "{ 1 2 3 } median ." "2" } - { $example "USE: math.statistics" "{ 1 2 3 4 } median ." "5/2" } } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } median ." "2+1/2" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: range { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } { $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." } { $examples - { $example "USE: math.statistics" "{ 1 2 3 } range ." "2" } - { $example "USE: math.statistics" "{ 1 2 3 4 } range ." "3" } } ; + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } range ." "3" } } ; HELP: std { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." } { $examples - { $example "USE: math.statistics" "{ 1 2 3 } std ." "1.0" } - { $example "USE: math.statistics" "{ 1 2 3 4 } std ." "1.290994448735806" } } ; + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ; HELP: ste { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } { $examples - { $example "USE: math.statistics" "{ -2 2 } ste ." "2.0" } - { $example "USE: math.statistics" "{ -2 2 2 } ste ." "1.333333333333333" } } ; + { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" } + { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ; HELP: var { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } { $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." } { $examples - { $example "USE: math.statistics" "{ 1 } var ." "0" } - { $example "USE: math.statistics" "{ 1 2 3 } var ." "1" } - { $example "USE: math.statistics" "{ 1 2 3 4 } var ." "5/3" } } ; + { $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } var ." "1" } + { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } var ." "1+2/3" } } ; diff --git a/extra/math/text/english/english-docs.factor b/extra/math/text/english/english-docs.factor index d544f49ad8..a7fdc421aa 100644 --- a/extra/math/text/english/english-docs.factor +++ b/extra/math/text/english/english-docs.factor @@ -4,4 +4,4 @@ IN: math.text.english HELP: number>text { $values { "n" integer } { "str" string } } { $description "Converts an integer to a text string representation in English, including appropriate punctuation and conjunctions." } -{ $examples { $example "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ; +{ $examples { $example "USING: math.text.english prettyprint ;" "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ; diff --git a/extra/math/vectors/vectors-docs.factor b/extra/math/vectors/vectors-docs.factor index fe33dd65e3..140eddb2f6 100755 --- a/extra/math/vectors/vectors-docs.factor +++ b/extra/math/vectors/vectors-docs.factor @@ -69,12 +69,12 @@ HELP: v/ HELP: vmax { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } { $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." } -{ $examples { $example "USE: math.vectors" "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ; +{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ; HELP: vmin { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } { $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." } -{ $examples { $example "USE: math.vectors" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ; +{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ; HELP: v. { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "x" "a real number" } } @@ -99,7 +99,7 @@ HELP: normalize HELP: set-axis { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } } { $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." } -{ $examples { $example "USE: math.vectors" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ; +{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ; { 2map v+ v- v* v/ } related-words diff --git a/extra/opengl/capabilities/capabilities-docs.factor b/extra/opengl/capabilities/capabilities-docs.factor index e73b7a3f0b..f5424e19da 100644 --- a/extra/opengl/capabilities/capabilities-docs.factor +++ b/extra/opengl/capabilities/capabilities-docs.factor @@ -43,7 +43,7 @@ HELP: has-gl-extensions? { $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; HELP: has-gl-version-or-extensions? -{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } } { $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; HELP: require-gl-extensions diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor old mode 100644 new mode 100755 index 59b7a3bcc3..8fee55962f --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,5 +1,5 @@ USING: arrays combinators.lib kernel math math.functions math.vectors namespaces - opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; + opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render combinators.cleave ; IN: opengl.demo-support : NEAR-PLANE 1.0 64.0 / ; inline @@ -47,14 +47,15 @@ M: demo-gadget pref-dim* ( gadget -- dim ) GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear GL_MODELVIEW glMatrixMode glLoadIdentity - { [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] - [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] - [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } call-with ; + [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] + [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] + [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] + tri ; : reset-last-drag-rel ( -- ) - { 0 0 } last-drag-loc set ; + { 0 0 } last-drag-loc set-global ; : last-drag-rel ( -- rel ) - drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ; + drag-loc [ last-drag-loc get v- ] keep last-drag-loc set-global ; : drag-yaw-pitch ( -- yaw pitch ) last-drag-rel MOUSE-MOTION-SCALE v*n first2 ; diff --git a/extra/opengl/shaders/shaders-docs.factor b/extra/opengl/shaders/shaders-docs.factor index e065367323..93251627f4 100644 --- a/extra/opengl/shaders/shaders-docs.factor +++ b/extra/opengl/shaders/shaders-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs ; +opengl.gl multiline assocs strings ; IN: opengl.shaders HELP: gl-shader @@ -28,19 +28,19 @@ HELP: fragment-shader } ; HELP: -{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } } +{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } { "shader" "a new " { $link gl-shader } } } { $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ; HELP: -{ $values { "source" "The GLSL source code to compile" } } +{ $values { "source" "The GLSL source code to compile" } { "vertex-shader" "a new " { $link vertex-shader } } } { $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER " } "." } ; HELP: -{ $values { "source" "The GLSL source code to compile" } } +{ $values { "source" "The GLSL source code to compile" } { "fragment-shader" "a new " { $link fragment-shader } } } { $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER " } "." } ; HELP: gl-shader-ok? -{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } } { $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ; HELP: check-gl-shader @@ -52,7 +52,7 @@ HELP: delete-gl-shader { $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ; HELP: gl-shader-info-log -{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } } { $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ; HELP: gl-program @@ -69,17 +69,17 @@ HELP: gl-program } ; HELP: -{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } } +{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } { "program" "a new " { $link gl-program } } } { $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ; HELP: -{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } } +{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } { "program" "a new " { $link gl-program } } } { $description "Wrapper for " { $link } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ; { } related-words HELP: gl-program-ok? -{ $values { "program" "A " { $link gl-program } " object" } } +{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } } { $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ; HELP: check-gl-program @@ -87,7 +87,7 @@ HELP: check-gl-program { $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ; HELP: gl-program-info-log -{ $values { "program" "A " { $link gl-program } " object" } } +{ $values { "program" "A " { $link gl-program } " object" } { "log" string } } { $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ; HELP: delete-gl-program diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor old mode 100644 new mode 100755 index 0ff708d6d4..ceda434c75 --- a/extra/opengl/shaders/shaders.factor +++ b/extra/opengl/shaders/shaders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel opengl.gl alien.c-types continuations namespaces assocs alien libc opengl math sequences combinators.lib -macros arrays ; +macros arrays combinators.cleave ; IN: opengl.shaders : with-gl-shader-source-ptr ( string quot -- ) @@ -50,7 +50,7 @@ IN: opengl.shaders alien>char-string ] with-malloc ; -: check-gl-shader ( shader -- shader* ) +: check-gl-shader ( shader -- shader ) dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ; : delete-gl-shader ( shader -- ) glDeleteShader ; inline @@ -85,7 +85,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; alien>char-string ] with-malloc ; -: check-gl-program ( program -- program* ) +: check-gl-program ( program -- program ) dup gl-program-ok? [ dup gl-program-info-log throw ] unless ; : gl-program-shaders-length ( program -- shaders-length ) @@ -117,7 +117,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; : (make-with-gl-program) ( uniforms quot -- q ) [ \ dup , - [ swap (with-gl-program-uniforms) , \ call-with , % ] + [ swap (with-gl-program-uniforms) , \ cleave , % ] [ ] make , \ (with-gl-program) , ] [ ] make ; diff --git a/extra/parser-combinators/parser-combinators-docs.factor b/extra/parser-combinators/parser-combinators-docs.factor index 774069d5a5..41171ce822 100755 --- a/extra/parser-combinators/parser-combinators-docs.factor +++ b/extra/parser-combinators/parser-combinators-docs.factor @@ -12,7 +12,7 @@ HELP: list-of "'items' is a parser that can parse the individual elements. 'separator' " "is a parser for the symbol that separatest them. The result tree of " "the resulting parser is an array of the parsed elements." } -{ $example "USE: parser-combinators" "\"1,2,3,4\" 'integer' \",\" token list-of parse-1 ." "{ 1 2 3 4 }" } +{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' \",\" token list-of parse-1 ." "{ 1 2 3 4 }" } { $see-also list-of } ; HELP: any-char-parser @@ -23,4 +23,4 @@ HELP: any-char-parser "from the input string. The value consumed is the " "result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"foo\" any-char-parser parse-1 ." "102" } } ; +{ $example "USING: lazy-lists parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ; diff --git a/extra/parser-combinators/simple/simple-docs.factor b/extra/parser-combinators/simple/simple-docs.factor index bba37ca4ca..78b731f5b0 100755 --- a/extra/parser-combinators/simple/simple-docs.factor +++ b/extra/parser-combinators/simple/simple-docs.factor @@ -11,7 +11,7 @@ HELP: 'digit' "the input string. The numeric value of the digit " " consumed is the result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse-1 ." "1" } } ; +{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ; HELP: 'integer' { $values @@ -21,7 +21,7 @@ HELP: 'integer' "the input string. The numeric value of the integer " " consumed is the result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse-1 ." "123" } } ; +{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ; HELP: 'string' { $values { "parser" "a parser object" } } @@ -30,7 +30,8 @@ HELP: 'string' "quotations from the input string. The string value " " consumed is the result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ; +{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ; + HELP: 'bold' { $values { "parser" "a parser object" } } @@ -39,8 +40,9 @@ HELP: 'bold' "the '*' character from the input string. This is " "commonly used in markup languages to indicate bold " "faced text." } -{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" } -{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } ; +{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" } +{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } ; + HELP: 'italic' { $values { "parser" "a parser object" } } @@ -50,8 +52,8 @@ HELP: 'italic' "commonly used in markup languages to indicate italic " "faced text." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" } -{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } } ; +{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" } +{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } } ; HELP: comma-list { $values { "element" "a parser object" } { "parser" "a parser object" } } @@ -60,6 +62,6 @@ HELP: comma-list "'element' should be a parser that can parse the elements. The " "result of the parser is a sequence of the parsed elements." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ; +{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ; { $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor index 437edc1007..1991cba0eb 100755 --- a/extra/peg/parsers/parsers-docs.factor +++ b/extra/peg/parsers/parsers-docs.factor @@ -1,9 +1,19 @@ -! Copyright (C) 2007 Chris Double. +! Copyright (C) 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax peg peg.parsers.private unicode.categories ; IN: peg.parsers +HELP: 1token +{ $values + { "ch" "a character" } + { "parser" "a parser" } +} { $description + "Calls 1string on a character and returns a parser that matches that character." +} { $examples + { $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse parse-result-ast ." "\"a\"" } +} { $see-also 'string' } ; + HELP: (list-of) { $values { "items" "a sequence" } @@ -18,24 +28,26 @@ HELP: list-of { $values { "items" "a sequence" } { "separator" "a parser" } + { "parser" "a parser" } } { $description "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of one or more items." } { $notes "Use " { $link list-of-many } " to ensure a list contains two or more items." } { $examples - { $example "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" } - { $example "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } } { $see-also list-of-many } ; HELP: list-of-many { $values { "items" "a sequence" } { "separator" "a parser" } + { "parser" "a parser" } } { $description "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of two or more items." } { $notes "Use " { $link list-of } " to return a list of only one item." } { $examples - { $example "\"a\" \"a\" token \",\" token list-of-many parse ." "f" } - { $example "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of-many parse ." "f" } + { $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } } { $see-also list-of } ; HELP: epsilon @@ -60,8 +72,8 @@ HELP: exactly-n } { $description "Returns a parser that matches an exact repetition of the input parser." } { $examples - { $example "\"aaa\" \"a\" token 4 exactly-n parse ." "f" } - { $example "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 exactly-n parse ." "f" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } } { $see-also at-least-n at-most-n from-m-to-n } ; HELP: at-least-n @@ -72,9 +84,9 @@ HELP: at-least-n } { $description "Returns a parser that matches n or more repetitions of the input parser." } { $examples - { $example "\"aaa\" \"a\" token 4 at-least-n parse ." "f" } - { $example "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } - { $example "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 at-least-n parse ." "f" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" } } { $see-also exactly-n at-most-n from-m-to-n } ; HELP: at-most-n @@ -85,8 +97,8 @@ HELP: at-most-n } { $description "Returns a parser that matches n or fewer repetitions of the input parser." } { $examples - { $example "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } - { $example "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } } { $see-also exactly-n at-least-n from-m-to-n } ; HELP: from-m-to-n @@ -98,9 +110,9 @@ HELP: from-m-to-n } { $description "Returns a parser that matches between and including m to n repetitions of the input parser." } { $examples - { $example "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" } - { $example "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } - { $example "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } } { $see-also exactly-n at-most-n at-least-n } ; HELP: pack @@ -108,11 +120,11 @@ HELP: pack { "begin" "a parser" } { "body" "a parser" } { "end" "a parser" } - { "parser'" "a parser" } + { "parser" "a parser" } } { $description "Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." } { $examples - { $example "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "123" } + { $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "123" } } { $see-also surrounded-by } ; HELP: surrounded-by @@ -124,7 +136,7 @@ HELP: surrounded-by } { $description "Calls token on begin and end to make them into string parsers. Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." } { $examples - { $example "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "123" } + { $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "123" } } { $see-also pack } ; HELP: 'digit' diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 5e82756853..87306e1469 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -21,6 +21,8 @@ M: just-parser compile ( parser -- quot ) MEMO: just ( parser -- parser ) just-parser construct-boa init-parser ; +MEMO: 1token ( ch -- parser ) 1string token ; + r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq diff --git a/extra/peg/search/search-docs.factor b/extra/peg/search/search-docs.factor index fc1e618b9b..565601ea11 100755 --- a/extra/peg/search/search-docs.factor +++ b/extra/peg/search/search-docs.factor @@ -10,7 +10,7 @@ HELP: tree-write "Write the object to the standard output stream, unless " "it is an array, in which case recurse through the array " "writing each object to the stream." } -{ $example "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; +{ $example "USE: peg.search" "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ; HELP: search { $values @@ -24,8 +24,8 @@ HELP: search "parser." } -{ $example "\"one 123 two 456\" 'integer' search" "V{ 123 456 }" } -{ $example "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array choice search" "V{ 123 \"hello\" 456 }" } +{ $example "USING: peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' search ." "V{ 123 456 }" } +{ $example "USING: peg peg.parsers peg.search prettyprint ;" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2choice search ." "V{ 123 \"hello\" 456 }" } { $see-also replace } ; HELP: replace @@ -39,6 +39,6 @@ HELP: replace "successfully parse with the given parser replaced with " "the result of that parser." } -{ $example "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace" "\"one 246 two 912\"" } +{ $example "USING: math math.parser peg peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace ." "\"one 246 two 912\"" } { $see-also search } ; diff --git a/extra/promises/promises-docs.factor b/extra/promises/promises-docs.factor index 1adc14ca77..ade3357f34 100755 --- a/extra/promises/promises-docs.factor +++ b/extra/promises/promises-docs.factor @@ -29,6 +29,6 @@ HELP: LAZY: { $values { "word" "a new word to define" } { "definition" "a word definition" } } { $description "Creates a lazy word in the current vocabulary. When executed the word will return a " { $link promise } " that when forced, executes the word definition. Any values on the stack that are required by the word definition are captured along with the promise." } { $examples - { $example "IN: promises LAZY: my-add ( a b -- c ) + ;\n1 2 my-add force ." "3" } + { $example "USING: math prettyprint promises ;" "LAZY: my-add ( a b -- c ) + ;" "1 2 my-add force ." "3" } } { $see-also force promise-with promise-with2 } ; diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index f6e7c05910..5a6b0bdfac 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -222,3 +222,7 @@ IN: regexp-tests [ f ] [ "foo bar" "foo\\B bar" f matches? ] unit-test [ t ] [ "fooxbar" "foo\\Bxbar" f matches? ] unit-test [ f ] [ "foo" "foo\\Bbar" f matches? ] unit-test + +[ t ] [ "s@f" "[a-z.-]@[a-z]" f matches? ] unit-test +[ f ] [ "a" "[a-z.-]@[a-z]" f matches? ] unit-test +[ t ] [ ".o" "\\.[a-z]" f matches? ] unit-test diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index fe1d87d9e9..8a642a8692 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -167,7 +167,8 @@ C: group-result "(" ")" surrounded-by ; : 'range' ( -- parser ) - any-char-parser "-" token <& any-char-parser <&> + [ CHAR: ] = not ] satisfy "-" token <& + [ CHAR: ] = not ] satisfy <&> [ first2 char-between?-quot ] <@ ; : 'character-class-term' ( -- parser ) diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor index fa10fff01c..be0789ba5e 100644 --- a/extra/semantic-db/hierarchy/hierarchy.factor +++ b/extra/semantic-db/hierarchy/hierarchy.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ; +USING: accessors db.tuples hashtables kernel new-slots +semantic-db semantic-db.relations sequences sequences.deep ; IN: semantic-db.hierarchy TUPLE: tree id children ; @@ -41,4 +42,4 @@ C: tree ] if ; : get-root-nodes ( node-id -- root-nodes ) - (get-root-nodes) flatten ; + (get-root-nodes) flatten prune ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 01476a145a..257133c67f 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,18 +1,28 @@ -USING: accessors arrays db db.sqlite db.tuples kernel math namespaces -semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations -sequences tools.test tools.walker ; +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 +tools.walker ; IN: semantic-db.tests -[ +: db-path "semantic-db-test.db" temp-file ; +: test-db db-path sqlite-db ; +: delete-db [ db-path delete-file ] ignore-errors ; + +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-tmp-sqlite +] with-db -[ +delete-db + +test-db [ init-semantic-db "test content" create-context* [ [ 4 ] [ context ] unit-test @@ -35,10 +45,12 @@ IN: semantic-db.tests ! [ 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-tmp-sqlite +] with-db + +delete-db ! test hierarchy -[ +test-db [ init-semantic-db "family tree" create-context* [ "adam" create-node* "adam" set @@ -52,7 +64,9 @@ IN: semantic-db.tests [ { "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 break get-root-nodes [ 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-tmp-sqlite +] with-db + +delete-db diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index a48048f152..e8075c016d 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -86,3 +86,4 @@ arc "arc" #! 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* ; + diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor deleted file mode 100644 index 7eec2fe179..0000000000 --- a/extra/semantic-db/type/type.factor +++ /dev/null @@ -1,48 +0,0 @@ -! Copyright (C) 2008 Alex Chapman -! See http://factorcode.org/license.txt for BSD license. -USING: arrays db db.types kernel semantic-db sequences sequences.lib ; -IN: semantic-db.type - -! types: -! - have type 'type' in context 'semantic-db' -! - have a context in context 'semantic-db' - -: assign-type ( type nid -- arc-id ) - has-type-relation spin arc-id ; - -: create-node-of-type ( type content -- node-id ) - node-id [ assign-type drop ] keep ; - -: select-nodes-of-type ( type -- node-ids ) - ":type" INTEGER param - has-type-relation ":has_type" INTEGER param 2array - "select a.subject from arc a where a.relation = :has_type and a.object = :type" - single-int-results ; - -: select-node-of-type ( type -- node-id ) - select-nodes-of-type ?first ; - -: select-nodes-of-type-with-content ( type content -- node-ids ) - ! find nodes with the given content that are the subjects of arcs with: - ! relation = has-type-relation - ! object = type - ":name" TEXT param - swap ":type" INTEGER param - has-type-relation ":has_type" INTEGER param 3array - "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.object = :type and a.relation = :has_type" - single-int-results ; - -: select-node-of-type-with-content ( type content -- node-id/f ) - select-nodes-of-type-with-content ?first ; - -: ensure-node-of-type ( type content -- node-id ) - [ select-node-of-type-with-content ] [ create-node-of-type ] ensure2 ; - ! 2dup select-node-of-type-with-content [ 2nip ] [ create-node-of-type ] if* ; - - -: ensure-type ( type -- node-id ) - dup "type" = [ - drop type-type - ] [ - type-type swap ensure-node-of-type - ] if ; diff --git a/extra/sequences/lib/lib-docs.factor b/extra/sequences/lib/lib-docs.factor index eb56e35cd5..6f4a173874 100755 --- a/extra/sequences/lib/lib-docs.factor +++ b/extra/sequences/lib/lib-docs.factor @@ -8,7 +8,7 @@ HELP: map-withn "passed to the quotation given to map-withn for each element in the sequence." } { $examples - { $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" } + { $example "USING: math sequences.lib prettyprint ;" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" } } { $see-also each-withn } ; @@ -24,7 +24,7 @@ HELP: sigma { $description "Like map sum, but without creating an intermediate sequence." } { $example "! Find the sum of the squares [0,99]" - "USING: math.ranges combinators.lib ;" + "USING: math math.ranges sequences.lib prettyprint ;" "100 [1,b] [ sq ] sigma ." "338350" } ; @@ -33,7 +33,7 @@ HELP: count { $values { "seq" sequence } { "quot" quotation } { "n" integer } } { $description "Efficiently returns the number of elements that the predicate quotation matches." } { $example - "USING: math.ranges combinators.lib ;" + "USING: math math.ranges sequences.lib prettyprint ;" "100 [1,b] [ even? ] count ." "50" } ; diff --git a/extra/serialize/serialize-docs.factor b/extra/serialize/serialize-docs.factor index 6b2dd304f5..fc060d6b33 100755 --- a/extra/serialize/serialize-docs.factor +++ b/extra/serialize/serialize-docs.factor @@ -8,7 +8,7 @@ HELP: serialize } { $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." } { $examples - { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } + { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } { $see-also deserialize } ; @@ -17,6 +17,6 @@ HELP: deserialize } { $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." } { $examples - { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } + { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } { $see-also serialize } ; diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 36455bd060..f573499695 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -11,7 +11,8 @@ USING: namespaces sequences kernel math io math.functions io.binary strings classes words sbufs tuples arrays vectors byte-arrays bit-arrays quotations hashtables assocs help.syntax help.markup float-arrays splitting -io.encodings.string io.encodings.utf8 combinators ; +io.encodings.string io.encodings.utf8 combinators new-slots +accessors ; ! Variable holding a assoc of objects already serialized SYMBOL: serialized @@ -20,9 +21,9 @@ TUPLE: id obj ; C: id -M: id hashcode* id-obj hashcode* ; +M: id hashcode* obj>> hashcode* ; -M: id equal? over id? [ [ id-obj ] 2apply eq? ] [ 2drop f ] if ; +M: id equal? over id? [ [ obj>> ] 2apply eq? ] [ 2drop f ] if ; : add-object ( obj -- ) #! Add an object to the sequence of already serialized @@ -103,7 +104,7 @@ M: ratio (serialize) ( obj -- ) M: string (serialize) ( obj -- ) [ CHAR: s serialize-string ] serialize-shared ; -: serialize-elements +: serialize-elements ( seq -- ) [ (serialize) ] each CHAR: . write1 ; M: tuple (serialize) ( obj -- ) diff --git a/extra/shuffle/shuffle-docs.factor b/extra/shuffle/shuffle-docs.factor index 8f6ccc410a..4caace3b00 100755 --- a/extra/shuffle/shuffle-docs.factor +++ b/extra/shuffle/shuffle-docs.factor @@ -11,7 +11,7 @@ HELP: npick "placed on the top of the stack." } { $examples - { $example "USE: shuffle" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } } { $see-also dup over pick } ; @@ -23,7 +23,7 @@ HELP: ndup "placed on the top of the stack." } { $examples - { $example "USE: shuffle" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } } { $see-also dup 2dup 3dup } ; @@ -34,7 +34,7 @@ HELP: nnip "for any number of items." } { $examples - { $example "USE: shuffle" "1 2 3 4 3 nnip .s" "4" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 nnip .s" "4" } } { $see-also nip 2nip } ; @@ -45,7 +45,7 @@ HELP: ndrop "for any number of items." } { $examples - { $example "USE: shuffle" "1 2 3 4 3 ndrop .s" "1" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 ndrop .s" "1" } } { $see-also drop 2drop 3drop } ; @@ -55,7 +55,7 @@ HELP: nrot "number of items on the stack. " } { $examples - { $example "USE: shuffle" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } } { $see-also rot -nrot } ; @@ -65,7 +65,7 @@ HELP: -nrot "number of items on the stack. " } { $examples - { $example "USE: shuffle" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } } { $see-also rot nrot } ; diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor index 358d1a5bf6..92ddcc494a 100644 --- a/extra/singleton/singleton-docs.factor +++ b/extra/singleton/singleton-docs.factor @@ -8,7 +8,7 @@ HELP: SINGLETON: } { $description "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton." } { $examples - { $example "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } + { $example "USING: singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } } { $see-also POSTPONE: PREDICATE: } ; @@ -20,7 +20,7 @@ HELP: SINGLETONS: } { $description "Defines a new singleton for each class in the list." } { $examples - { $example "SINGLETONS: foo bar baz ;" "" } + { $example "USE: singleton" "SINGLETONS: foo bar baz ;" "" } } { $see-also POSTPONE: SINGLETON: } ; diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor old mode 100644 new mode 100755 index 1451283f23..0b77443a50 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -5,7 +5,7 @@ sequences words ; IN: singleton : define-singleton ( token -- ) - \ word swap in get create-class + \ word swap create-class-in dup [ eq? ] curry define-predicate-class ; : SINGLETON: diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index 92b605e91c..14957ceca2 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -6,7 +6,7 @@ IN: smtp.server ! Mock SMTP server for testing purposes. -! Usage: 4321 smtp-server +! Usage: 4321 mock-smtp-server ! $ telnet 127.0.0.1 4321 ! Trying 127.0.0.1... ! Connected to localhost. @@ -61,7 +61,7 @@ SYMBOL: data-mode ] } } cond nip [ process ] when ; -: smtp-server ( port -- ) +: mock-smtp-server ( port -- ) "Starting SMTP server on port " write dup . flush "127.0.0.1" swap ascii [ accept [ diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 76ceaceea4..a705a9609e 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,4 +1,4 @@ -USING: smtp tools.test io.streams.string threads +USING: smtp tools.test io.streams.string io.sockets threads smtp.server kernel sequences namespaces logging accessors assocs sorting ; IN: smtp.tests @@ -62,12 +62,11 @@ IN: smtp.tests rot from>> ] unit-test -[ ] [ [ 4321 smtp-server ] in-thread ] unit-test +[ ] [ [ 4321 mock-smtp-server ] in-thread ] unit-test [ ] [ [ - "localhost" smtp-host set - 4321 smtp-port set + "localhost" 4321 smtp-server set "Hi guys\nBye guys" >>body @@ -77,6 +76,6 @@ IN: smtp.tests "Ed " } >>to "Doug " >>from - send + send-email ] with-scope ] unit-test diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index b23d5e3798..a941b14a47 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -8,19 +8,16 @@ calendar.format new-slots accessors ; IN: smtp SYMBOL: smtp-domain -SYMBOL: smtp-host "localhost" smtp-host set-global -SYMBOL: smtp-port 25 smtp-port set-global +SYMBOL: smtp-server "localhost" 25 smtp-server set-global SYMBOL: read-timeout 1 minutes read-timeout set-global SYMBOL: esmtp t esmtp set-global -: log-smtp-connection ( host port -- ) 2drop ; - -\ log-smtp-connection NOTICE add-input-logging +LOG: log-smtp-connection NOTICE ( addrspec -- ) : with-smtp-connection ( quot -- ) - smtp-host get smtp-port get - 2dup log-smtp-connection - ascii [ + smtp-server get + dup log-smtp-connection + ascii [ smtp-domain [ host-name or ] change read-timeout get stdio get set-timeout call @@ -33,8 +30,8 @@ SYMBOL: esmtp t esmtp set-global : validate-address ( string -- string' ) #! Make sure we send funky stuff to the server by accident. - dup [ "\r\n>" member? ] contains? - [ "Bad e-mail address: " swap append throw ] when ; + dup "\r\n>" seq-intersect empty? + [ "Bad e-mail address: " swap append throw ] unless ; : mail-from ( fromaddr -- ) "MAIL FROM:<" write validate-address write ">" write crlf ; @@ -91,8 +88,8 @@ LOG: smtp-response DEBUG : get-ok ( -- ) flush receive-response check-response ; : validate-header ( string -- string' ) - dup [ "\r\n" member? ] contains? - [ "Invalid header string: " swap append throw ] when ; + dup "\r\n" seq-intersect empty? + [ "Invalid header string: " swap append throw ] unless ; : write-header ( key value -- ) swap @@ -153,7 +150,7 @@ M: email clone email construct-empty H{ } clone >>headers ; -: send ( email -- ) +: send-email ( email -- ) prepare (send) ; ! Dirk's old AUTH CRAM-MD5 code. I don't know anything about diff --git a/extra/symbols/symbols-docs.factor b/extra/symbols/symbols-docs.factor index c6886ce31a..f542948970 100644 --- a/extra/symbols/symbols-docs.factor +++ b/extra/symbols/symbols-docs.factor @@ -5,5 +5,5 @@ HELP: SYMBOLS: { $syntax "SYMBOLS: words... ;" } { $values { "words" "a sequence of new words to define" } } { $description "Creates a new word for every token until the ';'." } -{ $examples { $example "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } +{ $examples { $example "USING: prettyprint symbols ;" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } { $see-also POSTPONE: SYMBOL: } ; diff --git a/extra/tools/browser/browser-tests.factor b/extra/tools/browser/browser-tests.factor deleted file mode 100755 index 38d9ae65e2..0000000000 --- a/extra/tools/browser/browser-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: tools.browser.tests -USING: tools.browser tools.test help.markup ; - -[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor deleted file mode 100755 index c189a6f9de..0000000000 --- a/extra/tools/browser/browser.factor +++ /dev/null @@ -1,364 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces splitting sequences io.files kernel assocs -words vocabs vocabs.loader definitions parser continuations -inspector debugger io io.styles hashtables -sorting prettyprint source-files arrays combinators strings -system math.parser help.markup help.topics help.syntax -help.stylesheet memoize io.encodings.utf8 ; -IN: tools.browser - -MEMO: (vocab-file-contents) ( path -- lines ) - ?resource-path dup exists? - [ utf8 file-lines ] [ drop f ] if ; - -: vocab-file-contents ( vocab name -- seq ) - vocab-path+ dup [ (vocab-file-contents) ] when ; - -: set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-path+ [ - ?resource-path utf8 set-file-lines - ] [ - "The " swap vocab-name - " vocabulary was not loaded from the file system" - 3append throw - ] ?if ; - -: vocab-summary-path ( vocab -- string ) - vocab-dir "summary.txt" path+ ; - -: vocab-summary ( vocab -- summary ) - dup dup vocab-summary-path vocab-file-contents - dup empty? [ - drop vocab-name " vocabulary" append - ] [ - nip first - ] if ; - -M: vocab summary - [ - dup vocab-summary % - " (" % - vocab-words assoc-size # - " words)" % - ] "" make ; - -M: vocab-link summary vocab-summary ; - -: set-vocab-summary ( string vocab -- ) - >r 1array r> - dup vocab-summary-path - set-vocab-file-contents ; - -: vocab-tags-path ( vocab -- string ) - vocab-dir "tags.txt" path+ ; - -: vocab-tags ( vocab -- tags ) - dup vocab-tags-path vocab-file-contents ; - -: set-vocab-tags ( tags vocab -- ) - dup vocab-tags-path set-vocab-file-contents ; - -: add-vocab-tags ( tags vocab -- ) - [ vocab-tags append prune ] keep set-vocab-tags ; - -: vocab-authors-path ( vocab -- string ) - vocab-dir "authors.txt" path+ ; - -: vocab-authors ( vocab -- authors ) - dup vocab-authors-path vocab-file-contents ; - -: set-vocab-authors ( authors vocab -- ) - dup vocab-authors-path set-vocab-file-contents ; - -: subdirs ( dir -- dirs ) - directory [ second ] subset keys natural-sort ; - -: (all-child-vocabs) ( root name -- vocabs ) - [ vocab-dir path+ ?resource-path subdirs ] keep - dup empty? [ - drop - ] [ - swap [ "." swap 3append ] with map - ] if ; - -: vocabs-in-dir ( root name -- ) - dupd (all-child-vocabs) [ - 2dup vocab-dir? [ 2dup swap >vocab-link , ] when - vocabs-in-dir - ] with each ; - -: all-vocabs ( -- assoc ) - vocab-roots get [ - dup [ "" vocabs-in-dir ] { } make - ] { } map>assoc ; - -MEMO: all-vocabs-seq ( -- seq ) - all-vocabs values concat ; - -: dangerous? ( name -- ? ) - #! Hack - { - { [ "cpu." ?head ] [ t ] } - { [ "io.unix" ?head ] [ t ] } - { [ "io.windows" ?head ] [ t ] } - { [ "ui.x11" ?head ] [ t ] } - { [ "ui.windows" ?head ] [ t ] } - { [ "ui.cocoa" ?head ] [ t ] } - { [ "cocoa" ?head ] [ t ] } - { [ "core-foundation" ?head ] [ t ] } - { [ "vocabs.loader.test" ?head ] [ t ] } - { [ "editors." ?head ] [ t ] } - { [ ".windows" ?tail ] [ t ] } - { [ ".unix" ?tail ] [ t ] } - { [ "unix." ?head ] [ t ] } - { [ ".linux" ?tail ] [ t ] } - { [ ".bsd" ?tail ] [ t ] } - { [ ".macosx" ?tail ] [ t ] } - { [ "windows." ?head ] [ t ] } - { [ "cocoa" ?head ] [ t ] } - { [ ".test" ?tail ] [ t ] } - { [ "raptor" ?head ] [ t ] } - { [ dup "tools.deploy.app" = ] [ t ] } - { [ t ] [ f ] } - } cond nip ; - -: filter-dangerous ( seq -- seq' ) - [ vocab-name dangerous? not ] subset ; - -: try-everything ( -- failures ) - all-vocabs-seq - filter-dangerous - require-all ; - -: load-everything ( -- ) - try-everything load-failures. ; - -: unrooted-child-vocabs ( prefix -- seq ) - dup empty? [ CHAR: . add ] unless - vocabs - [ vocab-root not ] subset - [ - vocab-name swap ?head CHAR: . rot member? not and - ] with subset - [ vocab ] map ; - -: all-child-vocabs ( prefix -- assoc ) - vocab-roots get [ - over dupd dupd (all-child-vocabs) - swap [ >vocab-link ] curry map - ] { } map>assoc - f rot unrooted-child-vocabs 2array add ; - -: load-children ( prefix -- ) - all-child-vocabs values concat - filter-dangerous - require-all - load-failures. ; - -: vocab-status-string ( vocab -- string ) - { - { [ dup not ] [ drop "" ] } - { [ dup vocab-main ] [ drop "[Runnable]" ] } - { [ t ] [ drop "[Loaded]" ] } - } cond ; - -: write-status ( vocab -- ) - vocab vocab-status-string write ; - -: vocab. ( vocab -- ) - [ - dup [ write-status ] with-cell - dup [ ($link) ] with-cell - [ vocab-summary write ] with-cell - ] with-row ; - -: vocab-headings. ( -- ) - [ - [ "State" write ] with-cell - [ "Vocabulary" write ] with-cell - [ "Summary" write ] with-cell - ] with-row ; - -: root-heading. ( root -- ) - [ "Children from " swap append ] [ "Children" ] if* - $heading ; - -: vocabs. ( assoc -- ) - [ - dup empty? [ - 2drop - ] [ - swap root-heading. - standard-table-style [ - vocab-headings. [ vocab. ] each - ] ($grid) - ] if - ] assoc-each ; - -: describe-summary ( vocab -- ) - vocab-summary [ - "Summary" $heading print-element - ] when* ; - -TUPLE: vocab-tag name ; - -C: vocab-tag - -: tags. ( seq -- ) [ ] map $links ; - -: describe-tags ( vocab -- ) - vocab-tags f like [ - "Tags" $heading tags. - ] when* ; - -TUPLE: vocab-author name ; - -C: vocab-author - -: authors. ( seq -- ) [ ] map $links ; - -: describe-authors ( vocab -- ) - vocab-authors f like [ - "Authors" $heading authors. - ] when* ; - -: describe-help ( vocab -- ) - vocab-help [ - "Documentation" $heading nl ($link) - ] when* ; - -: describe-children ( vocab -- ) - vocab-name all-child-vocabs vocabs. ; - -: describe-files ( vocab -- ) - vocab-files [ ] map [ - "Files" $heading - [ - snippet-style get [ - code-style get [ - stack. - ] with-nesting - ] with-style - ] ($block) - ] when* ; - -: describe-words ( vocab -- ) - words dup empty? [ - "Words" $heading - dup natural-sort $links - ] unless drop ; - -: map>set ( seq quot -- ) - map concat prune natural-sort ; inline - -: vocab-xref ( vocab quot -- vocabs ) - >r dup vocab-name swap words r> map - [ [ word? ] subset [ word-vocabulary ] map ] map>set - remove [ ] subset [ vocab ] map ; inline - -: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; - -: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; - -: describe-uses ( vocab -- ) - vocab-uses dup empty? [ - "Uses" $heading - dup $links - ] unless drop ; - -: describe-usage ( vocab -- ) - vocab-usage dup empty? [ - "Used by" $heading - dup $links - ] unless drop ; - -: $describe-vocab ( element -- ) - first - dup describe-children - dup vocab-root over vocab-dir? [ - dup describe-summary - dup describe-tags - dup describe-authors - dup describe-files - ] when - dup vocab [ - dup describe-help - dup describe-words - dup describe-uses - dup describe-usage - ] when drop ; - -: keyed-vocabs ( str quot -- seq ) - all-vocabs [ - swap >r - [ >r 2dup r> swap call member? ] subset - r> swap - ] assoc-map 2nip ; inline - -: tagged ( tag -- assoc ) - [ vocab-tags ] keyed-vocabs ; - -: authored ( author -- assoc ) - [ vocab-authors ] keyed-vocabs ; - -: $tagged-vocabs ( element -- ) - first tagged vocabs. ; - -MEMO: all-tags ( -- seq ) - all-vocabs-seq [ vocab-tags ] map>set ; - -: $authored-vocabs ( element -- ) - first authored vocabs. ; - -MEMO: all-authors ( -- seq ) - all-vocabs-seq [ vocab-authors ] map>set ; - -: $tags ( element -- ) - drop "Tags" $heading all-tags tags. ; - -: $authors ( element -- ) - drop "Authors" $heading all-authors authors. ; - -M: vocab-spec article-title vocab-name " vocabulary" append ; - -M: vocab-spec article-name vocab-name ; - -M: vocab-spec article-content - vocab-name \ $describe-vocab swap 2array ; - -M: vocab-spec article-parent drop "vocab-index" ; - -M: vocab-tag >link ; - -M: vocab-tag article-title - vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ; - -M: vocab-tag article-name vocab-tag-name ; - -M: vocab-tag article-content - \ $tagged-vocabs swap vocab-tag-name 2array ; - -M: vocab-tag article-parent drop "vocab-index" ; - -M: vocab-tag summary article-title ; - -M: vocab-author >link ; - -M: vocab-author article-title - vocab-author-name "Vocabularies by " swap append ; - -M: vocab-author article-name vocab-author-name ; - -M: vocab-author article-content - \ $authored-vocabs swap vocab-author-name 2array ; - -M: vocab-author article-parent drop "vocab-index" ; - -M: vocab-author summary article-title ; - -: reset-cache ( -- ) - \ (vocab-file-contents) reset-memoized - \ all-vocabs-seq reset-memoized - \ all-authors reset-memoized - \ all-tags reset-memoized ; diff --git a/extra/tools/completion/completion-docs.factor b/extra/tools/completion/completion-docs.factor index 7683ef1ca1..4d7154fb2d 100644 --- a/extra/tools/completion/completion-docs.factor +++ b/extra/tools/completion/completion-docs.factor @@ -24,7 +24,7 @@ HELP: runs { $values { "seq" "a sequence of integers" } { "newseq" "a sequence of sequences of integers" } } { $description "Groups subsequences of consecutive integers." } { $examples - { $example "USE: tools.completion" "{ 1 2 3 5 6 9 10 } runs ." "V{ V{ 1 2 3 } V{ 5 6 } V{ 9 10 } }" } + { $example "USING: prettyprint tools.completion ;" "{ 1 2 3 5 6 9 10 } runs ." "V{ V{ 1 2 3 } V{ 5 6 } V{ 9 10 } }" } } ; HELP: score diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 301ffa3378..15dc32115e 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -34,31 +34,33 @@ IN: tools.deploy.backend : ?, [ , ] [ drop ] if ; -: bootstrap-profile ( config -- profile ) +: bootstrap-profile ( -- profile ) [ - [ - "math" deploy-math? get ?, - "compiler" deploy-compiler? get ?, - "ui" deploy-ui? get ?, - "io" native-io? ?, - ] { } make - ] bind ; + "math" deploy-math? get ?, + "compiler" deploy-compiler? get ?, + "ui" deploy-ui? get ?, + "io" native-io? ?, + ] { } make ; -: staging-image-name ( profile -- name ) - "staging." swap bootstrap-profile "-" join ".image" 3append ; +: staging-image-name ( -- name ) + "staging." + bootstrap-profile strip-word-names? [ "strip" add ] when + "-" join ".image" 3append ; : staging-command-line ( config -- flags ) [ - "-i=" my-boot-image-name append , + [ + "-i=" my-boot-image-name append , - "-output-image=" over staging-image-name append , + "-output-image=" staging-image-name append , - "-include=" swap bootstrap-profile " " join append , + "-include=" bootstrap-profile " " join append , - "-no-stack-traces" , + strip-word-names? [ "-no-stack-traces" , ] when - "-no-user-init" , - ] { } make ; + "-no-user-init" , + ] { } make + ] bind ; : run-factor ( vm flags -- ) swap add* dup . run-with-output ; inline @@ -68,16 +70,18 @@ IN: tools.deploy.backend : deploy-command-line ( image vocab config -- flags ) [ - "-i=" swap staging-image-name append , + [ + "-i=" staging-image-name append , - "-run=tools.deploy.shaker" , + "-run=tools.deploy.shaker" , - "-deploy-vocab=" swap append , + "-deploy-vocab=" swap append , - "-output-image=" swap append , + "-output-image=" swap append , - "-no-stack-traces" , - ] { } make ; + strip-word-names? [ "-no-stack-traces" , ] when + ] { } make + ] bind ; : make-deploy-image ( vm image vocab config -- ) make-boot-image diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 64f863b730..78f1d487de 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: vocabs.loader io.files io kernel sequences assocs splitting parser prettyprint namespaces math vocabs -hashtables tools.browser ; +hashtables tools.vocabs ; IN: tools.deploy.config SYMBOL: deploy-name diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index d473d8f640..c68c259a6e 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,11 +1,11 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config -tools.deploy.backend math ; +tools.deploy.backend math sequences io.launcher ; : shake-and-bake "." resource-path [ vm - "hello.image" temp-file + "test.image" temp-file rot dup deploy-config make-deploy-image ] with-directory ; @@ -15,8 +15,30 @@ tools.deploy.backend math ; "hello.image" temp-file file-length 500000 <= ] unit-test +[ ] [ "sudoku" shake-and-bake ] unit-test + +[ t ] [ + "hello.image" temp-file file-length 1500000 <= +] unit-test + [ ] [ "hello-ui" shake-and-bake ] unit-test [ t ] [ "hello.image" temp-file file-length 2000000 <= ] unit-test + +[ ] [ "bunny" shake-and-bake ] unit-test + +[ t ] [ + "hello.image" temp-file file-length 3000000 <= +] unit-test + +[ ] [ + "tools.deploy.test.1" shake-and-bake + vm "-i=" "test.image" temp-file append try-process +] unit-test + +[ ] [ + "tools.deploy.test.2" shake-and-bake + vm "-i=" "test.image" temp-file append try-process +] unit-test diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 0ddc2d5707..bddf3d76c9 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -1,11 +1,29 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces continuations.private kernel.private init -assocs kernel vocabs words sequences memory io system arrays -continuations math definitions mirrors splitting parser classes -inspector layouts vocabs.loader prettyprint.config prettyprint -debugger io.streams.c io.streams.duplex io.files io.backend -quotations words.private tools.deploy.config compiler.units ; +USING: qualified io.streams.c init fry namespaces assocs kernel +parser tools.deploy.config vocabs sequences words words.private +memory kernel.private continuations io prettyprint +vocabs.loader debugger system strings ; +QUALIFIED: bootstrap.stage2 +QUALIFIED: classes +QUALIFIED: compiler.errors.private +QUALIFIED: compiler.units +QUALIFIED: continuations +QUALIFIED: definitions +QUALIFIED: init +QUALIFIED: inspector +QUALIFIED: io.backend +QUALIFIED: io.nonblocking +QUALIFIED: io.thread +QUALIFIED: layouts +QUALIFIED: libc.private +QUALIFIED: libc.private +QUALIFIED: listener +QUALIFIED: prettyprint.config +QUALIFIED: random.private +QUALIFIED: source-files +QUALIFIED: threads +QUALIFIED: vocabs IN: tools.deploy.shaker : strip-init-hooks ( -- ) @@ -43,9 +61,6 @@ IN: tools.deploy.shaker run-file ] when ; -: strip-assoc ( retained-keys assoc -- newassoc ) - swap [ nip member? ] curry assoc-subset ; - : strip-word-names ( words -- ) "Stripping word names" show [ f over set-word-name f swap set-word-vocabulary ] each ; @@ -57,8 +72,11 @@ IN: tools.deploy.shaker : strip-word-props ( retain-props words -- ) "Stripping word properties" show [ - [ word-props strip-assoc f assoc-like ] keep - set-word-props + [ + word-props swap + '[ , nip member? ] assoc-subset + f assoc-like + ] keep set-word-props ] with each ; : retained-props ( -- seq ) @@ -81,10 +99,101 @@ IN: tools.deploy.shaker strip-word-names? [ dup strip-word-names ] when 2drop ; -: strip-environment ( retain-globals -- ) +: strip-recompile-hook ( -- ) + [ [ f ] { } map>assoc ] + compiler.units:recompile-hook + set-global ; + +: strip-vocab-globals ( except names -- words ) + [ child-vocabs [ words ] map concat ] map concat seq-diff ; + +: stripped-globals ( -- seq ) + [ + random.private:mt , + + { + bootstrap.stage2:bootstrap-time + continuations:error + continuations:error-continuation + continuations:error-thread + continuations:restarts + error-hook + init:init-hooks + inspector:inspector-hook + io.thread:io-thread + libc.private:mallocs + source-files:source-files + stderr + stdio + } % + + deploy-threads? [ + threads:initial-thread , + ] unless + + strip-io? [ io.backend:io-backend , ] when + + { io.backend:io-backend io.nonblocking:default-buffer-size } + { "alarms" "io" "tools" } strip-vocab-globals % + + strip-dictionary? [ + { } { "cpu" } strip-vocab-globals % + + { + vocabs:dictionary + lexer-factory + vocabs:load-vocab-hook + layouts:num-tags + layouts:num-types + layouts:tag-mask + layouts:tag-numbers + layouts:type-numbers + classes:typemap + vocab-roots + definitions:crossref + compiled-crossref + interactive-vocabs + word + compiler.units:recompile-hook + listener:listener-hook + lexer-factory + classes:update-map + classes:classr word-vocabulary r> member? ] curry - subset % - ] when - ] { } make dup . ; - -: strip-recompile-hook ( -- ) - [ [ f ] { } map>assoc ] recompile-hook set-global ; - : strip ( -- ) strip-libc strip-cocoa @@ -165,7 +225,7 @@ SYMBOL: deploy-vocab strip-init-hooks deploy-vocab get vocab-main set-boot-quot* retained-props >r - retained-globals strip-environment + stripped-globals strip-globals r> strip-words ; : (deploy) ( final-image vocab config -- ) diff --git a/extra/tools/deploy/test/1/1.factor b/extra/tools/deploy/test/1/1.factor new file mode 100755 index 0000000000..0bf8b10d0c --- /dev/null +++ b/extra/tools/deploy/test/1/1.factor @@ -0,0 +1,6 @@ +IN: tools.deploy.test.1 +USING: threads ; + +: deploy-test-1 1000 sleep ; + +MAIN: deploy-test-1 diff --git a/extra/tools/deploy/test/1/deploy.factor b/extra/tools/deploy/test/1/deploy.factor new file mode 100755 index 0000000000..f06bcbc0f0 --- /dev/null +++ b/extra/tools/deploy/test/1/deploy.factor @@ -0,0 +1,14 @@ +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-io 2 } + { deploy-reflection 1 } + { deploy-threads? t } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-name "tools.deploy.test.1" } + { deploy-math? t } + { deploy-compiler? t } + { "stop-after-last-window?" t } + { deploy-ui? f } +} diff --git a/extra/tools/deploy/test/2/2.factor b/extra/tools/deploy/test/2/2.factor new file mode 100755 index 0000000000..e029e3050a --- /dev/null +++ b/extra/tools/deploy/test/2/2.factor @@ -0,0 +1,6 @@ +IN: tools.deploy.test.2 +USING: calendar calendar.format ; + +: deploy-test-2 now (timestamp>string) ; + +MAIN: deploy-test-2 diff --git a/extra/tools/deploy/test/2/deploy.factor b/extra/tools/deploy/test/2/deploy.factor new file mode 100755 index 0000000000..bd087d65bf --- /dev/null +++ b/extra/tools/deploy/test/2/deploy.factor @@ -0,0 +1,14 @@ +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-io 2 } + { deploy-reflection 1 } + { deploy-threads? t } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-name "tools.deploy.test.2" } + { deploy-math? t } + { deploy-compiler? t } + { "stop-after-last-window?" t } + { deploy-ui? f } +} diff --git a/extra/tools/deploy/test/3/3.factor b/extra/tools/deploy/test/3/3.factor new file mode 100755 index 0000000000..443e82f7d9 --- /dev/null +++ b/extra/tools/deploy/test/3/3.factor @@ -0,0 +1,8 @@ +IN: tools.deploy.test.3 +USING: io.encodings.ascii io.files kernel ; + +: deploy-test-3 + "resource:extra/tools/deploy/test/3/3.factor" + ?resource-path ascii file-contents drop ; + +MAIN: deploy-test-3 diff --git a/extra/tools/deploy/test/3/deploy.factor b/extra/tools/deploy/test/3/deploy.factor new file mode 100755 index 0000000000..b8b8bf4aa2 --- /dev/null +++ b/extra/tools/deploy/test/3/deploy.factor @@ -0,0 +1,14 @@ +USING: tools.deploy.config ; +H{ + { deploy-math? t } + { deploy-reflection 1 } + { deploy-name "tools.deploy.test.3" } + { deploy-threads? t } + { deploy-word-props? f } + { "stop-after-last-window?" t } + { deploy-ui? f } + { deploy-io 3 } + { deploy-compiler? t } + { deploy-word-defs? f } + { deploy-c-types? f } +} diff --git a/extra/tools/disassembler/disassembler-tests.factor b/extra/tools/disassembler/disassembler-tests.factor new file mode 100755 index 0000000000..9983db7d00 --- /dev/null +++ b/extra/tools/disassembler/disassembler-tests.factor @@ -0,0 +1,6 @@ +IN: tools.disassembler.tests +USING: math tuples prettyprint.backend tools.disassembler +tools.test strings ; + +[ ] [ \ + disassemble ] unit-test +[ ] [ { string pprint* } disassemble ] unit-test diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 1e003dcf69..479ae9c42c 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified -system math generator.fixup io.encodings.ascii accessors ; +system math generator.fixup io.encodings.ascii accessors +generic ; IN: tools.disassembler : in-file "gdb-in.txt" temp-file ; @@ -22,6 +23,9 @@ M: pair make-disassemble-cmd [ number>string write bl ] each ] with-file-writer ; +M: method-spec make-disassemble-cmd + first2 method make-disassemble-cmd ; + : run-gdb ( -- lines ) +closed+ >>stdin @@ -33,6 +37,6 @@ M: pair make-disassemble-cmd : tabs>spaces ( str -- str' ) { { CHAR: \t CHAR: \s } } substitute ; -: disassemble ( word -- ) +: disassemble ( obj -- ) make-disassemble-cmd run-gdb [ tabs>spaces ] map [ print ] each ; diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index 743822e7f9..a605543bda 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -89,6 +89,6 @@ HELP: run-all-tests { $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } { $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; -HELP: failure. -{ $values { "failures" "an association list of unit test failures" } } +HELP: test-failures. +{ $values { "assoc" "an association list of unit test failures" } } { $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to the " { $link stdio } " stream." } ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 259b91c3af..031b3c3af8 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -4,7 +4,7 @@ USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.files vocabs tools.time vocabs.loader source-files compiler.units inspector -inference effects ; +inference effects tools.vocabs ; IN: tools.test SYMBOL: failures diff --git a/extra/tools/browser/authors.txt b/extra/tools/vocabs/browser/authors.txt similarity index 100% rename from extra/tools/browser/authors.txt rename to extra/tools/vocabs/browser/authors.txt diff --git a/extra/tools/vocabs/browser/browser-docs.factor b/extra/tools/vocabs/browser/browser-docs.factor new file mode 100755 index 0000000000..3765efb863 --- /dev/null +++ b/extra/tools/vocabs/browser/browser-docs.factor @@ -0,0 +1,7 @@ +USING: help.markup help.syntax io strings ; +IN: tools.vocabs.browser + +ARTICLE: "vocab-index" "Vocabulary index" +{ $tags } +{ $authors } +{ $describe-vocab "" } ; diff --git a/extra/tools/vocabs/browser/browser-tests.factor b/extra/tools/vocabs/browser/browser-tests.factor new file mode 100755 index 0000000000..7e12a56cf2 --- /dev/null +++ b/extra/tools/vocabs/browser/browser-tests.factor @@ -0,0 +1,4 @@ +IN: tools.vocabs.browser.tests +USING: tools.vocabs.browser tools.test help.markup ; + +[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor new file mode 100755 index 0000000000..2c66305d47 --- /dev/null +++ b/extra/tools/vocabs/browser/browser.factor @@ -0,0 +1,207 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel combinators vocabs vocabs.loader tools.vocabs io +io.files io.styles help.markup help.stylesheet sequences assocs +help.topics namespaces prettyprint words sorting definitions +arrays inspector ; +IN: tools.vocabs.browser + +: vocab-status-string ( vocab -- string ) + { + { [ dup not ] [ drop "" ] } + { [ dup vocab-main ] [ drop "[Runnable]" ] } + { [ t ] [ drop "[Loaded]" ] } + } cond ; + +: write-status ( vocab -- ) + vocab vocab-status-string write ; + +: vocab. ( vocab -- ) + [ + dup [ write-status ] with-cell + dup [ ($link) ] with-cell + [ vocab-summary write ] with-cell + ] with-row ; + +: vocab-headings. ( -- ) + [ + [ "State" write ] with-cell + [ "Vocabulary" write ] with-cell + [ "Summary" write ] with-cell + ] with-row ; + +: root-heading. ( root -- ) + [ "Children from " swap append ] [ "Children" ] if* + $heading ; + +: vocabs. ( assoc -- ) + [ + dup empty? [ + 2drop + ] [ + swap root-heading. + standard-table-style [ + vocab-headings. [ vocab. ] each + ] ($grid) + ] if + ] assoc-each ; + +: describe-summary ( vocab -- ) + vocab-summary [ + "Summary" $heading print-element + ] when* ; + +TUPLE: vocab-tag name ; + +INSTANCE: vocab-tag topic + +C: vocab-tag + +: tags. ( seq -- ) [ ] map $links ; + +: describe-tags ( vocab -- ) + vocab-tags f like [ + "Tags" $heading tags. + ] when* ; + +TUPLE: vocab-author name ; + +INSTANCE: vocab-author topic + +C: vocab-author + +: authors. ( seq -- ) [ ] map $links ; + +: describe-authors ( vocab -- ) + vocab-authors f like [ + "Authors" $heading authors. + ] when* ; + +: describe-help ( vocab -- ) + vocab-help [ + "Documentation" $heading nl ($link) + ] when* ; + +: describe-children ( vocab -- ) + vocab-name all-child-vocabs vocabs. ; + +: describe-files ( vocab -- ) + vocab-files [ ] map [ + "Files" $heading + [ + snippet-style get [ + code-style get [ + stack. + ] with-nesting + ] with-style + ] ($block) + ] when* ; + +: describe-words ( vocab -- ) + words dup empty? [ + "Words" $heading + dup natural-sort $links + ] unless drop ; + +: vocab-xref ( vocab quot -- vocabs ) + >r dup vocab-name swap words r> map + [ [ word? ] subset [ word-vocabulary ] map ] map>set + remove [ ] subset [ vocab ] map ; inline + +: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; + +: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; + +: describe-uses ( vocab -- ) + vocab-uses dup empty? [ + "Uses" $heading + dup $links + ] unless drop ; + +: describe-usage ( vocab -- ) + vocab-usage dup empty? [ + "Used by" $heading + dup $links + ] unless drop ; + +: $describe-vocab ( element -- ) + first + dup describe-children + dup vocab-root over vocab-dir? [ + dup describe-summary + dup describe-tags + dup describe-authors + dup describe-files + ] when + dup vocab [ + dup describe-help + dup describe-words + dup describe-uses + dup describe-usage + ] when drop ; + +: keyed-vocabs ( str quot -- seq ) + all-vocabs [ + swap >r + [ >r 2dup r> swap call member? ] subset + r> swap + ] assoc-map 2nip ; inline + +: tagged ( tag -- assoc ) + [ vocab-tags ] keyed-vocabs ; + +: authored ( author -- assoc ) + [ vocab-authors ] keyed-vocabs ; + +: $tagged-vocabs ( element -- ) + first tagged vocabs. ; + +: $authored-vocabs ( element -- ) + first authored vocabs. ; + +: $tags ( element -- ) + drop "Tags" $heading all-tags tags. ; + +: $authors ( element -- ) + drop "Authors" $heading all-authors authors. ; + +INSTANCE: vocab topic + +INSTANCE: vocab-link topic + +M: vocab-spec article-title vocab-name " vocabulary" append ; + +M: vocab-spec article-name vocab-name ; + +M: vocab-spec article-content + vocab-name \ $describe-vocab swap 2array ; + +M: vocab-spec article-parent drop "vocab-index" ; + +M: vocab-tag >link ; + +M: vocab-tag article-title + vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ; + +M: vocab-tag article-name vocab-tag-name ; + +M: vocab-tag article-content + \ $tagged-vocabs swap vocab-tag-name 2array ; + +M: vocab-tag article-parent drop "vocab-index" ; + +M: vocab-tag summary article-title ; + +M: vocab-author >link ; + +M: vocab-author article-title + vocab-author-name "Vocabularies by " swap append ; + +M: vocab-author article-name vocab-author-name ; + +M: vocab-author article-content + \ $authored-vocabs swap vocab-author-name 2array ; + +M: vocab-author article-parent drop "vocab-index" ; + +M: vocab-author summary article-title ; diff --git a/extra/tools/browser/tags.txt b/extra/tools/vocabs/browser/tags.txt similarity index 100% rename from extra/tools/browser/tags.txt rename to extra/tools/vocabs/browser/tags.txt diff --git a/extra/vocabs/monitor/authors.txt b/extra/tools/vocabs/monitor/authors.txt similarity index 100% rename from extra/vocabs/monitor/authors.txt rename to extra/tools/vocabs/monitor/authors.txt diff --git a/extra/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor similarity index 79% rename from extra/vocabs/monitor/monitor.factor rename to extra/tools/vocabs/monitor/monitor.factor index 78e2339764..071f179676 100755 --- a/extra/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel -tools.browser namespaces continuations vocabs.loader ; -IN: vocabs.monitor +vocabs.loader tools.vocabs namespaces continuations ; +IN: tools.vocabs.monitor ! Use file system change monitoring to flush the tags/authors ! cache @@ -21,4 +21,4 @@ SYMBOL: vocab-monitor [ monitor-thread t ] "Vocabulary monitor" spawn-server drop ] ignore-errors ; -[ start-monitor-thread ] "vocabs.monitor" add-init-hook +[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook diff --git a/extra/vocabs/monitor/summary.txt b/extra/tools/vocabs/monitor/summary.txt similarity index 100% rename from extra/vocabs/monitor/summary.txt rename to extra/tools/vocabs/monitor/summary.txt diff --git a/extra/tools/browser/browser-docs.factor b/extra/tools/vocabs/vocabs-docs.factor similarity index 59% rename from extra/tools/browser/browser-docs.factor rename to extra/tools/vocabs/vocabs-docs.factor index 28bef58a8a..33f197d0ea 100755 --- a/extra/tools/browser/browser-docs.factor +++ b/extra/tools/vocabs/vocabs-docs.factor @@ -1,52 +1,75 @@ -USING: help.markup help.syntax io strings ; -IN: tools.browser - -ARTICLE: "vocab-index" "Vocabulary index" -{ $tags } -{ $authors } -{ $describe-vocab "" } ; - -ARTICLE: "tools.browser" "Vocabulary browser" -"Getting and setting vocabulary meta-data:" -{ $subsection vocab-file-contents } -{ $subsection set-vocab-file-contents } -{ $subsection vocab-summary } -{ $subsection set-vocab-summary } -{ $subsection vocab-tags } -{ $subsection set-vocab-tags } -{ $subsection add-vocab-tags } -"Global meta-data:" -{ $subsection all-vocabs } -{ $subsection all-vocabs-seq } -{ $subsection all-tags } -{ $subsection all-authors } -"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" -{ $subsection reset-cache } ; - -HELP: vocab-file-contents -{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } -{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-file-contents -{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } -{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; - -HELP: vocab-summary -{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } -{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-summary -{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; - -HELP: vocab-tags -{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } -{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-tags -{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; - -HELP: all-vocabs -{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } -{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; +USING: help.markup help.syntax strings ; +IN: tools.vocabs + +ARTICLE: "tools.vocabs" "Vocabulary tools" +"Reloading source files changed on disk:" +{ $subsection refresh } +{ $subsection refresh-all } +"Vocabulary summaries:" +{ $subsection vocab-summary } +{ $subsection set-vocab-summary } +"Vocabulary tags:" +{ $subsection vocab-tags } +{ $subsection set-vocab-tags } +{ $subsection add-vocab-tags } +"Getting and setting vocabulary meta-data:" +{ $subsection vocab-file-contents } +{ $subsection set-vocab-file-contents } +"Global meta-data:" +{ $subsection all-vocabs } +{ $subsection all-vocabs-seq } +{ $subsection all-tags } +{ $subsection all-authors } +"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" +{ $subsection reset-cache } ; + +ABOUT: "tools.vocabs" + +HELP: vocab-files +{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; + +HELP: vocab-tests +{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; + +HELP: source-modified? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ; + +HELP: refresh +{ $values { "prefix" string } } +{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; + +HELP: refresh-all +{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; + +{ refresh refresh-all } related-words + +HELP: vocab-file-contents +{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } +{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-file-contents +{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } +{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; + +HELP: vocab-summary +{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } +{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-summary +{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; + +HELP: vocab-tags +{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } +{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-tags +{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; + +HELP: all-vocabs +{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } +{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor new file mode 100755 index 0000000000..675a2e1d6e --- /dev/null +++ b/extra/tools/vocabs/vocabs.factor @@ -0,0 +1,268 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +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 ; +IN: tools.vocabs + +: vocab-tests-file, ( vocab -- ) + dup "-tests.factor" vocab-dir+ vocab-path+ + dup resource-exists? [ , ] [ drop ] if ; + +: vocab-tests-dir, ( vocab -- ) + dup vocab-dir "tests" path+ vocab-path+ + dup resource-exists? [ + dup ?resource-path directory keys + [ ".factor" tail? ] subset + [ path+ , ] with each + ] [ drop ] if ; + +: vocab-tests ( vocab -- tests ) + dup vocab-root [ + [ + f >vocab-link dup + vocab-tests-file, + vocab-tests-dir, + ] { } make + ] [ drop f ] if ; + +: vocab-files ( vocab -- seq ) + f >vocab-link [ + dup vocab-source-path [ , ] when* + dup vocab-docs-path [ , ] when* + vocab-tests % + ] { } make ; + +: source-modified? ( path -- ? ) + dup source-files get at [ + dup source-file-path ?resource-path utf8 file-lines lines-crc32 + swap source-file-checksum = not + ] [ + resource-exists? + ] ?if ; + +: modified ( seq quot -- seq ) + [ dup ] swap compose { } map>assoc + [ nip ] assoc-subset + [ nip source-modified? ] assoc-subset keys ; inline + +: modified-sources ( vocabs -- seq ) + [ vocab-source-path ] modified ; + +: modified-docs ( vocabs -- seq ) + [ vocab-docs-path ] modified ; + +: update-roots ( vocabs -- ) + [ dup find-vocab-root swap vocab set-vocab-root ] each ; + +: to-refresh ( prefix -- modified-sources modified-docs ) + child-vocabs + dup update-roots + dup modified-sources swap modified-docs ; + +: vocab-heading. ( vocab -- ) + nl + "==== " write + dup vocab-name swap vocab write-object ":" print + nl ; + +: load-error. ( triple -- ) + dup first vocab-heading. + dup second print-error + drop ; + +: load-failures. ( failures -- ) + [ load-error. nl ] each ; + +SYMBOL: failures + +: require-all ( vocabs -- failures ) + [ + V{ } clone blacklist set + V{ } clone failures set + [ + [ require ] + [ swap vocab-name failures get set-at ] + recover + ] each + failures get + ] with-compiler-errors ; + +: do-refresh ( modified-sources modified-docs -- ) + 2dup + [ f swap set-vocab-docs-loaded? ] each + [ f swap set-vocab-source-loaded? ] each + append prune require-all load-failures. ; + +: refresh ( prefix -- ) to-refresh do-refresh ; + +SYMBOL: sources-changed? + +[ t sources-changed? set-global ] "tools.vocabs" add-init-hook + +: refresh-all ( -- ) + "" refresh f sources-changed? set-global ; + +MEMO: (vocab-file-contents) ( path -- lines ) + ?resource-path dup exists? + [ utf8 file-lines ] [ drop f ] if ; + +: vocab-file-contents ( vocab name -- seq ) + vocab-path+ dup [ (vocab-file-contents) ] when ; + +: set-vocab-file-contents ( seq vocab name -- ) + dupd vocab-path+ [ + ?resource-path utf8 set-file-lines + ] [ + "The " swap vocab-name + " vocabulary was not loaded from the file system" + 3append throw + ] ?if ; + +: vocab-summary-path ( vocab -- string ) + vocab-dir "summary.txt" path+ ; + +: vocab-summary ( vocab -- summary ) + dup dup vocab-summary-path vocab-file-contents + dup empty? [ + drop vocab-name " vocabulary" append + ] [ + nip first + ] if ; + +M: vocab summary + [ + dup vocab-summary % + " (" % + vocab-words assoc-size # + " words)" % + ] "" make ; + +M: vocab-link summary vocab-summary ; + +: set-vocab-summary ( string vocab -- ) + >r 1array r> + dup vocab-summary-path + set-vocab-file-contents ; + +: vocab-tags-path ( vocab -- string ) + vocab-dir "tags.txt" path+ ; + +: vocab-tags ( vocab -- tags ) + dup vocab-tags-path vocab-file-contents ; + +: set-vocab-tags ( tags vocab -- ) + dup vocab-tags-path set-vocab-file-contents ; + +: add-vocab-tags ( tags vocab -- ) + [ vocab-tags append prune ] keep set-vocab-tags ; + +: vocab-authors-path ( vocab -- string ) + vocab-dir "authors.txt" path+ ; + +: vocab-authors ( vocab -- authors ) + dup vocab-authors-path vocab-file-contents ; + +: set-vocab-authors ( authors vocab -- ) + dup vocab-authors-path set-vocab-file-contents ; + +: subdirs ( dir -- dirs ) + directory [ second ] subset keys natural-sort ; + +: (all-child-vocabs) ( root name -- vocabs ) + [ vocab-dir path+ ?resource-path subdirs ] keep + dup empty? [ + drop + ] [ + swap [ "." swap 3append ] with map + ] if ; + +: vocabs-in-dir ( root name -- ) + dupd (all-child-vocabs) [ + 2dup vocab-dir? [ 2dup swap >vocab-link , ] when + vocabs-in-dir + ] with each ; + +: all-vocabs ( -- assoc ) + vocab-roots get [ + dup [ "" vocabs-in-dir ] { } make + ] { } map>assoc ; + +MEMO: all-vocabs-seq ( -- seq ) + all-vocabs values concat ; + +: dangerous? ( name -- ? ) + #! Hack + { + { [ "cpu." ?head ] [ t ] } + { [ "io.unix" ?head ] [ t ] } + { [ "io.windows" ?head ] [ t ] } + { [ "ui.x11" ?head ] [ t ] } + { [ "ui.windows" ?head ] [ t ] } + { [ "ui.cocoa" ?head ] [ t ] } + { [ "cocoa" ?head ] [ t ] } + { [ "core-foundation" ?head ] [ t ] } + { [ "vocabs.loader.test" ?head ] [ t ] } + { [ "editors." ?head ] [ t ] } + { [ ".windows" ?tail ] [ t ] } + { [ ".unix" ?tail ] [ t ] } + { [ "unix." ?head ] [ t ] } + { [ ".linux" ?tail ] [ t ] } + { [ ".bsd" ?tail ] [ t ] } + { [ ".macosx" ?tail ] [ t ] } + { [ "windows." ?head ] [ t ] } + { [ "cocoa" ?head ] [ t ] } + { [ ".test" ?tail ] [ t ] } + { [ "raptor" ?head ] [ t ] } + { [ dup "tools.deploy.app" = ] [ t ] } + { [ t ] [ f ] } + } cond nip ; + +: filter-dangerous ( seq -- seq' ) + [ vocab-name dangerous? not ] subset ; + +: try-everything ( -- failures ) + all-vocabs-seq + filter-dangerous + require-all ; + +: load-everything ( -- ) + try-everything load-failures. ; + +: unrooted-child-vocabs ( prefix -- seq ) + dup empty? [ CHAR: . add ] unless + vocabs + [ vocab-root not ] subset + [ + vocab-name swap ?head CHAR: . rot member? not and + ] with subset + [ vocab ] map ; + +: all-child-vocabs ( prefix -- assoc ) + vocab-roots get [ + over dupd dupd (all-child-vocabs) + swap [ >vocab-link ] curry map + ] { } map>assoc + f rot unrooted-child-vocabs 2array add ; + +: all-child-vocabs-seq ( prefix -- assoc ) + vocab-roots get swap [ + dupd (all-child-vocabs) + [ vocab-dir? ] with subset + ] curry map concat ; + +: map>set ( seq quot -- ) + map concat prune natural-sort ; inline + +MEMO: all-tags ( -- seq ) + all-vocabs-seq [ vocab-tags ] map>set ; + +MEMO: all-authors ( -- seq ) + all-vocabs-seq [ vocab-authors ] map>set ; + +: reset-cache ( -- ) + \ (vocab-file-contents) reset-memoized + \ all-vocabs-seq reset-memoized + \ all-authors reset-memoized + \ all-tags reset-memoized ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 1b37673c38..e86cee0c47 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -32,14 +32,17 @@ SYMBOL: walking-thread \ break t "break?" set-word-prop +: walk ( quot -- quot' ) + \ break add* [ break rethrow ] recover ; + : add-breakpoint ( quot -- quot' ) dup [ break ] head? [ \ break add* ] unless ; -: walk ( quot -- ) add-breakpoint call ; +: (step-into-quot) ( quot -- ) add-breakpoint call ; -: (step-into-if) ? walk ; +: (step-into-if) ? (step-into-quot) ; -: (step-into-dispatch) nth walk ; +: (step-into-dispatch) nth (step-into-quot) ; : (step-into-execute) ( word -- ) dup "step-into" word-prop [ @@ -48,7 +51,7 @@ SYMBOL: walking-thread dup primitive? [ execute break ] [ - word-def walk + word-def (step-into-quot) ] if ] ?if ; @@ -104,8 +107,8 @@ SYMBOL: +detached+ [ nip \ break add ] change-frame ; { - { call [ walk ] } - { (throw) [ drop walk ] } + { call [ (step-into-quot) ] } + { (throw) [ drop (step-into-quot) ] } { execute [ (step-into-execute) ] } { if [ (step-into-if) ] } { dispatch [ (step-into-dispatch) ] } diff --git a/extra/trees/splay/splay-docs.factor b/extra/trees/splay/splay-docs.factor index 1c49febe01..253d3f4aec 100644 --- a/extra/trees/splay/splay-docs.factor +++ b/extra/trees/splay/splay-docs.factor @@ -11,7 +11,7 @@ HELP: { $description "Creates an empty splay tree" } ; HELP: >splay -{ $values { "assoc" assoc } { "splay" splay } } +{ $values { "assoc" assoc } { "tree" splay } } { $description "Converts any " { $link assoc } " into an splay tree." } ; HELP: splay diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 2fca5eca95..7746db85d3 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -6,7 +6,7 @@ IN: trees.splay TUPLE: splay ; -: ( -- splay-tree ) +: ( -- tree ) \ splay construct-tree ; INSTANCE: splay tree-mixin @@ -130,7 +130,7 @@ M: splay delete-at ( key tree -- ) M: splay new-assoc 2drop ; -: >splay ( assoc -- splay-tree ) +: >splay ( assoc -- tree ) T{ splay T{ tree f f 0 } } assoc-clone-like ; : SPLAY{ diff --git a/extra/triggers/authors.txt b/extra/triggers/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/triggers/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/triggers/summary.txt b/extra/triggers/summary.txt new file mode 100644 index 0000000000..34353dc799 --- /dev/null +++ b/extra/triggers/summary.txt @@ -0,0 +1 @@ +triggers allow you to register code to be 'triggered' diff --git a/extra/triggers/triggers-tests.factor b/extra/triggers/triggers-tests.factor new file mode 100644 index 0000000000..744a4b13a7 --- /dev/null +++ b/extra/triggers/triggers-tests.factor @@ -0,0 +1,14 @@ +USING: triggers kernel tools.test ; +IN: triggers.tests + +SYMBOL: test-trigger +test-trigger reset-trigger +: add-test-trigger test-trigger add-trigger ; +[ ] [ test-trigger call-trigger ] unit-test +[ "op called" ] [ "op" [ "op called" ] add-test-trigger test-trigger call-trigger ] unit-test +[ "first called" "second called" ] [ + test-trigger reset-trigger + "second op" [ "second called" ] add-test-trigger + "first op" [ "first called" ] add-test-trigger + test-trigger call-trigger +] unit-test diff --git a/extra/triggers/triggers.factor b/extra/triggers/triggers.factor new file mode 100644 index 0000000000..ffdfe373cd --- /dev/null +++ b/extra/triggers/triggers.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: assocs digraphs kernel namespaces sequences ; +IN: triggers + +: triggers ( -- triggers ) + \ triggers global [ drop H{ } clone ] cache ; + +: trigger-graph ( trigger -- graph ) + triggers [ drop ] cache ; + +: reset-trigger ( trigger -- ) + swap triggers set-at ; + +: add-trigger ( key quot trigger -- ) + #! trigger should be a symbol. Note that symbols with the same name but + #! different vocab are not equal + trigger-graph add-vertex ; + +: before ( key1 key2 trigger -- ) + trigger-graph add-edge ; + +: after ( key1 key2 trigger -- ) + swapd before ; + +: call-trigger ( trigger -- ) + trigger-graph topological-sorted-values [ call ] each ; + diff --git a/extra/tuples/lib/lib-docs.factor b/extra/tuples/lib/lib-docs.factor index 0ab709a11f..75df1550f4 100644 --- a/extra/tuples/lib/lib-docs.factor +++ b/extra/tuples/lib/lib-docs.factor @@ -5,7 +5,7 @@ HELP: >tuple< { $values { "class" "a tuple class" } } { $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." } { $example - "USE: tuples.lib" + "USING: kernel prettyprint tuples.lib ;" "TUPLE: foo a b c ;" "1 2 3 \\ foo construct-boa \\ foo >tuple< .s" "1\n2\n3" @@ -17,7 +17,7 @@ HELP: >tuple*< { $values { "class" "a tuple class" } } { $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." } { $example - "USE: tuples.lib" + "USING: kernel prettyprint tuples.lib ;" "TUPLE: foo a bb* ccc dddd* ;" "1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s" "2\n4" diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 5ab3ec28f3..a965e8a30c 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -297,7 +297,7 @@ CLASS: { { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" } [ [ - 2drop dup view-dim swap window set-gadget-dim + 2drop dup view-dim swap window set-gadget-dim yield ] ui-try ] } diff --git a/extra/ui/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor index af2df94ade..789d9b9e6a 100644 --- a/extra/ui/commands/commands-docs.factor +++ b/extra/ui/commands/commands-docs.factor @@ -46,10 +46,10 @@ HELP: command-name { $description "Outputs a human-readable name for the command." } { $examples { $example - "USE: ui.commands" + "USING: io ui.commands ;" ": com-my-command ;" "\\ com-my-command command-name write" - "My command" + "My Command" } } ; @@ -104,10 +104,10 @@ HELP: command-string { $description "Outputs a string containing the command name followed by the gesture." } { $examples { $example - "USING: ui.commands ui.gestures ;" + "USING: io ui.commands ui.gestures ;" ": com-my-command ;" "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write" - "My command (C+s)" + "My Command (C+s)" } } ; diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 8078ec4a33..8dca72c29e 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -4,6 +4,7 @@ USING: alien alien.accessors alien.c-types arrays io kernel libc math math.vectors namespaces opengl opengl.gl prettyprint assocs sequences io.files io.styles continuations freetype ui.gadgets.worlds ui.render ui.backend byte-arrays ; + IN: ui.freetype TUPLE: freetype-renderer ; @@ -74,7 +75,7 @@ M: freetype-renderer free-fonts ( world -- ) : open-face ( font style -- face ) ttf-name ttf-path dup malloc-file-contents - swap file-length + swap file-info file-info-size (open-face) ; SYMBOL: dpi diff --git a/extra/ui/gestures/gestures-docs.factor b/extra/ui/gestures/gestures-docs.factor index 95f2e5bf87..299498b1b8 100644 --- a/extra/ui/gestures/gestures-docs.factor +++ b/extra/ui/gestures/gestures-docs.factor @@ -194,7 +194,7 @@ HELP: gesture>string { $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } } { $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." } { $examples - { $example "USE: ui.gestures" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" } + { $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" } } ; ARTICLE: "ui-gestures" "UI gestures" diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index e494afd46d..574b71c44d 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -119,7 +119,8 @@ SYMBOL: drag-timer : stop-drag-timer ( -- ) hand-buttons get-global empty? [ - drag-timer get-global box> cancel-alarm + drag-timer get-global ?box + [ cancel-alarm ] [ drop ] if ] when ; : fire-motion ( -- ) diff --git a/extra/ui/render/render-docs.factor b/extra/ui/render/render-docs.factor index 2f82d983cc..fb4c000971 100755 --- a/extra/ui/render/render-docs.factor +++ b/extra/ui/render/render-docs.factor @@ -1,5 +1,5 @@ USING: ui.gadgets ui.gestures help.markup help.syntax -kernel classes strings opengl.gl ; +kernel classes strings opengl.gl models ; IN: ui.render HELP: gadget @@ -15,7 +15,7 @@ HELP: gadget { { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." } { { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." } { { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." } - { { $link gadget-model } " - XXX" } + { { $link gadget-model } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } } } "Gadgets delegate to " { $link rect } " instances holding their location and dimensions." } { $notes diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index 093222f17b..51a545db47 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -8,7 +8,7 @@ namespaces parser prettyprint quotations tools.annotations editors tools.profiler tools.test tools.time tools.walker ui.commands ui.gadgets.editors ui.gestures ui.operations ui.tools.deploy vocabs vocabs.loader words sequences -tools.browser classes compiler.units ; +tools.vocabs classes compiler.units ; IN: ui.tools.operations V{ } clone operations set-global @@ -84,11 +84,7 @@ UNION: definition word method-spec link vocab vocab-link ; { +secondary+ t } } define-operation -[ - class - { link word vocab vocab-link vocab-tag vocab-author } - memq? -] \ com-follow H{ +[ topic? ] \ com-follow H{ { +keyboard+ T{ key-down f { C+ } "H" } } { +primary+ t } } define-operation diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index b37b4ca707..45ac645392 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -7,7 +7,7 @@ source-files definitions strings tools.completion tools.crossref tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words vocabs.loader -tools.browser unicode.case calendar ui ; +tools.vocabs unicode.case calendar ui ; IN: ui.tools.search TUPLE: live-search field list ; diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 062bcf9416..d71b657491 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -8,7 +8,8 @@ prettyprint quotations sequences ui ui.commands ui.gadgets ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds ui.gadgets.presentations ui.gestures words vocabs.loader -tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ; +tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar +mirrors ; IN: ui.tools : ( -- tabs ) @@ -66,7 +67,7 @@ workspace "tool-switching" f { { T{ key-down f { A+ } "1" } com-listener } { T{ key-down f { A+ } "2" } com-browser } { T{ key-down f { A+ } "3" } com-inspector } - { T{ key-down f { A+ } "5" } com-profiler } + { T{ key-down f { A+ } "4" } com-profiler } } define-command-map \ workspace-window diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 477fffe6af..6286297f68 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -148,7 +148,7 @@ SYMBOL: ui-thread \ ui-running get-global ; : update-ui-loop ( -- ) - ui-running? ui-thread get-global self eq? [ + ui-running? ui-thread get-global self eq? and [ ui-notify-flag get lower-flag [ update-ui ] ui-try update-ui-loop diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index a1b513380c..8eb5fe59aa 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -266,11 +266,6 @@ SYMBOL: nc-buttons key-modifiers swap message>button [ ] [ ] if ; -: mouse-buttons ( -- seq ) WM_LBUTTONDOWN WM_RBUTTONDOWN 2array ; - -: capture-mouse? ( umsg -- ? ) - mouse-buttons member? ; - : prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world ) nip >r mouse-event>gesture r> >lo-hi rot window ; @@ -287,8 +282,10 @@ SYMBOL: nc-buttons mouse-captured off ; : handle-wm-buttondown ( hWnd uMsg wParam lParam -- ) - >r >r dup capture-mouse? [ over set-capture ] when r> r> - prepare-mouse send-button-down ; + >r >r + over set-capture + dup message>button drop nc-buttons get delete + r> r> prepare-mouse send-button-down ; : handle-wm-buttonup ( hWnd uMsg wParam lParam -- ) mouse-captured get [ release-capture ] when @@ -340,7 +337,7 @@ H{ } clone wm-handlers set-global [ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler [ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler [ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler - + [ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler [ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler [ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor old mode 100644 new mode 100755 index 81f3163a77..9f0e704157 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -20,4 +20,4 @@ IN: units.tests : km/L km 1 L d/ ; : mpg miles 1 gallons d/ ; -[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test +! [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test diff --git a/extra/units/units.factor b/extra/units/units.factor index f7aad72545..13d0a5d1cf 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -12,9 +12,6 @@ TUPLE: dimensions-not-equal ; M: dimensions-not-equal summary drop "Dimensions do not match" ; -: seq-intersect ( seq1 seq2 -- seq1/\seq2 ) - swap [ member? ] curry subset ; - : remove-one ( seq obj -- seq ) 1array split1 append ; diff --git a/extra/unix/stat/freebsd/freebsd.factor b/extra/unix/stat/freebsd/freebsd.factor new file mode 100644 index 0000000000..a81fc4f02e --- /dev/null +++ b/extra/unix/stat/freebsd/freebsd.factor @@ -0,0 +1,30 @@ +USING: kernel alien.syntax math ; + +IN: unix.stat + +! FreeBSD 8.0-CURRENT + +C-STRUCT: stat + { "__dev_t" "st_dev" } + { "ino_t" "st_ino" } + { "mode_t" "st_mode" } + { "nlink_t" "st_nlink" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "__dev_t" "st_rdev" } + { "timespec" "st_atim" } + { "timespec" "st_mtim" } + { "timespec" "st_ctim" } + { "off_t" "st_size" } + { "blkcnt_t" "st_blocks" } + { "blksize_t" "st_blksize" } + { "fflags_t" "st_flags" } + { "__uint32_t" "st_gen" } + { "__int32_t" "st_lspare" } + { "timespec" "st_birthtimespec" } +! not sure about the padding here. + { "__uint32_t" "pad0" } + { "__uint32_t" "pad1" } ; + +FUNCTION: int stat ( char* pathname, stat* buf ) ; +FUNCTION: int lstat ( char* pathname, stat* buf ) ; \ No newline at end of file diff --git a/extra/unix/stat/linux/linux.factor b/extra/unix/stat/linux/linux.factor index 71248a59f1..2f4b6174d9 100644 --- a/extra/unix/stat/linux/linux.factor +++ b/extra/unix/stat/linux/linux.factor @@ -1,5 +1,5 @@ -USING: system combinators vocabs.loader ; +USING: layouts combinators vocabs.loader ; IN: unix.stat diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor index 6d60caf987..e0a6a9fb76 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -60,8 +60,9 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; << os { - { "linux" [ "unix.stat.linux" require ] } - { "macosx" [ "unix.stat.macosx" require ] } + { "linux" [ "unix.stat.linux" require ] } + { "macosx" [ "unix.stat.macosx" require ] } + { "freebsd" [ "unix.stat.freebsd" require ] } [ drop ] } case diff --git a/extra/unix/types/freebsd/freebsd.factor b/extra/unix/types/freebsd/freebsd.factor new file mode 100644 index 0000000000..8d2d11e8ee --- /dev/null +++ b/extra/unix/types/freebsd/freebsd.factor @@ -0,0 +1,19 @@ +USING: alien.syntax ; + +IN: unix.types + +TYPEDEF: ushort __uint16_t +TYPEDEF: uint __uint32_t +TYPEDEF: int __int32_t +TYPEDEF: longlong __int64_t + +TYPEDEF: __uint32_t __dev_t +TYPEDEF: __uint32_t ino_t +TYPEDEF: __uint16_t mode_t +TYPEDEF: __uint16_t nlink_t +TYPEDEF: __uint32_t uid_t +TYPEDEF: __uint32_t gid_t +TYPEDEF: __int64_t off_t +TYPEDEF: __int64_t blkcnt_t +TYPEDEF: __uint32_t blksize_t +TYPEDEF: __uint32_t fflags_t \ No newline at end of file diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor index 23698d2c9b..f046197d30 100644 --- a/extra/unix/types/types.factor +++ b/extra/unix/types/types.factor @@ -7,8 +7,9 @@ TYPEDEF: void* caddr_t os { - { "linux" [ "unix.types.linux" require ] } - { "macosx" [ "unix.types.macosx" require ] } + { "linux" [ "unix.types.linux" require ] } + { "macosx" [ "unix.types.macosx" require ] } + { "freebsd" [ "unix.types.freebsd" require ] } [ drop ] } case \ No newline at end of file diff --git a/extra/xml/xml-docs.factor b/extra/xml/xml-docs.factor index a941e0de92..dd77d7c766 100644 --- a/extra/xml/xml-docs.factor +++ b/extra/xml/xml-docs.factor @@ -170,7 +170,7 @@ HELP: ( text -- instruction ) HELP: names-match? { $values { "name1" "a name" } { "name2" "a name" } { "?" "t or f" } } { $description "checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." } -{ $example "USE: xml.data" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" } +{ $example "USING: prettyprint xml.data ;" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" } { $see-also name } ; HELP: xml-chunk diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor index 47e619cc00..a13e412afe 100755 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -1,5 +1,6 @@ -USING: xmode.tokens xmode.marker xmode.catalog kernel html html.elements io - io.files sequences words io.encodings.utf8 ; +USING: xmode.tokens xmode.marker xmode.catalog kernel html +html.elements io io.files sequences words io.encodings.utf8 +namespaces ; IN: xmode.code2html : htmlize-tokens ( tokens -- ) @@ -40,5 +41,9 @@ IN: xmode.code2html ; : htmlize-file ( path -- ) - dup utf8 over ".html" append utf8 - [ htmlize-stream ] with-stream ; + dup utf8 [ + stdio get + over ".html" append utf8 [ + htmlize-stream + ] with-file-writer + ] with-file-reader ; diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor index d14ffd93b3..379f6d6c94 100755 --- a/extra/xmode/code2html/responder/responder.factor +++ b/extra/xmode/code2html/responder/responder.factor @@ -1,15 +1,21 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files namespaces http.server http.server.static http -xmode.code2html kernel html sequences accessors ; +USING: io.files io.encodings.utf8 namespaces http.server +http.server.static http xmode.code2html kernel html sequences +accessors fry combinators.cleave ; IN: xmode.code2html.responder : ( root -- responder ) [ drop - "text/html" - over file-http-date "last-modified" set-header - swap [ - dup file-name swap htmlize-stream - ] curry >>body + "text/html" swap + [ file-http-date "last-modified" set-header ] + [ + '[ + , + dup file-name swap utf8 + + [ htmlize-stream ] with-html-stream + ] >>body + ] bi ] ; diff --git a/extra/xmode/tokens/tokens.factor b/extra/xmode/tokens/tokens.factor index 7b913cbac0..018164dfcf 100755 --- a/extra/xmode/tokens/tokens.factor +++ b/extra/xmode/tokens/tokens.factor @@ -3,9 +3,9 @@ compiler.units ; IN: xmode.tokens ! Based on org.gjt.sp.jedit.syntax.Token +<< SYMBOL: tokens -<< { "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [ create-in dup define-symbol dup word-name swap diff --git a/misc/factor.sh b/misc/factor.sh index 0ad44430c8..b96aa8d24b 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -56,7 +56,7 @@ check_ret() { check_gcc_version() { echo -n "Checking gcc version..." - GCC_VERSION=`gcc --version` + GCC_VERSION=`$CC --version` check_ret gcc if [[ $GCC_VERSION == *3.3.* ]] ; then echo "bad!" @@ -85,18 +85,35 @@ set_md5sum() { fi } +set_gcc() { + case $OS in + openbsd) ensure_program_installed egcc; CC=egcc;; + *) CC=gcc;; + esac +} + +set_make() { + case $OS in + netbsd) MAKE='gmake';; + freebsd) MAKE='gmake';; + openbsd) MAKE='gmake';; + dragonflybsd) MAKE='gmake';; + *) MAKE='make';; + esac + if ! [[ $MAKE -eq 'gmake' ]] ; then + ensure_program_installed gmake + fi +} + check_installed_programs() { ensure_program_installed chmod ensure_program_installed uname ensure_program_installed git ensure_program_installed wget curl ensure_program_installed gcc - ensure_program_installed make + ensure_program_installed make gmake ensure_program_installed md5sum md5 ensure_program_installed cut - case $OS in - netbsd) ensure_program_installed gmake;; - esac check_gcc_version } @@ -105,7 +122,7 @@ check_library_exists() { GCC_OUT=factor-library-test.out echo -n "Checking for library $1..." echo "int main(){return 0;}" > $GCC_TEST - gcc $GCC_TEST -o $GCC_OUT -l $1 + $CC $GCC_TEST -o $GCC_OUT -l $1 if [[ $? -ne 0 ]] ; then echo "not found!" echo "Warning: library $1 not found." @@ -153,6 +170,9 @@ find_os() { *linux*) OS=linux;; *Linux*) OS=linux;; *NetBSD*) OS=netbsd;; + *FreeBSD*) OS=freebsd;; + *OpenBSD*) OS=openbsd;; + *DragonFly*) OS=dragonflybsd;; esac } @@ -163,6 +183,7 @@ find_architecture() { case $uname_m in i386) ARCH=x86;; i686) ARCH=x86;; + amd64) ARCH=x86;; *86) ARCH=x86;; *86_64) ARCH=x86;; "Power Macintosh") ARCH=ppc;; @@ -203,6 +224,8 @@ echo_build_info() { echo GIT_PROTOCOL=$GIT_PROTOCOL echo GIT_URL=$GIT_URL echo DOWNLOADER=$DOWNLOADER + echo CC=$CC + echo MAKE=$MAKE } set_build_info() { @@ -236,6 +259,8 @@ find_build_info() { set_factor_binary set_build_info set_downloader + set_gcc + set_make echo_build_info } @@ -260,12 +285,8 @@ cd_factor() { } invoke_make() { - case $OS in - netbsd) make='gmake';; - *) make='make';; - esac - $make $* - check_ret $make + $MAKE $* + check_ret $MAKE } make_clean() { diff --git a/misc/factor.vim b/misc/factor.vim index 4d15245da8..93ce3d6bd5 100644 --- a/misc/factor.vim +++ b/misc/factor.vim @@ -21,15 +21,26 @@ else set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255 endif -syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple +syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained syn match factorComment /\<#! .*/ contains=factorTodo syn match factorComment /\/ end=/\<;\>/ contains=@factorCluster,factorStackEffect,factorStackEffectErr,factorArray0,factorQuotation0 +syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0 + +syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents +syn region factorMethod matchgroup=factorMethodDelims start=/\/ end=/\<;\>/ contains=@factorDefnContents +syn region factorGeneric matchgroup=factorGenericDelims start=/\/ end=/$/ contains=factorStackEffect +syn region factorGenericN matchgroup=factorGenericNDelims start=/\/ end=/$/ contains=factorStackEffect + +syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained +syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\/ end=/\<;\>/ contains=@factorDefnContents contained +syn region factorPGeneric matchgroup=factorPGenericDelims start=/\/ end=/$/ contains=factorStackEffect contained +syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\/ end=/$/ contains=factorStackEffect + +syn region None matchgroup=factorPrivate start=/\</ end=/\\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN -syn region None matchgroup=factorGeneric start=/\/ end=/$/ contains=factorStackEffect,factorStackEffectErr syn keyword factorBoolean boolean f general-t t syn keyword factorCompileDirective inline foldable parsing @@ -37,15 +48,17 @@ syn keyword factorCompileDirective inline foldable parsing " kernel vocab keywords -syn keyword factorKeyword continuation-name set-datastack wrapper continuation-catch set-continuation-name slip pick 2slip 2nip tuple set-boot clone with-datastack cpu -roll tuck -rot (continue) set-continuation-retain swapd >boolean wrapper? dupd 3dup dup ifcc callstack windows? os-env = over continuation alist>quot ? 2dup cond win64? continue 3drop hashcode quotation xor when curry millis set-callstack unless >r die version callcc0 or os callcc1 get-walker-hook depth equal? 3keep no-cond? continue-with if exit tuple? set-retainstack unix? (continue-with) general-t continuation? 3slip macosx? r> rot win32? retainstack 2apply >quotation >continuation< type continuation-call clear call drop continuation-data set-continuation-call 2drop no-cond unit set-continuation-data keep-datastack and when* quotation? ?if literalize datastack swap unless* 2swap set-continuation-catch eq? not roll set-walker-hook continuation-retain with make-dip wrapped keep 2keep <=> if* nip -syn keyword factorKeyword sin integer? log2 cot oct> number>string integer first-bignum sech abs repeat tanh real? vmin norm-sq neg between? asech >rect bignum? atanh -i * + fp-nan? - small / sqrt infimum fix-float cosech even? v*n < bits>double > most-positive-fixnum ^theta numerator digit+ >base (random-int) acosech cosh min pi number vmax zero? sum digit> rem bitor supremum string>integer most-negative-fixnum >polar >fraction ceiling acos acot ^ asin acosh /f ratio e fixnum? /i ^n cis coth 1+ 1- conjugate sinh acosec i number= number? double>bits epsilon float product string>number n/v norm max tan acoth absq float? asinh denominator rational? fixnum rect> >fixnum imaginary recip exp sec bitxor w>h/h >bin align base> times log <= [-] init-random sq odd? (repeat) [v-] ^mag bitnot ratio? random-int >digit (next-power-of-2) v* v+ v- v. v/ >float [-1,1]? arg small? bitand set-axis >oct v/n complex rational shift (^) polar> (gcd) cosec next-power-of-2 >float-rect atan sgn >= float>bits normalize real bin> complex? gcd d>w/w hex> mod string>ratio asec floor n*v >hex truncate bits>float vneg >bignum bignum power-of-2? integer, /mod (string>integer) cos -syn keyword factorKeyword second sort-values all-eq? pop* find slice-error-reason inject-with prune remove (group) split1-slice slice-error (slice*) split* head-slice* find* split, first remove-nth hash-prune push-if ?push reverse subseq split1 diff subset split new padding column? copy-into-check column@ peek last/first add find-last ?nth add* slice-from cache-nth subseq? (3append) replace-slice reversed-seq find-last-with empty? ((append)) reversed? reversed@ map-with find-last-with* set-slice-error-reason set-column-col natural-sort (subst) set-slice-seq index* concat push binsearch slice-seq 3append nsort length tail-slice* reversed ?head sequence= ?tail sequence? memq? join split-next, delete set-nth subst monotonic? group map flip unclip set-reversed-seq find-last* start* max-length assoc min-length all-equal? all? pad-left contains? inject slice first2 first3 first4 exchange bounds-check? column-seq check-slice pad-right each subset-with unpair tail head interleave (delete) copy-into sort sequence reduce set-slice-from set-slice-to 2map (cut) member? cut rassoc (append) last-index* sort-keys change-nth 2each >sequence nth tail* head* third tail-slice set-length collapse-slice column (mismatch) contains-with? push-new pop tail? head? slice? slice@ delete-all binsearch* move find-with* 2reduce slice-to find-with like slice-error? set-column-seq nappend column-col cut* (split) index each-with last-index fourth append accumulate drop-prefix mismatch head-slice all-with? start -syn keyword factorKeyword namespace-error-object inc dec make off bind get-global init-namespaces set-global namespace on ndrop namespace-error? namestack namespace-error +@ # % make-hash global , set-namestack with-scope building change nest set-namespace-error-object get set counter -syn keyword factorKeyword array pair byte-array pair? 1array 2array resize-array 4array 3array byte-array? array? >array -syn keyword factorKeyword cwd duplex-stream pathname? set-pathname-string with-log-file directory duplex-stream-out format (readln) duplex-stream? read1 with-stream-style c-stream-error? stream-write1 with-stream line-reader? set-duplex-stream-out server? cr> directory? log-message flush format-column stream-readln nested-style-stream? set-timeout write-pathname file-modified duplex-stream-closed? print set-duplex-stream-closed? pathname line-reader ?resource-path terpri write-object le> string-out stream-terpri log-client do-nested-style path+ set-client-stream-host plain-writer? server-stream resource-path >be parent-dir with-stream* server-loop string-in nested-style-stream stream-close stream-copy c-stream-error with-style client-stream-host stat plain-writer file-length contents stream-read stream-format check-closed? set-client-stream-port write1 bl write-outliner map-last (with-stream-style) set-line-reader-cr tabular-output (lines) stream-write log-stream server-client (stream-copy) with-nested-stream lines readln cd client-stream nth-byte with-logging stream-read1 nested-style-stream-style accept check-closed client-stream-port do-nested-quot pathname-string set-nested-style-stream-style read home close with-stream-table stdio be> log-error duplex-stream-out+ server stream-flush set-duplex-stream-in line-reader-cr >le with-client (directory) set-server-client stream-print with-server exists? with-nesting string-lines write duplex-stream-in client-stream? duplex-stream-in+ -syn keyword factorKeyword sbuf ch>upper string? LETTER? >sbuf >lower quotable? string>sbuf blank? string sbuf? printable? >string letter? resize-string control? alpha? >upper Letter? ch>lower digit? ch>string -syn keyword factorKeyword >vector array>vector vector? vector -syn keyword factorKeyword set-restart-continuation cleanup error-hook restart-name restarts. stack-underflow. expired-error. restart restart? word-xt. (:help-none) set-catchstack c-string-error. condition debug-help :get datastack-overflow. set-condition-restarts condition? error. objc-error. print-error assert :res catchstack rethrow assert= kernel-error restart-obj assert? undefined-symbol-error. retainstack-overflow. restarts error-help divide-by-zero-error. ffi-error. signal-error. (:help-multi) set-restart-obj xt. memory-error. retainstack-underflow. set-condition-continuation datastack-underflow. try assert-depth error-continuation error-stack-trace assert-expect recover :edit kernel-error? error callstack-overflow. stack-overflow. callstack-underflow. set-assert-got set-restart-name restart-continuation condition-restarts heap-scan-error. :help type-check-error. assert-got throw negative-array-size-error. :c condition-continuation :trace undefined-word-error. io-error. parse-dump set-assert-expect :r :s compute-restarts catch restart. +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 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 cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal @@ -73,11 +86,16 @@ syn match factorBackslash /\<\\\>\s\+\S\+\>/ syn region factorUsing start=/\/ end=/;/ syn region factorRequires start=/\/ end=/;/ -syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget +syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor syn match factorSymbol /\/ syn match factorPostpone /\/ syn match factorDefer /\/ syn match factorForget /\/ +syn match factorMixin /\/ +syn match factorInstance /\/ +syn match factorHook /\/ +syn match factorMain /\/ +syn match factorConstructor /\/ syn match factorAlien /\/ @@ -87,8 +105,6 @@ syn region factorTuple start=/\/ end=/\<;\>/ "misc: " HELP: " ARTICLE: -" PROVIDE: -" MAIN: "literals: " PRIMITIVE: @@ -106,8 +122,11 @@ syn region factorTuple start=/\/ end=/\<;\>/ syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline -syn match factorStackEffectErr /\<)\>/ -syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ +syn region factorMultiString matchgroup=factorMultiStringDelims start=/\/ end=/^;$/ contains=factorMultiStringContents +syn match factorMultiStringContents /.*/ contained + +"syn match factorStackEffectErr /\<)\>/ +"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained "adapted from lisp.vim @@ -127,18 +146,18 @@ else endif if exists("g:factor_norainbow") - syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL + syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL else - syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 - syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 - syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 - syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 - syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 - syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 - syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 - syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 - syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 - syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 + syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 + syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 + syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 + syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 + syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 + syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 + syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 + syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 + syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 + syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 endif syn match factorBracketErr /\<\]\>/ @@ -163,11 +182,21 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorKeyword Keyword HiLink factorOperator Operator HiLink factorBoolean Boolean - HiLink factorDefinition Typedef + HiLink factorDefnDelims Typedef + HiLink factorMethodDelims Typedef + HiLink factorGenericDelims Typedef + HiLink factorGenericNDelims Typedef + HiLink factorConstructor Typedef + HiLink factorPrivate Special + HiLink factorPrivateDefnDelims Special + HiLink factorPrivateMethodDelims Special + HiLink factorPGenericDelims Special + HiLink factorPGenericNDelims Special HiLink factorString String HiLink factorSbuf String + HiLink factorMultiStringContents String + HiLink factorMultiStringDelims Typedef HiLink factorBracketErr Error - HiLink factorStackEffectErr Error HiLink factorComplex Number HiLink factorRatio Number HiLink factorBinary Number @@ -186,14 +215,17 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorCharErr Error HiLink factorDelimiter Delimiter HiLink factorBackslash Special - HiLink factorCompileDirective Keyword + HiLink factorCompileDirective Typedef HiLink factorSymbol Define + HiLink factorMixin Typedef + HiLink factorInstance Typedef + HiLink factorHook Typedef + HiLink factorMain Define HiLink factorPostpone Define HiLink factorDefer Define HiLink factorForget Define HiLink factorAlien Define HiLink factorTuple Typedef - HiLink factorGeneric Define if &bg == "dark" hi hlLevel0 ctermfg=red guifg=red1 @@ -230,3 +262,4 @@ set expandtab set autoindent " annoying? " vim: syntax=vim + diff --git a/misc/factor.vim.fgen b/misc/factor.vim.fgen index 9782c4f1d0..7bcba78cde 100644 --- a/misc/factor.vim.fgen +++ b/misc/factor.vim.fgen @@ -1,4 +1,4 @@ -<% USING: kernel io prettyprint words sequences ; +<% USING: kernel io prettyprint vocabs sequences ; %>" Vim syntax file " Language: factor " Maintainer: Alex Chapman @@ -22,15 +22,26 @@ else set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255 endif -syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple +syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained syn match factorComment /\<#! .*/ contains=factorTodo syn match factorComment /\/ end=/\<;\>/ contains=@factorCluster,factorStackEffect,factorStackEffectErr,factorArray0,factorQuotation0 +syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0 + +syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents +syn region factorMethod matchgroup=factorMethodDelims start=/\/ end=/\<;\>/ contains=@factorDefnContents +syn region factorGeneric matchgroup=factorGenericDelims start=/\/ end=/$/ contains=factorStackEffect +syn region factorGenericN matchgroup=factorGenericNDelims start=/\/ end=/$/ contains=factorStackEffect + +syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained +syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\/ end=/\<;\>/ contains=@factorDefnContents contained +syn region factorPGeneric matchgroup=factorPGenericDelims start=/\/ end=/$/ contains=factorStackEffect contained +syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\/ end=/$/ contains=factorStackEffect + +syn region None matchgroup=factorPrivate start=/\</ end=/\\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN -syn region None matchgroup=factorGeneric start=/\/ end=/$/ contains=factorStackEffect,factorStackEffectErr syn keyword factorBoolean boolean f general-t t syn keyword factorCompileDirective inline foldable parsing @@ -40,10 +51,13 @@ syn keyword factorCompileDirective inline foldable parsing ! that this changes factor.vim from around 8k to around 100k (and is a bit ! broken) -! vocabs [ words [ "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] when* ] each %> +! vocabs [ words [ "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] when* ] each +%> " kernel vocab keywords -<% { "kernel" "math" "sequences" "namespaces" "arrays" "io" "strings" "vectors" "errors" } [ words "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] each %> +<% { "kernel" "assocs" "combinators" "math" "sequences" "namespaces" "arrays" "io" "strings" "vectors" "continuations" } [ + words "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write + ] each %> syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal syn cluster factorNumber contains=@factorReal,factorComplex @@ -70,11 +84,16 @@ syn match factorBackslash /\<\\\>\s\+\S\+\>/ syn region factorUsing start=/\/ end=/;/ syn region factorRequires start=/\/ end=/;/ -syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget +syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor syn match factorSymbol /\/ syn match factorPostpone /\/ syn match factorDefer /\/ syn match factorForget /\/ +syn match factorMixin /\/ +syn match factorInstance /\/ +syn match factorHook /\/ +syn match factorMain /\/ +syn match factorConstructor /\/ syn match factorAlien /\/ @@ -84,8 +103,6 @@ syn region factorTuple start=/\/ end=/\<;\>/ "misc: " HELP: " ARTICLE: -" PROVIDE: -" MAIN: "literals: " PRIMITIVE: @@ -103,8 +120,11 @@ syn region factorTuple start=/\/ end=/\<;\>/ syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline -syn match factorStackEffectErr /\<)\>/ -syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ +syn region factorMultiString matchgroup=factorMultiStringDelims start=/\/ end=/^;$/ contains=factorMultiStringContents +syn match factorMultiStringContents /.*/ contained + +"syn match factorStackEffectErr /\<)\>/ +"syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained "adapted from lisp.vim @@ -124,18 +144,18 @@ else endif if exists("g:factor_norainbow") - syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL + syn region factorArray matchgroup=factorDelimiter start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ matchgroup=factorDelimiter end=/\<}\>/ contains=ALL else - syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 - syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 - syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 - syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 - syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 - syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 - syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 - syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 - syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 - syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 + syn region factorArray0 matchgroup=hlLevel0 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray1,factorQuotation1 + syn region factorArray1 contained matchgroup=hlLevel1 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray2,factorQuotation2 + syn region factorArray2 contained matchgroup=hlLevel2 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray3,factorQuotation3 + syn region factorArray3 contained matchgroup=hlLevel3 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray4,factorQuotation4 + syn region factorArray4 contained matchgroup=hlLevel4 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray5,factorQuotation5 + syn region factorArray5 contained matchgroup=hlLevel5 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray6,factorQuotation6 + syn region factorArray6 contained matchgroup=hlLevel6 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray7,factorQuotation7 + syn region factorArray7 contained matchgroup=hlLevel7 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray8,factorQuotation8 + syn region factorArray8 contained matchgroup=hlLevel8 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray9,factorQuotation9 + syn region factorArray9 contained matchgroup=hlLevel9 start=/\<\(V\|H\|T\|W\|F\|B\)\?{\>/ end=/\<}\>/ contains=@factorCluster,factorArray0,factorQuotation0 endif syn match factorBracketErr /\<\]\>/ @@ -160,11 +180,21 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorKeyword Keyword HiLink factorOperator Operator HiLink factorBoolean Boolean - HiLink factorDefinition Typedef + HiLink factorDefnDelims Typedef + HiLink factorMethodDelims Typedef + HiLink factorGenericDelims Typedef + HiLink factorGenericNDelims Typedef + HiLink factorConstructor Typedef + HiLink factorPrivate Special + HiLink factorPrivateDefnDelims Special + HiLink factorPrivateMethodDelims Special + HiLink factorPGenericDelims Special + HiLink factorPGenericNDelims Special HiLink factorString String HiLink factorSbuf String + HiLink factorMultiStringContents String + HiLink factorMultiStringDelims Typedef HiLink factorBracketErr Error - HiLink factorStackEffectErr Error HiLink factorComplex Number HiLink factorRatio Number HiLink factorBinary Number @@ -183,14 +213,17 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorCharErr Error HiLink factorDelimiter Delimiter HiLink factorBackslash Special - HiLink factorCompileDirective Keyword + HiLink factorCompileDirective Typedef HiLink factorSymbol Define + HiLink factorMixin Typedef + HiLink factorInstance Typedef + HiLink factorHook Typedef + HiLink factorMain Define HiLink factorPostpone Define HiLink factorDefer Define HiLink factorForget Define HiLink factorAlien Define HiLink factorTuple Typedef - HiLink factorGeneric Define if &bg == "dark" hi hlLevel0 ctermfg=red guifg=red1