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

basis/classes/struct/struct-tests.factor

@@ -316,6 +316,11 @@ STRUCT: struct-test-optimization
 
 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 
+[ t ] [
+    [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
+    { x>> } inlined?
+] unit-test
+
 ! Test cloning structs
 STRUCT: clone-test-struct { x int } { y char[3] } ;
 
@@ -340,3 +345,4 @@ STRUCT: struct-that's-a-word { x int } ;
 : struct-that's-a-word ( -- ) "OOPS" throw ;
 
 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
+

basis/classes/struct/struct.factor

@@ -42,11 +42,9 @@ M: struct hashcode*
 : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
 
 : memory>struct ( ptr class -- struct )
-    [ 1array ] dip slots>tuple ;
+    ! This is sub-optimal if the class is not literal, but gets
-
+    ! optimized down to efficient code if it is.
-\ memory>struct [
+    '[ _ boa ] call( ptr -- struct ) ; inline
-    dup struct-class? [ '[ _ boa ] ] [ drop f ] if
-] 1 define-partial-eval
 
 <PRIVATE
 : (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )

basis/compiler/tree/propagation/call-effect/call-effect-tests.factor

@@ -47,9 +47,15 @@ IN: compiler.tree.propagation.call-effect.tests
 [ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
 [ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
 [ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
-[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
+[ t ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value (( -- object )) effect= ] unit-test
 [ f ] [ [ dup drop ] final-info first infer-value ] unit-test
 
 ! This should not hang
 [ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
-[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
+[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
+
+! This should get inlined, because the parameter to the curry is literal even though
+! [ boa ] by itself doesn't infer
+TUPLE: a-tuple x ;
+
+[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test

basis/compiler/tree/propagation/call-effect/call-effect.factor

@@ -50,12 +50,12 @@ M: curry cached-effect
 M: compose cached-effect
     [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
 
+: safe-infer ( quot -- effect )
+    [ infer ] [ 2drop +unknown+ ] recover ;
+
 M: quotation cached-effect
     dup cached-effect>>
-    [ ] [
+    [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
-        [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
-        (>>cached-effect)
-    ] ?if ;
 
 : call-effect-unsafe? ( quot effect -- ? )
     [ cached-effect ] dip
@@ -116,6 +116,29 @@ M: quotation cached-effect
 : execute-effect>quot ( effect -- quot )
     inline-cache new '[ drop _ _ execute-effect-ic ] ;
 
+! Some bookkeeping to make sure that crap like
+! [ dup curry call( quot -- ) ] dup curry call( quot -- ) ]
+! doesn't hang the compiler.
+GENERIC: already-inlined-quot? ( quot -- ? )
+
+M: curry already-inlined-quot? quot>> already-inlined-quot? ;
+
+M: compose already-inlined-quot?
+    [ first>> already-inlined-quot? ]
+    [ second>> already-inlined-quot? ] bi or ;
+
+M: quotation already-inlined-quot? already-inlined? ;
+
+GENERIC: add-quot-to-history ( quot -- )
+
+M: curry add-quot-to-history quot>> add-quot-to-history ;
+
+M: compose add-quot-to-history
+    [ first>> add-quot-to-history ]
+    [ second>> add-quot-to-history ] bi ;
+
+M: quotation add-quot-to-history add-to-history ;
+
 : last2 ( seq -- penultimate ultimate )
     2 tail* first2 ;
 
@@ -129,22 +152,18 @@ ERROR: uninferable ;
     (( -- object )) swap compose-effects ;
 
 : (infer-value) ( value-info -- effect )
-    dup class>> {
+    dup literal?>> [
-        { \ quotation [
+        literal>>
-            literal>> [ uninferable ] unless*
+        [ callable? [ uninferable ] unless ]
-            dup already-inlined? [ uninferable ] when
+        [ already-inlined-quot? [ uninferable ] when ]
-            cached-effect dup +unknown+ = [ uninferable ] when
+        [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
-        ] }
+    ] [
-        { \ curry [
+        dup class>> {
-            slots>> third (infer-value)
+            { \ curry [ slots>> third (infer-value) remove-effect-input ] }
-            remove-effect-input
+            { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
-        ] }
+            [ uninferable ]
-        { \ compose [
+        } case
-            slots>> last2 [ (infer-value) ] bi@
+    ] if ;
-            compose-effects
-        ] }
-        [ uninferable ]
-    } case ;
 
 : infer-value ( value-info -- effect/f )
     [ (infer-value) ]
@@ -152,17 +171,20 @@ ERROR: uninferable ;
     recover ;
 
 : (value>quot) ( value-info -- quot )
-    dup class>> {
+    dup literal?>> [
-        { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
+        literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
-        { \ curry [
+    ] [
-            slots>> third (value>quot)
+        dup class>> {
-            '[ [ obj>> ] [ quot>> @ ] bi ]
+            { \ curry [
-        ] }
+                slots>> third (value>quot)
-        { \ compose [
+                '[ [ obj>> ] [ quot>> @ ] bi ]
-            slots>> last2 [ (value>quot) ] bi@
+            ] }
-            '[ [ first>> @ ] [ second>> @ ] bi ]
+            { \ compose [
-        ] }
+                slots>> last2 [ (value>quot) ] bi@
-    } case ;
+                '[ [ first>> @ ] [ second>> @ ] bi ]
+            ] }
+        } case
+    ] if ;
 
 : value>quot ( value-info -- quot: ( code effect -- ) )
     (value>quot) '[ drop @ ] ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -97,11 +97,9 @@ SYMBOL: history
 :: inline-word ( #call word -- ? )
     word already-inlined? [ f ] [
         #call word splicing-body [
-            [
+            word add-to-history
-                word add-to-history
+            #call (>>body)
-                dup (propagate)
+            #call propagate-body
-            ] with-scope
-            #call (>>body) t
         ] [ f ] if*
     ] if ;
 
@@ -141,5 +139,7 @@ SYMBOL: history
     #! Note the logic here: if there's a custom inlining hook,
     #! it is permitted to return f, which means that we try the
     #! normal inlining heuristic.
-    dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+    [
-    [ 2drop t ] [ (do-inlining) ] if ;
+        dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+        [ 2drop t ] [ (do-inlining) ] if
+    ] with-scope ;

basis/compiler/tree/propagation/propagation-tests.factor

@@ -799,3 +799,6 @@ SYMBOL: not-an-assoc
 
 [ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
 [ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
+
+! Don't crash if bad literal inputs are passed to unsafe words
+[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel sequences sequences.private assocs words
+USING: fry accessors kernel sequences sequences.private assocs
-namespaces classes.algebra combinators classes classes.tuple
+words namespaces classes.algebra combinators
-classes.tuple.private continuations arrays alien.c-types
+combinators.short-circuit classes classes.tuple
-math math.private slots generic definitions
+classes.tuple.private continuations arrays alien.c-types math
-stack-checker.state
+math.private slots generic definitions stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -63,9 +63,19 @@ M: #declare propagate-before
     [ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
     with-datastack ;
 
+: literal-inputs? ( #call -- ? )
+    in-d>> [ value-info literal?>> ] all? ;
+
+: input-classes-match? ( #call word -- ? )
+    [ in-d>> ] [ "input-classes" word-prop ] bi*
+    [ [ value-info literal>> ] dip instance? ] 2all? ;
+
 : foldable-call? ( #call word -- ? )
-    "foldable" word-prop
+    {
-    [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
+        [ nip "foldable" word-prop ]
+        [ drop literal-inputs? ]
+        [ input-classes-match? ]
+    } 2&& ;
 
 : (fold-call) ( #call word -- info )
     [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*

basis/struct-arrays/struct-arrays-tests.factor

@@ -1,6 +1,7 @@
 IN: struct-arrays.tests
 USING: classes.struct struct-arrays tools.test kernel math sequences
-alien.syntax alien.c-types destructors libc accessors sequences.private ;
+alien.syntax alien.c-types destructors libc accessors sequences.private
+compiler.tree.debugger ;
 
 STRUCT: test-struct-array
     { x int }
@@ -52,4 +53,10 @@ STRUCT: fixed-string { text char[100] } ;
     ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
 ] unit-test
 
-[ 10 "int" <struct-array> ] must-fail
+[ 10 "int" <struct-array> ] must-fail
+
+STRUCT: wig { x int } ;
+: <bacon> ( -- wig ) 0 wig <struct-boa> ; inline
+: waterfall ( -- a b ) 1 wig <struct-array> <bacon> swap first x>> ; inline
+
+[ t ] [ [ waterfall ] { x>> } inlined? ] unit-test

basis/tools/deploy/deploy-tests.factor

@@ -101,4 +101,8 @@ M: quit-responder call-responder*
 
 os windows? os macosx? or [
     [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
+] when
+
+os macosx? [
+    [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test
 ] when

basis/tools/deploy/test/14/14.factor

@@ -0,0 +1,26 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes.struct cocoa cocoa.classes
+cocoa.subclassing core-graphics.types kernel math ;
+IN: tools.deploy.test.14
+
+CLASS: {
+    { +superclass+ "NSObject" }
+    { +name+ "Bar" }
+} {
+    "bar:"
+    "float"
+    { "id" "SEL" "NSRect" }
+    [
+        [ origin>> [ x>> ] [ y>> ] bi + ]
+        [ size>> [ w>> ] [ h>> ] bi + ]
+        bi +
+    ]
+} ;
+
+: main ( -- )
+    Bar -> alloc -> init
+    S{ CGRect f S{ CGPoint f 1.0 2.0 } S{ CGSize f 3.0 4.0 } } -> bar:
+    10.0 assert= ;
+
+MAIN: main

basis/tools/deploy/test/14/authors.txt

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

basis/tools/deploy/test/14/deploy.factor

@@ -0,0 +1,14 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-c-types? f }
+    { deploy-reflection 1 }
+    { deploy-word-defs? f }
+    { "stop-after-last-window?" t }
+    { deploy-word-props? f }
+    { deploy-threads? t }
+    { deploy-ui? f }
+    { deploy-unicode? f }
+    { deploy-name "tools.deploy.test.14" }
+}

basis/tools/deploy/test/14/tags.txt

@@ -0,0 +1 @@
+unportable

core/make/make-docs.factor

@@ -23,7 +23,7 @@ $nl
 "and"
 { $code "[ [ reverse % ] each ] \"\" make" }
 "is equivalent to"
-{ $code "[ [ reverse ] map concat" }
+{ $code "[ reverse ] map concat" }
 { $heading "Utilities for simple make patterns" }
 "Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link suffix } " is equivalent to the following, with the added caveat that the below example always outputs an array:"
 { $code "[ , % ] { } make" }
@@ -70,4 +70,4 @@ HELP: ,
 
 HELP: %
 { $values { "seq" sequence } }
-{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
+{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;

core/sequences/sequences-docs.factor

@@ -278,7 +278,7 @@ HELP: reduce-index
 
 HELP: accumulate
 { $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
-{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
+{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
 $nl
 "When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." }
 { $examples