steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Imported https://downloads.factorcode.org/releases/0.77/Factor-0.77.zip

release import-0.77
nomennescio 2019-10-18 15:04:49 +02:00
parent bf2e8754cb 6463771b6a
commit 01538945e5
318 changed files with 16687 additions and 8553 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.cvskeywords
View File

@ -1,10 +1,10 @@
./library/win32/win32-io-internals.factor:! $Id: win32-io-internals.factor,v 1.8 2005/07/23 09:30:17 eiz Exp $
./library/win32/win32-io-internals.factor:! $Id: win32-io-internals.factor,v 1.11 2005/09/03 18:48:25 spestov Exp $
./library/win32/win32-io.factor:! $Id: win32-io.factor,v 1.4 2005/07/23 06:11:07 eiz Exp $
./library/win32/win32-stream.factor:! $Id: win32-stream.factor,v 1.8 2005/07/23 06:11:07 eiz Exp $
./library/win32/win32-errors.factor:! $Id: win32-errors.factor,v 1.7 2005/06/09 02:32:45 eiz Exp $
./library/win32/win32-server.factor:! $Id: win32-server.factor,v 1.7 2005/07/23 06:11:07 eiz Exp $
./library/win32/winsock.factor:! $Id: winsock.factor,v 1.5 2005/06/13 21:04:58 spestov Exp $
./library/bootstrap/win32-io.factor:! $Id: win32-io.factor,v 1.8 2005/06/19 21:50:33 spestov Exp $
./library/win32/win32-stream.factor:! $Id: win32-stream.factor,v 1.10 2005/09/03 18:48:25 spestov Exp $
./library/win32/win32-errors.factor:! $Id: win32-errors.factor,v 1.8 2005/09/03 18:48:25 spestov Exp $
./library/win32/win32-server.factor:! $Id: win32-server.factor,v 1.11 2005/09/03 18:48:25 spestov Exp $
./library/win32/winsock.factor:! $Id: winsock.factor,v 1.6 2005/08/31 22:42:52 eiz Exp $
./library/bootstrap/win32-io.factor:! $Id: win32-io.factor,v 1.9 2005/08/31 05:39:36 eiz Exp $
./factor/ExternalFactor.java: * $Id: ExternalFactor.java,v 1.27 2005/07/17 20:29:04 spestov Exp $
./factor/ConstructorArtifact.java: * $Id: ConstructorArtifact.java,v 1.1 2005/03/01 23:55:59 spestov Exp $
./factor/math/Complex.java: * $Id: Complex.java,v 1.1.1.1 2004/07/16 06:26:13 spestov Exp $

96
CHANGES.html
View File

@ -1,9 +1,99 @@
<!-- :noWordSep=+-*\=><;.?/'()%,_|: -->
<html>
<head><title>Factor change log</title></head>
<body>
<h1>Factor 0.77:</h1>
<ul>
<li>Compiler:
<ul>
<li>Optimizing out conditionals where the test value is a constant.</li>
<li>Optimizing out type checks that are always/never satisfied.</li>
<li>Inlining method bodies when generic words are called on values with known compile-time types.</li>
<li>Side-effect-free words that output immutable values are evaluated at compile time if all their inputs are literal. You can declare a word as having this condition by suffixing the definition with <code>foldable</code>, eg:
<pre>: cube dup dup * * ; foldable</pre></li>
<li>Various arithmetic identities such as <code>1 *</code> are optimized out.
</ul>
</li>
<li>Collections:
<ul>
<li><code>2each ( seq seq quot -- quot: elt -- elt )</code> combinator</li>
<li><code>join ( seq glue -- seq )</code> word. Takes a sequence of sequences, and constructs a new sequence with the glue in between each sequence. For example:
<pre> [ "usr" "bin" "grep" ] "/" join
<b>"usr/bin/grep"</b></pre></li>
<li>Integers now support the sequence protocol. An integer is an increasing sequence of its predecessors. This means the <code>count ( n -- [ 0 ... n-1 ] )</code> word is gone; just use <code>&gt;vector</code> instead. Also, <code>project</code> has been made redundant by <code>map</code>.</li>
<li>The <code>seq-transpose ( seq -- seq )</code> word is now named <code>flip</code>.
</li>
<li>The matrices library has been greatly simplified. Matrices are now represented as vectors of vectors, and matrix words have been moved to the <code>math</code> vocabulary.</li>
<li>More descriptive "out of bounds" errors.</li>
<li>New <code>make-hash ( quot -- namespace )</code> combinator executes quotation in a new namespace, which is then pushed on the stack.</li>
<li>The <code>&lt;namespace&gt;</code> word is gone. It would create a hashtable with a default capacity. Now, just write <code>{{ }} clone</code>.</li>
<li>Sequence construction words changed:
<pre>
make-list ==&gt; [ ] make
make-vector ==&gt; { } make
make-string ==&gt; "" make
make-rstring ==&gt; "" make reverse
make-sbuf ==&gt; SBUF" " make
</pre></li>
<li>The <code>every?</code> word has been replaced with <code>monotonic? ( seq quot -- ? )</code>. Its behavior is a superset of <code>every?</code> -- it now accepts any transitive relation, and checks if the sequence is monotonic under this relation. For example,
<code>[ = ] monotonic?</code> checks if all elements in a sequence are equal, and <code>[ < ] monotonic?</code> checks for a strictly increasing sequence of integers.</li>
</ul>
</li>
<li>Development tools:
<ul>
<li>In the UI, object slots are now clickable in the inspector.</li>
<li>Inspector now supports a history and an interactive loop; it prints a brief help message when it starts describing usage.</li>
<li>The prettyprinter has been merged with the unparser. The <code>unparse ( object -- string )</code> word has been moved to the <code>prettyprint</code> vocabulary, and can now produce a parsable string for any class supported by the prettyprinter.</li>
<li>New <code>unparse-short ( object -- string )</code> returns a string no longer than a single line.</li>
<li>The prettyprinter now supports many more configuration variables. See the handbook for details.</li>
<li>New <code>profile ( word -- )</code> word. Causes the word's accumulative runtime to be stored in a global variable named by the word. This is done with the annotation facility, the word's definition is modified; use <code>reload ( word -- )</code> to get the old definition back from the source file.</li>
</ul>
</li>
<li>User interface:
<ul>
<li>Binary search is now used for spacial indexing where possible. This improves performance when there are a lot of lines of output in the listener.</li>
<li>Scroll bars now behave in a more intuitive manner, closer to conventional GUIs.</li>
<li>Menus now appear when the mouse button is pressed, not released, and dragging through the menu with the button held down behaves as one would expect.</li>
<li>The data stack and call stack are now shown. In the single-stepper, these two display the state of the program being stepped. In the inspector, the call stack display is replaced with an inspector history.</li>
<li>Pack layouts with gaps are now supported.</li>
<li>Many bug fixes.</li>
</ul>
</li>
<li>Everything else:
<ul>
<li>New <code>sleep ( ms -- )</code> word pauses current thread for a number of milliseconds.</li>
<li>New <code>with-datastack ( stack word -- stack )</code> combinator.</li>
<li>New <code>cond ( conditions -- )</code> combinator. It behaves like a set of nested <code>ifte</code>s, and compiles if each branch has the same stack effect. See its documentation comment for details.</li>
<li>Formally documented method combination (<code>G:</code> syntax) in handbook.
<li>Erlang/Termite-style concurrency library in <code>contrib/concurrency</code> (Chris Double).</li>
<li>Completely redid infix algebra in <code>contrib/algebra/</code>. Now, vector operations are possible
and the syntax doesn't use so many spaces. New way to write the quadratic formula:
<pre>MATH: quadratic[a;b;c] =
plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;</pre>
(Daniel Ehrenberg)</li>
<li>Support for client sockets on Windows. (Mackenzie Straight)</li>
</ul>
</li>
</ul>
<h1>Factor 0.76:</h1>
<!-- :noWordSep=+-*\=><;.?/'()%,_|: -->
<ul>
<li>
@ -116,6 +206,10 @@ write1 ( char -- )</pre>
<li>md5 hashing algorithm in <code>contrib/crypto/</code> (Doug Coleman).
</ul>
</ul>
</body>
</html>

18
Makefile
View File

@ -7,7 +7,16 @@ else
STRIP = strip
endif
ifdef STATIC
DEFAULT_LIBS = -lm -Wl,-static -Wl,-whole-archive \
-Wl,-export-dynamic \
-lSDL -lSDL_gfx -lSDL_ttf \
-Wl,-no-whole-archive \
-lfreetype -lz -L/usr/X11R6/lib -lX11 -lXext \
-Wl,-Bdynamic
else
DEFAULT_LIBS = -lm
endif
UNIX_OBJS = native/unix/file.o \
native/unix/signal.o \
@ -28,7 +37,7 @@ else
PLAF_OBJS = $(UNIX_OBJS)
endif
OBJS = $(PLAF_OBJS) native/arithmetic.o native/array.o native/bignum.o \
OBJS = $(PLAF_OBJS) native/array.o native/bignum.o \
native/s48_bignum.o \
native/complex.o native/cons.o native/error.o \
native/factor.o native/fixnum.o \
@ -45,7 +54,8 @@ OBJS = $(PLAF_OBJS) native/arithmetic.o native/array.o native/bignum.o \
native/debug.o \
native/hashtable.o \
native/icache.o \
native/io.o
native/io.o \
native/wrapper.o
default:
@echo "Run 'make' with one of the following parameters:"
@ -76,13 +86,13 @@ macosx:
linux:
$(MAKE) f \
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
LIBS="$(DEFAULT_LIBS) -ldl"
LIBS="-ldl $(DEFAULT_LIBS)"
$(STRIP) f
linux-ppc:
$(MAKE) f \
CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -mregnames" \
LIBS="$(DEFAULT_LIBS) -ldl"
LIBS="-ldl $(DEFAULT_LIBS)"
$(STRIP) f
windows:

5
README.txt
View File

@ -69,8 +69,8 @@ The Factor source distribution ships with four boot image files:
boot.image.le32 - for x86
boot.image.be32 - for PowerPC, SPARC
boot.image.le64 - for x86-64
boot.image.be64 - for Alpha, PowerPC/64, UltraSparc
boot.image.le64 - for x86-64, Alpha
boot.image.be64 - for PowerPC/64, UltraSparc
Once you have compiled the Factor runtime, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
@ -136,7 +136,6 @@ as, and issue a command similar to the following to bootstrap Factor:
generic/ - generic words, for object oriented programming style
help/ - online help system
httpd/ - HTTP client, server, and web application framework
icons/ - images used by web framework and UI
inference/ - stack effect inference, used by compiler, as well as a
useful development tool of its own
io/ - input and output streams

77
TODO.FACTOR.txt
View File

@ -1,27 +1,17 @@
+ ui:
- fix listener prompt display after presentation commands invoked
- theme abstraction in ui
- menu dragging
- fix up the min thumb size hack
- gaps in pack layout
- find out why so many small bignums get consed
- long lines of text fail in draw-surface
- only redraw dirty gadgets
- faster mouse tracking
- binary search to locate visible children of packs
- rewrite frame layout for new style
- an interior paint that is only painted on rollover and mouse press;
use it for menu items. give menus a gradient background
- scroll bar: more intuitive behavior when clicking inside the elevator
- timers
- nicer scrollbars with up/down buttons
- icons
- off-by-one error in pick-up?
- closing ui does not stop timers
- adding/removing timers automatically for animated gadgets
- theme abstraction in ui
- find out why so many small bignums get consed
- use incremental strategy for all pack layouts where possible
- multiline editing in listener
- sort out clipping off-by-one flaw when filling rectangles
- better menu positioning
- only redraw dirty gadgets
- get stuff in examples dir running in the ui
- opengl rendering
- text selection
- clipboard support
@ -42,10 +32,11 @@
- http keep alive, and range get
- code walker & exceptions
- sleep word
+ ffi:
- C structs, enums, unions: use new-style string mode parsing
- alien/c-types.factor is ugly
- smarter out parameter handling
- clarify powerpc passing of value struct parameters
- ffi unicode strings: null char security hole
@ -53,63 +44,63 @@
- value type structs
- bitfields in C structs
- setting struct members that are not *
- callbacks
+ compiler:
- inference needs to be more robust with heavily recursive code
- powerpc: float ffi parameters
- removing unneeded #label
- flushing optimization
- compile-byte/cell: instantiating aliens
- fix fixnum<< and /i overflow on PowerPC
- simplifier:
- kill replace after a peek
- merge inc-d's across VOPs that don't touch the stack
- intrinsic char-slot set-char-slot integer-slot set-integer-slot
- [ [ dup call ] dup call ] infer hangs
- more accurate types for various words
- declarations
- type inference fails with some assembler words;
displaced, register and other predicates need to inherit from list
not cons, and need stronger branch partial eval
- optimize away arithmetic dispatch
- the invalid recursion form case needs to be fixed, for inlines too
- #jump-f #jump-f-label
- re-introduce #target-label => #target optimization
+ sequences
- dipping 2nmap, 2each
- array sort
- nappend: instead of using push, enlarge the sequence with set-length
then add set the elements with set-nth
- specialized arrays
- recursion is iffy; if the stack at the recursive call doesn't match
up, throw an error
+ kernel:
- reader syntax for arrays, byte arrays, displaced aliens
- out of memory error when printing global namespace
- first time hash/vector is grown, set size to something big
- merge timers with sleeping tasks
- what about tasks and timers between image restarts
- split: return vectors
- specialized arrays
- there is a problem with hashcodes of words and bootstrapping
- delegating generic words with a non-standard picker
- powerpc has weird callstack residue
- instances: do not use make-list
- unions containing tuples do not work properly
- method doc strings
- clean up metaclasses
- vectors: ensure its ok with bignum indices
- code gc
- doc comments of generics
- M: object should not inhibit delegation
- set-path: iterative
- parse-command-line: no unswons of cli args
- >c/c>: vector stack
- tag: move from kernel-internals to kernel
- word: when bootstrapping, 'word' var is not cleared
- search: slow
- investigate if rehashing on startup is really necessary
- vectorize >n, n>, (get)
- mutable strings simplifying string operarations
- 2each, find*, subset are ugly
- map and 2map duplicate logic
+ i/o:
- buffer: instantiating aliens
- faster stream-copy
- reading and writing byte arrays
- unix io: handle \n\r and \n\0
- stream server can hang because of exception handler limitations
- better i/o scheduler
- unify unparse and prettyprint
- utf16, utf8 encoding
- fix i/o on generic x86/ppc unix
- 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
- print parsing words in bold
+ nice to have libraries:

2
actions.xml
View File

@ -64,7 +64,7 @@
FactorPlugin.evalInListener(view,
"\""
+ FactorReader.charsToEscapes(word)
+ "\" apropos.");
+ "\" apropos");
}
</CODE>
</ACTION>

BIN
boot.image.be32
View File

Binary file not shown.

BIN
boot.image.be64
View File

Binary file not shown.

BIN
boot.image.le32
View File

Binary file not shown.

BIN
boot.image.le64
View File

Binary file not shown.

7
contrib/algebra/README.TXT
View File

@ -1,5 +1,6 @@
This is the infix minilanguage created by Daniel Ehrenberg, allowing you to do infix math in Factor. The syntax is simple: all operators are right-associative, and square brackets ('[' and ']') are used for paretheses. The syntax for creating an infix expression is ([ infix code goes here ]). That will leave the expression in the internal s-expression format which is easier to process by the evaluator and the CAS. The CAS subsystem of the infix minilanguage does algebra. Currently, it doesn't do very much, only modular arithmetic, though there may be more by the time you read this. There is also constant folding. The way to evaluate an infix expression is to make a seperate word to evaluate it in. The syntax for this is :| name | args |: body ; . Args are one or more variables that you use in the expression. Their values come from the stack. Variables are effectively substituted in to the expression. To make a new variable, use the syntax VARIABLE: variablename in top level code. The variables included by default are x, y, z, a, b, and c. To make a new operator, just set its arith-1 and/or arith-2 word properties, which should link to a word that is the unary or binary arithmetic version, respectively. To make a new constant, like pi, just set the constant? word property of a word that pushes it to t. When opening the files in this package, open first infix.factor, then algebra.factor, then repl.factor. To close, here's an implementation of the quadratic formula using infix math. This is included in the module.
:| quadratic-formula a b c |:
[ [ - b ] / 2 * a ] +- [ sqrt [ sq b ] - 4 * a * c ] / 2 * a ;
This is the infix minilanguage created by Daniel Ehrenberg, allowing you to do infix math in Factor. The syntax is simple: all infix are right-associative and parentheses may be used. There are also unary operators and operators which take arguments in square brackets seperated by semicolons. Infix operators are the ones that are made of non-alphabetic characters. To make a word that uses infix, the syntax is MATH: functionname[firstarg;secondarg;etc]=value ; Args are one or more variables that you use in the expression. Their values come from the stack. Variables are effectively substituted in to the expression. Any alphabetic string may be used as a variable. To make a new operator, just update the functions hashtable in the infix vocabulary. For more information, see the code or contact the author of this program. To close, here's an implementation of the quadratic formula using infix math. This is included in the module.
MATH: quadratic[a;b;c] =
plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;
If you find any bugs in this or have any questions, please contact me at microdan @ gmail . com, ask LittleDan@irc.freenode.net, or ask irc.freenode.net/#concatenative

55
contrib/algebra/algebra.factor
View File

@ -1,55 +0,0 @@
IN: algebra USING: lists math kernel words namespaces ;
GENERIC: (fold-consts) ( infix -- infix ? )
M: number (fold-consts)
f ;
M: var (fold-consts)
t ;
M: list2 (fold-consts)
2unlist (fold-consts) [
2list t
] [
swap arith-1 word-prop unit call f
] ifte ;
M: list3 (fold-consts)
3unlist >r (fold-consts) r> swapd (fold-consts) >r rot r> or [
3list t
] [
rot arith-2 word-prop unit call f
] ifte ;
: fold-consts ( infix -- infix )
#! Given a mathematical s-expression, perform constant folding,
#! which is doing all the calculations it can do without any
#! variables added.
(fold-consts) drop ;
VARIABLE: modularity
#! This is the variable that stores what mod we're in
GENERIC: (install-mod) ( infix -- infix-with-mod )
: put-mod ( object -- [ mod object modularity ] )
[ \ mod , , modularity , ] make-list ;
M: num/vc (install-mod)
put-mod ;
M: list2 (install-mod)
2unlist (install-mod) 2list put-mod ;
M: list3 (install-mod)
3unlist (install-mod) swap (install-mod) swap 3list put-mod ;
: install-mod ( arglist infix -- new-arglist infix-with-mod)
#! Given an argument list and an infix expression, produce
#! a new arglist and a new infix expression that will evaluate
#! the given one using modular arithmetic.
>r modularity swons r> (install-mod) ;
:| quadratic-formula a b c |:
[ [ - b ] / 2 * a ] +- [ sqrt [ sq b ] - 4 * a * c ] / 2 * a ;

193
contrib/algebra/infix.factor
View File

@ -1,193 +0,0 @@
IN: algebra
USING: kernel lists math namespaces test io words parser
generic errors prettyprint vectors kernel-internals ;
SYMBOL: variable?
#! For word props: will this be a var in an infix expression?
PREDICATE: word var
#! Class of variables
variable? word-prop ;
SYMBOL: constant?
#! Word prop for things like pi and e
PREDICATE: word con
constant? word-prop ;
PREDICATE: cons single
#! Single-element list
cdr not ;
UNION: num/vc number var con ;
PREDICATE: cons list-word
#! List where first element is a word but not a variable
unswons tuck word? and [ var? not ] [ drop f ] ifte ;
PREDICATE: cons list-nvl
#! List where first element is a number, variable, or list
unswons dup num/vc? swap cons? or and ;
UNION: num/con number con ;
GENERIC: infix ( list -- list )
#! Parse an infix expression. This is right associative
#! and everything has equal precendence. The output is
#! an s-expression. Operators can be unary or binary.
M: num/vc infix ;
M: single infix car infix ;
M: list-word infix
uncons infix 2list ;
M: list-nvl infix
unswons infix swap uncons infix swapd 3list ;
: ([
#! Begin a literal infix expression
[ ] ; parsing
: ])
#! End a literal infix expression.
reverse infix swons ; parsing
: VARIABLE:
#! Make a variable, which acts like a symbol
CREATE dup define-symbol t variable? set-word-prop ; parsing
VARIABLE: x
VARIABLE: y
VARIABLE: z
VARIABLE: a
VARIABLE: b
VARIABLE: c
VARIABLE: d
SYMBOL: arith-1
#! Word prop for unary mathematical function
SYMBOL: arith-2
#! Word prop for binary mathematical function
PREDICATE: cons list2
#! List of 2 elements
length 2 = ;
PREDICATE: cons list3
#! List of 3 elements
length 3 = ;
GENERIC: (eval-infix) ( varstuff infix -- quote )
M: num/con (eval-infix)
nip unit \ drop swons ;
: (find) ( counter item list -- index )
dup [
2dup car = [ 2drop ] [ >r >r 1 + r> r> cdr (find) ] ifte
] [
"Undefined variable in infix expression" throw
] ifte ;
: find ( list item -- index )
0 -rot swap (find) ;
M: var (eval-infix)
find [ swap array-nth ] cons ;
: swap-in-infix ( var fix1 fix2 -- [ fix1solved swap fix2solved ] )
>r dupd (eval-infix) swap r> (eval-infix) \ swap swons append ;
M: list3 (eval-infix)
unswons arith-2 word-prop unit -rot 2unlist
swap-in-infix \ dup swons swap append ;
M: list2 (eval-infix)
2unlist swapd (eval-infix) swap arith-1 word-prop add ;
: build-prefix ( num-of-vars -- quote )
#! What needs to be placed in front of the eval-infix quote
[ dup , \ <array> , dup [
2dup - 1 - [ swap set-array-nth ] cons , \ keep ,
] repeat drop ] make-list ;
: eval-infix ( vars infix -- quote )
#! Given a list of variables and an infix expression in s-expression
#! form, build a quotation which takes as many arguments from the
#! datastack as there are elements in the varnames list, builds
#! it into a vector, and calculates the values of the expression with
#! the values filled in.
over length build-prefix -rot (eval-infix) append ;
DEFER: fold-consts
: (| f ; parsing ! delete
: | reverse f ; parsing ! delete
: end-infix ( vars reverse-infix -- code )
infix fold-consts eval-infix ;
: |) reverse end-infix swons \ call swons ; parsing ! delete
: 3keep
#! like keep or 2keep but with 3
-rot >r >r swap r> r> 3dup
>r >r >r >r rot r> swap call r> r> r> ;
: :|
#! :| sq x |: x * x ;
CREATE [
"in-defintion" off
3dup nip "infix-code" set-word-prop
end-infix define-compound
] f "in-definition" on ; parsing
: |:
#! :| sq x |: x * x ;
reverse 3dup nip "infix-args" set-word-prop
swap f ; parsing
: .w/o-line ( obj -- )
[ one-line on 4 swap prettyprint* drop ] with-scope ;
PREDICATE: compound infix-word "infix-code" word-prop ;
M: infix-word see
dup prettyprint-IN:
":| " write dup prettyprint-word " " write
dup "infix-args" word-prop [ prettyprint-word " " write ] each
"|:\n " write
"infix-code" word-prop .w/o-line
" ;" print ;
: (fac) dup 0 = [ drop ] [ dup 1 - >r * r> (fac) ] ifte ;
: fac
#! Factorial
1 swap (fac) ;
: infix-relation
#! Wraps operators like = and > so that if they're given
#! f as either argument, they return f, and they return f if
#! the operation yields f, but if it yields t, it returns the
#! left argument. This way, these types of operations can be
#! composed.
>r 2dup and not [
r> 3drop f
] [
dupd r> call [
drop f
] unless
] ifte ;
! Wrapped operations
: new= [ = ] infix-relation ;
: new> [ > ] infix-relation ;
: new< [ < ] infix-relation ;
: new>= [ >= ] infix-relation ;
: new<= [ <= ] infix-relation ;
: +- ( a b -- a+b a-b )
[ + ] 2keep - ;
: || ;
! Install arithmetic operators into words
[ + - / * ^ and or xor mod +- min gcd max bitand polar> align shift /mod /i /f rect> bitor
bitxor rem || ] [
dup arith-2 set-word-prop
] each
[ [[ = new= ]] [[ > new> ]] [[ < new< ]] [[ >= new>= ]] [[ <= new<= ]] ] [
uncons arith-2 set-word-prop
] each
[ sqrt abs fac sq asin denominator rational? rad>deg exp recip sgn >rect acoth arg fixnum
bitnot sinh acosec acosh acosech complex? ratio? number? >polar number= cis deg>rad >fixnum
cot cos sec cosec tan imaginary coth asech atanh absq >float numerator acot acos atan asec
cosh log bignum? conjugate asinh sin float? real? >bignum tanh sech ] [
dup arith-1 set-word-prop
] each
[ [[ - neg ]] ] [ uncons arith-1 set-word-prop ] each
[ pi i e -i inf -inf pi/2 ] [ t constant? set-word-prop ] each

362
contrib/algebra/parse-k.factor Normal file
View File

@ -0,0 +1,362 @@
IN: infix
USING: sequences kernel io math strings combinators namespaces prettyprint
errors parser generic lists kernel-internals hashtables words vectors ;
! Tokenizer
TUPLE: tok char ;
TUPLE: brackets seq ender ;
SYMBOL: apostrophe
SYMBOL: code #! Source code
SYMBOL: spot #! Current index of string
: take-until ( quot -- parsed-stuff | quot: char -- ? )
#! Take the substring of a string starting at spot
#! from code until the quotation given is true and
#! advance spot to after the substring.
>r spot get code get 2dup r>
skip [ swap subseq ] keep
spot set ;
: parse-blank ( -- )
#! Advance code past any whitespace, including newlines
spot get code get [ blank? not ] skip spot set ;
: not-done? ( -- ? )
#! Return t if spot is not at the end of code
code get length spot get = not ;
: incr-spot ( -- )
#! Increment spot.
spot [ 1 + ] change ;
: parse-var ( -- variable-name )
#! Take a series of letters from code, advancing
#! spot and returning the letters.
[ letter? not ] take-until ;
: parse-num ( -- number )
#! Take a number from code, advancing spot and
#! returning the number.
[ "0123456789." member? not ] take-until string>number ;
: get-token ( -- char )
spot get code get nth ;
DEFER: token
: next-token ( list -- list )
#! Take one token from code and return it
parse-blank not-done? [
get-token token
] when ;
: token
{
{ [ dup letter? ] [ drop parse-var swons ] }
{ [ dup "0123456789." member? ] [ drop parse-num swons ] }
{ [ dup ";!@#$%^&*?/|\\=+_-~" member? ] [ <tok> swons incr-spot ] }
{ [ dup "([{" member? ] [ drop f incr-spot ] }
{ [ dup ")]}" member? ] [ <brackets> swons incr-spot ] }
{ [ dup CHAR: ' = ] [ drop apostrophe swons incr-spot ] }
{ [ t ] [ "Bad character " swap ch>string append throw ] }
} cond next-token ;
: tokenize ( string -- tokens )
#! Tokenize a string, returning a list of tokens
[
code set 0 spot set
f next-token reverse
] with-scope ;
! Parser
TUPLE: apply func args ;
#! Function application
C: apply
>r [ ] subset r>
[ set-apply-args ] keep
[ set-apply-func ] keep ;
UNION: value number string ;
: semicolon ( -- semicolon )
#! The semicolon token
<< tok f CHAR: ; >> ;
: nest-apply ( [ ast ] -- apply )
unswons unit swap [
swap <apply> unit
] each car ;
GENERIC: parse-token ( ast tokens token -- ast tokens )
#! Take one or more tokens
DEFER: parse-tokens
: semicolon-split ( list -- [ ast ] )
reverse semicolon unit split [ parse-tokens ] map ;
M: value parse-token
swapd swons swap ;
M: brackets parse-token
swapd dup brackets-seq swap brackets-ender {
{ [ dup CHAR: ] = ] [ drop semicolon-split >r unswons r> <apply> swons ] }
{ [ dup CHAR: } = ] [ drop semicolon-split >vector swons ] }
{ [ CHAR: ) = ] [ reverse parse-tokens swons ] }
} cond swap ;
M: object tok-char drop -1 ; ! Hack!
GENERIC: tok>string ( token/string -- string )
M: tok tok>string
tok-char ch>string ;
M: string tok>string ;
: binary-op ( ast tokens token -- ast )
>r >r unswons r> parse-tokens 2list r>
tok>string swap <apply> swons ;
: unary-op ( ast tokens token -- ast )
tok>string -rot nip
parse-tokens unit <apply> unit ;
: null-op ( ast tokens token -- ast )
nip tok-char ch>string swons ;
M: tok parse-token
over [
pick [
binary-op
] [
unary-op
] ifte
] [
null-op
] ifte f ;
( ast tokens token -- ast tokens )
M: symbol parse-token ! apostrophe
drop unswons >r parse-tokens >r unswons r> 2list r>
unit parse-tokens swap <apply> swons f ;
: (parse-tokens) ( ast tokens -- ast )
dup [
unswons parse-token (parse-tokens)
] [
drop
] ifte ;
: parse-tokens ( tokens -- ast )
#! Convert a list of tokens into an AST
f swap (parse-tokens) nest-apply ;
: parse-full ( string -- ast )
#! Convert a string into an AST
tokenize parse-tokens ;
! Compiler
GENERIC: compile-ast ( vars ast -- quot )
M: string compile-ast ! variables
swap index dup -1 = [
"Variable not found" throw
] [
[ swap array-nth ] cons
] ifte ;
: replace-with ( data -- [ drop data ] )
\ drop swap 2list ;
UNION: comp-literal number general-list ;
M: comp-literal compile-ast ! literal numbers
replace-with nip ;
: accumulator ( vars { asts } quot -- quot )
-rot [
[
\ dup ,
compile-ast %
dup %
] each-with
] [ ] make nip ;
M: vector compile-ast ! literal vectors
dup [ number? ] all? [
replace-with nip
] [
[ , ] accumulator [ { } make nip ] cons
] ifte ;
: infix-relation
#! Wraps operators like = and > so that if they're given
#! f as either argument, they return f, and they return f if
#! the operation yields f, but if it yields t, it returns the
#! left argument. This way, these types of operations can be
#! composed.
>r 2dup and not [
r> 3drop f
] [
dupd r> call [
drop f
] unless
] ifte ;
: functions
#! Regular functions
#! Gives quotation applicable to stack
{{
[ [[ "+" 2 ]] + ]
[ [[ "-" 2 ]] - ]
[ [[ ">" 2 ]] [ > ] infix-relation ]
[ [[ "<" 2 ]] [ < ] infix-relation ]
[ [[ "=" 2 ]] [ = ] infix-relation ]
[ [[ "-" 1 ]] neg ]
[ [[ "~" 1 ]] not ]
[ [[ "&" 2 ]] and ]
[ [[ "|" 2 ]] or ]
[ [[ "&" 1 ]] t [ and ] reduce ]
[ [[ "|" 1 ]] f [ or ] reduce ]
[ [[ "*" 2 ]] * ]
[ [[ "ln" 1 ]] log ]
[ [[ "plusmin" 2 ]] [ + ] 2keep - ]
[ [[ "@" 2 ]] swap nth ]
[ [[ "sqrt" 1 ]] sqrt ]
[ [[ "/" 2 ]] / ]
[ [[ "^" 2 ]] ^ ]
[ [[ "#" 1 ]] length ]
[ [[ "eq" 2 ]] eq? ]
[ [[ "*" 1 ]] first ]
[ [[ "+" 1 ]] flip ]
[ [[ "\\" 1 ]] <reversed> ]
[ [[ "sin" 1 ]] sin ]
[ [[ "cos" 1 ]] cos ]
[ [[ "tan" 1 ]] tan ]
[ [[ "max" 2 ]] max ]
[ [[ "min" 2 ]] min ]
[ [[ "," 2 ]] append ]
[ [[ "," 1 ]] concat ]
[ [[ "sn" 3 ]] -rot set-nth ]
[ [[ "prod" 1 ]] product ]
[ [[ "vec" 1 ]] >vector ]
}} ;
: drc ( list -- list )
#! all of list except last element (backwards cdr)
dup cdr [
uncons drc cons
] [
drop f
] ifte ;
: map-with-left ( seq object quot -- seq )
[ swapd call ] cons swapd map-with ; inline
: high-functions
#! Higher-order functions
#! Gives quotation applicable to quotation and rest of stack
{{
[ [[ "!" 2 ]] 2map ]
[ [[ "!" 1 ]] map ]
[ [[ ">" 2 ]] map-with ]
[ [[ "<" 2 ]] map-with-left ]
[ [[ "^" 1 ]] all? ]
[ [[ "~" 1 ]] call not ]
[ [[ "~" 2 ]] call not ]
[ [[ "/" 2 ]] swapd reduce ]
[ [[ "\\" 2 ]] swapd accumulate ]
}} ;
: get-hash ( key table -- value )
#! like hash but throws exception if f
dupd hash [ nip ] [
[ "Key not found " write . ] string-out throw
] ifte* ;
: >apply< ( apply -- func args )
dup apply-func swap apply-args ;
: make-apply ( arity apply/string -- quot )
dup string? [
swons functions get-hash
] [
>apply< car >r over r> make-apply
-rot swons high-functions get-hash cons
] ifte ;
: get-function ( apply -- quot )
>apply< length swap make-apply ;
M: apply compile-ast ! function application
[ apply-args [ swap ] accumulator [ drop ] append ] keep
get-function append ;
: push-list ( list item -- list )
unit append ;
: parse-comp ( args string -- quot )
#! Compile a string into a quotation w/o prologue
parse-full compile-ast ;
: prologue ( args -- quot )
#! Build the prolog for a function
[
length dup , \ <array> ,
[ 1 - ] keep [
2dup - [ swap set-array-nth ] cons , \ keep ,
] repeat drop
] [ ] make ;
: ast>quot ( args ast -- quot )
over prologue -rot compile-ast append ;
: define-math ( seq -- )
" " join
dup parse-full apply-args uncons car swap
>apply< >r create-in r>
[ "math-args" set-word-prop ] 2keep
>r tuck >r >r swap "code" set-word-prop r> r> r>
rot ast>quot define-compound ;
: MATH:
#! MATH: sq[x]=x*x ;
"in-definition" on
string-mode on
[
string-mode off define-math
] f ; parsing
: TEST-MATH:
#! Executes and prints the result of a math
#! expression at parsetime
string-mode on [
" " join string-mode off parse-full
f swap ast>quot call .
] f ; parsing
! PREDICATE: compound infix-word "code" word-prop ;
! M: infix-word definer
! drop POSTPONE: MATH: ;
! M: infix-word class.
! "code" word-prop write " ;" print ;
!
! Redefine compound to not include infix words so see works
! IN: words
! USING: kernel words parse-k ;
!
! PREDICATE: word compound
! dup word-primitive 1 = swap infix-word? not and ;
MATH: quadratic[a;b;c] =
plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;

