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

@@ -348,7 +348,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 +357,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 +368,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/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/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"
 } ;

core/classes/tuple/tuple.factor

@@ -336,6 +336,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/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/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/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

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/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/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 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 ;
 IN: optimizer.math
-USING: alien alien.accessors arrays generic hashtables kernel
-assocs math math.private kernel.private sequences words parser
-inference.class inference.dataflow vectors strings sbufs io
-namespaces assocs quotations math.intervals sequences.private
-combinators splitting layouts math.parser classes
-classes.algebra generic.math optimizer.pattern-match
-optimizer.backend optimizer.def-use optimizer.inlining
-optimizer.math.partial generic.standard system accessors ;
 
 : define-math-identities ( word identities -- )
     >r all-derived-ops r> define-identities ;
@@ -169,6 +170,22 @@ optimizer.math.partial generic.standard system accessors ;
     ] 2curry each-derived-op
 ] each
 
+: math-output-class/interval-2-fast ( node word -- classes intervals )
+    math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline
+
+[
+    { + interval+ }
+    { - interval- }
+    { * interval* }
+    { shift interval-shift-safe }
+] [
+    first2 [
+        [
+            math-output-class/interval-2-fast
+        ] curry "output-classes" set-word-prop
+    ] curry each-fast-derived-op
+] each
+
 : real-value? ( value -- n ? )
     dup value? [ value-literal dup real? ] [ drop f f ] if ;
 
@@ -420,3 +437,37 @@ most-negative-fixnum most-positive-fixnum [a,b]
         [ fixnumify-bitand ]
     }
 } define-optimizers
