diff --git a/Makefile b/Makefile index 2ea43706f4..52914d128a 100755 --- a/Makefile +++ b/Makefile @@ -58,6 +58,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/math.o \ vm/nursery_collector.o \ vm/object_start_map.o \ + vm/objects.o \ vm/primitives.o \ vm/profiler.o \ vm/quotations.o \ diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 04ee02a5d7..a2ce533afd 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -588,5 +588,4 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; ! Regression: calling an undefined function would raise a protection fault FUNCTION: void this_does_not_exist ( ) ; -[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with - +[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index a26ba5a27a..b2159e9c09 100755 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -21,7 +21,6 @@ IN: compiler.tests.intrinsics [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test -[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 4bf4cf88f0..63f145d752 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -51,7 +51,6 @@ MATCH-VARS: ?a ?b ?c ; { { { ?b ?a } { ?a ?b } } [ swap ] } { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] } { { { ?a ?b } { ?a ?a ?b } } [ dupd ] } - { { { ?a ?b } { ?b ?a ?b } } [ tuck ] } { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] } { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] } { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] } diff --git a/basis/compiler/tree/propagation/recursive/recursive-tests.factor b/basis/compiler/tree/propagation/recursive/recursive-tests.factor index 974bb584eb..42325d97ca 100644 --- a/basis/compiler/tree/propagation/recursive/recursive-tests.factor +++ b/basis/compiler/tree/propagation/recursive/recursive-tests.factor @@ -27,14 +27,16 @@ IN: compiler.tree.propagation.recursive.tests ] unit-test [ t ] [ + T{ interval f { -268435456 t } { 268435455 t } } T{ interval f { 1 t } { 268435455 t } } - T{ interval f { -268435456 t } { 268435455 t } } tuck + over integer generalize-counter-interval = ] unit-test [ t ] [ + T{ interval f { -268435456 t } { 268435455 t } } T{ interval f { 1 t } { 268435455 t } } - T{ interval f { -268435456 t } { 268435455 t } } tuck + over fixnum generalize-counter-interval = ] unit-test diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 1f40bf00a2..ff68fb2400 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -3,7 +3,7 @@ USING: kernel sequences words fry generic accessors classes.tuple classes classes.algebra definitions stack-checker.state quotations classes.tuple.private math -math.partial-dispatch math.private math.intervals +math.partial-dispatch math.private math.intervals sets.private math.floats.private math.integers.private layouts math.order vectors hashtables combinators effects generalizations assocs sets combinators.short-circuit sequences.private locals @@ -290,3 +290,13 @@ CONSTANT: lookup-table-at-max 256 ] [ drop f ] if ; \ at* [ at-quot ] 1 define-partial-eval + +: diff-quot ( seq -- quot: ( seq' -- seq'' ) ) + tester '[ [ @ not ] filter ] ; + +\ diff [ diff-quot ] 1 define-partial-eval + +: intersect-quot ( seq -- quot: ( seq' -- seq'' ) ) + tester '[ _ filter ] ; + +\ intersect [ intersect-quot ] 1 define-partial-eval diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index cde2a7e113..ce25cd6a63 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators grouping kernel locals math -math.matrices math.order multiline sequence-parser sequences +math.matrices math.order multiline sequences.parser sequences tools.continuations ; IN: compression.run-length diff --git a/basis/core-text/core-text-tests.factor b/basis/core-text/core-text-tests.factor index a5cf69fdee..b6b54df7c3 100644 --- a/basis/core-text/core-text-tests.factor +++ b/basis/core-text/core-text-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test core-text core-text.fonts core-foundation core-foundation.dictionaries destructors arrays kernel generalizations -math accessors core-foundation.utilities combinators hashtables colors +locals math accessors core-foundation.utilities combinators hashtables colors colors.constants ; IN: core-text.tests @@ -18,10 +18,11 @@ IN: core-text.tests ] with-destructors ] unit-test -: test-typographic-bounds ( string font -- ? ) +:: test-typographic-bounds ( string font -- ? ) [ - test-font &CFRelease tuck COLOR: white &CFRelease - compute-line-metrics { + font test-font &CFRelease :> ctfont + string ctfont COLOR: white &CFRelease :> ctline + ctfont ctline compute-line-metrics { [ width>> float? ] [ ascent>> float? ] [ descent>> float? ] @@ -33,4 +34,4 @@ IN: core-text.tests [ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test -[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test \ No newline at end of file +[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index c16d564e13..5d3caca206 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -329,14 +329,6 @@ CONSTANT: rs-reg 14 3 ds-reg 4 STWU ] \ dupd define-sub-primitive -[ - 3 ds-reg 0 LWZ - 4 ds-reg -4 LWZ - 3 ds-reg 4 STWU - 4 ds-reg -4 STW - 3 ds-reg -8 STW -] \ tuck define-sub-primitive - [ 3 ds-reg 0 LWZ 4 ds-reg -4 LWZ diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 98a5188962..c993a1fdec 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -335,15 +335,6 @@ big-endian off ds-reg [] temp0 MOV ] \ dupd define-sub-primitive -[ - temp0 ds-reg [] MOV - temp1 ds-reg -1 bootstrap-cells [+] MOV - ds-reg bootstrap-cell ADD - ds-reg [] temp0 MOV - ds-reg -1 bootstrap-cells [+] temp1 MOV - ds-reg -2 bootstrap-cells [+] temp0 MOV -] \ tuck define-sub-primitive - [ temp0 ds-reg [] MOV temp1 ds-reg bootstrap-cell neg [+] MOV diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 6ba8e2d5b8..829637b4aa 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -70,11 +70,12 @@ IN: csv.tests "can write csv too!" [ "foo1,bar1\nfoo2,bar2\n" ] -[ { { "foo1" "bar1" } { "foo2" "bar2" } } tuck write-csv >string ] named-unit-test +[ { { "foo1" "bar1" } { "foo2" "bar2" } } [ write-csv ] keep >string ] named-unit-test + "escapes quotes commas and newlines when writing" [ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ] -[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } tuck write-csv >string ] named-unit-test ! " +[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } [ write-csv ] keep >string ] named-unit-test ! " [ { { "writing" "some" "csv" "tests" } } ] [ diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index ffcbec70d0..8d26d3b098 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint fry sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators -math.intervals io nmake accessors vectors math.ranges random +math.intervals io locals nmake accessors vectors math.ranges random math.bitwise db.queries destructors db.tuples.private interpolate io.streams.string make db.private sequences.deep db.errors.sqlite ; @@ -85,12 +85,11 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) nip [ key>> ] [ value>> ] [ type>> ] tri ; -M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) - tuck - [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi - rot set-slot-named - [ [ key>> ] [ type>> ] bi ] dip - swap ; +M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) + generate-bind generator-singleton>> eval-generator :> obj + generate-bind slot-name>> :> name + obj name tuple set-slot-named + generate-bind key>> obj generate-bind type>> ; M: sqlite-statement bind-tuple ( tuple statement -- ) [ diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index 87e70d69e7..4bcd9c5b78 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -129,9 +129,6 @@ HELP: c-string-error. HELP: ffi-error. { $error-description "Thrown by " { $link dlopen } " and " { $link dlsym } " if a problem occurs while loading a native library or looking up a symbol. See " { $link "alien" } "." } ; -HELP: heap-scan-error. -{ $error-description "Thrown if " { $link next-object } " is called outside of a " { $link begin-scan } "/" { $link end-scan } " pair." } ; - HELP: undefined-symbol-error. { $error-description "Thrown if a previously-compiled " { $link alien-invoke } " call refers to a native library symbol which no longer exists." } ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 690e631e81..f1e23b18f5 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -103,9 +103,6 @@ HOOK: signal-error. os ( obj -- ) : ffi-error. ( obj -- ) "FFI error" print drop ; -: heap-scan-error. ( obj -- ) - "Cannot do next-object outside begin/end-scan" print drop ; - : undefined-symbol-error. ( obj -- ) "The image refers to a library or symbol that was not found at load time" print drop ; @@ -148,14 +145,13 @@ PREDICATE: vm-error < array { 6 [ array-size-error. ] } { 7 [ c-string-error. ] } { 8 [ ffi-error. ] } - { 9 [ heap-scan-error. ] } - { 10 [ undefined-symbol-error. ] } - { 11 [ datastack-underflow. ] } - { 12 [ datastack-overflow. ] } - { 13 [ retainstack-underflow. ] } - { 14 [ retainstack-overflow. ] } - { 15 [ memory-error. ] } - { 16 [ fp-trap-error. ] } + { 9 [ undefined-symbol-error. ] } + { 10 [ datastack-underflow. ] } + { 11 [ datastack-overflow. ] } + { 12 [ retainstack-underflow. ] } + { 13 [ retainstack-overflow. ] } + { 14 [ memory-error. ] } + { 15 [ fp-trap-error. ] } } ; inline M: vm-error summary drop "VM error" ; diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 9602933785..b3d2ff296e 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -2,17 +2,20 @@ USING: help.markup help.syntax quotations kernel ; IN: fry HELP: _ -{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ; +{ $description "Fry specifier. Inserts a literal value into the fried quotation." } +{ $examples "See " { $link "fry.examples" } "." } ; HELP: @ -{ $description "Fry specifier. Splices a quotation into the fried quotation." } ; +{ $description "Fry specifier. Splices a quotation into the fried quotation." } +{ $examples "See " { $link "fry.examples" } "." } ; HELP: fry { $values { "quot" quotation } { "quot'" quotation } } { $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." } { $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:" { $code "[ X ] fry call" "'[ X ]" } -} ; +} +{ $examples "See " { $link "fry.examples" } "." } ; HELP: '[ { $syntax "'[ code... ]" } @@ -59,7 +62,6 @@ $nl { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } { { $link curry } { $snippet ": curry '[ _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } - { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } } } ; ARTICLE: "fry.philosophy" "Fried quotation philosophy" diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index 549db25e09..10d9b282ad 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -1,18 +1,41 @@ +! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license USING: fry tools.test math prettyprint kernel io arrays sequences eval accessors ; IN: fry.tests +SYMBOLS: a b c d e f g h ; + +[ [ 1 ] ] [ 1 '[ _ ] ] unit-test +[ [ 1 ] ] [ [ 1 ] '[ @ ] ] unit-test +[ [ 1 2 ] ] [ [ 1 ] [ 2 ] '[ @ @ ] ] unit-test + +[ [ 1 2 a ] ] [ 1 2 '[ _ _ a ] ] unit-test +[ [ 1 2 ] ] [ 1 2 '[ _ _ ] ] unit-test +[ [ a 1 2 ] ] [ 1 2 '[ a _ _ ] ] unit-test +[ [ 1 2 a ] ] [ [ 1 ] [ 2 ] '[ @ @ a ] ] unit-test +[ [ 1 a 2 b ] ] [ 1 2 '[ _ a _ b ] ] unit-test +[ [ 1 a 2 b ] ] [ 1 [ 2 ] '[ _ a @ b ] ] unit-test +[ [ a 1 b ] ] [ 1 '[ a _ b ] ] unit-test + +[ [ a 1 b ] ] [ [ 1 ] '[ a @ b ] ] unit-test +[ [ a 1 2 ] ] [ [ 1 ] [ 2 ] '[ a @ @ ] ] unit-test + +[ [ a [ 1 ] b ] ] [ 1 '[ a [ _ ] b ] ] unit-test +[ [ a 1 b [ c 2 d ] e 3 f ] ] [ 1 2 3 '[ a _ b [ c _ d ] e _ f ] ] unit-test +[ [ a 1 b [ c 2 d [ e 3 f ] ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ c _ d [ e _ f ] ] g _ h ] ] unit-test +[ [ a 1 b [ [ c 2 d ] e 3 f ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ [ c _ d ] e _ f ] g _ h ] ] unit-test + [ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test [ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test -[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test +[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test -[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test +[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test -[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test +[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test -[ [ "a" "b" [ write ] dip print ] ] +[ [ "a" write "b" print ] ] [ "a" "b" '[ _ write _ print ] ] unit-test [ 1/2 ] [ diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index 184c6247a6..60c76b726f 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -1,7 +1,6 @@ -! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences combinators parser splitting math -quotations arrays make words locals.backend summary sets ; +! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license +USING: accessors combinators kernel locals.backend math parser +quotations sequences sets splitting words ; IN: fry : _ ( -- * ) "Only valid inside a fry" throw ; @@ -9,21 +8,10 @@ IN: fry ERROR: >r/r>-in-fry-error ; +GENERIC: fry ( quot -- quot' ) + ] - } case ; - -M: >r/r>-in-fry-error summary - drop - "Explicit retain stack manipulation is not permitted in fried quotations" ; - : check-fry ( quot -- quot ) dup { load-local load-locals get-local drop-locals } intersect [ >r/r>-in-fry-error ] unless-empty ; @@ -36,21 +24,119 @@ M: callable count-inputs [ count-inputs ] map-sum ; M: fry-specifier count-inputs drop 1 ; M: object count-inputs drop 0 ; -GENERIC: deep-fry ( obj -- ) +MIXIN: fried +PREDICATE: fried-callable < callable + count-inputs 0 > ; +INSTANCE: fried-callable fried -: shallow-fry ( quot -- quot' curry# ) - check-fry - [ [ deep-fry ] each ] [ ] make - [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat - { _ } split [ spread>quot ] [ length 1 - ] bi ; +: (ncurry) ( quot n -- quot ) + { + { 0 [ ] } + { 1 [ \ curry suffix! ] } + { 2 [ \ 2curry suffix! ] } + { 3 [ \ 3curry suffix! ] } + [ [ \ 3curry suffix! ] dip 3 - (ncurry) ] + } case ; + +: [ncurry] ( n -- quot ) + [ V{ } clone ] dip (ncurry) >quotation ; + +: [ndip] ( quot n -- quot' ) + { + { 0 [ ] } + { 1 [ \ dip [ ] 2sequence ] } + { 2 [ \ 2dip [ ] 2sequence ] } + { 3 [ \ 3dip [ ] 2sequence ] } + [ [ \ 3dip [ ] 2sequence ] dip 3 - [ndip] ] + } case ; + +: (make-curry) ( tail quot -- quot' ) + swap [ncurry] curry [ compose ] compose ; + +: make-compose ( consecutive quot -- consecutive quot' ) + [ + [ [ ] ] + [ [ncurry] ] if-zero + ] [ + [ [ compose ] ] + [ [ compose compose ] curry ] if-empty + ] bi* compose + 0 swap ; + +: make-curry ( consecutive quot -- consecutive' quot' ) + [ 1 + ] dip + [ [ ] ] [ (make-curry) 0 swap ] if-empty ; + +: convert-curry ( consecutive quot -- consecutive' quot' ) + [ [ ] make-curry ] [ + dup first \ @ = + [ rest >quotation make-compose ] + [ >quotation make-curry ] if + ] if-empty ; + +: prune-curries ( seq -- seq' ) + dup [ empty? not ] find + [ [ 1 + tail ] dip but-last prefix ] + [ 2drop { } ] if* ; + +: convert-curries ( seq -- tail seq' ) + unclip-slice [ 0 swap [ convert-curry ] map ] dip + [ prune-curries ] + [ >quotation 1quotation prefix ] if-empty ; + +: mark-composes ( quot -- quot' ) + [ dup \ @ = [ drop [ _ @ ] ] [ 1quotation ] if ] map concat ; inline + +: shallow-fry ( quot -- quot' ) + check-fry mark-composes + { _ } split convert-curries + [ [ [ ] ] [ [ ] (make-curry) but-last ] if-zero ] + [ spread>quot swap [ [ ] (make-curry) compose ] unless-zero ] if-empty ; + +DEFER: dredge-fry + +TUPLE: dredge-fry-state + { in-quot read-only } + { prequot read-only } + { quot read-only } ; + +: ( quot -- dredge-fry ) + V{ } clone V{ } clone dredge-fry-state boa ; inline + +: in-quot-slices ( n i state -- head tail ) + in-quot>> + [ ] + [ [ drop ] 2dip swap 1 + tail-slice ] 3bi ; inline + +: push-head-slice ( head state -- ) + quot>> [ push-all ] [ \ _ swap push ] bi ; inline + +: push-subquot ( tail elt state -- ) + [ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline + +: (dredge-fry-subquot) ( n state i elt -- ) + rot { + [ nip in-quot-slices ] ! head tail i elt state + [ [ 2drop swap ] dip push-head-slice ] + [ [ drop ] 2dip push-subquot ] + [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ] + } 3cleave ; inline recursive + +: (dredge-fry-simple) ( n state -- ) + [ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive + +: dredge-fry ( n dredge-fry -- ) + 2dup in-quot>> [ fried? ] find-from + [ (dredge-fry-subquot) ] + [ drop (dredge-fry-simple) ] if* ; inline recursive PRIVATE> -: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ; - -M: callable deep-fry - [ count-inputs \ _ % ] [ fry % ] bi ; - -M: object deep-fry , ; +M: callable fry ( quot -- quot' ) + 0 swap + [ dredge-fry ] [ + [ prequot>> >quotation ] + [ quot>> >quotation shallow-fry ] bi append + ] bi ; SYNTAX: '[ parse-quotation fry append! ; diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index 377a89a884..954602cf06 100755 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -75,9 +75,8 @@ SYMBOLS: get-controllers [ product-id = ] with filter ; : find-controller-instance ( product-id instance-id -- controller/f ) get-controllers [ - tuck [ product-id = ] - [ instance-id = ] 2bi* and + [ instance-id = ] bi-curry bi* and ] with with find nip ; TUPLE: keyboard-state keys ; diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index e9a709030e..5b869f138e 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -212,7 +212,7 @@ HELP: nwith } ; HELP: napply -{ $values { "n" integer } } +{ $values { "quot" quotation } { "n" integer } } { $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth." } { $examples @@ -332,18 +332,6 @@ HELP: nappend-as { nappend nappend-as } related-words -HELP: ntuck -{ $values - { "n" integer } -} -{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; - -HELP: nspin -{ $values - { "n" integer } -} -{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ; - ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsections narray @@ -363,8 +351,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" -nrot nnip ndrop - ntuck - nspin mnswap nweave } ; diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index c54e35002f..546413447e 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -26,8 +26,6 @@ IN: generalizations.tests { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test [ [ 1 ] 5 ndip ] must-infer [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test -[ 5 nspin ] must-infer -[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 8d6d6f2ac0..6c8a0b5fde 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -71,9 +71,6 @@ MACRO: ndrop ( n -- ) MACRO: nnip ( n -- ) '[ [ _ ndrop ] dip ] ; -MACRO: ntuck ( n -- ) - 2 + '[ dup _ -nrot ] ; - MACRO: ndip ( n -- ) [ [ dip ] curry ] n*quot [ call ] compose ; @@ -112,8 +109,8 @@ MACRO: cleave* ( n -- ) [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ] if-zero ; -MACRO: napply ( n -- ) - [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ; +: napply ( quot n -- ) + [ dupn ] [ spread* ] bi ; inline : apply-curry ( ...a quot n -- ) [ [curry] ] dip napply ; inline @@ -139,6 +136,3 @@ MACRO: nbi-curry ( n -- ) : nappend ( n -- seq ) narray concat ; inline -MACRO: nspin ( n -- ) - [ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ; - diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor index 56a2cb9142..46bdc698b7 100644 --- a/basis/hints/hints-docs.factor +++ b/basis/hints/hints-docs.factor @@ -20,7 +20,7 @@ HELP: specialized-def { $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; HELP: HINTS: -{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } } +{ $values { "defspec" "a word or method" } { "hints..." "a list of sequences of classes or literals" } } { $description "Defines specialization hints for a word or a method." $nl "Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." } @@ -35,8 +35,8 @@ $nl "M: assoc count-occurrences" " swap [ = nip ] curry assoc-filter assoc-size ;" "" - "HINTS: { sequence count-occurrences } { object array } ;" - "HINTS: { assoc count-occurrences } { object hashtable } ;" + "HINTS: M\ sequence count-occurrences { object array } ;" + "HINTS: M\ assoc count-occurrences { object hashtable } ;" } } ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 4f10808b04..e305c8477a 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays combinators -grouping compression.huffman images +grouping compression.huffman images fry images.processing io io.binary io.encodings.binary io.files io.streams.byte-array kernel locals math math.bitwise math.constants math.functions math.matrices math.order @@ -232,7 +232,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; block dup length>> sqrt >fixnum group flip dup matrix-dim coord-matrix flip [ - [ first2 spin nth nth ] + [ '[ _ [ second ] [ first ] bi ] dip nth nth ] [ x,y v+ color-id jpeg-image draw-color ] bi ] with each^2 ; @@ -295,7 +295,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; binary [ [ { HEX: FF } read-until - read1 tuck HEX: 00 = and + read1 [ HEX: 00 = and ] keep swap ] [ drop ] produce swap >marker { EOI } assert= diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index cb9a347de1..26c3ebee34 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -290,6 +290,14 @@ ERROR: invalid-color-type/bit-depth loading-png ; : validate-truecolor-alpha ( loading-png -- loading-png ) { 8 16 } validate-bit-depth ; +: pad-bitmap ( image -- image ) + dup dim>> first 4 divisor? [ + dup [ bytes-per-pixel ] + [ dim>> first * ] + [ dim>> first 4 mod ] tri + '[ _ group [ _ 0 append ] map B{ } concat-as ] change-bitmap + ] unless ; + : loading-png>bitmap ( loading-png -- bytes component-order ) dup color-type>> { { greyscale [ @@ -315,7 +323,7 @@ ERROR: invalid-color-type/bit-depth loading-png ; [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ] [ [ width>> ] [ height>> ] bi 2array >>dim ] [ png-component >>component-type ] - } cleave ; + } cleave pad-bitmap ; : load-png ( stream -- loading-png ) [ diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 1e941afed0..4ecb1e12a8 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -141,7 +141,6 @@ MACRO: undo ( quot -- ) [undo] ; \ 2dup [ over =/fail over =/fail ] define-inverse \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse \ pick [ [ pick ] dip =/fail ] define-inverse -\ tuck [ swapd [ =/fail ] keep ] define-inverse \ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse \ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 452dc4a409..1301d69913 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -50,16 +50,17 @@ M: winnt add-completion ( win32-handle -- ) } cond ] with-timeout ; -:: wait-for-overlapped ( us -- bytes-transferred overlapped error? ) +:: wait-for-overlapped ( usec -- bytes-transferred overlapped error? ) master-completion-port get-global - 0 [ ! bytes - f ! key - f [ ! overlapped - us [ 1000 /i ] [ INFINITE ] if* ! timeout - GetQueuedCompletionStatus zero? - ] keep - *void* dup [ OVERLAPPED memory>struct ] when - ] keep *int spin ; + 0 :> bytes + f :> key + f :> overlapped + usec [ 1000 /i ] [ INFINITE ] if* :> timeout + bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error? + + bytes *int + overlapped *void* dup [ OVERLAPPED memory>struct ] when + error? ; : resume-callback ( result overlapped -- ) >c-ptr pending-overlapped get-global delete-at* drop resume-with ; diff --git a/basis/io/buffers/buffers-tests.factor b/basis/io/buffers/buffers-tests.factor index d366df7c54..93d2f5b2fc 100644 --- a/basis/io/buffers/buffers-tests.factor +++ b/basis/io/buffers/buffers-tests.factor @@ -8,7 +8,7 @@ strings accessors destructors ; [ length ] dip buffer-reset ; : string>buffer ( string -- buffer ) - dup length tuck buffer-set ; + dup length [ buffer-set ] keep ; : buffer-read-all ( buffer -- byte-array ) [ [ pos>> ] [ ptr>> ] bi ] diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 5ae21fcfee..6bd3f77ffa 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -151,12 +151,16 @@ PRIVATE> M: winnt file-system-info ( path -- file-system-info ) normalize-path root-directory (file-system-info) ; -: volume>paths ( string -- array ) - 16384 tuck dup length - 0 dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [ - win32-error-string throw +:: volume>paths ( string -- array ) + 16384 :> names-buf-length + names-buf-length :> names + 0 :> names-length + + string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret + ret 0 = [ + ret win32-error-string throw ] [ - *uint "ushort" heap-size * head + names names-length *uint "ushort" heap-size * head utf16n alien>string CHAR: \0 split ] if ; @@ -166,13 +170,16 @@ M: winnt file-system-info ( path -- file-system-info ) FindFirstVolume dup win32-error=0/f [ utf16n alien>string ] dip ; -: find-next-volume ( handle -- string/f ) - MAX_PATH 1 + [ tuck ] keep - FindNextVolume 0 = [ +:: find-next-volume ( handle -- string/f ) + MAX_PATH 1 + :> buf-length + buf-length :> buf + + handle buf buf-length FindNextVolume :> ret + ret 0 = [ GetLastError ERROR_NO_MORE_FILES = [ drop f ] [ win32-error-string throw ] if ] [ - utf16n alien>string + buf utf16n alien>string ] if ; : find-volumes ( -- array ) diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 6cae50bd9e..8a800115f6 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -132,7 +132,7 @@ M: windows run-process* ( process -- handle ) current-directory get absolute-path cd dup make-CreateProcess-args - tuck fill-redirection + [ fill-redirection ] keep dup call-CreateProcess lpProcessInformation>> ] with-destructors ; diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index 8fb638b856..39f92158a6 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -35,5 +35,7 @@ IN: lists.lazy.tests [ [ drop ] leach ] must-infer [ lnth ] must-infer +[ { 1 2 3 } ] [ { 1 2 3 4 5 } >list [ 2 > ] luntil list>array ] unit-test + [ ] [ "resource:license.txt" utf8 llines list>array drop ] unit-test [ ] [ "resource:license.txt" utf8 lcontents list>array drop ] unit-test diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 7b386e9c81..122a2205dd 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -111,14 +111,15 @@ C: lazy-until over nil? [ drop ] [ ] if ; M: lazy-until car ( lazy-until -- car ) - cons>> car ; + cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) - [ 2drop nil ] [ luntil ] if ; + [ [ cons>> cdr ] [ quot>> ] bi ] + [ [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ] bi + [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- ? ) - drop f ; + drop f ; TUPLE: lazy-while cons quot ; @@ -128,13 +129,13 @@ C: lazy-while over nil? [ drop ] [ ] if ; M: lazy-while car ( lazy-while -- car ) - cons>> car ; + cons>> car ; M: lazy-while cdr ( lazy-while -- cdr ) - [ cons>> cdr ] keep quot>> lwhile ; + [ cons>> cdr ] keep quot>> lwhile ; M: lazy-while nil? ( lazy-while -- ? ) - [ car ] keep quot>> call( elt -- ? ) not ; + [ car ] keep quot>> call( elt -- ? ) not ; TUPLE: lazy-filter cons quot ; diff --git a/basis/locals/fry/fry.factor b/basis/locals/fry/fry.factor index ff6a491a79..a2a1a6c178 100644 --- a/basis/locals/fry/fry.factor +++ b/basis/locals/fry/fry.factor @@ -1,18 +1,21 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: accessors fry fry.private generalizations kernel -locals.types make sequences ; +locals.types sequences ; IN: locals.fry ! Support for mixing locals with fry M: let count-inputs body>> count-inputs ; - M: lambda count-inputs body>> count-inputs ; -M: lambda deep-fry - clone [ shallow-fry swap ] change-body - [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ; +M: lambda fry + clone [ [ count-inputs ] [ fry ] bi ] change-body + [ [ vars>> length ] keep '[ _ _ mnswap _ call ] ] + [ drop [ncurry] curry [ call ] compose ] 2bi ; -M: let deep-fry - clone [ fry '[ @ call ] ] change-body , ; +M: let fry + clone [ fry ] change-body ; + +INSTANCE: lambda fried +INSTANCE: let fried diff --git a/basis/locals/macros/macros.factor b/basis/locals/macros/macros.factor index e64693f2a3..1f9525e5eb 100644 --- a/basis/locals/macros/macros.factor +++ b/basis/locals/macros/macros.factor @@ -14,4 +14,4 @@ M: let expand-macros* expand-macros literal ; M: lambda condomize? drop t ; -M: lambda condomize '[ @ ] ; +M: lambda condomize [ call ] curry ; diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 8d057de720..8fa41c5026 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -78,10 +78,10 @@ PRIVATE> : n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline : n*V ( alpha x -- alpha*x ) clone n*V! ; inline -: V+ ( x y -- x+y ) - 1.0 -rot n*V+V ; inline -: V- ( x y -- x-y ) - -1.0 spin n*V+V ; inline +:: V+ ( x y -- x+y ) + 1.0 x y n*V+V ; inline +:: V- ( x y -- x-y ) + -1.0 y x n*V+V ; inline : Vneg ( x -- -x ) -1.0 swap n*V ; inline diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index bc09f9fe0f..5c03e41870 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -96,9 +96,9 @@ C: combo initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; -: combination-indices ( m combo -- seq ) - [ tuck dual-index combinadic ] keep - seq>> length 1 - swap [ - ] with map ; +:: combination-indices ( m combo -- seq ) + combo m combo dual-index combinadic + combo seq>> length 1 - swap [ - ] with map ; : apply-combination ( m combo -- seq ) [ combination-indices ] keep seq>> nths ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 1ee4e1e100..a569b4af7b 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -79,7 +79,7 @@ IN: math.intervals.tests [ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test -[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test +[ t ] [ 1 2 [a,b] empty-interval over interval-union = ] unit-test [ t ] [ 0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] = @@ -250,7 +250,7 @@ IN: math.intervals.tests dup full-interval eq? [ drop 32 random-bits 31 2^ - ] [ - dup to>> first over from>> first tuck - random + + [ ] [ from>> first ] [ to>> first ] tri over - random + 2dup swap interval-contains? [ nip ] [ diff --git a/basis/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor index 8411447aac..5c154a6820 100755 --- a/basis/math/matrices/elimination/elimination.factor +++ b/basis/math/matrices/elimination/elimination.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.vectors math.matrices namespaces -sequences ; +USING: kernel locals math math.vectors math.matrices +namespaces sequences ; IN: math.matrices.elimination SYMBOL: matrix @@ -85,12 +85,11 @@ SYMBOL: matrix ] each ] with-matrix ; -: basis-vector ( row col# -- ) - [ clone ] dip - [ swap nth neg recip ] 2keep - [ 0 spin set-nth ] 2keep - [ n*v ] dip - matrix get set-nth ; +:: basis-vector ( row col# -- ) + row clone :> row' + col# row' nth neg recip :> a + 0 col# row' set-nth + a row n*v col# matrix get set-nth ; : nullspace ( matrix -- seq ) echelon reduced dup empty? [ diff --git a/basis/math/ratios/ratios-tests.factor b/basis/math/ratios/ratios-tests.factor index 8124fcdd24..153d650914 100644 --- a/basis/math/ratios/ratios-tests.factor +++ b/basis/math/ratios/ratios-tests.factor @@ -84,8 +84,8 @@ unit-test [ 1.0 ] [ 0.5 1/2 + ] unit-test [ 1.0 ] [ 1/2 0.5 + ] unit-test -[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test +[ 1/134217728 ] [ -1 -134217728 >fixnum / ] unit-test +[ 134217728 ] [ -134217728 >fixnum -1 / ] unit-test [ 5 ] [ "10/2" string>number ] diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor index 3b6e7d62ba..9834f44add 100644 --- a/basis/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -98,6 +98,19 @@ HELP: histogram* } { $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ; +HELP: sorted-histogram +{ $values + { "seq" sequence } + { "alist" "an array of key/value pairs" } +} +{ $description "Outputs a " { $link histogram } " of a sequence sorted by number of occurences from lowest to highest." } +{ $examples + { $example "USING: prettyprint math.statistics ;" + """"abababbbbbbc" sorted-histogram .""" + "{ { 99 1 } { 97 3 } { 98 8 } }" + } +} ; + HELP: sequence>assoc { $values { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" } @@ -145,6 +158,7 @@ ARTICLE: "histogram" "Computing histograms" { $subsections histogram histogram* + sorted-histogram } "Combinators for implementing histogram:" { $subsections diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 9c72b848ca..73a87ffb72 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -79,6 +79,9 @@ PRIVATE> : histogram ( seq -- hashtable ) [ inc-at ] sequence>hashtable ; +: sorted-histogram ( seq -- alist ) + histogram >alist sort-values ; + : collect-values ( seq quot: ( obj hashtable -- ) -- hash ) '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor index eea31dd34e..d66fdd0c08 100644 --- a/basis/persistent/hashtables/hashtables-tests.factor +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -1,6 +1,6 @@ IN: persistent.hashtables.tests USING: persistent.hashtables persistent.assocs hashtables assocs -tools.test kernel namespaces random math.ranges sequences fry ; +tools.test kernel locals namespaces random math.ranges sequences fry ; [ t ] [ PH{ } assoc-empty? ] unit-test @@ -86,7 +86,7 @@ M: hash-0-b hashcode* 2drop 0 ; : random-assocs ( n -- hash phash ) [ random-string ] replicate [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ] - [ PH{ } clone swap [ spin new-at ] each-index ] + [ PH{ } clone swap [| ph elt i | i elt ph new-at ] each-index ] bi ; : ok? ( assoc1 assoc2 -- ? ) diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor index 0179216e62..256baabd5e 100644 --- a/basis/persistent/hashtables/hashtables.factor +++ b/basis/persistent/hashtables/hashtables.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentHashMap by Rich Hickey. USING: kernel math accessors assocs fry combinators parser -prettyprint.custom make +prettyprint.custom locals make persistent.assocs persistent.hashtables.nodes persistent.hashtables.nodes.empty @@ -38,8 +38,8 @@ M: persistent-hash pluck-at M: persistent-hash >alist [ root>> >alist% ] { } make ; -: >persistent-hash ( assoc -- phash ) - T{ persistent-hash } swap [ spin new-at ] assoc-each ; +:: >persistent-hash ( assoc -- phash ) + T{ persistent-hash } assoc [| ph k v | v k ph new-at ] assoc-each ; M: persistent-hash equal? over persistent-hash? [ assoc= ] [ 2drop f ] if ; diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 2527959f32..b02604e9bd 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -58,7 +58,7 @@ M: persistent-vector nth-unsafe [ 2array ] [ drop level>> 1 + ] 2bi node boa ; : new-child ( new-child node -- node' expansion/f ) - dup full? [ tuck level>> 1node ] [ node-add f ] if ; + dup full? [ [ level>> 1node ] keep swap ] [ node-add f ] if ; : new-last ( val seq -- seq' ) [ length 1 - ] keep new-nth ; @@ -70,7 +70,7 @@ M: persistent-vector nth-unsafe dup level>> 1 = [ new-child ] [ - tuck children>> last (ppush-new-tail) + [ nip ] 2keep children>> last (ppush-new-tail) [ swap new-child ] [ swap node-set-last f ] ?if ] if ; diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index 2de4e8b0e0..fa75232fd5 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -25,7 +25,7 @@ IN: regexp.dfa ] unless ; : epsilon-table ( states nfa -- table ) - [ H{ } clone tuck ] dip + [ [ H{ } clone ] dip over ] dip '[ _ _ t epsilon-loop ] each ; : find-epsilon-closure ( states nfa -- dfa-state ) diff --git a/basis/regexp/disambiguate/disambiguate.factor b/basis/regexp/disambiguate/disambiguate.factor index 876d898cb4..fcde135cf8 100644 --- a/basis/regexp/disambiguate/disambiguate.factor +++ b/basis/regexp/disambiguate/disambiguate.factor @@ -44,12 +44,12 @@ TUPLE: parts in out ; [ _ meaningful-integers ] keep add-out ] map ; -: class-partitions ( classes -- assoc ) - [ integer? ] partition [ - dup powerset-partition spin add-integers - [ [ partition>class ] keep 2array ] map - [ first ] filter - ] [ '[ _ singleton-partition ] map ] 2bi append ; +:: class-partitions ( classes -- assoc ) + classes [ integer? ] partition :> ( integers classes ) + + classes powerset-partition classes integers add-integers + [ [ partition>class ] keep 2array ] map [ first ] filter + integers [ classes singleton-partition ] map append ; : new-transitions ( transitions -- assoc ) ! assoc is class, partition values [ keys ] gather diff --git a/basis/regexp/minimize/minimize.factor b/basis/regexp/minimize/minimize.factor index 1885144e6c..a6eb4f00a2 100644 --- a/basis/regexp/minimize/minimize.factor +++ b/basis/regexp/minimize/minimize.factor @@ -85,7 +85,7 @@ IN: regexp.minimize '[ _ delete-duplicates ] change-transitions ; : combine-state-transitions ( hash -- hash ) - H{ } clone tuck '[ + [ H{ } clone ] dip over '[ _ [ 2array ] change-at ] assoc-each [ swap ] assoc-map ; diff --git a/basis/roman/roman-tests.factor b/basis/roman/roman-tests.factor index a510514e23..c7ab7fafd9 100644 --- a/basis/roman/roman-tests.factor +++ b/basis/roman/roman-tests.factor @@ -29,7 +29,7 @@ USING: arrays kernel math roman roman.private sequences tools.test ; [ 3444 ] [ 3444 >roman roman> ] unit-test [ 3999 ] [ 3999 >roman roman> ] unit-test [ 0 >roman ] must-fail -[ 4000 >roman ] must-fail +[ 40000 >roman ] must-fail [ "vi" ] [ "iii" "iii" roman+ ] unit-test [ "viii" ] [ "x" "ii" roman- ] unit-test [ "ix" ] [ "iii" "iii" roman* ] unit-test diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index f8c7da9ab4..a645898c03 100644 --- a/basis/roman/roman.factor +++ b/basis/roman/roman.factor @@ -17,7 +17,7 @@ CONSTANT: roman-values ERROR: roman-range-error n ; : roman-range-check ( n -- n ) - dup 1 3999 between? [ roman-range-error ] unless ; + dup 1 10000 between? [ roman-range-error ] unless ; : roman-digit-index ( ch -- n ) 1string roman-digits index ; inline diff --git a/basis/sequences/parser/authors.txt b/basis/sequences/parser/authors.txt new file mode 100644 index 0000000000..a07c427c98 --- /dev/null +++ b/basis/sequences/parser/authors.txt @@ -0,0 +1,2 @@ +Daniel Ehrenberg +Doug Coleman diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/basis/sequences/parser/parser-tests.factor similarity index 96% rename from extra/sequence-parser/sequence-parser-tests.factor rename to basis/sequences/parser/parser-tests.factor index af13e5b86e..0c4f1390bb 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/basis/sequences/parser/parser-tests.factor @@ -1,6 +1,6 @@ -USING: tools.test sequence-parser unicode.categories kernel +USING: tools.test sequences.parser unicode.categories kernel accessors ; -IN: sequence-parser.tests +IN: sequences.parser.tests [ "hello" ] [ "hello" [ take-rest ] parse-sequence ] unit-test diff --git a/extra/sequence-parser/sequence-parser.factor b/basis/sequences/parser/parser.factor similarity index 99% rename from extra/sequence-parser/sequence-parser.factor rename to basis/sequences/parser/parser.factor index d14a77057f..93bbbdf53d 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/basis/sequences/parser/parser.factor @@ -3,7 +3,7 @@ USING: accessors circular combinators.short-circuit fry io kernel locals math math.order sequences sorting.functor sorting.slots unicode.categories ; -IN: sequence-parser +IN: sequences.parser TUPLE: sequence-parser sequence n ; diff --git a/basis/shuffle/shuffle-docs.factor b/basis/shuffle/shuffle-docs.factor index 15398450a7..363727a6c5 100644 --- a/basis/shuffle/shuffle-docs.factor +++ b/basis/shuffle/shuffle-docs.factor @@ -1,5 +1,7 @@ USING: help.markup help.syntax ; IN: shuffle +HELP: spin $complex-shuffle ; HELP: roll $complex-shuffle ; HELP: -roll $complex-shuffle ; +HELP: tuck $complex-shuffle ; diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 43c0b75be1..0ff41edec6 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -22,6 +22,10 @@ MACRO: shuffle-effect ( effect -- ) SYNTAX: shuffle( ")" parse-effect suffix! \ shuffle-effect suffix! ; +: tuck ( x y -- y x y ) swap over ; inline deprecated + +: spin ( x y z -- z y x ) swap rot ; inline deprecated + : roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline deprecated : -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline deprecated diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 2c0ce853aa..154e67ebb1 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -43,7 +43,6 @@ IN: stack-checker.known-words { swapd (( x y z -- y x z )) } { nip (( x y -- y )) } { 2nip (( x y z -- z )) } - { tuck (( x y -- y x y )) } { over (( x y -- x y x )) } { pick (( x y z -- x y z x )) } { swap (( x y -- y x )) } @@ -623,11 +622,7 @@ M: bad-executable summary \ { integer object } { array } define-primitive \ make-flushable -\ begin-scan { } { } define-primitive - -\ next-object { } { object } define-primitive - -\ end-scan { } { } define-primitive +\ all-instances { } { array } define-primitive \ size { object } { fixnum } define-primitive \ size make-flushable @@ -704,7 +699,7 @@ M: bad-executable summary \ lookup-method { object array } { word } define-primitive \ reset-dispatch-stats { } { } define-primitive -\ dispatch-stats { } { array } define-primitive +\ dispatch-stats { } { byte-array } define-primitive \ optimized? { word } { object } define-primitive diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 414bcaaffe..274566c868 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -319,7 +319,7 @@ FORGET: erg's-inference-bug [ [ bad-recursion-3 ] infer ] must-fail FORGET: bad-recursion-3 -: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive +: bad-recursion-4 ( -- ) 4 [ dup call [ rot ] dip swap ] times ; inline recursive [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail : bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index 931cb36ea9..f486adcb32 100755 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -22,8 +22,7 @@ IN: suffix-arrays : ( from/f to/f seq -- slice ) [ - tuck - [ drop 0 or ] [ length or ] 2bi* + [ drop 0 or ] [ length or ] bi-curry bi* [ min ] keep ] keep ; inline diff --git a/basis/tools/memory/memory-docs.factor b/basis/tools/memory/memory-docs.factor index f729e8945f..b18396538f 100644 --- a/basis/tools/memory/memory-docs.factor +++ b/basis/tools/memory/memory-docs.factor @@ -13,11 +13,8 @@ ARTICLE: "tools.memory" "Object memory tools" data-room code-room } -"There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:" -{ $subsections - each-object - instances -} +"A combinator to get objects from the heap:" +{ $subsections instances } "You can check an object's the heap memory usage:" { $subsections size } "The garbage collector can be invoked manually:" diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 089bad3158..936d388b01 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -98,7 +98,7 @@ M: bad-developer-name summary [ main-file-string ] dip utf8 set-file-contents ; : scaffold-main ( vocab-root vocab -- ) - tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [ + [ ".factor" vocab-root/vocab/suffix>path ] keep swap scaffolding? [ set-scaffold-main-file ] [ 2drop diff --git a/basis/tools/time/time-tests.factor b/basis/tools/time/time-tests.factor new file mode 100644 index 0000000000..00c774663c --- /dev/null +++ b/basis/tools/time/time-tests.factor @@ -0,0 +1,4 @@ +IN: tools.time.tests +USING: tools.time tools.test compiler ; + +[ ] [ [ [ ] time ] compile-call ] unit-test diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 11c2a48a2a..5a92a4cea2 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -20,8 +20,9 @@ TUPLE: node value children ; ] [ [ [ children>> swap first head-slice % ] - [ tuck traverse-step traverse-to-path ] - 2bi + [ nip ] + [ traverse-step traverse-to-path ] + 2tri ] make-node ] if ] if ; @@ -35,7 +36,9 @@ TUPLE: node value children ; ] [ [ [ traverse-step traverse-from-path ] - [ tuck children>> swap first 1 + tail-slice % ] 2bi + [ nip ] + [ children>> swap first 1 + tail-slice % ] + 2tri ] make-node ] if ] if ; diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index c4392c4c6d..02d9f37023 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -23,7 +23,7 @@ GENERIC: group-struct ( obj -- group/f ) gr_mem>> utf8 alien>strings ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) - \ unix:group tuck 4096 + [ \ unix:group ] dip over 4096 [ ] keep f ; : check-group-struct ( group-struct ptr -- group-struct/f ) diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index f0ee13dd38..f2c5691452 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -9,7 +9,7 @@ IN: validators >lower "on" = ; : v-default ( str def -- str/def ) - over empty? spin ? ; + [ nip empty? ] 2keep ? ; : v-required ( str -- str ) dup empty? [ "required" throw ] when ; diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index ba057edffa..86ff4497b8 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -3,7 +3,7 @@ USING: classes.struct alien.c-types alien.syntax ; IN: vm -TYPEDEF: intptr_t cell +TYPEDEF: uintptr_t cell C-TYPE: context STRUCT: zone diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index ae8ef62c16..25e30829c0 100644 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -44,8 +44,8 @@ C: test-implementation [ >>x drop ] ! IInherited::setX } } { IUnrelated { - [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrelated::xMulAdd + [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus + [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd } } } dup +test-wrapper+ set [ diff --git a/basis/windows/com/wrapper/wrapper-docs.factor b/basis/windows/com/wrapper/wrapper-docs.factor index 6a6f6f2bb4..0298e80445 100644 --- a/basis/windows/com/wrapper/wrapper-docs.factor +++ b/basis/windows/com/wrapper/wrapper-docs.factor @@ -27,8 +27,8 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} [ >>x drop ] ! IInherited::setX } } { "IUnrelated" { - [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrealted::xMulAdd + [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus + [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd } } } """ } ; diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index 97de95a932..40b8e2191c 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -110,7 +110,7 @@ ERROR: mutually-recursive-rulesets ruleset ; dup [ glob-matches? ] [ 2drop f ] if ; : suitable-mode? ( file-name first-line mode -- ? ) - tuck first-line-glob>> ?glob-matches + [ nip ] 2keep first-line-glob>> ?glob-matches [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ; : find-mode ( file-name first-line -- mode ) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index d3a4f1e9a2..6b8db76ac9 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -86,7 +86,7 @@ M: regexp text-matches? [ >string ] dip first-match dup [ to>> ] when ; : rule-start-matches? ( rule -- match-count/f ) - dup start>> tuck swap can-match-here? [ + [ start>> dup ] keep can-match-here? [ rest-of-line swap text>> text-matches? ] [ drop f @@ -96,7 +96,7 @@ M: regexp text-matches? dup mark-following-rule? [ dup start>> swap can-match-here? 0 and ] [ - dup end>> tuck swap can-match-here? [ + [ end>> dup ] keep can-match-here? [ rest-of-line swap text>> context get end>> or text-matches? @@ -170,7 +170,7 @@ M: seq-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck body-token>> next-token, + [ body-token>> next-token, ] keep delegate>> [ push-context ] when* ; UNION: abstract-span-rule span-rule eol-span-rule ; @@ -179,7 +179,7 @@ M: abstract-span-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep ! ... end subst ... dup context get (>>in-rule) delegate>> push-context ; @@ -190,7 +190,7 @@ M: span-rule handle-rule-end M: mark-following-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep f context get (>>end) context get (>>in-rule) ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5d4144e354..702590516c 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -340,7 +340,6 @@ tuple { "swapd" "kernel" (( x y z -- y x z )) } { "nip" "kernel" (( x y -- y )) } { "2nip" "kernel" (( x y z -- z )) } - { "tuck" "kernel" (( x y -- y x y )) } { "over" "kernel" (( x y -- x y x )) } { "pick" "kernel" (( x y z -- x y z x )) } { "swap" "kernel" (( x y -- y x )) } @@ -473,9 +472,7 @@ tuple { "resize-array" "arrays" (( n array -- newarray )) } { "resize-string" "strings" (( n str -- newstr )) } { "" "arrays" (( n elt -- array )) } - { "begin-scan" "memory" (( -- )) } - { "next-object" "memory" (( -- obj )) } - { "end-scan" "memory" (( -- )) } + { "all-instances" "memory" (( -- array )) } { "size" "memory" (( obj -- n )) } { "die" "kernel" (( -- )) } { "(fopen)" "io.streams.c" (( path mode -- alien )) } diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 9c84904ff7..1a2cdf6a70 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -17,25 +17,19 @@ load-help? off ! Create a boot quotation for the target [ [ - ! Rehash hashtables, since bootstrap.image creates them - ! using the host image's hashing algorithms. We don't - ! use each-object here since the catch stack isn't yet - ! set up. - gc - begin-scan - [ hashtable? ] pusher [ (each-object) ] dip - end-scan - [ rehash ] each + ! Rehash hashtables first, since bootstrap.image creates + ! them using the host image's hashing algorithms. + [ hashtable? ] instances [ rehash ] each boot ] % "math.integers" require "math.floats" require "memory" require - + "io.streams.c" require "vocabs.loader" require - + "syntax" require "bootstrap.layouts" require diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index f40769ae39..0d207d9cc6 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -20,7 +20,7 @@ $nl { $see-also "see" } ; ARTICLE: "definition-checking" "Definition sanity checking" -"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions." +"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } "." $nl "The parser also catches forward references when reloading source files. This is best illustrated with an example. Suppose we load a source file " { $snippet "a.factor" } ":" { $code diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 1434acf521..d0bc4e1600 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -63,19 +63,18 @@ TUPLE: predicate-engine class methods ; C: predicate-engine -: push-method ( method specializer atomic assoc -- ) +: push-method ( method class atomic assoc -- ) dupd [ [ ] [ H{ } clone ] ?if [ methods>> set-at ] keep ] change-at ; -: flatten-method ( class method assoc -- ) - [ [ flatten-class keys ] keep ] 2dip [ - [ spin ] dip push-method - ] 3curry each ; +: flatten-method ( method class assoc -- ) + over flatten-class keys + [ swap push-method ] with with with each ; : flatten-methods ( assoc -- assoc' ) - H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; + H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ; ! 2. Convert methods : split-methods ( assoc class -- first second ) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index f70d9d4214..9a4fd4495a 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -21,12 +21,10 @@ HELP: 2over $shuffle ; HELP: pick ( x y z -- x y z x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ; -HELP: spin $complex-shuffle ; HELP: rot ( x y z -- y z x ) $complex-shuffle ; HELP: -rot ( x y z -- z x y ) $complex-shuffle ; HELP: dupd ( x y -- x x y ) $complex-shuffle ; HELP: swapd ( x y z -- y x z ) $complex-shuffle ; -HELP: tuck ( x y -- y x y ) $complex-shuffle ; HELP: datastack ( -- ds ) { $values { "ds" array } } @@ -821,14 +819,12 @@ $nl "Duplicating stack elements deep in the stack:" { $subsections dupd - tuck } "Permuting stack elements deep in the stack:" { $subsections swapd rot -rot - spin } ; ARTICLE: "shuffle-words" "Shuffle words" diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index d9babb5fd7..726fa1f5bb 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -13,11 +13,11 @@ IN: kernel.tests [ ] [ 10000 [ [ -1 f ] ignore-errors ] times ] unit-test ! Make sure we report the correct error on stack underflow -[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with +[ clear drop ] [ { "kernel-error" 10 f f } = ] must-fail-with [ ] [ :c ] unit-test -[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 13 f f } = ] must-fail-with +[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -34,15 +34,15 @@ IN: kernel.tests [ t "no-compile" set-word-prop ] each >> -[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with +[ overflow-d ] [ { "kernel-error" 11 f f } = ] must-fail-with [ ] [ :c ] unit-test -[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with +[ overflow-d-alt ] [ { "kernel-error" 11 f f } = ] must-fail-with [ ] [ [ :c ] with-string-writer drop ] unit-test -[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with +[ overflow-r ] [ { "kernel-error" 13 f f } = ] must-fail-with [ ] [ :c ] unit-test diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index a0934c2b17..bb27f7e57e 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -8,8 +8,6 @@ DEFER: 2dip DEFER: 3dip ! Stack stuff -: spin ( x y z -- z y x ) swap rot ; inline - : 2over ( x y z -- x y z x y ) pick pick ; inline : clear ( -- ) { } set-datastack ; diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index c09f2950e4..e25bbf13e2 100644 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -4,7 +4,7 @@ IN: math.integers ARTICLE: "integers" "Integers" { $subsections integer } "Integers come in two varieties -- fixnums and bignums. Fixnums fit in a machine word and are faster to manipulate; if the result of a fixnum operation is too large to fit in a fixnum, the result is upgraded to a bignum. Here is an example where two fixnums are multiplied yielding a bignum:" -{ $example "USE: classes" "134217728 class ." "fixnum" } +{ $example "USE: classes" "67108864 class ." "fixnum" } { $example "USE: classes" "128 class ." "fixnum" } { $example "134217728 128 * ." "17179869184" } { $example "USE: classes" "1 128 shift class ." "bignum" } diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 44c038b6ee..30d1254082 100644 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -23,8 +23,8 @@ IN: math.integers.tests [ -1 ] [ 1 neg ] unit-test [ -1 ] [ 1 >bignum neg ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 * ] unit-test -[ 268435456 ] [ -268435456 >fixnum neg ] unit-test +[ 134217728 ] [ -134217728 >fixnum -1 * ] unit-test +[ 134217728 ] [ -134217728 >fixnum neg ] unit-test [ 9 3 ] [ 93 10 /mod ] unit-test [ 9 3 ] [ 93 >bignum 10 /mod ] unit-test @@ -100,12 +100,12 @@ unit-test [ 16 ] [ 13 next-power-of-2 ] unit-test [ 16 ] [ 16 next-power-of-2 ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test -[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test -[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test +[ 134217728 ] [ -134217728 >fixnum -1 /i ] unit-test +[ 134217728 0 ] [ -134217728 >fixnum -1 /mod ] unit-test +[ 0 ] [ -1 -134217728 >fixnum /i ] unit-test [ 4420880996869850977 ] [ 13262642990609552931 3 /i ] unit-test -[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test -[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test +[ 0 -1 ] [ -1 -134217728 >fixnum /mod ] unit-test +[ 0 -1 ] [ -1 -134217728 >bignum /mod ] unit-test [ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test [ 8 530505719624382123 ] [ 13262642990609552931 1591517158873146351 /mod ] unit-test [ 8 ] [ 13262642990609552931 1591517158873146351 /i ] unit-test @@ -117,7 +117,7 @@ unit-test [ f ] [ 30 zero? ] unit-test [ t ] [ 0 >bignum zero? ] unit-test -[ 4294967280 ] [ 268435455 >fixnum 16 fixnum* ] unit-test +[ 2147483632 ] [ 134217727 >fixnum 16 fixnum* ] unit-test [ 23603949310011464311086123800853779733506160743636399259558684142844552151041 ] [ @@ -156,7 +156,7 @@ unit-test [ 4294967296 ] [ 1 32 shift ] unit-test [ 1267650600228229401496703205376 ] [ 1 100 shift ] unit-test -[ t ] [ 1 27 shift fixnum? ] unit-test +[ t ] [ 1 26 shift fixnum? ] unit-test [ t ] [ t diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index d40705a531..acf187a33a 100644 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -2,42 +2,20 @@ USING: help.markup help.syntax debugger sequences kernel quotations math ; IN: memory -HELP: begin-scan ( -- ) -{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects." -$nl -"This word must always be paired with a call to " { $link end-scan } "." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: next-object ( -- obj ) -{ $values { "obj" object } } -{ $description "Outputs the object at the heap scan pointer, and then advances the heap scan pointer. If the end of the heap has been reached, outputs " { $link f } ". This is unambiguous since the " { $link f } " object is tagged immediate and not actually stored in the heap." } -{ $errors "Throws a " { $link heap-scan-error. } " if called outside a " { $link begin-scan } "/" { $link end-scan } " pair." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: end-scan ( -- ) -{ $description "Finishes a heap iteration by re-enabling the garbage collector. This word must always be paired with a call to " { $link begin-scan } "." } -{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; - -HELP: each-object -{ $values { "quot" { $quotation "( obj -- )" } } } -{ $description "Applies a quotation to each object in the heap. The garbage collector is switched off while this combinator runs, so the given quotation must not allocate too much memory." } -{ $notes "This word is the low-level facility used to implement the " { $link instances } " word." } ; - HELP: instances { $values { "quot" { $quotation "( obj -- ? )" } } { "seq" "a fresh sequence" } } -{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } -{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ; +{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } ; HELP: gc ( -- ) { $description "Performs a full garbage collection." } ; -HELP: data-room ( -- cards decks generations ) -{ $values { "cards" "number of kilobytes reserved for card marking" } { "decks" "number of kilobytes reserved for decks of cards" } { "generations" "array of free/total kilobytes pairs" } } -{ $description "Queries the runtime for memory usage information." } ; +HELP: data-room ( -- data-room ) +{ $values { "data-room" data-room } } +{ $description "Queries the VM for memory usage information." } ; -HELP: code-room ( -- code-total code-used code-free largest-free-block ) -{ $values { "code-total" "total kilobytes in the code heap" } { "code-used" "kilobytes used in the code heap" } { "code-free" "kilobytes free in the code heap" } { "largest-free-block" "size of largest free block" } } -{ $description "Queries the runtime for memory usage information." } ; +HELP: code-room ( -- code-room ) +{ $values { "code-room" code-room } } +{ $description "Queries the VM for memory usage information." } ; HELP: size ( obj -- n ) { $values { "obj" "an object" } { "n" "a size in bytes" } } @@ -56,17 +34,6 @@ HELP: save-image-and-exit ( path -- ) HELP: save { $description "Saves a snapshot of the heap to the current image file." } ; -HELP: count-instances -{ $values - { "quot" quotation } - { "n" integer } } -{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." } -{ $examples { $unchecked-example - "USING: memory words prettyprint ;" - "[ word? ] count-instances ." - "24210" -} } ; - ARTICLE: "images" "Images" "Factor has the ability to save the entire state of the system into an " { $emphasis "image file" } ". The image contains a complete dump of all data and code in the current Factor instance." { $subsections diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 1c61e33d83..4ab68a1ef1 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,26 +1,11 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences vectors arrays system math +USING: kernel continuations sequences system io.backend alien.strings memory.private ; IN: memory -: (each-object) ( quot: ( obj -- ) -- ) - next-object dup [ - swap [ call ] keep (each-object) - ] [ 2drop ] if ; inline recursive - -: each-object ( quot -- ) - gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline - -: count-instances ( quot -- n ) - 0 swap [ 1 0 ? + ] compose each-object ; inline - : instances ( quot -- seq ) - #! To ensure we don't need to grow the vector while scanning - #! the heap, we do two scans, the first one just counts the - #! number of objects that satisfy the predicate. - [ count-instances 100 + ] keep swap - [ [ push-if ] 2curry each-object ] keep >array ; inline + [ all-instances ] dip filter ; inline : save-image ( path -- ) normalize-path native-string>alien (save-image) ; diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 844581c6d9..97dbab384e 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -216,7 +216,7 @@ HELP: filter-moved { $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ; HELP: forget-smudged -{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ; +{ $description "Forgets removed definitions." } ; HELP: finish-parsing { $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } } diff --git a/core/splitting/splitting-docs.factor b/core/splitting/splitting-docs.factor index 10fea15a64..5085571312 100644 --- a/core/splitting/splitting-docs.factor +++ b/core/splitting/splitting-docs.factor @@ -13,6 +13,7 @@ ARTICLE: "sequences-split" "Splitting sequences" split1-last split1-last-slice split + split-when } "Splitting a string into lines:" { $subsections string-lines } ; @@ -37,9 +38,14 @@ HELP: split1-last-slice { split1 split1-slice split1-last split1-last-slice } related-words +HELP: split-when +{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- ? )" } } { "pieces" "a new array" } } +{ $description "Splits " { $snippet "seq" } " at each occurrence of an element for which " { $snippet "quot" } " gives a true output and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." } +{ $examples { $example "USING: ascii kernel prettyprint splitting ;" "\"hello,world-how.are:you\" [ letter? not ] split-when ." "{ \"hello\" \"world\" \"how\" \"are\" \"you\" }" } } ; + HELP: split { $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } } -{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." } +{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } " and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." } { $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ; HELP: ?head diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index ed68038fa6..e672624d96 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,4 +1,4 @@ -USING: splitting tools.test kernel sequences arrays strings ; +USING: splitting tools.test kernel sequences arrays strings ascii ; IN: splitting.tests [ "hello" "world ." ] [ "hello world ." " " split1 ] unit-test @@ -57,3 +57,6 @@ unit-test [ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test [ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test [ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test + +[ { "hey" "world" "what's" "happening" } ] +[ "heyAworldBwhat'sChappening" [ LETTER? ] split-when ] unit-test diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 7aae30f20b..7b805dffe5 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -55,17 +55,21 @@ PRIVATE> : split ( seq separators -- pieces ) - [ split, ] { } make ; + [ [ member? ] curry split, ] { } make ; + +: split-when ( seq quot -- pieces ) + [ split, ] { } make ; inline GENERIC: string-lines ( str -- seq ) diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index 31a4b75eb2..a379a03828 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -63,7 +63,7 @@ C: transaction : process-to-date ( account date -- account ) over interest-last-paid>> 1 days time+ - [ dupd process-day ] spin each-day ; + [ [ dupd process-day ] ] 2dip swap each-day ; : inserting-transactions ( account transactions -- account ) [ [ date>> process-to-date ] keep >>transaction ] each ; diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index fb4f17cca5..a28a676b90 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files splitting strings io.encodings.ascii +USING: kernel locals io io.files splitting strings io.encodings.ascii hashtables sequences assocs math namespaces prettyprint math.parser combinators arrays sorting unicode.case ; @@ -21,10 +21,7 @@ IN: benchmark.knucleotide CHAR: \n swap remove >upper ; : tally ( x exemplar -- b ) - clone tuck - [ - [ [ 1 + ] [ 1 ] if* ] change-at - ] curry each ; + clone [ [ inc-at ] curry each ] keep ; : small-groups ( x n -- b ) swap @@ -42,10 +39,10 @@ IN: benchmark.knucleotide ] each drop ; -: handle-n ( inputs x -- ) - tuck length - small-groups H{ } tally - at [ 0 ] unless* +:: handle-n ( inputs x -- ) + inputs x length small-groups :> groups + groups H{ } tally :> b + x b at [ 0 ] unless* number>string 8 CHAR: \s pad-tail write ; : process-input ( input -- ) diff --git a/extra/c/lexer/lexer-tests.factor b/extra/c/lexer/lexer-tests.factor index c972b8816c..082827353d 100644 --- a/extra/c/lexer/lexer-tests.factor +++ b/extra/c/lexer/lexer-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors c.lexer kernel sequence-parser tools.test ; +USING: accessors c.lexer kernel sequences.parser tools.test ; IN: c.lexer.tests [ 36 ] diff --git a/extra/c/lexer/lexer.factor b/extra/c/lexer/lexer.factor index 962407e6ec..57894217bd 100644 --- a/extra/c/lexer/lexer.factor +++ b/extra/c/lexer/lexer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.short-circuit generalizations kernel locals math.order math.ranges -sequence-parser sequences sorting.functor sorting.slots +sequences.parser sequences sorting.functor sorting.slots unicode.categories ; IN: c.lexer diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index 3018fa7a24..d69583e124 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: sequence-parser io io.encodings.utf8 io.files +USING: sequences.parser io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories assocs math splitting make unicode.categories @@ -93,11 +93,11 @@ ERROR: header-file-missing path ; skip-whitespace/comments [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; -: handle-define ( preprocessor-state sequence-parser -- ) - [ take-define-identifier ] - [ skip-whitespace/comments take-rest ] bi - "\\" ?tail [ readlns append ] when - spin symbol-table>> set-at ; +:: handle-define ( preprocessor-state sequence-parser -- ) + sequence-parser take-define-identifier :> ident + sequence-parser skip-whitespace/comments take-rest :> def + def "\\" ?tail [ readlns append ] when :> def + def ident preprocessor-state symbol-table>> set-at ; : handle-undef ( preprocessor-state sequence-parser -- ) take-token swap symbol-table>> delete-at ; diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor index da71acb074..ed5dd1268f 100644 --- a/extra/couchdb/couchdb.factor +++ b/extra/couchdb/couchdb.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations debugger hashtables http http.client io io.encodings.string io.encodings.utf8 json.reader -json.writer kernel make math math.parser namespaces sequences strings -urls urls.encoding vectors ; +json.writer kernel locals make math math.parser namespaces sequences +strings urls urls.encoding vectors ; IN: couchdb ! NOTE: This code only works with the latest couchdb (0.9.*), because old @@ -136,8 +136,9 @@ C: db : attachments> ( assoc -- attachments ) "_attachments" swap at ; : >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ; -: copy-key ( to from to-key from-key -- ) - rot at spin set-at ; +:: copy-key ( to from to-key from-key -- ) + from-key from at + to-key to set-at ; : copy-id ( to from -- ) "_id" "id" copy-key ; diff --git a/extra/curses/curses.factor b/extra/curses/curses.factor index 4d6c77fd23..23adf31700 100644 --- a/extra/curses/curses.factor +++ b/extra/curses/curses.factor @@ -123,8 +123,10 @@ PRIVATE> : curses-writef ( window string -- ) [ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ; -: (curses-read) ( window-ptr n encoding -- string ) - [ [ tuck ] keep wgetnstr curses-error ] dip alien>string ; +:: (curses-read) ( window-ptr n encoding -- string ) + n :> buf + window-ptr buf n wgetnstr curses-error + buf encoding alien>string ; : curses-read ( window n -- string ) utf8 [ window-ptr ] 2dip (curses-read) ; diff --git a/extra/decimals/decimals.factor b/extra/decimals/decimals.factor index cc12b4fed1..d5c62fee5e 100644 --- a/extra/decimals/decimals.factor +++ b/extra/decimals/decimals.factor @@ -37,7 +37,7 @@ SYNTAX: D: parse-decimal suffix! ; ] 2bi ; : scale-decimals ( D1 D2 -- D1' D2' ) - scale-mantissas tuck [ ] 2dip ; + scale-mantissas [ ] curry bi@ ; ERROR: decimal-types-expected d1 d2 ; diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor index 2b3379861f..ccbe90fb3c 100755 --- a/extra/digraphs/digraphs.factor +++ b/extra/digraphs/digraphs.factor @@ -44,7 +44,7 @@ DEFER: (topological-sort) ] if ; : topological-sort ( digraph -- seq ) - dup clone V{ } clone spin + [ V{ } clone ] dip [ clone ] keep [ drop (topological-sort) ] assoc-each drop reverse ; : topological-sorted-values ( digraph -- seq ) diff --git a/extra/ecdsa/ecdsa.factor b/extra/ecdsa/ecdsa.factor index c4d889991e..8e285a0904 100644 --- a/extra/ecdsa/ecdsa.factor +++ b/extra/ecdsa/ecdsa.factor @@ -50,7 +50,7 @@ PRIVATE> : get-private-key ( -- bin/f ) ec-key-handle EC_KEY_get0_private_key - dup [ dup BN_num_bits bits>bytes tuck BN_bn2bin drop ] when ; + dup [ dup BN_num_bits bits>bytes [ BN_bn2bin drop ] keep ] when ; :: get-public-key ( -- bin/f ) ec-key-handle :> KEY diff --git a/extra/fries/fries.factor b/extra/fries/fries.factor index 133e8913dd..3f970a86bf 100644 --- a/extra/fries/fries.factor +++ b/extra/fries/fries.factor @@ -1,11 +1,15 @@ USING: arrays vectors combinators effects kernel math sequences splitting strings.parser parser fry sequences.extras ; + +! a b c glue => acb +! c b a [ append ] dip prepend + IN: fries : str-fry ( str on -- quot ) split - [ unclip-last [ [ spin glue ] reduce-r ] 2curry ] + [ unclip-last [ [ [ append ] [ prepend ] bi* ] reduce-r ] 2curry ] [ length 1 - 1 [ call-effect ] 2curry ] bi ; : gen-fry ( str on -- quot ) split - [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ] + [ unclip-last [ [ [ 1array ] [ append ] [ prepend ] tri* ] reduce-r ] 2curry ] [ length 1 - 1 [ call-effect ] 2curry ] bi ; SYNTAX: i" parse-string rest "_" str-fry append! ; diff --git a/extra/gpu/framebuffers/framebuffers.factor b/extra/gpu/framebuffers/framebuffers.factor index efd71782d0..bea72961e4 100755 --- a/extra/gpu/framebuffers/framebuffers.factor +++ b/extra/gpu/framebuffers/framebuffers.factor @@ -157,10 +157,13 @@ M: renderbuffer framebuffer-attachment-dim [ swap depth-attachment>> [ swap call ] [ drop ] if* ] [ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline -: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- ) - [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ] - [ swap depth-attachment>> [ GL_DEPTH_ATTACHMENT spin call ] [ drop ] if* ] - [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline +:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- ) + framebuffer color-attachments>> + [| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index + framebuffer depth-attachment>> + [| attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when* + framebuffer stencil-attachment>> + [| attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- ) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 9fcbffd0db..8d506cda28 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables sequence-parser +USING: accessors arrays hashtables sequences.parser html.parser.utils kernel namespaces sequences math unicode.case unicode.categories combinators.short-circuit quoting fry ; diff --git a/extra/io/serial/windows/windows.factor b/extra/io/serial/windows/windows.factor index 551fd16b33..645e4939de 100755 --- a/extra/io/serial/windows/windows.factor +++ b/extra/io/serial/windows/windows.factor @@ -11,8 +11,7 @@ IN: io.serial.windows : get-comm-state ( duplex -- dcb ) in>> handle>> - DCB tuck - GetCommState win32-error=0/f ; + DCB [ GetCommState win32-error=0/f ] keep ; : set-comm-state ( duplex dcb -- ) [ in>> handle>> ] dip diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index 60e9e39d9f..48bf2b693a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu -opengl.demo-support sequences specialized-arrays ; +opengl.demo-support sequences specialized-arrays locals ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: jamshred.gl @@ -50,8 +50,9 @@ CONSTANT: wall-drawing-offset 0.15 over color>> gl-color segment-vertex-and-normal gl-normal gl-vertex ; -: draw-vertex-pair ( theta next-segment segment -- ) - rot tuck draw-segment-vertex draw-segment-vertex ; +:: draw-vertex-pair ( theta next-segment segment -- ) + segment theta draw-segment-vertex + next-segment theta draw-segment-vertex ; : draw-segment ( next-segment segment -- ) GL_QUAD_STRIP [ diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index ae72bd847c..b1644ef443 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -53,13 +53,13 @@ C: oint : scalar-projection ( v1 v2 -- n ) #! the scalar projection of v1 onto v2 - tuck v. swap norm / ; + [ v. ] [ norm ] bi / ; : proj-perp ( u v -- w ) dupd proj v- ; : perpendicular-distance ( oint oint -- distance ) - tuck distance-vector swap 2dup left>> scalar-projection abs + [ distance-vector ] keep 2dup left>> scalar-projection abs -rot up>> scalar-projection abs + ; :: reflect ( v n -- v' ) diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index baeacd750b..6982af63f6 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -31,16 +31,13 @@ CONSTANT: max-speed 30.0 forward-pivot ; : to-tunnel-start ( player -- ) - [ tunnel>> first dup location>> ] - [ tuck (>>location) (>>nearest-segment) ] bi ; + dup tunnel>> first + [ >>nearest-segment ] + [ location>> >>location ] bi drop ; : play-in-tunnel ( player segments -- ) >>tunnel to-tunnel-start ; -: update-nearest-segment ( player -- ) - [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] - [ (>>nearest-segment) ] tri ; - : update-time ( player -- seconds-passed ) millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index e2e1c20122..ac696f5444 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -6,19 +6,6 @@ alien.c-types ; SPECIALIZED-ARRAY: float IN: jamshred.tunnel.tests -[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } - T{ segment f { 1 1 1 } f f f 1 } - T{ oint f { 0 0 0.25 } } - nearer-segment number>> ] unit-test - -[ 0 ] [ T{ oint f { 0 0 0 } } find-nearest-segment number>> ] unit-test -[ 1 ] [ T{ oint f { 0 0 -1 } } find-nearest-segment number>> ] unit-test -[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } find-nearest-segment number>> ] unit-test - -[ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test - -[ float-array{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test - : test-segment-oint ( -- oint ) { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index f7eac9d02c..f94fc979ce 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -63,32 +63,6 @@ CONSTANT: default-segment-radius 1 #! valid values [ '[ _ clamp-length ] bi@ ] keep ; -: nearer-segment ( segment segment oint -- segment ) - #! return whichever of the two segments is nearer to the oint - [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ; - -: (find-nearest-segment) ( nearest next oint -- nearest ? ) - #! find the nearest of 'next' and 'nearest' to 'oint', and return - #! t if the nearest hasn't changed - pick [ nearer-segment dup ] dip = ; - -: find-nearest-segment ( oint segments -- segment ) - dup first swap rest-slice rot [ (find-nearest-segment) ] curry - find 2drop ; - -: nearest-segment-forward ( segments oint start -- segment ) - rot dup length swap find-nearest-segment ; - -: nearest-segment-backward ( segments oint start -- segment ) - swapd 1 + 0 spin find-nearest-segment ; - -: nearest-segment ( segments oint start-segment -- segment ) - #! find the segment nearest to 'oint', and return it. - #! start looking at segment 'start-segment' - number>> over [ - [ nearest-segment-forward ] 3keep nearest-segment-backward - ] dip nearer-segment ; - : get-segment ( segments n -- segment ) over clamp-length swap nth ; diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index 90e28594e7..6ea1dc5633 100755 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -50,10 +50,10 @@ CONSTANT: pov-polygons [ [ 0.0 ] unless* ] tri@ [ (xy>loc) ] dip (z>loc) ; -: move-axis ( gadget x y z -- ) - (xyz>loc) rot tuck - [ indicator>> (>>loc) ] - [ z-indicator>> (>>loc) ] 2bi* ; +:: move-axis ( gadget x y z -- ) + x y z (xyz>loc) :> ( xy z ) + xy gadget indicator>> (>>loc) + z gadget z-indicator>> (>>loc) ; : move-pov ( gadget pov -- ) swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ] @@ -82,10 +82,10 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ; [ >>controller ] [ product-string