wrunt's alien-invoke shorthand, tons of bug fixes, cleanups and documentation updates

CHANGES.txt

@@ -1,48 +1,68 @@
 Factor 0.75:
 ------------
 
-New generational garbage collector. There are two command line switches
++ Runtime and core library
-for controlling it:
 
- +Yn   Size of 2 youngest generations, megabytes
+- New generational garbage collector. There are two command line
- +An   Size of tenured and semi-spaces, megabytes
+  switches for controlling it:
 
-OpenGL binding in contrib/gl/ (Alex Chapman).
+   +Yn   Size of 2 youngest generations, megabytes
+   +An   Size of tenured and semi-spaces, megabytes
 
-The compiler now does constant folding for certain words with literal
+- Generic words can now dispatch on stack elements other than the top
-operands. The compiler's peephole optimizer has been improved.
+  one; define your generic like this to dispatch on the second element:
 
-The alien interface now supports "float" and "double" types, and arrays
+   G: foo [ over ] [ type ] ;
-of C types.
 
-The SO_OOBINLINE socket flag is now set. In 0.74, sending out-of-band
+  Or this for the third:
-data could fill up the buffer and cause a denial-of-service attack.
 
-Generic words can now dispatch on stack elements other than the top one;
+   G: foo [ pick ] [ type ] ;
-define your generic like this to dispatch on the second element:
 
- G: foo [ over ] [ type ] ;
+  Note that GENERIC: foo is the same as
 
-Or this for the third:
+   G: foo [ dup ] [ type ] ;
 
- G: foo [ pick ] [ type ] ;
+- Sequence API refactoring, as described in
+  http://www.jroller.com/page/slava/20050518.
 
-Note that GENERIC: foo is the same as
+- The SO_OOBINLINE socket flag is now set. In 0.74, sending out-of-band
+  data could fill up the buffer and cause a denial-of-service attack.
 
- G: foo [ dup ] [ type ] ;
+- You can now set timeouts for I/O operations with the set-timeout
+  generic word. The HTTP server sets a timeout of 60 seconds for client
+  requests.
 
-Sequence API refactoring, as described in
++ Compiler
-http://www.jroller.com/page/slava/20050518.
 
-HTTP server now supports virtual hosting.
+- The compiler now does constant folding for certain words with literal
+  operands. The compiler's peephole optimizer has been improved.
 
-You can now set timeouts for I/O operations with the set-timeout generic
+- The alien interface now supports "float" and "double" types, and
-word. The HTTP server sets a timeout of 60 seconds for client requests.
+  arrays of C types.
 
-The Factor plugin now supports connecting to Factor instances on
+- New short-hand syntax for defining words that alien-invoke
-arbitrary host and port names. This allows interactive development on
+  (Alex Chapman).
-one machine while testing on another. A new command was added to
+  
-evaluate the word definition at the caret in the listener.
+  LIBRARY: gl
+  FUNCTION: void glTranslatef ( GLfloat x, GLfloat y, GLfloat z ) ;
+
+  should be the same as doing:
+
+  : glTranslatef ( x y z -- )
+      "void" "gl" "glTranslatef"
+      [ "GLfloat" "GLfloat" "GLfloat" ] alien-invoke ;
+  \ glTranslatef compile
+
++ Framework
+
+- OpenGL binding in contrib/gl/ (Alex Chapman).
+
+- HTTP server now supports virtual hosting.
+
+- The Factor plugin now supports connecting to Factor instances on
+  arbitrary host and port names. This allows interactive development on
+  one machine while testing on another. A new command was added to
+  evaluate the word definition at the caret in the listener.
 
 Factor 0.74:
 ------------

TODO.FACTOR.txt

@@ -9,26 +9,14 @@
 <erg> if write returns -1  and errno == EINTR then it's not a real error, you can try again
 - single-stepper and variable access: wrong namespace?
 - investigate if COPYING_GEN needs a fix
-- faster layout
 - http keep alive, and range get
 - sleep word
 - fix i/o on generic x86/ppc unix
-- alien primitives need a more general input type
-- 2map slow with lists
-- nappend: instead of using push, enlarge the sequence with set-length
-  then add set the elements with set-nth
-- faster sequence operations
-- generic some? all? memq? fiber?
-- index and index* are very slow with lists
 - code walker & exceptions
 - if two tasks write to a unix stream, the buffer can overflow
 - rename prettyprint* to pprint, prettyprint to pp
 - reader syntax for arrays, byte arrays, displaced aliens
-- dipping seq-2nmap, seq-2each
-- array sort
 - images saved from plugin do not work
-- generic skip
-- inference needs to be more robust with heavily recursive code
 - investigate orphans
 
 + plugin:
@@ -40,6 +28,7 @@
 
 + ui:
 
+- faster layout
 - tiled window manager
 - faster repaint
 - console with presentations
@@ -53,6 +42,7 @@
 
 + ffi:
 
+- alien primitives need a more general input type
 - smarter out parameter handling
 - clarify powerpc passing of value struct parameters
 - box/unbox_signed/unsigned_8
@@ -64,6 +54,7 @@
 
 + compiler:
 
+- inference needs to be more robust with heavily recursive code
 - powerpc: float ffi parameters
 - fix fixnum<< and /i overflow on PowerPC
 - simplifier:
@@ -84,6 +75,15 @@
 
 + sequences
 
+- generic skip
+- dipping seq-2nmap, seq-2each
+- array sort
+- 2map slow with lists
+- nappend: instead of using push, enlarge the sequence with set-length
+  then add set the elements with set-nth
+- faster sequence operations
+- generic some? all? memq? fiber?
+- index and index* are very slow with lists
 - specialized arrays
 - list map, subset: not tail recursive
 - phase out sbuf-append

contrib/gl/gl-internals.factor

@@ -1,49 +0,0 @@
-IN: gl-internals
-USING: alien kernel sequences stdio math test parser namespaces lists strings words compiler ;
-
-! usage of 'LIBRARY:' and 'FUNCTION:' :
-!
-!     LIBRARY: gl
-!     FUNCTION: void glTranslatef ( GLfloat x, GLfloat y, GLfloat z ) ;
-!
-! should be the same as doing:
-!
-!     : glTranslatef ( x y z -- )
-!         "void" "gl" "glTranslatef" [ "GLfloat" "GLfloat" "GLfloat" ] alien-invoke ;
-!     \ glTranslatef compile
-!
-! other forms:
-!
-!    FUNCTION: void glEnd ( ) ; -> : glEnd ( -- ) "void" "gl" "glEnd" [ ] alien-invoke ; 
-!
-! TODO: show returns in the stack effect
-
-: LIBRARY: scan "c-library" set ; parsing
-
-: compile-function-call ( type lib func types stack-effect -- )
-    >r over create-in >r 
-    [ alien-invoke ] cons cons cons cons r> swap define-compound
-    word r> "stack-effect" set-word-prop
-    word compile ;
-
-: unpair ( list -- list1 list2 )
-    [ uncons uncons unpair rot swons >r cons r> ]
-    [ f f ] ifte* ;
-
-: remove-trailing-char ( str ch -- str )
-    >r dup length 1 - swap 2dup nth r> =
-      [ head ] 
-      [ nip ] ifte ;
-
-: parse-stack-effect ( lst -- str )
-    unpair reverse "--" swons reverse
-    [ CHAR: , remove-trailing-char " " append ] map " " swons concat ;
-
-: (function) ( type lib func function-args -- )
-    unswons drop reverse unswons drop reverse
-    parse-stack-effect compile-function-call ;
-
-: FUNCTION:
-    scan "c-library" get scan string-mode on
-      [ string-mode off (function) ] [ ] ; parsing
-

contrib/gl/load.factor

@@ -9,5 +9,8 @@ win32? [
     "glu" "libGLU.so" "cdecl" add-library
 ] ifte
 
-[ "gl-internals.factor" "sdl-gl.factor" "gl.factor" "glu.factor" ]
+[ "sdl-gl.factor" "gl.factor" "glu.factor" ]
 [ "contrib/gl/" swap append run-file ] each
+
+"gl" words [ try-compile ] each
+"glu" words [ try-compile ] each

doc/compiler.tex

@@ -66,8 +66,128 @@
 \maketitle
 \tableofcontents{}
 