+
+{ + - * / }
+[ { number number } "input-classes" set-word-prop ] each
+
+{ /f < > <= >= }
+[ { real real } "input-classes" set-word-prop ] each
+
+{ /i 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,12 @@ PREDICATE: list < improper-list
 [ 2 3 ] [ 2 interval-inference-bug ] unit-test
 [ 1 4 ] [ 1 interval-inference-bug ] unit-test
 [ 0 5 ] [ 0 interval-inference-bug ] unit-test
+
+: aggressive-flush-regression ( a -- b )
+    f over >r <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

core/sequences/sequences.factor

@@ -21,9 +21,12 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable
 M: sequence like drop ;
 
 GENERIC: lengthen ( n seq -- )
+GENERIC: shorten ( n seq -- )
 
 M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
 
+M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
+
 : empty? ( seq -- ? ) length zero? ; inline
 : delete-all ( seq -- ) 0 swap set-length ;
 
@@ -530,7 +533,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
 
 : peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
 
-: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ;
+: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
 
 : move-backward ( shift from to seq -- )
     2over number= [
@@ -575,7 +578,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
     copy ;
 
 : pop ( seq -- elt )
-    [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ;
+    [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
 
 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
 

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 )

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/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/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/float-arrays/float-arrays.factor

@@ -72,3 +72,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/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/nehe/2/2.factor

@@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
 ui.gadgets ui.render ;
 IN: nehe.2
 
-TUPLE: nehe2-gadget ;
+TUPLE: nehe2-gadget < gadget ;
 
 : width 256 ;
 : height 256 ;
 
 : <nehe2-gadget> (  -- gadget )
-  nehe2-gadget construct-gadget ;
+  nehe2-gadget new-gadget ;
 
 M: nehe2-gadget pref-dim* ( gadget -- dim )
   drop width height 2array ;

extra/nehe/3/3.factor

@@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
 ui.gadgets ui.render ;
 IN: nehe.3
 
-TUPLE: nehe3-gadget ;
+TUPLE: nehe3-gadget < gadget ;
 
 : width 256 ;
 : height 256 ;
 
 : <nehe3-gadget> (  -- gadget )
-  nehe3-gadget construct-gadget ;
+  nehe3-gadget new-gadget ;
 
 M: nehe3-gadget pref-dim* ( gadget -- dim )
   drop width height 2array ;

extra/nehe/4/4.factor

@@ -2,14 +2,14 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
 ui.gadgets ui.render threads ;
 IN: nehe.4
 
-TUPLE: nehe4-gadget rtri rquad thread quit? ;
+TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
 
 : width 256 ;
 : height 256 ;
 : redraw-interval 10 ;
 
 : <nehe4-gadget> (  -- gadget )
-  nehe4-gadget construct-gadget
+  nehe4-gadget new-gadget
   0.0 over set-nehe4-gadget-rtri
   0.0 over set-nehe4-gadget-rquad ;
 

extra/nehe/5/5.factor

@@ -2,13 +2,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui
 ui.gadgets ui.render threads ;
 IN: nehe.5
 
-TUPLE: nehe5-gadget rtri rquad thread quit? ;
+TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
 : width 256 ;
 : height 256 ;
 : redraw-interval 10 ;
 
 : <nehe5-gadget> (  -- gadget )
-  nehe5-gadget construct-gadget
+  nehe5-gadget new-gadget
   0.0 over set-nehe5-gadget-rtri
   0.0 over set-nehe5-gadget-rquad ;
 

extra/opengl/demo-support/demo-support.factor

@@ -9,10 +9,10 @@ IN: opengl.demo-support
 
 SYMBOL: last-drag-loc
 
-TUPLE: demo-gadget yaw pitch distance ;
+TUPLE: demo-gadget < gadget yaw pitch distance ;
 
-: <demo-gadget> ( yaw pitch distance -- gadget )
+: new-demo-gadget ( yaw pitch distance class -- gadget )
-    demo-gadget construct-gadget
+    new-gadget
         swap >>distance
         swap >>pitch
         swap >>yaw ;
@@ -31,19 +31,19 @@ M: demo-gadget distance-step ( gadget -- dz )
 : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
 
 : yaw-demo-gadget ( yaw gadget -- )
-    [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ;
+    [ + ] with change-yaw relayout-1 ;
 
 : pitch-demo-gadget ( pitch gadget -- )
-    [ [ demo-gadget-pitch + ] keep set-demo-gadget-pitch ] keep relayout-1 ;
+    [ + ] with change-pitch relayout-1 ;
 
 : zoom-demo-gadget ( distance gadget -- )
-    [ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ;
+    [ + ] with change-distance relayout-1 ;
 
 M: demo-gadget pref-dim* ( gadget -- dim )
     drop { 640 480 } ;
 
 : -+ ( x -- -x x )
-    dup neg swap ;
+    [ neg ] keep ;
 
 : demo-gadget-frustum ( gadget -- -x x -y y near far )
     [ near-plane ] [ far-plane ] [ fov-ratio ] tri [

extra/optimizer/debugger/debugger.factor

@@ -47,24 +47,28 @@ MATCH-VARS: ?a ?b ?c ;
 
 : pretty-shuffle ( in out -- word/f )
     2array {
-        { { { ?a } { } } drop }
+        { { { ?a } { ?a } } [ ] }
-        { { { ?a ?b } { } } 2drop }
+        { { { ?a ?b } { ?a ?b } } [ ] }
-        { { { ?a ?b ?c } { } } 3drop }
+        { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
-        { { { ?a } { ?a ?a } } dup }
+        { { { ?a } { } } [ drop ] }
-        { { { ?a ?b } { ?a ?b ?a ?b } } 2dup }
+        { { { ?a ?b } { } } [ 2drop ] }
-        { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } 3dup }
+        { { { ?a ?b ?c } { } } [ 3drop ] }
-        { { { ?a ?b } { ?a ?b ?a } } over }
+        { { { ?a } { ?a ?a } } [ dup ] }
-        { { { ?b ?a } { ?a ?b } } swap }
+        { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
-        { { { ?a ?b ?c } { ?a ?b ?c ?a } } pick }
+        { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
-        { { { ?a ?b ?c } { ?c ?a ?b } } -rot }
+        { { { ?a ?b } { ?a ?b ?a } } [ over ] }
-        { { { ?a ?b ?c } { ?b ?c ?a } } rot }
+        { { { ?b ?a } { ?a ?b } } [ swap ] }
-        { { { ?a ?b } { ?b } } nip }
+        { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
+        { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
+        { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
+        { { { ?a ?b } { ?b } } [ nip ] }
+        { { { ?a ?b ?c } { ?c } } [ 2nip ] }
         { _ f }
     } match-choose ;
 
 M: #shuffle node>quot
     dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle
-    [ , ] [ >r drop t r> ] if*
+    [ % ] [ >r drop t r> ] if*
     dup effect-str "#shuffle: " prepend comment, ;
 
 : pushed-literals ( node -- seq )

extra/spheres/spheres.factor

@@ -99,14 +99,13 @@ main()
 }
 ;
 
-TUPLE: spheres-gadget
+TUPLE: spheres-gadget < demo-gadget
     plane-program solid-sphere-program texture-sphere-program
     reflection-framebuffer reflection-depthbuffer
     reflection-texture ;
 
 : <spheres-gadget> ( -- gadget )
-    20.0 10.0 20.0 <demo-gadget>
+    20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
-    { set-delegate } spheres-gadget construct ;
 
 M: spheres-gadget near-plane ( gadget -- z )
     drop 1.0 ;

extra/tools/deploy/shaker/shaker.factor

@@ -101,6 +101,7 @@ IN: tools.deploy.shaker
                 "if-intrinsics"
                 "infer"
                 "inferred-effect"
+                "input-classes"
                 "interval"
                 "intrinsics"
                 "loc"

extra/ui/gadgets/borders/borders.factor

@@ -33,7 +33,8 @@ M: border pref-dim*
     [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
 
 : border-loc ( border dim -- loc )
-    [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ;
+    [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
+    v- v* v+ [ >fixnum ] map ;
 
 : border-child-rect ( border -- rect )
     dup border-dim [ border-loc ] keep <rect> ;

extra/windows/ole32/ole32.factor

@@ -10,6 +10,7 @@ TYPEDEF: void* LPUNKNOWN
 TYPEDEF: wchar_t* LPOLESTR
 TYPEDEF: wchar_t* LPCOLESTR
 
+TYPEDEF: REFGUID LPGUID
 TYPEDEF: REFGUID REFIID
 TYPEDEF: REFGUID REFCLSID