9
contrib/algebra/repl.factor
View File

@ -1,9 +0,0 @@
IN: algebra USING: prettyprint io kernel parser ;
: algebra-repl ( -- )
"ok " write flush
read-line dup "exit" = [
terpri "bye" print
] [
parse infix f swap eval-infix call . algebra-repl
] ifte ;

187
contrib/concurrency/concurrency-examples.factor Normal file
View File

@ -0,0 +1,187 @@
! Copyright (C) 2005 Chris Double. All Rights Reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! Examples of using the concurrency library.
IN: concurrency-examples
USING: concurrency kernel io lists threads math sequences namespaces unparser prettyprint errors dlists ;
: (logger) ( mailbox -- )
#! Using the given mailbox, start a thread which
#! logs messages put into the box.
dup mailbox-get print (logger) ;
: logger ( -- mailbox )
#! Start a logging thread, which will log messages to the
#! console that are put in the returned mailbox.
make-mailbox dup [ (logger) ] cons in-thread ;
: (pong-server0) ( -- )
receive uncons "ping" = [
"pong" swap send (pong-server0)
] [
"Pong server shutting down" swap send
] ifte ;
: pong-server0 ( -- process)
[ (pong-server0) ] spawn ;
TUPLE: ping-message from ;
TUPLE: shutdown-message from ;
GENERIC: handle-message
M: ping-message handle-message ( message -- bool )
ping-message-from "pong" swap send t ;
M: shutdown-message handle-message ( message -- bool )
shutdown-message-from "Pong server shutdown commenced" swap send f ;
: (pong-server1) ( -- )
"pong-server1 waiting for message..." print
receive handle-message [ (pong-server1) ] when ;
: pong-server1 ( -- process )
[
(pong-server1)
"pong-server1 exiting..." print
] spawn ;
TUPLE: echo-message from text ;
M: echo-message handle-message ( message -- bool )
dup echo-message-text swap echo-message-from send t ;
GENERIC: handle-message2
PREDICATE: tagged-message ping-message2 ( obj -- ? ) tagged-message-data "ping" = ;
PREDICATE: tagged-message shutdown-message2 ( obj -- ? ) tagged-message-data "shutdown" = ;
M: ping-message2 handle-message2 ( message -- bool )
"pong" reply t ;
M: shutdown-message2 handle-message2 ( message -- bool )
"Pong server shutdown commenced" reply f ;
: (pong-server2) ( -- )
"pong-server2 waiting for message..." print
receive handle-message2 [ (pong-server2) ] when ;
: pong-server2 ( -- process )
[
(pong-server2)
"pong-server2 exiting..." print
] spawn ;
: pong-server3 ( -- process )
[ handle-message2 ] spawn-server ;
GENERIC: handle-rpc-message
GENERIC: run-rpc-command
TUPLE: rpc-command op args ;
PREDICATE: rpc-command add-command ( msg -- bool )
rpc-command-op "add" = ;
PREDICATE: rpc-command product-command ( msg -- bool )
rpc-command-op "product" = ;
PREDICATE: rpc-command shutdown-command ( msg -- bool )
rpc-command-op "shutdown" = ;
PREDICATE: rpc-command crash-command ( msg -- bool )
rpc-command-op "crash" = ;
M: tagged-message handle-rpc-message ( message -- bool )
dup tagged-message-data run-rpc-command -rot reply not ;
M: add-command run-rpc-command ( command -- shutdown? result )
rpc-command-args sum f ;
M: product-command run-rpc-command ( command -- shutdown? result )
rpc-command-args product f ;
M: shutdown-command run-rpc-command ( command -- shutdown? result )
drop t t ;
M: crash-command run-rpc-command ( command -- shutdown? result )
drop 1 0 / f ;
: fragile-rpc-server ( -- process )
[ handle-rpc-message ] spawn-server ;
: (robust-rpc-server) ( worker -- )
[
receive over send
] [
[
"Worker died, Starting a new worker" print
drop [ handle-rpc-message ] spawn-linked-server
] when
] catch
(robust-rpc-server) ;
: robust-rpc-server ( -- process )
[
[ handle-rpc-message ] spawn-linked-server
(robust-rpc-server)
] spawn ;
: test-add ( process -- )
[
"add" [ 1 2 3 ] <rpc-command> swap send-synchronous .
] cons spawn drop ;
: test-crash ( process -- )
[
"crash" f <rpc-command> swap send-synchronous .
] cons spawn drop ;
! ******************************
! Experimental code below
! ******************************
USE: gadgets
USE: gadgets-labels
USE: gadgets-presentations
USE: generic
TUPLE: promised-label promise ;
C: promised-label ( promise -- promised-label )
<gadget> over set-delegate [ set-promised-label-promise ] keep
[ [ dup promised-label-promise ?promise drop relayout ] cons spawn drop ] keep ;
: promised-label-text ( promised-label -- text )
promised-label-promise dup promise-fulfilled? [
?promise
] [
drop "Unfulfilled Promise"
] ifte ;
M: promised-label pref-dim ( promised-label - dim )
dup promised-label-text label-size ;
M: promised-label draw-gadget* ( promised-label -- )
dup delegate draw-gadget*
dup promised-label-text draw-string ;
: fib ( n -- n )
yield dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] ifte ;
: test-promise-ui ( -- )
<promise> dup <promised-label> gadget. [ 12 fib unparse swap fulfill ] cons spawn drop ;

182
contrib/concurrency/concurrency-tests.factor Normal file
View File

@ -0,0 +1,182 @@
! Copyright (C) 2005 Chris Double. All Rights Reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
IN: concurrency
USING: kernel concurrency concurrency-examples threads vectors
sequences lists namespaces test errors dlists strings
math words ;
[ "junk" ] [
<dlist>
5 over dlist-push-end
"junk" over dlist-push-end
20 over dlist-push-end
[ string? ] swap dlist-pop?
] unit-test
[ 5 20 ] [
<dlist>
5 over dlist-push-end
"junk" over dlist-push-end
20 over dlist-push-end
[ string? ] over dlist-pop? drop
[ ] dlist-each
] unit-test
[ "junk" ] [
<dlist>
5 over dlist-push-end
"junk" over dlist-push-end
20 over dlist-push-end
[ integer? ] over dlist-pop? drop
[ integer? ] over dlist-pop? drop
[ ] dlist-each
] unit-test
[ t ] [
<dlist>
5 over dlist-push-end
"junk" over dlist-push-end
20 over dlist-push-end
[ string? ] swap dlist-pred?
] unit-test
[ t ] [
<dlist>
5 over dlist-push-end
"junk" over dlist-push-end
20 over dlist-push-end
[ integer? ] swap dlist-pred?
] unit-test
[ f ] [
<dlist>
5 over dlist-push-end
"junk" over dlist-push-end
20 over dlist-push-end
[ string? ] over dlist-pop? drop
[ string? ] swap dlist-pred?
] unit-test
[ { 1 2 3 } ] [
0 <vector>
make-mailbox
2dup [ mailbox-get swap push ] cons cons in-thread
2dup [ mailbox-get swap push ] cons cons in-thread
2dup [ mailbox-get swap push ] cons cons in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ { 1 2 3 } ] [
0 <vector>
make-mailbox
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ { 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector>
make-mailbox
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
2dup [ [ integer? ] swap mailbox-get? swap push ] cons cons in-thread
2dup [ [ string? ] swap mailbox-get? swap push ] cons cons in-thread
2dup [ [ string? ] swap mailbox-get? swap push ] cons cons in-thread
1 over mailbox-put
"junk" over mailbox-put
[ 456 ] over mailbox-put
3 over mailbox-put
"junk2" over mailbox-put
mailbox-get
] unit-test
[ f ] [ 1 2 gensym <tagged-message> gensym tag-match? ] unit-test
[ f ] [ "junk" gensym tag-match? ] unit-test
[ t ] [ 1 2 gensym <tagged-message> dup tagged-message-tag tag-match? ] unit-test
[ "test" ] [
[ self ] "test" with-process
] unit-test
[ "received" ] [
[
receive dup tagged-message? [
"received" reply
] [
drop f
] ifte
] spawn
"sent" swap send-synchronous
] unit-test
[ 1 3 2 ] [
1 self send
2 self send
3 self send
receive
[ 2 mod 0 = not ] receive-if
receive
] unit-test
[ "pong" "Pong server shutdown commenced" ] [
pong-server3 "ping" over send-synchronous
swap "shutdown" swap send-synchronous
] unit-test
[ t 60 120 ] [
fragile-rpc-server
<< rpc-command f "product" [ 4 5 6 ] >> over send-synchronous >r
<< rpc-command f "add" [ 10 20 30 ] >> over send-synchronous >r
<< rpc-command f "shutdown" [ ] >> swap send-synchronous
r> r>
] unit-test
[ "crash" ] [
[
[
"crash" throw
] spawn-link drop
receive
]
[
] catch
] unit-test
[ 50 ] [
[ 50 ] future ?future
] unit-test
[ { 50 50 50 } ] [
0 <vector>
<promise>
2dup [ ?promise swap push ] cons cons spawn drop
2dup [ ?promise swap push ] cons cons spawn drop
2dup [ ?promise swap push ] cons cons spawn drop
50 swap fulfill
] unit-test

436
contrib/concurrency/concurrency.factor Normal file
View File

@ -0,0 +1,436 @@
! Copyright (C) 2005 Chris Double. All Rights Reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! Concurrency library for Factor based on Erlang/Termite style
! concurrency.
USING: kernel lists generic threads io namespaces errors words
math sequences hashtables unparser strings vectors dlists ;
IN: concurrency
#! Debug
USE: prettyprint
: (dlist-pop?) ( dlist pred dnode -- obj | f )
[
[ dlist-node-data swap call ] 2keep rot [
swapd [ (dlist-unlink) ] keep dlist-node-data nip
] [
dlist-node-next (dlist-pop?)
] ifte
] [
2drop f
] ifte* ;
: dlist-pop? ( pred dlist -- obj | f )
#! Return first item in the dlist that when passed to the
#! predicate quotation, true is left on the stack. The
#! item is removed from the dlist. The 'pred' quotation
#! must have stack effect ( obj -- bool ).
#! TODO: needs a better name and should be moved to dlists.
dup dlist-first swapd (dlist-pop?) ;
: (dlist-pred?) ( pred dnode -- bool )
[
[ dlist-node-data swap call ] 2keep rot [
2drop t
] [
dlist-node-next (dlist-pred?)
] ifte
] [
drop f
] ifte* ;
: dlist-pred? ( pred dlist -- obj | f )
#! Return true if any item in the dlist that when passed to the
#! predicate quotation, true is left on the stack.
#! The 'pred' quotation must have stack effect ( obj -- bool ).
#! TODO: needs a better name and should be moved to dlists.
dlist-first (dlist-pred?) ;
TUPLE: mailbox threads data ;
: make-mailbox ( -- mailbox )
#! A mailbox is an object that can be used for safe thread
#! communication. Items can be put in the mailbox and retrieved in a
#! FIFO order. If the mailbox is empty when a get operation is
#! performed then the thread will block until another thread places
#! something in the mailbox. If multiple threads are waiting on the
#! same mailbox, only one of the waiting threads will be unblocked
#! to process the get operation.
0 <vector> <dlist> <mailbox> ;
: mailbox-empty? ( mailbox -- bool )
#! Return true if the mailbox is empty
mailbox-data dlist-empty? ;
: mailbox-put ( obj mailbox -- )
#! Put the object into the mailbox. Any threads that have
#! a blocking get on the mailbox are resumed.
[ mailbox-data dlist-push-end ] keep
[ mailbox-threads ] keep 0 <vector> swap set-mailbox-threads
[ schedule-thread ] each yield ;
: (mailbox-block-unless-pred) ( pred mailbox -- pred mailbox )
#! Block the thread if there are not items in the mailbox
#! that return true when the predicate is called with the item
#! on the stack. The predicate must have stack effect ( X -- bool ).
dup mailbox-data pick swap dlist-pred? [
[
swap mailbox-threads push stop
] callcc0
(mailbox-block-unless-pred)
] unless ;
: (mailbox-block-if-empty) ( mailbox -- mailbox )
#! Block the thread if the mailbox is empty
dup mailbox-empty? [
[
swap mailbox-threads push stop
] callcc0
(mailbox-block-if-empty)
] when ;
: mailbox-get ( mailbox -- obj )
#! Get the first item put into the mailbox. If it is
#! empty the thread blocks until an item is put into it.
#! The thread then resumes, leaving the item on the stack.
(mailbox-block-if-empty)
mailbox-data dlist-pop-front ;
: mailbox-get? ( pred mailbox -- obj )
#! Get the first item in the mailbox which satisfies the predicate.
#! 'pred' will be called with each item on the stack. When pred returns
#! true that item will be returned. If nothing in the mailbox
#! satisfies the predicate then the thread will block until something does.
(mailbox-block-unless-pred)
mailbox-data dlist-pop? ;
#! Processes run on nodes identified by a hostname and port.
TUPLE: node hostname port ;
: localnode ( -- node )
#! Return the default node on the localhost
"localhost" 9000 <node> ;
#! Processes run in nodes. Each process has a mailbox that is
#! used for receiving messages sent to that process.
TUPLE: process node links pid mailbox ;
: make-process ( -- process )
#! Return a process set to run on the local node. A process is
#! similar to a thread but can send and receive messages to and
#! from other processes. It may also be linked to other processes so
#! that it receives a message if that process terminates.
localnode [ ] gensym unparse make-mailbox <process> ;
: make-linked-process ( process -- process )
#! Return a process set to run on the local node. That process is
#! linked to the process on the stack. It will receive a message if
#! that process terminates.
localnode swap unit gensym unparse make-mailbox <process> ;
#! The 'self-process' variable holds the currently executing process.
SYMBOL: self-process
: self ( -- process )
#! Returns the contents of the 'self-process' variables which
#! is the process object for the current process.
self-process get ;
: init-main-process ( -- )
#! Setup the main process.
make-process self-process set ;
init-main-process
: with-process ( quot process -- )
#! Calls the quotation with 'self' set
#! to the given process.
[
self-process set
] make-hash
swap bind ;
: spawn ( quot -- process )
#! Start a process which runs the given quotation.
[ in-thread ] make-process [ with-process ] over slip ;
TUPLE: linked-exception error ;
: send ( message process -- )
#! Send the message to the process by placing it in the
#! processes mailbox.
process-mailbox mailbox-put ;
: receive ( -- message )
#! Return a message from the current processes mailbox.
#! If the box is empty, suspend the process until something
#! is placed in the box.
self process-mailbox mailbox-get dup linked-exception? [
linked-exception-error throw
] when ;
: receive-if ( pred -- message )
#! Return the first message frmo the current processes mailbox
#! that satisfies the predicate. To satisfy the predicate, 'pred'
#! is called with the item on the stack and the predicate should leave
#! a boolean indicating whether it was satisfied or not. The predicate
#! must have stack effect ( X -- bool ). If nothing in the mailbox
#! satisfies the predicate then the process will block until something does.
self process-mailbox mailbox-get? dup linked-exception? [
linked-exception-error throw
] when ;
: rethrow-linked ( error -- )
#! Rethrow the error to the linked process
self process-links [ over <linked-exception> swap send ] each drop ;
: spawn-link ( quot -- process )
#! Same as spawn but if the quotation throws an error that
#! is uncaught, that error gets propogated to the process
#! performing the spawn-link.
[ [ [ rethrow-linked ] when* ] catch ] cons
[ in-thread ] self make-linked-process [ with-process ] over slip ;
#! A common operation is to send a message to a process containing
#! the sending process so the receiver can send a reply back. A 'tag'
#! is also sent so that the sender can match the reply with the
#! original request. The 'tagged-message' tuple ecapsulates this.
TUPLE: tagged-message data from tag ;
: >tagged-message< ( tagged-message -- data from tag )
#! Explode a message tuple.
dup tagged-message-data swap
dup tagged-message-from swap
tagged-message-tag ;
: (recv) ( msg form -- )
#! Process a form with the following format:
#! [ pred match-quot ]
#! 'pred' is a word that has stack effect ( msg -- bool ). It is
#! executed with the message on the stack. It should return a
#! boolean if it is a message this form should process.
#! 'match-quot' is a quotation with stack effect ( msg -- ). It
#! will be called with the message on the top of the stack if
#! the 'pred' word returned true.
uncons >r dupd execute [
r> car call
] [
r> 2drop
] ifte ;
: recv ( forms -- )
#! Get a message from the processes mailbox. Compare it against the
#! forms to run a quotation if it matches the given message. 'forms'
#! is a list of quotations in the following format:
#! [ pred match-quot ]
#! 'pred' is a word that has stack effect ( msg -- bool ). It is
#! executed with the message on the stack. It should return a
#! boolean if it is a message this form should process.
#! 'match-quot' is a quotation with stack effect ( msg -- ). It
#! will be called with the message on the top of the stack if
#! the 'pred' word returned true.
#! Each form in the list will be matched against the message,
#! even if a prior match succeeded. This means multiple quotations
#! may be run against the message.
receive swap [ dupd (recv) ] each drop ;
: tag-message ( message -- tagged-message )
#! Given a message, wrap it with a tagged message.
self gensym <tagged-message> ;
: tag-match? ( message tag -- bool )
#! Return true if the message is a tagged message and
#! its tag matches the given tag.
swap dup tagged-message? [
tagged-message-tag =
] [
2drop f
] ifte ;
: send-synchronous ( message process -- reply )
#! Sends a message to the process using the 'message'
#! protocol and waits for a reply to that message. The reply
#! is matched up with the request by generating a message tag
#! which should be sent back with the reply.
>r tag-message [ tagged-message-tag ] keep r> send
unit [ car tag-match? ] cons receive-if tagged-message-data ;
: reply ( tagged-message message -- )
#! Replies to the tagged-message which should have been a result of a
#! 'send-synchronous' call. It will send 'message' back to the process
#! that originally sent the tagged message, and will have the same tag
#! as that in 'tagged-message'.
swap >tagged-message< rot drop ( message from tag )
swap >r >r self r> <tagged-message> r> send ;
: forever ( quot -- )
#! Loops forever executing the quotation.
dup >r call r> forever ;
SYMBOL: quit-cc
: (spawn-server) ( quot -- )
#! Receive a message, and run 'quot' on it. If 'quot'
#! returns true, start again, otherwise exit loop.
#! The quotation should have stack effect ( message -- bool ).
"Waiting for message in server: " write self process-pid print
receive over call [ (spawn-server) ] when ;
: spawn-server ( quot -- process )
#! Spawn a server that receives messages, calling the
#! quotation on the message. If the quotation returns false
#! the spawned process exits. If it returns true, the process
#! starts from the beginning again. The quotation should have
#! stack effect ( message -- bool ).
[
(spawn-server)
"Exiting process: " write self process-pid print
] cons spawn ;
: spawn-linked-server ( quot -- process )
#! Similar to 'spawn-server' but the parent process will be linked
#! to the child.
[
(spawn-server)
"Exiting process: " write self process-pid print
] cons spawn-link ;
: send-reply ( message pred quot -- )
#! The intent of this word is to provde an easy way to
#! check the data contained in a message, process it, and
#! return a result to the original sender.
#! Given a message tuple, call 'pred' given the
#! message data from that tuple on the top of the stack.
#! 'pred' should have stack effect ( data -- boolean ).
#! If 'pred' returns true, call 'quot' with the message
#! data from the message tuple on the stack. 'quot' has
#! stack effect ( data -- result ).
#! The result of that call will be sent back to the
#! messages original caller with the same tag as the
#! original message.
>r >r >tagged-message< rot ( from tag data r: quot pred )
dup r> call [ ( from tag data r: quot )
r> call ( from tag result )
self ( from tag result self )
rot ( from self tag result )
<tagged-message> swap send
] [
r> drop 3drop
] ifte ;
: maybe-send-reply ( message pred quot -- )
#! Same as !result but if false is returned from
#! quot then nothing is sent back to the caller.
>r >r >tagged-message< rot ( from tag data r: quot pred )
dup r> call [ ( from tag data r: quot )
r> call ( from tag result )
[
self ( from tag result self )
rot ( from self tag result )
<tagged-message> swap send
] [
2drop
] ifte*
] [
r> drop 3drop
] ifte ;
: server-cc ( -- cc | process)
#! Captures the current continuation and returns the value.
#! If that CC is called with a process on the stack it will
#! set 'self' for the current process to it. Otherwise it will
#! return the value. This allows capturing a continuation in a server,
#! and jumping back into it from a spawn and keeping the 'self'
#! variable correct. It's a workaround until I can find out how to
#! stop 'self' from being clobbered back to its old value.
[ ] callcc1 dup process? [ self-process set f ] when ;
: call-server-cc ( server-cc -- )
#! Calls the server continuation passing the current 'self'
#! so the server continuation gets its new self updated.
self swap call ;
: future ( quot -- future )
#! Spawn a process to call the quotation and immediately return
#! a 'future' on the stack. The future can later be queried with
#! ?future. If the quotation has completed the result will be returned.
#! If not, the process will block until the quotation completes.
#! 'quot' must have stack effect ( -- X ).
[ call self send ] cons spawn ;
: ?future ( future -- result )
#! Block the process until the future has completed and then place the
#! result on the stack. Return the result immediately if the future has completed.
process-mailbox mailbox-get ;
TUPLE: promise fulfilled? value processes ;
C: promise ( -- <promise> )
[ 0 <vector> swap set-promise-processes ] keep ;
: fulfill ( value promise -- )
#! Set the future of the promise to the given value. Threads
#! blocking on the promise will then be released.
dup promise-fulfilled? [
[ set-promise-value ] keep
[ t swap set-promise-fulfilled? ] keep
[ promise-processes ] keep 0 <vector> swap set-promise-processes
[ schedule-thread ] each yield
] unless ;
: (maybe-block-promise) ( promise -- promise )
#! Block the process if the promise is unfulfilled. This is different from
#! (mailbox-block-if-empty) in that when a promise is fulfilled, all threads
#! need to be resumed, rather than just one.
dup promise-fulfilled? [
[
swap promise-processes push stop
] callcc0
] unless ;
: ?promise ( promise -- result )
(maybe-block-promise) promise-value ;
! ******************************
! Experimental code below
! ******************************
SYMBOL: lazy-quot
: lazy ( quot -- lazy )
#! Spawn a process that immediately blocks and return it.
#! When '?lazy' is called on the returned process, call the quotation
#! and return the result. The quotation must have stack effect ( -- X ).
[
[
lazy-quot set
[
[ tagged-message? [ [ drop t ] [ get call ] send-reply ] ]
] recv
] with-scope
] cons spawn ;
: ?lazy ( lazy -- result )
#! Given a process spawned using 'lazy', evaluate it and return the result.
lazy-quot swap send-synchronous ;

549
contrib/concurrency/concurrency.html Normal file
View File

@ -0,0 +1,549 @@
<html>
<head>
<title>Factor Concurrency Library</title>
<link rel="stylesheet" type="text/css" href="style.css">
</head>
<body>
<h1>Factor Concurrency Library</h1>
<p class="note">The concurrency library here is based upon the style
of concurrency used in systems like Erlang and Termite. It is
currently at a very early stage and only supports concurrent
processes within a single Factor image. The interface is very likely to
change so it is quite experimental at this stage. The ability to
have distributed processes is planned.</p>
<h1>Overview</h1>
<p>A concurrency oriented program is one in which multiple processes
run simultaneously in a single Factor image. The processes can
communicate with each other by asynchronous message sends. Although
processes can share data via Factor's mutable data structures it is
not recommended as the use of shared state concurrency is often a
cause of problems.</p>
<h1>Loading</h1>
<p>The quickest way to get up and running with this library is to
change to the 'concurrency' directory and run Factor. Then execute the
following commands:</p>
<pre class="code">
"load.factor" run-file
USE: concurrency
USE: concurrency-examples
</pre>
<h1>Processes</h1>
<p>A process is basically a thread with a message queue. Other
processes can place items on this queue by sending the process a
message. A process can check its queue for messages, blocking if none
are pending, and process them as they are queued.</p>
<p>Factor processes are very lightweight. Each process can take as
little as 900 bytes of memory. This library has been tested running
hundreds of thousands of simple processes.</p>
<p>The messages that are sent from process to process are any Factor
value. Factor tuples are ideal for this sort of thing as you can send
a tuple to a process and the predicate dispatch mechanism can be used
to perform actions depending on what the type of the tuple is.</p>
<p>Processes are usually created using the 'spawn' word:</p>
<pre class="code">
IN: concurrency
spawn ( quot -- process )
</pre>
<p>This word takes a quotation on the stack and starts a process that
will execute that quotation asynchronously. When the quotation
completes the process will die. 'spawn' leaves on the stack the
process object that was started. This object can be used to send
messages to the process using the 'send' word:</p>
<pre class="code">
IN: concurrency
send ( message process -- )
</pre>
<p>'send' will return immediately after placing the message in the
target processes message queue. A process can get a message from its
queue using the 'receive' word:</p>
<pre class="code">
IN: concurrency
receive ( -- message )
</pre>
<p>This will get the most recent message
and leave it on the stack. If there are no messages in the queue the
process will 'block' until a message is available. When a process is
blocked it takes no CPU time at all.</p>
<pre class="code">
[ receive print ] spawn
"Hello Process!" swap send
</pre>
<p>This example spawns a process that first blocks, waiting to receive
a message. When a message is received, the 'receive' call returns
leaving it on the stack. It then prints the message and exits. 'spawn'
left the process on the stack so it's available to send the 'Hello
Process!' message to it. Immediately after the 'send' you should see
'Hello Process!' printed on the console.</p>
<p>It is also possible to selectively retrieve messages from the
message queue. The 'receive-if' word takes a predicate quotation on the stack
and returns the first message in the queue that satisfies the
predicate. If no items satisfy the predicate then the process is
blocked until a message is received that does.
</p>
<pre class="code">
: odd? ( n -- ? )
2 mod 1 = ;
<span class="highlite">1 self send
2 self send
3 self send</span>
<span class="highlite">receive .</span>
=> 1
<span class="highlite">[ odd? ] receive-if .</span>
=> 3
<span class="highlite">receive .</span>
=> 2
</pre>
<h2>Self</h2>
<p>A process can get access to its own process object using the 'self'
word so it can pass it to other processes. This allows the other processes to send
messages back. A simple example of using this gets the current
processes 'self' and spawns a process which sends a message to it. We
then receive the message from the original process</p>
<pre class="code">
<span class="highlite">self .s</span>
=> &lt;&lt; process ... >>
<span class="highlite">[ "Hello!" swap send ] cons spawn drop receive .</span>
=> "Hello"
</pre>
<h1>Servers</h1>
<p>A common idiom is to create 'server' processes that act on messages
that are sent to it. These follow a basic pattern of blocking until a
message is received, processing that message then looping back to
blocking for a message.</p>
<p>The following example shows a very simple server that expects a
cons cell as its message. The 'car' of the cons should be the senders
process object. If the 'cdr' is 'ping' then the server sends 'pong'
back to the caller. If the 'cdr' is anything else then the server
exits:</p>
<pre class="code">
: (pong-server0) ( -- )
receive uncons "ping" = [
"pong" swap send (pong-server0)
] [
"Pong server shutting down" swap send
] ifte ;
: pong-server0 ( -- process)
[ (pong-server0) ] spawn ;
<span class="highlite">pong-server0</span>
<span class="highlite">self "ping" cons over send receive .</span>
=> "pong"
<span class="highlite">self "ping" cons over send receive .</span>
=> "pong"
<span class="highlite">self "shutdown" cons over send receive .</span>
=> "Pong server shutting down"
</pre>
<p>Handling the deconstructing of messages and dispatching based on
the message can be a bit of a chore. Especially in servers that take a
number of different messages. One approach to factor this code out,
and reduce the amount of stack juggling required, is to use tuples as
messages. This allows using the generic dispatch mechanism. The
following example implements the pong server but using tuples as
messages:</p>
<pre class="code">
TUPLE: ping-message from ;
TUPLE: shutdown-message from ;
GENERIC: handle-message
M: ping-message handle-message ( message -- bool )
ping-message-from "pong" swap send t ;
M: shutdown-message handle-message ( message -- bool )
shutdown-message-from "Pong server shutdown commenced" swap send f ;
: (pong-server1) ( -- )
"pong-server1 waiting for message..." print
receive handle-message [ (pong-server1) ] when ;
: pong-server1 ( -- process )
[
(pong-server1)
"pong-server1 exiting..." print
] spawn ;
</pre>
<p>Two tuples are created for a 'ping' and 'shutdown' message. Each
has a 'from' slot which holds the process of the sender. The server
loop, in '(pong-server1)', calls a generic method called
'handle-message'. This has signature ( message -- bool ). These
methods return a boolean.
True means continue the server
loop. False means exit and shut down the server.</p>
<p>Two methods are added to the generic word. One for 'ping' and the
other for 'pong'. Here's a sample run:</p>
<pre class="code"> clear
<span class="highlite">pong-server1</span>
=> pong-server1 waiting for message...
<span class="highlite">self &lt;ping-message> over send receive .</span>
=> "pong"
pong-server1 waiting for message...
<span class="highlite">self &lt;ping-message> over send receive .</span>
=> "pong"
pong-server1 waiting for message...
<span class="highlite">self &lt;shutdown-message> over send receive .</span>
=> "Pong server shutdown commenced"
pong-server1 exiting...
</pre>
<p>The advantage of this approach is it is easy to extend the server
without shutting it down. Adding a new message is as simple as
defining the tuple and adding a method to 'handle-message' specialised
on that tuple. Here's an example of adding an 'echo' message, without
shutting the server down:</p>
<pre class="code">
<span class="highlite">pong-server1</span>
=> pong-server1 waiting for message...
<span class="highlite">self &lt;ping-message> over send receive .</span>
=> "pong"
TUPLE: echo-message from text ;
M: echo-message handle-message ( message -- bool )
dup echo-message-text swap echo-message-from send t ;
<span class="highlite">self "Hello World" &lt;echo-message> over send receive .</span>
=>"Hello World"
</pre>
<h2>Synchronous Sends</h2>
<p>The 'send' word sends a message asynchronously, and the sending
process continues immediately. The 'pong server' examples shown
previously all sent messages to the server and waited for a reply back
from the server. This pattern of synchronous sending is made easier
with the 'send-synchronous' word:</p>
<pre class="code">
IN: concurrency
send-synchronous ( message process -- reply )
</pre>
<p>This word will send a message to the given process and immediately
block until a reply is received for this particular message send. It
leaves the reply on the stack. Note that it doesn't wait for just any
reply, it waits for a reply specifically to this send.</p>
<p>To do this it wraps the requested message inside a 'tagged-message'
tuple. This tuple is defined as:</p>
<pre class="code">
TUPLE: tagged-message data from tag ;
</pre>
<p>When 'send-synchronous' is called it will created a
'tagged-message', storing the current process in the 'from' slot. This
is what the receiving server will use to send the reply to. It also
generates a random 'tag' which is stored in the 'tag' slot. The
receiving server will include this value in its reply. After the send
the current process will block waiting for a reply that has the exact
same tag. In this way you can be sure that the reply you got was for
the specific message sent.</p>
<p>Here is the 'pong server' recoded to use 'send-synchronous' and the
tagged-message type:</p>
<pre class="code">
GENERIC: handle-message2
PREDICATE: tagged-message ping-message2 ( obj -- ? )
tagged-message-data "ping" = ;
PREDICATE: tagged-message shutdown-message2 ( obj -- ? )
tagged-message-data "shutdown" = ;
M: ping-message2 handle-message2 ( message -- bool )
"pong" reply t ;
M: shutdown-message2 handle-message2 ( message -- bool )
"Pong server shutdown commenced" reply f ;
: (pong-server2) ( -- )
"pong-server2 waiting for message..." print
receive handle-message2 [ (pong-server2) ] when ;
: pong-server2 ( -- process )
[
(pong-server2)
"pong-server2 exiting..." print
] spawn ;
<span class="highlite">pong-server2</span>
=> pong-server2 waiting for message...
<span class="highlite">"ping" over send-synchronous .</span>
=> "pong"
pong-server2 waiting for message...
<span class="highlite">"ping" over send-synchronous .</span>
=> "pong"
pong-server2 waiting for message...
<span class="highlite">"shutdown" over send-synchronous .</span>
=> "Pong server shutdown commenced"
pong-server2 exiting...
</pre>
<p>The main difference in this example is that the 'handle-message2'
methods are dispatched over predicate types. Two predicate types are
set up both based on the 'tagged-message' tuple mentioned earlier. The
first is for 'ping-message2' which is a tagged message where the
message data is the string "ping". The second is also a tagged message
but the message data is the string "shutdown".</p>
<p>The implementation of the methods uses the 'reply' word. 'reply'
takes a received tagged-message and a new message on the stack and replies to
it. This means that it sends a reply back to the calling process using
the same 'tag'
as the original message. It is a convenience word so you don't have to
manually unpack the tagged-message tuple to get at the originating
process and tag. Its signature is:</p>
<pre class="code">
IN: concurrency
reply ( tagged-message message -- )
</pre>
<h2>Generic Server</h2>
<p>You'll probably have noticed that the general pattern of the pong
server examples are the same. In a loop they receive a message,
process it using a generic function, and either exit or go back to the
beginning of the loop. This is abstracted in the 'spawn-server'
word:</p>
<pre class="code">
IN: quotation
spawn-server ( quot -- process )
</pre>
<p>This takes a quotation that has stack effect ( message -- bool ).
'spawn-server' will spawn a server loop that waits for a message. When
it is received the quotation is called on it. If the quotation returns
false then the server process exits, otherwise it loops from the
beginning again. Using this word you can write the previous
'pong-server2' example as:</p>
<pre class="code">
GENERIC: handle-message2
PREDICATE: tagged-message ping-message2 ( obj -- ? ) tagged-message-data "ping" = ;
PREDICATE: tagged-message shutdown-message2 ( obj -- ? ) tagged-message-data "shutdown" = ;
M: ping-message2 handle-message2 ( message -- bool )
"pong" reply t ;
M: shutdown-message2 handle-message2 ( message -- bool )
"Pong server shutdown commenced" reply f ;
: pong-server3 ( -- process )
[ handle-message2 ] spawn-server ;
</pre>
<p>The main change is that you no longer need the helper
(pong-server2) word.</p>
<h2>Exceptions</h2>
<p>A process can handle exceptions using the standard Factor exception
handling mechanism. If an exception is uncaught the process will
terminate. For example:</p>
<pre class="code">
<span class="highlite">[
1 0 /
"This will not print" print
] spawn</span>
=>
Division by zero
:s :r show stacks at time of error.
:get ( var -- value ) inspects the error namestack.
</pre>
<p>Processes can be linked so that a parent process can receive the
exception that caused the child process to terminate. In this way
'supervisor' processes can be created that are notified when child
processes terminate and possibly restart them.</p>
<p>The easiest way to form this link is using the 'spawn-link'
word. This will create a unidirectional link, such that if an
uncaught exception causes the child to terminate, the parent process
can catch it:</p>
<pre class="code">
<span class="highlite">[
[
1 0 /
"This will not print" print
] spawn-link drop
receive
] [
[ "Exception caught." print ] when
] catch</span>
=> "Exception caught."
</pre>
<p>Exceptions are only raised in the parent when the parent does a
'receive' or 'receive-if'. This is because the exception is sent from
the child to the parent as a message.</p>
<p>To demonstrate how a 'supervisor' process could be created we'll
use the following example 'rpc-server'. It processes 'add', 'product'
and 'crash' messages. 'crash' causes a deliberate divide by zero error
to terminate the process:</p>
<pre class="code">
GENERIC: handle-rpc-message
GENERIC: run-rpc-command
TUPLE: rpc-command op args ;
PREDICATE: rpc-command add-command ( msg -- bool )
rpc-command-op "add" = ;
PREDICATE: rpc-command product-command ( msg -- bool )
rpc-command-op "product" = ;
PREDICATE: rpc-command shutdown-command ( msg -- bool )
rpc-command-op "shutdown" = ;
PREDICATE: rpc-command crash-command ( msg -- bool )
rpc-command-op "crash" = ;
M: tagged-message handle-rpc-message ( message -- bool )
dup tagged-message-data run-rpc-command -rot reply not ;
M: add-command run-rpc-command ( command -- shutdown? result )
rpc-command-args sum f ;
M: product-command run-rpc-command ( command -- shutdown? result )
rpc-command-args product f ;
M: shutdown-command run-rpc-command ( command -- shutdown? result )
drop t t ;
M: crash-command run-rpc-command ( command -- shutdown? result )
drop 1 0 / f ;
: fragile-rpc-server ( -- process )
[ handle-rpc-message ] spawn-server ;
: test-add ( process -- )
[
"add" [ 1 2 3 ] &lt;rpc-command> swap send-synchronous .
] cons spawn drop ;
: test-crash ( process -- )
[
"crash" f &lt;rpc-command> swap send-synchronous .
] cons spawn drop ;
</pre>
<p>An example of use:</p>
<pre class="code">
<span class="highlite">fragile-rpc-server</span>
=> Waiting for message in server: G:13037
<span class="highlite">dup test-add</span>
=> 6
Waiting for message in server: G:13037
<span class="highlite">dup test-crash</span>
=> Division by zero
:s :r show stacks at time of error.
:get ( var -- value ) inspects the error namestack.
<span class="highlite">dup test-add</span>
</pre>
<p>After the crash, all other messages are ignored by the server as it
is no longer running. The following is a way to re-use this code by
running a 'supervisor' process that links with the 'worker' rpc-server. When
the worker crashes the supervisor process restarts it. All
messages sent to the supervisor are immediately forwarded to the
worker:</p>
<pre class="code">
: (robust-rpc-server) ( worker -- )
[
#! Forward all messages to worker
receive over send
] [
[
"Worker died, Starting a new worker" print
drop [ handle-rpc-message ] spawn-linked-server
] when
] catch
(robust-rpc-server) ;
: robust-rpc-server ( -- process )
[
[ handle-rpc-message ] spawn-linked-server
(robust-rpc-server)
] spawn ;
</pre>
<p>This time when the 'robust-rpc-server' is run you'll notice that
messages after the crash are still processed:</p>
<pre class="code">
<span class="highlite">robust-rpc-server</span>
=> Waiting for message in server: G:13045
<span class="highlite">dup test-add</span>
=> 6
Waiting for message in server: G:13045
<span class="highlite">dup test-crash</span>
=> Worker died, Starting a new worker
Waiting for message in server: G:13050
<span class="highlite">dup test-add</span>
=> 6
Waiting for message in server: G:13050
</pre>
<h2>Futures</h2>
<p>A future is a placeholder for the result of a computation that is
being calculated in a process. When the process has completed the
computation the future can be queried to find out the result. If the
computation has not completed when the future is queried them the
process will block until the result is completed.</p>
<p>A future is created using the 'future' word:</p>
<pre class="code">
IN: concurrency
future ( quot -- future )
</pre>
<p>The quotation will be run in a spawned process, and a future object
is immediately returned. This future object can be resolved using the
word '?future':</p>
<pre class="code">
IN: concurrency
?future ( future -- result )
</pre>
<p>Futures are useful for starting calculations that take a long time
to run but aren't needed to later in the process. When the process
needs the value it can use '?future' to get the result or block until
the result is available. For example:</p>
<pre class="code">
[ 30 fib ] future
...do stuff...
?future
</pre>
<h2>Promises</h2>
<p>A promise is similar to a future but it is not produced by
calcuating something in the background. It represents a promise to
provide a value sometime later. A process can request the value of a
promise and will block if the promise is not fulfilled. Later, another
process can fulfill the promise, providing a value. All threads
waiting on the promise will then resume with that value on the
stack.</p>
<p>The words that operate on promises are:</p>
<pre class="code">
IN: concurrency
&lt;promise> ( -- promise )
fulfill ( value promise -- )
?promise ( promise -- result )
</pre>
<p>A simple example of use is:</p>
<pre class="code">
<span class="highlite">&lt;promise>
[ ?promise "Promise fulfilled: " write print ] spawn drop
[ ?promise "Promise fulfilled: " write print ] spawn drop
[ ?promise "Promise fulfilled: " write print ] spawn drop
"hello" swap fulfill</span>
=> Promise fulfilled: hello
Promise fulfilled: hello
Promise fulfilled: hello
</pre>
<p>In this example a promise is created and three processes spawned,
waiting for that promise to be fulfilled. The main process then
fulfills that promise with the value "hello" and all the blocking
processes resume, printing the value.</p>
<h2>GUI</h2>
<p>In the Alice programming system it's possible to display futures
and promises in the inspector and the values will automatically change
then the future is ready, or the promise fulfilled. It's possible to
do similar things with the Factor GUI but there is nothing currently
built-in. A simple example of how this might work is included in the
concurrency-examples vocabulary, with the 'test-promise-ui' word.</p>
<pre class="code">
: test-promise-ui ( -- )
&lt;promise> dup &lt;promised-label> gadget.
[ 12 fib unparse swap fulfill ] cons spawn drop ;
</pre>
<p>This creates a 'promised-label' gadget. This is a gadget, also
implemented in the examples, that has an attached promise. The gadget will display the text 'Unfulfilled
Promise' while the promise is unfulfilled. When it is fulfilled the
gadget will immediately redisplay the value of the promise (which will
need to be a printable value for this example).</p>
<p>The example above displays the gadget using 'gadget.' and then
spawns a thread to compute the 12th fibonacci number and fulfill the
promise with it converted to a string. As soon as the fulfill occurs
the gadget redisplays with the new value.</p>
<p>So running 'test-promise-ui' will displays 'Unfulfilled Promise'
and a short time later change to the new computed value. You will need
to have the Factor GUI listener for this to work:</p>
<pre class="code">
USE: shells
[ ui ] in-thread
</pre>
<p class="footer">
News and updates to this software can be obtained from the authors
weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
</body> </html>

17
contrib/concurrency/load.factor Normal file
View File

@ -0,0 +1,17 @@
USE: kernel
USE: httpd
USE: threads
USE: prettyprint
USE: errors
USE: io
USE: parser
: a "../dlists.factor" run-file
"concurrency.factor" run-file ;
: b "concurrency-examples.factor" run-file ;
: c "concurrency-tests.factor" run-file ;
a
b
USE: concurrency
USE: concurreny-examples

28
contrib/concurrency/style.css Normal file
View File

@ -0,0 +1,28 @@
body { background: white; color: black; }
p { margin-left: 10%; margin-right: 10%;
font: normal 100% Verdana, Arial, Helvetica; }
td { margin-left: 10%; margin-right: 10%;
font: normal 100% Verdana, Arial, Helvetica; }
table { margin-left: 10%; margin-right: 10%; }
ul { margin-left: 10%; margin-right: 10%;
font: normal 100% Verdana, Arial, Helvetica; }
ol { margin-left: 10%; margin-right: 10%;
font: normal 100% Verdana, Arial, Helvetica; }
h1 { text-align: center; margin-bottom: 0; margin-top: 1em; }
h2 { margin: 0 5% 0 7.5%; font-size: 120%; font-style: italic; }
h3 { border: 2px solid blue; border-width: 2px 0.5em 2px 0.5em;
padding: 0.2em 0.2em 0.2em 0.5em; background: #fafafa;
margin-left: 10%; margin-right: 10%; margin-top: 2em;
font-size: 100%; }
.note { border: 2px solid blue; border-width: 2px 2px 2px 2em;
padding: 0.5em 0.5em 0.5em 1em; background: #ffe; }
.code { border: 1px solid black; border-width: 1px;
padding: 0.5em; background: #ffe;
margin-left: 10%; margin-right: 10%; }
blockquote { margin-left: 25%; margin-right: 25%;
font-style: italic; }
.highlite { color: red; }
.footer { margin-top: 2.5em; border-top: 1px solid gray; color:
#AAA; font-size: 85%; padding-top: 0.33em; }
#copyright { text-align: center; color: #AAA;
font-size: 65%; }

2
contrib/cont-responder/cont-numbers-game.factor
View File

@ -69,7 +69,7 @@ USE: namespaces
</form>
</body>
</html>
] show [ "num" get ] bind parse-number ;
] show [ "num" get ] bind string>number ;
: guess-banner
"I'm thinking of a number between 0 and 100." web-print ;

