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

.cvskeywords

@@ -1,83 +1,10 @@
-./library/win32/win32-io-internals.factor:! $Id: win32-io-internals.factor,v 1.13 2005/10/30 03:25:38 spestov Exp $
+./library/win32/win32-io-internals.factor:! $Id: win32-io-internals.factor,v 1.15 2006/01/28 20:49:31 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.11 2005/09/24 19:21:17 spestov Exp $
+./library/win32/win32-stream.factor:! $Id: win32-stream.factor,v 1.16 2006/01/28 20:49:31 spestov Exp $
-./library/win32/win32-errors.factor:! $Id: win32-errors.factor,v 1.10 2005/10/06 22:11:53 erg Exp $
+./library/win32/win32-errors.factor:! $Id: win32-errors.factor,v 1.11 2005/12/22 02:30:00 erg Exp $
-./library/win32/win32-server.factor:! $Id: win32-server.factor,v 1.11 2005/09/03 18:48:25 spestov Exp $
+./library/win32/win32-server.factor:! $Id: win32-server.factor,v 1.13 2006/01/28 20:49:31 spestov Exp $
 ./library/win32/winsock.factor:! $Id: winsock.factor,v 1.8 2005/09/12 15:10:33 erg Exp $
 ./library/bootstrap/win32-io.factor:! $Id: win32-io.factor,v 1.10 2005/09/29 19:26:32 eiz Exp $
-./factor/ExternalFactor.java: * $Id: ExternalFactor.java,v 1.29 2005/10/26 01:52:25 spestov Exp $
+./native/s48_bignum.c:$Id: s48_bignum.c,v 1.12 2005/12/21 02:36:52 spestov Exp $
-./factor/ConstructorArtifact.java: * $Id: ConstructorArtifact.java,v 1.1 2005/03/01 23:55:59 spestov Exp $
+./native/s48_bignumint.h:$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
-./factor/math/Complex.java: * $Id: Complex.java,v 1.1.1.1 2004/07/16 06:26:13 spestov Exp $
+./native/s48_bignum.h:$Id: s48_bignum.h,v 1.13 2005/12/21 02:36:52 spestov Exp $
-./factor/math/FactorNumber.java: * $Id: FactorNumber.java,v 1.1.1.1 2004/07/16 06:26:12 spestov Exp $
-./factor/math/NumberParser.java: * $Id: NumberParser.java,v 1.2 2004/08/07 22:45:47 spestov Exp $
-./factor/math/Ratio.java: * $Id: Ratio.java,v 1.1.1.1 2004/07/16 06:26:13 spestov Exp $
-./factor/math/FactorMath.java: * $Id: FactorMath.java,v 1.2 2004/08/26 23:37:16 spestov Exp $
-./factor/FactorArtifact.java: * $Id: FactorArtifact.java,v 1.2 2005/02/23 04:07:46 spestov Exp $
-./factor/FactorExternalizable.java: * $Id: FactorExternalizable.java,v 1.1.1.1 2004/07/16 06:26:06 spestov Exp $
-./factor/FactorArray.java: * $Id: FactorArray.java,v 1.8 2005/01/07 19:37:20 spestov Exp $
-./factor/FactorLib.java: * $Id: FactorLib.java,v 1.8 2004/11/17 04:04:50 spestov Exp $
-./factor/ReadTable.java: * $Id: ReadTable.java,v 1.4 2004/09/06 00:14:36 spestov Exp $
-./factor/FactorReader.java: * $Id: FactorReader.java,v 1.22 2005/04/12 17:35:25 spestov Exp $
-./factor/FactorParsingDefinition.java: * $Id: FactorParsingDefinition.java,v 1.3 2004/11/17 04:04:50 spestov Exp $
-./factor/Cons.java: * $Id: Cons.java,v 1.5 2005/01/14 00:49:42 spestov Exp $
-./factor/parser/ComplexLiteral.java: * $Id: ComplexLiteral.java,v 1.4 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/Base.java: * $Id: Base.java,v 1.3 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/Field.java: * $Id: Field.java,v 1.1 2005/03/29 04:45:09 spestov Exp $
-./factor/parser/NoParsing.java: * $Id: NoParsing.java,v 1.3 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/StringLiteral.java: * $Id: StringLiteral.java,v 1.4 2005/04/03 23:02:48 spestov Exp $
-./factor/parser/BeginMethod.java: * $Id: BeginMethod.java,v 1.5 2005/02/22 02:26:19 spestov Exp $
-./factor/parser/Tuple.java: * $Id: Tuple.java,v 1.3 2005/04/14 23:37:05 spestov Exp $
-./factor/parser/Def.java: * $Id: Def.java,v 1.9 2005/01/07 19:37:21 spestov Exp $
-./factor/parser/F.java: * $Id: F.java,v 1.3 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/CharLiteral.java: * $Id: CharLiteral.java,v 1.6 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/LineComment.java: * $Id: LineComment.java,v 1.5 2005/02/22 02:26:19 spestov Exp $
-./factor/parser/BeginUnion.java: * $Id: BeginUnion.java,v 1.1 2005/01/07 19:37:21 spestov Exp $
-./factor/parser/Using.java: * $Id: Using.java,v 1.2 2005/01/29 21:39:29 spestov Exp $
-./factor/parser/T.java: * $Id: T.java,v 1.3 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/StackComment.java: * $Id: StackComment.java,v 1.4 2004/11/19 22:28:23 spestov Exp $
-./factor/parser/BeginConstructor.java: * $Id: BeginConstructor.java,v 1.4 2005/02/23 04:14:56 spestov Exp $
-./factor/parser/Definer.java: * $Id: Definer.java,v 1.1 2005/01/07 00:10:00 spestov Exp $
-./factor/parser/Primitive.java: * $Id: Primitive.java,v 1.1 2005/03/24 03:49:40 spestov Exp $
-./factor/parser/PushWord.java: * $Id: PushWord.java,v 1.2 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/BeginPredicate.java: * $Id: BeginPredicate.java,v 1.1 2005/01/07 19:37:21 spestov Exp $
-./factor/parser/BeginCons.java: * $Id: BeginCons.java,v 1.1 2005/01/14 00:49:43 spestov Exp $
-./factor/parser/BeginStruct.java: * $Id: BeginStruct.java,v 1.2 2005/04/10 02:43:41 spestov Exp $
-./factor/parser/Use.java: * $Id: Use.java,v 1.4 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/EndStruct.java: * $Id: EndStruct.java,v 1.1 2005/03/29 04:45:09 spestov Exp $
-./factor/parser/EndVector.java: * $Id: EndVector.java,v 1.2 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/Ket.java: * $Id: Ket.java,v 1.3 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/ClassDefinition.java: * $Id: ClassDefinition.java,v 1.1 2005/03/19 02:49:14 spestov Exp $
-./factor/parser/Ine.java: * $Id: Ine.java,v 1.10 2005/01/07 19:37:21 spestov Exp $
-./factor/parser/EndCons.java: * $Id: EndCons.java,v 1.2 2005/04/03 23:02:48 spestov Exp $
-./factor/parser/Bra.java: * $Id: Bra.java,v 1.3 2004/11/17 04:04:50 spestov Exp $
-./factor/parser/In.java: * $Id: In.java,v 1.5 2004/12/12 21:32:46 spestov Exp $
-./factor/parser/StringBufferLiteral.java: * $Id: StringBufferLiteral.java,v 1.1 2005/04/03 23:02:48 spestov Exp $
-./factor/parser/BeginVector.java: * $Id: BeginVector.java,v 1.2 2004/11/17 04:04:50 spestov Exp $
-./factor/MethodArtifact.java: * $Id: MethodArtifact.java,v 1.1 2005/02/22 02:26:18 spestov Exp $
-./factor/FactorWord.java: * $Id: FactorWord.java,v 1.15 2005/05/11 02:30:58 spestov Exp $
-./factor/VocabularyLookup.java: * $Id: VocabularyLookup.java,v 1.6 2005/05/06 23:48:59 spestov Exp $
-./factor/jedit/FactorVocabCompletion.java: * $Id: FactorVocabCompletion.java,v 1.3 2005/04/01 17:42:13 spestov Exp $
-./factor/jedit/FactorAsset.java: * $Id: FactorAsset.java,v 1.7 2005/02/22 02:26:18 spestov Exp $
-./factor/jedit/InferBufferProcessor.java: * $Id: InferBufferProcessor.java,v 1.3 2005/01/24 02:53:55 spestov Exp $
-./factor/jedit/FactorParsedData.java: * $Id: FactorParsedData.java,v 1.5 2005/06/08 22:11:53 spestov Exp $
-./factor/jedit/RestartableFactorScanner.java: * $Id: RestartableFactorScanner.java,v 1.3 2004/12/12 21:32:46 spestov Exp $
-./factor/jedit/FactorSideKickParser.java: * $Id: FactorSideKickParser.java,v 1.30 2005/07/04 21:35:22 spestov Exp $
-./factor/jedit/EditWordDialog.java: * $Id: EditWordDialog.java,v 1.8 2005/04/12 17:35:25 spestov Exp $
-./factor/jedit/FactorPlugin.java: * $Id: FactorPlugin.java,v 1.56 2005/10/19 00:19:09 spestov Exp $
-./factor/jedit/FactorOptionPane.java: * $Id: FactorOptionPane.java,v 1.3 2005/06/04 06:20:54 spestov Exp $
-./factor/jedit/FactorShell.java: * $Id: FactorShell.java,v 1.13 2005/07/17 20:29:17 spestov Exp $
-./factor/jedit/WordPreview.java: * $Id: WordPreview.java,v 1.13 2005/07/04 21:35:22 spestov Exp $
-./factor/jedit/WordListDialog.java: * $Id: WordListDialog.java,v 1.4 2004/12/20 02:06:55 spestov Exp $
-./factor/jedit/FactorBufferProcessor.java: * $Id: FactorBufferProcessor.java,v 1.6 2005/04/03 20:55:55 spestov Exp $
-./factor/jedit/CompileBufferProcessor.java: * $Id: CompileBufferProcessor.java,v 1.2 2005/01/24 02:53:55 spestov Exp $
-./factor/jedit/FactorWordRenderer.java: * $Id: FactorWordRenderer.java,v 1.17 2005/05/04 03:50:03 spestov Exp $
-./factor/jedit/TextAreaPopup.java: * $Id: TextAreaPopup.java,v 1.2 2005/04/29 06:37:11 spestov Exp $
-./factor/jedit/InsertUseDialog.java: * $Id: InsertUseDialog.java,v 1.3 2004/09/04 05:05:49 spestov Exp $
-./factor/jedit/FactorWordCompletion.java: * $Id: FactorWordCompletion.java,v 1.4 2005/04/12 17:35:26 spestov Exp $
-./factor/FactorMethodDefinition.java: * $Id: FactorMethodDefinition.java,v 1.2 2005/01/07 00:09:59 spestov Exp $
-./factor/FactorScanner.java: * $Id: FactorScanner.java,v 1.7 2004/12/05 23:33:19 spestov Exp $
-./factor/FactorParseException.java: * $Id: FactorParseException.java,v 1.3 2004/08/13 22:43:03 spestov Exp $
-./factor/FactorException.java: * $Id: FactorException.java,v 1.1.1.1 2004/07/16 06:26:06 spestov Exp $
-./native/s48_bignum.c:$Id: s48_bignum.c,v 1.10 2005/06/13 00:55:29 spestov Exp $
-./native/s48_bignumint.h:$Id: s48_bignumint.h,v 1.13 2005/06/13 00:55:30 spestov Exp $
-./native/s48_bignum.h:$Id: s48_bignum.h,v 1.11 2005/06/13 00:55:29 spestov Exp $

CHANGES.html

@@ -4,6 +4,137 @@
 <head><title>Factor change log</title></head>
 <body>
 
+<h1>Factor 0.80:</h1>
+
+<ul>
+
+<li>New help system, browsable in the UI and via the HTTP server (<code>/responder/help</code>). In the UI listener, invoke <code>handbook</code> to read the documentation root, and invoke <code>\ foo help</code> to look at documentation for the word <code>foo</code>.</li>
+
+<li>Sequences:
+
+<ul>
+<li>Association list words <code>assoc*</code>, <code>set-assoc</code>, <code>acons</code> and <code>remove-assoc</code> are gone.</li>
+<li>The <code>repeated</code> virtual sequence type is gone. Instead, the
+<code>&lt;array&gt;</code> word takes an initial element in addition to an
+initial size.</li>
+<li>The <code>fill</code> word to create a new string with an initial character
+repeated a certain number of times has been renamed to <code>&lt;string&gt;</code>.</li>
+<li>Add a new <code>interleave ( seq quot between -- )</code> combinator that applies
+a quotation to each element of a sequence, calling another quotation in between each
+pair.</li>
+<li>Add a new <code>&lt;=&gt; ( obj1 obj2 -- n )</code> word for comparing two
+objects using an intrinsic order. For numbers this is the standard order, for strings
+this is lexicographic order, and for words, this compares word names.</li>
+<li>The <code>natural-sort ( seq -- seq )</code> word replaces <code>number-sort</code>,
+<code>string-sort</code> and <code>word-sort</code>.</li>
+</ul>
+
+</li>
+
+<li>Hashtables:
+<ul>
+<li><code>hash* ( key hash -- [[ key value ]] )</code> is now <code>hash* ( key hash -- value ? )</code></li>
+<li><code>hash-clear</code> is now <code>clear-hash</code></li>
+<li><code>hash-each</code>, <code>hash-each-with</code>, <code>hash-all?</code>, <code>hash-all-with?</code>, <code>hash-subset</code>, <code>hash-subset-with</code> now pass the key and value separately on the stack to the given quotation, instead of passing a cons cell</li>
+<li>Literal syntax change: <code>H{ [[ key value ]] ... }</code> is now <code>H{ { key value } }</code></li>
+</ul>
+</li>
+
+<li>Math:
+
+<ul>
+
+<li>The <code>sum</code> and <code>product</code> words have been moved to
+<code>contrib/math/</code>.</li>
+<li>The <code>mod</code> word is now supported for ratios and floating point numbers.</li>
+<li>The <code>truncate</code>, <code>floor</code> and <code>ceiling</code> words are now supported for floating point numbers.</li>
+<li>The NaN, positive infinity and negative infinity floating point numbers now parse and unparse as <code>0.0/0.0</code>, <code>1.0/0.0</code>, and <code>-1.0/0.0</code> respectively.</li>
+<li>The NaN value is now equal to itself under <code>=</code>.</li>
+<li>Negative and postive zero are no longer equal under <code>=</code>. However, the new <code>zero?</code> word tests if the top of the stack is a zero, and it tests for both positive and negative zero.</li>
+</ul>
+
+</li>
+
+<li>Streams:
+
+<ul>
+<li><code>stream-format ( string style stream -- )</code> now takes a hashtable
+rather than an association list for specifying style information.</li>
+<li><code>stream-write</code> and <code>stream-terpri</code> are now generic words, and there is a new <code>with-nested-stream</code> generic word. You can wrap your output streams in a <code>&lt;plain-writer&gt;</code> to avoid implementing these.</li>
+</ul>
+</li>
+
+
+<li>C library interface:
+
+<ul>
+<li>Some alien word changes:
+<pre>&lt;foo&gt; ==&gt; "foo" &lt;c-object&gt;
+&lt;foo-array&gt; ==&gt; "foo" &lt;c-array&gt;</pre>
+<li>Support for binding to Objective C libraries is now included.
+<ul>
+<li>Normal usage of Objective C classes and methods is done using the <code>OBJC-CLASS:</code>
+and <code>OBJC-MESSAGE:</code> parsing words. See the example in
+<code>examples/cocoa-speech.factor</code>.</li>
+<li>Objective C runtime introspection functions and structures are defined in the
+<code>objective-c</code> vocabulary.</li>
+</ul>
+</li>
+<li>Added a pair of words for between Factor strings and C strings, <code>alien&gt;string</code> and <code>string&gt;alien</code>.
+</li>
+
+<li>Compiler changes:
+
+<ul>
+<li>AMD64 compiler backend.</li>
+<li>Fixed some problems with compilation of inlined recursive words.</li>
+</ul>
+
+</li>
+
+<li>UI changes:
+
+<ul>
+<li>Fixed invalid OpenGL calls which caused problems on Windows machines with ATI
+drivers, and Linux machines with the MesaGL implementation.</li>
+<li>The listener looks different now. An expandable top area is used for browsing objects, words and help, and the stack display has been shrunk to a single status line at the bottom of the window.</li>
+<li>A left click on a presentation now invokes the default command. A right click
+shows a menu of possibilities.</li>
+</ul>
+
+</li>
+
+<li>Bootstrap changes:
+
+<ul>
+<li>Source files are no longer loaded in the stage-2 bootstrap. Since stage-2 bootstrap
+runs in the interpreter, this reduces bootstrap time by a few minutes. Instead, all
+source files, including the compiler backend, are loaded in stage-1 bootstrap, and thus
+boot images are now CPU-specific. Boot images can be created as follows:
+<pre>
+USE: image
+"x86" make-image
+"ppc" make-image
+"amd64" make-image
+</pre></li>
+</ul>
+
+</li>
+
+<li>Contributed libraries:
+
+<ul>
+<li>All libraries in <code>contrib/</code> have been tested and updated for recent language
+changes, and you can run <code>contrib/load.factor</code> to load all of them at once (Trent Buck)</li>
+<li>Updated <code>contrib/x11/</code> with many more examples (Eduardo Cavazos)</li>
+<li>Added splay tree library in <code>contrib/splay-trees.factor</code> (Mackenzie Straight)</li>
+<li>Improved AJAX support in <code>contrib/httpd/</code>. The "prototype" JavaScript library is now included (Chris Double)</li>
+</ul>
+
+</li>
+
+</ul>
+
 <h1>Factor 0.79:</h1>
 
 <ul>
@@ -109,6 +240,7 @@ However, most uses of <code>catch</code> can be replaced by <code>cleanup</code>
 <li>Advanced math library with quaternions, matrices, polynomials, statistics and various
 functions in <code>contrib/math/</code>. (Doug Coleman)</li>
 <li>Dimensioned units in <code>contrib/units/</code>. (Doug Coleman)</li>
+<li>X11 binding in <code>contrib/x11/</code> (Eduardo Cavazos)</li>
 </ul>
 
 </li>

Makefile

@@ -50,7 +50,8 @@ OBJS = $(PLAF_OBJS) native/array.o native/bignum.o \
 	native/hashtable.o \
 	native/icache.o \
 	native/io.o \
-	native/wrapper.o
+	native/wrapper.o \
+	native/ffi_test.o
 
 default:
 	@echo "Run 'make' with one of the following parameters:"
@@ -84,7 +85,7 @@ macosx-sdl:
 		CFLAGS="$(DEFAULT_CFLAGS) -DFACTOR_SDL" \
 		LIBS="$(DEFAULT_LIBS) -lSDL -lSDLmain -framework Cocoa -framework OpenGL" 
 
-linux:
+linux linux-x86 linux-amd64:
 	$(MAKE) $(BINARY) \
 		CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \
 		LIBS="-ldl $(DEFAULT_LIBS)"

README.txt

@@ -9,22 +9,18 @@ implementation. It is not an introduction to the language itself.
 Factor is fully supported on the following platforms:
 
   Linux/x86
-  FreeBSD/x86
+  Linux/AMD64
   Microsoft Windows 2000 or later
   Mac OS X/PowerPC
+
+The following platforms should work, but are not tested on a
+regular basis:
+
+  FreeBSD/x86
+  FreeBSD/AMD64
   Linux/PowerPC
 
-While Factor may run on other Unix platforms (Solaris/Sparc,
+Other platforms are not supported.
-Linux/Alpha, and so on), the native compiler will not be available, and
-thus much functionality will be missing. In particular, the following
-features require the native compiler and only work on supported
-platforms:
-
-  C library interface
-  Non-blocking I/O
-  Networking
-
-Factor _will not_ run, at all, on Windows NT or Windows 9x.
 
 * Compiling Factor
 
@@ -44,8 +40,8 @@ parameters to build the Factor runtime:
   macosx-sdl
   windows
 
-Note: If you wish to use the Factor UI on Mac OS X, you must build with the
+Note: If you wish to use the Factor UI on Mac OS X, you must build with
-macosx-sdl target.
+the macosx-sdl target.
 
 The following options can be given to make:
 
@@ -57,7 +53,7 @@ The former allows optimization flags to be specified, for example
 difference in Factor's performance, so willing hackers should
 experiment.
 
-The latter flag disables optimization and builds an executable with
+The DEBUG flag disables optimization and builds an executable with
 debug symbols. This is probably only of interest to people intending to
 hack on the runtime sources.
 
@@ -69,12 +65,11 @@ Compilation will yield an executable named 'f'.
 
 * Building Factor
 
-The Factor source distribution ships with four boot image files:
+The Factor source distribution ships with three boot image files:
 
-  boot.image.le32 - for x86
+  boot.image.x86
-  boot.image.be32 - for PowerPC, SPARC
+  boot.image.ppc
-  boot.image.le64 - for x86-64, Alpha
+  boot.image.amd64
-  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.
@@ -112,8 +107,8 @@ naming the libraries during bootstrap, as in the next section.
 
 * Setting up SDL libraries for use with Factor
 
-The Windows binary package for Factor includes all prerequisite DLLs. On Unix,
+The Windows binary package for Factor includes all prerequisite DLLs.
-you need recent versions of SDL and FreeType.
+On Unix, you need recent versions of SDL and FreeType.
 
 If you have installed these libraries but the UI still fails with an
 error, you will need to find out the exact names that they are installed
@@ -135,7 +130,6 @@ as, and issue a command similar to the following to bootstrap Factor:
     freetype/ - FreeType binding, rendering glyphs to OpenGL textures
     generic/ - generic words, for object oriented programming style
     help/ - online help system
-    httpd/ - HTTP client, server, and web application framework
     inference/ - stack effect inference, used by compiler, as well as a
       useful development tool of its own
     io/ - input and output streams
@@ -150,7 +144,6 @@ as, and issue a command similar to the following to bootstrap Factor:
     win32/ - Windows-specific I/O code
   contrib/ - various handy libraries not part of the core
   examples/ - small examples illustrating various language features
-  factor/ - Java code for the Factor jEdit plugin
   fonts/ - TrueType fonts used by UI
 
 * Learning Factor
@@ -158,7 +151,7 @@ as, and issue a command similar to the following to bootstrap Factor:
 The UI has a simple tutorial that will show you the most basic concepts.
 
 There is a detailed language and library reference available at
-http://factor.sourceforge.net/handbook.pdf.
+http://factorcode.org/handbook.pdf.
 
 You can browse the source code; it is organized into small,
 well-commented files and should be easy to follow once you have a good
@@ -166,12 +159,25 @@ grasp of the language.
 
 * Community
 
-The Factor homepage is located at http://factor.sourceforge.net/.
+The Factor homepage is located at http://factorcode.org/.
 
 Factor developers meet in the #concatenative channel on the
 irc.freenode.net server. Drop by if you want to discuss anything related
 to Factor or language design in general.
 
+* Credits
+
+The following people have contributed code to the Factor core:
+
+Slava Pestov:       Lead developer
+Alex Chapman:       OpenGL binding
+Doug Coleman:       Mersenne Twister random number generator
+Mackenzie Straight: Windows port
+Trent Buck:         Debian package
+
+A number of contributed libraries not part of the core can be found in
+contrib/. See contrib/README.txt for details.
+
 Have fun!
 
 :tabSize=2:indentSize=2:noTabs=true:

TODO.FACTOR.txt

@@ -1,115 +1,35 @@
-+ ui:
+- fix remaining HTML stream issues
-
+- help cross-referencing
-- fix remaining GL issues
+- UI browser pane needs 'back' button
-- UI issue: try resizing slider while menu is open
+- runtime primitives like fopen: check for null input
-- make-pane: if no input, just return pane-output
+- amd64 alien calls
-- keyboard completion
+- port ffi to win64
-- get outliner working with lots of lines of output
+- intrinsic char-slot set-char-slot for x86
-- listener continuations
+- fix up the min thumb size hack
-- fix up the min thumb size hack
+- the invalid recursion form case needs to be fixed, for inlines too
-- off-by-one error in pick-up?
+- code walker & exceptions
-- closing ui does not stop timers
+- signal handler should not lose stack pointers
-- adding/removing timers automatically for animated gadgets
+- FIELD: char key_vector[32];
-- tabular output
+- FIELD: union { char b[20]; short s[10]; long l[5]; } data;
-- debugger should use outlining
+- MEMBER: long pad[24];
-- support nested incremental layouts more efficiently
+- C structs, enums, unions: use new-style string mode parsing
-- only redraw dirty gadgets
+- ffi unicode strings: null char security hole
-- find out why so many small bignums get consed
+- utf16 string boxing
-- use incremental strategy for all pack layouts where possible
+- [ [ dup call ] dup call ] infer hangs
-- multiline editing in listener
+- slice: if sequence or seq start is changed, abstraction violation
-- text selection
+- out of memory error when printing global namespace
-- clipboard support
+- delegating generic words with a non-standard picker
-- bug: slider bars go to 0 pixel width/height
+- code gc
-- bug: left click to bring up context menu, click splitter bar
+- stream server can hang because of exception handler limitations
-  and pane grows to 100%
+- better i/o scheduler
-- bug: click tutorial, full screen, the right-most arrow icon
+- if two tasks write to a unix stream, the buffer can overflow
-  loses the vertical bar
+- font problem: http://iarc1.ece.utexas.edu/~erg/font-bug.JPG
-
+- make 3.4 bits>double an error
-+ tutorial:
+
-
+- 2220.446049250313 [ dup float? [ tanh ] when ] 
-- multiline code snippets
+  - call and compile-1 give  C{ 0.0/0.0 0.0/0.0 }  0.0/0.0
-- s-expression text styling language
+- 2.718281828459045e+19 [ dup float? [ sech ] when ]
-- word wrap
+  - call/compile-1:  C{ 0.0/0.0 0.0/0.0 }  0.0
-
+- 0.0/0.0 next-power-of-2 never terminates -- comparison always returns false
-+ misc
+- 0.0/0.0 >fixnum .  -> 0    0.0/0.0 >bignum .  -> 0
-
+
-- code walker & exceptions
-- investigate if rehashing on startup is really necessary
-- remove word transfer hack in bootstrap
-- signal handler should not lose stack pointers
-
-+ ffi:
-
-- C structs, enums, unions: use new-style string mode parsing
-- smarter out parameter handling
-- clarify powerpc passing of value struct parameters
-- ffi unicode strings: null char security hole
-- utf16 string boxing
-- value type structs
-- bitfields in C structs
-- setting struct members that are not *
-- callbacks
-- FIELD: char key_vector[32];
-- FIELD: union { char b[20]; short s[10]; long l[5]; } data;
-- MEMBER: long pad[24];
-- convert factor sequences to c arrays, and vice versa
-
-+ compiler:
-
-- inference: try changing nth and set-nth array methods to call -unsafe,
-  unbalanced branches error
-- compile interruption checks
-- check that set-datastack and set-callstack compile correctly in the
-  face of optimization
-- floating point intrinsics
-- new basic block optimizer
-- fix fixnum/mod overflow on PowerPC
-- intrinsic char-slot set-char-slot
-- [ ] [ throw ] ifte ==> should raise 'unbalanced branches' error
-- declare slot types for built-ins
-- remove dead code after a 'throw'
-- flushing optimization
-- [ [ dup call ] dup call ] infer hangs
-- the invalid recursion form case needs to be fixed, for inlines too
-- recursion is iffy; if the stack at the recursive call doesn't match
-  up, throw an error
-- compile continuations
-
-+ sequences:
-
-- slice: if sequence or seq start is changed, abstraction violation
-- split: return vectors
-- set-path: iterative
-- specialized arrays
-- instances: do not use make-list
-- >c/c>: vector stack
-- search: slow
-- vectorize >n, n>, (get)
-- mutable strings simplifying string operarations
-- real Unicode support (strings are already 16 bits and can be extended
-  to 21 if the need arises, but we need full character classification
-  predicates, comparison, case conversion, sorting...)
-
-+ kernel:
-
-- better prettyprinting of cond
-- better handling of random arrangements of html words when
-  prettyprinting
-- friendlier .factor-rc load error handling
-- reader syntax for byte arrays, displaced aliens
-- out of memory error when printing global namespace
-- merge timers with sleeping tasks
-- what about tasks and timers between image restarts
-- there is a problem with hashcodes of words and bootstrapping
-- delegating generic words with a non-standard picker
-- code gc
-
-+ i/o:
-
-- i/o tasks hanging around
-- faster stream-copy
-- reading and writing byte arrays
-- stream server can hang because of exception handler limitations
-- better i/o scheduler
-- utf16, utf8 encoding
-- if two tasks write to a unix stream, the buffer can overflow

actions.xml

