diff --git a/.gitignore b/.gitignore index 290f075aae..f4334f3727 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,4 @@ temp logs work build-support/wordsize +*.bak diff --git a/Makefile b/Makefile index 973ba1f3d4..ffcbf6364c 100644 --- a/Makefile +++ b/Makefile @@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS) clean: rm -f vm/*.o - rm -f factor*.dll libfactor*.* + rm -f factor*.dll libfactor.{a,so,dylib} vm/resources.o: $(WINDRES) vm/factor.rs vm/resources.o diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor index dac8b72dd5..2d494afca3 100644 --- a/basis/alarms/alarms-docs.factor +++ b/basis/alarms/alarms-docs.factor @@ -5,7 +5,7 @@ HELP: alarm { $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ; HELP: add-alarm -{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } } +{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" 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 diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 03208de63a..739b45486f 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -39,12 +39,12 @@ HELP: byte-length { $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ; HELP: c-getter -{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } } +{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } } { $description "Outputs a quotation which reads values of this C type from a C structure." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; HELP: c-setter -{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( obj c-ptr n -- )" } } } +{ $values { "name" string } { "quot" { $quotation "( obj c-ptr n -- )" } } } { $description "Outputs a quotation which writes values of this C type to a C structure." } { $errors "Throws an error if the type does not exist." } ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a93c87611d..543af8dee8 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -164,7 +164,7 @@ GENERIC: stack-size ( type -- size ) foldable M: string stack-size c-type stack-size ; -M: c-type stack-size size>> ; +M: c-type stack-size size>> cell align ; GENERIC: byte-length ( seq -- n ) flushable @@ -436,6 +436,6 @@ M: long-long-type box-return ( type -- ) "double" define-primitive-type "long" "ptrdiff_t" typedef - + "long" "intptr_t" typedef "ulong" "size_t" typedef ] with-compilation-unit diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index ce30a2ee25..adb25aa977 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,14 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays generic hashtables kernel kernel.private -math namespaces parser sequences strings words libc +math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture ; IN: alien.structs -: if-value-structs? ( ctype true false -- ) - value-structs? - [ drop call ] [ >r 2drop "void*" r> call ] if ; inline - TUPLE: struct-type size align fields ; M: struct-type heap-size size>> ; @@ -17,20 +13,26 @@ M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; -M: struct-type unbox-parameter - [ %unbox-struct ] [ unbox-parameter ] if-value-structs? ; +: if-value-struct ( ctype true false -- ) + [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline -M: struct-type unbox-return - f swap %unbox-struct ; +M: struct-type unbox-parameter + [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ; M: struct-type box-parameter - [ %box-struct ] [ box-parameter ] if-value-structs? ; + [ %box-large-struct ] [ box-parameter ] if-value-struct ; + +: if-small-struct ( c-type true false -- ? ) + [ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline + +M: struct-type unbox-return + [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; M: struct-type box-return - f swap %box-struct ; + [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; M: struct-type stack-size - [ heap-size ] [ stack-size ] if-value-structs? ; + [ heap-size ] [ stack-size ] if-value-struct ; : c-struct? ( type -- ? ) (c-type) struct-type? ; @@ -40,7 +42,7 @@ M: struct-type stack-size -rot define-c-type ; : define-struct-early ( name vocab fields -- fields ) - -rot [ rot first2 ] 2curry map ; + [ first2 ] with with map ; : compute-struct-align ( types -- n ) [ c-type-align ] map supremum ; diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor index caabbd7419..cf7915159a 100644 --- a/basis/binary-search/binary-search-docs.factor +++ b/basis/binary-search/binary-search-docs.factor @@ -2,7 +2,7 @@ IN: binary-search USING: help.markup help.syntax sequences kernel math.order ; HELP: search -{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } +{ $values { "seq" "a sorted sequence" } { "quot" { $quotation "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } { $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")." $nl "If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "." diff --git a/basis/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor index 71aa2e8adc..f9b7b56779 100644 --- a/basis/bootstrap/image/download/download.factor +++ b/basis/bootstrap/image/download/download.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: http.client checksums checksums.openssl splitting assocs +USING: http.client checksums checksums.md5 splitting assocs kernel io.files bootstrap.image sequences io urls ; IN: bootstrap.image.download @@ -13,7 +13,7 @@ IN: bootstrap.image.download : need-new-image? ( image -- ? ) dup exists? [ - [ openssl-md5 checksum-file hex-string ] + [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ] [ drop t ] if ; diff --git a/basis/calendar/windows/tags.txt b/basis/calendar/windows/tags.txt old mode 100644 new mode 100755 index 02ec70f741..6bf68304bb --- a/basis/calendar/windows/tags.txt +++ b/basis/calendar/windows/tags.txt @@ -1,2 +1 @@ unportable -windows diff --git a/basis/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor index 9b5e3fdfd9..400599383f 100644 --- a/basis/cocoa/messages/messages-docs.factor +++ b/basis/cocoa/messages/messages-docs.factor @@ -31,7 +31,7 @@ HELP: alien>objc-types { objc>alien-types alien>objc-types } related-words HELP: import-objc-class -{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } } +{ $values { "name" string } { "quot" { $quotation "( -- )" } } } { $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ; HELP: root-class diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index d1b18ab5da..65d290df3a 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -2,10 +2,10 @@ USING: help.markup help.syntax parser vocabs.loader strings ; IN: command-line HELP: run-bootstrap-init -{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ; +{ $description "Runs the bootstrap initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-boot-rc" } " on Unix and " { $snippet "factor-boot-rc" } " on Windows." } ; HELP: run-user-init -{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ; +{ $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ; HELP: cli-param { $values { "param" string } } @@ -57,7 +57,7 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap" "A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:" { $table { { $snippet "-output-image=" { $emphasis "image" } } { "Save the result to " { $snippet "image" } ". The default is " { $snippet "factor.image" } "." } } - { { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-boot-rc" } " file in the user's home directory." } } + { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } } { { $snippet "-include=" { $emphasis "components..." } } "A list of components to include (see below)." } { { $snippet "-exclude=" { $emphasis "components..." } } "A list of components to exclude." } { { $snippet "-ui-backend=" { $emphasis "backend" } } { "One of " { $snippet "x11" } ", " { $snippet "windows" } ", or " { $snippet "cocoa" } ". The default is platform-specific." } } @@ -74,9 +74,9 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap" "By default, all optional components are loaded. To load all optional components except for a given list, use the " { $snippet "-exclude=" } " switch; to only load specified optional components, use the " { $snippet "-include=" } "." $nl "For example, to build an image with the compiler but no other components, you could do:" -{ $code "./factor -i=boot.ppc.image -include=compiler" } +{ $code "./factor -i=boot.macosx-ppc.image -include=compiler" } "To build an image with everything except for the user interface and graphical tools," -{ $code "./factor -i=boot.ppc.image -exclude=\"ui ui.tools\"" } +{ $code "./factor -i=boot.macosx-ppc.image -exclude=\"ui ui.tools\"" } "To generate a bootstrap image in the first place, see " { $link "bootstrap.image" } "." ; ARTICLE: "standard-cli-args" "Command line switches for general usage" @@ -84,17 +84,43 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage" { $table { { $snippet "-e=" { $emphasis "code" } } { "This specifies a code snippet to evaluate. If you want Factor to exit immediately after, also specify " { $snippet "-run=none" } "." } } { { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } } - { { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-rc" } " file in the user's home directory on startup." } } + { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } } { { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } } { { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } } } ; -ARTICLE: "rc-files" "Running code on startup" -"Unless the " { $snippet "-no-user-init" } " command line switch is specified, The startup routine runs the " { $snippet ".factor-rc" } " file in the user's home directory, if it exists. This file can contain initialization and customization for your development environment." +ARTICLE: "factor-boot-rc" "Bootstrap initialization file" +"The botstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts." $nl -"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:" -{ $subsection run-user-init } -{ $subsection run-bootstrap-init } ; +"A word to run this file from an existing Factor session:" +{ $subsection run-bootstrap-init } +"For example, if you changed " { $snippet ".factor-boot-rc" } " and do not want to bootstrap again, you can just invoke " { $link run-bootstrap-init } " in the listener." ; + +ARTICLE: "factor-rc" "Startup initialization file" +"The startup initialization file is named " { $snippet "factor-rc" } " on Windows and " { $snippet ".factor-rc" } " on Unix. If it exists, it is run every time Factor starts." +$nl +"A word to run this file from an existing Factor session:" +{ $subsection run-user-init } ; + +ARTICLE: "rc-files" "Running code on startup" +"Factor looks for two files in your home directory." +{ $subsection "factor-boot-rc" } +{ $subsection "factor-rc" } +"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files." +$nl +"If you are unsure where the files should be located, evaluate the following code:" +{ $code + "USE: command-line" + "\"factor-rc\" rc-path print" + "\"factor-boot-rc\" rc-path print" +} +"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration, adds an additional vocabulary root (see " { $link "vocabs.roots" } "), and increases the font size in the UI by setting the DPI (dots-per-inch) variable:" +{ $code + "USING: editors.gvim vocabs.loader ui.freetype namespaces sequences ;" + "\"/opt/local/bin\" \\ gvim-path set-global" + "\"/home/jane/src/\" vocab-roots get push" + "100 dpi set-global" +} ; ARTICLE: "cli" "Command line usage" "Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "." diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 37dbf9b7a6..7691f6877b 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -5,14 +5,18 @@ kernel.private namespaces parser sequences strings system splitting io.files eval ; IN: command-line +: rc-path ( name -- path ) + os windows? [ "." prepend ] unless + home prepend-path ; + : run-bootstrap-init ( -- ) "user-init" get [ - home ".factor-boot-rc" append-path ?run-file + "factor-boot-rc" rc-path ?run-file ] when ; : run-user-init ( -- ) "user-init" get [ - home ".factor-rc" append-path ?run-file + "factor-rc" rc-path ?run-file ] when ; : cli-var-param ( name value -- ) swap set-global ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 0d45b28126..9f6e8e9c9b 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -235,7 +235,7 @@ M: float-regs reg-class-variable drop float-regs ; GENERIC: inc-reg-class ( register-class -- ) : ?dummy-stack-params ( reg-class -- ) - dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ; + dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ; : ?dummy-int-params ( reg-class -- ) dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ; @@ -264,7 +264,7 @@ M: object reg-class-full? : spill-param ( reg-class -- n reg-class ) stack-params get - >r reg-size stack-params +@ r> + >r reg-size cell align stack-params +@ r> stack-params ; : fastcall-param ( reg-class -- n reg-class ) diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 6cb860d33f..512d26f4bf 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -6,7 +6,7 @@ HELP: enable-compiler { $description "Enables the optimizing compiler." } ; HELP: disable-compiler -{ $description "Enables the optimizing compiler." } ; +{ $description "Disable the optimizing compiler." } ; ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically. This can be changed:" diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index b01a835b4a..a6afc4b243 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io debugger -words fry continuations vocabs assocs dlists definitions math -threads graphs generic combinators deques search-deques +words fry continuations vocabs assocs dlists definitions +math threads graphs generic combinators deques search-deques prettyprint io stack-checker stack-checker.state stack-checker.inlining compiler.errors compiler.units compiler.tree.builder compiler.tree.optimizer diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index d7e82402d5..3ca6fc87f3 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -146,13 +146,21 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, ! Make sure XT doesn't get clobbered in stack frame -: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y ) - "void" +: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y ) + "int" f "ffi_test_31" { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } alien-invoke gc 3 ; -[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test +[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test + +: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result ) + "float" + f "ffi_test_31_point_5" + { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" } + alien-invoke ; + +[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test FUNCTION: longlong ffi_test_21 long x long y ; diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index c2ec6552cd..4e79c4cd2d 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -34,14 +34,10 @@ IN: compiler.tree.builder if ; : (build-tree-from-word) ( word -- ) - dup - [ "inline" word-prop ] - [ "recursive" word-prop ] bi and [ - 1quotation f initial-recursive-state infer-quot - ] [ - [ specialized-def ] [ initial-recursive-state ] bi - infer-quot - ] if ; + dup initial-recursive-state recursive-state set + dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and + [ 1quotation ] [ specialized-def ] if + infer-quot-here ; : check-cannot-infer ( word -- ) dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ; diff --git a/basis/compiler/tree/dead-code/liveness/liveness.factor b/basis/compiler/tree/dead-code/liveness/liveness.factor index 08bfde55b2..44b71935c8 100644 --- a/basis/compiler/tree/dead-code/liveness/liveness.factor +++ b/basis/compiler/tree/dead-code/liveness/liveness.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors namespaces assocs deques search-deques -kernel sequences sequences.deep words sets stack-checker.branches -compiler.tree compiler.tree.def-use compiler.tree.combinators ; +dlists kernel sequences sequences.deep words sets +stack-checker.branches compiler.tree compiler.tree.def-use +compiler.tree.combinators ; IN: compiler.tree.dead-code.liveness SYMBOL: work-list diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor index 9be9f13043..705f44eeb6 100644 --- a/basis/compiler/tree/def-use/def-use.factor +++ b/basis/compiler/tree/def-use/def-use.factor @@ -18,12 +18,16 @@ TUPLE: definition value node uses ; swap >>node V{ } clone >>uses ; +ERROR: no-def-error value ; + : def-of ( value -- definition ) - def-use get at* [ "No def" throw ] unless ; + dup def-use get at* [ nip ] [ no-def-error ] if ; + +ERROR: multiple-defs-error ; : def-value ( node value -- ) def-use get 2dup key? [ - "Multiple defs" throw + multiple-defs-error ] [ [ [ ] keep ] dip set-at ] if ; diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index d257cd6600..2e40693e69 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/basis/compiler/tree/recursive/recursive.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs arrays namespaces accessors sequences deques -search-deques compiler.tree compiler.tree.combinators ; +search-deques dlists compiler.tree compiler.tree.combinators ; IN: compiler.tree.recursive ! Collect label info diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index a23301c1e2..c61967fc8a 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -2,36 +2,42 @@ USING: help.markup help.syntax sequences ; IN: concurrency.combinators HELP: parallel-map -{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } } +{ $values { "seq" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: 2parallel-map -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: parallel-each -{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } +{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: 2parallel-each -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- )" } } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: parallel-filter -{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } } +{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." } { $errors "Throws an error if one of the iterations throws an error." } ; ARTICLE: "concurrency.combinators" "Concurrent combinators" -"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":" +"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators." +$nl +"Concurrent sequence combinators:" { $subsection parallel-each } { $subsection 2parallel-each } { $subsection parallel-map } { $subsection 2parallel-map } -{ $subsection parallel-filter } ; +{ $subsection parallel-filter } +"Concurrent cleave combinators:" +{ $subsection parallel-cleave } +{ $subsection parallel-spread } +{ $subsection parallel-napply } ; ABOUT: "concurrency.combinators" diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index 562111242d..3a38daed86 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -1,6 +1,7 @@ IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math -concurrency.mailboxes threads sequences accessors arrays ; +concurrency.mailboxes threads sequences accessors arrays +math.parser ; [ [ drop ] parallel-each ] must-infer { 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as @@ -45,3 +46,10 @@ concurrency.mailboxes threads sequences accessors arrays ; ] unit-test [ { f } [ "OOPS" throw ] parallel-each ] must-fail + +[ "1a" "4b" "3c" ] [ + 2 + { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave + [ number>string ] 3 parallel-napply + { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread +] unit-test diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor index ab3ca7ed4a..4608faf79b 100644 --- a/basis/concurrency/combinators/combinators.factor +++ b/basis/concurrency/combinators/combinators.factor @@ -1,34 +1,58 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.futures concurrency.count-downs sequences -kernel ; +kernel macros fry combinators generalizations ; IN: concurrency.combinators r r> keep await ; inline + [ ] dip keep await ; inline + PRIVATE> : parallel-each ( seq quot -- ) over length [ - [ >r curry r> spawn-stage ] 2curry each + '[ _ curry _ spawn-stage ] each ] (parallel-each) ; inline : 2parallel-each ( seq1 seq2 quot -- ) 2over min-length [ - [ >r 2curry r> spawn-stage ] 2curry 2each + '[ _ 2curry _ spawn-stage ] 2each ] (parallel-each) ; inline : parallel-filter ( seq quot -- newseq ) - over >r pusher >r each r> r> like ; inline + over [ pusher [ each ] dip ] dip like ; inline : parallel-map ( seq quot -- newseq ) - [ curry future ] curry map future-values ; - inline + [future] map future-values ; inline : 2parallel-map ( seq1 seq2 quot -- newseq ) - [ 2curry future ] curry 2map future-values ; + '[ _ 2curry future ] 2map future-values ; + + ; inline + +: (parallel-cleave) ( quots -- quot-array spread-array ) + [ [future] ] map dup length (parallel-spread) ; inline + +PRIVATE> + +MACRO: parallel-cleave ( quots -- ) + (parallel-cleave) '[ _ cleave _ spread ] ; + +MACRO: parallel-spread ( quots -- ) + (parallel-cleave) '[ _ spread _ spread ] ; + +MACRO: parallel-napply ( quot n -- ) + [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ; diff --git a/basis/concurrency/futures/futures-docs.factor b/basis/concurrency/futures/futures-docs.factor index 99b4bb6e81..22549c1720 100644 --- a/basis/concurrency/futures/futures-docs.factor +++ b/basis/concurrency/futures/futures-docs.factor @@ -5,7 +5,7 @@ continuations help.markup help.syntax quotations ; IN: concurrency.futures HELP: future -{ $values { "quot" "a quotation with stack effect " { $snippet "( -- value )" } } { "future" future } } +{ $values { "quot" { $quotation "( -- value )" } } { "future" future } } { $description "Creates a deferred computation." $nl "The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ; diff --git a/basis/concurrency/locks/locks-docs.factor b/basis/concurrency/locks/locks-docs.factor index a3cf2fc782..b74dcec384 100644 --- a/basis/concurrency/locks/locks-docs.factor +++ b/basis/concurrency/locks/locks-docs.factor @@ -14,7 +14,7 @@ HELP: { $description "Creates a reentrant lock." } ; HELP: with-lock-timeout -{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } +{ $values { "lock" lock } { "timeout" { $maybe duration } } { "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." } ; @@ -36,7 +36,7 @@ HELP: rw-lock { $class-description "The class of reader/writer locks." } ; HELP: with-read-lock-timeout -{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } +{ $values { "lock" lock } { "timeout" { $maybe duration } } { "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." } ; @@ -45,7 +45,7 @@ HELP: with-read-lock { $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 } } +{ $values { "lock" lock } { "timeout" { $maybe duration } } { "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." } ; diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor index a9b86e3bcd..234fb27d60 100644 --- a/basis/concurrency/mailboxes/mailboxes-docs.factor +++ b/basis/concurrency/mailboxes/mailboxes-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel arrays ; +USING: help.markup help.syntax kernel arrays calendar ; IN: concurrency.mailboxes HELP: @@ -18,46 +18,41 @@ HELP: mailbox-put { $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ; HELP: block-unless-pred -{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } - { "mailbox" mailbox } - { "timeout" "a timeout in milliseconds, or " { $link f } } +{ $values { "pred" { $quotation "( obj -- ? )" } } + { "mailbox" mailbox } + { "timeout" "a " { $link duration } " or " { $link f } } } { $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ; HELP: block-if-empty { $values { "mailbox" mailbox } - { "timeout" "a timeout in milliseconds, or " { $link f } } + { "timeout" "a " { $link duration } " or " { $link f } } } { $description "Block the thread if the mailbox is empty." } ; HELP: mailbox-get -{ $values { "mailbox" mailbox } - { "obj" object } -} +{ $values { "mailbox" mailbox } { "obj" object } } { $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ; HELP: mailbox-get-all -{ $values { "mailbox" mailbox } - { "array" array } -} +{ $values { "mailbox" mailbox } { "array" array } } { $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ; HELP: while-mailbox-empty { $values { "mailbox" mailbox } - { "quot" "a quotation with stack effect " { $snippet "( -- )" } } + { "quot" { $quotation "( -- )" } } } { $description "Repeatedly call the quotation while there are no items in the mailbox." } ; HELP: mailbox-get? { $values { "mailbox" mailbox } - { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } + { "pred" { $quotation "( obj -- ? )" } } { "obj" object } } -{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ; - +{ $description "Get the first item in the mailbox which satisfies the predicate. When the predicate returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ; ARTICLE: "concurrency.mailboxes" "Mailboxes" -"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary." +"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary." { $subsection mailbox } { $subsection } "Removing the first element:" diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor index 6a4a2bf8d6..be7a8cf65b 100644 --- a/basis/concurrency/promises/promises-docs.factor +++ b/basis/concurrency/promises/promises-docs.factor @@ -12,7 +12,7 @@ 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 " { $link duration } " or " { $link f } } { "result" object } } +{ $values { "promise" promise } { "timeout" { $maybe duration } } { "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." } ; diff --git a/basis/concurrency/semaphores/semaphores-docs.factor b/basis/concurrency/semaphores/semaphores-docs.factor index 379fd6a3a0..c86623f86f 100644 --- a/basis/concurrency/semaphores/semaphores-docs.factor +++ b/basis/concurrency/semaphores/semaphores-docs.factor @@ -9,7 +9,7 @@ HELP: { $description "Creates a counting semaphore with the specified initial count." } ; HELP: acquire-timeout -{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } } +{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } } { $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." } ; @@ -22,7 +22,7 @@ HELP: release { $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ; HELP: with-semaphore-timeout -{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } } +{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } { "quot" quotation } } { $description "Calls the quotation with the semaphore held." } ; HELP: with-semaphore diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 96dd577c10..d26e7f6ff7 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -141,10 +141,10 @@ HOOK: %loop-entry cpu ( -- ) HOOK: small-enough? cpu ( n -- ? ) ! Is this structure small enough to be returned in registers? -HOOK: struct-small-enough? cpu ( heap-size -- ? ) +HOOK: struct-small-enough? cpu ( c-type -- ? ) -! Do we pass value structs by value or hidden reference? -HOOK: value-structs? cpu ( -- ? ) +! Do we pass this struct by value or hidden reference? +HOOK: value-struct? cpu ( c-type -- ? ) ! If t, all parameters are shadowed by dummy stack parameters HOOK: dummy-stack-params? cpu ( -- ? ) @@ -207,14 +207,3 @@ M: object %callback-return drop %return ; M: stack-params param-reg drop ; M: stack-params param-regs drop f ; - -: if-small-struct ( n size true false -- ? ) - [ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip - [ '[ nip @ ] ] dip if ; - inline - -: %unbox-struct ( n c-type -- ) - [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; - -: %box-struct ( n c-type -- ) - [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor index 090495aa11..5cfa1391c4 100644 --- a/basis/cpu/ppc/linux/linux.factor +++ b/basis/cpu/ppc/linux/linux.factor @@ -15,7 +15,7 @@ M: linux lr-save 1 cells ; M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ; -M: ppc value-structs? f ; +M: ppc value-struct? drop f ; M: ppc dummy-stack-params? f ; diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor index 877fb37d31..c742cf2ddc 100644 --- a/basis/cpu/ppc/macosx/macosx.factor +++ b/basis/cpu/ppc/macosx/macosx.factor @@ -16,7 +16,7 @@ M: macosx lr-save 2 cells ; M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; -M: ppc value-structs? t ; +M: ppc value-struct? drop t ; M: ppc dummy-stack-params? t ; diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 0124c40877..9108c0e8f7 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel layouts system math alien.c-types +USING: kernel layouts system math alien.c-types sequences compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ; IN: cpu.x86.64.winnt @@ -10,8 +10,9 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ; M: x86.64 reserved-area-size 4 cells ; -M: x86.64 struct-small-enough? ( size -- ? ) - heap-size cell <= ; +M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ; + +M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ; M: x86.64 dummy-stack-params? f ; @@ -21,6 +22,7 @@ M: x86.64 dummy-fp-params? t ; << "longlong" "ptrdiff_t" typedef +"longlong" "intptr_t" typedef "int" "long" typedef "uint" "ulong" typedef >> diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index dfe3d3e55e..58d95ffcde 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -507,7 +507,7 @@ M: x86 %prepare-alien-invoke temp-reg-1 2 cells [+] ds-reg MOV temp-reg-1 3 cells [+] rs-reg MOV ; -M: x86 value-structs? t ; +M: x86 value-struct? drop t ; M: x86 small-enough? ( n -- ? ) HEX: -80000000 HEX: 7fffffff between? ; diff --git a/basis/deques/deques-docs.factor b/basis/deques/deques-docs.factor index 58f077ed1e..e747bd9316 100644 --- a/basis/deques/deques-docs.factor +++ b/basis/deques/deques-docs.factor @@ -4,7 +4,7 @@ IN: deques HELP: deque-empty? { $values { "deque" deque } { "?" "a boolean" } } -{ $description "Returns true if a deque is empty." } +{ $contract "Returns true if a deque is empty." } { $notes "This operation is O(1)." } ; HELP: clear-deque @@ -12,12 +12,6 @@ HELP: clear-deque { "deque" deque } } { $description "Removes all elements from a deque." } ; -HELP: deque-length -{ $values - { "deque" deque } - { "n" integer } } -{ $description "Returns the number of elements in a deque." } ; - HELP: deque-member? { $values { "value" object } { "deque" deque } @@ -31,7 +25,7 @@ HELP: push-front HELP: push-front* { $values { "obj" object } { "deque" deque } { "node" "a node" } } -{ $description "Push the object onto the front of the deque and return the newly created node." } +{ $contract "Push the object onto the front of the deque and return the newly created node." } { $notes "This operation is O(1)." } ; HELP: push-back @@ -41,7 +35,7 @@ HELP: push-back HELP: push-back* { $values { "obj" object } { "deque" deque } { "node" "a node" } } -{ $description "Push the object onto the back of the deque and return the newly created node." } +{ $contract "Push the object onto the back of the deque and return the newly created node." } { $notes "This operation is O(1)." } ; HELP: push-all-back @@ -56,7 +50,7 @@ HELP: push-all-front HELP: peek-front { $values { "deque" deque } { "obj" object } } -{ $description "Returns the object at the front of the deque." } ; +{ $contract "Returns the object at the front of the deque." } ; HELP: pop-front { $values { "deque" deque } { "obj" object } } @@ -65,12 +59,12 @@ HELP: pop-front HELP: pop-front* { $values { "deque" deque } } -{ $description "Pop the object off the front of the deque." } +{ $contract "Pop the object off the front of the deque." } { $notes "This operation is O(1)." } ; HELP: peek-back { $values { "deque" deque } { "obj" object } } -{ $description "Returns the object at the back of the deque." } ; +{ $contract "Returns the object at the back of the deque." } ; HELP: pop-back { $values { "deque" deque } { "obj" object } } @@ -79,13 +73,13 @@ HELP: pop-back HELP: pop-back* { $values { "deque" deque } } -{ $description "Pop the object off the back of the deque." } +{ $contract "Pop the object off the back of the deque." } { $notes "This operation is O(1)." } ; HELP: delete-node { $values { "node" object } { "deque" deque } } -{ $description "Deletes the node from the deque." } ; +{ $contract "Deletes the node from the deque." } ; HELP: deque { $description "A data structure that has constant-time insertion and removal of elements at both ends." } ; @@ -111,7 +105,7 @@ $nl "Querying the deque:" { $subsection peek-front } { $subsection peek-back } -{ $subsection deque-length } +{ $subsection deque-empty? } { $subsection deque-member? } "Adding and removing elements:" { $subsection push-front* } @@ -123,7 +117,6 @@ $nl { $subsection delete-node } { $subsection node-value } "Utility operations built in terms of the above:" -{ $subsection deque-empty? } { $subsection push-front } { $subsection push-all-front } { $subsection push-back } diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor index 1d86a3f1db..f4e68c214b 100644 --- a/basis/deques/deques.factor +++ b/basis/deques/deques.factor @@ -10,13 +10,10 @@ GENERIC: peek-back ( deque -- obj ) GENERIC: pop-front* ( deque -- ) GENERIC: pop-back* ( deque -- ) GENERIC: delete-node ( node deque -- ) -GENERIC: deque-length ( deque -- n ) GENERIC: deque-member? ( value deque -- ? ) GENERIC: clear-deque ( deque -- ) GENERIC: node-value ( node -- value ) - -: deque-empty? ( deque -- ? ) - deque-length zero? ; +GENERIC: deque-empty? ( deque -- ? ) : push-front ( obj deque -- ) push-front* drop ; diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 557010cf7c..ef6087f852 100644 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel quotations -deques ; +deques search-deques hashtables ; IN: dlists ARTICLE: "dlists" "Double-linked lists" @@ -18,10 +18,20 @@ $nl { $subsection dlist-contains? } "Deleting a node matching a predicate:" { $subsection delete-node-if* } -{ $subsection delete-node-if } ; +{ $subsection delete-node-if } +"Search deque implementation:" +{ $subsection } ; ABOUT: "dlists" +HELP: +{ $values { "list" dlist } } +{ $description "Creates a new double-linked list." } ; + +HELP: +{ $values { "search-deque" search-deque } } +{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ; + HELP: dlist-find { $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 92b141dca8..6df3e306dd 100644 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -5,7 +5,7 @@ IN: dlists.tests [ t ] [ deque-empty? ] unit-test -[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ] +[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } } ] [ 1 over push-front ] unit-test ! Make sure empty lists are empty @@ -17,10 +17,10 @@ IN: dlists.tests [ 1 ] [ 1 over push-front pop-back ] unit-test [ 1 ] [ 1 over push-back pop-front ] unit-test [ 1 ] [ 1 over push-back pop-back ] unit-test -[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-front* ] unit-test -[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-back* ] unit-test -[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-front* ] unit-test -[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-back* ] unit-test +[ T{ dlist f f f } ] [ 1 over push-front dup pop-front* ] unit-test +[ T{ dlist f f f } ] [ 1 over push-front dup pop-back* ] unit-test +[ T{ dlist f f f } ] [ 1 over push-back dup pop-front* ] unit-test +[ T{ dlist f f f } ] [ 1 over push-back dup pop-back* ] unit-test ! Test the prev,next links for two nodes [ f ] [ @@ -52,15 +52,6 @@ IN: dlists.tests [ 1 ] [ 1 over push-back [ 1 = ] delete-node-if ] unit-test [ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test [ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test -[ 0 ] [ 1 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test -[ 1 ] [ 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop deque-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop deque-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop deque-length ] unit-test - -[ 0 ] [ deque-length ] unit-test -[ 1 ] [ 1 over push-front deque-length ] unit-test -[ 0 ] [ 1 over push-front dup pop-front* deque-length ] unit-test [ t ] [ 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test [ t ] [ 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 5072c3edfd..549dbf947d 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -2,51 +2,57 @@ ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel math sequences accessors deques -summary ; +search-deques summary hashtables ; IN: dlists -TUPLE: dlist front back length ; - -: ( -- obj ) - dlist new - 0 >>length ; - -M: dlist deque-length length>> ; - dlist-node +PRIVATE> + +TUPLE: dlist +{ front ?dlist-node } +{ back ?dlist-node } ; + +: ( -- list ) + dlist new ; inline + +: ( -- search-deque ) + 20 ; + +M: dlist deque-empty? front>> not ; + M: dlist-node node-value obj>> ; -: inc-length ( dlist -- ) - [ 1+ ] change-length drop ; inline - -: dec-length ( dlist -- ) - [ 1- ] change-length drop ; inline - : set-prev-when ( dlist-node dlist-node/f -- ) - [ (>>prev) ] [ drop ] if* ; + [ (>>prev) ] [ drop ] if* ; inline : set-next-when ( dlist-node dlist-node/f -- ) - [ (>>next) ] [ drop ] if* ; + [ (>>next) ] [ drop ] if* ; inline : set-next-prev ( dlist-node -- ) - dup next>> set-prev-when ; + dup next>> set-prev-when ; inline : normalize-front ( dlist -- ) - dup back>> [ f >>front ] unless drop ; + dup back>> [ f >>front ] unless drop ; inline : normalize-back ( dlist -- ) - dup front>> [ f >>back ] unless drop ; + dup front>> [ f >>back ] unless drop ; inline : set-back-to-front ( dlist -- ) - dup back>> [ dup front>> >>back ] unless drop ; + dup back>> [ dup front>> >>back ] unless drop ; inline : set-front-to-back ( dlist -- ) - dup front>> [ dup back>> >>front ] unless drop ; + dup front>> [ dup back>> >>front ] unless drop ; inline : (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? ) over [ @@ -62,22 +68,20 @@ M: dlist-node node-value obj>> ; : unlink-node ( dlist-node -- ) dup prev>> over next>> set-prev-when - dup next>> swap prev>> set-next-when ; + dup next>> swap prev>> set-next-when ; inline PRIVATE> M: dlist push-front* ( obj dlist -- dlist-node ) [ front>> f swap dup dup set-next-prev ] keep [ (>>front) ] keep - [ set-back-to-front ] keep - inc-length ; + set-back-to-front ; M: dlist push-back* ( obj dlist -- dlist-node ) [ back>> f ] keep [ back>> set-next-when ] 2keep [ (>>back) ] 2keep - [ set-front-to-back ] keep - inc-length ; + set-front-to-back ; ERROR: empty-dlist ; @@ -88,31 +92,27 @@ M: dlist peek-front ( dlist -- obj ) front>> [ obj>> ] [ empty-dlist ] if* ; M: dlist pop-front* ( dlist -- ) - dup front>> [ empty-dlist ] unless [ - dup front>> + dup front>> [ empty-dlist ] unless* dup next>> f rot (>>next) f over set-prev-when swap (>>front) ] keep - [ normalize-back ] keep - dec-length ; + normalize-back ; M: dlist peek-back ( dlist -- obj ) back>> [ obj>> ] [ empty-dlist ] if* ; M: dlist pop-back* ( dlist -- ) - dup back>> [ empty-dlist ] unless [ - dup back>> + dup back>> [ empty-dlist ] unless* dup prev>> f rot (>>prev) f over set-next-when swap (>>back) ] keep - [ normalize-front ] keep - dec-length ; + normalize-front ; : dlist-find ( dlist quot -- obj/f ? ) [ obj>> ] prepose @@ -128,7 +128,7 @@ M: dlist delete-node ( dlist-node dlist -- ) { { [ 2dup front>> eq? ] [ nip pop-front* ] } { [ 2dup back>> eq? ] [ nip pop-back* ] } - [ dec-length unlink-node ] + [ drop unlink-node ] } cond ; : delete-node-if* ( dlist quot -- obj/f ? ) @@ -148,7 +148,6 @@ M: dlist delete-node ( dlist-node dlist -- ) M: dlist clear-deque ( dlist -- ) f >>front f >>back - 0 >>length drop ; : dlist-each ( dlist quot -- ) diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor index 61fab306a2..974645b284 100644 --- a/basis/documents/documents-docs.factor +++ b/basis/documents/documents-docs.factor @@ -42,7 +42,7 @@ HELP: doc-lines { $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ; HELP: each-line -{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" "a quotation with stack effect " { $snippet "( string -- )" } } } +{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( string -- )" } } } { $description "Applies the quotation to each line in the range." } { $notes "The range is created by calling " { $link } "." } { $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ; diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index 1550fccc0b..79387f9820 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -1,11 +1,11 @@ USING: definitions io.launcher kernel parser words sequences math -math.parser namespaces editors make ; +math.parser namespaces editors make system ; IN: editors.emacs : emacsclient ( file line -- ) [ \ emacsclient get "emacsclient" or , - "--no-wait" , + os windows? [ "--no-wait" , ] unless "+" swap number>string append , , ] { } make try-process ; diff --git a/basis/freetype/freetype.factor b/basis/freetype/freetype.factor index 8572a8bd91..683169e394 100644 --- a/basis/freetype/freetype.factor +++ b/basis/freetype/freetype.factor @@ -64,7 +64,7 @@ C-STRUCT: glyph { "FT_Pos" "advance-x" } { "FT_Pos" "advance-y" } - { "long" "format" } + { "intptr_t" "format" } { "int" "bitmap-rows" } { "int" "bitmap-width" } diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 286dbb469e..8f402f2e8c 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -15,7 +15,7 @@ HELP: fry } ; HELP: '[ -{ $syntax "code... ]" } +{ $syntax "'[ code... ]" } { $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." } { $examples "See " { $link "fry.examples" } "." } ; @@ -49,6 +49,8 @@ $nl "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map" "{ 8 13 14 27 } [ even? dup 5 ? ] map" } +"The following is a no-op:" +{ $code "'[ @ ]" } "Here are some built-in combinators rewritten in terms of fried quotations:" { $table { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } @@ -74,18 +76,21 @@ ARTICLE: "fry.limitations" "Fried quotation limitations" "As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ; ARTICLE: "fry" "Fried quotations" -"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation." +"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack." $nl -"Fried quotations are denoted with a special parsing word:" +"Fried quotations are started by a special parsing word:" { $subsection POSTPONE: '[ } -"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":" +"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:" { $subsection _ } { $subsection @ } -"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left." +"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on." { $subsection "fry.examples" } { $subsection "fry.philosophy" } { $subsection "fry.limitations" } -"Quotations can also be fried without using a parsing word:" -{ $subsection fry } ; +"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)." +$nl +"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:" +{ $subsection fry } +"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ; ABOUT: "fry" diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor index 128ec448b7..0fe80427b9 100644 --- a/basis/furnace/alloy/alloy.factor +++ b/basis/furnace/alloy/alloy.factor @@ -4,7 +4,6 @@ USING: kernel sequences db.tuples alarms calendar db fry furnace.db furnace.cache furnace.asides -furnace.referrer furnace.sessions furnace.conversations furnace.auth.providers @@ -24,8 +23,7 @@ IN: furnace.alloy ] dip - - ; + ; : start-expiring ( db -- ) '[ diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor new file mode 100644 index 0000000000..e7e722344a --- /dev/null +++ b/basis/furnace/auth/auth-docs.factor @@ -0,0 +1,193 @@ +USING: assocs classes help.markup help.syntax kernel +quotations strings words furnace.auth.providers.db +checksums.sha2 furnace.auth.providers math byte-arrays +http multiline ; +IN: furnace.auth + +HELP: +{ $values + { "responder" "a responder" } + { "protected" "a new responder" } +} +{ $description "Wraps a responder in a protected responder. Access to the wrapped responder will be conditional upon the client authenticating with the current authentication realm." } ; + +HELP: >>encoded-password +{ $values { "user" user } { "string" string } } +{ $description "Sets the user's password by combining it with a random salt and encoding it with the current authentication realm's checksum." } ; + +HELP: capabilities +{ $var-description "Global variable holding all defined capabilities. New capabilities may be defined with " { $link define-capability } "." } ; + +HELP: check-login +{ $values { "password" string } { "username" string } { "user/f" { $maybe user } } } +{ $description "Checks a username/password pair with the current authentication realm. Outputs a user if authentication succeeded, otherwise outputs " { $link f } "." } ; + +HELP: define-capability +{ $values { "word" symbol } } +{ $description "Defines a new capability by adding it to the " { $link capabilities } " global variable." } ; + +HELP: encode-password +{ $values + { "string" string } { "salt" integer } + { "bytes" byte-array } +} +{ $description "Encodes a password with the current authentication realm's checksum." } ; + +HELP: have-capabilities? +{ $values + { "capabilities" "a sequence of capabilities" } + { "?" "a boolean" } +} +{ $description "Tests if the currently logged-in user possesses the given capabilities." } ; + +HELP: logged-in-user +{ $var-description "Holds the currently logged-in user." } ; + +HELP: login-required +{ $values + { "description" string } { "capabilities" "a sequence of capabilities" } +} +{ $description "Redirects the client to a login page." } ; + +HELP: login-required* +{ $values + { "description" string } { "capabilities" "a sequence of capabilities" } { "realm" "an authenticaiton realm" } + { "response" response } +} +{ $contract "Constructs an HTTP response for redirecting the client to a login page." } ; + +HELP: protected +{ $class-description "The class of protected responders. See " { $link "furnace.auth.protected" } " for a description of usage and slots." } ; + +HELP: realm +{ $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ; + +HELP: uchange +{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } } +{ $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ; + +HELP: uget +{ $values { "key" symbol } { "value" object } } +{ $description "Outputs the value of a user profile variable." } ; + +HELP: uset +{ $values { "value" object } { "key" symbol } } +{ $description "Sets the value of a user profile variable." } ; + +HELP: username +{ $values { "string/f" { $maybe string } } +} +{ $description "Outputs the currently logged-in username, or " { $link f } " if no user is logged in." } ; +HELP: users +{ $values { "provider" "an authentication provider" } } +{ $description "Outputs the current authentication provider." } ; + +ARTICLE: "furnace.auth.capabilities" "Authentication capabilities" +"Every user in the authentication framework has a set of associated capabilities." +$nl +"Defining new capabilities:" +{ $subsection define-capability } +"Capabilities are stored in a global variable:" +{ $subsection capabilities } +"Protected resources can be restricted to users possessing certain capabilities only by storing a sequence of capabilities in the " { $slot "capabilities" } " slot of a " { $link protected } " instance." ; + +ARTICLE: "furnace.auth.protected" "Protected resources" +"To restrict access to authenticated clients only, wrap a responder in a protected responder." +{ $subsection protected } +{ $subsection } +"Protected responders have the following two slots which may be set:" +{ $table + { { $slot "description" } "A string identifying the protected resource for user interface purposes" } + { { $slot "capabilities" } { "A sequence of capabilities; see " { $link "furnace.auth.capabilities" } } } +} ; + +ARTICLE: "furnace.auth.realm-config" "Authentication realm configuration" +"Instances of subclasses of " { $link realm } " have the following slots which may be set:" +{ $table + { { $slot "name" } "A string identifying the realm for user interface purposes" } + { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } ". By default, the " { $link users-in-db } " provider is used." } } + { { $slot "checksum" } { "An implementation of the checksum protocol used for verifying passwords (see " { $link "checksums" } "). The " { $link sha-256 } " checksum is used by default." } } + { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } } } + { { $slot "secure" } { "A boolean, that when set to a true value, forces the client to access the authentication realm via HTTPS. An attempt to access the realm via HTTP results in a redirect to the corresponding HTTPS URL. On by default." } } +} ; + +ARTICLE: "furnace.auth.providers" "Authentication providers" +"The " { $vocab-link "furnace.auth" } " framework looks up users using an authentication provider. Different authentication providers can be swapped in to implement various authentication strategies." +$nl +"Each authentication realm has a provider stored in the " { $slot "users" } " slot. The default provider is " { $link users-in-db } "." +{ $subsection "furnace.auth.providers.protocol" } +{ $subsection "furnace.auth.providers.null" } +{ $subsection "furnace.auth.providers.assoc" } +{ $subsection "furnace.auth.providers.db" } ; + +ARTICLE: "furnace.auth.features" "Optional authentication features" +"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm." +{ $subsection "furnace.auth.features.deactivate-user" } +{ $subsection "furnace.auth.features.edit-profile" } +{ $subsection "furnace.auth.features.recover-password" } +{ $subsection "furnace.auth.features.registration" } ; + +ARTICLE: "furnace.auth.realms" "Authentication realms" +"The superclass of authentication realms:" +{ $subsection realm } +"There are two concrete implementations:" +{ $subsection "furnace.auth.basic" } +{ $subsection "furnace.auth.login" } +"Authentication realms need to be configured after construction." +{ $subsection "furnace.auth.realm-config" } ; + +ARTICLE: "furnace.auth.users" "User profiles" +"A responder wrapped in an authentication realm may access the currently logged-in user," +{ $subsection logged-in-user } +"as well as the logged-in username:" +{ $subsection username } +"Values can also be stored in user profile variables:" +{ $subsection uget } +{ $subsection uset } +{ $subsection uchange } +"User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ; + +ARTICLE: "furnace.auth.example" "Furnace authentication example" +"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':" +{ $code + <" + "view your todo list" >>description"> +} +"The " { $vocab-link "webapps.wiki" } " vocabulary defines a mix of protected and unprotected actions. One example of a protected action is that for deleting wiki pages, an action normally reserved for administrators. This action is protected with the following code:" +{ $code + <" + "delete wiki articles" >>description + { can-delete-wiki-articles? } >>capabilities"> +} +"The " { $vocab-link "websites.concatenative" } " vocabulary wraps all of its responders, including the wiki, in a login authentication realm:" +{ $code +<" : ( responder -- responder' ) + "Factor website" + "Factor website" >>name + allow-registration + allow-password-recovery + allow-edit-profile + allow-deactivation ;"> +} ; + +ARTICLE: "furnace.auth" "Furnace authentication" +"The " { $vocab-link "furnace.auth" } " vocabulary implements a pluggable authentication framework." +$nl +"Usernames and passwords are verified using an " { $emphasis "authentication provider" } "." +{ $subsection "furnace.auth.providers" } +"Users have capabilities assigned to them." +{ $subsection "furnace.auth.capabilities" } +"An " { $emphasis "authentication realm" } " is a responder which manages access to protected resources." +{ $subsection "furnace.auth.realms" } +"Actions contained inside an authentication realm can be protected by wrapping them with a responder." +{ $subsection "furnace.auth.protected" } +"Actions contained inside an authentication realm can access the currently logged-in user profile." +{ $subsection "furnace.auth.users" } +"Authentication realms can be adorned with additional functionality." +{ $subsection "furnace.auth.features" } +"An administration tool." +{ $subsection "furnace.auth.user-admin" } +"A concrete example." +{ $subsection "furnace.auth.example" } ; + +ABOUT: "furnace.auth" diff --git a/basis/furnace/auth/basic/basic-docs.factor b/basis/furnace/auth/basic/basic-docs.factor new file mode 100644 index 0000000000..c0d3184c78 --- /dev/null +++ b/basis/furnace/auth/basic/basic-docs.factor @@ -0,0 +1,16 @@ +USING: help.markup help.syntax ; +IN: furnace.auth.basic + +HELP: +{ $values { "responder" "a responder" } { "name" "an authentication realm name" } { "realm" basic-auth-realm } } +{ $description "Wraps a responder in a basic authentication realm. The realm must be configured before use; see " { $link "furnace.auth.realm-config" } "." } ; + +HELP: basic-auth-realm +{ $class-description "The basic authentication realm class. Slots are described in " { $link "furnace.auth.realm-config" } "." } ; + +ARTICLE: "furnace.auth.basic" "Basic authentication" +"The " { $vocab-link "furnace.auth.basic" } " vocabulary implements HTTP basic authentication." +{ $subsection basic-auth-realm } +{ $subsection } ; + +ABOUT: "furnace.auth.basic" diff --git a/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor new file mode 100644 index 0000000000..ef4f2e1075 --- /dev/null +++ b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor @@ -0,0 +1,26 @@ +USING: help.markup help.syntax kernel ; +IN: furnace.auth.features.deactivate-user + +HELP: allow-deactivation +{ $values { "realm" "an authentication realm" } } +{ $description "Adds a " { $snippet "deactivate-user" } " action to an authentication realm." } ; + +HELP: allow-deactivation? +{ $values { "?" "a boolean" } } +{ $description "Outputs true if the current authentication realm allows user profile deactivation." } ; + +ARTICLE: "furnace.auth.features.deactivate-user" "User profile deactivation" +"The " { $vocab-link "furnace.auth.features.deactivate-user" } " vocabulary implements an authentication feature for user profile deactivation, allowing users to voluntarily deactivate their account." +$nl +"To enable this feature, call the following word on an authentication realm:" +{ $subsection allow-deactivation } +"To check if deactivation is enabled:" +{ $subsection allow-deactivation? } +"This feature adds a " { $snippet "deactivate-user" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" +{ $code + "" + " Deactivate user" + "" +} ; + +ABOUT: "furnace.auth.features.deactivate-user" diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor new file mode 100644 index 0000000000..6f3c9d151b --- /dev/null +++ b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor @@ -0,0 +1,24 @@ +USING: help.markup help.syntax kernel ; +IN: furnace.auth.features.edit-profile + +HELP: allow-edit-profile +{ $values { "realm" "an authentication realm" } } +{ $description "Adds an " { $snippet "edit-profile" } " action to an authentication realm." } ; + +HELP: allow-edit-profile? +{ $values { "?" "a boolean" } } +{ $description "Outputs true if the current authentication realm allows user profile editing." } ; + +ARTICLE: "furnace.auth.features.edit-profile" "User profile editing" +"The " { $vocab-link "furnace.auth.features.edit-profile" } " vocabulary implements an authentication feature for user profile editing, allowing users to change some details of their account." +$nl +"To enable this feature, call the following word on an authentication realm:" +{ $subsection allow-edit-profile } +"To check if profile editing is enabled:" +{ $subsection allow-edit-profile? } +"This feature adds an " { $snippet "edit-profile" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" +{ $code + "" + " Edit profile" + "" +} ; diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor index 243ea7bfff..cefb472b22 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile.factor @@ -58,7 +58,7 @@ IN: furnace.auth.features.edit-profile "edit your profile" >>description ; -: allow-edit-profile ( login -- login ) +: allow-edit-profile ( realm -- realm ) "edit-profile" add-responder ; : allow-edit-profile? ( -- ? ) diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.xml b/basis/furnace/auth/features/edit-profile/edit-profile.xml index 878bdd64fb..f85869e56a 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile.xml +++ b/basis/furnace/auth/features/edit-profile/edit-profile.xml @@ -61,7 +61,7 @@

- +

diff --git a/basis/furnace/auth/features/recover-password/recover-1.xml b/basis/furnace/auth/features/recover-password/recover-1.xml index a8b67513a4..6dc882538e 100644 --- a/basis/furnace/auth/features/recover-password/recover-1.xml +++ b/basis/furnace/auth/features/recover-password/recover-1.xml @@ -32,7 +32,7 @@ - + diff --git a/basis/furnace/auth/features/recover-password/recover-3.xml b/basis/furnace/auth/features/recover-password/recover-3.xml index 2df400ffe2..ec68e27947 100644 --- a/basis/furnace/auth/features/recover-password/recover-3.xml +++ b/basis/furnace/auth/features/recover-password/recover-3.xml @@ -31,7 +31,7 @@

- +

diff --git a/basis/furnace/auth/features/recover-password/recover-password-docs.factor b/basis/furnace/auth/features/recover-password/recover-password-docs.factor new file mode 100644 index 0000000000..1dc7e99eff --- /dev/null +++ b/basis/furnace/auth/features/recover-password/recover-password-docs.factor @@ -0,0 +1,34 @@ +USING: help.markup help.syntax kernel strings urls ; +IN: furnace.auth.features.recover-password + +HELP: allow-password-recovery +{ $values { "realm" "an authentication realm" } } +{ $description "Adds a " { $snippet "recover-password" } " action to an authentication realm." } ; + +HELP: allow-password-recovery? +{ $values { "?" "a boolean" } } +{ $description "Outputs true if the current authentication realm allows user password recovery." } ; + +HELP: lost-password-from +{ $var-description "A variable with the source e-mail address of password recovery e-mails." } ; + +ARTICLE: "furnace.auth.features.recover-password" "User password recovery" +"The " { $vocab-link "furnace.auth.features.recover-password" } +" vocabulary implements an authentication feature for user password recovery, allowing users to get a new password e-mailed to them in the event they forget their current one." +$nl +"To enable this feature, first call the following word on an authentication realm," +{ $subsection allow-password-recovery } +"Then set a global configuration variable:" +{ $subsection lost-password-from } +"In addition, the " { $link "smtp" } " may need to be configured as well." +$nl +"To check if password recovery is enabled:" +{ $subsection allow-password-recovery? } +"This feature adds a " { $snippet "recover-password" } " action to the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" +{ $code + "" + " Recover password" + "" +} ; + +ABOUT: "furnace.auth.features.recover-password" diff --git a/basis/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor index 49e692d5a6..5885aaef61 100644 --- a/basis/furnace/auth/features/recover-password/recover-password.factor +++ b/basis/furnace/auth/features/recover-password/recover-password.factor @@ -110,7 +110,7 @@ SYMBOL: lost-password-from { realm "features/recover-password/recover-4" } >>template ; -: allow-password-recovery ( login -- login ) +: allow-password-recovery ( realm -- realm ) "recover-password" add-responder diff --git a/basis/furnace/auth/features/registration/register.xml b/basis/furnace/auth/features/registration/register.xml index 45c090905e..1e2fec6dd0 100644 --- a/basis/furnace/auth/features/registration/register.xml +++ b/basis/furnace/auth/features/registration/register.xml @@ -62,7 +62,7 @@

- +

diff --git a/basis/furnace/auth/features/registration/registration-docs.factor b/basis/furnace/auth/features/registration/registration-docs.factor new file mode 100644 index 0000000000..1f12570173 --- /dev/null +++ b/basis/furnace/auth/features/registration/registration-docs.factor @@ -0,0 +1,24 @@ +USING: help.markup help.syntax kernel ; +IN: furnace.auth.features.registration + +HELP: allow-registration +{ $values { "realm" "an authentication realm" } } +{ $description "Adds a " { $snippet "registration" } " action to an authentication realm." } ; + +HELP: allow-registration? +{ $values { "?" "a boolean" } } +{ $description "Outputs true if the current authentication realm allows user registration." } ; + +ARTICLE: "furnace.auth.features.registration" "User registration" +"The " { $vocab-link "furnace.auth.features.registration" } " vocabulary implements an authentication feature for user registration, allowing new users to create accounts." +$nl +"To enable this feature, call the following word on an authentication realm:" +{ $subsection allow-registration } +"To check if user registration is enabled:" +{ $subsection allow-registration? } +"This feature adds a " { $snippet "register" } " action to the realm. A link to this action is inserted on the login page if the " { $vocab-link "furnace.auth.login" } " authentication realm is used. Links to this action can be inserted from other pages using the following Chloe XML snippet:" +{ $code + "" + " Register" + "" +} ; diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor index ef8923c98b..0484c11727 100644 --- a/basis/furnace/auth/features/registration/registration.factor +++ b/basis/furnace/auth/features/registration/registration.factor @@ -38,7 +38,7 @@ IN: furnace.auth.features.registration ; -: allow-registration ( login -- login ) +: allow-registration ( realm -- realm ) "register" add-responder ; : allow-registration? ( -- ? ) diff --git a/basis/furnace/auth/login/login-docs.factor b/basis/furnace/auth/login/login-docs.factor new file mode 100644 index 0000000000..08b7d933e6 --- /dev/null +++ b/basis/furnace/auth/login/login-docs.factor @@ -0,0 +1,23 @@ +USING: help.markup help.syntax kernel strings ; +IN: furnace.auth.login + +HELP: +{ $values + { "responder" "a responder" } { "name" string } + { "realm" "a new responder" } +} +{ $description "Wraps a responder in a new login realm with the given name. The realm must be configured before use; see " { $link "furnace.auth.realm-config" } "." } ; + +HELP: login-realm +{ $class-description "The login realm class. Slots are described in " { $link "furnace.auth.realm-config" } "." } ; + +ARTICLE: "furnace.auth.login" "Login authentication" +"The " { $vocab-link "furnace.auth.login" } " vocabulary implements an authentication realm which displays a login page with a username and password field." +{ $subsection login-realm } +{ $subsection } +"The " { $snippet "logout" } " action logs the user out of the realm, and a link to this action can be inserted in Chloe templates using the following XML snippet:" +{ $code + "Logout" +} ; + +ABOUT: "furnace.auth.login" diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index 2c98672490..4fc4e7e8be 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -58,9 +58,13 @@ M: login-realm modify-form ( responder -- ) permit-id get [ delete-permit ] when* URL" $realm" end-aside ; + + : flashed-variables { description capabilities } ; : login-failed ( -- * ) @@ -107,7 +111,7 @@ M: login-realm login-required* ( description capabilities login -- response ) M: login-realm user-registered ( user realm -- ) drop successful-login ; -: ( responder name -- auth ) +: ( responder name -- realm ) login-realm new-realm "login" add-responder "logout" add-responder diff --git a/basis/furnace/auth/login/login.xml b/basis/furnace/auth/login/login.xml index 917c182fb3..9a37174e95 100644 --- a/basis/furnace/auth/login/login.xml +++ b/basis/furnace/auth/login/login.xml @@ -35,7 +35,7 @@

- +

diff --git a/basis/furnace/auth/providers/assoc/assoc-docs.factor b/basis/furnace/auth/providers/assoc/assoc-docs.factor new file mode 100644 index 0000000000..61c2ac4eed --- /dev/null +++ b/basis/furnace/auth/providers/assoc/assoc-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax io.streams.string ; +IN: furnace.auth.providers.assoc + +HELP: +{ $values { "provider" users-in-memory } } +{ $description "Creates a new authentication provider which stores the usernames and passwords in an associative mapping." } ; + +ARTICLE: "furnace.auth.providers.assoc" "In-memory authentication provider" +"The " { $vocab-link "furnace.auth.providers.assoc" } " vocabulary implements an authentication provider which looks up usernames and passwords in an associative mapping." +{ $subsection users-in-memory } +{ $subsection } +"The " { $slot "assoc" } " slot of the " { $link users-in-memory } " tuple maps usernames to checksums of passwords." ; + +ABOUT: "furnace.auth.providers.assoc" diff --git a/basis/furnace/auth/providers/db/db-docs.factor b/basis/furnace/auth/providers/db/db-docs.factor new file mode 100644 index 0000000000..219edf9490 --- /dev/null +++ b/basis/furnace/auth/providers/db/db-docs.factor @@ -0,0 +1,13 @@ +USING: help.markup help.syntax ; +IN: furnace.auth.providers.db + +HELP: users-in-db +{ $class-description "Singleton class implementing the database authentication provider." } ; + +ARTICLE: "furnace.auth.providers.db" "Database authentication provider" +"The " { $vocab-link "furnace.auth.providers.db" } " vocabulary implements an authentication provider which looks up authentication requests in the " { $snippet "USERS" } " table of the current database. The database schema is Factor-specific, and the table should be initialized by calling" +{ $code "users create-table" } +"The authentication provider class:" +{ $subsection users-in-db } ; + +ABOUT: "furnace.auth.providers.db" diff --git a/basis/furnace/auth/providers/null/null-docs.factor b/basis/furnace/auth/providers/null/null-docs.factor new file mode 100644 index 0000000000..100b16c7d3 --- /dev/null +++ b/basis/furnace/auth/providers/null/null-docs.factor @@ -0,0 +1,10 @@ +USING: help.markup help.syntax ; +IN: furnace.auth.providers.null + +HELP: no-users +{ $class-description "Singleton class implementing the dummy authentication provider." } ; + +ARTICLE: "furnace.auth.providers.null" "Dummy authentication provider" +"The " { $vocab-link "furnace.auth.providers.null" } " vocabulary implements an authentication provider which refuses all authentication requests. It is only useful for testing purposes." ; + +ABOUT: "furnace.auth.providers.null" diff --git a/basis/furnace/auth/providers/providers-docs.factor b/basis/furnace/auth/providers/providers-docs.factor new file mode 100644 index 0000000000..5d15bf4f65 --- /dev/null +++ b/basis/furnace/auth/providers/providers-docs.factor @@ -0,0 +1,45 @@ +USING: help.markup help.syntax strings ; +IN: furnace.auth.providers + +HELP: user +{ $class-description "The class of users. Instances have the following slots:" +{ $table + { { $slot "username" } { "The username, used to identify the user for login purposes" } } + { { $slot "realname" } { "The user's real name, optional" } } + { { $slot "password" } { "The user's password, encoded with a checksum" } } + { { $slot "salt" } { "A random salt prepended to the password to ensure that two users with the same plain-text password still have different checksum output" } } + { { $slot "email" } { "The user's e-mail address, optional" } } + { { $slot "ticket" } { "Used for password recovery" } } + { { $slot "capabilities" } { "A sequence of capabilities; see " { $link "furnace.auth.capabilities" } } } + { { $slot "profile" } { "A hashtable with webapp-specific configuration" } } + { { $slot "deleted" } { "A boolean indicating whether the user is active or not. This allows a user account to be deactivated without removing the user from the database" } } + { { $slot "changed?" } { "A boolean indicating whether the user has changed since being retrieved from the database" } } +} } ; + +HELP: add-user +{ $values { "provider" "an authentication provider" } { "user" user } } +{ $description "A utility word which calls " { $link new-user } " and throws an error if the user already exists." } ; + +HELP: get-user +{ $values { "username" string } { "provider" "an authentication provider" } { "user/f" { $maybe user } } } +{ $contract "Looks up a username in the authentication provider." } ; + +HELP: new-user +{ $values { "user" user } { "provider" "an authentication provider" } { "user/f" { $maybe user } } } +{ $contract "Adds a new user to the authentication provider. Outputs " { $link f } " if a user with this username already exists." } ; + +HELP: update-user +{ $values { "user" user } { "provider" "an authentication provider" } } +{ $contract "Stores a user back to an authentication provider after being changed. This is a no-op with in-memory providers; providers which use an external store will save the user in this word. " } ; + +ARTICLE: "furnace.auth.providers.protocol" "Authentication provider protocol" +"The " { $vocab-link "furnace.auth.providers" } " vocabulary implements a protocol for persistence and authentication of users." +$nl +"The class of users:" +{ $subsection user } +"Generic protocol:" +{ $subsection get-user } +{ $subsection new-user } +{ $subsection update-user } ; + +ABOUT: "furnace.auth.providers.protocol" diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor index 60844fadae..4ad2c8a249 100644 --- a/basis/furnace/conversations/conversations-docs.factor +++ b/basis/furnace/conversations/conversations-docs.factor @@ -28,7 +28,7 @@ HELP: cset { $description "Sets the value of a conversation variable." } ; HELP: cchange -{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } } +{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } } { $description "Applies the quotation to the old value of the conversation variable, and assigns the resulting value back to the variable." } ; ARTICLE: "furnace.conversations" "Furnace conversation scope" diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor index 57181ff0e9..911433d100 100644 --- a/basis/furnace/furnace-docs.factor +++ b/basis/furnace/furnace-docs.factor @@ -1,159 +1,129 @@ -USING: assocs help.markup help.syntax io.streams.string quotations sequences strings urls ; +USING: assocs help.markup help.syntax kernel +quotations sequences strings urls xml.data http ; IN: furnace HELP: adjust-redirect-url -{ $values - { "url" url } - { "url'" url } -} -{ $description "" } ; +{ $values { "url" url } { "url'" url } } +{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ; HELP: adjust-url -{ $values - { "url" url } - { "url'" url } -} -{ $description "" } ; - -HELP: base-path -{ $values - { "string" string } - { "pair" null } -} -{ $description "" } ; +{ $values { "url" url } { "url'" url } } +{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ; HELP: client-state -{ $values - { "key" null } - { "value/f" null } -} -{ $description "" } ; - -HELP: cookie-client-state -{ $values - { "key" null } { "request" null } - { "value/f" null } -} -{ $description "" } ; +{ $values { "key" string } { "value/f" { $maybe string } } } +{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } +{ $notes "This word is used by session management, conversation scope and asides." } ; HELP: each-responder -{ $values - { "quot" quotation } -} -{ $description "" } ; - -HELP: exit-continuation -{ $description "" } ; - -HELP: exit-with -{ $values - { "value" null } -} -{ $description "" } ; +{ $values { "quot" { $quotation "( responder -- )" } } } +{ $description "Applies the quotation to each responder involved in processing the current request." } ; HELP: hidden-form-field -{ $values - { "value" null } { "name" null } -} -{ $description "" } ; +{ $values { "value" string } { "name" string } } +{ $description "Renders an HTML hidden form field tag." } +{ $notes "This word is used by session management, conversation scope and asides." } +{ $examples + { $example + "USING: furnace io ;" + "\"bar\" \"foo\" hidden-form-field nl" + "" + } +} ; HELP: link-attr -{ $values - { "tag" null } { "responder" null } -} -{ $description "" } ; +{ $values { "tag" tag } { "responder" "a responder" } } +{ $contract "Modifies an XHTML " { $snippet "a" } " tag." } +{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } +{ $examples "Conversation scope adds attributes to link tags." } ; HELP: modify-form -{ $values - { "responder" null } -} -{ $description "" } ; +{ $values { "responder" "a responder" } } +{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." } +{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } +{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ; HELP: modify-query -{ $values - { "query" null } { "responder" null } - { "query'" null } -} -{ $description "" } ; +{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } +{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." } +{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } +{ $examples "Asides add query parameters to URLs." } ; HELP: modify-redirect-query -{ $values - { "query" null } { "responder" null } - { "query'" null } -} -{ $description "" } ; - -HELP: nested-forms-key -{ $description "" } ; +{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } +{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." } +{ $notes "This word is called by " { $link "furnace.redirection" } "." } +{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ; HELP: nested-responders -{ $values - - { "seq" sequence } -} -{ $description "" } ; - -HELP: post-client-state -{ $values - { "key" null } { "request" null } - { "value/f" null } -} +{ $values { "seq" "a sequence of responders" } } { $description "" } ; HELP: referrer -{ $values - - { "referrer/f" null } -} -{ $description "" } ; +{ $values { "referrer/f" { $maybe string } } } +{ $description "Outputs the current request's referrer URL." } ; HELP: request-params -{ $values - { "request" null } - { "assoc" assoc } -} -{ $description "" } ; +{ $values { "request" request } { "assoc" assoc } } +{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ; HELP: resolve-base-path -{ $values - { "string" string } - { "string'" string } -} +{ $values { "string" string } { "string'" string } } { $description "" } ; HELP: resolve-template-path -{ $values - { "pair" null } - { "path" "a pathname string" } -} +{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } } { $description "" } ; HELP: same-host? -{ $values - { "url" url } - { "?" "a boolean" } -} -{ $description "" } ; +{ $values { "url" url } { "?" "a boolean" } } +{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ; HELP: user-agent -{ $values - - { "user-agent" null } -} -{ $description "" } ; +{ $values { "user-agent" { $maybe string } } } +{ $description "Outputs the user agent reported by the client for the current request." } ; HELP: vocab-path -{ $values - { "vocab" "a vocabulary specifier" } - { "path" "a pathname string" } -} +{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } } { $description "" } ; +HELP: exit-with +{ $values { "value" object } } +{ $description "Exits from an outer " { $link with-exit-continuation } "." } ; + HELP: with-exit-continuation -{ $values - { "quot" quotation } -} -{ $description "" } ; +{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } } +{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." } +{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ; + +ARTICLE: "furnace.extension-points" "Furnace extension points" +"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used." +$nl +"Responders can implement methods on the following generic words:" +{ $subsection modify-query } +{ $subsection modify-redirect-query } +{ $subsection link-attr } +{ $subsection modify-form } +"Presentation-level code can call the following words:" +{ $subsection adjust-url } +{ $subsection adjust-redirect-url } ; + +ARTICLE: "furnace.misc" "Miscellaneous Furnace features" +"Inspecting the chain of responders handling the current request:" +{ $subsection nested-responders } +{ $subsection each-responder } +{ $subsection resolve-base-path } +"Vocabulary root-relative resources:" +{ $subsection vocab-path } +{ $subsection resolve-template-path } +"Early return from a responder:" +{ $subsection with-exit-continuation } +{ $subsection exit-with } +"Other useful words:" +{ $subsection hidden-form-field } +{ $subsection request-params } +{ $subsection client-state } +{ $subsection user-agent } ; ARTICLE: "furnace.persistence" "Furnace persistence layer" { $subsection "furnace.db" } @@ -193,10 +163,13 @@ ARTICLE: "furnace" "Furnace framework" { $subsection "furnace.alloy" } { $subsection "furnace.persistence" } { $subsection "furnace.presentation" } +{ $subsection "furnace.auth" } { $subsection "furnace.load-balancing" } "Utilities:" { $subsection "furnace.referrer" } { $subsection "furnace.redirection" } +{ $subsection "furnace.extension-points" } +{ $subsection "furnace.misc" } "Related frameworks:" { $subsection "db" } { $subsection "xml" } diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index a77b0d28c7..29eb00a8f4 100644 --- a/basis/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -90,7 +90,7 @@ M: object modify-form drop ; } case ; : referrer ( -- referrer/f ) - #! Typo is intentional, its in the HTTP spec! + #! Typo is intentional, it's in the HTTP spec! "referer" request get header>> at dup [ >url ensure-port [ remap-port ] change-port ] when ; @@ -125,7 +125,7 @@ SYMBOL: exit-continuation : exit-with ( value -- ) exit-continuation get continue-with ; -: with-exit-continuation ( quot -- ) +: with-exit-continuation ( quot -- value ) '[ exit-continuation set @ ] callcc1 exit-continuation off ; USE: vocabs.loader @@ -152,3 +152,4 @@ USE: vocabs.loader "furnace.scopes" require "furnace.sessions" require "furnace.syndication" require +"webapps.user-admin" require diff --git a/basis/furnace/referrer/referrer-docs.factor b/basis/furnace/referrer/referrer-docs.factor index 5deebbe9a7..599461c37c 100644 --- a/basis/furnace/referrer/referrer-docs.factor +++ b/basis/furnace/referrer/referrer-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax io.streams.string ; +USING: help.markup help.syntax io.streams.string +furnace ; IN: furnace.referrer HELP: @@ -10,6 +11,9 @@ HELP: ARTICLE: "furnace.referrer" "Form submission referrer checking" "The " { $vocab-link "furnace.referrer" } " implements a simple security measure which can be used to thwart cross-site scripting attacks." -{ $subsection } ; +{ $subsection } +"Explicit referrer checking:" +{ $subsection referrer } +{ $subsection same-host? } ; ABOUT: "furnace.referrer" diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor index 778452edc2..959d6b69b8 100644 --- a/basis/furnace/sessions/sessions-docs.factor +++ b/basis/furnace/sessions/sessions-docs.factor @@ -9,7 +9,7 @@ HELP: { $description "Wraps a responder in a session manager responder." } ; HELP: schange -{ $values { "key" symbol } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } } +{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } } { $description "Applies the quotation to the old value of the session variable, and assigns the resulting value back to the variable." } ; HELP: sget diff --git a/basis/furnace/summary.txt b/basis/furnace/summary.txt new file mode 100644 index 0000000000..afbc1b9b2c --- /dev/null +++ b/basis/furnace/summary.txt @@ -0,0 +1 @@ +Furnace web framework diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 9fb837a873..6e27bd9256 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -1,5 +1,6 @@ USING: help.markup help.syntax io kernel math namespaces parser -prettyprint sequences vocabs.loader namespaces stack-checker ; +prettyprint sequences vocabs.loader namespaces stack-checker +help ; IN: help.cookbook ARTICLE: "cookbook-syntax" "Basic syntax cookbook" @@ -324,6 +325,19 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" { "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." } } ; +ARTICLE: "cookbook-next" "Next steps" +"Once you have read through " { $link "first-program" } " and " { $link "cookbook" } ", the best way to keep learning Factor is to start looking at some simple example programs. Here are a few particularly nice vocabularies which should keep you busy for a little while:" +{ $list + { $vocab-link "base64" } + { $vocab-link "roman" } + { $vocab-link "rot13" } + { $vocab-link "smtp" } + { $vocab-link "time-server" } + { $vocab-link "tools.hexdump" } + { $vocab-link "webapps.counter" } +} +"If you see code in there that you do not understand, use " { $link see } " and " { $link help } " to explore." ; + ARTICLE: "cookbook" "Factor cookbook" "The Factor cookbook is a high-level overview of the most important concepts required to program in Factor." { $subsection "cookbook-syntax" } @@ -336,6 +350,7 @@ ARTICLE: "cookbook" "Factor cookbook" { $subsection "cookbook-scripts" } { $subsection "cookbook-compiler" } { $subsection "cookbook-philosophy" } -{ $subsection "cookbook-pitfalls" } ; +{ $subsection "cookbook-pitfalls" } +{ $subsection "cookbook-next" } ; ABOUT: "cookbook" diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index d1d9ca049a..2ed86a0a19 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -65,6 +65,11 @@ $nl { "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } } } ; +ARTICLE: "tail-call-opt" "Tail-call optimization" +"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $emphasis "tail-call optimization" } " and the Factor implementation guarantees that it will be performed." +$nl +"Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ; + ARTICLE: "evaluator" "Evaluation semantics" { $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:" { $list @@ -72,7 +77,7 @@ ARTICLE: "evaluator" "Evaluation semantics" { "a " { $link wrapper } " - the wrapped object is pushed on the data stack. Wrappers are used to push word objects directly on the stack when they would otherwise execute. See the " { $link POSTPONE: \ } " parsing word." } { "All other types of objects are pushed on the data stack." } } -"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage." +{ $subsection "tail-call-opt" } { $see-also "compiler" } ; ARTICLE: "objects" "Objects" diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 2fe4edfe7f..277d965e39 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.crossref help.stylesheet help.topics help.syntax definitions io prettyprint summary arrays math -sequences vocabs ; +sequences vocabs strings ; IN: help ARTICLE: "printing-elements" "Printing markup elements" @@ -33,6 +33,10 @@ ARTICLE: "block-elements" "Block elements" { $subsection $side-effects } { $subsection $errors } { $subsection $see-also } +"Elements used in " { $link $values } " forms:" +{ $subsection $instance } +{ $subsection $maybe } +{ $subsection $quotation } "Boilerplate paragraphs:" { $subsection $low-level-note } { $subsection $io-error } @@ -281,7 +285,7 @@ HELP: $link } ; HELP: textual-list -{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } } +{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- )" } } } { $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." } { $examples { $example "USING: help.markup io ;" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" } @@ -318,7 +322,37 @@ HELP: $table HELP: $values { $values { "element" "an array of pairs of markup elements" } } -{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder can be an element of any form." } ; +{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is intereted as if it were shorthand for " { $snippet "{ $instance class }" } "." } +{ $see-also $maybe $instance $quotation } ; + +HELP: $instance +{ $values { "element" "an array with shape " { $snippet "{ class }" } } } +{ $description + "Produces the text ``a " { $emphasis "class" } "'' or ``an " { $emphasis "class" } "'', depending on the first letter of " { $emphasis "class" } "." +} +{ $examples + { $markup-example { $instance string } } + { $markup-example { $instance integer } } + { $markup-example { $instance f } } +} ; + +HELP: $maybe +{ $values { "element" "an array with shape " { $snippet "{ class }" } } } +{ $description + "Produces the text ``a " { $emphasis "class" } " or f'' or ``an " { $emphasis "class" } " or f'', depending on the first letter of " { $emphasis "class" } "." +} +{ $examples + { $markup-example { $maybe string } } +} ; + +HELP: $quotation +{ $values { "element" "an array with shape " { $snippet "{ effect }" } } } +{ $description + "Produces the text ``a quotation with stack effect " { $emphasis "effect" } "''." +} +{ $examples + { $markup-example { $quotation "( obj -- )" } } +} ; HELP: $list { $values { "element" "an array of markup elements" } } diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 386dca9576..6b90ba6937 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -5,23 +5,22 @@ io.files html.streams html.elements html.components help kernel assocs sequences make words accessors arrays help.topics vocabs tools.vocabs tools.vocabs.browser namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order -sorting ; +sorting debugger ; IN: help.html : escape-char ( ch -- ) dup H{ - { CHAR: " "__quote__" } + { CHAR: " "__quo__" } { CHAR: * "__star__" } { CHAR: : "__colon__" } { CHAR: < "__lt__" } { CHAR: > "__gt__" } - { CHAR: ? "__question__" } - { CHAR: \\ "__backslash__" } + { CHAR: ? "__que__" } + { CHAR: \\ "__back__" } { CHAR: | "__pipe__" } - { CHAR: _ "__underscore__" } { CHAR: / "__slash__" } - { CHAR: \\ "__backslash__" } { CHAR: , "__comma__" } + { CHAR: @ "__at__" } } at [ % ] [ , ] ?if ; : escape-filename ( string -- filename ) @@ -88,19 +87,17 @@ M: topic browser-link-href topic>filename ; all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ; : generate-help-files ( -- ) - all-topics [ help>html ] each ; + all-topics [ '[ _ help>html ] try ] each ; : generate-help ( -- ) - { "resource:core" "resource:basis" "resource:extra" } vocab-roots [ - load-everything - - "/tmp/docs/" make-directory - - "/tmp/docs/" [ + "docs" temp-file + [ make-directories ] + [ + [ generate-indices generate-help-files ] with-directory - ] with-variable ; + ] bi ; MEMO: load-index ( name -- index ) binary file-contents bytes>object ; diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 1eae56cfcc..a307833338 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -3,7 +3,8 @@ USING: accessors arrays definitions generic io kernel assocs hashtables namespaces make parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots -vocabs help.stylesheet help.topics vocabs.loader alias ; +vocabs help.stylesheet help.topics vocabs.loader alias +quotations ; IN: help.markup ! Simple markup language. @@ -234,7 +235,8 @@ ALIAS: $slot $snippet ] ($grid) ; : a/an ( str -- str ) - first "aeiou" member? "an" "a" ? ; + [ first ] [ length ] bi 1 = + "afhilmnorsx" "aeiou" ? member? "an" "a" ? ; GENERIC: ($instance) ( element -- ) @@ -244,7 +246,17 @@ M: word ($instance) M: string ($instance) dup a/an write bl $snippet ; -: $instance ( children -- ) first ($instance) ; +M: f ($instance) + drop { f } $link ; + +: $instance ( element -- ) first ($instance) ; + +: $maybe ( element -- ) + $instance " or " print-element { f } $instance ; + +: $quotation ( element -- ) + { "a " { $link quotation } " with stack effect " } print-element + $snippet ; : values-row ( seq -- seq ) unclip \ $snippet swap ?word-name 2array diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index 402b6e68a9..1f2975bce1 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -14,7 +14,7 @@ HELP: required-attr { $errors "Throws an error if the attribute is not specified." } ; HELP: optional-attr -{ $values { "tag" tag } { "name" string } { "value" "a " { $link string } " or " { $link f } } } +{ $values { "tag" tag } { "name" string } { "value" { $maybe string } } } { $description "Extracts an attribute from a tag." } { $notes "Outputs " { $link f } " if the attribute is not specified." } ; @@ -24,7 +24,7 @@ HELP: compile-attr HELP: CHLOE: { $syntax "name definition... ;" } -{ $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } } +{ $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } } { $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ; HELP: COMPONENT: @@ -46,7 +46,7 @@ HELP: [code] { $description "Compiles the quotation. It will be called when the template is called." } ; HELP: process-children -{ $values { "tag" tag } { "quot" "a quotation with stack effect " { $snippet "( compiled-tag -- )" } } } +{ $values { "tag" tag } { "quot" { $quotation "( compiled-tag -- )" } } } { $description "Compiles the tag. The quotation will be applied to the resulting quotation when the template is called." } { $examples "See " { $link "html.templates.chloe.extend.tags.example" } " for an example which uses this word to implement a custom control flow tag." } ; diff --git a/basis/html/templates/fhtml/fhtml-tests.factor b/basis/html/templates/fhtml/fhtml-tests.factor index b863087a92..d314a60124 100644 --- a/basis/html/templates/fhtml/fhtml-tests.factor +++ b/basis/html/templates/fhtml/fhtml-tests.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.string io.encodings.utf8 html.templates html.templates.fhtml kernel -tools.test sequences parser ; +tools.test sequences parser splitting prettyprint ; IN: html.templates.fhtml.tests : test-template ( path -- ? ) @@ -8,8 +8,10 @@ IN: html.templates.fhtml.tests prepend [ ".fhtml" append [ call-template ] with-string-writer + lines ] keep - ".html" append utf8 file-contents = ; + ".html" append utf8 file-lines + [ . . ] [ = ] 2bi ; [ t ] [ "example" test-template ] unit-test [ t ] [ "bug" test-template ] unit-test diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index d4f277a7c3..7a35ba812b 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -40,7 +40,7 @@ HELP: http-post { $errors "Throws an error if the HTTP request fails." } ; HELP: with-http-get -{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } } +{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" { $quotation "( chunk -- )" } } { "response" response } } { $description "Downloads the contents of a URL. Chunks of data are passed to the quotation as they are read." } { $errors "Throws an error if the HTTP request fails." } ; @@ -50,7 +50,7 @@ HELP: http-request { $errors "Throws an error if the HTTP request fails." } ; HELP: with-http-request -{ $values { "request" request } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } } +{ $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } } { $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." } { $errors "Throws an error if the HTTP request fails." } ; diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor index 4db04f04aa..6fb5b73fad 100644 --- a/basis/http/http-docs.factor +++ b/basis/http/http-docs.factor @@ -81,7 +81,7 @@ HELP: delete-cookie { $side-effects "request/response" } ; HELP: get-cookie -{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" "a " { $link cookie } " or " { $link f } } } +{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" { $maybe cookie } } } { $description "Gets a named cookie from a request or response." } ; HELP: put-cookie diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor index bca72a6126..fbe20b5fcd 100644 --- a/basis/http/server/static/static-docs.factor +++ b/basis/http/server/static/static-docs.factor @@ -4,7 +4,7 @@ USING: help.markup help.syntax io.streams.string ; IN: http.server.static HELP: -{ $values { "root" "a pathname string" } { "hook" "a quotation with stack effect " { $snippet "( path mime-type -- response )" } } { "responder" file-responder } } +{ $values { "root" "a pathname string" } { "hook" { $quotation "( path mime-type -- response )" } } { "responder" file-responder } } { $description "Creates a file responder which serves content from " { $snippet "path" } " by using the hook to generate a response." } ; HELP: diff --git a/basis/io/encodings/utf16/.utf16.factor.swo b/basis/io/encodings/utf16/.utf16.factor.swo deleted file mode 100644 index 01be8fdab2..0000000000 Binary files a/basis/io/encodings/utf16/.utf16.factor.swo and /dev/null differ diff --git a/basis/io/files/listing/listing-tests.factor b/basis/io/files/listing/listing-tests.factor index a2347c8db9..8c2dc28559 100644 --- a/basis/io/files/listing/listing-tests.factor +++ b/basis/io/files/listing/listing-tests.factor @@ -3,4 +3,6 @@ USING: tools.test io.files.listing strings kernel ; IN: io.files.listing.tests +\ directory. must-infer + [ ] [ "" directory. ] unit-test diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index c774103fca..09922fc929 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -17,7 +17,7 @@ HELP: { $errors "Throws an error if a memory mapping could not be established." } ; HELP: with-mapped-file -{ $values { "path" "a pathname string" } { "length" integer } { "quot" "a quotation with stack effect " { $snippet "( mmap -- )" } } } +{ $values { "path" "a pathname string" } { "length" integer } { "quot" { $quotation "( mmap -- )" } } } { $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } { $errors "Throws an error if a memory mapping could not be established." } ; diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor index ce59e23b45..3242b276e6 100644 --- a/basis/io/monitors/monitors-docs.factor +++ b/basis/io/monitors/monitors-docs.factor @@ -23,7 +23,7 @@ HELP: next-change { $errors "Throws an error if the monitor is closed from another thread." } ; HELP: with-monitor -{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" { $quotation "( monitor -- )" } } } { $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } { $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; diff --git a/basis/io/pools/pools-docs.factor b/basis/io/pools/pools-docs.factor index aae1698349..36f437dd09 100644 --- a/basis/io/pools/pools-docs.factor +++ b/basis/io/pools/pools-docs.factor @@ -22,7 +22,7 @@ HELP: return-connection { $description "Returns a connection to the pool." } ; HELP: with-pooled-connection -{ $values { "pool" pool } { "quot" "a quotation with stack effect " { $snippet "( conn -- )" } } } +{ $values { "pool" pool } { "quot" { $quotation "( conn -- )" } } } { $description "Calls a quotation with a pooled connection on the stack. If the quotation returns successfully, the connection is returned to the pool; if the quotation throws an error, the connection is disposed of with " { $link dispose } "." } ; HELP: make-connection diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor index 22c40da3d7..b093840987 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -114,11 +114,11 @@ HELP: stop-this-server { $description "Stops the current threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ; HELP: secure-port -{ $values { "n" "an " { $link integer } " or " { $link f } } } +{ $values { "n" { $maybe integer } } } { $description "Outputs the port number on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." } { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ; HELP: insecure-port -{ $values { "n" "an " { $link integer } " or " { $link f } } } +{ $values { "n" { $maybe integer } } } { $description "Outputs the port number on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." } { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ; diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 674ed8803c..942bdb041d 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -114,19 +114,29 @@ M: threaded-server handle-client* handler>> call ; ] when* ] unless ; +: (start-server) ( threaded-server -- ) + init-server + dup threaded-server [ + dup name>> [ + [ listen-on [ start-accept-loop ] parallel-each ] + [ ready>> raise-flag ] + bi + ] with-logging + ] with-variable ; + PRIVATE> : start-server ( threaded-server -- ) - init-server - dup secure-config>> [ - dup threaded-server [ - dup name>> [ - [ listen-on [ start-accept-loop ] parallel-each ] - [ ready>> raise-flag ] - bi - ] with-logging - ] with-variable - ] with-secure-context ; + #! Only create a secure-context if we want to listen on + #! a secure port, otherwise start-server won't work at + #! all if SSL is not available. + dup secure>> [ + dup secure-config>> [ + (start-server) + ] with-secure-context + ] [ + (start-server) + ] if ; : wait-for-server ( threaded-server -- ) ready>> wait-for-flag ; diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index 3454f3384e..25401293f5 100644 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -56,7 +56,7 @@ ARTICLE: "network-streams" "Networking" { $subsection "network-addressing" } { $subsection "network-connection" } { $subsection "network-packet" } -{ $subsection "io.sockets.secure" } +{ $vocab-subsection "Secure sockets (SSL, TLS)" "io.sockets.secure" } { $see-also "io.pipes" } ; ABOUT: "network-streams" diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor index b2927af362..5d72bde0f5 100644 --- a/basis/io/timeouts/timeouts-docs.factor +++ b/basis/io/timeouts/timeouts-docs.factor @@ -2,11 +2,11 @@ IN: io.timeouts USING: help.markup help.syntax math kernel calendar ; HELP: timeout -{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } } +{ $values { "obj" object } { "dt/f" { $maybe duration } } } { $contract "Outputs an object's timeout." } ; HELP: set-timeout -{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } } +{ $values { "dt/f" { $maybe duration } } { "obj" object } } { $contract "Sets an object's timeout." } ; HELP: cancel-operation @@ -14,7 +14,7 @@ HELP: cancel-operation { $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ; HELP: with-timeout -{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } } +{ $values { "obj" object } { "quot" { $quotation "( obj -- )" } } } { $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ; ARTICLE: "io.timeouts" "I/O timeout protocol" diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 3f254e7713..98206bc992 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -117,8 +117,8 @@ M: unix stat>file-info ( stat -- file-info ) [ stat-st_blksize >>blocksize ] } cleave ; -M: unix stat>type ( stat -- type ) - stat-st_mode S_IFMT bitand { +: n>file-type ( n -- type ) + S_IFMT bitand { { S_IFREG [ +regular-file+ ] } { S_IFDIR [ +directory+ ] } { S_IFCHR [ +character-device+ ] } @@ -129,6 +129,9 @@ M: unix stat>type ( stat -- type ) [ drop +unknown+ ] } case ; +M: unix stat>type ( stat -- type ) + stat-st_mode n>file-type ; + ! Linux has no extra fields in its stat struct os { { macosx [ "io.unix.files.bsd" require ] } @@ -150,7 +153,7 @@ os { M: unix >directory-entry ( byte-array -- directory-entry ) [ dirent-d_name utf8 alien>string ] - [ dirent-d_type ] bi directory-entry boa ; + [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ; M: unix (directory-entries) ( path -- seq ) [ diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index d0409ce59a..7f84b9d9e5 100755 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -114,11 +114,6 @@ M: windows delete-directory ( path -- ) normalize-path RemoveDirectory win32-error=0/f ; -M: windows >directory-entry ( byte-array -- directory-entry ) - [ WIN32_FIND_DATA-cFileName utf16n alien>string ] - [ WIN32_FIND_DATA-dwFileAttributes ] - bi directory-entry boa ; - : find-first-file ( path -- WIN32_FIND_DATA handle ) "WIN32_FIND_DATA" tuck FindFirstFile @@ -177,6 +172,15 @@ TUPLE: windows-file-info < file-info attributes ; : win32-file-type ( n -- symbol ) FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; +TUPLE: windows-directory-entry < directory-entry attributes ; + +M: windows >directory-entry ( byte-array -- directory-entry ) + [ WIN32_FIND_DATA-cFileName utf16n alien>string ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ] + tri + dupd remove windows-directory-entry boa ; + : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) [ \ windows-file-info new ] dip { diff --git a/basis/io/windows/nt/launcher/launcher-tests.factor b/basis/io/windows/nt/launcher/launcher-tests.factor index 949b0a7961..cbae2f5eca 100644 --- a/basis/io/windows/nt/launcher/launcher-tests.factor +++ b/basis/io/windows/nt/launcher/launcher-tests.factor @@ -1,157 +1,157 @@ -USING: io.launcher tools.test calendar accessors environment -namespaces kernel system arrays io io.files io.encodings.ascii -sequences parser assocs hashtables math continuations eval ; -IN: io.windows.launcher.nt.tests - -[ ] [ - - "notepad" >>command - 1/2 seconds >>timeout - "notepad" set -] unit-test - -[ f ] [ "notepad" get process-running? ] unit-test - -[ f ] [ "notepad" get process-started? ] unit-test - -[ ] [ "notepad" [ run-detached ] change ] unit-test - -[ "notepad" get wait-for-process ] must-fail - -[ t ] [ "notepad" get killed>> ] unit-test - -[ f ] [ "notepad" get process-running? ] unit-test - -[ ] [ - - vm "-quiet" "-run=hello-world" 3array >>command - "out.txt" temp-file >>stdout - try-process -] unit-test - -[ "Hello world" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ ] [ - - vm "-run=listener" 2array >>command - +closed+ >>stdin - try-process -] unit-test - -[ ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "stderr.factor" 3array >>command - "out.txt" temp-file >>stdout - "err.txt" temp-file >>stderr - try-process - ] with-directory -] unit-test - -[ "output" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ "error" ] [ - "err.txt" temp-file ascii file-lines first -] unit-test - -[ ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "stderr.factor" 3array >>command - "out.txt" temp-file >>stdout - +stdout+ >>stderr - try-process - ] with-directory -] unit-test - -[ "outputerror" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ "output" ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "stderr.factor" 3array >>command - "err2.txt" temp-file >>stderr - ascii lines first - ] with-directory -] unit-test - -[ "error" ] [ - "err2.txt" temp-file ascii file-lines first -] unit-test - -[ t ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - ascii contents - ] with-directory eval - - os-envs = -] unit-test - -[ t ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - +replace-environment+ >>environment-mode - os-envs >>environment - ascii contents - ] with-directory eval - - os-envs = -] unit-test - -[ "B" ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - { { "A" "B" } } >>environment - ascii contents - ] with-directory eval - - "A" swap at -] unit-test - -[ f ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - { { "HOME" "XXX" } } >>environment - +prepend-environment+ >>environment-mode - ascii contents - ] with-directory eval - - "HOME" swap at "XXX" = -] unit-test - -2 [ - [ ] [ - - "cmd.exe /c dir" >>command - "dir.txt" temp-file >>stdout - try-process - ] unit-test - - [ ] [ "dir.txt" temp-file delete-file ] unit-test -] times - -[ "append-test" temp-file delete-file ] ignore-errors - -[ "Hello appender\r\nHello appender\r\n" ] [ - 2 [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "append.factor" 3array >>command - "append-test" temp-file >>stdout - try-process - ] with-directory - ] times - - "append-test" temp-file ascii file-contents -] unit-test +USING: io.launcher tools.test calendar accessors environment +namespaces kernel system arrays io io.files io.encodings.ascii +sequences parser assocs hashtables math continuations eval ; +IN: io.windows.launcher.nt.tests + +[ ] [ + + "notepad" >>command + 1/2 seconds >>timeout + "notepad" set +] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ f ] [ "notepad" get process-started? ] unit-test + +[ ] [ "notepad" [ run-detached ] change ] unit-test + +[ "notepad" get wait-for-process ] must-fail + +[ t ] [ "notepad" get killed>> ] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ ] [ + + vm "-quiet" "-run=hello-world" 3array >>command + "out.txt" temp-file >>stdout + try-process +] unit-test + +[ "Hello world" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + + vm "-run=listener" 2array >>command + +closed+ >>stdin + try-process +] unit-test + +[ ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + "err.txt" temp-file >>stderr + try-process + ] with-directory +] unit-test + +[ "output" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "error" ] [ + "err.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + +stdout+ >>stderr + try-process + ] with-directory +] unit-test + +[ "outputerror" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "output" ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "stderr.factor" 3array >>command + "err2.txt" temp-file >>stderr + ascii lines first + ] with-directory +] unit-test + +[ "error" ] [ + "err2.txt" temp-file ascii file-lines first +] unit-test + +[ t ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ t ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + +replace-environment+ >>environment-mode + os-envs >>environment + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ "B" ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + { { "A" "B" } } >>environment + ascii contents + ] with-directory eval + + "A" swap at +] unit-test + +[ f ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + { { "USERPROFILE" "XXX" } } >>environment + +prepend-environment+ >>environment-mode + ascii contents + ] with-directory eval + + "USERPROFILE" swap at "XXX" = +] unit-test + +2 [ + [ ] [ + + "cmd.exe /c dir" >>command + "dir.txt" temp-file >>stdout + try-process + ] unit-test + + [ ] [ "dir.txt" temp-file delete-file ] unit-test +] times + +[ "append-test" temp-file delete-file ] ignore-errors + +[ "Hello appender\r\nHello appender\r\n" ] [ + 2 [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "append.factor" 3array >>command + "append-test" temp-file >>stdout + try-process + ] with-directory + ] times + + "append-test" temp-file ascii file-contents +] unit-test diff --git a/basis/io/windows/tags.txt b/basis/io/windows/tags.txt old mode 100644 new mode 100755 index 02ec70f741..6bf68304bb --- a/basis/io/windows/tags.txt +++ b/basis/io/windows/tags.txt @@ -1,2 +1 @@ unportable -windows diff --git a/basis/libc/libc-docs.factor b/basis/libc/libc-docs.factor index 5e285bf26d..37a3b7068f 100644 --- a/basis/libc/libc-docs.factor +++ b/basis/libc/libc-docs.factor @@ -33,7 +33,7 @@ HELP: free { $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ; HELP: with-malloc -{ $values { "size" "a positive integer" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr -- )" } } } +{ $values { "size" "a positive integer" } { "quot" { $quotation "( c-ptr -- )" } } } { $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ; HELP: &free diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 003ef459e3..04e077fc4f 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -346,7 +346,6 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as - :: literal-identity-test ( -- a b ) { } V{ } ; @@ -356,6 +355,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; swapd [ eq? ] [ eq? ] 2bi* ] unit-test +:: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ; + +[ { 4 } ] [ 3 mutable-local-in-literal-test ] unit-test + :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- ) obj1 obj2 <=> { { +lt+ [ lt-quot call ] } @@ -385,6 +388,8 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test +[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test + ! :: wlet-&&-test ( a -- ? ) ! [wlet | is-integer? [ a integer? ] ! is-even? [ a even? ] diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index e74ecf3dc9..7de9d10436 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -229,6 +229,8 @@ M: tuple rewrite-element M: local rewrite-element , ; +M: local-reader rewrite-element , ; + M: word rewrite-element literalize , ; M: object rewrite-element , ; diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index 4f2606bda0..9ed164330b 100644 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -310,8 +310,9 @@ ARTICLE: "math-bitfields" "Constructing bit fields" "Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:" { $subsection bitfield } ; -ARTICLE: "math.bitwise" "Bitwise arithmetic" -"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl +ARTICLE: "math.bitwise" "Additional bitwise arithmetic" +"The " { $vocab-link "math.bitwise" } " vocabulary provides bitwise arithmetic words extending " { $link "bitwise-arithmetic" } ". They are useful for efficiency, low-level programming, and interfacing with C libraries." +$nl "Setting and clearing bits:" { $subsection set-bit } { $subsection clear-bit } diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index ad1907fcb0..afd83d4458 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math math.functions sequences sequences.private words namespaces macros hints -combinators fry ; +combinators fry io.binary ; IN: math.bitwise ! utilities @@ -93,3 +93,11 @@ PRIVATE> : bit-count ( x -- n ) dup 0 < [ bitnot ] when (bit-count) ; inline + +! Signed byte array to integer conversion +: signed-le> ( bytes -- x ) + [ le> ] [ length 8 * 1- on-bits ] bi + 2dup > [ bitnot bitor ] [ drop ] if ; + +: signed-be> ( bytes -- x ) + signed-le> ; diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index f9bb8e9897..ea3da55082 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -279,7 +279,7 @@ HELP: mod-inv } ; HELP: each-bit -{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( ? -- )" } } } +{ $values { "n" integer } { "quot" { $quotation "( ? -- )" } } } { $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 "USING: math.functions make prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" } diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 43efc35c27..c582c560a9 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -15,7 +15,7 @@ IN: math.functions PRIVATE> : rect> ( x y -- z ) - over real? over real? and [ + 2dup [ real? ] both? [ (rect>) ] [ "Complex number must have real components" throw @@ -27,10 +27,10 @@ M: real sqrt >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; : each-bit ( n quot: ( ? -- ) -- ) - over 0 = pick -1 = or [ + over [ 0 = ] [ -1 = ] bi or [ 2drop ] [ - 2dup >r >r >r odd? r> call r> 2/ r> each-bit + 2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread ] if ; inline recursive : map-bits ( n quot: ( ? -- obj ) -- seq ) @@ -69,8 +69,7 @@ PRIVATE> >rect [ >float ] bi@ ; inline : >polar ( z -- abs arg ) - >float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; - inline + >float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; inline : cis ( arg -- z ) dup fcos swap fsin rect> ; inline @@ -79,11 +78,10 @@ PRIVATE> r >r >float-rect swap r> swap fpow r> rot * fexp /f ; - inline + [ >float-rect swap ] [ swap fpow ] [ rot * fexp /f ] tri* ; inline : ^theta ( w abs arg -- theta ) - >r >r >float-rect r> flog * swap r> * + ; inline + [ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline : ^complex ( x y -- z ) swap >polar [ ^mag ] [ ^theta ] 3bi polar> ; inline @@ -106,18 +104,18 @@ PRIVATE> : (^mod) ( n x y -- z ) 1 swap [ - [ dupd * pick mod ] when >r sq over mod r> + [ dupd * pick mod ] when [ sq over mod ] dip ] each-bit 2nip ; inline : (gcd) ( b a x y -- a d ) over zero? [ 2nip ] [ - swap [ /mod >r over * swapd - r> ] keep (gcd) + swap [ /mod [ over * swapd - ] dip ] keep (gcd) ] if ; : gcd ( x y -- a d ) - 0 -rot 1 -rot (gcd) dup 0 < [ neg ] when ; foldable + [ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable : lcm ( a b -- c ) [ * ] 2keep gcd nip /i ; foldable @@ -131,7 +129,7 @@ PRIVATE> : ^mod ( x y n -- z ) over 0 < [ - [ >r neg r> ^mod ] keep mod-inv + [ [ neg ] dip ^mod ] keep mod-inv ] [ -rot (^mod) ] if ; foldable @@ -141,14 +139,14 @@ GENERIC: absq ( x -- y ) foldable M: real absq sq ; : ~abs ( x y epsilon -- ? ) - >r - abs r> < ; + [ - abs ] dip < ; : ~rel ( x y epsilon -- ? ) - >r [ - abs ] 2keep [ abs ] bi@ + r> * < ; + [ [ - abs ] 2keep [ abs ] bi@ + ] dip * < ; : ~ ( x y epsilon -- ? ) { - { [ pick fp-nan? pick fp-nan? or ] [ 3drop f ] } + { [ 2over [ fp-nan? ] either? ] [ 3drop f ] } { [ dup zero? ] [ drop number= ] } { [ dup 0 < ] [ ~rel ] } [ ~abs ] diff --git a/basis/math/geometry/rect/rect-docs.factor b/basis/math/geometry/rect/rect-docs.factor index a892940363..31c9e44b1d 100644 --- a/basis/math/geometry/rect/rect-docs.factor +++ b/basis/math/geometry/rect/rect-docs.factor @@ -47,3 +47,21 @@ HELP: { $values { "rect" "a new " { $link rect } } } { $description "Creates a rectangle located at the origin with zero dimensions." } ; +ARTICLE: "math.geometry.rect" "Rectangles" +"The " { $vocab-link "math.geometry.rect" } " vocabulary defines a rectangle data type and operations on them." +{ $subsection rect } +"Rectangles can be taken apart:" +{ $subsection rect-loc } +{ $subsection rect-dim } +{ $subsection rect-bounds } +{ $subsection rect-extent } +"New rectangles can be created:" +{ $subsection } +{ $subsection } +{ $subsection } +"More utility words for working with rectangles:" +{ $subsection offset-rect } +{ $subsection rect-intersect } +{ $subsection intersects? } ; + +ABOUT: "math.geometry.rect" diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor index c5e5a6e7b8..5a96c7aceb 100644 --- a/basis/math/intervals/intervals-docs.factor +++ b/basis/math/intervals/intervals-docs.factor @@ -156,8 +156,8 @@ HELP: interval* { $description "Multiplies two intervals." } ; HELP: interval-shift -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link f } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link full-interval } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers." } ; HELP: interval-max { $values { "i1" interval } { "i2" interval } { "i3" interval } } @@ -253,8 +253,8 @@ HELP: points>interval ; HELP: interval-shift-safe -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link f } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers, or if the endpoints of " { $snippet "i2" } " are so large that the resulting interval will consume too much memory." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Shifts " { $snippet "i1" } " to the left by " { $snippet "i2" } " bits. Outputs " { $link full-interval } " if the endpoints of either " { $snippet "i1" } " or " { $snippet "i2" } " are not integers, or if the endpoints of " { $snippet "i2" } " are so large that the resulting interval will consume too much memory." } ; 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." } ; @@ -304,20 +304,20 @@ HELP: interval>points { $description "Outputs both endpoints of the interval." } ; HELP: assume< -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less than all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less than all points in " { $snippet "i2" } "." } ; HELP: assume<= -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less or equal to all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less or equal to all points in " { $snippet "i2" } "." } ; HELP: assume> { $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } { $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ; HELP: assume>= -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } -{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than or equal to all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ; +{ $values { "i1" interval } { "i2" interval } { "i3" interval } } +{ $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than or equal to all points in " { $snippet "i2" } "." } ; HELP: integral-closure { $values { "i1" "an " { $link interval } " with integer end-points" } { "i2" "a closed " { $link interval } " with integer end-points" } } diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 54ee0ac894..4182d25524 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -12,10 +12,10 @@ SYMBOL: full-interval TUPLE: interval { from read-only } { to read-only } ; : ( from to -- int ) - over first over first { + 2dup [ first ] bi@ { { [ 2dup > ] [ 2drop 2drop empty-interval ] } { [ 2dup = ] [ - 2drop over second over second and + 2drop 2dup [ second ] both? [ interval boa ] [ 2drop empty-interval ] if ] } [ 2drop interval boa ] @@ -26,16 +26,16 @@ TUPLE: interval { from read-only } { to read-only } ; : closed-point ( n -- endpoint ) t 2array ; : [a,b] ( a b -- interval ) - >r closed-point r> closed-point ; foldable + [ closed-point ] dip closed-point ; foldable : (a,b) ( a b -- interval ) - >r open-point r> open-point ; foldable + [ open-point ] dip open-point ; foldable : [a,b) ( a b -- interval ) - >r closed-point r> open-point ; foldable + [ closed-point ] dip open-point ; foldable : (a,b] ( a b -- interval ) - >r open-point r> closed-point ; foldable + [ open-point ] dip closed-point ; foldable : [a,a] ( a -- interval ) closed-point dup ; foldable @@ -51,11 +51,11 @@ TUPLE: interval { from read-only } { to read-only } ; : [-inf,inf] ( -- interval ) full-interval ; inline : compare-endpoints ( p1 p2 quot -- ? ) - >r over first over first r> call [ + [ 2dup [ first ] bi@ ] dip call [ 2drop t ] [ - over first over first = [ - swap second swap second not or + 2dup [ first ] bi@ = [ + [ second ] bi@ not or ] [ 2drop f ] if @@ -86,7 +86,7 @@ TUPLE: interval { from read-only } { to read-only } ; ] if ; : (interval-op) ( p1 p2 quot -- p3 ) - [ [ first ] [ first ] [ ] tri* call ] + [ [ first ] [ first ] [ call ] tri* ] [ drop [ second ] both? ] 3bi 2array ; inline @@ -177,7 +177,7 @@ TUPLE: interval { from read-only } { to read-only } ; drop f ] [ interval>points - 2dup [ second ] bi@ and + 2dup [ second ] both? [ [ first ] bi@ = ] [ 2drop f ] if ] if ; @@ -193,9 +193,9 @@ TUPLE: interval { from read-only } { to read-only } ; dup [ interval>points [ first ] bi@ [a,b] ] when ; : interval-integer-op ( i1 i2 quot -- i3 ) - >r 2dup - [ interval>points [ first integer? ] both? ] both? - r> [ 2drop [-inf,inf] ] if ; inline + [ + 2dup [ interval>points [ first integer? ] both? ] both? + ] dip [ 2drop [-inf,inf] ] if ; inline : interval-shift ( i1 i2 -- i3 ) #! Inaccurate; could be tighter @@ -302,7 +302,7 @@ SYMBOL: incomparable 2tri and and ; : (interval<) ( i1 i2 -- i1 i2 ? ) - over from>> over from>> endpoint< ; + 2dup [ from>> ] bi@ endpoint< ; : interval< ( i1 i2 -- ? ) { @@ -314,10 +314,10 @@ SYMBOL: incomparable } cond 2nip ; : left-endpoint-<= ( i1 i2 -- ? ) - >r from>> r> to>> = ; + [ from>> ] dip to>> = ; : right-endpoint-<= ( i1 i2 -- ? ) - >r to>> r> from>> = ; + [ to>> ] dip from>> = ; : interval<= ( i1 i2 -- ? ) { diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index fd0e910b37..6874b79d2e 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -126,7 +126,7 @@ SYMBOL: fast-math-ops : math-method* ( word left right -- quot ) 3dup math-op - [ >r 3drop r> 1quotation ] [ drop math-method ] if ; + [ [ 3drop ] dip 1quotation ] [ drop math-method ] if ; : math-both-known? ( word left right -- ? ) 3dup math-op @@ -157,13 +157,13 @@ SYMBOL: fast-math-ops ] bi@ append ; : each-derived-op ( word quot -- ) - >r derived-ops r> each ; inline + [ derived-ops ] dip each ; inline : each-fast-derived-op ( word quot -- ) - >r fast-derived-ops r> each ; inline + [ fast-derived-ops ] dip each ; inline : each-integer-derived-op ( word quot -- ) - >r integer-derived-ops r> each ; inline + [ integer-derived-ops ] dip each ; inline [ [ diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 5acdc43ca3..41fd28e441 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -8,7 +8,7 @@ TUPLE: range { step read-only } ; : ( a b step -- range ) - >r over - r> + [ over - ] dip [ / 1+ 0 max >integer ] keep range boa ; inline diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index d9dea22b7b..81294d29f7 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -12,10 +12,10 @@ IN: math.ratios dup 1 number= [ drop ] [ ] if ; inline : scale ( a/b c/d -- a*d b*c ) - 2>fraction >r * swap r> * swap ; inline + 2>fraction [ * swap ] dip * swap ; inline : ratio+d ( a/b c/d -- b*d ) - denominator swap denominator * ; inline + [ denominator ] bi@ * ; inline PRIVATE> @@ -24,7 +24,7 @@ M: integer / "Division by zero" throw ] [ dup 0 < [ [ neg ] bi@ ] when - 2dup gcd nip tuck /i >r /i r> fraction> + 2dup gcd nip tuck /i [ /i ] dip fraction> ] if ; M: ratio hashcode* @@ -52,7 +52,7 @@ M: ratio >= scale >= ; M: ratio + 2dup scale + -rot ratio+d / ; M: ratio - 2dup scale - -rot ratio+d / ; -M: ratio * 2>fraction * >r * r> / ; +M: ratio * 2>fraction * [ * ] dip / ; M: ratio / scale / ; M: ratio /i scale /i ; M: ratio /f scale /f ; diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 140eddb2f6..7ee948be65 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -34,7 +34,7 @@ HELP: n*v { $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; HELP: v*n -{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } } { $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; HELP: n/v diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 5316720b2f..01a421b4e7 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -25,7 +25,7 @@ IN: math.vectors : normalize ( u -- v ) dup norm v/n ; : set-axis ( u v axis -- w ) - [ >r zero? 2over ? r> swap nth ] map-index 2nip ; + [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; HINTS: vneg { array } ; HINTS: norm-sq { array } ; diff --git a/basis/models/filter/filter-docs.factor b/basis/models/filter/filter-docs.factor index 8c50aac65b..c3f4df3250 100644 --- a/basis/models/filter/filter-docs.factor +++ b/basis/models/filter/filter-docs.factor @@ -15,7 +15,7 @@ HELP: filter } ; HELP: -{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } } +{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } { "filter" "a new " { $link filter } } } { $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." } { $examples "See the example in the documentation for " { $link filter } "." } ; diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 97e4557ada..5295420ee3 100644 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -66,11 +66,11 @@ HELP: set-model { set-model change-model (change-model) } related-words HELP: change-model -{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } } +{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } } { $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value, and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ; HELP: (change-model) -{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } } +{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } } { $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." } { $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ; diff --git a/basis/opengl/gl/windows/tags.txt b/basis/opengl/gl/windows/tags.txt old mode 100644 new mode 100755 index 02ec70f741..6bf68304bb --- a/basis/opengl/gl/windows/tags.txt +++ b/basis/opengl/gl/windows/tags.txt @@ -1,2 +1 @@ unportable -windows diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 64326f340e..ecb4c4a08c 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -31,7 +31,7 @@ IN: opengl over glEnableClientState dip glDisableClientState ; inline : words>values ( word/value-seq -- value-seq ) - [ dup word? [ execute ] [ ] if ] map ; + [ dup word? [ execute ] when ] map ; : (all-enabled) ( seq quot -- ) over [ glEnable ] each dip [ glDisable ] each ; inline @@ -64,17 +64,18 @@ MACRO: all-enabled-client-state ( seq quot -- ) [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline : line-vertices ( a b -- ) - append >c-float-array gl-vertex-pointer ; + [ first2 [ 0.5 + ] bi@ ] bi@ 4 narray + >c-float-array gl-vertex-pointer ; : gl-line ( a b -- ) line-vertices GL_LINES 0 2 glDrawArrays ; : (rect-vertices) ( dim -- vertices ) { - [ drop 0 1 ] - [ first 1- 1 ] - [ [ first 1- ] [ second ] bi ] - [ second 0 swap ] + [ drop 0.5 0.5 ] + [ first 0.3 - 0.5 ] + [ [ first 0.3 - ] [ second 0.3 - ] bi ] + [ second 0.3 - 0.5 swap ] } cleave 8 narray >c-float-array ; : rect-vertices ( dim -- ) diff --git a/basis/peg/peg-docs.factor b/basis/peg/peg-docs.factor index 00390c1b1e..976c32d102 100644 --- a/basis/peg/peg-docs.factor +++ b/basis/peg/peg-docs.factor @@ -98,7 +98,7 @@ HELP: optional HELP: semantic { $values { "parser" "a parser" } - { "quot" "a quotation with stack effect ( object -- bool )" } + { "quot" { $quotation "( object -- ? )" } } } { $description "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with " @@ -130,7 +130,7 @@ HELP: ensure-not HELP: action { $values { "parser" "a parser" } - { "quot" "a quotation with stack effect ( ast -- ast )" } + { "quot" { $quotation "( ast -- ast )" } } } { $description "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting " diff --git a/basis/prettyprint/backend/backend-docs.factor b/basis/prettyprint/backend/backend-docs.factor index cc4f5cedb5..64e1fd45ff 100644 --- a/basis/prettyprint/backend/backend-docs.factor +++ b/basis/prettyprint/backend/backend-docs.factor @@ -37,7 +37,7 @@ HELP: nesting-limit? $prettyprinting-note ; HELP: check-recursion -{ $values { "obj" "an object" } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } } +{ $values { "obj" "an object" } { "quot" { $quotation "( obj -- )" } } } { $description "If the object is already being printed, that is, if the prettyprinter has encountered a cycle in the object graph, or if the maximum nesting depth has been reached, outputs a dummy string. Otherwise applies the quotation to the object." } $prettyprinting-note ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 31b6ba3f26..2af0224e32 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -217,14 +217,24 @@ M: vector pprint* pprint-object ; M: byte-vector pprint* pprint-object ; M: hashtable pprint* pprint-object ; +GENERIC: valid-callable? ( obj -- ? ) + +M: object valid-callable? drop f ; + +M: quotation valid-callable? drop t ; + +M: curry valid-callable? quot>> valid-callable? ; + +M: compose valid-callable? + [ first>> ] [ second>> ] bi [ valid-callable? ] both? ; + M: curry pprint* - dup quot>> callable? [ pprint-object ] [ + dup valid-callable? [ pprint-object ] [ "( invalid curry )" swap present-text ] if ; M: compose pprint* - dup [ first>> callable? ] [ second>> callable? ] bi and - [ pprint-object ] [ + dup valid-callable? [ pprint-object ] [ "( invalid compose )" swap present-text ] if ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 6a4ac71eb8..7fa3c5a1a3 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -355,3 +355,18 @@ INTERSECTION: intersection-see-test sequence number ; [ ] [ \ curry see ] unit-test [ "POSTPONE: [" ] [ \ [ unparse ] unit-test + +TUPLE: started-out-hustlin' ; + +GENERIC: ended-up-ballin' + +M: started-out-hustlin' ended-up-ballin' ; inline + +[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [ + [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer +] unit-test + +[ "( invalid curry )" ] [ 1 2 curry unparse ] unit-test +[ "( invalid curry )" ] [ 1 2 3 curry curry unparse ] unit-test +[ "( invalid compose )" ] [ 1 2 compose unparse ] unit-test +[ "( invalid compose )" ] [ [ 1 ] 2 3 curry compose unparse ] unit-test diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index b0293a8759..1ecca0ec19 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -7,7 +7,7 @@ prettyprint.config sorting splitting grouping math.parser vocabs definitions effects classes.builtin classes.tuple io.files classes continuations hashtables classes.mixin classes.union classes.intersection classes.predicate classes.singleton -combinators quotations sets accessors colors ; +combinators quotations sets accessors colors parser ; IN: prettyprint : make-pprint ( obj quot -- block in use ) @@ -48,6 +48,22 @@ IN: prettyprint dupd remove [ { "syntax" "scratchpad" } member? not ] filter use. in. ; +: vocab-names ( words -- vocabs ) + dictionary get + [ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ; + +: prelude. ( -- ) + in get use get vocab-names vocabs. ; + +[ + nl + "Restarts were invoked adding vocabularies to the search path." print + "To avoid doing this in the future, add the following USING:" print + "and IN: forms at the top of the source file:" print nl + prelude. + nl +] print-use-hook set-global + : with-use ( obj quot -- ) make-pprint vocabs. do-pprint ; inline @@ -253,6 +269,9 @@ M: object see block> ] with-use nl ; +M: method-spec see + first2 method see ; + GENERIC: see-class* ( word -- ) M: union-class see-class* diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor index 842a36a13b..4f1c073a2d 100644 --- a/basis/prettyprint/sections/sections-docs.factor +++ b/basis/prettyprint/sections/sections-docs.factor @@ -145,7 +145,7 @@ HELP: save-end-position { $description "Save the current position as the end position of the block." } ; HELP: pprint-sections -{ $values { "block" block } { "advancer" "a quotation with stack effect " { $snippet "( block -- )" } } } +{ $values { "block" block } { "advancer" { $quotation "( block -- )" } } } { $description "Prints child sections of a block, ignoring any " { $link line-break } " sections. The " { $snippet "advancer" } " quotation is called between every pair of sections." } ; HELP: do-break @@ -157,7 +157,7 @@ HELP: empty-block? { $description "Tests if the block has no child sections." } ; HELP: if-nonempty -{ $values { "block" block } { "quot" "a quotation with stack effect " { $snippet "( block -- )" } } } +{ $values { "block" block } { "quot" { $quotation "( block -- )" } } } { $description "If the block has child sections, calls the quotation, otherwise does nothing." } ; HELP: ( ] when pop-stack boa push-stack ; + [ ] when pop-stack new swap >>term push-stack ; ! non-capturing groups : (parse-special-group) ( -- ) @@ -294,6 +294,7 @@ ERROR: unrecognized-escape char ; read1 { { CHAR: \ [ CHAR: \ ] } + { CHAR: / [ CHAR: / ] } { CHAR: ^ [ CHAR: ^ ] } { CHAR: $ [ CHAR: $ ] } { CHAR: - [ CHAR: - ] } diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 2339628801..4878b67d0f 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -2,6 +2,9 @@ USING: regexp tools.test kernel sequences regexp.parser regexp.traversal eval ; IN: regexp-tests +\ must-infer +\ matches? must-infer + [ f ] [ "b" "a*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test [ t ] [ "a" "a*" matches? ] unit-test @@ -43,6 +46,18 @@ IN: regexp-tests [ t ] [ "a" ".+" matches? ] unit-test [ t ] [ "ab" ".+" matches? ] unit-test +[ t ] [ " " "[\\s]" matches? ] unit-test +[ f ] [ "a" "[\\s]" matches? ] unit-test +[ f ] [ " " "[\\S]" matches? ] unit-test +[ t ] [ "a" "[\\S]" matches? ] unit-test +[ f ] [ " " "[\\w]" matches? ] unit-test +[ t ] [ "a" "[\\w]" matches? ] unit-test +[ t ] [ " " "[\\W]" matches? ] unit-test +[ f ] [ "a" "[\\W]" matches? ] unit-test + +[ t ] [ "/" "\\/" matches? ] unit-test + +[ t ] [ "a" R' a'i matches? ] unit-test [ t ] [ "" "a|b*|c+|d?" matches? ] unit-test [ t ] [ "a" "a|b*|c+|d?" matches? ] unit-test @@ -331,3 +346,7 @@ IN: regexp-tests [ { 0 3 } ] [ "abc" "(ab|a)(bc)?" first-match ] unit-test [ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" first-match ] unit-test + +[ t ] [ "a:b" ".+:?" matches? ] unit-test + +[ 1 ] [ "hello" ".+?" match length ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 083a48a470..c9a1d2f47d 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -28,7 +28,7 @@ IN: regexp : match ( string regexp -- pair ) do-match return-match ; -: match* ( string regexp -- pair ) +: match* ( string regexp -- pair captured-groups ) do-match [ return-match ] [ captured-groups>> ] bi ; : matches? ( string regexp -- ? ) @@ -129,8 +129,6 @@ IN: regexp : option? ( option regexp -- ? ) options>> key? ; -USE: multiline -/* M: regexp pprint* [ [ @@ -139,4 +137,3 @@ M: regexp pprint* case-insensitive swap option? [ "i" % ] when ] "" make ] keep present-text ; -*/ diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index 91c7ce16dc..c9e8a54348 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -107,7 +107,8 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) : increment-state ( dfa-traverser state -- dfa-traverser ) [ dup traverse-forward>> - [ 1+ ] [ 1- ] ? change-current-index + [ [ 1+ ] change-current-index ] + [ [ 1- ] change-current-index ] if dup current-state>> >>last-state ] dip first >>current-state ; diff --git a/basis/regexp/utils/utils-tests.factor b/basis/regexp/utils/utils-tests.factor new file mode 100644 index 0000000000..d048ad4be1 --- /dev/null +++ b/basis/regexp/utils/utils-tests.factor @@ -0,0 +1,4 @@ +USING: regexp.utils tools.test ; +IN: regexp.utils.tests + +[ [ ] [ ] while-changes ] must-infer diff --git a/basis/regexp/utils/utils.factor b/basis/regexp/utils/utils.factor index fb058ecf92..5116dd2b7e 100644 --- a/basis/regexp/utils/utils.factor +++ b/basis/regexp/utils/utils.factor @@ -5,9 +5,7 @@ namespaces regexp.backend sequences unicode.categories math.ranges fry combinators.short-circuit vectors ; IN: regexp.utils -: (while-changes) ( obj quot pred pred-ret -- obj ) - ! quot: ( obj -- obj' ) - ! pred: ( obj -- <=> ) +: (while-changes) ( obj quot: ( obj -- obj' ) pred: ( obj -- <=> ) pred-ret -- obj ) [ [ dup slip ] dip pick over call ] dip dupd = [ 3drop ] [ (while-changes) ] if ; inline recursive diff --git a/basis/search-deques/search-deques-docs.factor b/basis/search-deques/search-deques-docs.factor index fef770b0f8..fe0ce7c157 100644 --- a/basis/search-deques/search-deques-docs.factor +++ b/basis/search-deques/search-deques-docs.factor @@ -1,21 +1,15 @@ IN: search-deques -USING: help.markup help.syntax kernel dlists hashtables +USING: help.markup help.syntax kernel hashtables deques assocs ; ARTICLE: "search-deques" "Search deques" "A search deque is a data structure with constant-time insertion and removal of elements at both ends, and constant-time membership tests. Inserting an element more than once has no effect. Search deques implement all deque operations in terms of an underlying deque, and membership testing with " { $link deque-member? } " is implemented with an underlying assoc. Search deques are defined in the " { $vocab-link "search-deques" } " vocabulary." $nl "Creating a search deque:" -{ $subsection } -"Default implementation:" -{ $subsection } ; +{ $subsection } ; ABOUT: "search-deques" HELP: ( assoc deque -- search-deque ) { $values { "assoc" assoc } { "deque" deque } { "search-deque" search-deque } } { $description "Creates a new " { $link search-deque } "." } ; - -HELP: ( -- search-deque ) -{ $values { "search-deque" search-deque } } -{ $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ; diff --git a/basis/search-deques/search-deques-tests.factor b/basis/search-deques/search-deques-tests.factor index cf2837a84c..7c40c60f7a 100644 --- a/basis/search-deques/search-deques-tests.factor +++ b/basis/search-deques/search-deques-tests.factor @@ -1,6 +1,6 @@ IN: search-deques.tests USING: search-deques tools.test namespaces -kernel sequences words deques vocabs ; +kernel sequences words deques vocabs dlists ; "h" set @@ -15,13 +15,11 @@ kernel sequences words deques vocabs ; [ t ] [ "1" get "2" get eq? ] unit-test [ t ] [ "2" get "3" get eq? ] unit-test -[ 3 ] [ "h" get deque-length ] unit-test [ t ] [ 7 "h" get deque-member? ] unit-test [ 3 ] [ "1" get node-value ] unit-test [ ] [ "1" get "h" get delete-node ] unit-test -[ 2 ] [ "h" get deque-length ] unit-test [ 1 ] [ "h" get pop-back ] unit-test [ 7 ] [ "h" get pop-back ] unit-test diff --git a/basis/search-deques/search-deques.factor b/basis/search-deques/search-deques.factor index 8e5506090c..5546a9766d 100644 --- a/basis/search-deques/search-deques.factor +++ b/basis/search-deques/search-deques.factor @@ -1,16 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel assocs deques dlists hashtables ; +USING: accessors kernel assocs deques ; IN: search-deques TUPLE: search-deque assoc deque ; C: search-deque -: ( -- search-deque ) - 0 ; - -M: search-deque deque-length deque>> deque-length ; +M: search-deque deque-empty? deque>> deque-empty? ; M: search-deque peek-front deque>> peek-front ; diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index efdc7e23b2..31ae0a6789 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -24,7 +24,7 @@ M: inference-error error-help error>> error-help ; +warning+ (inference-error) ; inline M: inference-error error. - [ "In word: " write word>> . ] [ error>> error. ] bi ; + [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; TUPLE: literal-expected ; @@ -108,3 +108,9 @@ M: inconsistent-recursive-call-error error. "The recursive word " write word>> pprint " calls itself with a different set of quotation parameters than were input" print ; + +TUPLE: unknown-primitive-error ; + +M: unknown-primitive-error error. + drop + "Cannot determine stack effect statically" print ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 4aea0f2d28..fdc4b4b35c 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -162,7 +162,7 @@ M: object infer-call* { \ load-locals [ infer-load-locals ] } { \ get-local [ infer-get-local ] } { \ drop-locals [ infer-drop-locals ] } - { \ do-primitive [ \ do-primitive cannot-infer-effect ] } + { \ do-primitive [ unknown-primitive-error inference-warning ] } { \ alien-invoke [ infer-alien-invoke ] } { \ alien-indirect [ infer-alien-indirect ] } { \ alien-callback [ infer-alien-callback ] } diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor index 41d7331230..9abfb1fcd5 100644 --- a/basis/stack-checker/recursive-state/recursive-state.factor +++ b/basis/stack-checker/recursive-state/recursive-state.factor @@ -4,9 +4,7 @@ USING: accessors arrays sequences kernel sequences assocs namespaces stack-checker.recursive-state.tree ; IN: stack-checker.recursive-state -TUPLE: recursive-state words word quotations inline-words ; - -C: recursive-state +TUPLE: recursive-state word words quotations inline-words ; : prepare-recursive-state ( word rstate -- rstate ) swap >>word diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 9bf8ed62f0..defcde53f0 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -580,3 +580,5 @@ DEFER: eee' dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive [ bogus-error ] must-infer + +[ [ clear ] infer. ] [ inference-error? ] must-fail-with diff --git a/extra/state-tables/authors.txt b/basis/state-tables/authors.txt similarity index 100% rename from extra/state-tables/authors.txt rename to basis/state-tables/authors.txt diff --git a/extra/state-tables/state-tables-tests.factor b/basis/state-tables/state-tables-tests.factor similarity index 100% rename from extra/state-tables/state-tables-tests.factor rename to basis/state-tables/state-tables-tests.factor diff --git a/extra/state-tables/state-tables.factor b/basis/state-tables/state-tables.factor similarity index 100% rename from extra/state-tables/state-tables.factor rename to basis/state-tables/state-tables.factor diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index b181ba9d60..fa68cc0a8e 100755 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -5,6 +5,7 @@ math.vectors math.order sorting binary-search sets assocs fry ; IN: suffix-arrays } " then passed to " { $link (spawn) } "." } ; HELP: run-queue -{ $values { "queue" dlist } } +{ $values { "queue" deque } } { $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time." $nl "By convention, threads are queued with " { $link push-front } @@ -129,7 +129,7 @@ HELP: interrupt { $description "Interrupts a sleeping thread." } ; HELP: suspend -{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "state" string } { "obj" object } } +{ $values { "quot" { $quotation "( 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 } "." @@ -149,7 +149,7 @@ $nl } ; HELP: spawn-server -{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } { "thread" thread } } +{ $values { "quot" { $quotation "( -- ? )" } } { "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:" @@ -172,5 +172,5 @@ HELP: tset { $description "Sets the value of a thread-local variable." } ; HELP: tchange -{ $values { "key" object } { "quot" "a quotation with stack effect " { $snippet "( value -- newvalue )" } } } +{ $values { "key" object } { "quot" { $quotation "( value -- newvalue )" } } } { $description "Applies the quotation to the current value of a thread-local variable, storing the result back to the same variable." } ; diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index f0a3235e62..c61b4547a9 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -13,7 +13,7 @@ ARTICLE: "tools.annotations" "Word annotations" ABOUT: "tools.annotations" HELP: annotate -{ $values { "word" "a word" } { "quot" "a quotation with stack effect " { $snippet "( word def -- def )" } } } +{ $values { "word" "a word" } { "quot" { $quotation "( word def -- def )" } } } { $description "Changes a word definition to the result of applying a quotation to the old definition." } { $notes "This word is used to implement " { $link watch } "." } ; @@ -28,7 +28,7 @@ HELP: breakpoint { $description "Annotates a word definition to enter the single stepper when executed." } ; HELP: breakpoint-if -{ $values { "quot" "a quotation with stack effect" { $snippet "( -- ? )" } } { "word" word } } +{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } } { $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ; HELP: annotate-methods diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 4bb6d6142f..2306ff53a8 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -72,7 +72,9 @@ IN: tools.completion ] if ; : string-completions ( short strs -- seq ) - [ dup ] { } map>assoc completions ; + dup zip completions ; : limited-completions ( short candidates -- seq ) - completions dup length 1000 > [ drop f ] when ; + [ completions ] [ drop ] 2bi + 2dup [ length 50 > ] [ empty? ] bi* and + [ 2drop f ] [ drop 50 short head ] if ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index a7332ea9ea..f8f9680c16 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -9,7 +9,7 @@ sorting compiler.units definitions ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes QUALIFIED: command-line -QUALIFIED: compiler.errors.private +QUALIFIED: compiler.errors QUALIFIED: continuations QUALIFIED: definitions QUALIFIED: init @@ -291,7 +291,7 @@ IN: tools.deploy.shaker strip-debugger? [ { - compiler.errors.private:compiler-errors + compiler.errors:compiler-errors continuations:thread-error-hook } % ] when diff --git a/basis/tools/deploy/windows/tags.txt b/basis/tools/deploy/windows/tags.txt old mode 100644 new mode 100755 index b58a515ed8..660d511420 --- a/basis/tools/deploy/windows/tags.txt +++ b/basis/tools/deploy/windows/tags.txt @@ -1,3 +1,2 @@ unportable -windows tools diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index 02c0ad126d..f19ffb83a4 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -60,7 +60,7 @@ HELP: must-fail { $notes "This word is used to test boundary conditions and fail-fast behavior." } ; HELP: must-fail-with -{ $values { "quot" "a quotation run with an empty stack" } { "pred" "a quotation with stack effect " { $snippet "( error -- ? )" } } } +{ $values { "quot" "a quotation run with an empty stack" } { "pred" { $quotation "( error -- ? )" } } } { $description "Runs a quotation with an empty stack, expecting it to throw an error which must satisfy " { $snippet "pred" } ". If the quotation does not throw an error, or if the error does not match the predicate, the unit test fails." } { $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ; diff --git a/basis/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor index 25312ad868..5f1ff6dabd 100644 --- a/basis/ui/commands/commands-docs.factor +++ b/basis/ui/commands/commands-docs.factor @@ -71,7 +71,7 @@ HELP: command-word { $description "Outputs the word that will be executed by " { $link invoke-command } ". This is only used for documentation purposes." } ; HELP: command-map -{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } } +{ $values { "group" string } { "class" "a class word" } { "command-map" { $maybe command-map } } } { $description "Outputs a named command map defined on a class." } { $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map." $nl @@ -82,7 +82,7 @@ HELP: commands { $description "Outputs a hashtable mapping command map names to " { $link command-map } " instances." } ; HELP: define-command-map -{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "pairs" "a sequence of gesture/word pairs" } } +{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "pairs" "a sequence of gesture/word pairs" } } { $description "Defines a command map on the specified gadget class. The " { $snippet "specs" } " parameter is a sequence of pairs " { $snippet "{ gesture word }" } ". The words must be valid commands; see " { $link define-command } "." } diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 5a6118fb00..d2dfe56ed4 100644 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -196,7 +196,6 @@ M: freetype-renderer string-height ( open-font string -- h ) :: (draw-string) ( open-font sprites string loc -- ) GL_TEXTURE_2D [ loc [ - -0.5 0.5 0.0 glTranslated string open-font string char-widths scan-sums [ [ open-font sprites ] 2dip draw-char ] 2each diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index c4edaac144..4a428404c1 100644 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/basis/ui/gadgets/buttons/buttons-docs.factor @@ -10,19 +10,19 @@ $nl "A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by the " { $link } " word to construct a row of buttons for choosing among several alternatives." } ; HELP: + diff --git a/extra/webapps/pastebin/new-paste.xml b/extra/webapps/pastebin/new-paste.xml index 96339b6cf8..9866c8819a 100644 --- a/extra/webapps/pastebin/new-paste.xml +++ b/extra/webapps/pastebin/new-paste.xml @@ -18,6 +18,6 @@ -

+

diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 8fe672049f..a48d2ea42d 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -52,7 +52,7 @@ -

+

diff --git a/extra/webapps/user-admin/new-user.xml b/extra/webapps/user-admin/new-user.xml index d3cf681165..0820dbcb64 100644 --- a/extra/webapps/user-admin/new-user.xml +++ b/extra/webapps/user-admin/new-user.xml @@ -37,7 +37,7 @@ Capabilities: -

  • +
    diff --git a/extra/webapps/user-admin/user-admin-docs.factor b/extra/webapps/user-admin/user-admin-docs.factor new file mode 100644 index 0000000000..3551210664 --- /dev/null +++ b/extra/webapps/user-admin/user-admin-docs.factor @@ -0,0 +1,22 @@ +USING: help.markup help.syntax db strings ; +IN: webapps.user-admin + +HELP: +{ $values { "responder" "a new responder" } } +{ $description "Creates a new instance of the user admin tool. This tool must be added to an authentication realm, and access is restricted to users having the " { $link can-administer-users? } " capability." } ; + +HELP: can-administer-users? +{ $description "A user capability. Users having this capability may use the " { $link user-admin } " tool." } +{ $notes "See " { $link "furnace.auth.capabilities" } " for information about capabilities." } ; + +HELP: make-admin +{ $values { "username" string } } +{ $description "Makes an existing user into an administrator by giving them the " { $link can-administer-users? } " capability, thus allowing them to use the user admin tool." } ; + +ARTICLE: "furnace.auth.user-admin" "Furnace user administration tool" +"The " { $vocab-link "webapps.user-admin" } " vocabulary implements a web application for adding, removing and editing users in authentication realms that use " { $link "furnace.auth.providers.db" } "." +{ $subsection } +"Access to the web app itself is protected, and only users having an administrative capability can access it:" +{ $subsection can-administer-users? } +"To make an existing user an administrator, call the following word in a " { $link with-db } " scope:" +{ $subsection make-admin } ; diff --git a/extra/webapps/wee-url/shorten.xml b/extra/webapps/wee-url/shorten.xml index 53f611a8d8..3dda556aa2 100644 --- a/extra/webapps/wee-url/shorten.xml +++ b/extra/webapps/wee-url/shorten.xml @@ -4,7 +4,7 @@

    Shorten URL:

    - +     diff --git a/extra/webapps/wiki/edit.xml b/extra/webapps/wiki/edit.xml index 9cb2e92f93..f8c593cf2f 100644 --- a/extra/webapps/wiki/edit.xml +++ b/extra/webapps/wiki/edit.xml @@ -16,7 +16,7 @@

    - +

    diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 1d9c01fd65..759cc77449 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -32,7 +32,7 @@ - + diff --git a/misc/factor.el b/misc/factor.el index 5d937c14ca..170da980be 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -1,36 +1,198 @@ -;; Eduardo Cavazos - wayo.cavazos@gmail.com +;;; factor.el --- Interacting with Factor within emacs +;; +;; Authors: Eduardo Cavazos +;; Jose A Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;;; Quick setup: -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Add these lines to your .emacs file: - -;; (load-file "/scratch/repos/Factor/misc/factor.el") -;; (setq factor-binary "/scratch/repos/Factor/factor") -;; (setq factor-image "/scratch/repos/Factor/factor.image") - +;; +;; (load-file "/scratch/repos/Factor/misc/factor.el") +;; (setq factor-binary "/scratch/repos/Factor/factor") +;; (setq factor-image "/scratch/repos/Factor/factor.image") +;; ;; Of course, you'll have to edit the directory paths for your system -;; accordingly. - +;; accordingly. Alternatively, put this file in your load-path and use +;; +;; (require 'factor) +;; +;; instead of load-file. +;; ;; That's all you have to do to "install" factor.el on your ;; system. Whenever you edit a factor file, Emacs will know to switch ;; to Factor mode. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; For further customization options, +;; M-x customize-group RET factor +;; +;; To start a Factor listener inside Emacs, +;; M-x run-factor -;; M-x run-factor === Start a Factor listener inside Emacs +;;; Requirements: -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require 'font-lock) +(require 'comint) + +;;; Customization: (defgroup factor nil "Factor mode" :group 'languages) -(defvar factor-mode-syntax-table nil - "Syntax table used while in Factor mode.") +(defcustom factor-default-indent-width 4 + "Default indentantion width for factor-mode. + +This value will be used for the local variable +`factor-indent-width' in new factor buffers. For existing code, +we first check if `factor-indent-width' is set explicitly in a +local variable section or line (e.g. '! -*- factor-indent-witdth: 2 -*-'). +If that's not the case, `factor-mode' tries to infer its correct +value from the existing code in the buffer." + :type 'integer + :group 'factor) + +(defcustom factor-binary "~/factor/factor" + "Full path to the factor executable to use when starting a listener." + :type '(file :must-match t) + :group 'factor) + +(defcustom factor-image "~/factor/factor.image" + "Full path to the factor image to use when starting a listener." + :type '(file :must-match t) + :group 'factor) (defcustom factor-display-compilation-output t "Display the REPL buffer before compiling files." - :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :type 'boolean :group 'factor) +(defcustom factor-mode-hook nil + "Hook run when entering Factor mode." + :type 'hook + :group 'factor) + +(defgroup factor-faces nil + "Faces used in Factor mode" + :group 'factor + :group 'faces) + +(defsubst factor--face (face) `((t ,(face-attr-construct face)))) + +(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face) + "Face for parsing words." + :group 'factor-faces) + +(defface factor-font-lock-comment (factor--face font-lock-comment-face) + "Face for comments." + :group 'factor-faces) + +(defface factor-font-lock-string (factor--face font-lock-string-face) + "Face for strings." + :group 'factor-faces) + +(defface factor-font-lock-stack-effect (factor--face font-lock-comment-face) + "Face for stack effect specifications." + :group 'factor-faces) + +(defface factor-font-lock-word-definition (factor--face font-lock-function-name-face) + "Face for word, generic or method being defined." + :group 'factor-faces) + +(defface factor-font-lock-symbol-definition (factor--face font-lock-variable-name-face) + "Face for name of symbol being defined." + :group 'factor-faces) + +(defface factor-font-lock-vocabulary-name (factor--face font-lock-constant-face) + "Face for names of vocabularies in USE or USING." + :group 'factor-faces) + +(defface factor-font-lock-type-definition (factor--face font-lock-type-face) + "Face for type (tuple) names." + :group 'factor-faces) + +(defface factor-font-lock-constructor (factor--face font-lock-type-face) + "Face for constructors ()." + :group 'factor-faces) + +(defface factor-font-lock-setter-word (factor--face font-lock-function-name-face) + "Face for setter words (>>foo)." + :group 'factor-faces) + +(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face) + "Face for parsing words." + :group 'factor-faces) + + +;;; Factor mode font lock: + +(defconst factor--parsing-words + '("{" "}" "^:" "^::" ";" "<<" ">" + "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" + "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:" + "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{" + "IN:" "INSTANCE:" "INTERSECTION:" + "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:" + "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" + "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:" + "TUPLE:" "T{" "t\\??" "TYPEDEF:" + "UNION:" "USE:" "USING:" "V{" "VAR:" "VARS:" "W{")) + +(defconst factor--regex-parsing-words-ext + (regexp-opt '("B" "call-next-method" "delimiter" "f" "flushable" "foldable" + "initial:" "inline" "parsing" "read-only" "recursive") + 'words)) + +(defsubst factor--regex-second-word (prefixes) + (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t))) + +(defconst factor--regex-word-definition + (factor--regex-second-word '(":" "::" "M:" "GENERIC:"))) + +(defconst factor--regex-type-definition + (factor--regex-second-word '("TUPLE:"))) + +(defconst factor--regex-parent-type "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)") + +(defconst factor--regex-constructor "<[^ >]+>") + +(defconst factor--regex-setter "\\W>>[^ ]+\\b") + +(defconst factor--regex-symbol-definition + (factor--regex-second-word '("SYMBOL:"))) + +(defconst factor--regex-using-line "^USING: +\\([^;]*\\);") +(defconst factor--regex-use-line "^USE: +\\(.*\\)$") + +(defconst factor-font-lock-keywords + `(("#!.*$" . 'factor-font-lock-comment) + ("!( .* )" . 'factor-font-lock-comment) + ("^!.*$" . 'factor-font-lock-comment) + (" !.*$" . 'factor-font-lock-comment) + ("( .* )" . 'factor-font-lock-stack-effect) + ("\"\\(\\\\\"\\|[^\"]\\)*\"" . 'factor-font-lock-string) + ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) + ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)") + '(2 'factor-font-lock-parsing-word))) + factor--parsing-words) + (,factor--regex-parsing-words-ext . 'factor-font-lock-parsing-word) + (,factor--regex-word-definition 2 'factor-font-lock-word-definition) + (,factor--regex-type-definition 2 'factor-font-lock-type-definition) + (,factor--regex-parent-type 1 'factor-font-lock-type-definition) + (,factor--regex-constructor . 'factor-font-lock-constructor) + (,factor--regex-setter . 'factor-font-lock-setter-word) + (,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition) + (,factor--regex-using-line 1 'factor-font-lock-vocabulary-name) + (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name)) + "Font lock keywords definition for Factor mode.") + + +;;; Factor mode syntax: + +(defvar factor-mode-syntax-table nil + "Syntax table used while in Factor mode.") (if factor-mode-syntax-table () @@ -72,90 +234,146 @@ (modify-syntax-entry ?\) ")(" factor-mode-syntax-table) (modify-syntax-entry ?\" "\" " factor-mode-syntax-table))) -(defvar factor-mode-map (make-sparse-keymap)) + +;;; Factor mode indentation: -(defcustom factor-mode-hook nil - "Hook run when entering Factor mode." - :type 'hook - :group 'factor) +(make-variable-buffer-local + (defvar factor-indent-width factor-default-indent-width + "Indentation width in factor buffers. A local variable.")) -(defconst factor--parsing-words - '("{" "}" "^:" "^::" ";" "<<" ">" - "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" - "DEFER:" "ERROR:" "FORGET:" - "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{" - "IN:" "INSTANCE:" "INTERSECTION:" - "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:" - "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" - "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:" - "TUPLE:" "T{" "t\\??" "TYPEDEF:" - "UNION:" "USE:" "USING:" "V{" "VAR:" "VARS:" "W{")) +(defconst factor--regexp-word-start + (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) + (format "^\\(%s\\): " (mapconcat 'identity sws "\\|")))) -(defconst factor--regex-parsing-words-ext - (regexp-opt '("B" "call-next-method" "delimiter" "f" "flushable" "foldable" - "initial:" "inline" "parsing" "read-only" "recursive") - 'words)) +(defun factor--guess-indent-width () + "Chooses an indentation value from existing code." + (let ((word-cont "^ +[^ ]") + (iw)) + (save-excursion + (beginning-of-buffer) + (while (not iw) + (if (not (re-search-forward factor--regexp-word-start nil t)) + (setq iw factor-default-indent-width) + (forward-line) + (when (looking-at word-cont) + (setq iw (current-indentation)))))) + iw)) -(defun factor--regex-second-word (prefixes) - (format "^%s +\\([^ ]+\\)" (regexp-opt prefixes t))) +(defsubst factor--ppss-brackets-depth () + (nth 0 (syntax-ppss))) -(defconst factor--regex-word-definition - (factor--regex-second-word '(":" "::" "M:" "GENERIC:"))) +(defsubst factor--ppss-brackets-start () + (nth 1 (syntax-ppss))) -(defconst factor--regex-type-definition - (factor--regex-second-word '("TUPLE:"))) +(defsubst factor--indentation-at (pos) + (save-excursion (goto-char pos) (current-indentation))) -(defconst factor--regex-const-definition - (factor--regex-second-word '("SYMBOL:"))) +(defconst factor--regex-closing-paren "[])}]") +(defsubst factor--at-closing-paren-p () + (looking-at factor--regex-closing-paren)) -(defconst factor-font-lock-keywords - `(("#!.*$" . font-lock-comment-face) - ("!( .* )" . font-lock-comment-face) - ("^!.*$" . font-lock-comment-face) - (" !.*$" . font-lock-comment-face) - ("( .* )" . font-lock-comment-face) - ("\"[^ ][^\"]*\"" . font-lock-string-face) - ("\"\"" . font-lock-string-face) - ("\\(P\\|SBUF\\)\"" 1 font-lock-keyword-face) - ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)") - '(2 font-lock-keyword-face))) - factor--parsing-words) - (,factor--regex-parsing-words-ext . font-lock-keyword-face) - (,factor--regex-word-definition 2 font-lock-function-name-face) - (,factor--regex-type-definition 2 font-lock-type-face) - (,factor--regex-const-definition 2 font-lock-constant-face))) +(defsubst factor--at-first-char-p () + (= (- (point) (line-beginning-position)) (current-indentation))) -(defun factor-indent-line () +(defconst factor--regex-single-liner + (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:" + "PRIVATE>" " (factor--ppss-brackets-depth) 0)) + (let ((op (factor--ppss-brackets-start))) + (when (> (line-number-at-pos) (line-number-at-pos op)) + (if (factor--at-closing-paren-p) + (factor--indentation-at op) + (factor--increased-indentation (factor--indentation-at op)))))))) + +(defun factor--indent-definition () + (save-excursion + (beginning-of-line) + (when (factor--at-begin-of-def) 0))) + +(defun factor--indent-setter-line () + (when (factor--at-setter-line) + (save-excursion + (let ((indent (and (factor--at-constructor-line) (current-indentation)))) + (while (not (or indent + (bobp) + (factor--at-begin-of-def) + (factor--at-end-of-def))) + (if (factor--at-constructor-line) + (setq indent (factor--increased-indentation)) + (forward-line -1))) + indent)))) + +(defun factor--indent-continuation () + (save-excursion + (forward-line -1) + (while (and (not (bobp)) (factor--looking-at-emptiness)) + (forward-line -1)) + (if (or (factor--at-end-of-def) (factor--at-setter-line)) + (factor--decreased-indentation) + (if (factor--at-begin-of-def) + (factor--increased-indentation) + (current-indentation))))) + +(defun factor--calculate-indentation () + "Calculate Factor indentation for line at point." + (or (and (bobp) 0) + (factor--indent-definition) + (factor--indent-in-brackets) + (factor--indent-setter-line) + (factor--indent-continuation) + 0)) + +(defun factor--indent-line () "Indent current line as Factor code" - (indent-line-to (+ (current-indentation) 4))) + (let ((target (factor--calculate-indentation)) + (pos (- (point-max) (point)))) + (if (= target (current-indentation)) + (if (< (current-column) (current-indentation)) + (back-to-indentation)) + (beginning-of-line) + (delete-horizontal-space) + (indent-to target) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))))) -(defun factor-mode () - "A mode for editing programs written in the Factor programming language. -\\{factor-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map factor-mode-map) - (setq major-mode 'factor-mode) - (setq mode-name "Factor") - (set (make-local-variable 'indent-line-function) #'factor-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "! ") - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(factor-font-lock-keywords t nil nil nil)) - (set-syntax-table factor-mode-syntax-table) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'factor-indent-line) - (run-hooks 'factor-mode-hook)) - -(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'comint) - -(defvar factor-binary "~/factor/factor") -(defvar factor-image "~/factor/factor.image") + +;;; Factor mode commands: (defun factor-telnet-to-port (port) (interactive "nPort: ") @@ -186,11 +404,6 @@ (unless (get-buffer-window (current-buffer) t) (display-buffer (current-buffer) t)))) -;; (defun factor-send-region (start end) -;; (interactive "r") -;; (comint-send-region "*factor*" start end) -;; (comint-send-string "*factor*" "\n")) - (defun factor-send-string (str) (let ((n (length (split-string str "\n")))) (save-excursion @@ -243,6 +456,9 @@ (beginning-of-line) (insert "! ")) +(defvar factor-mode-map (make-sparse-keymap) + "Key map used by Factor mode.") + (define-key factor-mode-map "\C-c\C-f" 'factor-run-file) (define-key factor-mode-map "\C-c\C-r" 'factor-send-region) (define-key factor-mode-map "\C-c\C-d" 'factor-send-definition) @@ -253,81 +469,42 @@ (define-key factor-mode-map [return] 'newline-and-indent) (define-key factor-mode-map [tab] 'indent-for-tab-command) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; indentation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst factor-word-starting-keywords - '("" ":" "TUPLE" "MACRO" "MACRO:" "M")) + +;; Factor mode: -(defmacro factor-word-start-re (keywords) - `(format - "^\\(%s\\): " - (mapconcat 'identity ,keywords "\\|"))) +;;;###autoload +(defun factor-mode () + "A mode for editing programs written in the Factor programming language. +\\{factor-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map factor-mode-map) + (setq major-mode 'factor-mode) + (setq mode-name "Factor") + (set (make-local-variable 'comment-start) "! ") + (set (make-local-variable 'font-lock-defaults) + '(factor-font-lock-keywords t nil nil nil)) + (set-syntax-table factor-mode-syntax-table) + (set (make-local-variable 'indent-line-function) 'factor--indent-line) + (setq factor-indent-width (factor--guess-indent-width)) + (setq indent-tabs-mode nil) + (run-hooks 'factor-mode-hook)) -(defun factor-calculate-indentation () - "Calculate Factor indentation for line at point." - (let ((not-indented t) - (cur-indent 0)) - (save-excursion - (beginning-of-line) - (if (bobp) - (setq cur-indent 0) - (save-excursion - (while not-indented - ;; Check that we are inside open brackets - (save-excursion - (let ((cur-depth (factor-brackets-depth))) - (forward-line -1) - (setq cur-indent (+ (current-indentation) - (* default-tab-width - (- cur-depth (factor-brackets-depth))))) - (setq not-indented nil))) - (forward-line -1) - ;; Check that we are after the end of previous word - (if (looking-at ".*;[ \t]*$") - (progn - (setq cur-indent (- (current-indentation) default-tab-width)) - (setq not-indented nil)) - ;; Check that we are after the start of word - (if (looking-at (factor-word-start-re factor-word-starting-keywords)) -; (if (looking-at "^[A-Z:]*: ") - (progn - (message "inword") - (setq cur-indent (+ (current-indentation) default-tab-width)) - (setq not-indented nil)) - (if (bobp) - (setq not-indented nil)))))))) - cur-indent)) +(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) -(defun factor-brackets-depth () - "Returns number of brackets, not closed on previous lines." - (syntax-ppss-depth - (save-excursion - (syntax-ppss (line-beginning-position))))) - -(defun factor-indent-line () - "Indent current line as Factor code" - (let ((target (factor-calculate-indentation)) - (pos (- (point-max) (point)))) - (if (= target (current-indentation)) - (if (< (current-column) (current-indentation)) - (back-to-indentation)) - (beginning-of-line) - (delete-horizontal-space) - (indent-to target) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; factor-listener-mode -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Factor listener mode +;;;###autoload (define-derived-mode factor-listener-mode comint-mode "Factor Listener") (define-key factor-listener-mode-map [f8] 'factor-refresh-all) +;;;###autoload (defun run-factor () + "Start a factor listener inside emacs, or switch to it if it +already exists." (interactive) (switch-to-buffer (make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil @@ -336,5 +513,12 @@ (factor-listener-mode)) (defun factor-refresh-all () + "Reload source files and documentation for all loaded +vocabularies which have been modified on disk." (interactive) (comint-send-string "*factor*" "refresh-all\n")) + + + +(provide 'factor) +;;; factor.el ends here diff --git a/extra/factory/authors.txt b/unmaintained/factory/authors.txt similarity index 100% rename from extra/factory/authors.txt rename to unmaintained/factory/authors.txt diff --git a/extra/factory/commands/authors.txt b/unmaintained/factory/commands/authors.txt similarity index 100% rename from extra/factory/commands/authors.txt rename to unmaintained/factory/commands/authors.txt diff --git a/extra/factory/commands/commands.factor b/unmaintained/factory/commands/commands.factor similarity index 100% rename from extra/factory/commands/commands.factor rename to unmaintained/factory/commands/commands.factor diff --git a/extra/factory/factory-menus b/unmaintained/factory/factory-menus similarity index 100% rename from extra/factory/factory-menus rename to unmaintained/factory/factory-menus diff --git a/extra/factory/factory-rc b/unmaintained/factory/factory-rc similarity index 100% rename from extra/factory/factory-rc rename to unmaintained/factory/factory-rc diff --git a/extra/factory/factory.factor b/unmaintained/factory/factory.factor similarity index 100% rename from extra/factory/factory.factor rename to unmaintained/factory/factory.factor diff --git a/extra/factory/load/authors.txt b/unmaintained/factory/load/authors.txt similarity index 100% rename from extra/factory/load/authors.txt rename to unmaintained/factory/load/authors.txt diff --git a/extra/factory/load/load.factor b/unmaintained/factory/load/load.factor similarity index 100% rename from extra/factory/load/load.factor rename to unmaintained/factory/load/load.factor diff --git a/extra/factory/summary.txt b/unmaintained/factory/summary.txt similarity index 100% rename from extra/factory/summary.txt rename to unmaintained/factory/summary.txt diff --git a/extra/factory/tags.txt b/unmaintained/factory/tags.txt similarity index 100% rename from extra/factory/tags.txt rename to unmaintained/factory/tags.txt diff --git a/extra/geom/dim/authors.txt b/unmaintained/geom/dim/authors.txt similarity index 100% rename from extra/geom/dim/authors.txt rename to unmaintained/geom/dim/authors.txt diff --git a/extra/geom/dim/dim.factor b/unmaintained/geom/dim/dim.factor similarity index 100% rename from extra/geom/dim/dim.factor rename to unmaintained/geom/dim/dim.factor diff --git a/extra/geom/pos/authors.txt b/unmaintained/geom/pos/authors.txt similarity index 100% rename from extra/geom/pos/authors.txt rename to unmaintained/geom/pos/authors.txt diff --git a/extra/geom/pos/pos.factor b/unmaintained/geom/pos/pos.factor similarity index 100% rename from extra/geom/pos/pos.factor rename to unmaintained/geom/pos/pos.factor diff --git a/extra/geom/rect/authors.txt b/unmaintained/geom/rect/authors.txt similarity index 100% rename from extra/geom/rect/authors.txt rename to unmaintained/geom/rect/authors.txt diff --git a/extra/geom/rect/rect.factor b/unmaintained/geom/rect/rect.factor similarity index 100% rename from extra/geom/rect/rect.factor rename to unmaintained/geom/rect/rect.factor diff --git a/extra/mortar/authors.txt b/unmaintained/mortar/authors.txt similarity index 100% rename from extra/mortar/authors.txt rename to unmaintained/mortar/authors.txt diff --git a/extra/mortar/mortar.factor b/unmaintained/mortar/mortar.factor similarity index 100% rename from extra/mortar/mortar.factor rename to unmaintained/mortar/mortar.factor diff --git a/extra/mortar/sugar/sugar.factor b/unmaintained/mortar/sugar/sugar.factor similarity index 100% rename from extra/mortar/sugar/sugar.factor rename to unmaintained/mortar/sugar/sugar.factor diff --git a/extra/mortar/tags.txt b/unmaintained/mortar/tags.txt similarity index 100% rename from extra/mortar/tags.txt rename to unmaintained/mortar/tags.txt diff --git a/extra/odbc/authors.txt b/unmaintained/odbc/authors.txt similarity index 100% rename from extra/odbc/authors.txt rename to unmaintained/odbc/authors.txt diff --git a/extra/odbc/odbc-docs.factor b/unmaintained/odbc/odbc-docs.factor similarity index 100% rename from extra/odbc/odbc-docs.factor rename to unmaintained/odbc/odbc-docs.factor diff --git a/extra/odbc/odbc.factor b/unmaintained/odbc/odbc.factor similarity index 100% rename from extra/odbc/odbc.factor rename to unmaintained/odbc/odbc.factor diff --git a/extra/odbc/summary.txt b/unmaintained/odbc/summary.txt similarity index 100% rename from extra/odbc/summary.txt rename to unmaintained/odbc/summary.txt diff --git a/extra/odbc/tags.txt b/unmaintained/odbc/tags.txt similarity index 100% rename from extra/odbc/tags.txt rename to unmaintained/odbc/tags.txt diff --git a/extra/ui/gadgets/tiling/tiling.factor b/unmaintained/tiling/tiling.factor similarity index 100% rename from extra/ui/gadgets/tiling/tiling.factor rename to unmaintained/tiling/tiling.factor diff --git a/extra/x/authors.txt b/unmaintained/x/authors.txt similarity index 100% rename from extra/x/authors.txt rename to unmaintained/x/authors.txt diff --git a/extra/x/font/authors.txt b/unmaintained/x/font/authors.txt similarity index 100% rename from extra/x/font/authors.txt rename to unmaintained/x/font/authors.txt diff --git a/extra/x/font/font.factor b/unmaintained/x/font/font.factor similarity index 100% rename from extra/x/font/font.factor rename to unmaintained/x/font/font.factor diff --git a/extra/x/gc/authors.txt b/unmaintained/x/gc/authors.txt similarity index 100% rename from extra/x/gc/authors.txt rename to unmaintained/x/gc/authors.txt diff --git a/extra/x/gc/gc.factor b/unmaintained/x/gc/gc.factor similarity index 100% rename from extra/x/gc/gc.factor rename to unmaintained/x/gc/gc.factor diff --git a/extra/x/keysym-table/authors.txt b/unmaintained/x/keysym-table/authors.txt similarity index 100% rename from extra/x/keysym-table/authors.txt rename to unmaintained/x/keysym-table/authors.txt diff --git a/extra/x/keysym-table/keysym-table.factor b/unmaintained/x/keysym-table/keysym-table.factor similarity index 100% rename from extra/x/keysym-table/keysym-table.factor rename to unmaintained/x/keysym-table/keysym-table.factor diff --git a/extra/x/pen/authors.txt b/unmaintained/x/pen/authors.txt similarity index 100% rename from extra/x/pen/authors.txt rename to unmaintained/x/pen/authors.txt diff --git a/extra/x/pen/pen.factor b/unmaintained/x/pen/pen.factor similarity index 100% rename from extra/x/pen/pen.factor rename to unmaintained/x/pen/pen.factor diff --git a/extra/x/widgets/authors.txt b/unmaintained/x/widgets/authors.txt similarity index 100% rename from extra/x/widgets/authors.txt rename to unmaintained/x/widgets/authors.txt diff --git a/extra/x/widgets/button/authors.txt b/unmaintained/x/widgets/button/authors.txt similarity index 100% rename from extra/x/widgets/button/authors.txt rename to unmaintained/x/widgets/button/authors.txt diff --git a/extra/x/widgets/button/button.factor b/unmaintained/x/widgets/button/button.factor similarity index 100% rename from extra/x/widgets/button/button.factor rename to unmaintained/x/widgets/button/button.factor diff --git a/extra/x/widgets/keymenu/authors.txt b/unmaintained/x/widgets/keymenu/authors.txt similarity index 100% rename from extra/x/widgets/keymenu/authors.txt rename to unmaintained/x/widgets/keymenu/authors.txt diff --git a/extra/x/widgets/keymenu/keymenu.factor b/unmaintained/x/widgets/keymenu/keymenu.factor similarity index 100% rename from extra/x/widgets/keymenu/keymenu.factor rename to unmaintained/x/widgets/keymenu/keymenu.factor diff --git a/extra/x/widgets/label/authors.txt b/unmaintained/x/widgets/label/authors.txt similarity index 100% rename from extra/x/widgets/label/authors.txt rename to unmaintained/x/widgets/label/authors.txt diff --git a/extra/x/widgets/label/label.factor b/unmaintained/x/widgets/label/label.factor similarity index 100% rename from extra/x/widgets/label/label.factor rename to unmaintained/x/widgets/label/label.factor diff --git a/extra/x/widgets/widgets.factor b/unmaintained/x/widgets/widgets.factor similarity index 100% rename from extra/x/widgets/widgets.factor rename to unmaintained/x/widgets/widgets.factor diff --git a/extra/x/widgets/wm/child/authors.txt b/unmaintained/x/widgets/wm/child/authors.txt similarity index 100% rename from extra/x/widgets/wm/child/authors.txt rename to unmaintained/x/widgets/wm/child/authors.txt diff --git a/extra/x/widgets/wm/child/child.factor b/unmaintained/x/widgets/wm/child/child.factor similarity index 100% rename from extra/x/widgets/wm/child/child.factor rename to unmaintained/x/widgets/wm/child/child.factor diff --git a/extra/x/widgets/wm/frame/authors.txt b/unmaintained/x/widgets/wm/frame/authors.txt similarity index 100% rename from extra/x/widgets/wm/frame/authors.txt rename to unmaintained/x/widgets/wm/frame/authors.txt diff --git a/extra/x/widgets/wm/frame/drag/authors.txt b/unmaintained/x/widgets/wm/frame/drag/authors.txt similarity index 100% rename from extra/x/widgets/wm/frame/drag/authors.txt rename to unmaintained/x/widgets/wm/frame/drag/authors.txt diff --git a/extra/x/widgets/wm/frame/drag/drag.factor b/unmaintained/x/widgets/wm/frame/drag/drag.factor similarity index 100% rename from extra/x/widgets/wm/frame/drag/drag.factor rename to unmaintained/x/widgets/wm/frame/drag/drag.factor diff --git a/extra/x/widgets/wm/frame/drag/move/authors.txt b/unmaintained/x/widgets/wm/frame/drag/move/authors.txt similarity index 100% rename from extra/x/widgets/wm/frame/drag/move/authors.txt rename to unmaintained/x/widgets/wm/frame/drag/move/authors.txt diff --git a/extra/x/widgets/wm/frame/drag/move/move.factor b/unmaintained/x/widgets/wm/frame/drag/move/move.factor similarity index 100% rename from extra/x/widgets/wm/frame/drag/move/move.factor rename to unmaintained/x/widgets/wm/frame/drag/move/move.factor diff --git a/extra/x/widgets/wm/frame/drag/size/authors.txt b/unmaintained/x/widgets/wm/frame/drag/size/authors.txt similarity index 100% rename from extra/x/widgets/wm/frame/drag/size/authors.txt rename to unmaintained/x/widgets/wm/frame/drag/size/authors.txt diff --git a/extra/x/widgets/wm/frame/drag/size/size.factor b/unmaintained/x/widgets/wm/frame/drag/size/size.factor similarity index 100% rename from extra/x/widgets/wm/frame/drag/size/size.factor rename to unmaintained/x/widgets/wm/frame/drag/size/size.factor diff --git a/extra/x/widgets/wm/frame/frame.factor b/unmaintained/x/widgets/wm/frame/frame.factor similarity index 100% rename from extra/x/widgets/wm/frame/frame.factor rename to unmaintained/x/widgets/wm/frame/frame.factor diff --git a/extra/x/widgets/wm/menu/authors.txt b/unmaintained/x/widgets/wm/menu/authors.txt similarity index 100% rename from extra/x/widgets/wm/menu/authors.txt rename to unmaintained/x/widgets/wm/menu/authors.txt diff --git a/extra/x/widgets/wm/menu/menu.factor b/unmaintained/x/widgets/wm/menu/menu.factor similarity index 100% rename from extra/x/widgets/wm/menu/menu.factor rename to unmaintained/x/widgets/wm/menu/menu.factor diff --git a/extra/x/widgets/wm/root/authors.txt b/unmaintained/x/widgets/wm/root/authors.txt similarity index 100% rename from extra/x/widgets/wm/root/authors.txt rename to unmaintained/x/widgets/wm/root/authors.txt diff --git a/extra/x/widgets/wm/root/root.factor b/unmaintained/x/widgets/wm/root/root.factor similarity index 100% rename from extra/x/widgets/wm/root/root.factor rename to unmaintained/x/widgets/wm/root/root.factor diff --git a/extra/x/widgets/wm/unmapped-frames-menu/authors.txt b/unmaintained/x/widgets/wm/unmapped-frames-menu/authors.txt similarity index 100% rename from extra/x/widgets/wm/unmapped-frames-menu/authors.txt rename to unmaintained/x/widgets/wm/unmapped-frames-menu/authors.txt diff --git a/extra/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor b/unmaintained/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor similarity index 100% rename from extra/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor rename to unmaintained/x/widgets/wm/unmapped-frames-menu/unmapped-frames-menu.factor diff --git a/extra/x/widgets/wm/workspace/authors.txt b/unmaintained/x/widgets/wm/workspace/authors.txt similarity index 100% rename from extra/x/widgets/wm/workspace/authors.txt rename to unmaintained/x/widgets/wm/workspace/authors.txt diff --git a/extra/x/widgets/wm/workspace/workspace.factor b/unmaintained/x/widgets/wm/workspace/workspace.factor similarity index 100% rename from extra/x/widgets/wm/workspace/workspace.factor rename to unmaintained/x/widgets/wm/workspace/workspace.factor diff --git a/extra/x/x.factor b/unmaintained/x/x.factor similarity index 100% rename from extra/x/x.factor rename to unmaintained/x/x.factor diff --git a/vm/Config.x86.64 b/vm/Config.x86.64 index 53a4d3c5e1..63f06d5a78 100644 --- a/vm/Config.x86.64 +++ b/vm/Config.x86.64 @@ -1 +1,2 @@ PLAF_DLL_OBJS += vm/cpu-x86.64.o +CFLAGS += -DFACTOR_64 diff --git a/vm/code_gc.c b/vm/code_gc.c index bd6384408b..59e99b0260 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -333,12 +333,14 @@ void dump_heap(F_HEAP *heap) break; } - fprintf(stderr,"%lx %lx %s\n",(CELL)scan,scan->size,status); + print_cell_hex((CELL)scan); print_string(" "); + print_cell_hex(scan->size); print_string(" "); + print_string(status); print_string("\n"); scan = next_block(heap,scan); } - printf("%ld bytes of relocation data\n",size); + print_cell(size); print_string(" bytes of relocation data\n"); } /* Compute where each block is going to go, after compaction */ @@ -460,9 +462,6 @@ void compact_code_heap(void) /* Free all unreachable code blocks */ gc(); - fprintf(stderr,"*** Code heap compaction...\n"); - fflush(stderr); - /* Figure out where the code heap blocks are going to end up */ CELL size = compute_heap_forwarding(&code_heap); diff --git a/vm/code_heap.c b/vm/code_heap.c index 2268df27e3..f3a4071e98 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -238,10 +238,10 @@ CELL allot_code_block(CELL size) CELL used, total_free, max_free; heap_usage(&code_heap,&used,&total_free,&max_free); - fprintf(stderr,"Code heap stats:\n"); - fprintf(stderr,"Used: %ld\n",used); - fprintf(stderr,"Total free space: %ld\n",total_free); - fprintf(stderr,"Largest free block: %ld\n",max_free); + print_string("Code heap stats:\n"); + print_string("Used: "); print_cell(used); nl(); + print_string("Total free space: "); print_cell(total_free); nl(); + print_string("Largest free block: "); print_cell(max_free); nl(); fatal_error("Out of memory in add-compiled-block",0); } } diff --git a/vm/data_gc.c b/vm/data_gc.c index cf1632811c..9f8ffb625e 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -1,20 +1,5 @@ #include "master.h" -#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld, tenured_size=%ld\n" -#define GC_REQUESTED "garbage_collection: growing_data_heap=%d, requested_bytes=%ld\n" -#define BEGIN_GC "begin_gc: growing_data_heap=%d, collecting_gen=%ld\n" -#define END_GC "end_gc: gc_elapsed=%ld\n" -#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n" -#define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n" - -/* #define GC_DEBUG */ - -#ifdef GC_DEBUG - #define GC_PRINT printf -#else - INLINE void GC_PRINT() { } -#endif - CELL init_zone(F_ZONE *z, CELL size, CELL start) { z->size = size; @@ -36,8 +21,6 @@ F_DATA_HEAP *alloc_data_heap(CELL gens, CELL aging_size, CELL tenured_size) { - GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size); - young_size = align(young_size,DECK_SIZE); aging_size = align(aging_size,DECK_SIZE); tenured_size = align(tenured_size,DECK_SIZE); @@ -438,8 +421,6 @@ void collect_gen_cards(CELL gen) old->new references */ void collect_cards(void) { - GC_PRINT("Collect cards\n"); - int i; for(i = collecting_gen + 1; i < data_heap->gen_count; i++) collect_gen_cards(i); @@ -468,9 +449,7 @@ void collect_callstack(F_CONTEXT *stacks) CELL top = (CELL)stacks->callstack_top; CELL bottom = (CELL)stacks->callstack_bottom; - GC_PRINT("Collect callstack %ld %ld\n",top,bottom); iterate_callstack(top,bottom,collect_stack_frame); - GC_PRINT("Done\n"); } } @@ -486,7 +465,6 @@ void collect_gc_locals(void) the user environment and extra roots registered with REGISTER_ROOT */ void collect_roots(void) { - GC_PRINT("Collect roots\n"); copy_handle(&T); copy_handle(&bignum_zero); copy_handle(&bignum_pos_one); @@ -759,14 +737,6 @@ void begin_gc(CELL requested_bytes) so we set the newspace so the next generation. */ newspace = &data_heap->generations[collecting_gen + 1]; } - -#ifdef GC_DEBUG - printf("\n"); - dump_generations(); - printf("Newspace: "); - dump_zone(newspace); - printf("\n"); -#endif } void end_gc(CELL gc_elapsed) @@ -823,8 +793,6 @@ void garbage_collection(CELL gen, return; } - GC_PRINT(GC_REQUESTED,growing_data_heap_,requested_bytes); - s64 start = current_millis(); performing_gc = true; @@ -858,7 +826,6 @@ void garbage_collection(CELL gen, } } - GC_PRINT(BEGIN_GC,growing_data_heap,collecting_gen); begin_gc(requested_bytes); /* initialize chase pointer */ @@ -895,7 +862,6 @@ void garbage_collection(CELL gen, CELL gc_elapsed = (current_millis() - start); - GC_PRINT(END_GC,gc_elapsed); end_gc(gc_elapsed); performing_gc = false; diff --git a/vm/debug.c b/vm/debug.c index 41205d4aff..8c6ec203ad 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -15,20 +15,20 @@ void print_word(F_WORD* word, CELL nesting) if(type_of(word->vocabulary) == STRING_TYPE) { print_chars(untag_string(word->vocabulary)); - printf(":"); + print_string(":"); } if(type_of(word->name) == STRING_TYPE) print_chars(untag_string(word->name)); else { - printf("#name,nesting); - printf(">"); + print_string(">"); } } -void print_string(F_STRING* str) +void print_factor_string(F_STRING* str) { putchar('"'); print_chars(str); @@ -51,12 +51,12 @@ void print_array(F_ARRAY* array, CELL nesting) for(i = 0; i < length; i++) { - printf(" "); + print_string(" "); print_nested_obj(array_nth(array,i),nesting); } if(trimmed) - printf("..."); + print_string("..."); } void print_tuple(F_TUPLE* tuple, CELL nesting) @@ -64,7 +64,7 @@ void print_tuple(F_TUPLE* tuple, CELL nesting) F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); CELL length = to_fixnum(layout->size); - printf(" "); + print_string(" "); print_nested_obj(layout->class,nesting); CELL i; @@ -80,19 +80,19 @@ void print_tuple(F_TUPLE* tuple, CELL nesting) for(i = 0; i < length; i++) { - printf(" "); + print_string(" "); print_nested_obj(tuple_nth(tuple,i),nesting); } if(trimmed) - printf("..."); + print_string("..."); } void print_nested_obj(CELL obj, F_FIXNUM nesting) { if(nesting <= 0 && !full_output) { - printf(" ... "); + print_string(" ... "); return; } @@ -101,35 +101,35 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting) switch(type_of(obj)) { case FIXNUM_TYPE: - printf("%ld",untag_fixnum_fast(obj)); + print_fixnum(untag_fixnum_fast(obj)); break; case WORD_TYPE: print_word(untag_word(obj),nesting - 1); break; case STRING_TYPE: - print_string(untag_string(obj)); + print_factor_string(untag_string(obj)); break; case F_TYPE: - printf("f"); + print_string("f"); break; case TUPLE_TYPE: - printf("T{"); + print_string("T{"); print_tuple(untag_object(obj),nesting - 1); - printf(" }"); + print_string(" }"); break; case ARRAY_TYPE: - printf("{"); + print_string("{"); print_array(untag_object(obj),nesting - 1); - printf(" }"); + print_string(" }"); break; case QUOTATION_TYPE: - printf("["); + print_string("["); quot = untag_object(obj); print_array(untag_object(quot->array),nesting - 1); - printf(" ]"); + print_string(" ]"); break; default: - printf("#",type_of(obj),obj); + print_string("#xt); + print_string("\n"); + print_cell_hex((CELL)frame_executing(frame)); + print_cell_hex((CELL)frame->xt); } void print_callstack(void) { - printf("==== CALL STACK:\n"); + print_string("==== CALL STACK:\n"); CELL bottom = (CELL)stack_chain->callstack_bottom; CELL top = (CELL)stack_chain->callstack_top; iterate_callstack(top,bottom,print_stack_frame); @@ -180,11 +180,11 @@ void print_callstack(void) void dump_cell(CELL cell) { - printf("%08lx: ",cell); + print_cell_hex_pad(cell); print_string(": "); cell = get(cell); - printf("%08lx tag %ld",cell,TAG(cell)); + print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell)); switch(TAG(cell)) { @@ -192,24 +192,29 @@ void dump_cell(CELL cell) case BIGNUM_TYPE: case FLOAT_TYPE: if(cell == F) - printf(" -- F"); + print_string(" -- F"); else if(cell < TYPE_COUNT<>TAG_BITS); + { + print_string(" -- possible header: "); + print_cell(cell>>TAG_BITS); + } else if(cell >= data_heap->segment->start && cell < data_heap->segment->end) { CELL header = get(UNTAG(cell)); CELL type = header>>TAG_BITS; - printf(" -- object; "); + print_string(" -- object; "); if(TAG(header) == 0 && type < TYPE_COUNT) - printf(" type %ld",type); + { + print_string(" type "); print_cell(type); + } else - printf(" header corrupt"); + print_string(" header corrupt"); } break; } - printf("\n"); + nl(); } void dump_memory(CELL from, CELL to) @@ -222,32 +227,35 @@ void dump_memory(CELL from, CELL to) void dump_zone(F_ZONE *z) { - printf("start=%ld, size=%ld, here=%ld\n", - z->start,z->size,z->here - z->start); + print_string("Start="); print_cell(z->start); + print_string(", size="); print_cell(z->size); + print_string(", here="); print_cell(z->here - z->start); nl(); } void dump_generations(void) { - int i; + CELL i; - printf("Nursery: "); + print_string("Nursery: "); dump_zone(&nursery); for(i = 1; i < data_heap->gen_count; i++) { - printf("Generation %d: ",i); + print_string("Generation "); print_cell(i); print_string(": "); dump_zone(&data_heap->generations[i]); } for(i = 0; i < data_heap->gen_count; i++) { - printf("Semispace %d: ",i); + print_string("Semispace "); print_cell(i); print_string(": "); dump_zone(&data_heap->semispaces[i]); } - printf("Cards: base=%lx, size=%lx\n", - (CELL)data_heap->cards, - (CELL)(data_heap->cards_end - data_heap->cards)); + print_string("Cards: base="); + print_cell((CELL)data_heap->cards); + print_string(", size="); + print_cell((CELL)(data_heap->cards_end - data_heap->cards)); + nl(); } void dump_objects(F_FIXNUM type) @@ -260,9 +268,10 @@ void dump_objects(F_FIXNUM type) { if(type == -1 || type_of(obj) == type) { - printf("%lx ",obj); + print_cell_hex_pad(obj); + print_string(" "); print_nested_obj(obj,2); - printf("\n"); + nl(); } } @@ -277,9 +286,10 @@ void find_data_references_step(CELL *scan) { if(look_for == *scan) { - printf("%lx ",obj); + print_cell_hex_pad(obj); + print_string(" "); print_nested_obj(obj,2); - printf("\n"); + nl(); } } @@ -312,9 +322,10 @@ void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL liter if(look_for == get(scan)) { - printf("%lx ",obj); + print_cell_hex_pad(obj); + print_string(" "); print_nested_obj(obj,2); - printf("\n"); + nl(); } } } @@ -329,34 +340,34 @@ void factorbug(void) { if(fep_disabled) { - printf("Low level debugger disabled\n"); + print_string("Low level debugger disabled\n"); exit(1); } - open_console(); + /* open_console(); */ - printf("Starting low level debugger...\n"); - printf(" Basic commands:\n"); - printf("q -- continue executing Factor - NOT SAFE\n"); - printf("im -- save image to fep.image\n"); - printf("x -- exit Factor\n"); - printf(" Advanced commands:\n"); - printf("d -- dump memory\n"); - printf("u -- dump object at tagged \n"); - printf(". -- print object at tagged \n"); - printf("t -- toggle output trimming\n"); - printf("s r -- dump data, retain stacks\n"); - printf(".s .r .c -- print data, retain, call stacks\n"); - printf("e -- dump environment\n"); - printf("g -- dump generations\n"); - printf("card -- print card containing address\n"); - printf("addr -- print address containing card\n"); - printf("data -- data heap dump\n"); - printf("words -- words dump\n"); - printf("tuples -- tuples dump\n"); - printf("refs -- find data heap references to object\n"); - printf("push -- push object on data stack - NOT SAFE\n"); - printf("code -- code heap dump\n"); + print_string("Starting low level debugger...\n"); + print_string(" Basic commands:\n"); + print_string("q -- continue executing Factor - NOT SAFE\n"); + print_string("im -- save image to fep.image\n"); + print_string("x -- exit Factor\n"); + print_string(" Advanced commands:\n"); + print_string("d -- dump memory\n"); + print_string("u -- dump object at tagged \n"); + print_string(". -- print object at tagged \n"); + print_string("t -- toggle output trimming\n"); + print_string("s r -- dump data, retain stacks\n"); + print_string(".s .r .c -- print data, retain, call stacks\n"); + print_string("e -- dump environment\n"); + print_string("g -- dump generations\n"); + print_string("card -- print card containing address\n"); + print_string("addr -- print address containing card\n"); + print_string("data -- data heap dump\n"); + print_string("words -- words dump\n"); + print_string("tuples -- tuples dump\n"); + print_string("refs -- find data heap references to object\n"); + print_string("push -- push object on data stack - NOT SAFE\n"); + print_string("code -- code heap dump\n"); bool seen_command = false; @@ -364,7 +375,7 @@ void factorbug(void) { char cmd[1024]; - printf("READY\n"); + print_string("READY\n"); fflush(stdout); if(scanf("%1000s",cmd) <= 0) @@ -389,23 +400,22 @@ void factorbug(void) if(strcmp(cmd,"d") == 0) { - CELL addr, count; - scanf("%lx %lx",&addr,&count); + CELL addr = read_cell_hex(); + scanf(" "); + CELL count = read_cell_hex(); dump_memory(addr,addr+count); } - if(strcmp(cmd,"u") == 0) + else if(strcmp(cmd,"u") == 0) { - CELL addr, count; - scanf("%lx",&addr); - count = object_size(addr); + CELL addr = read_cell_hex(); + CELL count = object_size(addr); dump_memory(addr,addr+count); } else if(strcmp(cmd,".") == 0) { - CELL addr; - scanf("%lx",&addr); + CELL addr = read_cell_hex(); print_obj(addr); - printf("\n"); + print_string("\n"); } else if(strcmp(cmd,"t") == 0) full_output = !full_output; @@ -429,15 +439,15 @@ void factorbug(void) dump_generations(); else if(strcmp(cmd,"card") == 0) { - CELL addr; - scanf("%lx",&addr); - printf("%lx\n",(CELL)ADDR_TO_CARD(addr)); + CELL addr = read_cell_hex(); + print_cell_hex((CELL)ADDR_TO_CARD(addr)); + nl(); } else if(strcmp(cmd,"addr") == 0) { - CELL card; - scanf("%lx",&card); - printf("%lx\n",(CELL)CARD_TO_ADDR(card)); + CELL card = read_cell_hex(); + print_cell_hex((CELL)CARD_TO_ADDR(card)); + nl(); } else if(strcmp(cmd,"q") == 0) return; @@ -449,13 +459,12 @@ void factorbug(void) dump_objects(-1); else if(strcmp(cmd,"refs") == 0) { - CELL addr; - scanf("%lx",&addr); - printf("Data heap references:\n"); + CELL addr = read_cell_hex(); + print_string("Data heap references:\n"); find_data_references(addr); - printf("Code heap references:\n"); + print_string("Code heap references:\n"); find_code_references(addr); - printf("\n"); + nl(); } else if(strcmp(cmd,"words") == 0) dump_objects(WORD_TYPE); @@ -463,20 +472,19 @@ void factorbug(void) dump_objects(TUPLE_TYPE); else if(strcmp(cmd,"push") == 0) { - CELL addr; - scanf("%lx",&addr); + CELL addr = read_cell_hex(); dpush(addr); } else if(strcmp(cmd,"code") == 0) dump_heap(&code_heap); else - printf("unknown command\n"); + print_string("unknown command\n"); } } void primitive_die(void) { - fprintf(stderr,"The die word was called by the library. Unless you called it yourself,\n"); - fprintf(stderr,"you have triggered a bug in Factor. Please report.\n"); + print_string("The die word was called by the library. Unless you called it yourself,\n"); + print_string("you have triggered a bug in Factor. Please report.\n"); factorbug(); } diff --git a/vm/errors.c b/vm/errors.c index fe6e79be6d..7c06ec1310 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -2,21 +2,23 @@ void out_of_memory(void) { - fprintf(stderr,"Out of memory\n\n"); + print_string("Out of memory\n\n"); dump_generations(); exit(1); } void fatal_error(char* msg, CELL tagged) { - fprintf(stderr,"fatal_error: %s %lx\n",msg,tagged); + print_string("fatal_error: "); print_string(msg); + print_string(": "); print_cell_hex(tagged); nl(); exit(1); } void critical_error(char* msg, CELL tagged) { - fprintf(stderr,"You have triggered a bug in Factor. Please report.\n"); - fprintf(stderr,"critical_error: %s %lx\n",msg,tagged); + print_string("You have triggered a bug in Factor. Please report.\n"); + print_string("critical_error: "); print_string(msg); + print_string(": "); print_cell_hex(tagged); nl(); factorbug(); } @@ -57,10 +59,10 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) crash. */ else { - printf("You have triggered a bug in Factor. Please report.\n"); - printf("early_error: "); + print_string("You have triggered a bug in Factor. Please report.\n"); + print_string("early_error: "); print_obj(error); - printf("\n"); + nl(); factorbug(); } } diff --git a/vm/factor.c b/vm/factor.c index c8b07cba64..8e0aadb4fd 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -41,8 +41,8 @@ void default_parameters(F_PARAMETERS *p) /* Do some initialization that we do once only */ void do_stage1_init(void) { - fprintf(stderr,"*** Stage 2 early init... "); - fflush(stderr); + print_string("*** Stage 2 early init... "); + fflush(stdout); CELL words = find_all_words(); @@ -65,8 +65,8 @@ void do_stage1_init(void) userenv[STAGE2_ENV] = T; - fprintf(stderr,"done\n"); - fflush(stderr); + print_string("done\n"); + fflush(stdout); } /* Get things started */ diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 081ae42ebf..1ec41ac2b9 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -6,91 +6,76 @@ void ffi_test_0(void) { - printf("ffi_test_0()\n"); } int ffi_test_1(void) { - printf("ffi_test_1()\n"); return 3; } int ffi_test_2(int x, int y) { - printf("ffi_test_2(%d,%d)\n",x,y); return x + y; } int ffi_test_3(int x, int y, int z, int t) { - printf("ffi_test_3(%d,%d,%d,%d)\n",x,y,z,t); return x + y + z * t; } float ffi_test_4(void) { - printf("ffi_test_4()\n"); return 1.5; } double ffi_test_5(void) { - printf("ffi_test_5()\n"); return 1.5; } double ffi_test_6(float x, float y) { - printf("ffi_test_6(%f,%f)\n",x,y); return x * y; } double ffi_test_7(double x, double y) { - printf("ffi_test_7(%f,%f)\n",x,y); return x * y; } double ffi_test_8(double x, float y, double z, float t, int w) { - printf("ffi_test_8(%f,%f,%f,%f,%d)\n",x,y,z,t,w); return x * y + z * t + w; } int ffi_test_9(int a, int b, int c, int d, int e, int f, int g) { - printf("ffi_test_9(%d,%d,%d,%d,%d,%d,%d)\n",a,b,c,d,e,f,g); return a + b + c + d + e + f + g; } int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h) { - printf("ffi_test_10(%d,%d,%f,%d,%f,%d,%d,%d)\n",a,b,c,d,e,f,g,h); return a - b - c - d - e - f - g - h; } int ffi_test_11(int a, struct foo b, int c) { - printf("ffi_test_11(%d,{%d,%d},%d)\n",a,b.x,b.y,c); return a * b.x + c * b.y; } int ffi_test_12(int a, int b, struct rect c, int d, int e, int f) { - printf("ffi_test_12(%d,%d,{%f,%f,%f,%f},%d,%d,%d)\n",a,b,c.x,c.y,c.w,c.h,d,e,f); return a + b + c.x + c.y + c.w + c.h + d + e + f; } int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k) { - printf("ffi_test_13(%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d)\n",a,b,c,d,e,f,g,h,i,j,k); return a + b + c + d + e + f + g + h + i + j + k; } struct foo ffi_test_14(int x, int y) { struct foo r; - printf("ffi_test_14(%d,%d)\n",x,y); r.x = x; r.y = y; return r; } @@ -119,7 +104,6 @@ struct tiny ffi_test_17(int x) F_STDCALL int ffi_test_18(int x, int y, int z, int t) { - printf("ffi_test_18(%d,%d,%d,%d)\n",x,y,z,t); return x + y + z * t; } @@ -134,8 +118,6 @@ void ffi_test_20(double x1, double x2, double x3, double y1, double y2, double y3, double z1, double z2, double z3) { - printf("ffi_test_20(%f,%f,%f,%f,%f,%f,%f,%f,%f)\n", - x1, x2, x3, y1, y2, y3, z1, z2, z3); } long long ffi_test_21(long x, long y) @@ -145,7 +127,6 @@ long long ffi_test_21(long x, long y) long ffi_test_22(long x, long long y, long long z) { - printf("ffi_test_22(%ld,%lld,%lld)\n",x,y,z); return x + y / z; } @@ -224,7 +205,15 @@ struct test_struct_7 ffi_test_30(void) return s; } -void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41) { } +int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41) +{ + return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41; +} + +float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41) +{ + return x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + x40 + x41; +} double ffi_test_32(struct test_struct_8 x, int y) { @@ -255,17 +244,12 @@ static int global_var; void ffi_test_36_point_5(void) { - printf("ffi_test_36_point_5\n"); global_var = 0; } int ffi_test_37(int (*f)(int, int, int)) { - printf("ffi_test_37\n"); - printf("global_var is %d\n",global_var); global_var = f(global_var,global_var * 2,global_var * 3); - printf("global_var is %d\n",global_var); - fflush(stdout); return global_var; } @@ -276,7 +260,6 @@ unsigned long long ffi_test_38(unsigned long long x, unsigned long long y) int ffi_test_39(long a, long b, struct test_struct_13 s) { - printf("ffi_test_39(%ld,%ld,%f,%f,%f,%f,%f,%f)\n",a,b,s.x1,s.x2,s.x3,s.x4,s.x5,s.x6); if(a != b) abort(); return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6; } @@ -286,7 +269,6 @@ struct test_struct_14 ffi_test_40(double x1, double x2) struct test_struct_14 retval; retval.x1 = x1; retval.x2 = x2; - printf("ffi_test_40(%f,%f)\n",x1,x2); return retval; } @@ -295,7 +277,6 @@ struct test_struct_12 ffi_test_41(int a, double x) struct test_struct_12 retval; retval.a = a; retval.x = x; - printf("ffi_test_41(%d,%f)\n",a,x); return retval; } @@ -304,7 +285,6 @@ struct test_struct_15 ffi_test_42(float x, float y) struct test_struct_15 retval; retval.x = x; retval.y = y; - printf("ffi_test_42(%f,%f)\n",x,y); return retval; } @@ -313,7 +293,6 @@ struct test_struct_16 ffi_test_43(float x, int a) struct test_struct_16 retval; retval.x = x; retval.a = a; - printf("ffi_test_43(%f,%d)\n",x,a); return retval; } @@ -322,6 +301,5 @@ struct test_struct_14 ffi_test_44(void) struct test_struct_14 retval; retval.x1 = 1.0; retval.x2 = 2.0; - //printf("ffi_test_44()\n"); return retval; } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index f9195a4285..7c51261157 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -48,7 +48,8 @@ struct test_struct_6 { char x, y, z, a, b, c; }; DLLEXPORT struct test_struct_6 ffi_test_29(void); struct test_struct_7 { char x, y, z, a, b, c, d; }; DLLEXPORT struct test_struct_7 ffi_test_30(void); -DLLEXPORT void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41); +DLLEXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41); +DLLEXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41); struct test_struct_8 { double x; double y; }; DLLEXPORT double ffi_test_32(struct test_struct_8 x, int y); struct test_struct_9 { float x; float y; }; diff --git a/vm/image.c b/vm/image.c index 289c1e94c8..0e6591f8d8 100755 --- a/vm/image.c +++ b/vm/image.c @@ -28,12 +28,15 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) F_ZONE *tenured = &data_heap->generations[TENURED]; - long int bytes_read = fread((void*)tenured->start,1,h->data_size,file); + F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file); if(bytes_read != h->data_size) { - fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n", - bytes_read,h->data_size); + print_string("truncated image: "); + print_fixnum(bytes_read); + print_string(" bytes read, "); + print_cell(h->data_size); + print_string(" bytes expected\n"); fatal_error("load_data_heap failed",0); } @@ -52,11 +55,14 @@ INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p) if(h->code_size != 0) { - long int bytes_read = fread(first_block(&code_heap),1,h->code_size,file); + F_FIXNUM bytes_read = fread(first_block(&code_heap),1,h->code_size,file); if(bytes_read != h->code_size) { - fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n", - bytes_read,h->code_size); + print_string("truncated image: "); + print_fixnum(bytes_read); + print_string(" bytes read, "); + print_cell(h->code_size); + print_string(" bytes expected\n"); fatal_error("load_code_heap failed",0); } } @@ -72,8 +78,8 @@ void load_image(F_PARAMETERS *p) FILE *file = OPEN_READ(p->image); if(file == NULL) { - FPRINTF(stderr,"Cannot open image file: %s\n",p->image); - fprintf(stderr,"%s\n",strerror(errno)); + print_string("Cannot open image file: "); print_native_string(p->image); nl(); + print_string(strerror(errno)); nl(); exit(1); } @@ -106,12 +112,11 @@ bool save_image(const F_CHAR *filename) FILE* file; F_HEADER h; - FPRINTF(stderr,"*** Saving %s...\n",filename); - file = OPEN_WRITE(filename); if(file == NULL) { - fprintf(stderr,"Cannot open image file: %s\n",strerror(errno)); + print_string("Cannot open image file: "); print_native_string(filename); nl(); + print_string(strerror(errno)); nl(); return false; } @@ -142,19 +147,19 @@ bool save_image(const F_CHAR *filename) if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) { - fprintf(stderr,"Save data heap failed: %s\n",strerror(errno)); + print_string("Save data heap failed: "); print_string(strerror(errno)); nl(); return false; } if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) { - fprintf(stderr,"Save code heap failed: %s\n",strerror(errno)); + print_string("Save code heap failed: "); print_string(strerror(errno)); nl(); return false; } if(fclose(file)) { - fprintf(stderr,"Failed to close image file: %s\n",strerror(errno)); + print_string("Failed to close image file: "); print_string(strerror(errno)); nl(); return false; } diff --git a/vm/layouts.h b/vm/layouts.h index 6dc29efdae..e55a5e9fd3 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -201,14 +201,6 @@ typedef struct { void *dll; } F_DLL; -typedef struct { - CELL header; - /* tagged */ - CELL obj; - /* tagged */ - CELL quot; -} F_CURRY; - typedef struct { CELL header; /* tagged */ diff --git a/vm/main-windows-nt.c b/vm/main-windows-nt.c old mode 100644 new mode 100755 index 743831958b..ef66651846 --- a/vm/main-windows-nt.c +++ b/vm/main-windows-nt.c @@ -13,9 +13,9 @@ int WINAPI WinMain( int nArgs; szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs); - if( NULL == szArglist ) + if(NULL == szArglist) { - wprintf(L"CommandLineToArgvW failed\n"); + puts("CommandLineToArgvW failed"); return 1; } diff --git a/vm/math.c b/vm/math.c index 388a472f2e..c6b91bc8f7 100644 --- a/vm/math.c +++ b/vm/math.c @@ -109,7 +109,7 @@ void primitive_fixnum_shift(void) } else if(y < WORD_SIZE - TAG_BITS) { - F_FIXNUM mask = -(1L << (WORD_SIZE - 1 - TAG_BITS - y)); + F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y)); if((x > 0 && (x & mask) == 0) || (x & mask) == mask) { dpush(tag_fixnum(x << y)); diff --git a/vm/os-netbsd.h b/vm/os-netbsd.h index 54b5d0bcff..6486acda4a 100644 --- a/vm/os-netbsd.h +++ b/vm/os-netbsd.h @@ -2,5 +2,4 @@ #define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) -#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) #define DIRECTORY_P(file) ((file)->d_type == DT_DIR) diff --git a/vm/os-unix.h b/vm/os-unix.h index 6db03148cd..2c5cc20e8d 100755 --- a/vm/os-unix.h +++ b/vm/os-unix.h @@ -23,9 +23,21 @@ typedef char F_SYMBOL; #define STRNCMP strncmp #define STRDUP strdup +#define CELL_FORMAT "%lu" +#define CELL_HEX_FORMAT "%lx" + +#ifdef FACTOR_64 + #define CELL_HEX_PAD_FORMAT "%016lx" +#else + #define CELL_HEX_PAD_FORMAT "%08lx" +#endif + +#define FIXNUM_FORMAT "%ld" + #define OPEN_READ(path) fopen(path,"rb") #define OPEN_WRITE(path) fopen(path,"wb") -#define FPRINTF(stream,format,arg) fprintf(stream,format,arg) + +#define print_native_string(string) print_string(string) void start_thread(void *(*start_routine)(void *)); diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index 54afd1c147..e22ea1446b 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -29,7 +29,13 @@ long exception_handler(PEXCEPTION_POINTERS pe) signal_number = ERROR_DIVIDE_BY_ZERO; c->EIP = (CELL)divide_by_zero_signal_handler_impl; } - else + /* If the Widcomm bluetooth stack is installed, the BTTray.exe process + injects code into running programs. For some reason this results in + random SEH exceptions with this (undocumented) exception code being + raised. The workaround seems to be ignoring this altogether, since that + is what happens if SEH is not enabled. Don't really have any idea what + this exception means. */ + else if(e->ExceptionCode != 0x40010006) { signal_number = 11; c->EIP = (CELL)misc_signal_handler_impl; diff --git a/vm/os-windows.c b/vm/os-windows.c index fc289c288e..7d486bb86b 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -92,7 +92,6 @@ void primitive_existsp(void) BY_HANDLE_FILE_INFORMATION bhfi; F_CHAR *path = unbox_u16_string(); - //wprintf(L"path = %s\n", path); HANDLE h = CreateFileW(path, GENERIC_READ, FILE_SHARE_READ, diff --git a/vm/os-windows.h b/vm/os-windows.h index f292c407e5..8d0f15648a 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -20,10 +20,22 @@ typedef wchar_t F_CHAR; #define STRNCMP wcsncmp #define STRDUP _wcsdup +#ifdef WIN64 + #define CELL_FORMAT "%Iu" + #define CELL_HEX_FORMAT "%Ix" + #define CELL_HEX_PAD_FORMAT "%016Ix" +#else + #define CELL_FORMAT "%lu" + #define CELL_HEX_FORMAT "%lx" + #define CELL_HEX_PAD_FORMAT "%08lx" +#endif + +#define FIXNUM_FORMAT "%Id" + #define OPEN_READ(path) _wfopen(path,L"rb") #define OPEN_WRITE(path) _wfopen(path,L"wb") -#define FPRINTF(stream,format,arg) fwprintf(stream,L##format,arg) +#define print_native_string(string) wprintf(L"%s",string) /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ #define EPOCH_OFFSET 0x019db1ded53e8000LL diff --git a/vm/utilities.c b/vm/utilities.c index ebc8e87977..35fc7ad087 100755 --- a/vm/utilities.c +++ b/vm/utilities.c @@ -14,3 +14,42 @@ F_CHAR *safe_strdup(const F_CHAR *str) if(!ptr) fatal_error("Out of memory in safe_strdup", 0); return ptr; } + +/* We don't use printf directly, because format directives are not portable. +Instead we define the common cases here. */ +void nl(void) +{ + fputs("\n",stdout); +} + +void print_string(const char *str) +{ + fputs(str,stdout); +} + +void print_cell(CELL x) +{ + printf(CELL_FORMAT,x); +} + +void print_cell_hex(CELL x) +{ + printf(CELL_HEX_FORMAT,x); +} + +void print_cell_hex_pad(CELL x) +{ + printf(CELL_HEX_PAD_FORMAT,x); +} + +void print_fixnum(F_FIXNUM x) +{ + printf(CELL_FORMAT,x); +} + +CELL read_cell_hex(void) +{ + CELL cell; + scanf(CELL_HEX_FORMAT,&cell); + return cell; +}; diff --git a/vm/utilities.h b/vm/utilities.h index 89a8ba57a3..d2b3223ce4 100755 --- a/vm/utilities.h +++ b/vm/utilities.h @@ -1,2 +1,10 @@ void *safe_malloc(size_t size); F_CHAR *safe_strdup(const F_CHAR *str); + +void nl(void); +void print_string(const char *str); +void print_cell(CELL x); +void print_cell_hex(CELL x); +void print_cell_hex_pad(CELL x); +void print_fixnum(F_FIXNUM x); +CELL read_cell_hex(void);