steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2009-07-18 23:13:43 -05:00
parent 200cd5d43f a213db05db
commit 7969581474
19 changed files with 183 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
basis/combinators/short-circuit/short-circuit-docs.factor
View File

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

39
basis/combinators/short-circuit/short-circuit-tests.factor
View File

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

30
basis/combinators/short-circuit/short-circuit.factor
View File

@ -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&& ] ;
<PRIVATE
: unoptimized-&& ( quots quot -- ? )
[ [ 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|| ] ;
MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
<PRIVATE
: unoptimized-|| ( quots quot -- ? )
[ [ 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-|| ;

14
basis/compiler/cfg/builder/builder.factor
View File

@ -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
current-word set
add-procedure ;
[ basic-block get ] 2dip
<cfg> 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 ;

4
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

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

25
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -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 '[
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

2
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

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

23
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

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

14
basis/compiler/tree/finalization/finalization.factor
View File

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

6
basis/debugger/debugger.factor
View File

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

16
basis/heaps/heaps.factor
View File

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

32
basis/stack-checker/transforms/transforms.factor
View File

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

3
basis/ui/tools/listener/listener.factor
View File

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

2
core/classes/tuple/tuple.factor
View File

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

2
core/math/math-docs.factor
View File

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

6
core/parser/parser-tests.factor
View File

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

10
core/vocabs/parser/parser-tests.factor Normal file
View File

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

15
core/vocabs/parser/parser.factor
View File

@ -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 )
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 ;
: <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 -- )

19
extra/benchmark/heaps/heaps.factor Normal file
View File

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