+\section{Stack effect inference}
+
+The stack effect inference tool checks correctness of code before it is run.
+A \emph{stack effect} is a list of input classes and a list of output classes corresponding to
+the effect a quotation has on the stack when called. For example, the stack effect of \verb|[ dup * ]| is \verb|[ [ integer ] [ integer ] ]|. The stack checker is used by passing a quotation to the \texttt{infer} word. It uses a sophisticated algorithm to infer stack effects of recursive words, combinators, and other tricky constructions, however, it cannot infer the stack effect of all words. In particular, anything using continuations, such as \texttt{catch} and I/O, will stump the stack checker.
+
+\subsection{Usage}
+
+The main entry point of the stack checker is a single word.
+
+\wordtable{
+\vocabulary{inference}
+\ordinaryword{infer}{infer ( quot -- effect )}
+}
+
+Takes a quotation and attempts to infer its stack effect. An exception is thrown if the stack effect cannot be inferred.
+
+You can combine unit testing with stack effect inference by writing unit tests that check stack effects of words. In fact, this can be automated with the \texttt{infer>test.} word; it takes a quotation on the stack, and prints a code snippet that tests the stack effect of the quotation:
+
+\begin{alltt}
+\textbf{ok} [ draw-shape ] infer>test.
+\textbf{[ [ [ object ] [  ] ] ]
+[ [ draw-shape ] infer ]
+unit-test}
+\end{alltt}
+
+You can then copy and paste this snippet into a test script, and run the test script after
+making changes to the word to ensure its stack effect signature has not changed.
+
+\subsection{The algorithm}
+
+The stack effect inference algorithm mirrors the interpreter algorithm. A ``meta data stack'' holds two types of entries; computed values, whose type is known but literal value will only be known at runtime, and literals, whose value is known statically. When a literal value is encountered, it is simply placed on the meta data stack. When a word is encountered, one of several actions are taken, depending on the type of the word:
+
+\begin{itemize}
+\item If the word has special stack effect inference behavior, this behavior is invoked. Shuffle words and various primitives fall into this category.
+\item If the word's stack effect is already known, then the inputs are removed from the meta data stack, and output values are added. If the meta data stack contains insufficient values, more values are added, and the newly added values are placed in the input list. Since inference begins with an empty stack, the input list contains all required input values when inference is complete.
+\item If the word is marked to be inlined, stack effect inference recurses into the word definition and uses the same meta data stack. See \ref{declarations}.
+\item Otherwise, the word's stack effect is inferred in a fresh inferencer instance, and the stack effect is cached. The fresh inferencer is used rather than the current one, so that type information and literals on the current meta data stack do not affect the subsequently-cached stack effect.
+\end{itemize}
+
+The following two examples demonstrate some simple cases:
+\begin{alltt}
+\textbf{ok} [ 1 2 3 ] infer .
+\textbf{[ [ ] [ fixnum fixnum fixnum ] ]}
+\textbf{ok} [ "hi" swap ] infer .
+\textbf{[ [ object ] [ string object ] ]}
+\end{alltt}
+
+\subsubsection{Combinators}
+
+A simple combinator such as \verb|keep| does not by itself have a stack effect, since \verb|call| takes an arbitrary quotation from the stack, which itself may have an arbitrary stack effect.
+\begin{verbatim}
+IN: kernel
+: keep ( x quot -- x | quot: x -- )
+    over >r call r> ; inline
+\end{verbatim}
+On the other hand, the stack effect of word that passes a literal quotation to \verb|keep| can be inferred. The quotation is a literal on the meta data stack, and since \verb|keep| is marked \verb|inline|, the special inference behavior of \verb|call| receives this quotation.
+\begin{alltt}
+\textbf{ok} [ [ dup * ] keep ] infer .
+\textbf{[ [ number ] [ number number ] ]}
+\end{alltt}
+Note that if \verb|call| is applied to a computed value, for example, a quotation taken from a variable, or a quotation that is constructed immediately before the \verb|call|, the stack effect inferencer will raise an error.
+\begin{alltt}
+\textbf{ok} [ frog get call ] infer .
+\textbf{! Inference error: A literal value was expected where a
+computed value was found: \#<computed @ 716167923>
+! Recursive state:
+:s :r :n :c show stacks at time of error.
+:get ( var -- value ) inspects the error namestack.}
+\end{alltt}
+Another word with special inference behavior is \verb|execute|. It is used much more rarely than \verb|call|, but does pretty much the same thing, except it takes a word as input rather than a string.
+
+\subsubsection{Conditionals}
+
+Simpler than a stack effect is the concept of a stack height difference. This is simply the input value count subtracted from the output value count. A conditional's stack effect can be inferred if each branch has the same stack height difference; in this case, we say that the conditional is \emph{balanced}, and the total stack effect is computed by performing a unification of types across each branch.
+
+The following two examples exhibit balanced conditionals:
+\begin{verbatim}
+[ 1 ] [ dup ] ifte
+dup cons? [ unit ] when cons
+\end{verbatim}
+The following example is not balanced and raises an error when we attempt to infer its stack effect:
+\begin{alltt}
+\textbf{ok} [ [ dup ] [ drop ] ifte ] infer .
+\textbf{! Inference error: Unbalanced branches
+! Recursive state:
+:s :r :n :c show stacks at time of error.
+:get ( var -- value ) inspects the error namestack.}
+\end{alltt}
+
+\subsubsection{Recursive words}
+
+Recursive words all have the same general form; there is a conditional, and one branch of the conditional is the \emph{base case} terminating the recursion, and the other branch is the \emph{inductive case}, which reduces the problem and recurses on the reduced problem. A key observation one must make is that in a well-formed recursion, the recursive call in the inductive case eventually results in the base case being called, so we can take the stack effect of the recursive call to be the stack effect of the base case.
+
+Consider the following implementation of a word that measures the length of a list:
+\begin{verbatim}
+: length ( list -- n )
+    [ cdr length 1 + ] [ 0 ] ifte* ;
+\end{verbatim}
+The stack effect can be inferred without difficulty:
+\begin{alltt}
+\textbf{ok} [ length ] infer .
+\textbf{[ [ object ] [ integer ] ]}
+\end{alltt}
+The base case is taken if the top of the stack is \verb|f|, and the base case has a stack effect \verb|[ [ object ] [ fixnum ] ]|.
+
+On the other hand if the top of the stack is something else, the inductive case is taken. The inductive case makes a recursive call to \verb|length|, and once we substitute the stack effect of the base case into this call point, we can infer that the stack effect of the recursive case is \verb|[ [ object ] [ integer ] ]|.
+
+If both branches contain a recursive call, the stack effect inferencer gives up.
+\begin{alltt}
+\textbf{ok} : fie [ fie ] [ fie ] ifte ;
+\textbf{ok} [ fie ] infer .
+\textbf{! Inference error: fie does not have a base case
+! Recursive state:
+:s :r :n :c show stacks at time of error.
+:get ( var -- value ) inspects the error namestack.}
+\end{alltt}
+
 \section{The compiler}
 
+\subsection{Basic usage}
+
 The compiler can provide a substantial speed boost for words whose stack effect can be inferred. Words without a known stack effect cannot be compiled, and must be run in the interpreter. The compiler generates native code, and so far, x86 and PowerPC backends have been developed.
 
 To compile a single word, call \texttt{compile}:
@@ -89,6 +209,61 @@ The compiler has two limitations you must be aware of. First, if an exception is
 
 The compiler consists of multiple stages -- first, a dataflow graph is inferred, then various optimizations are done on this graph, then it is transformed into a linear representation, further optimizations are done, and finally, machine code is generated from the linear representation.
 