@@ -1,126 +0,0 @@
-<?xml version="1.0"?>
-
-<!DOCTYPE ACTIONS SYSTEM "actions.dtd">
-
-<ACTIONS>
-	<ACTION NAME="factor-keymap">
-		<CODE>
-			{
-				p = new Properties();
-				p.load(factor.jedit.FactorPlugin.class
-					.getResourceAsStream(
-					"/factor.keymap"));
-				e = p.entrySet().iterator();
-				while(e.hasNext())
-				{
-					a = e.next();
-					jEdit.setProperty(a.key,a.value);
-				}
-			}
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-listener">
-		<CODE>
-			wm.addDockableWindow("console");
-			wm.getDockableWindow("console").setShell("Factor");
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-restart">
-		<CODE>
-			FactorPlugin.restartExternalInstance();
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-eval-selection">
-		<CODE>
-			sel = textArea.selectedText;
-			if(sel == null)
-				view.toolkit.beep();
-			else
-				FactorPlugin.evalInListener(view,sel);
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-eval-word-def">
-		<CODE>
-			FactorPlugin.evalWordDef(view);
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-run-file">
-		<CODE>
-			buffer.save(view,null);
-			VFSManager.waitForRequests();
-			FactorPlugin.evalInListener(view,
-				"\""
-				+ FactorReader.charsToEscapes(buffer.path)
-				+ "\" run-file");
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-apropos">
-		<CODE>
-			word = FactorPlugin.getWordAtCaret(textArea);
-			if(word == null)
-				view.toolkit.beep();
-			else
-			{
-				FactorPlugin.evalInListener(view,
-					"\""
-					+ FactorReader.charsToEscapes(word)
-					+ "\" apropos");
-			}
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-see">
-		<CODE>
-			FactorPlugin.factorWordPopupOp(view,"see");
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-edit">
-		<CODE>
-			FactorPlugin.factorWordWireOp(view,"jedit");
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-edit-dialog">
-		<CODE>
-			new EditWordDialog(view,FactorPlugin
-				.getSideKickParser());
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-usages">
-		<CODE>
-			FactorPlugin.factorWordOutputOp(view,"usages .");
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-insert-use">
-		<CODE>
-			word = FactorPlugin.getWordAtCaret(textArea);
-			if(word == null)
-				view.toolkit.beep();
-			else
-				FactorPlugin.insertUseDialog(view,word);
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-extract-word">
-		<CODE>
-			FactorPlugin.extractWord(view);
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-infer-effect">
-		<CODE>
-			FactorPlugin.factorWordPopupOp(view,"unit infer .");
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-compile">
-		<CODE>
-			FactorPlugin.factorWordOutputOp(view,"recompile");
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-infer-effects">
-		<CODE>
-			InferBufferProcessor.createInferUnitTests(view,buffer);
-		</CODE>
-	</ACTION>
-	<ACTION NAME="factor-compile-all">
-		<CODE>
-			new CompileBufferProcessor(view,buffer);
-		</CODE>
-	</ACTION>
-</ACTIONS>

build.xml

@@ -1,77 +0,0 @@
-<?xml version="1.0"?>
-
-<project name=" Factor" default="dist" basedir=".">
-
-	<path id="jedit-classpath">
-		<pathelement location="${user.home}/.jedit/jars/ErrorList.jar" />
-		<pathelement location="${user.home}/.jedit/jars/SideKick.jar" />
-		<pathelement location="${user.home}/.jedit/jars/Console.jar" />
-	</path>
-
-	<target name="compile">
-		<javac
-			srcdir="."
-			destdir="."
-			deprecation="on"
-			includeJavaRuntime="yes"
-			debug="true"
-			optimize="true"
-			classpathref="jedit-classpath"
-			source="1.4"
-			target="1.4"
-		>
-		<include name="**/*.java"/>
-		</javac>
-	</target>
-
-	<target name="dist" depends="compile">
-		<jar
-			jarfile="../Factor.jar"
-			compress="true"
-		>
-			<fileset dir=".">
-				<include name="factor/*.class"/>
-				<include name="factor/**/*.class"/>
-				<include name="factor/**/*.props"/>
-				<include name="factor/**/*.bsh"/>
-				<include name="factor/**/*.txt"/>
-				<include name="*.xml"/>
-				<include name="*.keymap"/>
-				<include name="library/**/*.png"/>
-				<include name="doc/*.html"/>
-				<include name="doc/jedit/*.html"/>
-				<include name="doc/jedit/*.png"/>
-			</fileset>
-		</jar>
-	</target>
-
-	<target name="clean" description="Clean old stuff.">
-		<delete>
-			<fileset dir="." includes="**/*.class"/>
-			<fileset dir="." includes="**/*~" defaultexcludes="no"/>
-			<fileset dir="." includes="**/#*#" defaultexcludes="no"/>
-			<fileset dir="." includes="**/*.rej"/>
-			<fileset dir="." includes="**/*.orig"/>
-			<fileset dir="." includes="**/.*.swp"/>
-			<fileset dir="." includes="**/.#*"/>
-			<fileset dir="." includes="**/.new*"/>
-			<fileset dir="." includes="**/.directory"/>
-		</delete>
-	</target>
-
-	<target name="docs" description="Build PDF and HTML docs.">
-		<delete>
-			<fileset dir="." includes="doc/devel-guide/*.html"/>
-			<fileset dir="." includes="doc/devel-guide.aux"/>
-			<fileset dir="." includes="doc/devel-guide.log"/>
-			<fileset dir="." includes="doc/devel-guide.pdf"/>
-		</delete>
-		<exec executable="latex" dir="doc">
-			<arg value="devel-guide.tex" />
-		</exec>
-		<exec executable="latex2html" dir="doc">
-			<arg value="-local_icons"/>
-			<arg value="devel-guide.tex" />
-		</exec>
-	</target>
-</project>

contrib/README.txt

@@ -14,6 +14,8 @@ library, but is useful enough to ship with the Factor distribution.
   
 - contrib/crypto/ -- MD5 and SHA1 cryptographic hashes (Doug Coleman)
 
+- contrib/factory/ -- X11 window manager (Eduardo Cavazos)
+
 - contrib/httpd/ -- HTTP server and client (Slava Pestov, Chris Double)
 
 - contrib/math/ -- extended math library (Doug Coleman)
@@ -23,15 +25,19 @@ library, but is useful enough to ship with the Factor distribution.
 
 - contrib/postgresql/ -- PostgreSQL binding (Doug Coleman)
 
+- contrib/random-tester/ -- Random compiler tester (Doug Coleman)
+
 - contrib/space-invaders/ -- Intel 8080-based Space Invaders arcade
   machine emulator (Chris Double)
 
 - contrib/sqlite/ -- SQLite binding (Chris Double)
 
+- contrib/x11 -- X Window System client library (Eduardo Cavazos)
+
 - contrib/coroutines.factor -- coroutines (Chris Double)
 
 - contrib/dlists.factor -- double-linked-lists (Mackenzie Straight)
 
-- contrib/xml.factor -- XML parser and writer (Daniel Ehrenberg)
+- contrib/splay-trees.factor -- Splay trees (Mackenzie Straight)
 
-- contrib/x11 -- X Window System client library (Eduardo Cavazos)
+- contrib/xml.factor -- XML parser and writer (Daniel Ehrenberg)

contrib/aim/aim.factor

@@ -1,7 +1,7 @@
 ! All Talk
 
 IN: aim-internals
-USING: kernel sequences lists stdio prettyprint strings namespaces math unparser threads vectors errors parser interpreter test io crypto words hashtables inspector aim-internals generic queues ;
+USING: kernel sequences lists prettyprint strings namespaces math threads vectors errors parser interpreter test io crypto words hashtables inspector aim-internals generic queues arrays ;
 
 SYMBOL: username
 SYMBOL: password
@@ -65,77 +65,78 @@ TUPLE: buddy name id gid capabilities buddy-icon online ;
 ! Family names from ethereal
 : family-names
 H{
-    [[ 1 "Generic" ]] [[ 2 "Location" ]] [[ 3 "Buddylist" ]]
+    { 1 "Generic" } { 2 "Location" } { 3 "Buddylist" }
-    [[ 4 "Messaging" ]] [[ 6 "Invitation" ]] [[ 8 "Popup" ]]
+    { 4 "Messaging" } { 6 "Invitation" } { 8 "Popup" }
-    [[ 9 "BOS" ]] [[ 10 "User Lookup" ]] [[ 11 "Stats" ]]
+    { 9 "BOS" } { 10 "User Lookup" } { 11 "Stats" }
-    [[ 12 "Translate" ]] [[ 19 "SSI" ]] [[ 21 "ICQ" ]]
+    { 12 "Translate" } { 19 "SSI" } { 21 "ICQ" }
-    [[ 34 "Unknown Family" ]] } ;
+    { 34 "Unknown Family" } } ;
 
 : sanitize-name ( name -- name ) HEX: 20 swap remove >lower ;
 
 : hash-swap ( hash -- hash )
-    [ [ unswons cons , ] hash-each ] { } make alist>hash ;
+    hash>alist [ first2 swap 2array ] map alist>hash ;
 
 : 2list>hash ( keys values -- hash )
     H{ } clone -rot [ swap pick set-hash ] 2each ;
 
 : capability-names
 H{
-    [[ "Unknown1" HEX: 094601054c7f11d18222444553540000 ]]
+    { "Unknown1" HEX: 094601054c7f11d18222444553540000 }
-    [[ "Games" HEX: 0946134a4c7f11d18222444553540000 ]]
+    { "Games" HEX: 0946134a4c7f11d18222444553540000 }
-    [[ "Send Buddy List" HEX: 0946134b4c7f11d18222444553540000 ]]
+    { "Send Buddy List" HEX: 0946134b4c7f11d18222444553540000 }
-    [[ "Chat" HEX: 748f2420628711d18222444553540000 ]]
+    { "Chat" HEX: 748f2420628711d18222444553540000 }
-    [[ "AIM/ICQ Interoperability" HEX: 0946134d4c7f11d18222444553540000 ]]
+    { "AIM/ICQ Interoperability" HEX: 0946134d4c7f11d18222444553540000 }
-    [[ "Voice Chat" HEX: 094613414c7f11d18222444553540000 ]]
+    { "Voice Chat" HEX: 094613414c7f11d18222444553540000 }
-    [[ "iChat" HEX: 094600004c7f11d18222444553540000 ]]
+    { "iChat" HEX: 094600004c7f11d18222444553540000 }
-    [[ "Send File" HEX: 094613434c7f11d18222444553540000 ]]
+    { "Send File" HEX: 094613434c7f11d18222444553540000 }
-    [[ "Unknown2" HEX: 094601ff4c7f11d18222444553540000 ]]
+    { "Unknown2" HEX: 094601ff4c7f11d18222444553540000 }
-    [[ "Live Video" HEX: 094601014c7f11d18222444553540000 ]]
+    { "Live Video" HEX: 094601014c7f11d18222444553540000 }
-    [[ "Direct Instant Messaging" HEX: 094613454c7f11d18222444553540000 ]]
+    { "Direct Instant Messaging" HEX: 094613454c7f11d18222444553540000 }
-    [[ "Unknown3" HEX: 094601034c7f11d18222444553540000 ]]
+    { "Unknown3" HEX: 094601034c7f11d18222444553540000 }
-    [[ "Buddy Icon" HEX: 094613464c7f11d18222444553540000 ]]
+    { "Buddy Icon" HEX: 094613464c7f11d18222444553540000 }
-    [[ "Add-Ins" HEX: 094613474c7f11d18222444553540000 ]]
+    { "Add-Ins" HEX: 094613474c7f11d18222444553540000 }
 } ;
 
-: capability-values capability-names hash-swap ;
+SYMBOL: capability-names-hash-swapped
+: capability-values capability-names-hash-swapped get ;
 
 : capability-abbrevs
 H{
-    [[ CHAR: A "Voice" ]]
+    { CHAR: A "Voice" }
-    [[ CHAR: C "Send File" ]]
+    { CHAR: C "Send File" }
-    [[ CHAR: E "AIM Direct IM" ]]
+    { CHAR: E "AIM Direct IM" }
-    [[ CHAR: F "Buddy Icon" ]]
+    { CHAR: F "Buddy Icon" }
-    [[ CHAR: G "Add-Ins" ]]
+    { CHAR: G "Add-Ins" }
-    [[ CHAR: H "Get File" ]]
+    { CHAR: H "Get File" }
-    [[ CHAR: K "Send Buddy List" ]]
+    { CHAR: K "Send Buddy List" }
 } ;
 
 : aim-errors
 H{
-    [[ 1 "Invalid SNAC header." ]]
+    { 1 "Invalid SNAC header." }
-    [[ 2 "Server rate limit exceeded." ]]
+    { 2 "Server rate limit exceeded." }
-    [[ 3 "Client rate limit exceeded." ]]
+    { 3 "Client rate limit exceeded." }
-    [[ 4 "Recipient is not logged in." ]]
+    { 4 "Recipient is not logged in." }
-    [[ 5 "Requested service unavailable." ]]
+    { 5 "Requested service unavailable." }
-    [[ 6 "Requested service not defined." ]]
+    { 6 "Requested service not defined." }
-    [[ 7 "You sent obsolete SNAC." ]]
+    { 7 "You sent obsolete SNAC." }
-    [[ 8 "Not supported by server." ]]
+    { 8 "Not supported by server." }
-    [[ 9 "Not supported by client." ]]
+    { 9 "Not supported by client." }
-    [[ 10 "Refused by client." ]]
+    { 10 "Refused by client." }
-    [[ 11 "Reply too big." ]]
+    { 11 "Reply too big." }
-    [[ 12 "Responses lost." ]]
+    { 12 "Responses lost." }
-    [[ 13 "Request denied." ]]
+    { 13 "Request denied." }
-    [[ 14 "Incorrect SNAC format." ]]
+    { 14 "Incorrect SNAC format." }
-    [[ 15 "Insufficient rights." ]]
+    { 15 "Insufficient rights." }
-    [[ 16 "In local permit/deny. (recipient blocked)" ]]
+    { 16 "In local permit/deny. (recipient blocked)" }
-    [[ 17 "Sender too evil." ]]
+    { 17 "Sender too evil." }
-    [[ 18 "Receiver too evil." ]]
+    { 18 "Receiver too evil." }
-    [[ 19 "User temporarily unavailable." ]]
+    { 19 "User temporarily unavailable." }
-    [[ 20 "No match." ]]
+    { 20 "No match." }
-    [[ 22 "List overflow." ]]
+    { 22 "List overflow." }
-    [[ 23 "Request ambiguous." ]]
+    { 23 "Request ambiguous." }
-    [[ 24 "Server queue full." ]]
+    { 24 "Server queue full." }
-    [[ 25 "Not while on AOL." ]]
+    { 25 "Not while on AOL." }
 } ;
 
 
@@ -149,6 +150,7 @@ H{
     H{ } clone banned-hash-id set
     <queue> modify-queue set
     HEX: 7fff random-int seq-num set
+    capability-names hash-swap capability-names-hash-swapped set 
     1 stage-num set ;
 
 : prepend-aim-protocol ( data -- )

contrib/aim/load.factor

@@ -1,9 +1,9 @@
-IN: network-util
+IN: scratchpad
-USING: parser sequences ;
+USING: kernel parser sequences words compiler ;
 
-[
+"/contrib/crypto/load.factor" run-resource
-    "contrib/crypto/load.factor"
-    "contrib/aim/net-bytes.factor"
-    "contrib/aim/aim.factor"
-] [ run-file ] each
 
+{ 
+    "net-bytes"
+    "aim"
+} [ "/contrib/aim/" swap ".factor" append3 run-resource ] each

contrib/aim/net-bytes.factor

@@ -1,5 +1,5 @@
 IN: aim-internals
-USING: kernel sequences lists stdio prettyprint strings namespaces math unparser threads vectors errors parser interpreter test io crypto ;
+USING: kernel sequences lists prettyprint strings namespaces math threads vectors errors parser interpreter test io crypto arrays ;
 
 SYMBOL: big-endian t big-endian set
 SYMBOL: unscoped-stream
@@ -31,7 +31,7 @@ SYMBOL: unscoped-stack
 
 ! TODO: make this work for types other than ""
 : papply ( seq seq -- seq )
-    [ [ 2list call % ] 2each ] "" make ;
+    [ [ 2array >list call % ] 2each ] "" make ;
 
 : writeln ( string -- )
     write terpri ;

contrib/cairo/cairo.factor

@@ -20,12 +20,9 @@ USE: lists
 USE: math
 USE: namespaces
 USE: sdl
-USE: sdl-event
-USE: sdl-gfx
-USE: sdl-video
 USE: vectors
 USE: prettyprint
-USE: stdio
+USE: io
 USE: test
 USE: syntax
 USE: sequences

contrib/cairo/cairo_sdl.factor

@@ -20,12 +20,9 @@ USE: lists
 USE: math
 USE: namespaces
 USE: sdl
-USE: sdl-event
-USE: sdl-gfx
-USE: sdl-video
 USE: vectors
 USE: prettyprint
-USE: stdio
+USE: io
 USE: test
 USE: syntax
 USE: sequences

contrib/cairo/cairo_simple.factor

@@ -12,8 +12,7 @@
 ! Then, start Factor as usual (./f factor.image) and enter these
 ! at the listener:
 !
-! "cairo.factor" run-file
+! "/contrib/cairo/load.factor" run-resource
-! "cairo_sdl.factor" run-file
 ! "cairo_simple.factor" run-file
 
 IN: cairo-simple
@@ -24,9 +23,7 @@ USE: errors
 USE: kernel
 USE: namespaces
 USE: sdl
-USE: sdl-event
+USE: alien
-USE: sdl-gfx
-USE: sdl-video
 
 : redraw ( -- )
 	cr get
@@ -52,7 +49,7 @@ USE: sdl-video
 : cairo-sdl-test ( -- )
     320 240 32 SDL_HWSURFACE  [
 		set-up-cairo
-        	<event> event-loop
+        	"event" <c-object> event-loop
 		cr get cairo_destroy
 	SDL_Quit
     ] with-screen ;

contrib/cairo/cairo_text.factor

@@ -12,14 +12,13 @@
 ! Then, start Factor as usual (./f factor.image) and enter these
 ! at the listener:
 !
-! "cairo.factor" run-file
+! "/contrib/cairo/load.factor" run-resource
-! "cairo_sdl.factor" run-file
 ! "cairo_text.factor" run-file
 
 IN: cairo-text
 SYMBOL: angle
 
-USING: cairo cairo-sdl compiler errors kernel namespaces sdl sdl-event sdl-gfx sdl-video lists math sequences ;
+USING: cairo cairo-sdl compiler errors kernel namespaces sdl lists math sequences alien ;
 
 : draw-rect ( angle -- )
 	cr get
@@ -96,7 +95,7 @@ USING: cairo cairo-sdl compiler errors kernel namespaces sdl sdl-event sdl-gfx s
 
     320 240 32 SDL_HWSURFACE  [
 		set-up-cairo
-        	<event> event-loop
+        	"event" <c-object> event-loop
 	SDL_Quit
     ] with-screen ;
 

contrib/cairo/load.factor

@@ -0,0 +1,13 @@
+IN: scratchpad
+USING: alien kernel parser compiler words sequences ;
+
+{ 
+    { "cairo" "libcairo" }
+    { "sdl-gfx" "libSDL_gfx" }
+    { "sdl" "libSDL" }
+} [ first2 add-simple-library ] each
+
+{ 
+    "cairo"
+    "cairo_sdl"
+} [ "/contrib/cairo/" swap ".factor" append3 run-resource ] each

contrib/concurrency/concurrency-examples.factor

@@ -23,8 +23,8 @@
 !
 ! Examples of using the concurrency library.
 IN: concurrency-examples
-USING: concurrency dlists errors gadgets-theme io kernel lists
+USING: concurrency dlists errors gadgets-theme gadgets-panes io kernel lists
-math namespaces opengl prettyprint sequences threads unparser ;
+math math-contrib namespaces opengl prettyprint sequences threads ;
 
 : (logger) ( mailbox -- )
   #! Using the given mailbox, start a thread which
@@ -43,7 +43,7 @@ math namespaces opengl prettyprint sequences threads unparser ;
     "Pong server shutting down" swap send
   ] if ;
   
-: pong-server0 ( -- process)
+: pong-server0 ( -- process )
   [ (pong-server0) ] spawn ;
 
 TUPLE: ping-message from ;
@@ -176,7 +176,7 @@ C: promised-label ( promise -- promised-label )
     drop "Unfulfilled Promise" 
   ] if ;
 
-M: promised-label pref-dim ( promised-label - dim )
+M: promised-label pref-dim* ( promised-label - dim )
   label-size ;
 
 M: promised-label draw-gadget* ( promised-label -- )

contrib/concurrency/concurrency.factor

@@ -24,7 +24,7 @@
 ! 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 ;
+       math sequences hashtables strings vectors dlists ;
 IN: concurrency
 
 #! Debug
@@ -356,7 +356,7 @@ SYMBOL: quit-cc
     r> drop 3drop
   ] if ;
 
-: server-cc ( -- cc | process)
+: 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

contrib/concurrency/concurrency.html

@@ -19,11 +19,9 @@ 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
+<p>The quickest way to get up and running with this library is to type the following into the listener:</p>
-change to the 'concurrency' directory and run Factor. Then execute the
-following commands:</p>
 <pre class="code">
-"load.factor" run-file
+"/contrib/concurrency/load.factor" run-resource
 USE: concurrency
 USE: concurrency-examples
 </pre>

contrib/concurrency/load.factor

@@ -1,17 +1,10 @@
-USE: kernel
+IN: scratchpad
-USE: httpd
+USING: kernel parser compiler words sequences ;
-USE: threads
-USE: prettyprint
-USE: errors
-USE: io
 
-USE: parser
+"/contrib/dlists.factor" run-resource
+"/contrib/math/load.factor" run-resource
 
-: a "../dlists.factor" run-file 
+{ 
-    "concurrency.factor" run-file ;
+    "concurrency"
-: b "concurrency-examples.factor" run-file ;
+    "concurrency-examples"
-: c "concurrency-tests.factor" run-file ;
+} [ "/contrib/concurrency/" swap ".factor" append3 run-resource ] each
-a
-b
-USE: concurrency
-USE: concurreny-examples

contrib/cont-responder/cont-examples.factor

@@ -34,7 +34,6 @@ USE: math
 USE: namespaces
 USE: prettyprint
 USE: inspector
-USE: unparser
 USE: sequences
 
 : display-page ( title -- ) 

contrib/cont-responder/cont-numbers-game.factor

@@ -32,10 +32,9 @@
 !
 ! The result is not that pretty but it shows the basic idea.
 IN: numbers-game
-USE: combinators
+USE: parser-combinators
 USE: kernel
 USE: math
-USE: random
 USE: parser
 USE: html
 USE: cont-responder
@@ -98,4 +97,4 @@ USE: namespaces
 
 : numbers-game number-to-guess numbers-game-loop ;
 
-"numbers-game" [ numbers-game ] install-cont-responder
+"numbers-game" [ numbers-game ] install-cont-responder

contrib/cont-responder/cont-testing.factor

@@ -87,7 +87,7 @@
 IN: cont-responder
 USE: namespaces
 USE: kernel
-USE: combinators
+USE: parser-combinators
 USE: io
 
 : <cont-test-state> ( -- <state> )

contrib/cont-responder/eval-responder.factor

@@ -33,14 +33,12 @@ USE: parser
 USE: lists
 USE: errors
 USE: strings
-USE: logic
 USE: live-updater
 USE: prettyprint
-USE: unparser
 USE: words
 USE: vectors
-USE: logging
 USE: sequences
+USE: hashtables
 
 : <evaluator> ( stack msg history -- )
   #! Create an 'evaluator' object that holds
@@ -73,7 +71,7 @@ USE: sequences
   #! Replace occurrences of single quotes with
   #! backslash quote.
   [
-    [ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc [ % ] [ % ] ?if ] each
+      [ dup H{ { CHAR: ' "\\'" } { CHAR: " "\\\"" } } hash [ % ] [ % ] ?if ] each
   ] "" make ;
  
 : make-eval-javascript ( string -- string )
@@ -119,10 +117,10 @@ USE: sequences
     "browser" "responder" set
     <table "1" =border table> 
       <tr> <th "2" =colspan th> "Source" write </th> </tr>
-      <tr> <td "2" =colspan td> [ [ parse ] catch [ "No such word" write ] [ car see ] if ] with-simple-html-output </td> </tr>
+      <tr> <td "2" =colspan td> [ [ parse ] catch [ "No such word" write ] [ car see ] if ] with-html-stream </td> </tr>
       <tr> <th> "Apropos" write </th> <th> "Usages" write </th> </tr>
-      <tr> <td "top" =valign td> [ apropos ] with-simple-html-output </td> 
+      <tr> <td "top" =valign td> [ apropos ] with-html-stream </td> 
-           <td "top" =valign td> [ [ parse ] catch [ "No such word" write ] [ car usages. ] if ] with-simple-html-output </td>
+           <td "top" =valign td> [ [ parse ] catch [ "No such word" write ] [ car usages. ] if ] with-html-stream </td>
       </tr>
     </table>
   ] make-hash ;
@@ -234,4 +232,3 @@ USE: sequences
   ] forever ;
 
 "eval" [ [ ] "None" [ ] <evaluator> eval-responder ] install-cont-responder
-

contrib/cont-responder/load.factor

@@ -1,54 +1,15 @@
-! Copyright (C) 2004 Chris Double.
+IN: scratchpad
-! 
+USING: words kernel parser sequences io compiler ;
-! 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.
-!
-! Start an httpd server and some words to re-load the continuation
-! server files.
-USE: kernel
-USE: httpd
-USE: threads
-USE: prettyprint
-USE: errors
-USE: io
 
-USE: parser
+"/contrib/httpd/load.factor" run-resource
+"/contrib/parser-combinators/load.factor" run-resource
 
-: l1 
+{ 
-  "cont-examples.factor" run-file 
+    "cont-examples"
-  "cont-numbers-game.factor" run-file ;
+    "cont-numbers-game"
-: l2 "todo.factor" run-file ;
+    "todo"
-: l3 "todo-example.factor" run-file ;
+    "todo-example"
-: l4 "live-updater.factor" run-file ;
+    "eval-responder"
-: l5 "eval-responder.factor" run-file ;
+    "live-updater-responder"
-: l6 "live-updater-responder.factor" run-file ;
+    "cont-testing"
-: l7 "cont-testing.factor" run-file ;
+} [ "/contrib/cont-responder/" swap ".factor" append3 run-resource ] each
-: l8 
-  #! Use for reloading and testing changes to browser responder
-  #! in factor core.
-  "../../library/httpd/browser-responder.factor" run-file ;
-: l9
-  #! Use for reloading and testing changes to cont responder
-  #! in factor core.
-  "../../library/httpd/cont-responder.factor" run-file ;
-DEFER: la
-: la 8888 httpd ;
-: lb [ la "httpd thread exited.\n" write flush ] in-thread  ;

contrib/cont-responder/todo-example.factor

@@ -27,6 +27,7 @@
 ! list of things to do. All data is stored in a directory in the 
 ! filesystem with the users name.
 IN: todo-example
+USING: xml ;
 USE: cont-responder
 USE: html
 USE: io
@@ -35,7 +36,6 @@ USE: namespaces
 USE: inspector
 USE: lists
 USE: cont-examples
-USE: regexp
 USE: prettyprint
 USE: todo
 USE: math

contrib/cont-responder/todo.factor

@@ -25,7 +25,6 @@
 ! 'password' and list of items. Each item has a priority, description, 
 ! and indication if it is complete. 
 IN: todo
-USE: parser
 USE: strings
 USE: io
 USE: namespaces
@@ -36,7 +35,6 @@ USE: prettyprint
 USE: hashtables
 USE: sequences
 USE: http
-USE: unparser
 
 : <todo> ( user password -- <todo> )
   #! Create an empty todo list
@@ -151,7 +149,7 @@ USE: unparser
 : 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 ;
+  >r item-priority r> item-priority <=> ;
   
 : todo-items ( <todo> -- alist )
   #! Return a list of items for the given todo list.

contrib/crypto/common.factor

@@ -1,6 +1,6 @@
 IN: crypto-internals
 USING: kernel io strings sequences namespaces math prettyprint
-unparser test parser lists ;
+test parser lists ;
 
 
 : w+ ( int -- int )
@@ -29,14 +29,14 @@ unparser test parser lists ;
 : pad-string-md5 ( string  -- padded-string )
     [
         dup % HEX: 80 ,
-        dup length HEX: 3f bitand zero-pad-length 0 fill %
+        dup length HEX: 3f bitand zero-pad-length 0 <string> %
         dup length 3 shift 8 >le %
     ] "" make nip ;
 
 : pad-string-sha1 ( string  -- padded-string )
     [
         dup % HEX: 80 ,
-        dup length HEX: 3f bitand zero-pad-length 0 fill %
+        dup length HEX: 3f bitand zero-pad-length 0 <string> %
         dup length 3 shift 8 >be %
     ] "" make nip ;
 

contrib/crypto/load.factor

