diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor index 6cd18201fe..66ba001094 100644 --- a/basis/combinators/short-circuit/short-circuit-docs.factor +++ b/basis/combinators/short-circuit/short-circuit-docs.factor @@ -1,62 +1,46 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax io.streams.string quotations -math ; +math kernel ; IN: combinators.short-circuit HELP: 0&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true." } ; +{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 0|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if any quotation in the sequence returns true." } ; +{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the first true result, or " { $link f } } } +{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ; HELP: 1&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ; +{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 1|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } +{ $values { "obj" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ; HELP: 2&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ; +{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 2|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } +{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ; HELP: 3&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ; +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 3|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ; HELP: n&& { $values - { "quots" "a sequence of quotations" } { "N" integer } + { "quots" "a sequence of quotations" } { "n" integer } { "quot" quotation } } -{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ; +{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each quotation, evaluating the result in the same manner as " { $link 0&& } "." } ; HELP: n|| { $values diff --git a/basis/combinators/short-circuit/short-circuit-tests.factor b/basis/combinators/short-circuit/short-circuit-tests.factor index e392d67d2a..b2bcb2a60f 100644 --- a/basis/combinators/short-circuit/short-circuit-tests.factor +++ b/basis/combinators/short-circuit/short-circuit-tests.factor @@ -1,32 +1,25 @@ - USING: kernel math tools.test combinators.short-circuit ; - IN: combinators.short-circuit.tests -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test +[ 5 ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& ] unit-test +[ 30 ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& ] unit-test -: must-be-t ( in -- ) [ t ] swap unit-test ; -: must-be-f ( in -- ) [ f ] swap unit-test ; +[ f ] [ { [ 1 ] [ f ] [ 3 ] } 0&& ] unit-test +[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] unit-test +[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& ] unit-test -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ "factor" ] [ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| ] unit-test +[ 11 ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| ] unit-test +[ 30 ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| ] unit-test +[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] unit-test -[ { [ 1 ] [ 2 ] [ 3 ] } 0&& 3 = ] must-be-t -[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& 5 = ] must-be-t -[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t +: compiled-&& ( a -- ? ) { [ 0 > ] [ even? ] [ 2 + ] } 1&& ; -[ { [ 1 ] [ f ] [ 3 ] } 0&& 3 = ] must-be-f -[ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] must-be-f -[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f +[ f ] [ 3 compiled-&& ] unit-test +[ 4 ] [ 2 compiled-&& ] unit-test -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t - -[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ] must-be-t - -[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ] must-be-t - -[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ; +[ 30 ] [ 10 20 compiled-|| ] unit-test +[ 2 ] [ 1 1 compiled-|| ] unit-test \ No newline at end of file diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index d8bab4dd34..a625a462af 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -12,10 +12,17 @@ MACRO:: n&& ( quots n -- quot ) n '[ _ nnip ] suffix 1array [ cond ] 3append ; -MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ; -MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ; -MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ; -MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ; + + +: 0&& ( quots -- ? ) [ ] unoptimized-&& ; +: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ; +: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ; +: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ; MACRO:: n|| ( quots n -- quot ) [ f ] quots [| q | @@ -27,7 +34,14 @@ MACRO:: n|| ( quots n -- quot ) n '[ drop _ ndrop t ] [ f ] 2array suffix 1array [ cond ] 3append ; -MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ; -MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ; -MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ; -MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ; + + +: 0|| ( quots -- ? ) [ ] unoptimized-|| ; +: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ; +: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ; +: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ; diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index c866835ac5..2eff8b9e28 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -23,30 +23,20 @@ IN: compiler.cfg.builder ! Convert tree SSA IR to CFG SSA IR. SYMBOL: procedures -SYMBOL: current-word -SYMBOL: current-label SYMBOL: loops -: add-procedure ( -- ) - basic-block get current-word get current-label get - procedures get push ; - : begin-procedure ( word label -- ) end-basic-block begin-basic-block H{ } clone loops set - current-label set - current-word set - add-procedure ; + [ basic-block get ] 2dip + procedures get push ; : with-cfg-builder ( nodes word label quot -- ) '[ begin-procedure @ ] with-scope ; inline GENERIC: emit-node ( node -- ) -: check-basic-block ( node -- node' ) - basic-block get [ drop f ] unless ; inline - : emit-nodes ( nodes -- ) [ basic-block get [ emit-node ] [ drop ] if ] each ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index e4a7b8972a..2618db0904 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -41,8 +41,8 @@ IN: compiler.cfg.intrinsics math.private:fixnum<= math.private:fixnum>= math.private:fixnum> - math.private:bignum>fixnum - math.private:fixnum>bignum + ! math.private:bignum>fixnum + ! math.private:fixnum>bignum kernel:eq? slots.private:slot slots.private:set-slot diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index c0f90e5932..98deca9472 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -19,7 +19,7 @@ IN: compiler.cfg.linear-scan.assignment SYMBOL: pending-intervals : add-active ( live-interval -- ) - pending-intervals get push ; + dup end>> pending-intervals get heap-push ; ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals @@ -37,7 +37,7 @@ SYMBOL: register-live-ins SYMBOL: register-live-outs : init-assignment ( live-intervals -- ) - V{ } clone pending-intervals set + pending-intervals set unhandled-intervals set H{ } clone register-live-ins set H{ } clone register-live-outs set @@ -61,12 +61,17 @@ SYMBOL: register-live-outs register->register ] [ drop ] if ; +: (expire-old-intervals) ( n heap -- ) + dup heap-empty? [ 2drop ] [ + 2dup heap-peek nip <= [ 2drop ] [ + dup heap-pop drop [ handle-spill ] [ handle-copy ] bi + (expire-old-intervals) + ] if + ] if ; + : expire-old-intervals ( n -- ) [ - [ pending-intervals get ] dip '[ - dup end>> _ < - [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if - ] filter-here + pending-intervals get (expire-old-intervals) ] { } make mapping-instructions % ; : insert-reload ( live-interval -- ) @@ -111,14 +116,12 @@ ERROR: overlapping-registers intervals ; dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ; : active-intervals ( n -- intervals ) - pending-intervals get [ covers? ] with filter + pending-intervals get heap-values [ covers? ] with filter check-assignment? get [ dup check-assignment ] when ; M: vreg-insn assign-registers-in-insn - dup [ all-vregs ] [ insn#>> active-intervals ] bi - '[ _ [ vreg>> = ] with find nip ] map - register-mapping - >>regs drop ; + dup [ all-vregs ] [ insn#>> active-intervals register-mapping ] bi + extract-keys >>regs drop ; M: ##gc assign-registers-in-insn ! This works because ##gc is always the first instruction diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 63da100b02..df521c1988 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -385,7 +385,7 @@ SYMBOL: max-uses [ \ live-interval new swap int-regs swap vreg boa >>vreg - max-uses get random 2 max [ not-taken ] replicate natural-sort + max-uses get random 2 max [ not-taken 2 * ] replicate natural-sort [ >>uses ] [ first >>start ] bi dup uses>> last >>end dup [ start>> ] [ end>> ] bi 1vector >>ranges diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index d2fa661136..68a780d42a 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs accessors sequences math math.order fry -combinators compiler.cfg.instructions compiler.cfg.registers +combinators binary-search compiler.cfg.instructions compiler.cfg.registers compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ; IN: compiler.cfg.linear-scan.live-intervals @@ -16,16 +16,21 @@ split-before split-after split-next start end ranges uses copy-from ; -: covers? ( insn# live-interval -- ? ) - ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ; +GENERIC: covers? ( insn# obj -- ? ) -: child-interval-at ( insn# interval -- interval' ) - dup split-after>> [ - 2dup split-after>> start>> < - [ split-before>> ] [ split-after>> ] if - child-interval-at - ] [ nip ] if ; +M: f covers? 2drop f ; +M: live-range covers? [ from>> ] [ to>> ] bi between? ; + +M: live-interval covers? ( insn# live-interval -- ? ) + ranges>> + dup length 4 <= [ + [ covers? ] with any? + ] [ + [ drop ] [ [ from>> <=> ] with search nip ] 2bi + covers? + ] if ; + ERROR: dead-value-error vreg ; : shorten-range ( n live-interval -- ) diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 4c17399c95..9b278dde9b 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences words memoize combinators classes classes.builtin classes.tuple math.partial-dispatch -fry assocs +fry assocs combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -29,10 +29,12 @@ GENERIC: finalize* ( node -- nodes ) M: #copy finalize* drop f ; M: #shuffle finalize* - dup - [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] - [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] - bi and [ drop f ] when ; + dup { + [ [ in-d>> length ] [ out-d>> length ] bi = ] + [ [ in-r>> length ] [ out-r>> length ] bi = ] + [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at = ] 2all? ] + [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at = ] 2all? ] + } 1&& [ drop f ] when ; MEMO: cached-expansion ( word -- nodes ) def>> splice-final ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index b10ca775f4..6c0985ce06 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -258,6 +258,12 @@ M: no-word-error summary M: no-word-error error. summary print ; +M: no-word-in-vocab summary + [ vocab>> ] [ word>> ] bi + [ "No word named ``" % % "'' found in ``" % % "'' vocabulary" % ] "" make ; + +M: no-word-in-vocab error. summary print ; + M: ambiguous-use-error summary words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index ae546080a1..32ed10d8f2 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -2,7 +2,7 @@ ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences arrays assocs sequences.private -growable accessors math.order summary ; +growable accessors math.order summary vectors ; IN: heaps GENERIC: heap-push* ( value key heap -- entry ) @@ -15,14 +15,14 @@ GENERIC: heap-size ( heap -- n ) ( class -- heap ) [ V{ } clone ] dip boa ; inline TUPLE: entry value key heap index ; -: ( value key heap -- entry ) f entry boa ; +: ( value key heap -- entry ) f entry boa ; inline PRIVATE> @@ -109,10 +109,10 @@ DEFER: up-heap [ data-exchange ] 2keep up-heap ] [ 3drop - ] if ; + ] if ; inline recursive : up-heap ( n heap -- ) - over 0 > [ (up-heap) ] [ 2drop ] if ; + over 0 > [ (up-heap) ] [ 2drop ] if ; inline recursive : (child) ( m heap -- n ) 2dup right-value @@ -132,10 +132,10 @@ DEFER: down-heap 3drop ] [ [ data-exchange ] 2keep down-heap - ] if ; + ] if ; inline recursive : down-heap ( m heap -- ) - 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; + 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; inline recursive PRIVATE> @@ -148,7 +148,7 @@ M: heap heap-push* ( value key heap -- entry ) [ swapd heap-push ] curry assoc-each ; : >entry< ( entry -- key value ) - [ value>> ] [ key>> ] bi ; + [ value>> ] [ key>> ] bi ; inline M: heap heap-peek ( heap -- value key ) data-first >entry< ; diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 056eda8b61..11534c58f9 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -83,6 +83,38 @@ IN: stack-checker.transforms \ spread t "no-compile" set-word-prop +\ 0&& [ '[ _ 0 n&& ] ] 1 define-transform + +\ 0&& t "no-compile" set-word-prop + +\ 1&& [ '[ _ 1 n&& ] ] 1 define-transform + +\ 1&& t "no-compile" set-word-prop + +\ 2&& [ '[ _ 2 n&& ] ] 1 define-transform + +\ 2&& t "no-compile" set-word-prop + +\ 3&& [ '[ _ 3 n&& ] ] 1 define-transform + +\ 3&& t "no-compile" set-word-prop + +\ 0|| [ '[ _ 0 n|| ] ] 1 define-transform + +\ 0|| t "no-compile" set-word-prop + +\ 1|| [ '[ _ 1 n|| ] ] 1 define-transform + +\ 1|| t "no-compile" set-word-prop + +\ 2|| [ '[ _ 2 n|| ] ] 1 define-transform + +\ 2|| t "no-compile" set-word-prop + +\ 3|| [ '[ _ 3 n|| ] ] 1 define-transform + +\ 3|| t "no-compile" set-word-prop + \ (call-next-method) [ [ [ "method-class" word-prop ] diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index e12e59d259..e34e354a87 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -304,7 +304,8 @@ M: listener-operation invoke-command ( target command -- ) : use-if-necessary ( word manifest -- ) 2dup [ vocabulary>> ] dip and [ manifest [ - vocabulary>> use-vocab + [ vocabulary>> use-vocab ] + [ dup name>> associate use-words ] bi ] with-variable ] [ 2drop ] if ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 7633f9b4c8..8e49e2f5f4 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -32,7 +32,7 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? ) M: tuple class layout-of 2 slot { word } declare ; : tuple-size ( tuple -- size ) - layout-of second ; inline + layout-of 3 slot { fixnum } declare ; inline : prepare-tuple>array ( tuple -- n tuple layout ) check-tuple [ tuple-size ] [ ] [ layout-of ] tri ; diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index e5f68a511c..b920ff54ea 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -324,7 +324,7 @@ HELP: each-integer HELP: all-integers? { $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "?" "a boolean" } } -{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." } +{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iteration stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." } { $notes "This word is used to implement " { $link all? } "." } ; HELP: find-integer diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 32f432a6cd..791fe1fa36 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -530,12 +530,6 @@ EXCLUDE: qualified.tests.bar => x ; [ 3 ] [ x ] unit-test [ 4 ] [ y ] unit-test -[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval( -- ) ] -[ error>> no-word-error? ] must-fail-with - -[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval( -- ) ] -[ error>> no-word-error? ] must-fail-with - ! Two similar bugs ! Replace : def with something in << >> diff --git a/core/vocabs/parser/parser-tests.factor b/core/vocabs/parser/parser-tests.factor new file mode 100644 index 0000000000..b9a3245b34 --- /dev/null +++ b/core/vocabs/parser/parser-tests.factor @@ -0,0 +1,10 @@ +IN: vocabs.parser.tests +USING: vocabs.parser tools.test eval kernel accessors ; + +[ "FROM: kernel => doesnotexist ;" eval( -- ) ] +[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ] +must-fail-with + +[ "RENAME: doesnotexist kernel => newname" eval( -- ) ] +[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ] +must-fail-with \ No newline at end of file diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index 0bfb607a52..7ac0bd2e58 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -59,16 +59,19 @@ C: extra-words [ qualified-vocabs>> delete-all ] tri ; +ERROR: no-word-in-vocab word vocab ; + > push ; -: (from) ( vocab words -- vocab words words' assoc ) - 2dup swap load-vocab words>> ; +: (from) ( vocab words -- vocab words words' vocab ) + 2dup swap load-vocab ; -: extract-words ( seq assoc -- assoc' ) - extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ; +: extract-words ( seq vocab -- assoc' ) + [ words>> extract-keys dup ] [ name>> ] bi + [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ; : (lookup) ( name assoc -- word/f ) at dup forward-reference? [ drop f ] when ; @@ -148,7 +151,7 @@ TUPLE: from vocab names words ; TUPLE: exclude vocab names words ; : ( vocab words -- from ) - (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ; + (from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ; : add-words-excluding ( vocab words -- ) (add-qualified) ; @@ -156,7 +159,7 @@ TUPLE: exclude vocab names words ; TUPLE: rename word vocab words ; : ( word vocab new-name -- rename ) - [ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip + [ 2dup load-vocab words>> dupd at [ ] [ swap no-word-in-vocab ] ?if ] dip associate rename boa ; : add-renamed-word ( word vocab new-name -- ) diff --git a/extra/benchmark/heaps/heaps.factor b/extra/benchmark/heaps/heaps.factor new file mode 100644 index 0000000000..1a63e3d48f --- /dev/null +++ b/extra/benchmark/heaps/heaps.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: heaps math sequences kernel ; +IN: benchmark.heaps + +: data ( -- seq ) + 1 6000 [ 13 + 79 * 13591 mod dup ] replicate nip ; + +: heap-test ( -- ) + + data + [ [ dup pick heap-push ] each ] + [ length [ dup heap-pop* ] times ] bi + drop ; + +: heap-benchmark ( -- ) + 100 [ heap-test ] times ; + +MAIN: heap-benchmark \ No newline at end of file