+\subsection{Stack effect inference}
+
+While most programming errors in Factor are only caught at runtime, the stack effect checker can be useful for checking correctness of code before it is run. It can also help narrow down problems with stack shuffling. The stack checker is used by passing a quotation to the \texttt{infer} word. It uses a sophisticated algorithm to infer stack effects of recursive words, combinators, and other tricky constructions, however, it cannot infer the stack effect of all words. In particular, anything using continuations, such as \texttt{catch} and I/O, will stump the stack checker. Despite this fault, it is still a useful tool.
+
+\begin{alltt}
+\textbf{ok} [ pile-fill * >fixnum over pref-size dup y
+\texttt{...} [ + ] change ] infer .
+\textbf{[ [ tuple number tuple ] [ tuple fixnum object number ] ]}
+\end{alltt}
+
+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 .
+\textbf{! Inference error: Unbalanced branches
+! Recursive state:
+! [ (repeat) G:54044 pick pick >= [ 3drop ]
+    [ [ swap >r call 1 + r> ] keep (repeat) ] ifte ]
+! [ repeat G:54042 0 -rot (repeat) ]
+:s :r :n :c show stacks at time of error.
+:get ( var -- value ) inspects the error namestack.}
+\end{alltt}
+
+One reason stack inference might fail is if the quotation contains unbalanced branches, as above. For the inference to work, both branches of a conditional must exit with the same stack height.
+
+Another situation when it fails is if your code calls quotations that are not statically known. This can happen if the word in question uses continuations, or if it pulls a quotation from a variable and calls it. This can also happen if you wrote your own combinator, but forgot to mark it as \texttt{inline}. For example, the following will fail:
+
+\begin{alltt}
+\textbf{ok} : dip swap >r call r> ;
+\textbf{ok} [ [ + ] dip * ] infer .
+! Inference error: A literal value was expected where a
+computed value was found: \#<computed @ 679711507>
+...
+\end{alltt}
+
+However, defining \texttt{dip} to be inlined will work:
+
+\begin{alltt}
+\textbf{ok} : dip swap >r call r> ; inline
+\textbf{ok} [ [ + ] dip * ] infer .
+\textbf{[ [ number number number ] [ number ] ]}
+\end{alltt}
+
+You can combine unit testing with stack effect inference by writing unit tests that check stack effects of words. In fact, this can be automated with the \texttt{infer>test.} word; it takes a quotation on the stack, and prints a code snippet that tests the stack effect of the quotation:
+
+\begin{alltt}
+\textbf{ok} [ draw-shape ] infer>test.
+\textbf{[ [ [ object ] [  ] ] ]
+[ [ draw-shape ] infer ]
+unit-test}
+\end{alltt}
+
+You can then copy and paste this snippet into a test script, and run the test script after
+making changes to the word to ensure its stack effect signature has not changed.
+
 \subsection{Linear intermediate representation}
 
 The linear IR is the second of the two intermediate

library/alien/aliens.factor

@@ -5,10 +5,10 @@ USING: hashtables kernel lists math namespaces parser stdio ;
 
 DEFER: dll?
 BUILTIN: dll 15 dll? [ 1 "dll-path" f ] ;
+
 DEFER: alien?
 BUILTIN: alien 16 alien? ;
-DEFER: byte-array?
+
-BUILTIN: byte-array 19 byte-array? ;
 DEFER: displaced-alien?
 BUILTIN: displaced-alien 20 displaced-alien? ;
 
@@ -31,10 +31,6 @@ M: alien = ( obj obj -- ? )
         2drop f
     ] ifte ;
 
-: ALIEN: scan-word <alien> swons ; parsing
-
-: DLL" skip-blank parse-string dlopen swons ; parsing
-
 : library ( name -- object )
     dup [ "libraries" get hash ] when ;
 
@@ -58,3 +54,19 @@ M: alien = ( obj obj -- ? )
 
 : library-abi ( library -- abi )
     library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
+
+! This will go elsewhere soon
+: byte-bit ( n alien -- byte bit )
+    over -3 shift alien-unsigned-1 swap 7 bitand ;
+
+: bit-nth ( n alien -- ? )
+    byte-bit 1 swap shift bitand 0 > ;
+
+: set-bit ( ? byte bit -- byte )
+    1 swap shift rot [ bitor ] [ bitnot bitand ] ifte ;
+
+: set-bit-nth ( ? n alien -- )
+    [ byte-bit set-bit ] 2keep
+    swap -3 shift set-alien-unsigned-1 ;
+
+: ALIEN: scan-word <alien> swons ; parsing

library/alien/c-types.factor

@@ -2,8 +2,8 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
 USING: assembler compiler compiler-backend errors generic
