added C primitive arrays, faster stack effect inference

doc/handbook.tex

@@ -775,7 +775,7 @@ as the next word in the quotation would expect them. Their behavior can be under
 \ordinaryword{2drop}{2drop ( x y -- )}
 \ordinaryword{3drop}{3drop ( x y z -- )}
 \ordinaryword{nip}{nip ( x y -- y )}
-\ordinaryword{2nip}{2nip ( x y -- y )}
+\ordinaryword{2nip}{2nip ( x y z -- z )}
 \ordinaryword{dup}{dup ( x -- x x )}
 \ordinaryword{2dup}{2dup ( x y -- x y x y )}
 \ordinaryword{3dup}{3dup ( x y z -- x y z x y z )}
@@ -846,7 +846,7 @@ The Factor interpreter executes quotations. Quotations are lists, and since list
 description=a word taking quotations or other words as input}
 The following pair of words invokes the interpreter reflectively. They are used to implement \emph{combinators}, which are words that take code from the stack. Combinator definitions must be followed by the \texttt{inline} word to mark them as inline in order to compile; for example:
 \begin{verbatim}
-: : keep ( x quot -- x | quot: x -- )
+: keep ( x quot -- x | quot: x -- )
     over >r call r> ; inline
 \end{verbatim}
 Word inlining is documented in \ref{declarations}.
@@ -4042,7 +4042,7 @@ Parsing words are documented in \ref{parsing-words}.
 \vocabulary{prettyprint}
 \genericword{prettyprint*}{prettyprint* ( indent object -- indent )}
 }
