Merge branch 'master' into trees

Makefile

@@ -57,6 +57,7 @@ default:
 	@echo "openbsd-x86-32"
 	@echo "openbsd-x86-64"
 	@echo "macosx-x86-32"
+	@echo "macosx-x86-64"
 	@echo "macosx-ppc"
 	@echo "solaris-x86-32"
 	@echo "solaris-x86-64"
@@ -92,6 +93,9 @@ macosx-ppc: macosx-freetype
 macosx-x86-32: macosx-freetype
 	$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86.32
 
+macosx-x86-64: macosx-freetype
+	$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86.64
+
 linux-x86-32:
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86.32
 

README.txt

@@ -74,6 +74,10 @@ following command line:
 
 ./factor -i=boot.<cpu>.image
 
+Or this command for Mac OS X systems:
+
+./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
+
 Bootstrap can take a while, depending on your system. When the process
 completes, a 'factor.image' file will be generated. Note that this image
 is both CPU and OS-specific, so in general cannot be shared between

core/alien/compiler/compiler.factor

@@ -5,8 +5,7 @@ hashtables kernel math namespaces sequences words
 inference.backend inference.dataflow system
 math.parser classes alien.arrays alien.c-types alien.structs
 alien.syntax cpu.architecture alien inspector quotations assocs
-kernel.private threads continuations.private libc combinators
-init ;
+kernel.private threads continuations.private libc combinators ;
 IN: alien.compiler
 
 ! Common protocol for alien-invoke/alien-callback/alien-indirect
@@ -302,7 +301,7 @@ M: alien-indirect generate-node
 ! this hashtable, they will all be blown away by code GC, beware
 SYMBOL: callbacks
 
-[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
+callbacks global [ H{ } assoc-like ] change-at
 
 : register-callback ( word -- ) dup callbacks get set-at ;
 

core/alien/syntax/syntax.factor

@@ -59,4 +59,4 @@ M: alien pprint*
         { [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] }
     } cond ;
 
-M: dll pprint* dll-path dup "DLL\" " pprint-string ;
+M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

core/assocs/assocs-tests.factor

@@ -87,3 +87,9 @@ unit-test
 [ H{ { 1 2 } { 3 4 } } ]
 [ "hi" 5 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ]
 unit-test
+
+[
+    H{ { 1.0 1.0 } { 2.0 2.0 } }
+] [
+    F{ 1.0 2.0 } [ dup ] H{ } map>assoc
+] unit-test

core/assocs/assocs.factor

@@ -135,7 +135,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     [ 0 or + ] change-at ;
 
 : map>assoc ( seq quot exemplar -- assoc )
-    >r [ 2array ] compose map r> assoc-like ; inline
+    >r [ 2array ] compose { } map-as r> assoc-like ; inline
 
 M: assoc >alist [ 2array ] { } assoc>map ;
 

core/bootstrap/image/image-docs.factor

@@ -14,7 +14,7 @@ $nl
 ABOUT: "bootstrap.image"
 
 HELP: make-image
