\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 )}
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}.
\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{
\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 .
: 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 <c-type> swap extend r> c-types get set-hash ; inline
-: define-c-type ( quot name vocab -- )
- >r >r <c-type> swap extend r> 2dup r> define-deref
- c-types get set-hash ; inline
-
-: <c-object> ( type -- byte-array )
+: <c-object> ( size -- 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 ,
] 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
: 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
- 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
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 ;
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
0 <vector> d-in set
recursive-state set
dataflow-graph off
- current-node off
- inferring-base-case off ;
+ current-node off ;
GENERIC: apply-object
: with-infer ( quot -- )
[
+ inferring-base-case off
f init-inference
call
check-active
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)
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 -- )
! : 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 ;
[ "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" ]
[ 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"
projects / factor.git / commitdiff