@@ -1,10 +1,14 @@
-IN: crypto
+IN: scratchpad
-USING: parser sequences words compiler ;
+USING: kernel parser sequences words compiler ;
-[
-    "contrib/crypto/common.factor"
-    "contrib/crypto/md5.factor"
-    "contrib/crypto/sha1.factor"
-] [ run-file ] each
 
-"crypto" words [ try-compile ] each
+"/contrib/math/load.factor" run-resource
 
+{
+    "common"
+    "random"
+    "miller-rabin"
+    "md5"
+    "sha1"
+    "rsa"
+    "rc4"
+} [ "/contrib/crypto/" swap ".factor" append3 run-resource ] each

contrib/crypto/md5.factor

@@ -1,6 +1,6 @@
 IN: crypto-internals
 USING: kernel io strings sequences namespaces math
-       unparser test parser lists crypto ;
+       test parser lists crypto ;
 
 SYMBOL: a
 SYMBOL: b

contrib/crypto/miller-rabin.factor

@@ -0,0 +1,61 @@
+USING: kernel math errors namespaces math-contrib sequences io ;
+USE: prettyprint
+USE: inspector
+IN: crypto
+
+SYMBOL: a
+SYMBOL: n
+SYMBOL: r
+SYMBOL: s
+SYMBOL: composite
+SYMBOL: count
+SYMBOL: trials
+
+: rand[1..n-1] ( n -- )
+    1- random-int 1+ ;
+
+: (factor-2s) ( s n -- s n )
+    dup 2 mod 0 = [ -1 shift >r 1+ r> (factor-2s) ] when ;
+
+: factor-2s ( n -- r s )
+    #! factor an even number into 2 ^ s * m
+    dup dup even? >r 0 > r> and [
+        "input must be positive and even" throw
+    ] unless 0 swap (factor-2s) ;
+
+: init-miller-rabin ( n -- )
+    0 composite set
+    [ n set ] keep 10000 < 20 100 ? trials set ;
+
+: miller-rabin ( n -- bool )
+    [
+        init-miller-rabin
+        n get even? [
+            f ] [
+            n get 1- factor-2s s set r set
+            trials get [
+                n get rand[1..n-1] a set
+                a get s get n get ^mod 1 = [
+                    0 count set
+                    r get [
+                        2 over ^ s get * a get swap n get ^mod n get - -1 = [
+                            count [ 1+ ] change
+                            r get +
+                        ] when
+                    ] repeat
+                    count get zero? [
+                        composite on
+                        trials get +
+                    ] when
+                ] unless
+            ] repeat
+            composite get 0 = [ t ] [ composite get not ] if
+        ] if
+    ] with-scope ;
+
+: next-miller-rabin-prime ( n -- p )
+    dup even? [ 1+ ] [ 2 + ] if
+    dup miller-rabin [ next-miller-rabin-prime ] unless ;
+
+
+! 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 100 miller-rabin

contrib/crypto/random.factor

@@ -0,0 +1,116 @@
+IN: crypto
+USING: kernel math sequences namespaces errors hashtables words arrays parser
+       compiler syntax lists io threads ;
+USE: prettyprint
+USE: inspector
+
+: add-bit ( bit integer -- integer )
+    1 shift bitor ;
+
+: append-bits ( inta intb nbits -- int )
+    swapd shift bitor ;
+
+! varying bit-length random number
+: random-bits ( n -- int )
+    random-int 2 swap ^ random-int ;
+
+: next-double ( -- f )
+    53 random-bits 9007199254740992 /f ;
+
+SYMBOL: last-keyboard
+: crypto-random-int ( numbits -- integer )
+    [ 
+        millis last-keyboard set
+        2 /  ! how many bits for repeat?
+        0 swap
+        [
+            readln 2drop 100 random-int sleep 
+            millis [ last-keyboard get - HEX: 3 bitand 2 append-bits ] keep
+            last-keyboard set
+        ] each
+    ] with-scope ;
+
+: auto-crypto-random-int ( numbits -- integer )
+    [ 
+        millis last-keyboard set
+        0 swap
+        [
+            drop 10 random-int sleep 
+            millis [ last-keyboard get - HEX: 1 bitand swap add-bit ] keep
+            last-keyboard set
+        ] each
+    ] with-scope ;
+
+IN: crypto-internals
+
+SYMBOL: q
+SYMBOL: m
+! : qm ( integer -- )
+    ! 1 swap - 2 mod dup 0 = [
+        ! 2 / 
+    ! ]
+    ! ;
+
+SYMBOL: test-count
+SYMBOL: num-tests
+! : (create-miller-rabin-prime) ( bitlength --  )
+    ! auto-crypto-random-int qm
+    
+IN: crypto
+
+! one in 2 ^ numtests chance of being composite (i believe)
+! : create-miller-rabin-prime ( bitlength numtests -- prime )
+    ! [
+        ! num-tests set
+        ! 0 test-count set
+        ! (create-miller-rabin-prime)
+        ! ! dup -1 = [ create-miller-rabin-prime ] when
+    ! ] with-scope ;
+
+! : numbits ( integer -- n )
+!    dup 0 = [ log2 1+ ] unless ;
+
+: 0count ( integer -- n )
+    0 swap [ 0 = [ 1+ ] when ] each-bit ;
+
+: 1count ( integer -- n )
+    0 swap [ 1 = [ 1+ ] when ] each-bit ;
+
+IN: crypto-internals
+SYMBOL: a
+SYMBOL: b
+SYMBOL: c
+SYMBOL: d
+SYMBOL: n
+
+
+IN: crypto
+
+: bit-reverse-table
+{
+    HEX: 00 HEX: 80 HEX: 40 HEX: C0 HEX: 20 HEX: A0 HEX: 60 HEX: E0 HEX: 10 HEX: 90 HEX: 50 HEX: D0 HEX: 30 HEX: B0 HEX: 70 HEX: F0 
+    HEX: 08 HEX: 88 HEX: 48 HEX: C8 HEX: 28 HEX: A8 HEX: 68 HEX: E8 HEX: 18 HEX: 98 HEX: 58 HEX: D8 HEX: 38 HEX: B8 HEX: 78 HEX: F8 
+    HEX: 04 HEX: 84 HEX: 44 HEX: C4 HEX: 24 HEX: A4 HEX: 64 HEX: E4 HEX: 14 HEX: 94 HEX: 54 HEX: D4 HEX: 34 HEX: B4 HEX: 74 HEX: F4 
+    HEX: 0C HEX: 8C HEX: 4C HEX: CC HEX: 2C HEX: AC HEX: 6C HEX: EC HEX: 1C HEX: 9C HEX: 5C HEX: DC HEX: 3C HEX: BC HEX: 7C HEX: FC 
+    HEX: 02 HEX: 82 HEX: 42 HEX: C2 HEX: 22 HEX: A2 HEX: 62 HEX: E2 HEX: 12 HEX: 92 HEX: 52 HEX: D2 HEX: 32 HEX: B2 HEX: 72 HEX: F2 
+    HEX: 0A HEX: 8A HEX: 4A HEX: CA HEX: 2A HEX: AA HEX: 6A HEX: EA HEX: 1A HEX: 9A HEX: 5A HEX: DA HEX: 3A HEX: BA HEX: 7A HEX: FA
+    HEX: 06 HEX: 86 HEX: 46 HEX: C6 HEX: 26 HEX: A6 HEX: 66 HEX: E6 HEX: 16 HEX: 96 HEX: 56 HEX: D6 HEX: 36 HEX: B6 HEX: 76 HEX: F6 
+    HEX: 0E HEX: 8E HEX: 4E HEX: CE HEX: 2E HEX: AE HEX: 6E HEX: EE HEX: 1E HEX: 9E HEX: 5E HEX: DE HEX: 3E HEX: BE HEX: 7E HEX: FE
+    HEX: 01 HEX: 81 HEX: 41 HEX: C1 HEX: 21 HEX: A1 HEX: 61 HEX: E1 HEX: 11 HEX: 91 HEX: 51 HEX: D1 HEX: 31 HEX: B1 HEX: 71 HEX: F1
+    HEX: 09 HEX: 89 HEX: 49 HEX: C9 HEX: 29 HEX: A9 HEX: 69 HEX: E9 HEX: 19 HEX: 99 HEX: 59 HEX: D9 HEX: 39 HEX: B9 HEX: 79 HEX: F9 
+    HEX: 05 HEX: 85 HEX: 45 HEX: C5 HEX: 25 HEX: A5 HEX: 65 HEX: E5 HEX: 15 HEX: 95 HEX: 55 HEX: D5 HEX: 35 HEX: B5 HEX: 75 HEX: F5
+    HEX: 0D HEX: 8D HEX: 4D HEX: CD HEX: 2D HEX: AD HEX: 6D HEX: ED HEX: 1D HEX: 9D HEX: 5D HEX: DD HEX: 3D HEX: BD HEX: 7D HEX: FD
+    HEX: 03 HEX: 83 HEX: 43 HEX: C3 HEX: 23 HEX: A3 HEX: 63 HEX: E3 HEX: 13 HEX: 93 HEX: 53 HEX: D3 HEX: 33 HEX: B3 HEX: 73 HEX: F3 
+    HEX: 0B HEX: 8B HEX: 4B HEX: CB HEX: 2B HEX: AB HEX: 6B HEX: EB HEX: 1B HEX: 9B HEX: 5B HEX: DB HEX: 3B HEX: BB HEX: 7B HEX: FB
+    HEX: 07 HEX: 87 HEX: 47 HEX: C7 HEX: 27 HEX: A7 HEX: 67 HEX: E7 HEX: 17 HEX: 97 HEX: 57 HEX: D7 HEX: 37 HEX: B7 HEX: 77 HEX: F7 
+    HEX: 0F HEX: 8F HEX: 4F HEX: CF HEX: 2F HEX: AF HEX: 6F HEX: EF HEX: 1F HEX: 9F HEX: 5F HEX: DF HEX: 3F HEX: BF HEX: 7F HEX: FF
+} ; inline
+
+! : each-byte
+
+: modular-exp ( a b n -- d )
+    n set b set a set 0 c set 1 d set
+    [
+        [ ] each-bit
+    ] with-scope ;
+

contrib/crypto/rc4.factor

@@ -0,0 +1,43 @@
+USING: kernel math sequences namespaces math-contrib ;
+IN: crypto-internals
+
+! http://en.wikipedia.org/wiki/RC4_%28cipher%29
+
+SYMBOL: i
+SYMBOL: j
+SYMBOL: s
+SYMBOL: key
+SYMBOL: l
+
+
+: swap-ij ( i j seq -- )
+    [
+        s set j set i set
+        i get s get nth j get s get nth i get s get set-nth j get s get set-nth
+    ] with-scope ;
+
+! key scheduling algorithm, initialize s
+: ksa ( -- )
+    256 [ ] map s set
+    0 j set
+    256 [
+        dup s get nth j get + over l get mod key get nth + 255 bitand j set
+        dup j get s get swap-ij
+    ] repeat ;
+
+: generate ( -- n )
+    i get 1+ 255 bitand i set
+    j get i get s get nth + 255 bitand j set
+    i get j get s get swap-ij
+    i get s get nth j get s get nth + 255 bitand s get nth ;
+
+IN: crypto
+
+
+: rc4 ( key -- )
+    [ key set ] keep
+    length l set
+    ksa
+    0 i set
+    0 j set ;
+

contrib/crypto/rsa.factor

@@ -0,0 +1,30 @@
+USING: kernel math namespaces math-contrib ;
+
+IN: crypto
+SYMBOL: d
+SYMBOL: p
+SYMBOL: q
+SYMBOL: n
+SYMBOL: m
+SYMBOL: ee
+
+: while-gcd ( -- )
+    m get ee get gcd nip 1 > [ ee [ 2 + ] change while-gcd ] when ;
+
+! n bits
+: generate-key-pair ( bitlen -- )
+    2 swap 1- 2 /i shift
+    [ random-int next-miller-rabin-prime p set ] keep
+    random-int next-miller-rabin-prime q set
+
+    p get q get * n set
+    p get 1- q get 1- * m set
+    3 ee set
+    while-gcd
+    m get ee get mod-inv m get + d set ;
+
+: rsa-encrypt ( message -- encrypted )
+    ee get n get ^mod ;
+
+: rsa-decrypt ( encrypted -- message )
+    d get n get ^mod ;

contrib/crypto/sha1.factor

@@ -1,6 +1,6 @@
 IN: crypto-internals
 USING: kernel io strings sequences namespaces math prettyprint
-unparser test parser lists vectors hashtables kernel-internals crypto ;
+test parser lists vectors hashtables kernel-internals math-contrib crypto ;
 
 ! Implemented according to RFC 3174.
 