-{ $values { "architecture" "a string" } }
+{ $values { "arch" "a string" } }
 { $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:"
 { $code "x86.32" "x86.64" "ppc" "arm" }
 "The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;

core/classes/classes-docs.factor

@@ -203,17 +203,3 @@ HELP: define-class
 { $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
 { $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link typemap } " and " { $link class<map } "." }
 $low-level-note ;
-
-: $predicate ( element -- )
-    { { "object" object } { "?" "a boolean" } } $values
-    [
-        "Tests if the object is an instance of the " ,
-        first "predicating" word-prop \ $link swap 2array ,
-        " class." ,
-    ] { } make $description ;
-
-M: predicate word-help* drop \ $predicate ;
-
-HELP: $predicate
-{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
-{ $description "Prints the boilerplate description of a class membership predicate word such as " { $link array? } " or " { $link integer? } "." } ;

core/combinators/combinators.factor

@@ -79,6 +79,10 @@ M: sequence hashcode*
     dup empty? [
         drop
     ] [
-        hash-case-table hash-dispatch-quot
-        [ dup hashcode >fixnum ] swap append
+        dup length 4 <= [
+            case>quot
+        ] [
+            hash-case-table hash-dispatch-quot
+            [ dup hashcode >fixnum ] swap append
+        ] if
     ] if ;

core/compiler/compiler.factor

@@ -16,9 +16,10 @@ M: object inference-error-major? drop t ;
 
 : begin-batch ( seq -- )
     batch-mode on
-    [
-        "Compiling " % length # " words..." %
-    ] "" make print flush
+    "quiet" get [ drop ] [
+        [ "Compiling " % length # " words..." % ] "" make
+        print flush
+    ] if
     V{ } clone compile-errors set-global ;
 
 : compile-error. ( pair -- )

core/compiler/test/curry.factor

@@ -50,7 +50,7 @@ IN: temporary
     global keys =
 ] unit-test
 
-[ 3 ] [ 1 2 [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test
+[ 3 ] [ 1 [ 2 ] [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test
 
 [ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test
 

core/compiler/test/simple.factor

@@ -56,3 +56,8 @@ IN: temporary
 \ recursive compile
 
 [ ] [ t recursive ] unit-test
+
+! Make sure error reporting works
+
+[ [ dup ] compile-1 ] unit-test-fails
+[ [ drop ] compile-1 ] unit-test-fails

core/continuations/continuations-docs.factor

@@ -85,7 +85,7 @@ HELP: continuation
 { $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
 
 HELP: >continuation<
-{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } { "c" array } }
+{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } }
 { $description "Takes a continuation apart into its constituents." } ;
 
 HELP: ifcc

core/cpu/arm/intrinsics/intrinsics.factor

@@ -418,17 +418,6 @@ IN: cpu.arm.intrinsics
     { +output+ { "out" } }
 } define-intrinsic
 
-\ curry [
-    \ curry 3 cells %allot
-    "obj" operand 1 %set-slot
-    "quot" operand 2 %set-slot
-    "out" get object %store-tagged
-] H{
-    { +input+ { { f "obj" } { f "quot" } } }
-    { +scratch+ { { f "out" } } }
-    { +output+ { "out" } }
-} define-intrinsic
-
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand dup %untag-fixnum

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -580,18 +580,6 @@ IN: cpu.ppc.intrinsics
     { +output+ { "vector" } }
 } define-intrinsic
 
-\ curry [
-    \ curry 3 cells %allot
-    "obj" operand 11 1 cells STW
-    "quot" operand 11 2 cells STW
-    ! Store tagged ptr in reg
-    "curry" get object %store-tagged
-] H{
-    { +input+ { { f "obj" } { f "quot" } } }
-    { +scratch+ { { f "curry" } } }
-    { +output+ { "curry" } }
-} define-intrinsic
-
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand dup %untag-fixnum

core/cpu/x86/intrinsics/intrinsics.factor

@@ -485,19 +485,6 @@ IN: cpu.x86.intrinsics
     { +output+ { "vector" } }
 } define-intrinsic
 
-\ curry [
-    \ curry 3 cells [
-        1 object@ "obj" operand MOV
-        2 object@ "quot" operand MOV
-        ! Store tagged ptr in reg
-        "curry" get object %store-tagged
-    ] %allot
-] H{
-    { +input+ { { f "obj" } { f "quot" } } }
-    { +scratch+ { { f "curry" } } }
-    { +output+ { "curry" } }
-} define-intrinsic
-
 ! Alien intrinsics
 : %alien-accessor ( quot -- )
     "offset" operand %untag-fixnum

core/generator/generator-docs.factor

@@ -48,11 +48,10 @@ HELP: literal-table
 { $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
 
 HELP: init-generator
-{ $values { "word" word } }
 { $description "Prepares to generate machine code for a word." } ;
 
 HELP: generate-1
-{ $values { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
+{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
 { $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
 
 HELP: generate-node

core/generic/math/math-docs.factor

@@ -4,7 +4,7 @@ generic.math ;
 HELP: math-upgrade
 { $values { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
 { $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." }
-{ $examples { $example "USE: generic.math" "fixnum bignum math-upgrade ." "[ >r >bignum r> ]" } } ;
+{ $examples { $example "USE: generic.math" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ;
 
 HELP: no-math-method
 { $values { "left" "an object" } { "right" "an object" } { "generic" "a generic word" } }
@@ -14,7 +14,7 @@ HELP: no-math-method
 HELP: math-method
 { $values { "word" "a generic word" } { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation" } }
 { $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
-{ $examples { $example "USE: generic.math" "\\ + fixnum float math-method ." "[ >r >float r> float+ ]" } } ;
+{ $examples { $example "USE: generic.math" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
 
 HELP: math-class
 { $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;

core/hashtables/hashtables-docs.factor

@@ -96,7 +96,7 @@ HELP: hash-deleted+
 { $side-effects "hash" } ;
 
 HELP: (set-hash)
-{ $values { "value" "a value" } { "key" "a key to add" } { "hash" hashtable } }
+{ $values { "value" "a value" } { "key" "a key to add" } { "hash" hashtable } { "new?" "a boolean" } }
 { $description "Stores the key/value pair into the hashtable. This word does not grow the hashtable if it exceeds capacity, therefore a hang can result. User code should use " { $link set-at } " instead, which grows the hashtable if necessary." }
 { $side-effects "hash" } ;
 

core/io/files/files-docs.factor

@@ -104,7 +104,7 @@ HELP: file-modified
 HELP: parent-directory
 { $values { "path" "a pathname string" } { "parent" "a pathname string" } }
 { $description "Strips the last component off a pathname." }
-{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc" } } ;
+{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
 
 HELP: file-name
 { $values { "path" "a pathname string" } { "string" string } }

core/io/files/files.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.files
 USING: io.backend io.files.private io hashtables kernel math
-memory namespaces sequences strings arrays definitions system
-combinators splitting ;
+memory namespaces sequences strings assocs arrays definitions
+system combinators splitting ;
 
 HOOK: <file-reader> io-backend ( path -- stream )
 
@@ -97,7 +97,9 @@ TUPLE: no-parent-directory path ;
         ] }
     } cond drop ;
 
-: copy-file ( from to -- )
+HOOK: copy-file io-backend ( from to -- )
+
+M: object copy-file
     dup parent-directory make-directories
     <file-writer> [
         stdio get swap
@@ -124,3 +126,34 @@ TUPLE: pathname string ;
 C: <pathname> pathname
 
 M: pathname <=> [ pathname-string ] compare ;
+
+HOOK: library-roots io-backend ( -- seq )
+HOOK: binary-roots io-backend ( -- seq )
+
+: find-file ( seq str -- path/f )
+    [
+        [ path+ exists? ] curry find nip
+    ] keep over [ path+ ] [ drop ] if ;
+
+: find-library ( str -- path/f )
+    library-roots swap find-file ;
+
+: find-binary ( str -- path/f )
+    binary-roots swap find-file ;
+
+<PRIVATE
+: append-path ( path files -- paths )
+    [ path+ ] curry* map ;
+
+: get-paths ( dir -- paths )
+    dup directory keys append-path ;
+
+: (walk-dir) ( path -- )
+    dup directory? [
+        get-paths dup % [ (walk-dir) ] each
+    ] [
+        drop
+    ] if ;
+PRIVATE>
+
+: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;

core/io/io-docs.factor

@@ -134,12 +134,13 @@ $nl
 $io-error ;
 
 HELP: make-block-stream
-{ $values { "quot" "a quotation" } { "style" "a hashtable" } { "stream" "an output stream" } }
-{ $contract "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied."
+{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
 $nl
 "Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
 $nl
 "The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
+{ $notes "Instead of calling this word directly, use " { $link with-nesting } "." }
 $io-error ;
 
 HELP: stream-write-table
@@ -151,16 +152,17 @@ $nl
 $io-error ;
 
 HELP: make-cell-stream
-{ $values { "quot" quotation } { "style" hashtable } { "stream" "an output stream" } { "table-cell" object } }
-{ $contract "Creates a table cell by calling the quotation in a new scope with a rebound " { $link stdio } " stream. Callers should not make any assumptions about the type of this word's output value; it should be treated like an opaque handle passed to " { $link stream-write-table } "." }
+{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
+{ $contract "Creates an output stream which writes to a table cell object." }
 { $notes "Instead of calling this word directly, use " { $link tabular-output } "." }
 $io-error ;
 
 HELP: make-span-stream
-{ $values { "style" "a hashtable" } { "quot" "a quotation" } { "stream" "an output stream" } }
-{ $contract "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "."
+{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
 $nl
-"Unlike " { $link make-block-stream } ", the quotation's output is inline, and not nested in a paragraph block." }
+"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
+{ $notes "Instead of calling this word directly, use " { $link with-style } "." }
 $io-error ;
 
 HELP: stream-print

core/kernel/kernel-docs.factor

@@ -32,7 +32,7 @@ $nl
 { $subsection >r }
 { $subsection r> }
 "The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
-{ $example "1 2 3 >r .s r>" "2\n1" }
+{ $example "1 2 3 >r .s r>" "1\n2" }
 "Words must not leave objects on the retain stack, nor expect values to be there on entry. The retain stack is for local storage within a word only, and occurrences of " { $link >r } " and " { $link r> } " must be balanced inside a single quotation. One exception is the following trick involving " { $link if } "; values may be pushed on the retain stack before the condition value is computed, as long as both branches of the " { $link if } " pop the values off the retain stack before returning:"
 { $code
     ": foo ( m ? n -- m+n/n )"
@@ -542,7 +542,7 @@ HELP: 3compose
 } ;
 
 HELP: while
-{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation" } { "tail" "a quotation" } }
+{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
 { $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
 { $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
 $nl

core/kernel/kernel.factor

@@ -3,7 +3,7 @@
 USING: kernel.private ;
 IN: kernel
 
-: version ( -- str ) "0.91" ; foldable
+: version ( -- str ) "0.92" ; foldable
 
 ! Stack stuff
 : roll ( x y z t -- y z t x ) >r rot r> swap ; inline

core/libc/libc-docs.factor

@@ -25,7 +25,7 @@ HELP: memcpy
 { $warning "As per the BSD C library documentation, the behavior is undefined if the source and destination overlap." } ;
 
 HELP: check-ptr
-{ $values { "c-ptr" "an alien address, byte array, or " { $link f } } { "checked" "an alien address or byte array with non-zero address" } }
+{ $values { "c-ptr" "an alien address, byte array, or " { $link f } } }
 { $description "Throws an error if the input is " { $link f } ". Otherwise the object remains on the data stack." } ;
 
 HELP: free

core/math/math-docs.factor

@@ -222,12 +222,12 @@ $nl
 HELP: bit?
 { $values { "x" integer } { "n" integer } { "?" "a boolean" } }
 { $description "Tests if the " { $snippet "n" } "th bit of " { $snippet "x" } " is set." }
-{ $examples { $example "BIN: 101 3 bit? ." "t" } } ;
+{ $examples { $example "BIN: 101 2 bit? ." "t" } } ;
 
 HELP: log2
-{ $values { "n" "a positive integer" } { "b" integer } }
-{ $description "Outputs the largest integer " { $snippet "b" } " such that " { $snippet "2^b" } " is less than " { $snippet "n" } "." }
-{ $errors "Throws an error if " { $snippet "n" } " is zero or negative." } ;
+{ $values { "x" "a positive integer" } { "n" integer } }
+{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than " { $snippet "x" } "." }
+{ $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ;
 
 HELP: 1+
 { $values { "x" number } { "y" number } }
@@ -344,7 +344,7 @@ HELP: each-integer
 { $notes "This word is used to implement " { $link each } "." } ;
 
 HELP: all-integers?
-{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } }
+{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "?" "a boolean" } }
 { $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." }
 { $notes "This word is used to implement " { $link all? } "." } ;
 

core/optimizer/known-words/known-words.factor

@@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
 io.streams.string layouts splitting math.intervals
 math.floats.private tuples tuples.private classes
 optimizer.def-use optimizer.backend optimizer.pattern-match
-float-arrays combinators.private ;
+float-arrays combinators.private combinators ;
 
 ! the output of <tuple> and <tuple-boa> has the class which is
 ! its second-to-last input
@@ -50,6 +50,20 @@ float-arrays combinators.private ;
     { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
 } define-optimizers
 
+: literal-member? ( #call -- ? )
+    node-in-d peek dup value?
+    [ value-literal sequence? ] [ drop f ] if ;
+
+: member-quot ( seq -- newquot )
+    [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
+
+: expand-member ( #call -- )
+    dup node-in-d peek value-literal member-quot splice-quot ;
+
+\ member? {
+    { [ dup literal-member? ] [ expand-member ] }
+} define-optimizers
+
 ! if the result of eq? is t and the second input is a literal,
 ! the first input is equal to the second
 \ eq? [

core/optimizer/math/math.factor

@@ -111,7 +111,7 @@ optimizer.def-use generic.standard ;
 
 : post-process ( class interval node -- classes intervals )
     dupd won't-overflow?
-    [ >r dup { f integer } memq? [ drop fixnum ] when r> ] when
+    [ >r dup { f integer } member? [ drop fixnum ] when r> ] when
     [ dup [ 1array ] when ] 2apply ;
 
 : math-output-interval-1 ( node word -- interval )

core/prettyprint/backend/backend-docs.factor

@@ -31,7 +31,7 @@ HELP: do-string-limit
 { $description "If " { $link string-limit } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ;
 
 HELP: pprint-string
-{ $values { "obj" object } { "str" string } { "prefix" "a prefix string" } }
+{ $values { "obj" object } { "str" string } { "prefix" string } { "suffix" string } }
 { $description "Outputs a text section consisting of the prefix, the string, and a final quote (\")." }
 $prettyprinting-note ;
 

core/prettyprint/backend/backend.factor

@@ -89,19 +89,20 @@ M: f pprint* drop \ f pprint-word ;
         { 0.3 0.3 0.3 1.0 } foreground set
     ] H{ } make-assoc ;
 
-: unparse-string ( str prefix -- str )
-    [
-        % do-string-limit [ unparse-ch ] each CHAR: " ,
-    ] "" make ;
+: unparse-string ( str prefix suffix -- str )
+    [ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ;
 
-: pprint-string ( obj str prefix -- )
+: pprint-string ( obj str prefix suffix -- )
     unparse-string swap string-style styled-text ;
 
-M: string pprint* dup "\"" pprint-string ;
+M: string pprint*
+    dup "\"" "\"" pprint-string ;
 
-M: sbuf pprint* dup "SBUF\" " pprint-string ;
+M: sbuf pprint*
+    dup "SBUF\" " "\"" pprint-string ;
 
-M: pathname pprint* dup pathname-string "P\" " pprint-string ;
+M: pathname pprint*
+    dup pathname-string "P\" " "\"" pprint-string ;
 
 ! Sequences
 : nesting-limit? ( -- ? )

core/quotations/quotations-docs.factor

@@ -22,7 +22,7 @@ $nl
 ABOUT: "quotations"
 
 HELP: callable
-{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations, " { $link f } " (which behaves like an empty quotation), and composed quotations built up with " { $link curry } "." } ;
+{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations and composed quotations built up with " { $link curry } " or " { $link compose } "." } ;
 
 HELP: quotation
 { $description "The class of quotations. See " { $link "syntax-quots" } " for syntax and " { $link "quotations" } " for general information." } ;

core/quotations/quotations-tests.factor

@@ -1,8 +1,8 @@
 USING: math kernel quotations tools.test sequences ;
 IN: temporary
 
-[ [ 3 ] ] [ 3 f curry ] unit-test
-[ [ \ + ] ] [ \ + f curry ] unit-test
+[ [ 3 ] ] [ 3 [ ] curry ] unit-test
+[ [ \ + ] ] [ \ + [ ] curry ] unit-test
 [ [ \ + = ] ] [ \ + [ = ] curry ] unit-test
 
 [ [ 1 + 2 + 3 + ] ] [
@@ -14,3 +14,5 @@ IN: temporary
 [ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test
 
 [ [ "hi" ] ] [ "hi" 1quotation ] unit-test
+
+[ 1 \ + curry ] unit-test-fails

core/sequences/sequences.factor

@@ -44,7 +44,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
 TUPLE: bounds-error index seq ;
 
 : bounds-error ( n seq -- * )
-    die \ bounds-error construct-boa throw ;
+    \ bounds-error construct-boa throw ;
 
 : bounds-check ( n seq -- n seq )
     2dup bounds-check? [ bounds-error ] unless ; inline
@@ -221,7 +221,8 @@ TUPLE: column seq col ;
 C: <column> column
 
 M: column virtual-seq column-seq ;
-M: column virtual@ dup column-col -rot column-seq nth ;
+M: column virtual@
+    dup column-col -rot column-seq nth bounds-check ;
 M: column length column-seq length ;
 
 INSTANCE: column virtual-sequence
@@ -546,11 +547,6 @@ M: sequence <=>
 
 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
 
-: flip ( matrix -- newmatrix )
-    dup empty? [
-        dup first length [ <column> dup like ] curry* map
-    ] unless ;
-
 : exchange ( m n seq -- )
     pick over bounds-check 2drop 2dup bounds-check 2drop
     exchange-unsafe ;
@@ -667,7 +663,19 @@ PRIVATE>
 : infimum ( seq -- n ) dup first [ min ] reduce ;
 : supremum ( seq -- n ) dup first [ max ] reduce ;
 
+: flip ( matrix -- newmatrix )
+    dup empty? [
+        dup [ length ] map infimum
+        [ <column> dup like ] curry* map
+    ] unless ;
+
+: sequence-hashcode-step ( oldhash newpart -- newhash )
+    swap [
+        dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum
+        fixnum+fast fixnum+fast
+    ] keep bitxor ; inline
+
 : sequence-hashcode ( n seq -- x )
     0 -rot [
-        hashcode* >fixnum swap 31 fixnum*fast fixnum+fast
+        hashcode* >fixnum sequence-hashcode-step
     ] curry* each ; inline

extra/bake/authors.txt

@@ -0,0 +1 @@
+Eduardo Cavazos

extra/bake/bake.factor

@@ -1,6 +1,6 @@
 
-USING: kernel parser namespaces quotations vectors strings
-sequences assocs tuples math combinators ;
+USING: kernel parser namespaces quotations arrays vectors strings
+       sequences assocs tuples math combinators ;
 
 IN: bake
 
@@ -22,6 +22,10 @@ C: <splice-quot> splice-quot
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: ,u ( seq -- seq ) unclip building get push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 SYMBOL: exemplar
 
 : reset-building ( -- ) 1024 <vector> building set ;
@@ -35,6 +39,7 @@ DEFER: bake
 : bake-item ( item -- )
   { { [ dup \ , = ]        [ drop , ] }
     { [ dup \ % = ] 	   [ drop % ] }
+    { [ dup \ ,u = ]	   [ drop ,u ] }
     { [ dup insert-quot? ] [ insert-quot-expr call , ] }
     { [ dup splice-quot? ] [ splice-quot-expr call % ] }
     { [ dup integer? ]     [ , ] }
@@ -48,4 +53,9 @@ DEFER: bake
 : bake-items ( seq -- ) [ bake-item ] each ;
 
 : bake ( seq -- seq )
-  [ reset-building save-exemplar bake-items finish-baking ] with-scope ;
+  [ reset-building save-exemplar bake-items finish-baking ] with-scope ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
+

extra/bake/summary.txt

@@ -0,0 +1 @@
+Bake is similar to make but with additional features

extra/benchmark/knucleotide/authors.txt

@@ -0,0 +1 @@
+Eric Mertens

extra/benchmark/knucleotide/knucleotide.factor

@@ -0,0 +1,64 @@
+USING: kernel io io.files splitting strings
+       hashtables sequences assocs math namespaces prettyprint
+       math.parser combinators arrays sorting ;
+
+IN: benchmark.knucleotide
+
+: float>string ( float places -- string )
+    swap >float number>string
+    "." split1 rot
+    over length over <
+    [ CHAR: 0 pad-right ] 
+    [ head ] if "." swap 3append ;
+
+: discard-lines ( -- )
+    readln
+    [ ">THREE" head? [ discard-lines ] unless ] when* ;
+
+: read-input ( -- input )
+    discard-lines
+    ">" read-until drop
+    CHAR: \n swap remove >upper ;
+
+: tally ( x exemplar -- b )
+    clone tuck
+    [
+      [ [ 1+ ] [ 1 ] if* ] change-at
+    ] curry each ;
+
+: small-groups ( x n -- b )
+    swap
+    [ length swap - 1+ ] 2keep
+    [ >r over + r> subseq ] 2curry map ;
+
+: handle-table ( inputs n -- )
+    small-groups
+    [ length ] keep
+    H{ } tally >alist
+    sort-values reverse
+    [
+      dup first write bl
+      second 100 * over / 3 float>string print
+    ] each
+    drop ;
+
+: handle-n ( inputs x -- )
+    tuck length
+    small-groups H{ } tally
+    at [ 0 ] unless*
+    number>string 8 CHAR: \s pad-right write ;
+
+: process-input ( input -- )
+    dup 1 handle-table nl
+    dup 2 handle-table nl
+    { "GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT" }
+    [ [ dupd handle-n ] keep print ] each
+    drop ;
+
+: knucleotide ( -- )
+    "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
+    <file-reader>
+    [ read-input ] with-stream
+    process-input ;
+
+MAIN: knucleotide

extra/benchmark/knucleotide/summary.txt

@@ -0,0 +1,2 @@
+The Great Computer Language Shootout's knucleotide benchmark to test
+hashtables.

extra/benchmark/mandel/mandel.factor

@@ -64,7 +64,7 @@ SYMBOL: cols
         building get >string
     ] with-scope ;
 
-: mandel-main ( file -- )
+: mandel-main ( -- )
     "mandel.ppm" resource-path <file-writer>
     [ mandel write ] with-stream ;
 

extra/benchmark/reverse-complement/reverse-complement.factor

@@ -26,6 +26,8 @@ HINTS: do-trans-map string ;
         over push
     ] if ;
 
+HINTS: do-line vector string ;
+
 : (reverse-complement) ( seq -- )
     readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
 

extra/benchmark/spectral-norm/spectral-norm.factor

@@ -49,7 +49,7 @@ IN: benchmark.spectral-norm
 
 HINTS: spectral-norm fixnum ;
 
-: spectral-norm-main ( n -- )
+: spectral-norm-main ( -- )
     2000 spectral-norm . ;
 
 MAIN: spectral-norm-main

extra/benchmark/sum-file/sum-file.factor

@@ -4,7 +4,7 @@ IN: benchmark.sum-file
 : sum-file-loop ( n -- n' )
     readln [ string>number + sum-file-loop ] when* ;
 
-: sum-file ( file -- n )
+: sum-file ( file -- )
     <file-reader> [ 0 sum-file-loop ] with-stream . ;
 
 : sum-file-main ( -- )

extra/cabal/authors.txt

@@ -0,0 +1 @@
+Eduardo Cavazos

extra/cabal/summary.txt

@@ -0,0 +1 @@
+Minimalist chat server

extra/cabal/ui/authors.txt

@@ -0,0 +1,2 @@
+Matthew Willis
+Eduardo Cavazos

extra/cabal/ui/summary.txt

@@ -0,0 +1 @@
+Connects to a cabal server

extra/calendar/calendar.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: arrays hashtables io io.streams.string kernel math
-math.vectors math.functions math.parser
-namespaces sequences strings tuples system ;
+math.vectors math.functions math.parser namespaces sequences
+strings tuples system debugger ;
 IN: calendar
 
 TUPLE: timestamp year month day hour minute second gmt-offset ;
@@ -316,7 +316,28 @@ M: timestamp <=> ( ts1 ts2 -- n )
 : timestamp>rfc3339 ( timestamp -- str )
     >gmt [
         (timestamp>rfc3339)
-     ] string-out ;
+    ] string-out ;
+
+: expect read1 assert= ;
+
+: (rfc3339>timestamp) ( -- timestamp )
+    4 read string>number ! year
+    CHAR: - expect
+    2 read string>number ! month
+    CHAR: - expect
+    2 read string>number ! day
+    CHAR: T expect
+    2 read string>number ! hour
+    CHAR: : expect
+    2 read string>number ! minute
+    CHAR: : expect
+    2 read string>number ! second
+    0 <timestamp> ;
+
+: rfc3339>timestamp ( str -- timestamp )
+    [
+        (rfc3339>timestamp)
+    ] string-in ;
 
 : file-time-string ( timestamp -- string )
     [

extra/cfdg/summary.txt

@@ -0,0 +1 @@
+Implementation of: http://contextfreeart.org

extra/channels/remote/remote-docs.factor

@@ -13,7 +13,7 @@ HELP: <remote-channel>
 "returned by " { $link publish }
 }
 { $examples 
-  { $example "\"localhost\" 9000 <node> \"ID123456\" <remote-channel> \"foo\" over to" }
+  { $code "\"localhost\" 9000 <node> \"ID123456\" <remote-channel> \"foo\" over to" }
 }
 { $see-also publish unpublish } ;
 
@@ -24,7 +24,7 @@ HELP: unpublish
 "accessible by remote nodes."
 }
 { $examples 
-  { $example "<channel> publish unpublish" }
+  { $code "<channel> publish unpublish" }
 }
 { $see-also <remote-channel> publish } ;
 
@@ -37,7 +37,7 @@ HELP: publish
 { $link to } " and " { $link from } " to access the channel."
 }
 { $examples 
-  { $example "<channel> publish" }
+  { $code "<channel> publish" }
 }
 { $see-also <remote-channel> unpublish } ;
 

extra/cocoa/cocoa.factor

@@ -58,8 +58,9 @@ SYMBOL: super-sent-messages
     "NSSavePanel"
     "NSView"
     "NSWindow"
+    "NSWorkspace"
 } [
-    f import-objc-class
+    [ ] import-objc-class
 ] each
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;

extra/cocoa/messages/messages.factor

@@ -4,7 +4,7 @@ USING: alien alien.c-types alien.compiler
 arrays assocs combinators compiler inference.transforms kernel
 math namespaces parser prettyprint prettyprint.sections
 quotations sequences strings words cocoa.runtime io macros
-memoize ;
+memoize debugger ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -201,8 +201,11 @@ H{
 : import-objc-class ( name quot -- )
     2dup unless-defined
     dupd define-objc-class-word
-    dup objc-class register-objc-methods
-    objc-meta-class register-objc-methods ;
+    [
+        dup
+        objc-class register-objc-methods
+        objc-meta-class register-objc-methods
+    ] curry try ;
 
 : root-class ( class -- root )
     dup objc-class-super-class [ root-class ] [ ] ?if ;

extra/combinators/lib/lib-docs.factor

@@ -1,8 +1,9 @@
-USING: help.syntax help.markup kernel prettyprint sequences ;
+USING: help.syntax help.markup kernel prettyprint sequences
+quotations math ;
 IN: combinators.lib
 
 HELP: generate
-{ $values { "generator" "a quotation" } { "predicate" "a quotation" } { "obj" "an object" } }
+{ $values { "generator" quotation } { "predicate" quotation } { "obj" object } }
 { $description "Loop until the generator quotation generates an object that satisfies predicate quotation." }
 { $unchecked-example
     "! Generate a random 20-bit prime number congruent to 3 (mod 4)"
@@ -12,7 +13,7 @@ HELP: generate
 } ;
 
 HELP: ndip
-{ $values { "quot" "a quotation" } { "n" "a number" } }
+{ $values { "quot" quotation } { "n" number } }
 { $description "A generalisation of " { $link dip } " that can work " 
 "for any stack depth. The quotation will be called with a stack that "
 "has 'n' items removed first. The 'n' items are then put back on the "
@@ -25,7 +26,7 @@ HELP: ndip
 { $see-also dip dipd } ;
 
 HELP: nslip
-{ $values { "n" "a number" } }
+{ $values { "n" number } }
 { $description "A generalisation of " { $link slip } " that can work " 
 "for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
 "removed from the stack, the quotation called, and the items restored."
@@ -36,7 +37,7 @@ HELP: nslip
 { $see-also slip nkeep } ;
 
 HELP: nkeep
-{ $values { "quot" "a quotation" } { "n" "a number" } }
+{ $values { "quot" quotation } { "n" number } }
 { $description "A generalisation of " { $link keep } " that can work " 
 "for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
 "saved, the quotation called, and the items restored."
@@ -47,7 +48,7 @@ HELP: nkeep
 { $see-also keep nslip } ;
 
 HELP: map-withn
-{ $values { "seq" "a sequence" } { "quot" "a quotation" } { "n" "a number" } { "newseq" "a sequence" } }
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }
 { $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "
 "passed to the quotation given to map-withn for each element in the sequence."
 } 
@@ -57,43 +58,44 @@ HELP: map-withn
 { $see-also each-withn } ;
 
 HELP: each-withn
-{ $values { "seq" "a sequence" } { "quot" "a quotation" } { "n" "a number" } }
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
 { $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "
 "passed to the quotation given to each-withn for each element in the sequence."
 } 
 { $see-also map-withn } ;
 
 HELP: sigma
-{ $values { "seq" "a sequence" } { "quot" "a quotation" } }
+{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
 { $description "Like map sum, but without creating an intermediate sequence." }
 { $example
     "! Find the sum of the squares [0,99]"
-    "USE: math.ranges"
-    "100 [1,b] [ sq ] sigma"
+    "USING: math.ranges combinators.lib ;"
+    "100 [1,b] [ sq ] sigma ."
     "338350"
 } ;
 
 HELP: count
-{ $values { "seq" "a sequence" } { "quot" "a quotation" } }
+{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }
 { $description "Efficiently returns the number of elements that the predicate quotation matches." }
 { $example
-    "USE: math.ranges"
+    "USING: math.ranges combinators.lib ;"
     "100 [1,b] [ even? ] count ."
     "50"
 } ;
 
 HELP: all-unique?
-{ $values { "seq" "a sequence" } { "?" "a boolean" } }
+{ $values { "seq" sequence } { "?" "a boolean" } }
 { $description "Tests whether a sequence contains any repeated elements." }
 { $example
+    "USE: combinators.lib"
     "{ 0 1 1 2 3 5 } all-unique? ."
     "f"
 } ;
 
 HELP: &&
-{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } }
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
 { $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ;
 
 HELP: ||
-{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } }
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
 { $description "Calls each quotation in turn; outputs " { $link t } " if one of the quotations output " { $link t } ", otherwise outputs " { $link f } ". As soon as a quotation outputs " { $link t } ", evaluation stops and subsequent quotations are not called." } ;

extra/combinators/lib/lib-tests.factor

@@ -58,3 +58,5 @@ IN: temporary
         [ dup array? ] [ dup vector? ] [ dup float? ]
     } || nip
 ] unit-test
+
+[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

extra/combinators/lib/lib.factor

@@ -67,6 +67,9 @@ MACRO: napply ( n -- )
 
 : map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
 
+MACRO: nfirst ( n -- )
+    [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ;

extra/concurrency/concurrency-docs.factor

@@ -25,9 +25,8 @@ HELP: mailbox-put
 
 HELP: (mailbox-block-unless-pred)
 { $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } 
-          { "mailbox" "a mailbox object" } 
-	  { "pred2" "same object as 'pred'" }
-	  { "mailbox2" "same object as 'mailbox'" }
+          { "mailbox" "a mailbox object" }
+          { "timeout" "a timeout in milliseconds" }
 }
 { $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack. The predicate must have stack effect " { $snippet "( X -- bool )" } "." } 
 { $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
@@ -35,6 +34,7 @@ HELP: (mailbox-block-unless-pred)
 HELP: (mailbox-block-if-empty)
 { $values { "mailbox" "a mailbox object" } 
 	  { "mailbox2" "same object as 'mailbox'" }
+      { "timeout" "a timeout in milliseconds" }
 }
 { $description "Block the thread if the mailbox is empty." } 
 { $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;

extra/crypto/common/common-docs.factor

@@ -13,8 +13,8 @@ HELP: bitroll
 { $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" "an integer" } }
 { $description "Roll n by s bits to the left, wrapping around after w bits." }
 { $examples
-    { $example "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
-    { $example "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
+    { $example "USE: crypto.common" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
+    { $example "USE: crypto.common" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
 } ;
 
 
@@ -22,7 +22,7 @@ HELP: hex-string
 { $values { "seq" "a sequence" } { "str" "a string" } }
 { $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
 { $examples
-    { $example "B{ 1 2 3 4 } hex-string print" "01020304" }
+    { $example "USE: crypto.common" "B{ 1 2 3 4 } hex-string print" "01020304" }
 }
 { $notes "Numbers are zero-padded on the left." } ;
 

extra/delegate/author.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

extra/delegate/delegate-docs.factor

@@ -0,0 +1,52 @@
+USING: delegate help.syntax help.markup ;
+
+HELP: define-protocol
+{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } }
+{ $description "Defines a symbol as a protocol." }
+{ $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ;
+
+HELP: PROTOCOL:
+{ $syntax "PROTOCOL: protocol-name words... ;" }
+{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ;
+
+{ define-protocol POSTPONE: PROTOCOL: } related-words
+
+HELP: define-consult
+{ $values { "class" "a class" } { "group" "a protocol, generic word or tuple class" } { "quot" "a quotation" } }
+{ $description "Defines a class to consult, using the given quotation, on the generic words contained in the group." }
+{ $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ;
+
+HELP: CONSULT:
+{ $syntax "CONSULT: group class getter... ;" } 
+{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } }
+{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ;
+
+{ define-consult POSTPONE: CONSULT: } related-words
+
+HELP: define-mimic
+{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
+{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." }
+{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ;
+
+HELP: MIMIC:
+{ $syntax "MIMIC: group mimicker mimicked" }
+{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
+{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ;
+
+HELP: group-words
+{ $values { "group" "a group" } { "words" "an array of words" } }
+{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ;
+
+ARTICLE: { "delegate" "intro" } "Delegation module"
+"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use"
+{ $subsection POSTPONE: PROTOCOL: }
+{ $subsection define-protocol }
+"One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are"
+{ $subsection POSTPONE: CONSULT: }
+{ $subsection define-consult }
+"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are"
+{ $subsection POSTPONE: MIMIC: }
+{ $subsection define-mimic } ;
+
+IN: delegate
+ABOUT: { "delegate" "intro" }

extra/delegate/delegate-tests.factor

@@ -0,0 +1,26 @@
+USING: delegate kernel arrays tools.test ;
+
+TUPLE: hello this that ;
+C: <hello> hello
+
+TUPLE: goodbye these those ;
+C: <goodbye> goodbye
+
+GENERIC: foo ( x -- y )
+GENERIC: bar ( a -- b )
+PROTOCOL: baz foo bar ;
+
+CONSULT: baz goodbye goodbye-these ;
+M: hello foo hello-this ;
+M: hello bar dup hello? swap hello-that 2array ;
+
+GENERIC: bing ( c -- d )
+CONSULT: hello goodbye goodbye-these ;
+M: hello bing dup hello? swap hello-that 2array ;
+MIMIC: bing goodbye hello
+
+[ 1 { t 0 } ] [ 1 0 <hello> [ foo ] keep bar ] unit-test
+[ { t 0 } ] [ 1 0 <hello> bing ] unit-test
+[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
+[ { t 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
+[ { f 0 } ] [ 1 0 <hello> f <goodbye> bing ] unit-test

extra/delegate/delegate.factor

@@ -0,0 +1,73 @@
+! Copyright (C) 2007 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser generic kernel classes words slots io definitions
+sequences sequences.private assocs prettyprint.sections arrays ;
+IN: delegate
+
+: define-protocol ( wordlist protocol -- )
+    swap { } like "protocol-words" set-word-prop ;
+
+: PROTOCOL:
+    CREATE dup reset-generic dup define-symbol
+    parse-definition swap define-protocol ; parsing
+
+PREDICATE: word protocol "protocol-words" word-prop ;
+
+GENERIC: group-words ( group -- words )
+
+M: protocol group-words
+    "protocol-words" word-prop ;
+
+M: generic group-words
+    1array ;
+
+M: tuple-class group-words
+    "slots" word-prop 1 tail ! The first slot is the delegate
+    ! 1 tail should be removed when the delegate slot is removed
+    dup [ slot-spec-reader ] map
+    swap [ slot-spec-writer ] map append ;
+
+: spin ( x y z -- z y x )
+    swap rot ;
+
+: define-consult-method ( word class quot -- )
+    pick add <method> spin define-method ;
+
+: define-consult ( class group quot -- )
+    >r group-words r>
+    swapd [ define-consult-method ] 2curry each ;
+
+: CONSULT:
+    scan-word scan-word parse-definition swapd define-consult ; parsing
+
+PROTOCOL: sequence-protocol
+    clone clone-like like new new-resizable nth nth-unsafe
+    set-nth set-nth-unsafe length immutable set-length lengthen ;
+
+PROTOCOL: assoc-protocol
+    at* assoc-size >alist assoc-find set-at
+    delete-at clear-assoc new-assoc assoc-like ;
+
+PROTOCOL: stream-protocol
+    stream-close stream-read1 stream-read stream-read-until
+    stream-flush stream-write1 stream-write stream-format
+    stream-nl make-span-stream make-block-stream stream-readln
+    make-cell-stream stream-write-table set-timeout ;
+
+PROTOCOL: definition-protocol
+    where set-where forget uses redefined*
+    synopsis* definer definition ;
+
+PROTOCOL: prettyprint-section-protocol
+    section-fits? indent-section? unindent-first-line?
+    newline-after?  short-section? short-section long-section
+    <section> delegate>block add-section ;
+
+: define-mimic ( group mimicker mimicked -- )
+    >r >r group-words r> r> [
+        pick "methods" word-prop at dup
+        [ method-def <method> spin define-method ] [ 3drop ] if
+    ] 2curry each ; 
+
+: MIMIC:
+    scan-word scan-word scan-word define-mimic ; parsing

extra/delegate/summary.txt

@@ -0,0 +1 @@
+Delegation and mimicking on top of the Factor object system

extra/documents/documents.factor

@@ -167,6 +167,12 @@ M: char-elt prev-elt
 M: char-elt next-elt
     drop [ drop 1 +col ] (next-char) ;
 
+TUPLE: one-char-elt ;
+
+M: one-char-elt prev-elt 2drop ;
+
+M: one-char-elt next-elt 2drop ;
+
 : (word-elt) ( loc document quot -- loc )
     pick >r
     >r >r first2 swap r> doc-line r> call
@@ -189,11 +195,11 @@ TUPLE: one-word-elt ;
 
 M: one-word-elt prev-elt
     drop
-    [ [ f -rot >r 1- r> (prev-word) ] (word-elt) ] (prev-char) ;
+    [ f -rot >r 1- r> (prev-word) ] (word-elt) ;
 
 M: one-word-elt next-elt
     drop
-    [ [ f -rot (next-word) ] (word-elt) ] (next-char) ;
+    [ f -rot (next-word) ] (word-elt) ;
 
 TUPLE: word-elt ;
 

extra/editors/editors.factor

@@ -1,21 +1,36 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser kernel namespaces sequences definitions io.files
-inspector continuations tuples tools.crossref io prettyprint
-source-files ;
+inspector continuations tuples tools.crossref tools.browser 
+io prettyprint source-files assocs vocabs vocabs.loader ;
 IN: editors
 
 TUPLE: no-edit-hook ;
 
-M: no-edit-hook summary drop "No edit hook is set" ;
+M: no-edit-hook summary
+    drop "You must load one of the below vocabularies before using editor integration:" ;
 
 SYMBOL: edit-hook
 
+: available-editors ( -- seq )
+    "editors" all-child-vocabs
+    values concat [ vocab-name ] map ;
+
+: editor-restarts ( -- alist )
+    available-editors
+    [ "Load " over append swap ] { } map>assoc ;
+
+: no-edit-hook ( -- )
+    \ no-edit-hook construct-empty
+    editor-restarts throw-restarts
+    require ;
+
 : edit-location ( file line -- )
-    >r ?resource-path r>
-    edit-hook get dup [
-        \ no-edit-hook construct-empty throw
-    ] if ;
+    edit-hook get [
+        >r >r ?resource-path r> r> call
+    ] [
+        no-edit-hook edit-location
+    ] if* ;
 
 : edit ( defspec -- )
     where [ first2 edit-location ] when* ;

extra/editors/editpadpro/editpadpro.factor

@@ -1,8 +1,15 @@
 USING: definitions kernel parser words sequences math.parser
-namespaces editors io.launcher ;
+namespaces editors io.launcher windows.shell32 io.files
+io.paths strings ;
 IN: editors.editpadpro
 
+: editpadpro-path
+    \ editpadpro-path get-global [
+        program-files "JGsoft" path+ walk-dir
+        [ >lower "editpadpro.exe" tail? ] find nip
+    ] unless* ;
+
 : editpadpro ( file line -- )
-    [ "editpadpro.exe /l" % # " \"" % % "\"" % ] "" make run-process ;
+    [ editpadpro-path % " /l" % # " \"" % % "\"" % ] "" make run-detached ;
 
 [ editpadpro ] edit-hook set-global

extra/editors/editpadpro/summary.txt

@@ -0,0 +1 @@
+EditPadPro editor integration

extra/editors/editplus/authors.txt

@@ -0,0 +1 @@
+Aaron Schaefer

extra/editors/editplus/editplus.factor

@@ -0,0 +1,15 @@
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 ;
+IN: editors.editplus
+
+: editplus-path ( -- path )
+    \ editplus-path get-global [
+        program-files "\\EditPlus 2\\editplus.exe" append
+    ] unless* ;
+
+: editplus ( file line -- )
+    [
+        editplus-path % " -cursor " % # " " % %
+    ] "" make run-detached ;
+
+[ editplus ] edit-hook set-global

extra/editors/editplus/summary.txt

@@ -0,0 +1 @@
+EditPlus editor integration

extra/editors/emacs/summary.txt

@@ -0,0 +1 @@
+Emacs editor integration

extra/editors/emeditor/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/editors/emeditor/emeditor.factor

@@ -0,0 +1,16 @@
+USING: editors hardware-info.windows io.files io.launcher
+kernel math.parser namespaces sequences windows.shell32 ;
+IN: editors.emeditor
+
+: emeditor-path ( -- path )
+    \ emeditor-path get-global [
+        program-files "\\EmEditor\\EmEditor.exe" path+
+    ] unless* ;
+
+: emeditor ( file line -- )
+    [
+        emeditor-path % " /l " % #
+        " " % "\"" % % "\"" %
+    ] "" make run-detached ;
+
+[ emeditor ] edit-hook set-global

extra/editors/emeditor/summary.txt

@@ -0,0 +1 @@
+EmEditor integration

extra/editors/gvim/gvim.factor

@@ -1,14 +1,18 @@
-USING: kernel math math.parser namespaces editors.vim ;
+USING: io.backend io.files kernel math math.parser
+namespaces editors.vim sequences system ;
 IN: editors.gvim
 
 TUPLE: gvim ;
 
+HOOK: gvim-path io-backend ( -- path )
+
+
 M: gvim vim-command ( file line -- string )
-    [
-        "\"" % vim-path get % "\"" %
-        vim-switches get [ % ] when*
-        "+" % # " \"" % % "\"" %
-    ] "" make ;
+    [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
+
+t vim-detach set-global ! don't block the ui
 
 T{ gvim } vim-editor set-global
-"gvim" vim-path set-global
+
+USE-IF: unix? editors.gvim.unix
+USE-IF: windows? editors.gvim.windows

extra/editors/gvim/summary.txt

@@ -0,0 +1 @@
+gVim editor integration

extra/editors/gvim/unix/unix.factor

@@ -0,0 +1,7 @@
+USING: editors.gvim io.unix.backend kernel namespaces ;
+IN: editors.gvim.unix
+
+M: unix-io gvim-path
+    \ gvim-path get-global [
+        "gvim"
+    ] unless* ;

extra/editors/gvim/windows/windows.factor

@@ -0,0 +1,8 @@
+USING: editors.gvim io.files io.windows kernel namespaces
+sequences windows.shell32 ;
+IN: editors.gvim.windows
+
+M: windows-io gvim-path
+    \ gvim-path get-global [
+        program-files walk-dir [ "gvim.exe" tail? ] find nip
+    ] unless* ;

extra/editors/notepadpp/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/editors/notepadpp/notepadpp.factor

@@ -0,0 +1,15 @@
+USING: editors io.files io.launcher kernel math.parser
+namespaces windows.shell32 ;
+IN: editors.notepadpp
+
+: notepadpp-path
+    \ notepadpp-path get-global [
+        program-files "notepad++\\notepad++.exe" path+
+    ] unless* ;
+
+: notepadpp ( file line -- )
+    [
+        notepadpp-path % " -n" % # " " % %
+    ] "" make run-detached ;
+
+[ notepadpp ] edit-hook set-global

extra/editors/notepadpp/summary.txt

@@ -0,0 +1 @@
+Notepad++ editor integration

extra/editors/scite/summary.txt

@@ -0,0 +1 @@
+SciTE editor integration

extra/editors/ted-notepad/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/editors/ted-notepad/summary.txt

@@ -0,0 +1 @@
+TED Notepad integration

extra/editors/ted-notepad/ted-notepad.factor

@@ -0,0 +1,16 @@
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 ;
+IN: editors.ted-notepad
+
+: ted-notepad-path
+    \ ted-notepad-path get-global [
+        program-files "\\TED Notepad\\TedNPad.exe" path+
+    ] unless* ;
+
+: ted-notepad ( file line -- )
+    [
+        ted-notepad-path % " /l" % #
+        " " % %
+    ] "" make run-detached ;
+
+[ ted-notepad ] edit-hook set-global

extra/editors/textmate/summary.txt

@@ -0,0 +1 @@
+Textmate editor integration

extra/editors/ultraedit/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/editors/ultraedit/summary.txt

@@ -0,0 +1 @@
+UltraEdit editor integration

extra/editors/ultraedit/ultraedit.factor

@@ -0,0 +1,17 @@
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 ;
+IN: editors.ultraedit
+
+: ultraedit-path ( -- path )
+    \ ultraedit-path get-global [
+        program-files
+        "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+
+    ] unless* ;
+
+: ultraedit ( file line -- )
+    [
+        ultraedit-path % " " % swap % "/" % # "/1" %
+    ] "" make run-detached ;
+
+
+[ ultraedit ] edit-hook set-global

extra/editors/vim/summary.txt

@@ -0,0 +1 @@
+Vim editor integration

extra/editors/wordpad/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/editors/wordpad/summary.txt

@@ -0,0 +1 @@
+Wordpad editor integration

extra/editors/wordpad/wordpad.factor

@@ -0,0 +1,15 @@
+USING: editors hardware-info.windows io.launcher kernel
+math.parser namespaces sequences windows.shell32 ;
+IN: editors.wordpad
+
+: wordpad-path ( -- path )
+    \ wordpad-path get [
+        program-files "\\Windows NT\\Accessories\\wordpad.exe" append
+    ] unless* ;
+
+: wordpad ( file line -- )
+    [
+        wordpad-path % drop " " % "\"" % % "\"" %
+    ] "" make run-detached ;
+
+[ wordpad ] edit-hook set-global

extra/faq/faq.factor

@@ -0,0 +1,114 @@
+! Copyright (C) 2007 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml kernel sequences xml.utilities combinators.lib
+math xml.data arrays assocs xml.generator xml.writer namespaces
+math.parser io ;
+IN: faq
+
+: find-after ( seq quot -- elem after )
+    over >r find r> rot 1+ tail ; inline
+
+: tag-named? ( tag name -- ? )
+    assure-name swap (get-tag) ;
+
+! Questions
+TUPLE: q/a question answer ;
+C: <q/a> q/a
+
+: li>q/a ( li -- q/a )
+    [ "br" tag-named? not ] subset
+    [ "strong" tag-named? ] find-after
+    >r tag-children r> <q/a> ;
+
+: q/a>li ( q/a -- li )
+    [ q/a-question "strong" build-tag* f "br" build-tag* 2array ] keep
+    q/a-answer append "li" build-tag* ;
+
+: xml>q/a ( xml -- q/a )
+    [ "question" tag-named tag-children ] keep
+    "answer" tag-named tag-children <q/a> ;
+
+: q/a>xml ( q/a -- xml )
+    [ q/a-question "question" build-tag* ] keep
+    q/a-answer "answer" build-tag*
+    "\n" swap 3array "qa" build-tag* ;
+
+! Lists of questions
+TUPLE: question-list title seq ;
+C: <question-list> question-list
+
+: xml>question-list ( list -- question-list )
+    [ "title" swap at ] keep
+    tag-children [ tag? ] subset [ xml>q/a ] map
+    <question-list> ;
+
+: question-list>xml ( question-list -- list )
+    [ question-list-seq [ q/a>xml "\n" swap 2array ]
+      map concat "list" build-tag* ] keep
+    question-list-title [ "title" pick set-at ] when* ;
+
+: html>question-list ( h3 ol -- question-list )
+    >r [ children>string ] [ f ] if* r>
+    children-tags [ li>q/a ] map <question-list> ;
+
+: question-list>h3 ( id question-list -- h3 )
+    question-list-title [
+        "h3" build-tag
+        swap number>string "id" pick set-at
+    ] [ drop f ] if* ;
+
+: question-list>html ( question-list start id -- h3/f ol )
+    -rot >r [ question-list>h3 ] keep
+    question-list-seq [ q/a>li ] map "ol" build-tag* r>
+    number>string "start" pick set-at
+    "margin-left: 5em" "style" pick set-at ;
+
+! Overall everything
+TUPLE: faq header lists ;
+C: <faq> faq
+
+: html>faq ( div -- faq )
+    unclip swap { "h3" "ol" } [ tags-named ] curry* map
+    first2 >r f add* r> [ html>question-list ] 2map <faq> ;
+
+: header, ( faq -- )
+    dup faq-header ,
+    faq-lists first 1 -1 question-list>html nip , ;
+
+: br, ( -- )
+    "br" contained, nl, ;
+
+: toc-link, ( question-list number -- )
+    number>string "#" swap append "href" swap 2array 1array
+    "a" swap [ question-list-title , ] tag*, br, ;
+
+: toc, ( faq -- )
+    "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
+        "strong" [ "The big questions" , ] tag, br,
+        faq-lists 1 tail dup length [ toc-link, ] 2each
+    ] tag*, ;
+
+: faq-sections, ( question-lists -- )
+    unclip question-list-seq length 1+ dupd
+    [ question-list-seq length + ] accumulate nip
+    0 -rot [ pick question-list>html [ , nl, ] 2apply 1+ ] 2each drop ;
+
+: faq>html ( faq -- div )
+    "div" [
+        dup header,
+        dup toc,
+        faq-lists faq-sections,
+    ] make-xml ;
+
+: xml>faq ( xml -- faq )
+    [ "header" tag-named children>string ] keep
+    "list" tags-named [ xml>question-list ] map <faq> ;
+
+: faq>xml ( faq -- xml )
+    "faq" [
+        "header" [ dup faq-header , ] tag,
+        faq-lists [ question-list>xml , nl, ] each
+    ] make-xml ;
+
+: read-write-faq ( xml-stream -- )
+    read-xml xml>faq faq>html write-xml ;

extra/fjsc/fjsc-tests.factor

@@ -4,51 +4,51 @@ USING: kernel tools.test parser-combinators lazy-lists fjsc ;
 IN: temporary
 
 { T{ ast-expression f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
-  "55 2abc1 100" 'expression' parse car parse-result-parsed
+  "55 2abc1 100" 'expression' parse-1
 ] unit-test
 
 { T{ ast-quotation f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
-  "[ 55 2abc1 100 ]" 'quotation' parse car parse-result-parsed
+  "[ 55 2abc1 100 ]" 'quotation' parse-1
 ] unit-test
 
 { T{ ast-array f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
-  "{ 55 2abc1 100 }" 'array' parse car parse-result-parsed
+  "{ 55 2abc1 100 }" 'array' parse-1
 ] unit-test
 
 { T{ ast-stack-effect f { } { "d" "e" "f" } } } [
-  "( -- d e f )" 'stack-effect' parse car parse-result-parsed 
+  "( -- d e f )" 'stack-effect' parse-1
 ] unit-test
 
 { T{ ast-stack-effect f { "a" "b" "c" } { "d" "e" "f" } } } [
-  "( a b c -- d e f )" 'stack-effect' parse car parse-result-parsed 
+  "( a b c -- d e f )" 'stack-effect' parse-1
 ] unit-test
 
 { T{ ast-stack-effect f { "a" "b" "c" } { } } } [
-  "( a b c -- )" 'stack-effect' parse car parse-result-parsed 
+  "( a b c -- )" 'stack-effect' parse-1
 ] unit-test
 
 { T{ ast-stack-effect f { } { } } } [
-  "( -- )" 'stack-effect' parse car parse-result-parsed 
+  "( -- )" 'stack-effect' parse-1
 ] unit-test
 
 { } [
   ": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop
 ] unit-test
 
- 
-{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [ 
-  "\"abcd\"" 'statement' parse car parse-result-parsed 
-] unit-test 
+
+{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [
+  "\"abcd\"" 'statement' parse-1
+] unit-test
 
 { T{ ast-expression f { T{ ast-use f "foo" } } } } [
-  "USE: foo" 'statement' parse car parse-result-parsed
+  "USE: foo" 'statement' parse-1
 ] unit-test
 
 { T{ ast-expression f { T{ ast-in f "foo" } } } } [
-  "IN: foo" 'statement' parse car parse-result-parsed
+  "IN: foo" 'statement' parse-1
 ] unit-test
 
 { T{ ast-expression f { T{ ast-using f { "foo" "bar" }  } } } } [
-  "USING: foo bar ;" 'statement' parse car parse-result-parsed
+  "USING: foo bar ;" 'statement' parse-1
 ] unit-test
 

extra/fjsc/fjsc.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Chris Double. All Rights Reserved.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel lazy-lists parser-combinators  parser-combinators.simple
-       strings promises sequences math math.parser namespaces words 
+       strings promises sequences math math.parser namespaces words
        quotations arrays hashtables io io.streams.string assocs ;
 IN: fjsc
 
@@ -53,11 +53,11 @@ C: <ast-hashtable> ast-hashtable
   [ CHAR: ] = not ] keep
   [ CHAR: ;" = not ] keep
   [ CHAR: " = not ] keep
-  digit? not 
+  digit? not
   and and and and and ;
 
-LAZY: 'identifier-ends' ( -- parser )  
-  [ 
+LAZY: 'identifier-ends' ( -- parser )
+  [
     [ blank? not ] keep
     [ CHAR: " = not ] keep
     [ CHAR: ;" = not ] keep
@@ -67,23 +67,23 @@ LAZY: 'identifier-ends' ( -- parser )
     and and and and and
   ] satisfy <!*> ;
 
-LAZY: 'identifier-middle' ( -- parser )  
+LAZY: 'identifier-middle' ( -- parser )
   [ identifier-middle? ] satisfy <!+> ;
 
 LAZY: 'identifier' ( -- parser )
-  'identifier-ends' 
+  'identifier-ends'
   'identifier-middle' <&>
-  'identifier-ends' <:&> 
+  'identifier-ends' <:&>
   [ concat >string f <ast-identifier> ] <@ ;
 
-  
+
 DEFER: 'expression'
 
 LAZY: 'effect-name' ( -- parser )
-  [ 
+  [
     [ blank? not ] keep
     CHAR: - = not
-    and    
+    and
   ] satisfy <!+> [ >string ] <@ ;
 
 LAZY: 'stack-effect' ( -- parser )
@@ -94,24 +94,24 @@ LAZY: 'stack-effect' ( -- parser )
   ")" token sp <& [ first2 <ast-stack-effect> ] <@ ;
 
 LAZY: 'define' ( -- parser )
-  ":" token sp 
+  ":" token sp
   'identifier' sp [ ast-identifier-value ] <@ &>
   'stack-effect' sp <!?> <&>
   'expression' <:&>
   ";" token sp <& [ first3 <ast-define> ] <@ ;
 
 LAZY: 'quotation' ( -- parser )
-  "[" token sp 
+  "[" token sp
   'expression' [ ast-expression-values ] <@ &>
   "]" token sp <& [ <ast-quotation> ] <@ ;
 
 LAZY: 'array' ( -- parser )
-  "{" token sp 
+  "{" token sp
   'expression' [ ast-expression-values ] <@ &>
   "}" token sp <& [ <ast-array> ] <@ ;
 
 LAZY: 'word' ( -- parser )
-  "\\" token sp 
+  "\\" token sp
   'identifier' sp &> [ ast-identifier-value f <ast-word> ] <@ ;
 
 LAZY: 'atom' ( -- parser )
@@ -137,7 +137,7 @@ LAZY: 'USING:' ( -- parser )
   ";" token sp <& [ <ast-using> ] <@ ;
 
 LAZY: 'hashtable' ( -- parser )
-  "H{" token sp 
+  "H{" token sp
   'expression' [ ast-expression-values ] <@ &>
   "}" token sp <& [ <ast-hashtable> ] <@ ;
 
@@ -147,14 +147,14 @@ LAZY: 'parsing-word' ( -- parser )
   'IN:' <|> ;
 
 LAZY: 'expression' ( -- parser )
-  'comment' 
-  'parsing-word' sp <|> 
-  'quotation' sp <|> 
+  'comment'
+  'parsing-word' sp <|>
+  'quotation' sp <|>
   'define' sp <|>
   'array' sp <|>
   'hashtable' sp <|>
   'word' sp <|>
-  'atom' sp <|> 
+  'atom' sp <|>
   <*> [ <ast-expression> ] <@ ;
 
 LAZY: 'statement' ( -- parser )
@@ -163,41 +163,41 @@ LAZY: 'statement' ( -- parser )
 GENERIC: (compile) ( ast -- )
 GENERIC: (literal) ( ast -- )
 
-M: ast-number (literal) 
+M: ast-number (literal)
   ast-number-value number>string , ;
 
-M: ast-number (compile) 
-  "factor.push_data(" ,
-  (literal)  
-  "," , ;
-
-M: ast-string (literal) 
-  "\"" ,
-  ast-string-value ,
-  "\"" , ;
-
-M: ast-string (compile) 
+M: ast-number (compile)
   "factor.push_data(" ,
   (literal)
   "," , ;
 
-M: ast-identifier (literal) 
+M: ast-string (literal)
+  "\"" ,
+  ast-string-value ,
+  "\"" , ;
+
+M: ast-string (compile)
+  "factor.push_data(" ,
+  (literal)
+  "," , ;
+
+M: ast-identifier (literal)
   dup ast-identifier-vocab [
-   "factor.get_word(\"" , 
+   "factor.get_word(\"" ,
    dup ast-identifier-vocab ,
    "\",\"" ,
-   ast-identifier-value , 
-   "\")" ,  
+   ast-identifier-value ,
+   "\")" ,
   ] [
-   "factor.find_word(\"" , ast-identifier-value , "\")" ,  
+   "factor.find_word(\"" , ast-identifier-value , "\")" ,
   ] if ;
 
-M: ast-identifier (compile) 
+M: ast-identifier (compile)
   (literal) ".execute(" ,  ;
 
-M: ast-define (compile) 
-  "factor.define_word(\"" , 
-  dup ast-define-name , 
+M: ast-define (compile)
+  "factor.define_word(\"" ,
+  dup ast-define-name ,
   "\",\"source\"," ,
   ast-define-expression (compile)
   "," , ;
@@ -207,7 +207,7 @@ M: ast-define (compile)
     unclip
     dup ast-comment? not [
       "function() {" ,
-      (compile) 
+      (compile)
       do-expressions
       ")}" ,
     ] [
@@ -217,74 +217,74 @@ M: ast-define (compile)
     drop "factor.cont.next" ,
   ] if  ;
 
-M: ast-quotation (literal)   
+M: ast-quotation (literal)
   "factor.make_quotation(\"source\"," ,
   ast-quotation-values do-expressions
   ")" , ;
 
-M: ast-quotation (compile)   
+M: ast-quotation (compile)
   "factor.push_data(factor.make_quotation(\"source\"," ,
   ast-quotation-values do-expressions
   ")," , ;
 
-M: ast-array (literal)   
-  "[" ,  
+M: ast-array (literal)
+  "[" ,
   ast-array-elements [ "," , ] [ (literal) ] interleave
   "]" , ;
 
-M: ast-array (compile)   
+M: ast-array (compile)
   "factor.push_data(" , (literal) "," , ;
 
-M: ast-hashtable (literal)   
-  "new Hashtable().fromAlist([" ,  
+M: ast-hashtable (literal)
+  "new Hashtable().fromAlist([" ,
   ast-hashtable-elements [ "," , ] [ (literal) ] interleave
   "])" , ;
 
-M: ast-hashtable (compile)   
+M: ast-hashtable (compile)
   "factor.push_data(" , (literal) "," , ;
 
 
 M: ast-expression (literal)
   ast-expression-values [
-    (literal) 
+    (literal)
   ] each ;
-  
+
 M: ast-expression (compile)
   ast-expression-values do-expressions ;
 
-M: ast-word (literal)   
+M: ast-word (literal)
   dup ast-word-vocab [
-   "factor.get_word(\"" , 
+   "factor.get_word(\"" ,
    dup ast-word-vocab ,
    "\",\"" ,
-   ast-word-value , 
-   "\")" ,  
+   ast-word-value ,
+   "\")" ,
   ] [
-   "factor.find_word(\"" , ast-word-value , "\")" ,  
+   "factor.find_word(\"" , ast-word-value , "\")" ,
   ] if ;
 
 M: ast-word (compile)
   "factor.push_data(" ,
   (literal)
   "," , ;
-  
+
 M: ast-comment (compile)
   drop ;
 
 M: ast-stack-effect (compile)
   drop ;
 
-M: ast-use (compile) 
+M: ast-use (compile)
   "factor.use(\"" ,
-  ast-use-name , 
+  ast-use-name ,
   "\"," , ;
 
-M: ast-in (compile) 
+M: ast-in (compile)
   "factor.set_in(\"" ,
-  ast-in-name , 
+  ast-in-name ,
   "\"," , ;
 
-M: ast-using (compile) 
+M: ast-using (compile)
   "factor.using([" ,
   ast-using-names [
     "," ,
@@ -308,17 +308,17 @@ M: string (parse-factor-quotation) ( object -- ast )
   <ast-string> ;
 
 M: quotation (parse-factor-quotation) ( object -- ast )
-  [ 
+  [
     [ (parse-factor-quotation) , ] each
   ] { } make <ast-quotation> ;
 
 M: array (parse-factor-quotation) ( object -- ast )
-  [ 
+  [
     [ (parse-factor-quotation) , ] each
   ] { } make <ast-array> ;
 
 M: hashtable (parse-factor-quotation) ( object -- ast )
-  >alist [ 
+  >alist [
     [ (parse-factor-quotation) , ] each
   ] { } make <ast-hashtable> ;
 
@@ -328,33 +328,33 @@ M: wrapper (parse-factor-quotation) ( object -- ast )
 GENERIC: fjsc-parse ( object -- ast )
 
 M: string fjsc-parse ( object -- ast )
-  'expression' parse car parse-result-parsed ;
+  'expression' parse-1 ;
 
 M: quotation fjsc-parse ( object -- ast )
   [
-    [ (parse-factor-quotation) , ] each 
+    [ (parse-factor-quotation) , ] each
   ] { } make <ast-expression> ;
 
 : fjsc-compile ( ast -- string )
   [
-    [ 
+    [
       "(" ,
-      (compile) 
+      (compile)
       ")" ,
     ] { } make [ write ] each
   ] string-out ;
-  
+
 : fjsc-compile* ( string -- string )
-  'statement' parse car parse-result-parsed fjsc-compile ;
+  'statement' parse-1 fjsc-compile ;
 
 : fc* ( string -- string )
   [
-  'statement' parse car parse-result-parsed ast-expression-values do-expressions 
+  'statement' parse-1 ast-expression-values do-expressions
   ] { } make [ write ] each ;
-  
+
 
 : fjsc-literal ( ast -- string )
   [
     [ (literal) ] { } make [ write ] each
   ] string-out ;
-  
+

extra/furnace/furnace.factor

@@ -5,7 +5,7 @@ USING: kernel vectors io assocs quotations splitting strings
        continuations tuples classes io.files 
        http http.server.templating http.basic-authentication 
        webapps.callback html html.elements 
-       http.server.responders furnace.validator ;
+       http.server.responders furnace.validator vocabs ;
 IN: furnace
 
 SYMBOL: default-action
@@ -101,36 +101,14 @@ SYMBOL: request-params
 
 : service-post ( url -- ) "response" get swap service-request ;
 
-: explode-tuple ( tuple -- )
-    dup tuple-slots swap class "slot-names" word-prop
-    [ set ] 2each ;
+: send-resource ( name -- )
+    template-path get swap path+ resource-path <file-reader>
+    stdio get stream-copy ;
 
-SYMBOL: model
-
-: call-template ( model template -- )
-    [
-        >r [ dup model set explode-tuple ] when* r>
-        ".furnace" append resource-path run-template-file
-    ] with-scope ;
-
-: render-template ( model template -- )
-    template-path get swap path+ call-template ;
-
-: render-page* ( model body-template head-template -- )
-    [
-        [ render-template ] [ f rot render-template ] html-document 
-    ] serve-html ;
-
-: render-titled-page* ( model body-template head-template title -- )
-    [ 
-        [ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document
-    ] serve-html ;
-
-
-: render-page ( model template title -- )
-    [
-        [ render-template ] simple-html-document
-    ] serve-html ;
+: render-template ( template -- )
+    template-path get swap path+
+    ".furnace" append resource-path
+    run-template-file ;
 
 : web-app ( name default path -- )
     [
@@ -141,3 +119,22 @@ SYMBOL: model
         [ service-post ] "post" set
         ! [ service-head ] "head" set
     ] make-responder ;
+
+: explode-tuple ( tuple -- )
+    dup tuple-slots swap class "slot-names" word-prop
+    [ set ] 2each ;
+
+SYMBOL: model
+
+: with-slots ( model quot -- )
+    [
+        >r [ dup model set explode-tuple ] when* r> call
+    ] with-scope ;
+
+: render-component ( model template -- )
+    swap [ render-template ] with-slots ;
+
+: browse-webapp-source ( vocab -- )
+    <a f >vocab-link browser-link-href =href a>
+        "Browse source" write
+    </a> ;

extra/globs/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/globs/globs-tests.factor

@@ -0,0 +1,18 @@
+IN: temporary
+USING: tools.test globs ;
+
+[ f ] [ "abd" "fdf" glob-matches? ] unit-test
+[ f ] [ "fdsafas" "?" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*as" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*a*" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*a?" glob-matches? ] unit-test
+[ t ] [ "fdsafas" "*?" glob-matches? ] unit-test
+[ f ] [ "fdsafas" "*s?" glob-matches? ] unit-test
+[ t ] [ "a" "[abc]" glob-matches? ] unit-test
+[ f ] [ "a" "[^abc]" glob-matches? ] unit-test
+[ t ] [ "d" "[^abc]" glob-matches? ] unit-test
+[ f ] [ "foo.java" "*.{xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo.txt" "*.{xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo.xml" "*.{xml,txt}" glob-matches? ] unit-test
+[ f ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo.{" "*.{" glob-matches? ] unit-test

extra/globs/globs.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser-combinators regexp lazy-lists sequences kernel
+promises strings ;
+IN: globs
+
+<PRIVATE
+
+: 'char' [ ",*?" member? not ] satisfy ;
+
+: 'string' 'char' <+> [ >lower token ] <@ ;
+
+: 'escaped-char' "\\" token any-char-parser &> [ 1token ] <@ ;
+
+: 'escaped-string' 'string' 'escaped-char' <|> ;
+
+DEFER: 'term'
+
+: 'glob' ( -- parser )
+    'term' <*> [ <and-parser> ] <@ ;
+
+: 'union' ( -- parser )
+    'glob' "," token nonempty-list-of "{" "}" surrounded-by
+    [ <or-parser> ] <@ ;
+
+LAZY: 'term'
+    'union'
+    'character-class' <|>
+    "?" token [ drop any-char-parser ] <@ <|>
+    "*" token [ drop any-char-parser <*> ] <@ <|>
+    'escaped-string' <|> ;
+
+PRIVATE>
+
+: <glob> 'glob' just parse-1 just ;
+
+: glob-matches? ( input glob -- ? )
+    >r >lower r> <glob> parse nil? not ;