Merge branch 'master' into hashcode

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
 

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
+kernel.private threads continuations.private libc combinators ;
-init ;
 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/combinators/combinators.factor

@@ -79,6 +79,10 @@ M: sequence hashcode*
     dup empty? [
         drop
     ] [
-        hash-case-table hash-dispatch-quot
+        dup length 4 <= [
-        [ dup hashcode >fixnum ] swap append
+            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
-    [
+    "quiet" get [ drop ] [
-        "Compiling " % length # " words..." %
+        [ "Compiling " % length # " words..." % ] "" make
-    ] "" make print flush
+        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/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/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
+memory namespaces sequences strings assocs arrays definitions
-combinators splitting ;
+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/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 )"

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.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 )
+: unparse-string ( str prefix suffix -- str )
-    [
+    [ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ;
-        % do-string-limit [ unparse-ch ] each CHAR: " ,
-    ] "" 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
+[ [ 3 ] ] [ 3 [ ] curry ] unit-test
-[ [ \ + ] ] [ \ + f 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

extra/bake/bake.factor

@@ -1,6 +1,6 @@
 
-USING: kernel parser namespaces quotations vectors strings
+USING: kernel parser namespaces quotations arrays vectors strings
-sequences assocs tuples math combinators ;
+       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/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/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
+math.vectors math.functions math.parser namespaces sequences
-namespaces sequences strings tuples system ;
+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/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-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/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

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
+inspector continuations tuples tools.crossref tools.browser 
-source-files ;
+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 [
-    edit-hook get dup [
+        >r >r ?resource-path r> r> call
-        \ no-edit-hook construct-empty throw
+    ] [
-    ] if ;
+        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 )
-    [
+    [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
-        "\"" % vim-path get % "\"" %
+
-        vim-switches get [ % ] when*
+t vim-detach set-global ! don't block the ui
-        "+" % # " \"" % % "\"" %
-    ] "" make ;
 
 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" } } } } [ 
+{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [
-  "\"abcd\"" 'statement' parse car parse-result-parsed 
+  "\"abcd\"" 'statement' parse-1
-] unit-test 
+] 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' 
+  'comment'
-  'parsing-word' sp <|> 
+  'parsing-word' sp <|>
-  'quotation' 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) 
+M: ast-number (compile)
-  "factor.push_data(" ,
-  (literal)  
-  "," , ;
-
-M: ast-string (literal) 
-  "\"" ,
-  ast-string-value ,
-  "\"" , ;
-
-M: ast-string (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) 
+M: ast-define (compile)
-  "factor.define_word(\"" , 
+  "factor.define_word(\"" ,
-  dup ast-define-name , 
+  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)   
+M: ast-hashtable (literal)
-  "new Hashtable().fromAlist([" ,  
+  "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 -- )
+: send-resource ( name -- )
-    dup tuple-slots swap class "slot-names" word-prop
+    template-path get swap path+ resource-path <file-reader>
-    [ set ] 2each ;
+    stdio get stream-copy ;
 
-SYMBOL: model
+: render-template ( template -- )
-
+    template-path get swap path+
-: call-template ( model template -- )
+    ".furnace" append resource-path
-    [
+    run-template-file ;
-        >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 ;
 
 : 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 ;

extra/globs/summary.txt

@@ -0,0 +1 @@
+Unix shell-style glob pattern matching

extra/hardware-info/windows/ce/ce.factor

@@ -1,7 +1,7 @@
-USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 ;
+USING: alien.c-types hardware-info hardware-info.windows
+kernel math namespaces windows windows.kernel32 ;
 IN: hardware-info.windows.ce
 
-TUPLE: wince ;
 T{ wince } os set-global
 
 : memory-status ( -- MEMORYSTATUS )

extra/hardware-info/windows/nt/nt.factor

@@ -1,8 +1,8 @@
-USING: alien alien.c-types hardware-info kernel libc math namespaces
+USING: alien alien.c-types hardware-info hardware-info.windows
+kernel libc math namespaces
 windows windows.advapi32 windows.kernel32 ;
 IN: hardware-info.windows.nt
 
-TUPLE: winnt ;
 T{ winnt } os set-global
 
 : memory-status ( -- MEMORYSTATUSEX )

extra/hardware-info/windows/windows.factor

@@ -1,5 +1,6 @@
 USING: alien alien.c-types kernel libc math namespaces
-windows windows.kernel32 windows.advapi32 hardware-info ;
+windows windows.kernel32 windows.advapi32 hardware-info
+words ;
 IN: hardware-info.windows
 
 TUPLE: wince ;
@@ -53,6 +54,22 @@ M: windows cpus ( -- n )
 : sse3? ( -- ? )
     PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
 
+: <u16-string-object> ( n -- obj )
+    "ushort" <c-array> ;
+
+: get-directory ( word -- str )
+    >r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r>
+    execute win32-error=0/f alien>u16-string ; inline
+
+: windows-directory ( -- str )
+    \ GetWindowsDirectory get-directory ;
+
+: system-directory ( -- str )
+    \ GetSystemDirectory get-directory ;
+
+: system-windows-directory ( -- str )
+    \ GetSystemWindowsDirectory get-directory ;
+
 USE-IF: wince? hardware-info.windows.ce
 USE-IF: winnt? hardware-info.windows.nt
 

extra/help/handbook/handbook.factor

@@ -1,7 +1,7 @@
 USING: help help.markup help.syntax help.topics
 namespaces words sequences classes assocs vocabs kernel
 arrays prettyprint.backend kernel.private io tools.browser
-generic ;
+generic math tools.profiler system ui ;
 IN: help.handbook
 
 ARTICLE: "conventions" "Conventions"
@@ -222,6 +222,72 @@ ARTICLE: "handbook" "Factor documentation"
 USING: io.files io.sockets float-arrays inference ;
 
 ARTICLE: "changes" "Changes in the latest release"
+{ $heading "Factor 0.91" }
+{ $subheading "Performance" }
+{ $list
+    { "Continuations are now supported by the static stack effect system. This means that the " { $link infer } " word and the optimizing compiler now both support code which uses continuations." }
+    { "Many words which previously ran in the interpreter, such as error handling and I/O, are now compiled to optimized machine code." }
+    { "A non-optimizing, just-in-time compiler replaces the interpreter with no loss in functionality or introspective ability." }
+    { "The non-optimizing compiler compiles quotations the first time they are called, generating a series of stack pushes and subroutine calls. It offers a 33%-50% performance increase over the interpreter." }
+    { "The optimizing compiler now performs some more representation inference. Alien pointers are unboxed where possible. This improves performance of the " { $vocab-link "ogg.player" } " Ogg Theora video player." }
+    { "The queue of sleeping tasks is now a sorted priority queue. This reduces overhead for workloads involving large numbers of sleeping threads (Doug Coleman)" }
+    { "Improved hash code algorithm for sequences" }
+    { "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
+    { "New " { $link big-random } " word for generating large random numbers quickly" }
+    { "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." }
+    { "Calls to " { $link member? } " with a literal sequence are now open-coded. If there are four or fewer elements, a series of conditionals are generated; if there are more than four elements, there is a hash dispatch followed by conditionals in each branch." }
+}
+{ $subheading "IO" }
+{ $list
+    { "More robust Windows CE native I/O" }
+    { "New " { $link os-envs } " word to get the current set of environment variables" }
+    { "Redesigned " { $vocab-link "io.launcher" } " supports passing environment variables to the child process" }
+    { { $link <process-stream> } " implemented on Windows (Doug Coleman)" }
+    { "Updated " { $vocab-link "io.mmap" } " for new module system, now supports Windows CE (Doug Coleman)" }
+    { { $vocab-link "io.sniffer" } " - packet sniffer library (Doug Coleman, Elie Chaftari)" }
+    { { $vocab-link "io.server" } " - improved logging support, logs to a file by default" }
+    { { $vocab-link "io.files" } " - several new file system manipulation words added" }
+    { { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" }
+    { { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $snippet "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
+}
+{ $subheading "Tools" }
+{ $list
+    { "Graphical deploy tool added - see " { $link "ui.tools.deploy" } }
+    { "The deploy tool now supports Windows" }
+    { { $vocab-link "network-clipboard" } " - clipboard synchronization with a simple TCP/IP protocol" }
+}
+{ $subheading "UI" }
+{ $list
+    { { $vocab-link "cairo" } " - updated for new module system, new features (Sampo Vuori)" }
+    { { $vocab-link "springies" } " - physics simulation UI demo (Eduardo Cavazos)" }
+    { { $vocab-link "ui.gadgets.buttons" } " - added check box and radio button gadgets" }
+    { "Double- and triple-click-drag now supported in the editor gadget to select words or lines at a time" }
+    { "Windows can be closed on request now using " { $link close-window } }
+    { "New icons (Elie Chaftari)" }
+}
+{ $subheading "Libraries" }
+{ $list
+    { "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } }
+    { "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." }
+    { "The optimizing compiler no longer depends on the number tower and it is possible to bootstrap a minimal image by just passing " { $snippet "-include=compiler" } " to stage 2 bootstrap." }
+    { { $vocab-link "benchmark.knucleotide" } " - new benchmark (Eric Mertens)" }
+    { { $vocab-link "channels" } " - concurrent message passing over message channels" }
+    { { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" }
+    { { $vocab-link "dlists" } " - various updates (Doug Coleman)" }
+    { { $vocab-link "editors.emeditor" } " - EmEditor integration (Doug Coleman)" }
+    { { $vocab-link "editors.editplus" } " - EditPlus integration (Aaron Schaefer)" }
+    { { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" }
+    { { $vocab-link "editors.ted-notepad" } " - TED Notepad integration (Doug Coleman)" }
+    { { $vocab-link "editors.ultraedit" } " - UltraEdit integration (Doug Coleman)" }
+    { { $vocab-link "globs" } " - simple Unix shell-style glob patterns" }
+    { { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" }
+    { { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" }
+    { { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" }
+    { { $vocab-link "rss" } " - add Atom feed generation (Daniel Ehrenberg)" }
+    { { $vocab-link "tuples.lib" } " - some utility words for working with tuples (Doug Coleman)" }
+    { { $vocab-link "webapps.pastebin" } " - improved appearance, add Atom feed generation, add syntax highlighting using " { $vocab-link "xmode" } }
+    { { $vocab-link "webapps.planet" } " - add Atom feed generation" }
+}
 { $heading "Factor 0.90" }
 { $subheading "Core" }
 { $list
@@ -249,7 +315,7 @@ ARTICLE: "changes" "Changes in the latest release"
 "Most existing libraries were improved when ported to the new module system; the most notable changes include:"
 { $list
     { { $vocab-link "asn1" } ": ASN1 parser and writer. (Elie Chaftari)" }
-    { { $vocab-link "benchmarks" } ": new set of benchmarks." }
+    { { $vocab-link "benchmark" } ": new set of benchmarks." }
     { { $vocab-link "cfdg" } ": Context-free design grammar implementation; see " { $url "http://www.chriscoyne.com/cfdg/" } ". (Eduardo Cavazos)" }
     { { $vocab-link "cryptlib" } ": Cryptlib library binding. (Elie Chaftari)" }
     { { $vocab-link "cryptlib.streams" } ": Streams which perform SSL encryption and decryption. (Matthew Willis)" }

extra/html/parser/analyzer/analyzer.factor

@@ -1,15 +1,23 @@
-USING: assocs browser.parser kernel math sequences strings ;
+USING: assocs html.parser kernel math sequences strings ;
-IN: browser.analyzer
+IN: html.parser.analyzer
 
-: remove-blank-text ( vector -- vector )
+: remove-blank-text ( vector -- vector' )
     [
         dup tag-name text = [
-            tag-text [ blank? not ] all?
+            tag-text [ blank? ] all? not
         ] [
             drop t
         ] if
     ] subset ;
 
+: trim-text ( vector -- vector' )
+    [
+        dup tag-name text = [
+            [ tag-text [ blank? ] trim ] keep
+            [ set-tag-text ] keep
+        ] when
+    ] map ;
+
 : find-by-id ( id vector -- vector )
     [ tag-attributes "id" swap at = ] curry* subset ;
 
@@ -79,5 +87,5 @@ IN: browser.analyzer
 ! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html "Currency" "name" pick find-first-attribute-key-value
 
 ! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html
-! "Currency" "name" pick find-first-attribute-key-value 
+! "Currency" "name" pick find-first-attribute-key-value
 ! pick find-between remove-blank-text

extra/html/parser/parser-tests.factor

@@ -1,4 +1,4 @@
-USING: browser.parser kernel tools.test ;
+USING: html.parser kernel tools.test ;
 IN: temporary
 
 [

extra/html/parser/parser.factor

@@ -1,8 +1,7 @@
-USING: arrays browser.utils hashtables io kernel namespaces
+USING: arrays html.parser.utils hashtables io kernel
-prettyprint quotations
+namespaces prettyprint quotations
 sequences splitting state-parser strings ;
-USE: tools.interpreter
+IN: html.parser
-IN: browser.parser
 
 TUPLE: tag name attributes text matched? closing? ;
 
@@ -121,7 +120,7 @@ SYMBOL: tagstack
     ] unless ;
 
 : parse-attributes ( -- hashtable )
-    [ (parse-attributes) ] { } make >hashtable ; 
+    [ (parse-attributes) ] { } make >hashtable ;
 
 : (parse-tag)
     [

extra/html/parser/printer/printer.factor

@@ -1,9 +1,9 @@
-USING: assocs browser.parser browser.utils combinators
+USING: assocs html.parser html.parser.utils combinators
 continuations hashtables
 hashtables.private io kernel math
 namespaces prettyprint quotations sequences splitting
 state-parser strings ;
-IN: browser.printer
+IN: html.parser.printer
 
 SYMBOL: no-section
 SYMBOL: html
@@ -42,7 +42,7 @@ HOOK: print-closing-named-tag printer ( tag -- )
 M: printer print-text-tag ( tag -- )
     tag-text write ;
 
-M: printer print-comment-tag ( tag -- ) 
+M: printer print-comment-tag ( tag -- )
     "<!--" write
     tag-text write
     "-->" write ;
@@ -67,7 +67,6 @@ M: printer print-closing-named-tag ( tag -- )
     [
         swap bl write "=" write ?quote write
     ] assoc-each ;
-        
 
 M: src-printer print-opening-named-tag ( tag -- )
     "<" write
@@ -102,7 +101,7 @@ SYMBOL: tablestack
     [
         V{ } clone tablestack set
     ] with-scope ;
-    
+
 ! { { 1 2 } { 3 4 } }
 ! H{ { table-gap { 10 10 } } } [
     ! [ [ [ [ . ] with-cell ] each ] with-row ] each

extra/html/parser/utils/utils-tests.factor

@@ -2,7 +2,7 @@ USING: assocs combinators continuations hashtables
 hashtables.private io kernel math
 namespaces prettyprint quotations sequences splitting
 state-parser strings tools.test ;
-USING: browser.utils ;
+USING: html.parser.utils ;
 IN: temporary
 
 [ "'Rome'" ] [ "Rome" single-quote ] unit-test

extra/html/parser/utils/utils.factor

@@ -2,8 +2,8 @@ USING: assocs circular combinators continuations hashtables
 hashtables.private io kernel math
 namespaces prettyprint quotations sequences splitting
 state-parser strings ;
-USING: browser.parser ;
+USING: html.parser ;
-IN: browser.utils
+IN: html.parser.utils
 
 : string-parse-end?
     get-next not ;

extra/http/http.factor

@@ -20,7 +20,7 @@ IN: http
     dup letter?
     over LETTER? or
     over digit? or
-    swap "/_?." member? or ; foldable
+    swap "/_-?." member? or ; foldable
 
 : url-encode ( str -- str )
     [

extra/id3/id3.factor

@@ -2,7 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 
-USING: arrays combinators io io.binary io.files io.utf16 kernel math math.parser namespaces sequences splitting strings assocs ;
+USING: arrays combinators io io.binary io.files io.paths
+io.utf16 kernel math math.parser namespaces sequences
+splitting strings assocs ;
 
 IN: id3
 
@@ -121,18 +123,6 @@ C: <extended-header> extended-header
 : id3v2 ( filename -- tag/f )
   <file-reader> [ read-tag ] with-stream ;
 
-: 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 ;
-
-: walk-dir ( path -- seq )
-  [ (walk-dir) ] { } make ;
-
 : file? ( path -- ? )
   stat 3drop not ;
 

extra/inverse/inverse.factor

@@ -1,18 +1,9 @@
 USING: kernel words inspector slots quotations sequences assocs
 math arrays inference effects shuffle continuations debugger
 tuples namespaces vectors bit-arrays byte-arrays strings sbufs
-math.functions macros ;
+math.functions macros combinators.private combinators ;
 IN: inverse
 
-: (repeat) ( from to quot -- )
-    pick pick >= [
-        3drop
-    ] [
-        [ swap >r call 1+ r> ] keep (repeat)
-    ] if ; inline
-
-: repeat ( n quot -- ) 0 -rot (repeat) ; inline
-
 TUPLE: fail ;
 : fail ( -- * ) \ fail construct-empty throw ;
 M: fail summary drop "Unification failed" ;
@@ -27,17 +18,12 @@ M: fail summary drop "Unification failed" ;
 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
 
 : define-math-inverse ( word quot1 quot2 -- )
-    2array "math-inverse" set-word-prop ;
+    pick 1quotation 3array "math-inverse" set-word-prop ;
 
 : define-pop-inverse ( word n quot -- )
     >r dupd "pop-length" set-word-prop r>
     "pop-inverse" set-word-prop ;
 
-DEFER: [undo]
-
-: make-inverse ( word -- quot )
-    word-def [undo] ;
-
 TUPLE: no-inverse word ;
 : no-inverse ( word -- * ) \ no-inverse construct-empty throw ;
 M: no-inverse summary
@@ -54,10 +40,7 @@ M: no-inverse summary
     effect-in length 0 = and ;
 
 : assure-constant ( constant -- quot )
-    dup word? [
+    dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
-        dup constant-word?
-        [ "Badly formed math inverse" throw ] unless
-    ] when 1quotation ;
 
 : swap-inverse ( math-inverse revquot -- revquot* quot )
     next assure-constant rot second [ swap ] swap 3compose ;
@@ -68,25 +51,52 @@ M: no-inverse summary
 : ?word-prop ( word/object name -- value/f )
     over word? [ word-prop ] [ 2drop f ] if ;
 
-GENERIC: inverse ( revquot word -- revquot* quot )
-
-M: word inverse
-    dup "inverse" word-prop [ ]
-    [ dup primitive? [ no-inverse ] [ make-inverse ] if ] ?if ;
-
 : undo-literal ( object -- quot )
     [ =/fail ] curry ;
 
+PREDICATE: word normal-inverse "inverse" word-prop ;
+PREDICATE: word math-inverse "math-inverse" word-prop ;
+PREDICATE: word pop-inverse "pop-length" word-prop ;
+UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
+
+: inline-word ( word -- )
+    {
+        { [ dup word? not over symbol? or ] [ , ] }
+        { [ dup explicit-inverse? ] [ , ] }
+        { [ dup compound? over { if dispatch } member? not and ]
+          [ word-def [ inline-word ] each ] }
+        { [ drop t ] [ "Quotation is not invertible" throw ] }
+    } cond ;
+
+: math-exp? ( n n word -- ? )
+    { + - * / ^ } member? -rot [ number? ] 2apply and and ;
+
+: (fold-constants) ( quot -- )
+    dup length 3 < [ % ] [
+        dup first3 3dup math-exp?
+        [ execute , 3 ] [ 2drop , 1 ] if
+        tail-slice (fold-constants) 
+    ] if ;
+
+: fold-constants ( quot -- folded )
+    [ (fold-constants) ] [ ] make ;
+
+: do-inlining ( quot -- inlined-quot )
+    [ [ inline-word ] each ] [ ] make fold-constants ;
+
+GENERIC: inverse ( revquot word -- revquot* quot )
+
 M: object inverse undo-literal ;
 M: symbol inverse undo-literal ;
 
-PREDICATE: word math-inverse "math-inverse" word-prop ;
+M: normal-inverse inverse
+    "inverse" word-prop ;
+
 M: math-inverse inverse
     "math-inverse" word-prop
     swap next dup \ swap =
     [ drop swap-inverse ] [ pull-inverse ] if ;
 
-PREDICATE: word pop-inverse "pop-length" word-prop ;
 M: pop-inverse inverse
     [ "pop-length" word-prop cut-slice swap ] keep
     "pop-inverse" word-prop compose call ;
@@ -96,11 +106,11 @@ M: pop-inverse inverse
     [ unclip-slice inverse % (undo) ] if ;
 
 : [undo] ( quot -- undo )
-    reverse [ (undo) ] [ ] make ;
+    do-inlining reverse [ (undo) ] [ ] make ;
 
 MACRO: undo ( quot -- ) [undo] ;
 
-! Inversions of selected words
+! Inverse of selected words
 
 \ swap [ swap ] define-inverse
 \ dup [ [ =/fail ] keep ] define-inverse

extra/io/paths/paths.factor

@@ -0,0 +1,24 @@
+USING: assocs io.files kernel namespaces sequences ;
+IN: io.paths
+
+: find-file ( seq str -- path/f )
+    [
+        [ path+ exists? ] curry find nip
+    ] keep over [ path+ ] [ drop ] if ;
+
+<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 ;

extra/io/unix/launcher/launcher-tests.factor

@@ -0,0 +1,33 @@
+IN: temporary
+USING: io.unix.launcher tools.test ;
+
+[ "" tokenize-command ] unit-test-fails
+[ "   " tokenize-command ] unit-test-fails
+[ { "a" } ] [ "a" tokenize-command ] unit-test
+[ { "abc" } ] [ "abc" tokenize-command ] unit-test
+[ { "abc" } ] [ "abc   " tokenize-command ] unit-test
+[ { "abc" } ] [ "   abc" tokenize-command ] unit-test
+[ { "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
+[ { "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
+[ { "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
+[ { "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
+[ { "abc\\ def" } ] [ "  'abc\\\\ def'" tokenize-command ] unit-test
+[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
+[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
+[ "'abc def' \"hey" tokenize-command ] unit-test-fails
+[ "'abc def" tokenize-command ] unit-test-fails
+[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\"  " tokenize-command ] unit-test
+
+[
+    {
+        "Hello world.app/Contents/MacOS/hello-ui"
+        "-i=boot.macosx-ppc.image"
+        "-include= math compiler ui"
+        "-deploy-vocab=hello-ui"
+        "-output-image=Hello world.app/Contents/Resources/hello-ui.image"
+        "-no-stack-traces"
+        "-no-user-init"
+    }
+] [
+    "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
+] unit-test

extra/io/unix/launcher/launcher.factor

@@ -2,17 +2,45 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io io.launcher io.unix.backend io.nonblocking
 sequences kernel namespaces math system alien.c-types
-debugger continuations arrays assocs combinators unix.process ;
+debugger continuations arrays assocs combinators unix.process
+parser-combinators memoize promises strings ;
 IN: io.unix.launcher
 
 ! Search unix first
 USE: unix
 
-: get-arguments ( -- seq )
+! Our command line parser. Supported syntax:
-    +command+ get
+! foo bar baz -- simple tokens
-    [ "/bin/sh" "-c" rot 3array ] [ +arguments+ get ] if* ;
+! foo\ bar -- escaping the space
+! 'foo bar' -- quotation
+! "foo bar" -- quotation
+LAZY: 'escaped-char' "\\" token any-char-parser &> ;
 
-: assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ;
+LAZY: 'quoted-char' ( delimiter -- parser' )
+    'escaped-char'
+    swap [ member? not ] curry satisfy
+    <|> ; inline
+
+LAZY: 'quoted' ( delimiter -- parser )
+    dup 'quoted-char' <!*> swap dup surrounded-by ;
+
+LAZY: 'unquoted' ( -- parser ) " '\"" 'quoted-char' <!+> ;
+
+LAZY: 'argument' ( -- parser )
+    "\"" 'quoted' "'" 'quoted' 'unquoted' <|> <|>
+    [ >string ] <@ ;
+
+MEMO: 'arguments' ( -- parser )
+    'argument' " " token <!+> nonempty-list-of ;
+
+: tokenize-command ( command -- arguments )
+    'arguments' just parse-1 ;
+
+: get-arguments ( -- seq )
+    +command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
+
+: assoc>env ( assoc -- env )
+    [ "=" swap 3append ] { } assoc>map ;
 
 : (spawn-process) ( -- )
     [

extra/io/unix/mmap/mmap.factor

@@ -13,7 +13,7 @@ IN: io.unix.mmap
 M: unix-io <mapped-file> ( path length -- obj )
     swap >r
     dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
-    r> mmap-open \ mapped-file construct-boa ;
+    r> mmap-open f mapped-file construct-boa ;
 
 M: unix-io (close-mapped-file) ( mmap -- )
     [ mapped-file-address ] keep

extra/io/windows/ce/files/files.factor

@@ -7,7 +7,8 @@ IN: windows.ce.files
 ! M: windows-ce-io normalize-pathname ( string -- string )
     ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
 
-M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
+M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
+    FILE_ATTRIBUTE_NORMAL bitor ;
 M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
 
 : finish-read ( port status bytes-ret -- )

extra/io/windows/launcher/launcher.factor

@@ -53,8 +53,11 @@ TUPLE: CreateProcess-args
         CreateProcess-args-lpProcessInformation
     } get-slots CreateProcess win32-error=0/f ;
 
+: escape-argument ( str -- newstr )
+    [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ;
+
 : join-arguments ( args -- cmd-line )
-    [ "\"" swap "\"" 3append ] map " " join ;
+    [ "\"" swap escape-argument "\"" 3append ] map " " join ;
 
 : app-name/cmd-line ( -- app-name cmd-line )
     +command+ get [
@@ -84,9 +87,9 @@ TUPLE: CreateProcess-args
     pass-environment? [
         [
             get-environment
-            [ swap % "=" % % "\0" % ] assoc-each
+            [ "=" swap 3append string>u16-alien % ] assoc-each
             "\0" %
-        ] "" make >c-ushort-array
+        ] { } make >c-ushort-array
         over set-CreateProcess-args-lpEnvironment
     ] when ;
 

extra/io/windows/mmap/mmap.factor

@@ -62,7 +62,7 @@ M: windows-ce-io with-privileges
 
 : mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
     { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
-        >r >r open-file dup f r> 0 0 f
+        >r >r 0 open-file dup f r> 0 0 f
         CreateFileMapping [ win32-error=0/f ] keep
         dup close-later
         dup

extra/io/windows/nt/backend/backend.factor

@@ -27,7 +27,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
         { [ dup ".\\" head? ] [
             >r unicode-prefix cwd r> 1 tail 3append
         ] }
-        ! c:\\
+        ! c:\\foo
         { [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
         ! \\\\?\\c:\\foo
         { [ dup unicode-prefix head? ] [ ] }
@@ -38,7 +38,8 @@ M: windows-nt-io normalize-pathname ( string -- string )
                 dup first CHAR: \\ = [ CHAR: \\ , ] unless %
             ] "" make
         ] }
-    } cond [ "/\\." member? ] right-trim ;
+    } cond [ "/\\." member? ] right-trim
+    dup peek CHAR: : = [ "\\" append ] when ;
 
 SYMBOL: io-hash
 

extra/io/windows/nt/files/files.factor

@@ -3,8 +3,8 @@ io.windows.nt io.windows.nt.backend kernel libc math
 threads windows windows.kernel32 ;
 IN: io.windows.nt.files
 
-M: windows-nt-io CreateFile-flags ( -- DWORD )
+M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
-    FILE_FLAG_OVERLAPPED ;
+    FILE_FLAG_OVERLAPPED bitor ;
 
 M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
     make-overlapped ;

extra/io/windows/windows.factor

@@ -4,7 +4,7 @@ USING: alien alien.c-types arrays destructors io io.backend
 io.buffers io.files io.nonblocking io.sockets io.binary
 io.sockets.impl windows.errors strings io.streams.duplex kernel
 math namespaces sequences windows windows.kernel32
-windows.winsock splitting ;
+windows.shell32 windows.winsock splitting ;
 IN: io.windows
 
 TUPLE: windows-nt-io ;
@@ -23,7 +23,7 @@ TUPLE: win32-file handle ptr overlapped ;
 : <win32-duplex-stream> ( in out -- stream )
     >r f <win32-file> r> f <win32-file> handle>duplex-stream ;
 
-HOOK: CreateFile-flags io-backend ( -- DWORD )
+HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
 HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
 HOOK: add-completion io-backend ( port -- )
 
@@ -31,7 +31,8 @@ M: windows-io normalize-directory ( string -- string )
     "\\" ?tail drop "\\*" append ;
 
 : share-mode ( -- fixnum )
-    FILE_SHARE_READ FILE_SHARE_WRITE bitor ; inline
+    FILE_SHARE_READ FILE_SHARE_WRITE bitor
+    FILE_SHARE_DELETE bitor ; foldable
 
 M: win32-file init-handle ( handle -- )
     drop ;
@@ -40,24 +41,25 @@ M: win32-file close-handle ( handle -- )
     win32-file-handle CloseHandle drop ;
 
 ! Clean up resources (open handle) if add-completion fails
-: open-file ( path access-mode create-mode -- handle )
+: open-file ( path access-mode create-mode flags -- handle )
     [
-        >r share-mode f r> CreateFile-flags f CreateFile
+        >r >r >r normalize-pathname r>
+        share-mode f r> r> CreateFile-flags f CreateFile
         dup invalid-handle? dup close-later
         dup add-completion
     ] with-destructors ;
 
 : open-pipe-r/w ( path -- handle )
-    GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING open-file ;
+    GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING 0 open-file ;
 
 : open-read ( path -- handle length )
-    normalize-pathname GENERIC_READ OPEN_EXISTING open-file 0 ;
+    GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
 
 : open-write ( path -- handle length )
-    normalize-pathname GENERIC_WRITE CREATE_ALWAYS open-file 0 ;
+    GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
 
 : (open-append) ( path -- handle )
-    normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
+    GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
 
 : set-file-pointer ( handle length -- )
     dupd d>w/w <uint> FILE_BEGIN SetFilePointer
@@ -109,12 +111,14 @@ M: windows-io <file-appender> ( path -- stream )
     open-append <win32-file> <writer> ;
 
 M: windows-io rename-file ( from to -- )
-    [ normalize-pathname ] 2apply
+    [ normalize-pathname ] 2apply MoveFile win32-error=0/f ;
-    MoveFile win32-error=0/f ;
 
 M: windows-io delete-file ( path -- )
-    normalize-pathname
+    normalize-pathname DeleteFile win32-error=0/f ;
-    DeleteFile win32-error=0/f ;
+
+M: windows-io copy-file ( from to -- )
+    dup parent-directory make-directories
+    [ normalize-pathname ] 2apply 0 CopyFile win32-error=0/f ;
 
 M: windows-io make-directory ( path -- )
     normalize-pathname

extra/jamshred/tunnel/tunnel-tests.factor

@@ -12,4 +12,4 @@ IN: temporary
 
 [ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
 
-[ { 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
+[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test