@@ -55,10 +55,10 @@ SYMBOL: K
 ! use this syntax eventually
 ! JUMP-TABLE: f 4 ( maximum )
 ! H{
-    ! [[ 0 [ >r over bitnot r> bitand >r bitand r> bitor ] ]]
+    ! { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
-    ! [[ 1 [ bitxor bitxor ] ]]
+    ! { 1 [ bitxor bitxor ] }
-    ! [[ 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] ]]
+    ! { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
-    ! [[ 3 [ bitxor bitxor ] ]]
+    ! { 3 [ bitxor bitxor ] }
 ! } f-table set
 
 ! J: 0 f >r over bitnot r> bitand >r bitand r> bitor ;

contrib/factory/factory.factor

@@ -0,0 +1,566 @@
+
+IN: factory
+
+USING: kernel namespaces generic math sequences hashtables io arrays words
+       prettyprint lists concurrency
+       xlib x concurrent-widgets simple-error-handler ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: workspace-menu
+DEFER: wm-frame?
+DEFER: manage-window
+DEFER: window-list
+DEFER: refresh-window-list
+DEFER: layout-frame
+DEFER: mapped-windows
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: popup-window ( -- ) mouse-sensor move-window raise-window map-window ;
+
+: popup-window% [ popup-window ] with-window-object ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: root-menu
+
+: setup-root-menu ( -- )
+  create-menu root-menu set
+  "black" lookup-color root-menu get set-window-background%
+  "xterm"  [ "launch program..." print ] root-menu get add-popup-menu-item
+  "xlogo"  [ "launch program..." print ] root-menu get add-popup-menu-item
+  "xclock" [ "launch program..." print ] root-menu get add-popup-menu-item
+  "xload"  [ "launch program..." print ] root-menu get add-popup-menu-item
+  "emacs"  [ "launch program..." print ] root-menu get add-popup-menu-item
+  "Workspaces"
+    [ workspace-menu get popup-window% ] root-menu get add-popup-menu-item ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: MouseMask
+  [ ButtonPressMask
+    ButtonReleaseMask
+    PointerMotionMask ] 0 [ execute bitor ] reduce ;
+
+: drag-mouse-loop ( position -- )
+  MouseMask mask-event XAnyEvent-type			! position type
+  { { [ dup MotionNotify = ]
+      [ drop drag-mouse-loop ] }
+    { [ dup ButtonRelease = ]
+      [ drop						! position
+        mouse-sensor					! push release
+        ungrab-server
+        CurrentTime ungrab-pointer
+        flush-dpy ] }
+    { [ t ] [ drop "drag-mouse-loop ignoring event" print drag-mouse-loop ] } }
+  cond ;
+
+: drag-mouse ( -- )
+  MouseMask grab-pointer grab-server mouse-sensor drag-mouse-loop ;
+
+: drag-mouse% [ drag-mouse ] with-window-object ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: drag-move-window ( -- ) drag-mouse swap v- window-position v+ move-window ;
+
+: drag-move-window% [ drag-move-window ] with-window-object ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: drag-resize-window ( -- ) drag-mouse nip window-position v- resize-window ;
+
+: drag-resize-window% [ drag-resize-window ] with-window-object ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: move-request-x
+GENERIC: move-request-y
+GENERIC: move-request-position
+GENERIC: execute-move-request
+GENERIC: size-request-width
+GENERIC: size-request-height
+GENERIC: size-request-size
+GENERIC: execute-size-request
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! wm-root
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: wm-root ;
+
+: create-wm-root ( window -- )
+  >r dpy get r> <window>			! <window>
+  <wm-root>					! <window> <wm-root>
+  [ set-delegate ] keep				! <wm-root>
+  [ add-to-window-table ] keep			! <wm-root>
+
+  [ SubstructureRedirectMask
+    SubstructureNotifyMask
+    ButtonPressMask
+    ButtonReleaseMask
+    KeyPressMask
+    KeyReleaseMask ] 0 [ execute bitor ] reduce	! <wm-frame> mask
+
+  over select-input% ;				! <wm-frame>
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! M: wm-root handle-map-request-event
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: id>obj ( id -- obj )
+  dup			! id id
+  window-table get hash	! id obj-or-f
+  dup
+  [ swap drop ]
+  [ drop >r dpy get r> <window> ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-root handle-map-request-event ( event <wm-root> -- )
+  drop XMapRequestEvent-window id>obj				! obj
+
+  { { [ dup wm-frame? ]
+      [ map-window% ] }
+
+    { [ dup valid-window?% not ]
+      [ "Not a valid window." print drop ] }
+
+    { [ dup window-override-redirect% 1 = ]
+      [ "Not reparenting: " print
+        "new window has override_redirect attribute set." print
+        drop ] }
+
+    { [ t ] [ window-id manage-window ] } }
+
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Words for working with an XConfigureRequestEvent
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bit-test ( a b -- t-or-f ) bitand 0 = not ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-request-x? ( event -- ) XConfigureRequestEvent-value_mask CWX bit-test ;
+: move-request-y? ( event -- ) XConfigureRequestEvent-value_mask CWY bit-test ;
+
+: move-request? ( event -- ? ) dup move-request-x? swap move-request-y? or ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: size-request-width? ( event -- )
+  XConfigureRequestEvent-value_mask CWWidth bit-test ;
+
+: size-request-height? ( event -- )
+  XConfigureRequestEvent-value_mask CWHeight bit-test ;
+
+: size-request? ( event -- )
+  dup size-request-width? swap size-request-height? or ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! M: wm-root handle-configure-request-event
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-root move-request-x ( event wm-root -- x )
+  drop
+  dup move-request-x?
+  [ XConfigureRequestEvent-x ]
+  [ XConfigureRequestEvent-window [ window-x ] with-win ]
+  if ;
+
+M: wm-root move-request-y ( event wm-root -- y )
+  drop
+  dup move-request-y?
+  [ XConfigureRequestEvent-y ]
+  [ XConfigureRequestEvent-window [ window-y ] with-win ]
+  if ;
+
+M: wm-root move-request-position ( event wm-root -- { x y } )
+  2dup move-request-x -rot move-request-y 2array ;
+
+M: wm-root execute-move-request ( event wm-root -- )
+  dupd move-request-position swap XConfigureRequestEvent-window move-window+ ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-root size-request-width ( event wm-root -- width )
+  drop
+  dup size-request-width?
+  [ XConfigureRequestEvent-width ]
+  [ XConfigureRequestEvent-window [ window-width ] with-win ]
+  if ;
+
+M: wm-root size-request-height ( event wm-root -- height )
+  drop 
+  dup size-request-height?
+  [ XConfigureRequestEvent-height ]
+  [ XConfigureRequestEvent-window [ window-height ] with-win ]
+  if ;
+
+M: wm-root size-request-size ( event wm-root -- { width height } )
+  2dup size-request-width -rot size-request-height 2array ;
+
+M: wm-root execute-size-request ( event wm-root -- )
+  dupd size-request-size swap XConfigureRequestEvent-window resize-window+ ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-root handle-configure-request-event ( event wm-root -- )
+  over move-request? [ 2dup execute-move-request ] when
+  over size-request? [ 2dup execute-size-request ] when
+  drop drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! M: wm-root handle-button-press-event
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-root handle-button-press-event ( event wm-root -- )
+  drop						! event
+
+  { { [ dup XButtonEvent-button Button1 = ]
+      [ root-menu get window-map-state% IsUnmapped =
+        [ XButtonEvent-root-position root-menu get move-window%
+          root-menu get raise-window%
+          root-menu get map-window% ]
+        [ root-menu get unmap-window% ]
+        if ] }
+
+    { [ dup XButtonEvent-button Button2 = ]
+      [ window-list get window-map-state% IsUnmapped =
+        [ XButtonEvent-root-position window-list get move-window%
+          window-list get raise-window%
+          window-list get refresh-window-list
+          window-list get map-window% ]
+        [ window-list get unmap-window% ]
+        if ] } }
+
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! M: wm-root handle-key-press-event
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! M: wm-root handle-key-press-event ( event wm-root -- )
+!   drop
+!   { { [ dup XKeyEvent-keycode 67 = ]
+!       [ workspace-1 get switch-to-workspace ] }
+!     { [ dup XKeyEvent-keycode 68 = ]
+!       [ workspace-2 get switch-to-workspace ] }
+!     { [ dup XKeyEvent-keycode 69 = ]
+!       [ workspace-3 get switch-to-workspace ] }
+!     { [ dup XKeyEvent-keycode 70 = ]
+!       [ workspace-4 get switch-to-workspace ] } }
+!   cond ;
+
+M: wm-root handle-key-press-event ( event wm-root -- )
+  drop
+  { { [ dup XKeyEvent-keycode 67 = ]
+      [ "Switch to workspace 1" print drop ] }
+    { [ dup XKeyEvent-keycode 68 = ]
+      [ "Switch to workspace 2" print drop ] }
+    { [ dup XKeyEvent-keycode 69 = ]
+      [ "Switch to workspace 3" print drop ] }
+    { [ dup XKeyEvent-keycode 70 = ]
+      [ "Switch to workspace 4" print drop ] }
+    { [ t ]
+      [ "wm-root ignoring key press" print drop ] } }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: wm-child ;
+
+: create-wm-child ( id -- <wm-child> )
+  >r dpy get r> <window> <wm-child>		! <window> <wm-child>
+  [ set-delegate ] keep
+  [ add-to-window-table ] keep ;
+
+M: wm-child handle-property-event ( child event -- )
+  "A <wm-child> received a property event" print drop drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: wm-frame child ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: create-wm-frame ( child -- <wm-frame> )
+  >r create-window-object r>			! <window> child
+  <wm-frame>					! <window> <wm-frame>
+  [ set-delegate ] keep				! <wm-frame>
+  [ add-to-window-table ] keep			! <wm-frame>
+  
+  [ SubstructureRedirectMask
+    SubstructureNotifyMask
+    ExposureMask
+    ButtonPressMask
+    ButtonReleaseMask
+    EnterWindowMask ] 0 [ execute bitor ] reduce	! <wm-frame> mask
+
+  over select-input% ;				! <wm-frame>
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: manage-window ( window -- )
+  grab-server
+
+  create-wm-child				! child
+  create-wm-frame				! frame
+
+  dup "cornflowerblue" lookup-color swap set-window-background%
+
+  dup wm-frame-child add-to-save-set%		! frame
+
+  dup wm-frame-child window-position%		! frame position
+  over						! frame position frame
+  move-window%
+  
+  dup wm-frame-child 0 swap set-window-border-width%
+  dup dup wm-frame-child			! frame frame child
+  reparent-window%
+
+  dup wm-frame-child window-size%		! frame child-size
+  { 20 20 } v+					! frame child-size+
+  over						! frame child-size+ frame
+  resize-window%
+
+  dup wm-frame-child { 10 10 } swap move-window%
+
+  dup map-window%
+  dup map-subwindows%
+
+  dup wm-frame-child PropertyChangeMask swap select-input%
+  
+  flush-dpy 0 sync-dpy ungrab-server ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: destroy-window-event-match? ( event <wm-frame> -- ? )
+  window-id swap XDestroyWindowEvent-window = ;
+
+M: wm-frame handle-destroy-window-event ( event <wm-frame> -- )
+  2dup destroy-window-event-match?
+  [ destroy-window% drop ] [ drop drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: map-request-event-match? ( event <wm-frame> -- ? )
+  window-id swap XMapRequestEvent-window = ;
+
+M: wm-frame handle-map-request-event ( event <wm-frame> -- )
+  2dup map-request-event-match?				! event frame ?
+  [ dup wm-frame-child map-window% map-window% drop ] [ drop drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: map-event-match? ( event <wm-frame> -- ? )
+  window-id swap XMapEvent-window = ;
+
+M: wm-frame handle-map-event ( event <wm-frame> -- )
+  2dup map-event-match?
+  [ dup map-window% raise-window% drop ] [ drop drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! M: wm-frame handle-configure-request-event ( event frame )
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-frame move-request-x ( event frame -- x )
+  over move-request-x?
+  [ drop XConfigureRequestEvent-x ]
+  [ nip window-x% ]
+  if ;
+
+M: wm-frame move-request-y ( event frame -- y )
+  over move-request-y?
+  [ drop XConfigureRequestEvent-y ]
+  [ nip window-y% ]
+  if ;
+
+M: wm-frame move-request-position ( event frame -- { x y } )
+  2dup move-request-x -rot move-request-y 2array ;
+
+M: wm-frame execute-move-request ( event frame )
+  dup -rot move-request-position swap move-window% ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-frame size-request-width ( event frame -- width )
+  over size-request-width?
+  [ drop XConfigureRequestEvent-width ]
+  [ nip wm-frame-child window-width% ]
+  if ;
+
+M: wm-frame size-request-height ( event frame -- height )
+  over size-request-height?
+  [ drop XConfigureRequestEvent-height ]
+  [ nip wm-frame-child window-height% ]
+  if ;
+
+M: wm-frame size-request-size ( event frame -- size )
+  2dup size-request-width -rot size-request-height 2array ;
+
+: execute-size-request/child ( event frame )
+  dup wm-frame-child -rot size-request-size swap resize-window% ;
+
+: execute-size-request/frame ( event frame )
+  dup -rot size-request-size { 20 20 } v+ swap resize-window% ;
+
+M: wm-frame execute-size-request ( event frame )
+  2dup execute-size-request/child execute-size-request/frame ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-frame handle-configure-request-event ( event frame )
+  over move-request? [ 2dup execute-move-request ] when
+  over size-request? [ 2dup execute-size-request ] when
+  drop drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: unmap-event-match? ( event frame -- ? )
+  wm-frame-child window-id swap XUnmapEvent-window = ;
+
+M: wm-frame handle-unmap-event ( event frame )
+  2dup unmap-event-match? [ unmap-window% drop ] [ drop drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: drag-move-frame ( frame -- ) drag-move-window% ;
+
+: drag-resize-frame ( frame -- ) dup drag-resize-window% layout-frame ;
+
+M: wm-frame handle-button-press-event ( event frame )
+  over XButtonEvent-button				! event frame button
+  { { [ dup Button1 = ] [ drop nip drag-move-frame ] }
+    { [ dup Button2 = ] [ drop nip drag-resize-frame ] }
+    { [ dup Button3 = ] [ drop nip unmap-window% ] }
+    { [ t ] [ drop drop drop ] } }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-frame handle-enter-window-event ( event frame )
+  nip dup wm-frame-child valid-window?%
+  [ wm-frame-child >r RevertToPointerRoot CurrentTime r> set-input-focus% ]
+  [ destroy-window% ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: wm-frame handle-property-event ( event frame )
+  "Inside handle-property-event" print drop drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: layout-frame ( frame -- )
+  dup wm-frame-child { 10 10 } swap move-window%
+  dup wm-frame-child				! frame child
+  over window-size%				! frame child size
+  { 20 20 } v-					! frame child child-size
+  swap resize-window%				! frame
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Workspaces
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: switch-to
+
+SYMBOL: current-workspace
+
+TUPLE: workspace windows ;
+
+: create-workspace [ ] <workspace> ;
+
+M: workspace switch-to ( workspace -- )
+  mapped-windows dup current-workspace get set-workspace-windows
+  [ unmap-window+ ] each
+  dup workspace-windows [ map-window+ ] each
+  current-workspace set ;
+
+SYMBOL: workspace-1
+SYMBOL: workspace-2
+SYMBOL: workspace-3
+SYMBOL: workspace-4
+
+create-workspace workspace-1 set
+create-workspace workspace-2 set
+create-workspace workspace-3 set
+create-workspace workspace-4 set
+
+workspace-1 get current-workspace set
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: workspace-menu
+
+: setup-workspace-menu ( -- )
+  create-menu workspace-menu set
+  "black" lookup-color workspace-menu get set-window-background%
+  "Workspace 1"
+    [ workspace-1 get switch-to ] workspace-menu get add-popup-menu-item
+  "Workspace 2"
+    [ workspace-2 get switch-to ] workspace-menu get add-popup-menu-item
+  "Workspace 3"
+    [ workspace-3 get switch-to ] workspace-menu get add-popup-menu-item
+  "Workspace 4"
+    [ workspace-4 get switch-to ] workspace-menu get add-popup-menu-item ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! window-list
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: window-list
+
+: setup-window-list ( -- )
+  create-menu window-list set
+  "black" lookup-color window-list get set-window-background% ;
+
+: not-transient? ( frame -- ? ) wm-frame-child get-transient-for-hint% not ;
+
+: add-window-to-list ( window-list frame -- window-list )
+  dup					! window-list frame frame
+  wm-frame-child			! window-list frame child
+  fetch-name%				! window-list frame name-or-f
+  dup					! window-list frame name-or-f name-or-f
+  [ ] [ drop "*untitled*" ] if	! window-list frame name
+  swap					! window-list name frame
+  [ map-window% ]			! window-list name frame [ map-window% ]
+  cons					! window-list name action
+  pick					! window-list name action window-list
+  add-popup-menu-item ;
+
+: refresh-window-list ( window-list -- )
+  dup window-children% [ destroy-window+ ] each
+  ! clean-window-table
+  window-table get hash-values [ wm-frame? ] subset
+  [ not-transient? ] subset
+  [ add-window-to-list ] each
+  drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: window-is-mapped? ( window -- ? ) window-map-state+ IsUnmapped = not ;
+
+: mapped-windows ( -- [ a b c d ... ] )
+  root get window-children+ [ window-is-mapped? ] subset ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: manage-existing-windows ( -- ) mapped-windows [ manage-window ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start-factory ( dpy-string -- )
+  initialize-x
+  SetSimpleErrorHandler
+  root get create-wm-root
+  setup-root-menu
+  setup-window-list
+  setup-workspace-menu
+  manage-existing-windows
+  [ concurrent-event-loop ] spawn ;

contrib/factory/make-simple-error-handler

@@ -0,0 +1,3 @@
+gcc -c simple-error-handler.c
+gcc -L /usr/X11R6/lib -shared -o simple-error-handler.so \
+  simple-error-handler.o -lX11

contrib/factory/simple-error-handler.c

@@ -0,0 +1,13 @@
+#include <stdio.h>
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+
+int SimpleErrorHandler ( Display* dpy, XErrorEvent* event ) {
+  char msg[255];
+  printf ( "X11 : SimpleErrorHandler called!!!\n\n" ) ;
+  XGetErrorText ( dpy, event->error_code, msg, sizeof msg ) ;
+  printf ( "X error (%#lx): %s", event->resourceid, msg ) ;
+  return 0 ;
+}
+
+void SetSimpleErrorHandler() { XSetErrorHandler( SimpleErrorHandler ) ; }

contrib/factory/simple-error-handler.factor

@@ -0,0 +1,6 @@
+IN: simple-error-handler
+USING: compiler alien xlib ;
+LIBRARY: simple-error-handler
+"simple-error-handler" "simple-error-handler.so" "cdecl" add-library
+FUNCTION: void SetSimpleErrorHandler (  ) ;
+\ SetSimpleErrorHandler compile

contrib/httpd/browser-responder.factor

@@ -4,11 +4,11 @@
 ! 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.
+!        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
+!        this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
+!        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
@@ -25,95 +25,67 @@
 ! cont-responder facilities.
 !
 IN: browser-responder
-USING: html cont-responder kernel io namespaces words lists prettyprint 
+USING: cont-responder hashtables help html io kernel lists
-       memory sequences ;
+memory namespaces prettyprint sequences words xml ;
 
 : option ( current text -- )
-  #! Output the HTML option tag for the given text. If
+    #! Output the HTML option tag for the given text. If
-  #! it is equal to the current string, make the option selected.
+    #! it is equal to the current string, make the option selected.
-  2dup = [
+    2dup = [
-    "<option selected>" write
+        "<option selected>" write
-  ] [
+    ] [
-    "<option>" write
+        "<option>" write
-  ] if      
+    ] if            
-  chars>entities write 
+    chars>entities write 
-  "</option>\n" write drop ;
+    "</option>\n" write drop ;
 
 : vocab-list ( vocab -- )
-  #! Write out the HTML for the list of vocabularies. Make the currently 
+    #! Write out the HTML for the list of vocabularies. Make the currently 
-  #! selected vocab be 'vocab'.
+    #! selected vocab be 'vocab'.
-  <select "vocab" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select> 
+    <select "vocab" =name "width: 200px; " =style "20" =size "document.forms.main.submit()" =onchange select> 
-    vocabs [ over swap option ] each drop
+        vocabs [ over swap option ] each drop
-  </select> ;
+    </select> ;
 
 : word-list ( vocab word -- )
-  #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item
+    #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item
-  #! the currently selected option.
+    #! the currently selected option.
-  <select "word" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select> 
+    <select "word" =name "width: 200px; " =style "20" =size "document.forms.main.submit()" =onchange select> 
-    swap words word-sort [ word-name over swap option ] each drop
+        swap words natural-sort
-  </select> ;
+        [ word-name over swap option ] each drop
+    </select> ;
 
 : word-source ( vocab word -- )
-  #! Write the source for the given word from the vocab as HTML.
+    #! Write the source for the given word from the vocab as HTML.
-  swap lookup [
+    swap lookup [ [ (help) ] with-html-stream ] when* ;
-    [ see ] with-simple-html-output
-  ] when* ;
-
-: vm-statistics ( -- )
-  #! Display statistics about the vm.
-  <pre> room. </pre> ;
 
 : browser-body ( vocab word -- )
-  #! Write out the HTML for the body of the main browser page.
+    #! Write out the HTML for the body of the main browser page.
-  <table "100%" =width table> 
+    <table "100%" =width table> 
-    <tr>  
+        <tr>
-      <td> <b> "Vocabularies" write </b> </td>
+            <th> "Vocabularies" write </th>
-      <td> <b> "Words" write </b> </td>
+            <th> "Words" write </th>
-      <td> <b> "Source" write </b> </td>
+            <th> "Documentation" write </th>
-    </tr>
+        </tr>
-    <tr>  
+        <tr>    
-      <td "top" =valign "width: 200" =style td> over vocab-list </td> 
+            <td "top" =valign "width: 200px;" =style td> over vocab-list </td> 
-      <td "top" =valign "width: 200" =style td> 2dup word-list </td> 
+            <td "top" =valign "width: 200px;" =style td> 2dup word-list </td> 
-      <td "top" =valign td> word-source </td> 
+            <td "top" =valign td> word-source </td> 
-    </tr>
+        </tr>
-  </table>
+    </table> ;
-  vm-statistics ;
 
 : browser-title ( vocab word -- )
-  #! Output the HTML title for the browser.
+    #! Output the HTML title for the browser.
-  <title> 
+    [ "Factor Browser - " % swap % " - " % % ] "" make ;
-    "Factor Browser - " write 
-    swap write
-    " - " write
-    write
-  </title> ;
-
-: browser-style ( -- )
-  #! Stylesheet for browser pages
-  <style>
-    "A:link { text-decoration:none}\n" write
-    "A:visited { text-decoration:none}\n" write
-    "A:active { text-decoration:none}\n" write
-    "A:hover, A.nav:hover { border: 1px solid black; text-decoration: none; margin: 0px }\n" write
-    "A { margin: 1px }" write
-  </style> ;
 
 : browse ( vocab word -- )
-  #! Display a Smalltalk like browser for exploring words.
+    #! Display a Smalltalk like browser for exploring words.
-  [
+    [
-    <html> 
+        2dup browser-title [
-      <head> 2dup browser-title browser-style </head>
+            <form "main" =name "" =action "get" =method form> browser-body </form>
-      <body> 
+        ] html-document
-        <form "main" =name "" =action "get" =method form> browser-body </form>
+    ] show-final ;
-      </body>
-    </html> 
-  ] show-final ;
 
 : browser-responder ( -- )
-  #! Start the Smalltalk-like browser.
+    #! Start the Smalltalk-like browser.
-  "query" get [     
+    "vocab" "query" get hash [ "browser-responder" ] unless*
-     [ "vocab" swap assoc ] keep
+    "word" "query" get hash [ "browse" ] unless* browse ;
-     "word" swap assoc
-  ] [
-    "browser-responder" "browse" 
-  ] if* browse ;

contrib/httpd/cont-responder.factor

@@ -21,7 +21,7 @@
 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 IN: cont-responder
-USING: http httpd math random namespaces io
+USING: http httpd math namespaces io
        lists strings kernel html hashtables
        parser generic sequences ;
 
@@ -40,8 +40,7 @@ SYMBOL: post-refresh-get?
 
 : get-random-id ( -- id ) 
   #! Generate a random id to use for continuation URL's
-  [ 32 [ 9 random-int CHAR: 0 + , ] times ] "" make
+  [ "ID" % 32 [ 9 random-int CHAR: 0 + , ] times ] "" make ;
-  string>number 36 >base ;
 
 SYMBOL: table
 
@@ -51,7 +50,7 @@ SYMBOL: table
     
 : reset-continuation-table ( -- ) 
   #! Create the initial global table
-  continuation-table hash-clear ;
+  continuation-table clear-hash ;
 
 H{ } clone table global set-hash
 
@@ -81,7 +80,7 @@ TUPLE: item expire? quot id time-added ;
   #! if they are 'timeout-seconds' old (ie. were added
   #! more than 'timeout-seconds' ago.
   continuation-table clone [ ( timeout-seconds [[ id item ]] -- )
-    uncons swapd expired? [
+    swapd expired? [
       continuation-table remove-hash
     ] [
       drop
@@ -274,7 +273,7 @@ SYMBOL: root-continuation
 : id-or-root ( -- id )
   #! Return the continuation id for the current requested continuation
   #! or the root continuation if no id is supplied.
-  "id" "query" get assoc [ root-continuation get ] unless* ;
+  "id" "query" get hash [ root-continuation get ] unless* ;
 
 : cont-get/post-responder ( id-or-f -- ) 
   #! httpd responder that retrieves a continuation and calls it.
@@ -283,7 +282,7 @@ SYMBOL: root-continuation
   #! no root continuation exists the expired continuation handler
   #! should be called.
   drop [
-    "response" get alist>hash 
+    "response" get 
      id-or-root [
       resume-continuation
     ] [
@@ -296,14 +295,17 @@ SYMBOL: root-continuation
   #! by returning a quotation that will pass the original 
   #! quotation to the callback continuation.
   [ , callback-cc get , \ continue-with , ] [ ] make ;
-  
+
+: quot-url ( quot -- url )
+  callback-quot expirable register-continuation id>url ;
+
 : quot-href ( text quot -- )
   #! Write to standard output an HTML HREF where the href,
   #! when referenced, will call the quotation and then return
   #! back to the most recent 'show' call (via the callback-cc).
   #! The text of the link will be the 'text' argument on the 
   #! stack.
-  <a callback-quot expirable register-continuation id>url =href a> write </a> ;
+  <a quot-url =href a> write </a> ;
 
 : init-session-namespace ( -- )
   #! Setup the initial session namespace. Currently this only
@@ -376,13 +378,3 @@ SYMBOL: root-continuation
 : button ( label -- )
   #! Output an HTML submit button with the given label.
   <input "submit" =type =value input/> ;
-
-: with-simple-html-output ( quot -- )
-  #! Run the quotation inside an HTML stream wrapped
-  #! around stdio.
-  <pre> 
-    stdio get <html-stream> [
-      call
-    ] with-stream
-  </pre> ;
-

contrib/httpd/default-responders.factor

@@ -1,9 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: httpd
-USING: browser-responder cont-responder file-responder kernel
+USING: io browser-responder cont-responder file-responder
-namespaces prettyprint quit-responder resource-responder
+help-responder inspect-responder kernel namespaces prettyprint ;
-test-responder ;
 
 #! Remove all existing responders, and create a blank
 #! responder table.
@@ -15,6 +14,21 @@ global [
         "404" "responder" set
         [ drop no-such-responder ] "get" set
     ] make-responder
+
+    ! Online help browsing
+    "help" [ help-responder ] install-cont-responder
+
+    ! Javascript source used by ajax libraries
+    [ 
+      "contrib/httpd/javascript/" resource-path "doc-root" set
+      "javascript" "responder" set
+      [ file-responder ] "get" set
+      [ file-responder ] "post" set
+      [ file-responder ] "head" set
+    ] make-responder
+
+    ! Global variables
+    "inspector" [ inspect-responder ] install-cont-responder
     
     ! Servers Factor word definitions from the image.
     "browser" [ browser-responder ] install-cont-responder

contrib/httpd/file-responder.factor

@@ -9,9 +9,9 @@ io strings ;
 
 : file-response ( mime-type length -- )
     [
-        number>string "Content-Length" swons ,
+        number>string "Content-Length" set
-        "Content-Type" swons ,
+        "Content-Type" set
-    ] [ ] make "200 OK" response terpri ;
+    ] make-hash "200 OK" response terpri ;
 
 : serve-static ( filename mime-type -- )
     over file-length file-response  "method" get "head" = [

contrib/httpd/help-responder.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: help-responder
+USING: cont-responder hashtables help html kernel namespaces
+sequences ;
+
+: help-responder ( filename -- )
+    [
+        "topic" "query" get hash
+        dup empty? [ drop "handbook" ] when
+        dup article-title
+        [ [ (help) ] with-html-stream ] html-document
+    ] show-final ;

contrib/httpd/html-tags.factor

@@ -24,7 +24,7 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: html
-USING: prettyprint ;
+USE: prettyprint
 USE: strings
 USE: lists
 USE: kernel
@@ -72,6 +72,11 @@ USE: sequences
 !
 ! <input "text" =type "name" =name "20" =size input/>
 
+SYMBOL: html
+SYMBOL: attrs
+
+: write-html H{ { html t } } format ;
+
 : attrs>string ( alist -- string )
     #! Convert the attrs alist to a string
     #! suitable for embedding in an html tag.
@@ -81,7 +86,7 @@ USE: sequences
     #! With the attribute namespace on the stack, get the attributes
     #! and write them to standard output. If no attributes exist, write
     #! nothing.
-    "attrs" get attrs>string write ;
+    attrs get attrs>string write-html ;
 
 : html-word ( name def -- )
     #! Define 'word creating' word to allow
@@ -90,7 +95,7 @@ USE: sequences
  
 : <foo> "<" swap ">" append3 ;
 
-: do-<foo> <foo> write ;
+: do-<foo> <foo> write-html ;
 
 : def-for-html-word-<foo> ( name -- )
     #! Return the name and code for the <foo> patterned
@@ -99,7 +104,7 @@ USE: sequences
 
 : <foo "<" swap append ;
 
-: do-<foo write H{ } clone >n V{ } clone "attrs" set ;
+: do-<foo write-html H{ } clone >n V{ } clone attrs set ;
 
 : def-for-html-word-<foo ( name -- )
     #! Return the name and code for the <foo patterned
@@ -108,7 +113,9 @@ USE: sequences
 
 : foo> ">" append ;
 
-: do-foo> write-attributes n> drop ">" write ;
+: do-foo> write-attributes n> drop ">" write-html ;
+
+: do-foo/> write-attributes n> drop "/>" write-html ;
 
 : def-for-html-word-foo> ( name -- )
     #! Return the name and code for the foo> patterned
@@ -120,21 +127,23 @@ USE: sequences
 : def-for-html-word-</foo> ( name -- )
     #! Return the name and code for the </foo> patterned
     #! word.    
-    </foo> dup [ write ] cons html-word define-close ;
+    </foo> dup [ write-html ] cons html-word define-close ;
 
 : <foo/> [ "<" % % "/>" % ] "" make ;
 
+: do-<foo/> <foo/> write-html ;
+
 : def-for-html-word-<foo/> ( name -- )
     #! Return the name and code for the <foo/> patterned
     #! word.
-    dup <foo/> swap [ do-<foo> ] cons html-word drop ;
+    dup <foo/> swap [ do-<foo/> ] cons html-word drop ;
 
 : foo/> "/>" append ;
 
 : def-for-html-word-foo/> ( name -- )
     #! Return the name and code for the foo/> patterned
     #! word.    
-    foo/> [ do-foo> ] html-word define-close ;
+    foo/> [ do-foo/> ] html-word define-close ;
 
 : define-closed-html-word ( name -- ) 
     #! Given an HTML tag name, define the words for
@@ -153,7 +162,7 @@ USE: sequences
 
 : define-attribute-word ( name -- )
     dup "=" swap append swap [
-        , [ swons "attrs" get push ] %
+        , [ swons attrs get push ] %
     ] [ ] make html-word drop ;
 
 ! Define some closed HTML tags

contrib/httpd/html.factor

@@ -1,73 +1,85 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: html
-USING: generic http io kernel lists math namespaces
+USING: cont-responder generic hashtables help http inspector io
-presentation sequences strings styles words ;
+kernel lists prototype-js math namespaces sequences strings
-
+styles words xml ;
-: html-entities ( -- alist )
-    [
-        [[ CHAR: < "&lt;"   ]]
-        [[ CHAR: > "&gt;"   ]]
-        [[ CHAR: & "&amp;"  ]]
-        [[ CHAR: ' "&apos;" ]]
-        [[ CHAR: " "&quot;" ]]
-    ] ;
-
-: chars>entities ( str -- str )
-    #! Convert <, >, &, ' and " to HTML entities.
-    [
-        [ dup html-entities assoc [ % ] [ , ] ?if ] each
-    ] "" make ;
 
 : hex-color, ( triplet -- )
-    3 swap head [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
+    3 swap head
+    [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
 
 : fg-css, ( color -- )
     "color: #" % hex-color, "; " % ;
 
+: bg-css, ( color -- )
+    "background-color: #" % hex-color, "; " % ;
+
 : style-css, ( flag -- )
-    dup [ italic bold-italic ] member?
+    dup
+    { italic bold-italic } member?
     [ "font-style: italic; " % ] when
-    [ bold bold-italic ] member?
+    { bold bold-italic } member?
     [ "font-weight: bold; " % ] when ;
 
-: underline-css, ( flag -- )
-    [ "text-decoration: underline; " % ] when ;
-
 : size-css, ( size -- )
-    "font-size: " % # "; " % ;
+    "font-size: " % # "pt; " % ;
 
 : font-css, ( font -- )
     "font-family: " % % "; " % ;
 
-: assoc-apply ( value-alist quot-alist -- )
+: hash-apply ( value-hash quot-hash -- )
     #! Looks up the key of each pair in the first list in the
     #! second list to produce a quotation. The quotation is
     #! applied to the value of the pair. If there is no
     #! corresponding quotation, the value is popped off the
     #! stack.
     swap [
-        unswons rot assoc* dup [ cdr call ] [ 2drop ] if
+        swap rot hash dup [ call ] [ 2drop ] if
-    ] each-with ;
+    ] hash-each-with ;
 
-: css-style ( style -- )
+: span-css-style ( style -- str )
     [
-        [
+        H{
-            [ foreground  fg-css, ]
+            { foreground  [ fg-css,        ] }
-            [ font        font-css, ]
+            { background  [ bg-css,        ] }
-            [ font-style  style-css, ]
+            { font        [ font-css,      ] }
-            [ font-size   size-css, ]
+            { font-style  [ style-css,     ] }
-            [ underline   underline-css, ]
+            { font-size   [ size-css,      ] }
-        ] assoc-apply
+        } hash-apply
     ] "" make ;
 
 : span-tag ( style quot -- )
-    over css-style dup "" = [
+    over span-css-style dup empty? [
         drop call
     ] [
         <span =style span> call </span>
     ] if ;
 
+: border-css, ( border -- )
+    "border: 1px solid #" % hex-color, "; " % ;
+
+: padding-css, ( padding -- ) "padding: " % # "px; " % ;
+
+: pre-css, ( -- ) "white-space: pre; font-family:monospace; " % ;
+
+: div-css-style ( style -- str )
+    [
+        H{
+            { page-color [ bg-css, ] }
+            { border-color [ border-css, ] }
+            { border-width [ padding-css, ] }
+            { wrap-margin [ [ pre-css, ] unless ] }
+        } hash-apply
+    ] "" make ;
+
+: div-tag ( style quot -- )
+    swap div-css-style dup empty? [
+        drop call
+    ] [
+        <div =style div> call </div>
+    ] if ;
+
 : resolve-file-link ( path -- link )
     #! The file responder needs relative links not absolute
     #! links.
@@ -79,69 +91,121 @@ presentation sequences strings styles words ;
     [ "/" % resolve-file-link url-encode % ] "" make ;
 
 : file-link-tag ( style quot -- )
-    over file swap assoc [
+    over file swap hash [
         <a file-link-href =href a> call </a>
     ] [
         call
     ] if* ;
 
-: browser-link-href ( word -- href )
+: do-escaping ( string style -- string )
-    dup word-name swap word-vocabulary
+    html swap hash [ chars>entities ] unless ;
-    [
-        "/responder/browser/?vocab=" %
-        url-encode %
-        "&word=" %
-        url-encode %
-    ] "" make ;
 
-: browser-link-tag ( style quot -- style )
+GENERIC: browser-link-href ( presented -- href )
-    over presented swap assoc dup word? [
+
-        <a browser-link-href =href a> call </a>
+M: object browser-link-href drop f ;
+
+M: word browser-link-href
+    "/responder/browser/" swap [
+        dup word-vocabulary "vocab" set word-name "word" set
+    ] make-hash build-url ;
+
+M: link browser-link-href
+    link-name [ \ f ] unless* dup word? [
+        browser-link-href
     ] [
-        drop call
+        "/responder/help/" swap "topic" associate build-url
     ] if ;
 
+: object-link-tag ( style quot -- )
+    presented pick hash browser-link-href
+    [ <a =href a> call </a> ] [ call ] if* ;
+
+TUPLE: nested-stream ;
+
+C: nested-stream [ set-delegate ] keep ;
+
+M: nested-stream stream-close drop ;
+
 TUPLE: html-stream ;
 
+C: html-stream ( stream -- stream ) [ set-delegate ] keep ;
+
 M: html-stream stream-write1 ( char stream -- )
-    [
+    >r ch>string r> stream-write ;
-        dup html-entities assoc [ write ] [ write1 ] ?if
+
-    ] with-wrapper ;
+: delegate-write delegate stream-write ;
+
+M: html-stream stream-write ( str stream -- )
+    >r chars>entities r> delegate-write ;
 
 M: html-stream stream-format ( str style stream -- )
     [
         [
             [
-                [ drop chars>entities write ] span-tag
+                [
+                    do-escaping stdio get delegate-write
+                ] span-tag
             ] file-link-tag
-        ] browser-link-tag
+        ] object-link-tag
-    ] with-wrapper ;
+    ] with-stream* ;
-
-C: html-stream ( stream -- stream )
-    #! Wraps the given stream in an HTML stream. An HTML stream
-    #! converts special characters to entities when being
-    #! written, and supports writing attributed strings with
-    #! the following attributes:
-    #!
-    #! foreground - an rgb triplet in a list
-    #! background - an rgb triplet in a list
-    #! font
-    #! font-style
-    #! font-size
-    #! underline
-    #! file
-    #! word
-    #! vocab
-    [ >r <wrapper-stream> r> set-delegate ] keep ;
 
 : with-html-stream ( quot -- )
-    [ stdio [ <html-stream> ] change  call ] with-scope ;
+    stdio get <html-stream> swap with-stream* ;
+
+: html-outliner ( caption contents -- )
+    <table "display: inline; " =style table>
+        <tr>
+            <td>
+                "+" get-random-id dup >r rot [
+                    with-html-stream
+                ] curry [ , \ show-final , ] [ ] make updating-anchor
+            </td>
+            <td>
+                call
+            </td>
+        </tr>
+        <tr>
+            <td> </td>
+            <td> <div r> =id div> </td>
+        </tr>
+    </table> ;
+
+: outliner-tag ( style quot -- )
+    outline pick hash [ html-outliner ] [ call ] if* ;
+
+M: html-stream with-nested-stream ( quot style stream -- )
+    [
+        [
+            [
+                [
+                    stdio get <nested-stream> swap with-stream*
+                ] div-tag
+            ] object-link-tag
+        ] outliner-tag
+    ] with-stream* ;
+
+M: html-stream stream-terpri [ <br/> ] with-stream* ;
+
+: default-css ( -- )
+  <style>
+    "A:link { text-decoration: none; color: black; }" print
+    "A:visited { text-decoration: none; color: black; }" print
+    "A:active { text-decoration: none; color: black; }" print
+    "A:hover, A:hover { text-decoration: none; color: black; }" print
+  </style> ;
+
+: xhtml-preamble
+    "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>" print
+    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" print ;
 
 : html-document ( title quot -- )
+    xhtml-preamble
     swap chars>entities dup
     <html>
         <head>
             <title> write </title>
+            default-css
+            include-prototype-js
         </head>
         <body>
             <h1> write </h1>

contrib/httpd/http-client.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: http-client
-USING: errors http kernel lists math namespaces parser sequences
+USING: errors hashtables http kernel math namespaces parser
-io strings ;
+sequences io strings ;
 
 : parse-host ( url -- host port )
     #! Extract the host name and port number from an HTTP URL.
@@ -19,7 +19,7 @@ io strings ;
     " " split1 drop string>number ;
 
 : read-response ( -- code header )
-    #! After sending a GET oR POST we read a response line and
+    #! After sending a GET or POST we read a response line and
     #! header.
     flush readln parse-response read-header ;
 
@@ -34,18 +34,18 @@ io strings ;
 
 DEFER: http-get
 
-: do-redirect ( code headers stream -- code headers stream )
+: do-redirect ( code headers string -- code headers string )
     #! Should this support Location: headers that are
     #! relative URLs?
     pick 302 = [
-        stream-close "Location" swap assoc nip http-get
+        drop "Location" swap hash nip http-get
     ] when ;
 
 : http-get ( url -- code headers stream )
     #! Opens a stream for reading from an HTTP URL.
     parse-url over parse-host <client> [
-        [ get-request read-response ] with-stream*
+        get-request read-response stdio get contents
-    ] keep do-redirect ;
+    ] with-stream do-redirect ;
 
 : download ( url file -- )
     #! Downloads the contents of a URL to a file.
@@ -60,8 +60,10 @@ DEFER: http-get
         crlf
     ] keep write ;
 
-: http-post ( content-type content url -- code headers stream )
+: http-post ( content-type content url -- code headers string )
     #! Make a POST request. The content is URL encoded for you.
     parse-url over parse-host <client> [
-        [ post-request flush read-response ] with-stream*
+        [
+            post-request flush read-response stdio get contents
+        ] with-stream
     ] keep ;

contrib/httpd/http-common.factor

@@ -1,17 +1,25 @@
 ! Copyright (C) 2003, 2005 Slava Pestov
 IN: http
-USING: errors kernel lists math namespaces parser sequences
+USING: errors hashtables io kernel lists math namespaces parser
-io strings ;
+sequences strings ;
 
-: header-line ( alist line -- alist )
+: header-line ( line -- )
-    ": " split1 dup [ cons swons ] [ 2drop ] if ;
+    ": " split1 dup [ swap set ] [ 2drop ] if ;
 
-: (read-header) ( alist -- alist )
+: (read-header) ( hash -- hash )
     readln dup
     empty? [ drop ] [ header-line (read-header) ] if ;
 
-: read-header ( -- alist )
+: read-header ( -- hash )
-    [ ] (read-header) ;
+    [ (read-header) ] make-hash ;
+
+: url-quotable? ( ch -- ? )
+    #! In a URL, can this character be used without
+    #! URL-encoding?
+    dup letter?
+    over LETTER? or
+    over digit? or
+    swap "/_?." member? or ; foldable
 
 : url-encode ( str -- str )
     [
@@ -54,3 +62,12 @@ io strings ;
 
 : url-decode ( str -- str )
     [ 0 swap url-decode-iter ] "" make ;
+
+: build-url ( path query-params -- str )
+    [
+        swap % dup hash-empty? [
+            "?" %
+            dup hash>alist
+            [ [ url-encode ] map "=" join ] map "&" join %
+        ] unless drop
+    ] "" make ;

contrib/httpd/httpd.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: httpd
-USING: errors kernel lists namespaces io strings threads http
+USING: errors hashtables kernel lists namespaces io strings 
-sequences ;
+threads http sequences ;
 
 : (url>path) ( uri -- path )
     url-decode "http://" ?head [
@@ -20,15 +20,15 @@ sequences ;
     ".." over subseq? [ drop f ] when ;
 
 : request-method ( cmd -- method )
-    [
+    H{
-        [[ "GET" "get" ]]
+        { "GET" "get" }
-        [[ "POST" "post" ]]
+        { "POST" "post" }
-        [[ "HEAD" "head" ]]
+        { "HEAD" "head" }
-    ] assoc [ "bad" ] unless* ;
+    } hash [ "bad" ] unless* ;
 
 : host ( -- string )
     #! The host the current responder was called from.
-    "Host" "header" get assoc ":" split1 drop ;
+    "Host" "header" get hash ":" split1 drop ;
 
 : (handle-request) ( arg cmd -- method path host )
     request-method dup "method" set swap

contrib/httpd/inspect-responder.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: inspect-responder
+USING: cont-responder generic hashtables help html inspector
+kernel lists namespaces sequences ;
+
+! Mini object inspector
+: http-inspect ( obj -- )
+    "Inspecting " over summary append
+    [ describe ] simple-html-document ;
+
+M: general-t browser-link-href
+    "/responder/inspector/" swap
+    [ [ http-inspect ] show-final ] curry quot-url
+    append ;
+
+: inspect-responder ( url -- )
+    [ global http-inspect ] show-final ;

contrib/httpd/live-updater.factor

@@ -1,58 +1,21 @@
 ! Copyright (C) 2004 Chris Double.
-! 
+! See http://factorcode.org/license.txt for BSD license.
-! 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.
 !
-! cont-responder code for display forms and anchors that use XMLHttpRequest
+! cont-responder code for display forms and anchors that use
-! and the 'liveUpdater.js' code.
+! XMLHttpRequest and the 'liveUpdater.js' code.
 IN: live-updater
-USE: kernel
+USING: cont-responder html io kernel lists namespaces strings
-USE: io
+xml ;
-USE: strings
-USE: html
-USE: cont-responder
-USE: namespaces
-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 ] if ;
 
 : get-live-updater-js ( filename -- string )
   #! Return the liveUpdater javascript code as a string.
-  <file-reader> [ get-live-updater-js* ] "" make ;
+  "/contrib/httpd/liveUpdater.js" <resource-stream> contents ;
-
-: live-updater-url ( -- url )
-  #! Generate an URL to the liveUpdater.js code.
-  t [ 
-    [
-      "js/liveUpdater.js" get-live-updater-js write
-    ] show        
-  ] register-continuation id>url ;
 
 : include-live-updater-js ( -- )
   #! Write out the HTML script to include the live updater
   #! javascript code.
-  <script "JavaScript" =language live-updater-url =src script> 
+  <script "JavaScript" =language script>
-    "" write
+    get-live-updater-js write-html
   </script> ;
 
 : write-live-anchor-tag ( text -- id )
@@ -61,9 +24,7 @@ USE: lists
   #! an onclick is set via DHTML later to make it run a
   #! quotation on the server. The randomly generated id
   #! for the anchor is returned.
-  <a get-random-id dup =id "#" =href a>  
+  <a get-random-id dup =id "#" =href a> swap write </a> ;  
-    swap write
-  </a> ;  
 
 : register-live-anchor-quot ( div-id div-quot -- kid )
   #! Register the 'quot' with the cont-responder so
@@ -76,7 +37,7 @@ USE: lists
     "div-id" set
   ] make-hash [ 
     [
-      t "disable-initial-redirect?" set
+      "disable-initial-redirect?" on
       [ 
         <div "div-id" get =id div> "div-quot" get call </div>    
       ] show 
@@ -92,11 +53,11 @@ USE: lists
   #! replace whatever HTML DOM object currently has that same
   #! id.
   <script "JavaScript" =language script> 
-    "document.getElementById('" write
+    "document.getElementById('" write-html
-    write
+    write-html
-    "').onclick=liveUpdaterUri('" write
+    "').onclick=liveUpdaterUri('" write-html
-    register-live-anchor-quot id>url write
+    register-live-anchor-quot id>url write-html
-    "');" write
+    "');" write-html
   </script> ;
   
 : live-anchor ( id quot text -- )
@@ -128,7 +89,7 @@ USE: lists
     "div-id" set
   ] make-hash [ 
     [
-      t "disable-initial-redirect?" set
+      "disable-initial-redirect?" on
       #! Retrieve the search query value from the POST parameters.
       [ "s" get ] bind
       [ 

contrib/httpd/load.factor

@@ -1,20 +1,31 @@
-USING: kernel parser sequences io ;
+IN: scratchpad
-[
+USING: words kernel parser sequences io compiler ;
-    "contrib/httpd/http-common.factor"
+
-    "contrib/httpd/mime.factor"
+{ 
-    "contrib/httpd/html-tags.factor"
+    "mime"
-    "contrib/httpd/html.factor"
+    "xml"
-    "contrib/httpd/responder.factor"
+    "http-common"
-    "contrib/httpd/httpd.factor"
+    "html-tags"
-    "contrib/httpd/file-responder.factor"
+    "responder"
-    "contrib/httpd/cont-responder.factor"
+    "httpd"
-    "contrib/httpd/browser-responder.factor"
+    "cont-responder"
-    "contrib/httpd/default-responders.factor"
+    "live-updater"
-    "contrib/httpd/http-client.factor"
+    "prototype-js"
-    "contrib/httpd/test/html.factor"
+    "html"
-    "contrib/httpd/test/http-client.factor"
+    "file-responder"
-    "contrib/httpd/test/httpd.factor"
+    "help-responder"
-    "contrib/httpd/test/url-encoding.factor"
+    "inspect-responder"
-] [
+    "browser-responder"
-    dup print run-file
+    "default-responders"
-] each
+    "http-client"
+
+    "test/html"
+    "test/http-client"
+    "test/httpd"
+    "test/url-encoding"
+} [ "/contrib/httpd/" swap ".factor" append3 run-resource ] each
+
+"To start the HTTP server, issue the following command in the listener:" print
+"  USE: httpd" print
+"  [ 8888 httpd ] in-thread" print
+"Replacing '8888' with whatever port number you desire." print

contrib/httpd/mime.factor

@@ -1,34 +1,34 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: httpd
-USING: io hashtables kernel lists namespaces ;
+USING: io hashtables kernel sequences math namespaces ;
 
-: set-mime-types ( assoc -- )
+: file-extension ( filename -- extension )
-    "mime-types" global set-hash ;
+    "." split dup length 1 <= [ drop f ] [ peek ] if ;
-
-: mime-types ( -- assoc )
-    "mime-types" global hash ;
 
 : mime-type ( filename -- mime-type )
-    file-extension mime-types assoc [ "text/plain" ] unless* ;
+    file-extension "mime-types" get
+    hash [ "text/plain" ] unless* ;
 
-[
+H{
-    [[ "html"   "text/html"                        ]]
+    { "html"   "text/html"                        }
-    [[ "txt"    "text/plain"                       ]]
+    { "txt"    "text/plain"                       }
-    [[ "xml"    "text/xml"                         ]]
+    { "xml"    "text/xml"                         }
-    [[ "css"    "text/css"                         ]]
+    { "css"    "text/css"                         }
                                                     
-    [[ "gif"    "image/gif"                        ]]
+    { "gif"    "image/gif"                        }
-    [[ "png"    "image/png"                        ]]
+    { "png"    "image/png"                        }
-    [[ "jpg"    "image/jpeg"                       ]]
+    { "jpg"    "image/jpeg"                       }
-    [[ "jpeg"   "image/jpeg"                       ]]
+    { "jpeg"   "image/jpeg"                       }
                                                     
-    [[ "jar"    "application/octet-stream"         ]]
+    { "jar"    "application/octet-stream"         }
-    [[ "zip"    "application/octet-stream"         ]]
+    { "zip"    "application/octet-stream"         }
-    [[ "tgz"    "application/octet-stream"         ]]
+    { "tgz"    "application/octet-stream"         }
-    [[ "tar.gz" "application/octet-stream"         ]]
+    { "tar.gz" "application/octet-stream"         }
-    [[ "gz"     "application/octet-stream"         ]]
+    { "gz"     "application/octet-stream"         }
+
+    { "pdf"    "application/pdf"                  }
                                                     
-    [[ "factor" "application/x-factor"             ]]
+    { "factor" "application/x-factor"             }
-    [[ "factsp" "application/x-factor-server-page" ]]
+    { "factsp" "application/x-factor-server-page" }
-] set-mime-types
+} "mime-types" global set-hash

contrib/httpd/prototype-js.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Wrapper for the Prototype javascript library.
+! For information and license details for protoype 
+! see http://prototype.conio.net
+IN: prototype-js
+USING: io httpd cont-responder html kernel lists namespaces strings ;
+
+: include-prototype-js ( -- )
+  #! Write out the HTML script tag to include the prototype
+  #! javascript library.
+  <script "text/javascript" =type "/responder/javascript/prototype.js" =src script>
+  </script> ;
+
+: updating-javascript ( id quot -- string )
+  #! Return the javascript code to perform the updating
+  #! ajax call.
+  quot-url swap 
+  [ "new Ajax.Updater(\"" % % "\",\"" % % "\", { method: \"get\" });" % ] "" make ;
+
+: updating-anchor ( text id quot -- )
+  #! Write the HTML for an anchor that when clicked will
+  #! call the given quotation on the server. The output generated
+  #! from that quotation will replace the DOM element on the page with
+  #! the given id. The 'text' is the anchor text.
+  <a "#" =href updating-javascript =onclick a> write </a> ;

contrib/httpd/responder.factor

@@ -1,15 +1,15 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: httpd
-USING: hashtables http kernel lists math namespaces parser
+USING: arrays hashtables http kernel lists math namespaces
-sequences io strings ;
+parser sequences io strings ;
 
 ! Variables
 SYMBOL: vhosts
 SYMBOL: responders
 
 : print-header ( alist -- )
-    [ unswons write ": " write url-encode print ] each ;
+    [ swap write ": " write url-encode print ] hash-each ;
 
 : response ( header msg -- )
     "HTTP/1.0 " write print print-header ;
@@ -19,7 +19,7 @@ SYMBOL: responders
 
 : error-head ( error -- )
     dup log-error
-    [ [[ "Content-Type" "text/html" ]] ] over response ;
+    H{ { "Content-Type" "text/html" } } over response ;
 
 : httpd-error ( error -- )
     #! This must be run from handle-request
@@ -34,7 +34,7 @@ SYMBOL: responders
     ] with-scope ;
 
 : serving-content ( mime -- )
-    "Content-Type" swons unit
+    "Content-Type" associate
     "200 Document follows" response terpri ;
 
 : serving-html "text/html" serving-content ;
@@ -42,7 +42,7 @@ SYMBOL: responders
 : serving-text "text/plain" serving-content ;
 
 : redirect ( to -- )
-    "Location" swons unit
+    "Location" associate
     "301 Moved Permanently" response terpri ;
 
 : directory-no/ ( -- )
@@ -51,28 +51,26 @@ SYMBOL: responders
         "raw-query" get [ CHAR: ? , % ] when*
     ] "" make redirect ;
 
-: query>alist ( query -- alist )
+: query>hash ( query -- hash )
     dup [
         "&" split [
-            "=" split1
+            "=" split1 [ dup [ url-decode ] when ] 2apply 2array
-            dup [ url-decode ] when swap
-            dup [ url-decode ] when swap cons
         ] map
-    ] when ;
+    ] when alist>hash ;
 
-: read-post-request ( header -- alist )
+: read-post-request ( header -- hash )
-    "Content-Length" swap assoc dup
+    "Content-Length" swap hash dup
-    [ string>number read query>alist ] when ;
+    [ string>number read query>hash ] when ;
 
-: log-user-agent ( alist -- )
+: log-user-agent ( hash -- )
-    "User-Agent" swap assoc* [
+    "User-Agent" swap hash [
-        unswons [ % ": " % % ] "" make log-message
+        [ "User Agent: " % ": " % % ] "" make log-message
     ] when* ;
 
 : prepare-url ( url -- url )
     #! This is executed in the with-request namespace.
     "?" split1
-    dup "raw-query" set query>alist "query" set
+    dup "raw-query" set query>hash "query" set
     dup "request" set ;
 
 : prepare-header ( -- )
@@ -87,11 +85,11 @@ SYMBOL: responders
 ! - request -- the entire URL requested, including responder
 !              name
 ! - raw-query -- raw query string
-! - query -- an alist of query parameters, eg
+! - query -- a hashtable of query parameters, eg
 !            foo.bar?a=b&c=d becomes
-!            [ [[ "a" "b" ]] [[ "c" "d" ]] ]
+!            H{ { "a" "b" } { "c" "d" } }
-! - header -- an alist of headers from the user's client
+! - header -- a hashtable of headers from the user's client
-! - response -- an alist of the POST request response
+! - response -- a hashtable of the POST request response
 
 : add-responder ( responder -- )
     #! Add a responder object to the list.

contrib/httpd/test/html.factor

@@ -1,5 +1,11 @@
 IN: temporary
-USING: html io kernel namespaces styles test ;
+USING: html http io kernel namespaces styles test xml ;
+
+[
+    "/responder/foo?z=%20"
+] [
+    "/responder/foo" H{ { "z" " " } } build-url
+] unit-test
 
 [
     "<html>&'sgml'"
@@ -16,16 +22,7 @@ USING: html io kernel namespaces styles test ;
 [ "" ]
 [
     [
-        [ ] [ drop ] span-tag
+        H{ } [ drop ] span-tag
-    ] string-out
-] unit-test
-
-[ "<span style='color: #ff00ff; font-family: Monospaced; '>car</span>" ]
-[
-    [
-        [ [ foreground 1 0 1 ] [[ font "Monospaced" ]] ]
-        [ drop "car" write ]
-        span-tag
     ] string-out
 ] unit-test
 
@@ -34,30 +31,23 @@ USING: html io kernel namespaces styles test ;
 
 [ "hello world" ]
 [
-    [ "hello world" [ ] html-format ] string-out
+    [ "hello world" H{ } html-format ] string-out
 ] unit-test
 
-[ "<span style='color: #ff00ff; font-family: Monospaced; '>car</span>" ]
+[ "<span style='font-family: monospace; '>car</span>" ]
 [
     [
         "car"
-        [ [ foreground 1 0 1 ] [[ font "Monospaced" ]] ]
+        H{ { font "monospace" } }
         html-format
     ] string-out
 ] unit-test
 
+[ "<span style='color: #ff00ff; '>car</span>" ]
 [
-    "<html><head><title>Foo</title></head><body><h1>Foo</h1></body></html>"
-] [
     [
-        "Foo" [ ] html-document
+        "car"
-    ] string-out
+        H{ { foreground { 1 0 1 1 } } }
-] unit-test
+        html-format
-
-[
-    "<html><head><title>Foo</title></head><body><h1>Foo</h1><pre>Hi</pre></body></html>"
-] [
-    [
-        "Foo" [ "Hi" write ] simple-html-document
     ] string-out
 ] unit-test

contrib/httpd/test/httpd.factor

@@ -13,17 +13,6 @@ USE: lists
     [ "text/html" 12 file-response ] string-out
 ] unit-test
 
-[
-    [
-        [[ "X-Spyware-Requested" "yes" ]]
-        [[ "User-Agent" "Internet Explorer 0.4alpha" ]]
-    ]
-]
-[
-    [ [[ "User-Agent" "Internet Explorer 0.4alpha" ]] ]
-    "X-Spyware-Requested: yes" header-line
-] unit-test
-
 [ ] [ "404 not found" httpd-error ] unit-test
 
 [ "arg" ] [
@@ -60,12 +49,12 @@ USE: lists
 [ ] [ "GET ../index.html" parse-request ] unit-test
 [ ] [ "POO" parse-request ] unit-test
 
-[ [ [[ "Foo" "Bar" ]] ] ] [ "Foo=Bar" query>alist ] unit-test
+[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test
 
-[ [ [[ "Foo" "Bar" ]] [[ "Baz" "Quux" ]] ] ]
+[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ]
-[ "Foo=Bar&Baz=Quux" query>alist ] unit-test
+[ "Foo=Bar&Baz=Quux" query>hash ] unit-test
 
-[ [ [[ "Baz" " " ]] ] ]
+[ H{ { "Baz" " " } } ]
-[ "Baz=%20" query>alist ] unit-test
+[ "Baz=%20" query>hash ] unit-test
 
-[ [ [ "Foo" ] ] ] [ "Foo" query>alist ] unit-test
+[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test

contrib/httpd/xml.factor

@@ -1,5 +1,6 @@
-USING: kernel math infix parser namespaces sequences strings prettyprint
+USING: kernel math parser namespaces sequences strings
-    errors lists hashtables vectors html io generic words ;
+prettyprint errors lists hashtables vectors io generic
+words ;
 IN: xml
 
 ! * Simple SAX-ish parser
@@ -124,12 +125,18 @@ M: xml-string-error error.
     ] if ;
 
 : entities
+    #! We have both directions here as a shortcut.
     H{
-        [[ "lt" CHAR: < ]]
+        { "lt" CHAR: < }
-        [[ "gt" CHAR: > ]]
+        { "gt" CHAR: > }
-        [[ "amp" CHAR: & ]]
+        { "amp" CHAR: & }
-        [[ "apos" CHAR: ' ]]
+        { "apos" CHAR: ' }
-        [[ "quot" CHAR: " ]]
+        { "quot" CHAR: " }
+        { CHAR: < "&lt;"   }
+        { CHAR: > "&gt;"   }
+        { CHAR: & "&amp;"  }
+        { CHAR: ' "&apos;" }
+        { CHAR: " "&quot;" }
     } ;
 
 : parse-entity ( -- ch )
@@ -286,11 +293,8 @@ M: unclosed error.
     "Tags: " print
     unclosed-tags [ "  <" write write ">" print ] each ;
 
-: seq-last ( seq -- last )
-    [ length 1 - ] keep nth ;
-
 : push-datum ( object -- )
-    xml-stack get seq-last cdr push ;
+    xml-stack get peek cdr push ;
 
 GENERIC: process ( object -- )
 
@@ -308,17 +312,17 @@ M: closer process
     closer-name xml-stack get pop uncons
     >r [ 
         opener-name [
-	    2dup = [ 2drop ] [ swap <mismatched> throw ] if
+            2dup = [ 2drop ] [ swap <mismatched> throw ] if
-	] keep
+        ] keep
     ] keep opener-props r> <tag> push-datum ;
 
 : initialize-xml-stack ( -- )
     f V{ } clone cons unit >vector xml-stack set ;
 
-: xml ( string -- vector )
+: xml ( string -- tag )
     #! Produces a tree of XML nodes
     [
-	initialize-xml-stack
+        initialize-xml-stack
         [ process ] xml-each
         xml-stack get
         dup length 1 = [ <unclosed> throw ] unless
@@ -329,26 +333,18 @@ M: closer process
 
 : print-props ( hash -- )
     [
-        " " % unswons % "=\"" % % "\"" %
+        " " % swap % "=\"" % % "\"" %
     ] hash-each ;
 
 GENERIC: (xml>string) ( object -- )
 
-: reverse-entities ! not as many as entities needed for printing
+: chars>entities ( str -- str )
-    H{
+    #! Convert <, >, &, ' and " to HTML entities.
-        [[ CHAR: & "amp" ]]
-        [[ CHAR: < "lt" ]]
-        [[ CHAR: " "quot" ]]
-    } ;
-
-M: string (xml>string)
     [
-        dup reverse-entities hash [
+        [ dup entities hash [ % ] [ , ] ?if ] each
-            CHAR: & , % CHAR: ; ,
+    ] "" make ;
-        ] [
+
-            ,
+M: string (xml>string) chars>entities % ;
-        ] ?if
-    ] each ;
 
 : print-open/close ( tag -- )
     CHAR: > ,
@@ -404,13 +400,23 @@ M: comment (xml>string)
 
 ! * System for words specialized on tag names
 
+TUPLE: process-missing process tag ;
+M: process-missing error.
+    "Tag <" write
+    process-missing-tag tag-name write
+    "> not implemented on process " write
+    dup process-missing-process word-name print ;
+
+: run-process ( tag word -- )
+    2dup "xtable" word-prop
+    >r dup tag-name r> hash* [ 2nip call ] [
+        drop <process-missing> throw
+    ] if ;
+
 : PROCESS:
     CREATE
     dup H{ } clone "xtable" set-word-prop
-    dup literalize [
+    dup literalize [ run-process ] cons define-compound ; parsing
-        "xtable" word-prop
-        >r dup tag-name r> hash call
-    ] cons define-compound ; parsing
 
 : TAG:
     scan scan-word [

contrib/load.factor

@@ -0,0 +1,26 @@
+! Load all contrib libs, compile them, and save a new image.
+IN: scratchpad
+USING: alien compiler kernel memory parser sequences words ;
+
+{ 
+    "coroutines"
+    "dlists"
+    "splay-trees"
+} [ "/contrib/" swap ".factor" append3 run-resource clear ] each
+
+{ "cairo"
+  "math"
+  "concurrency"
+  "crypto"
+  "aim"
+  "httpd"
+  "units"
+  "sqlite"
+  "win32"
+  "x11"
+  ! "factory" has a C component, ick.
+  "postgresql"
+  "parser-combinators"
+  "cont-responder"
+  "space-invaders"
+} [ "/contrib/" swap "/load.factor" append3 run-resource clear ] each

contrib/math/analysis.factor

@@ -41,7 +41,7 @@ IN: math-contrib
     #! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
     #! gamma(n+1) = n! for n > 0
     dup Z:(-inf,0]? [
-            drop inf
+            drop 1./0.
         ] [
             dup abs gamma-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
     ] if ;
@@ -50,13 +50,13 @@ IN: math-contrib
     #! gammaln(x) is an alternative when gamma(x)'s range
     #! varies too widely
     dup 0 < [
-            drop inf
+            drop 1./0.
         ] [
             dup abs gammaln-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
     ] if ;
 
 : nth-root ( n x -- )
-    log >r recip r> * e swap ^ ;
+    over 0 = [ "0th root is undefined" throw ] when >r recip r> swap ^ ;
 
 ! Forth Scientific Library Algorithm #1
 !

contrib/math/combinatorics.factor

@@ -1,6 +1,7 @@
 IN: math-contrib
 USING: kernel sequences errors namespaces math ;
 
+: <range> ( from to -- seq ) dup <slice> ; inline
 : (0..n] ( n -- (0..n] ) 1+ 1 swap <range> ; inline
 : [1..n] ( n -- [1..n] ) (0..n] ; inline
 : [k..n] ( k n -- [k..n] ) 1+ <range> ; inline

contrib/math/infix.factor

@@ -1,6 +1,7 @@
 IN: infix
-USING: sequences kernel io math strings combinators namespaces prettyprint
+USING: arrays errors generic hashtables io kernel kernel-internals lists math math-contrib namespaces parser parser-combinators prettyprint sequences strings vectors words ;
-       errors parser generic lists kernel-internals hashtables words vectors ;
+
+: 2list ( x y -- [ x y ] ) f cons cons ;
 
 ! Tokenizer
 
@@ -135,10 +136,10 @@ M: tok parse-token
             binary-op
         ] [
             unary-op
-        ] ifte
+        ] if
     ] [
         null-op
-    ] ifte f ;
+    ] if f ;
 
 ( ast tokens token -- ast tokens )
 
@@ -151,7 +152,7 @@ M: symbol parse-token ! apostrophe
         unswons parse-token (parse-tokens)
     ] [
         drop
-    ] ifte ;
+    ] if ;
 
 : parse-tokens ( tokens -- ast )
     #! Convert a list of tokens into an AST
@@ -171,7 +172,7 @@ M: string compile-ast ! variables
         "Variable not found" throw
     ] [
         [ swap array-nth ] cons
-    ] ifte ;
+    ] if ;
 
 : replace-with ( data -- [ drop data ] )
     \ drop swap 2list ;
@@ -195,7 +196,7 @@ M: vector compile-ast ! literal vectors
         replace-with nip
     ] [
         [ , ] accumulator [ { } make nip ] cons
-    ] ifte ;
+    ] if ;
 
 : infix-relation
     #! Wraps operators like = and > so that if they're given
@@ -209,7 +210,7 @@ M: vector compile-ast ! literal vectors
         dupd r> call [
             drop f
         ] unless
-    ] ifte ;
+    ] if ;
 
 : functions
     #! Regular functions
@@ -256,7 +257,7 @@ M: vector compile-ast ! literal vectors
         uncons drc cons
     ] [
         drop f
-    ] ifte ;
+    ] if ;
 
 : map-with-left ( seq object quot -- seq )
     [ swapd call ] cons swapd map-with ; inline
@@ -280,7 +281,7 @@ M: vector compile-ast ! literal vectors
     #! like hash but throws exception if f
     dupd hash [ nip ] [
         [ "Key not found " write . ] string-out throw
-    ] ifte* ;
+    ] if* ;
 
 : >apply< ( apply -- func args )
     dup apply-func swap apply-args ;
@@ -291,7 +292,7 @@ M: vector compile-ast ! literal vectors
     ] [
         >apply< car >r over r> make-apply
         -rot swons high-functions get-hash cons
-    ] ifte ;
+    ] if ;
 
 : get-function ( apply -- quot )
     >apply< length swap make-apply ;

contrib/math/load.factor

@@ -1,14 +1,13 @@
-IN: dimensions
+IN: scratchpad
-USING: parser sequences words compiler ;
+USING: kernel parser sequences words compiler ;
-[
-    "contrib/math/utils.factor"
-    "contrib/math/combinatorics.factor"
-    "contrib/math/analysis.factor"
-    "contrib/math/polynomials.factor"
-    "contrib/math/quaternions.factor"
-    "contrib/math/matrices.factor"
-    "contrib/math/statistics.factor"
-] [ run-file ] each
-
-"math-contrib" words [ try-compile ] each
 
+{ 
+    "utils"
+    "combinatorics"
+    "analysis"
+    "polynomials"
+    "quaternions"
+    "matrices"
+    "statistics"
+    "numerical-integration"
+} [ "/contrib/math/" swap ".factor" append3 run-resource ] each

contrib/math/matrices.factor

@@ -5,7 +5,7 @@ USING: arrays generic kernel sequences math ;
 
 ! Matrices
 : zero-matrix ( m n -- matrix )
-    swap [ drop zero-array ] map-with ;
+    swap [ drop 0 <array> ] map-with ;
 
 : identity-matrix ( n -- matrix )
     #! Make a nxn identity matrix.

contrib/math/numerical-integration.factor

@@ -0,0 +1,33 @@
+IN: math-contrib
+
+USING: kernel sequences errors namespaces math lists vectors errors prettyprint ;
+USING: io inspector ;
+
+: setup-range ( from to -- frange )
+    step-size get swap <frange> ;
+
+: integrate-rect ( from to f -- x )
+    >r setup-range dup decrement-length r>
+    [ step-size get * ] append map sum ;
+
+: integrate-trap ( from to f -- x )
+    >r setup-range r>
+    map 1 over tail >r >vector dup pop drop r>
+    [ + 2 / step-size get * ] 2map sum ;
+
+
+SYMBOL: num-steps 180 num-steps set ! simpsons
+: setup-simpson-range ( from to -- frange )
+    [ swap - num-steps get /f ] 2keep swapd <frange> ;
+
+: generate-simpson-weights ( seq -- seq )
+    length 2 / V{ 1 4 } clone swap 2 -
+    [ { 2 4 } append ] times { 1 } append ;
+
+: integrate-simpson ( from to f -- x )
+    >r setup-simpson-range r> dupd map dup generate-simpson-weights
+    [ * ] 2map sum swap [ third ] keep first - 6 / * ; 
+
+
+: quadrature ( from to f -- x )
+    integrate-simpson ;

contrib/math/polynomials.factor

@@ -7,7 +7,7 @@ USING: kernel sequences vectors math math-internals namespaces arrays ;
 
 : 2length ( seq seq -- ) [ length ] 2apply ;
 
-: zero-vector ( n -- vector ) 0 <repeated> >vector ;
+: zero-vector ( n -- vector ) 0 <array> >vector ;
 
 : zero-pad ( n seq -- seq )
     #! extend seq by n zeros
@@ -110,9 +110,8 @@ IN: math-contrib
 
 : pdiff ( p -- p' )
     #! Polynomial derivative.
-    dup empty? [ [ length ] keep v* 1 swap tail ] unless ;
+    dup length v* { 0 } ?head drop ;
-
-: polyval ( x p -- n )
-    #! evaluate polynomial in a straightforward way
-    ptrim dup length 1 swap <range> [ pick swap ^ ] map 1 rot cut swapd v. swap pop + nip ;
 
+: polyval ( p x -- p[x] )
+    #! Evaluate a polynomial.
+    >r dup length r> powers v. ;

contrib/math/statistics.factor

@@ -11,11 +11,13 @@ USING: kernel math sequences ;
 
 : harmonic-mean ( seq -- n )
     #! harmonic mean, reciprocal of sum of reciprocals.
-    [ recip ] map sum recip ;
+    #! positive reals only
+    0 [ recip + ] reduce recip ;
 
+! : number-sort [ - ] sort ;
 : median ( seq -- n )
     #! middle number if odd, avg of two middle numbers if even
-    number-sort dup length dup even? [
+    [ - ] sort dup length dup even? [
         1+ 2 /i dup 1- rot [ nth ] keep swapd nth + 2 /
     ] [
         2 /i swap nth
@@ -23,14 +25,14 @@ USING: kernel math sequences ;
 
 : range ( seq -- n )
     #! max - min
-    dup first 2dup [ min ] reduce >r [ max ] reduce r> - ;
+    minmax swap - ;
 
 : var ( seq -- )
     #! variance, normalize by N-1
     dup length 1- dup 0 = [
         0 2nip
     ] [
-        swap [ mean ] keep [ over - sq ] map sum nip swap /
+        swap [ mean ] keep 0 [ pick - sq + ] reduce nip swap /
     ] if ;
 
 : std

contrib/math/test.factor

@@ -45,32 +45,32 @@ USING: kernel math test sequences math-contrib ;
 [ 1 ] [ 2 0 nCk ] unit-test
 [ 1 ] [ 2 0 nPk ] unit-test
 [ t ] [ -9000000000000000000000000000000000000000000 gamma inf = ] unit-test
-[ t ] [ -1.5 gamma 2.36327 - abs .0001 < ] unit-test
+[ t ] [ -1.5 gamma 2.36327 almost= ] unit-test
 [ t ] [ -1 gamma inf = ] unit-test
-[ t ] [ -0.5 gamma -3.5449 - abs .0001 < ] unit-test
+[ t ] [ -0.5 gamma -3.5449 almost= ] unit-test
 [ t ] [ 0 gamma inf = ] unit-test
-[ t ] [ .5 gamma 1.7725 - abs .0001 < ] unit-test
+[ t ] [ .5 gamma 1.7724538 almost= ] unit-test
-[ t ] [ 1 gamma 1 - abs .0001 < ] unit-test
+[ t ] [ 1 gamma 1 almost= ] unit-test
-[ t ] [ 2 gamma 1 - abs .0001 < ] unit-test
+[ t ] [ 2 gamma 1 almost= ] unit-test
-[ t ] [ 3 gamma 2 - abs .0001 < ] unit-test
+[ t ] [ 3 gamma 2 almost= ] unit-test
-[ t ] [ 11 gamma 3628800 - abs .0001 < ] unit-test
+[ t ] [ 11 gamma 3628800 almost= ] unit-test
 [ t ] [ 90000000000000000000000000000000000000000000 gamma inf = ] unit-test
 ! some fun identities
-[ t ] [ 2/3 gamma 2 pi * 3 sqrt 1/3 gamma * / - abs .00001 < ] unit-test
+[ t ] [ 2/3 gamma 2 pi * 3 sqrt 1/3 gamma * / almost= ] unit-test
-[ t ] [ 3/4 gamma 2 sqrt pi * 1/4 gamma / - abs .0001 < ] unit-test
+[ t ] [ 3/4 gamma 2 sqrt pi * 1/4 gamma / almost= ] unit-test
-[ t ] [ 4/5 gamma 2 5 sqrt / 2 + sqrt pi * 1/5 gamma / - abs .0001 < ] unit-test
+[ t ] [ 4/5 gamma 2 5 sqrt / 2 + sqrt pi * 1/5 gamma / almost= ] unit-test
-[ t ] [ 3/5 gamma 2 2 5 sqrt / - sqrt pi * 2/5 gamma / - abs .0001 < ] unit-test
+[ t ] [ 3/5 gamma 2 2 5 sqrt / - sqrt pi * 2/5 gamma / almost= ] unit-test
 [ t ] [ -90000000000000000000000000000000000000000000 gammaln inf = ] unit-test
 [ t ] [ -1.5 gammaln inf = ] unit-test
 [ t ] [ -1 gammaln inf = ] unit-test
 [ t ] [ -0.5 gammaln inf = ] unit-test
 [ t ] [ 0 gammaln inf = ] unit-test
-[ t ] [ .5 gammaln .5724 - abs .0001 < ] unit-test
+[ t ] [ .5 gammaln 0.57236494 almost= ] unit-test
-[ t ] [ 1 gammaln 0 - abs .0001 < ] unit-test
+[ t ] [ 1 gammaln 0 almost= ] unit-test
-[ t ] [ 2 gammaln 0 - abs .0001 < ] unit-test
+[ t ] [ 2 gammaln 0 almost= ] unit-test
-[ t ] [ 3 gammaln 0.6931 - abs .0001 < ] unit-test
+[ t ] [ 3 gammaln 0.693147180 almost= ] unit-test
-[ t ] [ 11 gammaln 15.1044 - abs .0001 < ] unit-test
+[ t ] [ 11 gammaln 15.1044 almost= ] unit-test
-[ t ] [ 9000000000000000000000000000000000000000000 gammaln 8.811521863477754e+44 - abs 5.387515050969975e+30 < ] unit-test
+[ t ] [ 9000000000000000000000000000000000000000000 gammaln 8.811521863477754e+44 almost= ] unit-test
 
 [ 1 ] [ qi norm ] unit-test
 [ 1 ] [ qj norm ] unit-test
@@ -211,6 +211,10 @@ unit-test
 
 [ 1 ] [ { 1 } mean ] unit-test
 [ 3/2 ] [ { 1 2 } mean ] unit-test
+[ 0 ] [ { 0 0 0 } geometric-mean ] unit-test
+[ t ] [ { 2 2 2 2 } geometric-mean 2.0 almost= ] unit-test
+[ 1 ] [ { 1 1 1 } geometric-mean ] unit-test
+[ 1/3 ] [ { 1 1 1 } harmonic-mean ] unit-test
 
 [ 0 ] [ { 1 } range ] unit-test
 [ 89 ] [ { 1 2 30 90 } range ] unit-test

contrib/math/utils.factor

@@ -1,5 +1,5 @@
 IN: math-contrib
-USING: errors kernel sequences math ;
+USING: errors kernel sequences math sequences-internals namespaces arrays ;
 
 : deg>rad pi * 180 / ; inline
 : rad>deg 180 * pi / ; inline
@@ -26,8 +26,101 @@ USING: errors kernel sequences math ;
         -rot (^mod)
     ] if ; foldable
 
+: powers ( n x -- { 1 x x^2 x^3 ... } )
+    #! Output sequence has n elements.
+    <array> 1 [ * ] accumulate ;
+
 : ** ( u v -- u*v' ) conjugate * ; inline
 
 : c. ( v v -- x )
     #! Complex inner product.
     0 [ ** + ] 2reduce ;
+
+: sum ( v -- n ) 0 [ + ] reduce ;
+: product ( v -- n ) 1 [ * ] reduce ;
+
+: proj ( u v -- w )
+    #! Orthogonal projection of u onto v.
+    [ [ v. ] keep norm-sq v/n ] keep n*v ;
+
+: minmax ( seq -- min max )
+    #! find the min and max of a seq in one pass
+    1./0. -1./0. rot [ dup pick max -rot nip pick min -rot nip ] each ;
+
+: absminmax ( seq -- min max )
+    #! find the absolute values of the min and max of a seq in one pass
+    minmax 2dup [ abs ] 2apply > [ swap ] when ;
+
+SYMBOL: almost=-precision .000001 almost=-precision set
+: almost= ( a b -- bool )
+    2dup - abs almost=-precision get < [
+            2drop t
+        ] [
+            2array absminmax dup almost=-precision get * >r - abs r>
+            dup 0 < [ >= ] [ <= ] if
+    ] if ;
+
+TUPLE: frange from step length ;
+
+C: frange ( from step to -- seq )
+    #! example: 0 .01 10 <frange> >array
+    >r pick - swap [ / ceiling 1+ ] keep -rot swapd r> 
+    [ set-frange-length ] keep
+    [ set-frange-step ] keep
+    [ set-frange-from ] keep ;
+
+: decrement-length ( frange -- )
+    [ frange-length 1- ] keep set-frange-length ;
+
+: <frange-no-endpt> ( from step length -- seq )
+    <frange> dup decrement-length ;
+
+M: frange length ( frange -- n )
+    frange-length ;
+
+: increment-start ( frange -- )
+    [ [ frange-from ] keep frange-step + ] keep set-frange-from ;
+
+: frange-range ( frange -- range )
+    [ frange-step ] keep frange-length 1- * ;
+
+M: frange nth ( n frange -- obj ) [ frange-step * ] keep frange-from + ;
+M: frange nth-unsafe ( n frange -- obj ) nth ;
+
+: nseq-swap ( a b seq -- seq )
+    #! swap indices a,b in seq
+    3dup [ nth ] keep swapd [ nth ] keep
+    >r >r rot r> r> swapd set-nth -rot set-nth ;
+
+! : pivot ( left right index seq -- )
+    ! [ nth ] keep [ nseq-swap ] 3keep ;
+
+SYMBOL: step-size .01 step-size set  ! base on arguments
+: (limit) ( count diff quot -- x quot )
+    pick 10 > [ "Not converging fast enough" throw ] when
+    [ call ] keep >r 2dup swap - 0 < [ "not converging" throw ] when
+    2dup almost= rot drop r>
+    swap [ step-size [ 2 / ] change rot 1+ -rot (limit) ] unless ;
+
+: limit ( quot -- x )
+    .1 step-size set [ call ] keep step-size [ 2 / ] change 0 -rot (limit) 2drop ;
+
+! take elements n at a time and apply the quotation, forming a new seq
+: group-map ( seq n quot -- seq )
+    pick length pick /
+    [ [ >r pick pick r> -rot pick over * [ + ] keep swap rot <slice> pick call
+    , ] repeat ] { } make 2nip nip ;
+
+: nths ( start n seq -- seq )
+    -rot pick length <frange-no-endpt> [ over nth ] map nip ;
+
+! take a set of every nth element and apply the quotation, forming a new seq
+! { 1 2 3 4 5 6 } 3 [ sum ] skip-map ->  { 1 4 } { 2 5 } { 3 6 } -> { 5 7 9 }
+: skip-map ( seq n quot -- seq )
+    pick length pick /mod 
+    0 = [ "seq length must be a multiple of n" throw ] unless
+    1 <= [ "seq must be 2n or longer" throw ] when 
+    over [ [ dup >r >r pick pick r> rot swapd nths over call , r> ] repeat ] { } make 2nip nip ;
+
+: nth-rand ( seq -- elem ) [ length random-int ] keep nth ;
+

contrib/parser-combinators/lazy-examples.factor

@@ -22,12 +22,10 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 IN: lazy-examples
 USE: lazy
-USE: stack
 USE: math
 USE: lists
-USE: combinators
+USE: parser-combinators
 USE: kernel
-USE: logic
 USE: sequences
 USE: namespaces
 
@@ -65,4 +63,4 @@ USE: namespaces
 
 : lprimes 2 lfrom sieve ;
 
-: first-ten-primes 10 lprimes ltake llist>list ;
+: first-ten-primes 10 lprimes ltake llist>list ;

contrib/parser-combinators/lazy.factor

@@ -228,7 +228,7 @@ DEFER: list>llist
 : lappend ( llist1 llist2 -- llist )
   #! Concatenate two lazy lists such that they appear to be one big
   #! lazy list.
-  2list list>llist lappend* ;
+  [ ] cons cons list>llist lappend* ;
 
 : leach ( llist quot -- )
   #! Call the quotation on each item in the lazy list. 
@@ -263,35 +263,3 @@ DEFER: list>llist
     drop lnil
   ] if ;
 
-! M: lcons nth lnth ;
-
-: test1 
-  [ 1 ] list>llist
-  [ 2 ] list>llist
-  2list
-  list>llist
-  lappend* ;
-
-: test2 
-  [ 1 2 ] list>llist
-  [ 3 4 ] list>llist
-  2list
-  list>llist
-  lappend* ;
-
-: test3
-  [ 1 2 3 ] list>llist
-  [ 4 5 6 ] list>llist
-  [ 7 8 9 ] list>llist
-  2list cons
-  list>llist
-  lappend* ;
-
-: test4
-  [ 1 2 3 4 5 ] list>llist
-  [ 2 mod 1 = ] lsubset ;
-
-: test5 lnil unit delay lunit [ lnil? not ] lsubset ;
-
-: test6 lnil unit delay lunit lappend* ;
-

contrib/parser-combinators/load.factor

@@ -0,0 +1,9 @@
+IN: scratchpad
+USING: kernel parser sequences words compiler ;
+
+{
+    "lazy"
+    "parser-combinators"
+    "lazy-examples"
+    "tests"
+} [ "/contrib/parser-combinators/" swap ".factor" append3 run-resource ] each

contrib/parser-combinators/parser-combinators.factor

@@ -20,14 +20,8 @@
 ! 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.
+USING: lazy kernel sequences strings lists math io ;
 IN: parser-combinators
-USE: lazy
-USE: kernel
-USE: sequences
-USE: strings
-USE: lists
-USE: math
-USE: io
 
 GENERIC: phead
 

contrib/parser-combinators/tests.factor

@@ -20,8 +20,8 @@
 ! 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.
+USING: kernel lazy test errors strings parser lists math sequences parser-combinators ;
 IN: scratchpad
-USING: kernel lazy parser-combinators test errors strings parser lists math sequences unparser ;
 
 ! Testing <&>
 [ [ [[ "cd" [[ "a" "b" ]] ]] ] ] [

contrib/postgresql/libpq.factor

@@ -0,0 +1,323 @@
+! See http://factor.sf.net/license.txt for BSD license.
+
+! adapted from libpq-fe.h version 7.4.7
+! tested on debian linux with postgresql 7.4.7
+
+IN: postgresql
+USING: alien ;
+
+! ConnSatusType
+: CONNECTION_OK 					HEX: 0 ; inline
+: CONNECTION_BAD					HEX: 1 ; inline
+: CONNECTION_STARTED				HEX: 2 ; inline
+: CONNECTION_MADE					HEX: 3 ; inline
+: CONNECTION_AWAITING_RESPONSE		HEX: 4 ; inline
+: CONNECTION_AUTH_OK				HEX: 5 ; inline
+: CONNECTION_SETENV					HEX: 6 ; inline
+: CONNECTION_SSL_STARTUP			HEX: 7 ; inline
+: CONNECTION_NEEDED					HEX: 8 ; inline
+
+! PostgresPollingStatusType
+: PGRES_POLLING_FAILED 				HEX: 0 ; inline
+: PGRES_POLLING_READING 			HEX: 1 ; inline
+: PGRES_POLLING_WRITING 			HEX: 2 ; inline
+: PGRES_POLLING_OK 					HEX: 3 ; inline
+: PGRES_POLLING_ACTIVE 				HEX: 4 ; inline
+
+! ExecStatusType;
+: PGRES_EMPTY_QUERY 				HEX: 0 ; inline
+: PGRES_COMMAND_OK					HEX: 1 ; inline
+: PGRES_TUPLES_OK					HEX: 2 ; inline
+: PGRES_COPY_OUT					HEX: 3 ; inline
+: PGRES_COPY_IN						HEX: 4 ; inline
+: PGRES_BAD_RESPONSE				HEX: 5 ; inline
+: PGRES_NONFATAL_ERROR				HEX: 6 ; inline
+: PGRES_FATAL_ERROR					HEX: 7 ; inline
+
+! PGTransactionStatusType;
+: PQTRANS_IDLE						HEX: 0 ; inline
+: PQTRANS_ACTIVE					HEX: 1 ; inline
+: PQTRANS_INTRANS					HEX: 2 ; inline
+: PQTRANS_INERROR					HEX: 3 ; inline
+: PQTRANS_UNKNOWN					HEX: 4 ; inline
+
+! PGVerbosity;
+: PQERRORS_TERSE					HEX: 0 ; inline
+: PQERRORS_DEFAULT					HEX: 1 ; inline
+: PQERRORS_VERBOSE					HEX: 2 ; inline
+
+
+TYPEDEF: int ConnStatusType
+TYPEDEF: int ExecStatusType 
+TYPEDEF: int PostgresPollingStatusType
+TYPEDEF: int PGTransactionStatusType 
+TYPEDEF: int PGVerbosity 
+
+TYPEDEF: void* PGconn*
+TYPEDEF: void* PGresult*
+TYPEDEF: uint Oid
+TYPEDEF: uint* Oid*
+TYPEDEF: char pqbool
+TYPEDEF: void* PQconninfoOption*
+TYPEDEF: void* PGnotify*
+TYPEDEF: void* PQArgBlock*
+TYPEDEF: void* PQprintOpt*
+TYPEDEF: void* FILE*
+TYPEDEF: void* SSL*
+
+LIBRARY: postgresql
+
+
+! Exported functions of libpq
+! ===	in fe-connect.c ===
+
+! make a new client connection to the backend
+! Asynchronous (non-blocking)
+FUNCTION: PGconn* PQconnectStart ( char* conninfo ) ;
+FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
+
+! Synchronous (blocking)
+FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
+FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
+			 char* pgoptions, char* pgtty,
+			 char* dbName,
+			 char* login, char* pwd ) ;
+
+: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
+	f f PQsetdbLogin ;
+
+! close the current connection and free the PGconn data structure
+FUNCTION: void PQfinish ( PGconn* conn ) ;
+
+! get info about connection options known to PQconnectdb
+FUNCTION: PQconninfoOption* PQconndefaults ( ) ;
+
+! free the data structure returned by PQconndefaults()
+FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
+
+! 
+! close the current connection and restablish a new one with the same
+! parameters
+!
+! Asynchronous (non-blocking)
+FUNCTION: int	PQresetStart ( PGconn* conn ) ;
+FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
+
+! Synchronous (blocking)
+FUNCTION: void PQreset ( PGconn* conn ) ;
+
+! issue a cancel request
+FUNCTION: int	PQrequestCancel ( PGconn* conn ) ;
+
+! Accessor functions for PGconn objects
+FUNCTION: char* PQdb ( PGconn* conn ) ;
+FUNCTION: char* PQuser ( PGconn* conn ) ;
+FUNCTION: char* PQpass ( PGconn* conn ) ;
+FUNCTION: char* PQhost ( PGconn* conn ) ;
+FUNCTION: char* PQport ( PGconn* conn ) ;
+FUNCTION: char* PQtty ( PGconn* conn ) ;
+FUNCTION: char* PQoptions ( PGconn* conn ) ;
+FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
+FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
+FUNCTION: char* PQparameterStatus ( PGconn* conn,
+				  char* paramName ) ;
+FUNCTION: int	PQprotocolVersion ( PGconn* conn ) ;
+FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
+FUNCTION: int	PQsocket ( PGconn* conn ) ;
+FUNCTION: int	PQbackendPID ( PGconn* conn ) ;
+FUNCTION: int	PQclientEncoding ( PGconn* conn ) ;
+FUNCTION: int	PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
+
+! May not be compiled into libpq
+! Get the SSL structure associated with a connection
+FUNCTION: SSL* PQgetssl ( PGconn* conn ) ;
+
+
+! Set verbosity for PQerrorMessage and PQresultErrorMessage
+FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
+	PGVerbosity verbosity ) ;
+
+! Enable/disable tracing
+FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
+FUNCTION: void PQuntrace ( PGconn* conn ) ;
+
+! BROKEN
+! Function types for notice-handling callbacks
+! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res);
+! typedef void (*PQnoticeProcessor) (void *arg, char* message);
+! ALIAS: void* PQnoticeReceiver
+! ALIAS: void* PQnoticeProcessor
+
+! Override default notice handling routines
+! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
+					! PQnoticeReceiver proc,
+					! void* arg ) ;
+! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
+					! PQnoticeProcessor proc,
+					! void* arg ) ;
+! END BROKEN
+
+! === in fe-exec.c ===
+
+! Simple synchronous query
+FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
+FUNCTION: PGresult* PQexecParams ( PGconn* conn,
+			 char* command,
+			 int nParams,
+			 Oid* paramTypes,
+			 char** paramValues,
+			 int* paramLengths,
+			 int* paramFormats,
+			 int resultFormat ) ;
+FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
+			 char* stmtName,
+			 int nParams,
+			 char** paramValues,
+			 int* paramLengths,
+			 int* paramFormats,
+			 int resultFormat ) ;
+
+! Interface for multiple-result or asynchronous queries
+FUNCTION: int	PQsendQuery ( PGconn* conn, char* query ) ;
+FUNCTION: int PQsendQueryParams ( PGconn* conn,
+				  char* command,
+				  int nParams,
+				  Oid* paramTypes,
+				  char** paramValues,
+				  int* paramLengths,
+				  int* paramFormats,
+				  int resultFormat ) ;
+FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
+				  char* stmtName,
+				  int nParams,
+				  char** paramValues,
+				  int *paramLengths,
+				  int *paramFormats,
+				  int resultFormat ) ;
+FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
+
+! Routines for managing an asynchronous query
+FUNCTION: int	PQisBusy ( PGconn* conn ) ;
+FUNCTION: int	PQconsumeInput ( PGconn* conn ) ;
+
+! LISTEN/NOTIFY support
+FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
+
+! Routines for copy in/out
+FUNCTION: int	PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int	PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
+FUNCTION: int	PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
+
+! Deprecated routines for copy in/out
+FUNCTION: int	PQgetline ( PGconn* conn, char* string, int length ) ;
+FUNCTION: int	PQputline ( PGconn* conn, char* string ) ;
+FUNCTION: int	PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
+FUNCTION: int	PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int	PQendcopy ( PGconn* conn ) ;
+
+! Set blocking/nonblocking connection to the backend
+FUNCTION: int	PQsetnonblocking ( PGconn* conn, int arg ) ;
+FUNCTION: int	PQisnonblocking ( PGconn* conn ) ;
+
+! Force the write buffer to be written (or at least try)
+FUNCTION: int	PQflush ( PGconn* conn ) ;
+
+! 
+! * "Fast path" interface --- not really recommended for application
+! * use
+!
+FUNCTION: PGresult* PQfn ( PGconn* conn,
+	 int fnid,
+	 int* result_buf,
+	 int* result_len,
+	 int result_is_int,
+	 PQArgBlock* args,
+	 int nargs ) ;
+
+! Accessor functions for PGresult objects
+FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
+FUNCTION: char* PQresStatus ( ExecStatusType status ) ;
+FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ;
+FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ;
+FUNCTION: int	PQntuples ( PGresult* res ) ;
+FUNCTION: int	PQnfields ( PGresult* res ) ;
+FUNCTION: int	PQbinaryTuples ( PGresult* res ) ;
+FUNCTION: char* PQfname ( PGresult* res, int field_num ) ;
+FUNCTION: int	PQfnumber ( PGresult* res, char* field_name ) ;
+FUNCTION: Oid	PQftable ( PGresult* res, int field_num ) ;
+FUNCTION: int	PQftablecol ( PGresult* res, int field_num ) ;
+FUNCTION: int	PQfformat ( PGresult* res, int field_num ) ;
+FUNCTION: Oid	PQftype ( PGresult* res, int field_num ) ;
+FUNCTION: int	PQfsize ( PGresult* res, int field_num ) ;
+FUNCTION: int	PQfmod ( PGresult* res, int field_num ) ;
+FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
+FUNCTION: char* PQoidStatus ( PGresult* res ) ;
+FUNCTION: Oid	PQoidValue ( PGresult* res ) ;
+FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
+FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: int	PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: int	PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
+
+! Delete a PGresult
+FUNCTION: void PQclear ( PGresult* res ) ;
+
+! For freeing other alloc'd results, such as PGnotify structs
+FUNCTION: void PQfreemem ( void* ptr ) ;
+
+! Exists for backward compatibility.
+: PQfreeNotify PQfreemem ;
+
+!
+! Make an empty PGresult with given status (some apps find this
+! useful). If conn is not NULL and status indicates an error, the
+! conn's errorMessage is copied.
+!
+FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status ) ;
+
+! Quoting strings before inclusion in queries.
+FUNCTION: size_t PQescapeString ( char* to, char* from, size_t length ) ;
+FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
+			  size_t* bytealen ) ;
+FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
+				size_t* retbuflen ) ;
+
+! === in fe-print.c ===
+
+FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ;
+
+! really old printing routines
+FUNCTION: void PQdisplayTuples ( PGresult* res,
+				FILE* fp,		
+				int fillAlign,
+				char* fieldSep,
+				int printHeader,
+				int quiet ) ;
+
+FUNCTION: void PQprintTuples ( PGresult* res,
+			  FILE* fout,		
+			  int printAttName,
+			  int terseOutput,	
+			  int width ) ;	
+						
+! === in fe-lobj.c ===
+
+! Large-object access routines
+FUNCTION: int	lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
+FUNCTION: int	lo_close ( PGconn* conn, int fd ) ;
+FUNCTION: int	lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int	lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int	lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
+FUNCTION: Oid	lo_creat ( PGconn* conn, int mode ) ;
+FUNCTION: int	lo_tell ( PGconn* conn, int fd ) ;
+FUNCTION: int	lo_unlink ( PGconn* conn, Oid lobjId ) ;
+FUNCTION: Oid	lo_import ( PGconn* conn, char* filename ) ;
+FUNCTION: int	lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
+
+! === in fe-misc.c ===
+
+! Determine length of multibyte encoded char at *s
+FUNCTION: int	PQmblen ( uchar* s, int encoding ) ;
+
+! Get encoding id from environment variable PGCLIENTENCODING
+FUNCTION: int	PQenv2encoding ( ) ;
+

contrib/postgresql/load.factor

@@ -1,14 +1,11 @@
-IN: postgresql
+IN: scratchpad
 USING: alien compiler kernel parser sequences words ;
 
-win32? [
+"postgresql" "libpq" add-simple-library
-	! PostgreSQL 7.5 will most likely support windows
-    ! "postgresql" "dll" "stdcall" add-library
-] [
-    "postgresql" "libpq.so" "cdecl" add-library
-] if
 
-[ "postgresql.factor" ]
+{
-[ "contrib/postgresql/" swap append run-file ] each
+    "libpq"
-
+    "postgresql"
-"postgresql" words [ try-compile ] each
+    "postgresql-test"
+    ! "private" ! Put your password in this file
+} [ "/contrib/postgresql/" swap ".factor" append3 run-resource ] each

contrib/postgresql/postgresql-test.factor

@@ -2,60 +2,32 @@
 ! Set username and password in  the 'connect' word.
 
 IN: postgresql-test
-USING: kernel postgresql alien errors io ;
+USING: kernel postgresql alien errors io prettyprint sequences namespaces ;
-
-
-: connect ( -- PGconn )
-	"localhost" "" "" "" "factor-test" "username" "password" PQsetdbLogin
-	dup PQstatus 0 =
-	[
-		"couldn't connect to database" throw
-	] unless ;
-
-! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK.
-! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
-
-: do-query ( PGconn query -- PGresult* )
-	PQexec
-	dup PQresultStatus PGRES_COMMAND_OK =
-	over PQresultStatus PGRES_TUPLES_OK =
-	or	
-	[
-		dup PQresultErrorMessage print
-		"query failed" throw
-	] unless ;
-
-! 
-: do-query-drop ( PGconn query -- PGresult * )
-	do-query PQclear ; ! PQclear frees libpq.so memory
-
-: do-query-drop-nofail ( PGconn query -- PGresult * )
-	[ do-query ]
-    catch
-	[
-		"non-fatal error, continuing" print
-		drop
-		PQclear ! clear memory
-	] when ;
 
 ! just a basic demo
-: run-test ( -- )
+: run-test ( host str str str db user pass -- )
-	connect
+    [
-	dup "drop table animal" do-query-drop-nofail
+	    "drop table animal" do-command
-	dup "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-query-drop-nofail
-	dup "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)" do-query-drop
-	dup "select * from animal where name = 'Mufasa'" do-query
-	dup PQntuples 1 = [ "...there can only be one Mufasa..." throw ] unless
 
-	dup 0 0 PQgetvalue print
+	    "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command
-	dup 0 1 PQgetvalue print
+	    "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)" do-command
-	dup 0 2 PQgetvalue print
+	    "select * from animal where name = 'Mufasa'" [ ] do-query
-	dup 0 3 PQgetvalue print
+	    "select * from animal where name = 'Mufasa'"
-	PQclear
+        [
-	dup "insert into animal (species, name, age) values ('lion', 'Simba', 1)" do-query-drop
+	        result>seq length 1 = [ "...there can only be one Mufasa..." throw ] unless
-	dup "select * from animal" do-query
+        ] do-query
-	! dup PQntuples >dec print
+	    "insert into animal (species, name, age) values ('lion', 'Simba', 1)" do-command
-	PQclear
+
-	PQfinish
+	    "select * from animal" 
-	;
+        [
+              "Animal table:" print
+              result>seq print-table
+        ] do-query
+
+        ! intentional errors
+        ! [ "select asdf from animal"
+        ! [ ] do-query ] catch [ "caught: " write print ] when*
+        ! "select asdf from animal" [ ] do-query 
+        ! "aofijweafew" do-command
+    ] with-postgres-catch ;
 

contrib/postgresql/postgresql.factor

@@ -4,324 +4,60 @@
 ! tested on debian linux with postgresql 7.4.7
 
 IN: postgresql
-USING: alien ;
+USING: kernel alien errors io prettyprint sequences lists namespaces arrays math ;
+SYMBOL: postgres-conn
+SYMBOL: query-res
 
-! ConnSatusType
+: connect-postgres ( host port pgopts pgtty db user pass -- conn )
-: CONNECTION_OK 					HEX: 0 ; inline
+    PQsetdbLogin
-: CONNECTION_BAD					HEX: 1 ; inline
+    dup PQstatus 0 = [ "couldn't connect to database" throw ] unless ;
-: CONNECTION_STARTED				HEX: 2 ; inline
-: CONNECTION_MADE					HEX: 3 ; inline
-: CONNECTION_AWAITING_RESPONSE		HEX: 4 ; inline
-: CONNECTION_AUTH_OK				HEX: 5 ; inline
-: CONNECTION_SETENV					HEX: 6 ; inline
-: CONNECTION_SSL_STARTUP			HEX: 7 ; inline
-: CONNECTION_NEEDED					HEX: 8 ; inline
 
-! PostgresPollingStatusType
+: with-postgres ( host port pgopts pgtty db user pass quot -- )
-: PGRES_POLLING_FAILED 				HEX: 0 ; inline
+    [ >r connect-postgres postgres-conn set r>
-: PGRES_POLLING_READING 			HEX: 1 ; inline
+    [ postgres-conn get PQfinish ] cleanup ] with-scope ; inline
-: PGRES_POLLING_WRITING 			HEX: 2 ; inline
-: PGRES_POLLING_OK 					HEX: 3 ; inline
-: PGRES_POLLING_ACTIVE 				HEX: 4 ; inline
 
-! ExecStatusType;
+: with-postgres-catch ( host port pgopts pgtty db user pass quot -- )
-: PGRES_EMPTY_QUERY 				HEX: 0 ; inline
+    [ with-postgres ] catch [ "caught: " write print ] when* ;
-: PGRES_COMMAND_OK					HEX: 1 ; inline
-: PGRES_TUPLES_OK					HEX: 2 ; inline
-: PGRES_COPY_OUT					HEX: 3 ; inline
-: PGRES_COPY_IN						HEX: 4 ; inline
-: PGRES_BAD_RESPONSE				HEX: 5 ; inline
-: PGRES_NONFATAL_ERROR				HEX: 6 ; inline
-: PGRES_FATAL_ERROR					HEX: 7 ; inline
 
-! PGTransactionStatusType;
+: test-connection ( host port pgopts pgtty db user pass -- bool )
-: PQTRANS_IDLE						HEX: 0 ; inline
+    [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ;
-: PQTRANS_ACTIVE					HEX: 1 ; inline
-: PQTRANS_INTRANS					HEX: 2 ; inline
-: PQTRANS_INERROR					HEX: 3 ; inline
-: PQTRANS_UNKNOWN					HEX: 4 ; inline
 
-! PGVerbosity;
+: postgres-error ( ret -- ret )
-: PQERRORS_TERSE					HEX: 0 ; inline
+    dup 0 = [ PQresultErrorMessage throw ] when ;
-: PQERRORS_DEFAULT					HEX: 1 ; inline
+
-: PQERRORS_VERBOSE					HEX: 2 ; inline
+: (do-query) ( PGconn query -- PGresult* )
+    ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
+    ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
+    PQexec
+    dup PQresultStatus PGRES_COMMAND_OK =
+    over PQresultStatus PGRES_TUPLES_OK =
+    or [
+        [ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw
+    ] unless ;
+
+: (do-command) ( PGconn query -- PGresult* )
+    [ (do-query) ] catch
+    [
+        swap
+        "non-fatal error: " print
+        "\tQuery: " write "'" write write "'" print
+        "\t" write print
+    ] when* drop ;
+
+: do-command ( str -- )
+    unit \ (do-command) add postgres-conn get swap call ;
+
+: prepare ( str quot word -- quot )
+    rot unit swap append swap append postgres-conn get swap ;
+
+: do-query ( str quot -- )
+    [ (do-query) query-res set ] prepare catch [ rethrow ] [ query-res get PQclear ] if* ;
+
+: result>seq ( -- )
+    query-res get [ PQnfields ] keep PQntuples
+    [ [ over [ [ 2dup query-res get -rot PQgetvalue , ] repeat ] { } make , ] repeat ] { } make nip ;
+
+: print-table ( seq -- )
+    [ [ "\t" append write ] each "\n" write ] each ;
 
 
-TYPEDEF: int ConnStatusType
-TYPEDEF: int ExecStatusType 
-TYPEDEF: int PostgresPollingStatusType
-TYPEDEF: int PGTransactionStatusType 
-TYPEDEF: int PGVerbosity 
-
-TYPEDEF: void* PGconn*
-TYPEDEF: void* PGresult*
-TYPEDEF: uint Oid
-TYPEDEF: uint* Oid*
-TYPEDEF: char pqbool
-TYPEDEF: void* PQconninfoOption*
-TYPEDEF: void* PGnotify*
-TYPEDEF: void* PQArgBlock*
-TYPEDEF: void* PQprintOpt*
-TYPEDEF: void* FILE*
-TYPEDEF: void* SSL*
-
-LIBRARY: postgresql
-
-
-! Exported functions of libpq
-! ===	in fe-connect.c ===
-
-! make a new client connection to the backend
-! Asynchronous (non-blocking)
-FUNCTION: PGconn* PQconnectStart ( char* conninfo ) ;
-FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
-
-! Synchronous (blocking)
-FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
-FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
-			 char* pgoptions, char* pgtty,
-			 char* dbName,
-			 char* login, char* pwd ) ;
-
-! An alias without the login/password, defined as the following in the .h file
-! #define PQsetdb(M_PGHOST,M_PGPORT,M_PGOPT,M_PGTTY,M_DBNAME)  \
-	! PQsetdbLogin(M_PGHOST, M_PGPORT, M_PGOPT, M_PGTTY, M_DBNAME, NULL, NULL)
-
-: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
-	f f PQsetdbLogin ;
-
-! close the current connection and free the PGconn data structure
-FUNCTION: void PQfinish ( PGconn* conn ) ;
-
-! get info about connection options known to PQconnectdb
-FUNCTION: PQconninfoOption* PQconndefaults ( ) ;
-
-! free the data structure returned by PQconndefaults()
-FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
-
-! 
-! close the current connection and restablish a new one with the same
-! parameters
-!
-! Asynchronous (non-blocking)
-FUNCTION: int	PQresetStart ( PGconn* conn ) ;
-FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
-
-! Synchronous (blocking)
-FUNCTION: void PQreset ( PGconn* conn ) ;
-
-! issue a cancel request
-FUNCTION: int	PQrequestCancel ( PGconn* conn ) ;
-
-! Accessor functions for PGconn objects
-FUNCTION: char* PQdb ( PGconn* conn ) ;
-FUNCTION: char* PQuser ( PGconn* conn ) ;
-FUNCTION: char* PQpass ( PGconn* conn ) ;
-FUNCTION: char* PQhost ( PGconn* conn ) ;
-FUNCTION: char* PQport ( PGconn* conn ) ;
-FUNCTION: char* PQtty ( PGconn* conn ) ;
-FUNCTION: char* PQoptions ( PGconn* conn ) ;
-FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
-FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
-FUNCTION: char* PQparameterStatus ( PGconn* conn,
-				  char* paramName ) ;
-FUNCTION: int	PQprotocolVersion ( PGconn* conn ) ;
-FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
-FUNCTION: int	PQsocket ( PGconn* conn ) ;
-FUNCTION: int	PQbackendPID ( PGconn* conn ) ;
-FUNCTION: int	PQclientEncoding ( PGconn* conn ) ;
-FUNCTION: int	PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
-
-! May not be compiled into libpq
-! Get the SSL structure associated with a connection
-FUNCTION: SSL* PQgetssl ( PGconn* conn ) ;
-
-
-! Set verbosity for PQerrorMessage and PQresultErrorMessage
-FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
-	PGVerbosity verbosity ) ;
-
-! Enable/disable tracing
-FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
-FUNCTION: void PQuntrace ( PGconn* conn ) ;
-
-! BROKEN
-! Function types for notice-handling callbacks
-! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res);
-! typedef void (*PQnoticeProcessor) (void *arg, char* message);
-! ALIAS: void* PQnoticeReceiver
-! ALIAS: void* PQnoticeProcessor
-
-! Override default notice handling routines
-! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
-					! PQnoticeReceiver proc,
-					! void* arg ) ;
-! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
-					! PQnoticeProcessor proc,
-					! void* arg ) ;
-! END BROKEN
-
-! === in fe-exec.c ===
-
-! Simple synchronous query
-FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
-FUNCTION: PGresult* PQexecParams ( PGconn* conn,
-			 char* command,
-			 int nParams,
-			 Oid* paramTypes,
-			 char** paramValues,
-			 int* paramLengths,
-			 int* paramFormats,
-			 int resultFormat ) ;
-FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
-			 char* stmtName,
-			 int nParams,
-			 char** paramValues,
-			 int* paramLengths,
-			 int* paramFormats,
-			 int resultFormat ) ;
-
-! Interface for multiple-result or asynchronous queries
-FUNCTION: int	PQsendQuery ( PGconn* conn, char* query ) ;
-FUNCTION: int PQsendQueryParams ( PGconn* conn,
-				  char* command,
-				  int nParams,
-				  Oid* paramTypes,
-				  char** paramValues,
-				  int* paramLengths,
-				  int* paramFormats,
-				  int resultFormat ) ;
-FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
-				  char* stmtName,
-				  int nParams,
-				  char** paramValues,
-				  int *paramLengths,
-				  int *paramFormats,
-				  int resultFormat ) ;
-FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
-
-! Routines for managing an asynchronous query
-FUNCTION: int	PQisBusy ( PGconn* conn ) ;
-FUNCTION: int	PQconsumeInput ( PGconn* conn ) ;
-
-! LISTEN/NOTIFY support
-FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
-
-! Routines for copy in/out
-FUNCTION: int	PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
-FUNCTION: int	PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
-FUNCTION: int	PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
-
-! Deprecated routines for copy in/out
-FUNCTION: int	PQgetline ( PGconn* conn, char* string, int length ) ;
-FUNCTION: int	PQputline ( PGconn* conn, char* string ) ;
-FUNCTION: int	PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
-FUNCTION: int	PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
-FUNCTION: int	PQendcopy ( PGconn* conn ) ;
-
-! Set blocking/nonblocking connection to the backend
-FUNCTION: int	PQsetnonblocking ( PGconn* conn, int arg ) ;
-FUNCTION: int	PQisnonblocking ( PGconn* conn ) ;
-
-! Force the write buffer to be written (or at least try)
-FUNCTION: int	PQflush ( PGconn* conn ) ;
-
-! 
-! * "Fast path" interface --- not really recommended for application
-! * use
-!
-FUNCTION: PGresult* PQfn ( PGconn* conn,
-	 int fnid,
-	 int* result_buf,
-	 int* result_len,
-	 int result_is_int,
-	 PQArgBlock* args,
-	 int nargs ) ;
-
-! Accessor functions for PGresult objects
-FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
-FUNCTION: char* PQresStatus ( ExecStatusType status ) ;
-FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ;
-FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ;
-FUNCTION: int	PQntuples ( PGresult* res ) ;
-FUNCTION: int	PQnfields ( PGresult* res ) ;
-FUNCTION: int	PQbinaryTuples ( PGresult* res ) ;
-FUNCTION: char* PQfname ( PGresult* res, int field_num ) ;
-FUNCTION: int	PQfnumber ( PGresult* res, char* field_name ) ;
-FUNCTION: Oid	PQftable ( PGresult* res, int field_num ) ;
-FUNCTION: int	PQftablecol ( PGresult* res, int field_num ) ;
-FUNCTION: int	PQfformat ( PGresult* res, int field_num ) ;
-FUNCTION: Oid	PQftype ( PGresult* res, int field_num ) ;
-FUNCTION: int	PQfsize ( PGresult* res, int field_num ) ;
-FUNCTION: int	PQfmod ( PGresult* res, int field_num ) ;
-FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
-FUNCTION: char* PQoidStatus ( PGresult* res ) ;
-FUNCTION: Oid	PQoidValue ( PGresult* res ) ;
-FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
-FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
-FUNCTION: int	PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
-FUNCTION: int	PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
-
-! Delete a PGresult
-FUNCTION: void PQclear ( PGresult* res ) ;
-
-! For freeing other alloc'd results, such as PGnotify structs
-FUNCTION: void PQfreemem ( void* ptr ) ;
-
-! Exists for backward compatibility.
-: PQfreeNotify PQfreemem ;
-
-!
-! Make an empty PGresult with given status (some apps find this
-! useful). If conn is not NULL and status indicates an error, the
-! conn's errorMessage is copied.
-!
-FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status ) ;
-
-! Quoting strings before inclusion in queries.
-FUNCTION: size_t PQescapeString ( char* to, char* from, size_t length ) ;
-FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
-			  size_t* bytealen ) ;
-FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
-				size_t* retbuflen ) ;
-
-! === in fe-print.c ===
-
-FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ;
-
-! really old printing routines
-FUNCTION: void PQdisplayTuples ( PGresult* res,
-				FILE* fp,		
-				int fillAlign,
-				char* fieldSep,
-				int printHeader,
-				int quiet ) ;
-
-FUNCTION: void PQprintTuples ( PGresult* res,
-			  FILE* fout,		
-			  int printAttName,
-			  int terseOutput,	
-			  int width ) ;	
-						
-! === in fe-lobj.c ===
-
-! Large-object access routines
-FUNCTION: int	lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
-FUNCTION: int	lo_close ( PGconn* conn, int fd ) ;
-FUNCTION: int	lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
-FUNCTION: int	lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
-FUNCTION: int	lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
-FUNCTION: Oid	lo_creat ( PGconn* conn, int mode ) ;
-FUNCTION: int	lo_tell ( PGconn* conn, int fd ) ;
-FUNCTION: int	lo_unlink ( PGconn* conn, Oid lobjId ) ;
-FUNCTION: Oid	lo_import ( PGconn* conn, char* filename ) ;
-FUNCTION: int	lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
-
-! === in fe-misc.c ===
-
-! Determine length of multibyte encoded char at *s
-FUNCTION: int	PQmblen ( uchar* s, int encoding ) ;
-
-! Get encoding id from environment variable PGCLIENTENCODING
-FUNCTION: int	PQenv2encoding ( ) ;
-