-hashtables kernel lists math namespaces parser sequences strings
+hashtables kernel kernel-internals lists math namespaces parser
-words ;
+sequences strings words ;
 
 : <c-type> ( -- type )
     <namespace> [
@@ -91,6 +91,11 @@ SYMBOL: c-types
     2dup define-set-nth
     define-out ;
 
+: (typedef) c-types get [ >r get r> set ] bind ;
+
+: typedef ( old new -- )
+    over "*" append over "*" append (typedef) (typedef) ;
+
 global [ c-types nest drop ] bind
 
 [
@@ -225,19 +230,6 @@ global [ c-types nest drop ] bind
     \ %unbox-double "unbox-op" set
 ] "double" define-primitive-type
 
-: (alias-c-type)
-    c-types get [ >r get r> set ] bind ;
-
-: alias-c-type ( old new -- )
-    over "*" append over "*" append
-    (alias-c-type) (alias-c-type) ;
-
 ! FIXME for 64-bit platforms
-"int" "long" alias-c-type
+"int" "long" typedef
-"uint" "ulong" alias-c-type
+"uint" "ulong" typedef
-
-: ALIAS:
-    #! Followed by old then new. This is a parsing word so that
-    #! we can define aliased types, and then a C struct, in the
-    #! same source file.
-    scan scan alias-c-type ; parsing

library/alien/malloc.factor

@@ -1,19 +1,12 @@
 ! Copyright (C) 2004, 2005 Mackenzie Straight.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: kernel-internals
-USING: alien errors kernel math ;
+USING: alien errors kernel ;
 
-: malloc ( size -- address )
+LIBRARY: libc
-    "ulong" "libc" "malloc" [ "ulong" ] alien-invoke ;
+FUNCTION: ulong malloc ( ulong size ) ;
+FUNCTION: ulong free ( ulong ptr ) ;
+FUNCTION: ulong realloc ( ulong ptr, ulong size ) ;
+FUNCTION: void memcpy ( ulong dst, ulong src, ulong size ) ;
 
-: free ( address -- )
+: check-ptr dup 0 = [ "Out of memory" throw ] when ;
-    "void" "libc" "free" [ "ulong" ] alien-invoke ;
-
-: realloc ( address size -- address )
-    "ulong" "libc" "realloc" [ "ulong" "ulong" ] alien-invoke ;
-
-: memcpy ( dst src size -- )
-    "void" "libc" "memcpy" [ "ulong" "ulong" "ulong" ] alien-invoke ;
-
-: check-ptr ( ptr -- ptr )
-    dup 0 number= [ "Out of memory" throw ] when ;

library/alien/syntax.factor

@@ -0,0 +1,46 @@
+! Copyright (C) 2005 Alex Chapman.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: alien
+USING: compiler kernel lists namespaces parser sequences words ;
+
+! usage of 'LIBRARY:' and 'FUNCTION:' :
+!
+!     LIBRARY: gl
+!     FUNCTION: void glTranslatef ( GLfloat x, GLfloat y, GLfloat z ) ;
+!
+! should be the same as doing:
+!
+!     : glTranslatef ( x y z -- )
+!         "void" "gl" "glTranslatef" [ "GLfloat" "GLfloat" "GLfloat" ] alien-invoke ;
+!     \ glTranslatef compile
+!
+! other forms:
+!
+!    FUNCTION: void glEnd ( ) ; -> : glEnd ( -- ) "void" "gl" "glEnd" [ ] alien-invoke ; 
+!
+! TODO: show returns in the stack effect
+
+: LIBRARY: scan "c-library" set ; parsing
+
+: parse-arglist ( lst -- types stack effect )
+    unpair [
+        " " % [ "," ?tail drop % " " % ] each "-- " %
+    ] make-string ;
+
+: (define-c-word) ( type lib func types stack-effect -- )
+    >r over create-in >r 
+    [ alien-invoke ] cons cons cons cons r> swap define-compound
+    word r> "stack-effect" set-word-prop ;
+
+: define-c-word ( type lib func function-args -- )
+    [ "()" subseq? not ] subset parse-arglist (define-c-word) ;
+
+: FUNCTION:
+    scan "c-library" get scan string-mode on
+    [ string-mode off define-c-word ] [ ] ; parsing
+
+: TYPEDEF:
+    #! TYPEDEF: old new
+    scan scan typedef ; parsing
+
+: DLL" skip-blank parse-string dlopen swons ; parsing

library/bootstrap/boot-stage1.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: image
-USING: lists parser namespaces stdio kernel vectors words
+USING: generic hashtables kernel lists math memory namespaces
-hashtables sequences ;
+parser prettyprint sequences stdio vectors words ;
 
 "Bootstrap stage 1..." print
 
@@ -14,16 +14,21 @@ hashtables sequences ;
 [
     [
         "/version.factor"
+
         "/library/stack.factor"
         "/library/combinators.factor"
+
         "/library/collections/sequences.factor"
         "/library/collections/arrays.factor"
+
         "/library/kernel.factor"
+
         "/library/math/math.factor"
         "/library/math/integer.factor"
         "/library/math/ratio.factor"
         "/library/math/float.factor"
         "/library/math/complex.factor"
+
         "/library/collections/cons.factor"
         "/library/collections/assoc.factor"
         "/library/collections/lists.factor"
@@ -36,16 +41,21 @@ hashtables sequences ;
         "/library/collections/vectors-epilogue.factor"
         "/library/collections/slicing.factor"
         "/library/collections/strings-epilogue.factor"
+
         "/library/math/matrices.factor"
+
         "/library/words.factor"
         "/library/vocabularies.factor"
         "/library/errors.factor"
         "/library/continuations.factor"
+
         "/library/io/stream.factor"
         "/library/io/stdio.factor"
         "/library/io/c-streams.factor"
         "/library/io/files.factor"
+
         "/library/threads.factor"
+
         "/library/syntax/parse-numbers.factor"
         "/library/syntax/parse-words.factor"
         "/library/syntax/parse-errors.factor"
@@ -54,29 +64,74 @@ hashtables sequences ;
         "/library/syntax/generic.factor"
         "/library/syntax/math.factor"
         "/library/syntax/parse-syntax.factor"
+        
         "/library/alien/aliens.factor"
-        "/library/cli.factor"
         
         "/library/syntax/unparser.factor"
         "/library/syntax/prettyprint.factor"
-        
+
-        "/library/tools/debugger.factor"
         "/library/tools/gensym.factor"
         "/library/tools/interpreter.factor"
+        "/library/tools/debugger.factor"
+        "/library/tools/memory.factor"
+
+        "/library/inference/conditions.factor"
+        "/library/inference/dataflow.factor"
+        "/library/inference/values.factor"
+        "/library/inference/inference.factor"
+        "/library/inference/branches.factor"
+        "/library/inference/words.factor"
+        "/library/inference/stack.factor"
+        "/library/inference/partial-eval.factor"
+        
+        "/library/compiler/assembler.factor"
+        "/library/compiler/relocate.factor"
+        "/library/compiler/xt.factor"
+        "/library/compiler/optimizer.factor"
+        "/library/compiler/vops.factor"
+        "/library/compiler/linearizer.factor"
+        "/library/compiler/intrinsics.factor"
+        "/library/compiler/simplifier.factor"
+        "/library/compiler/generator.factor"
+        "/library/compiler/compiler.factor"
+
+        "/library/alien/c-types.factor"
+        "/library/alien/enums.factor"
+        "/library/alien/structs.factor"
+        "/library/alien/compiler.factor"
+        "/library/alien/syntax.factor"
+
+        "/library/cli.factor"
+        
         "/library/tools/memory.factor"
     ] pull-in
+] make-list
 
-    "delegate" [ "generic" ] search
+"delegate" [ "generic" ] search
-    "object" [ "generic" ] search
+"object" [ "generic" ] search
-    "typemap" [ "generic" ] search
+"typemap" [ "generic" ] search
-    "builtins" [ "generic" ] search
+"builtins" [ "generic" ] search
 
-    vocabularies get [ "generic" off ] bind
+vocabularies get [ "generic" off ] bind
 
-    reveal
+reveal
-    reveal
+reveal
-    reveal
+reveal
-    reveal
+reveal
+
+[
+    [
+        boot
+        
+        "Rehashing hash tables..." print
+
+        [ hashtable? ] instances
+        [ dup hash-size 1 max swap set-bucket-count ] each
+    
+        "Building cross-reference database..." print
+        
+        recrossref
+    ] %
 
     [
         "/library/generic/generic.factor"
@@ -91,9 +146,23 @@ hashtables sequences ;
     
         "/library/bootstrap/init.factor"
     ] pull-in
+    
+    ! uncomment this if type numbers change. it takes a long time...
+
+    [
+        "Building generics..." print
+    
+        all-words [ generic? ] subset [ make-generic ] each
+    ] %
 ] make-list
 
-"boot" [ "kernel" ] search swons
+swap
+
+[
+    "/library/bootstrap/boot-stage2.factor" run-resource
+]
+
+append3
 
 vocabularies get [
     "!syntax" get "syntax" set

library/bootstrap/boot-stage2.factor

@@ -4,17 +4,6 @@ USING: alien assembler command-line compiler generic hashtables
 kernel lists memory namespaces parser sequences stdio unparser
 words ;
 
-"Making the image happy..." print
-
-! Rehash hashtables
-[ hashtable? ] instances
-[ dup hash-size swap set-bucket-count ] each
-
-! Update generics
-[ dup generic? [ make-generic ] [ drop ] ifte ] each-word
-
-recrossref
-
 : pull-in ( ? list -- )
     swap [
         [
@@ -24,36 +13,7 @@ recrossref
         drop
     ] ifte ;
 
-"Loading compiler and friends..." print
+"Loading compiler backend..." print
-t [
-    "/library/inference/conditions.factor"
-    "/library/inference/dataflow.factor"
-    "/library/inference/values.factor"
-    "/library/inference/inference.factor"
-    "/library/inference/branches.factor"
-    "/library/inference/words.factor"
-    "/library/inference/stack.factor"
-    "/library/inference/partial-eval.factor"
-
-    "/library/compiler/assembler.factor"
-    "/library/compiler/relocate.factor"
-    "/library/compiler/xt.factor"
-    "/library/compiler/optimizer.factor"
-    "/library/compiler/vops.factor"
-    "/library/compiler/linearizer.factor"
-    "/library/compiler/intrinsics.factor"
-    "/library/compiler/simplifier.factor"
-    "/library/compiler/generator.factor"
-    "/library/compiler/compiler.factor"
-        
-    "/library/alien/c-types.factor"
-    "/library/alien/enums.factor"
-    "/library/alien/structs.factor"
-    "/library/alien/compiler.factor"
-    "/library/alien/malloc.factor"
-
-    "/library/io/buffer.factor"
-] pull-in
 
 cpu "x86" = [
     "/library/compiler/x86/assembler.factor"

library/bootstrap/boot-stage3.factor

@@ -43,7 +43,11 @@ compile? [
 
 "Loading more library code..." print
 
+
 t [
+    "/library/alien/malloc.factor"
+    "/library/io/buffer.factor"
+
     "/library/math/constants.factor"
     "/library/math/pow.factor"
     "/library/math/more-matrices.factor"

library/bootstrap/image.factor

@@ -46,6 +46,7 @@ SYMBOL: boot-quot
 : vector-type    11 ; inline
 : string-type    12 ; inline
 : word-type      17 ; inline
+: tuple-type     18 ; inline
 
 : immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
 : >header ( id -- tagged ) object-tag immediate ;
@@ -228,16 +229,19 @@ M: string ' ( string -- pointer )
 
 ( Arrays and vectors )
 
-: emit-array ( list -- pointer )
+: emit-array ( list type -- pointer )
-    [ ' ] map
+    >r [ ' ] map r>
     object-tag here-as >r
-    array-type >header emit
+    >header emit
     dup length emit-fixnum
     ( elements -- ) [ emit ] each
     align-here r> ;
 
+M: tuple ' ( tuple -- pointer )
+    <mirror> >list tuple-type emit-array ;
+
 : emit-vector ( vector -- pointer )
-    dup >list emit-array swap length
+    dup >list array-type emit-array swap length
     object-tag here-as >r
     vector-type >header emit
     emit-fixnum ( length )
@@ -248,7 +252,8 @@ M: vector ' ( vector -- pointer )
     emit-vector ;
 
 : emit-hashtable ( hash -- pointer )
-    dup buckets>list emit-array swap hash>alist length
+    dup buckets>list array-type emit-array
+    swap hash>alist length
     object-tag here-as >r
     hashtable-type >header emit
     emit-fixnum ( length )
@@ -265,9 +270,7 @@ M: hashtable ' ( hashtable -- pointer )
 
 : vocabulary, ( hash -- )
     dup hashtable? [
-        [
+        [ cdr dup word? [ word, ] [ drop ] ifte ] hash-each
-            cdr dup word? [ word, ] [ drop ] ifte
-        ] hash-each
     ] [
         drop
     ] ifte ;
@@ -282,6 +285,7 @@ M: hashtable ' ( hashtable -- pointer )
         vocabularies set
         typemap [ ] change
         builtins [ ] change
+        crossref [ ] change
     ] extend '
     global-offset fixup ;
 

library/bootstrap/init.factor

@@ -10,7 +10,3 @@ USING: io-internals namespaces parser stdio threads words ;
     init-io
     "HOME" os-env [ "." ] unless* "~" set
     init-search-path ;
-
-"Good morning!" print
-flush
-"/library/bootstrap/boot-stage2.factor" run-resource

library/bootstrap/primitives.factor

@@ -41,6 +41,7 @@ vocabularies get [
     [ "execute" "words"                       [ [ word ] [ ] ] ]
     [ "call" "kernel"                         [ [ general-list ] [ ] ] ]
     [ "ifte" "kernel"                         [ [ object general-list general-list ] [ ] ] ]
+    [ "dispatch" "kernel-internals"           [ [ fixnum vector ] [ ] ] ]
     [ "cons" "lists"                          [ [ object object ] [ cons ] ] ]
     [ "<vector>" "vectors"                    [ [ integer ] [ vector ] ] ]
     [ "string-compare" "strings"              [ [ string string ] [ integer ] ] ]
@@ -152,7 +153,7 @@ vocabularies get [
     [ "dlsym" "alien"                         [ [ string object ] [ integer ] ] ]
     [ "dlclose" "alien"                       [ [ dll ] [ ] ] ]
     [ "<alien>" "alien"                       [ [ integer ] [ alien ] ] ]
-    [ "<byte-array>" "alien"                  [ [ integer ] [ byte-array ] ] ]
+    [ "<byte-array>" "kernel-internals"       [ [ integer ] [ byte-array ] ] ]
     [ "<displaced-alien>" "alien"             [ [ integer object ] [ displaced-alien ] ] ]
     [ "alien-signed-cell" "alien"             [ [ alien integer ] [ integer ] ] ]
     [ "set-alien-signed-cell" "alien"         [ [ integer alien integer ] [ ] ] ]

library/collections/arrays.factor

@@ -23,7 +23,6 @@ BUILTIN: array 8 array? ;
 : array-capacity ( a -- n ) 1 slot ; inline
 : array-nth ( n a -- obj ) swap 2 fixnum+ slot ; inline
 : set-array-nth ( obj n a -- ) swap 2 fixnum+ set-slot ; inline
-: dispatch ( n vtable -- ) 2 slot array-nth call ;
 
 M: array length array-capacity ;
 M: array nth array-nth ;
@@ -34,3 +33,9 @@ M: array resize resize-array ;
     dup array-capacity [
         3dup swap array-nth pick rot set-array-nth
     ] repeat 2drop ;
+
+DEFER: byte-array?
+BUILTIN: byte-array 19 byte-array? ;
+
+M: byte-array length array-capacity ;
+M: byte-array resize resize-array ;

library/collections/lists.factor

@@ -146,6 +146,9 @@ M: general-list nth ( n list -- element )
     #! Is every element of list1 in list2?
     swap [ swap contains? ] all-with? ;
 
+: unpair ( list -- list1 list2 )
+    [ uncons uncons unpair rot swons >r cons r> ] [ f f ] ifte* ;
+
 : <queue> ( -- queue )
     #! Make a new functional queue.
     [[ [ ] [ ] ]] ;

library/collections/sequences-epilogue.factor

@@ -11,7 +11,8 @@ vectors ;
 UNION: sequence array string sbuf vector ;
 
 M: object thaw clone ;
-M: object freeze drop ;
+
+M: object like drop ;
 
 M: object empty? ( seq -- ? ) length 0 = ;
 
@@ -52,7 +53,7 @@ M: sequence tree-each swap [ swap tree-each ] each-with ;
     0 swap (nmap) ; inline
 
 : immutable ( seq quot -- seq | quot: seq -- )
-    swap [ thaw ] keep >r dup >r swap call r> r> freeze ; inline
+    swap [ thaw ] keep >r dup >r swap call r> r> like ; inline
 
 M: object map ( seq quot -- seq | quot: elt -- elt )
     swap [ swap nmap ] immutable ;

library/collections/sequences.factor

@@ -18,7 +18,6 @@ GENERIC: nth ( n sequence -- obj )
 GENERIC: set-nth ( value n sequence -- obj )
 GENERIC: thaw ( seq -- mutable-seq )
 GENERIC: like ( seq seq -- seq )
-GENERIC: freeze ( new orig -- new )
 GENERIC: reverse ( seq -- seq )
 GENERIC: peek ( seq -- elt )
 GENERIC: contains? ( elt seq -- ? )

library/collections/strings-epilogue.factor

@@ -23,8 +23,8 @@ sequences strings ;
 M: object >string >sbuf (sbuf>string) ;
 
 M: string thaw >sbuf ;
-M: string freeze drop >string ;
+
-M: string like ( seq sbuf -- sbuf ) drop >string ;
+M: string like ( seq sbuf -- string ) drop >string ;
 
 M: sbuf clone ( sbuf -- sbuf )
     [ length <sbuf> dup ] keep nappend ;

library/collections/vectors-epilogue.factor

@@ -21,7 +21,7 @@ M: vector clone ( vector -- vector )
     0 <repeated> >vector ;
 
 M: general-list thaw >vector ;
-M: general-list freeze drop >list ;
+
 M: general-list like drop >list ;
 
 M: vector like drop >vector ;

library/compiler/simplifier.factor

@@ -18,21 +18,19 @@ GENERIC: next-logical ( linear vop -- linear )
 ! No delegation.
 M: tuple simplify-node drop f ;
 
+: (simplify-1) ( ? list -- ? )
+    dup [
+        [ car simplify-node swap , or ] keep cdr (simplify-1)
+    ] when ;
+
 : simplify-1 ( list -- list ? )
     #! Return a new linear IR.
-     dup [
+    [ (simplify-1) ] make-list swap ;
-         dup car simplify-node
-         [ uncons simplify-1 drop cons t ]
-         [ uncons simplify-1 >r cons r> ] ifte
-     ] [
-         f
-     ] ifte ;
 
 : simplify ( linear -- linear )
     #! Keep simplifying until simplify-1 returns f.
-    [
+    [ dup simplifying set  simplify-1 ] with-scope
-        dup simplifying set  simplify-1
+    [ simplify ] when ;
-    ] with-scope  [ simplify ] when ;
 
 : label-called? ( label -- ? )
     simplifying get [ calls-label? ] some-with? ;

library/compiler/vops.factor

@@ -40,11 +40,6 @@ M: vop calls-label? vop-label = ;
 : make-vop ( inputs outputs label vop -- vop )
     [ >r <vop> r> set-delegate ] keep ;
 
-: VOP:
-    #! Followed by a VOP name.
-    scan dup [ ] define-tuple
-    create-in [ make-vop ] define-constructor ; parsing
-
 : empty-vop f f f ;
 : label-vop ( label) >r f f r> ;
 : label/src-vop ( label src) unit swap f swap ;
@@ -57,83 +52,105 @@ M: vop calls-label? vop-label = ;
 : 3-vop ( in1 in2 dest) >r 2list r> unit f ;
 
 ! miscellanea
-VOP: %prologue
+TUPLE: %prologue ;
+C: %prologue make-vop ;
 : %prologue empty-vop <%prologue> ;
 
-VOP: %label
+TUPLE: %label ;
+C: %label make-vop ;
 : %label label-vop <%label> ;
 M: %label calls-label? 2drop f ;
 
 ! Return vops take a label that is ignored, to have the
 ! same stack effect as jumps. This is needed for the
 ! simplifier.
-VOP: %return
+TUPLE: %return ;
+C: %return make-vop ;
 : %return ( label) label-vop <%return> ;
 
-VOP: %return-to
+TUPLE: %return-to ;
+C: %return-to make-vop ;
 : %return-to label-vop <%return-to> ;
 
-VOP: %jump
+TUPLE: %jump ;
+C: %jump make-vop ;
 : %jump label-vop <%jump> ;
 
-VOP: %jump-label
+TUPLE: %jump-label ;
+C: %jump-label make-vop ;
 : %jump-label label-vop <%jump-label> ;
 
-VOP: %call
+TUPLE: %call ;
+C: %call make-vop ;
 : %call label-vop <%call> ;
 
-VOP: %call-label
+TUPLE: %call-label ;
+C: %call-label make-vop ;
 : %call-label label-vop <%call-label> ;
 
-VOP: %jump-t
+TUPLE: %jump-t ;
+C: %jump-t make-vop ;
 : %jump-t <vreg> label/src-vop <%jump-t> ;
 
-VOP: %jump-f
+TUPLE: %jump-f ;
+C: %jump-f make-vop ;
 : %jump-f <vreg> label/src-vop <%jump-f> ;
 
 ! dispatch tables
-VOP: %dispatch
+TUPLE: %dispatch ;
+C: %dispatch make-vop ;
 : %dispatch <vreg> src-vop <%dispatch> ;
 
-VOP: %target-label
+TUPLE: %target-label ;
+C: %target-label make-vop ;
 : %target-label label-vop <%target-label> ;
 
-VOP: %target
+TUPLE: %target ;
+C: %target make-vop ;
 : %target label-vop <%target> ;
 
-VOP: %end-dispatch
+TUPLE: %end-dispatch ;
+C: %end-dispatch make-vop ;
 : %end-dispatch empty-vop <%end-dispatch> ;
 
 ! stack operations
-VOP: %peek-d
+TUPLE: %peek-d ;
+C: %peek-d make-vop ;
 : %peek-d ( vreg n -- ) swap <vreg> src/dest-vop <%peek-d> ;
 M: %peek-d basic-block? drop t ;
 
-VOP: %replace-d
+TUPLE: %replace-d ;
+C: %replace-d make-vop ;
 : %replace-d ( vreg n -- ) swap <vreg> 2-in-vop <%replace-d> ;
 M: %replace-d basic-block? drop t ;
 
-VOP: %inc-d
+TUPLE: %inc-d ;
+C: %inc-d make-vop ;
 : %inc-d ( n -- ) src-vop <%inc-d> ;
 : %dec-d ( n -- ) neg %inc-d ;
 M: %inc-d basic-block? drop t ;
 
-VOP: %immediate
+TUPLE: %immediate ;
+C: %immediate make-vop ;
 : %immediate ( vreg obj -- )
     swap <vreg> src/dest-vop <%immediate> ;
 M: %immediate basic-block? drop t ;
 
-VOP: %peek-r
+TUPLE: %peek-r ;
+C: %peek-r make-vop ;
 : %peek-r ( vreg n -- ) swap <vreg> src/dest-vop <%peek-r> ;
 
-VOP: %replace-r
+TUPLE: %replace-r ;
+C: %replace-r make-vop ;
 : %replace-r ( vreg n -- ) swap <vreg> 2-in-vop <%replace-r> ;
 
-VOP: %inc-r
+TUPLE: %inc-r ;
+C: %inc-r make-vop ;
 : %inc-r ( n -- ) src-vop <%inc-r> ;
 
 ! this exists, unlike %dec-d which does not, due to x86 quirks
-VOP: %dec-r
+TUPLE: %dec-r ;
+C: %dec-r make-vop ;
 : %dec-r ( n -- ) src-vop <%dec-r> ;
 
 : in-1 0 0 %peek-d , ;
@@ -142,22 +159,26 @@ VOP: %dec-r
 : out-1 0 0 %replace-d , ;
 
 ! indirect load of a literal through a table
-VOP: %indirect
+TUPLE: %indirect ;
+C: %indirect make-vop ;
 : %indirect ( vreg obj -- )
     swap <vreg> src/dest-vop <%indirect> ;
 M: %indirect basic-block? drop t ;
 
 ! object slot accessors
 ! mask off a tag (see also %untag-fixnum)
-VOP: %untag
+TUPLE: %untag ;
+C: %untag make-vop ;
 : %untag <vreg> dest-vop <%untag> ;
 M: %untag basic-block? drop t ;
 
-VOP: %slot
+TUPLE: %slot ;
+C: %slot make-vop ;
 : %slot ( n vreg ) >r <vreg> r> <vreg> 2-vop <%slot> ;
 M: %slot basic-block? drop t ;
 
-VOP: %set-slot
+TUPLE: %set-slot ;
+C: %set-slot make-vop ;
 : %set-slot ( value obj n )
     #! %set-slot writes to vreg n.
     >r >r <vreg> r> <vreg> r> <vreg> 3list dup second f
@@ -166,38 +187,56 @@ M: %set-slot basic-block? drop t ;
 
 ! in the 'fast' versions, the object's type and slot number is
 ! known at compile time, so these become a single instruction
-VOP: %fast-slot
+TUPLE: %fast-slot ;
+C: %fast-slot make-vop ;
 : %fast-slot ( vreg n )
     swap <vreg> 2-vop <%fast-slot> ;
 M: %fast-slot basic-block? drop t ;
 
-VOP: %fast-set-slot
+TUPLE: %fast-set-slot ;
+C: %fast-set-slot make-vop ;
 : %fast-set-slot ( value obj n )
     #! %fast-set-slot writes to vreg obj.
     >r >r <vreg> r> <vreg> r> over >r 3list r> unit f
     <%fast-set-slot> ;
 M: %fast-set-slot basic-block? drop t ;
 
-VOP: %write-barrier
+TUPLE: %write-barrier ;
+C: %write-barrier make-vop ;
 : %write-barrier ( ptr ) <vreg> unit dup f <%write-barrier> ;
 
 ! fixnum intrinsics
-VOP: %fixnum+       : %fixnum+ 3-vop <%fixnum+> ;
+TUPLE: %fixnum+ ;
-VOP: %fixnum-       : %fixnum- 3-vop <%fixnum-> ;
+C: %fixnum+ make-vop ;       : %fixnum+ 3-vop <%fixnum+> ;
-VOP: %fixnum*       : %fixnum* 3-vop <%fixnum*> ;
+TUPLE: %fixnum- ;
-VOP: %fixnum-mod    : %fixnum-mod 3-vop <%fixnum-mod> ;
+C: %fixnum- make-vop ;       : %fixnum- 3-vop <%fixnum-> ;
-VOP: %fixnum/i      : %fixnum/i 3-vop <%fixnum/i> ;
+TUPLE: %fixnum* ;
-VOP: %fixnum/mod    : %fixnum/mod f <%fixnum/mod> ;
+C: %fixnum* make-vop ;       : %fixnum* 3-vop <%fixnum*> ;
-VOP: %fixnum-bitand : %fixnum-bitand 3-vop <%fixnum-bitand> ;
+TUPLE: %fixnum-mod ;
-VOP: %fixnum-bitor  : %fixnum-bitor 3-vop <%fixnum-bitor> ;
+C: %fixnum-mod make-vop ;    : %fixnum-mod 3-vop <%fixnum-mod> ;
-VOP: %fixnum-bitxor : %fixnum-bitxor 3-vop <%fixnum-bitxor> ;
+TUPLE: %fixnum/i ;
-VOP: %fixnum-bitnot : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
+C: %fixnum/i make-vop ;      : %fixnum/i 3-vop <%fixnum/i> ;
+TUPLE: %fixnum/mod ;
+C: %fixnum/mod make-vop ;    : %fixnum/mod f <%fixnum/mod> ;
+TUPLE: %fixnum-bitand ;
+C: %fixnum-bitand make-vop ; : %fixnum-bitand 3-vop <%fixnum-bitand> ;
+TUPLE: %fixnum-bitor ;
+C: %fixnum-bitor make-vop ;  : %fixnum-bitor 3-vop <%fixnum-bitor> ;
+TUPLE: %fixnum-bitxor ;
+C: %fixnum-bitxor make-vop ; : %fixnum-bitxor 3-vop <%fixnum-bitxor> ;
+TUPLE: %fixnum-bitnot ;
+C: %fixnum-bitnot make-vop ; : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
 
-VOP: %fixnum<=      : %fixnum<= 3-vop <%fixnum<=> ;
+TUPLE: %fixnum<= ;
-VOP: %fixnum<       : %fixnum< 3-vop <%fixnum<> ;
+C: %fixnum<= make-vop ;      : %fixnum<= 3-vop <%fixnum<=> ;
-VOP: %fixnum>=      : %fixnum>= 3-vop <%fixnum>=> ;
+TUPLE: %fixnum< ;
-VOP: %fixnum>       : %fixnum> 3-vop <%fixnum>> ;
+C: %fixnum< make-vop ;       : %fixnum< 3-vop <%fixnum<> ;
-VOP: %eq?           : %eq? 3-vop <%eq?> ;
+TUPLE: %fixnum>= ;
+C: %fixnum>= make-vop ;      : %fixnum>= 3-vop <%fixnum>=> ;
+TUPLE: %fixnum> ;
+C: %fixnum> make-vop ;       : %fixnum> 3-vop <%fixnum>> ;
+TUPLE: %eq? ;
+C: %eq? make-vop ;           : %eq? 3-vop <%eq?> ;
 
 ! At the VOP level, the 'shift' operation is split into five
 ! distinct operations:
@@ -207,27 +246,35 @@ VOP: %eq?           : %eq? 3-vop <%eq?> ;
 ! - shifts with a small negative count: %fixnum>>
 ! - shifts with a small negative count: %fixnum>>
 ! - shifts with a large negative count: %fixnum-sgn
-VOP: %fixnum<<   : %fixnum<<   3-vop <%fixnum<<> ;
+TUPLE: %fixnum<< ;
-VOP: %fixnum>>   : %fixnum>>   3-vop <%fixnum>>> ;
+C: %fixnum<< make-vop ;   : %fixnum<<   3-vop <%fixnum<<> ;
+TUPLE: %fixnum>> ;
+C: %fixnum>> make-vop ;   : %fixnum>>   3-vop <%fixnum>>> ;
 ! due to x86 limitations the destination of this VOP must be
 ! vreg 2 (EDX), and the source must be vreg 0 (EAX).
-VOP: %fixnum-sgn : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
+TUPLE: %fixnum-sgn ;
+C: %fixnum-sgn make-vop ; : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
 
 ! Integer comparison followed by a conditional branch is
 ! optimized
-VOP: %jump-fixnum<=
+TUPLE: %jump-fixnum<= ;
+C: %jump-fixnum<= make-vop ;
 : %jump-fixnum<= 2-in/label-vop <%jump-fixnum<=> ;
 
-VOP: %jump-fixnum< 
+TUPLE: %jump-fixnum< ;
+C: %jump-fixnum< make-vop ; 
 : %jump-fixnum< 2-in/label-vop <%jump-fixnum<> ;
 
-VOP: %jump-fixnum>=
+TUPLE: %jump-fixnum>= ;
+C: %jump-fixnum>= make-vop ;
 : %jump-fixnum>= 2-in/label-vop <%jump-fixnum>=> ;
 
-VOP: %jump-fixnum> 
+TUPLE: %jump-fixnum> ;
+C: %jump-fixnum> make-vop ; 
 : %jump-fixnum> 2-in/label-vop <%jump-fixnum>> ;
 
-VOP: %jump-eq?     
+TUPLE: %jump-eq? ;
+C: %jump-eq? make-vop ;     
 : %jump-eq? 2-in/label-vop <%jump-eq?> ;
 
 : fast-branch ( class -- class )
@@ -245,18 +292,22 @@ PREDICATE: tuple fast-branch
     class fast-branch ;
 
 ! some slightly optimized inline assembly
-VOP: %type
+TUPLE: %type ;
+C: %type make-vop ;
 : %type ( vreg ) <vreg> dest-vop <%type> ;
 M: %type basic-block? drop t ;
 
-VOP: %arithmetic-type
+TUPLE: %arithmetic-type ;
+C: %arithmetic-type make-vop ;
 : %arithmetic-type <vreg> dest-vop <%arithmetic-type> ;
 
-VOP: %tag-fixnum
+TUPLE: %tag-fixnum ;
+C: %tag-fixnum make-vop ;
 : %tag-fixnum <vreg> dest-vop <%tag-fixnum> ;
 M: %tag-fixnum basic-block? drop t ;
 
-VOP: %untag-fixnum
+TUPLE: %untag-fixnum ;
+C: %untag-fixnum make-vop ;
 : %untag-fixnum <vreg> dest-vop <%untag-fixnum> ;
 M: %untag-fixnum basic-block? drop t ;
 
@@ -266,44 +317,57 @@ M: %untag-fixnum basic-block? drop t ;
 : check-src ( vop reg -- )
     swap vop-in-1 = [ "bad VOP source" throw ] unless ;
 
-VOP: %getenv
+TUPLE: %getenv ;
+C: %getenv make-vop ;
 : %getenv swap src/dest-vop <%getenv> ;
 M: %getenv basic-block? drop t ;
 
-VOP: %setenv
+TUPLE: %setenv ;
+C: %setenv make-vop ;
 : %setenv 2-in-vop <%setenv> ;
 M: %setenv basic-block? drop t ;
 
 ! alien operations
-VOP: %parameters
+TUPLE: %parameters ;
+C: %parameters make-vop ;
 : %parameters ( n -- vop ) src-vop <%parameters> ;
 
-VOP: %parameter
+TUPLE: %parameter ;
+C: %parameter make-vop ;
 : %parameter ( n -- vop ) src-vop <%parameter> ;
 
-VOP: %cleanup
+TUPLE: %cleanup ;
+C: %cleanup make-vop ;
 : %cleanup ( n -- vop ) src-vop <%cleanup> ;
 
-VOP: %unbox
+TUPLE: %unbox ;
+C: %unbox make-vop ;
 : %unbox ( [[ n func ]] -- vop ) src-vop <%unbox> ;
 
-VOP: %unbox-float
+TUPLE: %unbox-float ;
+C: %unbox-float make-vop ;
 : %unbox-float ( [[ n func ]] -- vop ) src-vop <%unbox-float> ;
 
-VOP: %unbox-double
+TUPLE: %unbox-double ;
+C: %unbox-double make-vop ;
 : %unbox-double ( [[ n func ]] -- vop ) src-vop <%unbox-double> ;
 
-VOP: %box
+TUPLE: %box ;
+C: %box make-vop ;
 : %box ( func -- vop ) src-vop <%box> ;
 
-VOP: %box-float
+TUPLE: %box-float ;
+C: %box-float make-vop ;
 : %box-float ( func -- vop ) src-vop <%box-float> ;
 
-VOP: %box-double
+TUPLE: %box-double ;
+C: %box-double make-vop ;
 : %box-double ( [[ n func ]] -- vop ) src-vop <%box-double> ;
 
-VOP: %alien-invoke
+TUPLE: %alien-invoke ;
+C: %alien-invoke make-vop ;
 : %alien-invoke ( func -- vop ) src-vop <%alien-invoke> ;
 
-VOP: %alien-global
+TUPLE: %alien-global ;
+C: %alien-global make-vop ;
 : %alien-global ( global -- vop ) src-vop <%alien-global> ;

library/inference/branches.factor

@@ -124,5 +124,3 @@ USE: kernel-internals
     pop-literal vtable>list
     #dispatch pop-d drop infer-branches
 ] "infer" set-word-prop
-
-\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop

library/inference/dataflow.factor

@@ -14,11 +14,6 @@ TUPLE: node effect param in-d out-d in-r out-r
 : make-node ( effect param in-d out-d in-r out-r node -- node )
     [ >r f <node> r> set-delegate ] keep ;
 
-: NODE:
-    #! Followed by a node name.
-    scan dup [ ] define-tuple
-    create-in [ make-node ] define-constructor ; parsing
-
 : empty-node f f f f f f f f f ;
 : param-node ( label) f swap f f f f f ;
 : in-d-node ( inputs) >r f f r> f f f f ;
@@ -27,31 +22,40 @@ TUPLE: node effect param in-d out-d in-r out-r
 : d-tail ( n -- list ) meta-d get tail* >list ;
 : r-tail ( n -- list ) meta-r get tail* >list ;
 
-NODE: #label
+TUPLE: #label ;
+C: #label make-node ;
 : #label ( label -- node ) param-node <#label> ;
 
-NODE: #call
+TUPLE: #call ;
+C: #call make-node ;
 : #call ( word -- node ) param-node <#call> ;
 
-NODE: #call-label
+TUPLE: #call-label ;
+C: #call-label make-node ;
 : #call-label ( label -- node ) param-node <#call-label> ;
 
-NODE: #push
+TUPLE: #push ;
+C: #push make-node ;
 : #push ( outputs -- node ) d-tail out-d-node <#push> ;
 
-NODE: #drop
+TUPLE: #drop ;
+C: #drop make-node ;
 : #drop ( inputs -- node ) d-tail in-d-node <#drop> ;
 
-NODE: #values
+TUPLE: #values ;
+C: #values make-node ;
 : #values ( -- node ) meta-d get >list in-d-node <#values> ;
 
-NODE: #return
+TUPLE: #return ;
+C: #return make-node ;
 : #return ( -- node ) meta-d get >list in-d-node <#return> ;
 
-NODE: #ifte
+TUPLE: #ifte ;
+C: #ifte make-node ;
 : #ifte ( in -- node ) 1 d-tail in-d-node <#ifte> ;
 
-NODE: #dispatch
+TUPLE: #dispatch ;
+C: #dispatch make-node ;
 : #dispatch ( in -- node ) 1 d-tail in-d-node <#dispatch> ;
 
 : node-inputs ( d-count r-count node -- )

library/inference/words.factor

@@ -129,10 +129,6 @@ M: compound apply-word ( word -- )
         rethrow
     ] catch ;
 
-: no-base-case ( word -- )
-    word-name " does not have a base case." append
-    inference-error ;
-
 : recursive-word ( word [[ label quot ]] -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive

library/sdl/sdl-event.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: sdl USING: alien generic kernel ;
+IN: sdl USING: alien generic kernel kernel-internals ;
 
 BEGIN-ENUM: 0
     ENUM: SDL_NOEVENT         ! Unused (do not remove)

library/test/inference.factor

@@ -2,24 +2,6 @@ IN: temporary
 USING: generic inference kernel lists math math-internals
 namespaces parser sequences test vectors ;
 
-! [ [ [ object object ] f ] ]
-! [ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ]
-! unit-test
-! 
-! [ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ]
-! [
-!     [ [ vector ] [ cons vector cons integer object cons ] ]
-!     [ [ vector ] [ cons vector cons ] ]
-!     decompose
-! ] unit-test
-! 
-! [ [ [ object ] [ object ] ] ]
-! [
-!     [ [ object number ] [ object ] ]
-!     [ [ object number ] [ object ] ]
-!     decompose
-! ] unit-test
-
 : old-effect ( [ in-types out-types ] -- [[ in out ]] )
     uncons car length >r length r> cons ;
 
@@ -232,3 +214,7 @@ M: real iterate drop ;
 [ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test
 [ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test
 [ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test
+
+: no-base-case dup [ no-base-case ] [ no-base-case ] ifte ;
+
+[ [ no-base-case ] infer ] unit-test-fails

library/test/sequences.factor

@@ -11,3 +11,4 @@ USING: lists sequences test vectors ;
 [ { 1 2 } { 4 5 } ] [ 2 { 1 2 3 4 5 } cut* ] unit-test
 [ { 3 4 } ] [ 2 4 1 10 <range> subseq ] unit-test
 [ { 3 4 } ] [ 0 2 2 4 1 10 <range> <slice> subseq ] unit-test
+[ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test

library/unix/syscalls.factor

@@ -37,6 +37,14 @@ END-STRUCT
 : poll ( pollfds nfds timeout -- n )
     "int" "libc" "poll" [ "pollfd*" "uint" "int" ] alien-invoke ;
 
+BEGIN-STRUCT: timeval
+    FIELD: long sec
+    FIELD: long usec
+END-STRUCT
+
+: select ( nfds readfds writefds exceptfds timeout -- n )
+    "int" "libc" "select" [ "int" "void*" "void*" "void*" "timeval*" ] alien-invoke ;
+
 BEGIN-STRUCT: hostent
     FIELD: char* name
     FIELD: void* aliases

library/words.factor

@@ -50,8 +50,6 @@ M: word set-allot-count ( n w -- ) 7 set-integer-slot ;
 ! words can be recompiled when redefined.
 SYMBOL: crossref
 
-global [ <namespace> crossref set ] bind
-
 : (add-crossref)
     dup word? [
         crossref get [ dupd nest set-hash ] bind

native/primitives.c

@@ -7,6 +7,7 @@ void* primitives[] = {
 	primitive_execute,
 	primitive_call,
 	primitive_ifte,
+	primitive_dispatch,
 	primitive_cons,
 	primitive_vector,
 	primitive_string_compare,

native/run.c

@@ -94,6 +94,13 @@ void primitive_ifte(void)
 	call(cond == F ? f : t);
 }
 
+void primitive_dispatch(void)
+{
+	F_VECTOR *v = (F_VECTOR*)UNTAG(dpop());
+	F_FIXNUM n = untag_fixnum_fast(dpop());
+	call(get(AREF(untag_array_fast(v->array),n)));
+}
+
 void primitive_getenv(void)
 {
 	F_FIXNUM e = untag_fixnum_fast(dpeek());

native/run.h

@@ -93,5 +93,6 @@ void dosym(F_WORD* word);
 void primitive_execute(void);
 void primitive_call(void);
 void primitive_ifte(void);
+void primitive_dispatch(void);
 void primitive_getenv(void);
 void primitive_setenv(void);

native/string.c

@@ -31,7 +31,7 @@ void primitive_rehash_string(void)
 }
 
 /* untagged */
-F_STRING* string(CELL capacity, CELL fill)
+F_STRING *string(CELL capacity, CELL fill)
 {
 	CELL i;
 
@@ -73,7 +73,7 @@ void primitive_resize_string(void)
 	dpush(tag_object(resize_string(string,capacity,F)));
 }
 
-F_STRING* memory_to_string(const BYTE* string, CELL length)
+F_STRING *memory_to_string(const BYTE* string, CELL length)
 {
 	F_STRING* s = allot_string(length);
 	CELL i;
@@ -92,24 +92,24 @@ F_STRING* memory_to_string(const BYTE* string, CELL length)
 void primitive_memory_to_string(void)
 {
 	CELL length = unbox_unsigned_cell();
-	BYTE* string = (BYTE*)unbox_unsigned_cell();
+	BYTE *string = (BYTE*)unbox_unsigned_cell();
 	dpush(tag_object(memory_to_string(string,length)));
 }
 
 /* untagged */
-F_STRING* from_c_string(const char* c_string)
+F_STRING *from_c_string(const char *c_string)
 {
 	return memory_to_string((BYTE*)c_string,strlen(c_string));
 }
 
 /* FFI calls this */
-void box_c_string(const char* c_string)
+void box_c_string(const char *c_string)
 {
-	dpush(tag_object(from_c_string(c_string)));
+	dpush(c_string ? tag_object(from_c_string(c_string)) : F);
 }
 
 /* untagged */
-char* to_c_string(F_STRING* s)
+char *to_c_string(F_STRING *s)
 {
 	CELL i;
 	CELL capacity = string_capacity(s);
@@ -123,7 +123,7 @@ char* to_c_string(F_STRING* s)
 	return to_c_string_unchecked(s);
 }
 
-void string_to_memory(F_STRING* s, BYTE* string)
+void string_to_memory(F_STRING *s, BYTE *string)
 {
 	CELL i;
 	CELL capacity = string_capacity(s);
@@ -133,26 +133,27 @@ void string_to_memory(F_STRING* s, BYTE* string)
 
 void primitive_string_to_memory(void)
 {
-	BYTE* address = (BYTE*)unbox_unsigned_cell();
+	BYTE *address = (BYTE*)unbox_unsigned_cell();
-	F_STRING* str = untag_string(dpop());
+	F_STRING *str = untag_string(dpop());
 	string_to_memory(str,address);
 }
 
 /* untagged */
-char* to_c_string_unchecked(F_STRING* s)
+char *to_c_string_unchecked(F_STRING *s)
 {
 	CELL capacity = string_capacity(s);
-	F_STRING* _c_str = allot_string(capacity / CHARS + 1);
+	F_STRING *_c_str = allot_string(capacity / CHARS + 1);
-	BYTE* c_str = (BYTE*)(_c_str + 1);
+	BYTE *c_str = (BYTE*)(_c_str + 1);
 	string_to_memory(s,c_str);
 	c_str[capacity] = '\0';
 	return (char*)c_str;
 }
 
 /* FFI calls this */
-char* unbox_c_string(void)
+char *unbox_c_string(void)
 {
-	return to_c_string(untag_string(dpop()));
+	CELL str = dpop();
+	return (str ? to_c_string(untag_string(str)) : NULL);
 }
 
 /* FFI calls this */