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

core/alien/c-types/c-types-tests.factor

@@ -48,3 +48,5 @@ TYPEDEF: uchar* MyLPBYTE
 [
     0 B{ 1 2 3 4 } <displaced-alien> <void*>
 ] must-fail
+
+[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test

core/alien/c-types/c-types.factor

@@ -151,7 +151,9 @@ 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 ;
+    [
+        \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
+    ] [ ] make define-inline ;
 
 : nth-word ( name vocab -- word )
     >r "-nth" append r> create ;
@@ -348,7 +350,7 @@ M: long-long-type box-return ( type -- )
 
     <c-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 +359,7 @@ M: long-long-type box-return ( type -- )
 
     <c-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 +370,7 @@ M: long-long-type box-return ( type -- )
 
     <c-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

core/assocs/assocs-docs.factor

@@ -44,10 +44,11 @@ ARTICLE: "assocs-protocol" "Associative mapping protocol"
 { $subsection set-at }
 { $subsection delete-at }
 { $subsection clear-assoc }
-"The following two words are optional:"
+"The following three words are optional:"
+{ $subsection value-at* }
 { $subsection new-assoc }
 { $subsection assoc-like }
-"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode } " generic words. Two utility words will help with the implementation of the last two:"
+"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode* } " generic words. Two utility words will help with the implementation of the last two:"
 { $subsection assoc= }
 { $subsection assoc-hashcode }
 "Finally, assoc classes should define a word for converting other types of assocs; conventionally, such words are named " { $snippet ">" { $emphasis "class" } } " where " { $snippet { $emphasis "class" } } " is the class name. Such a word can be implemented using a utility:"
@@ -57,13 +58,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 +118,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 +239,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 } "." }
+{ $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." } ;
+
+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" } }

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 )
+M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
-    swap [ = nip ] curry assoc-find 2drop ;
+
+: value-at ( value assoc -- key/f ) value-at* drop ;
+
+: value? ( value assoc -- ? ) value-at* nip ;
 
 : push-at ( value key assoc -- )
     [ ?push ] change-at ;

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

core/bootstrap/primitives.factor

@@ -121,7 +121,7 @@ bootstrapping? on
     [ [ dup pair? [ first2 create ] when ] map ] map ;
 
 : define-builtin-slots ( class slots -- )
-    prepare-slots 1 make-slots
+    prepare-slots make-slots 1 finalize-slots
     [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
 
 : define-builtin ( symbol slotspec -- )
@@ -273,18 +273,16 @@ bi
     { "echelon" { "fixnum" "math" } read-only }
 } define-builtin
 
-"tuple" "kernel" create {
+"tuple" "kernel" create
 [ { } define-builtin ]
-    [ { "delegate" } "slot-names" set-word-prop ]
 [ define-tuple-layout ]
 [
-        { "delegate" }
+    { "delegate" } make-slots
-        [ drop ] [ generate-tuple-slots ] 2bi
+    [ drop ] [ finalize-tuple-slots ] 2bi
     [ "slots" set-word-prop ]
     [ define-accessors ]
     2bi
-    ]
+] tri
-} cleave
 
 ! Create special tombstone values
 "tombstone" "hashtables.private" create

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

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 ;

core/classes/tuple/parser/parser-tests.factor

@@ -1,35 +1,44 @@
 IN: classes.tuple.parser.tests
 USING: accessors classes.tuple.parser lexer words classes
-sequences math kernel slots tools.test parser compiler.units ;
+sequences math kernel slots tools.test parser compiler.units
+arrays classes.tuple ;
 
 TUPLE: test-1 ;
 