contrib/random-tester/load.factor

@@ -0,0 +1,8 @@
+USING: kernel parser sequences words compiler ;
+IN: scratchpad
+
+{
+    "utils"
+    "random"
+    "random-tester"
+} [ "/contrib/random-tester/" swap ".factor" append3 run-resource ] each

contrib/random-tester/random-tester.factor

@@ -0,0 +1,561 @@
+USING: kernel math sequences namespaces errors hashtables words arrays parser
+       compiler syntax lists io ;
+USING: inspector prettyprint ;
+USING: optimizer compiler-frontend compiler-backend inference ;
+IN: random-tester
+
+! Math words are listed in arrays according to the number of arguments,
+! if they can throw exceptions or not, and what they output.
+! integer>x -> takes an integer, outputs anything
+! integer>integer -> always outputs an integer
+
+! Math vocabulary words
+: math-1 ( -- seq )
+    {
+        1+ 1- >bignum >digit >fixnum abs absq arg 
+        bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
+        cosh cot coth denominator double>bits exp float>bits floor imaginary
+        log neg next-power-of-2 numerator quadrant real sec
+        sech sgn sin sinh sq sqrt tan tanh truncate 
+    } ;
+: math-throw-1
+    {
+        recip log2
+        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
+    } ;
+
+: integer>x
+    {
+        1+ 1- >bignum >digit >fixnum abs absq arg 
+        bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech
+        cosh cot coth denominator double>bits exp float>bits floor imaginary
+        log neg next-power-of-2 numerator quadrant real sec
+        sech sgn sin sinh sq sqrt tan tanh truncate 
+    } ;
+
+: ratio>x
+    {
+        1+ 1- >bignum >digit >fixnum abs absq arg 
+        cis conjugate cos cosec cosech
+        cosh cot coth double>bits exp float>bits floor imaginary
+        log neg next-power-of-2 quadrant real sec
+        sech sgn sin sinh sq sqrt tan tanh truncate 
+    } ;
+
+! ceiling, truncate, floor eventually
+: float>x ( float -- x )
+    {
+        1+ 1- >bignum >digit >fixnum abs absq arg 
+        ceiling cis conjugate cos cosec cosech
+        cosh cot coth double>bits exp float>bits floor imaginary
+        log neg next-power-of-2 quadrant real sec
+        sech sgn sin sinh sq sqrt tan tanh truncate
+    } ;
+
+: complex>x
+    {
+        1+ 1- abs absq arg 
+        conjugate cos cosec cosech
+        cosh cot coth exp imaginary
+        log neg quadrant real
+        sec sech sin sinh sq sqrt tan tanh 
+    } ;
+
+: integer>x-throw
+    {
+        recip log2
+        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
+    } ;
+: ratio>x-throw
+    {
+        recip
+        asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh
+    } ;
+
+: integer>integer
+    {
+        1+ 1- >bignum >digit >fixnum abs absq 
+        bitnot ceiling conjugate 
+        denominator double>bits float>bits floor imaginary
+        neg next-power-of-2 numerator quadrant
+        real sgn sq truncate 
+    } ;
+
+: ratio>ratio { 1+ 1- >digit abs absq conjugate neg real sq } ;
+
+: float>float
+    {
+        1+ 1- >digit abs absq arg ceiling
+        conjugate cos cosec cosech
+        cosh cot coth exp floor neg real sec
+        sech sin sinh sq tan tanh truncate
+    } ;
+
+: complex>complex
+    {
+        1+ 1- abs absq arg 
+        conjugate cosec cosech
+        cosh cot coth exp 
+        log neg quadrant 
+        sech sin sinh sq sqrt tanh 
+    } ;
+
+
+: math-2 ( -- seq )
+    { * + - /f max min polar> bitand bitor bitxor align } ;
+: math-throw-2 ( -- seq ) { / /i mod rem } ;
+
+: 2integer>x ( n n -- x ) ( -- word )
+    { * + - /f max min polar> bitand bitor bitxor align } ;
+: 2ratio>x ( r r -- x ) ( -- word ) { * + - /f max min polar> } ;
+: 2float>x ( f f -- x ) ( -- word ) { * + - /f max min polar> } ;
+: 2complex>x ( c c -- x ) ( -- word ) { * + - /f } ;
+
+: 2integer>integer ( n n -- n ) ( -- word )
+    { * + - max min bitand bitor bitxor align } ;
+: 2ratio>ratio ( r r -- r ) ( -- word ) { * + - max min } ;
+: 2float>float ( f f -- f ) ( -- word ) { * + - /f max min } ;
+: 2complex>complex ( c c -- c ) ( -- word ) { * + - /f } ;
+
+: (random-integer-quotation) ( -- quot )
+    random-integer ,
+    max-length random-int
+    [
+        [
+            [ integer>integer nth-rand , ]
+            [ random-integer , 2integer>integer nth-rand , ]
+        ] do-one
+    ] times ;
+: random-integer-quotation ( -- quot )
+    [
+        (random-integer-quotation)
+    ] [ ] make ;
+
+: random-integer-quotation-1 ( -- quot )
+    [
+        (random-integer-quotation) 2integer>integer nth-rand ,
+    ] [ ] make ;
+
+: (random-ratio-quotation) ( -- quot )
+        random-ratio ,
+        max-length random-int
+        [
+            [
+                [ ratio>ratio nth-rand , ]
+                [ random-ratio , 2ratio>ratio nth-rand , ]
+            ] do-one
+        ] times ;
+
+: random-ratio-quotation ( -- quot )
+    [
+        (random-ratio-quotation)
+    ] [ ] make ;
+
+: random-ratio-quotation-1 ( -- quot )
+    [
+        (random-ratio-quotation) 2ratio>ratio nth-rand ,
+    ] [ ] make ;
+
+: random-float-quotation ( -- quot )
+    [
+        random-float ,
+        max-length random-int
+        [
+            [
+                [ float>float nth-rand , ]
+                [ random-float , 2float>float nth-rand , ]
+            ] do-one
+        ] times
+    ] [ ] make ;
+
+: random-complex-quotation ( -- quot )
+    [
+        random-complex ,
+        max-length random-int
+        [
+            [
+                [ complex>complex nth-rand , ]
+                [ random-complex , 2complex>complex nth-rand , ]
+            ] do-one
+        ] times
+    ] [ ] make ;
+
+
+SYMBOL: last-quot
+SYMBOL: first-arg
+: runtime-check
+    [ last-quot set ] keep
+    [ call ] keep
+    call
+    ! 2dup swap unparse write " " write unparse print
+    = [ last-quot get . "problem in runtime" throw ] unless ;
+
+: runtime-check-1
+    [ last-quot set first-arg set ] 2keep
+    [ call ] 2keep
+    call
+    2dup swap unparse write " " write unparse print
+    = [ "problem in runtime" throw ] unless ;
+
+: interp-runtime-check ( quot -- )
+    dup . 
+    ! 0 [ tan tan ] compile-1 drop
+    [ last-quot set ] keep
+    [ call ] keep compile-1
+    2dup swap unparse write " " write unparse print
+    = [ "problem in math" throw ] unless ;
+
+: interp-compile-check-1 ( x quot -- )
+    .s flush
+    [ last-quot set ] keep
+    [ call ] 2keep compile-1
+    2dup swap unparse write " " write unparse print
+    = [ "problem in math" throw ] unless ;
+
+: interp-compile-check-2 ( x quot -- )
+    .s flush
+    [ last-quot set ] keep
+    [ call ] 3keep compile-1
+    2dup swap unparse write " " write unparse print
+    = [ "problem in math" throw ] unless ;
+
+: interp-compile-check* ( quot -- )
+    dup .
+    >r 100 200 300 400 r> [ call 4array ] keep
+    >r 100 200 300 400 r> compile-1 4array
+    = [ "problem found! (compile-check*)" throw ] unless ;
+
+: interp-compile-check-catch ( quot -- )
+    dup .
+    [ last-quot set ] keep
+    [ catch [ "caught: " write dup print-error ] when* ] keep 
+    [ compile-1 ] catch [ nip "caught: " write dup print-error ] when*
+    = [ "problem in math" throw ] unless ;
+
+: update-math-xt ( -- )
+    math-1 [ update-xt ] each
+    math-throw-1 [ update-xt ] each
+    math-2 [ update-xt ] each
+    math-throw-2 [ update-xt ] each ;
+
+: update-xt-check ( quot -- )
+    update-math-xt
+    dup .
+    [ last-quot set ] keep
+    [ call ] keep
+    [ last car update-xt ] keep call
+    2dup swap unparse write " " write unparse print
+    = [ "update-xt problem" throw ] unless ;
+
+
+
+
+! 1-arg tests
+    
+: random-integer>x-quot random-integer integer>x nth-rand unit cons ;
+: random-ratio>x-quot ( -- ) random-ratio ratio>x nth-rand unit cons ;
+: random-float>x-quot ( -- ) random-float float>x nth-rand unit cons ;
+: random-complex>x-quot ( -- ) random-complex complex>x nth-rand unit cons ;
+
+: test-integer>x ( -- ) random-integer>x-quot interp-runtime-check ;
+: test-ratio>x ( -- ) random-ratio>x-quot interp-runtime-check ;
+: test-float>x ( -- ) random-float>x-quot interp-runtime-check ;
+: test-complex>x ( -- ) random-complex>x-quot interp-runtime-check ;
+
+: test-integer>x-runtime ( -- ) random-integer>x-quot runtime-check ;
+: test-integer>x-1-runtime ( -- ) random-integer>x-quot runtime-check ;
+
+: test-integer>x-1 ( -- )
+    random-integer integer>x nth-rand unit interp-compile-check-1 ;
+: test-ratio>x-1 ( -- )
+    random-ratio ratio>x nth-rand unit interp-compile-check-1 ;
+: test-float>x-1 ( -- )
+    random-float float>x nth-rand unit interp-compile-check-1 ;
+: test-complex>x-1 ( -- )
+    random-complex complex>x nth-rand unit interp-compile-check-1 ;
+
+: test-integer>x-throws ( -- )
+    random-integer integer>x-throw nth-rand unit cons interp-compile-check-catch ;
+: test-ratio>x-throws ( -- )
+    random-ratio ratio>x-throw nth-rand unit cons interp-compile-check-catch ;
+
+: test-update-xt ( -- )
+    random-integer random-integer 2integer>x nth-rand unit swons swons update-xt-check ;
+
+! 2-arg tests
+: test-2integer>x ( -- )
+    random-integer random-integer 2integer>x nth-rand unit swons swons interp-runtime-check ;
+
+: test-2ratio>x ( -- )
+    random-ratio random-ratio 2ratio>x nth-rand unit swons swons interp-runtime-check ;
+
+: test-2float>x ( -- )
+    random-float random-float 2float>x nth-rand unit swons swons interp-runtime-check ;
+
+: test-2complex>x ( -- )
+    random-complex random-complex 2complex>x nth-rand unit swons swons interp-runtime-check ;
+
+
+: test-2random>x ( -- )
+    random-number random-number math-2 nth-rand unit swons swons interp-runtime-check ;
+
+
+
+: test-2integer>x-2 ( -- )
+    random-integer random-integer 2integer>x nth-rand unit interp-compile-check-2 ;
+
+: test-2ratio>x-2 ( -- )
+    random-ratio random-ratio 2ratio>x nth-rand unit interp-compile-check-2 ;
+
+: test-2float>x-2 ( -- )
+    random-float random-float 2float>x nth-rand unit interp-compile-check-2 ;
+
+: test-2complex>x-2 ( -- )
+    random-complex random-complex 2complex>x nth-rand unit interp-compile-check-2 ;
+
+
+! : test-2integer>x-1 ( -- )
+    ! random-integer random-integer-quotation-1 interp-compile-check-1 ;
+
+
+: test-2integer>x-throws ( -- )
+    [
+        random-integer , random-integer ,
+        math-throw-2 nth-rand ,
+    ] [ ] make interp-compile-check-catch ;
+
+: test-^-shift ( -- )
+    [
+        100 random-int 50 - ,
+        100 random-int 50 - ,
+        { ^ shift } nth-rand ,
+    ] [ ] make interp-compile-check-catch ;
+
+: test-^-ratio ( -- )
+    [
+        random-ratio , random-ratio , \ ^ ,
+    ] [ ] make interp-compile-check-catch ;
+
+: test-math {
+        ! test-integer>x 
+        ! test-ratio>x 
+        ! test-float>x 
+        ! test-complex>x 
+
+        ! test-integer>x-1
+        ! test-ratio>x-1
+        ! test-float>x-1
+        ! test-complex>x-1
+
+        ! test-integer>x-throws
+        ! test-ratio>x-throws
+
+        ! ! test-update-xt
+        ! test-2integer>x
+        ! test-2ratio>x
+        ! test-2float>x
+        ! test-2complex>x
+        test-2integer>x-2
+        test-2ratio>x-2
+        test-2float>x-2
+        test-2complex>x-2
+        ! ! test-2integer>x-1
+        ! test-2integer>x-throws
+        ! test-^-shift
+        ! test-^-ratio
+    } nth-rand unit call ;
+
+
+! Boolean logic tests
+: logic-0 ( -- seq )
+    { unix? win32? bootstrapping? f t } ;
+
+: logic-1 ( -- seq )
+    {
+        not tuple? float? integer? complex? ratio? continuation? wrapper?
+        number?  rational? bignum? fixnum? float? primitive? symbol?
+        compound? real?
+    } ;
+!  odd? even? power-of-2?
+: logic-2 ( -- seq ) { < > <= >= number= = eq?  and or } ;
+: logic-3 ( -- seq ) { between? } ;
+: complex-logic-2 ( -- seq ) { number= = eq? and or } ;
+
+: logic-0-test ( -- ) logic-0 nth-rand unit interp-runtime-check ;
+
+: integer-logic-1-test ( -- )
+    [
+        random-integer , logic-1 nth-rand ,
+    ] [ ] make interp-runtime-check ;
+
+: ratio-logic-1-test ( -- )
+    [
+        random-ratio , logic-1 nth-rand ,
+    ] [ ] make interp-runtime-check ;
+
+: float-logic-1-test ( -- )
+    [
+        random-float , logic-1 nth-rand ,
+    ] [ ] make interp-runtime-check ;
+
+: complex-logic-1-test ( -- )
+    [
+        random-complex , logic-1 nth-rand ,
+    ] [ ] make interp-runtime-check ;
+
+
+: integer-logic-2-test ( -- )
+    [
+        random-integer , random-integer , logic-2 nth-rand , 
+    ] [ ] make interp-runtime-check ;
+
+: ratio-logic-2-test ( -- )
+    [
+        random-ratio , random-ratio , logic-2 nth-rand , 
+    ] [ ] make interp-runtime-check ;
+
+: float-logic-2-test ( -- )
+    [
+        random-float , random-float , logic-2 nth-rand , 
+    ] [ ] make interp-runtime-check ;
+
+: complex-logic-2-test ( -- )
+    [
+        random-complex , random-complex , complex-logic-2 nth-rand , 
+    ] [ ] make interp-runtime-check ;
+
+
+: string-to-math-test ( -- )
+    [
+        {
+        [ random-integer , \ number>string , ]
+        [ random-integer , \ number>string , \ string>number , ]
+        } do-one
+    ] [ ] make interp-runtime-check ;
+
+
+: test-float?-when
+    [
+        random-number , \ dup , \ float? , float>x nth-rand unit , \ when ,
+    ] [ ] make interp-runtime-check ;
+
+: test-integer?-when-1
+    random-float [
+        \ dup , \ float? , float>x nth-rand unit , \ when ,
+    ] [ ] make interp-compile-check-1 ;
+
+: test-ratio?-when-1
+    random-ratio [
+        \ dup , \ ratio? , ratio>x nth-rand unit , \ when ,
+    ] [ ] make interp-compile-check-1 ;
+
+: test-float?-when-1
+    random-float [
+        \ dup , \ float? , float>x nth-rand unit , \ when ,
+    ] [ ] make interp-compile-check-1 ;
+
+: test-complex?-when-1
+    random-complex [
+        \ dup , \ complex? , complex>x nth-rand unit , \ when ,
+    ] [ ] make interp-compile-check-1 ;
+
+: stack-identity-0
+    H{
+        { 1 drop }
+        { 1000000000000000000000000001 drop }
+        { -11111111111111111111111111 drop }
+        { -1 drop }
+        { 1.203 drop }
+        { -1.203 drop }
+        { "asdf" drop }
+     } ; inline
+: stack-identity-1
+    H{
+        { dup drop }
+        { >r r> }
+     } ; inline
+: stack-identity-2
+    H{
+        { swap swap }
+        { over drop }
+        { dupd nip }
+        { 2dup 2drop }
+     } ; inline
+: stack-identity-3
+    H{
+        { rot -rot }
+        { pick drop }
+        { 3dup 3drop }
+     } ; inline
+: stack-identity-4
+    H{
+        { 2swap 2swap }
+     } ; inline
+
+: get-stack-identity-table ( n -- hash )
+    {
+        { [ dup 0 = ] [ drop stack-identity-0 ] }
+        { [ dup 1 = ] [ drop stack-identity-1 ] }
+        { [ dup 2 = ] [ drop stack-identity-2 ] }
+        { [ dup 3 = ] [ drop stack-identity-3 ] }
+        { [ dup 4 = ] [ drop stack-identity-4 ] }
+        { [ t ] [ drop f ] }
+    } cond ;
+
+: get-stack-identity-table<= ( n -- hash )
+    1+ random-int get-stack-identity-table ;
+
+
+: random-stack-identity ( n -- quot )
+    #! n is number of items on stack
+    [
+        max-length random-int
+        [ dup get-stack-identity-table<= random-hash-entry swap , , ] times
+        drop
+    ] [ ] make ;
+
+
+: test-random-stack-identity ( -- )
+    4 random-stack-identity interp-compile-check* ;
+
+
+! change the % to make longer quotations
+: if-quot ( -- )
+    [
+        random-ratio , random-ratio , logic-2 nth-rand ,
+        2 [ 30% [ if-quot ] [ random-ratio-quotation-1 ] if unit % ] times
+        \ if ,
+    ] [ ] make ;
+
+: when-quot
+    [
+        random-ratio , random-ratio , logic-2 nth-rand ,
+        90% [ when-quot ] [ random-ratio-quotation-1 ] if unit %
+        coin-flip \ when \ unless ? ,
+    ] [ ] make ;
+
+: nested-ifs ( -- quot )
+    [
+        random-ratio ,
+        if-quot %
+        ! when-quot %
+    ] [ ] make ;
+
+: test-if ( -- ) nested-ifs interp-runtime-check ;
+
+: random-test ( -- )
+    {
+        test-if
+        test-random-stack-identity
+        test-math
+    }
+    nth-rand execute ;
+
+
+: watch-simplifier ( -- )
+    [
+        dup word-def dataflow optimize
+        linearize [ split-blocks simplify . ] hash-each
+    ] with-compiler ;
+
+

