diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 3cbe155dd2..0b517c0e66 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -77,8 +77,6 @@ SYMBOL: bootstrap-time "stage2: deployment mode" print ] [ "debugger" require - "inspector" require - "tools.errors" require "listener" require "none" require ] if diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index 6bdfd6241c..848e310d63 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -2,8 +2,10 @@ USING: vocabs.loader sequences ; IN: bootstrap.tools { + "editors" "inspector" "bootstrap.image" + "see" "tools.annotations" "tools.crossref" "tools.errors" @@ -19,5 +21,4 @@ IN: bootstrap.tools "vocabs.hierarchy" "vocabs.refresh" "vocabs.refresh.monitor" - "editors" } [ require ] each diff --git a/basis/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor index 400599383f..7dee15d2e2 100644 --- a/basis/cocoa/messages/messages-docs.factor +++ b/basis/cocoa/messages/messages-docs.factor @@ -2,13 +2,13 @@ USING: help.markup help.syntax strings alien ; IN: cocoa.messages HELP: send -{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } } +{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } } { $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." } { $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." } { $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ; HELP: super-send -{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } } +{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } } { $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ; HELP: objc-class diff --git a/basis/cocoa/subclassing/subclassing-docs.factor b/basis/cocoa/subclassing/subclassing-docs.factor index 181912b0f0..0944727e46 100644 --- a/basis/cocoa/subclassing/subclassing-docs.factor +++ b/basis/cocoa/subclassing/subclassing-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax strings alien hashtables ; IN: cocoa.subclassing HELP: define-objc-class -{ $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } } +{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } } { $description "Defines a new Objective C class. The hashtable can contain the following keys:" { $list { { $link +name+ } " - a string naming the new class. Required." } diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 626ab678c0..e58cf0c834 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -55,28 +55,22 @@ SYMBOL: compiled GENERIC: no-compile? ( word -- ? ) -M: word no-compile? "no-compile" word-prop ; - M: method-body no-compile? "method-generic" word-prop no-compile? ; M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; +M: word no-compile? + { + [ macro? ] + [ inline? ] + [ "special" word-prop ] + [ "no-compile" word-prop ] + } 1|| ; + : ignore-error? ( word error -- ? ) #! Ignore some errors on inline combinators, macros, and special #! words such as 'call'. - [ - { - [ macro? ] - [ inline? ] - [ no-compile? ] - [ "special" word-prop ] - } 1|| - ] [ - { - [ do-not-compile? ] - [ literal-expected? ] - } 1|| - ] bi* and ; + [ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ; : finish ( word -- ) #! Recompile callers if the word's stack effect changed, then diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 0c9b1817c8..3a0fada735 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -443,5 +443,7 @@ M: object bad-dispatch-position-test* ; [ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test [ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test +[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test + ! Not sure if I want to fix this... ! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with \ No newline at end of file diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index da021412fe..a86d5b8c52 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -1,6 +1,7 @@ USING: compiler compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien -arrays memory vocabs parser eval ; +arrays memory vocabs parser eval quotations compiler.errors +definitions ; IN: compiler.tests.simple ! Test empty word @@ -238,3 +239,13 @@ M: f single-combination-test-2 single-combination-test-4 ; "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj ) ] unit-test ] times + +! This should not compile +GENERIC: bad-effect-test ( a -- ) +M: quotation bad-effect-test call ; inline +: bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ; + +[ bad-effect-test* ] [ not-compiled? ] must-fail-with + +! Don't want compiler error to stick around +[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index d4780b335b..e21ab74cc2 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -140,8 +140,19 @@ IN: compiler.tree.propagation.known-words '[ _ _ 2bi ] "outputs" set-word-prop ] each -\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op -\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op +: shift-op-class ( info1 info2 -- newclass ) + [ class>> ] bi@ + 2dup [ null-class? ] either? [ 2drop null ] [ drop math-closure ] if ; + +: shift-op ( word interval-quot post-proc-quot -- ) + '[ + [ shift-op-class ] [ _ binary-op-interval ] 2bi + @ + + ] "outputs" set-word-prop ; + +\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] shift-op ] each-derived-op +\ shift [ [ interval-shift-safe ] [ integer-valued ] shift-op ] each-fast-derived-op \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 0a8cb61a9f..5d12c14f5f 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -407,10 +407,18 @@ IN: compiler.tree.propagation.tests [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes +] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare 1 swap 7 bitand shift ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes +] unit-test + cell-bits 32 = [ [ V{ integer } ] [ [ { fixnum } declare 1 swap 31 bitand shift ] @@ -900,9 +908,20 @@ M: tuple-with-read-only-slot clone [ t ] [ [ void* ] { } inlined? ] unit-test [ V{ void*-array } ] [ [ void* ] final-classes ] unit-test +! bitand identities [ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test [ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test [ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test [ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test [ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test + +[ V{ fixnum } ] [ [ >bignum 10 mod 2^ ] final-classes ] unit-test +[ V{ bignum } ] [ [ >bignum 10 bitand ] final-classes ] unit-test +[ V{ bignum } ] [ [ >bignum 10 >bignum bitand ] final-classes ] unit-test +[ V{ bignum } ] [ [ >bignum 10 mod ] final-classes ] unit-test +[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum bitand ] final-classes ] unit-test +[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum swap bitand ] final-classes ] unit-test + +! Could be bignum not integer but who cares +[ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index b8ff96f833..d1f5386450 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -42,30 +42,27 @@ IN: compiler.tree.propagation.transforms : positive-fixnum? ( obj -- ? ) { [ fixnum? ] [ 0 >= ] } 1&& ; -: simplify-bitand? ( value -- ? ) - value-info literal>> positive-fixnum? ; +: simplify-bitand? ( value1 value2 -- ? ) + [ literal>> positive-fixnum? ] + [ class>> fixnum swap class<= ] + bi* and ; -: all-ones? ( int -- ? ) - dup 1 + bitand zero? ; inline +: all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline -: redundant-bitand? ( var 111... -- ? ) - [ value-info ] bi@ [ interval>> ] [ literal>> ] bi* { +: redundant-bitand? ( value1 value2 -- ? ) + [ interval>> ] [ literal>> ] bi* { [ nip integer? ] [ nip all-ones? ] [ 0 swap [a,b] interval-subset? ] } 2&& ; -: (zero-bitand?) ( value-info value-info' -- ? ) +: zero-bitand? ( value1 value2 -- ? ) [ interval>> ] [ literal>> ] bi* { [ nip integer? ] [ nip bitnot all-ones? ] [ 0 swap bitnot [a,b] interval-subset? ] } 2&& ; -: zero-bitand? ( var1 var2 -- ? ) - [ value-info ] bi@ - { [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ; - { bitand-integer-integer bitand-integer-fixnum @@ -73,35 +70,45 @@ IN: compiler.tree.propagation.transforms bitand } [ [ - { + in-d>> first2 [ value-info ] bi@ { { - [ dup in-d>> first2 zero-bitand? ] - [ drop [ 2drop 0 ] ] + [ 2dup zero-bitand? ] + [ 2drop [ 2drop 0 ] ] } { - [ dup in-d>> first2 redundant-bitand? ] - [ drop [ drop ] ] + [ 2dup swap zero-bitand? ] + [ 2drop [ 2drop 0 ] ] } { - [ dup in-d>> first2 swap redundant-bitand? ] - [ drop [ nip ] ] + [ 2dup redundant-bitand? ] + [ 2drop [ drop ] ] } { - [ dup in-d>> first simplify-bitand? ] - [ drop [ >fixnum fixnum-bitand ] ] + [ 2dup swap redundant-bitand? ] + [ 2drop [ nip ] ] } { - [ dup in-d>> second simplify-bitand? ] - [ drop [ [ >fixnum ] dip fixnum-bitand ] ] + [ 2dup simplify-bitand? ] + [ 2drop [ >fixnum fixnum-bitand ] ] } - [ drop f ] + { + [ 2dup swap simplify-bitand? ] + [ 2drop [ [ >fixnum ] dip fixnum-bitand ] ] + } + [ 2drop f ] } cond ] "custom-inlining" set-word-prop ] each ! Speeds up 2^ +: 2^? ( #call -- ? ) + in-d>> first2 [ value-info ] bi@ + [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ] + [ class>> fixnum class<= ] + bi* and ; + \ shift [ - in-d>> first value-info literal>> 1 = [ + 2^? [ cell-bits tag-bits get - 1 - '[ >fixnum dup 0 < [ 2drop 0 ] [ diff --git a/basis/concurrency/mailboxes/mailboxes-docs.factor b/basis/concurrency/mailboxes/mailboxes-docs.factor index a58a1a4cc6..727efd45d0 100644 --- a/basis/concurrency/mailboxes/mailboxes-docs.factor +++ b/basis/concurrency/mailboxes/mailboxes-docs.factor @@ -18,9 +18,10 @@ 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" { $quotation "( obj -- ? )" } } +{ $values { "mailbox" mailbox } { "timeout" "a " { $link duration } " or " { $link f } } + { "pred" { $quotation "( obj -- ? )" } } } { $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." } ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 4888896866..2920421e6b 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -8,19 +8,22 @@ continuations.private combinators generic.math classes.builtin classes compiler.units generic.standard generic.single vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer -generic.parser strings.parser vocabs.loader vocabs.parser see +generic.parser strings.parser vocabs.loader vocabs.parser source-files.errors ; IN: debugger -GENERIC: error. ( error -- ) GENERIC: error-help ( error -- topic ) -M: object error. . ; - M: object error-help drop f ; M: tuple error-help class ; +M: source-file-error error-help error>> error-help ; + +GENERIC: error. ( error -- ) + +M: object error. . ; + M: string error. print ; : :s ( -- ) diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 4ce3776277..d4867714d3 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -2,7 +2,7 @@ USING: help.syntax help.markup delegate.private ; IN: delegate HELP: define-protocol -{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } } +{ $values { "protocol" "a word for the new protocol" } { "wordlist" "a sequence of words" } } { $description "Defines a symbol as a protocol." } { $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ; diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor index 850c68fd9d..a4e02009df 100644 --- a/basis/documents/documents-docs.factor +++ b/basis/documents/documents-docs.factor @@ -12,11 +12,11 @@ HELP: +line { $description "Adds an integer to the line number of a line/column pair." } ; HELP: =col -{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } } +{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } } { $description "Sets the column number of a line/column pair." } ; HELP: =line -{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } } +{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } } { $description "Sets the line number of a line/column pair." } ; HELP: lines-equal? diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index c7fc0d5f0b..5aab808763 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -63,7 +63,7 @@ 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 )" } } } +{ $values { "quot" { $quotation "( old -- new )" } } { "key" symbol } } { $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ; HELP: uget diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index f5c0de2ea2..e9a709030e 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -266,26 +266,6 @@ HELP: spread-curry { $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." } { $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ; -HELP: neach -{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } } -{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ; - -HELP: nmap -{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } } -{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ; - -HELP: nmap-as -{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } } -{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ; - -HELP: mnmap -{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } } -{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ; - -HELP: mnmap-as -{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the " { $snippet "exemplar" } "s" } } -{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ; - HELP: mnswap { $values { "m" integer } { "n" integer } } { $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } @@ -401,11 +381,6 @@ ARTICLE: "combinator-generalizations" "Generalized combinators" apply-curry cleave-curry spread-curry - neach - nmap - nmap-as - mnmap - mnmap-as } ; ARTICLE: "other-generalizations" "Additional generalizations" @@ -424,6 +399,7 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators" "shuffle-generalizations" "combinator-generalizations" "other-generalizations" -} ; +} +"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence iteration combinators." ; ABOUT: "generalizations" diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index cb2c40ca0a..c54e35002f 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -82,108 +82,6 @@ IN: generalizations.tests [ '[ number>string _ append ] 4 napply ] must-infer -: neach-test ( a b c d -- ) - [ 4 nappend print ] 4 neach ; -: nmap-test ( a b c d -- e ) - [ 4 nappend ] 4 nmap ; -: nmap-as-test ( a b c d -- e ) - [ 4 nappend ] [ ] 4 nmap-as ; -: mnmap-3-test ( a b c d -- e f g ) - [ append ] 4 3 mnmap ; -: mnmap-2-test ( a b c d -- e f ) - [ [ append ] 2bi@ ] 4 2 mnmap ; -: mnmap-as-test ( a b c d -- e f ) - [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ; -: mnmap-1-test ( a b c d -- e ) - [ 4 nappend ] 4 1 mnmap ; -: mnmap-0-test ( a b c d -- ) - [ 4 nappend print ] 4 0 mnmap ; - -[ """A1a! -B2b@ -C3c# -D4d$ -""" ] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - [ neach-test ] with-string-writer -] unit-test - -[ { "A1a!" "B2b@" "C3c#" "D4d$" } ] -[ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - nmap-test -] unit-test - -[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ] -[ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - nmap-as-test -] unit-test - -[ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a!" "b@" "c#" "d$" } -] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - mnmap-3-test -] unit-test - -[ - { "A1" "B2" "C3" "D4" } - { "a!" "b@" "c#" "d$" } -] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - mnmap-2-test -] unit-test - -[ - { "A1" "B2" "C3" "D4" } - [ "a!" "b@" "c#" "d$" ] -] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - mnmap-as-test -] unit-test - -[ { "A1a!" "B2b@" "C3c#" "D4d$" } ] -[ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - mnmap-1-test -] unit-test - -[ """A1a! -B2b@ -C3c# -D4d$ -""" ] [ - { "A" "B" "C" "D" } - { "1" "2" "3" "4" } - { "a" "b" "c" "d" } - { "!" "@" "#" "$" } - [ mnmap-0-test ] with-string-writer -] unit-test - [ 6 8 10 12 ] [ 1 2 3 4 5 6 7 8 [ + ] 4 apply-curry 4 spread* diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 2ae076655e..8d6d6f2ac0 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -142,57 +142,3 @@ MACRO: nbi-curry ( n -- ) MACRO: nspin ( n -- ) [ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ; -MACRO: nmin-length ( n -- ) - dup 1 - [ min ] n*quot - '[ [ length ] _ napply @ ] ; - -: nnth-unsafe ( n ...seq n -- ) - [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline -MACRO: nset-nth-unsafe ( n -- ) - [ [ drop ] ] - [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ] - if-zero ; - -: (neach) ( ...seq quot n -- len quot' ) - dup dup dup - '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline - -: neach ( ...seq quot n -- ) - (neach) each-integer ; inline - -: nmap-as ( ...seq quot exemplar n -- result ) - '[ _ (neach) ] dip map-integers ; inline - -: nmap ( ...seq quot n -- result ) - dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline - -MACRO: nnew-sequence ( n -- ) - [ [ drop ] ] - [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ; - -: nnew-like ( len ...exemplar quot n -- result... ) - dup dup dup dup '[ - _ nover - [ [ _ nnew-sequence ] dip call ] - _ ndip [ like ] - _ apply-curry - _ spread* - ] call ; inline - -MACRO: (ncollect) ( n -- ) - dup dup 1 + - '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ; - -: ncollect ( len quot ...into n -- ) - (ncollect) each-integer ; inline - -: nmap-integers ( len quot ...exemplar n -- result... ) - dup dup dup - '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline - -: mnmap-as ( m*seq quot n*exemplar m n -- result*n ) - dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline - -: mnmap ( m*seq quot m n -- result*n ) - 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline - diff --git a/basis/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor index c91e5a56d6..52b436507e 100644 --- a/basis/grouping/grouping-tests.factor +++ b/basis/grouping/grouping-tests.factor @@ -1,5 +1,5 @@ USING: grouping tools.test kernel sequences arrays -math ; +math accessors ; IN: grouping.tests [ { 1 2 3 } 0 group ] must-fail @@ -12,6 +12,15 @@ IN: grouping.tests >array ] unit-test +[ 0 ] [ { } 2 length ] unit-test +[ 0 ] [ { 1 } 2 length ] unit-test +[ 1 ] [ { 1 2 } 2 length ] unit-test +[ 2 ] [ { 1 2 3 } 2 length ] unit-test + +[ 1 ] [ V{ } 2 0 over set-length seq>> length ] unit-test +[ 2 ] [ V{ } 2 1 over set-length seq>> length ] unit-test +[ 3 ] [ V{ } 2 2 over set-length seq>> length ] unit-test + [ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 [ >array ] map ] unit-test [ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index 83579d2beb..8a39a5d5cf 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -46,7 +46,7 @@ M: abstract-groups group@ TUPLE: abstract-clumps < chunking-seq ; M: abstract-clumps length - [ seq>> length ] [ n>> ] bi - 1 + ; inline + [ seq>> length 1 + ] [ n>> ] bi [-] ; inline M: abstract-clumps set-length [ n>> + 1 - ] [ seq>> ] bi set-length ; inline diff --git a/basis/heaps/heaps-docs.factor b/basis/heaps/heaps-docs.factor index 32b6ffe7ed..8ceb7bb78f 100644 --- a/basis/heaps/heaps-docs.factor +++ b/basis/heaps/heaps-docs.factor @@ -53,12 +53,12 @@ HELP: { $description "Create a new " { $link max-heap } "." } ; HELP: heap-push -{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } } +{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } } { $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } { $side-effects "heap" } ; HELP: heap-push* -{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } } +{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } { "entry" entry } } { $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." } { $side-effects "heap" } ; @@ -68,7 +68,7 @@ HELP: heap-push-all { $side-effects "heap" } ; HELP: heap-peek -{ $values { "heap" "a heap" } { "key" object } { "value" object } } +{ $values { "heap" "a heap" } { "value" object } { "key" object } } { $description "Output the first element in the heap, leaving it in the heap." } ; HELP: heap-pop* @@ -77,7 +77,7 @@ HELP: heap-pop* { $side-effects "heap" } ; HELP: heap-pop -{ $values { "heap" "a heap" } { "key" object } { "value" object } } +{ $values { "heap" "a heap" } { "value" object } { "key" object } } { $description "Output and remove the first element in the heap." } { $side-effects "heap" } ; diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 4022d3bd38..6fb4c562cf 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -1,6 +1,7 @@ USING: help.crossref help.topics help.markup tools.test words definitions assocs sequences kernel namespaces parser arrays -io.streams.string continuations debugger compiler.units eval ; +io.streams.string continuations debugger compiler.units eval +help.syntax ; IN: help.crossref.tests [ ] [ @@ -54,3 +55,11 @@ IN: help.crossref.tests ] unit-test [ "xxx" ] [ "yyy" article-parent ] unit-test + +ARTICLE: "crossref-test-1" "Crossref test 1" +"Hello world" ; + +ARTICLE: "crossref-test-2" "Crossref test 2" +{ $markup-example { $subsection "crossref-test-1" } } ; + +[ V{ } ] [ "crossref-test-2" >link article-children ] unit-test diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor index 56f104a1a1..dac3900cc9 100644 --- a/basis/help/lint/checks/checks.factor +++ b/basis/help/lint/checks/checks.factor @@ -33,14 +33,13 @@ SYMBOL: vocab-articles : extract-values ( element -- seq ) \ $values swap elements dup empty? [ - first rest [ first ] map prune natural-sort + first rest [ first ] map prune ] unless ; : effect-values ( word -- seq ) stack-effect [ in>> ] [ out>> ] bi append - [ dup pair? [ first ] when effect>string ] map - prune natural-sort ; + [ dup pair? [ first ] when effect>string ] map prune ; : contains-funky-elements? ( element -- ? ) { diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index ea64df3edc..229a025442 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -430,8 +430,8 @@ M: simple-element elements* M: object elements* 2drop ; M: array elements* - [ [ elements* ] with each ] 2keep - [ first eq? ] keep swap [ , ] [ drop ] if ; + [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ] + [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ; : elements ( elt-type element -- seq ) [ elements* ] { } make ; diff --git a/basis/help/vocabs/vocabs-tests.factor b/basis/help/vocabs/vocabs-tests.factor index 5637dd92f4..aca1ae43c9 100644 --- a/basis/help/vocabs/vocabs-tests.factor +++ b/basis/help/vocabs/vocabs-tests.factor @@ -1,5 +1,6 @@ -USING: help.vocabs tools.test help.markup help vocabs ; +USING: help.vocabs tools.test help.markup help vocabs io ; IN: help.vocabs.tests [ ] [ { $vocab "scratchpad" } print-content ] unit-test [ ] [ "classes" vocab print-topic ] unit-test +[ ] [ nl ] unit-test diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index a542575446..e45224fcc2 100755 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -173,6 +173,8 @@ GENERIC: (get-remote-address) ( handle remote -- sockaddr ) [ |dispose ] [ |dispose ] bi ] with-destructors ; +SYMBOL: bind-local-address + GENERIC: establish-connection ( client-out remote -- ) GENERIC: ((client)) ( remote -- handle ) @@ -321,6 +323,18 @@ M: invalid-inet-server summary M: inet (server) invalid-inet-server ; +ERROR: invalid-local-address addrspec ; + +M: invalid-local-address summary + drop "Cannot use with-local-address with ; use or instead" ; + +: with-local-address ( addr quot -- ) + [ + [ ] [ inet4? ] [ inet6? ] tri or + [ bind-local-address ] + [ invalid-local-address ] if + ] dip with-variable ; inline + { { [ os unix? ] [ "io.sockets.unix" require ] } { [ os winnt? ] [ "io.sockets.windows.nt" require ] } diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index fa46a71ca0..3564b32890 100755 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -69,8 +69,12 @@ M: object establish-connection ( client-out remote -- ) [ (io-error) ] } cond ; +: ?bind-client ( socket -- ) + bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline + M: object ((client)) ( addrspec -- fd ) - protocol-family SOCK_STREAM socket-fd dup init-client-socket ; + protocol-family SOCK_STREAM socket-fd + [ init-client-socket ] [ ?bind-client ] [ ] tri ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor index ccf86ca308..0f3ac39607 100755 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -1,6 +1,9 @@ +! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors io.sockets io.sockets.private io.backend.windows io.backend windows.winsock system destructors alien.c-types classes.struct combinators ; +FROM: namespaces => get ; IN: io.sockets.windows M: windows addrinfo-error ( n -- ) @@ -55,7 +58,11 @@ M: object (get-remote-address) ( socket addrspec -- sockaddr ) M: object ((client)) ( addrspec -- handle ) [ SOCK_STREAM open-socket ] keep - [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ; + [ + bind-local-address get + [ nip make-sockaddr/size ] + [ unspecific-sockaddr/size ] if* bind-socket + ] [ drop ] 2bi ; : server-socket ( addrspec type -- fd ) [ open-socket ] [ drop ] 2bi diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index f70b6ff4a1..7fba57a4bb 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -122,7 +122,7 @@ HELP: uncons { $description "Put the head and tail of the list on the stack." } ; HELP: unswons -{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $values { "cons" list } { "cdr" "the tail of the list" } { "car" "the head of the list" } } { $description "Put the head and tail of the list on the stack." } ; { leach foldl lmap>array } related-words diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor index 2dc5918bda..4af3f01ef7 100644 --- a/basis/logging/logging-docs.factor +++ b/basis/logging/logging-docs.factor @@ -47,19 +47,19 @@ HELP: log-message { $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; HELP: add-logging -{ $values { "level" "a log level" } { "word" word } } +{ $values { "word" word } { "level" "a log level" } } { $description "Causes the word to log a message every time it is called." } ; HELP: add-input-logging -{ $values { "level" "a log level" } { "word" word } } +{ $values { "word" word } { "level" "a log level" } } { $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ; HELP: add-output-logging -{ $values { "level" "a log level" } { "word" word } } +{ $values { "word" word } { "level" "a log level" } } { $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ; HELP: add-error-logging -{ $values { "level" "a log level" } { "word" word } } +{ $values { "word" word } { "level" "a log level" } } { $description "Causes the word to log its input values and any errors it throws." $nl "If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller." diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 5b1920f572..1939de4f97 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -239,7 +239,7 @@ HELP: cis { cis exp } related-words HELP: polar> -{ $values { "z" number } { "abs" "a non-negative real number" } { "arg" real } } +{ $values { "abs" "a non-negative real number" } { "arg" real } { "z" number } } { $description "Converts an absolute value and argument (polar form) to a complex number." } ; HELP: [-1,1]? diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 4a76a20598..f3d039e54a 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -110,19 +110,9 @@ IN: math.matrices : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; : mnorm ( m -- n ) dup mmax abs m/n ; - - -: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ; +: cross ( vec1 vec2 -- vec3 ) + [ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ] + [ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline : proj ( v u -- w ) [ [ v. ] [ norm-sq ] bi / ] keep n*v ; diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor index 7f525debfe..74aa2ebca3 100644 --- a/basis/math/primes/primes-docs.factor +++ b/basis/math/primes/primes-docs.factor @@ -44,7 +44,8 @@ HELP: random-prime HELP: unique-primes { $values - { "numbits" integer } { "n" integer } + { "n" integer } + { "numbits" integer } { "seq" sequence } } { $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor index 3ff286d508..602fd9802c 100644 --- a/basis/math/vectors/specialization/specialization.factor +++ b/basis/math/vectors/specialization/specialization.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: words kernel make sequences effects sets kernel.private accessors combinators math math.intervals math.vectors -math.vectors.conversion.backend -namespaces assocs fry splitting classes.algebra generalizations -locals compiler.tree.propagation.info ; +math.vectors.conversion.backend namespaces assocs fry splitting +classes.algebra generalizations locals +compiler.tree.propagation.info ; IN: math.vectors.specialization SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ; diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 81af5c12d2..63564f064d 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -96,6 +96,7 @@ PRIVATE> :: vbroadcast ( u n -- v ) u length n u nth u like ; : vshuffle-elements ( u perm -- v ) + over length 0 pad-tail swap [ '[ _ nth ] ] keep map-as ; : vshuffle-bytes ( u perm -- v ) diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index b9f9019245..65978f0b46 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -3,7 +3,7 @@ USING: assocs hashtables kernel sequences generic words arrays classes slots slots.private classes.tuple classes.tuple.private math vectors math.vectors quotations -accessors combinators byte-arrays specialized-arrays ; +accessors combinators byte-arrays vocabs vocabs.loader ; IN: mirrors TUPLE: mirror { object read-only } ; @@ -53,12 +53,13 @@ INSTANCE: array enumerated-sequence INSTANCE: vector enumerated-sequence INSTANCE: callable enumerated-sequence INSTANCE: byte-array enumerated-sequence -INSTANCE: specialized-array enumerated-sequence -INSTANCE: simd-128 enumerated-sequence -INSTANCE: simd-256 enumerated-sequence GENERIC: make-mirror ( obj -- assoc ) M: hashtable make-mirror ; M: integer make-mirror drop f ; M: enumerated-sequence make-mirror ; M: object make-mirror ; + +"specialized-arrays" vocab [ + "specialized-arrays.mirrors" require +] when diff --git a/basis/persistent/heaps/heaps-docs.factor b/basis/persistent/heaps/heaps-docs.factor index 49852bac4d..31422f23b9 100644 --- a/basis/persistent/heaps/heaps-docs.factor +++ b/basis/persistent/heaps/heaps-docs.factor @@ -18,7 +18,7 @@ HELP: pheap-peek { $description "Gets the object in the heap with minumum priority." } ; HELP: pheap-push -{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } } +{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } } { $description "Creates a new persistent heap also containing the given object of the given priority." } ; HELP: pheap-pop* diff --git a/basis/sequences/generalizations/generalizations-docs.factor b/basis/sequences/generalizations/generalizations-docs.factor new file mode 100644 index 0000000000..7940427e69 --- /dev/null +++ b/basis/sequences/generalizations/generalizations-docs.factor @@ -0,0 +1,46 @@ +! (c)2009 Joe Groff bsd license +USING: help.syntax help.markup kernel sequences quotations +math arrays combinators ; +IN: sequences.generalizations + +HELP: neach +{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } } +{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ; + +HELP: nmap +{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } } +{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ; + +HELP: nmap-as +{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } } +{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ; + +HELP: mnmap +{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } } +{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ; + +HELP: mnmap-as +{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } } +{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ; + +HELP: nproduce +{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } } +{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ; + +HELP: nproduce-as +{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } } +{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ; + +ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators" +"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of the iteration " { $link "sequences-combinators" } "." +{ $subsections + neach + nmap + nmap-as + mnmap + mnmap-as + nproduce + nproduce-as +} ; + +ABOUT: "sequences.generalizations" diff --git a/basis/sequences/generalizations/generalizations-tests.factor b/basis/sequences/generalizations/generalizations-tests.factor new file mode 100644 index 0000000000..d1861b8f9d --- /dev/null +++ b/basis/sequences/generalizations/generalizations-tests.factor @@ -0,0 +1,120 @@ +! (c)2009 Joe Groff bsd license +USING: tools.test generalizations kernel math arrays sequences +sequences.generalizations ascii fry math.parser io io.streams.string ; +IN: sequences.generalizations.tests + +: neach-test ( a b c d -- ) + [ 4 nappend print ] 4 neach ; +: nmap-test ( a b c d -- e ) + [ 4 nappend ] 4 nmap ; +: nmap-as-test ( a b c d -- e ) + [ 4 nappend ] [ ] 4 nmap-as ; +: mnmap-3-test ( a b c d -- e f g ) + [ append ] 4 3 mnmap ; +: mnmap-2-test ( a b c d -- e f ) + [ [ append ] 2bi@ ] 4 2 mnmap ; +: mnmap-as-test ( a b c d -- e f ) + [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ; +: mnmap-1-test ( a b c d -- e ) + [ 4 nappend ] 4 1 mnmap ; +: mnmap-0-test ( a b c d -- ) + [ 4 nappend print ] 4 0 mnmap ; +: nproduce-as-test ( n -- a b ) + [ dup zero? not ] + [ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as + [ drop ] 2dip ; +: nproduce-test ( n -- a b ) + [ dup zero? not ] + [ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce + [ drop ] 2dip ; + +[ """A1a! +B2b@ +C3c# +D4d$ +""" ] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + [ neach-test ] with-string-writer +] unit-test + +[ { "A1a!" "B2b@" "C3c#" "D4d$" } ] +[ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + nmap-test +] unit-test + +[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ] +[ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + nmap-as-test +] unit-test + +[ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a!" "b@" "c#" "d$" } +] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + mnmap-3-test +] unit-test + +[ + { "A1" "B2" "C3" "D4" } + { "a!" "b@" "c#" "d$" } +] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + mnmap-2-test +] unit-test + +[ + { "A1" "B2" "C3" "D4" } + [ "a!" "b@" "c#" "d$" ] +] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + mnmap-as-test +] unit-test + +[ { "A1a!" "B2b@" "C3c#" "D4d$" } ] +[ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + mnmap-1-test +] unit-test + +[ """A1a! +B2b@ +C3c# +D4d$ +""" ] [ + { "A" "B" "C" "D" } + { "1" "2" "3" "4" } + { "a" "b" "c" "d" } + { "!" "@" "#" "$" } + [ mnmap-0-test ] with-string-writer +] unit-test + +[ { 10 8 6 4 2 } B{ 9 7 5 3 1 } ] +[ 10 nproduce-as-test ] unit-test + +[ { 10 8 6 4 2 } { 9 7 5 3 1 } ] +[ 10 nproduce-test ] unit-test diff --git a/basis/sequences/generalizations/generalizations.factor b/basis/sequences/generalizations/generalizations.factor new file mode 100644 index 0000000000..210b27f3f3 --- /dev/null +++ b/basis/sequences/generalizations/generalizations.factor @@ -0,0 +1,79 @@ +! (c)2009 Joe Groff bsd license +USING: kernel sequences sequences.private math +combinators macros math.order math.ranges quotations fry effects +memoize.private generalizations ; +IN: sequences.generalizations + +MACRO: nmin-length ( n -- ) + dup 1 - [ min ] n*quot + '[ [ length ] _ napply @ ] ; + +: nnth-unsafe ( n ...seq n -- ) + [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline +MACRO: nset-nth-unsafe ( n -- ) + [ [ drop ] ] + [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ] + if-zero ; + +: (neach) ( ...seq quot n -- len quot' ) + dup dup dup + '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline + +: neach ( ...seq quot n -- ) + (neach) each-integer ; inline + +: nmap-as ( ...seq quot exemplar n -- result ) + '[ _ (neach) ] dip map-integers ; inline + +: nmap ( ...seq quot n -- result ) + dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline + +MACRO: nnew-sequence ( n -- ) + [ [ drop ] ] + [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ; + +: nnew-like ( len ...exemplar quot n -- result... ) + 5 dupn '[ + _ nover + [ [ _ nnew-sequence ] dip call ] + _ ndip [ like ] + _ apply-curry + _ spread* + ] call ; inline + +MACRO: (ncollect) ( n -- ) + 3 dupn 1 + + '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ; + +: ncollect ( len quot ...into n -- ) + (ncollect) each-integer ; inline + +: nmap-integers ( len quot ...exemplar n -- result... ) + 4 dupn + '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline + +: mnmap-as ( m*seq quot n*exemplar m n -- result*n ) + dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline + +: mnmap ( m*seq quot m n -- result*n ) + 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline + +: naccumulator-for ( quot ...exemplar n -- quot' vec... ) + 5 dupn '[ + [ [ length ] keep new-resizable ] _ napply + [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep + ] call ; inline + +: naccumulator ( quot n -- quot' vec... ) + [ V{ } swap dupn ] keep naccumulator-for ; inline + +: nproduce-as ( pred quot ...exemplar n -- seq... ) + 7 dupn '[ + _ ndup + [ _ naccumulator-for [ while ] _ ndip ] + _ ncurry _ ndip + [ like ] _ apply-curry _ spread* + ] call ; inline + +: nproduce ( pred quot n -- seq... ) + [ { } swap dupn ] keep nproduce-as ; inline diff --git a/basis/specialized-arrays/mirrors/mirrors.factor b/basis/specialized-arrays/mirrors/mirrors.factor new file mode 100644 index 0000000000..ee7953b501 --- /dev/null +++ b/basis/specialized-arrays/mirrors/mirrors.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: mirrors specialized-arrays math.vectors ; +IN: specialized-arrays.mirrors + +INSTANCE: specialized-array enumerated-sequence +INSTANCE: simd-128 enumerated-sequence +INSTANCE: simd-256 enumerated-sequence diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 67c58987a1..7a15e5067d 100755 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -168,3 +168,7 @@ SYNTAX: SPECIALIZED-ARRAY: "prettyprint" vocab [ "specialized-arrays.prettyprint" require ] when + +"mirrors" vocab [ + "specialized-arrays.mirrors" require +] when diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 963ea7592c..0bf271535a 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -8,10 +8,6 @@ IN: tools.errors #! Tools for source-files.errors. Used by tools.tests and others #! for error reporting -M: source-file-error compute-restarts error>> compute-restarts ; - -M: source-file-error error-help error>> error-help ; - CONSTANT: +listener-input+ "" : error-location ( error -- string ) diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index f7da0d1636..7f44a6138c 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -1,7 +1,7 @@ -IN: tools.profiler.tests USING: accessors tools.profiler tools.test kernel memory math -threads alien tools.profiler.private sequences compiler compiler.units -words ; +threads alien alien.c-types tools.profiler.private sequences +compiler compiler.units words ; +IN: tools.profiler.tests [ t ] [ \ length counter>> diff --git a/basis/tools/walker/walker-docs.factor b/basis/tools/walker/walker-docs.factor index bbfb9cbd9f..318f7e065c 100644 --- a/basis/tools/walker/walker-docs.factor +++ b/basis/tools/walker/walker-docs.factor @@ -6,7 +6,7 @@ HELP: breakpoint { $description "Annotates a word definition to enter the single stepper when executed." } ; HELP: breakpoint-if -{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } } +{ $values { "word" word } { "quot" { $quotation "( -- ? )" } } } { $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ; HELP: B diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor index bebfaf13fe..b1ae421f52 100644 --- a/basis/ui/gadgets/menus/menus-docs.factor +++ b/basis/ui/gadgets/menus/menus-docs.factor @@ -3,7 +3,7 @@ kernel ; IN: ui.gadgets.menus HELP: -{ $values { "target" object } { "commands" "a sequence of commands" } { "hook" { $quotation "( button -- )" } } { "menu" "a new " { $link gadget } } } +{ $values { "target" object } { "hook" { $quotation "( button -- )" } } { "commands" "a sequence of commands" } { "menu" "a new " { $link gadget } } } { $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ; HELP: show-menu diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor index 1e4b875f28..17adb2bd64 100644 --- a/basis/ui/gadgets/scrollers/scrollers-docs.factor +++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor @@ -24,7 +24,7 @@ HELP: { } related-words HELP: set-scroll-position -{ $values { "scroller" scroller } { "value" "a pair of integers" } } +{ $values { "value" "a pair of integers" } { "scroller" scroller } } { $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; HELP: relative-scroll-rect diff --git a/basis/ui/gadgets/tracks/tracks-docs.factor b/basis/ui/gadgets/tracks/tracks-docs.factor index 0bbedc8d0d..cf5c94aa6b 100644 --- a/basis/ui/gadgets/tracks/tracks-docs.factor +++ b/basis/ui/gadgets/tracks/tracks-docs.factor @@ -18,7 +18,7 @@ HELP: { $description "Creates a new track which lays out children along the given orientation, either " { $link horizontal } " or " { $link vertical } "." } ; HELP: track-add -{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } } +{ $values { "track" track } { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } } { $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ; ABOUT: "ui-track-layout" diff --git a/basis/ui/pens/pens-docs.factor b/basis/ui/pens/pens-docs.factor index 4aa0e50945..4a5ec277f0 100644 --- a/basis/ui/pens/pens-docs.factor +++ b/basis/ui/pens/pens-docs.factor @@ -2,11 +2,11 @@ IN: ui.pens USING: help.markup help.syntax kernel ui.gadgets ; HELP: draw-interior -{ $values { "pen" object } { "gadget" gadget } } +{ $values { "gadget" gadget } { "pen" object } } { $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ; HELP: draw-boundary -{ $values { "pen" object } { "gadget" gadget } } +{ $values { "gadget" gadget } { "pen" object } } { $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ; ARTICLE: "ui-pen-protocol" "UI pen protocol" @@ -23,4 +23,4 @@ $nl { $vocab-subsection "Polygon pens" "ui.pens.polygon" } { $vocab-subsection "Solid pens" "ui.pens.solid" } { $vocab-subsection "Tile pens" "ui.pens.tile" } -"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ; \ No newline at end of file +"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ; diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor index b70c7c5050..a2a67d58bc 100644 --- a/basis/vectors/functor/functor.factor +++ b/basis/vectors/functor/functor.factor @@ -24,6 +24,8 @@ M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; inline M: A new-resizable drop ; inline +M: V new-resizable drop ; inline + M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; : >V ( seq -- vector ) V new clone-like ; inline diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index 287e972405..4f6ade8580 100644 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -43,4 +43,6 @@ M: byte-array like M: byte-array new-resizable drop ; inline +M: byte-vector new-resizable drop ; inline + INSTANCE: byte-vector growable diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 4701476d2a..1717359fa8 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -438,7 +438,7 @@ $nl { $notes "This word is used behind the scenes to compile " { $link cond } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ; HELP: case>quot -{ $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } } +{ $values { "default" quotation } { "assoc" "a sequence of pairs of quotations" } { "quot" quotation } } { $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "." $nl "This word uses three strategies:" diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 5fb5a38af2..84da26a082 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -122,7 +122,7 @@ HELP: continuation { $description "Reifies the current continuation from the point immediately after which the caller returns." } ; HELP: >continuation< -{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } } +{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } } { $description "Takes a continuation apart into its constituents." } ; HELP: ifcc @@ -271,4 +271,4 @@ HELP: with-return HELP: restart { $values { "restart" restart } } { $description "Invokes a restart." } -{ $class-description "The class of restarts." } ; \ No newline at end of file +{ $class-description "The class of restarts." } ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 0f80aac2f3..dea523538e 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -124,7 +124,7 @@ HELP: make-generic $low-level-note ; HELP: define-generic -{ $values { "word" word } { "effect" effect } { "combination" "a method combination" } } +{ $values { "word" word } { "combination" "a method combination" } { "effect" effect } } { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." } { $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ; diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 68a8de3d43..2ca11e2e24 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -66,4 +66,6 @@ M: growable shorten ( n seq -- ) 2dup (>>length) ] when 2drop ; inline +M: growable new-resizable new-sequence 0 over set-length ; inline + INSTANCE: growable sequence diff --git a/core/io/io.factor b/core/io/io.factor index e240467c07..ca36bc3b36 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -87,42 +87,51 @@ SYMBOL: error-stream : bl ( -- ) " " write ; - -: each-line ( quot -- ) - [ readln ] each-morsel ; inline +: each-stream-line ( stream quot -- ) + swap [ stream-readln ] curry each-morsel ; inline -: lines ( -- seq ) - [ ] accumulator [ each-line ] dip { } like ; +: each-line ( quot -- ) + input-stream get swap each-stream-line ; inline : stream-lines ( stream -- seq ) - [ lines ] with-input-stream ; + [ [ ] accumulator [ each-stream-line ] dip { } like ] with-disposal ; -: contents ( -- seq ) - [ 65536 read-partial dup ] [ ] produce nip - element-exemplar concat-as ; +: lines ( -- seq ) + input-stream get stream-lines ; inline : stream-contents ( stream -- seq ) - [ contents ] with-input-stream ; + [ + [ [ 65536 swap stream-read-partial dup ] curry [ ] produce nip ] + [ stream-element-exemplar concat-as ] bi + ] with-disposal ; + +: contents ( -- seq ) + input-stream get stream-contents ; inline + +: each-stream-block ( stream quot: ( block -- ) -- ) + swap [ 8192 swap stream-read-partial ] curry each-morsel ; inline : each-block ( quot: ( block -- ) -- ) - [ 8192 read-partial ] each-morsel ; inline + input-stream get swap each-stream-block ; inline : stream-copy ( in out -- ) [ [ [ write ] each-block ] with-output-stream ] diff --git a/core/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor index 1bc09429dc..eeada8d0c9 100644 --- a/core/io/streams/byte-array/byte-array-docs.factor +++ b/core/io/streams/byte-array/byte-array-docs.factor @@ -27,8 +27,9 @@ HELP: { $description "Creates an output stream writing data to a byte array using an encoding." } ; HELP: with-byte-reader -{ $values { "encoding" "an encoding descriptor" } - { "quot" quotation } { "byte-array" byte-array } } +{ $values { "byte-array" byte-array } + { "encoding" "an encoding descriptor" } + { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ; HELP: with-byte-writer diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 3f1e715448..d4f8f3c28c 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -168,7 +168,7 @@ HELP: xor { $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ; HELP: both? -{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." } { $examples { $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" } @@ -176,7 +176,7 @@ HELP: both? } ; HELP: either? -{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } } { $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." } { $examples { $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" } @@ -213,18 +213,18 @@ HELP: call-clear ( quot -- ) { $notes "Used to implement " { $link "threads" } "." } ; HELP: keep -{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } } +{ $values { "x" object } { "quot" { $quotation "( x -- ... )" } } } { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } { $examples { $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" } } ; HELP: 2keep -{ $values { "quot" { $quotation "( x y -- ... )" } } { "x" object } { "y" object } } +{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ... )" } } } { $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ; HELP: 3keep -{ $values { "quot" { $quotation "( x y z -- ... )" } } { "x" object } { "y" object } { "z" object } } +{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( x y z -- ... )" } } } { $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ; HELP: bi @@ -664,7 +664,7 @@ HELP: getenv ( n -- obj ) { $description "Reads an object from the Factor VM's environment table. User code never has to read the environment table directly; instead, use one of the callers of this word." } ; HELP: setenv ( obj n -- ) -{ $values { "n" "a non-negative integer" } { "obj" object } } +{ $values { "obj" object } { "n" "a non-negative integer" } } { $description "Writes an object to the Factor VM's environment table. User code never has to write to the environment table directly; instead, use one of the callers of this word." } ; HELP: object diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 838d877a40..6538109687 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -122,7 +122,7 @@ DEFER: if : 2bi@ ( w x y z quot -- ) dup 2bi* ; inline -: 2tri@ ( u v w y x z quot -- ) +: 2tri@ ( u v w x y z quot -- ) dup dup 2tri* ; inline ! Quotation building diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index a53604ddf9..60fb5559c5 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -5,39 +5,18 @@ strings arrays combinators splitting math assocs byte-arrays make ; IN: math.parser : digit> ( ch -- n ) - H{ - { CHAR: 0 0 } - { CHAR: 1 1 } - { CHAR: 2 2 } - { CHAR: 3 3 } - { CHAR: 4 4 } - { CHAR: 5 5 } - { CHAR: 6 6 } - { CHAR: 7 7 } - { CHAR: 8 8 } - { CHAR: 9 9 } - { CHAR: A 10 } - { CHAR: B 11 } - { CHAR: C 12 } - { CHAR: D 13 } - { CHAR: E 14 } - { CHAR: F 15 } - { CHAR: a 10 } - { CHAR: b 11 } - { CHAR: c 12 } - { CHAR: d 13 } - { CHAR: e 14 } - { CHAR: f 15 } - { CHAR: , f } - } at* [ drop 255 ] unless ; inline + 127 bitand { + { [ dup CHAR: 9 <= ] [ CHAR: 0 - ] } + { [ dup CHAR: a < ] [ CHAR: A 10 - - ] } + [ CHAR: a 10 - - ] + } cond + dup 0 < [ drop 255 ] [ dup 16 >= [ drop 255 ] when ] if ; inline : string>digits ( str -- digits ) [ digit> ] B{ } map-as ; inline : (digits>integer) ( valid? accum digit radix -- valid? accum ) - over [ - 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if - ] [ 2drop ] if ; inline + 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline : each-digit ( seq radix quot -- n/f ) [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline @@ -54,8 +33,8 @@ SYMBOL: negative? : string>natural ( seq radix -- n/f ) over empty? [ 2drop f ] [ - [ [ digit> ] dip (digits>integer) ] each-digit - ] if ; inline + [ over CHAR: , eq? [ 2drop ] [ [ digit> ] dip (digits>integer) ] if ] each-digit + ] if ; : sign ( -- str ) negative? get "-" "+" ? ; @@ -83,8 +62,8 @@ SYMBOL: negative? ] if ; inline : dec>float ( str -- n/f ) - [ CHAR: , eq? not ] filter - >byte-array 0 suffix (string>float) ; + [ CHAR: , eq? not ] BV{ } filter-as + 0 over push B{ } like (string>float) ; : hex>float-parts ( str -- neg? mantissa-str expt ) "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ; @@ -111,23 +90,33 @@ SYMBOL: negative? { { 16 [ hex>float ] } [ drop dec>float ] - } case ; + } case ; inline : number-char? ( char -- ? ) - "0123456789ABCDEFabcdef." member? ; + "0123456789ABCDEFabcdef." member? ; inline + +: last-unsafe ( seq -- elt ) + [ length 1 - ] [ nth-unsafe ] bi ; inline : numeric-looking? ( str -- ? ) - "-" ?head drop dup empty? [ drop f ] [ - dup first number-char? [ - last number-char? - ] [ drop f ] if - ] if ; + dup first-unsafe number-char? [ + last-unsafe number-char? + ] [ + dup first-unsafe CHAR: - eq? [ + dup length 1 eq? [ drop f ] [ + 1 over nth-unsafe number-char? [ + last-unsafe number-char? + ] [ drop f ] if + ] if + ] [ drop f ] if + ] if + ] if ; inline PRIVATE> : string>float ( str -- n/f ) - 10 base>float ; + 10 base>float ; inline : base> ( str radix -- n/f ) over numeric-looking? [ @@ -138,13 +127,13 @@ PRIVATE> } case ] [ 2drop f ] if ; -: string>number ( str -- n/f ) 10 base> ; -: bin> ( str -- n/f ) 2 base> ; -: oct> ( str -- n/f ) 8 base> ; -: hex> ( str -- n/f ) 16 base> ; +: string>number ( str -- n/f ) 10 base> ; inline +: bin> ( str -- n/f ) 2 base> ; inline +: oct> ( str -- n/f ) 8 base> ; inline +: hex> ( str -- n/f ) 16 base> ; inline : >digit ( n -- ch ) - dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; + dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline : positive>base ( num radix -- str ) dup 1 <= [ "Invalid radix" throw ] when @@ -234,12 +223,12 @@ M: ratio >base { { 16 [ float>hex ] } [ drop float>decimal ] - } case ; + } case ; inline PRIVATE> : float>string ( n -- str ) - 10 float>base ; + 10 float>base ; inline M: float >base { @@ -251,9 +240,9 @@ M: float >base [ float>base ] } cond ; -: number>string ( n -- str ) 10 >base ; -: >bin ( n -- str ) 2 >base ; -: >oct ( n -- str ) 8 >base ; -: >hex ( n -- str ) 16 >base ; +: number>string ( n -- str ) 10 >base ; inline +: >bin ( n -- str ) 2 >base ; inline +: >oct ( n -- str ) 8 >base ; inline +: >hex ( n -- str ) 16 >base ; inline -: # ( n -- ) number>string % ; +: # ( n -- ) number>string % ; inline diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 7e94d71c29..888f9f3b4c 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -188,7 +188,7 @@ HELP: parse-lines { $errors "Throws a " { $link lexer-error } " if the input is malformed." } ; HELP: parse-base -{ $values { "base" "an integer between 2 and 36" } { "parsed" integer } } +{ $values { "parsed" integer } { "base" "an integer between 2 and 36" } { "parsed" integer } } { $description "Reads an integer in a specific numerical base from the parser input." } $parsing-note ; diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 49b6ec1374..db2649142d 100644 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -23,13 +23,13 @@ M: sbuf like dup string? [ dup length sbuf boa ] [ >sbuf ] if ] unless ; inline -M: sbuf new-resizable drop ; inline - M: sbuf equal? over sbuf? [ sequence= ] [ 2drop f ] if ; M: string new-resizable drop ; inline +M: sbuf new-resizable drop ; inline + M: string like #! If we have a string, we're done. #! If we have an sbuf, and it's at full capacity, we're done. diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index ef02754a60..2156557fff 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -218,7 +218,7 @@ HELP: 3sequence { $description "Creates a three-element sequence of the same type as " { $snippet "exemplar" } "." } ; HELP: 4sequence -{ $values { "obj1" object } { "obj2" object } { "exemplar" sequence } { "obj3" object } { "obj4" object } { "seq" sequence } } +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "obj4" object } { "exemplar" sequence } { "seq" sequence } } { $description "Creates a four-element sequence of the same type as " { $snippet "exemplar" } "." } ; HELP: first2 @@ -277,7 +277,7 @@ HELP: reduce-index } } ; HELP: accumulate-as -{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } } +{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of the same type as " { $snippet "exemplar" } " containing intermediate results, together with the final result." $nl "The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence." @@ -285,7 +285,7 @@ $nl "When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } ; HELP: accumulate -{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } } +{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } } { $description "Combines successive elements of the sequence using a binary operation, and outputs an array of intermediate results, together with the final result." $nl "The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence." @@ -300,7 +300,7 @@ HELP: map { $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ; HELP: map-as -{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } } +{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } { $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." } { $examples "The following example converts a string into an array of one-element strings:" @@ -426,6 +426,10 @@ HELP: filter { $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } } { $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ; +HELP: filter-as +{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } } +{ $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ; + HELP: filter-here { $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } } { $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." } @@ -483,7 +487,7 @@ HELP: remove-nth } } ; HELP: move -{ $values { "from" "an index in " { $snippet "seq" } } { "to" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } } +{ $values { "to" "an index in " { $snippet "seq" } } { "from" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } } { $description "Sets the element with index " { $snippet "m" } " to the element with index " { $snippet "n" } "." } { $side-effects "seq" } ; @@ -510,7 +514,7 @@ HELP: delete-slice { $side-effects "seq" } ; HELP: replace-slice -{ $values { "new" sequence } { "seq" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq'" sequence } } +{ $values { "new" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "seq'" sequence } } { $description "Replaces a range of elements beginning at index " { $snippet "from" } " and ending before index " { $snippet "to" } " with a new sequence." } { $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." } ; @@ -1512,6 +1516,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators" "Filtering:" { $subsections filter + filter-as partition } "Testing if a sequence contains elements satisfying a predicate:" diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index c64095cb73..93709122c7 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -483,11 +483,17 @@ PRIVATE> : push-if ( elt quot accum -- ) [ keep ] dip rot [ push ] [ 2drop ] if ; inline +: pusher-for ( quot exemplar -- quot accum ) + [ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline + : pusher ( quot -- quot accum ) - V{ } clone [ [ push-if ] 2curry ] keep ; inline + V{ } pusher-for ; inline + +: filter-as ( seq quot exemplar -- subseq ) + dup [ pusher-for [ each ] dip ] curry dip like ; inline : filter ( seq quot -- subseq ) - over [ pusher [ each ] dip ] dip like ; inline + over filter-as ; inline : push-either ( elt quot accum1 accum2 -- ) [ keep swap ] 2dip ? push ; inline @@ -498,11 +504,14 @@ PRIVATE> : partition ( seq quot -- trueseq falseseq ) over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline +: accumulator-for ( quot exemplar -- quot' vec ) + [ length ] keep new-resizable [ [ push ] curry compose ] keep ; inline + : accumulator ( quot -- quot' vec ) - V{ } clone [ [ push ] curry compose ] keep ; inline + V{ } accumulator-for ; inline : produce-as ( pred quot exemplar -- seq ) - [ accumulator [ while ] dip ] dip like ; inline + dup [ accumulator-for [ while ] dip ] curry dip like ; inline : produce ( pred quot -- seq ) { } produce-as ; inline diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index 93078c162b..f021944f86 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -17,6 +17,7 @@ TUPLE: source-file-error error asset file line# ; M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ; M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ; +M: source-file-error compute-restarts error>> compute-restarts ; : sort-errors ( errors -- alist ) [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ; diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index ef19d16351..cb1e5e6017 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -38,7 +38,7 @@ HELP: source-file } ; HELP: record-checksum -{ $values { "source-file" source-file } { "lines" "a sequence of strings" } } +{ $values { "lines" "a sequence of strings" } { "source-file" source-file } } { $description "Records the CRC32 checksm of the source file's contents." } $low-level-note ; diff --git a/extra/alien/data/map/map.factor b/extra/alien/data/map/map.factor index 72f5cb5517..62bd45938b 100644 --- a/extra/alien/data/map/map.factor +++ b/extra/alien/data/map/map.factor @@ -1,7 +1,8 @@ ! (c)Joe Groff bsd license USING: accessors alien alien.c-types alien.data alien.parser arrays byte-arrays combinators effects.parser fry generalizations grouping kernel -lexer locals macros make math math.ranges parser sequences sequences.private ; +lexer locals macros make math math.ranges parser sequences +sequences.generalizations sequences.private ; FROM: alien.arrays => array-length ; IN: alien.data.map diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index 2e292f0141..a741af8002 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -3,13 +3,15 @@ USING: accessors alien.c-types arrays classes.struct combinators combinators.short-circuit game.worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images images.loader -io io.encodings.ascii io.files io.files.temp kernel math -math.matrices math.parser math.vectors method-chains sequences -splitting threads ui ui.gadgets ui.gadgets.worlds -ui.pixel-formats specialized-arrays specialized-vectors ; +io io.encodings.ascii io.files io.files.temp kernel locals math +math.matrices math.vectors.simd math.parser math.vectors +method-chains namespaces sequences splitting threads ui ui.gadgets +ui.gadgets.worlds ui.pixel-formats specialized-arrays +specialized-vectors ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-VECTOR: uint +SIMD: float IN: gpu.demos.bunny GLSL-SHADER-FILE: bunny-vertex-shader vertex-shader "bunny.v.glsl" @@ -52,7 +54,10 @@ VERTEX-FORMAT: bunny-vertex { f float-components 1 f } { "normal" float-components 3 f } { f float-components 1 f } ; -VERTEX-STRUCT: bunny-vertex-struct bunny-vertex + +STRUCT: bunny-vertex-struct + { vertex float-4 } + { normal float-4 } ; SPECIALIZED-VECTOR: bunny-vertex-struct @@ -74,43 +79,58 @@ UNIFORM-TUPLE: loading-uniforms { "texcoord-scale" vec2-uniform f } { "loading-texture" texture-uniform f } ; -: numbers ( str -- seq ) - " " split [ string>number ] map sift ; +: numbers ( tokens -- seq ) + [ string>number ] map ; inline : ( vertex -- struct ) bunny-vertex-struct - swap >float-array >>vertex ; inline + swap first3 0.0 float-4-boa >>vertex ; inline + +: (read-line-tokens) ( seq stream -- seq ) + " \n" over stream-read-until + [ [ pick push ] unless-empty ] + [ + { + { CHAR: \s [ (read-line-tokens) ] } + { CHAR: \n [ drop ] } + [ 2drop [ f ] when-empty ] + } case + ] bi* ; inline recursive + +: stream-read-line-tokens ( stream -- seq ) + V{ } clone swap (read-line-tokens) ; + +: each-line-tokens ( quot -- ) + input-stream get [ stream-read-line-tokens ] curry each-morsel ; inline : (parse-bunny-model) ( vs is -- vs is ) - readln [ + [ numbers { - { [ dup length 5 = ] [ 3 head pick push ] } + { [ dup length 5 = ] [ pick push ] } { [ dup first 3 = ] [ rest over push-all ] } [ drop ] - } cond (parse-bunny-model) - ] when* ; + } cond + ] each-line-tokens ; inline : parse-bunny-model ( -- vertexes indexes ) 100000 100000 - (parse-bunny-model) ; + (parse-bunny-model) ; inline -: normal ( vertexes -- normal ) - [ [ second ] [ first ] bi v- ] - [ [ third ] [ first ] bi v- ] bi cross - vneg normalize ; inline +:: normal ( a b c -- normal ) + c a v- + b a v- cross normalize ; inline -: calc-bunny-normal ( vertexes indexes -- ) - swap - [ [ nth vertex>> ] curry { } map-as normal ] - [ [ nth [ v+ ] change-normal drop ] curry with each ] 2bi ; +:: calc-bunny-normal ( a b c vertexes -- ) + a b c [ vertexes nth vertex>> ] tri@ normal :> n + a b c [ vertexes nth [ n v+ ] change-normal drop ] tri@ ; inline : calc-bunny-normals ( vertexes indexes -- ) - 3 - [ calc-bunny-normal ] with each ; + 3 swap + [ [ first3 ] dip calc-bunny-normal ] curry each ; inline : normalize-bunny-normals ( vertexes -- ) - [ [ normalize ] change-normal drop ] each ; + [ [ normalize ] change-normal drop ] each ; inline : bunny-data ( filename -- vertexes indexes ) ascii [ parse-bunny-model ] with-file-reader diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index aece1b40d6..fc6d495dff 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -277,7 +277,7 @@ padding-no [ 0 ] initialize ] [ nip ] if ":" join ; : replace-log-line-numbers ( object log -- log' ) - "\n" split [ empty? not ] filter + "\n" split harvest [ replace-log-line-number ] with map "\n" join ; diff --git a/extra/models/combinators/combinators-docs.factor b/extra/models/combinators/combinators-docs.factor index 5ccfe1f758..8ac3657105 100644 --- a/extra/models/combinators/combinators-docs.factor +++ b/extra/models/combinators/combinators-docs.factor @@ -10,7 +10,7 @@ HELP: filter-model { $description "Creates a model that uses the updates of another model only when they satisfy a given predicate" } ; HELP: fold -{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model" model } } +{ $values { "model" model } { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } } { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ; HELP: switch-models @@ -38,4 +38,4 @@ ARTICLE: "models.combinators" "Extending models" "Also, it provides methods of manipulating and combining models, expecially useful when programming user interfaces: " "The output models of some gadgets (see " { $vocab-link "ui.gadgets.controls" } " ) can be manipulated and used as the input models of others. " ; -ABOUT: "models.combinators" \ No newline at end of file +ABOUT: "models.combinators" diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 574724dfaf..9538972582 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -188,9 +188,7 @@ M: mdb-query-msg skip : asc ( key -- spec ) 1 2array ; inline : desc ( key -- spec ) -1 2array ; inline -GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg ) - -M: mdb-query-msg sort +: sort ( mdb-query-msg sort-quot -- mdb-query-msg ) output>array [ 1array >hashtable ] map >>orderby ; inline : key-spec ( spec-quot -- spec-assoc ) diff --git a/extra/pop3/authors.txt b/extra/pop3/authors.txt new file mode 100644 index 0000000000..0a1127186c --- /dev/null +++ b/extra/pop3/authors.txt @@ -0,0 +1 @@ +Elie Chaftari \ No newline at end of file diff --git a/extra/pop3/pop3-docs.factor b/extra/pop3/pop3-docs.factor new file mode 100644 index 0000000000..aeb6d210f6 --- /dev/null +++ b/extra/pop3/pop3-docs.factor @@ -0,0 +1,312 @@ +! Copyright (C) 2009 Elie Chaftari. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs help.markup help.syntax kernel math +sequences strings ; +IN: pop3 + +HELP: +{ $values + + { "pop3-account" pop3-account } +} +{ $description "creates a " { $link pop3-account } " object with defaults for the port and timeout slots." } ; + +HELP: account +{ $values + + { "pop3-account" pop3-account } +} +{ $description "You only need to call " { $link connect } " after calling this word to reconnect to the latest accessed POP3 account." } +{ $examples + { $code + "account connect" + "" + } +} ; + +HELP: >user +{ $values + { "name" "userID of the account" } +} +{ $description "Sends the userID of the account on the POP3 server (this could be the full e-mail address)" $nl +"This must be the first command after " { $link connect } " if username and password have not been set with " { $link } "." +} ; + +HELP: >pwd +{ $values + { "password" "password for the userID" } +} +{ $description "Sends the clear-text password for the userID. The password may be case sensitive. This must be the next command after " { $link >user } "." } ; + +HELP: capa +{ $values + + { "array" array } +} +{ $description "Queries the mail server capabilities, as described in RFC 2449. It is advised to check for command support before calling the appropriate words (e.g. TOP UIDL)." } ; + +HELP: connect +{ $values + { "pop3-account" pop3-account } +} +{ $description "Opens a network connection to the pop3 mail server with the settings given in the pop3-account slots." } +{ $examples + { $code "USING: accessors pop3 ;" + "" + " \"pop.yourisp.com\" >>host" + " \"username@yourisp.com\" >>user" + " \"pass123\" >>pwd" + "connect" + "" + } +} ; + +HELP: consolidate +{ $values + + { "seq" sequence } +} +{ $description "Builds a sequence of email tuples, iterating over each email top and consolidating its headers with its number, uidl, and size." } ; + +HELP: delete +{ $values + { "message#" fixnum } +} +{ $description "This marks message number message# for deletion from the server. This is the way to get rid of a problem causing message. It is not actually deleted until the " { $link close } " word is issued. If you lose the connection to the mail server before calling the " { $link close } " word, the server should not delete any messages. Example: 3 delete" } ; + +HELP: headers +{ $values + + { "assoc" assoc } +} +{ $description "Gathers and associates the From:, Subject:, and To: headers of each message." } ; + +HELP: list +{ $values + + { "assoc" assoc } +} +{ $description "Lists each message with its number and size in bytes" } ; + +HELP: pop3-account +{ $class-description "A POP3 account on a POP3 server. It has the following slots:" + { $table + { { $slot "#" } "The ephemeral ordinal number of the message." } + { { $slot "host" } "The name or IP address of the remote host to which a POP3 connection is required." } + { { $slot "port" } "The POP3 server port (defaults to 110)." } + { { $slot "timeout" } "Maximum time in minutes to wait for a response from the POP3 server (defaults to 1 minutes)." } + { { $slot "user" } "The userID of the account on the POP3 server." } + { { $slot "pwd" } { "The clear-text password for the userID." } } + { { $slot "stream" } { "The duplex input/output stream wrapping the POP3 session." } } + { { $slot "capa" } { "A list of the mail server capabilities." } } + { { $slot "count" } { "Number of messages in the mailbox." } } + { { $slot "list" } { "A list of every message with its number and size in bytes" } } + { { $slot "uidls" } { "The UIDL (Unique IDentification Listing) of every message in the mailbox together with its ordinal number." } } + { { $slot "messages" } { "A sequence of email tuples in the mailbox containing each email's headers, number, uidl, and size." } } + } +"The " { $slot "host" } " is required; the rest are either set by default or optional." $nl +"The " { $slot "user" } " and " { $slot "pwd" } " must either be set before using " { $link connect } " or immediately after it with the " { $link >user } " and " { $link >pwd } " words." +} ; + +HELP: message +{ $class-description "An e-mail message having the following slots:" + { $table + { { $slot "#" } "The ephemeral ordinal number of the message." } + { { $slot "uidl" } "The POP3 UIDL (Unique IDentification Listing) of the message." } + { { $slot "headers" } "The From:, Subject:, and To: headers of the message." } + { { $slot "from" } "The sender of the message. An e-mail address." } + { { $slot "to" } "The recipients of the message." } + { { $slot "subject" } { "The subject of the message." } } + { { $slot "size" } { "The size of the message in octets." } } + } +} ; + +HELP: close +{ $description "Deletes any messages marked for deletion, and then logs you off of the mail server. This is the last command to use." } ; + +HELP: retrieve +{ $values + { "message#" fixnum } + { "seq" sequence } +} +{ $description "Sends message number message# to you. You should prepare for some base64 decoding. You probably want to do this with a mailer." } ; + +HELP: reset +{ $description "Resets the status of the remote POP3 server. This includes resetting the status of all messages to not be deleted." } ; + +HELP: count +{ $values + + { "n" fixnum } +} +{ $description "Gets the number of messages in the mailbox." } ; + +HELP: top +{ $values + { "message#" fixnum } { "#lines" fixnum } + { "seq" sequence } +} +{ $description "Lists the header for message# and the first #lines of the message text. For example, 1 0 top would list just the headers for message 1, where as 1 5 top would list the headers and first 5 lines of the message text." } ; + +HELP: uidl +{ $values + { "message#" fixnum } + { "uidl" string } +} +{ $description "Gets the POP3 UIDL (Unique IDentification Listing) of the given message#." } ; + +HELP: uidls +{ $values + + { "assoc" assoc } +} +{ $description "Gets the POP3 UIDL (Unique IDentification Listing) of every specific message in the mailbox together with its ordinal number. UIDL provides a mechanism that avoids numbering issues between POP3 sessions by assigning a permanent and unique ID for each message." } ; + +ARTICLE: "pop3" "POP3 client library" +"The " { $vocab-link "pop3" } " vocab implements a client interface to the POP3 protocol, enabling a Factor application to talk to POP3 servers. It allows interactive sessions similar to telnet ones to do maintenance on your mailbox on a POP3 mail server; to look at, and possibly delete, any problem causing message (e.g. too large, improperly formatted, etc.)." $nl +"Word names do not necessarily map directly to POP3 commands defined in RFC1081 or RFC1939, although most commands are supported." $nl +"This article assumes that you are familiar with the POP3 protocol." +$nl +"Connecting to the mail server:" +{ $subsections connect } +"You need to construct a pop3-account tuple first, setting at least the host slot." +{ $subsections } +{ $examples + { $code "USING: accessors pop3 ;" + "" + " \"pop.yourisp.com\" >>host" + " \"username@yourisp.com\" >>user" + " \"pass123\" >>pwd" + "connect" + "" + } +} +$nl +"If you do not supply the username or password, you will need to call the " { $link >user } " and " { $link >pwd } " vocabs in this order after the " { $link connect } " vocab." +{ $examples + { $code "USING: accessors pop3 ;" + "" + " \"pop.yourisp.com\" >>host" + "connect" + "" + "\"username@yourisp.com\" >user" + "\"pass123\" >pwd" + "" + } +} +$nl +{ $notes "Subsequent calls to the " { $link pop3-account } " thus created can be done by calling the " { $link account } " word. If you needed to reconnect to the same POP3 account after having called " { $link close } ", you only need to call " { $link account } " followed by " { $link connect } "." } +$nl +"Querying the mail server:" +$nl +"For its capabilities:" +{ $subsections capa } +{ $examples + { $code + "capa ." + "{ \"CAPA\" \"TOP\" \"UIDL\" }" + "" + } +} +$nl +"For the message count:" +{ $subsections count } +{ $examples + { $code + "count ." + "2" + "" + } +} +$nl +"For each message's size:" +{ $subsections list } +{ $examples + { $code + "list ." + "H{ { 1 \"1006\" } { 2 \"747\" } }" + "" + } +} +$nl +"For a specific message raw header, appropriate headers, or number of lines:" +{ $subsections top } +{ $examples + { $code + "1 0 top ." + "" + "" + } + { $code + "1 5 top ." + "" + "" + } + { $code + "1 0 top headers ." + "H{" + " { \"From:\" \"from@mail.com\" }" + " { \"Subject:\" \"Re:\" }" + " { \"To:\" \"username@host.com\" }" + "}" + "" + } +} +$nl +"To consolidate all the messages of this account into a single association:" +{ $subsections consolidate } +{ $examples + { $code + "consolidate ." +"""{ + T{ message + { # 1 } + { uidl \"000000d547ac2fc2\" } + { from \"from.first@mail.com\" } + { to \"username@host.com\" } + { subject \"First subject\" } + { size \"1006\" } + } + T{ message + { # 2 } + { uidl \"000000d647ac2fc2\" } + { from \"from.second@mail.com\" } + { to \"username@host.com\" } + { subject \"Second subject\" } + { size \"747\" } + } +}""" + "" + } +} +$nl +"You may want to delete message #2 but want to make sure you are deleting the right one. You can check that message #2 has the uidl from the example above." +{ $subsections uidl } +{ $examples + { $code + "2 uidl ." + "\"000000d647ac2fc2\"" + "" + } +} +$nl +"Now with your mind at rest, you can delete message #2. The message is marked for deletion." +{ $subsections delete } +{ $examples + { $code + "2 delete" + "" + } +} +$nl +"The messages marked for deletion are actually deleted only when " { $link close } " is called. This should be the last command you issue. " +{ $subsections close } +{ $examples + { $code + "close" + "" + } +} +{ $notes "If you change your mind at any point, you can call " { $link reset } " to reset the status of all messages to not be deleted." } ; + +ABOUT: "pop3" diff --git a/extra/pop3/pop3-tests.factor b/extra/pop3/pop3-tests.factor new file mode 100644 index 0000000000..8efc07ceee --- /dev/null +++ b/extra/pop3/pop3-tests.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2009 Elie Chaftari. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.promises namespaces kernel pop3 pop3.server +sequences tools.test accessors ; +IN: pop3.tests + +FROM: pop3 => count delete ; + + "p1" set + +[ ] [ "p1" get mock-pop3-server ] unit-test +[ ] [ + + "127.0.0.1" >>host + "p1" get ?promise >>port + connect +] unit-test +[ ] [ "username@host.com" >user ] unit-test +[ ] [ "password" >pwd ] unit-test +[ { "CAPA" "TOP" "UIDL" } ] [ capa ] unit-test +[ 2 ] [ count ] unit-test +[ H{ { 1 "1006" } { 2 "747" } } ] [ list ] unit-test +[ + H{ + { "From:" "from.first@mail.com" } + { "Subject:" "First test with mock POP3 server" } + { "To:" "username@host.com" } + } +] [ 1 0 top drop headers ] unit-test +[ + { + T{ message + { # 1 } + { uidl "000000d547ac2fc2" } + { from "from.first@mail.com" } + { to "username@host.com" } + { subject "First test with mock POP3 server" } + { size "1006" } + } + T{ message + { # 2 } + { uidl "000000d647ac2fc2" } + { from "from.second@mail.com" } + { to "username@host.com" } + { subject "Second test with mock POP3 server" } + { size "747" } + } + } +] [ consolidate ] unit-test +[ "000000d547ac2fc2" ] [ 1 uidl ] unit-test +[ ] [ 1 delete ] unit-test +[ ] [ reset ] unit-test +[ ] [ close ] unit-test + + + "p2" set + +[ ] [ "p2" get mock-pop3-server ] unit-test +[ ] [ + + "127.0.0.1" >>host + "p2" get ?promise >>port + "username@host.com" >>user + "password" >>pwd + connect +] unit-test +[ f ] [ 1 retrieve empty? ] unit-test +[ ] [ close ] unit-test diff --git a/extra/pop3/pop3.factor b/extra/pop3/pop3.factor new file mode 100644 index 0000000000..030d265f37 --- /dev/null +++ b/extra/pop3/pop3.factor @@ -0,0 +1,199 @@ +! Copyright (C) 2009 Elie Chaftari. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors annotations arrays assocs calendar combinators +fry hashtables io io.crlf io.encodings.utf8 io.sockets +io.streams.duplex io.timeouts kernel make math math.parser +math.ranges namespaces prettyprint sequences splitting +strings ; +IN: pop3 + +TUPLE: pop3-account +# host port timeout user pwd stream capa count list +uidls messages ; + +: ( -- pop3-account ) + pop3-account new + 110 >>port + 1 minutes >>timeout ; + +: account ( -- pop3-account ) pop3-account get ; + +TUPLE: message # uidl headers from to subject size ; + +> ; + +: ( -- message ) message new ; inline + +TUPLE: raw-source top headers content ; + +: ( -- raw-source ) raw-source new ; inline + +: raw ( -- raw-source ) raw-source get ; + +: set-read-timeout ( -- ) + stream [ + account timeout>> timeouts + ] with-stream* ; + +: get-ok ( -- ) + stream [ + readln dup "+OK" head? [ drop ] [ throw ] if + ] with-stream* ; + +: get-ok-and-total ( -- total ) + stream [ + readln dup "+OK" head? [ + " " split second string>number dup account (>>count) + ] [ throw ] if + ] with-stream* ; + +: get-ok-and-uidl ( -- uidl ) + stream [ + readln dup "+OK" head? [ + " " split last + ] [ throw ] if + ] with-stream* ; + +: command ( string -- ) write crlf flush get-ok ; + +: command-and-total ( string -- total ) write crlf flush + get-ok-and-total ; + +: command-and-uidl ( string -- uidl ) write crlf flush + get-ok-and-uidl ; + +: associate-split ( seq -- assoc ) + [ " " split1 ] H{ } map>assoc ; + +: split-map ( seq -- assoc ) + associate-split [ [ string>number ] dip ] assoc-map ; + +: (readlns) ( -- ) + readln dup "." = [ , ] dip [ (readlns) ] unless ; + +: readlns ( -- seq ) [ (readlns) ] { } make but-last ; + +: (list) ( -- ) + stream [ + "LIST" command + readlns account (>>list) + ] with-stream* ; + +: (uidls) ( -- ) + stream [ + "UIDL" command + readlns account (>>uidls) + ] with-stream* ; + +PRIVATE> + +: >user ( name -- ) + [ stream ] dip '[ + "USER " _ append command + ] with-stream* ; + +: >pwd ( password -- ) + [ stream ] dip '[ + "PASS " _ append command + ] with-stream* ; + +: connect ( pop3-account -- ) + [ + [ host>> ] [ port>> ] bi + utf8 drop + ] keep swap >>stream + { + [ pop3-account set ] + [ user>> [ >user ] when* ] + [ pwd>> [ >pwd ] when* ] + } cleave + set-read-timeout + get-ok ; + +: capa ( -- array ) + stream [ + "CAPA" command + readlns dup account (>>capa) + ] with-stream* ; + +: count ( -- n ) + stream [ + "STAT" command-and-total + ] with-stream* ; + +: list ( -- assoc ) + (list) account list>> split-map ; + +: uidl ( message# -- uidl ) + [ stream ] dip '[ + "UIDL " _ number>string append command-and-uidl + ] with-stream* ; + +: uidls ( -- assoc ) + (uidls) account uidls>> split-map ; + +: top ( message# #lines -- seq ) + raw-source set + [ stream ] 2dip '[ + "TOP " _ number>string append " " + append _ number>string append + command + readlns dup raw (>>top) + ] with-stream* ; + +: headers ( -- assoc ) + raw top>> { + [ + [ dup "From:" head? + [ raw [ swap suffix ] change-headers drop ] + [ drop ] if + ] each + ] + [ + [ dup "To:" head? + [ raw [ swap suffix ] change-headers drop ] + [ drop ] if + ] each + ] + [ + [ dup "Subject:" head? + [ raw [ swap suffix ] change-headers drop ] + [ drop ] if + ] each + ] + } cleave raw headers>> associate-split ; + +: retrieve ( message# -- seq ) + [ stream ] dip '[ + "RETR " _ number>string append command + readlns dup raw (>>content) + ] with-stream* ; + +: delete ( message# -- ) + [ stream ] dip '[ + "DELE " _ number>string append command + ] with-stream* ; + +: reset ( -- ) + stream [ "RSET" command ] with-stream* ; + +: consolidate ( -- seq ) + count zero? [ "No mail for account." ] [ + 1 account count>> [a,b] [ + { + [ 0 top drop ] + [ swap >># ] + [ uidls at >>uidl ] + [ list at >>size ] + } cleave + "From:" headers at >>from + "To:" headers at >>to + "Subject:" headers at >>subject + account [ swap suffix ] change-messages drop + ] each account messages>> + ] if ; + +: close ( -- ) + stream [ "QUIT" command ] with-stream ; diff --git a/extra/pop3/server/server.factor b/extra/pop3/server/server.factor new file mode 100644 index 0000000000..775a457fc5 --- /dev/null +++ b/extra/pop3/server/server.factor @@ -0,0 +1,266 @@ +! Copyright (C) 2009 Elie Chaftari. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors calendar combinators concurrency.promises +destructors fry io io.crlf io.encodings.utf8 io.sockets +io.sockets.secure.unix.debug io.streams.duplex io.timeouts +kernel locals math.parser namespaces prettyprint sequences +splitting threads ; +IN: pop3.server + +! Mock POP3 server for testing purposes. + +! $ telnet 127.0.0.1 (start-pop3-server outputs listening port) +! Trying 127.0.0.1... +! Connected to localhost. +! Escape character is '^]'. +! +OK POP3 server ready +! USER username@host.com +! +OK Password required +! PASS password +! +OK Logged in +! STAT +! +OK 2 1753 +! LIST +! +OK 2 messages: +! 1 1006 +! 2 747 +! . +! UIDL 1 +! +OK 1 000000d547ac2fc2 +! TOP 1 0 +! +OK +! Return-Path: +! Delivered-To: username@host.com +! Received: from User.local ([66.249.71.201]) +! by mail.isp.com with ESMTP id n95BgmJg012655 +! for ; Mon, 5 Oct 2009 14:42:59 +0300 +! Date: Mon, 5 Oct 2009 14:42:31 +0300 +! Message-Id: <4273644000823950677-1254742951070701@User.local> +! MIME-Version: 1.0 +! Content-Transfer-Encoding: base64 +! From: from.first@mail.com +! To: username@host.com +! Subject: First test with mock POP3 server +! Content-Type: text/plain; charset=UTF-8 +! +! . +! DELE 1 +! +OK Marked for deletion +! QUIT +! +OK POP3 server closing connection +! Connection closed by foreign host. + +: process ( -- ) + read-crlf { + { + [ dup "USER" head? ] + [ + + "+OK Password required\r\n" + write flush t + ] + } + { + [ dup "PASS" head? ] + [ + "+OK Logged in\r\n" + write flush t + ] + } + { + [ dup "CAPA" = ] + [ + "+OK\r\nCAPA\r\nTOP\r\nUIDL\r\n.\r\n" + write flush t + ] + } + { + [ dup "STAT" = ] + [ + "+OK 2 1753\r\n" + write flush t + ] + } + { + [ dup "LIST" = ] + [ + "+OK 2 messages:\r\n1 1006\r\n2 747\r\n.\r\n" + write flush t + ] + } + { + [ dup "UIDL" head? ] + [ + { + { + [ dup "UIDL 1" = ] + [ + "+OK 1 000000d547ac2fc2\r\n" + write flush t + ] + } + { + [ dup "UIDL 2" = ] + [ + "+OK 2 000000d647ac2fc2\r\n" + write flush t + ] + } + [ + "+OK\r\n1 000000d547ac2fc2\r\n2 000000d647ac2fc2\r\n.\r\n" + write flush t + ] + } cond + ] + } + { + [ dup "TOP" head? ] + [ + { + { + [ dup "TOP 1 0" = ] + [ +"""+OK +Return-Path: +Delivered-To: username@host.com +Received: from User.local ([66.249.71.201]) + by mail.isp.com with ESMTP id n95BgmJg012655 + for ; Mon, 5 Oct 2009 14:42:59 +0300 +Date: Mon, 5 Oct 2009 14:42:31 +0300 +Message-Id: <4273644000823950677-1254742951070701@User.local> +MIME-Version: 1.0 +Content-Transfer-Encoding: base64 +From: from.first@mail.com +To: username@host.com +Subject: First test with mock POP3 server +Content-Type: text/plain; charset=UTF-8 + +. +""" + write flush t + ] + } + { + [ dup "TOP 2 0" = ] + [ +"""+OK +Return-Path: +Delivered-To: username@host.com +Received: from User.local ([66.249.71.201]) + by mail.isp.com with ESMTP id n95BgmJg012655 + for ; Mon, 5 Oct 2009 14:44:09 +0300 +Date: Mon, 5 Oct 2009 14:43:11 +0300 +Message-Id: <9783644000823934577-4563442951070856@User.local> +MIME-Version: 1.0 +Content-Transfer-Encoding: base64 +From: from.second@mail.com +To: username@host.com +Subject: Second test with mock POP3 server +Content-Type: text/plain; charset=UTF-8 + +. +""" + write flush t + ] + } + } cond + ] + } + { + [ dup "RETR" head? ] + [ + { + { + [ dup "RETR 1" = ] + [ +"""+OK +Return-Path: +Delivered-To: username@host.com +Received: from User.local ([66.249.71.201]) + by mail.isp.com with ESMTP id n95BgmJg012655 + for ; Mon, 5 Oct 2009 14:42:59 +0300 +Date: Mon, 5 Oct 2009 14:42:31 +0300 +Message-Id: <4273644000823950677-1254742951070701@User.local> +MIME-Version: 1.0 +Content-Transfer-Encoding: base64 +From: from.first@mail.com +To: username@host.com +Subject: First test with mock POP3 server +Content-Type: text/plain; charset=UTF-8 + +This is the body of the first test. +. +""" + write flush t + ] + } + { + [ dup "RETR 2" = ] + [ +"""+OK +Return-Path: +Delivered-To: username@host.com +Received: from User.local ([66.249.71.201]) + by mail.isp.com with ESMTP id n95BgmJg012655 + for ; Mon, 5 Oct 2009 14:44:09 +0300 +Date: Mon, 5 Oct 2009 14:43:11 +0300 +Message-Id: <9783644000823934577-4563442951070856@User.local> +MIME-Version: 1.0 +Content-Transfer-Encoding: base64 +From: from.second@mail.com +To: username@host.com +Subject: Second test with mock POP3 server +Content-Type: text/plain; charset=UTF-8 + +This is the body of the second test. +. +""" + write flush t + ] + } + } cond + ] + } + { + [ dup "DELE" head? ] + [ + "+OK Marked for deletion\r\n" + write flush t + ] + } + { + [ dup "RSET" = ] + [ + "+OK\r\n" + write flush t + ] + } + { + [ dup "QUIT" = ] + [ + "+OK POP3 server closing connection\r\n" + write flush f + ] + } + } cond nip [ process ] when ; + +:: mock-pop3-server ( promise -- ) + #! Store the port we are running on in the promise. + [ + [ + "127.0.0.1" 0 utf8 [ + dup addr>> port>> promise fulfill + accept drop [ + 1 minutes timeouts + "+OK POP3 server ready\r\n" write flush + process + global [ flush ] bind + ] with-stream + ] with-disposal + ] with-test-context + ] in-thread ; + +: start-pop3-server ( -- ) + [ mock-pop3-server ] keep ?promise + number>string "POP3 server started on port " + prepend print ; diff --git a/extra/pop3/server/summary.txt b/extra/pop3/server/summary.txt new file mode 100644 index 0000000000..56d261eb25 --- /dev/null +++ b/extra/pop3/server/summary.txt @@ -0,0 +1 @@ +POP3 server for testing purposes diff --git a/extra/pop3/summary.txt b/extra/pop3/summary.txt new file mode 100644 index 0000000000..387a099622 --- /dev/null +++ b/extra/pop3/summary.txt @@ -0,0 +1 @@ +Retrieve mail via POP3 diff --git a/extra/pop3/tags.txt b/extra/pop3/tags.txt new file mode 100644 index 0000000000..80d57bb287 --- /dev/null +++ b/extra/pop3/tags.txt @@ -0,0 +1,2 @@ +enterprise +network diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index 2d76b12c38..d05942ff7e 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -47,7 +47,7 @@ void factor_vm::call_fault_handler( else signal_callstack_top = NULL; - MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state)); + MACH_STACK_POINTER(thread_state) = align_stack_pointer(MACH_STACK_POINTER(thread_state)); /* Now we point the program counter at the right handler function. */ if(exception == EXC_BAD_ACCESS) @@ -63,7 +63,13 @@ void factor_vm::call_fault_handler( } else { - signal_number = (exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT); + switch(exception) + { + case EXC_ARITHMETIC: signal_number = SIGFPE; break; + case EXC_BAD_INSTRUCTION: signal_number = SIGILL; break; + default: signal_number = SIGABRT; break; + } + MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::misc_signal_handler_impl; } } @@ -226,7 +232,7 @@ void mach_initialize () fatal_error("mach_port_insert_right() failed",0); /* The exceptions we want to catch. */ - mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC; + mask = EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC; /* Create the thread listening on the exception port. */ start_thread(mach_exception_thread,NULL); diff --git a/vm/os-freebsd-x86.32.hpp b/vm/os-freebsd-x86.32.hpp index e682fec13c..5ed5cf0e81 100644 --- a/vm/os-freebsd-x86.32.hpp +++ b/vm/os-freebsd-x86.32.hpp @@ -4,12 +4,6 @@ namespace factor { -inline static void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.mc_esp; -} - inline static unsigned int uap_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -43,6 +37,8 @@ inline static void uap_clear_fpu_status(void *uap) } } -#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip) + +#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_esp) +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_eip) } diff --git a/vm/os-freebsd-x86.64.hpp b/vm/os-freebsd-x86.64.hpp index 8f8d218a10..02f7fb3ad2 100644 --- a/vm/os-freebsd-x86.64.hpp +++ b/vm/os-freebsd-x86.64.hpp @@ -4,12 +4,6 @@ namespace factor { -inline static void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.mc_rsp; -} - inline static unsigned int uap_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -33,6 +27,8 @@ inline static void uap_clear_fpu_status(void *uap) } } -#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip) + +#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_rsp) +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_rip) } diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index 1972a728e6..ff5d29ecd7 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -10,4 +10,9 @@ void early_init(); const char *vm_executable_path(); const char *default_image_path(); +template Type align_stack_pointer(Type sp) +{ + return sp; +} + } diff --git a/vm/os-linux-arm.hpp b/vm/os-linux-arm.hpp index 70c3eb3ff6..3af92fda99 100644 --- a/vm/os-linux-arm.hpp +++ b/vm/os-linux-arm.hpp @@ -5,15 +5,9 @@ namespace factor { -inline static void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.arm_sp; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc) - void flush_icache(cell start, cell len); +#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_sp) +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_pc) + } diff --git a/vm/os-linux-ppc.hpp b/vm/os-linux-ppc.hpp index 62671e5ded..51e017bdad 100644 --- a/vm/os-linux-ppc.hpp +++ b/vm/os-linux-ppc.hpp @@ -4,14 +4,7 @@ namespace factor { #define FRAME_RETURN_ADDRESS(frame,vm) *((void **)(vm->frame_successor(frame) + 1) + 1) - -inline static void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1]; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP]) +#define UAP_STACK_POINTER(ucontext) ((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_R1] +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_NIP]) } diff --git a/vm/os-linux-x86.32.hpp b/vm/os-linux-x86.32.hpp index bd2315ccef..53a93d17de 100644 --- a/vm/os-linux-x86.32.hpp +++ b/vm/os-linux-x86.32.hpp @@ -29,12 +29,6 @@ struct _fpstate { #define X86_FXSR_MAGIC 0x0000 -inline static void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.gregs[7]; -} - inline static unsigned int uap_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -54,7 +48,8 @@ inline static void uap_clear_fpu_status(void *uap) fpregs->mxcsr &= 0xffffffc0; } -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14]) + +#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[7]) +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[14]) } diff --git a/vm/os-linux-x86.64.hpp b/vm/os-linux-x86.64.hpp index 42adb3c6b8..14ba9fb002 100644 --- a/vm/os-linux-x86.64.hpp +++ b/vm/os-linux-x86.64.hpp @@ -3,12 +3,6 @@ namespace factor { -inline static void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.gregs[15]; -} - inline static unsigned int uap_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -23,7 +17,7 @@ inline static void uap_clear_fpu_status(void *uap) ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0; } -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16]) +#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[15]) +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[16]) } diff --git a/vm/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp index 2bea926890..30fd4b2081 100644 --- a/vm/os-macosx-ppc.hpp +++ b/vm/os-macosx-ppc.hpp @@ -62,7 +62,7 @@ inline static unsigned int uap_fpu_status(void *uap) return mach_fpu_status(UAP_FS(uap)); } -inline static cell fix_stack_pointer(cell sp) +template Type align_stack_pointer(Type sp) { return sp; } diff --git a/vm/os-macosx-x86.32.hpp b/vm/os-macosx-x86.32.hpp index 89906cd9a4..a6fe8e2703 100644 --- a/vm/os-macosx-x86.32.hpp +++ b/vm/os-macosx-x86.32.hpp @@ -64,9 +64,9 @@ inline static unsigned int uap_fpu_status(void *uap) return mach_fpu_status(UAP_FS(uap)); } -inline static cell fix_stack_pointer(cell sp) +template Type align_stack_pointer(Type sp) { - return ((sp + 4) & ~15) - 4; + return (Type)((((cell)sp + 4) & ~15) - 4); } inline static void mach_clear_fpu_status(i386_float_state_t *float_state) diff --git a/vm/os-macosx-x86.64.hpp b/vm/os-macosx-x86.64.hpp index fd6db4d68c..cb1980ddbf 100644 --- a/vm/os-macosx-x86.64.hpp +++ b/vm/os-macosx-x86.64.hpp @@ -62,9 +62,9 @@ inline static unsigned int uap_fpu_status(void *uap) return mach_fpu_status(UAP_FS(uap)); } -inline static cell fix_stack_pointer(cell sp) +template Type align_stack_pointer(Type sp) { - return ((sp + 8) & ~15) - 8; + return (Type)((((cell)sp + 8) & ~15) - 8); } inline static void mach_clear_fpu_status(x86_float_state64_t *float_state) diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index cdc0ff7b42..0d230f48e3 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -11,12 +11,8 @@ void early_init(); const char *vm_executable_path(); const char *default_image_path(); -inline static void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return ucontext->uc_stack.ss_sp; -} - void c_to_factor_toplevel(cell quot); +#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_stack.ss_sp) + } diff --git a/vm/os-netbsd-x86.32.hpp b/vm/os-netbsd-x86.32.hpp index f2f47ecf6c..21b3557239 100644 --- a/vm/os-netbsd-x86.32.hpp +++ b/vm/os-netbsd-x86.32.hpp @@ -3,9 +3,9 @@ namespace factor { -#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) - static inline unsigned int uap_fpu_status(void *uap) { return 0; } -static inline void uap_clear_fpu_status(void *uap) { } +static inline void uap_clear_fpu_status(void *uap) {} + +#define UAP_STACK_POINTER(ucontext) (_UC_MACHINE_SP((ucontext_t *)ucontext)) } diff --git a/vm/os-netbsd-x86.64.hpp b/vm/os-netbsd-x86.64.hpp index a9d52a6c2b..3e94998993 100644 --- a/vm/os-netbsd-x86.64.hpp +++ b/vm/os-netbsd-x86.64.hpp @@ -3,10 +3,9 @@ namespace factor { -#define ucontext_stack_pointer(uap) \ - ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP])) - static inline unsigned int uap_fpu_status(void *uap) { return 0; } -static inline void uap_clear_fpu_status(void *uap) { } +static inline void uap_clear_fpu_status(void *uap) {} + +#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.__gregs[_REG_URSP]) } diff --git a/vm/os-openbsd-x86.32.hpp b/vm/os-openbsd-x86.32.hpp index 0abd019219..34a641c235 100644 --- a/vm/os-openbsd-x86.32.hpp +++ b/vm/os-openbsd-x86.32.hpp @@ -3,16 +3,10 @@ namespace factor { -inline static void *openbsd_stack_pointer(void *uap) -{ - struct sigcontext *sc = (struct sigcontext*) uap; - return (void *)sc->sc_esp; -} - -#define ucontext_stack_pointer openbsd_stack_pointer -#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip) - static inline unsigned int uap_fpu_status(void *uap) { return 0; } -static inline void uap_clear_fpu_status(void *uap) { } +static inline void uap_clear_fpu_status(void *uap) {} + +#define UAP_STACK_POINTER(ucontext) (((struct sigcontext *)ucontext)->sc_esp) +#define UAP_PROGRAM_COUNTER(ucontext) (((struct sigcontext *)ucontext)->sc_eip) } diff --git a/vm/os-openbsd-x86.64.hpp b/vm/os-openbsd-x86.64.hpp index 9dce48ee91..032e77b154 100644 --- a/vm/os-openbsd-x86.64.hpp +++ b/vm/os-openbsd-x86.64.hpp @@ -3,16 +3,10 @@ namespace factor { -inline static void *openbsd_stack_pointer(void *uap) -{ - struct sigcontext *sc = (struct sigcontext*) uap; - return (void *)sc->sc_rsp; -} - -#define ucontext_stack_pointer openbsd_stack_pointer -#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip) - static inline unsigned int uap_fpu_status(void *uap) { return 0; } -static inline void uap_clear_fpu_status(void *uap) { } +static inline void uap_clear_fpu_status(void *uap) {} + +#define UAP_STACK_POINTER(ucontext) (((struct sigcontext *)ucontext)->sc_rsp) +#define UAP_PROGRAM_COUNTER(ucontext) (((struct sigcontext *)ucontext)->sc_rip) } diff --git a/vm/os-solaris-x86.32.hpp b/vm/os-solaris-x86.32.hpp index b89b8d541b..2ec8bc138f 100644 --- a/vm/os-solaris-x86.32.hpp +++ b/vm/os-solaris-x86.32.hpp @@ -3,13 +3,7 @@ namespace factor { -inline static void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.gregs[ESP]; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP]) +#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[ESP]) +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[EIP]) } diff --git a/vm/os-solaris-x86.64.hpp b/vm/os-solaris-x86.64.hpp index 0d3a74e11d..72a7b5c2fd 100644 --- a/vm/os-solaris-x86.64.hpp +++ b/vm/os-solaris-x86.64.hpp @@ -3,13 +3,7 @@ namespace factor { -inline static void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.gregs[RSP]; -} - -#define UAP_PROGRAM_COUNTER(ucontext) \ - (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP]) +#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RSP]) +#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RIP]) } diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 2f9d5a3c89..cd88541136 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -115,63 +115,47 @@ segment::~segment() if(retval) fatal_error("Segment deallocation failed",0); } - -stack_frame *factor_vm::uap_stack_pointer(void *uap) + +void factor_vm::dispatch_signal(void *uap, void (handler)()) { - /* There is a race condition here, but in practice a signal - delivered during stack frame setup/teardown or while transitioning - from Factor to C is a sign of things seriously gone wrong, not just - a divide by zero or stack underflow in the listener */ if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap))) { - stack_frame *ptr = (stack_frame *)ucontext_stack_pointer(uap); - if(!ptr) - critical_error("Invalid uap",(cell)uap); - return ptr; + stack_frame *ptr = (stack_frame *)UAP_STACK_POINTER(uap); + assert(ptr); + signal_callstack_top = ptr; } else - return NULL; -} + signal_callstack_top = NULL; -void factor_vm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) -{ - signal_fault_addr = (cell)siginfo->si_addr; - signal_callstack_top = uap_stack_pointer(uap); - UAP_PROGRAM_COUNTER(uap) = (cell)factor::memory_signal_handler_impl; + UAP_STACK_POINTER(uap) = align_stack_pointer(UAP_STACK_POINTER(uap)); + UAP_PROGRAM_COUNTER(uap) = (cell)handler; } void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) { - tls_vm()->memory_signal_handler(signal,siginfo,uap); -} - -void factor_vm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) -{ - signal_number = signal; - signal_callstack_top = uap_stack_pointer(uap); - UAP_PROGRAM_COUNTER(uap) = (cell)factor::misc_signal_handler_impl; + factor_vm *vm = tls_vm(); + vm->signal_fault_addr = (cell)siginfo->si_addr; + vm->dispatch_signal(uap,factor::memory_signal_handler_impl); } void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) { - tls_vm()->misc_signal_handler(signal,siginfo,uap); -} - -void factor_vm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap) -{ - signal_number = signal; - signal_callstack_top = uap_stack_pointer(uap); - signal_fpu_status = fpu_status(uap_fpu_status(uap)); - uap_clear_fpu_status(uap); - UAP_PROGRAM_COUNTER(uap) = - (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF) - ? (cell)factor::misc_signal_handler_impl - : (cell)factor::fp_signal_handler_impl; + factor_vm *vm = tls_vm(); + vm->signal_number = signal; + vm->dispatch_signal(uap,factor::misc_signal_handler_impl); } void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap) { - tls_vm()->fpe_signal_handler(signal, siginfo, uap); + factor_vm *vm = tls_vm(); + vm->signal_number = signal; + vm->signal_fpu_status = fpu_status(uap_fpu_status(uap)); + uap_clear_fpu_status(uap); + + vm->dispatch_signal(uap, + (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF) + ? factor::misc_signal_handler_impl + : factor::fp_signal_handler_impl); } static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact) diff --git a/vm/vm.hpp b/vm/vm.hpp index 202996ce26..2c85b8ec49 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -689,17 +689,12 @@ struct factor_vm void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length); bool windows_stat(vm_char *path); - #if defined(WINNT) + #if defined(WINNT) void open_console(); LONG exception_handler(PEXCEPTION_POINTERS pe); - // next method here: - #endif + #endif #else // UNIX - void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap); - void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap); - void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap); - stack_frame *uap_stack_pointer(void *uap); - + void dispatch_signal(void *uap, void (handler)()); #endif #ifdef __APPLE__