diff --git a/doc/handbook.tex b/doc/handbook.tex index aced70bc37..cd7c86d785 100644 --- a/doc/handbook.tex +++ b/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 . diff --git a/library/alien/c-types.factor b/library/alien/c-types.factor index 075ff47a34..3d79d02ca3 100644 --- a/library/alien/c-types.factor +++ b/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 -- ) - >r "*" swap append r> create - "getter" rot hash 0 swons define-compound ; +: define-c-type ( quot name -- ) + >r swap extend r> c-types get set-hash ; inline -: define-c-type ( quot name vocab -- ) - >r >r swap extend r> 2dup r> define-deref - c-types get set-hash ; inline - -: ( type -- byte-array ) +: ( size -- byte-array ) cell / ceiling ; -: ( n type -- byte-array ) +: ( n size -- byte-array ) * cell / ceiling ; -: 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 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 [ ] cons + define-compound ; + +: array-constructor ( name vocab -- ) + #! Make a word ( n -- byte-array ). + >r dup "-array" append r> constructor-word + swap c-size [ ] 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 , \ , \ 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 diff --git a/library/alien/structs.factor b/library/alien/structs.factor index d44b2dfeb3..35311dd35c 100644 --- a/library/alien/structs.factor +++ b/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 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 [ ] cons - define-compound ; - -: array-constructor ( width -- ) - #! Make a word ( n -- byte-array ). - "struct-name" get "-array" append "in" get constructor-word - swap bytes>cells [ * ] 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> ] 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 ] "getter" set - ] "struct-name" get "in" get define-c-type - "void*" c-type "struct-name" get "*" append - c-types get set-hash ; + ] + "struct-name" get define-c-type + "struct-name" get "in" get init-c-type ; : BEGIN-STRUCT: ( -- offset ) scan "struct-name" set 0 ; parsing diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index b409c33fbc..2229c8e93d 100644 --- a/library/compiler/compiler.factor +++ b/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 ; diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index 4ba84a9a33..5eacf2c381 100644 --- a/library/inference/dataflow.factor +++ b/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 diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 5f9fed22c0..ecada0d78a 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -70,8 +70,7 @@ SYMBOL: d-in 0 d-in set recursive-state set dataflow-graph off - current-node off - inferring-base-case off ; + current-node 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 diff --git a/library/inference/words.factor b/library/inference/words.factor index 2613fdf4da..85e919102a 100644 --- a/library/inference/words.factor +++ b/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. [ - [ - recursive-state get init-inference - dup dup inline-block drop effect present-effect - [ "infer-effect" set-word-prop ] keep - ] with-scope consume/produce + inferring-base-case set + recursive-state get init-inference + dup inline-block drop + effect present-effect + ] with-scope [ consume/produce ] keep ; + +: infer-compound ( word -- ) + [ + dup f (infer-compound) "infer-effect" set-word-prop ] [ - [ - >r inferring-base-case get [ - drop - ] [ - t "no-effect" set-word-prop - ] ifte r> rethrow - ] when* + [ swap t "no-effect" set-word-prop 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 [ - drop no-base-case + over "base-case" word-prop [ + nip consume/produce ] [ - base-case - ] ifte + inferring-base-case get [ + drop no-base-case + ] [ + car base-case + ] ifte + ] ifte* ] ifte* ; M: word apply-object ( word -- ) diff --git a/library/math/matrices.factor b/library/math/matrices.factor index bd2b2cba8e..555676e4bb 100644 --- a/library/math/matrices.factor +++ b/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 ; diff --git a/library/sdl/sdl-gfx.factor b/library/sdl/sdl-gfx.factor index a6b8a78180..c20827da60 100644 --- a/library/sdl/sdl-gfx.factor +++ b/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" ] diff --git a/library/test/strings.factor b/library/test/strings.factor index 3a04d0a31d..d44eaef2ae 100644 --- a/library/test/strings.factor +++ b/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"