diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 5f57068bab..276dd581c5 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -48,3 +48,5 @@ TYPEDEF: uchar* MyLPBYTE [ 0 B{ 1 2 3 4 } ] must-fail + +[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 602b22881f..405d679f4a 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -151,7 +151,8 @@ M: byte-array byte-length length ; swap dup length memcpy ; : (define-nth) ( word type quot -- ) - >r heap-size [ rot * ] swap prefix r> append define-inline ; + >r heap-size [ rot * >fixnum ] swap prefix + r> append define-inline ; : nth-word ( name vocab -- word ) >r "-nth" append r> create ; @@ -348,7 +349,7 @@ M: long-long-type box-return ( type -- ) [ alien-unsigned-4 zero? not ] >>getter - [ 1 0 ? set-alien-unsigned-4 ] >>setter + [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter 4 >>size 4 >>align "box_boolean" >>boxer @@ -357,7 +358,7 @@ M: long-long-type box-return ( type -- ) [ alien-float ] >>getter - [ >r >r >float r> r> set-alien-float ] >>setter + [ [ >float ] 2dip set-alien-float ] >>setter 4 >>size 4 >>align "box_float" >>boxer @@ -368,7 +369,7 @@ M: long-long-type box-return ( type -- ) [ alien-double ] >>getter - [ >r >r >float r> r> set-alien-double ] >>setter + [ [ >float ] 2dip set-alien-double ] >>setter 8 >>size 8 >>align "box_double" >>boxer diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 0e1042391c..51293955d5 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -57,13 +57,19 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" { $subsection key? } { $subsection at } -{ $subsection value-at } { $subsection assoc-empty? } { $subsection keys } { $subsection values } { $subsection assoc-stack } { $see-also at* assoc-size } ; +ARTICLE: "assocs-values" "Transposed assoc operations" +"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:" +{ $subsection value-at } +{ $subsection value-at* } +{ $subsection value? } +"With most assoc implementations, these words runs in linear time, proportional to the number of entries in the assoc. For fast value lookups, use " { $vocab-link "biassocs" } "." ; + ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)." { $subsection assoc-subset? } @@ -111,6 +117,7 @@ $nl { $subsection "assocs-protocol" } "A large set of utility words work on any object whose class implements the associative mapping protocol." { $subsection "assocs-lookup" } +{ $subsection "assocs-values" } { $subsection "assocs-mutation" } { $subsection "assocs-combinators" } { $subsection "assocs-sets" } ; @@ -231,10 +238,17 @@ HELP: assoc-stack { $description "Searches for the key in successive elements of the sequence, starting from the end. If an assoc containing the key is found, the associated value is output. If no assoc contains the key, outputs " { $link f } "." } { $notes "This word is used to implement abstractions such as nested scopes; if the sequence is a stack represented by a vector, then the most recently pushed assoc -- the innermost scope -- will be searched first." } ; +HELP: value-at* +{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } { "?" "a boolean" } } +{ $description "Looks up the key associated with a value. The boolean flag can decide beteen the case of a missing key, and a key of " { $link f } "." } ; + HELP: value-at { $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } } -{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } -{ $notes "This word runs in linear time, proportional to the number of entries in the assoc." } ; +{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } ; + +HELP: value? +{ $values { "value" "an object" } { "assoc" assoc } { "?" "a boolean" } } +{ $description "Tests if an assoc contains at least one key with the given value." } ; HELP: delete-at* { $values { "key" "a key" } { "assoc" assoc } { "old" "the previous value or " { $link f } } { "?" "a boolean" } } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index f56ac810d9..6cb8958298 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -144,10 +144,13 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : extract-keys ( seq assoc -- subassoc ) [ [ dupd at ] curry ] keep map>assoc ; -! M: assoc >alist [ 2array ] { } assoc>map ; +GENERIC: value-at* ( value assoc -- key/f ? ) -: value-at ( value assoc -- key/f ) - swap [ = nip ] curry assoc-find 2drop ; +M: assoc value-at* swap [ = nip ] curry assoc-find nip ; + +: value-at ( value assoc -- key/f ) value-at* drop ; + +: value? ( value assoc -- ? ) value-at* nip ; : push-at ( value key assoc -- ) [ ?push ] change-at ; diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 632938bb2d..97a95f98b8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -119,6 +119,7 @@ SYMBOL: jit-primitive SYMBOL: jit-word-jump SYMBOL: jit-word-call SYMBOL: jit-push-literal +SYMBOL: jit-push-immediate SYMBOL: jit-if-word SYMBOL: jit-if-jump SYMBOL: jit-dispatch-word @@ -149,6 +150,7 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } + { jit-push-immediate 36 } { jit-declare-word 42 } { undefined-quot 60 } } at header-size + ; @@ -438,6 +440,7 @@ M: quotation ' jit-word-jump jit-word-call jit-push-literal + jit-push-immediate jit-if-word jit-if-jump jit-dispatch-word diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 444cf50e58..665fc86ebb 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -306,3 +306,9 @@ INTERSECTION: empty-intersection ; [ t ] [ object \ f class-not \ f class-or class<= ] unit-test [ ] [ object flatten-builtin-class drop ] unit-test + +SINGLETON: sa +SINGLETON: sb +SINGLETON: sc + +[ sa ] [ sa { sa sb sc } min-class ] unit-test diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index a72c9f1333..1d370c1859 100755 --- a/core/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.predicate kernel sequences words ; +USING: classes classes.algebra classes.predicate kernel +sequences words ; IN: classes.singleton PREDICATE: singleton-class < predicate-class @@ -11,3 +12,6 @@ PREDICATE: singleton-class < predicate-class \ word over [ eq? ] curry define-predicate-class ; M: singleton-class instance? eq? ; + +M: singleton-class (classes-intersect?) + over singleton-class? [ eq? ] [ call-next-method ] if ; diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 10cbe268da..d40b71b477 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -51,7 +51,7 @@ must-fail-with [ error>> unexpected-eof? ] must-fail-with -[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ] +[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] [ error>> no-initial-value? ] must-fail-with diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 114146e450..51c175a282 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -298,16 +298,16 @@ $nl "For example, compare the definitions of the " { $link sbuf } " class," { $code "TUPLE: sbuf" - "{ \"underlying\" string }" - "{ \"length\" array-capacity } ;" + "{ underlying string }" + "{ length array-capacity } ;" "" "INSTANCE: sbuf growable" } "with that of the " { $link vector } " class:" { $code "TUPLE: vector" - "{ \"underlying\" array }" - "{ \"length\" array-capacity } ;" + "{ underlying array }" + "{ length array-capacity } ;" "" "INSTANCE: vector growable" } ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 6cf6a9897a..71c5f3efe6 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -336,6 +336,8 @@ M: tuple-class boa [ tuple-layout ] bi ; +M: tuple-class initial-value* new ; + ! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index bd90ca65f0..76a42b3f2d 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -40,6 +40,12 @@ big-endian off ds-reg [] arg0 MOV ! store literal on datastack ] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define +[ + arg0 0 MOV ! load literal + ds-reg bootstrap-cell ADD ! increment datastack pointer + ds-reg [] arg0 MOV ! store literal on datastack +] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define + [ arg0 0 MOV ! load XT arg1 stack-reg MOV ! pass callstack pointer as arg 2 diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 058822bf2f..9be8151bee 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -72,6 +72,7 @@ SYMBOL: label-table : rt-xt 4 ; : rt-here 5 ; : rt-label 6 ; +: rt-immediate 7 ; TUPLE: label-fixup label class ; diff --git a/core/grouping/grouping-docs.factor b/core/grouping/grouping-docs.factor index f7a37691a6..3b3a98eabd 100644 --- a/core/grouping/grouping-docs.factor +++ b/core/grouping/grouping-docs.factor @@ -2,10 +2,14 @@ USING: help.markup help.syntax sequences strings ; IN: grouping ARTICLE: "grouping" "Groups and clumps" +"Splitting a sequence into disjoint, fixed-length subsequences:" +{ $subsection group } "A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:" { $subsection groups } { $subsection } { $subsection } +"Splitting a sequence into overlapping, fixed-length subsequences:" +{ $subsection clump } "A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" { $subsection clumps } { $subsection } diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 57919671c8..336f1da91a 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -59,4 +59,11 @@ M: growable lengthen ( n seq -- ) 2dup (>>length) ] when 2drop ; +M: growable shorten ( n seq -- ) + growable-check + 2dup length < [ + 2dup contract + 2dup (>>length) + ] when 2drop ; + INSTANCE: growable sequence diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 591baf1287..7be70f1ad4 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -5,8 +5,9 @@ sequences words inference.class quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions compiler.units system layouts vectors optimizer.math.partial -optimizer.inlining optimizer.backend math.order -accessors hashtables classes assocs ; +optimizer.inlining optimizer.backend math.order math.functions +accessors hashtables classes assocs io.encodings.utf8 +io.encodings.ascii io.encodings ; [ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test @@ -193,19 +194,15 @@ M: fixnum detect-fx ; [ t ] [ - [ { string sbuf } declare push-all ] \ push-all inlined? + [ { string sbuf } declare ] \ push-all def>> append \ + inlined? ] unit-test [ t ] [ - [ { string sbuf } declare push-all ] \ + inlined? + [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined? ] unit-test [ t ] [ - [ { string sbuf } declare push-all ] \ fixnum+ inlined? -] unit-test - -[ t ] [ - [ { string sbuf } declare push-all ] \ >fixnum inlined? + [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined? ] unit-test [ t ] [ @@ -600,6 +597,29 @@ TUPLE: declared-fixnum { x fixnum } ; { slot } inlined? ] unit-test +[ t ] [ + [ + { array } declare length + 1 + dup 100 fixnum> [ 1 fixnum+ ] when + ] \ fixnum+ inlined? +] unit-test + +[ t ] [ + [ [ resize-array ] keep length ] \ length inlined? +] unit-test + +[ t ] [ + [ dup 0 > [ sqrt ] when ] \ sqrt inlined? +] unit-test + +[ t ] [ + [ { utf8 } declare decode-char ] \ decode-char inlined? +] unit-test + +[ t ] [ + [ { ascii } declare decode-char ] \ decode-char inlined? +] unit-test + ! Later ! [ t ] [ diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 2f7058ba96..7cd0c1d540 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -129,8 +129,12 @@ GENERIC: infer-classes-before ( node -- ) GENERIC: infer-classes-around ( node -- ) +GENERIC: infer-classes-after ( node -- ) + M: node infer-classes-before drop ; +M: node infer-classes-after drop ; + M: node child-constraints children>> length dup zero? [ drop f ] [ f ] if ; @@ -203,11 +207,19 @@ M: pair constraint-satisfied? [ ] [ param>> "default-output-classes" word-prop ] ?if r> ; -M: #call infer-classes-before - [ compute-constraints ] keep - [ output-classes ] [ out-d>> ] bi +: intersect-values ( classes intervals values -- ) tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ; +M: #call infer-classes-before + [ compute-constraints ] + [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ; + +: input-classes ( #call -- classes ) + param>> "input-classes" word-prop ; + +M: #call infer-classes-after + [ input-classes ] [ in-d>> ] bi intersect-classes ; + M: #push infer-classes-before out-d>> [ [ value-literal ] keep set-value-literal* ] each ; @@ -340,6 +352,7 @@ M: object infer-classes-around { [ infer-classes-before ] [ annotate-node ] + [ infer-classes-after ] [ infer-children ] [ merge-children ] } cleave ; diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor index e1d5bd434c..9e01492529 100644 --- a/core/inference/errors/errors.factor +++ b/core/inference/errors/errors.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel generic sequences prettyprint io words arrays +summary effects debugger assocs accessors inference.backend +inference.dataflow ; IN: inference.errors -USING: inference.backend inference.dataflow kernel generic -sequences prettyprint io words arrays summary effects debugger -assocs accessors ; M: inference-error error-help error>> error-help ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 6f5277bc35..1c9138fe0b 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -153,8 +153,10 @@ M: object infer-call ] "infer" set-word-prop : set-primitive-effect ( word effect -- ) - 2dup effect-out "default-output-classes" set-word-prop - dupd [ make-call-node ] 2curry "infer" set-word-prop ; + [ in>> "input-classes" set-word-prop ] + [ out>> "default-output-classes" set-word-prop ] + [ dupd [ make-call-node ] 2curry "infer" set-word-prop ] + 2tri ; ! Stack effects for all primitives \ fixnum< { fixnum fixnum } { object } set-primitive-effect diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 942476616f..0181f80af4 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -99,14 +99,20 @@ M: decoder stream-read-partial stream-read ; [ >r drop "" like r> ] [ pick push ((read-until)) ] if ; inline -: (read-until) ( seps stream -- string/f sep/f ) - SBUF" " clone -rot >decoder< +: (read-until) ( quot -- string/f sep/f ) + 100 swap ((read-until)) ; inline + +: decoder-read-until ( seps stream encoding -- string/f sep/f ) [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry - ((read-until)) ; inline + (read-until) ; -M: decoder stream-read-until (read-until) ; +M: decoder stream-read-until >decoder< decoder-read-until ; -M: decoder stream-readln "\r\n" over (read-until) handle-readln ; +: decoder-readln ( stream encoding -- string/f sep/f ) + [ decode-char dup [ dup "\r\n" member? ] [ drop f t ] if ] 2curry + (read-until) ; + +M: decoder stream-readln dup >decoder< decoder-readln handle-readln ; M: decoder dispose stream>> dispose ; @@ -119,8 +125,11 @@ M: object encoder boa ; M: encoder stream-write1 >encoder< encode-char ; +: decoder-write ( string stream encoding -- ) + [ encode-char ] 2curry each ; + M: encoder stream-write - >encoder< [ encode-char ] 2curry each ; + >encoder< decoder-write ; M: encoder dispose encoder-stream dispose ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 09524802e0..ae8a455c71 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -11,21 +11,21 @@ SINGLETON: utf8 >length) method should-inline? ] unit-test diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 618a2c746d..30acdb1b48 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -2,12 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel -math namespaces sequences vectors words quotations hashtables -combinators classes classes.algebra generic.math -optimizer.math.partial continuations optimizer.def-use -optimizer.backend generic.standard optimizer.specializers -optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control kernel.private definitions sets ; +math math.order namespaces sequences vectors words quotations +hashtables combinators effects classes classes.union +classes.algebra generic.math optimizer.math.partial +continuations optimizer.def-use optimizer.backend +generic.standard optimizer.specializers optimizer.def-use +optimizer.pattern-match generic.standard optimizer.control +kernel.private definitions sets summary ; IN: optimizer.inlining : remember-inlining ( node history -- ) @@ -31,9 +32,9 @@ DEFER: (flat-length) : word-flat-length ( word -- n ) { ! not inline - { [ dup inline? not ] [ drop 0 ] } + { [ dup inline? not ] [ drop 1 ] } ! recursive and inline - { [ dup recursive-calls get key? ] [ drop 4 ] } + { [ dup recursive-calls get key? ] [ drop 10 ] } ! inline [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ] } cond ; @@ -41,7 +42,7 @@ DEFER: (flat-length) : (flat-length) ( seq -- n ) [ { - { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup quotation? ] [ (flat-length) 2 + ] } { [ dup array? ] [ (flat-length) ] } { [ dup word? ] [ word-flat-length ] } [ drop 0 ] @@ -51,7 +52,7 @@ DEFER: (flat-length) : flat-length ( word -- n ) H{ } clone recursive-calls [ [ recursive-calls get conjoin ] - [ def>> (flat-length) ] + [ def>> (flat-length) 5 /i ] bi ] with-variable ; @@ -102,7 +103,7 @@ DEFER: (flat-length) [ f splice-quot ] [ 2drop t ] if ; : inline-method ( #call -- node ) - dup node-param { + dup param>> { { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } { [ dup math-partial? ] [ inline-math-partial ] } @@ -155,15 +156,35 @@ DEFER: (flat-length) (optimize-predicate) optimize-check ; : flush-eval? ( #call -- ? ) - dup node-param "flushable" word-prop [ - node-out-d [ unused? ] all? - ] [ - drop f - ] if ; + dup node-param "flushable" word-prop + [ node-out-d [ unused? ] all? ] [ drop f ] if ; + +ERROR: flushed-eval-error word ; + +M: flushed-eval-error summary + drop "Flushed evaluation of word would have thrown an error" ; + +: flushed-eval-quot ( #call -- quot ) + #! A quotation to replace flushed evaluations with. We can't + #! just remove the code altogether, because if the optimizer + #! knows the input types of a word, it assumes the inputs are + #! of this type after the word returns, since presumably + #! the word would have checked input types itself. However, + #! if the word gets flushed, then it won't do this checking; + #! so we have to do it here. + [ + dup param>> "input-classes" word-prop [ + make-specializer % + [ dup param>> literalize , \ flushed-eval-error , ] [ ] make , + \ unless , + ] when* + dup in-d>> length [ \ drop , ] times + out-d>> length [ f , ] times + ] [ ] make ; : flush-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup node-out-d length f inline-literals ; + dup param>> +inlined+ depends-on + dup flushed-eval-quot f splice-quot ; : partial-eval? ( #call -- ? ) dup node-param "foldable" word-prop [ @@ -195,13 +216,28 @@ DEFER: (flat-length) [ drop +inlined+ depends-on ] [ swap 1array ] 2bi splice-quot ; +: classes-known? ( #call -- ? ) + node-input-classes [ + [ class-types length 1 = ] + [ union-class? not ] + bi and + ] contains? ; + +: inlining-rank ( #call -- n ) + { + [ param>> flat-length 24 swap [-] 4 /i ] + [ param>> "default" word-prop -4 0 ? ] + [ param>> "specializer" word-prop 1 0 ? ] + [ param>> method-body? 1 0 ? ] + [ classes-known? 2 0 ? ] + } cleave + + + + ; + +: should-inline? ( #call -- ? ) + inlining-rank 5 >= ; + : optimistic-inline? ( #call -- ? ) - dup node-param "specializer" word-prop dup [ - >r node-input-classes r> specialized-length tail* - [ class-types length 1 = ] all? - ] [ - 2drop f - ] if ; + dup param>> "specializer" word-prop + [ should-inline? ] [ drop f ] if ; : already-inlined? ( #call -- ? ) [ param>> ] [ history>> ] bi memq? ; @@ -211,11 +247,8 @@ DEFER: (flat-length) dup param>> dup def>> splice-word-def ] if ; -: should-inline? ( word -- ? ) - flat-length 11 <= ; - : method-body-inline? ( #call -- ? ) - param>> dup [ method-body? ] [ "default" word-prop not ] bi and + dup param>> method-body? [ should-inline? ] [ drop f ] if ; M: #call optimize-node* diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 76ad0009cb..7527199fe9 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien arrays generic hashtables definitions -inference.dataflow inference.state inference.class kernel assocs -math math.order math.private kernel.private sequences words -parser vectors strings sbufs io namespaces assocs quotations -sequences.private io.binary io.streams.string layouts splitting -math.intervals math.floats.private classes.tuple classes.predicate -classes.tuple.private classes classes.algebra optimizer.def-use -optimizer.backend optimizer.pattern-match optimizer.inlining -sequences.private combinators byte-arrays byte-vectors -slots.private ; +kernel assocs math math.order math.private kernel.private +sequences words parser vectors strings sbufs io namespaces +assocs quotations sequences.private io.binary io.streams.string +layouts splitting math.intervals math.floats.private +classes.tuple classes.predicate classes.tuple.private classes +classes.algebra sequences.private combinators byte-arrays +byte-vectors slots.private inference.dataflow inference.state +inference.class optimizer.def-use optimizer.backend +optimizer.pattern-match optimizer.inlining ; IN: optimizer.known-words { (tuple) } [ diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index 27ef4042e2..c20cba99cb 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: effects alien alien.accessors arrays generic hashtables +kernel assocs math math.libm math.private kernel.private +sequences words parser vectors strings sbufs io namespaces +assocs quotations math.intervals sequences.private combinators +splitting layouts math.parser classes classes.algebra +generic.math inference.class inference.dataflow +optimizer.pattern-match optimizer.backend optimizer.def-use +optimizer.inlining optimizer.math.partial generic.standard +system accessors ; IN: optimizer.math -USING: alien alien.accessors arrays generic hashtables kernel -assocs math math.private kernel.private sequences words parser -inference.class inference.dataflow vectors strings sbufs io -namespaces assocs quotations math.intervals sequences.private -combinators splitting layouts math.parser classes -classes.algebra generic.math optimizer.pattern-match -optimizer.backend optimizer.def-use optimizer.inlining -optimizer.math.partial generic.standard system accessors ; : define-math-identities ( word identities -- ) >r all-derived-ops r> define-identities ; @@ -169,6 +170,22 @@ optimizer.math.partial generic.standard system accessors ; ] 2curry each-derived-op ] each +: math-output-class/interval-2-fast ( node word -- classes intervals ) + math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline + +[ + { + interval+ } + { - interval- } + { * interval* } + { shift interval-shift-safe } +] [ + first2 [ + [ + math-output-class/interval-2-fast + ] curry "output-classes" set-word-prop + ] curry each-fast-derived-op +] each + : real-value? ( value -- n ? ) dup value? [ value-literal dup real? ] [ drop f f ] if ; @@ -420,3 +437,40 @@ most-negative-fixnum most-positive-fixnum [a,b] [ fixnumify-bitand ] } } define-optimizers + +{ + - * / } +[ { number number } "input-classes" set-word-prop ] each + +{ /f < > <= >= } +[ { real real } "input-classes" set-word-prop ] each + +{ /i mod /mod } +[ { rational rational } "input-classes" set-word-prop ] each + +{ bitand bitor bitxor bitnot shift } +[ { integer integer } "input-classes" set-word-prop ] each + +{ + fcosh + flog + fsinh + fexp + fasin + facosh + fasinh + ftanh + fatanh + facos + fpow + fatan + fatan2 + fcos + ftan + fsin + fsqrt +} [ + dup stack-effect + [ in>> length real "input-classes" set-word-prop ] + [ out>> length float "default-output-classes" set-word-prop ] + 2bi +] each diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor index 4f9bfaef12..ad9feeed4a 100644 --- a/core/optimizer/math/partial/partial.factor +++ b/core/optimizer/math/partial/partial.factor @@ -170,3 +170,6 @@ SYMBOL: fast-math-ops : each-derived-op ( word quot -- ) >r derived-ops r> each ; inline + +: each-fast-derived-op ( word quot -- ) + >r fast-derived-ops r> each ; inline diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 655b54ea96..0a3439c65c 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -375,3 +375,12 @@ PREDICATE: list < improper-list [ 2 3 ] [ 2 interval-inference-bug ] unit-test [ 1 4 ] [ 1 interval-inference-bug ] unit-test [ 0 5 ] [ 0 interval-inference-bug ] unit-test + +: aggressive-flush-regression ( a -- b ) + f over >r drop r> 1 + ; + +[ 1.0 aggressive-flush-regression drop ] must-fail + +[ 1 [ "hi" + drop ] compile-call ] must-fail + +[ "hi" f [ drop ] compile-call ] must-fail diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor index 51fa254a25..647dda368f 100755 --- a/core/optimizer/pattern-match/pattern-match.factor +++ b/core/optimizer/pattern-match/pattern-match.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces generic +combinators classes classes.algebra +inference inference.dataflow ; IN: optimizer.pattern-match -USING: kernel sequences inference namespaces generic -combinators classes classes.algebra inference.dataflow ; ! Funny pattern matching SYMBOL: @ diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index bc92055338..c433ce4426 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -21,9 +21,12 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable M: sequence like drop ; GENERIC: lengthen ( n seq -- ) +GENERIC: shorten ( n seq -- ) M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; +M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; + : empty? ( seq -- ? ) length zero? ; inline : delete-all ( seq -- ) 0 swap set-length ; @@ -530,7 +533,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : peek ( seq -- elt ) [ length 1- ] [ nth ] bi ; -: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ; +: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ; : move-backward ( shift from to seq -- ) 2over number= [ @@ -575,7 +578,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; copy ; : pop ( seq -- elt ) - [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ; + [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; : all-equal? ( seq -- ? ) [ = ] monotonic? ; diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 205d4d34bf..57d62f6480 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -38,6 +38,18 @@ HELP: adjoin } { $side-effects "seq" } ; +HELP: conjoin +{ $values { "elt" object } { "assoc" "an assoc" } } +{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." } +{ $examples + { $example + "USING: kernel prettyprint sets ;" + "H{ } clone 1 over conjoin ." + "H{ { 1 1 } }" + } +} +{ $side-effects "assoc" } ; + HELP: unique { $values { "seq" "a sequence" } { "assoc" "an assoc" } } { $description "Outputs a new assoc where the keys and values are equal." } diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 39a501c7f8..acca168a4c 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -77,6 +77,7 @@ $nl "All other classes are handled with one of two cases:" { $list { "If the class is a union or mixin class which " { $emphasis "contains" } " one of the above known classes, then the initial value of the class is that of the known class, with preference given to classes earlier in the list. For example, if the slot is declared " { $link object } " (this is the default), the initial value is " { $link f } ". Similarly for " { $link sequence } " and " { $link assoc } "." } + { "If the class is a tuple class, the initial value of the slot is a new, shared instance of the class created with " { $link new } "." } { "Otherwise, a " { $link no-initial-value } " error is thrown. In this case, an initial value must be specified explicitly using " { $link initial: } "." } } "A word can be used to check if a class has an initial value or not:" diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 1453393a27..a5b2e4b3d8 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -125,6 +125,10 @@ ERROR: bad-slot-value value class ; ERROR: no-initial-value class ; +GENERIC: initial-value* ( class -- object ) + +M: class initial-value* no-initial-value ; + : initial-value ( class -- object ) { { [ \ f bootstrap-word over class<= ] [ f ] } @@ -134,7 +138,7 @@ ERROR: no-initial-value class ; { [ array bootstrap-word over class<= ] [ { } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] } { [ simple-alien bootstrap-word over class<= ] [ ] } - [ no-initial-value ] + [ dup initial-value* ] } cond nip ; GENERIC: make-slot ( desc -- slot-spec ) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 14632df771..5036a13d78 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,13 +1,8 @@ USING: arrays assocs kernel vectors sequences namespaces -random math.parser math fry ; + random math.parser math fry ; + IN: assocs.lib -: ref-at ( table key -- value ) swap at ; - -: put-at* ( table key value -- ) swap rot set-at ; - -: put-at ( table key value -- table ) swap pick set-at ; - : set-assoc-stack ( value key seq -- ) dupd [ key? ] with find-last nip set-at ; diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index b6d4152d0e..979a733692 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -1,6 +1,6 @@ USING: kernel math math.parser random arrays hashtables assocs sequences - vars ; + grouping vars ; IN: automata @@ -32,18 +32,6 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; ! step-wrapped-line ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 3nth ( n seq -- slice ) >r dup 3 + r> ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: map3-i ( seq -- i ) length 2 - ; - -: map3-quot ( seq quot -- quot ) >r [ 3nth ] curry r> compose ; inline - -: map3 ( seq quot -- seq ) >r dup map3-i swap r> map3-quot map ; inline - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : pattern>state ( {_a_b_c_} -- state ) rule> at ; : cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ; @@ -51,10 +39,9 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; : wrap-line ( a-line-z -- za-line-za ) dup peek 1array swap dup first 1array append append ; -: step-line ( line -- new-line ) [ >array pattern>state ] map3 ; - -: step-capped-line ( line -- new-line ) cap-line step-line ; +: step-line ( line -- new-line ) 3 [ pattern>state ] map ; +: step-capped-line ( line -- new-line ) cap-line step-line ; : step-wrapped-line ( line -- new-line ) wrap-line step-line ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index 467db53366..78f1074eb8 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -14,13 +14,22 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui.gadgets.packs ui.gadgets.grids ui.gadgets.theme + accessors + qualified namespaces.lib assocs.lib vars - rewrite-closures automata ; + rewrite-closures automata math.geometry.rect newfx ; IN: automata.ui ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +QUALIFIED: ui.gadgets.grids + +: grid-add ( grid child i j -- grid ) + >r >r dupd swap r> r> ui.gadgets.grids:grid-add ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ; : draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ; @@ -57,29 +66,40 @@ slate> relayout-1 ; DEFER: automata-window -: automata-window* ( -- ) init-rule set-interesting +: automata-window* ( -- ) + init-rule + set-interesting -{ -[ "1 - Center" [ start-center ] view-button ] -[ "2 - Random" [ start-random ] view-button ] -[ "3 - Continue" [ run-rule ] view-button ] -[ "5 - Random Rule" [ random-rule ] view-button ] -[ "n - New" [ automata-window ] view-button ] -} make* -[ [ gadget, ] curry ] map concat ! Hack -make-shelf over @top grid-add + -[ display ] closed-quot { 400 400 } over set-slate-dim dup >slate -over @center grid-add + -{ -{ T{ key-down f f "1" } [ [ start-center ] view-action ] } -{ T{ key-down f f "2" } [ [ start-random ] view-action ] } -{ T{ key-down f f "3" } [ [ run-rule ] view-action ] } -{ T{ key-down f f "5" } [ [ random-rule ] view-action ] } -{ T{ key-down f f "n" } [ [ automata-window ] view-action ] } -} [ make* ] map >hashtable tuck set-gadget-delegate -"Automata" open-window ; + "1 - Center" [ start-center ] view-button add-gadget + "2 - Random" [ start-random ] view-button add-gadget + "3 - Continue" [ run-rule ] view-button add-gadget + "5 - Random Rule" [ random-rule ] view-button add-gadget + "n - New" [ automata-window ] view-button add-gadget + + @top grid-add + + C[ display ] + { 400 400 } >>dim + dup >slate + + @center grid-add + + H{ } + T{ key-down f f "1" } [ start-center ] view-action is + T{ key-down f f "2" } [ start-random ] view-action is + T{ key-down f f "3" } [ run-rule ] view-action is + T{ key-down f f "5" } [ random-rule ] view-action is + T{ key-down f f "n" } [ automata-window ] view-action is + + + + tuck set-gadget-delegate + + "Automata" open-window ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/benchmark/stack/stack.factor b/extra/benchmark/stack/stack.factor new file mode 100644 index 0000000000..d4dc18e80f --- /dev/null +++ b/extra/benchmark/stack/stack.factor @@ -0,0 +1,19 @@ +USING: kernel sequences math math.functions vectors ; +IN: benchmark.stack + +: stack-loop ( vec -- ) + 1000 [ + 10000 [ + dup pop dup ! dup 10 > [ sqrt dup 1 + ] [ dup 2 * ] if + pick push + over push + ] times + 10000 [ dup pop* ] times + ] times + drop ; + +: stack-benchmark ( -- ) + V{ 123456 } clone stack-loop + 20000 123456 over set-first stack-loop ; + +MAIN: stack-benchmark diff --git a/extra/biassocs/authors.txt b/extra/biassocs/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/biassocs/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/biassocs/biassocs-docs.factor b/extra/biassocs/biassocs-docs.factor new file mode 100644 index 0000000000..1fde3d05b3 --- /dev/null +++ b/extra/biassocs/biassocs-docs.factor @@ -0,0 +1,28 @@ +IN: biassocs +USING: help.markup help.syntax assocs kernel ; + +HELP: biassoc +{ $class-description "The class of bidirectional assocs. Bidirectional assoc are implemented by combining two assocs, with one the transpose of the other." } ; + +HELP: +{ $values { "exemplar" assoc } { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a new assoc of the same type as " { $snippet "exemplar" } " for underlying storage." } ; + +HELP: +{ $values { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ; + +HELP: once-at +{ $values { "value" object } { "key" object } { "assoc" assoc } } +{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ; + +ARTICLE: "biassocs" "Bidirectional assocs" +"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." +$nl +"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." +{ $subsection biassoc } +{ $subsection biassoc? } +{ $subsection } +{ $subsection } ; + +ABOUT: "biassocs" diff --git a/extra/biassocs/biassocs-tests.factor b/extra/biassocs/biassocs-tests.factor new file mode 100644 index 0000000000..4cd7f00f80 --- /dev/null +++ b/extra/biassocs/biassocs-tests.factor @@ -0,0 +1,22 @@ +IN: biassocs.tests +USING: biassocs assocs namespaces tools.test ; + + "h" set + +[ 0 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 2 "h" get set-at ] unit-test + +[ 1 ] [ 2 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 1 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 3 "h" get set-at ] unit-test + +[ 1 ] [ 3 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 2 ] [ "h" get assoc-size ] unit-test diff --git a/extra/biassocs/biassocs.factor b/extra/biassocs/biassocs.factor new file mode 100644 index 0000000000..cd1e57f6ec --- /dev/null +++ b/extra/biassocs/biassocs.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs accessors ; +IN: biassocs + +TUPLE: biassoc from to ; + +: ( exemplar -- biassoc ) + [ clone ] [ clone ] bi biassoc boa ; + +: ( -- biassoc ) + H{ } ; + +M: biassoc assoc-size from>> assoc-size ; + +M: biassoc at* from>> at* ; + +M: biassoc value-at* to>> at* ; + +: once-at ( value key assoc -- ) + 2dup key? [ 3drop ] [ set-at ] if ; + +M: biassoc set-at + [ from>> set-at ] [ swapd to>> once-at ] 3bi ; + +M: biassoc delete-at + "biassocs do not support deletion" throw ; + +M: biassoc >alist + from>> >alist ; + +M: biassoc clear-assoc + [ from>> clear-assoc ] [ to>> clear-assoc ] bi ; + +INSTANCE: biassoc assoc diff --git a/extra/biassocs/summary.txt b/extra/biassocs/summary.txt new file mode 100644 index 0000000000..84c5b15afc --- /dev/null +++ b/extra/biassocs/summary.txt @@ -0,0 +1 @@ +Bidirectional assocs diff --git a/extra/biassocs/tags.txt b/extra/biassocs/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/biassocs/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/bit-arrays/bit-arrays.factor b/extra/bit-arrays/bit-arrays.factor index 3d699a2623..4e6f7428b0 100755 --- a/extra/bit-arrays/bit-arrays.factor +++ b/extra/bit-arrays/bit-arrays.factor @@ -76,7 +76,7 @@ M: bit-array byte-length length 7 + -3 shift ; n zero? [ 0 ] [ [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | [ n' zero? not ] [ - n' out underlying>> i 255 bitand set-alien-unsigned-1 + n' out underlying>> i set-alien-unsigned-1 n' -8 shift n'! i 1+ i! ] [ ] while diff --git a/extra/bitfields/tags.txt b/extra/bitfields/tags.txt index 9ffc038dbd..f4274299b1 100644 --- a/extra/bitfields/tags.txt +++ b/extra/bitfields/tags.txt @@ -1,2 +1 @@ -collections extensions diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index e6c97b90dd..ab624a606b 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -6,14 +6,17 @@ USING: combinators.short-circuit kernel namespaces math.order math.vectors math.trig + math.physics.pos + math.physics.vel combinators arrays sequences random vars - combinators.lib ; + combinators.lib + accessors ; IN: boids ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: boid pos vel ; +TUPLE: boid < vel ; C: boid @@ -70,10 +73,6 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: distance ( boid boid -- n ) [ boid-pos ] [ boid-pos ] bi* v- norm ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : constrain ( n a b -- n ) rot min max ; : angle-between ( vec vec -- angle ) @@ -81,10 +80,10 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ; +: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ; : relative-angle ( self other -- angle ) -over boid-vel -rot relative-position angle-between ; +over vel>> -rot relative-position angle-between ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -92,9 +91,9 @@ over boid-vel -rot relative-position angle-between ; : vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ; -: average-position ( boids -- pos ) [ boid-pos ] map vaverage ; +: average-position ( boids -- pos ) [ pos>> ] map vaverage ; -: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ; +: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -123,7 +122,7 @@ over boid-vel -rot relative-position angle-between ; dup cohesion-neighborhood dup empty? [ 2drop { 0 0 } ] - [ average-position swap boid-pos v- normalize* cohesion-weight> v*n ] + [ average-position swap pos>> v- normalize* cohesion-weight> v*n ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -143,7 +142,7 @@ over boid-vel -rot relative-position angle-between ; dup separation-neighborhood dup empty? [ 2drop { 0 0 } ] - [ average-position swap boid-pos swap v- normalize* separation-weight> v*n ] + [ average-position swap pos>> swap v- normalize* separation-weight> v*n ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -206,10 +205,10 @@ cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: new-pos ( boid -- pos ) [ boid-pos ] [ boid-vel time-slice> v*n ] bi v+ ; +: new-pos ( boid -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ; : new-vel ( boid -- vel ) - [ boid-vel ] [ acceleration time-slice> v*n ] bi v+ normalize* ; + [ vel>> ] [ acceleration time-slice> v*n ] bi v+ normalize* ; : wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ; diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index e3c54e0744..f45b1cc0ff 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -19,7 +19,9 @@ USING: combinators.short-circuit kernel namespaces ui.gadgets.packs ui.gadgets.grids ui.gestures - assocs.lib vars rewrite-closures boids ; + assocs.lib vars rewrite-closures boids accessors + math.geometry.rect + newfx ; IN: boids.ui @@ -27,9 +29,9 @@ IN: boids.ui ! draw-boid ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: point-a ( boid -- a ) boid-pos ; +: point-a ( boid -- a ) pos>> ; -: point-b ( boid -- b ) [ boid-pos ] [ boid-vel normalize* 20 v*n ] bi v+ ; +: point-b ( boid -- b ) [ pos>> ] [ vel>> normalize* 20 v*n ] bi v+ ; : boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ; @@ -112,52 +114,54 @@ VARS: population-label cohesion-label alignment-label separation-label ; + + { [ "ESC - Pause" [ drop toggle-loop ] button* ] [ "1 - Randomize" [ drop randomize ] button* ] [ 1 over set-pack-fill - population-label> over add-gadget - "3 - Add 10" [ drop add-10-boids ] button* over add-gadget - "2 - Sub 10" [ drop sub-10-boids ] button* over add-gadget ] + population-label> add-gadget + "3 - Add 10" [ drop add-10-boids ] button* add-gadget + "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ] [ 1 over set-pack-fill - cohesion-label> over add-gadget - "q - +0.1" [ drop inc-cohesion-weight ] button* over add-gadget - "a - -0.1" [ drop dec-cohesion-weight ] button* over add-gadget ] + cohesion-label> add-gadget + "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget + "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ] [ 1 over set-pack-fill - alignment-label> over add-gadget - "w - +0.1" [ drop inc-alignment-weight ] button* over add-gadget - "s - -0.1" [ drop dec-alignment-weight ] button* over add-gadget ] + alignment-label> add-gadget + "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget + "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ] [ 1 over set-pack-fill - separation-label> over add-gadget - "e - +0.1" [ drop inc-separation-weight ] button* over add-gadget - "d - -0.1" [ drop dec-separation-weight ] button* over add-gadget ] + separation-label> add-gadget + "e - +0.1" [ drop inc-separation-weight ] button* add-gadget + "d - -0.1" [ drop dec-separation-weight ] button* add-gadget ] - } [ call ] map [ [ gadget, ] each ] make-shelf + } [ call ] map [ add-gadget ] each 1 over set-pack-fill over @top grid-add slate> over @center grid-add H{ } clone - T{ key-down f f "1" } C[ drop randomize ] put-at - T{ key-down f f "2" } C[ drop sub-10-boids ] put-at - T{ key-down f f "3" } C[ drop add-10-boids ] put-at + T{ key-down f f "1" } C[ drop randomize ] is + T{ key-down f f "2" } C[ drop sub-10-boids ] is + T{ key-down f f "3" } C[ drop add-10-boids ] is - T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at - T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at + T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is + T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is - T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at - T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at + T{ key-down f f "w" } C[ drop inc-alignment-weight ] is + T{ key-down f f "s" } C[ drop dec-alignment-weight ] is - T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at - T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at + T{ key-down f f "e" } C[ drop inc-separation-weight ] is + T{ key-down f f "d" } C[ drop dec-separation-weight ] is - T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at + T{ key-down f f "ESC" } C[ drop toggle-loop ] is tuck set-gadget-delegate "Boids" open-window ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index b4cefbc5bd..ed89f2a809 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,34 +1,25 @@ -USING: alien alien.c-types arrays sequences math math.vectors -math.matrices math.parser io io.files kernel opengl opengl.gl -opengl.glu shuffle http.client vectors namespaces ui.gadgets -ui.gadgets.canvas ui.render ui splitting combinators -system combinators.lib float-arrays continuations -opengl.demo-support multiline ui.gestures bunny.fixed-pipeline -bunny.cel-shaded bunny.outlined bunny.model accessors destructors ; +USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline +bunny.model bunny.outlined destructors kernel math opengl.demo-support +opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ; IN: bunny -TUPLE: bunny-gadget model geom draw-seq draw-n ; +TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; : ( -- bunny-gadget ) - 0.0 0.0 0.375 - maybe-download read-model { - set-delegate - (>>model) - } bunny-gadget construct ; + 0.0 0.0 0.375 bunny-gadget new-demo-gadget + maybe-download read-model >>model-triangles ; : bunny-gadget-draw ( gadget -- draw ) - { draw-n>> draw-seq>> } - get-slots nth ; + [ draw-n>> ] [ draw-seq>> ] bi nth ; : bunny-gadget-next-draw ( gadget -- ) - dup { draw-seq>> draw-n>> } - get-slots + dup [ draw-seq>> ] [ draw-n>> ] bi 1+ swap length mod >>draw-n relayout-1 ; M: bunny-gadget graft* ( gadget -- ) GL_DEPTH_TEST glEnable - dup model>> >>geom + dup model-triangles>> >>geom dup [ ] [ ] @@ -48,8 +39,7 @@ M: bunny-gadget draw-gadget* ( gadget -- ) dup demo-gadget-set-matrices GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - { geom>> bunny-gadget-draw } get-slots - draw-bunny + [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny ] if ; M: bunny-gadget pref-dim* ( gadget -- dim ) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index fce73785b5..f64030ff70 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,9 +1,7 @@ -USING: alien alien.c-types arrays sequences math math.vectors -math.matrices math.parser io io.files kernel opengl opengl.gl -opengl.glu io.encodings.ascii opengl.capabilities shuffle -http.client vectors splitting system combinators -float-arrays continuations destructors namespaces sequences.lib -accessors ; +USING: accessors alien.c-types arrays combinators destructors http.client +io io.encodings.ascii io.files kernel math math.matrices math.parser +math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib +splitting vectors words ; IN: bunny.model : numbers ( str -- seq ) @@ -66,7 +64,7 @@ TUPLE: bunny-buffers array element-array nv ni ; { [ [ first concat ] [ second concat ] bi - append >c-double-array + append >c-float-array GL_ARRAY_BUFFER swap GL_STATIC_DRAW ] [ @@ -86,10 +84,10 @@ M: bunny-dlist bunny-geom M: bunny-buffers bunny-geom dup { array>> element-array>> } get-slots [ { GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [ - GL_DOUBLE 0 0 buffer-offset glNormalPointer + GL_FLOAT 0 0 buffer-offset glNormalPointer [ - nv>> "double" heap-size * buffer-offset - 3 GL_DOUBLE 0 roll glVertexPointer + nv>> "float" heap-size * buffer-offset + 3 GL_FLOAT 0 roll glVertexPointer ] [ ni>> GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index f3ee4594c7..fcba98a0e9 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -181,10 +181,9 @@ TUPLE: bunny-outlined ] [ drop ] if ; : remake-framebuffer-if-needed ( draw -- ) - dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi - over = - [ 2drop ] [ - [ dup dispose-framebuffer dup ] dip { + dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi = + [ drop ] [ + [ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri { [ GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) [ >>color-texture drop ] keep @@ -196,7 +195,8 @@ TUPLE: bunny-outlined [ >>depth-texture drop ] keep ] } 2cleave - (make-framebuffer) >>framebuffer drop + [ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi + drop ] if ; : clear-framebuffer ( -- ) diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 99968ca3c3..b5938a7ad7 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -3,7 +3,7 @@ USING: kernel math math.functions math.parser models models.filter models.range models.compose sequences ui ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs -ui.gadgets.sliders ui.render ; +ui.gadgets.sliders ui.render math.geometry.rect ; IN: color-picker ! Simple example demonstrating the use of models. @@ -15,7 +15,8 @@ TUPLE: color-preview < gadget ; : ( model -- gadget ) color-preview new-gadget - { 100 100 } over set-rect-dim ; + swap >>model + { 100 100 } >>dim ; M: color-preview model-changed swap model-value over set-gadget-interior relayout-1 ; @@ -26,7 +27,10 @@ M: color-preview model-changed : ( -- model gadget ) 3 [ 0 0 0 255 ] replicate dup [ range-model ] map - swap [ [ gadget, ] each ] make-filled-pile ; + swap + + swap + [ add-gadget ] each ; : ( -- gadget ) [ diff --git a/extra/float-arrays/float-arrays.factor b/extra/float-arrays/float-arrays.factor index 025a580633..0aa7fa5056 100755 --- a/extra/float-arrays/float-arrays.factor +++ b/extra/float-arrays/float-arrays.factor @@ -9,16 +9,8 @@ TUPLE: float-array { length array-capacity read-only } { underlying byte-array read-only } ; -bytes 8 * ; inline - -: float-array@ underlying>> swap >fixnum floats>bytes ; inline - -PRIVATE> - : ( n -- float-array ) - dup floats>bytes float-array boa ; inline + dup "double" float-array boa ; inline M: float-array clone [ length>> ] [ underlying>> clone ] bi float-array boa ; @@ -26,13 +18,13 @@ M: float-array clone M: float-array length length>> ; M: float-array nth-unsafe - float-array@ alien-double ; + underlying>> double-nth ; M: float-array set-nth-unsafe - [ >float ] 2dip float-array@ set-alien-double ; + [ >float ] 2dip underlying>> set-double-nth ; : >float-array ( seq -- float-array ) - T{ float-array f 0 B{ } } clone-like ; inline + T{ float-array } clone-like ; inline M: float-array like drop dup float-array? [ >float-array ] unless ; @@ -45,7 +37,7 @@ M: float-array equal? M: float-array resize [ drop ] [ - [ floats>bytes ] [ underlying>> ] bi* + [ "double" heap-size * ] [ underlying>> ] bi* resize-byte-array ] 2bi float-array boa ; @@ -58,13 +50,13 @@ INSTANCE: float-array sequence 1 [ set-first ] keep ; flushable : 2float-array ( x y -- array ) - T{ float-array f 0 B{ } } 2sequence ; flushable + T{ float-array } 2sequence ; flushable : 3float-array ( x y z -- array ) - T{ float-array f 0 B{ } } 3sequence ; flushable + T{ float-array } 3sequence ; flushable : 4float-array ( w x y z -- array ) - T{ float-array f 0 B{ } } 4sequence ; flushable + T{ float-array } 4sequence ; flushable : F{ ( parsed -- parsed ) \ } [ >float-array ] parse-literal ; parsing @@ -72,3 +64,20 @@ INSTANCE: float-array sequence M: float-array pprint-delims drop \ F{ \ } ; M: float-array >pprint-sequence ; + +USING: hints math.vectors arrays ; + +HINTS: vneg { float-array } { array } ; +HINTS: v*n { float-array object } { array object } ; +HINTS: v/n { float-array object } { array object } ; +HINTS: n/v { object float-array } { object array } ; +HINTS: v+ { float-array float-array } { array array } ; +HINTS: v- { float-array float-array } { array array } ; +HINTS: v* { float-array float-array } { array array } ; +HINTS: v/ { float-array float-array } { array array } ; +HINTS: vmax { float-array float-array } { array array } ; +HINTS: vmin { float-array float-array } { array array } ; +HINTS: v. { float-array float-array } { array array } ; +HINTS: norm-sq { float-array } { array } ; +HINTS: norm { float-array } { array } ; +HINTS: normalize { float-array } { array } ; diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor index ba0ff5bedd..d79593c337 100644 --- a/extra/gesture-logger/gesture-logger.factor +++ b/extra/gesture-logger/gesture-logger.factor @@ -5,10 +5,10 @@ ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors accessors ; IN: gesture-logger -TUPLE: gesture-logger stream ; +TUPLE: gesture-logger < gadget stream ; : ( stream -- gadget ) - \ gesture-logger construct-gadget + \ gesture-logger new-gadget swap >>stream { 100 100 } >>dim black solid-interior ; diff --git a/extra/hints/hints.factor b/extra/hints/hints.factor index 266e635867..82941a69de 100644 --- a/extra/hints/hints.factor +++ b/extra/hints/hints.factor @@ -1,6 +1,10 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser words definitions kernel ; IN: hints -USING: parser words ; -: HINTS: - scan-word parse-definition "specializer" set-word-prop ; +: HINTS: + scan-word + [ +inlined+ changed-definition ] + [ parse-definition "specializer" set-word-prop ] bi ; parsing diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index f08082c4ee..e6a0070ee0 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -25,7 +25,7 @@ M: buffer dispose* ptr>> free ; [ size>> ] [ fill>> ] bi - ; inline : buffer-empty? ( buffer -- ? ) - fill>> zero? ; + fill>> zero? ; inline : buffer-consume ( n buffer -- ) [ + ] change-pos diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 77e984e6e5..26b06dba8b 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -19,7 +19,7 @@ M: port set-timeout (>>timeout) ; : ( handle class -- port ) new swap >>handle ; inline -TUPLE: buffered-port < port buffer ; +TUPLE: buffered-port < port { buffer buffer } ; : ( handle class -- port ) @@ -35,7 +35,7 @@ HOOK: (wait-to-read) io-backend ( port -- ) : wait-to-read ( port -- eof? ) dup buffer>> buffer-empty? [ dup (wait-to-read) buffer>> buffer-empty? - ] [ drop f ] if ; + ] [ drop f ] if ; inline M: input-port stream-read1 dup check-disposed @@ -140,9 +140,7 @@ M: output-port dispose* ] with-destructors ; M: buffered-port dispose* - [ call-next-method ] - [ [ [ dispose ] when* f ] change-buffer drop ] - bi ; + [ call-next-method ] [ buffer>> dispose ] bi ; M: port cancel-operation handle>> cancel-operation ; @@ -152,3 +150,13 @@ M: port dispose* [ handle>> shutdown ] bi ] with-destructors ; + +! Fast-path optimization +USING: hints strings io.encodings.utf8 io.encodings.ascii +io.encodings.private ; + +HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ; + +HINTS: decoder-readln { input-port utf8 } { input-port ascii } ; + +HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index b7764894d1..d9a0f84b53 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ; +USING: accessors alarms arrays calendar jamshred.game jamshred.gl +jamshred.player jamshred.log kernel math math.constants namespaces +sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds +ui.gestures ui.render math.vectors math.geometry.rect ; IN: jamshred TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; diff --git a/extra/lists/tags.txt b/extra/lists/tags.txt index e44334b2b5..42d711b32b 100644 --- a/extra/lists/tags.txt +++ b/extra/lists/tags.txt @@ -1,3 +1 @@ -cons -lists -sequences +collections diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor index 8f9513ff2a..f7ec181f61 100644 --- a/extra/lsys/ui/ui.factor +++ b/extra/lsys/ui/ui.factor @@ -17,7 +17,7 @@ USING: kernel namespaces threads math math.order math.vectors self pos ori turtle opengl.camera lsys.tortoise lsys.tortoise.graphics lsys.strings.rewrite lsys.strings.interpret - combinators.short-circuit ; + combinators.short-circuit accessors ; ! lsys.strings ! lsys.strings.rewrite @@ -99,6 +99,8 @@ DEFER: empty-model : lsys-controller ( -- ) + + { [ "Load"