contrib/random-tester/random.factor

@@ -0,0 +1,88 @@
+USING: kernel math sequences namespaces errors hashtables words arrays parser
+       compiler syntax lists io ;
+USING: inspector prettyprint ;
+USING: optimizer compiler-frontend compiler-backend inference ;
+IN: random-tester
+
+! Tweak me
+: max-length 7 ; inline
+: max-value 1000000000 ; inline
+
+: 10% ( -- bool ) 10 random-int 8 > ;
+: 20% ( -- bool ) 10 random-int 7 > ;
+: 30% ( -- bool ) 10 random-int 6 > ;
+: 40% ( -- bool ) 10 random-int 5 > ;
+: 50% ( -- bool ) 10 random-int 4 > ;
+: 60% ( -- bool ) 10 random-int 3 > ;
+: 70% ( -- bool ) 10 random-int 2 > ;
+: 80% ( -- bool ) 10 random-int 1 > ;
+: 90% ( -- bool ) 10 random-int 0 > ;
+
+! varying bit-length random number
+: random-bits ( n -- int )
+    random-int 2 swap ^ random-int ;
+
+: random-seq ( -- seq )
+    { [ ] { } V{ } "" } nth-rand
+    [ max-length random-int [ max-value random-int , ] times ] swap make ;
+
+: random-string
+    [ max-length random-int [ max-value random-int , ] times ] "" make ;
+
+SYMBOL: special-integers
+[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] 
+{ } make \ special-integers set
+: special-integers ( -- seq ) \ special-integers get ;
+SYMBOL: special-floats
+[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
+{ } make \ special-floats set
+: special-floats ( -- seq ) \ special-floats get ;
+SYMBOL: special-complexes
+[ 
+    { -1 0 1 i -i } %
+    e , e neg , pi , pi neg ,
+    0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
+    pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
+    e neg e neg rect> , e e rect> ,
+] { } make \ special-complexes set
+: special-complexes ( -- seq ) \ special-complexes get ;
+
+: random-fixnum ( -- fixnum )
+    most-positive-fixnum random-int 1+ coin-flip [ neg 1- ] when >fixnum ;
+
+: random-bignum ( -- bignum )
+     400 random-bits first-bignum + coin-flip [ neg ] when ;
+    
+: random-integer
+    coin-flip [
+            random-fixnum
+        ] [
+            coin-flip [ random-bignum ] [ special-integers nth-rand ] if
+        ] if ;
+
+: random-positive-integer ( -- int )
+    random-integer dup 0 < [
+            neg
+        ] [
+            dup 0 = [ 1 + ] when
+    ] if ;
+
+: random-ratio ( -- ratio )
+    1000000000 dup [ random-int ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
+
+: random-float ( -- float )
+    coin-flip [ random-ratio ] [ special-floats nth-rand ] if
+    coin-flip 
+    [ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if
+    >float ;
+
+: random-number ( -- number )
+    {
+        [ random-integer ]
+        [ random-ratio ]
+        [ random-float ]
+    } do-one ;
+
+: random-complex ( -- C{ } )
+    random-number random-number rect> ;
+

contrib/random-tester/utils.factor

@@ -0,0 +1,22 @@
+USING: kernel math sequences namespaces errors hashtables words arrays parser
+       compiler syntax lists io ;
+USING: optimizer compiler-frontend compiler-backend inference
+       inspector prettyprint ;
+IN: random-tester
+
+
+: nth-rand ( seq -- elem ) [ length random-int ] keep nth ;
+
+! HASHTABLES
+: random-hash-entry ( hash -- key value ) hash>alist nth-rand first2 ;
+
+! ARRAYS
+: 4array ( a b c d -- seq ) 2array >r 2array r> append ;
+
+: coin-flip ( -- bool ) 2 random-int 1 = ;
+
+! UNCOMPILABLES
+: do-one ( seq -- ) nth-rand call ;
+
+
+

contrib/space-invaders/cpu-8080.factor

@@ -1,4 +1,26 @@
-USING: kernel lists math sequences errors vectors prettyprint io unparser namespaces 
+! Copyright (C) 2006 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.
+USING: kernel lists math sequences errors vectors prettyprint io namespaces arrays
        words parser hashtables lazy parser-combinators kernel-internals strings ;
 IN: cpu-8080
 
@@ -437,7 +459,7 @@ M: cpu reset ( cpu -- )
   [ 0 swap set-cpu-f  ] keep
   [ 0 swap set-cpu-pc  ] keep
   [ HEX: F000 swap set-cpu-sp  ] keep 
-  [ HEX: FFFF 0 <repeated> >vector swap set-cpu-ram ] keep
+  [ HEX: FFFF 0 <array> swap set-cpu-ram ] keep
   [ f swap set-cpu-halted? ] keep
   [ HEX: 10 swap set-cpu-last-interrupt ] keep
   0 swap set-cpu-cycles ;
@@ -558,18 +580,18 @@ C: cpu ( cpu -- cpu )
   #! where the 1st item is the getter and the 2nd is the setter
   #! for that register.
   H{
-    [[ "A"  { cpu-a  set-cpu-a  } ]]
+    { "A"  { cpu-a  set-cpu-a  } }
-    [[ "B"  { cpu-b  set-cpu-b  } ]]
+    { "B"  { cpu-b  set-cpu-b  } }
-    [[ "C"  { cpu-c  set-cpu-c  } ]]
+    { "C"  { cpu-c  set-cpu-c  } }
-    [[ "D"  { cpu-d  set-cpu-d  } ]]
+    { "D"  { cpu-d  set-cpu-d  } }
-    [[ "E"  { cpu-e  set-cpu-e  } ]]
+    { "E"  { cpu-e  set-cpu-e  } }
-    [[ "H"  { cpu-h  set-cpu-h  } ]]
+    { "H"  { cpu-h  set-cpu-h  } }
-    [[ "L"  { cpu-l  set-cpu-l  } ]]
+    { "L"  { cpu-l  set-cpu-l  } }
-    [[ "AF" { cpu-af set-cpu-af } ]]
+    { "AF" { cpu-af set-cpu-af } }
-    [[ "BC" { cpu-bc set-cpu-bc } ]]
+    { "BC" { cpu-bc set-cpu-bc } }
-    [[ "DE" { cpu-de set-cpu-de } ]]
+    { "DE" { cpu-de set-cpu-de } }
-    [[ "HL" { cpu-hl set-cpu-hl } ]]
+    { "HL" { cpu-hl set-cpu-hl } }
-    [[ "SP" { cpu-sp set-cpu-sp } ]]
+    { "SP" { cpu-sp set-cpu-sp } }
   } hash ;
 
 
@@ -577,14 +599,14 @@ C: cpu ( cpu -- cpu )
   #! Given a string containing a flag name, return a vector
   #! where the 1st item is a word that tests that flag.
   H{
-    [[ "NZ"  { flag-nz?  } ]]
+    { "NZ"  { flag-nz?  } }
-    [[ "NC"  { flag-nc?  } ]]
+    { "NC"  { flag-nc?  } }
-    [[ "PO"  { flag-po?  } ]]
+    { "PO"  { flag-po?  } }
-    [[ "PE"  { flag-pe?  } ]]
+    { "PE"  { flag-pe?  } }
-    [[ "Z"  { flag-z?  } ]]
+    { "Z"  { flag-z?  } }
-    [[ "C"  { flag-c? } ]]
+    { "C"  { flag-c? } }
-    [[ "P"  { flag-p?  } ]]
+    { "P"  { flag-p?  } }
-    [[ "M" { flag-m?  } ]]
+    { "M" { flag-m?  } }
   } hash ;
 
 SYMBOL: $1
@@ -699,81 +721,81 @@ SYMBOL: $4
 : patterns ( -- hashtable )
   #! table of code quotation patterns for each type of instruction.
   H{
-    [[ "NOP"          [ drop ]               ]]
+    { "NOP"          [ drop ]               }
-    [[ "RET-NN"          [ ret-from-sub  ]               ]]
+    { "RET-NN"          [ ret-from-sub  ]               }
-    [[ "RST-0"      [ 0 swap (emulate-RST) ] ]]
+    { "RST-0"      [ 0 swap (emulate-RST) ] }
-    [[ "RST-8"      [ 8 swap (emulate-RST) ] ]]
+    { "RST-8"      [ 8 swap (emulate-RST) ] }
-    [[ "RST-10H"      [ HEX: 10 swap (emulate-RST) ] ]]
+    { "RST-10H"      [ HEX: 10 swap (emulate-RST) ] }
-    [[ "RST-18H"      [ HEX: 18 swap (emulate-RST) ] ]]
+    { "RST-18H"      [ HEX: 18 swap (emulate-RST) ] }
-    [[ "RST-20H"      [ HEX: 20 swap (emulate-RST) ] ]]
+    { "RST-20H"      [ HEX: 20 swap (emulate-RST) ] }
-    [[ "RST-28H"      [ HEX: 28 swap (emulate-RST) ] ]]
+    { "RST-28H"      [ HEX: 28 swap (emulate-RST) ] }
-    [[ "RST-30H"      [ HEX: 30 swap (emulate-RST) ] ]]
+    { "RST-30H"      [ HEX: 30 swap (emulate-RST) ] }
-    [[ "RST-38H"      [ HEX: 38 swap (emulate-RST) ] ]]
+    { "RST-38H"      [ HEX: 38 swap (emulate-RST) ] }
-    [[ "RET-F|FF"      [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] ]]
+    { "RET-F|FF"      [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
-    [[ "CP-N"      [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] ]]
+    { "CP-N"      [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] }
-    [[ "CP-R"      [ [ cpu-a ] keep [ $1 ] keep sub-byte drop  ] ]]
+    { "CP-R"      [ [ cpu-a ] keep [ $1 ] keep sub-byte drop  ] }
-    [[ "CP-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] ]]
+    { "CP-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
-    [[ "OR-N"      [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] ]]
+    { "OR-N"      [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] }
-    [[ "OR-R"      [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] ]]
+    { "OR-R"      [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] }
-    [[ "OR-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a  ] ]]
+    { "OR-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a  ] }
-    [[ "XOR-N"      [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] ]]
+    { "XOR-N"      [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] }
-    [[ "XOR-R"      [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] ]]
+    { "XOR-R"      [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] }
-    [[ "XOR-(RR)"   [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a  ] ]]
+    { "XOR-(RR)"   [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a  ] }
-    [[ "AND-N"      [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a  ] ]]
+    { "AND-N"      [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a  ] }
-    [[ "AND-R"      [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] ]]
+    { "AND-R"      [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] }
-    [[ "AND-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a  ] ]]
+    { "AND-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a  ] }
-    [[ "ADC-R,N"      [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] ]]
+    { "ADC-R,N"      [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
-    [[ "ADC-R,R"      [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] ]]
+    { "ADC-R,R"      [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
-    [[ "ADC-R,(RR)"      [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] ]]
+    { "ADC-R,(RR)"      [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
-    [[ "ADD-R,N"      [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] ]]
+    { "ADD-R,N"      [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
-    [[ "ADD-R,R"      [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] ]]
+    { "ADD-R,R"      [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
-    [[ "ADD-RR,RR"    [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] ]]
+    { "ADD-RR,RR"    [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
-    [[ "ADD-R,(RR)"    [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2   ]  ]]
+    { "ADD-R,(RR)"    [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2   ]  }
-    [[ "SBC-R,N"      [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] ]]
+    { "SBC-R,N"      [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
-    [[ "SBC-R,R"      [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] ]]
+    { "SBC-R,R"      [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
-    [[ "SBC-R,(RR)"      [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] ]]
+    { "SBC-R,(RR)"      [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
-    [[ "SUB-R"      [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] ]]
+    { "SUB-R"      [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] }
-    [[ "SUB-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] ]]
+    { "SUB-(RR)"      [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] }
-    [[ "SUB-N"      [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] ]]
+    { "SUB-N"      [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] }
-    [[ "CPL"          [ (emulate-CPL) ]               ]]
+    { "CPL"          [ (emulate-CPL) ]               }
-    [[ "DAA"          [ (emulate-DAA) ]               ]]
+    { "DAA"          [ (emulate-DAA) ]               }
-    [[ "RLA"          [ (emulate-RLA) ]               ]]
+    { "RLA"          [ (emulate-RLA) ]               }
-    [[ "RRA"          [ (emulate-RRA) ]               ]]
+    { "RRA"          [ (emulate-RRA) ]               }
-    [[ "CCF"          [ carry-flag swap cpu-f-bitxor= ]               ]]
+    { "CCF"          [ carry-flag swap cpu-f-bitxor= ]               }
-    [[ "SCF"          [ carry-flag swap cpu-f-bitor= ]               ]]
+    { "SCF"          [ carry-flag swap cpu-f-bitor= ]               }
-    [[ "RLCA"          [ (emulate-RLCA) ]               ]]
+    { "RLCA"          [ (emulate-RLCA) ]               }
-    [[ "RRCA"          [ (emulate-RRCA) ]               ]]
+    { "RRCA"          [ (emulate-RRCA) ]               }
-    [[ "HALT"          [ drop  ]               ]]
+    { "HALT"          [ drop  ]               }
-    [[ "DI"          [ [ 255 interrupt-flag - ] swap cpu-f-bitand  ]               ]]
+    { "DI"          [ [ 255 interrupt-flag - ] swap cpu-f-bitand  ]               }
-    [[ "EI"          [ [ interrupt-flag ] swap cpu-f-bitor  ]  ]]  
+    { "EI"          [ [ interrupt-flag ] swap cpu-f-bitor  ]  }  
-    [[ "POP-RR"     [ [ pop-sp ] keep $2 ] ]]
+    { "POP-RR"     [ [ pop-sp ] keep $2 ] }
-    [[ "PUSH-RR"     [ [ $1 ] keep push-sp ] ]]
+    { "PUSH-RR"     [ [ $1 ] keep push-sp ] }
-    [[ "INC-R"     [ [ $1 ] keep [ inc-byte ] keep $2 ] ]]
+    { "INC-R"     [ [ $1 ] keep [ inc-byte ] keep $2 ] }
-    [[ "DEC-R"     [ [ $1 ] keep [ dec-byte ] keep $2 ] ]]
+    { "DEC-R"     [ [ $1 ] keep [ dec-byte ] keep $2 ] }
-    [[ "INC-RR"     [ [ $1 ] keep [ inc-word ] keep $2 ] ]]
+    { "INC-RR"     [ [ $1 ] keep [ inc-word ] keep $2 ] }
-    [[ "DEC-RR"     [ [ $1 ] keep [ dec-word ] keep $2 ] ]]
+    { "DEC-RR"     [ [ $1 ] keep [ dec-word ] keep $2 ] }
-    [[ "DEC-(RR)"     [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] ]]
+    { "DEC-(RR)"     [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
-    [[ "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep  [ $1 ] keep write-byte ] ]]
+    { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep  [ $1 ] keep write-byte ] }
-    [[ "JP-NN"           [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ]               ]]
+    { "JP-NN"           [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ]               }
-    [[ "JP-F|FF,NN"      [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] ]]
+    { "JP-F|FF,NN"      [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
-    [[ "JP-(RR)"      [ [ $1 ] keep set-cpu-pc ] ]]
+    { "JP-(RR)"      [ [ $1 ] keep set-cpu-pc ] }
-    [[ "CALL-NN"         [ (emulate-CALL) ] ]]
+    { "CALL-NN"         [ (emulate-CALL) ] }
-    [[ "CALL-F|FF,NN"    [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ]   ]]
+    { "CALL-F|FF,NN"    [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ]   }
-    [[ "LD-RR,NN"     [ [ next-word ] keep $2 ] ]]
+    { "LD-RR,NN"     [ [ next-word ] keep $2 ] }
-    [[ "LD-RR,RR"     [ [ $3 ] keep $2 ] ]]
+    { "LD-RR,RR"     [ [ $3 ] keep $2 ] }
-    [[ "LD-R,N"     [ [ next-byte ] keep $2 ] ]]
+    { "LD-R,N"     [ [ next-byte ] keep $2 ] }
-    [[ "LD-(RR),N"    [ [ next-byte ] keep [ $1 ] keep write-byte ] ]]
+    { "LD-(RR),N"    [ [ next-byte ] keep [ $1 ] keep write-byte ] }
-    [[ "LD-(RR),R"    [ [ $3 ] keep [ $1 ] keep write-byte ] ]]
+    { "LD-(RR),R"    [ [ $3 ] keep [ $1 ] keep write-byte ] }
-    [[ "LD-R,R"    [ [ $3 ] keep $2 ] ]]
+    { "LD-R,R"    [ [ $3 ] keep $2 ] }
-    [[ "LD-R,(RR)"    [ [ $3 ] keep [ read-byte ] keep $2  ] ]]
+    { "LD-R,(RR)"    [ [ $3 ] keep [ read-byte ] keep $2  ] }
-    [[ "LD-(NN),RR"    [ [ $1 ] keep [ next-word ] keep write-word ] ]]
+    { "LD-(NN),RR"    [ [ $1 ] keep [ next-word ] keep write-word ] }
-    [[ "LD-(NN),R"    [  [ $1 ] keep [ next-word ] keep write-byte ] ]]
+    { "LD-(NN),R"    [  [ $1 ] keep [ next-word ] keep write-byte ] }
-    [[ "LD-RR,(NN)"    [ [ next-word ] keep [ read-word ] keep $2 ]  ]]
+    { "LD-RR,(NN)"    [ [ next-word ] keep [ read-word ] keep $2 ]  }
-    [[ "LD-R,(NN)"    [ [ next-word ] keep [ read-byte ] keep $2 ] ]]
+    { "LD-R,(NN)"    [ [ next-word ] keep [ read-byte ] keep $2 ] }
-    [[ "OUT-(N),R"    [ [ $1 ] keep [ next-byte ] keep write-port ] ]]
+    { "OUT-(N),R"    [ [ $1 ] keep [ next-byte ] keep write-port ] }
-    [[ "IN-R,(N)"    [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] ]]
+    { "IN-R,(N)"    [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] }
-    [[ "EX-(RR),RR"  [  [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] ]]
+    { "EX-(RR),RR"  [  [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
-    [[ "EX-RR,RR"    [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] ]]
+    { "EX-RR,RR"    [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
   } ;
 
 : 8-bit-registers ( -- parser )

contrib/space-invaders/load.factor

@@ -1,12 +1,9 @@
 IN: scratchpad
-USING: parser compiler words sequences io ;
+USING: kernel parser compiler words sequences io ;
 
-"../parser-combinators/lazy.factor" run-file
+"/contrib/parser-combinators/load.factor" run-resource
-"../parser-combinators/parser-combinators.factor" run-file
-"cpu-8080.factor" run-file 
-"space-invaders.factor" run-file
 
-"cpu-8080" words [ try-compile ] each
+{
-"space-invaders" words [ try-compile ] each
+    "cpu-8080"
-
+    "space-invaders"
-"Use 'run' in the 'space-invaders' vocabulary to start." print
+} [ "/contrib/space-invaders/" swap ".factor" append3 run-resource ] each

contrib/space-invaders/readme.txt

@@ -33,4 +33,4 @@ input/output ports.
 
 For more information, contact the author, Chris Double, at
 chris.double@double.co.nz or from my weblog
-http://radio.weblogs.com/0102385
+http://www.bluishcoder.co.nz

contrib/space-invaders/space-invaders.factor

@@ -1,6 +1,27 @@
+! Copyright (C) 2006 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.
 USING: alien cpu-8080 errors generic io kernel kernel-internals
-lists math namespaces sdl sdl-event sdl-gfx sdl-video sequences
+lists math namespaces sdl sequences styles threads ;
-styles threads ;
 IN: space-invaders
 
 TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o ;
@@ -179,7 +200,7 @@ M: space-invaders update-video ( value addr cpu -- )
 : run ( -- )
   224 256 16 SDL_HWSURFACE [ 
    <space-invaders> "invaders.rom" over load-rom
-   <event> event-loop
+   "event" <c-object> event-loop
     SDL_Quit
   ] with-screen ;
 

contrib/space-invaders/tests.factor

@@ -1,3 +1,25 @@
+! Copyright (C) 2006 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.
 USING: kernel cpu-8080 test lazy parser-combinators math hashtables lists sequences words ;
 
 ! Test read-byte from ROM

contrib/splay-trees.factor

@@ -0,0 +1,115 @@
+! Copyright (c) 2005 Mackenzie Straight.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: splay-trees
+USING: kernel math sequences ;
+
+TUPLE: splay-tree r ;
+TUPLE: splay-node v k l r ;
+
+C: splay-tree ;
+
+: rotate-right
+    dup splay-node-l
+    [ splay-node-r swap set-splay-node-l ] 2keep
+    [ set-splay-node-r ] keep ;
+
+: rotate-left
+    dup splay-node-r
+    [ splay-node-l swap set-splay-node-r ] 2keep
+    [ set-splay-node-l ] keep ;
+
+: link-right ( left right key node -- left right key node )
+    swap >r [ swap set-splay-node-l ] 2keep
+    nip dup splay-node-l r> swap ;
+
+: link-left ( left right key node -- left right key node )
+    swap >r rot [ set-splay-node-r ] 2keep
+    drop dup splay-node-r swapd r> swap ;
+
+: cmp 2dup splay-node-k <=> ;
+
+: lcmp 2dup splay-node-l splay-node-k <=> ;
+
+: rcmp 2dup splay-node-r splay-node-k <=> ;
+
+DEFER: (splay)
+
+: splay-left
+    dup splay-node-l [
+        lcmp 0 < [ rotate-right ] when
+        dup splay-node-l [ link-right (splay) ] when
+    ] when ;
+
+: splay-right
+    dup splay-node-r [
+        rcmp 0 > [ rotate-left ] when
+        dup splay-node-r [ link-left (splay) ] when
+    ] when ;
+
+: (splay) ( left right key node -- )
+    cmp dup 0 <
+    [ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
+
+: assemble ( head left right node -- root )
+    [ splay-node-r swap set-splay-node-l ] keep
+    [ splay-node-l swap set-splay-node-r ] keep
+    [ swap splay-node-l swap set-splay-node-r ] 2keep
+    [ swap splay-node-r swap set-splay-node-l ] keep ;
+
+: splay-at ( key node -- node )
+    >r >r T{ splay-node } dup dup r> r> (splay) nip assemble ;
+
+: splay ( key tree -- )
+    [ splay-tree-r splay-at ] keep set-splay-tree-r ;
+
+: splay-split ( key tree -- node node )
+    2dup splay splay-tree-r cmp 0 < [
+        nip dup splay-node-l swap f over set-splay-node-l
+    ] [
+        nip dup splay-node-r swap f over set-splay-node-r swap
+    ] if ;
+
+: (get-splay) ( key tree -- node )
+    2dup splay splay-tree-r cmp 0 = [ nip ] [ 2drop f ] if ;
+
+: get-largest
+    dup [ dup splay-node-r [ nip get-largest ] when* ] when ;
+
+: splay-largest
+    dup [ dup get-largest splay-node-k swap splay-at ] when ;
+
+: splay-join ( n2 n1 -- node )
+    splay-largest [ [ set-splay-node-r ] keep ] [ drop f ] if* ;
+
+: (remove-splay) ( key tree -- )
+    tuck (get-splay) [
+        dup splay-node-r swap splay-node-l splay-join
+        swap set-splay-tree-r
+    ] [ drop ] if* ;
+
+: (set-splay) ( value key tree -- )
+    2dup (get-splay) [ 2nip set-splay-node-v ] [
+       2dup splay-split rot >r <splay-node> r> set-splay-tree-r
+    ] if* ;
+
+: new-root ( value key tree -- )
+    >r f f <splay-node> r> set-splay-tree-r ;
+
+: set-splay ( value key tree -- )
+    dup splay-tree-r [ (set-splay) ] [ new-root ] if ;
+
+: get-splay ( key tree -- value )
+    dup splay-tree-r [
+        (get-splay) dup [ splay-node-v ] when
+    ] [
+        2drop f
+    ] if ;
+
+: remove-splay ( key tree -- )
+    dup splay-tree-r [ (remove-splay) ] [ 2drop ] if ;
+
+USING: namespaces words ;
+
+<splay-tree> "foo" set
+[ dup word-name "foo" get set-splay ] each-word
+[ dup word-name "foo" get get-splay drop ] each-word

contrib/sqlite/load.factor

@@ -0,0 +1,11 @@
+IN: scratchpad
+USING: kernel alien parser compiler words sequences ;
+
+"sqlite" "libsqlite3" add-simple-library
+
+{
+    "sqlite"
+    "tuple-db"
+    "test"
+    "tuple-db-tests"
+} [ "/contrib/sqlite/" swap ".factor" append3 run-resource ] each

contrib/sqlite/sqlite.factor

@@ -37,6 +37,7 @@ USE: strings
 USE: namespaces
 USE: sequences
 USE: lists
+USE: compiler
 
 BEGIN-STRUCT: sqlite3
 END-STRUCT
@@ -170,7 +171,7 @@ END-STRUCT
   #! Open the database referenced by the filename and return
   #! a handle to that database. An error is thrown if the database
   #! failed to open.
-  <sqlite3-indirect> tuck sqlite3_open sqlite-check-result sqlite3-indirect-pointer ;
+  "sqlite3-indirect" <c-object> tuck sqlite3_open sqlite-check-result sqlite3-indirect-pointer ;
 
 : sqlite-close ( db -- )
   #! Close the given database
@@ -184,8 +185,8 @@ END-STRUCT
   #! Prepare a SQL statement. Returns the statement which
   #! can have values bound to parameters or simply executed.
   #! TODO: Support multiple statements in the SQL string.
-  dup length <sqlite3-stmt-indirect> dup >r 
+  dup length "sqlite3-stmt-indirect" <c-object> dup >r 
-  <char*-indirect> sqlite3_prepare sqlite-check-result
+  "char*-indirect" <c-object> sqlite3_prepare sqlite-check-result
   r> sqlite3-stmt-indirect-pointer ;
 
 : sqlite-bind-text ( statement col text -- )