-Prettyprints the given object. Unlike \texttt{prettyprint*}, this word does not emit a trailing newline, and the current indent level is given. This word is also generic, so you can add methods to have it print your own data types in a nice way.
+Prettyprints the given object. Unlike \texttt{prettyprint}, this word does not emit a trailing newline, and the current indent level is given. This word is also generic, so you can add methods to have it print your own data types in a nice way.
 
 The remaining words in this section are useful in the implementation of prettyprinter methods.
 \wordtable{
@@ -5234,7 +5234,7 @@ While most programming errors in Factor are only caught at runtime, the stack ef
 \textbf{[ [ tuple number tuple ] [ tuple fixnum object number ] ]}
 \end{alltt}
 
-The stack checker will report an error it it cannot infer the stack effect of a quotation. The ``recursive state'' dump is similar to a return stack, but it is not a real return stack, since only a code walk is taking place, not full evaluation. Understanding recursive state dumps is an art, much like understanding return stacks.
+The stack checker will report an error if it cannot infer the stack effect of a quotation. The ``recursive state'' dump is similar to a return stack, but it is not a real return stack, since only a code walk is taking place, not full evaluation. Understanding recursive state dumps is an art, much like understanding return stacks.
 
 \begin{alltt}
 \textbf{ok} [ 100 [ f f cons ] repeat ] infer .

library/alien/c-types.factor

@@ -26,23 +26,51 @@ SYMBOL: c-types
 : c-size ( name -- size )
     c-type [ "width" get ] bind ;
 
-: define-deref ( hash name vocab -- )
+: define-c-type ( quot name -- )
-    >r "*" swap append r> create
+    >r <c-type> swap extend r> c-types get set-hash ; inline
-    "getter" rot hash 0 swons define-compound ;
 
-: define-c-type ( quot name vocab -- )
+: <c-object> ( size -- byte-array )
-    >r >r <c-type> swap extend r> 2dup r> define-deref
-    c-types get set-hash ; inline
-
-: <c-object> ( type -- byte-array )
     cell / ceiling <byte-array> ;
 
-: <c-array> ( n type -- byte-array )
+: <c-array> ( n size -- byte-array )
     * cell / ceiling <byte-array> ;
 
-: define-out ( name -- )
+: define-pointer ( type -- )
+    "void*" c-type swap "*" append c-types get set-hash ;
+
+: define-deref ( name vocab -- )
+    >r dup "*" swap append r> create
+    "getter" rot c-type hash 0 swons define-compound ;
+
+: c-constructor ( name vocab -- )
+    #! Make a word <foo> where foo is the structure name that
+    #! allocates a Factor heap-local instance of this structure.
+    #! Used for C functions that expect you to pass in a struct.
+    dupd constructor-word
+    swap c-size [ <c-object> ] cons
+    define-compound ;
+
+: array-constructor ( name vocab -- )
+    #! Make a word <foo-array> ( n -- byte-array ).
+    >r dup "-array" append r> constructor-word
+    swap c-size [ <c-array> ] cons
+    define-compound ;
+
+: define-nth ( name vocab -- )
+    #! Make a word foo-nth ( n alien -- dsplaced-alien ).
+    >r dup "-nth" append r> create
+    swap dup c-size [ rot * ] cons "getter" rot c-type hash
+    append define-compound ;
+
+: define-set-nth ( name vocab -- )
+    #! Make a word foo-nth ( n alien -- dsplaced-alien ).
+    >r "set-" over "-nth" append3 r> create
+    swap dup c-size [ rot * ] cons "setter" rot c-type hash
+    append define-compound ;
+
+: define-out ( name vocab -- )
     #! Out parameter constructor for integral types.
-    dup "alien" constructor-word
+    dupd constructor-word
     swap c-type [
         [
             "width" get , \ <c-object> , \ tuck , 0 ,
@@ -50,8 +78,18 @@ SYMBOL: c-types
         ] make-list
     ] bind define-compound ;
 
+: init-c-type ( name vocab -- )
+    over define-pointer
+    2dup c-constructor
+    2dup array-constructor
+    define-nth ;
+
 : define-primitive-type ( quot name -- )
-    [ "alien" define-c-type ] keep define-out ;
+    [ define-c-type ] keep "alien"
+    2dup init-c-type
+    2dup define-deref
+    2dup define-set-nth
+    define-out ;
 
 global [ c-types nest drop ] bind
 

library/alien/structs.factor

@@ -28,41 +28,16 @@ math namespaces parser sequences strings words ;
 : define-member ( max type -- max )
     c-type [ "width" get ] bind max ;
 
-: bytes>cells cell / ceiling ;
-
-: struct-constructor ( width -- )
-    #! Make a word <foo> where foo is the structure name that
-    #! allocates a Factor heap-local instance of this structure.
-    #! Used for C functions that expect you to pass in a struct.
-    "struct-name" get "in" get constructor-word
-    swap bytes>cells [ <byte-array> ] cons
-    define-compound ;
-
-: array-constructor ( width -- )
-    #! Make a word <foo-array> ( n -- byte-array ).
-    "struct-name" get "-array" append "in" get constructor-word
-    swap bytes>cells [ * <byte-array> ] cons
-    define-compound ;
-
-: define-nth ( width -- )
-    #! Make a word foo-nth ( n alien -- dsplaced-alien ).
-    "struct-name" get "-nth" append create-in
-    swap [ swap >r * r> <displaced-alien> ] cons
-    define-compound ;
-
 : define-struct-type ( width -- )
     #! Define inline and pointer type for the struct. Pointer
     #! type is exactly like void*.
-    dup struct-constructor
-    dup array-constructor
-    dup define-nth
     [
         "width" set
         cell "align" set
         [ swap <displaced-alien> ] "getter" set
-    ] "struct-name" get "in" get define-c-type
+    ]
-    "void*" c-type "struct-name" get "*" append
+    "struct-name" get define-c-type
-    c-types get set-hash ;
+    "struct-name" get "in" get init-c-type ;
 
 : BEGIN-STRUCT: ( -- offset )
     scan "struct-name" set  0 ; parsing

library/compiler/compiler.factor

@@ -60,6 +60,7 @@ M: compound (compile) ( word -- )
 
 M: compound (uncrossref)
     dup f "infer-effect" set-word-prop
+    dup f "base-case" set-word-prop
     dup f "no-effect" set-word-prop
     decompile ;
 

library/inference/dataflow.factor

@@ -95,5 +95,8 @@ SYMBOL: current-node
     over node-out-d over set-node-out-d
     swap node-out-r swap set-node-out-r ;
 
+: node-effect ( node -- [[ d-in meta-d ]] )
+    dup node-in-d swap node-out-d cons ;
+
 ! Recursive state. An alist, mapping words to labels.
 SYMBOL: recursive-state

library/inference/inference.factor

@@ -70,8 +70,7 @@ SYMBOL: d-in
     0 <vector> d-in set
     recursive-state set
     dataflow-graph off
-    current-node off
+    current-node off ;
-    inferring-base-case off ;
 
 GENERIC: apply-object
 
@@ -128,6 +127,7 @@ M: object apply-object apply-literal ;
 
 : with-infer ( quot -- )
     [
+        inferring-base-case off
         f init-inference
         call
         check-active

library/inference/words.factor

@@ -52,23 +52,21 @@ hashtables parser prettyprint ;
         word-def infer-quot
     ] ifte ;
 