-[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test
+[ t ] [ test-1 "slots" word-prop empty? ] unit-test
 
 TUPLE: test-2 < test-1 ;
 
-[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test
+[ t ] [ test-2 "slots" word-prop empty? ] unit-test
 [ test-1 ] [ test-2 superclass ] unit-test
 
 TUPLE: test-3 a ;
 
-[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test
+[ { "a" } ] [ test-3 "slots" word-prop [ name>> ] map ] unit-test
 
 [ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
 
 TUPLE: test-4 < test-3 b ;
 
-[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test
+[ { "b" } ] [ test-4 "slots" word-prop [ name>> ] map ] unit-test
 
 TUPLE: test-5 { a integer } ;
 
-[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test
+[ { { "a" integer } } ]
+[
+    test-5 "slots" word-prop
+    [ [ name>> ] [ class>> ] bi 2array ] map
+] unit-test
 
 TUPLE: test-6 < test-5 { b integer } ;
 
 [ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test
 
-[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test
+[ { { "b" integer } } ]
+[
+    test-6 "slots" word-prop
+    [ [ name>> ] [ class>> ] bi 2array ] map
+] unit-test
 
 TUPLE: test-7 { b integer initial: 3 } ;
 
@@ -39,6 +48,8 @@ TUPLE: test-8 { b integer read-only } ;
 
 [ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test
 
+DEFER: foo
+
 [ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
 [ error>> invalid-slot-name? ]
 must-fail-with
@@ -51,17 +62,33 @@ must-fail-with
 [ error>> unexpected-eof? ]
 must-fail-with
 
-[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ]
+2 [
+    [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
     [ error>> no-initial-value? ]
     must-fail-with
 
+    [ f ] [ \ foo tuple-class? ] unit-test
+] times
+
+2 [
     [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
     [ error>> bad-initial-value? ]
     must-fail-with
 
+    [ f ] [ \ foo tuple-class? ] unit-test
+] times
+
+[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ]
+[ error>> duplicate-slot-names? ]
+must-fail-with
+
+[ f ] [ \ foo tuple-class? ] unit-test
+
 [ ] [
     [
-        { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 }
+        { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 foo }
         [ dup class? [ forget-class ] [ drop ] if ] each
     ] with-compilation-unit
 ] unit-test
+
+

core/classes/tuple/parser/parser.factor

@@ -4,10 +4,11 @@ USING: accessors kernel sets namespaces sequences summary parser
 lexer combinators words classes.parser classes.tuple arrays ;
 IN: classes.tuple.parser
 
+: slot-names ( slots -- seq )
+    [ dup array? [ first ] when ] map ;
+
 : shadowed-slots ( superclass slots -- shadowed )
-    [ all-slots [ name>> ] map ]
+    [ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
-    [ [ dup array? [ first ] when ] map ]
-    bi* intersect ;
 
 : check-slot-shadowing ( class superclass slots -- )
     shadowed-slots [
@@ -20,11 +21,19 @@ IN: classes.tuple.parser
         ] "" make note.
     ] with each ;
 
+ERROR: duplicate-slot-names names ;
+
+M: duplicate-slot-names summary
+    drop "Duplicate slot names" ;
+
+: check-duplicate-slots ( slots -- )
+    slot-names duplicates
+    dup empty? [ drop ] [ duplicate-slot-names ] if ;
+
 ERROR: invalid-slot-name name ;
 
 M: invalid-slot-name summary
-    drop
+    drop "Invalid slot name" ;
-    "Invalid slot name" ;
 
 : parse-long-slot-name ( -- )
     [ scan , \ } parse-until % ] { } make ;
@@ -38,7 +47,7 @@ M: invalid-slot-name summary
     #! : ...
     {
         { [ dup not ] [ unexpected-eof ] }
-        { [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
+        { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
         { [ dup ";" = ] [ drop f ] }
         [ dup "{" = [ drop parse-long-slot-name ] when , t ]
     } cond ;
@@ -52,4 +61,6 @@ M: invalid-slot-name summary
         { ";" [ tuple f ] }
         { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
         [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
-    } case 3dup check-slot-shadowing ;
+    } case
+    dup check-duplicate-slots
+    3dup check-slot-shadowing ;

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 }"
+    "{ underlying string }"
-    "{ \"length\" array-capacity } ;"
+    "{ length array-capacity } ;"
     ""
     "INSTANCE: sbuf growable"
 }
 "with that of the " { $link vector } " class:"
 { $code
     "TUPLE: vector"
-    "{ \"underlying\" array }"
+    "{ underlying array }"
-    "{ \"length\" array-capacity } ;"
+    "{ length array-capacity } ;"
     ""
     "INSTANCE: vector growable"
 } ;
@@ -346,11 +346,9 @@ HELP: tuple
 $nl
 "Tuple classes have additional word properties:"
 { $list
-    { { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
     { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
     { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
-    { { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
+    { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
-    { { $snippet "\"tuple-size\"" } " - the number of slots" }
 } } ;
 
 HELP: define-tuple-predicate

core/classes/tuple/tuple-tests.factor

@@ -443,36 +443,36 @@ TUPLE: redefinition-problem-2 ;
 ! Hardcore unit tests
 USE: threads
 
-\ thread slot-names "slot-names" set
+\ thread "slots" word-prop "slots" set
 
 [ ] [
     [
-        \ thread tuple { "xxx" } "slot-names" get append
+        \ thread tuple { "xxx" } "slots" get append
         define-tuple-class
     ] with-compilation-unit
 
     [ 1337 sleep ] "Test" spawn drop
 
     [
-        \ thread tuple "slot-names" get
+        \ thread tuple "slots" get
         define-tuple-class
     ] with-compilation-unit
 ] unit-test
 
 USE: vocabs
 
-\ vocab slot-names "slot-names" set
+\ vocab "slots" word-prop "slots" set
 
 [ ] [
     [
-        \ vocab tuple { "xxx" } "slot-names" get append
+        \ vocab tuple { "xxx" } "slots" get append
         define-tuple-class
     ] with-compilation-unit
 
     all-words drop
 
     [
-        \ vocab tuple "slot-names" get
+        \ vocab tuple "slots" get
         define-tuple-class
     ] with-compilation-unit
 ] unit-test

core/classes/tuple/tuple.factor

@@ -22,18 +22,6 @@ ERROR: not-a-tuple object ;
 
 <PRIVATE
 
-: (tuple) ( layout -- tuple )
-    #! In non-optimized code, this word simply calls the
-    #! <tuple> primitive. In optimized code, an intrinsic
-    #! is generated which allocates a tuple but does not set
-    #! any of its slots. This means that any code that uses
-    #! (tuple) must fill in the slots before the next
-    #! call to GC.
-    #!
-    #! This word is only used in the expansion of <tuple-boa>,
-    #! where this invariant is guaranteed to hold.
-    <tuple> ;
-
 : tuple-layout ( class -- layout )
     "layout" word-prop ;
 
@@ -86,9 +74,6 @@ M: tuple-class slots>tuple
 : >tuple ( seq -- tuple )
     unclip slots>tuple ;
 
-: slot-names ( class -- seq )
-    "slot-names" word-prop ;
-
 ERROR: bad-superclass class ;
 
 <PRIVATE
@@ -116,7 +101,7 @@ ERROR: bad-superclass class ;
 
 : superclass-size ( class -- n )
     superclasses but-last-slice
-    [ slot-names length ] sigma ;
+    [ "slots" word-prop length ] sigma ;
 
 : (instance-check-quot) ( class -- quot )
     [
@@ -150,19 +135,18 @@ ERROR: bad-superclass class ;
 : define-tuple-prototype ( class -- )
     dup tuple-prototype "prototype" set-word-prop ;
 
-: generate-tuple-slots ( class slots -- slot-specs )
+: finalize-tuple-slots ( class slots -- slots )
-    over superclass-size 2 + make-slots deprecated-slots ;
+    over superclass-size 2 + finalize-slots deprecated-slots ;
 
 : define-tuple-slots ( class -- )
-    dup dup "slot-names" word-prop generate-tuple-slots
+    dup dup "slots" word-prop finalize-tuple-slots
-    [ "slots" set-word-prop ]
     [ define-accessors ] ! new
     [ define-slots ] ! old
-    2tri ;
+    2bi ;
 
 : make-tuple-layout ( class -- layout )
     [ ]
-    [ [ superclass-size ] [ slot-names length ] bi + ]
+    [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
     [ superclasses dup length 1- ] tri
     <tuple-layout> ;
 
@@ -223,8 +207,9 @@ M: tuple-class update-class
     } cleave ;
 
 : define-new-tuple-class ( class superclass slots -- )
+    make-slots
     [ drop f f tuple-class define-class ]
-    [ nip "slot-names" set-word-prop ]
+    [ nip "slots" set-word-prop ]
     [ 2drop update-classes ]
     3tri ;
 
@@ -248,7 +233,7 @@ M: tuple-class update-class
     3bi ;
 
 : tuple-class-unchanged? ( class superclass slots -- ? )
-    rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
+    rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
 
 : valid-superclass? ( class -- ? )
     [ tuple-class? ] [ tuple eq? ] bi or ;
@@ -293,7 +278,7 @@ M: tuple-class reset-class
         [ call-next-method ]
         [
             {
-                "layout" "slots" "slot-names" "boa-check" "prototype"
+                "layout" "slots" "boa-check" "prototype"
             } reset-props
         ] bi
     ] bi ;
@@ -336,6 +321,8 @@ M: tuple-class boa
     [ tuple-layout ]
     bi <tuple-boa> ;
 
+M: tuple-class initial-value* new ;
+
 ! Deprecated
 M: object get-slots ( obj slots -- ... )
     [ execute ] with each ;

core/cpu/architecture/architecture.factor

@@ -162,8 +162,6 @@ PREDICATE: small-slot < integer cells small-enough? ;
 
 PREDICATE: small-tagged < integer v>operand small-enough? ;
 
-PREDICATE: inline-array < integer 32 < ;
-
 : if-small-struct ( n size true false -- ? )
     >r >r over not over struct-small-enough? and
     [ nip r> call r> drop ] [ r> drop r> call ] if ;

core/cpu/ppc/assembler/assembler-tests.factor

@@ -0,0 +1,118 @@
+IN: cpu.ppc.assembler.tests
+USING: cpu.ppc.assembler tools.test arrays kernel namespaces
+vocabs sequences ;
+
+: test-assembler ( expected quot -- )
+    [ 1array ] [ [ { } make ] curry ] bi* unit-test ;
+
+{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
+{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
+{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
+{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
+{ HEX: 38400001 } [ 1 2 LI ] test-assembler
+{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
+{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
+{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
+{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
+{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
+{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
+{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
+{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
+{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
+{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
+{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
+{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
+{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
+{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
+{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
+{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
+{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
+{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
+{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
+{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
+{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
+{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
+{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
+{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
+{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
+{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
+{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
+{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
+{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
+{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
+{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
+{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
+{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
+{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
+{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
+{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
+{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
+{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
+{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
+{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
+{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
+{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
+{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
+{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
+{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
+{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
+{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
+{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
+{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
+{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
+{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
+{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
+{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
+{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
+{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
+{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
+{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
+{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
+{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
+{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
+{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
+{ HEX: 48000001 } [ 1 B ] test-assembler
+{ HEX: 48000001 } [ 1 BL ] test-assembler
+{ HEX: 41800004 } [ 1 BLT ] test-assembler
+{ HEX: 41810004 } [ 1 BGT ] test-assembler
+{ HEX: 40810004 } [ 1 BLE ] test-assembler
+{ HEX: 40800004 } [ 1 BGE ] test-assembler
+{ HEX: 41800004 } [ 1 BLT ] test-assembler
+{ HEX: 40820004 } [ 1 BNE ] test-assembler
+{ HEX: 41820004 } [ 1 BEQ ] test-assembler
+{ HEX: 41830004 } [ 1 BO ] test-assembler
+{ HEX: 40830004 } [ 1 BNO ] test-assembler
+{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
+{ HEX: 4e800020 } [ BLR ] test-assembler
+{ HEX: 4e800021 } [ BLRL ] test-assembler
+{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
+{ HEX: 4e800420 } [ BCTR ] test-assembler
+{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
+{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
+{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
+{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
+{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
+{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
+{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
+{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
+{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
+{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
+{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
+{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
+{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
+{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
+{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
+{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
+{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
+{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
+{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
+{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
+{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
+{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
+{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
+{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
+{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
+{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
+{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
+
+"cpu.ppc.assembler" words [ must-infer ] each

core/cpu/ppc/assembler/assembler.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2005, 2006 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: generator.fixup generic kernel memory namespaces
+USING: generator.fixup kernel namespaces words io.binary math
-words math math.bitfields math.order io.binary ;
+math.order cpu.ppc.assembler.backend ;
 IN: cpu.ppc.assembler
 
 ! See the Motorola or IBM documentation for details. The opcode
@@ -15,215 +15,195 @@ IN: cpu.ppc.assembler
 !
 ! 14 15 10 STW
 
-: insn ( operand opcode -- ) { 26 0 } bitfield , ;
+! D-form
-: a-form ( d a b c xo rc -- n ) { 0 1 6 11 16 21 } bitfield ;
+D: ADDI 14
-: b-form ( bo bi bd aa lk -- n ) { 0 1 2 16 21 } bitfield ;
+D: ADDIC 12
-: s>u16 ( s -- u ) HEX: ffff bitand ;
+D: ADDIC. 13
-: d-form ( d a simm -- n ) s>u16 { 0 16 21 } bitfield ;
+D: ADDIS 15
-: sd-form ( d a simm -- n ) s>u16 { 0 21 16 } bitfield ;
+D: CMPI 11
-: i-form ( li aa lk -- n ) { 0 1 0 } bitfield ;
+D: CMPLI 10
-: x-form ( a s b rc xo -- n ) { 1 0 11 21 16 } bitfield ;
+D: LBZ 34
-: xfx-form ( d spr xo -- n ) { 1 11 21 } bitfield ;
+D: LBZU 35
-: xo-form ( d a b oe rc xo -- n ) { 1 0 10 11 16 21 } bitfield ;
+D: LFD 50
+D: LFDU 51
+D: LFS 48
+D: LFSU 49
+D: LHA 42
+D: LHAU 43
+D: LHZ 40
+D: LHZU 41
+D: LWZ 32
+D: LWZU 33
+D: MULI 7
+D: MULLI 7
+D: STB 38
+D: STBU 39
+D: STFD 54
+D: STFDU 55
+D: STFS 52
+D: STFSU 53
+D: STH 44
+D: STHU 45
+D: STW 36
+D: STWU 37
 
-: ADDI d-form 14 insn ;   : LI 0 rot ADDI ;   : SUBI neg ADDI ;
+! SD-form
-: ADDIS d-form 15 insn ;  : LIS 0 rot ADDIS ;
+SD: ANDI 28
+SD: ANDIS 29
+SD: ORI 24
+SD: ORIS 25
+SD: XORI 26
+SD: XORIS 27
 
-: ADDIC d-form 12 insn ;  : SUBIC neg ADDIC ;
+! X-form
+X: AND 0 28 31
+X: AND. 1 28 31
+X: CMP 0 0 31
+X: CMPL 0 32 31
+X: EQV 0 284 31
+X: EQV. 1 284 31
+X: FCMPO 0 32 63
+X: FCMPU 0 0 63
+X: LBZUX 0 119 31
+X: LBZX 0 87 31
+X: LHAUX 0 375 31
+X: LHAX 0 343 31
+X: LHZUX 0 311 31
+X: LHZX 0 279 31
+X: LWZUX 0 55 31
+X: LWZX 0 23 31
+X: NAND 0 476 31
+X: NAND. 1 476 31
+X: NOR 0 124 31
+X: NOR. 1 124 31
+X: OR 0 444 31
+X: OR. 1 444 31
+X: ORC 0 412 31
+X: ORC. 1 412 31
+X: SLW 0 24 31
+X: SLW. 1 24 31
+X: SRAW 0 792 31
+X: SRAW. 1 792 31
+X: SRAWI 0 824 31
+X: SRW 0 536 31
+X: SRW. 1 536 31
+X: STBUX 0 247 31
+X: STBX 0 215 31
+X: STHUX 0 439 31
+X: STHX 0 407 31
+X: STWUX 0 183 31
+X: STWX 0 151 31
+X: XOR 0 316 31
+X: XOR. 1 316 31
+X1: EXTSB 0 954 31
+X1: EXTSB. 1 954 31
+: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
+: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
+: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
+: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
 
-: ADDIC. d-form 13 insn ; : SUBIC. neg ADDIC. ;
+! XO-form
+XO: ADD 0 0 266 31
+XO: ADD. 0 1 266 31
+XO: ADDC 0 0 10 31
+XO: ADDC. 0 1 10 31
+XO: ADDCO 1 0 10 31
+XO: ADDCO. 1 1 10 31
+XO: ADDE 0 0 138 31
+XO: ADDE. 0 1 138 31
+XO: ADDEO 1 0 138 31
+XO: ADDEO. 1 1 138 31
+XO: ADDO 1 0 266 31
+XO: ADDO. 1 1 266 31
+XO: DIVW 0 0 491 31
+XO: DIVW. 0 1 491 31
+XO: DIVWO 1 0 491 31
+XO: DIVWO. 1 1 491 31
+XO: DIVWU 0 0 459 31
+XO: DIVWU. 0 1 459 31
+XO: DIVWUO 1 0 459 31
+XO: DIVWUO. 1 1 459 31
+XO: MULHW 0 0 75 31
+XO: MULHW. 0 1 75 31
+XO: MULHWU 0 0 11 31
+XO: MULHWU. 0 1 11 31
+XO: MULLW 0 0 235 31
+XO: MULLW. 0 1 235 31
+XO: MULLWO 1 0 235 31
+XO: MULLWO. 1 1 235 31
+XO: SUBF 0 0 40 31
+XO: SUBF. 0 1 40 31
+XO: SUBFC 0 0 8 31
+XO: SUBFC. 0 1 8 31
+XO: SUBFCO 1 0 8 31
+XO: SUBFCO. 1 1 8 31
+XO: SUBFE 0 0 136 31
+XO: SUBFE. 0 1 136 31
+XO: SUBFEO 1 0 136 31
+XO: SUBFEO. 1 1 136 31
+XO: SUBFO 1 0 40 31
+XO: SUBFO. 1 1 40 31
+XO1: NEG 0 0 104 31
+XO1: NEG. 0 1 104 31
+XO1: NEGO 1 0 104 31
+XO1: NEGO. 1 1 104 31
 
-: MULI d-form 7 insn ;
+! A-form
+: RLWINM ( d a b c xo -- ) 0 21 a-insn ;
+: RLWINM. ( d a b c xo -- ) 1 21 a-insn ;
+: FADD ( d a b -- ) 0 21 0 63 a-insn ;
+: FADD. ( d a b -- ) 0 21 1 63 a-insn ;
+: FSUB ( d a b -- ) 0 20 0 63 a-insn ;
+: FSUB. ( d a b -- ) 0 20 1 63 a-insn ;
+: FMUL ( d a c -- )  0 swap 25 0 63 a-insn ;
+: FMUL. ( d a c -- ) 0 swap 25 1 63 a-insn ;
+: FDIV ( d a b -- ) 0 18 0 63 a-insn ;
+: FDIV. ( d a b -- ) 0 18 1 63 a-insn ;
+: FSQRT ( d b -- ) 0 swap 0 22 0 63 a-insn ;
+: FSQRT. ( d b -- ) 0 swap 0 22 1 63 a-insn ;
 
-: (ADD) 266 xo-form 31 insn ;
+! Branches
-: ADD 0 0 (ADD) ;  : ADD. 0 1 (ADD) ;
+: B ( dest -- ) 0 0 (B) ;
-: ADDO 1 0 (ADD) ; : ADDO. 1 1 (ADD) ;
+: BL ( dest -- ) 0 1 (B) ;
+BC: LT 12 0
+BC: GE 4 0
+BC: GT 12 1
+BC: LE 4 1
+BC: EQ 12 2
+BC: NE 4 2
+BC: O  12 3
+BC: NO 4 3
+B: CLR 0 8 0 0 19
+B: CLRL 0 8 0 1 19
+B: CCTR 0 264 0 0 19
+: BLR ( -- ) 20 BCLR ;
+: BLRL ( -- ) 20 BCLRL ;
+: BCTR ( -- ) 20 BCCTR ;
 
-: (ADDC) 10 xo-form 31 insn ;
+! Special registers
-: ADDC 0 0 (ADDC) ;  : ADDC. 0 1 (ADDC) ;
+MFSPR: XER 1
-: ADDCO 1 0 (ADDC) ; : ADDCO. 1 1 (ADDC) ;
+MFSPR: LR 8
+MFSPR: CTR 9
+MTSPR: XER 1
+MTSPR: LR 8
+MTSPR: CTR 9
 
-: (ADDE) 138 xo-form 31 insn ;
+! Pseudo-instructions
-: ADDE 0 0 (ADDE) ;  : ADDE. 0 1 (ADDE) ;
+: LI 0 rot ADDI ; inline
-: ADDEO 1 0 (ADDE) ; : ADDEO. 1 1 (ADDE) ;
+: SUBI neg ADDI ; inline
-
+: LIS 0 rot ADDIS ; inline
-: ANDI sd-form 28 insn ;
+: SUBIC neg ADDIC ; inline
-: ANDIS sd-form 29 insn ;
+: SUBIC. neg ADDIC. ; inline
-
+: NOT dup NOR ; inline
-: (AND) 28 x-form 31 insn ;
+: NOT. dup NOR. ; inline
-: AND 0 (AND) ;  : AND. 0 (AND) ;
+: MR dup OR ; inline
-
+: MR. dup OR. ; inline
-: (DIVW) 491 xo-form 31 insn ;
+: (SLWI) 0 31 pick - ; inline
-: DIVW 0 0 (DIVW) ;  : DIVW. 0 1 (DIVW) ;
+: SLWI ( d a b -- ) (SLWI) RLWINM ;
-: DIVWO 1 0 (DIVW) ; : DIVWO. 1 1 (DIVW) ;
+: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
-
+: (SRWI) 32 over - swap 31 ; inline
-: (DIVWU) 459 xo-form 31 insn ;
+: SRWI ( d a b -- ) (SRWI) RLWINM ;
-: DIVWU 0 0 (DIVWU) ;  : DIVWU. 0 1 (DIVWU) ;
+: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
-: DIVWUO 1 0 (DIVWU) ; : DIVWUO. 1 1 (DIVWU) ;
+: LOAD32 ( n r -- ) >r w>h/h r> tuck LIS dup rot ORI ;
-
+: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
-: (EQV) 284 x-form 31 insn ;
+: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
-: EQV 0 (EQV) ;  : EQV. 1 (EQV) ;
-
-: (NAND) 476 x-form 31 insn ;
-: NAND 0 (NAND) ;  : NAND. 1 (NAND) ;
-
-: (NOR) 124 x-form 31 insn ;
-: NOR 0 (NOR) ;  : NOR. 1 (NOR) ;
-
-: NOT dup NOR ;   : NOT. dup NOR. ;
-
-: ORI sd-form 24 insn ;  : ORIS sd-form 25 insn ;
-
-: (OR) 444 x-form 31 insn ;
-: OR 0 (OR) ;  : OR. 1 (OR) ;
-
-: (ORC) 412 x-form 31 insn ;
-: ORC 0 (ORC) ;  : ORC. 1 (ORC) ;
-
-: MR dup OR ;  : MR. dup OR. ;
-
-: (MULHW) 75 xo-form 31 insn ;
-: MULHW 0 0 (MULHW) ;  : MULHW. 0 1 (MULHW) ;
-
-: MULLI d-form 7 insn ;
-
-: (MULHWU) 11 xo-form 31 insn ;
-: MULHWU 0 0 (MULHWU) ;  : MULHWU. 0 1 (MULHWU) ;
-
-: (MULLW) 235 xo-form 31 insn ;
-: MULLW 0 0 (MULLW) ;  : MULLW. 0 1 (MULLW) ;
-: MULLWO 1 0 (MULLW) ; : MULLWO. 1 1 (MULLW) ;
-
-: (SLW) 24 x-form 31 insn ;
-: SLW 0 (SLW) ;  : SLW. 1 (SLW) ;
-
-: (SRAW) 792 x-form 31 insn ;
-: SRAW 0 (SRAW) ;  : SRAW. 1 (SRAW) ;
-
-: (SRW) 536 x-form 31 insn ;
-: SRW 0 (SRW) ;  : SRW. 1 (SRW) ;
-
-: SRAWI 0 824 x-form 31 insn ;
-
-: (SUBF) 40 xo-form 31 insn ;
-: SUBF 0 0 (SUBF) ;  : SUBF. 0 1 (SUBF) ;
-: SUBFO 1 0 (SUBF) ; : SUBFO. 1 1 (SUBF) ;
-
-: (SUBFC) 8 xo-form 31 insn ;
-: SUBFC 0 0 (SUBFC) ;  : SUBFC. 0 1 (SUBFC) ;
-: SUBFCO 1 0 (SUBFC) ; : SUBFCO. 1 1 (SUBFC) ;
-
-: (SUBFE) 136 xo-form 31 insn ;
-: SUBFE 0 0 (SUBFE) ;  : SUBFE. 0 1 (SUBFE) ;
-: SUBFEO 1 0 (SUBFE) ; : SUBFEO. 1 1 (SUBFE) ;
-
-: (EXTSB) 0 swap 954 x-form 31 insn ;
-: EXTSB 0 (EXTSB) ;
-: EXTSB. 1 (EXTSB) ;
-
-: XORI sd-form 26 insn ;  : XORIS sd-form 27 insn ;
-
-: (XOR) 316 x-form 31 insn ;
-: XOR 0 (XOR) ;  : XOR. 1 (XOR) ;
-
-: (NEG) 0 -rot 104 xo-form 31 insn ;
-: NEG 0 0 (NEG) ;  : NEG. 0 1 (NEG) ;
-: NEGO 1 0 (NEG) ; : NEGO. 1 1 (NEG) ;
-
-: CMPI d-form 11 insn ;
-: CMPLI d-form 10 insn ;
-
-: CMP 0 0 x-form 31 insn ;
-: CMPL 0 32 x-form 31 insn ;
-
-: (RLWINM) a-form 21 insn ;
-: RLWINM 0 (RLWINM) ;  : RLWINM. 1 (RLWINM) ;
-
-: (SLWI) 0 31 pick - ;
-: SLWI (SLWI) RLWINM ;  : SLWI. (SLWI) RLWINM. ;
-: (SRWI) 32 over - swap 31 ;
-: SRWI (SRWI) RLWINM ;  : SRWI. (SRWI) RLWINM. ;
-
-: LBZ d-form 34 insn ;  : LBZU d-form 35 insn ;
-: LHA d-form 42 insn ;  : LHAU d-form 43 insn ;
-: LHZ d-form 40 insn ;  : LHZU d-form 41 insn ;
-: LWZ d-form 32 insn ;  : LWZU d-form 33 insn ;
-
-: LBZX 0  87 x-form 31 insn ; : LBZUX 0 119 x-form 31 insn ;
-: LHAX 0 343 x-form 31 insn ; : LHAUX 0 375 x-form 31 insn ;
-: LHZX 0 279 x-form 31 insn ; : LHZUX 0 311 x-form 31 insn ;
-: LWZX 0  23 x-form 31 insn ; : LWZUX 0  55 x-form 31 insn ;
-
-: STB d-form 38 insn ;  : STBU d-form 39 insn ;
-: STH d-form 44 insn ;  : STHU d-form 45 insn ;
-: STW d-form 36 insn ;  : STWU d-form 37 insn ;
-
-: STBX 0 215 x-form 31 insn ; : STBUX 247 x-form 31 insn ;
-: STHX 0 407 x-form 31 insn ; : STHUX 439 x-form 31 insn ;
-: STWX 0 151 x-form 31 insn ; : STWUX 183 x-form 31 insn ;
-
-GENERIC# (B) 2 ( dest aa lk -- )
-M: integer (B) i-form 18 insn ;
-M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
-M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
-
-: B 0 0 (B) ; : BL 0 1 (B) ;
-
-GENERIC: BC ( a b c -- )
-M: integer BC 0 0 b-form 16 insn ;
-M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
-M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
-
-: BLT 12 0 rot BC ;  : BGE 4 0 rot BC ;
-: BGT 12 1 rot BC ;  : BLE 4 1 rot BC ;
-: BEQ 12 2 rot BC ;  : BNE 4 2 rot BC ;
-: BO  12 3 rot BC ;  : BNO 4 3 rot BC ;
-
-: BCLR 0 8 0 0 b-form 19 insn ;
-: BLR 20 BCLR ;
-: BCLRL 0 8 0 1 b-form 19 insn ;
-: BLRL 20 BCLRL ;
-: BCCTR 0 264 0 0 b-form 19 insn ;
-: BCTR 20 BCCTR ;
-
-: MFSPR 5 shift 339 xfx-form 31 insn ;
-: MFXER 1 MFSPR ;  : MFLR 8 MFSPR ;  : MFCTR 9 MFSPR ;
-
-: MTSPR 5 shift 467 xfx-form 31 insn ;
-: MTXER 1 MTSPR ;  : MTLR 8 MTSPR ;  : MTCTR 9 MTSPR ;
-
-: LOAD32 >r w>h/h r> tuck LIS dup rot ORI ;
-
-: LOAD ( n r -- )
-    #! PowerPC cannot load a 32 bit literal in one instruction.
-   >r dup -32768 32767 between? [ r> LI ] [ r> LOAD32 ] if ;
-
-! Floating point
-: LFS d-form 48 insn ;  : LFSU d-form 49 insn ;
-: LFD d-form 50 insn ;  : LFDU d-form 51 insn ;
-: STFS d-form 52 insn ; : STFSU d-form 53 insn ;
-: STFD d-form 54 insn ; : STFDU d-form 55 insn ;
-
-: (FMR) >r 0 -rot 72 r> x-form 63 insn ;
-: FMR 0 (FMR) ;  : FMR. 1 (FMR) ;
-
-: (FCTIWZ) >r 0 -rot r> 15 x-form 63 insn ;
-: FCTIWZ 0 (FCTIWZ) ;  : FCTIWZ. 1 (FCTIWZ) ;
-
-: (FADD) >r 0 21 r> a-form 63 insn ;
-: FADD 0 (FADD) ;  : FADD. 1 (FADD) ;
-
-: (FSUB) >r 0 20 r> a-form 63 insn ;
-: FSUB 0 (FSUB) ;  : FSUB. 1 (FSUB) ;
-
-: (FMUL) >r 0 swap 25 r> a-form 63 insn ;
-: FMUL 0 (FMUL) ;  : FMUL. 1 (FMUL) ;
-
-: (FDIV) >r 0 18 r> a-form 63 insn ;
-: FDIV 0 (FDIV) ;  : FDIV. 1 (FDIV) ;
-
-: (FSQRT) >r 0 swap 0 22 r> a-form 63 insn ;
-: FSQRT 0 (FSQRT) ;  : FSQRT. 1 (FSQRT) ;
-
-: FCMPU 0 0 x-form 63 insn ;
-: FCMPO 0 32 x-form 63 insn ;

core/cpu/ppc/assembler/backend/backend.factor

@@ -0,0 +1,93 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: generator.fixup kernel namespaces sequences
+words math math.bitfields io.binary parser lexer ;
+IN: cpu.ppc.assembler.backend
+
+: insn ( operand opcode -- ) { 26 0 } bitfield , ;
+
+: a-insn ( d a b c xo rc opcode -- )
+    [ { 0 1 6 11 16 21 } bitfield ] dip insn ;
+
+: b-insn ( bo bi bd aa lk opcode -- )
+    [ { 0 1 2 16 21 } bitfield ] dip insn ;
+
+: s>u16 ( s -- u ) HEX: ffff bitand ;
+
+: d-insn ( d a simm opcode -- )
+    [ s>u16 { 0 16 21 } bitfield ] dip insn ;
+
+: define-d-insn ( word opcode -- )
+    [ d-insn ] curry (( d a simm -- )) define-declared ;
+
+: D: CREATE scan-word define-d-insn ; parsing
+
+: sd-insn ( d a simm opcode -- )
+    [ s>u16 { 0 21 16 } bitfield ] dip insn ;
+
+: define-sd-insn ( word opcode -- )
+    [ sd-insn ] curry (( d a simm -- )) define-declared ;
+
+: SD: CREATE scan-word define-sd-insn ; parsing
+
+: i-insn ( li aa lk opcode -- )
+    [ { 0 1 0 } bitfield ] dip insn ;
+
+: x-insn ( a s b rc xo opcode -- )
+    [ { 1 0 11 21 16 } bitfield ] dip insn ;
+
+: (X) ( -- word quot )
+    CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
+
+: X: (X) (( a s b -- )) define-declared ; parsing
+
+: (1) ( quot -- quot' ) [ 0 ] prepose ;
+
+: X1: (X) (1) (( a s -- )) define-declared ; parsing
+
+: xfx-insn ( d spr xo opcode -- )
+    [ { 1 11 21 } bitfield ] dip insn ;
+
+: CREATE-MF ( -- word ) scan "MF" prepend create-in ;
+
+: MFSPR:
+    CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
+    (( d -- )) define-declared ; parsing
+
+: CREATE-MT ( -- word ) scan "MT" prepend create-in ;
+
+: MTSPR:
+    CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
+    (( d -- )) define-declared ; parsing
+
+: xo-insn ( d a b oe rc xo opcode -- )
+    [ { 1 0 10 11 16 21 } bitfield ] dip insn ;
+
+: (XO) ( -- word quot )
+    CREATE scan-word scan-word scan-word scan-word
+    [ xo-insn ] 2curry 2curry ;
+
+: XO: (XO) (( a s b -- )) define-declared ; parsing
+
+: XO1: (XO) (1) (( a s -- )) define-declared ; parsing
+
+GENERIC# (B) 2 ( dest aa lk -- )
+M: integer (B) 18 i-insn ;
+M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
+M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
+
+GENERIC: BC ( a b c -- )
+M: integer BC 0 0 16 b-insn ;
+M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
+M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
+
+: CREATE-B ( -- word ) scan "B" prepend create-in ;
+
+: BC:
+    CREATE-B scan-word scan-word
+    [ rot BC ] 2curry (( c -- )) define-declared ; parsing
+
+: B:
+    CREATE-B scan-word scan-word scan-word scan-word scan-word
+    [ b-insn ] curry curry curry curry curry
+    (( bo -- )) define-declared ; parsing

core/cpu/ppc/bootstrap.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: bootstrap.image.private kernel namespaces system
+USING: bootstrap.image.private kernel kernel.private namespaces
-cpu.ppc.assembler generator.fixup compiler.units
+system cpu.ppc.assembler generator.fixup compiler.units
-compiler.constants math layouts words vocabs ;
+compiler.constants math math.private layouts words words.private
+vocabs slots.private ;
 IN: bootstrap.ppc
 
 4 \ cell set
@@ -11,9 +12,7 @@ big-endian on
 4 jit-code-format set
 
 : ds-reg 14 ;
-: quot-reg 3 ;
+: rs-reg 15 ;
-: temp-reg 6 ;
-: aux-reg 11 ;
 
 : factor-area-size 4 bootstrap-cells ;
 
@@ -24,86 +23,286 @@ big-endian on
 : xt-save stack-frame 2 bootstrap-cells - ;
 
 [
-    ! Load word
+    0 6 LOAD32
-    0 temp-reg LOAD32
+    6 dup 0 LWZ
-    temp-reg dup 0 LWZ
+    11 6 profile-count-offset LWZ
-    ! Bump profiling counter
+    11 11 1 tag-fixnum ADDI
-    aux-reg temp-reg profile-count-offset LWZ
+    11 6 profile-count-offset STW
-    aux-reg dup 1 tag-fixnum ADDI
+    11 6 word-code-offset LWZ
-    aux-reg temp-reg profile-count-offset STW
+    11 11 compiled-header-size ADDI
-    ! Load word->code
+    11 MTCTR
-    aux-reg temp-reg word-code-offset LWZ
-    ! Compute word XT
-    aux-reg dup compiled-header-size ADDI
-    ! Jump to XT
-    aux-reg MTCTR
     BCTR
 ] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define
 
 [
-    0 temp-reg LOAD32                          ! load XT
+    0 6 LOAD32
-    0 MFLR                                     ! load return address
+    0 MFLR
-    1 1 stack-frame neg ADDI                   ! create stack frame
+    1 1 stack-frame SUBI
-    temp-reg 1 xt-save STW                     ! save XT
+    6 1 xt-save STW
-    stack-frame temp-reg LI                    ! load frame size
+    stack-frame 6 LI
-    temp-reg 1 next-save STW                   ! save frame size
+    6 1 next-save STW
-    0 1 lr-save stack-frame + STW              ! save return address
+    0 1 lr-save stack-frame + STW
 ] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
 
 [
-    0 temp-reg LOAD32                          ! load literal
+    0 6 LOAD32
-    temp-reg dup 0 LWZ                         ! indirection
+    6 dup 0 LWZ
-    temp-reg ds-reg 4 STWU                     ! push literal
+    6 ds-reg 4 STWU
 ] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define
 
 [
-    0 temp-reg LOAD32                          ! load primitive address
+    0 6 LOAD32
-    4 1 MR                                     ! pass stack pointer to primitive
+    6 ds-reg 4 STWU
-    temp-reg MTCTR                             ! jump to primitive
+] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define
+
+[
+    0 6 LOAD32
+    4 1 MR
+    6 MTCTR
     BCTR
 ] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
 
-[
+[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
-    0 BL
-] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
 
-[
+[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
-    0 B
-] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
 
 : jit-call-quot ( -- )
-    temp-reg quot-reg quot-xt-offset LWZ       ! load quotation-xt
+    4 3 quot-xt-offset LWZ
-    temp-reg MTCTR                             ! jump to quotation-xt
+    4 MTCTR
     BCTR ;
 
 [
-    0 quot-reg LOAD32                          ! point quot-reg at false branch
+    0 3 LOAD32
-    temp-reg ds-reg 0 LWZ                      ! load boolean
+    6 ds-reg 0 LWZ
-    0 temp-reg \ f tag-number CMPI             ! compare it with f
+    0 6 \ f tag-number CMPI
-    2 BNE                                      ! skip next insn if its not f
+    2 BNE
-    quot-reg dup 4 ADDI                        ! point quot-reg at true branch
+    3 3 4 ADDI
-    quot-reg dup 0 LWZ                         ! load the branch
+    3 3 0 LWZ
-    ds-reg dup 4 SUBI                          ! pop boolean
+    ds-reg dup 4 SUBI
     jit-call-quot
 ] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
 
 [
-    0 quot-reg LOAD32                          ! load dispatch array
+    0 3 LOAD32
-    quot-reg dup 0 LWZ                         ! indirection
+    3 3 0 LWZ
-    temp-reg ds-reg 0 LWZ                      ! load index
+    6 ds-reg 0 LWZ
-    temp-reg dup 1 SRAWI                       ! turn it into an array offset
+    6 6 1 SRAWI
-    quot-reg dup temp-reg ADD                  ! compute quotation location
+    3 3 6 ADD
-    quot-reg dup array-start-offset LWZ        ! load quotation
+    3 3 array-start-offset LWZ
-    ds-reg dup 4 SUBI                          ! pop index
+    ds-reg dup 4 SUBI
     jit-call-quot
 ] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
 
 [
-    0 1 lr-save stack-frame + LWZ              ! load return address
+    0 1 lr-save stack-frame + LWZ
-    1 1 stack-frame ADDI                       ! pop stack frame
+    1 1 stack-frame ADDI
-    0 MTLR                                     ! get ready to return
+    0 MTLR
 ] f f f jit-epilog jit-define
 
 [ BLR ] f f f jit-return jit-define
 
+! Sub-primitives
+
+! Quotations and words
+[
+    3 ds-reg 0 LWZ
+    ds-reg dup 4 SUBI
+    jit-call-quot
+] f f f \ (call) define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    ds-reg dup 4 SUBI
+    4 3 word-xt-offset LWZ
+    4 MTCTR
+    BCTR
+] f f f \ (execute) define-sub-primitive
+
+! Objects
+[
+    3 ds-reg 0 LWZ
+    3 3 tag-mask get ANDI
+    3 3 tag-bits get SLWI
+    3 ds-reg 0 STW
+] f f f \ tag define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZU
+    3 3 1 SRAWI
+    4 4 0 0 31 tag-bits get - RLWINM
+    4 3 3 LWZX
+    3 ds-reg 0 STW
+] f f f \ slot define-sub-primitive
+
+! Shufflers
+[
+    ds-reg dup 4 SUBI
+] f f f \ drop define-sub-primitive
+
+[
+    ds-reg dup 8 SUBI
+] f f f \ 2drop define-sub-primitive
+
+[
+    ds-reg dup 12 SUBI
+] f f f \ 3drop define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    3 ds-reg 4 STWU
+] f f f \ dup define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZ
+    ds-reg dup 8 ADDI
+    3 ds-reg 0 STW
+    4 ds-reg -4 STW
+] f f f \ 2dup define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZ
+    5 ds-reg -8 LWZ
+    ds-reg dup 12 ADDI
+    3 ds-reg 0 STW
+    4 ds-reg -4 STW
+    5 ds-reg -8 STW
+] f f f \ 3dup define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    ds-reg dup 4 SUBI
+    3 ds-reg 0 STW
+] f f f \ nip define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    ds-reg dup 8 SUBI
+    3 ds-reg 0 STW
+] f f f \ 2nip define-sub-primitive
+
+[
+    3 ds-reg -4 LWZ
+    3 ds-reg 4 STWU
+] f f f \ over define-sub-primitive
+
+[
+    3 ds-reg -8 LWZ
+    3 ds-reg 4 STWU
+] f f f \ pick define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZ
+    4 ds-reg 0 STW
+    3 ds-reg 4 STWU
+] f f f \ dupd define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZ
+    3 ds-reg 4 STWU
+    4 ds-reg -4 STW
+    3 ds-reg -8 STW
+] f f f \ tuck define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZ
+    3 ds-reg -4 STW
+    4 ds-reg 0 STW
+] f f f \ swap define-sub-primitive
+
+[
+    3 ds-reg -4 LWZ
+    4 ds-reg -8 LWZ
+    3 ds-reg -8 STW
+    4 ds-reg -4 STW
+] f f f \ swapd define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZ
+    5 ds-reg -8 LWZ
+    4 ds-reg -8 STW
+    3 ds-reg -4 STW
+    5 ds-reg 0 STW
+] f f f \ rot define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZ
+    5 ds-reg -8 LWZ
+    3 ds-reg -8 STW
+    5 ds-reg -4 STW
+    4 ds-reg 0 STW
+] f f f \ -rot define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    ds-reg dup 4 SUBI
+    3 rs-reg 4 STWU
+] f f f \ >r define-sub-primitive
+
+[
+    3 rs-reg 0 LWZ
+    rs-reg dup 4 SUBI
+    3 ds-reg 4 STWU
+] f f f \ r> define-sub-primitive
+
+! Comparisons
+: jit-compare ( insn -- )
+    0 3 LOAD32
+    3 3 0 LWZ
+    4 ds-reg 0 LWZ
+    5 ds-reg -4 LWZU
+    5 0 4 CMP
+    2 swap execute ! magic number
+    \ f tag-number 3 LI
+    3 ds-reg 0 STW ;
+
+: define-jit-compare ( insn word -- )
+    [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip
+    define-sub-primitive ;
+
+\ BEQ \ eq? define-jit-compare
+\ BGE \ fixnum>= define-jit-compare
+\ BLE \ fixnum<= define-jit-compare
+\ BGT \ fixnum> define-jit-compare
+\ BLT \ fixnum< define-jit-compare
+
+! Math
+: jit-math ( insn -- )
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZU
+    [ 5 3 4 ] dip execute
+    5 ds-reg 0 STW ;
+
+[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+
+[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    4 ds-reg -4 LWZU
+    4 4 tag-bits get SRAWI
+    5 3 4 MULLW
+    5 ds-reg 0 STW
+] f f f \ fixnum*fast define-sub-primitive
+
+[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+
+[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+
+[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    3 3 NOT
+    3 3 tag-mask get XORI
+    3 ds-reg 0 STW
+] f f f \ fixnum-bitnot define-sub-primitive
+
 [ "bootstrap.ppc" forget-vocab ] with-compilation-unit

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -1,14 +1,13 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors alien.c-types arrays cpu.ppc.assembler
+USING: accessors alien alien.accessors alien.c-types arrays
-cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel
+cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
-kernel.private math math.private namespaces sequences words
+cpu.architecture kernel kernel.private math math.private
-generic quotations byte-arrays hashtables hashtables.private
+namespaces sequences words generic quotations byte-arrays
-generator generator.registers generator.fixup sequences.private
+hashtables hashtables.private generator generator.registers
-sbufs vectors system layouts math.floats.private
+generator.fixup sequences.private sbufs vectors system layouts
-classes classes.tuple classes.tuple.private sbufs.private
+math.floats.private classes slots.private combinators
-vectors.private strings.private slots.private combinators
+compiler.constants optimizer.allot ;
-compiler.constants ;
 IN: cpu.ppc.intrinsics
 
 : %slot-literal-known-tag
@@ -445,38 +444,33 @@ IN: cpu.ppc.intrinsics
     ! Store tagged ptr in reg
     "tuple" get tuple %store-tagged
 ] H{
-    { +input+ { { [ tuple-layout? ] "layout" } } }
+    { +input+ { { [ ] "layout" } } }
     { +scratch+ { { f "tuple" } } }
     { +output+ { "tuple" } }
 } define-intrinsic
 
-\ <array> [
+\ (array) [
     array "n" get 2 + cells %allot
     ! Store length
     "n" operand 12 LI
     12 11 cell STW
-    ! Store initial element
-    "n" get [ "initial" operand 11 rot 2 + cells STW ] each
     ! Store tagged ptr in reg
     "array" get object %store-tagged
 ] H{
-    { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
+    { +input+ { { [ ] "n" } } }
     { +scratch+ { { f "array" } } }
     { +output+ { "array" } }
 } define-intrinsic
 
-\ <byte-array> [
+\ (byte-array) [
     byte-array "n" get 2 cells + %allot
     ! Store length
     "n" operand 12 LI
     12 11 cell STW
-    ! Store initial element
-    0 12 LI
-    "n" get cell align cell /i [ 12 11 rot 2 + cells STW ] each
     ! Store tagged ptr in reg
     "array" get object %store-tagged
 ] H{
-    { +input+ { { [ inline-array? ] "n" } } }
+    { +input+ { { [ ] "n" } } }
     { +scratch+ { { f "array" } } }
     { +output+ { "array" } }
 } define-intrinsic

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

core/cpu/x86/intrinsics/intrinsics.factor

@@ -6,8 +6,7 @@ kernel.private math math.private namespaces quotations sequences
 words generic byte-arrays hashtables hashtables.private
 generator generator.registers generator.fixup sequences.private
 sbufs sbufs.private vectors vectors.private layouts system
-classes.tuple.private strings.private slots.private
+strings.private slots.private compiler.constants optimizer.allot ;
-compiler.constants ;
 IN: cpu.x86.intrinsics
 
 ! Type checks
@@ -298,37 +297,33 @@ IN: cpu.x86.intrinsics
         "tuple" get tuple %store-tagged
     ] %allot
 ] H{
-    { +input+ { { [ tuple-layout? ] "layout" } } }
+    { +input+ { { [ ] "layout" } } }
     { +scratch+ { { f "tuple" } { f "scratch" } } }
     { +output+ { "tuple" } }
 } define-intrinsic
 
-\ <array> [
+\ (array) [
     array "n" get 2 + cells [
         ! Store length
         1 object@ "n" operand MOV
-        ! Zero out the rest of the tuple
-        "n" get [ 2 + object@ "initial" operand MOV ] each
         ! Store tagged ptr in reg
         "array" get object %store-tagged
     ] %allot
 ] H{
-    { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
+    { +input+ { { [ ] "n" } } }
     { +scratch+ { { f "array" } } }
     { +output+ { "array" } }
 } define-intrinsic
 
-\ <byte-array> [
+\ (byte-array) [
     byte-array "n" get 2 cells + [
         ! Store length
         1 object@ "n" operand MOV
-        ! Store initial element
-        "n" get cell align cell /i [ 2 + object@ 0 MOV ] each
         ! Store tagged ptr in reg
         "array" get object %store-tagged
     ] %allot
 ] H{
-    { +input+ { { [ inline-array? ] "n" } } }
+    { +input+ { { [ ] "n" } } }
     { +scratch+ { { f "array" } } }
     { +output+ { "array" } }
 } define-intrinsic

core/debugger/debugger.factor

@@ -212,6 +212,12 @@ M: not-a-tuple summary
 M: bad-superclass summary
     drop "Tuple classes can only inherit from other tuple classes" ;
 
+M: no-initial-value summary
+    drop "Initial value must be provided for slots specialized to this class" ;
+
+M: bad-initial-value summary
+    drop "Incompatible initial value" ;
+
 M: no-cond summary
     drop "Fall-through in cond" ;
 

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 ;
 

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 <groups> }
 { $subsection <sliced-groups> }
+"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 <clumps> }

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

core/hashtables/hashtables-docs.factor

@@ -93,11 +93,6 @@ HELP: hash-deleted+
 { $description "Called to increment the deleted entry counter when an entry is removed with " { $link delete-at } }
 { $side-effects "hash" } ;
 
-HELP: (set-hash)
-{ $values { "value" "a value" } { "key" "a key to add" } { "hash" hashtable } { "new?" "a boolean" } }
-{ $description "Stores the key/value pair into the hashtable. This word does not grow the hashtable if it exceeds capacity, therefore a hang can result. User code should use " { $link set-at } " instead, which grows the hashtable if necessary." }
-{ $side-effects "hash" } ;
-
 HELP: grow-hash
 { $values { "hash" hashtable } }
 { $description "Enlarges the capacity of a hashtable. User code does not need to call this word directly." }

core/hashtables/hashtables-tests.factor

@@ -164,3 +164,16 @@ H{ } "x" set
 [ { "one" "two" 3 } ] [
     { 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
 ] unit-test
+
+! We want this to work
+[ ] [ hashtable new "h" set ] unit-test
+
+[ 0 ] [ "h" get assoc-size ] unit-test
+
+[ f f ] [ "goo" "h" get at* ] unit-test
+
+[ ] [ 1 2 "h" get set-at ] unit-test
+
+[ 1 ] [ "h" get assoc-size ] unit-test
+
+[ 1 ] [ 2 "h" get at ] unit-test

core/hashtables/hashtables.factor

@@ -20,15 +20,18 @@ TUPLE: hashtable
 : probe ( array i -- array i )
     2 fixnum+fast over wrap ; inline
 
-: (key@) ( key keys i -- array n ? )
+: no-key ( key array -- array n ? ) nip f f ; inline
+
+: (key@) ( key array i -- array n ? )
     3dup swap array-nth
     dup ((empty)) eq?
-    [ 3drop nip f f ] [
+    [ 3drop no-key ] [
         = [ rot drop t ] [ probe (key@) ] if
     ] if ; inline
 
 : key@ ( key hash -- array n ? )
-    array>> 2dup hash@ (key@) ; inline
+    array>> dup array-capacity 0 eq?
+    [ no-key ] [ 2dup hash@ (key@) ] if ; inline
 
 : <hash-array> ( n -- array )
     1+ next-power-of-2 4 * ((empty)) <array> ; inline
@@ -63,25 +66,20 @@ TUPLE: hashtable
 : hash-deleted+ ( hash -- )
     [ 1+ ] change-deleted drop ; inline
 
-: (set-hash) ( value key hash -- new? )
-    2dup new-key@
-    [ rot hash-count+ set-nth-pair t ]
-    [ rot drop set-nth-pair f ] if ; inline
-
 : (rehash) ( hash alist -- )
-    swap [ swapd (set-hash) drop ] curry assoc-each ;
+    swap [ swapd set-at ] curry assoc-each ; inline
 
 : hash-large? ( hash -- ? )
-    [ count>> 3 fixnum*fast  ]
+    [ count>> 3 fixnum*fast 1 fixnum+fast ]
-    [ array>> array-capacity ] bi > ;
+    [ array>> array-capacity ] bi fixnum> ; inline
 
 : hash-stale? ( hash -- ? )
-    [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ;
+    [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
 
 : grow-hash ( hash -- )
     [ dup >alist swap assoc-size 1+ ] keep
     [ reset-hash ] keep
-    swap (rehash) ;
+    swap (rehash) ; inline
 
 : ?grow-hash ( hash -- )
     dup hash-large? [
@@ -122,7 +120,10 @@ M: hashtable assoc-size ( hash -- n )
     r> (rehash) ;
 
 M: hashtable set-at ( value key hash -- )
-    dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ;
+    dup ?grow-hash
+    2dup new-key@
+    [ rot hash-count+ set-nth-pair ]
+    [ rot drop set-nth-pair ] if ;
 
 : associate ( value key -- hash )
     2 <hashtable> [ set-at ] keep ;

core/heaps/heaps.factor

@@ -5,8 +5,6 @@ USING: kernel math sequences arrays assocs sequences.private
 growable accessors math.order ;
 IN: heaps
 
-MIXIN: priority-queue
-
 GENERIC: heap-push* ( value key heap -- entry )
 GENERIC: heap-peek ( heap -- value key )
 GENERIC: heap-pop* ( heap -- )
@@ -36,13 +34,10 @@ TUPLE: max-heap < heap ;
 
 : <max-heap> ( -- max-heap ) max-heap <heap> ;
 
-INSTANCE: min-heap priority-queue
+M: heap heap-empty? ( heap -- ? )
-INSTANCE: max-heap priority-queue
-
-M: priority-queue heap-empty? ( heap -- ? )
     data>> empty? ;
 
-M: priority-queue heap-size ( heap -- n )
+M: heap heap-size ( heap -- n )
     data>> length ;
 
 <PRIVATE
@@ -152,7 +147,7 @@ DEFER: down-heap
 
 PRIVATE>
 
-M: priority-queue heap-push* ( value key heap -- entry )
+M: heap heap-push* ( value key heap -- entry )
     [ <entry> dup ] keep [ data-push ] keep up-heap ;
 
 : heap-push ( value key heap -- ) heap-push* drop ;
@@ -163,7 +158,7 @@ M: priority-queue heap-push* ( value key heap -- entry )
 : >entry< ( entry -- key value )
     [ value>> ] [ key>> ] bi ;
 
-M: priority-queue heap-peek ( heap -- value key )
+M: heap heap-peek ( heap -- value key )
     data-first >entry< ;
 
 : entry>index ( entry heap -- n )
@@ -172,7 +167,7 @@ M: priority-queue heap-peek ( heap -- value key )
     ] unless
     entry-index ;
 
-M: priority-queue heap-delete ( entry heap -- )
+M: heap heap-delete ( entry heap -- )
     [ entry>index ] keep
     2dup heap-size 1- = [
         nip data-pop*
@@ -182,10 +177,10 @@ M: priority-queue heap-delete ( entry heap -- )
         down-heap
     ] if ;
 
-M: priority-queue heap-pop* ( heap -- )
+M: heap heap-pop* ( heap -- )
     dup data-first swap heap-delete ;
 
-M: priority-queue heap-pop ( heap -- value key )
+M: heap heap-pop ( heap -- value key )
     dup data-first [ swap heap-delete ] keep >entry< ;
 
 : heap-pop-all ( heap -- alist )

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
+optimizer.inlining optimizer.backend math.order math.functions
-accessors hashtables classes assocs ;
+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?
+    [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
-] unit-test
-
-[ t ] [
-    [ { string sbuf } declare push-all ] \ >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 ] [

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 <repetition> ] if ;
@@ -203,11 +207,19 @@ M: pair constraint-satisfied?
     [ ] [ param>> "default-output-classes" word-prop ] ?if
     r> ;
 
-M: #call infer-classes-before
+: intersect-values ( classes intervals values -- )
-    [ compute-constraints ] keep
-    [ output-classes ] [ out-d>> ] bi
     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 ;

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 ;
 

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
+    [ in>> "input-classes" set-word-prop ]
-    dupd [ make-call-node ] 2curry "infer" 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 } <effect> set-primitive-effect
@@ -538,9 +540,6 @@ set-primitive-effect
 \ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
 \ <tuple> make-flushable
 
-\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
-\ (tuple) make-flushable
-
 \ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
 \ <tuple-layout> make-foldable
 

core/inspector/inspector.factor

@@ -33,10 +33,10 @@ SYMBOL: +editable+
 : write-value ( mirror key -- )
     <value-ref> write-slot-editor ;
 
-: describe-row ( obj key n -- )
+: describe-row ( mirror key n -- )
     [
         +number-rows+ get [ pprint-cell ] [ drop ] if
-        2dup write-key write-value
+        [ write-key ] [ write-value ] 2bi
     ] with-row ;
 
 : summary. ( obj -- ) [ summary ] keep write-object nl ;
@@ -48,21 +48,19 @@ SYMBOL: +editable+
         sort-keys values
     ] [ keys ] if ;
 
-: describe* ( obj flags -- )
+: describe* ( obj mirror keys -- )
-    clone [
+    rot summary.
-        dup summary.
+    dup empty? [
-        make-mirror dup sorted-keys dup empty? [
         2drop
     ] [
         dup enum? [ +sequence+ on ] when
         standard-table-style [
-                dup length
+            swap [ -rot describe-row ] curry each-index
-                rot [ -rot describe-row ] curry 2each
         ] tabular-output
-        ] if
+    ] if ;
-    ] bind ;
 
-: describe ( obj -- ) H{ } describe* ;
+: describe ( obj -- )
+    dup make-mirror dup sorted-keys describe* ;
 
 M: tuple error. describe ;
 
@@ -78,19 +76,21 @@ M: tuple error. describe ;
 
 SYMBOL: inspector-hook
 
-[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
+[ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global
 
 SYMBOL: inspector-stack
 
 SYMBOL: me
 
 : reinspect ( obj -- )
-    dup me set
+    [ me set ]
-    dup make-mirror dup mirror set keys \ keys set
+    [
-    inspector-hook get call ;
+        dup make-mirror dup mirror set dup sorted-keys dup \ keys set
+        inspector-hook get call
+    ] bi ;
 
 : (inspect) ( obj -- )
-    dup inspector-stack get push reinspect ;
+    [ inspector-stack get push ] [ reinspect ] bi ;
 
 : key@ ( n -- key ) \ keys get nth ;
 
@@ -123,6 +123,7 @@ SYMBOL: me
     "&add ( value key -- ) add new slot" print
     "&delete ( n -- ) remove a slot" print
     "&rename ( key n -- ) change a slot's key" print
+    "&globals ( -- ) inspect global namespace" print
     "&help -- display this message" print
     nl ;
 
@@ -133,3 +134,5 @@ SYMBOL: me
 
 : inspect ( obj -- )
     inspector-stack get [ (inspect) ] [ inspector ] if ;
+
+: &globals ( -- ) global inspect ;

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 )
+: (read-until) ( quot -- string/f sep/f )
-    SBUF" " clone -rot >decoder<
+    100 <sbuf> 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> 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 ;
 

core/io/encodings/utf8/utf8.factor

@@ -11,21 +11,21 @@ SINGLETON: utf8
 <PRIVATE 
 
 : starts-2? ( char -- ? )
-    dup [ -6 shift BIN: 10 number= ] when ;
+    dup [ -6 shift BIN: 10 number= ] when ; inline
 
 : append-nums ( stream byte -- stream char )
     over stream-read1 dup starts-2?
     [ swap 6 shift swap BIN: 111111 bitand bitor ]
-    [ 2drop replacement-char ] if ;
+    [ 2drop replacement-char ] if ; inline
 
 : double ( stream byte -- stream char )
-    BIN: 11111 bitand append-nums ;
+    BIN: 11111 bitand append-nums ; inline
 
 : triple ( stream byte -- stream char )
-    BIN: 1111 bitand append-nums append-nums ;
+    BIN: 1111 bitand append-nums append-nums ; inline
 
 : quad ( stream byte -- stream char )
-    BIN: 111 bitand append-nums append-nums append-nums ;
+    BIN: 111 bitand append-nums append-nums append-nums ; inline
 
 : begin-utf8 ( stream byte -- stream char )
     {
@@ -34,10 +34,10 @@ SINGLETON: utf8
         { [ dup -4 shift BIN: 1110 number= ] [ triple ] }
         { [ dup -3 shift BIN: 11110 number= ] [ quad ] }
         [ drop replacement-char ]
-    } cond ;
+    } cond ; inline
 
 : decode-utf8 ( stream -- char/f )
-    dup stream-read1 dup [ begin-utf8 ] when nip ;
+    dup stream-read1 dup [ begin-utf8 ] when nip ; inline
 
 M: utf8 decode-char
     drop decode-utf8 ;

core/kernel/kernel-tests.factor

@@ -114,10 +114,6 @@ IN: kernel.tests
 
 [ total-failure-1 ] must-fail
 
-: total-failure-2 [ ] (call) unimplemented ;
-
-[ total-failure-2 ] must-fail
-
 ! From combinators.lib
 [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test
 [ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test

core/optimizer/allot/allot.factor

@@ -0,0 +1,100 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences sequences.private classes.tuple
+classes.tuple.private kernel effects words quotations namespaces
+definitions math math.order layouts alien.accessors
+slots.private arrays byte-arrays inference.dataflow
+inference.known-words inference.state optimizer.inlining
+optimizer.backend ;
+IN: optimizer.allot
+
+! Expand memory allocation primitives into simpler constructs
+! to simplify the backend.
+
+: first-input ( #call -- obj ) dup in-d>> first node-literal ;
+
+: (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ;
+
+\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
+\ (tuple) make-flushable
+
+! if the input to new is a literal tuple class, we can expand it
+: literal-new? ( #call -- ? )
+    first-input tuple-class? ;
+
+: new-quot ( class -- quot )
+    dup all-slots 1 tail ! delegate slot
+    [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
+
+: expand-new ( #call -- node )
+    dup first-input
+    [ +inlined+ depends-on ] [ new-quot ] bi
+    f splice-quot ;
+
+\ new {
+    { [ dup literal-new? ] [ expand-new ] }
+} define-optimizers
+
+: tuple-boa-quot ( layout -- quot )
+    [
+        dup ,
+        [ nip (tuple) ] %
+        size>> 1 - [ 3 + ] map <reversed>
+        [ [ set-slot ] curry [ keep ] curry % ] each
+        [ f over 2 set-slot ] %
+    ] [ ] make ;
+
+: expand-tuple-boa ( #call -- node )
+    dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
+
+\ <tuple-boa> {
+    { [ t ] [ expand-tuple-boa ] }
+} define-optimizers
+
+: (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ;
+
+\ (array) { integer } { array } <effect> set-primitive-effect
+\ (array) make-flushable
+
+: <array>-quot ( n -- quot )
+    [
+        dup ,
+        [ (array) ] %
+        [ \ 2dup , , [ swap set-array-nth ] % ] each
+        \ 2nip ,
+    ] [ ] make ;
+
+: literal-<array>? ( #call -- ? )
+    first-input dup integer? [ 0 32 between? ] [ drop f ] if ;
+
+: expand-<array> ( #call -- node )
+    dup first-input <array>-quot f splice-quot ;
+
+\ <array> {
+    { [ dup literal-<array>? ] [ expand-<array> ] }
+} define-optimizers
+
+: (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ;
+
+\ (byte-array) { integer } { byte-array } <effect> set-primitive-effect
+\ (byte-array) make-flushable
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+: <byte-array>-quot ( n -- quot )
+    [
+        dup ,
+        [ nip (byte-array) ] %
+        bytes>cells [ cell * ] map
+        [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
+    ] [ ] make ;
+
+: literal-<byte-array>? ( #call -- ? )
+    first-input dup integer? [ 0 128 between? ] [ drop f ] if ;
+
+: expand-<byte-array> ( #call -- node )
+    dup first-input <byte-array>-quot f splice-quot ;
+
+\ <byte-array> {
+    { [ dup literal-<byte-array>? ] [ expand-<byte-array> ] }
+} define-optimizers

core/optimizer/def-use/def-use.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences inference.dataflow
+USING: namespaces assocs sequences kernel generic assocs classes
-inference.backend kernel generic assocs classes vectors
+vectors accessors combinators inference.dataflow inference.backend ;
-accessors combinators ;
 IN: optimizer.def-use
 
 SYMBOL: def-use

core/optimizer/inlining/inlining-tests.factor

@@ -7,14 +7,3 @@ sequences growable sbufs vectors sequences.private accessors kernel ;
 \ optimistic-inline? must-infer
 \ find-identity must-infer
 \ dispatching-class must-infer
-
-! Make sure we have sane heuristics
-[ t ] [ \ fixnum \ shift method should-inline? ] unit-test
-[ f ] [ \ array \ equal? method should-inline? ] unit-test
-[ f ] [ \ sequence \ hashcode* method should-inline? ] unit-test
-[ t ] [ \ array \ nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ sbuf \ set-nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ set-nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ set-nth method should-inline? ] unit-test
-[ t ] [ \ vector \ (>>length) method should-inline? ] unit-test

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
+math math.order namespaces sequences vectors words quotations
-combinators classes classes.algebra generic.math
+hashtables combinators effects classes classes.union
-optimizer.math.partial continuations optimizer.def-use
+classes.algebra generic.math optimizer.math.partial
-optimizer.backend generic.standard optimizer.specializers
+continuations optimizer.def-use optimizer.backend
-optimizer.def-use optimizer.pattern-match generic.standard
+generic.standard optimizer.specializers optimizer.def-use
-optimizer.control kernel.private definitions sets ;
+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 [
+    dup node-param "flushable" word-prop
-        node-out-d [ unused? ] all?
+    [ node-out-d [ unused? ] all? ] [ drop f ] if ;
-    ] [
+
-        drop f
+ERROR: flushed-eval-error word ;
-    ] if ;
+
+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 param>> +inlined+ depends-on
-    dup node-out-d length f <repetition> inline-literals ;
+    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 [
+    dup param>> "specializer" word-prop
-        >r node-input-classes r> specialized-length tail*
+    [ should-inline? ] [ drop f ] if ;
-        [ class-types length 1 = ] all?
-    ] [
-        2drop 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*

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
+kernel assocs math math.order math.private kernel.private
-math math.order math.private kernel.private sequences words
+sequences words parser vectors strings sbufs io namespaces
-parser vectors strings sbufs io namespaces assocs quotations
+assocs quotations sequences.private io.binary io.streams.string
-sequences.private io.binary io.streams.string layouts splitting
+layouts splitting math.intervals math.floats.private
-math.intervals math.floats.private classes.tuple classes.predicate
+classes.tuple classes.predicate classes.tuple.private classes
-classes.tuple.private classes classes.algebra optimizer.def-use
+classes.algebra sequences.private combinators byte-arrays
-optimizer.backend optimizer.pattern-match optimizer.inlining
+byte-vectors slots.private inference.dataflow inference.state
-sequences.private combinators byte-arrays byte-vectors
+inference.class optimizer.def-use optimizer.backend
-slots.private ;
+optimizer.pattern-match optimizer.inlining optimizer.allot ;
 IN: optimizer.known-words
 
 { <tuple> <tuple-boa> (tuple) } [
@@ -25,37 +25,6 @@ IN: optimizer.known-words
     dup class? [ drop tuple ] unless 1array f
 ] "output-classes" set-word-prop
 
-! if the input to new is a literal tuple class, we can expand it
-: literal-new? ( #call -- ? )
-    dup in-d>> first node-literal tuple-class? ;
-
-: new-quot ( class -- quot )
-    dup all-slots 1 tail ! delegate slot
-    [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
-
-: expand-new ( #call -- node )
-    dup dup in-d>> first node-literal
-    [ +inlined+ depends-on ] [ new-quot ] bi
-    f splice-quot ;
-
-\ new {
-    { [ dup literal-new? ] [ expand-new ] }
-} define-optimizers
-
-: tuple-boa-quot ( layout -- quot )
-    [ (tuple) ]
-    swap size>> 1 - [ 3 + ] map <reversed>
-    [ [ set-slot ] curry [ keep ] curry ] map concat
-    [ f over 2 set-slot ]
-    3append ;
-
-: expand-tuple-boa ( #call -- node )
-    dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
-
-\ <tuple-boa> {
-    { [ t ] [ expand-tuple-boa ] }
-} define-optimizers
-
 ! the output of clone has the same type as the input
 { clone (clone) } [
     [

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 ;
 
@@ -389,7 +406,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
 
 : convert-mod-to-and ( #call -- node )
     dup
-    dup node-in-d second node-literal 1-
+    dup in-d>> second node-literal 1-
     [ nip bitand ] curry f splice-quot ;
 
 \ mod [
@@ -420,3 +437,53 @@ most-negative-fixnum most-positive-fixnum [a,b]
         [ fixnumify-bitand ]
     }
 } define-optimizers
+
+: convert-*-to-shift? ( #call -- ? )
+    dup in-d>> second node-literal
+    dup integer? [ power-of-2? ] [ drop f ] if ;
+
+: convert-*-to-shift ( #call -- ? )
+    dup dup in-d>> second node-literal log2
+    [ nip fixnum-shift-fast ] curry
+    f splice-quot ;
+
+\ fixnum*fast {
+    { [ dup convert-*-to-shift? ] [ convert-*-to-shift ] }
+} 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 <repetition> "input-classes" set-word-prop ]
+    [ out>> length float <repetition> "default-output-classes" set-word-prop ]
+    2bi
+] each

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

core/optimizer/optimizer-tests.factor

@@ -375,3 +375,19 @@ 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 <array> drop r> 1 + ;
+
+[ 1.0 aggressive-flush-regression drop ] must-fail
+
+[ 1 [ "hi" + drop ] compile-call ] must-fail
+
+[ "hi" f [ <array> drop ] compile-call ] must-fail
+
+TUPLE: some-tuple x ;
+
+: allot-regression ( a -- b )
+    [ ] curry some-tuple boa ;
+
+[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test

core/optimizer/optimizer.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces optimizer.backend optimizer.def-use
-optimizer.known-words optimizer.math optimizer.control
+optimizer.known-words optimizer.math optimizer.allot
-optimizer.collect optimizer.inlining inference.class ;
+optimizer.control optimizer.collect optimizer.inlining
+inference.class ;
 IN: optimizer
 
 : optimize-1 ( node -- newnode ? )

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

core/prettyprint/prettyprint.factor

@@ -277,13 +277,32 @@ M: array pprint-slot-name
     f <inset unclip text pprint-elements block>
     \ } pprint-word block> ;
 
+: unparse-slot ( slot-spec -- array )
+    [
+        dup name>> ,
+        dup class>> object eq? [
+            dup class>> ,
+            initial: ,
+            dup initial>> ,
+        ] unless
+        dup read-only>> [
+            read-only ,
+        ] when
+        drop
+    ] { } make ;
+
+: pprint-slot ( slot-spec -- )
+    unparse-slot
+    dup length 1 = [ first ] when
+    pprint-slot-name ;
+
 M: tuple-class see-class*
     <colon \ TUPLE: pprint-word
     dup pprint-word
     dup superclass tuple eq? [
         "<" text dup superclass pprint-word
     ] unless
-    <block slot-names [ pprint-slot-name ] each block>
+    <block "slots" word-prop [ pprint-slot ] each block>
     pprint-; block> ;
 
 M: word see-class* drop ;

core/sequences/sequences-docs.factor

@@ -124,16 +124,28 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
 { $subsection each }
 { $subsection reduce }
 { $subsection interleave }
-{ $subsection 2each }
-{ $subsection 2reduce }
 "Mapping:"
 { $subsection map }
-{ $subsection 2map }
+{ $subsection map-as }
 { $subsection accumulate }
 { $subsection produce }
 "Filtering:"
 { $subsection push-if }
-{ $subsection filter } ;
+{ $subsection filter }
+"Testing if a sequence contains elements satisfying a predicate:"
+{ $subsection contains? }
+{ $subsection all? }
+"Testing how elements are related:"
+{ $subsection monotonic? }
+{ $subsection "sequence-2combinators" } ;
+
+ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
+"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
+{ $subsection 2each }
+{ $subsection 2reduce }
+{ $subsection 2map }
+{ $subsection 2map-as }
+{ $subsection 2all? } ;
 
 ARTICLE: "sequences-tests" "Testing sequences"
 "Testing for an empty sequence:"
@@ -147,12 +159,7 @@ ARTICLE: "sequences-tests" "Testing sequences"
 { $subsection head? }
 { $subsection tail? }
 { $subsection subseq? }
-"Testing if a sequence contains elements satisfying a predicate:"
-{ $subsection contains? }
-{ $subsection all? }
-{ $subsection 2all? }
 "Testing how elements are related:"
-{ $subsection monotonic? }
 { $subsection all-eq? }
 { $subsection all-equal? } ;
 
@@ -456,6 +463,15 @@ HELP: map
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
 { $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
 
+HELP: map-as
+{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
+{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
+{ $examples
+    "The following example converts a string into an array of one-element strings:"
+    { $example "USING: prettyprint strings sequences ;" "\"Hello\" [ 1string ] { } map-as ." "{ \"H\" \"e\" \"l\" \"l\" \"o\" }" }
+    "Note that " { $link map } " could not be used here, because it would create another string to hold results, and one-element strings cannot themselves be elements of strings."
+} ;
+
 HELP: change-nth
 { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }
 { $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." }
@@ -478,8 +494,7 @@ HELP: max-length
 
 HELP: 2each
 { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- )" } } }
-{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
+{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
-{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
 
 HELP: 2reduce
 { $values { "seq1" sequence }
@@ -488,18 +503,19 @@ HELP: 2reduce
           { "quot" "a quotation with stack effect "
                    { $snippet "( prev elt1 elt2 -- next )" } }
           { "result" "the final result" } }
-{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." }
+{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ;
-{ $notes "If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined." } ;
 
 HELP: 2map
 { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
-{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." }
+{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
-{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
+
+HELP: 2map-as
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
 
 HELP: 2all?
 { $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
+{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
-{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
 
 HELP: find
 { $values { "seq" sequence }

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 ;
 
@@ -380,10 +383,13 @@ PRIVATE>
 : 2reduce ( seq1 seq2 identity quot -- result )
     >r -rot r> 2each ; inline
 
-: 2map ( seq1 seq2 quot -- newseq )
+: 2map-as ( seq1 seq2 quot exemplar -- newseq )
-    pick >r (2each) over r>
+    >r (2each) over r>
     [ [ collect ] keep ] new-like ; inline
 
+: 2map ( seq1 seq2 quot -- newseq )
+    pick 2map-as ; inline
+
 : 2all? ( seq1 seq2 quot -- ? )
     (2each) all-integers? ; inline
 
@@ -530,7 +536,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 +581,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? ;
 

core/sets/sets-docs.factor

@@ -8,6 +8,7 @@ $nl
 { $subsection prune }
 "Test for duplicates:"
 { $subsection all-unique? }
+{ $subsection duplicates }
 "Set operations on sequences:"
 { $subsection diff }
 { $subsection intersect }
@@ -38,6 +39,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." }
@@ -52,6 +65,13 @@ HELP: prune
     { $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
 } ;
 
+HELP: duplicates
+{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
+{ $description "Outputs a new sequence consisting of elements which occur more than once in " { $snippet "seq" } "." }
+{ $examples
+    { $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 1 2 1 }" }
+} ;
+
 HELP: all-unique?
 { $values { "seq" sequence } { "?" "a boolean" } }
 { $description "Tests whether a sequence contains any repeated elements." }

core/sets/sets.factor

@@ -16,6 +16,9 @@ IN: sets
     [ ] [ length <hashtable> ] [ length <vector> ] tri
     [ [ (prune) ] 2curry each ] keep ;
 
+: duplicates ( seq -- newseq )
+    H{ } clone [ [ key? ] [ conjoin ] 2bi ] curry filter ;
+
 : gather ( seq quot -- newseq )
     map concat prune ; inline
 

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

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<= ] [ <bad-alien> ] }
-        [ no-initial-value ]
+        [ dup initial-value* ]
     } cond nip ;
 
 GENERIC: make-slot ( desc -- slot-spec )
@@ -184,9 +188,14 @@ M: array make-slot
         [ dup empty? not ] [ peel-off-attributes ] [ ] while drop
     check-initial-value ;
 
-: make-slots ( slots base -- specs )
+M: slot-spec make-slot
-    over length [ + ] with map
+    check-initial-value ;
-    [ [ make-slot ] dip >>offset ] 2map ;
+
+: make-slots ( slots -- specs )
+    [ make-slot ] map ;
+
+: finalize-slots ( specs base -- specs )
+    over length [ + ] with map [ >>offset ] 2map ;
 
 : slot-named ( name specs -- spec/f )
-    [ slot-spec-name = ] with find nip ;
+    [ name>> = ] with find nip ;

core/words/words-docs.factor

@@ -140,8 +140,6 @@ $nl
     
     { { $snippet "\"constructor\"" } { $link "tuple-constructors" } }
     
-    { { $snippet "\"slot-names\"" } { $link "tuples" } }
-    
     { { $snippet "\"type\"" } { $link "builtin-classes" } }
     
     { { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } }

extra/assocs/lib/lib.factor

@@ -1,13 +1,8 @@
 USING: arrays assocs kernel vectors sequences namespaces
        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 ;
 

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> <slice> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 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-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
 
 : step-capped-line  ( line -- new-line ) cap-line  step-line ;
-
 : step-wrapped-line ( line -- new-line ) wrap-line step-line ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

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,28 +66,39 @@ slate> relayout-1 ;
 
 DEFER: automata-window
 
-: automata-window* ( -- ) init-rule set-interesting <frame>
+: automata-window* ( -- )
+  init-rule
+  set-interesting
 
-{
+  <frame>
-[ "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 <slate> { 400 400 } over set-slate-dim dup >slate
+    <shelf>
-over @center grid-add
+
+      "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 ] <slate>
+      { 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
+
+  <handler>
+
+    tuck set-gadget-delegate
 
-{
-{ 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 <handler> tuck set-gadget-delegate
   "Automata" open-window ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

extra/bake/bake.factor

@@ -94,4 +94,4 @@ MACRO: bake ( seq -- quot ) [bake] ;
 
 :  `{ \ } [ >array     ] parse-literal \ bake parsed ; parsing
 : `V{ \ } [ >vector    ] parse-literal \ bake parsed ; parsing
-:  `[ \ } [ >quotation ] parse-literal \ bake parsed ; parsing
+:  `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing

extra/benchmark/beust1/beust1.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.ranges math.parser math.vectors sets sequences
+kernel io ;
+IN: benchmark.beust1
+
+: count-numbers ( max -- n )
+    1 [a,b] [ number>string all-unique? ] count ; inline
+
+: beust ( -- )
+    10000000 count-numbers
+    number>string " unique numbers." append print ;
+
+MAIN: beust

extra/benchmark/beust2/beust2.factor

@@ -0,0 +1,41 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.ranges math.parser sequences kernel io locals ;
+IN: benchmark.beust2
+
+! http://crazybob.org/BeustSequence.java.html
+
+:: (count-numbers) ( remaining first value used max listener -- ? )
+    10 first - [| i |
+        [let* | digit [ i first + ]
+                mask [ digit 2^ ]
+                value' [ i value + ] |
+            used mask bitand zero? [
+                value max > [ t ] [
+                    remaining 1 <= [
+                        listener call f
+                    ] [
+                        remaining 1-
+                        0
+                        value' 10 *
+                        used mask bitor
+                        max
+                        listener
+                        (count-numbers)
+                    ] if
+                ] if
+            ] [ f ] if
+        ]
+    ] contains? ; inline
+
+:: count-numbers ( max listener -- )
+    10 [ 1+ 1 1 0 max listener (count-numbers) ] contains? drop ;
+    inline
+
+:: beust ( -- )
+    [let | i! [ 0 ] |
+        10000000000 [ i 1+ i! ] count-numbers
+        i number>string " unique numbers." append print
+    ] ;
+
+MAIN: beust

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 <vector> 123456 over set-first stack-loop ;
+
+MAIN: stack-benchmark

extra/biassocs/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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: <biassoc>
+{ $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: <bihash>
+{ $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 <biassoc> }
+{ $subsection <bihash> } ;
+
+ABOUT: "biassocs"

extra/biassocs/biassocs-tests.factor

@@ -0,0 +1,22 @@
+IN: biassocs.tests
+USING: biassocs assocs namespaces tools.test ;
+
+<bihash> "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

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 ;
+
+: <biassoc> ( exemplar -- biassoc )
+    [ clone ] [ clone ] bi biassoc boa ;
+
+: <bihash> ( -- biassoc )
+    H{ } <biassoc> ;
+
+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

extra/biassocs/summary.txt

@@ -0,0 +1 @@
+Bidirectional assocs

extra/biassocs/tags.txt

@@ -0,0 +1 @@
+collections

extra/bit-arrays/bit-arrays.factor

@@ -76,7 +76,7 @@ M: bit-array byte-length length 7 + -3 shift ;
     n zero? [ 0 <bit-array> ] [
         [let | out [ n log2 1+ <bit-array> ] 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

extra/bitfields/tags.txt

@@ -1,2 +1 @@
-collections
 extensions

extra/boids/boids.factor

@@ -73,10 +73,6 @@ VAR: separation-radius
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: distance ( boid boid -- n ) [ pos>> ] [ pos>> ] bi* v- norm ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : constrain ( n a b -- n ) rot min max ;
 
 : angle-between ( vec vec -- angle )

extra/boids/ui/ui.factor

@@ -20,7 +20,8 @@ USING: combinators.short-circuit kernel namespaces
        ui.gadgets.grids
        ui.gestures
        assocs.lib vars rewrite-closures boids accessors
-       math.geometry.rect ;
+       math.geometry.rect
+       newfx ;
 
 IN: boids.ui
 
@@ -113,52 +114,54 @@ VARS: population-label cohesion-label alignment-label separation-label ;
 
   <frame>
 
+  <shelf>
+
   {
     [ "ESC - Pause" [ drop toggle-loop ] button* ]
 
     [ "1 - Randomize" [ drop randomize ] button* ]
 
     [ <pile> 1 over set-pack-fill
-      population-label> over add-gadget
+      population-label> add-gadget
-      "3 - Add 10" [ drop add-10-boids ] button* over add-gadget
+      "3 - Add 10" [ drop add-10-boids ] button* add-gadget
-      "2 - Sub 10" [ drop sub-10-boids ] button* over add-gadget ]
+      "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ]
 
     [ <pile> 1 over set-pack-fill
-      cohesion-label> over add-gadget
+      cohesion-label> add-gadget
-      "q - +0.1" [ drop inc-cohesion-weight ] button* over add-gadget
+      "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
-      "a - -0.1" [ drop dec-cohesion-weight ] button* over add-gadget ]
+      "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ]
 
     [ <pile> 1 over set-pack-fill
-      alignment-label> over add-gadget
+      alignment-label> add-gadget
-      "w - +0.1" [ drop inc-alignment-weight ] button* over add-gadget
+      "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
-      "s - -0.1" [ drop dec-alignment-weight ] button* over add-gadget ]
+      "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ]
 
     [ <pile> 1 over set-pack-fill
-      separation-label> over add-gadget
+      separation-label> add-gadget
-      "e - +0.1" [ drop inc-separation-weight ] button* over add-gadget
+      "e - +0.1" [ drop inc-separation-weight ] button* add-gadget
-      "d - -0.1" [ drop dec-separation-weight ] button* over 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 "1" } C[ drop randomize    ] is
-    T{ key-down f f "2" } C[ drop sub-10-boids ] put-at
+    T{ key-down f f "2" } C[ drop sub-10-boids ] is
-    T{ key-down f f "3" } C[ drop add-10-boids ] put-at
+    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 "q" } C[ drop inc-cohesion-weight ] is
-    T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at
+    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 "w" } C[ drop inc-alignment-weight ] is
-    T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at
+    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 "e" } C[ drop inc-separation-weight ] is
-    T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at
+    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
   <handler> tuck set-gadget-delegate "Boids" open-window ;
 
 : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;

extra/bunny/bunny.factor

@@ -1,34 +1,25 @@
-USING: alien alien.c-types arrays sequences math math.vectors
+USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
-math.matrices math.parser io io.files kernel opengl opengl.gl
+bunny.model bunny.outlined destructors kernel math opengl.demo-support
-opengl.glu shuffle http.client vectors namespaces ui.gadgets
+opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ;
-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 ;
 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> ( -- bunny-gadget )
-    0.0 0.0 0.375 <demo-gadget>
+    0.0 0.0 0.375 bunny-gadget new-demo-gadget
-    maybe-download read-model {
+    maybe-download read-model >>model-triangles ;
-        set-delegate
-        (>>model)
-    } bunny-gadget construct ;
 
 : bunny-gadget-draw ( gadget -- draw )
-    { draw-n>> draw-seq>> }
+    [ draw-n>> ] [ draw-seq>> ] bi nth ;
-    get-slots nth ;
 
 : bunny-gadget-next-draw ( gadget -- )
-    dup { draw-seq>> draw-n>> }
+    dup [ draw-seq>> ] [ draw-n>> ] bi
-    get-slots
     1+ swap length mod
     >>draw-n relayout-1 ;
 
 M: bunny-gadget graft* ( gadget -- )
     GL_DEPTH_TEST glEnable
-    dup model>> <bunny-geom> >>geom
+    dup model-triangles>> <bunny-geom> >>geom
     dup
     [ <bunny-fixed-pipeline> ]
     [ <bunny-cel-shaded> ]
@@ -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
+        [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny
-        draw-bunny
     ] if ;
 
 M: bunny-gadget pref-dim* ( gadget -- dim )

extra/bunny/model/model.factor

@@ -1,9 +1,7 @@
-USING: alien alien.c-types arrays sequences math math.vectors
+USING: accessors alien.c-types arrays combinators destructors http.client
-math.matrices math.parser io io.files kernel opengl opengl.gl
+io io.encodings.ascii io.files kernel math math.matrices math.parser
-opengl.glu io.encodings.ascii opengl.capabilities shuffle
+math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib
-http.client vectors splitting system combinators
+splitting vectors words ;
-float-arrays continuations destructors namespaces sequences.lib
-accessors ;
 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 <gl-buffer>
         ]
         [
@@ -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
+                nv>> "float" heap-size * buffer-offset
-                3 GL_DOUBLE 0 roll glVertexPointer
+                3 GL_FLOAT 0 roll glVertexPointer
             ] [
                 ni>>
                 GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements

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
+    dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi =
-    over =
+    [ drop ] [
-    [ 2drop ] [
+        [ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri {
-        [ dup dispose-framebuffer dup ] dip {
             [
                 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 ( -- )

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 accessors ;
 IN: color-picker
 
 ! Simple example demonstrating the use of models.
@@ -15,7 +15,8 @@ TUPLE: color-preview < gadget ;
 
 : <color-preview> ( 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
 : <color-sliders> ( -- model gadget )
     3 [ 0 0 0 255 <range> ] replicate
     dup [ range-model ] map <compose>
-    swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;
+    swap
+    <filled-pile>
+    swap
+      [ <color-slider> add-gadget ] each ;
 
 : <color-picker> ( -- gadget )
     [

extra/ctags/ctags-docs.factor

@@ -1,4 +1,4 @@
-USING: help.syntax help.markup kernel prettyprint sequences strings ;
+USING: help.syntax help.markup kernel prettyprint sequences strings words math ;
 IN: ctags
 
 ARTICLE: "ctags" "Ctags file"
@@ -6,7 +6,10 @@ ARTICLE: "ctags" "Ctags file"
 { $subsection ctags }
 { $subsection ctags-write }
 { $subsection ctag-strings }
-{ $subsection ctag } ;
+{ $subsection ctag }
+{ $subsection ctag-word }
+{ $subsection ctag-path }
+{ $subsection ctag-lineno } ;
 
 HELP: ctags ( path -- )
 { $values { "path" "a pathname string" } }
@@ -57,4 +60,41 @@ HELP: ctag ( seq -- str )
   }
 } ;
 
+HELP: ctag-lineno ( ctag -- n )
+{ $values { "ctag" sequence }
+          { "n" integer } }
+{ $description "Provides de line number " { $snippet "n" } " from a sequence in ctag format " }
+{ $examples
+  { $example
+    "USING: kernel ctags prettyprint ;"
+    "{ if  { \"resource:extra/unix/unix.factor\" 91 } } ctag-lineno ."
+    "91"
+  }
+} ;
+
+HELP: ctag-path ( ctag -- path )
+{ $values { "ctag" sequence }
+          { "path" string } }
+{ $description "Provides a path string " { $snippet "path" } " from a sequence in ctag format" }
+{ $examples
+  { $example
+    "USING: kernel ctags prettyprint ;"
+    "{ if  { \"resource:extra/unix/unix.factor\" 91 } } ctag-path ."
+    "\"resource:extra/unix/unix.factor\""
+  }
+} ;
+
+HELP: ctag-word ( ctag -- word )
+{ $values { "ctag" sequence }
+          { "word" word } }
+{ $description "Provides the " { $snippet "word" } " from a sequence in ctag format " }
+{ $examples
+  { $example
+    "USING: kernel ctags prettyprint ;"
+    "{ if  { \"resource:extra/unix/unix.factor\" 91 } } ctag-word ."
+    "if"
+  }
+} ;
+
+
 ABOUT: "ctags"

extra/ctags/ctags-tests.factor

@@ -1,6 +1,21 @@
 USING: kernel ctags tools.test io.backend sequences arrays prettyprint ;
 IN: ctags.tests
 
+[ t ] [
+  91
+  { if  { "resource:extra/unix/unix.factor" 91 } } ctag-lineno =
+] unit-test
+
+[ t ] [
+  "resource:extra/unix/unix.factor"
+  { if  { "resource:extra/unix/unix.factor" 91 } } ctag-path =
+] unit-test
+
+[ t ] [
+  \ if
+  { if  { "resource:extra/unix/unix.factor" 91 } } ctag-word =
+] unit-test
+
 [ t ] [
   "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append
   { if  { "resource:extra/unix/unix.factor" 91 } } ctag =
@@ -10,3 +25,4 @@ IN: ctags.tests
   "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array
   { { if  { "resource:extra/unix/unix.factor" 91 } } } ctag-strings =
 ] unit-test
+

extra/ctags/ctags.factor

@@ -9,29 +9,36 @@ io.encodings.ascii math.parser vocabs definitions
 namespaces words sorting ;
 IN: ctags
 
+: ctag-word ( ctag -- word )
+  first ;
+
+: ctag-path ( ctag -- path )
+  second first ;
+
+: ctag-lineno ( ctag -- n )
+  second second ;
+
 : ctag ( seq -- str )
   [
-    dup first ?word-name %
+    dup ctag-word ?word-name %
     "\t" %
-    second dup first normalize-path %
+    dup ctag-path normalize-path %
     "\t" %
-    second number>string %
+    ctag-lineno number>string %
   ] "" make ;
 
 : ctag-strings ( seq1 -- seq2 )
-  { } swap [ ctag suffix ] each ;
+  [ ctag ] map ;
 
 : ctags-write ( seq path -- )
   [ ctag-strings ] dip ascii set-file-lines ;
 
 : (ctags) ( -- seq )
-  { } all-words [
+  all-words [
     dup where [
-      2array suffix
+      2array
-    ] [
+    ] when*
-      drop
+  ] map [ sequence? ] filter ;
-    ] if*
-  ] each ;
 
 : ctags ( path -- )
   (ctags) sort-keys swap ctags-write ;

extra/ctags/etags/authors.txt

@@ -0,0 +1 @@
+Alfredo Beaumont

extra/ctags/etags/etags-docs.factor

@@ -0,0 +1,39 @@
+USING: help.syntax help.markup kernel prettyprint sequences strings words math ;
+IN: ctags.etags
+
+ARTICLE: "etags" "Etags file"
+{ $emphasis "Etags" } " generates a index file of every factor word in etags format as supported by emacs and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags#Etags_2" } "."
+{ $subsection etags }
+{ $subsection etags-write }
+{ $subsection etag-strings }
+{ $subsection etag-header }
+
+HELP: etags ( path -- )
+{ $values { "path" string } }
+{ $description "Generates a index file in etags format and stores in " { $snippet "path" } "." }
+{ $examples
+  { $unchecked-example
+    "USING: ctags.etags ;"
+    "\"ETAGS\" etags"
+    ""
+  }
+} ;
+
+HELP: etags-write ( alist path -- )
+{ $values { "alist" sequence }
+          { "path" string } }
+{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with etags format: its key must be a resource path and its value a vector, containing pairs of words and lines" }
+{ $examples
+  { $unchecked-example
+    "USING: kernel etags.ctags ;"
+    "{ { \"resource:extra/unix/unix.factor\" V{ { dup2 91 } } } } \"ETAGS\" etags-write"
+    ""
+  }
+} ;
+
+HELP: etag-strings ( alist -- seq )
+{ $values { "alist" sequence }
+          { "seq" sequence } }
+{ $description "Converts an " { $snippet "alist" } " with etag format (a path as key and a vector containing word/line pairs) in a " { $snippet "seq" } " of strings." } ;
+
+ABOUT: "etags" ;

extra/ctags/etags/etags-tests.factor

@@ -0,0 +1,72 @@
+USING: kernel ctags ctags.etags tools.test io.backend sequences arrays prettyprint hashtables assocs ;
+IN: ctags.etags.tests
+
+! etag-at
+[ t ]
+[
+  V{ }
+  "path" H{ } clone etag-at =
+] unit-test
+
+[ t ]
+[
+  V{ if { "path" 1 } }
+  "path" H{ { "path" V{ if { "path" 1 } } } } etag-at =
+] unit-test
+
+! etag-vector
+[ t ]
+[
+  V{ }
+  { if { "path" 1 } } H{ } clone etag-vector =
+] unit-test
+
+[ t ]
+[
+  V{ if { "path" 1 } }
+  { if { "path" 1 } }
+  { { "path" V{ if { "path" 1 } } } } >hashtable
+  etag-vector = 
+] unit-test
+
+! etag-pair 
+[ t ]
+[
+  { if 28 }
+  { if { "resource:core/kernel/kernel.factor" 28 } } etag-pair =
+] unit-test
+
+! etag-add
+[ t ]
+[
+  H{ { "path" V{ { if  1 } } } }
+  { if { "path" 1 } } H{ } clone [ etag-add ] keep =
+] unit-test
+
+! etag-hash
+[ t ]
+[
+  H{ { "path" V{ { if 1 } } } }
+  { { if { "path" 1 } } } etag-hash =
+] unit-test
+
+! line-bytes (note that for each line implicit \n is counted)
+[ t ]
+[
+  17
+  { "1234567890" "12345" } 2 lines>bytes =
+] unit-test
+  
+! etag
+[ t ]
+[
+  "if2,11"
+  { "1234567890" "12345" } { if 2 } etag =
+] unit-test
+
+! etag-length
+[ t ]
+[
+  14
+  V{ "if2,11" "if2,11" } etag-length =
+] unit-test

extra/ctags/etags/etags.factor

@@ -0,0 +1,75 @@
+! Copyright (C) 2008 Alfredo Beaumont
+! See http://factorcode.org/license.txt for BSD license.
+
+! Emacs Etags generator
+! Alfredo Beaumont <alfredo.beaumont@gmail.com>
+USING: kernel sequences sorting assocs words prettyprint ctags
+io.encodings.ascii io.files math math.parser namespaces strings locals
+shuffle io.backend arrays ;
+IN: ctags.etags
+
+: etag-at ( key hash -- vector )
+  at [ V{ } clone ] unless* ;
+
+: etag-vector ( alist hash -- vector )
+  [ ctag-path ] dip etag-at ;
+
+: etag-pair ( ctag -- seq )
+  dup [
+    first ,
+    second second ,
+  ] { } make ;
+
+: etag-add ( ctag hash -- )
+  [ etag-vector ] 2keep [
+    [ etag-pair ] [ ctag-path ] bi [ suffix ] dip
+  ] dip set-at ;
+    
+: etag-hash ( seq -- hash )
+  H{ } clone swap [ swap [ etag-add ] keep ] each ;
+
+: lines>bytes ( seq n -- bytes )
+  head 0 [ length 1+ + ] reduce ;
+
+: file>lines ( path -- lines )
+  ascii file-lines ;
+
+: etag ( lines seq -- str )
+  [
+    dup first ?word-name %
+    1 HEX: 7f <string> %
+    second dup number>string %
+    1 CHAR: , <string> %
+    1- lines>bytes number>string %
+  ] "" make ;
+
+: etag-length ( vector -- n )
+  0 [ length + ] reduce ;
+
+: (etag-header) ( n path -- str )
+  [
+    %
+    1 CHAR: , <string> %
+    number>string %
+  ] "" make ;
+
+: etag-header ( vec1 n resource -- vec2 )
+  normalize-path (etag-header) prefix
+  1 HEX: 0c <string> prefix ;
+
+: etag-strings ( alist -- seq )
+  { } swap [
+    [
+      [ first file>lines ]
+      [ second ] bi
+      [ etag ] with map
+      dup etag-length
+    ] keep first 
+    etag-header append
+  ] each ;
+
+: etags-write ( alist path -- )
+  [ etag-strings ] dip ascii set-file-lines ; 
+
+: etags ( path -- )
+  [ (ctags) sort-values etag-hash >alist ] dip etags-write ;

extra/ctags/etags/summary.txt

@@ -0,0 +1 @@
+Etags generator

extra/delegate/delegate-tests.factor

@@ -79,3 +79,15 @@ CONSULT: beta hey value>> 1- ;
 [ -1 ] [ 1 <hey> four ] unit-test
 [ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
 [ f ] [ hey \ one method ] unit-test
+
+TUPLE: slot-protocol-test-1 a b ;
+TUPLE: slot-protocol-test-2 < slot-protocol-test-1 { c integer } ;
+
+TUPLE: slot-protocol-test-3 d ;
+
+CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
+
+[ "a" "b" 5 ] [
+    T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } }
+    [ a>> ] [ b>> ] [ c>> ] tri
+] unit-test

extra/delegate/delegate.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors parser generic kernel classes classes.tuple
 words slots assocs sequences arrays vectors definitions
@@ -14,9 +14,11 @@ IN: delegate
 GENERIC: group-words ( group -- words )
 
 M: tuple-class group-words
-    "slot-names" word-prop [
+    all-slots [
-        [ reader-word ] [ writer-word ] bi
+        name>>
-        2array [ 0 2array ] map
+        [ reader-word 0 2array ]
+        [ writer-word 0 2array ] bi
+        2array
     ] map concat ;
 
 ! Consultation

extra/float-arrays/float-arrays.factor

@@ -9,16 +9,8 @@ TUPLE: float-array
 { length array-capacity read-only }
 { underlying byte-array read-only } ;
 
-<PRIVATE
-
-: floats>bytes 8 * ; inline
-
-: float-array@ underlying>> swap >fixnum floats>bytes ; inline
-
-PRIVATE>
-
 : <float-array> ( n -- float-array )
-    dup floats>bytes <byte-array> float-array boa ; inline
+    dup "double" <c-array> 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 <float-array> [ 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 } ;

extra/generalizations/generalizations-docs.factor

@@ -1,9 +1,21 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
 USING: help.syntax help.markup kernel sequences quotations
-math ;
+math arrays ;
 IN: generalizations
 
+HELP: narray
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link 1array } ", "
+{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "
+"that constructs an array from the top " { $snippet "n" } " elements of the stack."
+} ;
+
+HELP: firstn
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link first } ", "
+{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "
+"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."
+} ;
+
 HELP: npick
 { $values { "n" integer } }
 { $description "A generalization of " { $link dup } ", "
@@ -119,6 +131,7 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators"
 "macros where the arity of the input quotations depends on an "
 "input parameter."
 { $subsection narray }
+{ $subsection firstn }
 { $subsection ndup }
 { $subsection npick }
 { $subsection nrot }

extra/generalizations/generalizations-tests.factor

@@ -32,3 +32,7 @@ IN: generalizations.tests
 [ [ dup 2^ 2array ] 5 napply ] must-infer
 
 [ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
+
+[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
+[ ] [ { } 0 firstn ] unit-test
+[ "a" ] [ { "a" } 1 firstn ] unit-test

extra/generalizations/generalizations.factor

@@ -1,14 +1,20 @@
-! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
+! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
+! Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences sequences.private namespaces math math.ranges
+USING: kernel sequences sequences.private namespaces math
-combinators macros quotations fry locals arrays ;
+math.ranges combinators macros quotations fry arrays ;
 IN: generalizations
 
 MACRO: narray ( n -- quot )
-    dup [ f <array> ] curry
+    [ <reversed> ] [ '[ , f <array> ] ] bi
-    swap <reversed> [
+    [ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;
-        [ swap [ set-nth-unsafe ] keep ] curry
+
-    ] map concat append ;
+MACRO: firstn ( n -- )
+    dup zero? [ drop [ drop ] ] [
+        [ [ '[ , _ nth-unsafe ] ] map ]
+        [ 1- '[ , _ bounds-check 2drop ] ]
+        bi prefix '[ , cleave ]
+    ] if ;
 
 MACRO: npick ( n -- )
     1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
@@ -32,7 +38,7 @@ MACRO: ntuck ( n -- )
     2 + [ dupd -nrot ] curry ;
 
 MACRO: nrev ( n -- quot )
-    1 [a,b] [ '[ , -nrot ] ] map concat ;
+    1 [a,b] [ ] [ '[ @ , -nrot ] ] reduce ;
 
 MACRO: ndip ( quot n -- )
     dup saver -rot restorer 3append ;
@@ -44,11 +50,11 @@ MACRO: nkeep ( n -- )
     [ ] [ 1+ ] [ ] tri
     '[ [ , ndup ] dip , -nrot , nslip ] ;
 
-MACRO: ncurry ( n -- ) [ curry ] n*quot ;
+MACRO: ncurry ( n -- )
+    [ curry ] n*quot ;
 
-MACRO:: nwith ( quot n -- )
+MACRO: nwith ( n -- )
-    [let | n' [ n 1+ ] |
+    [ with ] n*quot ;
-        [ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;
 
 MACRO: napply ( n -- )
     2 [a,b]

extra/geo-ip/geo-ip.factor

@@ -1,5 +1,7 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences io.files io.launcher io.encodings.ascii
-io.streams.string http.client sequences.lib combinators
+io.streams.string http.client generalizations combinators
 math.parser math.vectors math.intervals interval-maps memoize
 csv accessors assocs strings math splitting grouping arrays ;
 IN: geo-ip

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 ;
 
 : <gesture-logger> ( stream -- gadget )
-    \ gesture-logger construct-gadget
+    \ gesture-logger new-gadget
     swap >>stream
     { 100 100 } >>dim
     black solid-interior ;

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 ;
+    scan-word
+    [ +inlined+ changed-definition ]
+    [ parse-definition "specializer" set-word-prop ] bi ;
     parsing

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

extra/io/ports/ports.factor

@@ -19,7 +19,7 @@ M: port set-timeout (>>timeout) ;
 : <port> ( handle class -- port )
     new swap >>handle ; inline
 
-TUPLE: buffered-port < port buffer ;
+TUPLE: buffered-port < port { buffer buffer } ;
 
 : <buffered-port> ( handle class -- port )
     <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 ]
+    [ call-next-method ] [ buffer>> dispose ] bi ;
-    [ [ [ dispose ] when* f ] change-buffer drop ]
-    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 } ;

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 ;

extra/lists/tags.txt

@@ -1,3 +1 @@
-cons
+collections
-lists
-sequences

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 ( -- )
 
+<pile>
+
 {
 
 [ "Load" <label> reverse-video-theme ]
@@ -145,9 +147,11 @@ DEFER: empty-model
   [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
   camera-action <bevel-button> ]
 
-} make*
+}
-[ [ gadget, ] curry ] map concat ! Hack
+
-make-pile 1 over set-pack-fill "L-system control" open-window ;
+[ call add-gadget ] each
+1 >>fill
+"L-system control" open-window ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -469,7 +473,7 @@ H{ } >rules ;
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : model-chooser ( -- )
-
+<pile>
 {
 [ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ]
 [ "abop-2" <label> [ drop abop-2 build-model ] closed-quot <bevel-button> ]
@@ -481,18 +485,21 @@ H{ } >rules ;
 [ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ]
 [ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ]
 [ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
-} make*
+}
-[ [ gadget, ] curry ] map concat ! Hack
+[ call add-gadget ] each
-make-pile 1 over set-pack-fill "L-system models" open-window ;
+1 >>fill
+"L-system models" open-window ;
 
 : scene-chooser ( -- )
+<pile>
 {
 [ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ]
 [ "abop-2" <label> [ drop abop-2-scene ] closed-quot <bevel-button> ]
 [ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ]
-} make*
+}
-[ [ gadget, ] curry ] map concat ! Hack
+[ call add-gadget ] each
-make-pile 1 over set-pack-fill "L-system scenes" open-window ;
+1 >>fill
+"L-system scenes" open-window ;
 
 : lsys-window* ( -- )
 [ lsys-controller lsys-viewer ] with-ui ;

extra/math/geometry/rect/rect-tests.factor

@@ -0,0 +1,37 @@
+
+USING: tools.test math.geometry.rect ;
+
+IN: math.geometry.rect.tests
+
+[ T{ rect f { 10 10 } { 20 20 } } ]
+[
+    T{ rect f { 10 10 } { 50 50 } }
+    T{ rect f { -10 -10 } { 40 40 } }
+    rect-intersect
+] unit-test
+
+[ T{ rect f { 200 200 } { 0 0 } } ]
+[
+    T{ rect f { 100 100 } { 50 50 } }
+    T{ rect f { 200 200 } { 40 40 } }
+    rect-intersect
+] unit-test
+
+[ f ] [
+    T{ rect f { 100 100 } { 50 50 } }
+    T{ rect f { 200 200 } { 40 40 } }
+    intersects?
+] unit-test
+
+[ t ] [
+    T{ rect f { 100 100 } { 50 50 } }
+    T{ rect f { 120 120 } { 40 40 } }
+    intersects?
+] unit-test
+
+[ f ] [
+    T{ rect f { 1000 100 } { 50 50 } }
+    T{ rect f { 120 120 } { 40 40 } }
+    intersects?
+] unit-test
+

extra/math/physics/pos/pos.factor

@@ -1,5 +1,17 @@
 
+USING: kernel sequences multi-methods accessors math.vectors ;
+
 IN: math.physics.pos
 
 TUPLE: pos pos ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: distance ( a b -- c )
+
+METHOD: distance { sequence sequence } v- norm ;
+
+METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+