Merge git://factorcode.org/git/factor

Makefile

@@ -62,6 +62,7 @@ default:
 	@echo "solaris-x86-64"
 	@echo "windows-ce-arm"
 	@echo "windows-nt-x86-32"
+	@echo "windows-nt-x86-64"
 	@echo ""
 	@echo "Additional modifiers:"
 	@echo ""
@@ -113,6 +114,9 @@ solaris-x86-64:
 windows-nt-x86-32:
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
 
+windows-nt-x86-64:
+	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
+
 windows-ce-arm:
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
 
@@ -138,7 +142,7 @@ clean:
 	rm -f vm/*.o
 
 vm/resources.o:
-	windres vm/factor.rs vm/resources.o
+	$(WINDRES) vm/factor.rs vm/resources.o
 
 .c.o:
 	$(CC) -c $(CFLAGS) -o $@ $<

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/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

@@ -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

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? ]     [ , ] }
@@ -49,3 +54,8 @@ DEFER: bake
 
 : bake ( seq -- seq )
   [ 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/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/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/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/summary.txt

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

extra/editors/emacs/summary.txt

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

extra/editors/gvim/gvim.factor

@@ -4,11 +4,7 @@ IN: editors.gvim
 TUPLE: gvim ;
 
 M: gvim vim-command ( file line -- string )
-    [
+    [ "\"" % vim-path get % "\" \"" % swap % "\" +" % # ] "" make ;
-        "\"" % vim-path get % "\"" %
-        vim-switches get [ % ] when*
-        "+" % # " \"" % % "\"" %
-    ] "" make ;
 
 T{ gvim } vim-editor set-global
 "gvim" vim-path set-global

extra/editors/gvim/summary.txt

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

extra/editors/notepadpp/authors.txt

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

extra/editors/notepadpp/notepadpp.factor

@@ -0,0 +1,13 @@
+USING: editors io.launcher math.parser namespaces ;
+IN: editors.notepadpp
+
+: notepadpp ( file line -- )
+    [
+        \ notepadpp get-global % " -n" % # " " % %
+    ] "" make run-detached ;
+
+! Put in your .factor-boot-rc
+! "c:\\Program Files\\notepad++\\notepad++.exe" \ notepadpp set-global
+! "k:\\Program Files (x86)\\notepad++\\notepad++.exe" \ notepadpp set-global
+
+[ 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/textmate/summary.txt

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

extra/editors/vim/summary.txt

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

extra/fjsc/fjsc-tests.factor

@@ -4,31 +4,31 @@ 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
 
 { } [
@@ -37,18 +37,18 @@ IN: temporary
 
 
 { T{ ast-expression f { T{ ast-string f "abcd" } } } } [
-  "\"abcd\"" 'statement' parse car parse-result-parsed 
+  "\"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

@@ -328,7 +328,7 @@ 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 )
   [
@@ -345,11 +345,11 @@ M: quotation fjsc-parse ( object -- ast )
   ] 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 ;
 
 

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/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 [

extra/io/windows/windows.factor

@@ -109,12 +109,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

extra/lint/lint.factor

@@ -13,7 +13,7 @@ SYMBOL: def-hash-keys
     2dup at -rot >r >r ?push r> r> set-at ;
 
 : add-word-def ( word quot -- )
-    dup quotation? [
+    dup callable? [
         def-hash get-global set-hash-vector
     ] [
         2drop
@@ -33,6 +33,7 @@ SYMBOL: def-hash-keys
         { [ drop drop drop ] 3drop }
         { [ 0 = ] zero? }
         { [ pop drop ] pop* }
+        { [ [ ] if ] when }
     } [ first2 swap add-word-def ] each ;
 
 : accessor-words ( -- seq )
@@ -108,13 +109,13 @@ M: object lint ( obj -- seq )
 : subseq/member? ( subseq/member seq -- ? )
     { [ 2dup start ] [ 2dup member? ] } || 2nip ;
 
-M: quotation lint ( quot -- seq )
+M: callable lint ( quot -- seq )
     def-hash-keys get [
         swap subseq/member?
     ] curry* subset ;
 
 M: word lint ( word -- seq )
-    word-def dup quotation? [ lint ] [ drop f ] if ;
+    word-def dup callable? [ lint ] [ drop f ] if ;
 
 : word-path. ( word -- )
     [ word-vocabulary ":" ] keep unparse 3append write nl ;

extra/macros/macros.factor

@@ -19,7 +19,7 @@ IN: macros
 : MACRO:
     (:) (MACRO:) ; parsing
 
-PREDICATE: word macro
+PREDICATE: compound macro
     "macro" word-prop >boolean ;
 
 M: macro definer drop \ MACRO: \ ; ;

extra/pack/pack.factor

@@ -24,7 +24,7 @@ M: integer b, ( m n -- ) >endian % ;
 
 ! for doing native, platform-dependent sized values
 M: string b, ( n string -- ) heap-size b, ;
-: read-native ( string -- ) heap-size read endian> ;
+: read-native ( string -- n ) heap-size read endian> ;
 
 ! Portable
 : s8, ( n -- ) 1 b, ;

extra/parser-combinators/parser-combinators-docs.factor

@@ -11,6 +11,15 @@ HELP: list-of
     "'items' is a parser that can parse the individual elements. 'separator' "
     "is a parser for the symbol that separatest them. The result tree of "
     "the resulting parser is an array of the parsed elements." }
-{ $example "USE: parser-combinators" "\"1,2,3,4\" 'integer' \",\" token list-of parse car parse-result-parsed ." "{ 1 2 3 4 }" }
+{ $example "USE: parser-combinators" "\"1,2,3,4\" 'integer' \",\" token list-of parse-1 ." "{ 1 2 3 4 }" }
 { $see-also list-of } ;
 
+HELP: any-char-parser
+{ $values
+  { "parser" "a parser object" } }
+{ $description
+    "Return a parser that consumes a single value "
+    "from the input string. The value consumed is the "
+    "result of the parse." }
+{ $examples
+{ $example "USING: lazy-lists parser-combinators ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;

extra/parser-combinators/parser-combinators.factor

@@ -1,27 +1,31 @@
 ! Copyright (C) 2004 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists promises kernel sequences strings math io
+USING: lazy-lists promises kernel sequences strings math
-arrays namespaces splitting ;
+arrays splitting ;
 IN: parser-combinators
 
 ! Parser combinator protocol
-GENERIC: (parse) ( input parser -- list )
+GENERIC: parse ( input parser -- list )
 
-M: promise (parse) ( input parser -- list )
+M: promise parse ( input parser -- list )
-  force (parse) ;
+    force parse ;
-
-: parse ( input parser -- promise )
-  (parse) ;
 
 TUPLE: parse-result parsed unparsed ;
 
+: parse-1 ( input parser -- result )
+    parse dup nil? [
+        "Parse error" throw
+    ] [
+        car parse-result-parsed
+    ] if ;
+
 C: <parse-result> parse-result
 
 TUPLE: token-parser string ;
 
 C: token token-parser ( string -- parser )
 
-M: token-parser (parse) ( input parser -- list )
+M: token-parser parse ( input parser -- list )
     token-parser-string swap over ?head-slice [
         <parse-result> 1list
     ] [
@@ -32,7 +36,7 @@ TUPLE: satisfy-parser quot ;
 
 C: satisfy satisfy-parser ( quot -- parser )
 
-M: satisfy-parser (parse) ( input parser -- list )
+M: satisfy-parser parse ( input parser -- list )
     #! A parser that succeeds if the predicate,
     #! when passed the first character in the input, returns
     #! true.
@@ -46,11 +50,14 @@ M: satisfy-parser (parse) ( input parser -- list )
         ] if
     ] if ;
 
+LAZY: any-char-parser ( -- parser )
+    [ drop t ] satisfy ;
+
 TUPLE: epsilon-parser ;
 
 C: epsilon epsilon-parser ( -- parser )
 
-M: epsilon-parser (parse) ( input parser -- list )
+M: epsilon-parser parse ( input parser -- list )
     #! A parser that parses the empty string. It
     #! does not consume any input and always returns
     #! an empty list as the parse tree with the
@@ -61,7 +68,7 @@ TUPLE: succeed-parser result ;
 
 C: succeed succeed-parser ( result -- parser )
 
-M: succeed-parser (parse) ( input parser -- list )
+M: succeed-parser parse ( input parser -- list )
     #! A parser that always returns 'result' as a
     #! successful parse with no input consumed.
     succeed-parser-result swap <parse-result> 1list ;
@@ -70,7 +77,7 @@ TUPLE: fail-parser ;
 
 C: fail fail-parser ( -- parser )
 
-M: fail-parser (parse) ( input parser -- list )
+M: fail-parser parse ( input parser -- list )
     #! A parser that always fails and returns
     #! an empty list of successes.
     2drop nil ;
@@ -82,7 +89,7 @@ TUPLE: and-parser parsers ;
         >r and-parser-parsers r> add
     ] [
         2array
-  ] if \ and-parser construct-boa ;
+    ] if and-parser construct-boa ;
 
 : and-parser-parse ( list p1  -- list )
     swap [
@@ -94,18 +101,19 @@ TUPLE: and-parser parsers ;
         ] lmap-with
     ] lmap-with lconcat ;
 
-M: and-parser (parse) ( input parser -- list )
+M: and-parser parse ( input parser -- list )
     #! Parse 'input' by sequentially combining the
     #! two parsers. First parser1 is applied to the
     #! input then parser2 is applied to the rest of
     #! the input strings from the first parser.
-  and-parser-parsers unclip swapd parse [ [ and-parser-parse ] reduce ] 2curry promise ;
+    and-parser-parsers unclip swapd parse
+    [ [ and-parser-parse ] reduce ] 2curry promise ;
 
 TUPLE: or-parser p1 p2 ;
 
 C: <|> or-parser ( parser1 parser2 -- parser )
 
-M: or-parser (parse) ( input parser1 -- list )
+M: or-parser parse ( input parser1 -- list )
     #! Return the combined list resulting from the parses
     #! of parser1 and parser2 being applied to the same
     #! input. This implements the choice parsing operator.
@@ -124,7 +132,7 @@ TUPLE: sp-parser p1 ;
 #! calling the original parser.
 C: sp sp-parser ( p1 -- parser )
 
-M: sp-parser (parse) ( input parser -- list )
+M: sp-parser parse ( input parser -- list )
     #! Skip all leading whitespace from the input then call
     #! the parser on the remaining input.
     >r left-trim-slice r> sp-parser-p1 parse ;
@@ -133,7 +141,7 @@ TUPLE: just-parser p1 ;
 
 C: just just-parser ( p1 -- parser )
 
-M: just-parser (parse) ( input parser -- result )
+M: just-parser parse ( input parser -- result )
     #! Calls the given parser on the input removes
     #! from the results anything where the remaining
     #! input to be parsed is not empty. So ensures a
@@ -144,7 +152,7 @@ TUPLE: apply-parser p1 quot ;
 
 C: <@ apply-parser ( parser quot -- parser )
 
-M: apply-parser (parse) ( input parser -- result )
+M: apply-parser parse ( input parser -- result )
     #! Calls the parser on the input. For each successfull
     #! parse the quot is call with the parse result on the stack.
     #! The result of that quotation then becomes the new parse result.
@@ -160,13 +168,12 @@ TUPLE: some-parser p1 ;
 
 C: some some-parser ( p1 -- parser )
 
-M: some-parser (parse) ( input parser -- result )
+M: some-parser parse ( input parser -- result )
     #! Calls the parser on the input, guarantees
     #! the parse is complete (the remaining input is empty),
     #! picks the first solution and only returns the parse
     #! tree since the remaining input is empty.
-  some-parser-p1 just parse car parse-result-parsed ;
+    some-parser-p1 just parse-1 ;
-
 
 : <& ( parser1 parser2 -- parser )
     #! Same as <&> except discard the results of the second parser.
@@ -178,11 +185,15 @@ M: some-parser (parse) ( input parser -- result )
 
 : <:&> ( parser1 parser2 -- result )
     #! Same as <&> except flatten the result.
-  <&> [ dup second swap first [ % , ] { } make ] <@ ;
+    <&> [ first2 add ] <@ ;
 
 : <&:> ( parser1 parser2 -- result )
     #! Same as <&> except flatten the result.
-  <&> [ dup second swap first [ , % ] { } make ] <@ ;
+    <&> [ first2 swap add* ] <@ ;
+
+: <:&:> ( parser1 parser2 -- result )
+    #! Same as <&> except flatten the result.
+    <&> [ first2 append ] <@ ;
 
 LAZY: <*> ( parser -- parser )
     dup <*> <&:> { } succeed <|> ;
@@ -198,10 +209,11 @@ LAZY: <?> ( parser -- parser )
     [ 1array ] <@ f succeed <|> ;
 
 TUPLE: only-first-parser p1 ;
-LAZY: only-first ( parser -- parser )
-  \ only-first-parser construct-boa ;
 
-M: only-first-parser (parse) ( input parser -- list )
+LAZY: only-first ( parser -- parser )
+    only-first-parser construct-boa ;
+
+M: only-first-parser parse ( input parser -- list )
     #! Transform a parser into a parser that only yields
     #! the first possibility.
     only-first-parser-p1 parse 1 swap ltake ;
@@ -240,15 +252,21 @@ LAZY: <(+)> ( parser -- parser )
     #! Implementation by Matthew Willis.
     dup <(*)> <&:> ;
 
-LAZY: pack ( close body open -- parser )
+: pack ( close body open -- parser )
     #! Parse a construct enclosed by two symbols,
     #! given a parser for the opening symbol, the
     #! closing symbol, and the body.
     <& &> ;
 
-LAZY: list-of ( items separator -- parser )
+: nonempty-list-of ( items separator -- parser )
+    [ over &> <*> <&:> ] keep <?> tuck pack ;
+
+: list-of ( items separator -- parser )
     #! Given a parser for the separator and for the
     #! items themselves, return a parser that parses
     #! lists of those items. The parse tree is an
     #! array of the parsed items.
-  over &> <*> <&:> { } succeed <|> ; 
+    nonempty-list-of { } succeed <|> ;
+
+LAZY: surrounded-by ( parser start end -- parser' )
+    [ token ] 2apply swapd pack ;

extra/parser-combinators/replace/replace.factor

@@ -13,21 +13,21 @@ IN: parser-combinators
   } cond ;
 
 : search ( string parser -- seq )
-  'any-char' [ drop f ] <@ <|> <*> parse dup nil? [
+  any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
     drop { }
   ] [
     car parse-result-parsed [ ] subset 
   ] if ;
 
 : search* ( string parsers -- seq )
-  unclip [ <|> ] reduce 'any-char' [ drop f ] <@ <|> <*> parse dup nil? [
+  unclip [ <|> ] reduce any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
     drop { }
   ] [
     car parse-result-parsed [ ] subset 
   ] if ;
 
 : (replace) ( string parser -- seq )
-  'any-char' <|> <*> parse car parse-result-parsed ;
+  any-char-parser <|> <*> parse-1 ;
 
 : replace ( string parser -- result )
  [  (replace) [ tree-write ] each ] string-out ;

extra/parser-combinators/simple/simple-docs.factor

@@ -3,17 +3,6 @@
 USING: help.syntax help.markup parser-combinators
 parser-combinators.simple ;
 
-HELP: 'any-char'
-{ $values 
-  { "parser" "a parser object" } }
-{ $description 
-    "Return a parser that consumes a single value "
-    "from the input string. The value consumed is the "  
-    "result of the parse." }
-{ $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"foo\" 'any-char' parse car parse-result-parsed ." "102" } }
-{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
-
 HELP: 'digit'
 { $values 
   { "parser" "a parser object" } }
@@ -22,8 +11,7 @@ HELP: 'digit'
     "the input string. The numeric value of the digit "
     " consumed is the result of the parse." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse car parse-result-parsed ." "1" } }
+{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse-1 ." "1" } } ;
-{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
 
 HELP: 'integer'
 { $values 
@@ -33,9 +21,7 @@ HELP: 'integer'
     "the input string. The numeric value of the integer "
     " consumed is the result of the parse." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse car parse-result-parsed ." "123" } }
+{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse-1 ." "123" } } ;
-{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
-
 HELP: 'string'
 { $values 
   { "parser" "a parser object" } }
@@ -44,9 +30,7 @@ HELP: 'string'
     "quotations from the input string. The string value "
     " consumed is the result of the parse." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse car parse-result-parsed ." "\"foo\"" } }
+{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
-{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
-
 HELP: 'bold'
 { $values 
   { "parser" "a parser object" } }
@@ -55,10 +39,8 @@ HELP: 'bold'
     "the '*' character from the input string. This is "
     "commonly used in markup languages to indicate bold "
     "faced text." }
-{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse car parse-result-parsed ." "\"foo\"" }
+{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" }
-{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse car parse-result-parsed ." "\"<strong>foo</strong>\"" }
+{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
-{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
-
 HELP: 'italic'
 { $values 
   { "parser" "a parser object" } }
@@ -68,10 +50,8 @@ HELP: 'italic'
     "commonly used in markup languages to indicate italic "
     "faced text." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse car parse-result-parsed ." "\"foo\"" }
+{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" }
-{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse car parse-result-parsed ." "\"<emphasis>foo</emphasis>\"" } }
+{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
-{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
-
 HELP: comma-list
 { $values 
   { "element" "a parser object" } { "parser" "a parser object" } }
@@ -80,5 +60,6 @@ HELP: comma-list
     "'element' should be a parser that can parse the elements. The "
     "result of the parser is a sequence of the parsed elements." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse car parse-result-parsed ." "{ 1 2 3 4 }" } }
+{ $example "USING: lazy-lits parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
-{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
+
+{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words

extra/parser-combinators/simple/simple.factor

@@ -4,9 +4,6 @@ USING: kernel strings math sequences lazy-lists words
 math.parser promises ;
 IN: parser-combinators 
 
-LAZY: 'any-char' ( -- parser )
-  [ drop t ] satisfy ;
-
 : 'digit' ( -- parser )
   [ digit? ] satisfy [ digit> ] <@ ;
 

extra/peg/peg-docs.factor

@@ -0,0 +1,113 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax peg ;
+
+HELP: parse
+{ $values 
+  { "string" "a string" } 
+  { "parse" "a parser" } 
+  { "result" "a <parse-result> or f" } 
+}
+{ $description 
+    "Given the input string, parse it using the given parser. The result is a <parse-result> object if "
+    "the parse was successful, otherwise it is f." } ;
+
+HELP: token
+{ $values 
+  { "string" "a string" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that matches the given string." } ;
+
+HELP: range
+{ $values 
+  { "min" "a character" } 
+  { "max" "a character" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that matches a single character that lies within the range of characters given, inclusive." }
+{ $example ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } ;
+
+HELP: seq
+{ $values 
+  { "seq" "a sequence of parsers" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if "
+    "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
+    "the individual parsers." } ;
+
+HELP: choice
+{ $values 
+  { "seq" "a sequence of parsers" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. "
+    "The resulting AST is that produced by the successful parser." } ;
+
+HELP: repeat0
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
+    "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
+    "parsed." } ;
+
+HELP: repeat1
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is "
+    "an array of the AST produced by the 'p1' parser." } ;
+
+HELP: optional
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
+    "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
+
+HELP: ensure
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
+    "AST and does not move the location in the input string. This can be used for lookahead and "
+    "disambiguation, along with the " { $link ensure-not } " word." }
+{ $example "\"0\" token ensure octal-parser" } ;
+
+HELP: ensure-not
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
+    "AST and does not move the location in the input string. This can be used for lookahead and "
+    "disambiguation, along with the " { $link ensure } " word." }
+{ $example "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
+
+HELP: action
+{ $values 
+  { "p1" "a parser" } 
+  { "quot" "a quotation with stack effect ( ast -- ast )" } 
+}
+{ $description 
+    "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
+    "from that parse. The result of the quotation is then used as the final AST. This can be used "
+    "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
+    "the default AST." }
+{ $example "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
+

extra/peg/peg-tests.factor

@@ -0,0 +1,139 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test strings namespaces arrays sequences peg peg.private ;
+IN: temporary
+
+{ 0 1 2 } [
+  0 next-id set-global get-next-id get-next-id get-next-id 
+] unit-test
+
+{ f } [
+  "endbegin" "begin" token parse
+] unit-test
+
+{ "begin" "end" } [
+  "beginend" "begin" token parse 
+  { parse-result-ast parse-result-remaining } get-slots
+  >string
+] unit-test
+
+{ f } [
+  "" CHAR: a CHAR: z range parse
+] unit-test
+
+{ f } [
+  "1bcd" CHAR: a CHAR: z range parse
+] unit-test
+
+{ CHAR: a } [
+  "abcd" CHAR: a CHAR: z range parse parse-result-ast
+] unit-test
+
+{ CHAR: z } [
+  "zbcd" CHAR: a CHAR: z range parse parse-result-ast
+] unit-test
+
+{ f } [
+  "bad" "a" token "b" token 2array seq parse
+] unit-test
+
+{ V{ "g" "o" } } [
+  "good" "g" token "o" token 2array seq parse parse-result-ast
+] unit-test
+
+{ "a" } [
+  "abcd" "a" token "b" token 2array choice parse parse-result-ast
+] unit-test
+
+{ "b" } [
+  "bbcd" "a" token "b" token 2array choice parse parse-result-ast
+] unit-test
+
+{ f } [
+  "cbcd" "a" token "b" token 2array choice parse 
+] unit-test
+
+{ f } [
+  "" "a" token "b" token 2array choice parse 
+] unit-test
+
+{ 0 } [
+  "" "a" token repeat0 parse parse-result-ast length
+] unit-test
+
+{ 0 } [
+  "b" "a" token repeat0 parse parse-result-ast length
+] unit-test
+
+{ V{ "a" "a" "a" } } [
+  "aaab" "a" token repeat0 parse parse-result-ast 
+] unit-test
+
+{ f } [
+  "" "a" token repeat1 parse 
+] unit-test
+
+{ f } [
+  "b" "a" token repeat1 parse 
+] unit-test
+
+{ V{ "a" "a" "a" } } [
+  "aaab" "a" token repeat1 parse parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [ 
+  "ab" "a" token optional "b" token 2array seq parse parse-result-ast 
+] unit-test
+
+{ V{ f "b" } } [ 
+  "b" "a" token optional "b" token 2array seq parse parse-result-ast 
+] unit-test
+
+{ f } [ 
+  "cb" "a" token optional "b" token 2array seq parse  
+] unit-test
+
+{ V{ CHAR: a CHAR: b } } [
+  "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse parse-result-ast
+] unit-test
+
+{ f } [
+  "bb" "a" token ensure CHAR: a CHAR: z range 2array seq parse 
+] unit-test
+
+{ t } [
+  "a+b" 
+  "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq
+  parse [ t ] [ f ] if
+] unit-test
+
+{ t } [
+  "a++b" 
+  "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq
+  parse [ t ] [ f ] if
+] unit-test
+
+{ t } [
+  "a+b" 
+  "a" token "+" token "++" token 2array choice "b" token 3array seq
+  parse [ t ] [ f ] if
+] unit-test
+
+{ f } [
+  "a++b" 
+  "a" token "+" token "++" token 2array choice "b" token 3array seq
+  parse [ t ] [ f ] if
+] unit-test
+
+{ 1 } [
+  "a" "a" token [ drop 1 ] action parse parse-result-ast 
+] unit-test
+
+{ V{ 1 1 } } [
+  "aa" "a" token [ drop 1 ] action dup 2array seq parse parse-result-ast 
+] unit-test
+
+{ f } [
+  "b" "a" token [ drop 1 ] action parse 
+] unit-test

extra/peg/peg.factor

@@ -0,0 +1,176 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences strings namespaces math assocs shuffle vectors combinators.lib ;
+IN: peg
+
+TUPLE: parse-result remaining ast ;
+
+GENERIC: parse ( state parser -- result )
+
+<PRIVATE
+
+SYMBOL: ignore 
+
+: <parse-result> ( remaining ast -- parse-result )
+  parse-result construct-boa ;
+
+SYMBOL: next-id 
+
+: get-next-id ( -- number )
+  next-id get-global 0 or dup 1+ next-id set-global ;
+
+TUPLE: parser id ;
+
+: init-parser ( parser -- parser )
+  get-next-id parser construct-boa over set-delegate ;
+
+TUPLE: token-parser symbol ;
+
+M: token-parser parse ( state parser -- result )
+  token-parser-symbol 2dup head? [
+    dup >r length tail-slice r> <parse-result>
+  ] [
+    2drop f
+  ] if ;
+
+TUPLE: range-parser min max ;
+
+M: range-parser parse ( state parser -- result )
+  over empty? [
+    2drop f
+  ] [
+    0 pick nth dup rot 
+    { range-parser-min range-parser-max } get-slots between? [
+      [ 1 tail-slice ] dip <parse-result>
+    ] [
+      2drop f
+    ] if
+  ] if ;
+
+TUPLE: seq-parser parsers ;
+
+: do-seq-parser ( result parser -- result )
+  [ dup parse-result-remaining ] dip parse [
+    [ parse-result-remaining swap set-parse-result-remaining ] 2keep  
+    parse-result-ast dup ignore = [ drop ] [ swap [ parse-result-ast push ] keep ] if
+  ] [
+    drop f
+  ] if* ;
+
+: (seq-parser) ( result parsers -- result )
+  dup empty? not pick and [
+    unclip swap [ do-seq-parser ] dip (seq-parser)
+  ] [
+    drop   
+  ] if ;
+
+M: seq-parser parse ( state parser -- result )
+  seq-parser-parsers [ V{ } clone <parse-result> ] dip  (seq-parser) ;
+
+TUPLE: choice-parser parsers ;
+  
+: (choice-parser) ( state parsers -- result )
+  dup empty? [
+    2drop f
+  ] [
+    unclip pick swap parse [
+      2nip 
+    ] [
+      (choice-parser)
+    ] if* 
+  ] if ;
+
+M: choice-parser parse ( state parser -- result )
+  choice-parser-parsers (choice-parser) ;
+
+TUPLE: repeat0-parser p1 ;
+
+: (repeat-parser) ( parser result -- result )
+  2dup parse-result-remaining swap parse [
+    [ parse-result-remaining swap set-parse-result-remaining ] 2keep 
+    parse-result-ast swap [ parse-result-ast push ] keep
+    (repeat-parser) 
+ ] [
+    nip
+  ] if* ;
+
+: clone-result ( result -- result )
+  { parse-result-remaining parse-result-ast }
+  get-slots 1vector  <parse-result> ;
+
+M: repeat0-parser parse ( state parser -- result )
+     repeat0-parser-p1 2dup parse [ 
+       nipd clone-result (repeat-parser) 
+     ] [ 
+       drop V{ } clone <parse-result> 
+     ] if* ;
+
+TUPLE: repeat1-parser p1 ;
+
+M: repeat1-parser parse ( state parser -- result )
+   repeat1-parser-p1 tuck parse dup [ clone-result (repeat-parser) ] [ nip ] if ;
+
+TUPLE: optional-parser p1 ;
+
+M: optional-parser parse ( state parser -- result )
+   dupd optional-parser-p1 parse swap f <parse-result> or ;
+
+TUPLE: ensure-parser p1 ;
+
+M: ensure-parser parse ( state parser -- result )
+   dupd ensure-parser-p1 parse [
+     ignore <parse-result>  
+   ] [
+     drop f
+   ] if ;
+
+TUPLE: ensure-not-parser p1 ;
+
+M: ensure-not-parser parse ( state parser -- result )
+   dupd ensure-not-parser-p1 parse [
+     drop f
+   ] [
+     ignore <parse-result>  
+   ] if ;
+
+TUPLE: action-parser p1 quot ;
+
+M: action-parser parse ( state parser -- result )
+   tuck action-parser-p1 parse dup [ 
+     dup parse-result-ast rot action-parser-quot call
+     swap [ set-parse-result-ast ] keep
+   ] [
+     nip
+   ] if ;
+
+PRIVATE>
+
+: token ( string -- parser )
+  token-parser construct-boa init-parser ;      
+
+: range ( min max -- parser )
+  range-parser construct-boa init-parser ;
+
+: seq ( seq -- parser )
+  seq-parser construct-boa init-parser ;
+
+: choice ( seq -- parser )
+  choice-parser construct-boa init-parser ;
+
+: repeat0 ( parser -- parser )
+  repeat0-parser construct-boa init-parser ;
+
+: repeat1 ( parser -- parser )
+  repeat1-parser construct-boa init-parser ;
+
+: optional ( parser -- parser )
+  optional-parser construct-boa init-parser ;
+
+: ensure ( parser -- parser )
+  ensure-parser construct-boa init-parser ;
+
+: ensure-not ( parser -- parser )
+  ensure-not-parser construct-boa init-parser ;
+
+: action ( parser quot -- parser )
+  action-parser construct-boa init-parser ;

extra/raptor/config.factor

@@ -1,5 +1,7 @@
 
-USING: namespaces unix.linux.if unix.linux.ifreq unix.linux.route ;
+USING: namespaces threads
+       unix.process unix.linux.if unix.linux.ifreq unix.linux.route
+       raptor.cron ;
 
 IN: raptor
 
@@ -24,21 +26,40 @@ IN: raptor
   configure-route
 ] networking-hook set-global
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Filesystems
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+"/dev/hda1"     root-device     set-global
+
+{ "/dev/hda5" } swap-devices	set-global
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! boot-hook
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 [
+                                    start-wait-loop
 
   ! rcS.d
 
   "mountvirtfs"                     start-service
-  "hostname.sh"			    start-service
+
+  ! "hostname.sh"			    start-service
+  "narodnik"                        set-hostname
+
   "keymap.sh"			    start-service
   "linux-restricted-modules-common" start-service
   "udev"                            start-service
   "mountdevsubfs" 		    start-service
   "module-init-tools" 		    start-service
   "procps.sh" 			    start-service
-  "checkroot.sh"		    start-service
+
+  !  "checkroot.sh"		    start-service
+
+     				    activate-swap
+				    mount-root
+
   "mtab"			    start-service
   "checkfs.sh" 			    start-service
   "mountall.sh"			    start-service
@@ -76,11 +97,17 @@ IN: raptor
   "rmnologin"			    start-service
 
   				    schedule-cron-jobs
-  				    start-listeners
+
-				    start-gettys
+  [ [ "/dev/tty2" tty-listener ] forever ] in-thread
+  [ [ "/dev/tty3" tty-listener ] forever ] in-thread
+  [ [ "/dev/tty4" tty-listener ] forever ] in-thread
+  [ [ "/dev/tty5" getty        ] forever ] in-thread
+  [ [ "/dev/tty6" getty        ] forever ] in-thread
 
 ] boot-hook set-global
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! reboot-hook
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 [
@@ -108,6 +135,8 @@ IN: raptor
   "reboot" 			    stop-service
 ] reboot-hook set-global
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! shutdown-hook
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 [

extra/raptor/cron/cron.factor

@@ -1,5 +1,6 @@
 
-USING: kernel threads sequences calendar combinators.cleave combinators.lib ;
+USING: kernel namespaces threads sequences calendar
+       combinators.cleave combinators.lib ;
 
 IN: raptor.cron
 
@@ -46,3 +47,16 @@ C: <when> when
 
 : schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: cron-jobs-hourly
+SYMBOL: cron-jobs-daily
+SYMBOL: cron-jobs-weekly
+SYMBOL: cron-jobs-monthly
+
+: schedule-cron-jobs ( -- )
+  { 17 } f f f f         <when> [ cron-jobs-hourly  get call ] schedule
+  { 25 } { 6 } f f f     <when> [ cron-jobs-daily   get call ] schedule
+  { 47 } { 6 } f f { 7 } <when> [ cron-jobs-weekly  get call ] schedule
+  { 52 } { 6 } { 1 } f f <when> [ cron-jobs-monthly get call ] schedule ;
+

extra/raptor/cronjobs.factor

@@ -1,47 +1,38 @@
 
-USING: kernel threads arrays sequences combinators.cleave raptor raptor.cron ;
+USING: kernel namespaces threads arrays sequences combinators.cleave
+       raptor raptor.cron ;
 
 IN: raptor
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
+: run-script ( path -- ) 1array [ fork-exec-args-wait ] curry in-thread ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: cron-hourly ( -- ) ;
+[
+    "/etc/cron.daily/apt"             run-script
+    "/etc/cron.daily/aptitude"	      run-script
+    "/etc/cron.daily/bsdmainutils"    run-script
+    "/etc/cron.daily/find.notslocate" run-script
+    "/etc/cron.daily/logrotate"	      run-script
+    "/etc/cron.daily/man-db"	      run-script
+    "/etc/cron.daily/ntp-server"      run-script
+    "/etc/cron.daily/slocate"	      run-script
+    "/etc/cron.daily/standard"	      run-script
+    "/etc/cron.daily/sysklogd"	      run-script
+    "/etc/cron.daily/tetex-bin"	      run-script
+] cron-jobs-daily set-global
     
-: cron-daily ( -- )
+[
-  { "/etc/cron.daily/apt"
+  "/etc/cron.weekly/cvs"                run-script
-    "/etc/cron.daily/aptitude"
+  "/etc/cron.weekly/man-db"		run-script
-    "/etc/cron.daily/bsdmainutils"
+  "/etc/cron.weekly/ntp-server"		run-script
-    "/etc/cron.daily/find.notslocate"
+  "/etc/cron.weekly/popularity-contest" run-script
-    "/etc/cron.daily/logrotate"
+  "/etc/cron.weekly/sysklogd"		run-script
-    "/etc/cron.daily/man-db"
+] cron-jobs-weekly set-global
-    "/etc/cron.daily/ntp-server"
-    "/etc/cron.daily/slocate"
-    "/etc/cron.daily/standard"
-    "/etc/cron.daily/sysklogd"
-    "/etc/cron.daily/tetex-bin" }
-  [ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
 
-: cron-weekly ( -- )
+[
-  { "/etc/cron.weekly/cvs"
+  "/etc/cron.monthly/scrollkeeper" run-script
-    "/etc/cron.weekly/man-db"
+  "/etc/cron.monthly/standard"     run-script
-    "/etc/cron.weekly/ntp-server"
+] cron-jobs-monthly set-global
-    "/etc/cron.weekly/popularity-contest"
-    "/etc/cron.weekly/sysklogd" }
-  [ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
-
-: cron-monthly ( -- )
-  { "/etc/cron.monthly/scrollkeeper"
-    "/etc/cron.monthly/standard" }
-  [ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: schedule-cron-jobs ( -- )
-  { 17 } f f f f         <when> [ cron-hourly  ] schedule
-  { 25 } { 6 } f f f     <when> [ cron-daily   ] schedule
-  { 47 } { 6 } f f { 7 } <when> [ cron-weekly  ] schedule
-  { 52 } { 6 } { 1 } f f <when> [ cron-monthly ] schedule ;

extra/raptor/raptor.factor

@@ -1,5 +1,6 @@
 
-USING: kernel parser namespaces threads unix.process combinators.cleave ;
+USING: kernel parser namespaces threads sequences unix unix.process
+       combinators.cleave bake ;
 
 IN: raptor
 
@@ -10,29 +11,31 @@ SYMBOL: reboot-hook
 SYMBOL: shutdown-hook
 SYMBOL: networking-hook
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : reload-raptor-config ( -- )
   "/etc/raptor/config.factor" run-file
   "/etc/raptor/cronjobs.factor" run-file ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-USING: sequences unix ;
+: fork-exec-wait ( pathname args -- )
+  fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid drop ] if ;
+
+: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: forever ( quot -- ) [ call ] [ forever ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : start-service ( name -- ) "/etc/init.d/" swap " start" 3append system drop ;
 : stop-service  ( name -- ) "/etc/init.d/" swap " stop"  3append system drop ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: fork-exec-wait ( pathname args -- )
+: getty ( tty -- ) `{ "/sbin/getty" "38400" , } fork-exec-args-wait ;
-  fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: respawn ( pathname args -- ) [ fork-exec-wait ] [ respawn ] 2bi ;
-
-: start-gettys ( -- )
-  [ "/sbin/getty" { "getty" "38400" "tty5" } respawn ] in-thread
-  [ "/sbin/getty" { "getty" "38400" "tty6" } respawn ] in-thread ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -40,23 +43,31 @@ USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
        listener ;
 
 : tty-listener ( tty -- )
-  [ <file-reader> <line-reader>  ]
+  [ <file-reader> ] [ <file-writer> ] bi <duplex-stream>
-  [ <file-writer> <plain-writer> ]
+  [ listener ] with-stream ;
-  bi <duplex-stream> [ listener ] with-stream ;
 
-: forever ( quot -- ) [ call ] [ forever ] bi ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: start-listeners ( -- )
+USING: unix.linux.swap unix.linux.fs ;
-  [ [ "/dev/tty2" tty-listener ] forever ] in-thread
+
-  [ [ "/dev/tty3" tty-listener ] forever ] in-thread
+SYMBOL: root-device
-  [ [ "/dev/tty4" tty-listener ] forever ] in-thread ;
+SYMBOL: swap-devices
+
+: activate-swap ( -- ) swap-devices get [ 0 swapon drop ] each ;
+
+: mount-root ( -- ) root-device get "/" "ext3" MS_REMOUNT f mount drop ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : start-networking ( -- ) networking-hook  get call ;
 
+: set-hostname ( name -- ) `{ "/bin/hostname" , } fork-exec-args-wait ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : boot     ( -- ) boot-hook     get call ;
 : reboot   ( -- ) reboot-hook   get call ;
 : shutdown ( -- ) shutdown-hook get call ;
 
 MAIN: boot
+

extra/raptor/readme-0.1.1

@@ -8,9 +8,22 @@ Raptor Linux is a mod of Ubuntu 6.06 (Dapper Drake)
 This is unlikely to work on another version of Ubuntu, much less
 another Linux distribution.
 
+*** Features ***
+
+  * /sbin/init is replaced with Factor
+  * Virtual terminals managed by Factor
+  * Listeners run on virtual terminals
+  * Native support for static ip networking
+  * Crontab replacement
+
 *** Install ***
 
+  # mkdir -v /etc/raptor
+
+  # cp -v /scratch/factor/extra/raptor/{config,cronjobs}.factor /etc/raptor
+
   ( scratchpad ) USE: raptor
+  ( scratchpad ) reload-raptor-config
   ( scratchpad ) save
 
   # mv -v /sbin/{init,init.orig}
@@ -19,10 +32,6 @@ another Linux distribution.
 
   # cp -v /scratch/factor/factor.image /sbin/init.image
 
-  # mkdir -v /etc/raptor
-
-  # cp -v /scratch/factor/extra/raptor/config.factor /etc/raptor/config.factor
-
 *** Static IP networking ***
 
 If you use a static IP in your network then Factor can take care of

extra/regexp/regexp-tests.factor

@@ -0,0 +1,77 @@
+USING: regexp tools.test ;
+IN: regexp-tests
+
+[ f ] [ "b" "a*" matches? ] unit-test
+[ t ] [ "" "a*" matches? ] unit-test
+[ t ] [ "a" "a*" matches? ] unit-test
+[ t ] [ "aaaaaaa" "a*" matches? ] unit-test
+[ f ] [ "ab" "a*" matches? ] unit-test
+
+[ t ] [ "abc" "abc" matches? ] unit-test
+[ t ] [ "a" "a|b|c" matches? ] unit-test
+[ t ] [ "b" "a|b|c" matches? ] unit-test
+[ t ] [ "c" "a|b|c" matches? ] unit-test
+[ f ] [ "c" "d|e|f" matches? ] unit-test
+
+[ f ] [ "aa" "a|b|c" matches? ] unit-test
+[ f ] [ "bb" "a|b|c" matches? ] unit-test
+[ f ] [ "cc" "a|b|c" matches? ] unit-test
+[ f ] [ "cc" "d|e|f" matches? ] unit-test
+
+[ f ] [ "" "a+" matches? ] unit-test
+[ t ] [ "a" "a+" matches? ] unit-test
+[ t ] [ "aa" "a+" matches? ] unit-test
+
+[ t ] [ "" "a?" matches? ] unit-test
+[ t ] [ "a" "a?" matches? ] unit-test
+[ f ] [ "aa" "a?" matches? ] unit-test
+
+[ f ] [ "" "." matches? ] unit-test
+[ t ] [ "a" "." matches? ] unit-test
+[ t ] [ "." "." matches? ] unit-test
+
+[ f ] [ "" ".+" matches? ] unit-test
+[ t ] [ "a" ".+" matches? ] unit-test
+[ t ] [ "ab" ".+" matches? ] unit-test
+
+[ t ] [ "" "a|b*|c+|d?" matches? ] unit-test
+[ t ] [ "a" "a|b*|c+|d?" matches? ] unit-test
+[ t ] [ "c" "a|b*|c+|d?" matches? ] unit-test
+[ t ] [ "cc" "a|b*|c+|d?" matches? ] unit-test
+[ f ] [ "ccd" "a|b*|c+|d?" matches? ] unit-test
+[ t ] [ "d" "a|b*|c+|d?" matches? ] unit-test
+
+[ t ] [ "foo" "foo|bar" matches? ] unit-test
+[ t ] [ "bar" "foo|bar" matches? ] unit-test
+[ f ] [ "foobar" "foo|bar" matches? ] unit-test
+
+[ f ] [ "" "(a)" matches? ] unit-test
+[ t ] [ "a" "(a)" matches? ] unit-test
+[ f ] [ "aa" "(a)" matches? ] unit-test
+[ t ] [ "aa" "(a*)" matches? ] unit-test
+
+[ f ] [ "aababaaabbac" "(a|b)+" matches? ] unit-test
+[ t ] [ "ababaaabba" "(a|b)+" matches? ] unit-test
+
+[ f ] [ "" "a{1}" matches? ] unit-test
+[ t ] [ "a" "a{1}" matches? ] unit-test
+[ f ] [ "aa" "a{1}" matches? ] unit-test
+
+[ f ] [ "a" "a{2,}" matches? ] unit-test
+[ t ] [ "aaa" "a{2,}" matches? ] unit-test
+[ t ] [ "aaaa" "a{2,}" matches? ] unit-test
+[ t ] [ "aaaaa" "a{2,}" matches? ] unit-test
+
+[ t ] [ "" "a{,2}" matches? ] unit-test
+[ t ] [ "a" "a{,2}" matches? ] unit-test
+[ t ] [ "aa" "a{,2}" matches? ] unit-test
+[ f ] [ "aaa" "a{,2}" matches? ] unit-test
+[ f ] [ "aaaa" "a{,2}" matches? ] unit-test
+[ f ] [ "aaaaa" "a{,2}" matches? ] unit-test
+
+[ f ] [ "" "a{1,3}" matches? ] unit-test
+[ t ] [ "a" "a{1,3}" matches? ] unit-test
+[ t ] [ "aa" "a{1,3}" matches? ] unit-test
+[ t ] [ "aaa" "a{1,3}" matches? ] unit-test
+[ f ] [ "aaaa" "a{1,3}" matches? ] unit-test
+

extra/regexp/regexp.factor

@@ -0,0 +1,132 @@
+USING: combinators kernel lazy-lists math math.parser
+namespaces parser parser-combinators parser-combinators.simple
+promises sequences strings ;
+USING: continuations io prettyprint ;
+IN: regexp
+
+: 'any-char'
+    "." token [ drop any-char-parser ] <@ ;
+
+: 'escaped-char'
+    "\\" token any-char-parser &> ;
+
+: 'ordinary-char'
+    [ "*+?|(){}" member? not ] satisfy ;
+
+: 'char' 'escaped-char' 'ordinary-char' <|> ;
+
+: 'string' 'char' <+> [ >string token ] <@ ;
+
+: exactly-n ( parser n -- parser' )
+    swap <repetition> and-parser construct-boa ;
+
+: at-most-n ( parser n -- parser' )
+    dup zero? [
+        2drop epsilon
+    ] [
+        2dup exactly-n
+        -rot 1- at-most-n <|>
+    ] if ;
+
+: at-least-n ( parser n -- parser' )
+    dupd exactly-n swap <*> <&> ;
+
+: from-m-to-n ( parser m n -- parser' )
+    >r [ exactly-n ] 2keep r> swap - at-most-n <&> ;
+
+DEFER: 'regexp'
+
+TUPLE: group-result str ;
+
+C: <group-result> group-result
+
+: 'grouping'
+    "(" token
+    'regexp' [ [ <group-result> ] <@ ] <@
+    ")" token <& &> ;
+
+: 'term'
+    'any-char'
+    'string' <|>
+    'grouping' <|>
+    <+> [
+        dup length 1 =
+        [ first ] [ and-parser construct-boa ] if
+    ] <@ ;
+
+: 'interval'
+    'term'
+    "{" token
+    'integer' <?> &>
+    "," token <?> <:&:>
+    'integer' <?> <:&:>
+    "}" token <& <&> [
+        first2 dup length {
+            { 1 [ first exactly-n ] }
+            { 2 [ first2 dup integer?
+                    [ nip at-most-n ]
+                    [ drop at-least-n ] if ] }
+            { 3 [ first3 nip from-m-to-n ] }
+        } case
+    ] <@ ;
+
+: 'character-range'
+    any-char-parser "-" token <& any-char-parser &> ;
+
+: 'character-class-inside'
+    any-char-parser
+    'character-range' <|> ;
+
+: 'character-class-inclusive'
+    "[" token
+    'character-class-inside'
+    "]" token ;
+
+: 'character-class-exclusive'
+    "[^" token
+    'character-class-inside'
+    "]" token ;
+
+: 'character-class'
+    'character-class-inclusive'
+    'character-class-exclusive' <|> ;
+
+: 'repetition'
+    'term'
+    [ "*+?" member? ] satisfy <&> [
+        first2 {
+            { CHAR: * [ <*> ] }
+            { CHAR: + [ <+> ] }
+            { CHAR: ? [ <?> ] }
+        } case
+    ] <@ ;
+
+: 'simple' 'term' 'repetition' <|> 'interval' <|> ;
+
+LAZY: 'union' ( -- parser )
+    'simple'
+    'simple' "|" token 'union' &> <&> [ first2 <|> ] <@
+    <|> ;
+
+LAZY: 'regexp' ( -- parser )
+    'repetition' 'union' <|> ;
+
+: <regexp> 'regexp' just parse-1 ;
+
+
+GENERIC: >regexp ( obj -- parser )
+M: string >regexp 'regexp' just parse-1 ;
+M: object >regexp ;
+
+: matches? ( string regexp -- ? ) >regexp just parse nil? not ;
+
+: parse-regexp ( accum end -- accum )
+    lexer get dup skip-blank [
+        [ index* dup 1+ swap ] 2keep swapd subseq swap
+    ] change-column  <regexp> parsed ;
+
+: R/ CHAR: / parse-regexp ; parsing
+: R| CHAR: | parse-regexp ; parsing
+: R" CHAR: " parse-regexp ; parsing
+: R' CHAR: ' parse-regexp ; parsing
+: R` CHAR: ` parse-regexp ; parsing

extra/tools/annotations/annotations.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words parser io inspector quotations sequences
-prettyprint continuations ;
+prettyprint continuations effects ;
 IN: tools.annotations
 
 : annotate ( word quot -- )
@@ -9,17 +9,29 @@ IN: tools.annotations
     swap define-compound do-parse-hook ;
     inline
 
-: entering ( str -- ) "! Entering: " write print .s flush ;
+: entering ( str -- )
+    "/-- Entering: " write dup .
+    stack-effect [
+        >r datastack r> effect-in length tail* stack.
+    ] [
+        .s
+    ] if* "\\--" print flush ;
 
-: leaving ( str -- ) "! Leaving: " write print .s flush ;
+: leaving ( str -- )
+    "/-- Leaving: " write dup .
+    stack-effect [
+        >r datastack r> effect-out length tail* stack.
+    ] [
+        .s
+    ] if* "\\--" print flush ;
 
-: (watch) ( str def -- def )
+: (watch) ( word def -- def )
     over [ entering ] curry
     rot [ leaving ] curry
     swapd 3append ;
 
 : watch ( word -- )
-    dup word-name swap [ (watch) ] annotate ;
+    dup [ (watch) ] annotate ;
 
 : breakpoint ( word -- )
     [ \ break add* ] annotate ;

extra/tools/deploy/deploy.factor

@@ -26,12 +26,8 @@ IN: tools.deploy
     [ (copy-lines) ] [ stream-close ] [ ] cleanup ;
 
 : stage2 ( vm flags -- )
-	[
+    >r "-i=" boot-image-name append 2array r> append dup .
-        "\"" % swap % "\" -i=" %
+    <process-stream>
-        boot-image-name %
-        [ " " % % ] each
-    ] "" make
-    dup print <process-stream>
     dup duplex-stream-out stream-close
     copy-lines ;
 
@@ -48,11 +44,11 @@ IN: tools.deploy
 
 : deploy-command-line ( vm image vocab config -- vm flags )
     [
-        "\"-include=" swap profile-string "\"" 3append ,
+        "-include=" swap profile-string append ,
 
         "-deploy-vocab=" swap append ,
 
-        "\"-output-image=" swap "\"" 3append ,
+        "-output-image=" swap append ,
 
         "-no-stack-traces" ,
         

extra/tools/deploy/macosx/macosx.factor

@@ -1,18 +1,17 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io io.files io.launcher kernel namespaces sequences
-system cocoa.plists cocoa.application tools.deploy
+system tools.deploy tools.deploy.config assocs hashtables
-tools.deploy.config assocs hashtables prettyprint ;
+prettyprint io.unix.backend cocoa cocoa.plists
+cocoa.application cocoa.classes qualified ;
+QUALIFIED: unix
 IN: tools.deploy.macosx
 
 : touch ( path -- )
-    "touch \"" swap "\"" 3append run-process ;
+    { "touch" } swap add run-process ;
 
 : rm ( path -- )
-    "rm -rf \"" swap "\"" 3append run-process ;
+    { "rm" "-rf" } swap add run-process ;
-
-: chmod ( path perms -- )
-    [ "chmod " % % " \"" % % "\"" % ] "" make run-process ;
 
 : bundle-dir ( -- dir )
     vm parent-directory parent-directory ;
@@ -21,10 +20,13 @@ IN: tools.deploy.macosx
     bundle-dir over path+ -rot
     >r "Contents" path+ r> path+ copy-directory ;
 
+: chmod ( path perms -- )
+    unix:chmod io-error ;
+
 : copy-vm ( executable bundle-name -- vm )
     "Contents/MacOS/" path+ swap path+ vm swap
     [ copy-file ] keep
-    [ "755" chmod ] keep ;
+    [ OCT: 755 chmod ] keep ;
 
 : copy-fonts ( name -- )
     "fonts/" resource-path
@@ -63,6 +65,12 @@ TUPLE: macosx-deploy-implementation ;
 
 T{ macosx-deploy-implementation } deploy-implementation set-global
 
+: show-in-finder ( path -- )
+    NSWorkspace
+    -> sharedWorkspace
+    over <NSString> rot parent-directory <NSString>
+    -> selectFile:inFileViewerRootedAtPath: drop ;
+
 M: macosx-deploy-implementation deploy ( vocab -- )
     ".app deploy tool" assert.app
     "." resource-path cd
@@ -70,5 +78,6 @@ M: macosx-deploy-implementation deploy ( vocab -- )
         bundle-name rm
         [ bundle-name create-app-dir ] keep
         [ bundle-name deploy.app-image ] keep
-        namespace
+        namespace deploy*
-    ] bind deploy* ;
+        bundle-name show-in-finder
+    ] bind ;

extra/tools/deploy/shaker/shaker.factor

@@ -111,6 +111,10 @@ SYMBOL: deploy-vocab
         builtins ,
         strip-io? [ io-backend , ] unless
 
+        deploy-compiler? get [
+            "callbacks" "alien.compiler" lookup ,
+        ] when
+
         strip-dictionary? [
             {
                 dictionary

extra/tools/test/ui/ui.factor

@@ -1,5 +1,5 @@
 USING: dlists ui.gadgets kernel ui namespaces io.streams.string
-io ui.private ;
+io ;
 IN: tools.test.ui
 
 ! We can't print to stdio here because that might be a pane

extra/ui/cocoa/cocoa.factor

@@ -5,7 +5,7 @@ kernel memory namespaces cocoa.messages cocoa.runtime
 cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows
 cocoa.classes cocoa.application sequences system ui ui.backend
 ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views
-core-foundation ;
+core-foundation threads ;
 IN: ui.cocoa
 
 TUPLE: cocoa-ui-backend ;
@@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
 : event-loop ( -- )
     event-loop? [
         [
-            [ NSApp do-events ui-step ] ui-try
+            [ NSApp do-events ui-step 10 sleep ] ui-try
         ] with-autorelease-pool event-loop
     ] when ;
 
@@ -60,11 +60,19 @@ M: cocoa-ui-backend set-title ( string world -- )
         drop
     ] if ;
 
-M: cocoa-ui-backend (open-world-window) ( world -- )
+M: cocoa-ui-backend (open-window) ( world -- )
     dup gadget-window
     dup auto-position
     world-handle second f -> makeKeyAndOrderFront: ;
 
+M: cocoa-ui-backend (close-window) ( handle -- )
+    first unregister-window ;
+
+M: cocoa-ui-backend close-window ( gadget -- )
+    find-world [
+        world-handle second f -> performClose:
+    ] when* ;
+
 M: cocoa-ui-backend raise-window ( world -- )
     world-handle [
         second dup f -> orderFront: -> makeKeyWindow

extra/ui/cocoa/views/views.factor

@@ -3,7 +3,8 @@
 USING: alien arrays assocs cocoa kernel math cocoa.messages
 cocoa.subclassing cocoa.classes cocoa.views cocoa.application
 cocoa.pasteboard cocoa.types cocoa.windows sequences ui
-ui.gadgets ui.gadgets.worlds ui.gestures core-foundation ;
+ui.gadgets ui.gadgets.worlds ui.gestures core-foundation
+threads ;
 IN: ui.cocoa.views
 
 : send-mouse-moved ( view event -- )
@@ -313,8 +314,6 @@ CLASS: {
 { "dealloc" "void" { "id" "SEL" }
     [
         drop
-        dup window stop-world
-        dup unregister-window
         dup remove-observer
         SUPER-> dealloc
     ]
@@ -347,6 +346,12 @@ CLASS: {
         forget-rollover
         2nip -> object -> contentView window unfocus-world
     ]
+}
+
+{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
+    [
+        2nip -> contentView window ungraft t
+    ]
 } ;
 
 : install-window-delegate ( window -- )

extra/ui/gadgets/editors/editors-tests.factor

@@ -1,5 +1,5 @@
 USING: ui.gadgets.editors tools.test kernel io io.streams.plain
-definitions namespaces ui.gadgets ui.private
+definitions namespaces ui.gadgets
 ui.gadgets.grids prettyprint documents ui.gestures
 tools.test.inference tools.test.ui models ;
 

extra/ui/gadgets/editors/editors.factor

@@ -4,7 +4,7 @@ USING: arrays documents ui.clipboards ui.commands ui.gadgets
 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
 ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
 kernel math models namespaces opengl opengl.gl sequences strings
-io.styles math.vectors sorting colors combinators ;
+io.styles math.vectors sorting colors combinators assocs ;
 IN: ui.gadgets.editors
 
 TUPLE: editor
@@ -94,8 +94,11 @@ M: editor ungraft*
         rot editor-line x>offset ,
     ] { } make ;
 
+: clicked-loc ( editor -- loc )
+    [ hand-rel ] keep point>loc ;
+
 : click-loc ( editor model -- )
-    >r [ hand-rel ] keep point>loc r> set-model ;
+    >r clicked-loc r> set-model ;
 
 : focus-editor ( editor -- )
     t over set-editor-focused? relayout-1 ;
@@ -244,11 +247,37 @@ M: editor user-input*
 
 M: editor gadget-text* editor-string % ;
 
-: start-selection ( editor -- )
-    dup editor-caret click-loc ;
-
 : extend-selection ( editor -- )
-    dup request-focus start-selection ;
+    dup request-focus dup editor-caret click-loc ;
+
+: mouse-elt ( -- elelement )
+    hand-click# get {
+        { 2 T{ one-word-elt } }
+        { 3 T{ one-line-elt } }
+    } at T{ one-char-elt } or ;
+
+: drag-direction? ( loc editor -- ? )
+    editor-mark* <=> 0 < ;
+
+: drag-selection-caret ( loc editor element -- loc )
+    >r [ drag-direction? ] 2keep
+    gadget-model
+    r> prev/next-elt ? ;
+
+: drag-selection-mark ( loc editor element -- loc )
+    >r [ drag-direction? not ] 2keep
+    nip dup editor-mark* swap gadget-model
+    r> prev/next-elt ? ;
+
+: drag-caret&mark ( editor -- caret mark )
+    dup clicked-loc swap mouse-elt
+    [ drag-selection-caret ] 3keep
+    drag-selection-mark ;
+
+: drag-selection ( editor -- )
+    dup drag-caret&mark
+    pick editor-mark set-model
+    swap editor-caret set-model ;
 
 : editor-cut ( editor clipboard -- )
     dupd gadget-copy remove-selection ;
@@ -296,17 +325,10 @@ M: editor gadget-text* editor-string % ;
         dup T{ one-word-elt } select-elt
     ] unless gadget-selection ;
 
-: (position-caret) ( editor -- )
-    dup extend-selection
-    dup editor-mark click-loc ;
-
 : position-caret ( editor -- )
-    hand-click# get {
+    mouse-elt dup T{ one-char-elt } =
-        { 1 [ (position-caret) ] }
+    [ drop dup extend-selection dup editor-mark click-loc ]
-        { 2 [ T{ one-word-elt } select-elt ] }
+    [ select-elt ] if ;
-        { 3 [ T{ one-line-elt } select-elt ] }
-        [ 2drop ]
-    } case ;
 
 : insert-newline "\n" swap user-input ;
 
@@ -408,7 +430,7 @@ editor "caret-motion" f {
 
 editor "selection" f {
     { T{ button-down f { S+ } } extend-selection }
-    { T{ drag } start-selection }
+    { T{ drag } drag-selection }
     { T{ gain-focus } focus-editor }
     { T{ lose-focus } unfocus-editor }
     { T{ delete-action } remove-selection }

extra/ui/gadgets/gadgets-tests.factor

@@ -2,7 +2,7 @@ IN: temporary
 USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
 namespaces models kernel tools.test.inference dlists math
 math.parser ui sequences hashtables assocs io arrays
-prettyprint io.streams.string ui.private ;
+prettyprint io.streams.string ;
 
 [ T{ rect f { 10 10 } { 20 20 } } ]
 [

extra/ui/gadgets/incremental/incremental.factor

@@ -40,13 +40,13 @@ M: incremental pref-dim*
     swap set-rect-loc ;
 
 : prefer-incremental ( gadget -- )
-    dup forget-pref-dim dup pref-dim over set-rect-dim
+    dup forget-pref-dim dup pref-dim swap set-rect-dim ;
-    layout ;
 
 : add-incremental ( gadget incremental -- )
     not-in-layout
     2dup (add-gadget)
     over prefer-incremental
+    over layout-later
     2dup incremental-loc
     tuck update-cursor
     dup prefer-incremental

extra/ui/gadgets/scrollers/scrollers-tests.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: ui.gadgets ui.gadgets.scrollers ui.private
+USING: ui.gadgets ui.gadgets.scrollers
 namespaces tools.test kernel models ui.gadgets.viewports
 ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
 ui.gadgets.sliders math math.vectors arrays sequences

extra/ui/gestures/gestures.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel math models namespaces
 sequences words strings system hashtables math.parser
-math.vectors tuples classes ui.gadgets timers ;
+math.vectors tuples classes ui.gadgets timers combinators.lib ;
 IN: ui.gestures
 
 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
@@ -176,9 +176,22 @@ drag-timer construct-empty drag-timer set-global
 : hand-click-rel ( gadget -- loc )
     hand-click-loc get-global swap screen-loc v- ;
 
+: multi-click-timeout? ( -- ? )
+    millis hand-last-time get - double-click-timeout get <= ;
+
+: multi-click-button? ( button -- button ? )
+    dup hand-last-button get = ;
+
+: multi-click-position? ( -- ? )
+    hand-loc get hand-click-loc get v- norm 10 <= ;
+
 : multi-click? ( button -- ? )
-    millis hand-last-time get - double-click-timeout get <=
+    {
-    swap hand-last-button get = and ;
+        [ multi-click-timeout? ]
+        [ multi-click-button? ]
+        [ multi-click-position? ]
+        [ multi-click-position? ]
+    } && nip ;
 
 : update-click# ( button -- )
     global [

extra/ui/tools/browser/browser-tests.factor

@@ -1,6 +1,6 @@
 IN: temporary
 USING: tools.test tools.test.ui ui.tools.browser
-tools.test.inference ui.private ;
+tools.test.inference ;
 
 { 0 1 } [ <browser-gadget> ] unit-test-effect
 [ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test

extra/ui/tools/deploy/deploy.factor

@@ -77,7 +77,8 @@ TUPLE: deploy-gadget vocab settings ;
 
 : com-deploy ( gadget -- )
     dup com-save
-    find-deploy-vocab [ deploy ] curry call-listener ;
+    dup find-deploy-vocab [ deploy ] curry call-listener
+    close-window ;
 
 : com-help ( -- )
     "ui-deploy" help-window ;
@@ -86,7 +87,11 @@ TUPLE: deploy-gadget vocab settings ;
     { +nullary+ t }
 } define-command
 
+: com-close ( gadget -- )
+    close-window ;
+
 deploy-gadget "toolbar" f {
+    { f com-close }
     { f com-help }
     { f com-revert }
     { f com-save }

extra/ui/tools/listener/listener-tests.factor

@@ -1,7 +1,7 @@
 USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
 timers tools.test ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.panes vocabs words tools.test.ui ui.private ;
+ui.gadgets.panes vocabs words tools.test.ui ;
 IN: temporary
 
 timers [ init-timers ] unless

extra/ui/tools/operations/operations.factor

@@ -64,6 +64,7 @@ V{ } clone operations set-global
     { +keyboard+ T{ key-down f { C+ } "E" } }
     { +primary+ t }
     { +secondary+ t }
+    { +listener+ t }
 } define-operation
 
 UNION: definition word method-spec link ;
@@ -72,6 +73,7 @@ UNION: editable-definition definition vocab vocab-link ;
 
 [ editable-definition? ] \ edit H{
     { +keyboard+ T{ key-down f { C+ } "E" } }
+    { +listener+ t }
 } define-operation
 
 UNION: reloadable-definition definition pathname ;

extra/ui/tools/search/search-tests.factor

@@ -1,6 +1,6 @@
 USING: assocs ui.tools.search help.topics io.files io.styles
 kernel namespaces sequences source-files threads timers
-tools.test ui.gadgets ui.gestures ui.private vocabs
+tools.test ui.gadgets ui.gestures vocabs
 vocabs.loader words tools.test.ui debugger ;
 IN: temporary
 

extra/ui/tools/tools-tests.factor

@@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
 ui.tools.search ui.tools.workspace kernel models namespaces
 sequences timers tools.test ui.gadgets ui.gadgets.buttons
 ui.gadgets.labelled ui.gadgets.presentations
-ui.gadgets.scrollers vocabs tools.test.ui ui ui.private ;
+ui.gadgets.scrollers vocabs tools.test.ui ui ;
 IN: temporary
 
 [

extra/ui/tools/tools.factor

@@ -67,11 +67,11 @@ M: workspace model-changed
 : com-profiler profiler-gadget select-tool ;
 
 workspace "tool-switching" f {
-    { T{ key-down f f "F2" } com-listener }
+    { T{ key-down f { C+ } "1" } com-listener }
-    { T{ key-down f f "F3" } com-browser }
+    { T{ key-down f { C+ } "2" } com-browser }
-    { T{ key-down f f "F4" } com-inspector }
+    { T{ key-down f { C+ } "3" } com-inspector }
-    { T{ key-down f f "F5" } com-walker }
+    { T{ key-down f { C+ } "4" } com-walker }
-    { T{ key-down f f "F6" } com-profiler }
+    { T{ key-down f { C+ } "5" } com-profiler }
 } define-command-map
 
 \ workspace-window
@@ -86,8 +86,8 @@ H{ { +nullary+ t } { +listener+ t } } define-command
 workspace "workflow" f {
     { T{ key-down f { C+ } "n" } workspace-window }
     { T{ key-down f f "ESC" } hide-popup }
-    { T{ key-down f f "F8" } refresh-all }
+    { T{ key-down f f "F2" } refresh-all }
-    { T{ key-down f { A+ } "F8" } test-changes }
+    { T{ key-down f { A+ } "F2" } test-changes }
 } define-command-map
 
 [

extra/ui/tools/walker/walker-tests.factor

@@ -1,6 +1,6 @@
 USING: arrays continuations ui.tools.listener ui.tools.walker
 ui.tools.workspace inspector kernel namespaces sequences threads
-listener tools.test ui ui.gadgets ui.gadgets.worlds ui.private
+listener tools.test ui ui.gadgets ui.gadgets.worlds
 ui.gadgets.packs vectors ui.tools tools.interpreter
 tools.interpreter.debug tools.test.inference tools.test.ui ;
 IN: temporary

extra/ui/tools/workspace/workspace.factor

@@ -2,11 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes continuations help help.topics kernel models
 sequences ui ui.backend ui.tools.debugger ui.gadgets
-ui.gadgets.books ui.gadgets.buttons
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
-ui.gadgets.labelled ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
-ui.gadgets.tracks ui.gadgets.worlds ui.gadgets.presentations
+ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
-ui.gadgets.status-bar ui.commands ui.gestures assocs arrays
+ui.commands ui.gestures assocs arrays namespaces ;
-namespaces ;
 IN: ui.tools.workspace
 
 TUPLE: workspace book listener popup ;

extra/ui/ui.factor

@@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
 prettyprint dlists sequences threads sequences words timers
 debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
 ui.gestures ui.backend ui.render continuations init
-combinators ;
+combinators hashtables ;
 IN: ui
 
 ! Assoc mapping aliens to gadgets
@@ -28,8 +28,6 @@ SYMBOL: windows
 : unregister-window ( handle -- )
     windows global [ [ first = not ] curry* subset ] change-at ;
 
-<PRIVATE
-
 : raised-window ( world -- )
     windows get-global [ second eq? ] curry* find drop
     windows get-global [ length 1- ] keep exchange ;
@@ -67,18 +65,6 @@ M: world ungraft*
     dup world-handle (close-window)
     reset-world ;
 
-PRIVATE>
-
-: open-world-window ( world -- )
-    dup pref-dim over set-gadget-dim dup relayout graft ;
-
-: open-window ( gadget title -- )
-    >r [ 1 track, ] { 0 1 } make-track r>
-    f <world> open-world-window ;
-
-: close-window ( gadget -- )
-    find-world [ ungraft ] when* ;
-
 : find-window ( quot -- world )
     windows get values
     [ gadget-child swap call ] curry* find-last nip ; inline
@@ -90,8 +76,6 @@ SYMBOL: ui-hook
     <dlist> \ layout-queue set-global
     V{ } clone windows set-global ;
 
-<PRIVATE
-
 : restore-gadget-later ( gadget -- )
     dup gadget-graft-state {
         { { f f } [ ] }
@@ -130,7 +114,7 @@ SYMBOL: ui-hook
         layout-queue [
             dup layout find-world [ , ] when*
         ] dlist-slurp
-    ] { } make ;
+    ] { } make prune ;
 
 : redraw-worlds ( seq -- )
     [ dup update-hand draw-world ] each ;
@@ -146,17 +130,26 @@ SYMBOL: ui-hook
 : notify-queued ( -- )
     graft-queue [ notify ] dlist-slurp ;
 
-PRIVATE>
-
 : ui-step ( -- )
     [
         do-timers
         notify-queued
         layout-queued
         redraw-worlds
-        10 sleep
     ] assert-depth ;
 
+: open-world-window ( world -- )
+    dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
+
+: open-window ( gadget title -- )
+    >r [ 1 track, ] { 0 1 } make-track r>
+    f <world> open-world-window ;
+
+HOOK: close-window ui-backend ( gadget -- )
+
+M: object close-window
+    find-world [ ungraft ] when* ;
+
 : start-ui ( -- )
     init-timers
     restore-windows? [

extra/ui/windows/windows.factor

@@ -94,8 +94,7 @@ SYMBOL: mouse-captured
     3drop window draw-world ;
 
 : handle-wm-size ( hWnd uMsg wParam lParam -- )
-    [ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array
+    [ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip
-    2nip
     dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
 
 : wm-keydown-codes ( -- key )
@@ -348,7 +347,10 @@ M: windows-ui-backend (close-window)
 : event-loop ( msg -- )
     {
         { [ windows get empty? ] [ drop ] }
-        { [ dup peek-message? ] [ >r [ ui-step ] ui-try r> event-loop ] }
+        { [ dup peek-message? ] [
+            >r [ ui-step 10 sleep ] ui-try
+            r> event-loop
+        ] }
         { [ dup MSG-message WM_QUIT = ] [ drop ] }
         { [ t ] [
             dup TranslateMessage drop
@@ -381,7 +383,7 @@ M: windows-ui-backend (close-window)
     >r class-name-ptr get-global f r>
     >r >r >r ex-style r> r>
         WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor
-        0 0 r>
+        CW_USEDEFAULT dup r>
     get-RECT-dimensions
     f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
 
@@ -397,8 +399,10 @@ M: windows-ui-backend (close-window)
     GetDoubleClickTime double-click-timeout set-global ;
 
 : cleanup-win32-ui ( -- )
-    class-name-ptr get-global f UnregisterClass drop
+    class-name-ptr get-global [
-    class-name-ptr get-global [ free ] when*
+        dup f UnregisterClass drop
+        free
+    ] when*
     f class-name-ptr set-global ;
 
 : setup-pixel-format ( hdc -- )

extra/ui/x11/x11.factor

@@ -5,7 +5,7 @@ ui.clipboards ui.gadgets.worlds assocs kernel math namespaces
 opengl sequences strings x11.xlib x11.events x11.xim x11.glx
 x11.clipboard x11.constants x11.windows io.utf8 combinators
 debugger system command-line ui.render math.vectors tuples
-opengl.gl ;
+opengl.gl threads ;
 IN: ui.x11
 
 TUPLE: x11-ui-backend ;
@@ -158,18 +158,14 @@ M: world selection-request-event
         { [ t ] [ drop send-notify-failure ] }
     } cond ;
 
-: close-window ( handle -- )
+M: x11-ui-backend (close-window) ( handle -- )
     dup x11-handle-xic XDestroyIC
     dup x11-handle-glx destroy-glx
     x11-handle-window dup unregister-window
     destroy-window ;
 
 M: world client-event
-    swap close-box? [
+    swap close-box? [ ungraft ] [ drop ] if ;
-        dup world-handle >r stop-world r> close-window
-    ] [
-        drop
-    ] if ;
 
 : gadget-window ( world -- )
     dup world-loc over rect-dim glx-window
@@ -182,7 +178,7 @@ M: world client-event
         next-event dup
         None XFilterEvent zero? [ drop wait-event ] unless
     ] [
-        ui-step wait-event
+        ui-step 10 sleep wait-event
     ] if ;
 
 : do-events ( -- )
@@ -222,7 +218,7 @@ M: x11-ui-backend set-title ( string world -- )
     world-handle x11-handle-window swap dpy get -rot
     3dup set-title-old set-title-new ;
 
-M: x11-ui-backend (open-world-window) ( world -- )
+M: x11-ui-backend (open-window) ( world -- )
     dup gadget-window
     world-handle x11-handle-window dup set-closable map-window ;
 

extra/unix/linux/fs/fs.factor

@@ -0,0 +1,25 @@
+
+USING: alien.syntax ;
+
+IN: unix.linux.fs
+
+: MS_RDONLY		1    ; ! Mount read-only.
+: MS_NOSUID		2    ; ! Ignore suid and sgid bits.
+: MS_NODEV		4    ; ! Disallow access to device special files.
+: MS_NOEXEC		8    ; ! Disallow program execution.
+: MS_SYNCHRONOUS	16   ; ! Writes are synced at once.
+: MS_REMOUNT		32   ; ! Alter flags of a mounted FS.
+: MS_MANDLOCK		64   ; ! Allow mandatory locks on an FS.
+: S_WRITE		128  ; ! Write on file/directory/symlink.
+: S_APPEND		256  ; ! Append-only file.
+: S_IMMUTABLE		512  ; ! Immutable file.
+: MS_NOATIME		1024 ; ! Do not update access times.
+: MS_NODIRATIME		2048 ; ! Do not update directory access times.
+: MS_BIND		4096 ; ! Bind directory at different place.
+
+FUNCTION: int mount
+( char* special_file, char* dir, char* fstype, ulong options, void* data ) ;
+
+! FUNCTION: int umount2 ( char* file, int flags ) ;
+
+FUNCTION: int umount ( char* file ) ;

extra/unix/linux/swap/swap.factor

@@ -0,0 +1,12 @@
+
+USING: alien.syntax ;
+
+IN: unix.linux.swap
+
+: SWAP_FLAG_PREFER	HEX: 8000 ; ! Set if swap priority is specified.
+: SWAP_FLAG_PRIO_MASK	HEX: 7fff ;
+: SWAP_FLAG_PRIO_SHIFT	0 ;
+
+FUNCTION: int swapon ( char* path, int flags ) ;
+
+FUNCTION: int swapoff ( char* path ) ;

extra/unix/process/process.factor

@@ -31,11 +31,23 @@ IN: unix.process
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! This is kludgy. We need a better implementation.
+USING: kernel alien.c-types namespaces continuations threads assocs unix
+       combinators.cleave ;
 
-USE: threads
+SYMBOL: pid-wait
 
-: wait-for-pid ( pid -- )
+! KEY | VALUE
-  dup "int" <c-object> WNOHANG waitpid
+! -----------
-  0 = [ 100 sleep wait-for-pid ] [ drop ] if ;
+! pid | continuation
 
+: init-pid-wait ( -- ) H{ } clone pid-wait set-global ;
+
+: wait-for-pid ( pid -- status ) [ pid-wait get set-at stop ] curry callcc1 ;
+
+: wait-loop ( -- )
+  -1 0 <int> tuck WNOHANG waitpid               ! &status return
+  [ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
+  dup [ schedule-thread-with ] [ 2drop ] if
+  250 sleep wait-loop ;
+
+: start-wait-loop ( -- ) init-pid-wait [ wait-loop ] in-thread ;

extra/unix/unix.factor

@@ -166,6 +166,10 @@ FUNCTION: time_t time ( time_t* t ) ;
 FUNCTION: int unlink ( char* path ) ;
 FUNCTION: int utimes ( char* path, timeval[2] times ) ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! wait and waitpid
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 ! Flags for waitpid
 
 : WNOHANG   1 ;
@@ -176,7 +180,27 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
 : WCONTINUED 8 ;
 : WNOWAIT    HEX: 1000000 ;
 
+! Examining status
+
+: WTERMSIG ( status -- value ) HEX: 7f bitand ;
+
+: WIFEXITED ( status -- ? ) WTERMSIG zero? ;
+
+: WEXITSTATUS ( status -- value ) HEX: ff00 bitand -8 shift ;
+
+: WIFSIGNALED ( status -- ? ) HEX: 7f bitand 1+ -1 shift 0 > ;
+
+: WCOREFLAG ( -- value ) HEX: 80 ;
+
+: WCOREDUMP ( status -- ? ) WCOREFLAG bitand zero? not ;
+
+: WIFSTOPPED ( status -- ? ) HEX: ff bitand HEX: 7f = ;
+
+: WSTOPSIG ( status -- value ) WEXITSTATUS ;
+
 FUNCTION: pid_t wait ( int* status ) ;
 FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;

extra/webapps/article-manager/furnace/article.furnace

@@ -1,4 +1,4 @@
-<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database ; %>
+<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
     <div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
     <% f "navigation" render-template %>
     <div id="article">

extra/webapps/article-manager/furnace/tag.furnace

@@ -1,4 +1,4 @@
-<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager ; %>
+<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
 
 	<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
     <% f "navigation" render-template %>

extra/webapps/fjsc/fjsc.factor

@@ -11,7 +11,7 @@ IN: webapps.fjsc
   #! Compile the factor code as a string, outputting the http
   #! response containing the javascript.
   serving-text
-  'expression' parse car parse-result-parsed fjsc-compile 
+  'expression' parse-1 fjsc-compile
   write flush ;
 
 ! The 'compile' action results in an URL that looks like

extra/webapps/planet/planet.factor

@@ -18,7 +18,7 @@ TUPLE: posting author title date link body ;
     #! entries is an array of { author entries } pairs.
     dup [
         [ fetch-feed ] [ error. drop f ] recover
-    ] parallel-map [ ] subset
+    ] parallel-map
     [ [ >r first r> 2array ] curry* map ] 2map concat ;
 
 : sort-entries ( entries -- entries' )
@@ -108,6 +108,7 @@ SYMBOL: cached-postings
     { "Kio M. Smallwood"
     "http://sekenre.wordpress.com/feed/atom/"
     "http://sekenre.wordpress.com/" }
+    { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
     { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
     { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
 } default-blogroll set-global

extra/windows/kernel32/kernel32.factor

@@ -566,7 +566,8 @@ FUNCTION: BOOL ConnectNamedPipe ( HANDLE hNamedPipe, LPOVERLAPPED lpOverlapped )
 ! FUNCTION: CopyFileA
 ! FUNCTION: CopyFileExA
 ! FUNCTION: CopyFileExW
-! FUNCTION: CopyFileW
+FUNCTION: BOOL CopyFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName, BOOL bFailIfExists ) ;
+: CopyFile CopyFileW ; inline
 ! FUNCTION: CopyLZFile
 ! FUNCTION: CreateActCtxA
 ! FUNCTION: CreateActCtxW
@@ -575,7 +576,7 @@ FUNCTION: BOOL ConnectNamedPipe ( HANDLE hNamedPipe, LPOVERLAPPED lpOverlapped )
 ! FUNCTION: CreateDirectoryExA
 ! FUNCTION: CreateDirectoryExW
 FUNCTION: BOOL CreateDirectoryW ( LPCTSTR lpPathName, LPSECURITY_ATTRIBUTES lpSecurityAttribytes ) ;
-: CreateDirectory CreateDirectoryW ;
+: CreateDirectory CreateDirectoryW ; inline
 
 ! FUNCTION: CreateEventA
 ! FUNCTION: CreateEventW

extra/x/x.factor

@@ -29,7 +29,8 @@ define-independent-class
 
 <display> "create" !( name <display> -- display ) [
   new-empty swap >>name
-  dup $name dup [ string>char-alien ] [ ] if XOpenDisplay >>ptr
+  dup $name dup [ string>char-alien ] [ ] if XOpenDisplay
+  dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
   dup $ptr XDefaultScreen >>default-screen
   dup $ptr XDefaultRootWindow dupd <window> new >>default-root
   dup $ptr over $default-screen XDefaultGC >>default-gc

extra/xml/data/data.factor

@@ -65,6 +65,8 @@ M: attrs set-at
 
 M: attrs assoc-size length ;
 M: attrs new-assoc drop V{ } new <attrs> ;
+M: attrs assoc-find >r delegate r> assoc-find ;
+M: attrs >alist delegate >alist ;
 
 : >attrs ( assoc -- attrs )
     V{ } assoc-clone-like

misc/factor.el

@@ -113,13 +113,6 @@
 (defvar factor-binary "/scratch/repos/Factor/factor")
 (defvar factor-image "/scratch/repos/Factor/factor.image")
 
-(defun run-factor ()
-  (interactive)
-  (switch-to-buffer
-   (make-comint-in-buffer "factor" nil factor-binary nil
-			  (concat "-i=" factor-image)
-			  "-run=listener")))
-
 (defun factor-telnet-to-port (port)
   (interactive "nPort: ")
   (switch-to-buffer
@@ -166,9 +159,30 @@
   (beginning-of-line)
   (insert "! "))
 
-
 (define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
 (define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
 (define-key factor-mode-map "\C-c\C-s" 'factor-see)
 (define-key factor-mode-map "\C-ce"    'factor-edit)
 (define-key factor-mode-map "\C-c\C-h" 'factor-help)
+(define-key factor-mode-map "\C-cc"    'comment-region)
+(define-key factor-mode-map [return]   'newline-and-indent)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-listener-mode
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-derived-mode factor-listener-mode comint-mode "Factor Listener")
+
+(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
+
+(defun run-factor ()
+  (interactive)
+  (switch-to-buffer
+   (make-comint-in-buffer "factor" nil factor-binary nil
+			  (concat "-i=" factor-image)
+			  "-run=listener"))
+  (factor-listener-mode))
+
+(defun factor-refresh-all ()
+  (interactive)
+  (comint-send-string "*factor*" "refresh-all\n"))

misc/factor.sh

@@ -0,0 +1,251 @@
+#!/bin/bash -e
+
+# Programs returning != 0 will not cause script to exit
+set +e
+
+# Case insensitive string comparison
+shopt -s nocaseglob
+#shopt -s nocasematch
+
+OS=
+ARCH=
+WORD=
+NO_UI=
+
+ensure_program_installed() {
+	echo -n "Checking for $1..."
+	result=`type -p $1`
+	if ! [[ -n $result ]] ; then
+		echo "not found!"
+		echo "Install $1 and try again."
+		exit 1
+	fi
+	echo "found!"
+}
+
+check_ret() {
+	RET=$?
+	if [[ $RET -ne 0 ]] ; then
+	   echo $1 failed
+	   exit 2
+	fi
+}
+
+check_gcc_version() {
+	GCC_VERSION=`gcc --version`
+	if [[ $GCC_VERSION == *3.3.* ]] ; then
+		echo "You have a known buggy version of gcc (3.3)"
+		echo "Install gcc 3.4 or higher and try again."
+		exit 3
+	fi
+}
+
+check_installed_programs() {
+	ensure_program_installed chmod
+	ensure_program_installed uname
+	ensure_program_installed git
+	ensure_program_installed wget
+	ensure_program_installed gcc
+	ensure_program_installed make
+	check_gcc_version
+}
+
+check_library_exists() {
+	GCC_TEST=factor-library-test.c
+	GCC_OUT=factor-library-test.out
+	echo "Checking for library $1"
+	echo "int main(){return 0;}" > $GCC_TEST
+	gcc $GCC_TEST -o $GCC_OUT -l $1
+	if [[ $? -ne 0 ]] ; then
+		echo "Warning: library $1 not found."
+		echo "***Factor will compile NO_UI=1"
+		NO_UI=1
+	fi
+	rm -f $GCC_TEST
+	rm -f $GCC_OUT
+}
+
+check_X11_libraries() {
+	check_library_exists freetype
+	check_library_exists GLU
+	check_library_exists GL
+	check_library_exists X11
+}
+
+check_libraries() {
+	case $OS in
+		linux) check_X11_libraries;;
+	esac
+}
+
+check_factor_exists() {
+	if [[ -d "factor" ]] ; then
+		echo "A directory called 'factor' already exists."
+		echo "Rename or delete it and try again."
+		exit 4
+	fi
+}
+
+find_os() {
+	uname_s=`uname -s`
+	case $uname_s in
+		CYGWIN_NT-5.2-WOW64) OS=windows-nt;;
+		*CYGWIN_NT*) OS=windows-nt;;
+		*CYGWIN*) OS=windows-nt;;
+		*darwin*) OS=macosx;;
+		*Darwin*) OS=macosx;;
+		*linux*) OS=linux;;
+		*Linux*) OS=linux;;
+	esac
+}
+
+find_architecture() {
+	uname_m=`uname -m`
+	case $uname_m in
+	   i386) ARCH=x86;;
+	   i686) ARCH=x86;;
+	   *86) ARCH=x86;;
+	   "Power Macintosh") ARCH=ppc;;
+	esac
+}
+
+write_test_program() {
+	echo "#include <stdio.h>" > $C_WORD.c
+	echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
+}
+
+find_word_size() {
+	C_WORD=factor-word-size
+	write_test_program
+	gcc -o $C_WORD $C_WORD.c
+	WORD=$(./$C_WORD)
+	check_ret $C_WORD
+	rm -f $C_WORD*
+}
+
+set_factor_binary() {
+	case $OS in
+		windows-nt) FACTOR_BINARY=factor-nt;;
+		macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
+		*) FACTOR_BINARY=factor;;
+	esac
+}
+
+echo_build_info() {
+	echo OS=$OS
+	echo ARCH=$ARCH
+	echo WORD=$WORD
+	echo FACTOR_BINARY=$FACTOR_BINARY
+	echo MAKE_TARGET=$MAKE_TARGET
+	echo BOOT_IMAGE=$BOOT_IMAGE
+}
+
+set_build_info() {
+	if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
+		echo "OS, ARCH, or WORD is empty.  Please report this"
+		exit 5
+	fi
+	
+	MAKE_TARGET=$OS-$ARCH-$WORD
+	BOOT_IMAGE=boot.$ARCH.$WORD.image
+	if [[ $OS == macosx && $ARCH == ppc ]] ; then
+		MAKE_TARGET=$OS-$ARCH
+		BOOT_IMAGE=boot.macosx-ppc.image
+	fi
+}
+
+find_build_info() {
+	find_os
+	find_architecture
+	find_word_size
+	set_factor_binary
+	set_build_info
+	echo_build_info
+}
+
+git_clone() {
+	echo "Downloading the git repository from factorcode.org..."
+	git clone git://factorcode.org/git/factor.git
+	check_ret git
+}
+
+git_pull_factorcode() {
+	git pull git://factorcode.org/git/factor.git
+	check_ret git
+}
+
+cd_factor() {
+	cd factor
+	check_ret cd
+}
+
+make_clean() {
+	make clean
+	check_ret make
+}
+
+make_factor() {
+	make NO_UI=$NO_UI $MAKE_TARGET -j5
+	check_ret make
+}
+
+delete_boot_images() {
+	echo "Deleting old images..."
+	rm $BOOT_IMAGE > /dev/null 2>&1
+	rm $BOOT_IMAGE.* > /dev/null 2>&1
+}
+
+get_boot_image() {
+	wget http://factorcode.org/images/latest/$BOOT_IMAGE
+	check_ret wget
+}
+
+maybe_download_dlls() {
+	if [[ $OS == windows-nt ]] ; then
+		wget http://factorcode.org/dlls/freetype6.dll
+		check_ret
+		wget http://factorcode.org/dlls/zlib1.dll
+		check_ret
+		chmod 777 *.dll
+		check_ret
+	fi
+}
+
+bootstrap() {
+	./$FACTOR_BINARY -i=$BOOT_IMAGE
+}
+
+usage() {
+	echo "usage: $0 install|update"
+}
+
+install() {
+	check_factor_exists
+	check_installed_programs
+	find_build_info
+	check_libraries
+	git_clone
+	cd_factor
+	make_factor
+	get_boot_image
+	maybe_download_dlls
+	bootstrap
+}
+
+update() {
+	check_installed_programs
+	find_build_info
+	check_libraries
+	git_pull_factorcode
+	make_clean
+	make_factor
+	delete_boot_images
+	get_boot_image
+	bootstrap
+}
+
+case "$1" in
+	install) install ;;
+	update) update ;;
+	*) usage ;;
+esac

misc/install.sh

@@ -1,120 +0,0 @@
-#!/bin/bash -e
-
-# Programs returning != 0 will not cause script to exit
-set +e
-
-# Case insensitive string comparison
-shopt -s nocaseglob
-#shopt -s nocasematch
-
-ensure_program_installed() {
-        echo -n "Checking for $1..."
-        result=`type -p $1`
-        if ! [[ -n $result ]] ; then
-                echo "not found!"
-                echo "Install $1 and try again."
-                exit 1
-        fi
-        echo "found!"
-}
-
-check_ret() {
-        RET=$?
-        if [[ $RET -ne 0 ]] ; then
-                echo $1 failed
-                exit 5
-        fi
-}
-
-ensure_program_installed uname
-ensure_program_installed git
-ensure_program_installed wget
-ensure_program_installed gcc
-ensure_program_installed make
-
-GCC_VERSION=`gcc --version`
-if [[ $GCC_VERSION == *3.3.* ]] ; then
-        echo "You have a known buggy version of gcc (3.3)"
-        echo "Install gcc 3.4 or higher and try again."
-        exit 1
-fi
-
-# OS
-OS=
-uname_s=`uname -s`
-case $uname_s in
-        CYGWIN_NT-5.2-WOW64) OS=windows-nt;;
-        *CYGWIN_NT*) OS=windows-nt;;
-        *CYGWIN*) OS=windows-nt;;
-        *darwin*) OS=macosx;;
-        *Darwin*) OS=macosx;;
-        *linux*) OS=linux;;
-        *Linux*) OS=linux;;
-esac
-
-# Architecture
-ARCH=
-uname_m=`uname -m`
-case $uname_m in
-        i386) ARCH=x86;;
-        i686) ARCH=x86;;
-        *86) ARCH=x86;;
-        "Power Macintosh") ARCH=ppc;;
-esac
-
-WORD=
-C_WORD=factor-word-size
-# Word size
-echo "#include <stdio.h>" > $C_WORD.c
-echo "int main() { printf(\"%d\", 8*sizeof(long)); return 0; }" >> $C_WORD.c
-gcc -o $C_WORD $C_WORD.c
-WORD=$(./$C_WORD)
-check_ret $C_WORD
-rm -f $C_WORD*
-
-case $OS in
-        windows-nt) FACTOR_BINARY=factor-nt;;
-        macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
-        *) FACTOR_BINARY=factor;;
-esac
-
-MAKE_TARGET=$OS-$ARCH-$WORD
-BOOT_IMAGE=boot.$ARCH.$WORD.image
-
-echo OS=$OS
-echo ARCH=$ARCH
-echo WORD=$WORD
-echo FACTOR_BINARY=$FACTOR_BINARY
-echo MAKE_TARGET=$MAKE_TARGET
-echo BOOT_IMAGE=$BOOT_IMAGE
-
-if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
-        echo "OS, ARCH, or WORD is empty.  Please report this"
-        exit 4
-fi
-
-echo "Downloading the git repository from factorcode.org..."
-git clone git://factorcode.org/git/factor.git
-check_ret git
-
-cd factor
-check_ret cd
-
-make $MAKE_TARGET
-check_ret make
-
-echo "Deleting old images..."
-rm $BOOT_IMAGE > /dev/null 2>&1
-rm $BOOT_IMAGE.* > /dev/null 2>&1
-wget http://factorcode.org/images/latest/$BOOT_IMAGE
-check_ret wget
-
-if [[ $OS == windows-nt ]] ; then
-	wget http://factorcode.org/dlls/freetype6.dll
-	check_ret
-	wget http://factorcode.org/dlls/zlib1.dll
-	check_ret
-fi
-
-
-./$FACTOR_BINARY -i=$BOOT_IMAGE

vm/Config.windows.nt

@@ -0,0 +1,8 @@
+LIBS = -lm
+EXE_SUFFIX=-nt
+DLL_SUFFIX=-nt
+PLAF_DLL_OBJS += vm/os-windows-nt.o
+PLAF_EXE_OBJS += vm/resources.o
+PLAF_EXE_OBJS += vm/main-windows-nt.o
+#CFLAGS += -mwindows
+include vm/Config.windows

vm/Config.windows.nt.x86.32

@@ -1,7 +1,3 @@
-LIBS = -lm
+WINDRES=windres
-EXE_SUFFIX=-nt
+include vm/Config.windows.nt
-DLL_SUFFIX=-nt
+include vm/Config.x86.32
-PLAF_DLL_OBJS += vm/os-windows-nt.o
-PLAF_EXE_OBJS += vm/resources.o
-PLAF_EXE_OBJS += vm/main-windows-nt.o
-include vm/Config.x86.32 vm/Config.windows

vm/Config.windows.nt.x86.64

@@ -0,0 +1,4 @@
+CC=/k/target/bin/x86_64-pc-mingw32-gcc
+include vm/Config.windows.nt
+include vm/Config.x86.64
+WINDRES = /k/target/bin/windres

vm/debug.c

@@ -213,6 +213,7 @@ void dump_objects(F_FIXNUM type)
 void factorbug(void)
 {
 	reset_stdio();
+	open_console();
 
 	printf("Starting low level debugger...\n");
 	printf("  Basic commands:\n");

vm/factor.c

@@ -26,6 +26,7 @@ void default_parameters(F_PARAMETERS *p)
 
 	p->secure_gc = false;
 	p->fep = false;
+	p->console = false;
 }
 
 /* Get things started */
@@ -110,6 +111,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 			p.fep = true;
 		else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0)
 			p.image = argv[i] + 3;
+		else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0)
+			p.console = true ;
 	}
 
 	init_factor(&p);
@@ -135,6 +138,9 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 
 	nest_stacks();
 
+	if(p.console)
+		open_console();
+
 	if(p.fep)
 		factorbug();