4
contrib/cont-responder/cont-testing.factor
View File

@ -94,10 +94,10 @@ USE: io
#! Create a namespace holding data required
#! for testing continuation based responder functions
#! at the interpreter console.
<namespace> [
[
reset-continuation-table
init-session-namespace
] extend ;
] make-hash ;
: test-cont-function ( <state> quot -- <state> )
#! Call a continuation responder function with required

14
contrib/cont-responder/eval-responder.factor
View File

@ -46,11 +46,11 @@ USE: sequences
#! Create an 'evaluator' object that holds
#! the current stack, output and history for
#! do-eval.
<namespace> [
[
"history" set
"output" set
"stack" set
] extend ;
] make-hash ;
: display-eval-form ( url -- )
#! Display the components for allowing entry of
@ -73,13 +73,13 @@ USE: sequences
#! Replace occurrences of single quotes with
#! backslash quote.
[
[ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc [ , ] [ , ] ?ifte ] each
] make-string ;
[ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc [ % ] [ % ] ?ifte ] each
] "" make ;
: make-eval-javascript ( string -- string )
#! Give a string return some javascript that when
#! executed will set the eval textarea to that string.
[ "document.forms.main.eval.value=\"" , escape-quotes , "\"" , ] make-string ;
[ "document.forms.main.eval.value=\"" % escape-quotes % "\"" % ] "" make ;
: write-eval-link ( string -- )
#! Given text to evaluate, create an A HREF link which when
#! clicked sets the eval textarea to that value.
@ -115,13 +115,13 @@ USE: sequences
#! Return an html fragment dispaying the source
#! of the given word.
dup dup
<namespace> [
{{ }} clone [
"browser" "responder" set
<table border= "1" table>
<tr> <th colspan= "2" th> "Source" write </th> </tr>
<tr> <td colspan= "2" td> [ [ parse ] [ [ "No such word" write ] [ car see ] ifte ] catch ] with-simple-html-output </td> </tr>
<tr> <th> "Apropos" write </th> <th> "Usages" write </th> </tr>
<tr> <td valign= "top" td> [ apropos. ] with-simple-html-output </td>
<tr> <td valign= "top" td> [ apropos ] with-simple-html-output </td>
<td valign= "top" td> [ [ parse ] [ [ "No such word" write ] [ car usages. ] ifte ] catch ] with-simple-html-output </td>
</tr>
</table>

8
contrib/cont-responder/live-updater-responder.factor
View File

@ -37,14 +37,14 @@ USE: prettyprint
: live-search-apropos-word ( string -- )
#! Given a string that is a factor word, show the
#! aporpos of that word.
<namespace> [
[
"browser" "responder" set
<pre>
stdio get <html-stream> [
apropos.
apropos
] with-stream
</pre>
] bind ;
] with-scope ;
: live-updater-responder ( -- )
[
@ -57,7 +57,7 @@ USE: prettyprint
<body>
[
[
"millis" [ millis prettyprint ] "Display Server millis" live-anchor
"millis" [ millis pprint ] "Display Server millis" live-anchor
<div id= "millis" div>
"The millisecond time from the server will appear here" write
</div>

12
contrib/cont-responder/live-updater.factor
View File

@ -34,11 +34,11 @@ USE: lists
: get-live-updater-js* ( stream -- string )
#! Read all lines from the stream, creating a string of the result.
dup stream-readln dup [ , "\n" , get-live-updater-js* ] [ drop stream-close ] ifte ;
dup stream-readln dup [ % "\n" % get-live-updater-js* ] [ drop stream-close ] ifte ;
: get-live-updater-js ( filename -- string )
#! Return the liveUpdater javascript code as a string.
<file-reader> [ get-live-updater-js* ] make-string ;
<file-reader> [ get-live-updater-js* ] "" make ;
: live-updater-url ( -- url )
#! Generate an URL to the liveUpdater.js code.
@ -71,10 +71,10 @@ USE: lists
#! fragment which is the output generated by calling
#! 'quot'. That HTML fragment will be wrapped in a
#! 'div' with the given id.
<namespace> [
[
"div-quot" set
"div-id" set
] extend [
] make-hash [
[
t "disable-initial-redirect?" set
[
@ -123,10 +123,10 @@ USE: lists
#! 'div' with the given id. The 'quot' is called with
#! a string on top of the stack. This is the input string
#! entered in the live search input box.
<namespace> [
[
"div-quot" set
"div-id" set
] extend [
] make-hash [
[
t "disable-initial-redirect?" set
#! Retrieve the search query value from the POST parameters.

124
contrib/cont-responder/todo-example.factor
View File

@ -44,65 +44,65 @@ USE: sequences
: todo-stylesheet ( -- string )
#! Return the stylesheet for the todo list
[
"table.list {" ,
" text-align:center;" ,
" font-family: Verdana;" ,
" font-weight: normal;" ,
" font-size: 11px;" ,
" color: #404040;" ,
" background-color: #fafafa;" ,
" border: 1px #6699cc solid;" ,
" border-collapse: collapse;" ,
" boder-spacing: 0px;" ,
"}" ,
"tr.heading {" ,
" border-bottom: 2px solid #6699cc;" ,
" border-left: 1px solix #6699cc;" ,
" background-color: #BEC8D1;" ,
" text-align: left;" ,
" text-indent: 0px;" ,
" font-family: verdana;" ,
" font-weight: bold;" ,
" color: #404040;" ,
"}" ,
"tr.item {" ,
" border-bottom: 1px solid #9cf;" ,
" border-top: 0px;" ,
" border-left: 1px solid #9cf;" ,
" border-right: 0px;" ,
" text-align: left;" ,
" text-indent: 2px;" ,
" font-family: verdana, sans-serif, arial;" ,
" font-weight: normal;" ,
" color: #404040;" ,
" background-color: #fafafa;" ,
"}" ,
"tr.complete {" ,
" border-bottom: 1px solid #9cf;" ,
" border-top: 0px;" ,
" border-left: 1px solid #9cf;" ,
" border-right: 0px;" ,
" text-align: left;" ,
" text-indent: 2px;" ,
" font-family: verdana, sans-serif, arial;" ,
" font-weight: normal;" ,
" color: #404040;" ,
" background-color: #ccc;" ,
"}" ,
"td.lbl {" ,
" font-weight: bold; text-align: right;" ,
"}" ,
"tr.required {" ,
" background: #FCC;" ,
"}" ,
"input:focus {" ,
" background: yellow;" ,
"}" ,
"textarea:focus {" ,
" background: yellow;" ,
"}" ,
] make-string ;
{
"table.list {"
" text-align:center;"
" font-family: Verdana;"
" font-weight: normal;"
" font-size: 11px;"
" color: #404040;"
" background-color: #fafafa;"
" border: 1px #6699cc solid;"
" border-collapse: collapse;"
" boder-spacing: 0px;"
"}"
"tr.heading {"
" border-bottom: 2px solid #6699cc;"
" border-left: 1px solix #6699cc;"
" background-color: #BEC8D1;"
" text-align: left;"
" text-indent: 0px;"
" font-family: verdana;"
" font-weight: bold;"
" color: #404040;"
"}"
"tr.item {"
" border-bottom: 1px solid #9cf;"
" border-top: 0px;"
" border-left: 1px solid #9cf;"
" border-right: 0px;"
" text-align: left;"
" text-indent: 2px;"
" font-family: verdana, sans-serif, arial;"
" font-weight: normal;"
" color: #404040;"
" background-color: #fafafa;"
"}"
"tr.complete {"
" border-bottom: 1px solid #9cf;"
" border-top: 0px;"
" border-left: 1px solid #9cf;"
" border-right: 0px;"
" text-align: left;"
" text-indent: 2px;"
" font-family: verdana, sans-serif, arial;"
" font-weight: normal;"
" color: #404040;"
" background-color: #ccc;"
"}"
"td.lbl {"
" font-weight: bold; text-align: right;"
"}"
"tr.required {"
" background: #FCC;"
"}"
"input:focus {"
" background: yellow;"
"}"
"textarea:focus {"
" background: yellow;"
"}"
} concat ;
: todo-stylesheet-url ( -- url )
#! Generate an URL for the stylesheet.
@ -234,7 +234,7 @@ USE: sequences
: get-todo-filename ( database-path <todo> -- filename )
#! Get the filename containing the todo list details.
[ swap , todo-username , ".todo" , ] make-string ;
[ swap % todo-username % ".todo" % ] "" make ;
: add-default-todo-item ( <todo> -- )
#! Add a default todo item. This is a workaround for the
@ -452,7 +452,7 @@ USE: sequences
#! Write the table of items for the todo list.
<table>
"heading" [
[ "Priority" write ] [ "Complete?" write ] [ "Description" write ] [ "Action" write ] [ bl ]
[ "Priority" write ] [ "Complete?" write ] [ "Description" write ] [ "Action" write ] [ " " write ]
] styled-row
todo-items [ write-item-row ] each
</table> ;
@ -473,7 +473,7 @@ USE: sequences
: show-todo-list ( -- )
#! Show the current todo list.
[
[ "todo" get todo-username , "'s To Do list" , ] make-string
[ "todo" get todo-username % "'s To Do list" % ] "" make
[ include-todo-stylesheet ]
[
"todo" get write-item-table

30
contrib/cont-responder/todo.factor
View File

@ -36,22 +36,23 @@ USE: prettyprint
USE: hashtables
USE: sequences
USE: http
USE: unparser
: <todo> ( user password -- <todo> )
#! Create an empty todo list
<namespace> [
[
"password" set
"user" set
f "items" set
] extend ;
] make-hash ;
: <todo-item> ( priority description -- )
#! Create a todo item
<namespace> [
[
"description" set
"priority" set
f "complete?" set
] extend ;
] make-hash ;
: add-todo-item ( <todo> <item> -- )
#! Add the item to the todo list
@ -93,14 +94,14 @@ USE: http
: read-todo ( -- <todo> )
#! Read a todo list from the current input stream.
read-line url-decode read-line url-decode <todo>
read-line str>number [
readln url-decode readln url-decode <todo>
readln string>number [
dup
<namespace> [
read-line url-decode "yes" = "complete?" set
read-line url-decode "priority" set
read-line url-decode "description" set
] extend add-todo-item
[
readln url-decode "yes" = "complete?" set
readln url-decode "priority" set
readln url-decode "description" set
] make-hash add-todo-item
] times ;
: load-todo ( filename -- <todo> )
@ -147,9 +148,10 @@ USE: http
#! return the description for the todo list item.
"description" swap hash ;
: priority-comparator ( item1 item2 -- bool )
#! Return true if item1 is a higher priority than item2
>r item-priority r> item-priority string> ;
: priority-comparator ( item1 item2 -- number )
#! Return 0 if item equals item2, -1 if item1 < item2 and
#! 1 if item1 > item2.
>r item-priority r> item-priority lexi ;
: todo-items ( <todo> -- alist )
#! Return a list of items for the given todo list.

68
contrib/crypto/common.factor Normal file
View File

@ -0,0 +1,68 @@
IN: crypto
USING: kernel io strings sequences namespaces math prettyprint
unparser test parser lists ;
: (shift-mod) ( n s w -- n )
>r shift r> 1 swap shift mod ;
: bitroll ( n s w -- n )
#! Roll n by s bits to the left, wrapping around after
#! w bits.
[ mod ] keep
over 0 < [ [ + ] keep ] when
[
(shift-mod)
] 3keep
[ - ] keep (shift-mod) bitor ;
: w+ ( int -- int )
+ HEX: ffffffff bitand ;
: nth-int ( string n -- int )
4 * dup 4 + rot subseq le> ;
: nth-int-be ( string n -- int )
4 * dup 4 + rot subseq be> ;
: float-sin ( int -- int )
sin abs 4294967296 * >bignum ;
: update ( num var -- )
[ w+ ] change ;
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ;
! calculate pad length. leave 8 bytes for length after padding
: zero-pad-length ( length -- pad-length )
dup 64 mod 56 < 55 119 ? swap - ; ! one less for first byte of padding 0x80
! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
: pad-string-md5 ( string -- padded-string )
[
dup % "\u0080" %
dup length 64 mod zero-pad-length 0 fill %
dup length 8 * 8 >le %
] "" make nip ;
: pad-string-sha1 ( string -- padded-string )
[
dup % "\u0080" %
dup length 64 mod zero-pad-length 0 fill %
dup length 8 * 8 >be %
] "" make nip ;
: num-blocks ( length -- num )
64 /i ;
: get-block ( string num -- string )
64 * dup 64 + rot subseq ;
: hex-string ( str -- str )
[
[
>hex 2 48 pad-left %
] each
] "" make ;

7
contrib/crypto/load.factor Normal file
View File

@ -0,0 +1,7 @@
IN: crypto
USING: parser sequences ;
[
"contrib/crypto/common.factor"
"contrib/crypto/md5.factor"
"contrib/crypto/sha1.factor"
] [ run-file ] each

55
contrib/crypto/md5.factor
View File

@ -11,27 +11,12 @@ SYMBOL: old-b
SYMBOL: old-c
SYMBOL: old-d
: w+ ( int -- int )
+ HEX: ffffffff bitand ;
: nth-int ( string n -- int )
4 * dup 4 + rot subseq le> ;
: initialize ( -- )
: initialize-md5 ( -- )
HEX: 67452301 dup a set old-a set
HEX: efcdab89 dup b set old-b set
HEX: 98badcfe dup c set old-c set
HEX: 10325476 dup d set old-d set ;
: float-sin ( int -- int )
sin abs 4294967296 * >bignum ;
: update ( num var -- )
[ w+ ] change ;
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ;
: update-md ( -- )
old-a a update-old-new
old-b b update-old-new
@ -88,7 +73,7 @@ SYMBOL: old-d
: S43 15 ;
: S44 21 ;
: process-block ( block -- )
: process-md5-block ( block -- )
S11 1 pick 0 nth-int [ F ] ABCD
S12 2 pick 1 nth-int [ F ] DABC
S13 3 pick 2 nth-int [ F ] CDAB
@ -160,34 +145,26 @@ SYMBOL: old-d
drop
;
! calculate pad length. leave 8 bytes for length after padding
: md5-zero-pad-length ( length -- pad-length )
dup 64 mod 56 < 55 119 ? swap - ; ! one less for first byte of padding 0x80
! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
: pad-string ( string -- padded-string )
[
dup % "\u0080" %
dup length 64 mod md5-zero-pad-length 0 fill %
dup length 8 * 8 >le %
] make-string ;
: num-blocks ( length -- num )
64 /i ;
: get-block ( string num -- string )
64 * dup 64 + rot subseq ;
: get-md5 ( -- str )
[
[ a b c d ] [ get 4 >le % ] each
] make-string hex-string ;
] "" make hex-string ;
: string>md5 ( string -- md5 )
[
initialize pad-string
dup length num-blocks [ 2dup get-block process-block ] repeat
2drop get-md5
initialize-md5 pad-string-md5
dup length num-blocks [ 2dup get-block process-md5-block ] repeat
drop get-md5
] with-scope ;
: stream>md5 ( stream -- md5 )
[
contents string>md5
] with-scope ;
: file>md5 ( file -- md5 )
[
<file-reader> stream>md5
] with-scope ;
: test-md5 ( -- )

157
contrib/crypto/sha1.factor Normal file
View File

@ -0,0 +1,157 @@
IN: crypto
USING: kernel io strings sequences namespaces math prettyprint
unparser test parser lists vectors hashtables kernel-internals ;
! Implemented according to RFC 3174.
SYMBOL: h0
SYMBOL: h1
SYMBOL: h2
SYMBOL: h3
SYMBOL: h4
SYMBOL: A
SYMBOL: B
SYMBOL: C
SYMBOL: D
SYMBOL: E
SYMBOL: w
SYMBOL: K
SYMBOL: f-table
: reset-w ( -- )
80 <vector> w set ;
: initialize-sha1 ( -- )
HEX: 67452301 dup h0 set A set
HEX: efcdab89 dup h1 set B set
HEX: 98badcfe dup h2 set C set
HEX: 10325476 dup h3 set D set
HEX: c3d2e1f0 dup h4 set E set
reset-w
[
20 [ HEX: 5a827999 , ] times
20 [ HEX: 6ed9eba1 , ] times
20 [ HEX: 8f1bbcdc , ] times
20 [ HEX: ca62c1d6 , ] times
] { } make K set ;
: get-wth ( n -- wth )
w get nth ;
: shift-wth ( n -- )
get-wth 1 32 bitroll ;
! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
: sha1-W ( t -- W_t )
dup 3 - get-wth
over 8 - get-wth bitxor
over 14 - get-wth bitxor
swap 16 - get-wth bitxor 1 32 bitroll ;
! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19)
! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39)
! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
! JUMP-TABLE: f 4 ( maximum )
! {{
! [[ 0 [ >r over bitnot r> bitand >r bitand r> bitor ] ]]
! [[ 1 [ bitxor bitxor ] ]]
! [[ 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] ]]
! [[ 3 [ bitxor bitxor ] ]]
! }} f-table set
! J: 0 f >r over bitnot r> bitand >r bitand r> bitor ;
! J: 1 f bitxor bitxor ;
! J: 2 f 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ;
! J: 3 f bitxor bitxor ;
! todo: make inlined
{
{ [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] }
{ [ dup 1 = ] [ drop bitxor bitxor ] }
{ [ dup 2 = ] [ drop 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
{ [ dup 3 = ] [ drop bitxor bitxor ] }
} f-table set
: sha1-f ( B C D t -- f_tbcd )
20 /i f-table get cond ;
: make-w ( -- )
! compute w, steps a-b of RFC 3174, section 6.1
80 [ dup 16 < [
[ nth-int-be w get push ] 2keep
] [
dup sha1-W w get push
] ifte
] repeat ;
: init-letters ( -- )
! step c of RFC 3174, section 6.1
h0 get A set
h1 get B set
h2 get C set
h3 get D set
h4 get E set ;
: calculate-letters ( -- )
! step d of RFC 3174, section 6.1
80 [
! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
[
[ B get C get D get ] keep sha1-f ,
dup get-wth ,
dup K get nth ,
A get 5 32 bitroll ,
E get ,
] { } make sum 4294967296 mod
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
>r
D get E set
C get D set
B get 30 32 bitroll C set
A get B set
r> A set
] repeat ;
: update-hs ( -- )
! step e of RFC 3174, section 6.1
A h0 update-old-new
B h1 update-old-new
C h2 update-old-new
D h3 update-old-new
E h4 update-old-new ;
: process-sha1-block ( block -- )
make-w init-letters calculate-letters update-hs drop ;
: get-sha1 ( -- str )
[
[ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each
] "" make hex-string ;
: string>sha1 ( string -- sha1 )
[
initialize-sha1 pad-string-sha1
dup length num-blocks [ reset-w 2dup get-block process-sha1-block ] repeat
drop get-sha1
] with-scope ;
: stream>sha1 ( stream -- sha1 )
[
contents string>sha1
] with-scope ;
: file>sha1 ( file -- sha1 )
[
<file-reader> stream>sha1
] with-scope ;
! unit test from the RFC
: test-sha1 ( -- )
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1 ] unit-test
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1 ] unit-test
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1 ] unit-test ! takes a long time...
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" [ 10 [ dup % ] times ] "" make nip string>sha1 ] unit-test ;

2
contrib/parser-combinators/lazy-examples.factor
View File

@ -42,7 +42,7 @@ USE: namespaces
#! each successive value being the result of applying quot to
#! n.
swap dup unit delay -rot
[ , dup , \ call , , \ lfrom-by , ] make-list delay lcons ;
[ , dup , \ call , , \ lfrom-by , ] [ ] make delay lcons ;
: lnaturals 0 lfrom ;
: lpositves 1 lfrom ;

12
contrib/parser-combinators/lazy.factor
View File

@ -80,7 +80,7 @@ DEFER: lnil
: lcons ( lcar lcdr -- promise )
#! Given a car and cdr, both lazy values, return a lazy cons.
swap [ , , \ <lcons> , ] make-list delay ;
swap [ , , \ <lcons> , ] [ ] make delay ;
: lunit ( lvalue -- llist )
#! Given a lazy value (a quotation that when called produces
@ -102,8 +102,8 @@ DEFER: lnil
drop
] [
swap 2dup
[ , \ lcdr , , \ lmap , ] make-list delay >r
[ , \ lcar , , \ call , ] make-list delay r>
[ , \ lcdr , , \ lmap , ] [ ] make delay >r
[ , \ lcar , , \ call , ] [ ] make delay r>
lcons
] ifte ;
@ -117,8 +117,8 @@ DEFER: lnil
nip
] [
swap dupd ( llist llist n -- )
[ [ 1 - ] cons , \ call , , \ lcdr , \ ltake , ] make-list delay >r
[ , \ lcar , ] make-list delay r>
[ [ 1 - ] cons , \ call , , \ lcdr , \ ltake , ] [ ] make delay >r
[ , \ lcar , ] [ ] make delay r>
lcons
] ifte
] ifte ;
@ -283,7 +283,7 @@ DEFER: list>llist
[ 1 2 3 ] list>llist
[ 4 5 6 ] list>llist
[ 7 8 9 ] list>llist
3list
2list cons
list>llist
lappend* ;

92
contrib/parser-combinators/parser-combinators.factor
View File

@ -27,6 +27,7 @@ USE: sequences
USE: strings
USE: lists
USE: math
USE: io
GENERIC: phead
@ -398,94 +399,3 @@ DEFER: <*>
#! Return a parser that optionally uses the parser
#! if that parser would be successfull.
[ (<?>) call ] cons ;
USE: prettyprint
USE: parser
USE: unparser
USE: io
! Testing <&>
: test1 "abcd" "a" token "b" token <&> call [ . ] leach ;
: test1a "abcd" "a" token "b" token <&> "c" token <&> call [ . ] leach ;
: test1b "abcd" "a" token "b" token "c" token <&> <&> call [ . ] leach ;
: test2 "decd" "a" token "b" token <&> call [ . ] leach ;
: test3 "dbcd" "a" token "b" token <&> call [ . ] leach ;
: test4 "adcd" "a" token "b" token <&> call [ . ] leach ;
! Testing <|>
: test5 "abcd" "a" token "b" token <|> call [ . ] leach ;
: test6 "bbcd" "a" token "b" token <|> call [ . ] leach ;
: test7 "cbcd" "a" token "b" token <|> call [ . ] leach ;
! Testing sp
: test8 " abcd" "a" token call [ . ] leach ;
: test9 " abcd" "a" token sp call [ . ] leach ;
! Testing just
: test10 "abcd" "abcd" token "abc" token <|> call [ . ] leach ;
: test11 "abcd" "abcd" token "abc" token <|> just call [ . ] leach ;
! Testing <@
: test12 "01234" [ digit? ] satisfy call [ . ] leach ;
: test13 "01234" [ digit? ] satisfy [ digit> ] <@ call [ . ] leach ;
! Testing some
: test14 "begin1" "begin" token call [ . ] leach ;
: test15 "This should fail with an error" print
"begin1" "begin" token some call . ;
: test16 "begin" "begin" token some call . ;
! parens test function
: parens ( -- parser )
#! Return a parser that parses nested parentheses.
[ "(" token parens <&> ")" token <&> parens <&> epsilon <|> call ] ;
: test17 "" parens call [ . ] leach ;
: test18 "()" parens call [ . ] leach ;
: test19 "((()))" parens call [ . ] leach ;
! <& parser and &> parser
: test20 "abcd" "a" token "b" token <&> call [ . ] leach ;
: test21 "abcd" "a" token "b" token <& call [ . ] leach ;
: test22 "abcd" "a" token "b" token &> call [ . ] leach ;
! nesting example
: parens-open "(" token ;
: parens-close ")" token ;
: nesting
[ parens-open
nesting &>
parens-close <&
nesting <&>
[ unswons 1 + max ] <@
0 succeed <|>
call ] ;
: test23 "" nesting just call [ . ] leach ;
: test24 "()" nesting just call [ . ] leach ;
: test25 "(())" nesting just call [ . ] leach ;
: test26 "()(()(()()))()" nesting just call [ . ] leach ;
! Testing <*> and <:&>
: test27 "1234" "1" token <*> call [ . ] leach ;
: test28 "1111234" "1" token <*> call [ . ] leach ;
: test28a "1111234" "1" token <*> [ car concat unit ] <@ call [ . ] leach ;
: test29 "234" "1" token <*> call [ . ] leach ;
: pdigit [ digit? ] satisfy [ digit> ] <@ ;
: pnatural pdigit <*> ;
: pnatural2 pnatural [ car [ >digit ] map >string dup pempty? [ drop 0 ] [ str>number ] ifte unit ] <@ ;
: test30 "12345" pnatural2 call [ . ] leach ;
! Testing <+>
: test31 "1234" "1" token <+> call [ . ] leach ;
: test32 "1111234" "1" token <+> call [ . ] leach ;
: test33 "234" "1" token <+> call [ . ] leach ;
! Testing <?>
: test34 "ab" "a" token pdigit <?> <&> "b" token <&> call [ . ] leach ;
: test35 "ac" "a" token pdigit <?> <&> "b" token <&> call [ . ] leach ;
: test36 "a5b" "a" token pdigit <?> <&> "b" token <&> call [ . ] leach ;
: pinteger "-" token <?> pnatural2 <&> [ uncons swap [ car -1 * ] when ] <@ ;
: test37 "123" pinteger call [ . ] leach ;
: test38 "-123" pinteger call [ . ] leach ;

4
contrib/parser-combinators/parser-combinators.html
View File

@ -7,7 +7,9 @@
<h1>Parsers</h1>
<p class="note">The parser combinator library described here is based
on a library written for the Clean pure functional programming language and
described in chapter 5 of the 'Clean Book'. Based on the description
described in chapter 5 of the 'Clean Book' (<a
href="ftp://ftp.cs.kun.nl/pub/Clean/papers/cleanbook/II.05.ParserCombinators.pdf">PDF
available here</a>). Based on the description
in that chapter I developed a version for Factor, a concatenative
language.</p>
<p>A parser is a word or quotation that, when called, processes

260
contrib/parser-combinators/tests.factor Normal file
View File

@ -0,0 +1,260 @@
! Copyright (C) 2005 Chris Double.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: scratchpad
USING: kernel lazy parser-combinators test errors strings parser lists math sequences unparser ;
! Testing <&>
[ [ [[ "cd" [[ "a" "b" ]] ]] ] ] [
"abcd" "a" token "b" token <&> call llist>list
] unit-test
[ [ [[ "d" [[ [[ "a" "b" ]] "c" ]] ]] ] ] [
"abcd" "a" token "b" token <&> "c" token <&> call llist>list
] unit-test
[ [ [[ "d" [[ "a" [[ "b" "c" ]] ]] ]] ] ] [
"abcd" "a" token "b" token "c" token <&> <&> call llist>list
] unit-test
[ f ] [
"decd" "a" token "b" token <&> call llist>list
] unit-test
[ f ] [
"dbcd" "a" token "b" token <&> call llist>list
] unit-test
[ f ] [
"adcd" "a" token "b" token <&> call llist>list
] unit-test
! Testing <|>
[ [ [[ "bcd" "a" ]] ] ] [
"abcd" "a" token "b" token <|> call llist>list
] unit-test
[ [ [[ "bcd" "b" ]] ] ] [
"bbcd" "a" token "b" token <|> call llist>list
] unit-test
[ f ] [
"cbcd" "a" token "b" token <|> call llist>list
] unit-test
! Testing sp
[ f ] [
" abcd" "a" token call llist>list
] unit-test
[ [ [[ "bcd" "a" ]] ] ] [
" abcd" "a" token sp call llist>list
] unit-test
! Testing just
[ [ [[ "" "abcd" ]] [[ "d" "abc" ]] ] ] [
"abcd" "abcd" token "abc" token <|> call llist>list
] unit-test
[ [ [[ "" "abcd" ]] ] ] [
"abcd" "abcd" token "abc" token <|> just call llist>list
] unit-test
! Testing <@
[ [ [[ "1234" 48 ]] ] ] [
"01234" [ digit? ] satisfy call llist>list
] unit-test
[ [ [[ "1234" 0 ]] ] ] [
"01234" [ digit? ] satisfy [ digit> ] <@ call llist>list
] unit-test
! Testing some
[ [ [[ "1" "begin" ]] ] ] [
"begin1" "begin" token call llist>list
] unit-test
[
"begin1" "begin" token some call
] unit-test-fails
[ "begin" ] [
"begin" "begin" token some call
] unit-test
! parens test function
: parens ( -- parser )
#! Return a parser that parses nested parentheses.
[ "(" token parens <&> ")" token <&> parens <&> epsilon <|> call ] ;
[ [ [[ "" "" ]] ] ] [
"" parens call llist>list
] unit-test
[
[[ "" [[ [[ [[ "(" "" ]] ")" ]] "" ]] ]]
[[ "()" "" ]]
] [
"()" parens call [ ] leach
] unit-test
[ [[ "((()))" "" ]] ] [
"((()))" parens call lcdr lcar
] unit-test
! <& parser and &> parser
[ [ [[ "cd" [[ "a" "b" ]] ]] ] ] [
"abcd" "a" token "b" token <&> call llist>list
] unit-test
[ [ [[ "cd" "a" ]] ] ] [
"abcd" "a" token "b" token <& call llist>list
] unit-test
[ [ [[ "cd" "b" ]] ] ] [
"abcd" "a" token "b" token &> call llist>list
] unit-test
! nesting example
: parens-open "(" token ;
: parens-close ")" token ;
: nesting
[ parens-open
nesting &>
parens-close <&
nesting <&>
[ unswons 1 + max ] <@
0 succeed <|>
call ] ;
[ [ [[ "" 0 ]] ] ] [
"" nesting just call llist>list
] unit-test
[ [ [[ "" 1 ]] ] ] [
"()" nesting just call llist>list
] unit-test
[ [ [[ "" 2 ]] ] ] [
"(())" nesting just call llist>list
] unit-test
[ [ [[ "" 3 ]] ] ] [
"()(()(()()))()" nesting just call llist>list
] unit-test
! Testing <*> and <:&>
[ [ [ "234" [ "1" ] ] [ "1234" ] ] ] [
"1234" "1" token <*> call llist>list
] unit-test
[
[ "234" [ "1" "1" "1" "1" ] ]
[ "1234" [ "1" "1" "1" ] ]
[ "11234" [ "1" "1" ] ]
[ "111234" [ "1" ] ]
[ "1111234" ]
] [
"1111234" "1" token <*> call [ ] leach
] unit-test
[
[ "234" "1111" ]
[ "1234" "111" ]
[ "11234" "11" ]
[ "111234" "1" ]
[ "1111234" f ]
] [
"1111234" "1" token <*> [ car concat unit ] <@ call [ ] leach
] unit-test
[ [ "234" ] ] [
"234" "1" token <*> call [ ] leach
] unit-test
: pdigit [ digit? ] satisfy [ digit> ] <@ ;
: pnatural pdigit <*> ;
: pnatural2 pnatural [ car [ >digit ] map >string dup pempty? [ drop 0 ] [ string>number ] ifte unit ] <@ ;
[
[ "" 12345 ]
[ "5" 1234 ]
[ "45" 123 ]
[ "345" 12 ]
[ "2345" 1 ]
[ "12345" 0 ]
] [
"12345" pnatural2 call [ ] leach
] unit-test
! Testing <+>
[ [ "234" [ "1" ] ] ] [
"1234" "1" token <+> call [ ] leach
] unit-test
[
[ "234" [ "1" "1" "1" "1" ] ]
[ "1234" [ "1" "1" "1" ] ]
[ "11234" [ "1" "1" ] ]
[ "111234" [ "1" ] ]
] [
"1111234" "1" token <+> call [ ] leach
] unit-test
[ ] [
"234" "1" token <+> call [ ] leach
] unit-test
! Testing <?>
[ [[ "" [[ [ "a" ] "b" ]] ]] ] [
"ab" "a" token pdigit <?> <&> "b" token <&> call [ ] leach
] unit-test
[ ] [
"ac" "a" token pdigit <?> <&> "b" token <&> call [ ] leach
] unit-test
[ [[ "" [[ [ "a" 5 ] "b" ]] ]] ] [
"a5b" "a" token pdigit <?> <&> "b" token <&> call [ ] leach
] unit-test
: pinteger "-" token <?> pnatural2 <&> [ uncons swap [ car -1 * ] when ] <@ ;
[
[ "" 123 ]
[ "3" 12 ]
[ "23" 1 ]
[ "123" 0 ]
] [
"123" pinteger call [ ] leach
] unit-test
[
[[ "" -123 ]]
[[ "3" -12 ]]
[[ "23" -1 ]]
[[ "123" 0 ]]
[ "-123" 0 ]
] [
"-123" pinteger call [ ] leach
] unit-test

212
doc/bootstrap.txt
View File

@ -1,212 +0,0 @@
THE BOOTSTRAP PROCESS
* Why bother?
Factor cannot be built entirely from source. That is, certain parts --
such as the parser itself -- are written in entirely in Factor, thus to
build a new Factor system, one needs to be running an existing Factor
system.
The Factor runtime, coded in C, knows nothing of the syntax of Factor
source files, or even the organization of words into vocabularies. Most
conventional languages fall into two implementation styles:
- A single monolithic executable is shipped, with most of the language
written in low level code. This includes Python, Perl, and so on. This
approach has the disadvantage that the language is less flexible, due to
the large native substrate.
- A smaller interpreter/compiler is shipped, that reads bytecode or
source files from disk, and constructs the standard library on startup.
This has the disadvantage of slow startup time. This includes Java.
* How does it work?
Factor takes a superior approach, used by Lisp and Smalltalk
implementations, where initialization consists of loading a memory
image. Execution then begins immediately. New images can be generated in
one of two ways:
- Saving the current memory heap to disk as a new image file.
This is easily done and easily implemented:
"foo.image" save-image
Since this simply saves a copy of the entire heap to a file, no more
will be said about it here.
- Generating a new image from sources.
If the former was the only way to save code changes to an image, things
would be out of hand. For example, if the runtime's object format has to
change, one would have to write a tool to read an image, convert each
object, and write it out again. Or if new primitives were added, or the
major parts of the library needed a reorganization... things would get
messy.
Generating a new image from source is called 'bootstrapping'.
Bootstrapping is the topic of the remainder of this document.
Some terminology: the current running Factor image, the one generating
the bootstrap image, is a 'host' image; the bootstrap image being
generated is a 'target' image.
* General overview of the bootstrap process
While Factor cannot be built entirely from source, bootstrapping allows
one to use an existing Factor implementation, that is up to date with
respect to the sources one is bootstrapping from, to build a new image
in a reasonably clean and controlled manner.
Bootstrapping proceeds in two stages:
- In first stage, the make-image word is used to generate a stage 1
image. The make-image word is defined in /library/bootstrap, and is
called like so:
"foo.image" make-image
Unlike save-image, make-image actually writes out each object
'manually', without dumping memory; this allows the object format to be
changed, by modifying /library/bootstrap/image.factor.
- In the second stage, one runs the Factor interpreter, passing the
stage 1 image on the command line. The stage 1 image then proceeds to
load remaining source files from disk, finally producing a completed
image, that can in turn make new images, etc.
Now, lets look at each stage in detail.
* Stage 1 bootstrap
The first stage is by far the most interesting.
Take a careful look at the words for searching vocabularies in
/library/vocabularies.factor.
They all access the vocabulary hash by accessing the 'vocabulary'
variable in the current namespace; so if one calls these words in a
dynamic scope where this variable is set to something other than the
global vocabulary hash, interesting things can happen.
(Note there is little risk of accidental capture here; you can name a
variable 'vocabularies', and it won't clash unless you actually define
it as a symbol in the 'words' vocabulary, which you won't do.)
** Setting up the target environment
After initializing some internal objects, make-image runs the file
/library/bootstrap/boot.factor. Bootstrapping is performed in new
dynamic scope, so that vocabularies can be overriden.
The first file run by bootstrapping is
/library/bootstrap/primitives.factor.
This file sets up an initially empty target image vocabulary hash; then,
it copies 'syntax' and 'generic' vocabularies from the host vocabulary
hash to the target vocabulary hash. Then, it adds new words, one for
each primitive, to the target vocabulary hash.
Files are run after being fully parsed; since the host vocabulary hash
is in scope when primitives.factor is parsed, primitives.factor can
still make use of host words. However, after primitives.factor is run,
the bootstrap vocabulary is very bare; containing syntax parsing and
primitives only.
** Bootstrapping the core library
Bootstrapping then continues, and loads various source files into the
target vocabulary hash. Each file loaded must only refer to primitive
words, and words loaded from previous files. So by reading through each
file referenced by boot.factor, you can see the entire construction of
the core of Factor, from the bottom up!
After most files being loaded, there is still a problem; the 'syntax'
and 'generic' vocabularies in the target image were copied from the host
image, and not loaded from source. The generic vocabulary is overwritten
near the end of bootstrap, by loading in the relevant source files.
(The reason 'generic' words have to be copied first, and not loaded in
order, is that the parsing words in this vocabulary are used to define
dispatch classes. This will be documented separately.)
** Bootstrapping syntax parsing words
So much for 'generic'. Bootstrapping the syntax words is a slightly
tougher problem. Since the syntax vocabulary parses source files itself,
a delicate trick must be performed.
Take a look at the start of /library/syntax/parse-syntax.factor:
IN: !syntax
USE: syntax
This file defines parsing words such as [ ] : ; and so on. As you can
see, the file itself is parsed using the host image 'syntax' vocabulary,
but the new parsing words are defined in a '!syntax' vocabulary.
After loading parse-syntax.factor, boot.factor then flips the two
vocabularies, and renames each word in '!syntax':
vocabularies get [
"!syntax" get "syntax" set
"syntax" get [
cdr dup word? [
"syntax" "vocabulary" set-word-property
] [
drop
] ifte
] hash-each
] bind
"!syntax" vocabularies get remove-hash
The reason parse-syntax.factor can't do IN: syntax is that because about
half way through parsing it, its own words would start executing. But we
can *never* execute target image words in the host image -- for example,
the target image might have a different set of primitives, different
runtime layout, and so on.
* Saving the stage 1 image
Once /library/bootstrap/boot.factor completes executing, make-image
resumes, and it now has a nice, shiny new vocabularies hash ready to
save to a target image. It then outputs this hash to a file, along with
various auxilliary objects, using the precise object format required by
the runtime.
It also outputs a 'boot quotation'. The boot quotation is executed by
the interpreter as soon as the target image is loaded, and leads us to
stage 2; but first, a little hack.
** The transfer hack
Some parsing words generate code in the target image vocabulary.
However, since the host image parsing words are actually executing
during bootstrap, the generated code refers to host image words. The
bootstrapping code performs a 'transfer' where each host image word that
is referred to in the target image is replaced with the
identically-named target image word.
* On to stage 2
The boot quotation left behind from stage 1 simply runs the
/library/bootstrap/boot-stage2.factor file.
This file begins by reloading each source file loaded in stage 1. This
is for convinience; after changing some core library files, it is faster
for the developer to just redo stage 2, and get an up to date image,
instead of doing the whole stage 1 process again.
After stage 1 has been redone, stage 2 proceeds to load more library
files. Basically, stage 1 only has barely enough to begin parsing source
files from disk; stage 2 loads everything else, like development tools,
the compiler, HTTP server. etc.
Stage 2 finishes by running /library/bootstrap/init-stage2.factor, which
infers stack effects and performs various cleanup tasks. Then, it uses
the 'save-image' word to save a memory dump, which becomes a shiny new
'factor.image', ready for hacking, and ready for bootstrapping more new
images!

2
doc/comparison.tex
View File

@ -119,7 +119,7 @@ DEFER: second-word-to-be-defined
\end{verbatim}
before the definition of the first word.
Factor supports named variables. This doesn't destroy concatenativity, though, because
Factor supports named variables. This doesn't destroy concatenativity, though, because words and quotations are not boundaries for it at all; dynamic scope is used.
\section{Common Lisp and Scheme}

3226
doc/handbook.tex
View File

File diff suppressed because it is too large Load Diff

BIN
doc/interpreter.dia
View File

Binary file not shown.

5537
doc/interpreter.eps
View File

File diff suppressed because it is too large Load Diff

4
doc/theory.tex
View File

@ -88,7 +88,7 @@ The set of program quotations, $QUOT \subset OBJ$, is the smallest set satisfyin
\begin{enumerate}
\item The empty list $\mbox{\texttt{f}} \in QUOT$.
\item The empty list $\bot \in QUOT$.
\item If $a \in OBJ$, $b \in QUOT$, $(a::b) \in QUOT$.
\end{enumerate}
@ -105,7 +105,7 @@ The set of stacks, $STACK \subset QUOT$, is the smallest set satisfying:
\begin{enumerate}
\item The empty list $\mbox{\texttt{f}} \in STACK$.
\item The empty list $\bot \in STACK$.
\item If $a \in QUOT$, $b \in STACK$, $(a::b) \in STACK$.
\end{enumerate}

22
examples/factorbot.factor
View File

@ -1,8 +1,8 @@
! Simple IRC bot written in Factor.
USING: errors generic hashtables http io kernel math namespaces
parser prettyprint sequences strings unparser words ;
IN: factorbot
USING: hashtables http io kernel math namespaces prettyprint
sequences strings words ;
SYMBOL: irc-stream
SYMBOL: nickname
@ -30,15 +30,15 @@ SYMBOL: receiver
"JOIN " irc-write irc-print ;
GENERIC: handle-irc
PREDICATE: string privmsg "PRIVMSG" swap subseq? ;
PREDICATE: string privmsg " " split1 nip "PRIVMSG" head? ;
PREDICATE: string ping "PING" head? ;
M: string handle-irc ( line -- )
M: object handle-irc ( line -- )
drop ;
: parse-privmsg ( line -- text )
":" ?head drop
"!" split1 swap speaker set
"PRIVMSG " split1 nip
" " split1 nip
"PRIVMSG " ?head drop
" " split1 swap receiver set
":" ?head drop ;
@ -48,6 +48,12 @@ M: privmsg handle-irc ( line -- )
[ "factorbot-commands" ] search dup
[ execute ] [ 2drop ] ifte ;
M: ping handle-irc ( line -- )
"PING " ?head drop "PONG " swap append irc-print ;
: parse-irc ( line -- )
":" ?head [ "!" split1 swap speaker set ] when handle-irc ;
: say ( line nick -- )
"PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
@ -72,7 +78,7 @@ M: privmsg handle-irc ( line -- )
: irc-loop ( -- )
irc-stream get stream-readln
[ dup print flush handle-irc irc-loop ] when* ;
[ dup print flush parse-irc irc-loop ] when* ;
: factorbot
"irc.freenode.net" connect

8
examples/mandel.factor
View File

@ -87,12 +87,10 @@ USE: test
: val 0.85 ;
: <color-map> ( nb-cols -- map )
[
dup [
dup 360 * pick 1 + / 360 / sat val
hsv>rgb 1.0 scale-rgb ,
] repeat
] make-vector nip ;
360 * swap 1 + / 360 / sat val
hsv>rgb 1.0 scale-rgb
] map-with ;
: iter ( c z nb-iter -- x )
over absq 4 >= over 0 = or [

2
examples/numbers-game.factor
View File

@ -1,7 +1,7 @@
IN: numbers-game
USING: kernel math parser random io ;
: read-number ( -- n ) readln parse-number ;
: read-number ( -- n ) readln str>number ;
: guess-banner
"I'm thinking of a number between 0 and 100." print ;

39
examples/plot3d.factor
View File

@ -15,28 +15,35 @@
! "examples/plot3d.factor" run-file
IN: plot3d
USING: alien compiler errors gl kernel lists math matrices
namespaces prettyprint sdl sequences ;
USING: alien compiler errors gl kernel lists math namespaces
prettyprint sdl sequences vectors ;
: display-list 1 ;
: matrix-get ( i j matrix -- ) swapd nth nth ;
: plot-vertex ( matrix i j -- )
rot matrix-get 3unlist glVertex3f ;
rot matrix-get 3unseq glVertex3f ;
: plot-face ( matrix i j -- face )
GL_QUADS glBegin
[ rot matrix-get ] 3keep
[ 1 + rot matrix-get v- ] 3keep
[ rot matrix-get ] 3keep
[ >r 1 + r> rot matrix-get v- cross normalize >list 3unlist glNormal3f ] 3keep
[ >r 1 + r> rot matrix-get v- cross normalize 3unseq glNormal3f ] 3keep
[ plot-vertex ] 3keep
[ 1 + plot-vertex ] 3keep
[ >r 1 + r> 1 + plot-vertex ] 3keep
>r 1 + r> plot-vertex
glEnd ;
: 2repeat ( i j quot -- | quot: i j -- i j )
rot [
rot [ [ rot dup slip -rot ] repeat ] keep -rot
] repeat 2drop ; inline
: plot-faces ( points -- )
dup matrix-rows 1 - over matrix-cols 1 - [
dup length 1 - over first length 1 - [
3dup plot-face
] 2repeat drop ;
@ -65,23 +72,27 @@ SYMBOL: theta
swap 15 - 30 / swap 15 - 30 / ;
: max-z ( seq -- z )
0.1 swap [ 2 swap nth max ] each ;
0.1 [ third max ] reduce ;
: min-z ( seq -- z )
-0.1 swap [ 2 swap nth min ] each ;
-0.1 [ third min ] reduce ;
: normalize-points ( seq -- )
dup min-z over [ over >r 3unlist r> - 3list ] nmap drop
dup max-z swap [ over >r 3unlist r> / 3list ] nmap drop ;
dup min-z over [ over >r 3unseq r> - 3vector ] nmap drop
dup max-z swap [ over >r 3unseq r> / 3vector ] nmap drop ;
: valuate-points ( quot -- matrix )
>r 30 30 r>
[ i/j>x/y ] swap unit [ 2keep rot 3list ] append3
make-matrix ;
30 [
( quot i )
30 [
( quot i j )
[ 3dup i/j>x/y rot call ] 2keep i/j>x/y rot 3vector nip
] map 2nip
] map-with ; inline
: make-plot
[ rect> sq exp real ] valuate-points
dup matrix-sequence normalize-points
[ rect> real ] valuate-points
dup [ normalize-points ] each
display-list GL_COMPILE glNewList
plot-faces
plot-axes

2
factor/jedit/FactorPlugin.props
View File

@ -2,7 +2,7 @@
plugin.factor.jedit.FactorPlugin.activate=startup
plugin.factor.jedit.FactorPlugin.name=Factor
plugin.factor.jedit.FactorPlugin.version=0.76
plugin.factor.jedit.FactorPlugin.version=0.77
plugin.factor.jedit.FactorPlugin.author=Slava Pestov
plugin.factor.jedit.FactorPlugin.docs=/doc/jedit/index.html

22
library/alien/aliens.factor
View File

@ -4,21 +4,8 @@ IN: alien
USING: hashtables io kernel kernel-internals lists math
namespaces parser ;
DEFER: dll?
BUILTIN: dll 15 dll? [ 1 "dll-path" f ] ;
DEFER: alien?
BUILTIN: alien 16 alien? ;
DEFER: displaced-alien?
BUILTIN: displaced-alien 20 displaced-alien? ;
UNION: c-ptr byte-array alien displaced-alien ;
: NULL ( -- null )
#! C null value.
0 <alien> ;
M: alien hashcode ( obj -- n )
alien-address >fixnum ;
@ -44,13 +31,12 @@ M: alien = ( obj obj -- ? )
: add-library ( library name abi -- )
"libraries" get [
<namespace> [
"abi" set
"name" set
] extend swap set
[ "abi" set "name" set ] make-hash swap set
] bind ;
: library-abi ( library -- abi )
library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
library "abi" swap ?hash [ "cdecl" ] unless* ;
: DLL" skip-blank parse-string dlopen swons ; parsing
: ALIEN: scan-word <alien> swons ; parsing

27
library/alien/c-types.factor
View File

@ -6,14 +6,14 @@ hashtables kernel kernel-internals lists math namespaces parser
sequences strings words ;
: <c-type> ( -- type )
<namespace> [
[ "No setter" throw ] "setter" set
[ "No getter" throw ] "getter" set
"no boxer" "boxer" set
"no unboxer" "unboxer" set
<< int-regs f >> "reg-class" set
0 "width" set
] extend ;
{{
[[ "setter" [ "No setter" throw ] ]]
[[ "getter" [ "No getter" throw ] ]]
[[ "boxer" "no boxer" ]]
[[ "unboxer" "no unboxer" ]]
[[ "reg-class" << int-regs f >> ]]
[[ "width" 0 ]]
}} clone ;
SYMBOL: c-types
@ -26,13 +26,12 @@ SYMBOL: c-types
c-type [ "width" get ] bind ;
: define-c-type ( quot name -- )
>r <c-type> swap extend r> c-types get set-hash ; inline
>r <c-type> [ swap bind ] keep r> c-types get set-hash ;
inline
: <c-object> ( size -- byte-array )
cell / ceiling <byte-array> ;
: <c-object> ( size -- c-ptr ) cell / ceiling <byte-array> ;
: <c-array> ( n size -- byte-array )
* cell / ceiling <byte-array> ;
: <c-array> ( n size -- c-ptr ) * <c-object> ;
: define-pointer ( type -- )
"void*" c-type swap "*" append c-types get set-hash ;
@ -74,7 +73,7 @@ SYMBOL: c-types
[
"width" get , \ <c-object> , \ tuck , 0 ,
"setter" get %
] make-list
] [ ] make
] bind define-compound ;
: init-c-type ( name vocab -- )

52
library/alien/compiler.factor
View File

@ -2,8 +2,8 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler compiler-backend compiler-frontend
errors generic hashtables inference kernel lists math namespaces
sequences io strings unparser words ;
errors generic hashtables inference io kernel lists math
namespaces prettyprint sequences strings words parser ;
! ! ! WARNING ! ! !
! Reloading this file into a running Factor instance on Win32
@ -26,21 +26,14 @@ sequences io strings unparser words ;
! FFI code does not run in the interpreter.
TUPLE: alien-error symbol library ;
C: alien-error ( lib sym -- )
[ set-alien-error-symbol ] keep
[ set-alien-error-library ] keep ;
TUPLE: alien-error library symbol ;
M: alien-error error. ( error -- )
[
"C library interface words cannot be interpreted. " %
"Either the compiler is disabled, " %
"or the " % dup alien-error-library unparse %
" library does not define the " %
alien-error-symbol unparse %
" symbol." %
] make-string print ;
"C library interface words cannot be interpreted. " write
"Either the compiler is disabled, " write
"or the " write dup alien-error-library pprint
" library does not define the " write
alien-error-symbol pprint " symbol." print ;
: alien-invoke ( ... return library function parameters -- ... )
#! Call a C library function.
@ -93,7 +86,7 @@ C: alien-node make-node ;
: incr-param ( reg-class -- )
#! OS X is so ugly.
dup class [ 1 + ] change dup float-regs? [
dup class inc dup float-regs? [
os "macosx" = [
int-regs [ swap float-regs-size 4 / + ] change
] [
@ -137,6 +130,23 @@ M: alien-node linearize-node* ( node -- )
[ dup parameters stack-space %cleanup , ] unless
linearize-return ;
: unpair ( seq -- odds evens )
2 swap group flip dup empty?
[ drop { } { } ] [ first2 ] ifte ;
: parse-arglist ( lst -- types stack effect )
unpair [
" " % [ "," ?tail drop % " " % ] each "-- " %
] "" make ;
: (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) ;
\ alien-invoke [ [ string object string general-list ] [ ] ]
"infer-effect" set-word-prop
@ -149,5 +159,13 @@ M: alien-node linearize-node* ( node -- )
] "infer" set-word-prop
global [
"libraries" get [ <namespace> "libraries" set ] unless
"libraries" get [ {{ }} clone "libraries" set ] unless
] bind
M: compound (uncrossref)
dup word-def \ alien-invoke swap member? [
drop
] [
dup { "infer-effect" "base-case" "no-effect" }
reset-props update-xt
] ifte ;

23
library/alien/enums.factor
View File

@ -1,23 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: kernel lists math parser words ;
: BEGIN-ENUM:
#! C-style enumerations. Their use is not encouraged unless
#! it is for C library interfaces. Used like this:
#!
#! BEGIN-ENUM 0
#! ENUM: x
#! ENUM: y
#! ENUM: z
#! END-ENUM
#!
#! This is the same as : x 0 ; : y 1 ; : z 2 ;.
scan str>number ; parsing
: ENUM:
dup CREATE swap unit define-compound 1 + ; parsing
: END-ENUM
drop ; parsing

18
library/alien/structs.factor
View File

@ -38,21 +38,3 @@ math namespaces parser sequences strings words ;
]
"struct-name" get define-c-type
"struct-name" get "in" get init-c-type ;
: BEGIN-STRUCT: ( -- offset )
scan "struct-name" set 0 ; parsing
: FIELD: ( offset -- offset )
scan scan define-field ; parsing
: END-STRUCT ( length -- )
define-struct-type ; parsing
: BEGIN-UNION: ( -- max )
scan "struct-name" set 0 ; parsing
: MEMBER: ( max -- max )
scan define-member ; parsing
: END-UNION ( max -- )
define-struct-type ; parsing

53
library/alien/syntax.factor
View File

@ -1,7 +1,8 @@
! 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 ;
USING: compiler kernel lists math namespaces parser
sequences words ;
! usage of 'LIBRARY:' and 'FUNCTION:' :
!
@ -22,19 +23,6 @@ USING: compiler kernel lists namespaces parser sequences words ;
: 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
@ -43,4 +31,39 @@ USING: compiler kernel lists namespaces parser sequences words ;
#! TYPEDEF: old new
scan scan typedef ; parsing
: DLL" skip-blank parse-string dlopen swons ; parsing
: BEGIN-STRUCT: ( -- offset )
scan "struct-name" set 0 ; parsing
: FIELD: ( offset -- offset )
scan scan define-field ; parsing
: END-STRUCT ( length -- )
define-struct-type ; parsing
: BEGIN-UNION: ( -- max )
scan "struct-name" set 0 ; parsing
: MEMBER: ( max -- max )
scan define-member ; parsing
: END-UNION ( max -- )
define-struct-type ; parsing
: BEGIN-ENUM:
#! C-style enumerations. Their use is not encouraged unless
#! it is for C library interfaces. Used like this:
#!
#! BEGIN-ENUM 0
#! ENUM: x
#! ENUM: y
#! ENUM: z
#! END-ENUM
#!
#! This is the same as : x 0 ; : y 1 ; : z 2 ;.
scan string>number ; parsing
: ENUM:
dup CREATE swap unit define-compound 1 + ; parsing
: END-ENUM
drop ; parsing

150
library/bootstrap/boot-stage1.factor
View File

@ -1,51 +1,60 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: image
USING: generic hashtables kernel lists math memory namespaces
parser prettyprint sequences io vectors words ;
USING: generic hashtables kernel kernel-internals
lists math memory namespaces parser prettyprint
sequences io vectors words ;
"Bootstrap stage 1..." print
"/library/bootstrap/primitives.factor" run-resource
: pull-in ( list -- ) [ dup print parse-resource % ] each ;
! The [ ] make form creates a boot quotation
[
[
[ hashtable? ] instances
[ dup hash-size 1 max swap set-bucket-count ] each
! The make-list form creates a boot quotation
[
[
boot
] %
{
"/version.factor"
"/library/stack.factor"
"/library/combinators.factor"
"/library/generic/early-generic.factor"
"/library/kernel.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/math/random.factor"
"/library/collections/growable.factor"
"/library/collections/cons.factor"
"/library/collections/vectors.factor"
"/library/collections/virtual-sequences.factor"
"/library/collections/sequences-epilogue.factor"
"/library/collections/strings.factor"
"/library/collections/sbuf.factor"
"/library/collections/assoc.factor"
"/library/collections/lists.factor"
"/library/collections/vectors.factor"
"/library/collections/hashtables.factor"
"/library/collections/namespaces.factor"
"/library/collections/vectors-epilogue.factor"
"/library/collections/sequence-eq.factor"
"/library/collections/slicing.factor"
"/library/collections/sequence-sort.factor"
"/library/collections/strings-epilogue.factor"
"/library/collections/tree-each.factor"
"/library/collections/queues.factor"
"/library/math/matrices.factor"
"/library/math/parse-numbers.factor"
"/library/words.factor"
"/library/vocabularies.factor"
@ -60,41 +69,67 @@ parser prettyprint sequences io vectors words ;
"/library/io/string-streams.factor"
"/library/io/c-streams.factor"
"/library/io/files.factor"
"/library/io/binary.factor"
"/library/threads.factor"
"/library/syntax/parse-numbers.factor"
"/library/syntax/parse-words.factor"
"/library/syntax/parse-errors.factor"
"/library/syntax/parser.factor"
"/library/syntax/parse-stream.factor"
"/library/generic/generic.factor"
"/library/generic/standard-combination.factor"
"/library/generic/slots.factor"
"/library/generic/math-combination.factor"
"/library/generic/predicate.factor"
"/library/generic/union.factor"
"/library/generic/complement.factor"
"/library/generic/tuple.factor"
"/library/syntax/generic.factor"
"/library/syntax/math.factor"
"/library/syntax/parse-syntax.factor"
"/library/alien/aliens.factor"
"/library/syntax/unparser.factor"
"/library/syntax/prettyprint.factor"
"/library/tools/gensym.factor"
"/library/io/logging.factor"
"/library/tools/interpreter.factor"
"/library/tools/debugger.factor"
"/library/tools/memory.factor"
"/library/tools/listener.factor"
"/library/tools/walker.factor"
"/library/tools/jedit.factor"
"/library/tools/annotations.factor"
"/library/tools/inspector.factor"
"/library/test/test.factor"
"/library/syntax/see.factor"
"/library/threads.factor"
"/library/tools/telnetd.factor"
"/library/bootstrap/image.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/inference/recursive-values.factor"
"/library/inference/class-infer.factor"
"/library/inference/kill-literals.factor"
"/library/inference/split-nodes.factor"
"/library/inference/optimizer.factor"
"/library/inference/inline-methods.factor"
"/library/inference/known-words.factor"
"/library/inference/call-optimizers.factor"
"/library/inference/print-dataflow.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"
@ -103,82 +138,23 @@ parser prettyprint sequences io vectors words ;
"/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
"object" [ "generic" ] search
"typemap" [ "generic" ] search
"builtins" [ "generic" ] search
vocabularies get [ "generic" off ] bind
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"
"/library/generic/slots.factor"
"/library/generic/object.factor"
"/library/generic/null.factor"
"/library/generic/builtin.factor"
"/library/generic/predicate.factor"
"/library/generic/union.factor"
"/library/generic/complement.factor"
"/library/generic/tuple.factor"
"/library/bootstrap/init.factor"
] pull-in
} [ dup print parse-resource % ] each
[
"Building generics..." print
all-words [ generic? ] subset [ make-generic ] each
] %
] make-list
swap
[
"/library/bootstrap/boot-stage2.factor" run-resource
]
append3
[ "/library/bootstrap/boot-stage2.factor" run-resource ] %
] [ ] make
vocabularies get [
"!syntax" get "syntax" set
"syntax" get [
cdr dup word? [
"syntax" "vocabulary" set-word-prop
] [
drop
] ifte
] hash-each
"syntax" get hash-values [ word? ] subset
[ "syntax" swap set-word-vocabulary ] each
] bind
"!syntax" vocabularies get remove-hash
FORGET: pull-in

128
library/bootstrap/boot-stage2.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
USING: alien assembler command-line compiler generic hashtables
kernel lists memory namespaces parser sequences io unparser
USING: alien assembler command-line compiler compiler-backend
errors generic hashtables io io-internals kernel
kernel-internals lists math memory namespaces parser sequences
words ;
\ fiber? t "inline" set-word-prop
: pull-in ( ? list -- )
swap [
[
@ -35,4 +34,123 @@ cpu "ppc" = [
"/library/compiler/ppc/alien.factor"
] pull-in
"/library/bootstrap/boot-stage3.factor" run-resource
"statically-linked" get [
unix? [
"sdl" "libSDL.so" "cdecl" add-library
"sdl-gfx" "libSDL_gfx.so" "cdecl" add-library
"sdl-ttf" "libSDL_ttf.so" "cdecl" add-library
] when
win32? [
"kernel32" "kernel32.dll" "stdcall" add-library
"user32" "user32.dll" "stdcall" add-library
"gdi32" "gdi32.dll" "stdcall" add-library
"winsock" "ws2_32.dll" "stdcall" add-library
"mswsock" "mswsock.dll" "stdcall" add-library
"libc" "msvcrt.dll" "cdecl" add-library
"sdl" "SDL.dll" "cdecl" add-library
"sdl-gfx" "SDL_gfx.dll" "cdecl" add-library
"sdl-ttf" "SDL_ttf.dll" "cdecl" add-library
] when
] unless
"Loading more library code..." print
t [
"/library/alien/malloc.factor"
"/library/io/buffer.factor"
"/library/math/constants.factor"
"/library/math/pow.factor"
"/library/math/trig-hyp.factor"
"/library/math/arc-trig-hyp.factor"
"/library/httpd/load.factor"
"/library/sdl/load.factor"
"/library/ui/load.factor"
"/library/help/tutorial.factor"
] pull-in
: compile? "compile" get supported-cpu? and ;
compile? [
"Compiling base..." print
[ car * = string>number number>string scan (generate) ]
[ compile ]
each
] when
compile? [
unix? [
"/library/unix/types.factor"
] pull-in
os "freebsd" = [
"/library/unix/syscalls-freebsd.factor"
] pull-in
os "linux" = [
"/library/unix/syscalls-linux.factor"
] pull-in
os "macosx" = [
"/library/unix/syscalls-macosx.factor"
] pull-in
unix? [
"/library/unix/syscalls.factor"
"/library/unix/io.factor"
"/library/unix/sockets.factor"
"/library/unix/files.factor"
] pull-in
os "win32" = [
"/library/win32/win32-io.factor"
"/library/win32/win32-errors.factor"
"/library/win32/winsock.factor"
"/library/win32/win32-io-internals.factor"
"/library/win32/win32-stream.factor"
"/library/win32/win32-server.factor"
"/library/bootstrap/win32-io.factor"
] pull-in
] when
"Building cross-reference database..." print
recrossref
compile? [
"Compiling system..." print
compile-all
terpri
"Unless you're working on the compiler, ignore the errors above." print
"Not every word compiles, by design." print
terpri
"Initializing native I/O..." print
init-io
] when
[
boot
run-user-init
"shell" get [ "shells" ] search execute
0 exit
] set-boot
0 [ compiled? [ 1 + ] when ] each-word
number>string write " words compiled" print
0 [ drop 1 + ] each-word
number>string write " words total" print
"Total bootstrap GC time: " write gc-time
number>string write " ms" print
"Bootstrapping is complete." print
"Now, you can run ./f factor.image" print
"factor.image" save-image
0 exit
FORGET: pull-in
FORGET: compile?

131
library/bootstrap/boot-stage3.factor
View File

@ -1,131 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
USING: alien assembler command-line compiler compiler-backend
compiler-frontend io-internals kernel lists math namespaces
parser sequences io unparser words ;
"Compiling base..." print
unix? [
"sdl" "libSDL.so" "cdecl" add-library
"sdl-gfx" "libSDL_gfx.so" "cdecl" add-library
"sdl-ttf" "libSDL_ttf.so" "cdecl" add-library
] when
win32? [
"kernel32" "kernel32.dll" "stdcall" add-library
"user32" "user32.dll" "stdcall" add-library
"gdi32" "gdi32.dll" "stdcall" add-library
"winsock" "ws2_32.dll" "stdcall" add-library
"mswsock" "mswsock.dll" "stdcall" add-library
"libc" "msvcrt.dll" "cdecl" add-library
"sdl" "SDL.dll" "cdecl" add-library
"sdl-gfx" "SDL_gfx.dll" "cdecl" add-library
"sdl-ttf" "SDL_ttf.dll" "cdecl" add-library
] when
default-cli-args
parse-command-line
init-assembler
: compile? "compile" get supported-cpu? and ;
"library/inference/branches.factor" run-file
compile? [
\ car compile
\ * compile
\ length compile
\ = compile
\ unparse compile
\ scan compile
\ optimize compile
\ (generate) compile
] when
"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/math/trig-hyp.factor"
"/library/math/arc-trig-hyp.factor"
"/library/math/random.factor"
"/library/in-thread.factor"
"/library/io/directories.factor"
"/library/io/binary.factor"
"/library/eval-catch.factor"
"/library/tools/listener.factor"
"/library/tools/word-tools.factor"
"/library/syntax/see.factor"
"/library/test/test.factor"
"/library/inference/test.factor"
"/library/tools/walker.factor"
"/library/tools/annotations.factor"
"/library/tools/inspector.factor"
"/library/bootstrap/image.factor"
"/library/io/logging.factor"
"/library/tools/telnetd.factor"
"/library/tools/jedit.factor"
"/library/httpd/load.factor"
"/library/sdl/load.factor"
"/library/ui/load.factor"
"/library/help/tutorial.factor"
] pull-in
compile? [
unix? [
"/library/unix/types.factor"
] pull-in
os "freebsd" = [
"/library/unix/syscalls-freebsd.factor"
] pull-in
os "linux" = [
"/library/unix/syscalls-linux.factor"
] pull-in
os "macosx" = [
"/library/unix/syscalls-macosx.factor"
] pull-in
unix? [
"/library/unix/syscalls.factor"
"/library/unix/io.factor"
"/library/unix/sockets.factor"
"/library/unix/files.factor"
] pull-in
os "win32" = [
"/library/win32/win32-io.factor"
"/library/win32/win32-errors.factor"
"/library/win32/winsock.factor"
"/library/win32/win32-io-internals.factor"
"/library/win32/win32-stream.factor"
"/library/win32/win32-server.factor"
"/library/bootstrap/win32-io.factor"
] pull-in
] when
compile? [
"Compiling system..." print
compile-all
"Initializing native I/O..." print
init-io
] when
FORGET: pull-in
FORGET: compile?
"/library/bootstrap/boot-stage4.factor" dup print run-resource

54
library/bootstrap/boot-stage4.factor
View File

@ -1,54 +0,0 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel
USING: alien assembler command-line compiler console errors
generic inference kernel-internals listener lists math memory
namespaces parser presentation prettyprint random io
unparser words ;
"Bootstrap stage 4..." print
: warm-boot ( -- )
#! A fully bootstrapped image has this as the boot
#! quotation.
init-assembler
init-error-handler
default-cli-args
parse-command-line
"null-stdio" get [ << null-stream f >> stdio set ] when ;
: shell ( str -- )
#! This handles the -shell:<foo> cli argument.
[ "shells" ] search execute ;
[
boot
warm-boot
run-user-init
"shell" get shell
0 exit
] set-boot
warm-boot
terpri
"Unless you're working on the compiler, ignore the errors above." print
"Not every word compiles, by design." print
terpri
0 [ compiled? [ 1 + ] when ] each-word
unparse write " words compiled" print
0 [ drop 1 + ] each-word
unparse write " words total" print
"Total bootstrap GC time: " write gc-time unparse write " ms" print
"Bootstrapping is complete." print
"Now, you can run ./f factor.image" print
! Save a bit of space
global [ stdio off ] bind
"factor.image" save-image
0 exit

217
library/bootstrap/image.factor
View File

@ -8,25 +8,31 @@
! generate the minimal image, and writing the cons cells, words,
! strings etc to the image file in the CFactor object memory
! format.
!
! What is a bootstrap image? It basically contains enough code
! to parse a source file. See platform/native/boot.factor --
! It initializes the core interpreter services, and proceeds to
! run platform/native/boot-stage2.factor.
IN: image
USING: errors generic hashtables kernel lists
math namespaces parser prettyprint sequences sequences io
strings vectors words ;
! If true in current namespace, we are bootstrapping.
SYMBOL: bootstrapping?
! The image being constructed; a vector of word-size integers
SYMBOL: image
! Boot quotation, set by boot.factor
SYMBOL: boot-quot
! Object cache
SYMBOL: objects
! Image output format
SYMBOL: big-endian
SYMBOL: 64-bits
SYMBOL: t-object
: emit ( cell -- ) image get push ;
: emit-seq ( seq -- ) image get swap nappend ;
: fixup ( value offset -- ) image get set-nth ;
( Object memory )
@ -34,8 +40,8 @@ SYMBOL: boot-quot
: image-magic HEX: 0f0e0d0c ;
: image-version 0 ;
: cell "64-bits" get 8 4 ? ;
: char "64-bits" get 4 2 ? ;
: cell 64-bits get 8 4 ? ;
: char 64-bits get 4 2 ? ;
: untag ( cell tag -- ) tag-mask bitnot bitand ;
: tag ( cell -- tag ) tag-mask bitand ;
@ -45,6 +51,7 @@ SYMBOL: boot-quot
: hashtable-type 10 ; inline
: vector-type 11 ; inline
: string-type 12 ; inline
: wrapper-type 14 ; inline
: word-type 17 ; inline
: tuple-type 18 ; inline
@ -53,12 +60,7 @@ SYMBOL: boot-quot
( Image header )
: base
#! We relocate the image to after the header, and leaving
#! some empty cells. This lets us differentiate an F pointer
#! (0/tag 3) from a pointer to the first object in the
#! image.
64 cell * ;
: base 1024 ;
: header ( -- )
image-magic emit
@ -95,14 +97,6 @@ GENERIC: ' ( obj -- ptr )
: align-here ( -- )
here 8 mod 4 = [ 0 emit ] when ;
( Remember what objects we've compiled )
: pooled-object ( object -- pointer )
"objects" get hash ;
: pool-object ( object pointer -- )
swap "objects" get set-hash ;
( Fixnums )
: emit-fixnum ( n -- ) fixnum-tag immediate emit ;
@ -115,11 +109,11 @@ M: bignum ' ( bignum -- tagged )
#! This can only emit 0, -1 and 1.
bignum-tag here-as >r
bignum-tag >header emit
[
{{
[[ 0 [ 1 0 ] ]]
[[ -1 [ 2 1 1 ] ]]
[[ 1 [ 2 0 1 ] ]]
] assoc unswons emit-fixnum [ emit ] each align-here r> ;
}} hash unswons emit-fixnum emit-seq align-here r> ;
( Special objects )
@ -127,11 +121,11 @@ M: bignum ' ( bignum -- tagged )
: t,
object-tag here-as
dup t-offset fixup "t" set
dup t-offset fixup t-object set
t-type >header emit
0 ' emit ;
M: t ' ( obj -- ptr ) drop "t" get ;
M: t ' ( obj -- ptr ) drop t-object get ;
M: f ' ( obj -- ptr )
#! f is #define F RETAG(0,OBJECT_TYPE)
drop object-tag ;
@ -148,37 +142,49 @@ M: f ' ( obj -- ptr )
( Words )
: word, ( word -- )
[
word-type >header ,
dup hashcode fixnum-tag immediate ,
0 ,
dup word-primitive ,
dup word-def ' ,
dup word-props ' ,
] make-list
swap object-tag here-as pool-object
[ emit ] each ;
: emit-word ( word -- )
dup word-props ' >r
dup word-def ' >r
dup word-primitive ' >r
dup word-vocabulary ' >r
dup word-name ' >r
object-tag here-as over objects get set-hash
word-type >header emit
hashcode emit-fixnum
r> emit
r> emit
r> emit
r> emit
r> emit
0 emit ;
: word-error ( word msg -- )
[ % dup word-vocabulary % " " % word-name % ] make-string
throw ;
[ % dup word-vocabulary % " " % word-name % ] "" make
throw ; inline
: transfer-word ( word -- word )
#! This is a hack. See doc/bootstrap.txt.
dup dup word-name swap word-vocabulary unit search
dup dup word-name swap word-vocabulary lookup
[ ] [ dup "Missing DEFER: " word-error ] ?ifte ;
: pooled-object ( object -- ptr ) objects get hash ;
: fixup-word ( word -- offset )
dup pooled-object [ ] [ "Not in image: " word-error ] ?ifte ;
transfer-word dup pooled-object dup
[ nip ] [ "Not in image: " word-error ] ifte ;
: fixup-words ( -- )
image get [
dup word? [ fixup-word ] when
] map image set ;
image get [ dup word? [ fixup-word ] when ] nmap ;
M: word ' ( word -- pointer )
transfer-word dup pooled-object dup [ nip ] [ drop ] ifte ;
M: word ' ( word -- pointer ) ;
( Wrappers )
M: wrapper ' ( wrapper -- pointer )
wrapped '
object-tag here-as >r
wrapper-type >header emit
emit r> ;
( Conses )
@ -189,37 +195,25 @@ M: cons ' ( c -- tagged )
( Strings )
: align-string ( n str -- )
tuck length - CHAR: \0 fill append ;
: emit-chars ( seq -- )
big-endian get [ [ reverse ] map ] unless
[ 0 [ swap 16 shift + ] reduce emit ] each ;
: emit-chars ( str -- )
"big-endian" get [ reverse ] unless
0 swap [ swap 16 shift + ] each emit ;
: pack-string ( string -- seq )
dup length 1 + char align CHAR: \0 pad-right char swap group ;
: (pack-string) ( n list -- )
#! Emit bytes for a string, with n characters per word.
[
2dup length > [ dupd align-string ] when
emit-chars
] each drop ;
: pack-string ( string -- )
char tuck swap group (pack-string) ;
: emit-string ( string -- )
: emit-string ( string -- ptr )
object-tag here-as swap
string-type >header emit
dup length emit-fixnum
dup hashcode emit-fixnum
"\0" append pack-string
pack-string emit-chars
align-here ;
M: string ' ( string -- pointer )
#! We pool strings so that each string is only written once
#! to the image
dup pooled-object [ ] [
dup emit-string dup >r pool-object r>
] ?ifte ;
objects get [ emit-string ] cache ;
( Arrays and vectors )
@ -228,13 +222,13 @@ M: string ' ( string -- pointer )
object-tag here-as >r
>header emit
dup length emit-fixnum
( elements -- ) [ emit ] each
( elements -- ) emit-seq
align-here r> ;
M: tuple ' ( tuple -- pointer )
<mirror> tuple-type emit-array ;
: emit-vector ( vector -- pointer )
M: vector ' ( vector -- pointer )
dup array-type emit-array swap length
object-tag here-as >r
vector-type >header emit
@ -242,94 +236,83 @@ M: tuple ' ( tuple -- pointer )
emit ( array ptr )
align-here r> ;
M: vector ' ( vector -- pointer )
emit-vector ;
( Hashes )
: emit-hashtable ( hash -- pointer )
dup buckets>list array-type emit-array
swap hash>alist length
M: hashtable ' ( hashtable -- pointer )
dup buckets>vector array-type emit-array
swap hash-size
object-tag here-as >r
hashtable-type >header emit
emit-fixnum ( length )
emit ( array ptr )
align-here r> ;
M: hashtable ' ( hashtable -- pointer )
#! Only hashtables are pooled, not vectors!
dup pooled-object [ ] [
dup emit-hashtable [ pool-object ] keep
] ?ifte ;
( End of the image )
: vocabulary, ( hash -- )
dup hashtable? [
[ cdr dup word? [ word, ] [ drop ] ifte ] hash-each
] [
drop
] ifte ;
: vocabularies, ( vocabularies -- )
[ cdr vocabulary, ] hash-each ;
: words, ( -- )
all-words [ emit-word ] each ;
: global, ( -- )
vocabularies get
dup vocabularies,
<namespace> [
vocabularies set
typemap [ ] change
builtins [ ] change
crossref [ ] change
] extend '
[
{ vocabularies typemap builtins } [ [ ] change ] each
] make-hash '
global-offset fixup ;
: boot, ( quot -- )
boot-quot get swap append ' boot-quot-offset fixup ;
: boot, ( quot -- ) ' boot-quot-offset fixup ;
: heap-size image get length header-size - cell * ;
: end ( quot -- )
"Generating words..." print
words,
"Generating global namespace..." print
global,
"Generating boot quotation..." print
boot,
"Performing some word fixups..." print
fixup-words
here base - heap-size-offset fixup ;
heap-size heap-size-offset fixup ;
( Image output )
: (write-image) ( image -- )
"64-bits" get 8 4 ? swap "big-endian" get [
64-bits get 8 4 ? swap big-endian get [
[ swap >be write ] each-with
] [
[ swap >le write ] each-with
] ifte ;
: write-image ( image file -- )
"Writing image to " write dup write "..." print
<file-writer> [ (write-image) ] with-stream ;
: with-minimal-image ( quot -- image )
: with-image ( quot -- image )
[
300000 <vector> image set
<namespace> "objects" set
bootstrapping? on
800000 <vector> image set
20000 <hashtable> objects set
call
"Image length: " write image get length .
"Object cache size: " write objects get hash-size .
image get
] with-scope ;
: with-image ( quot -- image )
#! The quotation leaves a boot quotation on the stack.
[ begin call end ] with-minimal-image ;
: make-image ( name -- )
#! Make an image for the C interpreter.
#! Make a bootstrap image.
[
boot-quot off
begin
"/library/bootstrap/boot-stage1.factor" run-resource
namespace global [ "foobar" set ] bind
end
] with-image
swap write-image ;
: make-images ( -- )
"64-bits" off
"big-endian" off "boot.image.le32" make-image
"big-endian" on "boot.image.be32" make-image
"64-bits" on
"big-endian" off "boot.image.le64" make-image
"big-endian" on "boot.image.be64" make-image
"64-bits" off ;
64-bits off
big-endian off "boot.image.le32" make-image
big-endian on "boot.image.be32" make-image
64-bits on
big-endian off "boot.image.le64" make-image
big-endian on "boot.image.be64" make-image
64-bits off ;

12
library/bootstrap/init.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel
USING: io-internals namespaces parser io threads words ;
IN: kernel-internals
USING: assembler command-line errors io io-internals kernel
namespaces parser threads words ;
: boot ( -- )
#! Initialize an interpreter with the basic services.
@ -9,4 +10,9 @@ USING: io-internals namespaces parser io threads words ;
init-threads
init-io
"HOME" os-env [ "." ] unless* "~" set
init-search-path ;
init-search-path
init-assembler
init-error-handler
default-cli-args
parse-command-line
"null-stdio" get [ << null-stream f >> stdio set ] when ;

524
library/bootstrap/primitives.factor
View File

@ -1,228 +1,332 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: image
USING: kernel lists math memory namespaces parser words vectors
hashtables generic alien assembler compiler errors files generic
io-internals kernel kernel-internals lists math math-internals
parser profiler strings unparser vectors words hashtables
sequences ;
USING: alien generic hashtables io kernel kernel-internals lists
math namespaces sequences strings vectors words ;
! This symbol needs the same hashcode in the target as in the
! Some very tricky code creating a bootstrap embryo in the
! host image.
"Creating primitives and basic runtime structures..." print
! These symbols need the same hashcode in the target as in the
! host.
vocabularies
{ vocabularies object null typemap builtins }
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab clone
"generic" vocab clone
"syntax" vocab
<namespace> vocabularies set
<namespace> typemap set
num-types <vector> builtins set
<namespace> crossref set
{{ }} clone vocabularies set
f crossref set
vocabularies get [
"generic" set
"syntax" set
reveal
] bind
vocabularies get [ "syntax" set [ reveal ] each ] bind
: set-stack-effect ( [ vocab word effect ] -- )
3unlist >r unit search r> dup string? [
"stack-effect" set-word-prop
] [
"infer-effect" set-word-prop
] ifte ;
: make-primitive ( { vocab word } n -- )
>r first2 create r> f define ;
: make-primitive ( n [ vocab word effect ] -- n )
[ 2unlist create >r 1 + r> over f define ] keep
set-stack-effect ;
{
{ "execute" "words" }
{ "call" "kernel" }
{ "ifte" "kernel" }
{ "dispatch" "kernel-internals" }
{ "cons" "lists" }
{ "<vector>" "vectors" }
{ "rehash-string" "strings" }
{ "<sbuf>" "strings" }
{ "sbuf>string" "strings" }
{ ">fixnum" "math" }
{ ">bignum" "math" }
{ ">float" "math" }
{ "(fraction>)" "math-internals" }
{ "string>float" "math-internals" }
{ "float>string" "math-internals" }
{ "float>bits" "math" }
{ "double>bits" "math" }
{ "bits>float" "math" }
{ "bits>double" "math" }
{ "<complex>" "math-internals" }
{ "fixnum+" "math-internals" }
{ "fixnum-" "math-internals" }
{ "fixnum*" "math-internals" }
{ "fixnum/i" "math-internals" }
{ "fixnum/f" "math-internals" }
{ "fixnum-mod" "math-internals" }
{ "fixnum/mod" "math-internals" }
{ "fixnum-bitand" "math-internals" }
{ "fixnum-bitor" "math-internals" }
{ "fixnum-bitxor" "math-internals" }
{ "fixnum-bitnot" "math-internals" }
{ "fixnum-shift" "math-internals" }
{ "fixnum<" "math-internals" }
{ "fixnum<=" "math-internals" }
{ "fixnum>" "math-internals" }
{ "fixnum>=" "math-internals" }
{ "bignum=" "math-internals" }
{ "bignum+" "math-internals" }
{ "bignum-" "math-internals" }
{ "bignum*" "math-internals" }
{ "bignum/i" "math-internals" }
{ "bignum/f" "math-internals" }
{ "bignum-mod" "math-internals" }
{ "bignum/mod" "math-internals" }
{ "bignum-bitand" "math-internals" }
{ "bignum-bitor" "math-internals" }
{ "bignum-bitxor" "math-internals" }
{ "bignum-bitnot" "math-internals" }
{ "bignum-shift" "math-internals" }
{ "bignum<" "math-internals" }
{ "bignum<=" "math-internals" }
{ "bignum>" "math-internals" }
{ "bignum>=" "math-internals" }
{ "float=" "math-internals" }
{ "float+" "math-internals" }
{ "float-" "math-internals" }
{ "float*" "math-internals" }
{ "float/f" "math-internals" }
{ "float<" "math-internals" }
{ "float<=" "math-internals" }
{ "float>" "math-internals" }
{ "float>=" "math-internals" }
{ "facos" "math-internals" }
{ "fasin" "math-internals" }
{ "fatan" "math-internals" }
{ "fatan2" "math-internals" }
{ "fcos" "math-internals" }
{ "fexp" "math-internals" }
{ "fcosh" "math-internals" }
{ "flog" "math-internals" }
{ "fpow" "math-internals" }
{ "fsin" "math-internals" }
{ "fsinh" "math-internals" }
{ "fsqrt" "math-internals" }
{ "<word>" "words" }
{ "update-xt" "words" }
{ "compiled?" "words" }
{ "drop" "kernel" }
{ "dup" "kernel" }
{ "swap" "kernel" }
{ "over" "kernel" }
{ "pick" "kernel" }
{ ">r" "kernel" }
{ "r>" "kernel" }
{ "eq?" "kernel" }
{ "getenv" "kernel-internals" }
{ "setenv" "kernel-internals" }
{ "stat" "io" }
{ "(directory)" "io" }
{ "gc" "memory" }
{ "gc-time" "memory" }
{ "save-image" "memory" }
{ "datastack" "kernel" }
{ "callstack" "kernel" }
{ "set-datastack" "kernel" }
{ "set-callstack" "kernel" }
{ "exit" "kernel" }
{ "room" "memory" }
{ "os-env" "kernel" }
{ "millis" "kernel" }
{ "(random-int)" "math" }
{ "type" "kernel" }
{ "tag" "kernel-internals" }
{ "cwd" "io" }
{ "cd" "io" }
{ "compiled-offset" "assembler" }
{ "set-compiled-offset" "assembler" }
{ "literal-top" "assembler" }
{ "set-literal-top" "assembler" }
{ "address" "memory" }
{ "dlopen" "alien" }
{ "dlsym" "alien" }
{ "dlclose" "alien" }
{ "<alien>" "alien" }
{ "<byte-array>" "kernel-internals" }
{ "<displaced-alien>" "alien" }
{ "alien-signed-cell" "alien" }
{ "set-alien-signed-cell" "alien" }
{ "alien-unsigned-cell" "alien" }
{ "set-alien-unsigned-cell" "alien" }
{ "alien-signed-8" "alien" }
{ "set-alien-signed-8" "alien" }
{ "alien-unsigned-8" "alien" }
{ "set-alien-unsigned-8" "alien" }
{ "alien-signed-4" "alien" }
{ "set-alien-signed-4" "alien" }
{ "alien-unsigned-4" "alien" }
{ "set-alien-unsigned-4" "alien" }
{ "alien-signed-2" "alien" }
{ "set-alien-signed-2" "alien" }
{ "alien-unsigned-2" "alien" }
{ "set-alien-unsigned-2" "alien" }
{ "alien-signed-1" "alien" }
{ "set-alien-signed-1" "alien" }
{ "alien-unsigned-1" "alien" }
{ "set-alien-unsigned-1" "alien" }
{ "alien-float" "alien" }
{ "set-alien-float" "alien" }
{ "alien-double" "alien" }
{ "set-alien-double" "alien" }
{ "alien-c-string" "alien" }
{ "set-alien-c-string" "alien" }
{ "throw" "errors" }
{ "string>memory" "kernel-internals" }
{ "memory>string" "kernel-internals" }
{ "alien-address" "alien" }
{ "slot" "kernel-internals" }
{ "set-slot" "kernel-internals" }
{ "integer-slot" "kernel-internals" }
{ "set-integer-slot" "kernel-internals" }
{ "char-slot" "kernel-internals" }
{ "set-char-slot" "kernel-internals" }
{ "resize-array" "kernel-internals" }
{ "resize-string" "strings" }
{ "<hashtable>" "hashtables" }
{ "<array>" "kernel-internals" }
{ "<tuple>" "kernel-internals" }
{ "begin-scan" "memory" }
{ "next-object" "memory" }
{ "end-scan" "memory" }
{ "size" "memory" }
{ "die" "kernel" }
{ "flush-icache" "assembler" }
{ "fopen" "io-internals" }
{ "fgetc" "io-internals" }
{ "fwrite" "io-internals" }
{ "fflush" "io-internals" }
{ "fclose" "io-internals" }
{ "expired?" "alien" }
{ "<wrapper>" "kernel" }
} dup length 3 swap [ + ] map-with [ make-primitive ] 2each
2 [
[ "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 ] ] ]
[ "rehash-string" "strings" [ [ string ] [ ] ] ]
[ "<sbuf>" "strings" [ [ integer ] [ sbuf ] ] ]
[ "sbuf>string" "strings" [ [ sbuf ] [ string ] ] ]
[ "arithmetic-type" "math-internals" [ [ object object ] [ object object fixnum ] ] ]
[ ">fixnum" "math" [ [ number ] [ fixnum ] ] ]
[ ">bignum" "math" [ [ number ] [ bignum ] ] ]
[ ">float" "math" [ [ number ] [ float ] ] ]
[ "(fraction>)" "math-internals" [ [ integer integer ] [ rational ] ] ]
[ "str>float" "parser" [ [ string ] [ float ] ] ]
[ "(unparse-float)" "unparser" [ [ float ] [ string ] ] ]
[ "float>bits" "math" [ [ real ] [ integer ] ] ]
[ "double>bits" "math" [ [ real ] [ integer ] ] ]
[ "bits>float" "math" [ [ integer ] [ float ] ] ]
[ "bits>double" "math" [ [ integer ] [ float ] ] ]
[ "<complex>" "math-internals" [ [ real real ] [ number ] ] ]
[ "fixnum+" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ]
[ "fixnum-" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ]
[ "fixnum*" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ]
[ "fixnum/i" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ]
[ "fixnum/f" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ]
[ "fixnum-mod" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ]
[ "fixnum/mod" "math-internals" [ [ fixnum fixnum ] [ integer fixnum ] ] ]
[ "fixnum-bitand" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ]
[ "fixnum-bitor" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ]
[ "fixnum-bitxor" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ]
[ "fixnum-bitnot" "math-internals" [ [ fixnum ] [ fixnum ] ] ]
[ "fixnum-shift" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ]
[ "fixnum<" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] ]
[ "fixnum<=" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] ]
[ "fixnum>" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] ]
[ "fixnum>=" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] ]
[ "bignum=" "math-internals" [ [ bignum bignum ] [ boolean ] ] ]
[ "bignum+" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum-" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum*" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum/i" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum/f" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum-mod" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum/mod" "math-internals" [ [ bignum bignum ] [ bignum bignum ] ] ]
[ "bignum-bitand" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum-bitor" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum-bitxor" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum-bitnot" "math-internals" [ [ bignum ] [ bignum ] ] ]
[ "bignum-shift" "math-internals" [ [ bignum bignum ] [ bignum ] ] ]
[ "bignum<" "math-internals" [ [ bignum bignum ] [ boolean ] ] ]
[ "bignum<=" "math-internals" [ [ bignum bignum ] [ boolean ] ] ]
[ "bignum>" "math-internals" [ [ bignum bignum ] [ boolean ] ] ]
[ "bignum>=" "math-internals" [ [ bignum bignum ] [ boolean ] ] ]
[ "float=" "math-internals" [ [ bignum bignum ] [ boolean ] ] ]
[ "float+" "math-internals" [ [ float float ] [ float ] ] ]
[ "float-" "math-internals" [ [ float float ] [ float ] ] ]
[ "float*" "math-internals" [ [ float float ] [ float ] ] ]
[ "float/f" "math-internals" [ [ float float ] [ float ] ] ]
[ "float<" "math-internals" [ [ float float ] [ boolean ] ] ]
[ "float<=" "math-internals" [ [ float float ] [ boolean ] ] ]
[ "float>" "math-internals" [ [ float float ] [ boolean ] ] ]
[ "float>=" "math-internals" [ [ float float ] [ boolean ] ] ]
[ "facos" "math-internals" [ [ real ] [ float ] ] ]
[ "fasin" "math-internals" [ [ real ] [ float ] ] ]
[ "fatan" "math-internals" [ [ real ] [ float ] ] ]
[ "fatan2" "math-internals" [ [ real real ] [ float ] ] ]
[ "fcos" "math-internals" [ [ real ] [ float ] ] ]
[ "fexp" "math-internals" [ [ real ] [ float ] ] ]
[ "fcosh" "math-internals" [ [ real ] [ float ] ] ]
[ "flog" "math-internals" [ [ real ] [ float ] ] ]
[ "fpow" "math-internals" [ [ real real ] [ float ] ] ]
[ "fsin" "math-internals" [ [ real ] [ float ] ] ]
[ "fsinh" "math-internals" [ [ real ] [ float ] ] ]
[ "fsqrt" "math-internals" [ [ real ] [ float ] ] ]
[ "<word>" "words" [ [ ] [ word ] ] ]
[ "update-xt" "words" [ [ word ] [ ] ] ]
[ "compiled?" "words" [ [ word ] [ boolean ] ] ]
[ "drop" "kernel" [ [ object ] [ ] ] ]
[ "dup" "kernel" [ [ object ] [ object object ] ] ]
[ "swap" "kernel" [ [ object object ] [ object object ] ] ]
[ "over" "kernel" [ [ object object ] [ object object object ] ] ]
[ "pick" "kernel" [ [ object object object ] [ object object object object ] ] ]
[ ">r" "kernel" [ [ object ] [ ] ] ]
[ "r>" "kernel" [ [ ] [ object ] ] ]
[ "eq?" "kernel" [ [ object object ] [ boolean ] ] ]
[ "getenv" "kernel-internals" [ [ fixnum ] [ object ] ] ]
[ "setenv" "kernel-internals" [ [ object fixnum ] [ ] ] ]
[ "stat" "io" [ [ string ] [ general-list ] ] ]
[ "(directory)" "io" [ [ string ] [ general-list ] ] ]
[ "gc" "memory" [ [ fixnum ] [ ] ] ]
[ "gc-time" "memory" [ [ string ] [ ] ] ]
[ "save-image" "memory" [ [ string ] [ ] ] ]
[ "datastack" "kernel" " -- ds " ]
[ "callstack" "kernel" " -- cs " ]
[ "set-datastack" "kernel" " ds -- " ]
[ "set-callstack" "kernel" " cs -- " ]
[ "exit" "kernel" [ [ integer ] [ ] ] ]
[ "room" "memory" [ [ ] [ integer integer integer integer general-list ] ] ]
[ "os-env" "kernel" [ [ string ] [ object ] ] ]
[ "millis" "kernel" [ [ ] [ integer ] ] ]
[ "(random-int)" "math" [ [ ] [ integer ] ] ]
[ "type" "kernel" [ [ object ] [ fixnum ] ] ]
[ "cwd" "io" [ [ ] [ string ] ] ]
[ "cd" "io" [ [ string ] [ ] ] ]
[ "compiled-offset" "assembler" [ [ ] [ integer ] ] ]
[ "set-compiled-offset" "assembler" [ [ integer ] [ ] ] ]
[ "literal-top" "assembler" [ [ ] [ integer ] ] ]
[ "set-literal-top" "assembler" [ [ integer ] [ ] ] ]
[ "address" "memory" [ [ object ] [ integer ] ] ]
[ "dlopen" "alien" [ [ string ] [ dll ] ] ]
[ "dlsym" "alien" [ [ string object ] [ integer ] ] ]
[ "dlclose" "alien" [ [ dll ] [ ] ] ]
[ "<alien>" "alien" [ [ integer ] [ alien ] ] ]
[ "<byte-array>" "kernel-internals" [ [ integer ] [ byte-array ] ] ]
[ "<displaced-alien>" "alien" [ [ integer c-ptr ] [ displaced-alien ] ] ]
[ "alien-signed-cell" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-signed-cell" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-unsigned-cell" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-unsigned-cell" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-signed-8" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-signed-8" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-unsigned-8" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-unsigned-8" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-signed-4" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-signed-4" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-unsigned-4" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-unsigned-4" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-signed-2" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-signed-2" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-unsigned-2" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-unsigned-2" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-signed-1" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-signed-1" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-unsigned-1" "alien" [ [ c-ptr integer ] [ integer ] ] ]
[ "set-alien-unsigned-1" "alien" [ [ integer c-ptr integer ] [ ] ] ]
[ "alien-float" "alien" [ [ c-ptr integer ] [ float ] ] ]
[ "set-alien-float" "alien" [ [ float c-ptr integer ] [ ] ] ]
[ "alien-double" "alien" [ [ c-ptr integer ] [ float ] ] ]
[ "set-alien-double" "alien" [ [ float c-ptr integer ] [ ] ] ]
[ "alien-c-string" "alien" [ [ c-ptr integer ] [ string ] ] ]
[ "set-alien-c-string" "alien" [ [ string c-ptr integer ] [ ] ] ]
[ "throw" "errors" [ [ object ] [ ] ] ]
[ "string>memory" "kernel-internals" [ [ string integer ] [ ] ] ]
[ "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] ]
[ "alien-address" "alien" [ [ alien ] [ integer ] ] ]
[ "slot" "kernel-internals" [ [ object fixnum ] [ object ] ] ]
[ "set-slot" "kernel-internals" [ [ object object fixnum ] [ ] ] ]
[ "integer-slot" "kernel-internals" [ [ object fixnum ] [ integer ] ] ]
[ "set-integer-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] ]
[ "char-slot" "kernel-internals" [ [ object fixnum ] [ fixnum ] ] ]
[ "set-char-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] ]
[ "resize-array" "kernel-internals" [ [ integer array ] [ array ] ] ]
[ "resize-string" "strings" [ [ integer string ] [ string ] ] ]
[ "<hashtable>" "hashtables" [ [ number ] [ hashtable ] ] ]
[ "<array>" "kernel-internals" [ [ number ] [ array ] ] ]
[ "<tuple>" "kernel-internals" [ [ number ] [ tuple ] ] ]
[ "begin-scan" "memory" [ [ ] [ ] ] ]
[ "next-object" "memory" [ [ ] [ object ] ] ]
[ "end-scan" "memory" [ [ ] [ ] ] ]
[ "size" "memory" [ [ object ] [ fixnum ] ] ]
[ "die" "kernel" [ [ ] [ ] ] ]
[ "flush-icache" "assembler" f ]
[ "fopen" "io-internals" [ [ string string ] [ alien ] ] ]
[ "fgetc" "io-internals" [ [ alien ] [ object ] ] ]
[ "fwrite" "io-internals" [ [ string alien ] [ ] ] ]
[ "fflush" "io-internals" [ [ alien ] [ ] ] ]
[ "fclose" "io-internals" [ [ alien ] [ ] ] ]
[ "expired?" "alien" [ [ object ] [ boolean ] ] ]
] [
make-primitive
] each drop
: set-stack-effect ( { vocab word effect } -- )
first3 >r lookup r> "stack-effect" set-word-prop ;
! These need a more descriptive comment.
[
[ "drop" "kernel" " x -- " ]
[ "dup" "kernel" " x -- x x " ]
[ "swap" "kernel" " x y -- y x " ]
[ "over" "kernel" " x y -- x y x " ]
[ "pick" "kernel" " x y z -- x y z x " ]
[ ">r" "kernel" " x -- r: x " ]
[ "r>" "kernel" " r: x -- x " ]
] [
{
{ "drop" "kernel" " x -- " }
{ "dup" "kernel" " x -- x x " }
{ "swap" "kernel" " x y -- y x " }
{ "over" "kernel" " x y -- x y x " }
{ "pick" "kernel" " x y z -- x y z x " }
{ ">r" "kernel" " x -- r: x " }
{ "r>" "kernel" " r: x -- x " }
{ "datastack" "kernel" " -- ds " }
{ "callstack" "kernel" " -- cs " }
{ "set-datastack" "kernel" " ds -- " }
{ "set-callstack" "kernel" " cs -- " }
{ "flush-icache" "assembler" " -- " }
} [
set-stack-effect
] each
FORGET: make-primitive
FORGET: set-stack-effect
! Okay, now we have primitives fleshed out. Bring up the generic
! word system.
: builtin-predicate ( class predicate -- )
[ \ type , over types first , \ eq? , ] [ ] make
define-predicate ;
: register-builtin ( class -- )
dup types first builtins get set-nth ;
: define-builtin ( symbol type# predicate slotspec -- )
>r >r >r
dup intern-symbol
dup r> 1vector "types" set-word-prop
dup builtin define-class
dup r> builtin-predicate
dup r> intern-slots 2dup "slots" set-word-prop
define-slots
register-builtin ;
{{ }} clone typemap set
num-types empty-vector builtins set
! Catch-all metaclass for providing a default method.
object num-types >vector "types" set-word-prop
object [ drop t ] "predicate" set-word-prop
object object define-class
! Null metaclass with no instances.
null { } "types" set-word-prop
null [ drop f ] "predicate" set-word-prop
null null define-class
"fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin
"fixnum" "math" create 0 "math-priority" set-word-prop
"fixnum" "math" create ">fixnum" [ "math" ] search unit "coercer" set-word-prop
"bignum" "math" create 1 "bignum?" "math" create { } define-builtin
"bignum" "math" create 1 "math-priority" set-word-prop
"bignum" "math" create ">bignum" [ "math" ] search unit "coercer" set-word-prop
"cons" "lists" create 2 "cons?" "lists" create
{ { 0 { "car" "lists" } f } { 1 { "cdr" "lists" } f } } define-builtin
"ratio" "math" create 4 "ratio?" "math" create
{ { 0 { "numerator" "math" } f } { 1 { "denominator" "math" } f } } define-builtin
"ratio" "math" create 2 "math-priority" set-word-prop
"float" "math" create 5 "float?" "math" create { } define-builtin
"float" "math" create 3 "math-priority" set-word-prop
"float" "math" create ">float" [ "math" ] search unit "coercer" set-word-prop
"complex" "math" create 6 "complex?" "math" create
{ { 0 { "real" "math" } f } { 1 { "imaginary" "math" } f } } define-builtin
"complex" "math" create 4 "math-priority" set-word-prop
"t" "!syntax" create 7 "t?" "kernel" create
{ } define-builtin
"array" "kernel-internals" create 8 "array?" "kernel-internals" create
{ } define-builtin
"f" "!syntax" create 9 "not" "kernel" create
{ } define-builtin
"hashtable" "hashtables" create 10 "hashtable?" "hashtables" create {
{ 1 { "hash-size" "hashtables" } { "set-hash-size" "kernel-internals" } }
{ 2 { "hash-array" "kernel-internals" } { "set-hash-array" "kernel-internals" } }
} define-builtin
"vector" "vectors" create 11 "vector?" "vectors" create {
{ 1 { "length" "sequences" } { "set-capacity" "kernel-internals" } }
{ 2 { "underlying" "kernel-internals" } { "set-underlying" "kernel-internals" } }
} define-builtin
"string" "strings" create 12 "string?" "strings" create {
{ 1 { "length" "sequences" } f }
{ 2 { "hashcode" "kernel" } f }
} define-builtin
"sbuf" "strings" create 13 "sbuf?" "strings" create {
{ 1 { "length" "sequences" } { "set-capacity" "kernel-internals" } }
{ 2 { "underlying" "kernel-internals" } { "set-underlying" "kernel-internals" } }
} define-builtin
"wrapper" "kernel" create 14 "wrapper?" "kernel" create
{ { 1 { "wrapped" "kernel" } f } } define-builtin
"dll" "alien" create 15 "dll?" "alien" create
{ { 1 { "dll-path" "alien" } f } } define-builtin
"alien" "alien" create 16 "alien?" "alien" create { } define-builtin
"word" "words" create 17 "word?" "words" create {
{ 1 { "hashcode" "kernel" } f }
{ 2 { "word-name" "words" } f }
{ 3 { "word-vocabulary" "words" } { "set-word-vocabulary" "words" } }
{ 4 { "word-primitive" "words" } { "set-word-primitive" "words" } }
{ 5 { "word-def" "words" } { "set-word-def" "words" } }
{ 6 { "word-props" "words" } { "set-word-props" "words" } }
} define-builtin
"tuple" "kernel" create 18 "tuple?" "kernel" create { } define-builtin
"byte-array" "kernel-internals" create 19 "byte-array?" "kernel-internals" create { } define-builtin
"displaced-alien" "alien" create 20 "displaced-alien?" "alien" create { } define-builtin
FORGET: builtin-predicate
FORGET: register-builtin
FORGET: define-builtin

4
library/bootstrap/win32-io.factor
View File

@ -39,9 +39,9 @@ USE: win32-api
IN: io-internals
: io-multiplex ( timeout -- task )
: io-multiplex ( timeout -- )
#! FIXME: needs to work given a timeout
-1 = [ win32-next-io-task ] when ;
dup -1 = [ drop INFINITE ] when cancel-timedout wait-for-io swap call ;
: init-io ( -- )
win32-init-stdio ;

2
library/cli.factor
View File

@ -8,7 +8,7 @@ sequences strings ;
! on all other words already being defined.
: ?run-file ( file -- )
dup exists? [ (run-file) ] [ drop ] ifte ;
dup exists? [ run-file ] [ drop ] ifte ;
: run-user-init ( -- )
#! Run user init file if it exists

13
library/collections/arrays.factor
View File

@ -17,9 +17,6 @@ DEFER: repeat
IN: kernel-internals
USING: kernel math-internals sequences ;
DEFER: array?
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
@ -34,8 +31,12 @@ M: array resize resize-array ;
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 ;
: make-tuple ( class size -- tuple )
#! Internal allocation function. Do not call it directly,
#! since you can fool the runtime and corrupt memory by
#! specifying an incorrect size. Note that this word is also
#! handled specially by the compiler's type inferencer.
<tuple> [ 2 set-slot ] keep ; flushable

12
library/collections/assoc.factor
View File

@ -2,24 +2,12 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: lists USING: kernel sequences ;
: assoc? ( list -- ? )
#! Push if the list appears to be an alist. An association
#! list is a list of conses where the car of each cons is a
#! key, and the cdr is a value.
dup list? [ [ cons? ] all? ] [ drop f ] ifte ;
: assoc* ( key alist -- [[ key value ]] )
#! Look up a key/value pair.
[ car = ] find-with nip ;
: assoc ( key alist -- value ) assoc* cdr ;
: assq* ( key alist -- [[ key value ]] )
#! Looks up a key/value pair using identity comparison.
[ car eq? ] find-with nip ;
: assq ( key alist -- value ) assq* cdr ;
: remove-assoc ( key alist -- alist )
#! Remove all key/value pairs with this key.
[ car = not ] subset-with ;

53
library/collections/cons.factor
View File

@ -6,69 +6,34 @@ IN: lists USING: generic kernel sequences ;
! else depends on, and is loaded early in bootstrap.
! lists.factor has everything else.
DEFER: cons?
BUILTIN: cons 2 cons? [ 0 "car" f ] [ 1 "cdr" f ] ;
! We borrow an idiom from Common Lisp. The car/cdr of an empty
! list is the empty list.
M: f car ;
M: f cdr ;
UNION: general-list f cons ;
UNION: general-list POSTPONE: f cons ;
GENERIC: >list ( seq -- list )
M: general-list >list ( list -- list ) ;
: last ( list -- last )
#! Last cons of a list.
dup cdr cons? [ cdr last ] when ;
dup cdr cons? [ cdr last ] when ; foldable
PREDICATE: general-list list ( list -- ? )
#! Proper list test. A proper list is either f, or a cons
#! cell whose cdr is a proper list.
dup [ last cdr ] when not ;
: uncons ( [[ car cdr ]] -- car cdr ) dup car swap cdr ;
: unswons ( [[ car cdr ]] -- cdr car ) dup cdr swap car ;
: uncons ( [[ car cdr ]] -- car cdr ) dup car swap cdr ; inline
: unswons ( [[ car cdr ]] -- cdr car ) dup cdr swap car ; inline
: swons ( cdr car -- [[ car cdr ]] ) swap cons ;
: unit ( a -- [ a ] ) f cons ;
: 2list ( a b -- [ a b ] ) unit cons ;
: 3list ( a b c -- [ a b c ] ) 2list cons ;
: 2unlist ( [ a b ] -- a b ) uncons car ;
: 3unlist ( [ a b c ] -- a b c ) uncons uncons car ;
: swons ( cdr car -- [[ car cdr ]] ) swap cons ; inline
: unit ( a -- [ a ] ) f cons ; inline
: 2list ( a b -- [ a b ] ) unit cons ; inline
: 2car ( cons cons -- car car ) swap car swap car ;
: 2cdr ( cons cons -- car car ) swap cdr swap cdr ;
: 2cons ( ca1 ca2 cd1 cd2 -- c1 c2 ) rot swons >r cons r> ;
: 2uncons ( c1 c2 -- ca1 ca2 cd1 cd2 ) [ 2car ] 2keep 2cdr ;
: zip ( list list -- list )
#! Make a new list containing pairs of corresponding
#! elements from the two given lists.
2dup and [ 2uncons zip >r cons r> cons ] [ 2drop [ ] ] ifte ;
: unzip ( assoc -- keys values )
#! Split an association list into two lists of keys and
#! values.
[ uncons >r uncons r> unzip 2cons ] [ [ ] [ ] ] ifte* ;
: unpair ( list -- list1 list2 )
[ uncons uncons unpair rot swons >r cons r> ] [ f f ] ifte* ;
: <queue> ( -- queue )
#! Make a new functional queue.
[[ [ ] [ ] ]] ;
: queue-empty? ( queue -- ? )
uncons or not ;
: enque ( obj queue -- queue )
uncons >r cons r> cons ;
: deque ( queue -- obj queue )
uncons
[ uncons swapd cons ] [ reverse uncons f swons ] ifte* ;
: 2car ( cons cons -- car car ) swap car swap car ; inline
: 2cdr ( cons cons -- car car ) swap cdr swap cdr ; inline
M: cons = ( obj cons -- ? )
2dup eq? [

15
library/collections/growable.factor
View File

@ -5,21 +5,6 @@
IN: kernel-internals
USING: errors kernel math math-internals sequences ;
: assert-positive ( fx -- )
0 fixnum<
[ "Sequence index must be positive" throw ] when ; inline
: assert-bounds ( fx seq -- )
over assert-positive
length fixnum>=
[ "Sequence index out of bounds" throw ] when ; inline
: bounds-check ( n seq -- fixnum seq )
>r >fixnum r> 2dup assert-bounds ; inline
: growable-check ( n seq -- fixnum seq )
>r >fixnum dup assert-positive r> ; inline
GENERIC: underlying
GENERIC: set-underlying
GENERIC: set-capacity

60
library/collections/hashtables.factor
View File

@ -1,20 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel-internals
DEFER: hash-array
DEFER: set-hash-array
DEFER: set-hash-size
IN: hashtables
USING: generic kernel lists math sequences vectors ;
! We put hash-size in the hashtables vocabulary, and
! the other words in kernel-internals.
DEFER: hashtable?
BUILTIN: hashtable 10 hashtable?
[ 1 "hash-size" set-hash-size ]
[ 2 hash-array set-hash-array ] ;
USING: generic kernel lists math sequences vectors
kernel-internals ;
! A hashtable is implemented as an array of buckets. The
! array index is determined using a hash function, and the
@ -62,9 +50,9 @@ IN: hashtables
: hash* ( key table -- [[ key value ]] )
#! Look up a value in the hashtable.
2dup (hashcode) swap hash-bucket assoc* ;
2dup (hashcode) swap hash-bucket assoc* ; flushable
: hash ( key table -- value ) hash* cdr ;
: hash ( key table -- value ) hash* cdr ; flushable
: set-hash* ( key hash quot -- )
#! Apply the quotation to yield a new association list.
@ -83,6 +71,7 @@ IN: hashtables
: hash>alist ( hash -- alist )
#! Push a list of key/value pairs in a hashtable.
[ ] swap [ hash-bucket [ swons ] each ] each-bucket ;
flushable
: (set-hash) ( value key hash -- )
dup hash-size+ [ set-assoc ] set-hash* ;
@ -113,25 +102,41 @@ IN: hashtables
: hash-clear ( hash -- )
0 over set-hash-size [ f -rot set-hash-bucket ] each-bucket ;
: buckets>list ( hash -- list )
hash-array >list ;
: buckets>vector ( hash -- vector )
hash-array >vector ;
: alist>hash ( alist -- hash )
dup length 1 max <hashtable> swap
[ unswons pick set-hash ] each ;
[ unswons pick set-hash ] each ; foldable
: hash-keys ( hash -- list )
hash>alist [ car ] map ;
hash>alist [ car ] map ; flushable
: hash-values ( hash -- alist )
hash>alist [ cdr ] map ;
hash>alist [ cdr ] map ; flushable
: hash-each ( hash quot -- )
: hash-each ( hash quot -- | quot: [[ k v ]] -- )
swap hash-array [ swap each ] each-with ; inline
: hash-each-with ( obj hash quot -- | quot: obj elt -- )
: hash-each-with ( obj hash quot -- | quot: obj [[ k v ]] -- )
swap [ with ] hash-each 2drop ; inline
: hash-all? ( hash quot -- | quot: [[ k v ]] -- ? )
swap hash-array [ swap all? ] all-with? ; inline
: hash-all-with? ( obj hash quot -- ? | quot: [[ k v ]] -- ? )
swap [ with rot ] hash-all? 2nip ; inline
: hash-contained? ( h1 h2 -- ? )
#! Test if h2 contains all the key/value pairs of h1.
swap [
uncons >r swap hash* dup [
cdr r> =
] [
r> 2drop f
] ifte
] hash-all-with? ; flushable
: hash-subset ( hash quot -- hash | quot: [[ k v ]] -- ? )
>r hash>alist r> subset alist>hash ; inline
@ -145,8 +150,7 @@ M: hashtable = ( obj hash -- ? )
2drop t
] [
over hashtable? [
swap hash>alist swap hash>alist 2dup
contained? >r swap contained? r> and
2dup hash-contained? >r swap hash-contained? r> and
] [
2drop f
] ifte
@ -166,8 +170,12 @@ M: hashtable hashcode ( hash -- n )
pick rot >r >r call dup r> r> set-hash
] ifte* ; inline
: map>hash ( seq quot -- hash | quot: elt -- value )
over >r map r> dup length <hashtable> -rot
[ pick set-hash ] 2each ; inline
: ?hash ( key hash/f -- value/f )
dup [ hash ] [ 2drop f ] ifte ;
dup [ hash ] [ 2drop f ] ifte ; flushable
: ?set-hash ( value key hash/f -- hash )
[ 1 <hashtable> ] unless* [ set-hash ] keep ;

57
library/collections/lists.factor
View File

@ -13,12 +13,10 @@ M: cons peek ( list -- last )
#! Last element of a list.
last car ;
: (each) ( list quot -- list quot )
[ >r car r> call ] 2keep >r cdr r> ; inline
M: f each ( list quot -- ) 2drop ;
M: cons each ( list quot -- | quot: elt -- ) (each) each ;
M: cons each ( list quot -- | quot: elt -- )
[ >r car r> call ] 2keep >r cdr r> each ;
: (list-find) ( list quot i -- i elt )
pick [
@ -34,38 +32,6 @@ M: cons each ( list quot -- | quot: elt -- ) (each) each ;
M: general-list find ( list quot -- i elt )
0 (list-find) ;
M: general-list find* ( start list quot -- i elt )
>r tail r> find ;
: partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
rot [ swapd cons ] [ >r cons r> ] ifte ;
: partition-step ( ref list combinator -- ref cdr combinator car ? )
pick pick car pick call >r >r unswons r> swap r> ; inline
: (partition) ( ref list combinator ret1 ret2 -- ret1 ret2 )
>r >r over [
partition-step r> r> partition-add (partition)
] [
3drop r> r>
] ifte ; inline
: partition ( ref list combinator -- list1 list2 )
#! The combinator must have stack effect:
#! ( ref element -- ? )
[ ] [ ] (partition) ; inline
: sort ( list comparator -- sorted )
#! To sort in ascending order, comparator must have stack
#! effect ( x y -- x>y ).
over [
( Partition ) [ >r uncons dupd r> partition ] keep
( Recurse ) [ sort swap ] keep sort
( Combine ) swapd cons append
] [
drop
] ifte ; inline
: unique ( elem list -- list )
#! Prepend an element to a list if it does not occur in the
#! list.
@ -76,25 +42,6 @@ M: general-list reverse-slice ( list -- list )
M: general-list reverse reverse-slice ;
IN: sequences
DEFER: <range>
IN: lists
: count ( n -- [ 0 ... n-1 ] )
0 swap <range> >list ;
: project ( n quot -- list )
>r count r> map ; inline
: project-with ( elt n quot -- list )
swap [ with rot ] project 2nip ; inline
: seq-transpose ( seq -- list )
#! An example illustrates this word best:
#! [ [ 1 2 3 ] [ 4 5 6 ] ] ==> [ [ 1 2 ] [ 3 4 ] [ 5 6 ] ]
dup first length [ swap [ nth ] map-with ] project-with ;
M: general-list head ( n list -- list )
#! Return the first n elements of the list.
over 0 > [

97
library/collections/namespaces.factor
View File

@ -1,8 +1,5 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: words
DEFER: literalize
IN: namespaces
USING: hashtables kernel kernel-internals lists math sequences
strings vectors words ;
@ -33,7 +30,7 @@ strings vectors words ;
: namespace ( -- namespace )
#! Push the current namespace.
namestack car ;
namestack car ; inline
: >n ( namespace -- n:namespace )
#! Push a namespace on the name stack.
@ -45,10 +42,6 @@ strings vectors words ;
: global ( -- g ) 4 getenv ;
: <namespace> ( -- n )
#! Create a new namespace.
23 <hashtable> ;
: (get) ( var ns -- value )
#! Internal word for searching the namestack.
dup [
@ -59,23 +52,19 @@ strings vectors words ;
] ?ifte
] [
2drop f
] ifte ;
] ifte ; flushable
: get ( variable -- value )
#! Push the value of a variable by searching the namestack
#! from the top down.
namestack (get) ;
namestack (get) ; flushable
: set ( value variable -- ) namespace set-hash ;
: on ( var -- ) t swap set ;
: off ( var -- ) f swap set ;
: nest ( variable -- hash )
#! If the variable is set in the current namespace, return
#! its value, otherwise set its value to a new namespace.
dup namespace hash [ ] [ >r <namespace> dup r> set ] ?ifte ;
dup namespace hash [ ] [ >r {{ }} clone dup r> set ] ?ifte ;
: change ( var quot -- )
#! Execute the quotation with the variable value on the
@ -83,88 +72,62 @@ strings vectors words ;
#! quotation.
>r dup get r> rot slip set ; inline
: on ( var -- ) t swap set ; inline
: off ( var -- ) f swap set ; inline
: inc ( var -- ) [ 1 + ] change ; inline
: dec ( var -- ) [ 1 - ] change ; inline
: bind ( namespace quot -- )
#! Execute a quotation with a namespace on the namestack.
swap >n call n> drop ; inline
: with-scope ( quot -- )
#! Execute a quotation with a new namespace on the
#! namestack.
<namespace> >n call n> drop ; inline
: make-hash ( quot -- hash ) {{ }} clone >n call n> ; inline
: extend ( namespace code -- namespace )
#! Used in code like this:
#! : <subclass>
#! <superclass> [
#! ....
#! ] extend ;
over >r bind r> ; inline
: with-scope ( quot -- ) make-hash drop ; inline
! Building sequences
SYMBOL: building
: make-seq ( quot sequence -- sequence )
#! Call , and % from the quotation to append to a sequence.
[ building set call building get ] with-scope ; inline
: make ( quot proto -- )
#! Call , and % from "quot" to append to a sequence
#! that has the same type as "proto".
[
dup thaw building set >r call building get r> like
] with-scope ; inline
: , ( obj -- )
#! Add to the sequence being built with make-seq.
building get push ;
: unique, ( obj -- )
#! Add the object to the sequence being built with make-seq
#! unless an equal object has already been added.
building get 2dup member? [ 2drop ] [ push ] ifte ;
: % ( seq -- )
#! Append to the sequence being built with make-seq.
building get swap nappend ;
: literal, ( word -- )
#! Append some code that pushes the word on the stack. Used
#! when building quotations.
literalize % ;
: make-vector ( quot -- vector )
100 <vector> make-seq ; inline
: make-list ( quot -- list )
make-vector >list ; inline
: make-sbuf ( quot -- sbuf )
100 <sbuf> make-seq ; inline
: make-string ( quot -- string )
make-sbuf >string ; inline
: make-rstring ( quot -- string )
make-sbuf <reversed> >string ; inline
: # ( n -- )
#! Only useful with "" make.
number>string % ;
! Building hashtables, and computing a transitive closure.
SYMBOL: hash-buffer
: make-hash ( quot -- hash )
[
<namespace> hash-buffer set
call
hash-buffer get
] with-scope ; inline
: hash, ( value key -- ? )
: closure, ( value key -- old )
hash-buffer get [ hash swap ] 2keep set-hash ;
: (closure) ( key hash -- )
tuck hash dup [
hash-keys [
dup dup hash, [
2drop
] [
swap (closure)
] ifte
dup dup closure, [ 2drop ] [ swap (closure) ] ifte
] each-with
] [
2drop
] ifte ;
: closure ( key hash -- list )
[ (closure) ] make-hash hash-keys ;
[
{{ }} clone hash-buffer set
(closure)
hash-buffer get hash-keys
] with-scope ;

24
library/collections/queues.factor Normal file
View File

@ -0,0 +1,24 @@
IN: queues
USING: errors kernel lists math sequences vectors ;
TUPLE: queue in out ;
C: queue ( -- queue ) ;
: queue-empty? ( queue -- ? )
dup queue-in swap queue-out or not ;
: enque ( obj queue -- )
[ queue-in cons ] keep set-queue-in ;
: deque ( queue -- obj )
dup queue-out [
uncons rot set-queue-out
] [
dup queue-in [
reverse uncons pick set-queue-out
f rot set-queue-in
] [
"Empty queue" throw
] ifte*
] ifte* ;

5
library/collections/sbuf.factor
View File

@ -10,11 +10,6 @@ USING: generic sequences ;
M: string resize resize-string ;
DEFER: sbuf?
BUILTIN: sbuf 13 sbuf?
[ 1 length set-capacity ]
[ 2 underlying set-underlying ] ;
M: sbuf set-length ( n sbuf -- ) grow-length ;
M: sbuf nth ( n sbuf -- ch ) bounds-check underlying char-slot ;

15
library/collections/sequence-eq.factor
View File

@ -9,21 +9,14 @@ UNION: sequence array string sbuf vector ;
: length= ( seq seq -- ? ) length swap length number= ;
: (sequence=) ( seq seq i -- ? )
over length over number= [
3drop t
] [
3dup 2nth = [ 1 + (sequence=) ] [ 3drop f ] ifte
] ifte ;
: sequence= ( seq seq -- ? )
#! Check if two sequences have the same length and elements,
#! but not necessarily the same class.
over general-list? over general-list? or [
swap >list swap >list =
2dup length= [
dup length [ >r 2dup r> 2nth = ] all? 2nip
] [
2dup length= [ 0 (sequence=) ] [ 2drop f ] ifte
] ifte ;
2drop f
] ifte ; flushable
M: sequence = ( obj seq -- ? )
2dup eq? [

92
library/collections/sequence-sort.factor Normal file
View File

@ -0,0 +1,92 @@
IN: sorting-internals
USING: kernel math sequences vectors ;
TUPLE: sorter seq start end mid ;
C: sorter ( seq start end -- sorter )
[ >r 1 + rot <slice> r> set-sorter-seq ] keep
dup sorter-seq midpoint over set-sorter-mid
dup sorter-seq length 1 - over set-sorter-end
0 over set-sorter-start ; inline
: s*/e* dup sorter-start swap sorter-end ; inline
: s*/e dup sorter-start swap sorter-seq length 1 - ; inline
: s/e* 0 swap sorter-end ; inline
: sorter-exchange dup s*/e* rot sorter-seq exchange ; inline
: compare over sorter-seq nth swap sorter-mid rot call ; inline
: >start> dup sorter-start 1 + swap set-sorter-start ; inline
: <end< dup sorter-end 1 - swap set-sorter-end ; inline
: sort-up ( quot sorter -- quot sorter )
dup s*/e < [
[ dup sorter-start compare 0 < ] 2keep rot
[ dup >start> sort-up ] when
] when ; inline
: sort-down ( quot sorter -- quot sorter )
dup s/e* <= [
[ dup sorter-end compare 0 > ] 2keep rot
[ dup <end< sort-down ] when
] when ; inline
: sort-step ( quot sorter -- quot sorter )
dup s*/e* <= [
sort-up sort-down dup s*/e* <= [
dup sorter-exchange dup >start> dup <end< sort-step
] when
] when ; inline
DEFER: (nsort)
: (nsort) ( quot seq start end -- )
2dup < [
<sorter> sort-step
[ dup sorter-seq swap s/e* (nsort) ] 2keep
[ dup sorter-seq swap s*/e (nsort) ] 2keep
] [
2drop
] ifte 2drop ; inline
: partition ( -1/1 seq -- seq )
dup midpoint@ swap rot 1 <
[ head-slice ] [ tail-slice ] ifte ; inline
: (binsearch) ( elt quot seq -- i )
dup length 1 <= [
2nip slice-from
] [
3dup >r >r >r midpoint swap call dup 0 = [
r> r> 3drop r> dup slice-from swap slice-to + 2 /i
] [
r> swap r> swap r> partition (binsearch)
] ifte
] ifte ; inline
: flatten-slice ( seq -- slice )
#! Binsearch returns an index relative to the sequence
#! being sliced, so if we are given a slice as input,
#! unexpected behavior will result.
dup slice? [ >vector ] when 0 over length rot <slice> ;
inline
IN: sequences
: nsort ( seq quot -- | quot: elt elt -- -1/0/1 )
swap dup length 1 <=
[ 2drop ] [ 0 over length 1 - (nsort) ] ifte ; inline
: sort ( seq quot -- seq | quot: elt elt -- -1/0/1 )
swap [ swap nsort ] immutable ; inline
: number-sort ( seq -- seq ) [ - ] sort ;
: string-sort ( seq -- seq ) [ lexi ] sort ;
: binsearch ( elt seq quot -- i | quot: elt elt -- -1/0/1 )
swap dup empty?
[ 3drop -1 ] [ flatten-slice (binsearch) ] ifte ;
inline
: binsearch* ( elt seq quot -- elt | quot: elt elt -- -1/0/1 )
over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] ifte ;
inline

194
library/collections/sequences-epilogue.factor
View File

@ -1,21 +1,8 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sequences
USING: generic kernel kernel-internals lists math strings
vectors ;
! A reversal of an underlying sequence.
TUPLE: reversed ;
C: reversed [ set-delegate ] keep ;
: reversed@ delegate [ length swap - 1 - ] keep ;
M: reversed nth ( n seq -- elt ) reversed@ nth ;
M: reversed set-nth ( elt n seq -- ) reversed@ set-nth ;
M: reversed thaw ( seq -- seq ) delegate reverse ;
! A repeated sequence is the same element n times.
TUPLE: repeated length object ;
M: repeated length repeated-length ;
M: repeated nth nip repeated-object ;
USING: errors generic kernel kernel-internals lists math strings
vectors words ;
! Combinators
M: object each ( seq quot -- )
@ -23,23 +10,11 @@ M: object each ( seq quot -- )
[ swap nth swap call ] 3keep
] repeat 2drop ;
: change-nth ( seq i quot -- )
pick pick >r >r >r swap nth r> call r> r> swap set-nth ;
inline
: (nmap) ( seq i quot -- )
pick length pick <= [
3drop
] [
[ change-nth ] 3keep >r 1 + r> (nmap)
] ifte ; inline
: nmap ( seq quot -- | quot: elt -- elt )
#! Destructive on seq.
0 swap (nmap) ; inline
: map ( seq quot -- seq | quot: elt -- elt )
swap [ swap nmap ] immutable ; inline
over [
length <vector> rot
[ -rot [ slip push ] 2keep ] each nip
] keep like ; inline
: map-with ( obj list quot -- list | quot: obj elt -- elt )
swap [ with rot ] map 2nip ; inline
@ -47,19 +22,28 @@ M: object each ( seq quot -- )
: accumulate ( list identity quot -- values | quot: x y -- z )
rot [ pick >r swap call r> ] map-with nip ; inline
: (2nmap) ( seq1 seq2 i quot -- elt3 )
pick pick >r >r >r 2nth r> call r> r> swap set-nth ; inline
: change-nth ( seq i quot -- )
pick pick >r >r >r swap nth r> call r> r> swap set-nth ;
inline
: 2nmap ( seq1 seq2 quot -- | quot: elt1 elt2 -- elt3 )
#! Destructive on seq2.
over length [
[ >r 3dup r> swap (2nmap) ] keep
] repeat 3drop ; inline
: nmap ( seq quot -- seq | quot: elt -- elt )
over length [ [ swap change-nth ] 3keep ] repeat 2drop ; inline
M: object 2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 )
swap [ swap 2nmap ] immutable ;
: 2each ( seq seq quot -- | quot: elt -- )
over length >r >r cons r> r>
[ [ swap >r >r uncons r> 2nth r> call ] 3keep ] repeat
2drop ; inline
M: object find* ( i seq quot -- i elt )
: 2reduce ( seq seq identity quot -- value | quot: e x y -- z )
>r -rot r> 2each ; inline
: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
over [
length <vector> 2swap
[ 2swap [ slip push ] 2keep ] 2each nip
] keep like ; inline
: find* ( i seq quot -- i elt )
pick pick length >= [
3drop -1 f
] [
@ -68,7 +52,10 @@ M: object find* ( i seq quot -- i elt )
] [
r> 1 + r> r> find*
] ifte
] ifte ;
] ifte ; inline
: find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
-rot [ with rot ] find* 2swap 2drop ; inline
M: object find ( seq quot -- i elt )
0 -rot find* ;
@ -102,14 +89,17 @@ M: object find ( seq quot -- i elt )
: subset-with ( obj seq quot -- seq | quot: obj elt -- ? )
swap [ with rot ] subset 2nip ; inline
: fiber? ( seq quot -- ? | quot: elt elt -- ? )
#! Tests if all elements are equivalent under the relation.
over empty?
[ 2drop t ] [ >r [ first ] keep r> all-with? ] ifte ; inline
: (monotonic) ( quot seq i -- ? )
2dup 1 + swap nth >r swap nth r> rot call ; inline
: monotonic? ( seq quot -- ? | quot: elt elt -- ? )
#! Eg, { 1 2 3 4 } [ < ] monotonic? ==> t
#! { 1 3 2 4 } [ < ] monotonic? ==> f
swap dup length 1 - [
pick pick >r >r (monotonic) r> r> rot
] all? 2nip ; inline
! Operations
M: object thaw clone ;
M: object like drop ;
M: object empty? ( seq -- ? ) length 0 = ;
@ -123,46 +113,31 @@ M: object empty? ( seq -- ? ) length 0 = ;
M: object >list ( seq -- list ) dup length 0 rot (>list) ;
: index* ( obj i seq -- n )
#! The index of the object in the sequence, starting from i.
[ = ] find-with* drop ;
: index ( obj seq -- n ) [ = ] find-with drop ; flushable
: index* ( obj i seq -- n ) [ = ] find-with* drop ; flushable
: member? ( obj seq -- ? ) [ = ] contains-with? ; flushable
: memq? ( obj seq -- ? ) [ eq? ] contains-with? ; flushable
: remove ( obj list -- list ) [ = not ] subset-with ; flushable
: index ( obj seq -- n )
#! The index of the object in the sequence.
[ = ] find-with drop ;
: copy-into ( start to from -- )
dup length [ >r pick r> + pick set-nth ] 2each 2drop ;
: member? ( obj seq -- ? )
#! Tests for membership using =.
[ = ] contains-with? ;
: memq? ( obj seq -- ? )
#! Tests for membership using eq?
[ eq? ] contains-with? ;
: remove ( obj list -- list )
#! Remove all occurrences of objects equal to this one from
#! the list.
[ = not ] subset-with ;
: remq ( obj list -- list )
#! Remove all occurrences of the object from the list.
[ eq? not ] subset-with ;
: nappend ( s1 s2 -- )
#! Destructively append s2 to s1.
[ over push ] each drop ;
: nappend ( to from -- )
>r dup length swap r>
over length over length + pick set-length
copy-into ;
: append ( s1 s2 -- s1+s2 )
#! Outputs a new sequence of the same type as s1.
swap [ swap nappend ] immutable ;
swap [ swap nappend ] immutable ; flushable
: add ( seq elt -- seq )
#! Outputs a new sequence of the same type as seq.
unit append ;
swap [ push ] immutable ; flushable
: append3 ( s1 s2 s3 -- s1+s2+s3 )
#! Return a new sequence of the same type as s1.
rot [ [ rot nappend ] keep swap nappend ] immutable ;
rot [ [ rot nappend ] keep swap nappend ] immutable ; flushable
: concat ( seq -- seq )
#! Append a sequence of sequences together. The new sequence
@ -170,7 +145,7 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
dup empty? [
[ 1024 <vector> swap [ dupd nappend ] each ] keep
first like
] unless ;
] unless ; flushable
M: object peek ( sequence -- element )
#! Get value at end of sequence.
@ -186,30 +161,37 @@ M: object peek ( sequence -- element )
: prune ( seq -- seq )
[
dup length <vector> swap [ over push-new ] each
] keep like ;
] keep like ; flushable
: >pop> ( stack -- stack ) dup pop drop ;
: join ( seq glue -- seq )
#! The new sequence is of the same type as glue.
swap dup empty? [
swap like
] [
dup length <vector> swap
[ over push 2dup push ] each nip >pop>
concat
] ifte ; flushable
M: object reverse-slice ( seq -- seq ) <reversed> ;
M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
! Set theoretic operations
: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
[ swap member? ] subset-with ;
[ swap member? ] subset-with ; flushable
: seq-diff ( seq1 seq2 -- seq2-seq1 )
[ swap member? not ] subset-with ;
: seq-diffq ( seq1 seq2 -- seq2-seq1 )
[ swap memq? not ] subset-with ;
[ swap member? not ] subset-with ; flushable
: seq-union ( seq1 seq2 -- seq1\/seq2 )
append prune ;
append prune ; flushable
: contained? ( seq1 seq2 -- ? )
#! Is every element of seq1 in seq2
swap [ swap member? ] all-with? ;
swap [ swap member? ] all-with? ; flushable
! Lexicographic comparison
: (lexi) ( seq seq i limit -- n )
@ -221,21 +203,49 @@ M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;
] [
r> drop - >r 3drop r>
] ifte
] ifte ;
] ifte ; flushable
: lexi ( s1 s2 -- n )
#! Lexicographically compare two sequences of numbers
#! (usually strings). Negative if s1<s2, zero if s1=s2,
#! positive if s1>s2.
0 pick length pick length min (lexi) ;
0 pick length pick length min (lexi) ; flushable
: lexi> ( seq seq -- ? )
#! Test if the first sequence follows the second
#! lexicographically.
lexi 0 > ;
: flip ( seq -- seq )
#! An example illustrates this word best:
#! { { 1 2 3 } { 4 5 6 } } ==> { { 1 4 } { 2 5 } { 3 6 } }
dup empty? [
dup first length [ swap [ nth ] map-with ] map-with
] unless ; flushable
: max-length ( seq -- n )
#! Longest sequence length in a sequence of sequences.
0 [ length max ] reduce ; flushable
: exchange ( n n seq -- )
[ tuck nth >r nth r> ] 3keep tuck
>r >r set-nth r> r> set-nth ;
: midpoint@ length 2 /i ; inline
: midpoint [ midpoint@ ] keep nth ; inline
IN: kernel
: depth ( -- n )
#! Push the number of elements on the datastack.
datastack length ;
: no-cond "cond fall-through" throw ; inline
: cond ( conditions -- )
#! Conditions is a sequence of quotation pairs.
#! { { [ X ] [ Y ] } { [ Z ] [ T ] } }
#! => X [ Y ] [ Z [ T ] [ ] ifte ] ifte
#! The last condition should be a catch-all 't'.
[ first call ] find nip dup
[ second call ] [ no-cond ] ifte ;
: with-datastack ( stack word -- stack )
datastack >r >r set-datastack r> execute
datastack r> [ push ] keep set-datastack 2nip ;

58
library/collections/sequences.factor
View File

@ -11,26 +11,25 @@ USING: errors generic kernel math math-internals strings vectors ;
! kernel-internals vocabulary, so don't use them unless you have
! a good reason.
GENERIC: empty? ( sequence -- ? )
GENERIC: length ( sequence -- n )
GENERIC: empty? ( sequence -- ? ) flushable
GENERIC: length ( sequence -- n ) flushable
GENERIC: set-length ( n sequence -- )
GENERIC: nth ( n sequence -- obj )
GENERIC: nth ( n sequence -- obj ) flushable
GENERIC: set-nth ( value n sequence -- obj )
GENERIC: thaw ( seq -- mutable-seq )
GENERIC: like ( seq seq -- seq )
GENERIC: reverse ( seq -- seq )
GENERIC: reverse-slice ( seq -- seq )
GENERIC: peek ( seq -- elt )
GENERIC: head ( n seq -- seq )
GENERIC: tail ( n seq -- seq )
GENERIC: concat ( seq -- seq )
GENERIC: thaw ( seq -- mutable-seq ) flushable
GENERIC: like ( seq seq -- seq ) flushable
GENERIC: reverse ( seq -- seq ) flushable
GENERIC: reverse-slice ( seq -- seq ) flushable
GENERIC: peek ( seq -- elt ) flushable
GENERIC: head ( n seq -- seq ) flushable
GENERIC: tail ( n seq -- seq ) flushable
GENERIC: resize ( n seq -- seq )
: immutable ( seq quot -- seq | quot: seq -- )
swap [ thaw ] keep >r dup >r swap call r> r> like ; inline
G: each ( seq quot -- | quot: elt -- )
[ over ] [ type ] ; inline
[ over ] standard-combination ; inline
: each-with ( obj seq quot -- | quot: obj elt -- )
swap [ with ] each 2drop ; inline
@ -38,21 +37,12 @@ G: each ( seq quot -- | quot: elt -- )
: reduce ( seq identity quot -- value | quot: x y -- z )
swapd each ; inline
G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
[ over ] [ type ] ; inline
G: find ( seq quot -- i elt | quot: elt -- ? )
[ over ] [ type ] ; inline
[ over ] standard-combination ; inline
: find-with ( obj seq quot -- i elt | quot: elt -- ? )
swap [ with rot ] find 2swap 2drop ; inline
G: find* ( i seq quot -- i elt | quot: elt -- ? )
[ over ] [ type ] ; inline
: find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
-rot [ with rot ] find* 2swap 2drop ; inline
: first 0 swap nth ; inline
: second 1 swap nth ; inline
: third 2 swap nth ; inline
@ -60,12 +50,24 @@ G: find* ( i seq quot -- i elt | quot: elt -- ? )
: push ( element sequence -- )
#! Push a value on the end of a sequence.
dup length swap set-nth ;
dup length swap set-nth ; inline
: 2nth ( s s n -- x x ) tuck swap nth >r swap nth r> ;
: 2nth ( s s n -- x x ) tuck swap nth >r swap nth r> ; inline
: 2unseq ( { x y } -- x y )
dup first swap second ;
: first2 ( { x y } -- x y )
dup first swap second ; inline
: 3unseq ( { x y z } -- x y z )
dup first over second rot third ;
: first3 ( { x y z } -- x y z )
dup first over second rot third ; inline
TUPLE: bounds-error index seq ;
: bounds-error <bounds-error> throw ; inline
: growable-check ( n seq -- fx seq )
>r >fixnum dup 0 fixnum<
[ r> 2dup bounds-error ] [ r> ] ifte ; inline
: bounds-check ( n seq -- fx seq )
growable-check 2dup length fixnum>=
[ 2dup bounds-error ] when ; inline

158
library/collections/slicing.factor
View File

@ -4,129 +4,56 @@ IN: sequences
USING: generic kernel kernel-internals lists math namespaces
strings vectors ;
! A range of integers.
TUPLE: range from to step ;
: head-slice ( n seq -- slice ) 0 -rot <slice> ; flushable
C: range ( from to -- range )
>r 2dup > -1 1 ? r>
[ set-range-step ] keep
[ set-range-to ] keep
[ set-range-from ] keep ;
: tail-slice ( n seq -- slice ) [ length ] keep <slice> ; flushable
M: range length ( range -- n )
dup range-to swap range-from - abs ;
: (slice*) [ length swap - ] keep ;
M: range nth ( n range -- n )
[ range-step * ] keep range-from + ;
: head-slice* ( n seq -- slice ) (slice*) head-slice ; flushable
M: range like ( seq range -- range )
drop >vector ;
: tail-slice* ( n seq -- slice ) (slice*) tail-slice ; flushable
M: range thaw ( range -- seq )
>vector ;
: subseq ( from to seq -- seq ) [ <slice> ] keep like ; flushable
! A slice of another sequence.
TUPLE: slice seq ;
M: object head ( index seq -- seq ) [ head-slice ] keep like ;
C: slice ( from to seq -- )
[ set-slice-seq ] keep
[ >r <range> r> set-delegate ] keep ;
: head* ( n seq -- seq ) [ head-slice* ] keep like ; flushable
M: slice nth ( n slice -- obj )
[ delegate nth ] keep slice-seq nth ;
M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
M: slice set-nth ( obj n slice -- )
[ delegate nth ] keep slice-seq set-nth ;
: tail* ( n seq -- seq ) [ tail-slice* ] keep like ; flushable
M: slice like ( seq slice -- seq )
slice-seq like ;
M: slice thaw ( slice -- seq )
>vector ;
: head-slice ( n seq -- slice )
0 -rot <slice> ;
: tail-slice ( n seq -- slice )
[ length ] keep <slice> ;
: tail-slice* ( n seq -- slice )
[ length swap - ] keep tail-slice ;
: subseq ( from to seq -- seq )
#! Makes a new sequence with the same contents and type as
#! the slice of another sequence.
[ <slice> ] keep like ;
M: object head ( index seq -- seq )
0 -rot subseq ;
M: object tail ( index seq -- seq )
#! Returns a new string, from the given index until the end
#! of the string.
[ length ] keep subseq ;
: tail* ( n seq -- seq )
#! Unlike tail, n is an index from the end of the
#! sequence. For example, if n=1, this returns a sequence of
#! one element.
[ length swap - ] keep tail ;
: length< ( seq seq -- ? )
swap length swap length < ;
: length< ( seq seq -- ? ) swap length swap length < ; flushable
: head? ( seq begin -- ? )
2dup length< [
2drop f
] [
dup length rot head-slice sequence=
] ifte ;
] ifte ; flushable
: ?head ( seq begin -- str ? )
2dup head? [
length swap tail t
] [
drop f
] ifte ;
2dup head? [ length swap tail t ] [ drop f ] ifte ; flushable
: tail? ( seq end -- ? )
2dup length< [
2drop f
] [
dup length pick length swap - rot tail-slice sequence=
] ifte ;
dup length rot tail-slice* sequence=
] ifte ; flushable
: ?tail ( seq end -- seq ? )
2dup tail? [
length swap [ length swap - ] keep head t
2dup tail? [ length swap head* t ] [ drop f ] ifte ; flushable
: (group) ( n seq -- )
2dup length >= [
dup like , drop
] [
drop f
2dup head , dupd tail-slice (group)
] ifte ;
: cut ( index seq -- seq seq )
#! Returns 2 sequences, that when concatenated yield the
#! original sequence.
[ head ] 2keep tail ;
: cut* ( index seq -- seq seq )
#! Returns 2 sequences, that when concatenated yield the
#! original sequences, without the element at the given
#! index.
[ head ] 2keep >r 1 + r> tail ;
: group-advance subseq , >r tuck + swap r> ;
: group-finish nip dup length swap subseq , ;
: (group) ( start n seq -- )
3dup >r dupd + r> 2dup length < [
group-advance (group)
] [
group-finish 3drop
] ifte ;
: group ( n seq -- list )
#! Split a sequence into element chunks.
[ 0 -rot (group) ] make-list ;
: group ( n seq -- seq ) [ (group) ] { } make ; flushable
: start-step ( subseq seq n -- subseq slice )
pick length dupd + rot <slice> ;
@ -140,36 +67,29 @@ M: object tail ( index seq -- seq )
] [
r> r> 1 + start*
] ifte
] ifte ;
] ifte ; flushable
: start ( subseq seq -- n )
#! The index of a subsequence in a sequence.
0 start* ;
0 start* ; flushable
: subseq? ( subseq seq -- ? ) start -1 > ;
: subseq? ( subseq seq -- ? ) start -1 > ; flushable
: (split1) ( seq subseq -- before after )
#! After is a slice.
dup pick start dup -1 = [
2drop dup like f
] [
[ swap length + over tail-slice ] keep rot head swap
] ifte ; flushable
: split1 ( seq subseq -- before after )
dup pick start dup -1 = [
2drop f
] [
[ swap length + over tail ] keep rot head swap
] ifte ;
#! After is of the same type as seq.
(split1) dup like ; flushable
: split-next ( index seq subseq -- next )
pick >r dup pick r> start* dup -1 = [
>r drop tail , r> ( end of sequence )
] [
swap length dupd + >r swap subseq , r>
] ifte ;
: (split) ( seq subseq -- )
tuck (split1) >r , r> dup [ swap (split) ] [ 2drop ] ifte ;
: (split) ( index seq subseq -- )
2dup >r >r split-next dup -1 = [
r> r> 3drop
] [
r> r> (split)
] ifte ;
: split ( seq subseq -- seq ) [ (split) ] [ ] make ; flushable
: split ( seq subseq -- list )
#! Split the sequence at each occurrence of subseq, and push
#! a list of the pieces.
[ 0 -rot (split) ] make-list ;
: cut ( n seq -- ) [ head ] 2keep tail ; flushable

17
library/collections/strings-epilogue.factor
View File

@ -4,22 +4,27 @@ IN: strings
USING: generic kernel kernel-internals lists math namespaces
sequences strings ;
: empty-sbuf ( len -- sbuf ) dup <sbuf> [ set-length ] keep ;
: empty-sbuf ( len -- sbuf )
dup <sbuf> [ set-length ] keep ; inline
: fill ( count char -- string ) <repeated> >string ;
: fill ( count char -- string )
<repeated> >string ; inline
: padding ( string count char -- string )
>r swap length - dup 0 <= [ r> 2drop "" ] [ r> fill ] ifte ;
flushable
: pad-left ( string count char -- string )
pick >r padding r> append ;
pick >r padding r> append ; flushable
: pad-right ( string count char -- string )
pick >r padding r> swap append ;
pick >r padding r> swap append ; flushable
: ch>string ( ch -- str ) 1 <sbuf> [ push ] keep (sbuf>string) ;
: ch>string ( ch -- str )
1 <sbuf> [ push ] keep (sbuf>string) ; flushable
: >sbuf ( seq -- sbuf ) dup length <sbuf> [ swap nappend ] keep ;
: >sbuf ( seq -- sbuf )
dup length <sbuf> [ swap nappend ] keep ; inline
M: object >string >sbuf (sbuf>string) ;

10
library/collections/strings.factor
View File

@ -3,13 +3,9 @@
IN: strings
USING: generic kernel kernel-internals lists math sequences ;
! Strings
DEFER: string?
BUILTIN: string 12 string? [ 1 length f ] [ 2 hashcode f ] ;
M: string nth ( n str -- ch ) bounds-check char-slot ;
GENERIC: >string ( seq -- string )
GENERIC: >string ( seq -- string ) flushable
M: string >string ;
@ -23,7 +19,7 @@ PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
: quotable? ( ch -- ? )
#! In a string literal, can this character be used without
#! escaping?
dup printable? swap "\"\\" member? not and ;
dup printable? swap "\"\\" member? not and ; foldable
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
@ -31,4 +27,4 @@ PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
dup letter?
over LETTER? or
over digit? or
swap "/_?." member? or ;
swap "/_?." member? or ; foldable

6
library/collections/tree-each.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sequences
USING: generic kernel lists ;
USING: generic kernel lists strings ;
G: tree-each ( obj quot -- | quot: elt -- )
[ over ] [ type ] ; inline
[ over ] standard-combination ; inline
: tree-each-with ( obj vector quot -- )
swap [ with ] tree-each 2drop ; inline
@ -13,5 +13,7 @@ M: object tree-each call ;
M: sequence tree-each swap [ swap tree-each ] each-with ;
M: string tree-each call ;
M: cons tree-each ( cons quot -- )
>r uncons r> tuck >r >r tree-each r> r> tree-each ;

31
library/collections/vectors-epilogue.factor
View File

@ -1,31 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
USING: errors generic kernel kernel-internals lists math
math-internals sequences ;
IN: vectors
: empty-vector ( len -- vec ) dup <vector> [ set-length ] keep ;
: >vector ( list -- vector )
dup length <vector> [ swap nappend ] keep ;
M: repeated thaw >vector ;
M: vector clone ( vector -- vector ) >vector ;
: zero-vector ( n -- vector ) 0 <repeated> >vector ;
M: general-list thaw >vector ;
M: general-list like drop >list ;
M: vector like drop >vector ;
: (1vector) [ push ] keep ; inline
: (2vector) [ swapd push ] keep (1vector) ; inline
: (3vector) [ >r rot r> push ] keep (2vector) ; inline
: 1vector ( x -- { x } ) 1 <vector> (1vector) ;
: 2vector ( x y -- { x y } ) 2 <vector> (2vector) ;
: 3vector ( x y z -- { x y z } ) 3 <vector> (3vector) ;

27
library/collections/vectors.factor
View File

@ -4,11 +4,6 @@ IN: vectors
USING: errors generic kernel kernel-internals lists math
math-internals sequences ;
DEFER: vector?
BUILTIN: vector 11 vector?
[ 1 length set-capacity ]
[ 2 underlying set-underlying ] ;
M: vector set-length ( len vec -- ) grow-length ;
M: vector nth ( n vec -- obj ) bounds-check underlying array-nth ;
@ -18,3 +13,25 @@ M: vector set-nth ( obj n vec -- )
M: vector hashcode ( vec -- n )
dup length 0 number= [ drop 0 ] [ first hashcode ] ifte ;
: empty-vector ( len -- vec )
dup <vector> [ set-length ] keep ; inline
: >vector ( list -- vector )
dup length <vector> [ swap nappend ] keep ; inline
M: object thaw >vector ;
M: vector clone ( vector -- vector ) >vector ;
M: general-list like drop >list ;
M: vector like drop >vector ;
: (1vector) [ push ] keep ; inline
: (2vector) [ swapd push ] keep (1vector) ; inline
: (3vector) [ >r rot r> push ] keep (2vector) ; inline
: 1vector ( x -- { x } ) 1 <vector> (1vector) ; flushable
: 2vector ( x y -- { x y } ) 2 <vector> (2vector) ; flushable
: 3vector ( x y z -- { x y z } ) 3 <vector> (3vector) ; flushable

53
library/collections/virtual-sequences.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sequences
USING: generic kernel math vectors ;
! A repeated sequence is the same element n times.
TUPLE: repeated length object ;
M: repeated length repeated-length ;
M: repeated nth nip repeated-object ;
! A reversal of an underlying sequence.
TUPLE: reversed ;
C: reversed [ set-delegate ] keep ;
: reversed@ delegate [ length swap - 1 - ] keep ;
M: reversed nth ( n seq -- elt ) reversed@ nth ;
M: reversed set-nth ( elt n seq -- ) reversed@ set-nth ;
M: reversed thaw ( seq -- seq ) delegate reverse ;
! A slice of another sequence.
TUPLE: slice seq from to step ;
: collapse-slice ( from to slice -- from to seq )
dup slice-from swap slice-seq >r tuck + >r + r> r> ;
C: slice ( from to seq -- seq )
#! A slice of a slice collapses.
>r dup slice? [ collapse-slice ] when r>
[ set-slice-seq ] keep
>r 2dup > -1 1 ? r>
[ set-slice-step ] keep
[ set-slice-to ] keep
[ set-slice-from ] keep ;
: <range> ( from to -- seq ) 0 <slice> ;
M: slice length ( range -- n )
dup slice-to swap slice-from - abs ;
: slice@ ( n slice -- n seq )
[ [ slice-step * ] keep slice-from + ] keep slice-seq ;
M: slice nth ( n slice -- obj ) slice@ nth ;
M: slice set-nth ( obj n slice -- ) slice@ set-nth ;
M: slice like ( seq slice -- seq ) slice-seq like ;

64
library/combinators.factor
View File

@ -1,64 +0,0 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel
: slip ( quot x -- x | quot: -- )
>r call r> ; inline
: 2slip ( quot x y -- x y | quot: -- )
>r >r call r> r> ; inline
: keep ( x quot -- x | quot: x -- )
over >r call r> ; inline
: 2keep ( x y quot -- x y | quot: x y -- )
over >r pick >r call r> r> ; inline
: 3keep ( x y z quot -- x y z | quot: x y z -- )
>r 3dup r> swap >r swap >r swap >r call r> r> r> ; inline
: while ( quot generator -- )
#! Keep applying the quotation to the value produced by
#! calling the generator until the generator returns f.
2dup >r >r swap >r call dup [
r> call r> r> while
] [
r> 2drop r> r> 2drop
] ifte ; inline
: ifte* ( cond true false -- | true: cond -- | false: -- )
#! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte
pick [ drop call ] [ 2nip call ] ifte ; inline
: ?ifte ( default cond true false -- )
#! [ X ] [ Y ] ?ifte ==> dup [ nip X ] [ drop Y ] ifte
>r >r dup [
nip r> r> drop call
] [
drop r> drop r> call
] ifte ; inline
: unless ( cond quot -- | quot: -- )
#! Execute a quotation only when the condition is f. The
#! condition is popped off the stack.
[ ] swap ifte ; inline
: unless* ( cond quot -- | quot: -- )
#! If cond is f, pop it off the stack and evaluate the
#! quotation. Otherwise, leave cond on the stack.
over [ drop ] [ nip call ] ifte ; inline
: when ( cond quot -- | quot: -- )
#! Execute a quotation only when the condition is not f. The
#! condition is popped off the stack.
[ ] ifte ; inline
: when* ( cond quot -- | quot: cond -- )
#! If the condition is true, it is left on the stack, and
#! the quotation is evaluated. Otherwise, the condition is
#! popped off the stack.
dupd [ drop ] ifte ; inline
: with ( obj quot elt -- obj quot )
#! Utility word for each-with, map-with.
pick pick >r >r swap call r> r> ; inline

14
library/compiler/assembler.factor
View File

@ -20,15 +20,13 @@ SYMBOL: interned-literals
: compile-aligned ( n -- )
compiled-offset cell 2 * align set-compiled-offset ; inline
: intern-literal ( obj -- lit# )
dup interned-literals get hash [ ] [
[
: add-literal ( obj -- lit# )
address
literal-top set-compiled-cell
literal-top dup cell + set-literal-top
dup
] keep interned-literals get set-hash
] ?ifte ;
literal-top dup cell + set-literal-top ;
: intern-literal ( obj -- lit# )
interned-literals get [ add-literal ] cache ;
: compile-byte ( n -- )
compiled-offset set-compiled-byte
@ -44,6 +42,6 @@ SYMBOL: interned-literals
compiled-offset 0 compile-cell ;
: init-assembler ( -- )
global [ <namespace> interned-literals set ] bind ;
{{ }} clone interned-literals global set-hash ;
: w>h/h dup -16 shift HEX: ffff bitand >r HEX: ffff bitand r> ;

45
library/compiler/compiler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
IN: compiler
USING: compiler-backend compiler-frontend errors inference
kernel lists math namespaces prettyprint io words ;
USING: compiler-backend compiler-frontend errors inference io
kernel lists math namespaces prettyprint sequences words ;
: supported-cpu? ( -- ? )
cpu "unknown" = not ;
@ -12,9 +12,7 @@ kernel lists math namespaces prettyprint io words ;
] unless ;
: compiling ( word -- word parameter )
check-architecture
"Compiling " write dup unparse. terpri flush
dup word-def ;
check-architecture "Compiling " write dup . dup word-def ;
GENERIC: (compile) ( word -- )
@ -27,7 +25,7 @@ M: compound (compile) ( word -- )
: precompile ( word -- )
#! Print linear IR of word.
[
word-def dataflow optimize linearize simplify [.]
word-def dataflow optimize linearize simplify [ . ] each
] with-scope ;
: compile-postponed ( -- )
@ -43,26 +41,29 @@ M: compound (compile) ( word -- )
"compile" get [ word compile ] when ; parsing
: cannot-compile ( word error -- )
"Cannot compile " write swap unparse. terpri print-error ;
"Cannot compile " write swap . print-error ;
: try-compile ( word -- )
[ compile ] [ [ cannot-compile ] when* ] catch ;
: compile-all ( -- ) [ try-compile ] each-word ;
: decompile ( word -- )
dup compiled? [
"Decompiling " write dup unparse. terpri flush
[ word-primitive ] keep set-word-primitive
] [
drop
] ifte ;
M: compound (uncrossref)
dup f "infer-effect" set-word-prop
dup f "base-case" set-word-prop
dup f "no-effect" set-word-prop
decompile ;
: recompile ( word -- )
dup decompile compile ;
dup update-xt compile ;
: compile-1 ( quot -- word )
#! Compute a quotation into an uninterned word, for testing
#! purposes.
gensym [ swap define-compound ] keep dup compile execute ;
\ dataflow profile
\ optimize profile
\ linearize profile
\ simplify profile
\ generate profile
\ kill-node profile
\ partial-eval profile
\ inline-method profile
\ apply-identities profile
\ subst-values profile
\ split-branch profile

6
library/compiler/generator.factor
View File

@ -2,7 +2,7 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: assembler compiler errors inference kernel lists math
namespaces sequences strings vectors words ;
memory namespaces sequences strings vectors words ;
! Compile a VOP.
GENERIC: generate-node ( vop -- )
@ -59,6 +59,10 @@ M: %target generate-node
GENERIC: v>operand
M: integer v>operand tag-bits shift ;
M: f v>operand address ;
: dest/src ( vop -- dest src )
dup vop-out-1 v>operand swap vop-in-1 v>operand ;

68
library/compiler/intrinsics.factor
View File

@ -3,7 +3,7 @@
IN: compiler-frontend
USING: assembler compiler-backend generic hashtables inference
kernel kernel-internals lists math math-internals namespaces
sequences words ;
sequences vectors words ;
! Architecture description
: fixnum-imm?
@ -54,26 +54,32 @@ sequences words ;
out-1
] "intrinsic" set-word-prop
: node-peek ( node -- obj ) node-in-d peek ;
: node-peek ( node -- value ) node-in-d peek ;
: peek-2 dup length 2 - swap nth ;
: node-peek-2 ( node -- obj ) node-in-d peek-2 ;
: type-tag ( type -- tag )
#! Given a type number, return the tag number.
dup 6 > [ drop 3 ] when ;
: typed? ( value -- ? ) value-types length 1 = ;
: value-tag ( value node -- n/f )
#! If the tag is known, output it, otherwise f.
node-classes hash dup [
types [ type-tag ] map dup [ = ] monotonic?
[ first ] [ drop f ] ifte
] [
drop f
] ifte ;
: slot@ ( node -- n )
: slot@ ( node -- n/f )
#! Compute slot offset.
node-in-d
dup peek literal-value cell *
swap peek-2 value-types car type-tag - ;
: typed-literal? ( node -- ? )
#! Output if the node's first input is well-typed, and the
#! second is a literal.
dup node-peek safe-literal? swap node-peek-2 typed? and ;
dup node-in-d reverse dup first dup literal? [
literal-value cell * swap second
rot value-tag dup [ - ] [ 2drop f ] ifte
] [
3drop f
] ifte ;
\ slot [
dup typed-literal? [
dup slot@ [
1 %dec-d ,
in-1
0 swap slot@ %fast-slot ,
@ -87,36 +93,34 @@ sequences words ;
] "intrinsic" set-word-prop
\ set-slot [
dup typed-literal? [
dup slot@ [
1 %dec-d ,
in-2
2 %dec-d ,
slot@ >r 0 1 r> %fast-set-slot ,
0 %write-barrier ,
] [
drop
in-3
3 %dec-d ,
1 %untag ,
0 1 2 %set-slot ,
1 %write-barrier ,
] ifte
1 %write-barrier ,
] "intrinsic" set-word-prop
\ type [
drop
in-1
0 %type ,
0 %tag-fixnum ,
0 %retag-fixnum ,
out-1
] "intrinsic" set-word-prop
\ arithmetic-type [
\ tag [
drop
in-1
0 %arithmetic-type ,
0 %tag-fixnum ,
1 %inc-d ,
0 %tag ,
0 %retag-fixnum ,
out-1
] "intrinsic" set-word-prop
@ -136,23 +140,23 @@ sequences words ;
: value/vreg-list ( in -- list )
[ 0 swap length 1 - ] keep
[ >r 2dup r> 3list >r 1 - >r 1 + r> r> ] map 2nip ;
[ >r 2dup r> 3vector >r 1 - >r 1 + r> r> ] map 2nip ;
: values>vregs ( in -- in )
value/vreg-list
dup [ 3unlist load-value ] each
[ car <vreg> ] map ;
dup [ first3 load-value ] each
[ first <vreg> ] map ;
: load-inputs ( node -- in )
dup node-in-d values>vregs
[ length swap node-out-d length - %dec-d , ] keep ;
: binary-op-reg ( node op -- )
>r load-inputs 2unlist swap dup r> execute ,
>r load-inputs first2 swap dup r> execute ,
0 0 %replace-d , ; inline
: literal-fixnum? ( value -- ? )
dup safe-literal? [ literal-value fixnum? ] [ drop f ] ifte ;
: literal-immediate? ( value -- ? )
dup literal? [ literal-value immediate? ] [ drop f ] ifte ;
: binary-op-imm ( imm op -- )
1 %dec-d , in-1
@ -162,7 +166,7 @@ sequences words ;
: binary-op ( node op -- )
#! out is a vreg where the vop stores the result.
fixnum-imm? [
>r dup node-peek dup literal-fixnum? [
>r dup node-peek dup literal-immediate? [
literal-value r> binary-op-imm drop
] [
drop r> binary-op-reg
@ -183,7 +187,7 @@ sequences words ;
[[ fixnum> %fixnum> ]]
[[ eq? %eq? ]]
] [
uncons [ literal, \ binary-op , ] make-list
uncons [ literalize , \ binary-op , ] [ ] make
"intrinsic" set-word-prop
] each
@ -197,7 +201,7 @@ sequences words ;
\ fixnum* [
! Turn multiplication by a power of two into a left shift.
dup node-peek dup literal-fixnum? [
dup node-peek dup literal-immediate? [
literal-value dup power-of-2? [
nip fast-fixnum*
] [

46
library/compiler/linearizer.factor
View File

@ -1,13 +1,16 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-frontend
USING: compiler-backend errors generic inference kernel
kernel-internals lists math namespaces prettyprint sequences
USING: compiler-backend errors generic lists inference kernel
math namespaces prettyprint sequences
strings words ;
GENERIC: linearize-node* ( node -- )
M: f linearize-node* ( f -- ) drop ;
M: node linearize-node* ( node -- ) drop ;
: linearize-node ( node -- )
[
dup linearize-node* node-successor linearize-node
@ -17,22 +20,17 @@ M: f linearize-node* ( f -- ) drop ;
#! Transform dataflow IR into linear IR. This strips out
#! stack flow information, and flattens conditionals into
#! jumps and labels.
[ %prologue , linearize-node ] make-list ;
[ %prologue , linearize-node ] [ ] make ;
M: #label linearize-node* ( node -- )
<label> dup %return-to , >r
dup node-param %label ,
node-children car linearize-node
f %return ,
node-children first linearize-node
r> %label , ;
M: #call linearize-node* ( node -- )
dup node-param
dup "intrinsic" word-prop [
call
] [
%call , drop
] ?ifte ;
dup "intrinsic" word-prop [ call ] [ %call , drop ] ?ifte ;
M: #call-label linearize-node* ( node -- )
node-param %call-label , ;
@ -52,7 +50,7 @@ M: object load-value ( vreg n value -- )
literal-value dup
immediate? [ %immediate ] [ %indirect ] ifte , ;
M: safe-literal load-value ( vreg n value -- )
M: literal load-value ( vreg n value -- )
nip push-literal ;
: push-1 ( value -- ) 0 swap push-literal ;
@ -68,38 +66,30 @@ M: #drop linearize-node* ( node -- )
in-1 1 %dec-d , 0 %jump-t , ;
M: #ifte linearize-node* ( node -- )
#! The parameter is a list of two lists, each one a dataflow
#! IR.
node-children 2unlist <label> [
ifte-head
linearize-node ( false branch )
<label> dup %jump-label ,
] keep %label , ( branch target of BRANCH-T )
swap linearize-node ( true branch )
%label , ( branch target of false branch end ) ;
node-children first2
<label> dup ifte-head
swap linearize-node ( false branch )
%label , ( branch target of BRANCH-T )
linearize-node ( true branch ) ;
: dispatch-head ( vtable -- end label/code )
: dispatch-head ( vtable -- label/code )
#! Output the jump table insn and return a list of
#! label/branch pairs.
in-1
1 %dec-d ,
0 %untag-fixnum ,
0 %dispatch ,
<label> ( end label ) swap
[ <label> dup %target-label , cons ] map
%end-dispatch , ;
: dispatch-body ( end label/param -- )
: dispatch-body ( label/param -- )
#! Output each branch, with a jump to the end label.
[ uncons %label , linearize-node %jump-label , ] each-with ;
[ uncons %label , linearize-node ] each ;
M: #dispatch linearize-node* ( vtable -- )
#! The parameter is a list of lists, each one is a branch to
#! take in case the top of stack has that type.
node-children dispatch-head dupd dispatch-body %label , ;
M: #values linearize-node* ( node -- )
drop ;
node-children dispatch-head dispatch-body ;
M: #return linearize-node* ( node -- )
drop f %return , ;

221
library/compiler/optimizer.factor
View File

@ -1,221 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-frontend
USING: hashtables inference kernel lists namespaces sequences ;
! The optimizer transforms dataflow IR to dataflow IR. Currently
! it removes literals that are eventually dropped, and never
! arise as inputs to any other type of function. Such 'dead'
! literals arise when combinators are inlined and quotations are
! lifted to their call sites.
GENERIC: literals* ( node -- )
: literals, ( node -- )
[ dup literals* node-successor literals, ] when* ;
: literals ( node -- list )
[ literals, ] make-list ;
GENERIC: can-kill* ( literal node -- ? )
: can-kill? ( literal node -- ? )
#! Return false if the literal appears in any node in the
#! list.
dup [
2dup can-kill* [
node-successor can-kill?
] [
2drop f
] ifte
] [
2drop t
] ifte ;
: kill-set ( node -- list )
#! Push a list of literals that may be killed in the IR.
dup literals [ swap can-kill? ] subset-with ;
GENERIC: kill-node* ( literals node -- )
DEFER: kill-node
: kill-children ( literals node -- )
node-children [ kill-node ] each-with ;
: kill-node ( literals node -- )
dup [
2dup kill-children
2dup kill-node* node-successor kill-node
] [
2drop
] ifte ;
GENERIC: useless-node? ( node -- ? )
DEFER: prune-nodes
: prune-children ( node -- )
[ node-children [ prune-nodes ] map ] keep
set-node-children ;
: (prune-nodes) ( node -- )
[
dup prune-children
dup node-successor dup useless-node? [
node-successor over set-node-successor
] [
nip
] ifte (prune-nodes)
] when* ;
: prune-nodes ( node -- node )
dup useless-node? [
node-successor prune-nodes
] [
[ (prune-nodes) ] keep
] ifte ;
: optimize ( dataflow -- dataflow )
#! Remove redundant literals from the IR. The original IR
#! is destructively modified.
dup kill-set over kill-node prune-nodes ;
! Generic nodes
M: node literals* ( node -- )
node-children [ literals, ] each ;
M: f can-kill* ( literal node -- ? )
2drop t ;
M: node can-kill* ( literal node -- ? )
2dup consumes-literal? >r produces-literal? r> or not ;
M: node kill-node* ( literals node -- )
2drop ;
M: f useless-node? ( node -- ? )
drop f ;
M: node useless-node? ( node -- ? )
drop f ;
! #push
M: #push literals* ( node -- )
node-out-d % ;
M: #push can-kill* ( literal node -- ? )
2drop t ;
M: #push kill-node* ( literals node -- )
[ node-out-d seq-diffq ] keep set-node-out-d ;
M: #push useless-node? ( node -- ? )
node-out-d empty? ;
! #drop
M: #drop can-kill* ( literal node -- ? )
2drop t ;
M: #drop kill-node* ( literals node -- )
[ node-in-d seq-diffq ] keep set-node-in-d ;
M: #drop useless-node? ( node -- ? )
node-in-d empty? ;
! #call
M: #call can-kill* ( literal node -- ? )
nip node-param {{
[[ dup t ]]
[[ drop t ]]
[[ swap t ]]
[[ over t ]]
[[ pick t ]]
[[ >r t ]]
[[ r> t ]]
}} hash ;
: kill-mask ( killing inputs -- mask )
[ swap memq? ] map-with ;
: (kill-shuffle) ( word -- map )
{{
[[ over
{{
[[ [ f t ] dup ]]
}}
]]
[[ pick
{{
[[ [ f f t ] over ]]
[[ [ f t f ] over ]]
[[ [ f t t ] dup ]]
}}
]]
[[ swap {{ }} ]]
[[ dup {{ }} ]]
[[ >r {{ }} ]]
[[ r> {{ }} ]]
}} hash ;
: lookup-mask ( mask word -- word )
over [ not ] all? [ nip ] [ (kill-shuffle) hash ] ifte ;
: kill-shuffle ( literals node -- )
#! If certain values passing through a stack op are being
#! killed, the stack op can be reduced, in extreme cases
#! to a no-op.
[ [ node-in-d kill-mask ] keep node-param lookup-mask ] keep
set-node-param ;
M: #call kill-node* ( literals node -- )
dup node-param (kill-shuffle)
[ kill-shuffle ] [ 2drop ] ifte ;
M: #call useless-node? ( node -- ? )
node-param not ;
! #call-label
M: #call-label can-kill* ( literal node -- ? )
2drop t ;
! #label
M: #label can-kill* ( literal node -- ? )
node-children car can-kill? ;
! #values
SYMBOL: branch-returns
M: #values can-kill* ( literal node -- ? )
dupd consumes-literal? [
branch-returns get
[ memq? ] subset-with
[ [ eq? ] fiber? ] all?
] [
drop t
] ifte ;
: branch-values ( branches -- )
[ last-node node-in-d ] map
unify-lengths seq-transpose branch-returns set ;
: can-kill-branches? ( literal node -- ? )
#! Check if the literal appears in either branch. This
#! assumes that the last element of each branch is a #values
#! node.
2dup consumes-literal? [
2drop f
] [
[
node-children dup branch-values
[ can-kill? ] all-with?
] with-scope
] ifte ;
! #ifte
M: #ifte can-kill* ( literal node -- ? )
can-kill-branches? ;
! #dispatch
M: #dispatch can-kill* ( literal node -- ? )
can-kill-branches? ;

4
library/compiler/ppc/assembler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: assembler
USING: compiler errors kernel math memory words ;
USING: compiler errors generic kernel math memory words ;
! See the Motorola or IBM documentation for details. The opcode
! names are standard, and the operand order is the same as in
@ -158,7 +158,7 @@ USING: compiler errors kernel math memory words ;
: STH d-form 44 insn ; : STHU d-form 45 insn ;
: STW d-form 36 insn ; : STWU d-form 37 insn ;
G: (B) ( dest aa lk -- ) [ pick ] [ type ] ;
G: (B) ( dest aa lk -- ) [ pick ] standard-combination ;
M: integer (B) i-form 18 insn ;
M: word (B) 0 -rot (B) relative-24 ;

22
library/compiler/ppc/generator.factor
View File

@ -12,7 +12,6 @@ kernel-internals lists math memory namespaces words ;
: compile-c-call ( symbol dll -- )
2dup dlsym 19 LOAD32 0 1 rel-dlsym 19 MTLR BLRL ;
M: integer v>operand tag-bits shift ;
M: vreg v>operand vreg-n 17 + ;
M: %prologue generate-node ( vop -- )
@ -86,7 +85,7 @@ M: %untag-fixnum generate-node ( vop -- )
: tag-fixnum ( dest src -- ) tag-bits SLWI ;
M: %tag-fixnum generate-node ( vop -- )
M: %retag-fixnum generate-node ( vop -- )
! todo: formalize scratch register usage
dest/src tag-fixnum ;
@ -125,20 +124,5 @@ M: %type generate-node ( vop -- )
"end" get save-xt
17 18 MR ;
M: %arithmetic-type generate-node ( vop -- )
0 <vreg> check-dest
<label> "end" set
! Load top two stack values
3 14 -4 LWZ
4 14 0 LWZ
! Compute their tags
3 3 tag-mask ANDI
4 4 tag-mask ANDI
! Are the tags equal?
0 3 4 CMPL
"end" get BEQ
! No, they are not equal. Call a runtime function to
! coerce the integers to a higher type.
"arithmetic_type" f compile-c-call
"end" get save-xt
17 3 MR ;
M: %tag generate-node ( vop -- )
dup vop-in-1 swap vop-out-1 tag-mask ANDI ;

45
library/compiler/simplifier.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: generic inference kernel lists math namespaces
USING: generic kernel lists math namespaces
prettyprint sequences strings words ;
! A peephole optimizer operating on the linear IR.
@ -71,7 +71,7 @@ M: %inc-d simplify-node ( linear vop -- linear ? )
[ over first operands= [ cdr cdr t ] [ f ] ifte ]
[ drop f ] ifte ;
M: %tag-fixnum simplify-node ( linear vop -- linear ? )
M: %retag-fixnum simplify-node ( linear vop -- linear ? )
drop \ %untag-fixnum cancel ;
: basic-block ( linear quot -- | quot: vop -- ? )
@ -221,9 +221,7 @@ M: %call-label simplify-node ( linear vop -- ? )
pick next-logical? [
>r dup dup car next-logical car vop-label
r> execute swap cdr cons t
] [
drop f
] ifte ; inline
] [ drop f ] ifte ; inline
: useless-jump ( linear -- linear ? )
#! A jump to a label immediately following is not needed.
@ -233,38 +231,21 @@ M: %call-label simplify-node ( linear vop -- ? )
: (dead-code) ( linear -- linear ? )
#! Remove all nodes until the next #label.
dup [
dup car %label? [
f
] [
cdr (dead-code) t or
] ifte
] [
f
] ifte ;
dup car %label?
[ f ] [ cdr (dead-code) t or ] ifte
] [ f ] ifte ;
: dead-code ( linear -- linear ? )
uncons (dead-code) >r cons r> ;
M: %jump-label simplify-node ( linear vop -- linear ? )
drop
\ %return dup double-jump [
t
] [
\ %jump-label dup double-jump [
t
] [
\ %jump dup double-jump
[
t
] [
useless-jump [
t
] [
dead-code
] ifte
] ifte
] ifte
] ifte ;
drop {
{ [ \ %return dup double-jump ] [ t ] }
{ [ \ %jump-label dup double-jump ] [ t ] }
{ [ \ %jump dup double-jump ] [ t ] }
{ [ useless-jump ] [ t ] }
{ [ t ] [ dead-code ] }
} cond ;
M: %target-label simplify-node ( linear vop -- linear ? )
drop

41
library/compiler/vops.factor
View File

@ -2,7 +2,7 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-backend
USING: errors generic hashtables kernel lists math namespaces
parser sequences words ;
parser sequences vectors words ;
! The linear IR is the second of the two intermediate
! representations used by Factor. It is basically a high-level
@ -46,15 +46,15 @@ M: vop calls-label? vop-label = ;
: empty-vop f f f ;
: label-vop ( label) >r f f r> ;
: label/src-vop ( label src) unit swap f swap ;
: src-vop ( src) unit f f ;
: dest-vop ( dest) unit dup f ;
: src/dest-vop ( src dest) >r unit r> unit f ;
: 2-in-vop ( in1 in2) 2list f f ;
: 3-in-vop ( in1 in2 in3) 3list f f ;
: 2-in/label-vop ( in1 in2 label) >r 2list f r> ;
: 2-vop ( in dest) [ 2list ] keep unit f ;
: 3-vop ( in1 in2 dest) >r 2list r> unit f ;
: label/src-vop ( label src) 1vector swap f swap ;
: src-vop ( src) 1vector f f ;
: dest-vop ( dest) 1vector dup f ;
: src/dest-vop ( src dest) >r 1vector r> 1vector f ;
: 2-in-vop ( in1 in2) 2vector f f ;
: 3-in-vop ( in1 in2 in3) 3vector f f ;
: 2-in/label-vop ( in1 in2 label) >r 2vector f r> ;
: 2-vop ( in dest) [ 2vector ] keep 1vector f ;
: 3-vop ( in1 in2 dest) >r 2vector r> 1vector f ;
! miscellanea
TUPLE: %prologue ;
@ -186,7 +186,7 @@ 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
>r >r <vreg> r> <vreg> r> <vreg> 3vector dup second f
<%set-slot> ;
M: %set-slot basic-block? drop t ;
@ -202,13 +202,13 @@ 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
>r >r <vreg> r> <vreg> r> over >r 3vector r> 1vector f
<%fast-set-slot> ;
M: %fast-set-slot basic-block? drop t ;
TUPLE: %write-barrier ;
C: %write-barrier make-vop ;
: %write-barrier ( ptr ) <vreg> unit dup f <%write-barrier> ;
: %write-barrier ( ptr ) <vreg> dest-vop <%write-barrier> ;
! fixnum intrinsics
TUPLE: %fixnum+ ;
@ -302,14 +302,15 @@ C: %type make-vop ;
: %type ( vreg ) <vreg> dest-vop <%type> ;
M: %type basic-block? drop t ;
TUPLE: %arithmetic-type ;
C: %arithmetic-type make-vop ;
: %arithmetic-type <vreg> dest-vop <%arithmetic-type> ;
TUPLE: %tag ;
C: %tag make-vop ;
: %tag ( vreg ) <vreg> dest-vop <%tag> ;
M: %tag basic-block? drop t ;
TUPLE: %tag-fixnum ;
C: %tag-fixnum make-vop ;
: %tag-fixnum <vreg> dest-vop <%tag-fixnum> ;
M: %tag-fixnum basic-block? drop t ;
TUPLE: %retag-fixnum ;
C: %retag-fixnum make-vop ;
: %retag-fixnum <vreg> dest-vop <%retag-fixnum> ;
M: %retag-fixnum basic-block? drop t ;
TUPLE: %untag-fixnum ;
C: %untag-fixnum make-vop ;

2
library/compiler/x86/assembler.factor
View File

@ -88,7 +88,7 @@ M: indirect canonicalize dup car EBP = [ drop [ EBP 0 ] ] when ;
( Displaced indirect register operands -- eg, [ EAX 4 ] )
PREDICATE: cons displaced
dup length 2 =
[ 2unlist integer? swap register? and ] [ drop f ] ifte ;
[ first2 integer? swap register? and ] [ drop f ] ifte ;
M: displaced modifier second byte? BIN: 01 BIN: 10 ? ;
M: displaced register car register ;

24
library/compiler/x86/generator.factor
View File

@ -4,7 +4,6 @@ IN: compiler-backend
USING: alien assembler compiler inference kernel
kernel-internals lists math memory namespaces sequences words ;
M: integer v>operand tag-bits shift ;
M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
! Not used on x86
@ -43,7 +42,7 @@ M: %return generate-node ( vop -- )
M: %untag generate-node ( vop -- )
vop-out-1 v>operand BIN: 111 bitnot AND ;
M: %tag-fixnum generate-node ( vop -- )
M: %retag-fixnum generate-node ( vop -- )
vop-out-1 v>operand 3 SHL ;
M: %untag-fixnum generate-node ( vop -- )
@ -93,21 +92,6 @@ M: %type generate-node ( vop -- )
f type MOV
"end" get save-xt ;
M: %arithmetic-type generate-node ( vop -- )
#! This one works directly with the stack. It outputs an
#! UNBOXED value in vop-out-1.
0 <vreg> check-dest
<label> "end" set
! Load top two stack values
EAX [ ESI -4 ] MOV
ECX [ ESI ] MOV
! Compute their tags
EAX tag-mask AND
ECX tag-mask AND
! Are the tags equal?
EAX ECX CMP
"end" get JE
! No, they are not equal. Call a runtime function to
! coerce the integers to a higher type.
"arithmetic_type" f compile-c-call
"end" get save-xt ;
M: %tag generate-node ( vop -- )
dup dup vop-in-1 check-dest
vop-in-1 v>operand tag-mask AND ;

20
library/continuations.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel USING: errors lists namespaces sequences ;
IN: kernel USING: errors lists namespaces sequences words ;
TUPLE: interp data call name catch ;
@ -8,24 +8,24 @@ TUPLE: interp data call name catch ;
datastack callstack >pop> >pop>
namestack catchstack <interp> ;
: continuation ( interp -- )
interp dup interp-call >pop> >pop> drop
dup interp-data >pop> drop ;
: >interp< ( interp -- data call name catch )
[ interp-data ] keep
[ interp-call ] keep
[ interp-name ] keep
interp-catch ;
: set-interp ( interp -- )
>interp< set-catchstack set-namestack
>r set-datastack r> set-callstack ;
: continuation ( interp -- )
interp dup interp-call >pop> >pop> drop
dup interp-data >pop> drop ;
: set-interp ( interp quot -- )
>r >interp< set-catchstack set-namestack
>r set-datastack r> r> swap set-callstack call ;
: callcc0 ( quot ++ | quot: cont -- | cont: ++ )
continuation
[ set-interp ] cons swap call ;
[ [ ] set-interp ] cons swap call ;
: callcc1 ( quot ++ obj | quot: cont -- | cont: obj ++ obj )
continuation
[ [ interp-data push ] keep set-interp ] cons swap call ;
[ swap literalize unit set-interp ] cons swap call ;

9
library/errors.factor
View File

@ -5,14 +5,11 @@ USING: kernel-internals lists ;
DEFER: callcc1
IN: errors
! This is a very lightweight exception handling system.
TUPLE: no-method object generic ;
: no-method ( object generic -- )
#! We 2dup here to leave both values on the stack, for
#! post-mortem inspection.
<no-method> throw ;
! This is a very lightweight exception handling system.
: no-method ( object generic -- ) <no-method> throw ; inline
: catchstack ( -- cs ) 6 getenv ;
: set-catchstack ( cs -- ) 6 setenv ;

9
library/eval-catch.factor
View File

@ -1,9 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: parser USING: kernel errors io ;
: eval-catch ( str -- )
[ eval ] [ [ print-error debug-help drop ] when* ] catch ;
: eval>string ( in -- out )
[ eval-catch ] string-out ;

55
library/generic/builtin.factor
View File

@ -1,55 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: generic
USING: errors hashtables kernel lists math namespaces parser
sequences strings vectors words ;
! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin
! Global vector mapping type numbers to builtin class objects.
SYMBOL: builtins
builtin [
"builtin-type" word-prop unit
] "builtin-supertypes" set-word-prop
builtin [
( generic vtable definition class -- )
rot set-vtable drop
] "add-method" set-word-prop
builtin 50 "priority" set-word-prop
! All builtin types are equivalent in ordering
builtin [ 2drop t ] "class<" set-word-prop
: builtin-predicate ( class -- )
dup "predicate" word-prop car
dup t "inline" set-word-prop
swap
[
\ type , "builtin-type" word-prop , \ eq? ,
] make-list
define-compound ;
: register-builtin ( class -- )
dup "builtin-type" word-prop builtins get set-nth ;
: define-builtin ( symbol type# predicate slotspec -- )
>r >r >r
dup intern-symbol
dup r> "builtin-type" set-word-prop
dup builtin define-class
dup r> unit "predicate" set-word-prop
dup builtin-predicate
dup r> define-slots
register-builtin ;
: builtin-type ( n -- symbol ) builtins get nth ;
PREDICATE: word builtin metaclass builtin = ;
: type-tag ( type -- tag )
#! Given a type number, return the tag number.
dup 6 > [ drop 3 ] when ;

Some files were not shown because too many files have changed in this diff Show More