-: infer-compound ( word -- )
+: (infer-compound) ( word base-case -- effect )
     #! Infer a word's stack effect in a separate inferencer
     #! instance.
     [
-        [
+        inferring-base-case set
-            recursive-state get init-inference
+        recursive-state get init-inference
-            dup dup inline-block drop effect present-effect
+        dup inline-block drop
-            [ "infer-effect" set-word-prop ] keep
+        effect present-effect
-        ] with-scope consume/produce
+    ] with-scope [ consume/produce ] keep ;
+
+: infer-compound ( word -- )
+    [
+        dup f (infer-compound) "infer-effect" set-word-prop
     ] [
-        [
+        [ swap t "no-effect" set-word-prop rethrow ] when*
-            >r inferring-base-case get [
-                drop
-            ] [
-                t "no-effect" set-word-prop
-            ] ifte r> rethrow
-        ] when*
     ] catch ;
 
 GENERIC: (apply-word)
@@ -114,40 +112,43 @@ M: compound apply-word ( word -- )
         apply-default
     ] ifte ;
 
-: with-recursion ( quot -- )
+: (base-case) ( word label -- )
+    over "inline" word-prop [
+        over inline-block drop
+        [ #call-label ] [ #call ] ?ifte node,
+    ] [
+        drop dup t (infer-compound) "base-case" set-word-prop
+    ] ifte ;
+
+: base-case ( word label -- )
     [
         inferring-base-case on
-        call
+        (base-case)
     ] [
         inferring-base-case off
         rethrow
     ] catch ;
 
-: base-case ( word [ label quot ] -- )
-    [
-        >r [ inline-block ] keep r> car [
-            #call-label
-        ] [
-            #call
-        ] ?ifte [ copy-effect ] keep node,
-    ] with-recursion ;
-
 : no-base-case ( word -- )
     word-name " does not have a base case." append
     inference-error ;
 
-: recursive-word ( word [ label quot ] -- )
+: recursive-word ( word [[ label quot ]] -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive
     #! call is to a local block, emit a label call node.
     over "infer-effect" word-prop [
         nip consume/produce
     ] [
-        inferring-base-case get [
+        over "base-case" word-prop [
-            drop no-base-case
+            nip consume/produce
         ] [
-            base-case
+            inferring-base-case get [
-        ] ifte
+                drop no-base-case
+            ] [
+                car base-case
+            ] ifte
+        ] ifte*
     ] ifte* ;
 
 M: word apply-object ( word -- )

library/math/matrices.factor

@@ -18,6 +18,8 @@ vectors ;
 ! : v. ( v v -- x ) 0 swap [ * + ] 2each ;
 : v. ( v v -- x ) v** 0 swap [ + ] each ;
 
+: norm ( v -- a ) dup v. sqrt ;
+
 ! Matrices
 ! The major dimension is the number of elements per row.
 TUPLE: matrix rows cols sequence ;

library/sdl/sdl-gfx.factor

@@ -92,6 +92,21 @@ IN: sdl USING: alien ;
     [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
     alien-invoke ;
 
+: polygonColor ( surface vx vy n color -- )
+    "void" "sdl-gfx" "polygonColor"
+    [ "surface*" "short*" "short*" "int" "int" ]
+    alien-invoke ;
+
+: aapolygonColor ( surface vx vy n color -- )
+    "void" "sdl-gfx" "aapolygonColor"
+    [ "surface*" "short*" "short*" "int" "int" ]
+    alien-invoke ;
+
+: filledPolygonColor ( surface vx vy n color -- )
+    "void" "sdl-gfx" "filledPolygonColor"
+    [ "surface*" "short*" "short*" "int" "int" ]
+    alien-invoke ;
+
 : characterColor ( surface x y c color -- )
     "void" "sdl-gfx" "characterColor"
     [ "surface*" "short" "short" "char" "uint" ]

library/test/strings.factor

@@ -76,7 +76,7 @@ unit-test
 
 [ f ] [ [ 0 10 "hello" subseq ] [ not ] catch ] unit-test
 
-[ [ "hell" "o wo" "rld" ] ] [ 4 "hello world" groups ] unit-test
+[ [ "hell" "o wo" "rld" ] ] [ 4 "hello world" group ] unit-test
 
 [ 4 ] [
     0 "There are Four Upper Case characters"