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/alias/alias-docs.factor b/basis/alias/alias-docs.factor index 4dcf1a7738..3f2eee6460 100644 --- a/basis/alias/alias-docs.factor +++ b/basis/alias/alias-docs.factor @@ -16,7 +16,7 @@ HELP: ALIAS: } } ; -ARTICLE: "alias" "Alias" +ARTICLE: "alias" "Word aliasing" "The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl "Make a new word that aliases another word:" { $subsection define-alias } 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/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/image.factor b/basis/bootstrap/image/image.factor index 8b0051148f..c0fafdc0f5 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -134,6 +134,7 @@ SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling SYMBOL: jit-declare-word +SYMBOL: jit-save-stack ! Default definition for undefined words SYMBOL: undefined-quot @@ -158,6 +159,7 @@ SYMBOL: undefined-quot { jit-profiling 35 } { jit-push-immediate 36 } { jit-declare-word 42 } + { jit-save-stack 43 } { undefined-quot 60 } } at header-size + ; @@ -459,6 +461,7 @@ M: quotation ' jit-return jit-profiling jit-declare-word + jit-save-stack undefined-quot } [ emit-userenv ] each ; 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/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 17a5942af2..7bad44f7a6 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -190,7 +190,7 @@ M: #if emit-node : emit-dispatch ( node -- ) ##epilogue - ds-pop ^^offset>slot i ##dispatch + ds-pop ^^offset>slot i 0 ##dispatch dispatch-branches ; : ( -- word ) @@ -221,21 +221,14 @@ M: #push emit-node literal>> ^^load-literal ds-push iterate-next ; ! #shuffle -: emit-shuffle ( effect -- ) - [ out>> ] [ in>> dup length ds-load zip ] bi - '[ _ at ] map ds-store ; - M: #shuffle emit-node - shuffle-effect emit-shuffle iterate-next ; - -M: #>r emit-node - [ in-d>> length ] [ out-r>> empty? ] bi - [ neg ##inc-d ] [ ds-load rs-store ] if - iterate-next ; - -M: #r> emit-node - [ in-r>> length ] [ out-d>> empty? ] bi - [ neg ##inc-r ] [ rs-load ds-store ] if + dup + H{ } clone + [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ] + [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ] + [ nip ] 2tri + [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ] + [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi iterate-next ; ! #return diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index c39f517671..b2c752e612 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -62,7 +62,7 @@ INSN: ##jump word ; INSN: ##return ; ! Jump tables -INSN: ##dispatch src temp ; +INSN: ##dispatch src temp offset ; INSN: ##dispatch-label label ; ! Slot access diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index d397c9d448..7433df9617 100644 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -43,8 +43,8 @@ M: ##branch linearize-insn : binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) [ (binary-conditional) ] - [ drop dup successors>> first useless-branch? ] 2bi - [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ; + [ drop dup successors>> second useless-branch? ] 2bi + [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; M: ##compare-branch linearize-insn binary-conditional _compare-branch emit-branch ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index 7f4b09e68f..158903b4bf 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -9,7 +9,10 @@ SYMBOL: visited : post-order-traversal ( bb -- ) dup id>> visited get key? [ drop ] [ dup id>> visited get conjoin - [ successors>> [ post-order-traversal ] each ] [ , ] bi + [ + successors>> + [ post-order-traversal ] each + ] [ , ] bi ] if ; : post-order ( bb -- blocks ) diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index f138f673e0..c8fcae87c0 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -15,16 +15,28 @@ IN: compiler.cfg.stacks 1 ##inc-d D 0 ##replace ; : ds-load ( n -- vregs ) - [ [ ^^peek ] map ] [ neg ##inc-d ] bi ; + dup 0 = + [ drop f ] + [ [ [ ^^peek ] map ] [ neg ##inc-d ] bi ] if ; : ds-store ( vregs -- ) - [ length ##inc-d ] [ [ ##replace ] each-index ] bi ; + [ + + [ length ##inc-d ] + [ [ ##replace ] each-index ] bi + ] unless-empty ; : rs-load ( n -- vregs ) - [ [ ^^peek ] map ] [ neg ##inc-r ] bi ; + dup 0 = + [ drop f ] + [ [ [ ^^peek ] map ] [ neg ##inc-r ] bi ] if ; : rs-store ( vregs -- ) - [ length ##inc-r ] [ [ ##replace ] each-index ] bi ; + [ + + [ length ##inc-r ] + [ [ ##replace ] each-index ] bi + ] unless-empty ; : 2inputs ( -- vreg1 vreg2 ) D 1 ^^peek D 0 ^^peek -2 ##inc-d ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 94c3f0d6f9..5f67f8097e 100644 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences layouts accessors combinators namespaces -math +math fry compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.simplify @@ -113,4 +113,18 @@ M: ##compare-imm rewrite ] when ] when ; +: dispatch-offset ( expr -- n ) + [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi + \ ##sub-imm eq? [ neg ] when ; + +: add-dispatch-offset? ( insn -- expr ? ) + src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline + +M: ##dispatch rewrite + dup add-dispatch-offset? [ + [ clone ] dip + [ in1>> vn>vreg >>src ] + [ dispatch-offset '[ _ + ] change-offset ] bi + ] [ drop ] if ; + M: insn rewrite ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index d3be68c3c9..b73736ed14 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -34,7 +34,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ; [ t ] [ { T{ ##peek f V int-regs 1 D 0 } - T{ ##dispatch f V int-regs 1 V int-regs 2 } + T{ ##dispatch f V int-regs 1 V int-regs 2 0 } } dup value-numbering = ] unit-test diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 35d4d59253..0d45b28126 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -93,7 +93,7 @@ M: ##return generate-insn drop %return ; M: ##dispatch-label generate-insn label>> %dispatch-label ; M: ##dispatch generate-insn - [ src>> register ] [ temp>> register ] bi %dispatch ; + [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ; : >slot< { diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index fe270f4410..b25f1fa8fe 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -72,8 +72,8 @@ SYMBOL: literal-table : rel-this ( class -- ) 0 swap rt-label rel-fixup ; -: rel-here ( class -- ) - 0 swap rt-here rel-fixup ; +: rel-here ( offset class -- ) + rt-here rel-fixup ; : init-fixup ( -- ) BV{ } clone relocation-table set 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/constants/constants.factor b/basis/compiler/constants/constants.factor index cd68602768..86c1f65049 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -37,14 +37,15 @@ IN: compiler.constants : rc-indirect-arm-pc 8 ; inline ! Relocation types -: rt-primitive 0 ; inline -: rt-dlsym 1 ; inline -: rt-literal 2 ; inline -: rt-dispatch 3 ; inline -: rt-xt 4 ; inline -: rt-here 5 ; inline -: rt-label 6 ; inline -: rt-immediate 7 ; inline +: rt-primitive 0 ; inline +: rt-dlsym 1 ; inline +: rt-literal 2 ; inline +: rt-dispatch 3 ; inline +: rt-xt 4 ; inline +: rt-here 5 ; inline +: rt-label 6 ; inline +: rt-immediate 7 ; inline +: rt-stack-chain 8 ; inline : rc-absolute? ( n -- ? ) [ rc-absolute-ppc-2/2 = ] diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/codegen.factor similarity index 95% rename from basis/compiler/tests/templates.factor rename to basis/compiler/tests/codegen.factor index 0a109a15eb..a56ee55c82 100644 --- a/basis/compiler/tests/templates.factor +++ b/basis/compiler/tests/codegen.factor @@ -230,3 +230,14 @@ TUPLE: id obj ; 10000000 [ "hi" 0 (gc-check-bug) drop ] times ; [ ] [ gc-check-bug ] unit-test + +! New optimization +: test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ; + +[ "a" ] [ 8 test-1 ] unit-test +[ "b" ] [ 9 test-1 ] unit-test + +: test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ; + +[ "a" ] [ 1 test-2 ] unit-test +[ "b" ] [ 2 test-2 ] unit-test diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 19d80ec14f..4e79c4cd2d 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -1,9 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors quotations kernel sequences namespaces -assocs words arrays vectors hints combinators stack-checker -stack-checker.state stack-checker.visitor stack-checker.errors -stack-checker.backend compiler.tree ; +assocs words arrays vectors hints combinators compiler.tree +stack-checker +stack-checker.state +stack-checker.errors +stack-checker.visitor +stack-checker.backend +stack-checker.recursive-state ; IN: compiler.tree.builder : with-tree-builder ( quot -- nodes ) @@ -12,12 +16,13 @@ IN: compiler.tree.builder : build-tree ( quot -- nodes ) #! Not safe to call from inference transforms. - [ f infer-quot ] with-tree-builder nip ; + [ f initial-recursive-state infer-quot ] with-tree-builder nip ; : build-tree-with ( in-stack quot -- nodes out-stack ) #! Not safe to call from inference transforms. [ - [ >vector meta-d set ] [ f infer-quot ] bi* + [ >vector meta-d set ] + [ f initial-recursive-state infer-quot ] bi* ] with-tree-builder nip unclip-last in-d>> ; @@ -29,14 +34,10 @@ IN: compiler.tree.builder if ; : (build-tree-from-word) ( word -- ) - dup - [ "inline" word-prop ] - [ "recursive" word-prop ] bi and [ - 1quotation f infer-quot - ] [ - [ specialized-def ] - [ dup 2array 1array ] 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/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index b712a6e354..4f99fa015d 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -22,8 +22,8 @@ ERROR: check-use-error value message ; GENERIC: check-node* ( node -- ) M: #shuffle check-node* - [ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ] - [ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ] + [ [ mapping>> values ] [ [ in-d>> ] [ in-r>> ] bi append ] bi subset? [ "Bad mapping inputs" throw ] unless ] + [ [ mapping>> keys ] [ [ out-d>> ] [ out-r>> ] bi append ] bi set= [ "Bad mapping outputs" throw ] unless ] bi ; : check-lengths ( seq -- ) @@ -31,13 +31,6 @@ M: #shuffle check-node* M: #copy check-node* inputs/outputs 2array check-lengths ; -: check->r/r> ( node -- ) - inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ; - -M: #>r check-node* check->r/r> ; - -M: #r> check-node* check->r/r> ; - M: #return-recursive check-node* inputs/outputs 2array check-lengths ; M: #phi check-node* @@ -113,11 +106,8 @@ M: #push check-stack-flow* check-out-d ; M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; -M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; - -M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ; - -M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ; +M: #shuffle check-stack-flow* + { [ check-in-d ] [ check-in-r ] [ check-out-d ] [ check-out-r ] } cleave ; : assert-datastack-empty ( -- ) datastack get empty? [ "Data stack not empty" throw ] unless ; diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index 719c80f911..eba82384ab 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -39,7 +39,7 @@ M: #branch remove-dead-code* [ drop filter-live ] [ swap nths ] 2bi [ make-values ] keep [ drop ] [ zip ] 2bi - #shuffle ; + #data-shuffle ; : insert-drops ( nodes values indices -- nodes' ) '[ 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/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index addb13ced3..185c776c4e 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -39,12 +39,6 @@ M: #copy compute-live-values* M: #call compute-live-values* nip look-at-inputs ; -M: #>r compute-live-values* - [ out-r>> ] [ in-d>> ] bi look-at-mapping ; - -M: #r> compute-live-values* - [ out-d>> ] [ in-r>> ] bi look-at-mapping ; - M: #shuffle compute-live-values* mapping>> at look-at-value ; @@ -61,7 +55,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; zip filter-mapping values ; : filter-live ( values -- values' ) - [ live-value? ] filter ; + dup empty? [ [ live-value? ] filter ] unless ; :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle ) inputs @@ -69,7 +63,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; outputs mapping-keys mapping-values - filter-corresponding zip #shuffle ; inline + filter-corresponding zip #data-shuffle ; inline :: drop-dead-values ( outputs -- #shuffle ) [let* | new-outputs [ outputs make-values ] @@ -95,16 +89,6 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; M: #introduce remove-dead-code* ( #introduce -- nodes ) maybe-drop-dead-outputs ; -M: #>r remove-dead-code* - [ filter-live ] change-out-r - [ filter-live ] change-in-d - dup in-d>> empty? [ drop f ] when ; - -M: #r> remove-dead-code* - [ filter-live ] change-out-d - [ filter-live ] change-in-r - dup in-r>> empty? [ drop f ] when ; - M: #push remove-dead-code* dup out-d>> first live-value? [ drop f ] unless ; @@ -125,12 +109,14 @@ M: #call remove-dead-code* M: #shuffle remove-dead-code* [ filter-live ] change-in-d [ filter-live ] change-out-d + [ filter-live ] change-in-r + [ filter-live ] change-out-r [ filter-mapping ] change-mapping - dup in-d>> empty? [ drop f ] when ; + dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ; M: #copy remove-dead-code* [ in-d>> ] [ out-d>> ] bi - 2dup swap zip #shuffle + 2dup swap zip #data-shuffle remove-dead-code* ; M: #terminate remove-dead-code* diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 59a028a4f4..a1d8773484 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -3,7 +3,7 @@ USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays prettyprint prettyprint.backend prettyprint.sections math words -combinators io sorting hints qualified +combinators combinators.short-circuit io sorting hints qualified compiler.tree compiler.tree.recursive compiler.tree.normalization @@ -57,9 +57,41 @@ TUPLE: shuffle-node { effect effect } ; M: shuffle-node pprint* effect>> effect>string text ; +: (shuffle-effect) ( in out #shuffle -- effect ) + mapping>> '[ _ at ] map ; + +: shuffle-effect ( #shuffle -- effect ) + [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ; + +: #>r? ( #shuffle -- ? ) + { + [ in-d>> length 1 = ] + [ out-r>> length 1 = ] + [ in-r>> empty? ] + [ out-d>> empty? ] + } 1&& ; + +: #r>? ( #shuffle -- ? ) + { + [ in-d>> empty? ] + [ out-r>> empty? ] + [ in-r>> length 1 = ] + [ out-d>> length 1 = ] + } 1&& ; + M: #shuffle node>quot - shuffle-effect dup pretty-shuffle - [ % ] [ shuffle-node boa , ] ?if ; + { + { [ dup #>r? ] [ drop \ >r , ] } + { [ dup #r>? ] [ drop \ r> , ] } + { + [ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ] + [ + shuffle-effect dup pretty-shuffle + [ % ] [ shuffle-node boa , ] ?if + ] + } + [ drop "COMPLEX SHUFFLE" , ] + } cond ; M: #push node>quot literal>> , ; @@ -82,16 +114,6 @@ M: #if node>quot M: #dispatch node>quot children>> [ nodes>quot ] map , \ dispatch , ; -M: #>r node>quot - [ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi - % ; - -DEFER: rdrop - -M: #r> node>quot - [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi - % ; - M: #alien-invoke node>quot params>> , \ #alien-invoke , ; M: #alien-indirect node>quot params>> , \ #alien-indirect , ; diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor index 2379f3918d..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 ; @@ -38,16 +42,16 @@ GENERIC: node-uses-values ( node -- values ) M: #introduce node-uses-values drop f ; M: #push node-uses-values drop f ; -M: #r> node-uses-values in-r>> ; M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ; M: #declare node-uses-values declaration>> keys ; M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ; +M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ; M: #alien-callback node-uses-values drop f ; M: node node-uses-values in-d>> ; GENERIC: node-defs-values ( node -- values ) -M: #>r node-defs-values out-r>> ; +M: #shuffle node-defs-values [ out-d>> ] [ out-r>> ] bi append ; M: #branch node-defs-values drop f ; M: #declare node-defs-values drop f ; M: #return node-defs-values drop f ; diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor index 4c197d7fc0..5d34eaad15 100644 --- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces sequences kernel math -combinators sets disjoint-sets fry stack-checker.state ; +combinators sets disjoint-sets fry stack-checker.values ; IN: compiler.tree.escape-analysis.allocations ! A map from values to one of the following: diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 2d2e429994..16a27e020a 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences words memoize classes.builtin +fry assocs compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -27,9 +28,10 @@ GENERIC: finalize* ( node -- nodes ) M: #copy finalize* drop f ; M: #shuffle finalize* - dup shuffle-effect - [ in>> ] [ out>> ] bi sequence= - [ drop f ] when ; + dup + [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] + [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] + bi and [ drop f ] when ; : builtin-predicate? ( #call -- ? ) word>> "predicating" word-prop builtin-class? ; diff --git a/basis/compiler/tree/identities/identities.factor b/basis/compiler/tree/identities/identities.factor index d6ed59cbaa..00632ec6f6 100644 --- a/basis/compiler/tree/identities/identities.factor +++ b/basis/compiler/tree/identities/identities.factor @@ -79,7 +79,7 @@ GENERIC: apply-identities* ( node -- node ) : select-input ( node n -- #shuffle ) [ [ in-d>> ] [ out-d>> ] bi ] dip - pick nth over first associate #shuffle ; + pick nth over first associate #data-shuffle ; M: #call apply-identities* dup word>> "identities" word-prop [ diff --git a/basis/compiler/tree/normalization/renaming/renaming.factor b/basis/compiler/tree/normalization/renaming/renaming.factor index 3050df2611..9d68f4a733 100644 --- a/basis/compiler/tree/normalization/renaming/renaming.factor +++ b/basis/compiler/tree/normalization/renaming/renaming.factor @@ -10,7 +10,7 @@ SYMBOL: rename-map [ rename-map get at ] keep or ; : rename-values ( values -- values' ) - rename-map get '[ [ _ at ] keep or ] map ; + dup empty? [ rename-map get '[ [ _ at ] keep or ] map ] unless ; : add-renamings ( old new -- ) [ rename-values ] dip @@ -22,13 +22,11 @@ M: #introduce rename-node-values* ; M: #shuffle rename-node-values* [ rename-values ] change-in-d + [ rename-values ] change-in-r [ [ rename-value ] assoc-map ] change-mapping ; M: #push rename-node-values* ; -M: #r> rename-node-values* - [ rename-values ] change-in-r ; - M: #terminate rename-node-values* [ rename-values ] change-in-d [ rename-values ] change-in-r ; 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/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 05f33902ec..9f9a43df64 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry arrays generic assocs kernel math namespaces parser -sequences words vectors math.intervals effects classes +sequences words vectors math.intervals classes accessors combinators stack-checker.state stack-checker.visitor stack-checker.inlining ; IN: compiler.tree @@ -42,30 +42,21 @@ TUPLE: #push < node literal out-d ; TUPLE: #renaming < node ; -TUPLE: #shuffle < #renaming mapping in-d out-d ; +TUPLE: #shuffle < #renaming mapping in-d out-d in-r out-r ; -: #shuffle ( inputs outputs mapping -- node ) +: #shuffle ( in-d out-d in-r out-r mapping -- node ) \ #shuffle new swap >>mapping + swap >>out-r + swap >>in-r swap >>out-d swap >>in-d ; +: #data-shuffle ( in-d out-d mapping -- node ) + [ f f ] dip #shuffle ; inline + : #drop ( inputs -- node ) - { } { } #shuffle ; - -TUPLE: #>r < #renaming in-d out-r ; - -: #>r ( inputs outputs -- node ) - \ #>r new - swap >>out-r - swap >>in-d ; - -TUPLE: #r> < #renaming in-r out-d ; - -: #r> ( inputs outputs -- node ) - \ #r> new - swap >>out-d - swap >>in-r ; + { } { } #data-shuffle ; TUPLE: #terminate < node in-d in-r ; @@ -171,16 +162,9 @@ TUPLE: #alien-callback < #alien-node ; GENERIC: inputs/outputs ( #renaming -- inputs outputs ) M: #shuffle inputs/outputs mapping>> unzip swap ; -M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ; -M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ; M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ; M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ; -: shuffle-effect ( #shuffle -- effect ) - [ in-d>> ] [ out-d>> ] [ mapping>> ] tri - '[ _ at ] map - ; - : recursive-phi-in ( #enter-recursive -- seq ) [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; @@ -193,8 +177,8 @@ M: vector #call, #call node, ; M: vector #push, #push node, ; M: vector #shuffle, #shuffle node, ; M: vector #drop, #drop node, ; -M: vector #>r, #>r node, ; -M: vector #r>, #r> node, ; +M: vector #>r, [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ; +M: vector #r>, [ swap [ f swap ] dip f ] [ swap zip ] 2bi #shuffle, ; M: vector #return, #return node, ; M: vector #enter-recursive, #enter-recursive node, ; M: vector #return-recursive, #return-recursive node, ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 8e07c08194..52903fce8d 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -42,7 +42,7 @@ M: #push unbox-tuples* ( #push -- nodes ) [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ; : flatten-values ( values -- values' ) - (flatten-values) flatten ; + dup empty? [ (flatten-values) flatten ] unless ; : prepare-slot-access ( #call -- tuple-values outputs slot-values ) [ in-d>> flatten-values ] @@ -54,7 +54,7 @@ M: #push unbox-tuples* ( #push -- nodes ) ] tri ; : slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle ) - [ drop ] [ zip ] 2bi #shuffle ; + [ drop ] [ zip ] 2bi #data-shuffle ; : unbox-slot-access ( #call -- nodes ) dup out-d>> first unboxed-slot-access? [ @@ -77,17 +77,11 @@ M: #copy unbox-tuples* [ flatten-values ] change-in-d [ flatten-values ] change-out-d ; -M: #>r unbox-tuples* - [ flatten-values ] change-in-d - [ flatten-values ] change-out-r ; - -M: #r> unbox-tuples* - [ flatten-values ] change-in-r - [ flatten-values ] change-out-d ; - M: #shuffle unbox-tuples* [ flatten-values ] change-in-d [ flatten-values ] change-out-d + [ flatten-values ] change-in-r + [ flatten-values ] change-out-r [ unzip [ flatten-values ] bi@ zip ] change-mapping ; M: #terminate unbox-tuples* diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index a23301c1e2..cb07e5a8d6 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -2,27 +2,27 @@ 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." } ; 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 b0b5b048d9..96dd577c10 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -50,7 +50,7 @@ HOOK: %call cpu ( word -- ) HOOK: %jump-label cpu ( label -- ) HOOK: %return cpu ( -- ) -HOOK: %dispatch cpu ( src temp -- ) +HOOK: %dispatch cpu ( src temp offset -- ) HOOK: %dispatch-label cpu ( word -- ) HOOK: %slot cpu ( dst obj slot tag temp -- ) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 9bf88185c5..aee0f3f4f3 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -57,7 +57,12 @@ big-endian on [ 0 6 LOAD32 - 4 1 MR + 7 6 0 LWZ + 1 7 0 STW +] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define + +[ + 0 6 LOAD32 6 MTCTR BCTR ] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 49caae4bb8..c656ae4d89 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -111,10 +111,10 @@ M: ppc %call ( label -- ) BL ; M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; -M:: ppc %dispatch ( src temp -- ) - 0 temp LOAD32 rc-absolute-ppc-2/2 rel-here - temp temp src ADD - temp temp 5 cells LWZ +M:: ppc %dispatch ( src temp offset -- ) + 0 temp LOAD32 + 4 offset + cells rc-absolute-ppc-2/2 rel-here + temp temp src LWZX temp MTCTR BCTR ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index f26d76551a..f892271fd5 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -6,7 +6,7 @@ accessors init combinators command-line cpu.x86.assembler cpu.x86 cpu.architecture compiler compiler.units compiler.constants compiler.alien compiler.codegen compiler.codegen.fixup compiler.cfg.instructions -compiler.cfg.builder compiler.cfg.intrinsics ; +compiler.cfg.builder compiler.cfg.intrinsics make ; IN: cpu.x86.32 ! We implement the FFI for Linux, OS X and Windows all at once. @@ -26,6 +26,18 @@ M: x86.32 stack-reg ESP ; M: x86.32 temp-reg-1 EAX ; M: x86.32 temp-reg-2 ECX ; +M:: x86.32 %dispatch ( src temp offset -- ) + ! Load jump table base. + src HEX: ffffffff ADD + offset cells rc-absolute-cell rel-here + ! Go + src HEX: 7f [+] JMP + ! Fix up the displacement above + cell code-alignment + [ 7 + building get dup pop* push ] + [ align-code ] + bi ; + M: x86.32 reserved-area-size 0 ; M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 44f840e66a..ba963ab477 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts vocabs parser ; +cpu.x86.assembler layouts vocabs parser compiler.constants ; IN: bootstrap.x86 4 \ cell set @@ -19,5 +19,14 @@ IN: bootstrap.x86 : fixnum>slot@ ( -- ) arg0 1 SAR ; : rex-length ( -- n ) 0 ; +[ + arg0 0 [] MOV ! load stack_chain + arg0 [] stack-reg MOV ! save stack pointer +] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define + +[ + (JMP) drop +] rc-relative rt-primitive 1 jit-primitive jit-define + << "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 0d20660021..75c808b50a 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math namespaces make sequences system layouts alien alien.c-types alien.accessors alien.structs -slots splitting assocs combinators cpu.x86.assembler +slots splitting assocs combinators make locals cpu.x86.assembler cpu.x86 cpu.architecture compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder @@ -24,6 +24,19 @@ M: x86.64 stack-reg RSP ; M: x86.64 temp-reg-1 RAX ; M: x86.64 temp-reg-2 RCX ; +M:: x86.64 %dispatch ( src temp offset -- ) + ! Load jump table base. + temp HEX: ffffffff MOV + offset cells rc-absolute-cell rel-here + ! Add jump table base + src temp ADD + src HEX: 7f [+] JMP + ! Fix up the displacement above + cell code-alignment + [ 15 + building get dup pop* push ] + [ align-code ] + bi ; + : param-reg-1 int-regs param-regs first ; inline : param-reg-2 int-regs param-regs second ; inline : param-reg-3 int-regs param-regs third ; inline diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index acac8b55bc..83a72d6dd3 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts vocabs parser ; +cpu.x86.assembler layouts vocabs parser compiler.constants math ; IN: bootstrap.x86 8 \ cell set @@ -16,5 +16,16 @@ IN: bootstrap.x86 : fixnum>slot@ ( -- ) ; : rex-length ( -- n ) 1 ; +[ + arg0 0 MOV ! load stack_chain + arg0 arg0 [] MOV + arg0 [] stack-reg MOV ! save stack pointer +] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define + +[ + arg1 0 MOV ! load XT + arg1 JMP ! go +] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define + << "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 6dadbc096c..1ee74a434b 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -44,12 +44,6 @@ big-endian off ds-reg [] arg0 MOV ! store literal on datastack ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define -[ - arg0 0 MOV ! load XT - arg1 stack-reg MOV ! pass callstack pointer as arg 2 - arg0 JMP ! go -] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define - [ (JMP) drop ] rc-relative rt-xt 1 jit-word-jump jit-define diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 4f72fe45e1..dfe3d3e55e 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -60,19 +60,6 @@ M: x86 %return ( -- ) 0 RET ; : align-code ( n -- ) 0 % ; -M:: x86 %dispatch ( src temp -- ) - ! Load jump table base. We use a temporary register - ! since on AMD64 we have to load a 64-bit immediate. On - ! x86, this is redundant. - ! Add jump table base - temp HEX: ffffffff MOV rc-absolute-cell rel-here - src temp ADD - src HEX: 7f [+] JMP - ! Fix up the displacement above - cell code-alignment dup bootstrap-cell 8 = 15 9 ? + - building get dup pop* push - align-code ; - M: x86 %dispatch-label ( word -- ) 0 cell, rc-absolute-cell rel-word ; 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 1d9f72f8c3..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" , - "--no-wait" , + \ emacsclient get "emacsclient" or , + os windows? [ "--no-wait" , ] unless "+" swap number>string append , , ] { } make try-process ; diff --git a/basis/editors/etexteditor/authors.txt b/basis/editors/etexteditor/authors.txt new file mode 100755 index 0000000000..7b1e3b7fa0 --- /dev/null +++ b/basis/editors/etexteditor/authors.txt @@ -0,0 +1 @@ +Kibleur Christophe \ No newline at end of file diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor new file mode 100755 index 0000000000..316bd24cfa --- /dev/null +++ b/basis/editors/etexteditor/etexteditor.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Kibleur Christophe. +! See http://factorcode.org/license.txt for BSD license. +USING: editors io.files io.launcher kernel math.parser +namespaces sequences windows.shell32 make ; +IN: editors.etexteditor + +: etexteditor-path ( -- str ) + \ etexteditor-path get-global [ + program-files "e\\e.exe" append-path + ] unless* ; + +: etexteditor ( file line -- ) + [ + etexteditor-path , + [ , ] [ "--line" , number>string , ] bi* + ] { } make run-detached drop ; + +[ etexteditor ] edit-hook set-global diff --git a/basis/editors/etexteditor/summary.txt b/basis/editors/etexteditor/summary.txt new file mode 100755 index 0000000000..46537003d9 --- /dev/null +++ b/basis/editors/etexteditor/summary.txt @@ -0,0 +1 @@ +etexteditor integration diff --git a/basis/editors/etexteditor/tags.txt b/basis/editors/etexteditor/tags.txt new file mode 100755 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/etexteditor/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor new file mode 100644 index 0000000000..dd453ae16d --- /dev/null +++ b/basis/furnace/actions/actions-docs.factor @@ -0,0 +1,170 @@ +USING: assocs classes help.markup help.syntax io.streams.string +http http.server.dispatchers http.server.responses +furnace.redirection strings multiline ; +IN: furnace.actions + +HELP: +{ $values { "action" action } } +{ $description "Creates a new action." } ; + +HELP: +{ $values + { "path" "a pathname string" } + { "response" response } +} +{ $description "Creates an HTTP response which serves a Chloe template. See " { $link "html.templates.chloe" } "." } ; + +HELP: +{ $values { "page" action } } +{ $description "Creates a new action which serves a Chloe template when servicing a GET request." } ; + +HELP: action +{ $class-description "The class of Furnace actions. New instances are created with " { $link } ". New instances of subclasses can be created with " { $link new-action } ". The " { $link page-action } " class is a useful subclass." +$nl +"Action slots are documented in " { $link "furnace.actions.config" } "." } ; + +HELP: new-action +{ $values + { "class" class } + { "action" action } +} +{ $description "Constructs a subclass of " { $link action } "." } ; + +HELP: page-action +{ $class-description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ; + +HELP: param +{ $values + { "name" string } + { "value" string } +} +{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } +{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ; + +HELP: params +{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." } +{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ; + +HELP: validate-integer-id +{ $description "A utility word which validates an integer parameter named " { $snippet "id" } "." } +{ $examples + { $code + "" + " [" + " validate-integer-id" + " \"id\" value select-tuple from-object" + " ] >>init" + } +} ; + +HELP: validate-params +{ $values + { "validators" "an association list mapping parameter names to validator quotations" } +} +{ $description "Validates query or POST parameters, depending on the request type, and stores them in " { $link "html.forms.values" } ". The validator quotations can execute " { $link "validators" } "." } +{ $examples + "A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:" + { $code + <" : validate-todo ( -- ) + { + { "summary" [ v-one-line ] } + { "priority" [ v-integer 0 v-min-value 10 v-max-value ] } + { "description" [ v-required ] } + } validate-params ;"> + } +} ; + +HELP: validation-failed +{ $description "Stops processing the current request and takes action depending on the type of the current request:" + { $list + { "For GET or HEAD requests, the client receives a " { $link <400> } " response." } + { "For POST requests, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." } + } +"This word is called by " { $link validate-params } " and can also be called directly. For more details, see " { $link "furnace.actions.lifecycle" } "." } ; + +ARTICLE: "furnace.actions.page.example" "Furnace page action example" +"The " { $vocab-link "webapps.counter" } " vocabulary defines a subclass of " { $link dispatcher } ":" +{ $code "TUPLE: counter-app < dispatcher ;" } +"The " { $snippet "" } " constructor word creates a new instance of the " { $snippet "counter-app" } " class, and adds a " { $link page-action } " instance to the dispatcher. This " { $link page-action } " has its " { $slot "template" } " slot set as follows," +{ $code "{ counter-app \"counter\" } >>template" } +"This means the action will serve the Chloe template located at " { $snippet "resource:extra/webapps/counter/counter.xml" } " upon receiving a GET request." ; + +ARTICLE: "furnace.actions.page" "Furnace page actions" +"Page actions implement the common case of an action that simply serves a Chloe template in response to a GET request." +{ $subsection page-action } +{ $subsection } +"When using a page action, instead of setting the " { $slot "display" } " slot, the " { $slot "template" } " slot is set instead. The " { $slot "init" } ", " { $slot "authorize" } ", " { $slot "validate" } " and " { $slot "submit" } " slots can still be set as usual." +$nl +"The " { $slot "template" } " slot of a " { $link page-action } " contains a pair with shape " { $snippet "{ responder name }" } ", where " { $snippet "responder" } " is a responder class, usually a subclass of " { $link dispatcher } ", and " { $snippet "name" } " is the name of a template file, without the " { $snippet ".xml" } " extension, relative to the directory containing the responder's vocabulary source file." +{ $subsection "furnace.actions.page.example" } ; + +ARTICLE: "furnace.actions.config" "Furnace action configuration" +"Actions have the following slots:" +{ $table + { { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error." } } + { { $slot "init" } { "A quotation called at the beginning of a GET or HEAD request. Typically this quotation configures " { $link "html.forms" } " and parses query parameters." } } + { { $slot "authorize" } { "A quotation called at the beginning of a GET, HEAD or POST request. In GET requests, it is called after the " { $slot "init" } " quotation; in POST requests, it is called after the " { $slot "validate" } " quotation. By convention, this quotation performs custom authorization checks which depend on query parameters or POST parameters." } } + { { $slot "display" } { "A quotation called after the " { $slot "init" } " quotation in a GET request. This quotation must return an HTTP " { $link response } "." } } + { { $slot "validate" } { "A quotation called at the beginning of a POST request to validate POST parameters." } } + { { $slot "submit" } { "A quotation called after the " { $slot "validate" } " quotation in a POST request. This quotation must return an HTTP " { $link response } "." } } +} +"At least one of the " { $slot "display" } " and " { $slot "submit" } " slots must be set, otherwise the action will be useless." ; + +ARTICLE: "furnace.actions.validation" "Form validation with actions" +"The action code is set up so that the " { $slot "init" } " quotation can validate query parameters, and the " { $slot "validate" } " quotation can validate POST parameters." +$nl +"A word to validate parameters and make them available as HTML form values (see " { $link "html.forms.values" } "); typically this word is invoked from the " { $slot "init" } " and " { $slot "validate" } " quotations:" +{ $subsection validate-params } +"The above word expects an association list mapping parameter names to validator quotations; validator quotations can use the words in the " +"Custom validation logic can invoke a word when validation fails; " { $link validate-params } " invokes this word for you:" +{ $subsection validation-failed } +"If validation fails, no more action code is executed, and the client is redirected back to the originating page, where validation errors can be displayed. Note that validation errors are rendered automatically by the " { $link "html.components" } " words, and in particular, " { $link "html.templates.chloe" } " use these words." ; + +ARTICLE: "furnace.actions.lifecycle" "Furnace action lifecycle" +{ $heading "GET request lifecycle" } +"A GET request results in the following sequence of events:" +{ $list + { "The " { $snippet "init" } " quotation is called." } + { "The " { $snippet "authorize" } " quotation is called." } + { "If the GET request was generated as a result of form validation failing during a POST, then the form values entered by the user, along with validation errors, are stored in " { $link "html.forms.values" } "." } + { "The " { $snippet "display" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack." } +} +"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a GET request, the client receives a " { $link <400> } " error." +{ $heading "HEAD request lifecycle" } +"A HEAD request proceeds exactly like a GET request. The only difference is that the " { $slot "body" } " slot of the " { $link response } " object is never rendered." +{ $heading "POST request lifecycle" } +"A POST request results in the following sequence of events:" +{ $list + { "The " { $snippet "validate" } " quotation is called." } + { "The " { $snippet "authorize" } " quotation is called." } + { "The " { $snippet "submit" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack. By convention, this response should be a " { $link } "." } +} +"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a POST request, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." ; + +ARTICLE: "furnace.actions.impl" "Furnace actions implementation" +"The following words are used by the action implementation and there is rarely any reason to call them directly:" +{ $subsection new-action } +{ $subsection param } +{ $subsection params } ; + +ARTICLE: "furnace.actions" "Furnace actions" +"The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle." +$nl +"Other than form validation capability, actions are also often simpler to use than implementing new responders directly, since creating a new class is not required, and the action dispatches on the request type (GET, HEAD, or POST)." +$nl +"The class of actions:" +{ $subsection action } +"Creating a new action:" +{ $subsection } +"Once created, an action needs to be configured; typically the creation and configuration of an action is encapsulated into a single word:" +{ $subsection "furnace.actions.config" } +"Validating forms with actions:" +{ $subsection "furnace.actions.validation" } +"More about the form validation lifecycle:" +{ $subsection "furnace.actions.lifecycle" } +"A convenience class:" +{ $subsection "furnace.actions.page" } +"Low-level features:" +{ $subsection "furnace.actions.impl" } ; + +ABOUT: "furnace.actions" diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 7505b3c612..6c56a8ad7b 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -22,18 +22,7 @@ SYMBOL: params SYMBOL: rest -: render-validation-messages ( -- ) - form get errors>> - [ -
    - [
  • escape-string write
    • ] each -
- ] unless-empty ; - -CHLOE: validation-messages - drop [ render-validation-messages ] [code] ; - -TUPLE: action rest authorize init display validate submit ; +TUPLE: action rest init authorize display validate submit ; : new-action ( class -- action ) new [ ] >>init [ ] >>validate [ ] >>authorize ; inline diff --git a/basis/furnace/alloy/alloy-docs.factor b/basis/furnace/alloy/alloy-docs.factor new file mode 100644 index 0000000000..f108428c90 --- /dev/null +++ b/basis/furnace/alloy/alloy-docs.factor @@ -0,0 +1,42 @@ +IN: furnace.alloy +USING: help.markup help.syntax db multiline ; + +HELP: init-furnace-tables +{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ; + +HELP: +{ $values { "responder" "a responder" } { "db" db } { "responder'" "an alloy responder" } } +{ $description "Wraps the responder with support for asides, conversations, sessions and database persistence." } +{ $examples + "The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:" + { $code + <" : counter-db ( -- db ) "counter.db" ; + +: run-counter ( -- ) + + counter-db + main-responder set-global + 8080 httpd ;"> + } +} ; + +HELP: start-expiring +{ $values { "db" db } } +{ $description "Starts a timer which expires old session state from the given database." } ; + +ARTICLE: "furnace.alloy" "Furnace alloy responder" +"The " { $vocab-link "furnace.alloy" } " vocabulary implements a convenience responder which combines several Furnace features into one easy-to-use wrapper:" +{ $list + { $link "furnace.asides" } + { $link "furnace.conversations" } + { $link "furnace.sessions" } + { $link "furnace.db" } +} +"A word to wrap a responder in an alloy:" +{ $subsection } +"Initializing database tables for asides, conversations and sessions:" +{ $subsection init-furnace-tables } +"Start a timer to expire asides, conversations and sessions:" +{ $subsection start-expiring } ; + +ABOUT: "furnace.alloy" 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/asides/asides-docs.factor b/basis/furnace/asides/asides-docs.factor new file mode 100644 index 0000000000..c5b7bdd537 --- /dev/null +++ b/basis/furnace/asides/asides-docs.factor @@ -0,0 +1,33 @@ +USING: help.markup help.syntax io.streams.string urls +furnace.redirection http furnace.sessions furnace.db ; +IN: furnace.asides + +HELP: +{ $values + { "responder" "a responder" } + { "responder'" "a new responder" } +} +{ $description "Creates a new " { $link asides } " responder wrapping an existing responder." } ; + +HELP: begin-aside +{ $values { "url" url } } +{ $description "Begins an aside. When the current action returns a " { $link } ", the redirect will have query parameters which reference the current page via an opaque handle." } ; + +HELP: end-aside +{ $values { "default" url } { "response" response } } +{ $description "Ends an aside. If an aside is currently active, the response redirects the client " } ; + +ARTICLE: "furnace.asides" "Furnace asides" +"The " { $vocab-link "furnace.asides" } " vocabulary provides support for sending a user to a page which can then return to the former location." +$nl +"To use asides, wrap your responder in an aside responder:" +{ $subsection } +"The asides responder must be wrapped inside a session responder (" { $link } "), which in turn must be wrapped inside a database persistence responder (" { $link } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one." +$nl +"Saving the current page in an aside which propagates through " { $link } " responses:" +{ $subsection begin-aside } +"Returning from an aside:" +{ $subsection end-aside } +"Asides are used by " { $vocab-link "furnace.auth.login" } "; when the client requests a protected page, an aside begins and the client is redirected to a login page. Upon a successful login, the aside ends and the client returns to the protected page. If the client directly visits the login page and logs in, there is no current aside, so the client is sent to the default URL passed to " { $link end-aside } ", which in the case of login is the root URL." ; + +ABOUT: "furnace.asides" 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 f486f4e246..878bdd64fb 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile.xml +++ b/basis/furnace/auth/features/edit-profile/edit-profile.xml @@ -62,7 +62,7 @@

- +

diff --git a/basis/furnace/auth/features/recover-password/recover-3.xml b/basis/furnace/auth/features/recover-password/recover-3.xml index a8ea635a1f..2df400ffe2 100644 --- a/basis/furnace/auth/features/recover-password/recover-3.xml +++ b/basis/furnace/auth/features/recover-password/recover-3.xml @@ -32,7 +32,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 b0d6971d1b..45c090905e 100644 --- a/basis/furnace/auth/features/registration/register.xml +++ b/basis/furnace/auth/features/registration/register.xml @@ -63,7 +63,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 766c097ca5..917c182fb3 100644 --- a/basis/furnace/auth/login/login.xml +++ b/basis/furnace/auth/login/login.xml @@ -36,7 +36,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/boilerplate/boilerplate-docs.factor b/basis/furnace/boilerplate/boilerplate-docs.factor new file mode 100644 index 0000000000..ad983c8dc1 --- /dev/null +++ b/basis/furnace/boilerplate/boilerplate-docs.factor @@ -0,0 +1,35 @@ +USING: help.markup help.syntax io.streams.string +http.server.dispatchers ; +IN: furnace.boilerplate + +HELP: +{ $values + { "responder" "a responder" } + { "boilerplate" "a new boilerplate responder" } +} +{ $description "Wraps a responder in a boilerplate responder. The boilerplate responder needs to be configured before use; see " { $link "furnace.boilerplate.config" } "." } ; + +HELP: boilerplate +{ $class-description "The class of boilerplate responders. Slots are documented in " { $link "furnace.boilerplate.config" } "." } ; + +ARTICLE: "furnace.boilerplate.config" "Boilerplate configuration" +"The " { $link boilerplate } " tuple has two slots which can be set:" +{ $table + { { $slot "template" } { "A pair with shape " { $snippet "{ responder name }" } ", where " { $snippet "responder" } " is a responder class, usually a subclass of " { $link dispatcher } ", and " { $snippet "name" } " is the name of a template file, without the " { $snippet ".xml" } " extension, relative to the directory containing the responder's vocabulary source file." } } + { { $slot "init" } { "A quotation run before the boilerplate template is rendered. This quotation can set values which the template can then display." } } +} ; + +ARTICLE: "furnace.boilerplate.example" "Boilerplate example" +"The " { $vocab-link "webapps.wiki" } " vocabulary uses boilerplate to add a footer and sidebar to every page. Since the footer and sidebar are themselves dynamic content, it sets the " { $slot "init" } " quotation as well as the " { $slot "template" } " slot:" +{ $code "" +" [ init-sidebars init-relative-link-prefix ] >>init" +" { wiki \"wiki-common\" } >>template" } ; + +ARTICLE: "furnace.boilerplate" "Furnace boilerplate support" +"The " { $vocab-link "furnace.boilerplate" } " vocabulary implements a facility for sharing a common header and footer between different pages on a web site. It builds on top of " { $link "html.templates.boilerplate" } "." +{ $subsection } +{ $subsection "furnace.boilerplate.config" } +{ $subsection "furnace.boilerplate.example" } +{ $see-also "html.templates.chloe.tags.boilerplate" } ; + +ABOUT: "furnace.boilerplate" diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor new file mode 100644 index 0000000000..4ad2c8a249 --- /dev/null +++ b/basis/furnace/conversations/conversations-docs.factor @@ -0,0 +1,53 @@ +USING: help.markup help.syntax urls http words kernel +furnace.sessions furnace.db ; +IN: furnace.conversations + +HELP: +{ $values + { "responder" "a responder" } + { "responder'" "a new responder" } +} +{ $description "Creates a new " { $link conversations } " responder wrapping an existing responder." } ; + +HELP: begin-conversation +{ $description "Starts a new conversation scope. Values can be stored in the conversation scope with " { $link cset } ", and the conversation can be continued with " { $link } "." } ; + +HELP: end-conversation +{ $description "Ends the current conversation scope." } ; + +HELP: +{ $values { "url" url } { "response" response } } +{ $description "Creates an HTTP response which redirects the client to the specified URL while continuing the conversation. Any values set in the current conversation scope will be visible to the resonder handling the URL." } ; + +HELP: cget +{ $values { "key" symbol } { "value" object } } +{ $description "Outputs the value of a conversation variable." } ; + +HELP: cset +{ $values { "value" object } { "key" symbol } } +{ $description "Sets the value of a conversation variable." } ; + +HELP: cchange +{ $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" +"The " { $vocab-link "furnace.conversations" } " vocabulary implements conversation scope, which allows data to be passed between requests on a finer level of granularity than session scope." +$nl +"Conversation scope is used by form validation to pass validation errors between requests." +$nl +"To use conversation scope, wrap your responder in an conversation responder:" +{ $subsection } +"The conversations responder must be wrapped inside a session responder (" { $link } "), which in turn must be wrapped inside a database persistence responder (" { $link } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one." +$nl +"Managing conversation scopes:" +{ $subsection begin-conversation } +{ $subsection end-conversation } +{ $subsection } +"Reading and writing conversation variables:" +{ $subsection cget } +{ $subsection cset } +{ $subsection cchange } +"Note that conversation scope is serialized as part of the session, which means that only serializable objects can be stored there. See " { $link "furnace.sessions.serialize" } " for details." ; + +ABOUT: "furnace.conversations" diff --git a/basis/furnace/db/db-docs.factor b/basis/furnace/db/db-docs.factor new file mode 100644 index 0000000000..a7ef02b77f --- /dev/null +++ b/basis/furnace/db/db-docs.factor @@ -0,0 +1,16 @@ +USING: help.markup help.syntax db http.server ; +IN: furnace.db + +HELP: +{ $values + { "responder" "a responder" } { "db" db } + { "responder'" db-persistence } +} +{ $description "Wraps a responder with database persistence support. The responder's " { $link call-responder* } " method will run in a " { $link with-db } " scope." } ; + +ARTICLE: "furnace.db" "Furnace database support" +"The " { $vocab-link "furnace.db" } " vocabulary implements a responder which maintains a database connection pool and runs each request in a " { $link with-db } " scope." +{ $subsection } +"The " { $vocab-link "furnace.alloy" } " vocabulary combines database persistence with several other features." ; + +ABOUT: "furnace.db" diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor new file mode 100644 index 0000000000..b86d4c3295 --- /dev/null +++ b/basis/furnace/furnace-docs.factor @@ -0,0 +1,180 @@ +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 "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 "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" 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 "( responder -- )" } } } +{ $description "Applies the quotation to each responder involved in processing the current request." } ; + +HELP: hidden-form-field +{ $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" 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" "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" 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" 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" "a sequence of responders" } } +{ $description "" } ; + +HELP: referrer +{ $values { "referrer/f" { $maybe string } } } +{ $description "Outputs the current request's referrer URL." } ; + +HELP: request-params +{ $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 } } +{ $description "" } ; + +HELP: resolve-template-path +{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } } +{ $description "" } ; + +HELP: same-host? +{ $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" { $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" } } +{ $description "" } ; + +HELP: exit-with +{ $values { "value" object } } +{ $description "Exits from an outer " { $link with-exit-continuation } "." } ; + +HELP: with-exit-continuation +{ $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 setateless 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" } +"Server-side state:" +{ $subsection "furnace.sessions" } +{ $subsection "furnace.conversations" } +{ $subsection "furnace.asides" } +{ $subsection "furnace.presentation" } ; + +ARTICLE: "furnace.presentation" "Furnace presentation layer" +"HTML components:" +{ $subsection "html.components" } +{ $subsection "html.forms" } +"Content templates:" +{ $subsection "html.templates" } +{ $subsection "html.templates.chloe" } +{ $subsection "html.templates.fhtml" } +{ $subsection "furnace.boilerplate" } +"Other types of content:" +{ $subsection "furnace.syndication" } +{ $subsection "furnace.json" } ; + +ARTICLE: "furnace.load-balancing" "Load balancing and fail-over with Furnace" +"The Furnace session manager persists sessions to a database. This means that HTTP requests can be transparently distributed between multiple Factor HTTP server instances, running the same web app on top of the same database, as long as the web applications do not use mutable global state, such as global variables. The Furnace framework itself does not use any mutable global state." ; + +ARTICLE: "furnace" "Furnace framework" +"The " { $vocab-link "furnace" } " vocabulary implements a full-featured web framework on top of the " { $link "http.server" } ". Some of its features include:" +{ $list + "Session management capable of load-balancing and fail-over" + "Form components and validation" + "Authentication system with basic authentication or login pages, and pluggable authentication backends" + "Easy Atom feed syndication" + "Conversation scope and asides for complex page flow" +} +"Major functionality:" +{ $subsection "furnace.actions" } +{ $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" } +{ $subsection "http.server" } +{ $subsection "logging" } +{ $subsection "urls" } ; + +ABOUT: "furnace" diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index 7285c436bc..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,31 @@ 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 +"furnace.actions" require +"furnace.alloy" require +"furnace.asides" require +"furnace.auth" require +"furnace.auth.basic" require +"furnace.auth.features.deactivate-user" require +"furnace.auth.features.edit-profile" require +"furnace.auth.features.recover-password" require +"furnace.auth.features.registration" require +"furnace.auth.login" require +"furnace.auth.providers.assoc" require +"furnace.auth.providers.db" require +"furnace.auth.providers.null" require +"furnace.boilerplate" require "furnace.chloe-tags" require +"furnace.conversations" require +"furnace.db" require +"furnace.json" require +"furnace.redirection" require +"furnace.referrer" require +"furnace.scopes" require +"furnace.sessions" require +"furnace.syndication" require +"webapps.user-admin" require diff --git a/basis/furnace/json/json-docs.factor b/basis/furnace/json/json-docs.factor new file mode 100644 index 0000000000..c20c2e6c91 --- /dev/null +++ b/basis/furnace/json/json-docs.factor @@ -0,0 +1,12 @@ +USING: kernel http.server help.markup help.syntax http ; +IN: furnace.json + +HELP: +{ $values { "body" object } { "response" response } } +{ $description "Creates an HTTP response which serves a serialized JSON object to the client." } ; + +ARTICLE: "furnace.json" "Furnace JSON support" +"The " { $vocab-link "furnace.json" } " vocabulary provides a utility word for serving HTTP responses with JSON content." +{ $subsection } ; + +ABOUT: "furnace.json" diff --git a/basis/furnace/redirection/redirection-docs.factor b/basis/furnace/redirection/redirection-docs.factor new file mode 100644 index 0000000000..fd3671fa1c --- /dev/null +++ b/basis/furnace/redirection/redirection-docs.factor @@ -0,0 +1,59 @@ +USING: help.markup help.syntax io.streams.string quotations urls +http.server http ; +IN: furnace.redirection + +HELP: +{ $values { "url" url } { "responder" "a responder" } } +{ $description "Creates a responder which unconditionally redirects the client to the given URL." } ; + +HELP: +{ $values { "url" url } { "response" response } } +{ $description "Creates a response which redirects the client to the given URL." } ; + +HELP: ( responder -- responder' ) +{ $values { "responder" "a responder" } { "responder'" "a responder" } } +{ $description "Creates a new responder which ensures that the client is connecting via HTTPS before delegating to the underlying responder. If the client is connecting via HTTP, a redirect is sent instead." } ; + +HELP: +{ $values + { "url" url } + { "response" response } +} +{ $description "Creates a responder which unconditionally redirects the client to the given URL after setting its protocol to HTTPS." } +{ $notes "This word is intended to be used with a relative URL. The client is redirected to the relative URL, but with HTTPS instead of HTTP." } ; + +HELP: >secure-url +{ $values + { "url" url } + { "url'" url } +} +{ $description "Sets the protocol of a URL to HTTPS." } ; + +HELP: if-secure +{ $values + { "quot" quotation } + { "response" response } +} +{ $description "Runs a quotation if the current request was made over HTTPS, otherwise returns a redirect to have the client request the current page again via HTTPS." } ; + +ARTICLE: "furnace.redirection.secure" "Secure redirection" +"The words in this section help with implementing sites which require SSL/TLS for additional security." +$nl +"Converting a HTTP URL into an HTTPS URL:" +{ $subsection >secure-url } +"Redirecting the client to an HTTPS URL:" +{ $subsection } +"Tools for writing responders which require SSL/TLS connections:" +{ $subsection if-secure } +{ $subsection } ; + +ARTICLE: "furnace.redirection" "Furnace redirection support" +"The " { $vocab-link "furnace.redirection" } " vocabulary builds additional functionality on top of " { $vocab-link "http.server.redirection" } ", and integrates with various Furnace features such as " { $link "furnace.asides" } " and " { $link "furnace.conversations" } "." +$nl +"A redirection response which takes asides and conversations into account:" +{ $subsection } +"A responder which unconditionally redirects the client to another URL:" +{ $subsection } +{ $subsection "furnace.redirection.secure" } ; + +ABOUT: "furnace.redirection" diff --git a/basis/furnace/referrer/referrer-docs.factor b/basis/furnace/referrer/referrer-docs.factor new file mode 100644 index 0000000000..599461c37c --- /dev/null +++ b/basis/furnace/referrer/referrer-docs.factor @@ -0,0 +1,19 @@ +USING: help.markup help.syntax io.streams.string +furnace ; +IN: furnace.referrer + +HELP: +{ $values + { "responder" "a responder" } + { "responder'" "a responder" } +} +{ $description "Wraps the responder in a filter responder which ensures that form submissions originate from a page on the same server. Any submissions which do not are sent back with a 403 error." } ; + +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 } +"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 new file mode 100644 index 0000000000..959d6b69b8 --- /dev/null +++ b/basis/furnace/sessions/sessions-docs.factor @@ -0,0 +1,55 @@ +USING: help.markup help.syntax io.streams.string quotations strings calendar serialize kernel furnace.db words kernel ; +IN: furnace.sessions + +HELP: +{ $values + { "responder" "a responder" } + { "responder'" "a new responder" } +} +{ $description "Wraps a responder in a session manager responder." } ; + +HELP: schange +{ $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 +{ $values { "key" symbol } { "value" object } } +{ $description "Outputs the value of a session variable." } ; + +HELP: sset +{ $values { "value" object } { "key" symbol } } +{ $description "Sets the value of a session variable." } ; + +ARTICLE: "furnace.sessions.config" "Session manager configuration" +"The " { $link sessions } " tuple has two slots which contain configuration parameters:" +{ $table + { { $slot "verify?" } { "If set to a true value, the client IP address and user agent of each session is tracked, and checked every time a client attempts to re-establish a session. While this does not offer any real security, it can thwart unskilled packet-sniffing attacks. On by default." } } + { { $slot "timeout" } { "A " { $link duration } " storing the maximum time that inactive sessions will be stored on the server. The default timeout is 20 minutes. Note that for sessions to actually expire, you must start a thread to do so; see the " { $vocab-link "furnace.alloy" } " vocabulary for an easy way of doing this." } } +} ; + +ARTICLE: "furnace.sessions.serialize" "Session state serialization" +"Session variable values are serialized to the database using the " { $link "serialize" } " library." +$nl +"This means that there are three restrictions on the values stored in the session:" +{ $list + "Continuations cannot be stored at all." + { "Object identity is not preserved between serialization and deserialization. That is, if an object is stored with " { $link sset } " and later retrieved with " { $link sget } ", the retrieved value will be " { $link = } " to the original, but not necessarily " { $link eq? } "." } + { "All objects reachable from the value passed to " { $link sset } " are serialized, so large structures should not be stored in the session state, and neither should anything that can reference the global namespace. Large structures should be persisted in the database directly instead, using " { $vocab-link "db.tuples" } "." } +} ; + +ARTICLE: "furnace.sessions" "Furnace sessions" +"The " { $vocab-link "furnace.sessions" } " vocabulary implements session management, which allows state to be maintained between HTTP requests. The session state is stored on the server; the client receives an opaque ID which is saved in a cookie (for GET requests) or a hidden form field (for POST requests)." +$nl +"To use session management, wrap your responder in an session manager:" +{ $subsection } +"The sessions responder must be wrapped inside a database persistence responder (" { $link } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one." +$nl +"Reading and writing session variables from a request:" +{ $subsection sget } +{ $subsection sset } +{ $subsection schange } +"Additional topics:" +{ $subsection "furnace.sessions.config" } +{ $subsection "furnace.sessions.serialize" } ; + +ABOUT: "furnace.sessions" 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/furnace/syndication/syndication-docs.factor b/basis/furnace/syndication/syndication-docs.factor new file mode 100644 index 0000000000..94a69ccd0e --- /dev/null +++ b/basis/furnace/syndication/syndication-docs.factor @@ -0,0 +1,73 @@ +USING: help.markup help.syntax io.streams.string kernel sequences strings urls syndication calendar ; +IN: furnace.syndication + +HELP: +{ $values { "action" feed-action } } +{ $description "Creates a new Atom feed action." } ; + +HELP: >entry +{ $values + { "object" object } + { "entry" entry } +} +{ $contract "Converts an object into an Atom feed entry. The default implementation constructs an entry by calling " +{ $link feed-entry-title } ", " +{ $link feed-entry-description } ", " +{ $link feed-entry-date } ", and " +{ $link feed-entry-url } "." } ; + +HELP: feed-action +{ $class-description "The class of feed actions. Contains several slots, documented in " { $link "furnace.syndication.config" } "." } ; + +HELP: feed-entry-date +{ $values + { "object" object } + { "timestamp" timestamp } +} +{ $contract "Outputs a feed entry timestmap." } ; + +HELP: feed-entry-description +{ $values + { "object" object } + { "description" null } +} +{ $contract "Outputs a feed entry description." } ; + +HELP: feed-entry-title +{ $values + { "object" object } + { "string" string } +} +{ $contract "Outputs a feed entry title." } ; + +HELP: feed-entry-url +{ $values + { "object" object } + { "url" url } +} +{ $contract "Outputs a feed entry URL." } ; + +ARTICLE: "furnace.syndication.config" "Configuring Atom feed actions" +"Instances of " { $link feed-action } " have three slots which need to be set:" +{ $table + { { $slot "title" } "The title of the feed as a string" } + { { $slot "url" } { "The feed " { $link url } } } + { { $slot "entries" } { "A quotation with stack effect " { $snippet "( -- seq )" } ", which produces a sequence of objects responding to the " { $link "furnace.syndication.protocol" } " protocol" } } +} ; + +ARTICLE: "furnace.syndication.protocol" "Atom feed entry protocol" +"An Atom feed action takes a sequence of objects and converts them into Atom feed entries. The objects must implement a protocol consisting of either a single generic word:" +{ $subsection >entry } +"Or a series of generic words, called by the default implementation of " { $link >entry } ":" +{ $subsection feed-entry-title } +{ $subsection feed-entry-description } +{ $subsection feed-entry-date } +{ $subsection feed-entry-url } ; + +ARTICLE: "furnace.syndication" "Furnace Atom syndication support" +"The " { $vocab-link "furnace.syndication" } " vocabulary builds on the " { $link "syndication" } " library by providing easy support for generating Atom feeds from " { $link "furnace.actions" } "." +{ $subsection } +{ $subsection "furnace.syndication.config" } +{ $subsection "furnace.syndication.protocol" } ; + +ABOUT: "furnace.syndication" diff --git a/core/grouping/authors.txt b/basis/grouping/authors.txt similarity index 100% rename from core/grouping/authors.txt rename to basis/grouping/authors.txt diff --git a/core/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor similarity index 100% rename from core/grouping/grouping-docs.factor rename to basis/grouping/grouping-docs.factor diff --git a/core/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor similarity index 100% rename from core/grouping/grouping-tests.factor rename to basis/grouping/grouping-tests.factor diff --git a/core/grouping/grouping.factor b/basis/grouping/grouping.factor similarity index 100% rename from core/grouping/grouping.factor rename to basis/grouping/grouping.factor diff --git a/core/grouping/summary.txt b/basis/grouping/summary.txt similarity index 100% rename from core/grouping/summary.txt rename to basis/grouping/summary.txt diff --git a/core/grouping/tags.txt b/basis/grouping/tags.txt similarity index 100% rename from core/grouping/tags.txt rename to basis/grouping/tags.txt diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 6c387632ed..92146755d9 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -62,7 +62,7 @@ M: heap heap-size ( heap -- n ) : data-set-nth ( entry n heap -- ) >r [ >>index drop ] 2keep r> - data>> set-nth-unsafe ; + data>> set-nth-unsafe ; inline : data-push ( entry heap -- n ) dup heap-size [ diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 5b60102e46..d1d9ca049a 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -166,16 +166,16 @@ ARTICLE: "io" "Input and output" { $heading "Encodings" } { $subsection "encodings-introduction" } { $subsection "io.encodings" } -"Wrapper streams:" +{ $heading "Wrapper streams" } { $subsection "io.streams.duplex" } { $subsection "io.streams.plain" } { $subsection "io.streams.string" } { $subsection "io.streams.byte-array" } -"Utilities:" +{ $heading "Utilities" } { $subsection "stream-binary" } { $subsection "styles" } { $subsection "checksums" } -"Implementation:" +{ $heading "Implementation" } { $subsection "io.streams.c" } { $subsection "io.ports" } { $see-also "destructors" } ; 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..4100a34d72 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -5,7 +5,7 @@ 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 -- ) @@ -22,6 +22,7 @@ IN: help.html { CHAR: / "__slash__" } { CHAR: \\ "__backslash__" } { CHAR: , "__comma__" } + { CHAR: @ "__at__" } } at [ % ] [ , ] ?if ; : escape-filename ( string -- filename ) @@ -88,19 +89,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 ; @@ -118,10 +117,10 @@ M: result link-href href>> ; [ [ title>> ] compare ] sort ; : article-apropos ( string -- results ) - "articles.idx" offline-apropos ; + "articles.idx" temp-file offline-apropos ; : word-apropos ( string -- results ) - "words.idx" offline-apropos ; + "words.idx" temp-file offline-apropos ; : vocab-apropos ( string -- results ) - "vocabs.idx" offline-apropos ; + "vocabs.idx" temp-file offline-apropos ; 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/forms/forms-docs.factor b/basis/html/forms/forms-docs.factor index 6556d2eac2..089a516072 100644 --- a/basis/html/forms/forms-docs.factor +++ b/basis/html/forms/forms-docs.factor @@ -85,6 +85,14 @@ HELP: validate-values { $values { "assoc" assoc } { "validators" "an assoc mapping value names to quotations" } } { $description "Validates values in the assoc by looking up the corresponding validation quotation, and storing the results in named values of the current form." } ; +HELP: validation-error +{ $values { "message" string } } +{ $description "Reports a validation error not associated with a specific form field." } +{ $notes "Such errors can be rendered by calling the " { $link render-validation-errors } " word." } ; + +HELP: render-validation-errors +{ $description "Renders any validation errors reported by calls to the " { $link validation-error } " word." } ; + ARTICLE: "html.forms.forms" "HTML form infrastructure" "The below words are used to implement the " { $vocab-link "furnace.actions" } " vocabulary. Calling them directly is rarely necessary." $nl diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index c1c1aa3def..f92f8d0764 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors strings namespaces assocs hashtables -mirrors math fry sequences words continuations ; +USING: kernel accessors strings namespaces assocs hashtables io +mirrors math fry sequences words continuations html.elements +xml.entities ; IN: html.forms TUPLE: form errors values validation-failed ; @@ -104,3 +105,11 @@ C: validation-error : validate-values ( assoc validators -- ) swap '[ [ dup _ at ] dip validate-value ] assoc-each ; + +: render-validation-errors ( -- ) + form get errors>> + [ +
    + [
  • escape-string write
    • ] each +
+ ] unless-empty ; diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index f390aad238..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." } ; @@ -154,6 +154,9 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags" "" } } } + { { $snippet "t:validation-errors" } { + "Renders validation errors in the current form which are not associated with any field. Such errors are reported by invoking " { $link validation-error } "." + } } } ; ARTICLE: "html.templates.chloe.tags" "Standard Chloe tags" diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index 1bc4684d5c..da3f80e9a5 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -65,6 +65,9 @@ CHLOE: comment drop ; CHLOE: call-next-template drop reset-buffer \ call-next-template , ; +CHLOE: validation-errors + drop [ render-validation-errors ] [code] ; + : attr>word ( value -- word/f ) ":" split1 swap lookup ; 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/extra/hexdump/authors.txt b/basis/io/files/listing/authors.txt similarity index 100% rename from extra/hexdump/authors.txt rename to basis/io/files/listing/authors.txt diff --git a/basis/io/files/listing/listing-docs.factor b/basis/io/files/listing/listing-docs.factor new file mode 100644 index 0000000000..6b19e9bfa7 --- /dev/null +++ b/basis/io/files/listing/listing-docs.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax io.streams.string strings ; +IN: io.files.listing + +HELP: directory. +{ $values + { "path" "a pathname string" } +} +{ $description "Prints information about all files in a directory to the output stream in a cross-platform way similar to the Unix " { $snippet "ls" } " command." } ; + +ARTICLE: "io.files.listing" "Listing files" +"The " { $vocab-link "io.files.listing" } " vocabulary implements directory file listing in a cross-platform way." $nl +"Listing a directory:" +{ $subsection directory. } ; + +ABOUT: "io.files.listing" diff --git a/basis/io/files/listing/listing-tests.factor b/basis/io/files/listing/listing-tests.factor new file mode 100644 index 0000000000..a2347c8db9 --- /dev/null +++ b/basis/io/files/listing/listing-tests.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2008 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test io.files.listing strings kernel ; +IN: io.files.listing.tests + +[ ] [ "" directory. ] unit-test diff --git a/basis/io/files/listing/listing.factor b/basis/io/files/listing/listing.factor new file mode 100755 index 0000000000..f88fcec3a1 --- /dev/null +++ b/basis/io/files/listing/listing.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators io io.files kernel +math.parser sequences system vocabs.loader calendar ; + +IN: io.files.listing + +> ] [ minute>> ] bi + [ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ; + +: ls-timestamp ( timestamp -- string ) + [ month>> month-abbreviation ] + [ day>> number>string 2 CHAR: \s pad-left ] + [ + dup year>> dup now year>> = + [ drop ls-time ] [ nip number>string ] if + 5 CHAR: \s pad-left + ] tri 3array " " join ; + +: read>string ( ? -- string ) "r" "-" ? ; inline + +: write>string ( ? -- string ) "w" "-" ? ; inline + +: execute>string ( ? -- string ) "x" "-" ? ; inline + +HOOK: (directory.) os ( path -- lines ) + +PRIVATE> + +: directory. ( path -- ) + [ (directory.) ] with-directory-files [ print ] each ; + +{ + { [ os unix? ] [ "io.files.listing.unix" ] } + { [ os windows? ] [ "io.files.listing.windows" ] } +} cond require diff --git a/basis/io/files/listing/tags.txt b/basis/io/files/listing/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/listing/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/listing/unix/authors.txt b/basis/io/files/listing/unix/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/io/files/listing/unix/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/io/files/listing/unix/tags.txt b/basis/io/files/listing/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/listing/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/listing/unix/unix.factor b/basis/io/files/listing/unix/unix.factor new file mode 100755 index 0000000000..313ce1f79a --- /dev/null +++ b/basis/io/files/listing/unix/unix.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators kernel system unicode.case +io.unix.files io.files.listing generalizations strings +arrays sequences io.files math.parser unix.groups unix.users +io.files.listing.private ; +IN: io.files.listing.unix + +string ( str bools -- str' ) + swap { + { { t t } [ >lower ] } + { { t f } [ >upper ] } + { { f t } [ drop "x" ] } + [ 2drop "-" ] + } case ; + +: permissions-string ( permissions -- str ) + { + [ type>> file-type>ch 1string ] + [ user-read? read>string ] + [ user-write? write>string ] + [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ] + [ group-read? read>string ] + [ group-write? write>string ] + [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ] + [ other-read? read>string ] + [ other-write? write>string ] + [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ] + } cleave 10 narray concat ; + +M: unix (directory.) ( path -- lines ) + [ [ + [ + dup file-info + { + [ permissions-string ] + [ nlink>> number>string 3 CHAR: \s pad-left ] + ! [ uid>> ] + ! [ gid>> ] + [ size>> number>string 15 CHAR: \s pad-left ] + [ modified>> ls-timestamp ] + } cleave 4 narray swap suffix " " join + ] map + ] with-group-cache ] with-user-cache ; + +PRIVATE> diff --git a/basis/io/files/listing/windows/authors.txt b/basis/io/files/listing/windows/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/io/files/listing/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/io/files/listing/windows/tags.txt b/basis/io/files/listing/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/listing/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/listing/windows/windows.factor b/basis/io/files/listing/windows/windows.factor new file mode 100755 index 0000000000..33ab47a50a --- /dev/null +++ b/basis/io/files/listing/windows/windows.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors calendar.format combinators io.files +kernel math.parser sequences splitting system io.files.listing +generalizations io.files.listing.private ; +IN: io.files.listing.windows + +" 20 CHAR: \s pad-right + ] [ + size>> number>string 20 CHAR: \s pad-left + ] if ; + +M: windows (directory.) ( entries -- lines ) + [ + dup file-info { + [ modified>> timestamp>ymdhms ] + [ directory-or-size ] + } cleave 2 narray swap suffix " " join + ] map ; + +PRIVATE> 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/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 9ebfdaaa5a..3f254e7713 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -172,6 +172,30 @@ M: unix (directory-entries) ( path -- seq ) PRIVATE> +: ch>file-type ( ch -- type ) + { + { CHAR: b [ +block-device+ ] } + { CHAR: c [ +character-device+ ] } + { CHAR: d [ +directory+ ] } + { CHAR: l [ +symbolic-link+ ] } + { CHAR: s [ +socket+ ] } + { CHAR: p [ +fifo+ ] } + { CHAR: - [ +regular-file+ ] } + [ drop +unknown+ ] + } case ; + +: file-type>ch ( type -- string ) + { + { +block-device+ [ CHAR: b ] } + { +character-device+ [ CHAR: c ] } + { +directory+ [ CHAR: d ] } + { +symbolic-link+ [ CHAR: l ] } + { +socket+ [ CHAR: s ] } + { +fifo+ [ CHAR: p ] } + { +regular-file+ [ CHAR: - ] } + [ drop CHAR: - ] + } case ; + : UID OCT: 0004000 ; inline : GID OCT: 0002000 ; inline : STICKY OCT: 0001000 ; inline diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index e3b96b98d8..d0409ce59a 100755 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -149,35 +149,39 @@ SYMBOLS: +read-only+ +hidden+ +system+ +sparse-file+ +reparse-point+ +compressed+ +offline+ +not-content-indexed+ +encrypted+ ; -: win32-file-attribute ( n attr symbol -- n ) - >r dupd mask? r> swap [ , ] [ drop ] if ; +TUPLE: windows-file-info < file-info attributes ; + +: win32-file-attribute ( n attr symbol -- ) + rot mask? [ , ] [ drop ] if ; : win32-file-attributes ( n -- seq ) [ - FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute - FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute - FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute - FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute - FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute - FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute - FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute - FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute - FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute - FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute - FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute - FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute - FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute - FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute - drop + { + [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ] + [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ] + [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ] + [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ] + [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ] + [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ] + [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ] + [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ] + [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ] + [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ] + [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ] + [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ] + [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ] + [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ] + } cleave ] { } make ; : win32-file-type ( n -- symbol ) FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) - [ \ file-info new ] dip + [ \ windows-file-info new ] dip { [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ] [ [ WIN32_FIND_DATA-nFileSizeLow ] [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size @@ -196,9 +200,10 @@ SYMBOLS: +read-only+ +hidden+ +system+ ] keep ; : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info ) - [ \ file-info new ] dip + [ \ windows-file-info new ] dip { [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ] [ [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size 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/json/authors.txt b/basis/json/authors.txt index 44b06f94bc..914f818278 100755 --- a/basis/json/authors.txt +++ b/basis/json/authors.txt @@ -1 +1,2 @@ Chris Double +Peter Burns \ No newline at end of file diff --git a/basis/json/json-docs.factor b/basis/json/json-docs.factor new file mode 100644 index 0000000000..816e7236ac --- /dev/null +++ b/basis/json/json-docs.factor @@ -0,0 +1,8 @@ +IN: json +USING: help.markup help.syntax ; + +ARTICLE: "json" "JSON serialization" +{ $subsection "json.reader" } +{ $subsection "json.writer" } ; + +ABOUT: "json" diff --git a/basis/json/json.factor b/basis/json/json.factor new file mode 100644 index 0000000000..d7cfc0e5bc --- /dev/null +++ b/basis/json/json.factor @@ -0,0 +1,7 @@ +IN: json +USE: vocabs.loader + +SINGLETON: json-null + +"json.reader" require +"json.writer" require diff --git a/basis/json/reader/reader-docs.factor b/basis/json/reader/reader-docs.factor index ea4dcbf954..4446c385d3 100644 --- a/basis/json/reader/reader-docs.factor +++ b/basis/json/reader/reader-docs.factor @@ -3,6 +3,12 @@ USING: help.markup help.syntax ; IN: json.reader -HELP: json> "( string -- object )" -{ $values { "string" "a string in JSON format" } { "object" "yhe object deserialized from the JSON string" } } +HELP: json> +{ $values { "string" "a string in JSON format" } { "object" "a deserialized object" } } { $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ; + +ARTICLE: "json.reader" "JSON reader" +"The " { $vocab-link "json.reader" } " vocabulary defines a word for parsing strings in JSON format." +{ $subsection json> } ; + +ABOUT: "json.reader" diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor index 995ae0e0b8..e97d45babe 100644 --- a/basis/json/reader/reader-tests.factor +++ b/basis/json/reader/reader-tests.factor @@ -1,4 +1,5 @@ -USING: arrays json.reader kernel multiline strings tools.test ; +USING: arrays json.reader kernel multiline strings tools.test +hashtables json ; IN: json.reader.tests { f } [ "false" json> ] unit-test @@ -8,21 +9,35 @@ IN: json.reader.tests { 102 } [ "102" json> ] unit-test { -102 } [ "-102" json> ] unit-test { 102 } [ "+102" json> ] unit-test +{ 1000.0 } [ "1.0e3" json> ] unit-test +{ 1000.0 } [ "10e2" json> ] unit-test { 102.0 } [ "102.0" json> ] unit-test { 102.5 } [ "102.5" json> ] unit-test { 102.5 } [ "102.50" json> ] unit-test { -10250.0 } [ "-102.5e2" json> ] unit-test { -10250.0 } [ "-102.5E+2" json> ] unit-test -{ 10+1/4 } [ "1025e-2" json> ] unit-test +{ 10.25 } [ "1025e-2" json> ] unit-test { 0.125 } [ "0.125" json> ] unit-test { -0.125 } [ "-0.125" json> ] unit-test +! not widely supported by javascript, but allowed in the grammar, and a nice +! feature to get +{ -0.0 } [ "-0.0" json> ] unit-test + { " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test { "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test +! unicode is allowed in json +{ "ß∂¬ƒ˚∆" } [ <" "ß∂¬ƒ˚∆""> json> ] unit-test { 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test { HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test +{ { } } [ "[]" json> ] unit-test { { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test +{ H{ } } [ "{}" json> ] unit-test + +! the returned hashtable should be different every time +{ H{ } } [ "key" "value" "{}" json> ?set-at "{}" json> nip ] unit-test + { H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test { H{ { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } } @@ -40,4 +55,3 @@ IN: json.reader.tests { 0 } [ " 0" json> ] unit-test { 0 } [ "0 " json> ] unit-test { 0 } [ " 0 " json> ] unit-test - diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index dd1ab8d5d8..0014ba1eb1 100644 --- a/basis/json/reader/reader.factor +++ b/basis/json/reader/reader.factor @@ -1,180 +1,61 @@ -! Copyright (C) 2006 Chris Double. +! Copyright (C) 2008 Peter Burns. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel parser-combinators namespaces make sequences promises strings - assocs math math.parser math.vectors math.functions math.order - lists hashtables ascii accessors ; +USING: kernel peg peg.ebnf math.parser math.private strings math +math.functions sequences arrays vectors hashtables assocs +prettyprint json ; IN: json.reader +vector ( seq -- vec ) first2 values swap prefix ; + ! Grammar for JSON from RFC 4627 +EBNF: (json>) -SYMBOL: json-null +ws = (" " | "\r" | "\t" | "\n")* -: [<&>] ( quot -- quot ) - { } make unclip [ <&> ] reduce ; +true = "true" => [[ t ]] +false = "false" => [[ f ]] +null = "null" => [[ json-null ]] -: [<|>] ( quot -- quot ) - { } make unclip [ <|> ] reduce ; +hex = [0-9a-fA-F] +char = '\\"' [[ CHAR: " ]] + | "\\\\" [[ CHAR: \ ]] + | "\\/" [[ CHAR: / ]] + | "\\b" [[ 8 ]] + | "\\f" [[ 12 ]] + | "\\n" [[ CHAR: \n ]] + | "\\r" [[ CHAR: \r ]] + | "\\t" [[ CHAR: \t ]] + | "\\u" (hex hex hex hex) [[ hex> ]] => [[ second ]] + | [^"\] +string = '"' char*:cs '"' => [[ cs >string ]] -LAZY: 'ws' ( -- parser ) - " " token - "\n" token <|> - "\r" token <|> - "\t" token <|> <*> ; +sign = ("-" | "+")? => [[ "-" = "-" "" ? ]] +digits = [0-9]+ => [[ >string ]] +decimal = "." digits => [[ concat ]] +exp = ("e" | "E") sign digits => [[ concat ]] +number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]] -LAZY: spaced ( parser -- parser ) - 'ws' swap &> 'ws' <& ; +elements = value ("," value)* => [[ grammar-list>vector ]] +array = "[" elements?:arr "]" => [[ arr >array ]] -LAZY: 'begin-array' ( -- parser ) - "[" token spaced ; +pair = ws string:key ws ":" value:val => [[ { key val } ]] +members = pair ("," pair)* => [[ grammar-list>vector ]] +object = "{" members?:hash "}" => [[ hash >hashtable ]] -LAZY: 'begin-object' ( -- parser ) - "{" token spaced ; +val = true + | false + | null + | string + | number + | array + | object -LAZY: 'end-array' ( -- parser ) - "]" token spaced ; +value = ws val:v ws => [[ v ]] -LAZY: 'end-object' ( -- parser ) - "}" token spaced ; +;EBNF -LAZY: 'name-separator' ( -- parser ) - ":" token spaced ; +PRIVATE> -LAZY: 'value-separator' ( -- parser ) - "," token spaced ; - -LAZY: 'false' ( -- parser ) - "false" token [ drop f ] <@ ; - -LAZY: 'null' ( -- parser ) - "null" token [ drop json-null ] <@ ; - -LAZY: 'true' ( -- parser ) - "true" token [ drop t ] <@ ; - -LAZY: 'quot' ( -- parser ) - "\"" token ; - -LAZY: 'hex-digit' ( -- parser ) - [ digit> ] satisfy [ digit> ] <@ ; - -: hex-digits>ch ( digits -- ch ) - 0 [ swap 16 * + ] reduce ; - -LAZY: 'string-char' ( -- parser ) - [ quotable? ] satisfy - "\\b" token [ drop 8 ] <@ <|> - "\\t" token [ drop CHAR: \t ] <@ <|> - "\\n" token [ drop CHAR: \n ] <@ <|> - "\\f" token [ drop 12 ] <@ <|> - "\\r" token [ drop CHAR: \r ] <@ <|> - "\\\"" token [ drop CHAR: " ] <@ <|> - "\\/" token [ drop CHAR: / ] <@ <|> - "\\\\" token [ drop CHAR: \\ ] <@ <|> - "\\u" token 'hex-digit' 4 exactly-n &> - [ hex-digits>ch ] <@ <|> ; - -LAZY: 'string' ( -- parser ) - 'quot' - 'string-char' <*> &> - 'quot' <& [ >string ] <@ ; - -DEFER: 'value' - -LAZY: 'member' ( -- parser ) - 'string' - 'name-separator' <& - 'value' <&> ; - -USE: prettyprint -LAZY: 'object' ( -- parser ) - 'begin-object' - 'member' 'value-separator' list-of &> - 'end-object' <& [ >hashtable ] <@ ; - -LAZY: 'array' ( -- parser ) - 'begin-array' - 'value' 'value-separator' list-of &> - 'end-array' <& ; - -LAZY: 'minus' ( -- parser ) - "-" token ; - -LAZY: 'plus' ( -- parser ) - "+" token ; - -LAZY: 'sign' ( -- parser ) - 'minus' 'plus' <|> ; - -LAZY: 'zero' ( -- parser ) - "0" token [ drop 0 ] <@ ; - -LAZY: 'decimal-point' ( -- parser ) - "." token ; - -LAZY: 'digit1-9' ( -- parser ) - [ - dup integer? [ - CHAR: 1 CHAR: 9 between? - ] [ - drop f - ] if - ] satisfy [ digit> ] <@ ; - -LAZY: 'digit0-9' ( -- parser ) - [ digit? ] satisfy [ digit> ] <@ ; - -: decimal>integer ( seq -- num ) 10 digits>integer ; - -LAZY: 'int' ( -- parser ) - 'zero' - 'digit1-9' 'digit0-9' <*> <&:> [ decimal>integer ] <@ <|> ; - -LAZY: 'e' ( -- parser ) - "e" token "E" token <|> ; - -: sign-number ( pair -- number ) - #! Pair is { minus? num } - #! Convert the json number value to a factor number - dup second swap first [ first "-" = [ -1 * ] when ] when* ; - -LAZY: 'exp' ( -- parser ) - 'e' - 'sign' &> - 'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ; - -: sequence>frac ( seq -- num ) - #! { 1 2 3 } => 0.123 - reverse 0 [ swap 10 / + ] reduce 10 / >float ; - -LAZY: 'frac' ( -- parser ) - 'decimal-point' 'digit0-9' <+> &> [ sequence>frac ] <@ ; - -: raise-to-power ( pair -- num ) - #! Pair is { num exp }. - #! Multiply 'num' by 10^exp - dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ; - -LAZY: 'number' ( -- parser ) - 'sign' - [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@ - 'exp' <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ; - -LAZY: 'value' ( -- parser ) - [ - 'false' , - 'null' , - 'true' , - 'string' , - 'object' , - 'array' , - 'number' , - ] [<|>] spaced ; -ERROR: could-not-parse-json ; - -: json> ( string -- object ) - #! Parse a json formatted string to a factor object - 'value' parse dup nil? [ - could-not-parse-json - ] [ - car parsed>> - ] if ; +: json> ( string -- object ) (json>) ; \ No newline at end of file diff --git a/basis/json/writer/writer-docs.factor b/basis/json/writer/writer-docs.factor index 21aa8b2cb5..8512d80384 100644 --- a/basis/json/writer/writer-docs.factor +++ b/basis/json/writer/writer-docs.factor @@ -3,13 +3,19 @@ USING: help.markup help.syntax ; IN: json.writer -HELP: >json "( obj -- string )" +HELP: >json { $values { "obj" "an object" } { "string" "the object converted to JSON format" } } { $description "Serializes the object into a JSON formatted string." } { $see-also json-print } ; -HELP: json-print "( obj -- )" +HELP: json-print { $values { "obj" "an object" } } { $description "Serializes the object into a JSON formatted string and outputs it to the standard output stream." } { $see-also >json } ; +ARTICLE: "json.writer" "JSON writer" +"The " { $vocab-link "json.writer" } " vocabulary defines words for converting objects to JSON format." +{ $subsection >json } +{ $subsection json-print } ; + +ABOUT: "json.writer" diff --git a/basis/json/writer/writer-tests.factor b/basis/json/writer/writer-tests.factor new file mode 100644 index 0000000000..6b6118c443 --- /dev/null +++ b/basis/json/writer/writer-tests.factor @@ -0,0 +1,20 @@ +USING: json.writer tools.test multiline json.reader json ; +IN: json.writer.tests + +{ "false" } [ f >json ] unit-test +{ "true" } [ t >json ] unit-test +{ "null" } [ json-null >json ] unit-test +{ "0" } [ 0 >json ] unit-test +{ "102" } [ 102 >json ] unit-test +{ "-102" } [ -102 >json ] unit-test +{ "102.0" } [ 102.0 >json ] unit-test +{ "102.5" } [ 102.5 >json ] unit-test + +{ "[1,\"two\",3.0]" } [ { 1 "two" 3.0 } >json ] unit-test +{ <" {"US$":1.0,"EU€":1.5}"> } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test + +! Random symbols are written simply as strings +SYMBOL: testSymbol +{ <" "testSymbol""> } [ testSymbol >json ] unit-test + +[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test \ No newline at end of file diff --git a/basis/json/writer/writer.factor b/basis/json/writer/writer.factor index cbcf426545..e374919039 100644 --- a/basis/json/writer/writer.factor +++ b/basis/json/writer/writer.factor @@ -1,44 +1,52 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io.streams.string io strings splitting sequences -math math.parser assocs classes words namespaces make -prettyprint hashtables mirrors tr ; +USING: accessors kernel io.streams.string io strings splitting +sequences math math.parser assocs classes words namespaces make +prettyprint hashtables mirrors tr json ; IN: json.writer #! Writes the object out to a stream in JSON format GENERIC: json-print ( obj -- ) : >json ( obj -- string ) - #! Returns a string representing the factor object in JSON format - [ json-print ] with-string-writer ; + #! Returns a string representing the factor object in JSON format + [ json-print ] with-string-writer ; M: f json-print ( f -- ) - drop "false" write ; + drop "false" write ; + +M: t json-print ( t -- ) + drop "true" write ; + +M: json-null json-print ( null -- ) + drop "null" write ; M: string json-print ( obj -- ) - CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ; + CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ; -M: number json-print ( num -- ) - number>string write ; +M: integer json-print ( num -- ) + number>string write ; + +M: real json-print ( num -- ) + >float number>string write ; M: sequence json-print ( array -- ) - CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ; + CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ; TR: jsvar-encode "-" "_" ; : tuple>fields ( object -- seq ) - [ - [ swap jsvar-encode >json % " : " % >json % ] "" make - ] { } assoc>map ; + [ + [ swap jsvar-encode >json % " : " % >json % ] "" make + ] { } assoc>map ; M: tuple json-print ( tuple -- ) - CHAR: { write1 tuple>fields "," join write CHAR: } write1 ; + CHAR: { write1 tuple>fields "," join write CHAR: } write1 ; M: hashtable json-print ( hashtable -- ) - CHAR: { write1 - [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ] - { } assoc>map "," join write - CHAR: } write1 ; + CHAR: { write1 + [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ] + { } assoc>map "," join write + CHAR: } write1 ; -M: object json-print ( object -- ) - unparse json-print ; +M: word json-print name>> json-print ; 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/linked-assocs/authors.txt b/basis/linked-assocs/authors.txt new file mode 100644 index 0000000000..35a4db1737 --- /dev/null +++ b/basis/linked-assocs/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +James Cash diff --git a/basis/linked-assocs/linked-assocs-docs.factor b/basis/linked-assocs/linked-assocs-docs.factor new file mode 100644 index 0000000000..6fd42954aa --- /dev/null +++ b/basis/linked-assocs/linked-assocs-docs.factor @@ -0,0 +1,23 @@ +IN: linked-assocs +USING: help.markup help.syntax assocs ; + +HELP: linked-assoc +{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assoc with a dlist. The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ; + +HELP: +{ $values { "exemplar" "an exemplar assoc" } { "assoc" linked-assoc } } +{ $description "Creates an empty linked assoc backed by a new instance of the same type as the exemplar." } ; + +HELP: +{ $values { "assoc" linked-assoc } } +{ $description "Creates an empty linked assoc backed by a hashtable." } ; + +ARTICLE: "linked-assocs" "Linked assocs" +"A " { $emphasis "linked assoc" } " is an assoc which combines an underlying assoc with a dlist to form a structure which has the insertion and retrieval characteristics of the underlying assoc (typically a hashtable), but with the ability to get the entries in insertion order by calling " { $link >alist } "." +$nl +"Linked assocs are implemented in the " { $vocab-link "linked-assocs" } " vocabulary." +{ $subsection linked-assoc } +{ $subsection } +{ $subsection } ; + +ABOUT: "linked-assocs" \ No newline at end of file diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor new file mode 100644 index 0000000000..7a259ee59a --- /dev/null +++ b/basis/linked-assocs/linked-assocs-tests.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences assocs tools.test linked-assocs math ; +IN: linked-assocs.test + +{ { 1 2 3 } } [ + 1 "b" pick set-at + 2 "c" pick set-at + 3 "a" pick set-at + values +] unit-test + +{ 2 t } [ + 1 "b" pick set-at + 2 "c" pick set-at + 3 "a" pick set-at + "c" swap at* +] unit-test + +{ { 2 3 4 } { "c" "a" "d" } 3 } [ + 1 "a" pick set-at + 2 "c" pick set-at + 3 "a" pick set-at + 4 "d" pick set-at + [ values ] [ keys ] [ assoc-size ] tri +] unit-test + +{ f 1 } [ + 1 "c" pick set-at + 2 "b" pick set-at + "c" over delete-at + "c" over at swap assoc-size +] unit-test + +{ { } 0 } [ + 1 "a" pick set-at + 2 "c" pick set-at + 3 "a" pick set-at + 4 "d" pick set-at + dup clear-assoc [ keys ] [ assoc-size ] bi +] unit-test + +{ { } { 1 2 3 } } [ + dup clone + 1 "c" pick set-at + 2 "q" pick set-at + 3 "a" pick set-at + [ values ] bi@ +] unit-test + +{ 9 } [ + + { [ 3 * ] [ 1- ] } "first" pick set-at + { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at + 4 6 pick values [ first call ] each + + swap values [ second call ] each +] unit-test \ No newline at end of file diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor new file mode 100644 index 0000000000..7330ac1a56 --- /dev/null +++ b/basis/linked-assocs/linked-assocs.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Slava Pestov, James Cash. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs arrays kernel deques dlists sequences fry ; +IN: linked-assocs + +TUPLE: linked-assoc assoc dlist ; + +: ( exemplar -- assoc ) + 0 swap new-assoc linked-assoc boa ; + +: ( -- assoc ) + H{ } ; + +M: linked-assoc assoc-size assoc>> assoc-size ; + +M: linked-assoc at* assoc>> at* [ [ obj>> second ] when ] keep ; + +M: linked-assoc delete-at + [ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ] + [ assoc>> delete-at ] 2bi ; + +> push-back* ; +PRIVATE> + +M: linked-assoc set-at + [ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep + assoc>> set-at ; + +: dlist>seq ( dlist -- seq ) + [ ] pusher [ dlist-each ] dip ; + +M: linked-assoc >alist + dlist>> dlist>seq ; + +M: linked-assoc clear-assoc + [ assoc>> clear-assoc ] [ dlist>> clear-deque ] bi ; + +M: linked-assoc clone + [ assoc>> clone ] [ dlist>> clone ] bi + linked-assoc boa ; + +INSTANCE: linked-assoc assoc diff --git a/basis/linked-assocs/summary.txt b/basis/linked-assocs/summary.txt new file mode 100644 index 0000000000..54b0d14d4c --- /dev/null +++ b/basis/linked-assocs/summary.txt @@ -0,0 +1 @@ +Assocs that yield items in insertion order diff --git a/basis/linked-assocs/tags.txt b/basis/linked-assocs/tags.txt new file mode 100644 index 0000000000..031765c41b --- /dev/null +++ b/basis/linked-assocs/tags.txt @@ -0,0 +1 @@ +assocs diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index c588269284..e74ecf3dc9 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -6,8 +6,7 @@ quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables prettyprint.sections sets sequences.private effects effects.parser generic generic.parser compiler.units accessors -locals.backend memoize macros.expander lexer classes -stack-checker.known-words ; +locals.backend memoize macros.expander lexer classes ; IN: locals ! Inspired by @@ -49,8 +48,7 @@ PREDICATE: local < word "local?" word-prop ; : ( name -- word ) #! Create a local variable identifier f - dup t "local?" set-word-prop - dup { } { object } define-primitive ; + dup t "local?" set-word-prop ; PREDICATE: local-word < word "local-word?" word-prop ; @@ -61,14 +59,12 @@ PREDICATE: local-reader < word "local-reader?" word-prop ; : ( name -- word ) f - dup t "local-reader?" set-word-prop - dup { } { object } define-primitive ; + dup t "local-reader?" set-word-prop ; PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) dup name>> "!" append f { - [ nip { object } { } define-primitive ] [ nip t "local-writer?" set-word-prop ] [ swap "local-reader" set-word-prop ] [ "local-writer" set-word-prop ] diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index c2fceffae6..3666fa2423 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private namespaces make quotations accessors words continuations vectors effects math -generalizations stack-checker.transforms fry ; +generalizations fry ; IN: macros.expander GENERIC: expand-macros ( quot -- quot' ) diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 0a6621f044..794d523d00 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -1,21 +1,18 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser kernel sequences words effects -stack-checker.transforms combinators assocs definitions -quotations namespaces memoize accessors ; +USING: parser kernel sequences words effects combinators assocs +definitions quotations namespaces memoize accessors ; IN: macros : real-macro-effect ( word -- effect' ) "declared-effect" word-prop in>> 1 ; : define-macro ( word definition -- ) - over "declared-effect" word-prop in>> length >r - 2dup "macro" set-word-prop - 2dup over real-macro-effect memoize-quot [ call ] append define - r> define-transform ; + [ "macro" set-word-prop ] + [ over real-macro-effect memoize-quot [ call ] append define ] + 2bi ; -: MACRO: - (:) define-macro ; parsing +: MACRO: (:) define-macro ; parsing PREDICATE: macro < word "macro" word-prop >boolean ; 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/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/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..aec7960857 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 @@ -71,10 +71,10 @@ MACRO: all-enabled-client-state ( seq quot -- ) : (rect-vertices) ( dim -- vertices ) { - [ drop 0 1 ] - [ first 1- 1 ] - [ [ first 1- ] [ second ] bi ] - [ second 0 swap ] + [ drop 0.5 0.5 ] + [ first 0.5 - 0.5 ] + [ [ first 0.5 - ] [ second 0.5 - ] bi ] + [ second 0.5 - 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/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index a867dbb2e3..e50fd52c10 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -53,3 +53,6 @@ M: persistent-hash clone ; M: persistent-hash pprint-delims drop \ PH{ \ } ; M: persistent-hash >pprint-sequence >alist ; M: persistent-hash pprint* pprint-object ; + +: passociate ( value key -- phash ) + T{ persistent-hash } new-at ; inline diff --git a/basis/persistent/sequences/sequences.factor b/basis/persistent/sequences/sequences.factor index 961e8bfce7..5503e369b4 100644 --- a/basis/persistent/sequences/sequences.factor +++ b/basis/persistent/sequences/sequences.factor @@ -14,3 +14,6 @@ M: sequence ppop 1 head* ; GENERIC: new-nth ( val i seq -- seq' ) M: sequence new-nth clone [ set-nth ] keep ; + +: changed-nth ( i seq quot -- seq' ) + [ [ nth ] dip call ] [ drop new-nth ] 3bi ; inline 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 b749bd63eb..31b6ba3f26 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -214,6 +214,7 @@ M: tuple pprint-narrow? drop t ; M: object pprint* pprint-object ; M: vector pprint* pprint-object ; +M: byte-vector pprint* pprint-object ; M: hashtable pprint* pprint-object ; M: curry pprint* 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: (le ] map concat ; + [ [ ] keep 4 /mod ] dip tuck + [ pick '[ _ random-32* 4 >le _ push-all ] times ] + [ + over zero? + [ 2drop ] [ random-32* 4 >le swap head over push-all ] if + ] 2bi* ; M: object random-32* ( tuple -- r ) 4 random-bytes* le> ; @@ -28,16 +33,13 @@ M: f random-bytes* ( n obj -- * ) no-random-number-generator ; M: f random-32* ( obj -- * ) no-random-number-generator ; : random-bytes ( n -- byte-array ) - [ - dup 3 mask zero? [ 1+ ] unless - random-generator get random-bytes* - ] keep head ; + random-generator get random-bytes* ; bignum ] + [ random-bytes >byte-array byte-array>bignum ] [ 3 shift 2^ ] bi / * >integer ; PRIVATE> diff --git a/basis/random/windows/tags.txt b/basis/random/windows/tags.txt old mode 100644 new mode 100755 index 02ec70f741..6bf68304bb --- a/basis/random/windows/tags.txt +++ b/basis/random/windows/tags.txt @@ -1,2 +1 @@ unportable -windows 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/serialize/serialize-docs.factor b/basis/serialize/serialize-docs.factor index fc060d6b33..34922a5eae 100644 --- a/basis/serialize/serialize-docs.factor +++ b/basis/serialize/serialize-docs.factor @@ -1,22 +1,34 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup ; +USING: help.syntax help.markup byte-arrays io ; IN: serialize HELP: serialize -{ $values { "obj" "object to serialize" } -} -{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." } -{ $examples - { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } -} -{ $see-also deserialize } ; +{ $values { "obj" "object to serialize" } } +{ $description "Serializes the object to " { $link output-stream } "." } ; HELP: deserialize -{ $values { "obj" "deserialized object" } +{ $values { "obj" "deserialized object" } } +{ $description "Deserializes an object by reading from " { $link input-stream } "." } ; + +HELP: object>bytes +{ $values { "obj" "object to serialize" } { "bytes" byte-array } } -{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." } -{ $examples - { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } +{ $description "Serializes the object to a byte array." } ; + +HELP: bytes>object +{ $values { "bytes" byte-array } { "obj" "deserialized object" } } -{ $see-also serialize } ; +{ $description "Deserializes an object from a byte array." } ; + +ARTICLE: "serialize" "Binary object serialization" +"The " { $vocab-link "serialize" } " vocabulary implements binary serialization for all Factor data types except for continuations. Unlike the prettyprinter, shared structure and circularity is preserved." +$nl +"Storing objects on streams:" +{ $subsection serialize } +{ $subsection deserialize } +"Storing objects as byte arrays:" +{ $subsection object>bytes } +{ $subsection bytes>object } ; + +ABOUT: "serialize" diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index 3a75ad65b6..4ed534151b 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: tools.test kernel serialize io io.streams.byte-array math -alien arrays byte-arrays bit-arrays float-arrays sequences math -prettyprint parser classes math.constants io.encodings.binary -random assocs ; +USING: tools.test kernel serialize serialize.private io +io.streams.byte-array math alien arrays byte-arrays bit-arrays +float-arrays sequences math prettyprint parser classes +math.constants io.encodings.binary random assocs ; IN: serialize.tests : test-serialize-cell diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 52c1535886..f062548482 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -15,6 +15,10 @@ locals prettyprint compiler.units sequences.private classes.tuple.private ; IN: serialize +GENERIC: (serialize) ( obj -- ) + +> ] bi@ eq? ] [ 2drop f ] if ; #! Return the id of an already serialized object serialized get at ; -! Serialize object -GENERIC: (serialize) ( obj -- ) - ! Numbers are serialized as follows: ! 0 => B{ 0 } ! 1<=x<=126 => B{ x | 0x80 } @@ -299,11 +300,11 @@ SYMBOL: deserialized : (deserialize) ( -- obj ) deserialize* [ "End of stream" throw ] unless ; +PRIVATE> + : deserialize ( -- obj ) - ! [ V{ } clone deserialized [ (deserialize) ] with-variable ; - ! ] with-compilation-unit ; : serialize ( obj -- ) H{ } clone serialized [ (serialize) ] with-variable ; diff --git a/basis/sorting/human/tags.txt b/basis/sorting/human/tags.txt index 3ab2d731fe..93a2a0fa14 100644 --- a/basis/sorting/human/tags.txt +++ b/basis/sorting/human/tags.txt @@ -1,2 +1,3 @@ collections text +algorithms diff --git a/basis/sorting/insertion/tags.txt b/basis/sorting/insertion/tags.txt index 42d711b32b..1e3d675068 100644 --- a/basis/sorting/insertion/tags.txt +++ b/basis/sorting/insertion/tags.txt @@ -1 +1,2 @@ collections +algorithms diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor new file mode 100644 index 0000000000..3bbba0fcb8 --- /dev/null +++ b/basis/stack-checker/backend/backend-tests.factor @@ -0,0 +1,22 @@ +USING: stack-checker.backend tools.test kernel namespaces +stack-checker.state sequences ; +IN: stack-checker.backend.tests + +[ ] [ + V{ } clone meta-d set + V{ } clone meta-r set + 0 d-in set +] unit-test + +[ 0 ] [ 0 ensure-d length ] unit-test + +[ 2 ] [ 2 ensure-d length ] unit-test +[ 2 ] [ meta-d get length ] unit-test + +[ 3 ] [ 3 ensure-d length ] unit-test +[ 3 ] [ meta-d get length ] unit-test + +[ 1 ] [ 1 ensure-d length ] unit-test +[ 3 ] [ meta-d get length ] unit-test + +[ ] [ 1 consume-d drop ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index f8dec5f823..94e59950f7 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -5,7 +5,8 @@ namespaces parser prettyprint sequences strings vectors words quotations effects classes continuations debugger assocs combinators compiler.errors accessors math.order definitions sets generic.standard.engines.tuple stack-checker.state -stack-checker.visitor stack-checker.errors ; +stack-checker.visitor stack-checker.errors +stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend : push-d ( obj -- ) meta-d get push ; @@ -17,15 +18,25 @@ IN: stack-checker.backend : peek-d ( -- obj ) pop-d dup push-d ; -: consume-d ( n -- seq ) [ pop-d ] replicate reverse ; - -: output-d ( values -- ) meta-d get push-all ; - -: ensure-d ( n -- values ) consume-d dup output-d ; - : make-values ( n -- values ) [ ] replicate ; +: ensure-d ( n -- values ) + meta-d get 2dup length > [ + 2dup + [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri + [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri + meta-d get push-all + ] when swap tail* ; + +: shorten-by ( n seq -- ) + [ length swap - ] keep shorten ; inline + +: consume-d ( n -- seq ) + [ ensure-d ] [ meta-d get shorten-by ] bi ; + +: output-d ( values -- ) meta-d get push-all ; + : produce-d ( n -- values ) make-values dup meta-d get push-all ; @@ -35,7 +46,10 @@ IN: stack-checker.backend meta-r get dup empty? [ too-many-r> inference-error ] [ pop ] if ; -: consume-r ( n -- seq ) [ pop-r ] replicate reverse ; +: consume-r ( n -- seq ) + meta-r get 2dup length > + [ too-many-r> inference-error ] when + [ swap tail* ] [ shorten-by ] 2bi ; : output-r ( seq -- ) meta-r get push-all ; @@ -69,9 +83,6 @@ M: object apply-object push-literal ; infer-quot-here ] dip recursive-state set ; -: infer-quot-recursive ( quot word label -- ) - 2array recursive-state get swap prefix infer-quot ; - : time-bomb ( error -- ) '[ _ throw ] infer-quot-here ; @@ -84,7 +95,7 @@ M: object apply-object push-literal ; ] [ dup value>> callable? [ [ value>> ] - [ [ recursion>> ] keep f 2array prefix ] + [ [ recursion>> ] keep add-local-quotation ] bi infer-quot ] [ drop bad-call @@ -113,6 +124,9 @@ M: object apply-object push-literal ; terminated?>> [ terminate ] when ] 2bi ; inline +: infer-word-def ( word -- ) + [ def>> ] [ add-recursive-state ] bi infer-quot ; + : check->r ( -- ) meta-r get empty? terminated? get or [ \ too-many->r inference-error ] unless ; @@ -161,7 +175,7 @@ M: object apply-object push-literal ; stack-visitor off dependencies off generic-dependencies off - [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ] + [ infer-word-def end-infer ] [ finish-word current-effect ] bi ] with-scope diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index d1417d035c..7b461d0028 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -3,7 +3,7 @@ USING: fry vectors sequences assocs math accessors kernel combinators quotations namespaces stack-checker.state stack-checker.backend stack-checker.errors stack-checker.visitor -; +stack-checker.values stack-checker.recursive-state ; IN: stack-checker.branches : balanced? ( pairs -- ? ) diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index bab6c17c85..9fb2b59f6c 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -2,12 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel generic sequences prettyprint io words arrays summary effects debugger assocs accessors namespaces -compiler.errors ; +compiler.errors stack-checker.values +stack-checker.recursive-state ; IN: stack-checker.errors -SYMBOL: recursive-state - -TUPLE: inference-error error type rstate ; +TUPLE: inference-error error type word ; M: inference-error compiler-error-type type>> ; @@ -15,7 +14,7 @@ M: inference-error error-help error>> error-help ; : (inference-error) ( ... class type -- * ) >r boa r> - recursive-state get + recursive-state get word>> \ inference-error boa throw ; inline : inference-error ( ... class -- * ) @@ -25,16 +24,15 @@ M: inference-error error-help error>> error-help ; +warning+ (inference-error) ; inline M: inference-error error. - [ - rstate>> - [ "Nesting:" print stack. ] unless-empty - ] [ error>> error. ] bi ; + [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; TUPLE: literal-expected ; M: literal-expected summary drop "Literal value expected" ; +M: object (literal) \ literal-expected inference-warning ; + TUPLE: unbalanced-branches-error branches quots ; : unbalanced-branches-error ( branches quots -- * ) diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 7847fdfdcf..b6a988652b 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -4,18 +4,20 @@ USING: fry namespaces assocs kernel sequences words accessors definitions math math.order effects classes arrays combinators vectors arrays stack-checker.state +stack-checker.errors +stack-checker.values stack-checker.visitor stack-checker.backend stack-checker.branches -stack-checker.errors -stack-checker.known-words ; +stack-checker.known-words +stack-checker.recursive-state ; IN: stack-checker.inlining ! Code to handle inline words. Much of the complexity stems from ! having to handle recursive inline words. -: (inline-word) ( word label -- ) - [ [ def>> ] keep ] dip infer-quot-recursive ; +: infer-inline-word-def ( word label -- ) + [ drop def>> ] [ add-inline-word ] 2bi infer-quot ; TUPLE: inline-recursive < identity-tuple id @@ -88,7 +90,7 @@ SYMBOL: enter-out nest-visitor dup - [ dup emit-enter-recursive (inline-word) ] + [ dup emit-enter-recursive infer-inline-word-def ] [ end-recursive-word ] [ nip ] 2tri @@ -133,20 +135,23 @@ SYMBOL: enter-out object '[ _ prepend ] bi@ ; -: call-recursive-inline-word ( word -- ) - dup "recursive" word-prop [ - [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri - [ 2nip check-call ] [ nip '[ _ #call-recursive, ] consume/produce ] 3bi - ] [ undeclared-recursion-error inference-error ] if ; +: call-recursive-inline-word ( word label -- ) + over "recursive" word-prop [ + [ required-stack-effect adjust-stack-effect ] dip + [ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi + ] [ drop undeclared-recursion-error inference-error ] if ; : inline-word ( word -- ) [ inlined-dependency depends-on ] [ - { - { [ dup inline-recursive-label ] [ call-recursive-inline-word ] } - { [ dup "recursive" word-prop ] [ inline-recursive-word ] } - [ dup (inline-word) ] - } cond + dup inline-recursive-label [ + call-recursive-inline-word + ] [ + dup "recursive" word-prop + [ inline-recursive-word ] + [ dup infer-inline-word-def ] + if + ] if* ] bi ; M: word apply-object diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index c40b94fd3c..4aea0f2d28 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -10,14 +10,16 @@ sequences sequences.private slots.private strings strings.private system threads.private classes.tuple classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private -combinators locals.backend words.private quotations.private +combinators locals locals.backend locals.private words.private +quotations.private stack-checker.values +stack-checker.alien stack-checker.state +stack-checker.errors +stack-checker.visitor stack-checker.backend stack-checker.branches -stack-checker.errors stack-checker.transforms -stack-checker.visitor -stack-checker.alien ; +stack-checker.recursive-state ; IN: stack-checker.known-words : infer-primitive ( word -- ) @@ -48,7 +50,7 @@ IN: stack-checker.known-words : infer-shuffle ( shuffle -- ) [ in>> length consume-d ] keep ! inputs shuffle [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies - [ nip ] [ swap zip ] 2bi ! inputs copies mapping + [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping #shuffle, ; : infer-shuffle-word ( word -- ) @@ -123,21 +125,23 @@ M: object infer-call* : infer-load-locals ( -- ) pop-literal nip - [ dup reverse infer-shuffle ] - [ infer->r ] - bi ; + consume-d dup reverse copy-values dup output-r + [ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ; : infer-get-local ( -- ) - pop-literal nip - [ infer-r> ] - [ dup 0 prefix infer-shuffle ] - [ infer->r ] - tri ; + [let* | n [ pop-literal nip ] + in-r [ n consume-r ] + out-d [ in-r first copy-value 1array ] + out-r [ in-r copy-values ] | + out-d output-d + out-r output-r + f out-d in-r out-r + out-r in-r zip out-d first in-r first 2array suffix + #shuffle, + ] ; : infer-drop-locals ( -- ) - pop-literal nip - [ infer-r> ] - [ { } infer-shuffle ] bi ; + f f pop-literal nip consume-r f f #shuffle, ; : infer-special ( word -- ) { @@ -164,6 +168,12 @@ M: object infer-call* { \ alien-callback [ infer-alien-callback ] } } case ; +: infer-local-reader ( word -- ) + (( -- value )) apply-word/effect ; + +: infer-local-writer ( word -- ) + (( value -- )) apply-word/effect ; + { >r r> declare call (call) curry compose execute (execute) if dispatch (throw) load-locals get-local drop-locals @@ -183,7 +193,10 @@ do-primitive alien-invoke alien-indirect alien-callback { [ dup "macro" word-prop ] [ apply-macro ] } { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] } { [ dup "inferred-effect" word-prop ] [ cached-infer ] } - { [ dup recursive-label ] [ call-recursive-word ] } + { [ dup local? ] [ infer-local-reader ] } + { [ dup local-reader? ] [ infer-local-reader ] } + { [ dup local-writer? ] [ infer-local-writer ] } + { [ dup recursive-word? ] [ call-recursive-word ] } [ dup infer-word apply-word/effect ] } cond ; diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor new file mode 100644 index 0000000000..9abfb1fcd5 --- /dev/null +++ b/basis/stack-checker/recursive-state/recursive-state.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays sequences kernel sequences assocs +namespaces stack-checker.recursive-state.tree ; +IN: stack-checker.recursive-state + +TUPLE: recursive-state word words quotations inline-words ; + +: prepare-recursive-state ( word rstate -- rstate ) + swap >>word + f >>quotations + f >>inline-words ; inline + +: initial-recursive-state ( word -- state ) + recursive-state new + f >>words + prepare-recursive-state ; inline + +f initial-recursive-state recursive-state set-global + +: add-recursive-state ( word -- rstate ) + recursive-state get clone + [ word>> dup ] keep [ store ] change-words + prepare-recursive-state ; + +: add-local-quotation ( recursive-state quot -- rstate ) + swap clone [ dupd store ] change-quotations ; + +: add-inline-word ( word label -- rstate ) + swap recursive-state get clone + [ store ] change-inline-words ; + +: recursive-word? ( word -- ? ) + recursive-state get 2dup word>> eq? + [ 2drop t ] [ words>> lookup ] if ; + +: inline-recursive-label ( word -- label/f ) + recursive-state get inline-words>> lookup ; + +: recursive-quotation? ( quot -- ? ) + recursive-state get quotations>> lookup ; diff --git a/basis/stack-checker/recursive-state/tree/tree.factor b/basis/stack-checker/recursive-state/tree/tree.factor new file mode 100644 index 0000000000..dd392af7c9 --- /dev/null +++ b/basis/stack-checker/recursive-state/tree/tree.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences math math.order ; +IN: stack-checker.recursive-state.tree + +! Persistent unbalanced hash tree using eq? comparison. +! We use this to speed up stack-checker.recursive-state. +! Perhaps this should go somewhere else + +TUPLE: node value key hashcode left right ; + +GENERIC: lookup ( key node -- value/f ) + +M: f lookup nip ; + +: decide ( key node -- key node ? ) + over hashcode over hashcode>> <= ; inline + +M: node lookup + 2dup key>> eq? + [ nip value>> ] + [ decide [ left>> ] [ right>> ] if lookup ] if ; + +GENERIC: store ( value key node -- node' ) + +M: f store drop dup hashcode f f node boa ; + +M: node store + clone decide + [ [ store ] change-left ] + [ [ store ] change-right ] if ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index a9df463703..f208178b10 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -27,7 +27,7 @@ ARTICLE: "inference-combinators" "Combinator stack effects" "Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:" { $example "[ [ 2 + ] keep ] infer." "( object -- object object )" } "Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":" -{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object object )" } +{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object )" } "Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred." $nl "A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "." diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 11dc6f9ef8..2706ec60ef 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -1,48 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs namespaces sequences kernel definitions math -effects accessors words fry classes.algebra stack-checker.errors +USING: assocs arrays namespaces sequences kernel definitions +math effects accessors words fry classes.algebra compiler.units ; IN: stack-checker.state -: ( -- value ) \ counter ; - -SYMBOL: known-values - -: known ( value -- known ) known-values get at ; - -: set-known ( known value -- ) - over [ known-values get set-at ] [ 2drop ] if ; - -: make-known ( known -- value ) - [ set-known ] keep ; - -: copy-value ( value -- value' ) - known make-known ; - -: copy-values ( values -- values' ) - [ copy-value ] map ; - -! Literal value -TUPLE: literal < identity-tuple value recursion ; - -: ( obj -- value ) - recursive-state get \ literal boa ; - -: literal ( value -- literal ) - known dup literal? - [ \ literal-expected inference-warning ] unless ; - -! Result of curry -TUPLE: curried obj quot ; - -C: curried - -! Result of compose -TUPLE: composed quot1 quot2 ; - -C: composed - ! Did the current control-flow path throw an error? SYMBOL: terminated? @@ -68,23 +30,6 @@ SYMBOL: meta-r V{ } clone meta-r set 0 d-in set ; -: init-known-values ( -- ) - H{ } clone known-values set ; - -: recursive-label ( word -- label/f ) - recursive-state get at ; - -: local-recursive-state ( -- assoc ) - recursive-state get dup - [ first dup word? [ inline? ] when not ] find drop - [ head-slice ] when* ; - -: inline-recursive-label ( word -- label/f ) - local-recursive-state at ; - -: recursive-quotation? ( quot -- ? ) - local-recursive-state [ first eq? ] with contains? ; - ! Words that the current quotation depends on SYMBOL: dependencies @@ -98,9 +43,12 @@ SYMBOL: dependencies ! Generic words that the current quotation depends on SYMBOL: generic-dependencies +: ?class-or ( class/f class -- class' ) + swap [ class-or ] when* ; + : depends-on-generic ( generic class -- ) generic-dependencies get dup - [ swap '[ null or _ class-or ] change-at ] [ 3drop ] if ; + [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ; ! Words we've inferred the stack effect of, for rollback SYMBOL: recorded diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index abc3ae1950..e4f8c50eeb 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -5,11 +5,12 @@ namespaces make quotations assocs combinators classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations stack-checker.backend stack-checker.state stack-checker.visitor -stack-checker.errors ; +stack-checker.errors stack-checker.values +stack-checker.recursive-state ; IN: stack-checker.transforms : give-up-transform ( word -- ) - dup recursive-label + dup recursive-word? [ call-recursive-word ] [ dup infer-word apply-word/effect ] if ; diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor new file mode 100644 index 0000000000..97aa774e55 --- /dev/null +++ b/basis/stack-checker/values/values.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors namespaces kernel assocs sequences +stack-checker.recursive-state ; +IN: stack-checker.values + +! Values +: ( -- value ) \ counter ; + +SYMBOL: known-values + +: init-known-values ( -- ) + H{ } clone known-values set ; + +: known ( value -- known ) known-values get at ; + +: set-known ( known value -- ) + over [ known-values get set-at ] [ 2drop ] if ; + +: make-known ( known -- value ) + [ set-known ] keep ; + +: copy-value ( value -- value' ) + known make-known ; + +: copy-values ( values -- values' ) + [ copy-value ] map ; + +! Literal value +TUPLE: literal < identity-tuple value recursion hashcode ; + +M: literal hashcode* nip hashcode>> ; + +: ( obj -- value ) + recursive-state get over hashcode \ literal boa ; + +GENERIC: (literal) ( value -- literal ) + +M: literal (literal) ; + +: literal ( value -- literal ) + known (literal) ; + +! Result of curry +TUPLE: curried obj quot ; + +C: curried + +! Result of compose +TUPLE: composed quot1 quot2 ; + +C: composed diff --git a/basis/stack-checker/visitor/dummy/dummy.factor b/basis/stack-checker/visitor/dummy/dummy.factor index a24d8e226d..5f05d97d1a 100644 --- a/basis/stack-checker/visitor/dummy/dummy.factor +++ b/basis/stack-checker/visitor/dummy/dummy.factor @@ -8,7 +8,7 @@ M: f #introduce, drop ; M: f #call, 3drop ; M: f #call-recursive, 3drop ; M: f #push, 2drop ; -M: f #shuffle, 3drop ; +M: f #shuffle, 2drop 2drop drop ; M: f #>r, 2drop ; M: f #r>, 2drop ; M: f #return, drop ; diff --git a/basis/stack-checker/visitor/visitor.factor b/basis/stack-checker/visitor/visitor.factor index 7d8ec90453..6093cd008a 100644 --- a/basis/stack-checker/visitor/visitor.factor +++ b/basis/stack-checker/visitor/visitor.factor @@ -13,7 +13,7 @@ HOOK: #introduce, stack-visitor ( values -- ) HOOK: #call, stack-visitor ( inputs outputs word -- ) HOOK: #call-recursive, stack-visitor ( inputs outputs word -- ) HOOK: #push, stack-visitor ( literal value -- ) -HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- ) +HOOK: #shuffle, stack-visitor ( in-d out-d in-r out-r mapping -- ) HOOK: #drop, stack-visitor ( values -- ) HOOK: #>r, stack-visitor ( inputs outputs -- ) HOOK: #r>, stack-visitor ( inputs outputs -- ) diff --git a/extra/suffix-arrays/authors.txt b/basis/suffix-arrays/authors.txt similarity index 100% rename from extra/suffix-arrays/authors.txt rename to basis/suffix-arrays/authors.txt diff --git a/extra/suffix-arrays/suffix-arrays-docs.factor b/basis/suffix-arrays/suffix-arrays-docs.factor similarity index 100% rename from extra/suffix-arrays/suffix-arrays-docs.factor rename to basis/suffix-arrays/suffix-arrays-docs.factor diff --git a/extra/suffix-arrays/suffix-arrays-tests.factor b/basis/suffix-arrays/suffix-arrays-tests.factor similarity index 100% rename from extra/suffix-arrays/suffix-arrays-tests.factor rename to basis/suffix-arrays/suffix-arrays-tests.factor diff --git a/extra/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor similarity index 99% rename from extra/suffix-arrays/suffix-arrays.factor rename to basis/suffix-arrays/suffix-arrays.factor index b181ba9d60..fa68cc0a8e 100755 --- a/extra/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/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/hexdump/authors.txt b/basis/tools/hexdump/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/tools/hexdump/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/hexdump/hexdump-docs.factor b/basis/tools/hexdump/hexdump-docs.factor similarity index 79% rename from extra/hexdump/hexdump-docs.factor rename to basis/tools/hexdump/hexdump-docs.factor index 4278e92f0e..9579fb7f81 100644 --- a/extra/hexdump/hexdump-docs.factor +++ b/basis/tools/hexdump/hexdump-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences strings ; -IN: hexdump +IN: tools.hexdump HELP: hexdump. { $values { "seq" sequence } } @@ -12,11 +12,11 @@ HELP: hexdump { $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." } { $see-also hexdump. } ; -ARTICLE: "hexdump" "Hexdump" -"The " { $vocab-link "hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl +ARTICLE: "tools.hexdump" "Hexdump" +"The " { $vocab-link "tools.hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl "Write hexdump to string:" { $subsection hexdump } "Write the hexdump to the output stream:" { $subsection hexdump. } ; -ABOUT: "hexdump" +ABOUT: "tools.hexdump" diff --git a/extra/hexdump/hexdump-tests.factor b/basis/tools/hexdump/hexdump-tests.factor similarity index 95% rename from extra/hexdump/hexdump-tests.factor rename to basis/tools/hexdump/hexdump-tests.factor index b3c03196f5..7202e4402c 100644 --- a/extra/hexdump/hexdump-tests.factor +++ b/basis/tools/hexdump/hexdump-tests.factor @@ -1,5 +1,5 @@ -IN: hexdump.tests -USING: hexdump kernel sequences tools.test ; +USING: tools.hexdump kernel sequences tools.test ; +IN: tools.hexdump.tests [ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test [ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test diff --git a/extra/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor similarity index 98% rename from extra/hexdump/hexdump.factor rename to basis/tools/hexdump/hexdump.factor index ecbc2d6169..c8b9f4accc 100644 --- a/extra/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays io io.streams.string kernel math math.parser namespaces sequences splitting grouping strings ascii ; -IN: hexdump +IN: tools.hexdump > @@ -54,3 +55,7 @@ threads alien tools.profiler.private sequences compiler.units ; ] unit-test [ 666 ] [ \ recompile-while-profiling-test counter>> ] unit-test + +[ ] [ [ [ ] compile-call ] profile ] unit-test + +[ [ gensym execute ] profile ] [ T{ undefined } = ] must-fail-with diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index e1076775fa..2811801266 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -263,3 +263,12 @@ SYMBOL: examples-flag [ example ] times "}" print ] with-variable ; + +: scaffold-rc ( path -- ) + [ touch-file ] [ "Click to edit: " write . ] bi ; + +: scaffold-factor-boot-rc ( -- ) + home ".factor-boot-rc" append-path scaffold-rc ; + +: scaffold-factor-rc ( -- ) + home ".factor-rc" append-path scaffold-rc ; 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/user-admin/new-user.xml b/extra/webapps/user-admin/new-user.xml index 7acdd384ba..d3cf681165 100644 --- a/extra/webapps/user-admin/new-user.xml +++ b/extra/webapps/user-admin/new-user.xml @@ -46,7 +46,7 @@

- +

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/misc/factor.el b/misc/factor.el index 1ae8919559..393ed26ae0 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -1,39 +1,181 @@ -;; 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) -;; BUG: A double quote character on a commented line will break the -;; syntax highlighting for that line. +;;; 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-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-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-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 () @@ -75,61 +217,8 @@ (modify-syntax-entry ?\) ")(" factor-mode-syntax-table) (modify-syntax-entry ?\" "\" " factor-mode-syntax-table))) -(defvar factor-mode-map (make-sparse-keymap)) - -(defcustom factor-mode-hook nil - "Hook run when entering Factor mode." - :type 'hook - :group 'factor) - -(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) - "BIN:" - "MAIN:" - "IN:" "USING:" "TUPLE:" "^C:" "^M:" - "METHOD:" - "USE:" "REQUIRE:" "PROVIDE:" - "REQUIRES:" - "GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:" - "C-STRUCT:" - "C-UNION:" "" "MACRO:" "MACRO::" "DEFER:" "TYPEDEF:" - "SYMBOLS:" -)) - -(defun factor-indent-line () - "Indent current line as Factor code" - (indent-line-to (+ (current-indentation) 4))) - -(defun factor-mode () - "A mode for editing programs written in the Factor programming language." - (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 nil 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: ") @@ -160,11 +249,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 @@ -217,6 +301,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) @@ -227,19 +314,39 @@ (define-key factor-mode-map [return] 'newline-and-indent) (define-key factor-mode-map [tab] 'indent-for-tab-command) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; indentation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Factor mode indentation: -(defconst factor-word-starting-keywords - '("" ":" "TUPLE" "MACRO" "MACRO:" "M")) +(defvar factor-indent-width factor-default-indent-width + "Indentation width in factor buffers. A local variable.") -(defmacro factor-word-start-re (keywords) - `(format - "^\\(%s\\): " - (mapconcat 'identity ,keywords "\\|"))) +(make-variable-buffer-local 'factor-indent-width) -(defun factor-calculate-indentation () +(defconst factor--regexp-word-start + (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) + (format "^\\(%s\\): " (mapconcat 'identity sws "\\|")))) + +(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--brackets-depth () + "Returns number of brackets, not closed on previous lines." + (syntax-ppss-depth + (save-excursion + (syntax-ppss (line-beginning-position))))) + +(defun factor--calculate-indentation () "Calculate Factor indentation for line at point." (let ((not-indented t) (cur-indent 0)) @@ -251,38 +358,31 @@ (while not-indented ;; Check that we are inside open brackets (save-excursion - (let ((cur-depth (factor-brackets-depth))) + (let ((cur-depth (factor--brackets-depth))) (forward-line -1) (setq cur-indent (+ (current-indentation) - (* default-tab-width - (- cur-depth (factor-brackets-depth))))) + (* factor-indent-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 cur-indent (- (current-indentation) factor-indent-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:]*: ") + (if (looking-at factor--regexp-word-start) (progn (message "inword") - (setq cur-indent (+ (current-indentation) default-tab-width)) + (setq cur-indent (+ (current-indentation) factor-indent-width)) (setq not-indented nil)) (if (bobp) (setq not-indented nil)))))))) cur-indent)) -(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)) + (let ((target (factor--calculate-indentation)) (pos (- (point-max) (point)))) (if (= target (current-indentation)) (if (< (current-column) (current-indentation)) @@ -293,9 +393,32 @@ (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; factor-listener-mode -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Factor mode: + +;;;###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 'indent-line-function) #'factor-indent-line) + (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)) + +(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) + + +;;; Factor listener mode (define-derived-mode factor-listener-mode comint-mode "Factor Listener") @@ -312,3 +435,8 @@ (defun factor-refresh-all () (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/alien.c b/vm/alien.c index 5b4ff3b832..8b7df45e9a 100755 --- a/vm/alien.c +++ b/vm/alien.c @@ -82,7 +82,7 @@ void box_alien(void *ptr) } /* make an alien pointing at an offset of another alien */ -DEFINE_PRIMITIVE(displaced_alien) +void primitive_displaced_alien(void) { CELL alien = dpop(); CELL displacement = to_cell(dpop()); @@ -107,7 +107,7 @@ DEFINE_PRIMITIVE(displaced_alien) /* address of an object representing a C pointer. Explicitly throw an error if the object is a byte array, as a sanity check. */ -DEFINE_PRIMITIVE(alien_address) +void primitive_alien_address(void) { box_unsigned_cell((CELL)pinned_alien_offset(dpop())); } @@ -121,11 +121,11 @@ INLINE void *alien_pointer(void) /* define words to read/write values at an alien address */ #define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \ - DEFINE_PRIMITIVE(alien_##name) \ + void primitive_alien_##name(void) \ { \ boxer(*(type*)alien_pointer()); \ } \ - DEFINE_PRIMITIVE(set_alien_##name) \ + void primitive_set_alien_##name(void) \ { \ type* ptr = alien_pointer(); \ type value = to(dpop()); \ @@ -170,7 +170,7 @@ void box_small_struct(CELL x, CELL y, CELL size) } /* open a native library and push a handle */ -DEFINE_PRIMITIVE(dlopen) +void primitive_dlopen(void) { CELL path = tag_object(string_to_native_alien( untag_string(dpop()))); @@ -183,7 +183,7 @@ DEFINE_PRIMITIVE(dlopen) } /* look up a symbol in a native library */ -DEFINE_PRIMITIVE(dlsym) +void primitive_dlsym(void) { CELL dll = dpop(); REGISTER_ROOT(dll); @@ -205,12 +205,12 @@ DEFINE_PRIMITIVE(dlsym) } /* close a native library handle */ -DEFINE_PRIMITIVE(dlclose) +void primitive_dlclose(void) { ffi_dlclose(untag_dll(dpop())); } -DEFINE_PRIMITIVE(dll_validp) +void primitive_dll_validp(void) { CELL dll = dpop(); if(dll == F) diff --git a/vm/alien.h b/vm/alien.h index babfbc358d..ec1eb08acf 100755 --- a/vm/alien.h +++ b/vm/alien.h @@ -1,7 +1,7 @@ CELL allot_alien(CELL delegate, CELL displacement); -DECLARE_PRIMITIVE(displaced_alien); -DECLARE_PRIMITIVE(alien_address); +void primitive_displaced_alien(void); +void primitive_alien_address(void); DLLEXPORT void *alien_offset(CELL object); @@ -10,32 +10,32 @@ void fixup_alien(F_ALIEN* d); DLLEXPORT void *unbox_alien(void); DLLEXPORT void box_alien(void *ptr); -DECLARE_PRIMITIVE(alien_signed_cell); -DECLARE_PRIMITIVE(set_alien_signed_cell); -DECLARE_PRIMITIVE(alien_unsigned_cell); -DECLARE_PRIMITIVE(set_alien_unsigned_cell); -DECLARE_PRIMITIVE(alien_signed_8); -DECLARE_PRIMITIVE(set_alien_signed_8); -DECLARE_PRIMITIVE(alien_unsigned_8); -DECLARE_PRIMITIVE(set_alien_unsigned_8); -DECLARE_PRIMITIVE(alien_signed_4); -DECLARE_PRIMITIVE(set_alien_signed_4); -DECLARE_PRIMITIVE(alien_unsigned_4); -DECLARE_PRIMITIVE(set_alien_unsigned_4); -DECLARE_PRIMITIVE(alien_signed_2); -DECLARE_PRIMITIVE(set_alien_signed_2); -DECLARE_PRIMITIVE(alien_unsigned_2); -DECLARE_PRIMITIVE(set_alien_unsigned_2); -DECLARE_PRIMITIVE(alien_signed_1); -DECLARE_PRIMITIVE(set_alien_signed_1); -DECLARE_PRIMITIVE(alien_unsigned_1); -DECLARE_PRIMITIVE(set_alien_unsigned_1); -DECLARE_PRIMITIVE(alien_float); -DECLARE_PRIMITIVE(set_alien_float); -DECLARE_PRIMITIVE(alien_double); -DECLARE_PRIMITIVE(set_alien_double); -DECLARE_PRIMITIVE(alien_cell); -DECLARE_PRIMITIVE(set_alien_cell); +void primitive_alien_signed_cell(void); +void primitive_set_alien_signed_cell(void); +void primitive_alien_unsigned_cell(void); +void primitive_set_alien_unsigned_cell(void); +void primitive_alien_signed_8(void); +void primitive_set_alien_signed_8(void); +void primitive_alien_unsigned_8(void); +void primitive_set_alien_unsigned_8(void); +void primitive_alien_signed_4(void); +void primitive_set_alien_signed_4(void); +void primitive_alien_unsigned_4(void); +void primitive_set_alien_unsigned_4(void); +void primitive_alien_signed_2(void); +void primitive_set_alien_signed_2(void); +void primitive_alien_unsigned_2(void); +void primitive_set_alien_unsigned_2(void); +void primitive_alien_signed_1(void); +void primitive_set_alien_signed_1(void); +void primitive_alien_unsigned_1(void); +void primitive_set_alien_unsigned_1(void); +void primitive_alien_float(void); +void primitive_set_alien_float(void); +void primitive_alien_double(void); +void primitive_set_alien_double(void); +void primitive_alien_cell(void); +void primitive_set_alien_cell(void); DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size); DLLEXPORT void box_value_struct(void *src, CELL size); @@ -43,7 +43,7 @@ DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size); DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) -DECLARE_PRIMITIVE(dlopen); -DECLARE_PRIMITIVE(dlsym); -DECLARE_PRIMITIVE(dlclose); -DECLARE_PRIMITIVE(dll_validp); +void primitive_dlopen(void); +void primitive_dlsym(void); +void primitive_dlclose(void); +void primitive_dll_validp(void); diff --git a/vm/callstack.c b/vm/callstack.c index b7e99b418c..dfa7dd5f4a 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -6,11 +6,6 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) stack_chain->callstack_bottom = callstack_bottom; } -F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top) -{ - stack_chain->callstack_top = callstack_top; -} - void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator) { F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; @@ -68,7 +63,7 @@ F_STACK_FRAME *capture_start(void) return frame + 1; } -DEFINE_PRIMITIVE(callstack) +void primitive_callstack(void) { F_STACK_FRAME *top = capture_start(); F_STACK_FRAME *bottom = stack_chain->callstack_bottom; @@ -82,7 +77,7 @@ DEFINE_PRIMITIVE(callstack) dpush(tag_object(callstack)); } -DEFINE_PRIMITIVE(set_callstack) +void primitive_set_callstack(void) { F_CALLSTACK *stack = untag_callstack(dpop()); @@ -158,7 +153,7 @@ void stack_frame_to_array(F_STACK_FRAME *frame) set_array_nth(array,frame_index++,frame_scan(frame)); } -DEFINE_PRIMITIVE(callstack_to_array) +void primitive_callstack_to_array(void) { F_CALLSTACK *stack = untag_callstack(dpop()); @@ -190,7 +185,7 @@ F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) /* Some primitives implementing a limited form of callstack mutation. Used by the single stepper. */ -DEFINE_PRIMITIVE(innermost_stack_frame_quot) +void primitive_innermost_stack_frame_quot(void) { F_STACK_FRAME *inner = innermost_stack_frame( untag_callstack(dpop())); @@ -199,7 +194,7 @@ DEFINE_PRIMITIVE(innermost_stack_frame_quot) dpush(frame_executing(inner)); } -DEFINE_PRIMITIVE(innermost_stack_frame_scan) +void primitive_innermost_stack_frame_scan(void) { F_STACK_FRAME *inner = innermost_stack_frame( untag_callstack(dpop())); @@ -208,7 +203,7 @@ DEFINE_PRIMITIVE(innermost_stack_frame_scan) dpush(frame_scan(inner)); } -DEFINE_PRIMITIVE(set_innermost_stack_frame_quot) +void primitive_set_innermost_stack_frame_quot(void) { F_CALLSTACK *callstack = untag_callstack(dpop()); F_QUOTATION *quot = untag_quotation(dpop()); diff --git a/vm/callstack.h b/vm/callstack.h index 6c38cd0117..da0748b071 100755 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -1,5 +1,4 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); -F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top); #define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) @@ -14,11 +13,11 @@ CELL frame_executing(F_STACK_FRAME *frame); CELL frame_scan(F_STACK_FRAME *frame); CELL frame_type(F_STACK_FRAME *frame); -DECLARE_PRIMITIVE(callstack); -DECLARE_PRIMITIVE(set_datastack); -DECLARE_PRIMITIVE(set_retainstack); -DECLARE_PRIMITIVE(set_callstack); -DECLARE_PRIMITIVE(callstack_to_array); -DECLARE_PRIMITIVE(innermost_stack_frame_quot); -DECLARE_PRIMITIVE(innermost_stack_frame_scan); -DECLARE_PRIMITIVE(set_innermost_stack_frame_quot); +void primitive_callstack(void); +void primitive_set_datastack(void); +void primitive_set_retainstack(void); +void primitive_set_callstack(void); +void primitive_callstack_to_array(void); +void primitive_innermost_stack_frame_quot(void); +void primitive_innermost_stack_frame_scan(void); +void primitive_set_innermost_stack_frame_quot(void); diff --git a/vm/code_gc.c b/vm/code_gc.c index 03661999c5..bd6384408b 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -295,7 +295,7 @@ void recursive_mark(F_BLOCK *block) } /* Push the free space and total size of the code heap */ -DEFINE_PRIMITIVE(code_room) +void primitive_code_room(void) { CELL used, total_free, max_free; heap_usage(&code_heap,&used,&total_free,&max_free); diff --git a/vm/code_gc.h b/vm/code_gc.h index f93cba9c7a..72ad8d451c 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -82,4 +82,4 @@ void recursive_mark(F_BLOCK *block); void dump_heap(F_HEAP *heap); void compact_code_heap(void); -DECLARE_PRIMITIVE(code_room); +void primitive_code_room(void); diff --git a/vm/code_heap.c b/vm/code_heap.c index 1435caa9d2..2268df27e3 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -68,9 +68,11 @@ INLINE CELL compute_code_rel(F_REL *rel, case RT_XT: return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt; case RT_HERE: - return rel->offset + code_start; + return rel->offset + code_start + (short)REL_ARGUMENT(rel); case RT_LABEL: return code_start + REL_ARGUMENT(rel); + case RT_STACK_CHAIN: + return (CELL)&stack_chain; default: critical_error("Bad rel type",rel->type); return -1; /* Can't happen */ @@ -322,7 +324,7 @@ void default_word_code(F_WORD *word, bool relocate) word->compiledp = F; } -DEFINE_PRIMITIVE(modify_code_heap) +void primitive_modify_code_heap(void) { bool rescan_code_heap = to_boolean(dpop()); F_ARRAY *alist = untag_array(dpop()); diff --git a/vm/code_heap.h b/vm/code_heap.h index c3b476c4b5..7b1545ddf5 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -13,8 +13,10 @@ typedef enum { RT_HERE, /* a local label */ RT_LABEL, - /* immeditae literal */ - RT_IMMEDIATE + /* immediate literal */ + RT_IMMEDIATE, + /* address of stack_chain var */ + RT_STACK_CHAIN } F_RELTYPE; typedef enum { @@ -71,4 +73,4 @@ F_COMPILED *add_compiled_block( CELL compiled_code_format(void); bool stack_traces_p(void); -DECLARE_PRIMITIVE(modify_code_heap); +void primitive_modify_code_heap(void); diff --git a/vm/data_gc.c b/vm/data_gc.c index 5342ff04d9..cf1632811c 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -250,13 +250,13 @@ CELL unaligned_object_size(CELL pointer) } } -DEFINE_PRIMITIVE(size) +void primitive_size(void) { box_unsigned_cell(object_size(dpop())); } /* Push memory usage statistics in data heap */ -DEFINE_PRIMITIVE(data_room) +void primitive_data_room(void) { F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F); int gen; @@ -281,7 +281,7 @@ void begin_scan(void) gc_off = true; } -DEFINE_PRIMITIVE(begin_scan) +void primitive_begin_scan(void) { gc(); begin_scan(); @@ -306,13 +306,13 @@ CELL next_object(void) } /* Push object at heap scan cursor and advance; pushes f when done */ -DEFINE_PRIMITIVE(next_object) +void primitive_next_object(void) { dpush(next_object()); } /* Re-enables GC */ -DEFINE_PRIMITIVE(end_scan) +void primitive_end_scan(void) { gc_off = false; } @@ -911,12 +911,12 @@ void minor_gc(void) garbage_collection(NURSERY,false,0); } -DEFINE_PRIMITIVE(gc) +void primitive_gc(void) { gc(); } -DEFINE_PRIMITIVE(gc_stats) +void primitive_gc_stats(void) { GROWABLE_ARRAY(stats); @@ -945,12 +945,12 @@ DEFINE_PRIMITIVE(gc_stats) dpush(stats); } -DEFINE_PRIMITIVE(gc_reset) +void primitive_gc_reset(void) { gc_reset(); } -DEFINE_PRIMITIVE(become) +void primitive_become(void) { F_ARRAY *new_objects = untag_array(dpop()); F_ARRAY *old_objects = untag_array(dpop()); diff --git a/vm/data_gc.h b/vm/data_gc.h index 3c21695c2c..0d63cc6bfe 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -13,11 +13,11 @@ CELL binary_payload_start(CELL pointer); void begin_scan(void); CELL next_object(void); -DECLARE_PRIMITIVE(data_room); -DECLARE_PRIMITIVE(size); -DECLARE_PRIMITIVE(begin_scan); -DECLARE_PRIMITIVE(next_object); -DECLARE_PRIMITIVE(end_scan); +void primitive_data_room(void); +void primitive_size(void); +void primitive_begin_scan(void); +void primitive_next_object(void); +void primitive_end_scan(void); void gc(void); DLLEXPORT void minor_gc(void); @@ -388,9 +388,9 @@ INLINE void* allot_object(CELL type, CELL a) CELL collect_next(CELL scan); -DECLARE_PRIMITIVE(gc); -DECLARE_PRIMITIVE(gc_stats); -DECLARE_PRIMITIVE(gc_reset); -DECLARE_PRIMITIVE(become); +void primitive_gc(void); +void primitive_gc_stats(void); +void primitive_gc_reset(void); +void primitive_become(void); CELL find_all_words(void); diff --git a/vm/debug.c b/vm/debug.c index 2550931c72..41205d4aff 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -474,7 +474,7 @@ void factorbug(void) } } -DEFINE_PRIMITIVE(die) +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"); diff --git a/vm/debug.h b/vm/debug.h index 547fdba436..594d8ec919 100755 --- a/vm/debug.h +++ b/vm/debug.h @@ -6,4 +6,4 @@ void dump_zone(F_ZONE *z); bool fep_disabled; -DECLARE_PRIMITIVE(die); +void primitive_die(void); diff --git a/vm/errors.c b/vm/errors.c index 36072920fe..fe6e79be6d 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -142,19 +142,19 @@ void misc_signal_handler_impl(void) signal_error(signal_number,signal_callstack_top); } -DEFINE_PRIMITIVE(throw) +void primitive_throw(void) { dpop(); throw_impl(dpop(),stack_chain->callstack_top); } -DEFINE_PRIMITIVE(call_clear) +void primitive_call_clear(void) { throw_impl(dpop(),stack_chain->callstack_bottom); } /* For testing purposes */ -DEFINE_PRIMITIVE(unimplemented) +void primitive_unimplemented(void) { not_implemented_error(); } diff --git a/vm/errors.h b/vm/errors.h index 22cd6533c3..c7f8bc8712 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -22,7 +22,7 @@ typedef enum void out_of_memory(void); void fatal_error(char* msg, CELL tagged); void critical_error(char* msg, CELL tagged); -DECLARE_PRIMITIVE(die); +void primitive_die(void); void throw_error(CELL error, F_STACK_FRAME *native_stack); void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack); @@ -32,8 +32,8 @@ void signal_error(int signal, F_STACK_FRAME *native_stack); void type_error(CELL type, CELL tagged); void not_implemented_error(void); -DECLARE_PRIMITIVE(throw); -DECLARE_PRIMITIVE(call_clear); +void primitive_throw(void); +void primitive_call_clear(void); INLINE void type_check(CELL type, CELL tagged) { @@ -57,4 +57,4 @@ void memory_signal_handler_impl(void); void divide_by_zero_signal_handler_impl(void); void misc_signal_handler_impl(void); -DECLARE_PRIMITIVE(unimplemented); +void primitive_unimplemented(void); diff --git a/vm/image.c b/vm/image.c index 62f9e1c906..289c1e94c8 100755 --- a/vm/image.c +++ b/vm/image.c @@ -161,7 +161,7 @@ bool save_image(const F_CHAR *filename) return true; } -DEFINE_PRIMITIVE(save_image) +void primitive_save_image(void) { /* do a full GC to push everything into tenured space */ gc(); @@ -184,7 +184,7 @@ void strip_compiled_quotations(void) gc_off = false; } -DEFINE_PRIMITIVE(save_image_and_exit) +void primitive_save_image_and_exit(void) { /* We unbox this before doing anything else. This is the only point where we might throw an error, so we have to throw an error here since diff --git a/vm/image.h b/vm/image.h index 9e582fc6c6..6e1b03af0d 100755 --- a/vm/image.h +++ b/vm/image.h @@ -40,8 +40,8 @@ void load_image(F_PARAMETERS *p); void init_objects(F_HEADER *h); bool save_image(const F_CHAR *file); -DECLARE_PRIMITIVE(save_image); -DECLARE_PRIMITIVE(save_image_and_exit); +void primitive_save_image(void); +void primitive_save_image_and_exit(void); /* relocation base of currently loaded image's data heap */ CELL data_relocation_base; diff --git a/vm/io.c b/vm/io.c index bc561f5e5b..bad4854775 100755 --- a/vm/io.c +++ b/vm/io.c @@ -29,7 +29,7 @@ void io_error(void) general_error(ERROR_IO,error,F,NULL); } -DEFINE_PRIMITIVE(fopen) +void primitive_fopen(void) { char *mode = unbox_char_string(); REGISTER_C_STRING(mode); @@ -49,7 +49,7 @@ DEFINE_PRIMITIVE(fopen) } } -DEFINE_PRIMITIVE(fgetc) +void primitive_fgetc(void) { FILE* file = unbox_alien(); @@ -74,7 +74,7 @@ DEFINE_PRIMITIVE(fgetc) } } -DEFINE_PRIMITIVE(fread) +void primitive_fread(void) { FILE* file = unbox_alien(); CELL size = unbox_array_size(); @@ -116,7 +116,7 @@ DEFINE_PRIMITIVE(fread) } } -DEFINE_PRIMITIVE(fputc) +void primitive_fputc(void) { FILE *file = unbox_alien(); F_FIXNUM ch = to_fixnum(dpop()); @@ -134,7 +134,7 @@ DEFINE_PRIMITIVE(fputc) } } -DEFINE_PRIMITIVE(fwrite) +void primitive_fwrite(void) { FILE *file = unbox_alien(); F_BYTE_ARRAY *text = untag_byte_array(dpop()); @@ -163,7 +163,7 @@ DEFINE_PRIMITIVE(fwrite) } } -DEFINE_PRIMITIVE(fflush) +void primitive_fflush(void) { FILE *file = unbox_alien(); for(;;) @@ -175,7 +175,7 @@ DEFINE_PRIMITIVE(fflush) } } -DEFINE_PRIMITIVE(fclose) +void primitive_fclose(void) { FILE *file = unbox_alien(); for(;;) diff --git a/vm/io.h b/vm/io.h index f4af9b8bec..08c9dd7807 100755 --- a/vm/io.h +++ b/vm/io.h @@ -3,15 +3,15 @@ void io_error(void); int err_no(void); void clear_err_no(void); -DECLARE_PRIMITIVE(fopen); -DECLARE_PRIMITIVE(fgetc); -DECLARE_PRIMITIVE(fread); -DECLARE_PRIMITIVE(fputc); -DECLARE_PRIMITIVE(fwrite); -DECLARE_PRIMITIVE(fflush); -DECLARE_PRIMITIVE(fclose); +void primitive_fopen(void); +void primitive_fgetc(void); +void primitive_fread(void); +void primitive_fputc(void); +void primitive_fwrite(void); +void primitive_fflush(void); +void primitive_fclose(void); /* Platform specific primitives */ -DECLARE_PRIMITIVE(open_file); -DECLARE_PRIMITIVE(existsp); -DECLARE_PRIMITIVE(read_dir); +void primitive_open_file(void); +void primitive_existsp(void); +void primitive_read_dir(void); 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/math.c b/vm/math.c index 7d3b64ed39..388a472f2e 100644 --- a/vm/math.c +++ b/vm/math.c @@ -21,12 +21,12 @@ CELL to_cell(CELL tagged) return (CELL)to_fixnum(tagged); } -DEFINE_PRIMITIVE(bignum_to_fixnum) +void primitive_bignum_to_fixnum(void) { drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek())))); } -DEFINE_PRIMITIVE(float_to_fixnum) +void primitive_float_to_fixnum(void) { drepl(tag_fixnum(float_to_fixnum(dpeek()))); } @@ -35,13 +35,13 @@ DEFINE_PRIMITIVE(float_to_fixnum) F_FIXNUM y = untag_fixnum_fast(dpop()); \ F_FIXNUM x = untag_fixnum_fast(dpop()); -DEFINE_PRIMITIVE(fixnum_add) +void primitive_fixnum_add(void) { POP_FIXNUMS(x,y) box_signed_cell(x + y); } -DEFINE_PRIMITIVE(fixnum_subtract) +void primitive_fixnum_subtract(void) { POP_FIXNUMS(x,y) box_signed_cell(x - y); @@ -49,7 +49,7 @@ DEFINE_PRIMITIVE(fixnum_subtract) /* Multiply two integers, and trap overflow. Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */ -DEFINE_PRIMITIVE(fixnum_multiply) +void primitive_fixnum_multiply(void) { POP_FIXNUMS(x,y) @@ -72,13 +72,13 @@ DEFINE_PRIMITIVE(fixnum_multiply) } } -DEFINE_PRIMITIVE(fixnum_divint) +void primitive_fixnum_divint(void) { POP_FIXNUMS(x,y) box_signed_cell(x / y); } -DEFINE_PRIMITIVE(fixnum_divmod) +void primitive_fixnum_divmod(void) { POP_FIXNUMS(x,y) box_signed_cell(x / y); @@ -90,7 +90,7 @@ DEFINE_PRIMITIVE(fixnum_divmod) * If we're shifting right by n bits, we won't overflow as long as none of the * high WORD_SIZE-TAG_BITS-n bits are set. */ -DEFINE_PRIMITIVE(fixnum_shift) +void primitive_fixnum_shift(void) { POP_FIXNUMS(x,y) @@ -122,12 +122,12 @@ DEFINE_PRIMITIVE(fixnum_shift) } /* Bignums */ -DEFINE_PRIMITIVE(fixnum_to_bignum) +void primitive_fixnum_to_bignum(void) { drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek())))); } -DEFINE_PRIMITIVE(float_to_bignum) +void primitive_float_to_bignum(void) { drepl(tag_bignum(float_to_bignum(dpeek()))); } @@ -136,37 +136,37 @@ DEFINE_PRIMITIVE(float_to_bignum) F_ARRAY *y = untag_object(dpop()); \ F_ARRAY *x = untag_object(dpop()); -DEFINE_PRIMITIVE(bignum_eq) +void primitive_bignum_eq(void) { POP_BIGNUMS(x,y); box_boolean(bignum_equal_p(x,y)); } -DEFINE_PRIMITIVE(bignum_add) +void primitive_bignum_add(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_add(x,y))); } -DEFINE_PRIMITIVE(bignum_subtract) +void primitive_bignum_subtract(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_subtract(x,y))); } -DEFINE_PRIMITIVE(bignum_multiply) +void primitive_bignum_multiply(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_multiply(x,y))); } -DEFINE_PRIMITIVE(bignum_divint) +void primitive_bignum_divint(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_quotient(x,y))); } -DEFINE_PRIMITIVE(bignum_divmod) +void primitive_bignum_divmod(void) { F_ARRAY *q, *r; POP_BIGNUMS(x,y); @@ -175,74 +175,74 @@ DEFINE_PRIMITIVE(bignum_divmod) dpush(tag_bignum(r)); } -DEFINE_PRIMITIVE(bignum_mod) +void primitive_bignum_mod(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_remainder(x,y))); } -DEFINE_PRIMITIVE(bignum_and) +void primitive_bignum_and(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_bitwise_and(x,y))); } -DEFINE_PRIMITIVE(bignum_or) +void primitive_bignum_or(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_bitwise_ior(x,y))); } -DEFINE_PRIMITIVE(bignum_xor) +void primitive_bignum_xor(void) { POP_BIGNUMS(x,y); dpush(tag_bignum(bignum_bitwise_xor(x,y))); } -DEFINE_PRIMITIVE(bignum_shift) +void primitive_bignum_shift(void) { F_FIXNUM y = to_fixnum(dpop()); F_ARRAY* x = untag_object(dpop()); dpush(tag_bignum(bignum_arithmetic_shift(x,y))); } -DEFINE_PRIMITIVE(bignum_less) +void primitive_bignum_less(void) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) == bignum_comparison_less); } -DEFINE_PRIMITIVE(bignum_lesseq) +void primitive_bignum_lesseq(void) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) != bignum_comparison_greater); } -DEFINE_PRIMITIVE(bignum_greater) +void primitive_bignum_greater(void) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) == bignum_comparison_greater); } -DEFINE_PRIMITIVE(bignum_greatereq) +void primitive_bignum_greatereq(void) { POP_BIGNUMS(x,y); box_boolean(bignum_compare(x,y) != bignum_comparison_less); } -DEFINE_PRIMITIVE(bignum_not) +void primitive_bignum_not(void) { drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek())))); } -DEFINE_PRIMITIVE(bignum_bitp) +void primitive_bignum_bitp(void) { F_FIXNUM bit = to_fixnum(dpop()); F_ARRAY *x = untag_object(dpop()); box_boolean(bignum_logbitp(bit,x)); } -DEFINE_PRIMITIVE(bignum_log2) +void primitive_bignum_log2(void) { drepl(tag_bignum(bignum_integer_length(untag_object(dpeek())))); } @@ -253,7 +253,7 @@ unsigned int bignum_producer(unsigned int digit) return *(ptr + digit); } -DEFINE_PRIMITIVE(byte_array_to_bignum) +void primitive_byte_array_to_bignum(void) { type_check(BYTE_ARRAY_TYPE,dpeek()); CELL n_digits = array_capacity(untag_object(dpeek())); @@ -383,7 +383,7 @@ CELL unbox_array_size(void) /* Does not reduce to lowest terms, so should only be used by math library implementation, to avoid breaking invariants. */ -DEFINE_PRIMITIVE(from_fraction) +void primitive_from_fraction(void) { F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO)); ratio->denominator = dpop(); @@ -392,17 +392,17 @@ DEFINE_PRIMITIVE(from_fraction) } /* Floats */ -DEFINE_PRIMITIVE(fixnum_to_float) +void primitive_fixnum_to_float(void) { drepl(allot_float(fixnum_to_float(dpeek()))); } -DEFINE_PRIMITIVE(bignum_to_float) +void primitive_bignum_to_float(void) { drepl(allot_float(bignum_to_float(dpeek()))); } -DEFINE_PRIMITIVE(str_to_float) +void primitive_str_to_float(void) { char *c_str, *end; double f; @@ -418,7 +418,7 @@ DEFINE_PRIMITIVE(str_to_float) drepl(allot_float(f)); } -DEFINE_PRIMITIVE(float_to_str) +void primitive_float_to_str(void) { char tmp[33]; snprintf(tmp,32,"%.16g",untag_float(dpop())); @@ -430,82 +430,82 @@ DEFINE_PRIMITIVE(float_to_str) double y = untag_float_fast(dpop()); \ double x = untag_float_fast(dpop()); -DEFINE_PRIMITIVE(float_eq) +void primitive_float_eq(void) { POP_FLOATS(x,y); box_boolean(x == y); } -DEFINE_PRIMITIVE(float_add) +void primitive_float_add(void) { POP_FLOATS(x,y); box_double(x + y); } -DEFINE_PRIMITIVE(float_subtract) +void primitive_float_subtract(void) { POP_FLOATS(x,y); box_double(x - y); } -DEFINE_PRIMITIVE(float_multiply) +void primitive_float_multiply(void) { POP_FLOATS(x,y); box_double(x * y); } -DEFINE_PRIMITIVE(float_divfloat) +void primitive_float_divfloat(void) { POP_FLOATS(x,y); box_double(x / y); } -DEFINE_PRIMITIVE(float_mod) +void primitive_float_mod(void) { POP_FLOATS(x,y); box_double(fmod(x,y)); } -DEFINE_PRIMITIVE(float_less) +void primitive_float_less(void) { POP_FLOATS(x,y); box_boolean(x < y); } -DEFINE_PRIMITIVE(float_lesseq) +void primitive_float_lesseq(void) { POP_FLOATS(x,y); box_boolean(x <= y); } -DEFINE_PRIMITIVE(float_greater) +void primitive_float_greater(void) { POP_FLOATS(x,y); box_boolean(x > y); } -DEFINE_PRIMITIVE(float_greatereq) +void primitive_float_greatereq(void) { POP_FLOATS(x,y); box_boolean(x >= y); } -DEFINE_PRIMITIVE(float_bits) +void primitive_float_bits(void) { box_unsigned_4(float_bits(untag_float(dpop()))); } -DEFINE_PRIMITIVE(bits_float) +void primitive_bits_float(void) { box_float(bits_float(to_cell(dpop()))); } -DEFINE_PRIMITIVE(double_bits) +void primitive_double_bits(void) { box_unsigned_8(double_bits(untag_float(dpop()))); } -DEFINE_PRIMITIVE(bits_double) +void primitive_bits_double(void) { box_double(bits_double(to_unsigned_8(dpop()))); } @@ -532,7 +532,7 @@ void box_double(double flo) /* Complex numbers */ -DEFINE_PRIMITIVE(from_rect) +void primitive_from_rect(void) { F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); complex->imaginary = dpop(); diff --git a/vm/math.h b/vm/math.h index 07d7fa9199..4fa3c8d35f 100644 --- a/vm/math.h +++ b/vm/math.h @@ -6,15 +6,15 @@ DLLEXPORT F_FIXNUM to_fixnum(CELL tagged); DLLEXPORT CELL to_cell(CELL tagged); -DECLARE_PRIMITIVE(bignum_to_fixnum); -DECLARE_PRIMITIVE(float_to_fixnum); +void primitive_bignum_to_fixnum(void); +void primitive_float_to_fixnum(void); -DECLARE_PRIMITIVE(fixnum_add); -DECLARE_PRIMITIVE(fixnum_subtract); -DECLARE_PRIMITIVE(fixnum_multiply); -DECLARE_PRIMITIVE(fixnum_divint); -DECLARE_PRIMITIVE(fixnum_divmod); -DECLARE_PRIMITIVE(fixnum_shift); +void primitive_fixnum_add(void); +void primitive_fixnum_subtract(void); +void primitive_fixnum_multiply(void); +void primitive_fixnum_divint(void); +void primitive_fixnum_divmod(void); +void primitive_fixnum_shift(void); CELL bignum_zero; CELL bignum_pos_one; @@ -25,27 +25,27 @@ INLINE CELL tag_bignum(F_ARRAY* bignum) return RETAG(bignum,BIGNUM_TYPE); } -DECLARE_PRIMITIVE(fixnum_to_bignum); -DECLARE_PRIMITIVE(float_to_bignum); -DECLARE_PRIMITIVE(bignum_eq); -DECLARE_PRIMITIVE(bignum_add); -DECLARE_PRIMITIVE(bignum_subtract); -DECLARE_PRIMITIVE(bignum_multiply); -DECLARE_PRIMITIVE(bignum_divint); -DECLARE_PRIMITIVE(bignum_divmod); -DECLARE_PRIMITIVE(bignum_mod); -DECLARE_PRIMITIVE(bignum_and); -DECLARE_PRIMITIVE(bignum_or); -DECLARE_PRIMITIVE(bignum_xor); -DECLARE_PRIMITIVE(bignum_shift); -DECLARE_PRIMITIVE(bignum_less); -DECLARE_PRIMITIVE(bignum_lesseq); -DECLARE_PRIMITIVE(bignum_greater); -DECLARE_PRIMITIVE(bignum_greatereq); -DECLARE_PRIMITIVE(bignum_not); -DECLARE_PRIMITIVE(bignum_bitp); -DECLARE_PRIMITIVE(bignum_log2); -DECLARE_PRIMITIVE(byte_array_to_bignum); +void primitive_fixnum_to_bignum(void); +void primitive_float_to_bignum(void); +void primitive_bignum_eq(void); +void primitive_bignum_add(void); +void primitive_bignum_subtract(void); +void primitive_bignum_multiply(void); +void primitive_bignum_divint(void); +void primitive_bignum_divmod(void); +void primitive_bignum_mod(void); +void primitive_bignum_and(void); +void primitive_bignum_or(void); +void primitive_bignum_xor(void); +void primitive_bignum_shift(void); +void primitive_bignum_less(void); +void primitive_bignum_lesseq(void); +void primitive_bignum_greater(void); +void primitive_bignum_greatereq(void); +void primitive_bignum_not(void); +void primitive_bignum_bitp(void); +void primitive_bignum_log2(void); +void primitive_byte_array_to_bignum(void); INLINE CELL allot_integer(F_FIXNUM x) { @@ -80,7 +80,7 @@ DLLEXPORT u64 to_unsigned_8(CELL obj); CELL unbox_array_size(void); -DECLARE_PRIMITIVE(from_fraction); +void primitive_from_fraction(void); INLINE double untag_float_fast(CELL tagged) { @@ -125,26 +125,26 @@ DLLEXPORT float to_float(CELL value); DLLEXPORT void box_double(double flo); DLLEXPORT double to_double(CELL value); -DECLARE_PRIMITIVE(fixnum_to_float); -DECLARE_PRIMITIVE(bignum_to_float); -DECLARE_PRIMITIVE(str_to_float); -DECLARE_PRIMITIVE(float_to_str); -DECLARE_PRIMITIVE(float_to_bits); +void primitive_fixnum_to_float(void); +void primitive_bignum_to_float(void); +void primitive_str_to_float(void); +void primitive_float_to_str(void); +void primitive_float_to_bits(void); -DECLARE_PRIMITIVE(float_eq); -DECLARE_PRIMITIVE(float_add); -DECLARE_PRIMITIVE(float_subtract); -DECLARE_PRIMITIVE(float_multiply); -DECLARE_PRIMITIVE(float_divfloat); -DECLARE_PRIMITIVE(float_mod); -DECLARE_PRIMITIVE(float_less); -DECLARE_PRIMITIVE(float_lesseq); -DECLARE_PRIMITIVE(float_greater); -DECLARE_PRIMITIVE(float_greatereq); +void primitive_float_eq(void); +void primitive_float_add(void); +void primitive_float_subtract(void); +void primitive_float_multiply(void); +void primitive_float_divfloat(void); +void primitive_float_mod(void); +void primitive_float_less(void); +void primitive_float_lesseq(void); +void primitive_float_greater(void); +void primitive_float_greatereq(void); -DECLARE_PRIMITIVE(float_bits); -DECLARE_PRIMITIVE(bits_float); -DECLARE_PRIMITIVE(double_bits); -DECLARE_PRIMITIVE(bits_double); +void primitive_float_bits(void); +void primitive_bits_float(void); +void primitive_double_bits(void); +void primitive_bits_double(void); -DECLARE_PRIMITIVE(from_rect); +void primitive_from_rect(void); diff --git a/vm/os-unix.c b/vm/os-unix.c index 4ca62e6623..c11962f6e1 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -55,7 +55,7 @@ void ffi_dlclose(F_DLL *dll) dll->dll = NULL; } -DEFINE_PRIMITIVE(existsp) +void primitive_existsp(void) { struct stat sb; box_boolean(stat(unbox_char_string(),&sb) >= 0); diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c index 9b73692aa0..02b51b82ed 100755 --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.c @@ -27,7 +27,7 @@ char *getenv(char *name) return 0; /* unreachable */ } -DEFINE_PRIMITIVE(os_envs) +void primitive_os_envs(void) { not_implemented_error(); } diff --git a/vm/os-windows.c b/vm/os-windows.c index c19aa5c4b5..fc289c288e 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -87,7 +87,7 @@ const F_CHAR *vm_executable_path(void) return safe_strdup(full_path); } -DEFINE_PRIMITIVE(existsp) +void primitive_existsp(void) { BY_HANDLE_FILE_INFORMATION bhfi; diff --git a/vm/primitives.h b/vm/primitives.h index 811b473acd..30e0a4af96 100644 --- a/vm/primitives.h +++ b/vm/primitives.h @@ -1,42 +1 @@ extern void *primitives[]; - -/* Primitives are called with two parameters, the word itself and the current -callstack pointer. The DEFINE_PRIMITIVE() macro takes care of boilerplate to -save the current callstack pointer so that GC and other facilities can proceed -to inspect Factor stack frames below the primitive's C stack frame. - -Usage: - -DEFINE_PRIMITIVE(name) -{ - ... CODE ... -} - -Becomes - -F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top) -{ - save_callstack_top(callstack_top); - ... CODE ... -} - -On x86, F_FASTCALL expands into a GCC declaration which forces the two -parameters to be passed in registers. This simplifies the quotation compiler -and support code in cpu-x86.S. - -We do the assignment of stack_chain->callstack_top in a ``noinline'' function -to inhibit assignment re-ordering. */ -#define DEFINE_PRIMITIVE(name) \ - INLINE void primitive_##name##_impl(void); \ - \ - F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \ - { \ - save_callstack_top(callstack_top); \ - primitive_##name##_impl(); \ - } \ - \ - INLINE void primitive_##name##_impl(void) \ - -/* Prototype for header files */ -#define DECLARE_PRIMITIVE(name) \ - F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) diff --git a/vm/profiler.c b/vm/profiler.c index 27e903178b..e3db67964f 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -32,7 +32,6 @@ F_COMPILED *compile_profiling_stub(F_WORD *word) /* Allocates memory */ void update_word_xt(F_WORD *word) { - /* If we just enabled the profiler, reset call count */ if(profiling_p) { if(!word->profiling) @@ -80,7 +79,7 @@ void set_profiling(bool profiling) iterate_code_heap(relocate_code_block); } -DEFINE_PRIMITIVE(profiling) +void primitive_profiling(void) { set_profiling(to_boolean(dpop())); } diff --git a/vm/profiler.h b/vm/profiler.h index d14ceb283b..26a3a78d4b 100755 --- a/vm/profiler.h +++ b/vm/profiler.h @@ -1,4 +1,4 @@ bool profiling_p; -DECLARE_PRIMITIVE(profiling); +void primitive_profiling(void); F_COMPILED *compile_profiling_stub(F_WORD *word); void update_word_xt(F_WORD *word); diff --git a/vm/quotations.c b/vm/quotations.c index b75d3f79e0..bf917aeec0 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -209,6 +209,7 @@ void jit_compile(CELL quot, bool relocate) case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { + EMIT(userenv[JIT_SAVE_STACK],0); EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj)); i++; @@ -344,6 +345,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { + COUNT(userenv[JIT_SAVE_STACK],i); COUNT(userenv[JIT_PRIMITIVE],i); i++; @@ -412,7 +414,7 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) } /* push a new quotation on the stack */ -DEFINE_PRIMITIVE(array_to_quotation) +void primitive_array_to_quotation(void) { F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION)); quot->array = dpeek(); @@ -421,7 +423,7 @@ DEFINE_PRIMITIVE(array_to_quotation) drepl(tag_object(quot)); } -DEFINE_PRIMITIVE(quotation_xt) +void primitive_quotation_xt(void) { F_QUOTATION *quot = untag_quotation(dpeek()); drepl(allot_cell((CELL)quot->xt)); diff --git a/vm/quotations.h b/vm/quotations.h index 0845957c0b..45bf78d14f 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -2,5 +2,5 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code); void jit_compile(CELL quot, bool relocate); F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack); F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset); -DECLARE_PRIMITIVE(array_to_quotation); -DECLARE_PRIMITIVE(quotation_xt); +void primitive_array_to_quotation(void); +void primitive_quotation_xt(void); diff --git a/vm/run.c b/vm/run.c index c4a3e115c1..c7d93d29c8 100755 --- a/vm/run.c +++ b/vm/run.c @@ -105,13 +105,13 @@ bool stack_to_array(CELL bottom, CELL top) } } -DEFINE_PRIMITIVE(datastack) +void primitive_datastack(void) { if(!stack_to_array(ds_bot,ds)) general_error(ERROR_DS_UNDERFLOW,F,F,NULL); } -DEFINE_PRIMITIVE(retainstack) +void primitive_retainstack(void) { if(!stack_to_array(rs_bot,rs)) general_error(ERROR_RS_UNDERFLOW,F,F,NULL); @@ -125,45 +125,45 @@ CELL array_to_stack(F_ARRAY *array, CELL bottom) return bottom + depth - CELLS; } -DEFINE_PRIMITIVE(set_datastack) +void primitive_set_datastack(void) { ds = array_to_stack(untag_array(dpop()),ds_bot); } -DEFINE_PRIMITIVE(set_retainstack) +void primitive_set_retainstack(void) { rs = array_to_stack(untag_array(dpop()),rs_bot); } -DEFINE_PRIMITIVE(getenv) +void primitive_getenv(void) { F_FIXNUM e = untag_fixnum_fast(dpeek()); drepl(userenv[e]); } -DEFINE_PRIMITIVE(setenv) +void primitive_setenv(void) { F_FIXNUM e = untag_fixnum_fast(dpop()); CELL value = dpop(); userenv[e] = value; } -DEFINE_PRIMITIVE(exit) +void primitive_exit(void) { exit(to_fixnum(dpop())); } -DEFINE_PRIMITIVE(millis) +void primitive_millis(void) { box_unsigned_8(current_millis()); } -DEFINE_PRIMITIVE(sleep) +void primitive_sleep(void) { sleep_millis(to_cell(dpop())); } -DEFINE_PRIMITIVE(set_slot) +void primitive_set_slot(void) { F_FIXNUM slot = untag_fixnum_fast(dpop()); CELL obj = dpop(); diff --git a/vm/run.h b/vm/run.h index 96e606e38c..2dbbcc8c06 100755 --- a/vm/run.h +++ b/vm/run.h @@ -48,8 +48,8 @@ typedef enum { JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_DECLARE_WORD = 42, + JIT_SAVE_STACK, STACK_TRACES_ENV = 59, @@ -226,18 +226,18 @@ DLLEXPORT void nest_stacks(void); DLLEXPORT void unnest_stacks(void); void init_stacks(CELL ds_size, CELL rs_size); -DECLARE_PRIMITIVE(datastack); -DECLARE_PRIMITIVE(retainstack); -DECLARE_PRIMITIVE(getenv); -DECLARE_PRIMITIVE(setenv); -DECLARE_PRIMITIVE(exit); -DECLARE_PRIMITIVE(os_env); -DECLARE_PRIMITIVE(os_envs); -DECLARE_PRIMITIVE(set_os_env); -DECLARE_PRIMITIVE(unset_os_env); -DECLARE_PRIMITIVE(set_os_envs); -DECLARE_PRIMITIVE(millis); -DECLARE_PRIMITIVE(sleep); -DECLARE_PRIMITIVE(set_slot); +void primitive_datastack(void); +void primitive_retainstack(void); +void primitive_getenv(void); +void primitive_setenv(void); +void primitive_exit(void); +void primitive_os_env(void); +void primitive_os_envs(void); +void primitive_set_os_env(void); +void primitive_unset_os_env(void); +void primitive_set_os_envs(void); +void primitive_millis(void); +void primitive_sleep(void); +void primitive_set_slot(void); bool stage2; diff --git a/vm/types.c b/vm/types.c index 5e2ed4bed9..f1588465a4 100755 --- a/vm/types.c +++ b/vm/types.c @@ -29,7 +29,7 @@ CELL clone_object(CELL object) } } -DEFINE_PRIMITIVE(clone) +void primitive_clone(void) { drepl(clone_object(dpeek())); } @@ -61,11 +61,14 @@ F_WORD *allot_word(CELL vocab, CELL name) update_word_xt(word); UNREGISTER_UNTAGGED(word); + if(profiling_p) + iterate_code_heap_step(word->profiling,relocate_code_block); + return word; } /* ( name vocabulary -- word ) */ -DEFINE_PRIMITIVE(word) +void primitive_word(void) { CELL vocab = dpop(); CELL name = dpop(); @@ -73,15 +76,15 @@ DEFINE_PRIMITIVE(word) } /* word-xt ( word -- start end ) */ -DEFINE_PRIMITIVE(word_xt) +void primitive_word_xt(void) { F_WORD *word = untag_word(dpop()); - F_COMPILED *code = word->code; + F_COMPILED *code = (profiling_p ? word->profiling : word->code); dpush(allot_cell((CELL)code + sizeof(F_COMPILED))); dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length)); } -DEFINE_PRIMITIVE(wrapper) +void primitive_wrapper(void) { F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); wrapper->object = dpeek(); @@ -120,7 +123,7 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill) } /* push a new array on the stack */ -DEFINE_PRIMITIVE(array) +void primitive_array(void) { CELL initial = dpop(); CELL size = unbox_array_size(); @@ -191,7 +194,7 @@ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill) return new_array; } -DEFINE_PRIMITIVE(resize_array) +void primitive_resize_array(void) { F_ARRAY* array = untag_array(dpop()); CELL capacity = unbox_array_size(); @@ -256,7 +259,7 @@ F_BYTE_ARRAY *allot_byte_array(CELL size) } /* push a new byte array on the stack */ -DEFINE_PRIMITIVE(byte_array) +void primitive_byte_array(void) { CELL size = unbox_array_size(); dpush(tag_object(allot_byte_array(size))); @@ -277,7 +280,7 @@ F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) return new_array; } -DEFINE_PRIMITIVE(resize_byte_array) +void primitive_resize_byte_array(void) { F_BYTE_ARRAY* array = untag_byte_array(dpop()); CELL capacity = unbox_array_size(); @@ -310,7 +313,7 @@ F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) return tuple; } -DEFINE_PRIMITIVE(tuple) +void primitive_tuple(void) { F_TUPLE_LAYOUT *layout = untag_object(dpop()); F_FIXNUM size = untag_fixnum_fast(layout->size); @@ -324,7 +327,7 @@ DEFINE_PRIMITIVE(tuple) } /* push a new tuple on the stack, filling its slots from the stack */ -DEFINE_PRIMITIVE(tuple_boa) +void primitive_tuple_boa(void) { F_TUPLE_LAYOUT *layout = untag_object(dpop()); F_FIXNUM size = untag_fixnum_fast(layout->size); @@ -431,7 +434,7 @@ F_STRING *allot_string(CELL capacity, CELL fill) return string; } -DEFINE_PRIMITIVE(string) +void primitive_string(void) { CELL initial = to_cell(dpop()); CELL length = unbox_array_size(); @@ -474,7 +477,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) return new_string; } -DEFINE_PRIMITIVE(resize_string) +void primitive_resize_string(void) { F_STRING* string = untag_string(dpop()); CELL capacity = unbox_array_size(); @@ -541,7 +544,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) for(i = 0; i < capacity; i++) \ string[i] = string_nth(s,i); \ } \ - DEFINE_PRIMITIVE(type##_string_to_memory) \ + void primitive_##type##_string_to_memory(void) \ { \ type *address = unbox_alien(); \ F_STRING *str = untag_string(dpop()); \ @@ -573,14 +576,14 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) STRING_TO_MEMORY(char); STRING_TO_MEMORY(u16); -DEFINE_PRIMITIVE(string_nth) +void primitive_string_nth(void) { F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); dpush(tag_fixnum(string_nth(string,index))); } -DEFINE_PRIMITIVE(set_string_nth) +void primitive_set_string_nth(void) { F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); diff --git a/vm/types.h b/vm/types.h index 6efae35f5e..ebbb8a2642 100755 --- a/vm/types.h +++ b/vm/types.h @@ -112,23 +112,23 @@ CELL allot_array_1(CELL obj); CELL allot_array_2(CELL v1, CELL v2); CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4); -DECLARE_PRIMITIVE(array); -DECLARE_PRIMITIVE(tuple); -DECLARE_PRIMITIVE(tuple_boa); -DECLARE_PRIMITIVE(tuple_layout); -DECLARE_PRIMITIVE(byte_array); -DECLARE_PRIMITIVE(clone); +void primitive_array(void); +void primitive_tuple(void); +void primitive_tuple_boa(void); +void primitive_tuple_layout(void); +void primitive_byte_array(void); +void primitive_clone(void); F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill); F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity); -DECLARE_PRIMITIVE(resize_array); -DECLARE_PRIMITIVE(resize_byte_array); +void primitive_resize_array(void); +void primitive_resize_byte_array(void); F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); -DECLARE_PRIMITIVE(string); +void primitive_string(void); F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill); -DECLARE_PRIMITIVE(resize_string); +void primitive_resize_string(void); F_STRING *memory_to_char_string(const char *string, CELL length); F_STRING *from_char_string(const char *c_string); @@ -152,14 +152,14 @@ DLLEXPORT u16 *unbox_u16_string(void); CELL string_nth(F_STRING* string, CELL index); void set_string_nth(F_STRING* string, CELL index, CELL value); -DECLARE_PRIMITIVE(string_nth); -DECLARE_PRIMITIVE(set_string_nth); +void primitive_string_nth(void); +void primitive_set_string_nth(void); F_WORD *allot_word(CELL vocab, CELL name); -DECLARE_PRIMITIVE(word); -DECLARE_PRIMITIVE(word_xt); +void primitive_word(void); +void primitive_word_xt(void); -DECLARE_PRIMITIVE(wrapper); +void primitive_wrapper(void); /* Macros to simulate a vector in C */ #define GROWABLE_ARRAY(result) \