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

basis/struct-arrays/struct-arrays.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.structs byte-arrays
-classes.struct kernel libc math parser sequences sequences.private ;
+classes.struct kernel libc math parser sequences
+sequences.private words fry memoize compiler.units ;
 IN: struct-arrays
 
 : c-type-struct-class ( c-type -- class )
@@ -11,7 +12,8 @@ TUPLE: struct-array
 { underlying c-ptr read-only }
 { length array-capacity read-only }
 { element-size array-capacity read-only }
-{ class read-only } ;
+{ class read-only }
+{ ctor read-only } ;
 
 M: struct-array length length>> ; inline
 M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
@@ -20,34 +22,49 @@ M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
     [ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
 
 M: struct-array nth-unsafe
-    [ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline
+    [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline
 
 M: struct-array set-nth-unsafe
     [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
 
+: (struct-element-constructor) ( c-type -- word )
+    [
+        "struct-array-ctor" f <word>
+        [
+            swap dup struct-class?
+            [ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if
+            (( alien -- object )) define-inline
+        ] keep
+    ] with-compilation-unit ;
+
+! Foldable memo word. This is an optimization; by precompiling a
+! constructor for array elements, we avoid memory>struct's slow path.
+MEMO: struct-element-constructor ( c-type -- word )
+    (struct-element-constructor) ; foldable
+
+: <direct-struct-array> ( alien length c-type -- struct-array )
+    [ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ]
+    tri struct-array boa ; inline
+
 M: struct-array new-sequence
-    [ element-size>> [ * (byte-array) ] 2keep ]
-    [ class>> ] bi struct-array boa ; inline
+    [ element-size>> * (byte-array) ] [ length>> ] [ class>> ] tri
+    <direct-struct-array> ; inline
 
 M: struct-array resize ( n seq -- newseq )
-    [ [ element-size>> * ] [ underlying>> ] bi resize ]
-    [ [ element-size>> ] [ class>> ] bi ] 2bi
-    struct-array boa ;
+    [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi
+    <direct-struct-array> ; inline
 
 : <struct-array> ( length c-type -- struct-array )
-    [ heap-size [ * <byte-array> ] 2keep ]
-    [ c-type-struct-class ] bi struct-array boa ; inline
+    [ heap-size * <byte-array> ] 2keep <direct-struct-array> ; inline
 
 ERROR: bad-byte-array-length byte-array ;
 
 : byte-array>struct-array ( byte-array c-type -- struct-array )
-    [ heap-size [
+    [
+        heap-size
         [ dup length ] dip /mod 0 =
         [ drop bad-byte-array-length ] unless
-    ] keep ] [ c-type-struct-class ] bi struct-array boa ; inline
-
-: <direct-struct-array> ( alien length c-type -- struct-array )
-    [ heap-size ] [ c-type-struct-class ] bi struct-array boa ; inline
+    ] keep <direct-struct-array> ; inline
 
 : struct-array-on ( struct length -- struct-array )
     [ [ >c-ptr ] [ class ] bi ] dip swap <direct-struct-array> ; inline    

basis/tools/deploy/shaker/shaker.factor

@@ -68,9 +68,14 @@ IN: tools.deploy.shaker
     ] when ;
 
 : strip-destructors ( -- )
-    "libc" vocab [
-        "Stripping destructor debug code" show
-        "vocab:tools/deploy/shaker/strip-destructors.factor"
+    "Stripping destructor debug code" show
+    "vocab:tools/deploy/shaker/strip-destructors.factor"
+    run-file ;
+
+: strip-struct-arrays ( -- )
+    "struct-arrays" vocab [
+        "Stripping dynamic struct array code" show
+        "vocab:tools/deploy/shaker/strip-struct-arrays.factor"
         run-file
     ] when ;
 
@@ -493,6 +498,7 @@ SYMBOL: deploy-vocab
 : strip ( -- )
     init-stripper
     strip-libc
+    strip-struct-arrays
     strip-destructors
     strip-call
     strip-cocoa

basis/tools/deploy/shaker/strip-call.factor

@@ -1,10 +1,14 @@
 ! Copyright (C) 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-IN: tools.deploy.shaker.call
-
+USING: combinators.private kernel ;
 IN: combinators
-USE: combinators.private
 
-: call-effect ( word effect -- ) call-effect-unsafe ; inline
+: call-effect ( word effect -- ) call-effect-unsafe ;
 
-: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
+: execute-effect ( word effect -- ) execute-effect-unsafe ;
+
+IN: compiler.tree.propagation.call-effect
+
+: call-effect-unsafe? ( quot effect -- ? ) 2drop t ; inline
+
+: execute-effect-unsafe? ( word effect -- ? ) 2drop t ; inline

basis/tools/deploy/shaker/strip-struct-arrays.factor

@@ -0,0 +1,13 @@
+USING: kernel stack-checker.transforms ;
+IN: struct-arrays
+
+: struct-element-constructor ( c-type -- word )
+    "Struct array usages must be compiled" throw ;
+
+<<
+
+\ struct-element-constructor [
+    (struct-element-constructor) [ ] curry
+] 1 define-transform
+
+>>

basis/windows/com/wrapper/wrapper.factor

@@ -3,7 +3,8 @@ init windows.com.syntax.private windows.com continuations kernel
 namespaces windows.ole32 libc vocabs assocs accessors arrays
 sequences quotations combinators math words compiler.units
 destructors fry math.parser generalizations sets
-specialized-arrays.alien specialized-arrays.direct.alien ;
+specialized-arrays.alien specialized-arrays.direct.alien
+windows.kernel32 ;
 IN: windows.com.wrapper
 
 TUPLE: com-wrapper < disposable callbacks vtbls ;

basis/windows/ole32/ole32-tests.factor

@@ -1,5 +1,6 @@
 USING: kernel tools.test windows.ole32 alien.c-types
-classes.struct specialized-arrays.uchar windows.kernel32 ;
+classes.struct specialized-arrays.uchar windows.kernel32
+windows.com.syntax ;
 IN: windows.ole32.tests
 
 [ t ] [

core/combinators/combinators-docs.factor

@@ -275,7 +275,7 @@ $nl
 "The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
 { $subsection call }
 { $subsection execute }
-"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:"
+"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:"
 { $subsection POSTPONE: call( }
 { $subsection POSTPONE: execute( }
 "The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
@@ -303,11 +303,25 @@ ABOUT: "combinators"
 
 HELP: call-effect
 { $values { "quot" quotation } { "effect" effect } }
-{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
+{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." }
+{ $examples
+  "The following two lines are equivalent:"
+  { $code
+    "call( a b -- c )"
+    "(( a b -- c )) call-effect"
+  }
+} ;
 
 HELP: execute-effect
 { $values { "word" word } { "effect" effect } }
-{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
+{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
+{ $examples
+  "The following two lines are equivalent:"
+  { $code
+    "execute( a b -- c )"
+    "(( a b -- c )) execute-effect"
+  }
+} ;
 
 HELP: execute-effect-unsafe
 { $values { "word" word } { "effect" effect } }

core/syntax/syntax-docs.factor

@@ -834,6 +834,14 @@ HELP: call(
 
 HELP: execute(
 { $syntax "execute( stack -- effect )" }
-{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
+{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." }
+{ $examples
+  { $code
+    "IN: scratchpad"
+    ""
+    ": eat ( -- ) ; : sleep ( -- ) ; : hack ( -- ) ;"
+    "{ eat sleep hack } [ execute( -- ) ] each"
+  }
+} ;
 
 { POSTPONE: call( POSTPONE: execute( } related-words

extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor

@@ -86,7 +86,7 @@ STRUCT: yuv_buffer
     [ yuv>rgb-row ] with with each
     drop ;
 
-HINTS: yuv>rgb byte-array byte-array ;
+HINTS: yuv>rgb byte-array yuv_buffer ;
 
 : yuv>rgb-benchmark ( -- )
     [ fake-data yuv>rgb ] with-destructors ;