diff --git a/Makefile b/Makefile index c8c1ce7f8a..4355f8a245 100644 --- a/Makefile +++ b/Makefile @@ -1,11 +1,13 @@ CC = gcc +# On FreeBSD, to use SDL and other libc_r libs: +CFLAGS = -Os -g -Wall -pthread # On PowerPC G5: # CFLAGS = -mcpu=970 -mtune=970 -mpowerpc64 -ffast-math -O3 # On Pentium 4: # CFLAGS = -march=pentium4 -ffast-math -O3 -fomit-frame-pointer # Add -fomit-frame-pointer if you don't care about debugging -CFLAGS = -Os -g -Wall +# CFLAGS = -Os -g -Wall # On Solaris: # LIBS = -lsocket -lnsl -lm @@ -24,7 +26,8 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \ native/run.o \ native/sbuf.o native/socket.o native/stack.o \ native/string.o native/types.o native/vector.o \ - native/write.o native/word.o native/compiler.o + native/write.o native/word.o native/compiler.o \ + native/ffi.o f: $(OBJS) $(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS) diff --git a/README.txt b/README.txt index 060dae42b8..5f48406582 100644 --- a/README.txt +++ b/README.txt @@ -41,8 +41,8 @@ exactly one primitive for performing conditional execution: USE: combinators - 1 10 < [ "10 is less than 1." print ] [ "whoa!" print ] ifte - ==> 10 is less than 1. + 1 10 < [ "1 is less than 10." print ] [ "whoa!" print ] ifte + ==> 1 is less than 10. Here is an example of a word that uses these two concepts: diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 292890b740..f94c017166 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -42,7 +42,7 @@ - finish namespaces docs - mention word accessors/mutators - to document: - >r r> (earlier on?) + >r r> example continuations streams multitasking diff --git a/doc/devel-guide.tex b/doc/devel-guide.tex index 6d3a90bde8..02651b83d2 100644 --- a/doc/devel-guide.tex +++ b/doc/devel-guide.tex @@ -967,25 +967,50 @@ USE: stack \section{Sequences} +Factor supports two primary types for storing sequential data; lists and vectors. +Lists are stored in a linked manner, with each node of the list holding an +element and a reference to the next node. Vectors, on the other hand, are contiguous sets of cells in memory, with each cell holding an element. Strings and string buffers can be considered as vectors specialized to holding characters, with the additional restriction that strings are immutable. + +Vectors are applicable to a different class of problems than lists. +Compare the relative performance of common operations on vectors and +lists: + +\begin{tabular}{|r|l|l|} +\hline +& +Lists& +Vectors\tabularnewline +\hline +\hline +Random access of an index& +linear time& +constant time\tabularnewline +\hline +Add new element at start& +constant time& +linear time\tabularnewline +\hline +Add new element at end& +linear time& +constant time\tabularnewline +\hline +\end{tabular} + +Vectors and lists can be converted back and forth using the \texttt{vector>list} +word \texttt{( vector -{}- list )} and the \texttt{list>vector} word +\texttt{( list -{}- vector )}. + \subsection{Lists and cons cells} -A list of objects is realized as a set of pairs; each pair holds a list element, -and a reference to the next pair. These pairs are known as \emph{cons cells}. All words relating to cons cells and lists are found in the \texttt{lists} -vocabulary. Lists have the following literal -syntax: - -\begin{alltt} -{[} "CEO" 5 "CFO" -4 f {]} -\end{alltt} - -A cons cell is an object that holds a reference to two other objects. -The order of the two objects matters -- the first is called the \emph{car}, +A \emph{cons cell} is a compound object holding references to two other objects. The order matters; the first is called the \emph{car}, the second is called the \emph{cdr}. The words \texttt{cons}, \texttt{car} and \texttt{cdr}% \footnote{These infamous names originate from the Lisp language. Originally, {}``Lisp'' stood for {}``List Processing''.% -} construct and deconstruct cons cells: +} construct and deconstruct cons cells. +All words relating to cons cells and lists are found in the \texttt{lists} +vocabulary. \begin{alltt} 1 2 cons . @@ -995,6 +1020,7 @@ The words \texttt{cons}, \texttt{car} and \texttt{cdr}% 5 6 cons cdr . \emph{6} \end{alltt} + The output of the first expression suggests a literal syntax for cons cells: @@ -1006,18 +1032,18 @@ cells: {[} "first" | {[} "second" | f {]} {]} cdr car . \emph{"second"} \end{alltt} -The last two examples make it clear how nested cons cells represent -a list. Since this {}``nested cons cell'' syntax is extremely cumbersome, -the parser provides an easier way: + +A \emph{proper list} (or often, just a \emph{list}) is a cons cell whose car is the first element, and the cdr is the \emph{rest of the list}. The car of the last cons cell in the list is the last element, and the cdr is \texttt{f}. + +Lists have the following literal +syntax: \begin{alltt} {[} 1 2 3 4 {]} cdr cdr car . \emph{3} \end{alltt} -A \emph{proper list} is a set of cons cells linked by their cdr, where the last cons cell has a cdr set to \texttt{f}. Also, the object \texttt{f} by itself -is a proper list, and in fact it is equivalent to the empty list \texttt{{[} -{]}}. An \emph{improper list} is a set of cons cells that does not terminate with \texttt{f}. Improper lists are input with the following syntax: +An \emph{improper list} is one where the cdr of the last cons cell is not \texttt{f}. Improper lists are input with the following syntax: \begin{verbatim} [ 1 2 3 | 4 ] @@ -1049,7 +1075,7 @@ It is worth mentioning a few words closely related to and defined in terms of \t : uncons dup car swap cdr ; \end{alltt} -\texttt{unswons ( cons -{}- cdr car)} is just a swapped version of \texttt{uncons}. It is defined as thus: +\texttt{unswons ( cons -{}- cdr car )} is just a swapped version of \texttt{uncons}. It is defined as thus: \begin{alltt} : unswons dup cdr swap car ; @@ -1081,9 +1107,10 @@ the original list, and a new element added at the end: 1 {[} 2 3 4 {]} cons . \emph{{[} 1 2 3 4 {]}} \end{alltt} + While \texttt{cons} and \texttt{add} appear to have similar effects, they are quite different -- \texttt{cons} is a very cheap operation, -while \texttt{add} has to copy the entire list first! If you need to add to the end of a sequence frequently, consider either using a vector, or adding to the beginning of a list and reversing the list when done. For information about lists, see \ref{sub:Vectors}. +while \texttt{add} has to copy the entire list first! If you need to add to the end of a sequence frequently, consider either using a vector, or adding to the beginning of a list and reversing the list when done. \texttt{append ( list list -{}- list )} Append two lists at the top of the stack: @@ -1094,6 +1121,7 @@ top of the stack: {[} 1 2 3 {]} dup {[} 4 5 6 {]} append .s \emph{\{ {[} 1 2 3 {]} {[} 1 2 3 4 5 6 {]} \}} \end{alltt} + The first list is copied, and the cdr of its last cons cell is set to point to the second list. The second example above shows that the original parameter was not modified. Interestingly, if the second parameter @@ -1103,6 +1131,7 @@ is not a proper list, \texttt{append} returns an improper list: {[} 1 2 3 {]} 4 append . \emph{{[} 1 2 3 | 4 {]}} \end{alltt} + \texttt{length ( list -{}- n )} Iterate down the cdr of the list until it reaches \texttt{f}, counting the number of elements in the list: @@ -1112,6 +1141,7 @@ it reaches \texttt{f}, counting the number of elements in the list: {[} {[} {[} "Hey" {]} 5 {]} length . \emph{2} \end{alltt} + \texttt{nth ( index list -{}- obj )} Look up an element specified by a zero-based index, by successively iterating down the cdr of the list: @@ -1120,6 +1150,7 @@ list: 1 {[} "Hamster" "Bagpipe" "Beam" {]} nth . \emph{"Bagpipe"} \end{alltt} + This word runs in linear time proportional to the list index. If you need constant time lookups, use a vector instead. @@ -1128,10 +1159,11 @@ identical to the original list except the element at the specified index is replaced: \begin{alltt} -{}``Done'' 1 {[} {}``Not started'' {}``Incomplete'' {]} set-nth . +"Done" 1 {[} "Not started" "Incomplete" {]} set-nth . -\emph{{[} {}``Done'' {}``Incomplete'' {]}} +\emph{{[} "Done" "Incomplete" {]}} \end{alltt} + \texttt{remove ( obj list -{}- list )} Push a new list, with all occurrences of the object removed. All other elements are in the same order: @@ -1140,6 +1172,7 @@ of the object removed. All other elements are in the same order: {[} "Canada" "New Zealand" "Australia" "Russia" {]} australia- . \emph{{[} "Canada" "New Zealand" "Russia" {]}} \end{alltt} + \texttt{remove-nth ( index list -{}- list )} Push a new list, with an index removed: @@ -1148,6 +1181,7 @@ an index removed: {[} "Canada" "New Zealand" "Australia" "Russia" {]} remove-1 . \emph{{[} "Canada" "Australia" "Russia" {]}} \end{alltt} + \texttt{reverse ( list -{}- list )} Push a new list which has the same elements as the original one, but in reverse order: @@ -1155,6 +1189,7 @@ same elements as the original one, but in reverse order: {[} 4 3 2 1 {]} reverse . \emph{{[} 1 2 3 4 {]}} \end{alltt} + \texttt{contains ( obj list -{}- list )} Look for an occurrence of an object in a list. The remainder of the list starting from the first occurrence is returned. If the object does not occur in the list, @@ -1170,22 +1205,24 @@ f is returned: "Pakistan" lived-in? . \emph{f} \end{alltt} -For now, assume {}``occurs'' means {}``contains an object that -looks like''. The issue of object equality is covered later. -\texttt{unique ( list -{}- list )} Return a new list with all duplicate -elements removed. This word executes in quadratic time, so should -not be used with large lists. For example: +For now, assume {}``occurs'' means {}``contains an object that +looks like''. The concept of object equality is covered later. + +\texttt{unique ( elem list -{}- list )} Return a new list containing the new element. If the list already contains the element, the same list is returned, otherwise the element is consed onto the list. This word executes in linear time, so its use in loops can be a potential performance bottleneck. \begin{alltt} -{[} 1 2 1 4 1 8 {]} unique . +1 {[} 1 2 4 8 {]} unique . \emph{{[} 1 2 4 8 {]}} +3 {[} 1 2 4 8 {]} unique . +\emph{{[} 3 1 2 4 8 {]}} \end{alltt} + \texttt{unit ( obj -{}- list )} Make a list of one element: \begin{alltt} -{}``Unit 18'' unit . -\emph{{[} {}``Unit 18'' {]}} +"Unit 18" unit . +\emph{{[} "Unit 18" {]}} \end{alltt} \subsection{\label{sub:Destructively-modifying-lists}Destructively modifying lists} @@ -1210,6 +1247,7 @@ the original list, and the original list has been destroyed: {[} 1 2 3 4 {]} dup nreverse .s \emph{\{ {[} 1 {]} {[} 4 3 2 1 {]} \}} \end{alltt} + Compare the second stack element (which is what remains of the original list) and the top stack element (the list returned by \texttt{nreverse}). @@ -1229,6 +1267,7 @@ it is unchanged, otherwise, it is equal to the return value: {[} 1 2 {]} {[} 3 4 {]} nappend . \emph{{[} 1 2 3 4 {]}} \end{alltt} + Note in the above examples, we use literal list parameters to \texttt{nreverse} and \texttt{nappend}. This is actually a very bad idea, since the same literal list may be used more than once! For example, lets make a colon definition: @@ -1238,11 +1277,12 @@ list may be used more than once! For example, lets make a colon definition: very-bad-idea . \emph{{[} 4 3 2 1 {]}} very-bad-idea . -\emph{{[} 4 {]}} -{}``very-bad-idea'' see +\emph{{[} 1 {]}} +"very-bad-idea" see \emph{: very-bad-idea} - \emph{ {[} 4 {]} nreverse ;} + \emph{ {[} 1 {]} nreverse ;} \end{alltt} + As you can see, the word definition itself was ruined! Sometimes it is desirable make a copy of a list, so that the copy @@ -1262,7 +1302,7 @@ itself. \subsection{\label{sub:Vectors}Vectors} -A \emph{vector} is a contiguous chunk of memory cells which hold references to arbitrary +A \emph{vector} is a contiguous chunk of memory cells holding references to arbitrary objects. Vectors have the following literal syntax: \begin{alltt} @@ -1286,9 +1326,10 @@ at a zero-based index of a vector: 2 \{ 1 2 \} vector-nth . \emph{ERROR: Out of bounds} \end{alltt} + \texttt{set-vector-nth ( obj index vector -{}- )} stores a value into a vector:% -\footnote{The words \texttt{get} and \texttt{set} used in this example will +\footnote{The words \texttt{get} and \texttt{set} used in this example refer to variables and will be formally introduced later.% } @@ -1301,6 +1342,7 @@ be formally introduced later.% "v" get . \emph{\{ "math" "philosophy" f f "CS" \}} \end{alltt} + \texttt{vector-length ( vector -{}- length )} pushes the number of elements in a vector. As the previous two examples demonstrate, attempting to fetch beyond the end of the vector will raise an error, while storing @@ -1334,47 +1376,6 @@ pop-state . \emph{12} \end{alltt} -\subsection{Vectors versus lists} - -Vectors are applicable to a different class of problems than lists. -Compare the relative performance of common operations on vectors and -lists: - -\begin{tabular}{|r|l|l|} -\hline -& -Lists& -Vectors\tabularnewline -\hline -\hline -Random access of an index& -linear time& -constant time\tabularnewline -\hline -Add new element at start& -constant time& -linear time\tabularnewline -\hline -Add new element at end& -linear time& -constant time\tabularnewline -\hline -\end{tabular} - -When using vectors, you need to pass around a vector and an index --- when working with lists, often only a list head is passed around. -For this reason, if you need a sequence for iteration only, a list -is a better choice because the list vocabulary contains a rich collection -of recursive words. - -On the other hand, when you need to maintain your own {}``stack''-like -collection, a vector is the obvious choice, since most pushes and -pops can then avoid allocating memory. - -Vectors and lists can be converted back and forth using the \texttt{vector>list} -word \texttt{( vector -{}- list )} and the \texttt{list>vector} word -\texttt{( list -{}- vector )}. - \subsection{Strings} A \emph{string} is a sequence of 16-bit Unicode characters (conventionally, @@ -1589,6 +1590,26 @@ new character positions are automatically filled with zeroes. \section{Control flow} +Recall the syntax for a conditional statement from the first chapter: + +\begin{alltt} +1 2 < {[} "1 is less than 2." print {]} {[} "bug!" print {]} ifte +\end{alltt} + +The syntax for the quotations there looks an aweful lot like the syntax for literal lists. In fact, code quotations \emph{are} lists. Factor code is data, and vice versa. + +Essentially, the interpreter iterates through code quotations, pushing literals and executing words. When a word is executed, one of two things happen -- either the word has a colon definition, and the interpreter is invoked recursively on the definition, or the word is primitive, and it is executed by the underlying virtual machine. + +\subsection{The call stack} + +So far, we have seen what we called ``the stack'' store intermediate values between computations. In fact Factor maintains a number of other stacks, and the formal name for the stack we've been dealing with so far is the \emph{data stack}. + +Another fundamental stack is the \emph{call stack}. When invoking an inner colon definition, the interpreter pushes the current execution state on the call stack so that it can be restored later. + +The call stack also serves a dual purpose as a temporary storage area. Sometimes, juggling values on the data stack becomes ackward, and in that case \texttt{>r} and \texttt{r>} can be used to move a value from the data stack to the call stack, and vice versa, respectively. + +give an example here + \subsection{Recursion} The idea of \emph{recursion} is key to understanding Factor. A \emph{recursive} word definition is one that refers to itself, usually in one branch of a conditional. The general form of a recursive word looks as follows: @@ -1602,9 +1623,11 @@ The idea of \emph{recursion} is key to understanding Factor. A \emph{recursive} {]} ifte ; \end{alltt} -The recursive case contains one more more calls to the original word. When a recursive call is made, the current execution state is saved on the \emph{call stack}, so that when the recursive call returns execution continues where it left off. +The recursive case contains one or more calls to the original word. -There are a few things worth noting about the stack flow inside a recursive word. The condition must take care to preserve any input parameters needed for the base case and recursive case. The base case must consume all inputs, and leave the final return values on the stack. The recursive case should also be coded such that the stack effect of the total definition is the same regardless of how many iterations are preformed; words that consume or produce different numbers of paramters depending on circumstances are very hard to debug. +There are a few things worth noting about the stack flow inside a recursive word. The condition must take care to preserve any input parameters needed for the base case and recursive case. The base case must consume all inputs, and leave the final return values on the stack. The recursive case should somehow reduce one of the parameters. This could mean incrementing or decrementing an integer, taking the \texttt{cdr} of a list, and so on. Parameters must eventually reduce to a state where the condition returns \texttt{f}, to avoid an infinite recursion. + +The recursive case should also be coded such that the stack effect of the total definition is the same regardless of how many iterations are preformed; words that consume or produce different numbers of paramters depending on circumstances are very hard to debug. In a programming language such as Java\footnote{Although by the time you read this, Java implementations might be doing tail-call optimization.}, using recursion to iterate through a long list is highly undesirable because it risks overflowing the (finite) call stack depth. However, Factor performs \emph{tail call optimization}, which is based on the observation that if the recursive call is made at a point right before the word being defined would return, there is \emph{actually nothing to save} on the call stack, so recursion call nesting can occur to arbitrary depth. Such recursion is known as \emph{tail recursion}. @@ -2377,11 +2400,7 @@ The scope created by \texttt{<\%} and \texttt{\%>} is \emph{dynamic}; that is, a \subsection{The name stack} -So far, we have seen what we called ``the stack'' store intermediate values between computations. In fact Factor maintains a number of other stacks, and the formal name for the stack we've been dealing with so far is the \emph{data stack}. - -Another stack is the \emph{call stack}. When a colon definition is invoked, the position within the current colon definition is pushed on the stack. This ensures that calling words return to the caller, just as in any other language with subroutines.\footnote{Factor supports a variety of structures for implementing non-local word exits, such as exceptions, co-routines, continuations, and so on. They all rely on manipulating the call stack and are described in later sections.} - -The \emph{name stack} is the focus of this section. The \texttt{bind} combinator creates dynamic scope by pushing and popping namespaces on the name stack. Its definition is simpler than one would expect: +The \texttt{bind} combinator creates dynamic scope by pushing and popping namespaces on the so-called \emph{name stack}. Its definition is simpler than one would expect: \begin{alltt} : bind ( namespace quot -- ) diff --git a/library/compiler/assembly-x86.factor b/library/compiler/assembly-x86.factor index 286f119c0b..36eec34103 100644 --- a/library/compiler/assembly-x86.factor +++ b/library/compiler/assembly-x86.factor @@ -44,12 +44,18 @@ USE: combinators : MOD-R/M ( r/m reg/opcode mod -- ) 6 shift swap 3 shift bitor bitor compile-byte ; -: PUSH ( reg -- ) +: PUSH-R ( reg -- ) HEX: 50 + compile-byte ; -: POP ( reg -- ) +: PUSH-I ( imm -- ) + HEX: 68 compile-byte compile-cell ; + +: POP-R ( reg -- ) HEX: 58 + compile-byte ; +: LEAVE ( -- ) + HEX: c9 compile-byte ; + : I>R ( imm reg -- ) #! MOV TO HEX: b8 + compile-byte compile-cell ; @@ -68,8 +74,7 @@ USE: combinators HEX: c7 compile-byte compile-byte compile-cell ; : R>[I] ( reg imm -- ) - #! MOV INDIRECT TO . - #! Actually only works with EAX. + #! MOV TO INDIRECT . over EAX = [ nip HEX: a3 compile-byte ] [ @@ -77,6 +82,10 @@ USE: combinators swap BIN: 101 swap 0 MOD-R/M ] ifte compile-cell ; +: R>R ( reg reg -- ) + #! MOV TO . + HEX: 89 compile-byte swap BIN: 11 MOD-R/M ; + : [R]>R ( reg reg -- ) #! MOV INDIRECT TO . HEX: 8b compile-byte swap 0 MOD-R/M ; @@ -92,6 +101,22 @@ USE: combinators compile-cell compile-cell ; +: R+I ( imm reg -- ) + #! ADD TO , STORE RESULT IN + over -128 127 between? [ + HEX: 83 compile-byte + 0 BIN: 11 MOD-R/M + compile-byte + ] [ + dup EAX = [ + drop HEX: 05 compile-byte + ] [ + HEX: 81 compile-byte + 0 BIN: 11 MOD-R/M + ] ifte + compile-cell + ] ifte ; + : R-I ( imm reg -- ) #! SUBTRACT FROM , STORE RESULT IN over -128 127 between? [ @@ -132,12 +157,20 @@ USE: combinators : [LITERAL] ( cell -- ) #! Push complex literal on data stack by following an #! indirect pointer. - ECX PUSH + ECX PUSH-R ( cell -- ) ECX [I]>R DATASTACK EAX [I]>R ECX EAX R>[R] 4 DATASTACK I+[I] - ECX POP ; + ECX POP-R ; + +: PUSH-DS ( -- ) + #! Push contents of EAX onto datastack. + ECX PUSH-R + DATASTACK ECX [I]>R + EAX ECX R>[R] + 4 DATASTACK I+[I] + ECX POP-R ; : POP-DS ( -- ) #! Pop datastack, store pointer to datastack top in EAX. diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index 16f14ff2d7..0db105185e 100644 --- a/library/cross-compiler.factor +++ b/library/cross-compiler.factor @@ -40,6 +40,12 @@ USE: vectors USE: vectors USE: words +IN: alien +DEFER: dlopen +DEFER: dlsym +DEFER: dlsym-self +DEFER: dlclose + IN: compiler DEFER: set-compiled-byte DEFER: set-compiled-cell @@ -288,6 +294,10 @@ IN: image literal-top set-literal-top address-of + dlopen + dlsym + dlsym-self + dlclose ] [ swap succ tuck primitive, ] each drop ; diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index 1b47875fe3..4db94ea509 100644 --- a/library/httpd/httpd.factor +++ b/library/httpd/httpd.factor @@ -113,11 +113,10 @@ USE: url-encoding global [ "httpd-quit" off ] bind ; : httpd-loop ( server -- server ) - [ - quit-flag not - ] [ + quit-flag [ dup dup accept httpd-connection - ] while ; + httpd-loop + ] unless ; : (httpd) ( port -- ) [ diff --git a/library/interpreter.factor b/library/interpreter.factor index 9dcf9cf6fc..ad358d141f 100644 --- a/library/interpreter.factor +++ b/library/interpreter.factor @@ -102,8 +102,11 @@ USE: vectors ] ifte ; : interpreter-loop ( -- ) - [ "quit-flag" get not ] [ interpret ] while - "quit-flag" off ; + "quit-flag" get [ + "quit-flag" off + ] [ + interpret interpreter-loop + ] ifte ; : room. ( -- ) room diff --git a/library/lists.factor b/library/lists.factor index 0350d7e830..0fa4764999 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -104,7 +104,7 @@ USE: vectors #! For example, given a proper list, pushes a cons cell #! whose car is the last element of the list, and whose cdr #! is f. - [ dup cdr cons? ] [ cdr ] while ; + dup cdr cons? [ cdr last* ] when ; : last ( list -- last ) #! Pushes last element of a list. Since this pushes the diff --git a/library/math/trig-hyp.factor b/library/math/trig-hyp.factor index 44576af3b0..02936dd0f2 100644 --- a/library/math/trig-hyp.factor +++ b/library/math/trig-hyp.factor @@ -38,8 +38,8 @@ USE: stack ! Hyperbolic functions: ! cosh sech sinh cosech tanh coth -: deg2rad pi * 180 / ; -: rad2deg 180 * pi / ; +: deg>rad pi * 180 / ; +: rad>deg 180 * pi / ; : cos ( z -- cos ) >rect 2dup diff --git a/library/platform/jvm/stream.factor b/library/platform/jvm/stream.factor index 361a72b9d5..f9157b542a 100644 --- a/library/platform/jvm/stream.factor +++ b/library/platform/jvm/stream.factor @@ -232,9 +232,10 @@ USE: strings : ( socket -- stream ) #! Wraps a socket inside a byte-stream. dup - [ [ ] "java.net.Socket" "getInputStream" jinvoke ] - [ [ ] "java.net.Socket" "getOutputStream" jinvoke ] - cleave + dup + [ ] "java.net.Socket" "getInputStream" jinvoke + swap + [ ] "java.net.Socket" "getOutputStream" jinvoke [ dup >str "client" set "socket" set diff --git a/library/platform/native/debugger.factor b/library/platform/native/debugger.factor index 5b43b6344d..f6479b3c00 100644 --- a/library/platform/native/debugger.factor +++ b/library/platform/native/debugger.factor @@ -84,7 +84,7 @@ USE: words "Operating system signal " write . ; : profiling-disabled-error ( obj -- ) - drop "Recompile with the FACTOR_PROFILER flag." print ; + drop "Recompile with #define FACTOR_PROFILER." print ; : negative-array-size-error ( obj -- ) "Cannot allocate array with negative size " write . ; @@ -95,6 +95,12 @@ USE: words : c-string-error ( obj -- ) "Cannot convert to C string: " write . ; +: ffi-disabled-error ( obj -- ) + drop "Recompile Factor with #define FFI." print ; + +: ffi-error ( obj -- ) + "FFI: " write print ; + : kernel-error. ( obj n -- str ) { expired-port-error @@ -112,6 +118,8 @@ USE: words negative-array-size-error bad-primitive-error c-string-error + ffi-disabled-error + ffi-error } vector-nth execute ; : kernel-error? ( obj -- ? ) diff --git a/library/platform/native/kernel.factor b/library/platform/native/kernel.factor index 8f045eb2b2..187d10bfc0 100644 --- a/library/platform/native/kernel.factor +++ b/library/platform/native/kernel.factor @@ -29,6 +29,7 @@ IN: vectors DEFER: vector= IN: kernel + USE: combinators USE: errors USE: io-internals @@ -69,6 +70,7 @@ USE: vectors [ drop 0 ] [ >fixnum ] [ >fixnum ] + [ drop 0 ] } generic ; : equal? ( obj obj -- ? ) @@ -89,6 +91,7 @@ USE: vectors [ eq? ] [ number= ] [ number= ] + [ eq? ] } generic ; : = ( obj obj -- ? ) @@ -118,6 +121,7 @@ USE: vectors [ 12 | "port" ] [ 13 | "bignum" ] [ 14 | "float" ] + [ 15 | "dll" ] ! These values are only used by the kernel for error ! reporting. [ 100 | "fixnum/bignum" ] diff --git a/library/platform/native/math.factor b/library/platform/native/math.factor index fc626d085b..3dbaa5343c 100644 --- a/library/platform/native/math.factor +++ b/library/platform/native/math.factor @@ -30,6 +30,9 @@ USE: combinators USE: kernel USE: stack +: bignum? ( obj -- ? ) type-of 13 eq? ; +: complex? ( obj -- ? ) type-of 5 eq? ; + : (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ; diff --git a/library/platform/native/primitives.factor b/library/platform/native/primitives.factor index 1f7c881bea..875b1d0074 100644 --- a/library/platform/native/primitives.factor +++ b/library/platform/native/primitives.factor @@ -26,21 +26,22 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. USE: combinators +USE: alien +USE: compiler USE: files USE: io-internals -USE: lists USE: kernel +USE: lists USE: math -USE: strings -USE: random -USE: real-math USE: parser USE: profiler +USE: random +USE: real-math USE: stack +USE: strings +USE: unparser USE: vectors USE: words -USE: unparser -USE: compiler [ [ execute | " word -- " ] @@ -196,6 +197,10 @@ USE: compiler [ set-compiled-offset | " ptr -- " ] [ literal-top | " -- ptr " ] [ set-literal-top | " ptr -- " ] + [ dlopen | " path -- dll " ] + [ dlsym | " name dll -- ptr " ] + [ dlsym-self | " name -- ptr " ] + [ dlclose | " dll -- " ] ] [ unswons "stack-effect" swap set-word-property ] each diff --git a/library/strings.factor b/library/strings.factor index 501d1750a1..06cdbb10bf 100644 --- a/library/strings.factor +++ b/library/strings.factor @@ -41,7 +41,7 @@ USE: stack : str-length< ( str str -- boolean ) #! Compare string lengths. - [ str-length ] 2apply < ; + swap str-length swap str-length < ; : cat ( [ "a" "b" "c" ] -- "abc" ) ! If f appears in the list, it is not appended to the diff --git a/library/telnetd.factor b/library/telnetd.factor index abb9d4102b..9df3b1777a 100644 --- a/library/telnetd.factor +++ b/library/telnetd.factor @@ -61,11 +61,10 @@ USE: threads global [ f "telnetd-quit-flag" set ] bind ; : telnetd-loop ( server -- server ) - [ - quit-flag not - ] [ + quit-flag [ dup >r accept telnet-connection r> - ] while ; + telnetd-loop + ] unless ; : telnetd ( port -- ) [ diff --git a/library/test/jvm-compiler/miscellaneous.factor b/library/test/jvm-compiler/miscellaneous.factor index 0c81c55cf7..a632147879 100644 --- a/library/test/jvm-compiler/miscellaneous.factor +++ b/library/test/jvm-compiler/miscellaneous.factor @@ -30,7 +30,7 @@ USE: words [ f ] [ ] [ gensym-test ] test-word : intern-test ( 1 2 -- ? ) - [ intern ] 2apply = ; + swap intern swap intern = ; [ f ] [ "#:a" "#:a" ] [ intern-test ] test-word [ t ] [ "#:" "#:" ] [ intern-test ] test-word diff --git a/library/test/x86-compiler/asm-test.factor b/library/test/x86-compiler/asm-test.factor index 65680886e2..290f71fd30 100644 --- a/library/test/x86-compiler/asm-test.factor +++ b/library/test/x86-compiler/asm-test.factor @@ -25,3 +25,13 @@ ECX ECX R>[R] 4 0 I+[I] 0 4 I+[I] + +4 EAX R+I +4 ECX R+I +65535 EAX R+I +65535 ECX R+I + +4 EAX R-I +4 ECX R-I +65535 EAX R-I +65535 ECX R-I diff --git a/native/bignum.c b/native/bignum.c index 1eb89097fe..7800bdf243 100644 --- a/native/bignum.c +++ b/native/bignum.c @@ -1,10 +1,5 @@ #include "factor.h" -void primitive_bignump(void) -{ - drepl(tag_boolean(typep(BIGNUM_TYPE,dpeek()))); -} - ARRAY* to_bignum(CELL tagged) { RATIO* r; diff --git a/native/bignum.h b/native/bignum.h index 8810eddc5d..651197bf02 100644 --- a/native/bignum.h +++ b/native/bignum.h @@ -8,7 +8,6 @@ INLINE ARRAY* untag_bignum(CELL tagged) return (ARRAY*)UNTAG(tagged); } -void primitive_bignump(void); ARRAY* to_bignum(CELL tagged); void primitive_to_bignum(void); CELL number_eq_bignum(ARRAY* x, ARRAY* y); diff --git a/native/complex.c b/native/complex.c index 3c0a417f83..20bd54f4cb 100644 --- a/native/complex.c +++ b/native/complex.c @@ -33,11 +33,6 @@ CELL possibly_complex(CELL real, CELL imaginary) return tag_complex(complex(real,imaginary)); } -void primitive_complexp(void) -{ - drepl(tag_boolean(typep(COMPLEX_TYPE,dpeek()))); -} - void primitive_real(void) { switch(type_of(dpeek())) diff --git a/native/complex.h b/native/complex.h index 7fffa7479e..a8f2c28387 100644 --- a/native/complex.h +++ b/native/complex.h @@ -18,7 +18,6 @@ COMPLEX* complex(CELL real, CELL imaginary); COMPLEX* to_complex(CELL x); CELL possibly_complex(CELL real, CELL imaginary); -void primitive_complexp(void); void primitive_real(void); void primitive_imaginary(void); void primitive_to_rect(void); diff --git a/native/error.c b/native/error.c index f0a77ee833..2cf1a46077 100644 --- a/native/error.c +++ b/native/error.c @@ -45,10 +45,12 @@ void general_error(CELL error, CELL tagged) fprintf(stderr,"Error #%ld\n",to_fixnum(error)); if(error == ERROR_TYPE) { + CELL obj = untag_cons(untag_cons(tagged)->cdr)->car; + fprintf(stderr,"Type #%ld\n",to_fixnum( untag_cons(tagged)->car)); - fprintf(stderr,"Got type #%ld\n",type_of( - untag_cons(tagged)->cdr)); + fprintf(stderr,"Object %ld\n",obj); + fprintf(stderr,"Got type #%ld\n",type_of(obj)); } fflush(stderr); exit(1); diff --git a/native/error.h b/native/error.h index 5718d1414b..99c1ebe47b 100644 --- a/native/error.h +++ b/native/error.h @@ -13,6 +13,8 @@ #define ERROR_NEGATIVE_ARRAY_SIZE (12<<3) #define ERROR_BAD_PRIMITIVE (13<<3) #define ERROR_C_STRING (14<<3) +#define ERROR_FFI_DISABLED (15<<3) +#define ERROR_FFI (16<<3) void fatal_error(char* msg, CELL tagged); void critical_error(char* msg, CELL tagged); diff --git a/native/factor.h b/native/factor.h index a8a4833d22..a8c3d88327 100644 --- a/native/factor.h +++ b/native/factor.h @@ -23,6 +23,12 @@ #include #include +#define FFI + +#ifdef FFI +#include +#endif /* FFI */ + #define INLINE inline static /* CELL must be 32 bits and your system must have 32-bit pointers */ @@ -81,5 +87,6 @@ and allows profiling. */ #include "vector.h" #include "stack.h" #include "compiler.h" +#include "ffi.h" #endif /* __FACTOR_H__ */ diff --git a/native/ffi.c b/native/ffi.c new file mode 100644 index 0000000000..222c0100e7 --- /dev/null +++ b/native/ffi.c @@ -0,0 +1,68 @@ +#include "factor.h" + +void primitive_dlopen(void) +{ +#ifdef FFI + char* path = to_c_string(untag_string(dpop())); + void* dllptr = dlopen(path,RTLD_NOW); + DLL* dll; + + if(dllptr == NULL) + { + general_error(ERROR_FFI,tag_object( + from_c_string(dlerror()))); + } + + dll = allot_object(DLL_TYPE,sizeof(DLL)); + dll->dll = dllptr; + dpush(tag_object(dll)); +#else + general_error(ERROR_FFI_DISABLED,F); +#endif +} + +void primitive_dlsym(void) +{ +#ifdef FFI + DLL* dll = untag_dll(dpop()); + void* sym = dlsym(dll->dll,to_c_string(untag_string(dpop()))); + if(sym == NULL) + { + general_error(ERROR_FFI,tag_object( + from_c_string(dlerror()))); + } + dpush(tag_cell((CELL)sym)); +#else + general_error(ERROR_FFI_DISABLED,F); +#endif +} + +void primitive_dlsym_self(void) +{ +#ifdef FFI + void* sym = dlsym(NULL,to_c_string(untag_string(dpop()))); + if(sym == NULL) + { + general_error(ERROR_FFI,tag_object( + from_c_string(dlerror()))); + } + dpush(tag_cell((CELL)sym)); +#else + general_error(ERROR_FFI_DISABLED,F); +#endif +} + +void primitive_dlclose(void) +{ +#ifdef FFI + DLL* dll = untag_dll(dpop()); + if(dlclose(dll->dll) == -1) + { + general_error(ERROR_FFI,tag_object( + from_c_string(dlerror()))); + } + dll->dll = NULL; +#else + general_error(ERROR_FFI_DISABLED,F); +#endif +} diff --git a/native/ffi.h b/native/ffi.h new file mode 100644 index 0000000000..50f6c1e2be --- /dev/null +++ b/native/ffi.h @@ -0,0 +1,15 @@ +typedef struct { + CELL header; + void* dll; +} DLL; + +INLINE DLL* untag_dll(CELL tagged) +{ + type_check(DLL_TYPE,tagged); + return (DLL*)UNTAG(tagged); +} + +void primitive_dlopen(void); +void primitive_dlsym(void); +void primitive_dlsym_self(void); +void primitive_dlclose(void); diff --git a/native/primitives.c b/native/primitives.c index 7effab30c6..18127cab7c 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -160,7 +160,11 @@ XT primitives[] = { primitive_set_compiled_offset, primitive_literal_top, primitive_set_literal_top, - primitive_address_of + primitive_address_of, + primitive_dlopen, + primitive_dlsym, + primitive_dlsym_self, + primitive_dlclose }; CELL primitive_to_xt(CELL primitive) diff --git a/native/primitives.h b/native/primitives.h index 5543503c54..1b78c77b0a 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 160 +#define PRIMITIVE_COUNT 163 CELL primitive_to_xt(CELL primitive); diff --git a/native/types.c b/native/types.c index 7c6cff7559..60228accef 100644 --- a/native/types.c +++ b/native/types.c @@ -103,6 +103,9 @@ CELL untagged_object_size(CELL pointer) case PORT_TYPE: size = sizeof(PORT); break; + case DLL_TYPE: + size = sizeof(DLL); + break; default: critical_error("Cannot determine size",relocating); size = -1;/* can't happen */ diff --git a/native/types.h b/native/types.h index b88203d235..d5e0bde38e 100644 --- a/native/types.h +++ b/native/types.h @@ -31,6 +31,7 @@ CELL T; #define PORT_TYPE 12 #define BIGNUM_TYPE 13 #define FLOAT_TYPE 14 +#define DLL_TYPE 15 /* Pseudo-types. For error reporting only. */ #define INTEGER_TYPE 100 /* FIXNUM or BIGNUM */ @@ -60,9 +61,12 @@ INLINE CELL tag_header(CELL cell) INLINE CELL untag_header(CELL cell) { + CELL type = cell >> TAG_BITS; if(TAG(cell) != HEADER_TYPE) critical_error("header type check",cell); - return cell >> TAG_BITS; + if(type <= HEADER_TYPE && type != WORD_TYPE) + critical_error("header invariant check",cell); + return type; } INLINE CELL tag_object(void* cell)