Merge branch 'master' of git://factorcode.org/git/factor

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
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
-     { "quot" quotation } }
-{ $description "Returns true if every quotation in the sequence of quotations returns true." } ;
 
 HELP: 0||
-{ $values
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the first true result, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
+{ $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 } "." } ;
-     { "quot" quotation } }
-{ $description "Returns true if any quotation in the sequence returns true." } ;
 
 HELP: 1&&
-{ $values
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
-     { "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." } ;
 
 HELP: 1||
-{ $values
+{ $values { "obj" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
-     { "quot" quotation } }
 { $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
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
-     { "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." } ;
 
 HELP: 2||
-{ $values
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
-     { "quot" quotation } }
 { $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
+{ $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 } } }
-     { "quots" "a sequence of quotations" }
+{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
-     { "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." } ;
 
 HELP: 3||
-{ $values
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } }
-     { "quots" "a sequence of quotations" }
-     { "quot" quotation } }
 { $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

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 ;
+[ f ] [ { [ 1 ] [ f ] [ 3 ] } 0&& ] unit-test
-: must-be-f ( in -- ) [ f ] swap 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
+: compiled-&& ( a -- ? ) { [ 0 > ] [ even? ] [ 2 + ] } 1&& ;
-[ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    1&&  5 = ] must-be-t
-[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t
 
-[       { [ 1 ] [ f ] [ 3 ] } 0&&  3 = ]          must-be-f
+[ f ] [ 3 compiled-&& ] unit-test
-[ 3     { [ 0 > ] [ even? ] [ 2 + ] } 1&& ]       must-be-f
+[ 4 ] [ 2 compiled-&& ] unit-test
-[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ;
-
-[ { [ 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
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+[ 30 ] [ 10 20 compiled-|| ] unit-test
+[ 2 ] [ 1 1 compiled-|| ] unit-test

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&& ] ;
+<PRIVATE
-MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
+
-MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
+: unoptimized-&& ( quots quot -- ? )
-MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
+    [ [ call dup ] ] dip call [ nip ] prepose [ f ] 2dip all? swap and ; inline
+
+PRIVATE>
+
+: 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|| ] ;
+<PRIVATE
-MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
+
-MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
+: unoptimized-|| ( quots quot -- ? )
-MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
+    [ [ call ] ] dip call map-find drop ; inline
+
+PRIVATE>
+
+: 0|| ( quots -- ? ) [ ] unoptimized-|| ;
+: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ;
+: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ;
+: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ;

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
-    <cfg> procedures get push ;
-
 : begin-procedure ( word label -- )
     end-basic-block
     begin-basic-block
     H{ } clone loops set
-    current-label set
+    [ basic-block get ] 2dip
-    current-word set
+    <cfg> procedures get push ;
-    add-procedure ;
 
 : 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 ;
 

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:bignum>fixnum
-    math.private:fixnum>bignum
+    ! math.private:fixnum>bignum
     kernel:eq?
     slots.private:slot
     slots.private:set-slot

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
+    <min-heap> pending-intervals set
     <min-heap> 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 '[
+        pending-intervals get (expire-old-intervals)
-            dup end>> _ <
-            [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
-        ] filter-here
     ] { } 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
+    dup [ all-vregs ] [ insn#>> active-intervals register-mapping ] bi
-    '[ _ [ vreg>> = ] with find nip ] map
+    extract-keys >>regs drop ;
-    register-mapping
-    >>regs drop ;
 
 M: ##gc assign-registers-in-insn
     ! This works because ##gc is always the first instruction

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 <live-range> 1vector >>ranges

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,15 +16,20 @@ split-before split-after split-next
 start end ranges uses
 copy-from ;
 
-: covers? ( insn# live-interval -- ? )
+GENERIC: covers? ( insn# obj -- ? )
-    ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
 
-: child-interval-at ( insn# interval -- interval' )
+M: f covers? 2drop f ;
-    dup split-after>> [
+
-        2dup split-after>> start>> <
+M: live-range covers? [ from>> ] [ to>> ] bi between? ;
-        [ split-before>> ] [ split-after>> ] if
+
-        child-interval-at
+M: live-interval covers? ( insn# live-interval -- ? )
-    ] [ nip ] if ;
+    ranges>>
+    dup length 4 <= [
+        [ covers? ] with any?
+    ] [
+        [ drop ] [ [ from>> <=> ] with search nip ] 2bi
+        covers?
+    ] if ;
         
 ERROR: dead-value-error vreg ;
 

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
+    dup {
-    [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
+        [ [ in-d>> length ] [ out-d>> length ] bi = ]
-    [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
+        [ [ in-r>> length ] [ out-r>> length ] bi = ]
-    bi and [ drop f ] when ;
+        [ [ 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 ;

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 ;

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 )
 
 <PRIVATE
 
-TUPLE: heap data ;
+TUPLE: heap { data vector } ;
 
 : <heap> ( class -- heap )
     [ V{ } clone ] dip boa ; inline
 
 TUPLE: entry value key heap index ;
 
-: <entry> ( value key heap -- entry ) f entry boa ;
+: <entry> ( 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< ;

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 ]

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 ;
 

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 ;

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

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 << >>

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

core/vocabs/parser/parser.factor

@@ -59,16 +59,19 @@ C: <extra-words> extra-words
     [ qualified-vocabs>> delete-all ]
     tri ;
 
+ERROR: no-word-in-vocab word vocab ;
+
 <PRIVATE
 
 : (add-qualified) ( qualified -- )
     manifest get qualified-vocabs>> push ;
 
-: (from) ( vocab words -- vocab words words' assoc )
+: (from) ( vocab words -- vocab words words' vocab )
-    2dup swap load-vocab words>> ;
+    2dup swap load-vocab ;
 
-: extract-words ( seq assoc -- assoc' )
+: extract-words ( seq vocab -- assoc' )
-    extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ;
+    [ 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 ;
 
 : <exclude> ( 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 -- )
     <exclude> (add-qualified) ;
@@ -156,7 +159,7 @@ TUPLE: exclude vocab names words ;
 TUPLE: rename word vocab words ;
 
 : <rename> ( 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 -- )

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 ( -- )
+    <min-heap>
+    data
+    [ [ dup pick heap-push ] each ]
+    [ length [ dup heap-pop* ] times ] bi
+    drop ;
+
+: heap-benchmark ( -- )
+    100 [ heap-test ] times ;
+
+MAIN: heap-benchmark