Merge git://spitspat.com/git/factor

core/alien/compiler/compiler.factor

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

core/alien/syntax/syntax.factor

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

core/assocs/assocs-tests.factor

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

core/assocs/assocs.factor

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

core/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/kernel/kernel-docs.factor

@@ -32,7 +32,7 @@ $nl
 { $subsection >r }
 { $subsection r> }
 "The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
-{ $example "1 2 3 >r .s r>" "2\n1" }
+{ $example "1 2 3 >r .s r>" "1\n2" }
 "Words must not leave objects on the retain stack, nor expect values to be there on entry. The retain stack is for local storage within a word only, and occurrences of " { $link >r } " and " { $link r> } " must be balanced inside a single quotation. One exception is the following trick involving " { $link if } "; values may be pushed on the retain stack before the condition value is computed, as long as both branches of the " { $link if } " pop the values off the retain stack before returning:"
 { $code
     ": foo ( m ? n -- m+n/n )"

core/prettyprint/backend/backend.factor

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

core/quotations/quotations-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/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/combinators/lib/lib-tests.factor

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

extra/combinators/lib/lib.factor

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

extra/delegate/author.txt

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

extra/delegate/delegate-docs.factor

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

extra/delegate/delegate-tests.factor

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

extra/delegate/delegate.factor

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

extra/delegate/summary.txt

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

extra/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/editplus/authors.txt

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

extra/editors/editplus/editplus.factor

@@ -0,0 +1,12 @@
+USING: editors io.launcher math.parser namespaces ;
+IN: editors.editplus
+
+: editplus ( file line -- )
+    [
+        \ editplus get-global % " -cursor " % # " " % %
+    ] "" make run-detached ;
+
+! Put in your .factor-boot-rc
+! "c:\\Program Files\\EditPlus\\editplus.exe" \ editplus set-global
+
+[ editplus ] edit-hook set-global

extra/editors/editplus/summary.txt

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

extra/editors/emeditor/authors.txt

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

extra/editors/emeditor/emeditor.factor

@@ -0,0 +1,10 @@
+USING: editors io.launcher kernel math.parser namespaces ;
+IN: editors.emeditor
+
+: emeditor ( file line -- )
+    [
+        \ emeditor get-global % " /l " % #
+        " " % "\"" % % "\"" %
+    ] "" make run-detached ;
+
+[ emeditor ] edit-hook set-global

extra/editors/emeditor/summary.txt

@@ -0,0 +1 @@
+EmEditor 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/notepadpp/notepadpp.factor

@@ -1,5 +1,5 @@
 USING: editors io.launcher math.parser namespaces ;
-IN: notepadpp
+IN: editors.notepadpp
 
 : notepadpp ( file line -- )
     [

extra/editors/ted-notepad/authors.txt

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

extra/editors/ted-notepad/summary.txt

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

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

@@ -0,0 +1,10 @@
+USING: editors io.launcher kernel math.parser namespaces ;
+IN: editors.ted-notepad
+
+: ted-notepad ( file line -- )
+    [
+        \ ted-notepad get-global % " /l" % #
+        " " % %
+    ] "" make run-detached ;
+
+[ ted-notepad ] edit-hook set-global

extra/editors/ultraedit/authors.txt

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

extra/editors/ultraedit/summary.txt

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

extra/editors/ultraedit/ultraedit.factor

@@ -0,0 +1,12 @@
+USING: editors io.launcher kernel math.parser namespaces ;
+IN: editors.ultraedit
+
+: ultraedit ( file line -- )
+    [
+        \ ultraedit get-global % " " % swap % "/" % # "/1" %
+    ] "" make run-detached ;
+
+! Put the path in your .factor-boot-rc
+! "K:\\Program Files (x86)\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" \ ultraedit set-global
+
+[ ultraedit ] edit-hook set-global

extra/editors/wordpad/authors.txt

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

extra/editors/wordpad/summary.txt

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

extra/editors/wordpad/wordpad.factor

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

extra/globs/authors.txt

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

extra/globs/globs-tests.factor

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

extra/globs/globs.factor

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

extra/globs/summary.txt

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

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

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

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

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

extra/hardware-info/windows/windows.factor

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

extra/help/handbook/handbook.factor

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

extra/html/parser/analyzer/analyzer.factor

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

extra/html/parser/parser-tests.factor

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

extra/html/parser/parser.factor

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

extra/html/parser/printer/printer.factor

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

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

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

extra/html/parser/utils/utils.factor

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

extra/inverse/inverse-docs.factor

@@ -24,7 +24,7 @@ HELP: matches?
 { $values { "quot" "a quotation" } { "?" "a boolean" } }
 { $description "Tests if the stack can match the given quotation. The quotation is inverted, and if the inverse can run without a unification failure, then t is returned. Else f is returned. If a different error is encountered (such as stack underflow), this will be propagated." } ;
 
-HELP: which
+HELP: switch
 { $values { "quot-alist" "an alist from inverse quots to quots" } }
 { $description "The equivalent of a case expression in a programming language with buitlin pattern matchining. It attempts to match the stack with each of the patterns, in order, by treating them as inverse quotations. Failure causes the next pattern to be tested." }
 { $code
@@ -34,7 +34,7 @@ HELP: which
 "    {"
 "        { [ <cons> ] [ sum + ] }"
 "        { [ f ] [ 0 ] }"
-"    } which ;" }
+"    } switch ;" }
 { $see-also undo } ;
 
 ARTICLE: { "inverse" "intro" } "Invertible quotations"
@@ -46,7 +46,7 @@ ARTICLE: { "inverse" "intro" } "Invertible quotations"
 "To use the inverse quotation for pattern matching"
 { $subsection undo }
 { $subsection matches? }
-{ $subsection which } ;
+{ $subsection switch } ;
 
 IN: inverse
 ABOUT: { "inverse" "intro" }

extra/inverse/inverse-tests.factor

@@ -1,5 +1,6 @@
 USING: inverse tools.test arrays math kernel sequences
-math.functions ;
+math.functions math.constants ;
+IN: inverse-tests
 
 [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
 [ { 3 4 } [ dup 2array ] undo ] unit-test-fails
@@ -20,7 +21,7 @@ C: <foo> foo
     {
         { [ dup 1+ 2array ] [ 3 * ] }
         { [ 3array ] [ + + ] }
-    } which ;
+    } switch ;
 
 [ 5 ] [ { 1 2 2 } something ] unit-test
 [ 6 ] [ { 2 3 } something ] unit-test
@@ -35,6 +36,8 @@ C: <foo> foo
 [ { t t f } ] [ { t f 1 } [ [ >boolean ] matches? ] map ] unit-test
 [ { t f } ] [ { { 1 2 3 } 4 } [ [ >array ] matches? ] map ] unit-test
 [ 9 9 ] [ 3 [ 1/2 ^ ] undo 3 [ sqrt ] undo ] unit-test
+[ 5 ] [ 6 5 - [ 6 swap - ] undo ] unit-test
+[ 6 ] [ 6 5 - [ 5 - ] undo ] unit-test
 
 TUPLE: cons car cdr ;
 
@@ -49,12 +52,19 @@ C: <nil> nil
         { [ <cons> ] [ list-sum + ] }
         { [ <nil> ] [ 0 ] }
         { [ ] [ "Malformed list" throw ] }
-    } which ;
+    } switch ;
 
 [ 10 ] [ 1 2 3 4 <nil> <cons> <cons> <cons> <cons> list-sum ] unit-test
+[ ] [ <nil> [ <nil> ] undo ] unit-test
+[ 1 2 ] [ 1 2 <cons> [ <cons> ] undo ] unit-test
+[ t ] [ 1 2 <cons> [ <cons> ] matches? ] unit-test
+[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
 
 : empty-cons ( -- cons ) cons construct-empty ;
 : cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
 
 [ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
 [ 1 2 ] [ 2 1 <cons> [ cons* ] undo ] unit-test
+
+[ t ] [ pi [ pi ] matches? ] unit-test
+[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test

extra/inverse/inverse.factor

@@ -1,18 +1,9 @@
 USING: kernel words inspector slots quotations sequences assocs
 math arrays inference effects shuffle continuations debugger
 tuples namespaces vectors bit-arrays byte-arrays strings sbufs
-math.functions macros ;
+math.functions macros combinators.private combinators ;
 IN: inverse
 
-: (repeat) ( from to quot -- )
-    pick pick >= [
-        3drop
-    ] [
-        [ swap >r call 1+ r> ] keep (repeat)
-    ] if ; inline
-
-: repeat ( n quot -- ) 0 -rot (repeat) ; inline
-
 TUPLE: fail ;
 : fail ( -- * ) \ fail construct-empty throw ;
 M: fail summary drop "Unification failed" ;
@@ -26,58 +17,100 @@ M: fail summary drop "Unification failed" ;
 
 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
 
-DEFER: [undo]
+: define-math-inverse ( word quot1 quot2 -- )
+    pick 1quotation 3array "math-inverse" set-word-prop ;
 
-: make-inverse ( word -- quot )
+: define-pop-inverse ( word n quot -- )
-    word-def [undo] ;
+    >r dupd "pop-length" set-word-prop r>
+    "pop-inverse" set-word-prop ;
 
 TUPLE: no-inverse word ;
 : no-inverse ( word -- * ) \ no-inverse construct-empty throw ;
 M: no-inverse summary
     drop "The word cannot be used in pattern matching" ;
 
-GENERIC: inverse ( word -- quot )
+: next ( revquot -- revquot* first )
+    dup empty?
+    [ "Badly formed math inverse" throw ]
+    [ unclip-slice ] if ;
 
-M: word inverse
+: constant-word? ( word -- ? )
-    dup "inverse" word-prop [ ]
+    stack-effect
-    [ dup primitive? [ no-inverse ] [ make-inverse ] if ] ?if ;
+    [ effect-out length 1 = ] keep
+    effect-in length 0 = and ;
 
-: undo-literal ( object -- quot )
+: assure-constant ( constant -- quot )
-    [ =/fail ] curry ;
+    dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
 
-M: object inverse undo-literal ;
+: swap-inverse ( math-inverse revquot -- revquot* quot )
-M: symbol inverse undo-literal ;
+    next assure-constant rot second [ swap ] swap 3compose ;
+
+: pull-inverse ( math-inverse revquot const -- revquot* quot )
+    assure-constant rot first compose ;
 
 : ?word-prop ( word/object name -- value/f )
     over word? [ word-prop ] [ 2drop f ] if ;
 
-: group-pops ( seq -- matrix )
+: undo-literal ( object -- quot )
-    [
+    [ =/fail ] curry ;
-        dup length [
-            2dup swap nth dup "pop-length" ?word-prop
-            [ 1+ dupd + tuck >r pick r> swap subseq , 1- ]
-            [ 1quotation , ] ?if
-        ] repeat drop
-    ] [ ] make ;
 
-: inverse-pop ( quot -- inverse )
+PREDICATE: word normal-inverse "inverse" word-prop ;
-    unclip >r reverse r> "pop-inverse" word-prop call ;
+PREDICATE: word math-inverse "math-inverse" word-prop ;
+PREDICATE: word pop-inverse "pop-length" word-prop ;
+UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
 
-: firstn ( n -- quot )
+: inline-word ( word -- )
-    { [ drop ] [ first ] [ first2 ] [ first3 ] [ first4 ] } nth ;
+    {
+        { [ dup word? not over symbol? or ] [ , ] }
+        { [ dup explicit-inverse? ] [ , ] }
+        { [ dup compound? over { if dispatch } member? not and ]
+          [ word-def [ inline-word ] each ] }
+        { [ drop t ] [ "Quotation is not invertible" throw ] }
+    } cond ;
 
-: define-pop-inverse ( word n quot -- )
+: math-exp? ( n n word -- ? )
-    -rot 2dup "pop-length" set-word-prop
+    { + - * / ^ } member? -rot [ number? ] 2apply and and ;
-    firstn rot append "pop-inverse" set-word-prop ;
+
+: (fold-constants) ( quot -- )
+    dup length 3 < [ % ] [
+        dup first3 3dup math-exp?
+        [ execute , 3 ] [ 2drop , 1 ] if
+        tail-slice (fold-constants) 
+    ] if ;
+
+: fold-constants ( quot -- folded )
+    [ (fold-constants) ] [ ] make ;
+
+: do-inlining ( quot -- inlined-quot )
+    [ [ inline-word ] each ] [ ] make fold-constants ;
+
+GENERIC: inverse ( revquot word -- revquot* quot )
+
+M: object inverse undo-literal ;
+M: symbol inverse undo-literal ;
+
+M: normal-inverse inverse
+    "inverse" word-prop ;
+
+M: math-inverse inverse
+    "math-inverse" word-prop
+    swap next dup \ swap =
+    [ drop swap-inverse ] [ pull-inverse ] if ;
+
+M: pop-inverse inverse
+    [ "pop-length" word-prop cut-slice swap ] keep
+    "pop-inverse" word-prop compose call ;
+
+: (undo) ( revquot -- )
+    dup empty? [ drop ]
+    [ unclip-slice inverse % (undo) ] if ;
 
 : [undo] ( quot -- undo )
-    reverse group-pops [
+    do-inlining reverse [ (undo) ] [ ] make ;
-        dup length 1 = [ first inverse ] [ inverse-pop ] if
-    ] map concat [ ] like ;
 
 MACRO: undo ( quot -- ) [undo] ;
 
-! Inversions of selected words
+! Inverse of selected words
 
 \ swap [ swap ] define-inverse
 \ dup [ [ =/fail ] keep ] define-inverse
@@ -96,8 +129,6 @@ MACRO: undo ( quot -- ) [undo] ;
 \ undo 1 [ [ call ] curry ] define-pop-inverse
 \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
 
-\ neg [ neg ] define-inverse
-\ recip [ recip ] define-inverse
 \ exp [ log ] define-inverse
 \ log [ exp ] define-inverse
 \ not [ not ] define-inverse
@@ -107,11 +138,11 @@ MACRO: undo ( quot -- ) [undo] ;
 : assert-literal ( n -- n )
     dup [ word? ] keep symbol? not and
     [ "Literal missing in pattern matching" throw ] when ;
-\ + 1 [ assert-literal [ - ] curry ] define-pop-inverse
+\ + [ - ] [ - ] define-math-inverse
-\ - 1 [ assert-literal [ + ] curry ] define-pop-inverse
+\ - [ + ] [ - ] define-math-inverse
-\ * 1 [ assert-literal [ / ] curry ] define-pop-inverse
+\ * [ / ] [ / ] define-math-inverse
-\ / 1 [ assert-literal [ * ] curry ] define-pop-inverse
+\ / [ * ] [ / ] define-math-inverse
-\ ^ 1 [ assert-literal recip [ ^ ] curry ] define-pop-inverse
+\ ^ [ recip ^ ] [ [ log ] 2apply / ] define-math-inverse
 
 \ ? 2 [
     [ assert-literal ] 2apply
@@ -160,13 +191,13 @@ MACRO: undo ( quot -- ) [undo] ;
 : slot-readers ( class -- quot )
     "slots" word-prop 1 tail ! tail gets rid of delegate
     [ slot-spec-reader 1quotation [ keep ] curry ] map concat
-    [ drop ] append ;
+    [ ] like [ drop ] compose ;
 
 : ?wrapped ( object -- wrapped )
     dup wrapper? [ wrapped ] when ;
 
 : boa-inverse ( class -- quot )
-    [ deconstruct-pred ] keep slot-readers append ;
+    [ deconstruct-pred ] keep slot-readers compose ;
 
 \ construct-boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
 
@@ -186,7 +217,7 @@ MACRO: undo ( quot -- ) [undo] ;
     [ writer>reader ] map [ get-slots ] curry
     compose ;
 
-\ construct 2 [ ?wrapped swap construct-inverse ] define-pop-inverse
+\ construct 2 [ >r ?wrapped r> construct-inverse ] define-pop-inverse
 
 ! More useful inverse-based combinators
 
@@ -196,21 +227,27 @@ MACRO: undo ( quot -- ) [undo] ;
         [ drop call ] [ nip throw ] if
     ] recover ; inline
 
-: infer-out ( quot -- #out )
+: true-out ( quot effect -- quot' )
-    infer effect-out ;
+    effect-out [ ndrop ] curry
+    [ t ] 3compose ;
 
-MACRO: matches? ( quot -- ? )
+: false-recover ( effect -- quot )
-    [undo] [ t ] append
+    effect-in [ ndrop f ] curry [ recover-fail ] curry ;
-    [ [ [ f ] recover-fail ] curry ] keep
+
-    infer-out 1- [ nnip ] curry append ;
+: [matches?] ( quot -- undoes?-quot )
+    [undo] dup infer [ true-out ] keep false-recover curry ;
+
+MACRO: matches? ( quot -- ? ) [matches?] ;
 
 TUPLE: no-match ;
 : no-match ( -- * ) \ no-match construct-empty throw ;
-M: no-match summary drop "Fall through in which" ;
+M: no-match summary drop "Fall through in switch" ;
 
 : recover-chain ( seq -- quot )
     [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
 
-MACRO: which ( quot-alist -- )
+: [switch]  ( quot-alist -- quot )
-    reverse [ >r [undo] r> append ] { } assoc>map
+    reverse [ >r [undo] r> compose ] { } assoc>map
     recover-chain ;
+
+MACRO: switch ( quot-alist -- ) [switch] ;

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/parser-combinators/parser-combinators-tests.factor

@@ -149,5 +149,3 @@ IN: scratchpad
 { { } } [
   "234" "1" token <+> parse list>array
 ] unit-test
-
-

extra/parser-combinators/parser-combinators.factor

@@ -1,128 +1,149 @@
 ! 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 quotations combinators ;
 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 car parse-result-parsed ;
+    dupd parse dup nil? [
+        "Cannot parse " rot append throw
+    ] [
+        nip car parse-result-parsed
+    ] if ;
 
 C: <parse-result> parse-result
 
+: parse-result-parsed-slice ( parse-result -- slice )
+    dup parse-result-parsed empty? [
+        parse-result-unparsed 0 0 rot <slice>
+    ] [
+        dup parse-result-unparsed
+        dup slice-from [ rot parse-result-parsed length - ] keep
+        rot slice-seq <slice>
+    ] if ;
+
 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 [
+    token-parser-string swap over ?head-slice [
-    <parse-result> 1list
+        <parse-result> 1list
-  ] [
+    ] [
-    2drop nil
+        2drop nil
-  ] if ;
+    ] if ;
+
+: 1token ( n -- parser ) 1string token ;
 
 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,
+    #! A parser that succeeds if the predicate,
-  #! when passed the first character in the input, returns
+    #! when passed the first character in the input, returns
-  #! true.
+    #! true.
-  over empty? [
+    over empty? [
-    2drop nil
+        2drop nil
-  ] [
-    satisfy-parser-quot >r unclip-slice dup r> call [
-      swap <parse-result> 1list
     ] [
-      2drop nil
+        satisfy-parser-quot >r unclip-slice dup r> call [
-    ] if
+            swap <parse-result> 1list
-  ] if ;
+        ] [
+            2drop nil
+        ] if
+    ] if ;
 
 LAZY: any-char-parser ( -- parser )
-  [ drop t ] satisfy ;
+    [ 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
+    #! A parser that parses the empty string. It
-  #! does not consume any input and always returns
+    #! does not consume any input and always returns
-  #! an empty list as the parse tree with the
+    #! an empty list as the parse tree with the
-  #! unmodified input.
+    #! unmodified input.
-  drop "" swap <parse-result> 1list ;
+    drop "" swap <parse-result> 1list ;
 
 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
+    #! A parser that always returns 'result' as a
-  #! successful parse with no input consumed.
+    #! successful parse with no input consumed.
-  succeed-parser-result swap <parse-result> 1list ;
+    succeed-parser-result swap <parse-result> 1list ;
 
 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
+    #! A parser that always fails and returns
-  #! an empty list of successes.
+    #! an empty list of successes.
-  2drop nil ;
+    2drop nil ;
 
 TUPLE: and-parser parsers ;
 
 : <&> ( parser1 parser2 -- parser )
-  over and-parser? [
+    over and-parser? [
-    >r and-parser-parsers r> add
+        >r and-parser-parsers r> add
-  ] [
+    ] [
-    2array
+        2array
-  ] if \ and-parser construct-boa ;
+    ] if and-parser construct-boa ;
+
+: <and-parser> ( parsers -- parser )
+    dup length 1 = [ first ] [ and-parser construct-boa ] if ;
 
 : and-parser-parse ( list p1  -- list )
-  swap [
+    swap [
-    dup parse-result-unparsed rot parse
+        dup parse-result-unparsed rot parse
-    [
+        [
-      >r parse-result-parsed r>
+            >r parse-result-parsed r>
-      [ parse-result-parsed 2array ] keep
+            [ parse-result-parsed 2array ] keep
-      parse-result-unparsed <parse-result>
+            parse-result-unparsed <parse-result>
-    ] lmap-with
+        ] lmap-with
-  ] lmap-with lconcat ;
+    ] lmap-with lconcat ;
 
-M: and-parser (parse) ( input parser -- list )
+M: and-parser parse ( input parser -- list )
-  #! Parse 'input' by sequentially combining the
+    #! Parse 'input' by sequentially combining the
-  #! two parsers. First parser1 is applied to the
+    #! two parsers. First parser1 is applied to the
-  #! input then parser2 is applied to the rest of
+    #! input then parser2 is applied to the rest of
-  #! the input strings from the first parser.
+    #! 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 ;
+TUPLE: or-parser parsers ;
 
-C: <|> or-parser ( parser1 parser2 -- parser )
+: <or-parser> ( parsers -- parser )
+    dup length 1 = [ first ] [ or-parser construct-boa ] if ;
 
-M: or-parser (parse) ( input parser1 -- list )
+: <|> ( parser1 parser2 -- parser )
-  #! Return the combined list resulting from the parses
+    2array <or-parser> ;
-  #! of parser1 and parser2 being applied to the same
+
-  #! input. This implements the choice parsing operator.
+M: or-parser parse ( input parser1 -- list )
-  [ or-parser-p1 ] keep or-parser-p2 >r dupd parse swap r> parse lappend ;
+    #! Return the combined list resulting from the parses
+    #! of parser1 and parser2 being applied to the same
+    #! input. This implements the choice parsing operator.
+    or-parser-parsers 0 swap seq>list
+    [ parse ] lmap-with lconcat ;
 
 : left-trim-slice ( string -- string )
-  #! Return a new string without any leading whitespace
+    #! Return a new string without any leading whitespace
-  #! from the original string.
+    #! from the original string.
-  dup empty? [
+    dup empty? [
-    dup first blank? [ 1 tail-slice left-trim-slice ] when
+        dup first blank? [ 1 tail-slice left-trim-slice ] when
-  ] unless ;
+    ] unless ;
 
 TUPLE: sp-parser p1 ;
 
@@ -130,111 +151,115 @@ 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
+    #! Skip all leading whitespace from the input then call
-  #! the parser on the remaining input.
+    #! the parser on the remaining input.
-  >r left-trim-slice r> sp-parser-p1 parse ;
+    >r left-trim-slice r> sp-parser-p1 parse ;
 
 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
+    #! Calls the given parser on the input removes
-  #! from the results anything where the remaining
+    #! from the results anything where the remaining
-  #! input to be parsed is not empty. So ensures a
+    #! input to be parsed is not empty. So ensures a
-  #! fully parsed input string.
+    #! fully parsed input string.
-  just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ;
+    just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ;
 
 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
+    #! Calls the parser on the input. For each successfull
-  #! parse the quot is call with the parse result on the stack.
+    #! parse the quot is call with the parse result on the stack.
-  #! The result of that quotation then becomes the new parse result.
+    #! The result of that quotation then becomes the new parse result.
-  #! This allows modification of parse tree results (like
+    #! This allows modification of parse tree results (like
-  #! converting strings to integers, etc).
+    #! converting strings to integers, etc).
-  [ apply-parser-p1 ] keep apply-parser-quot
+    [ apply-parser-p1 ] keep apply-parser-quot
-  -rot parse [
+    -rot parse [
-    [ parse-result-parsed swap call ] keep
+        [ parse-result-parsed swap call ] keep
-    parse-result-unparsed <parse-result>
+        parse-result-unparsed <parse-result>
-  ] lmap-with ;
+    ] lmap-with ;
 
 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
+    #! Calls the parser on the input, guarantees
-  #! the parse is complete (the remaining input is empty),
+    #! the parse is complete (the remaining input is empty),
-  #! picks the first solution and only returns the parse
+    #! picks the first solution and only returns the parse
-  #! tree since the remaining input is empty.
+    #! tree since the remaining input is empty.
-  some-parser-p1 just parse-1 ;
+    some-parser-p1 just parse-1 ;
-
 
 : <& ( parser1 parser2 -- parser )
-  #! Same as <&> except discard the results of the second parser.
+    #! Same as <&> except discard the results of the second parser.
-  <&> [ first ] <@ ;
+    <&> [ first ] <@ ;
 
 : &> ( parser1 parser2 -- parser )
-  #! Same as <&> except discard the results of the first parser.
+    #! Same as <&> except discard the results of the first parser.
-  <&> [ second ] <@ ;
+    <&> [ second ] <@ ;
 
 : <:&> ( parser1 parser2 -- result )
-  #! Same as <&> except flatten the result.
+    #! Same as <&> except flatten the result.
-  <&> [ dup second swap first [ % , ] { } make ] <@ ;
+    <&> [ first2 add ] <@ ;
 
 : <&:> ( parser1 parser2 -- result )
-  #! Same as <&> except flatten the 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 <|> ;
+    dup <*> <&:> { } succeed <|> ;
 
 : <+> ( parser -- parser )
-  #! Return a parser that accepts one or more occurences of the original
+    #! Return a parser that accepts one or more occurences of the original
-  #! parser.
+    #! parser.
-  dup <*> <&:> ;
+    dup <*> <&:> ;
 
 LAZY: <?> ( parser -- parser )
-  #! Return a parser that optionally uses the parser
+    #! Return a parser that optionally uses the parser
-  #! if that parser would be successfull.
+    #! if that parser would be successfull.
-  [ 1array ] <@ f succeed <|> ;
+    [ 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 )
-  #! Transform a parser into a parser that only yields
+    only-first-parser construct-boa ;
-  #! the first possibility.
+
-  only-first-parser-p1 parse 1 swap ltake ;
+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 ;
 
 LAZY: <!*> ( parser -- parser )
-  #! Like <*> but only return one possible result
+    #! Like <*> but only return one possible result
-  #! containing all matching parses. Does not return
+    #! containing all matching parses. Does not return
-  #! partial matches. Useful for efficiency since that's
+    #! partial matches. Useful for efficiency since that's
-  #! usually the effect you want and cuts down on backtracking
+    #! usually the effect you want and cuts down on backtracking
-  #! required.
+    #! required.
-  <*> only-first ;
+    <*> only-first ;
 
 LAZY: <!+> ( parser -- parser )
-  #! Like <+> but only return one possible result
+    #! Like <+> but only return one possible result
-  #! containing all matching parses. Does not return
+    #! containing all matching parses. Does not return
-  #! partial matches. Useful for efficiency since that's
+    #! partial matches. Useful for efficiency since that's
-  #! usually the effect you want and cuts down on backtracking
+    #! usually the effect you want and cuts down on backtracking
-  #! required.
+    #! required.
-  <+> only-first ;
+    <+> only-first ;
 
 LAZY: <!?> ( parser -- parser )
-  #! Like <?> but only return one possible result
+    #! Like <?> but only return one possible result
-  #! containing all matching parses. Does not return
+    #! containing all matching parses. Does not return
-  #! partial matches. Useful for efficiency since that's
+    #! partial matches. Useful for efficiency since that's
-  #! usually the effect you want and cuts down on backtracking
+    #! usually the effect you want and cuts down on backtracking
-  #! required.
+    #! required.
-  <?> only-first ;
+    <?> only-first ;
 
 LAZY: <(*)> ( parser -- parser )
     #! Like <*> but take shortest match first.
@@ -247,20 +272,37 @@ LAZY: <(+)> ( parser -- parser )
     dup <(*)> <&:> ;
 
 : pack ( close body open -- parser )
-  #! Parse a construct enclosed by two symbols,
+    #! Parse a construct enclosed by two symbols,
-  #! given a parser for the opening symbol, the
+    #! given a parser for the opening symbol, the
-  #! closing symbol, and the body.
+    #! closing symbol, and the body.
-  <& &> ;
+    <& &> ;
 
 : nonempty-list-of ( items separator -- parser )
-  [ over &> <*> <&:> ] keep <?> tuck pack ;
+    [ over &> <*> <&:> ] keep <?> tuck pack ;
 
 : list-of ( items separator -- parser )
-  #! Given a parser for the separator and for the
+    #! Given a parser for the separator and for the
-  #! items themselves, return a parser that parses
+    #! items themselves, return a parser that parses
-  #! lists of those items. The parse tree is an
+    #! lists of those items. The parse tree is an
-  #! array of the parsed items.
+    #! array of the parsed items.
-  nonempty-list-of { } succeed <|> ;
+    nonempty-list-of { } succeed <|> ;
 
 LAZY: surrounded-by ( parser start end -- parser' )
-  [ token ] 2apply swapd pack ;
+    [ token ] 2apply swapd pack ;
+
+: exactly-n ( parser n -- parser' )
+    swap <repetition> <and-parser> ;
+
+: 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 <&> ;

extra/peg/authors.txt

@@ -0,0 +1 @@
+Chris Double

extra/peg/ebnf/authors.txt

@@ -0,0 +1 @@
+Chris Double

extra/peg/ebnf/ebnf-tests.factor

@@ -0,0 +1,99 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg peg.ebnf ;
+IN: temporary
+
+{ T{ ebnf-non-terminal f "abc" } } [
+  "abc" 'non-terminal' parse parse-result-ast 
+] unit-test
+
+{ T{ ebnf-terminal f "55" } } [
+  "'55'" 'terminal' parse parse-result-ast 
+] unit-test
+
+{
+  T{ ebnf-rule f 
+     "digit"
+     V{ 
+       T{ ebnf-choice f
+          V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
+       }
+       f
+     }
+  } 
+} [
+  "digit = '1' | '2'" 'rule' parse parse-result-ast
+] unit-test
+
+{
+  T{ ebnf-rule f 
+     "digit" 
+     V{
+       T{ ebnf-sequence f
+          V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
+       }
+       f
+     }
+  }   
+} [
+  "digit = '1' '2'" 'rule' parse parse-result-ast
+] unit-test
+
+{
+  T{ ebnf-choice f
+     V{ 
+       T{ ebnf-sequence f
+          V{ T{ ebnf-non-terminal f "one" } T{ ebnf-non-terminal f "two" } }
+       }
+       T{ ebnf-non-terminal f "three" }
+     }
+  } 
+} [
+  "one two | three" 'choice' parse parse-result-ast
+] unit-test
+
+{
+  T{ ebnf-sequence f
+     V{ 
+       T{ ebnf-non-terminal f "one" }
+       T{ ebnf-choice f
+          V{ T{ ebnf-non-terminal f "two" } T{ ebnf-non-terminal f "three" } }
+       }
+     }
+  } 
+} [
+  "one (two | three)" 'choice' parse parse-result-ast
+] unit-test
+
+{
+  T{ ebnf-sequence f
+     V{ 
+       T{ ebnf-non-terminal f "one" }
+       T{ ebnf-repeat0 f
+          T{ ebnf-sequence f
+             V{
+                T{ ebnf-choice f
+                   V{ T{ ebnf-non-terminal f "two" } T{ ebnf-non-terminal f "three" } }
+                }
+                T{ ebnf-non-terminal f "four" }
+             }
+          }
+        }
+     }
+  } 
+} [
+  "one {(two | three) four}" 'choice' parse parse-result-ast
+] unit-test
+
+{
+  T{ ebnf-sequence f
+     V{ 
+         T{ ebnf-non-terminal f "one" } 
+         T{ ebnf-optional f T{ ebnf-non-terminal f "two" } }
+         T{ ebnf-non-terminal f "three" }
+     }
+  } 
+} [
+  "one [ two ] three" 'choice' parse parse-result-ast
+] unit-test

extra/peg/ebnf/ebnf.factor

@@ -0,0 +1,184 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel parser words arrays strings math.parser sequences 
+       quotations vectors namespaces math assocs continuations peg ;
+IN: peg.ebnf
+
+TUPLE: ebnf-non-terminal symbol ;
+TUPLE: ebnf-terminal symbol ;
+TUPLE: ebnf-choice options ;
+TUPLE: ebnf-sequence elements ;
+TUPLE: ebnf-repeat0 group ;
+TUPLE: ebnf-optional elements ;
+TUPLE: ebnf-rule symbol elements ;
+TUPLE: ebnf-action word ;
+TUPLE: ebnf rules ;
+
+C: <ebnf-non-terminal> ebnf-non-terminal
+C: <ebnf-terminal> ebnf-terminal
+C: <ebnf-choice> ebnf-choice
+C: <ebnf-sequence> ebnf-sequence
+C: <ebnf-repeat0> ebnf-repeat0
+C: <ebnf-optional> ebnf-optional
+C: <ebnf-rule> ebnf-rule
+C: <ebnf-action> ebnf-action
+C: <ebnf> ebnf
+
+SYMBOL: parsers
+SYMBOL: non-terminals
+SYMBOL: last-parser
+
+: reset-parser-generation ( -- ) 
+  V{ } clone parsers set 
+  H{ } clone non-terminals set 
+  f last-parser set ;
+
+: store-parser ( parser -- number )
+  parsers get [ push ] keep length 1- ;
+
+: get-parser ( index -- parser )
+  parsers get nth ;
+  
+: non-terminal-index ( name -- number )
+  dup non-terminals get at [
+    nip
+  ] [
+    f store-parser [ swap non-terminals get set-at ] keep
+  ] if* ;
+
+GENERIC: (generate-parser) ( ast -- id )
+
+: generate-parser ( ast -- id )
+  (generate-parser) dup last-parser set ;
+
+M: ebnf-terminal (generate-parser) ( ast -- id )
+  ebnf-terminal-symbol token sp store-parser ;
+
+M: ebnf-non-terminal (generate-parser) ( ast -- id )
+  [
+    ebnf-non-terminal-symbol dup non-terminal-index , 
+    parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
+  ] [ ] make delay sp store-parser ;
+
+M: ebnf-choice (generate-parser) ( ast -- id )
+  ebnf-choice-options [
+    generate-parser get-parser 
+  ] map choice store-parser ;
+
+M: ebnf-sequence (generate-parser) ( ast -- id )
+  ebnf-sequence-elements [
+    generate-parser get-parser
+  ] map seq store-parser ;
+
+M: ebnf-repeat0 (generate-parser) ( ast -- id )
+  ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
+
+M: ebnf-optional (generate-parser) ( ast -- id )
+  ebnf-optional-elements generate-parser get-parser optional store-parser ;
+
+M: ebnf-rule (generate-parser) ( ast -- id )
+  dup ebnf-rule-symbol non-terminal-index swap 
+  ebnf-rule-elements generate-parser get-parser ! nt-id body
+  swap [ parsers get set-nth ] keep ;
+
+M: ebnf-action (generate-parser) ( ast -- id )
+  ebnf-action-word search 1quotation 
+  last-parser get get-parser swap action store-parser ;
+
+M: vector (generate-parser) ( ast -- id )
+  [ generate-parser ] map peek ;
+
+M: f (generate-parser) ( ast -- id )
+  drop last-parser get ;
+
+M: ebnf (generate-parser) ( ast -- id )
+  ebnf-rules [
+    generate-parser 
+  ] map peek ;
+
+DEFER: 'rhs'
+
+: 'non-terminal' ( -- parser )
+  CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
+
+: 'terminal' ( -- parser )
+  "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
+
+: 'element' ( -- parser )
+  'non-terminal' 'terminal' 2array choice ;
+
+DEFER: 'choice'
+
+: 'group' ( -- parser )
+  "(" token sp hide
+  [ 'choice' sp ] delay
+  ")" token sp hide 
+  3array seq [ first ] action ;
+
+: 'repeat0' ( -- parser )
+  "{" token sp hide
+  [ 'choice' sp ] delay
+  "}" token sp hide 
+  3array seq [ first <ebnf-repeat0> ] action ;
+
+: 'optional' ( -- parser )
+  "[" token sp hide
+  [ 'choice' sp ] delay
+  "]" token sp hide 
+  3array seq [ first <ebnf-optional> ] action ;
+
+: 'sequence' ( -- parser )
+  [ 
+    'element' sp ,
+    'group' sp , 
+    'repeat0' sp ,
+    'optional' sp , 
+   ] { } make  choice  
+   repeat1 [ 
+     dup length 1 = [ first ] [ <ebnf-sequence> ] if
+   ] action ;  
+
+: 'choice' ( -- parser )
+  'sequence' sp "|" token sp list-of [ 
+    dup length 1 = [ first ] [ <ebnf-choice> ] if
+   ] action ;
+
+: 'action' ( -- parser )
+  "=>" token hide
+  [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
+  2array seq [ first <ebnf-action> ] action ;
+  
+: 'rhs' ( -- parser )
+  'choice' 'action' sp optional 2array seq ;
+ 
+: 'rule' ( -- parser )
+  'non-terminal' [ ebnf-non-terminal-symbol ] action 
+  "=" token sp hide 
+  'rhs' 
+  3array seq [ first2 <ebnf-rule> ] action ;
+
+: 'ebnf' ( -- parser )
+  'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
+
+: ebnf>quot ( string -- quot )
+  'ebnf' parse [
+     parse-result-ast [
+         reset-parser-generation
+         generate-parser drop
+         [
+             non-terminals get
+             [
+               get-parser [
+                 swap , \ in , \ get , \ create ,
+                 1quotation , \ define-compound , 
+               ] [
+                 drop
+               ] if*
+             ] assoc-each
+         ] [ ] make
+     ] with-scope
+   ] [
+    f
+   ] if* ;
+
+: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing

extra/peg/ebnf/summary.txt

@@ -0,0 +1 @@
+Grammar for parsing EBNF

extra/peg/peg-docs.factor

@@ -0,0 +1,150 @@
+! 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: satisfy
+{ $values 
+  { "quot" "a quotation" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that calls the quotation on the first character of the input string, "
+    "succeeding if that quotation returns true. The AST is the character from the 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" } ;
+
+HELP: sp
+{ $values 
+  { "p1" "a parser" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that calls the original parser 'p1' after stripping any whitespace "
+    " from the left of the input string." } ;
+
+HELP: hide
+{ $values 
+  { "p1" "a parser" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that succeeds if the original parser succeeds, but does not " 
+    "put any result in the AST. Useful for ignoring 'syntax' in the AST." }
+{ $example "\"[\" token hide number \"]\" token hide 3array seq" } ;
+
+HELP: delay
+{ $values 
+  { "quot" "a quotation with stack effect ( -- parser )" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Delays the construction of a parser until it is actually required to parse. This " 
+    "allows for calling a parser that results in a recursive call to itself. The quotation "
+    "should return the constructed parser." } ;

extra/peg/peg-tests.factor

@@ -0,0 +1,164 @@
+! 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
+
+{ f } [ 
+  "b" [ CHAR: a = ] satisfy parse 
+] unit-test
+
+{ CHAR: a } [ 
+  "a" [ CHAR: a = ] satisfy parse parse-result-ast
+] unit-test
+
+{ "a" } [
+  "    a" "a" token sp parse parse-result-ast
+] unit-test
+
+{ "a" } [
+  "a" "a" token sp parse parse-result-ast
+] unit-test
+
+{ V{ "a" } } [
+  "[a]" "[" token hide "a" token "]" token hide 3array seq parse parse-result-ast
+] unit-test
+
+{ f } [
+  "a]" "[" token hide "a" token "]" token hide 3array seq parse 
+] unit-test
+

extra/peg/peg.factor

@@ -0,0 +1,267 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences strings namespaces math assocs shuffle 
+       vectors arrays combinators.lib memoize ;
+IN: peg
+
+TUPLE: parse-result remaining ast ;
+
+GENERIC: (parse) ( state parser -- result )
+
+<PRIVATE
+
+SYMBOL: packrat-cache
+SYMBOL: ignore 
+SYMBOL: not-in-cache
+
+: not-in-cache? ( result -- ? )
+  not-in-cache = ;
+
+: <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 ;
+
+: from ( slice-or-string -- index )
+  dup slice? [ slice-from ] [ drop 0 ] if ;
+
+: get-cached ( input parser -- result )
+  [ from ] dip parser-id packrat-cache get at at* [ 
+    drop not-in-cache 
+  ] unless ;
+
+: put-cached ( result input parser -- )
+  parser-id dup packrat-cache get at [ 
+    nip
+  ] [ 
+    H{ } clone dup >r swap packrat-cache get set-at r>
+  ] if* 
+  [ from ] dip set-at ;
+
+PRIVATE>
+
+: parse ( input parser -- result )
+  packrat-cache get [
+    2dup get-cached dup not-in-cache? [ 
+!      "cache missed: " write over parser-id number>string write " - " write nl ! pick .
+      drop 
+      #! Protect against left recursion blowing the callstack
+      #! by storing a failed parse in the cache.
+      [ f ] dipd  [ put-cached ] 2keep
+      [ (parse) dup ] 2keep put-cached
+    ] [ 
+!      "cache hit: " write over parser-id number>string write " - " write nl ! pick . 
+      2nip
+    ] if
+  ] [
+    (parse)
+  ] if ;
+
+: packrat-parse ( input parser -- result )
+  H{ } clone packrat-cache [ parse ] with-variable ;
+
+<PRIVATE
+
+TUPLE: token-parser symbol ;
+
+M: token-parser (parse) ( input parser -- result )
+  token-parser-symbol 2dup head? [
+    dup >r length tail-slice r> <parse-result>
+  ] [
+    2drop f
+  ] if ;
+   
+TUPLE: satisfy-parser quot ;
+
+M: satisfy-parser (parse) ( state parser -- result )
+  over empty? [
+    2drop f 
+  ] [
+    satisfy-parser-quot [ unclip-slice dup ] dip call [  
+      <parse-result>
+    ] [
+      2drop f
+    ] if
+  ] 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 ;
+
+: left-trim-slice ( string -- string )
+  #! Return a new string without any leading whitespace
+  #! from the original string.
+  dup empty? [
+    dup first blank? [ 1 tail-slice left-trim-slice ] when
+  ] unless ;
+
+TUPLE: sp-parser p1 ;
+
+M: sp-parser (parse) ( state parser -- result )
+  [ left-trim-slice ] dip sp-parser-p1 parse ;
+
+TUPLE: delay-parser quot ;
+
+M: delay-parser (parse) ( state parser -- result )
+  delay-parser-quot call parse ;
+
+PRIVATE>
+
+MEMO: token ( string -- parser )
+  token-parser construct-boa init-parser ;      
+
+: satisfy ( quot -- parser )
+  satisfy-parser construct-boa init-parser ;
+
+MEMO: 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 ;
+
+MEMO: repeat0 ( parser -- parser )
+  repeat0-parser construct-boa init-parser ;
+
+MEMO: repeat1 ( parser -- parser )
+  repeat1-parser construct-boa init-parser ;
+
+MEMO: optional ( parser -- parser )
+  optional-parser construct-boa init-parser ;
+
+MEMO: ensure ( parser -- parser )
+  ensure-parser construct-boa init-parser ;
+
+MEMO: ensure-not ( parser -- parser )
+  ensure-not-parser construct-boa init-parser ;
+
+: action ( parser quot -- parser )
+  action-parser construct-boa init-parser ;
+
+MEMO: sp ( parser -- parser )
+  sp-parser construct-boa init-parser ;
+
+MEMO: hide ( parser -- parser )
+  [ drop ignore ] action ;
+
+MEMO: delay ( parser -- parser )
+  delay-parser construct-boa init-parser ;
+
+MEMO: list-of ( items separator -- parser )
+  hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ;

extra/peg/pl0/authors.txt

@@ -0,0 +1 @@
+Chris Double

extra/peg/pl0/pl0-tests.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg peg.pl0 ;
+IN: temporary
+
+{ "abc" } [
+  "abc" ident parse parse-result-ast 
+] unit-test
+
+{ 55 } [
+  "55abc" number parse parse-result-ast 
+] unit-test

extra/peg/pl0/pl0.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays strings math.parser sequences peg peg.ebnf memoize ;
+IN: peg.pl0
+
+#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
+MEMO: ident ( -- parser )
+  CHAR: a CHAR: z range 
+  CHAR: A CHAR: Z range 2array choice repeat1 
+  [ >string ] action ;
+
+MEMO: number ( -- parser )
+  CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ;
+
+<EBNF
+program = block '.' .
+block = [ 'const' ident '=' number { ',' ident '=' number } ';' ]
+        [ 'var' ident { ',' ident } ';' ]
+        { 'procedure' ident ';' [ block ';' ] } statement .
+statement = [ ident ':=' expression | 'call' ident |
+              'begin' statement {';' statement } 'end' |
+              'if' condition 'then' statement |
+              'while' condition 'do' statement ] .
+condition = 'odd' expression |
+            expression ('=' | '#' | '<=' | '<' | '>=' | '>') expression .
+expression = ['+' | '-'] term {('+' | '-') term } .
+term = factor {('*' | '/') factor } .
+factor = ident | number | '(' expression ')'
+EBNF>

extra/peg/pl0/summary.txt

@@ -0,0 +1 @@
+Grammar for PL/0 Language

extra/peg/summary.txt

@@ -0,0 +1 @@
+Parsing Expression Grammar and Packrat Parser

extra/random-tester/databank/databank.factor

@@ -0,0 +1,11 @@
+USING: kernel math.constants ;
+IN: random-tester.databank
+
+: databank ( -- array )
+    {
+        ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
+        pi 1/0. -1/0. 0/0. [ ]
+        f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
+        C{ 2 2 } C{ 1/0. 1/0. }
+    } ;
+

extra/random-tester/random-tester.factor

@@ -0,0 +1,45 @@
+USING: compiler continuations io kernel math namespaces
+prettyprint quotations random sequences vectors ;
+USING: random-tester.databank random-tester.safe-words ;
+IN: random-tester
+
+SYMBOL: errored
+SYMBOL: before
+SYMBOL: after
+SYMBOL: quot
+TUPLE: random-tester-error ;
+
+: setup-test ( #data #code -- data... quot )
+    #! Variable stack effect
+    >r [ databank random ] times r>
+    [ drop \ safe-words get random ] map >quotation ;
+
+: test-compiler ! ( data... quot -- ... )
+    errored off
+    dup quot set
+    datastack clone >vector dup pop* before set
+    [ call ] catch drop
+    datastack clone after set
+    clear
+    before get [ ] each
+    quot get [ compile-1 ] [ errored on ] recover ;
+
+: do-test ! ( data... quot -- )
+    .s flush test-compiler
+    errored get [
+        datastack after get 2dup = [
+            2drop
+        ] [
+            [ . ] each
+            "--" print
+            [ . ] each
+            quot get .
+            random-tester-error construct-empty throw
+        ] if
+    ] unless clear ;
+
+: random-test1 ( #data #code -- )
+    setup-test do-test ;
+
+: random-test2 ( -- )
+    3 2 setup-test do-test ;

extra/random-tester/random/random.factor

@@ -1,22 +1,12 @@
-USING: kernel math sequences namespaces errors hashtables words
+USING: kernel math sequences namespaces hashtables words
-arrays parser compiler syntax io tools prettyprint optimizer
+arrays parser compiler syntax io prettyprint optimizer
-inference ;
+random math.constants math.functions layouts random-tester.utils ;
 IN: random-tester
 
 ! Tweak me
 : max-length 15 ; inline
 : max-value 1000000000 ; inline
 
-: 10% ( -- bool ) 10 random 8 > ;
-: 20% ( -- bool ) 10 random 7 > ;
-: 30% ( -- bool ) 10 random 6 > ;
-: 40% ( -- bool ) 10 random 5 > ;
-: 50% ( -- bool ) 10 random 4 > ;
-: 60% ( -- bool ) 10 random 3 > ;
-: 70% ( -- bool ) 10 random 2 > ;
-: 80% ( -- bool ) 10 random 1 > ;
-: 90% ( -- bool ) 10 random 0 > ;
-
 ! varying bit-length random number
 : random-bits ( n -- int )
     random 2 swap ^ random ;
@@ -31,32 +21,29 @@ IN: random-tester
 SYMBOL: special-integers
 [ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] 
 { } make \ special-integers set-global
-: special-integers ( -- seq ) \ special-integers get ;
 SYMBOL: special-floats
 [ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
 { } make \ special-floats set-global
-: special-floats ( -- seq ) \ special-floats get ;
 SYMBOL: special-complexes
 [ 
-    { -1 0 1 i -i } %
+    { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
     e , e neg , pi , pi neg ,
     0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
     pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
     e neg e neg rect> , e e rect> ,
 ] { } make \ special-complexes set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
 
 : random-fixnum ( -- fixnum )
-    most-positive-fixnum random 1+ coin-flip [ neg 1- ] when >fixnum ;
+    most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
 
 : random-bignum ( -- bignum )
-     400 random-bits first-bignum + coin-flip [ neg ] when ;
+     400 random-bits first-bignum + 50% [ neg ] when ;
     
 : random-integer ( -- n )
-    coin-flip [
+    50% [
         random-fixnum
     ] [
-        coin-flip [ random-bignum ] [ special-integers random ] if
+        50% [ random-bignum ] [ special-integers get random ] if
     ] if ;
 
 : random-positive-integer ( -- int )
@@ -67,12 +54,12 @@ SYMBOL: special-complexes
     ] if ;
 
 : random-ratio ( -- ratio )
-    1000000000 dup [ random ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
+    1000000000 dup [ random ] 2apply 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
 
 : random-float ( -- float )
-    coin-flip [ random-ratio ] [ special-floats random ] if
+    50% [ random-ratio ] [ special-floats get random ] if
-    coin-flip 
+    50%
-    [ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if
+    [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
     >float ;
 
 : random-number ( -- number )

extra/random-tester/safe-words/safe-words.factor

@@ -0,0 +1,117 @@
+USING: kernel namespaces sequences sorting vocabs ;
+USING: arrays assocs generic hashtables  math math.intervals math.parser math.functions refs shuffle vectors words ;
+IN: random-tester.safe-words
+
+: ?-words
+    {
+        delegate
+
+        /f
+
+        bits>float bits>double
+        float>bits double>bits
+
+        >bignum >boolean >fixnum >float
+
+        array? integer? complex? value-ref? ref? key-ref?
+        interval? number?
+        wrapper? tuple?
+        [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? valid-digits? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
+        2^ not
+        ! arrays
+        resize-array <array>
+        ! assocs
+        (assoc-stack)
+        new-assoc
+        assoc-like
+        <hashtable>
+        all-integers? (all-integers?) ! hangs?
+        assoc-push-if
+
+        (clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
+    } ;
+
+: bignum-words
+    {
+        next-power-of-2 (next-power-of-2)
+        times
+        hashcode hashcode*
+    } ;
+
+: initialization-words
+    {
+        init-namespaces
+    } ;
+
+: stack-words
+    {
+        dup
+        drop 2drop 3drop
+        roll -roll 2swap
+
+        >r r>
+    } ;
+
+: method-words
+    {
+        method-def
+        forget-word
+    } ;
+
+: stateful-words
+    {
+        counter
+        gensym
+    } ;
+
+: foo-words
+    {
+        set-retainstack
+        retainstack callstack
+        datastack
+        callstack>array
+    } ;
+
+: exit-words
+    {
+        call-clear die
+    } ;
+
+: bad-words ( -- array )
+    [
+        ?-words %
+        bignum-words %
+        initialization-words %
+        stack-words %
+        method-words %
+        stateful-words %
+        exit-words %
+        foo-words %
+    ] { } make ;
+
+: safe-words ( -- array )
+    bad-words {
+        "alists" "arrays" "assocs" ! "bit-arrays" "byte-arrays"
+        ! "classes" "combinators" "compiler" "continuations"
+        ! "core-foundation" "definitions" "documents"
+        ! "float-arrays" "generic" "graphs" "growable"
+        "hashtables"  ! io.*
+        "kernel" "math" 
+        "math.bitfields" "math.complex" "math.constants" "math.floats"
+        "math.functions" "math.integers" "math.intervals" "math.libm"
+        "math.parser" "math.ratios" "math.vectors"
+        ! "namespaces" "quotations" "sbufs"
+        ! "queues" "strings" "sequences"
+        "vectors"
+        ! "words"
+    } [ words ] map concat seq-diff natural-sort ;
+    
+safe-words \ safe-words set-global
+
+! foo dup (clone) = .
+! foo dup clone = .
+! f [ byte-array>bignum assoc-clone-like ] compile-1
+! 2 3.14 [ construct-empty number= ] compile-1
+! 3.14 [ <vector> assoc? ] compile-1
+! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
+

extra/random-tester/utils/utils.factor

@@ -0,0 +1,95 @@
+USING: arrays assocs combinators.lib continuations kernel
+math math.functions namespaces quotations random sequences
+sequences.private shuffle ;
+
+IN: random-tester.utils
+
+: %chance ( n -- ? )
+    100 random > ;
+
+: 10% ( -- ? ) 10 %chance ;
+: 20% ( -- ? ) 20 %chance ;
+: 30% ( -- ? ) 30 %chance ;
+: 40% ( -- ? ) 40 %chance ;
+: 50% ( -- ? ) 50 %chance ;
+: 60% ( -- ? ) 60 %chance ;
+: 70% ( -- ? ) 70 %chance ;
+: 80% ( -- ? ) 80 %chance ;
+: 90% ( -- ? ) 90 %chance ;
+
+: call-if ( quot ? -- ) [ call ] [ drop ] if ; inline
+
+: with-10% ( quot -- ) 10% call-if ; inline
+: with-20% ( quot -- ) 20% call-if ; inline
+: with-30% ( quot -- ) 30% call-if ; inline
+: with-40% ( quot -- ) 40% call-if ; inline
+: with-50% ( quot -- ) 50% call-if ; inline
+: with-60% ( quot -- ) 60% call-if ; inline
+: with-70% ( quot -- ) 70% call-if ; inline
+: with-80% ( quot -- ) 80% call-if ; inline
+: with-90% ( quot -- ) 90% call-if ; inline
+
+: random-hash-key keys random ;
+: random-hash-value [ random-hash-key ] keep at ;
+
+: do-one ( seq -- ) random call ; inline
+
+TUPLE: p-list seq max count count-vec ;
+
+: reset-array ( seq -- )
+    [ drop 0 ] over map-into ;
+
+C: <p-list> p-list
+
+: make-p-list ( seq n -- tuple )
+    >r dup length [ 1- ] keep r>
+    [ ^ 0 swap 2array ] keep
+    0 <array> <p-list> ;
+
+: inc-seq ( seq max -- )
+    2dup [ < ] curry find-last over [
+        nipd 1+ 2over swap set-nth
+        1+ over length rot <slice> reset-array
+    ] [
+        3drop reset-array
+    ] if ;
+
+: inc-count ( tuple -- )
+    [ p-list-count first2 >r 1+ r> 2array ] keep
+    set-p-list-count ;
+
+: (get-permutation) ( seq index-seq -- newseq )
+    [ swap nth ] map-with ;
+
+: get-permutation ( tuple -- seq )
+    [ p-list-seq ] keep p-list-count-vec (get-permutation) ;
+
+: p-list-next ( tuple -- seq/f )
+    dup p-list-count first2 < [
+        [
+            [ get-permutation ] keep
+            [ p-list-count-vec ] keep p-list-max
+            inc-seq
+        ] keep inc-count
+    ] [
+        drop f
+    ] if ;
+
+: (permutations) ( tuple -- )
+    dup p-list-next [ , (permutations) ] [ drop ] if* ;
+
+: permutations ( seq n -- seq )
+    make-p-list [ (permutations) ] { } make ;
+
+: (each-permutation) ( tuple quot -- )
+    over p-list-next [
+        [ rot drop swap call ] 3keep
+        drop (each-permutation)
+    ] [
+        2drop
+    ] if* ; inline
+
+: each-permutation ( seq n quot -- )
+    >r make-p-list r> (each-permutation) ;
+
+

extra/raptor/config.factor

@@ -44,7 +44,10 @@ IN: raptor
   ! 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

extra/raptor/cronjobs.factor

@@ -6,8 +6,6 @@ IN: raptor
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
-
 : run-script ( path -- ) 1array [ fork-exec-args-wait ] curry in-thread ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

extra/raptor/raptor.factor

@@ -22,6 +22,8 @@ SYMBOL: networking-hook
 : 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 ;
@@ -59,6 +61,10 @@ SYMBOL: swap-devices
 
 : 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 ;

extra/regexp/regexp-tests.factor

@@ -0,0 +1,174 @@
+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 ] [ "\n" "." 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
+
+[ f ] [ "" "[a]" matches? ] unit-test
+[ t ] [ "a" "[a]" matches? ] unit-test
+[ t ] [ "a" "[abc]" matches? ] unit-test
+[ f ] [ "b" "[a]" matches? ] unit-test
+[ f ] [ "d" "[abc]" matches? ] unit-test
+[ t ] [ "ab" "[abc]{1,2}" matches? ] unit-test
+[ f ] [ "abc" "[abc]{1,2}" matches? ] unit-test
+
+[ f ] [ "" "[^a]" matches? ] unit-test
+[ f ] [ "a" "[^a]" matches? ] unit-test
+[ f ] [ "a" "[^abc]" matches? ] unit-test
+[ t ] [ "b" "[^a]" matches? ] unit-test
+[ t ] [ "d" "[^abc]" matches? ] unit-test
+[ f ] [ "ab" "[^abc]{1,2}" matches? ] unit-test
+[ f ] [ "abc" "[^abc]{1,2}" matches? ] unit-test
+
+[ t ] [ "]" "[]]" matches? ] unit-test
+[ f ] [ "]" "[^]]" matches? ] unit-test
+
+! [ "^" "[^]" matches? ] unit-test-fails
+[ t ] [ "^" "[]^]" matches? ] unit-test
+[ t ] [ "]" "[]^]" matches? ] unit-test
+
+[ t ] [ "[" "[[]" matches? ] unit-test
+[ f ] [ "^" "[^^]" matches? ] unit-test
+[ t ] [ "a" "[^^]" matches? ] unit-test
+
+[ t ] [ "-" "[-]" matches? ] unit-test
+[ f ] [ "a" "[-]" matches? ] unit-test
+[ f ] [ "-" "[^-]" matches? ] unit-test
+[ t ] [ "a" "[^-]" matches? ] unit-test
+
+[ t ] [ "-" "[-a]" matches? ] unit-test
+[ t ] [ "a" "[-a]" matches? ] unit-test
+[ t ] [ "-" "[a-]" matches? ] unit-test
+[ t ] [ "a" "[a-]" matches? ] unit-test
+[ f ] [ "b" "[a-]" matches? ] unit-test
+[ f ] [ "-" "[^-]" matches? ] unit-test
+[ t ] [ "a" "[^-]" matches? ] unit-test
+
+[ f ] [ "-" "[a-c]" matches? ] unit-test
+[ t ] [ "-" "[^a-c]" matches? ] unit-test
+[ t ] [ "b" "[a-c]" matches? ] unit-test
+[ f ] [ "b" "[^a-c]" matches? ] unit-test
+
+[ t ] [ "-" "[a-c-]" matches? ] unit-test
+[ f ] [ "-" "[^a-c-]" matches? ] unit-test
+
+[ t ] [ "\\" "[\\\\]" matches? ] unit-test
+[ f ] [ "a" "[\\\\]" matches? ] unit-test
+[ f ] [ "\\" "[^\\\\]" matches? ] unit-test
+[ t ] [ "a" "[^\\\\]" matches? ] unit-test
+
+[ t ] [ "0" "[\\d]" matches? ] unit-test
+[ f ] [ "a" "[\\d]" matches? ] unit-test
+[ f ] [ "0" "[^\\d]" matches? ] unit-test
+[ t ] [ "a" "[^\\d]" matches? ] unit-test
+
+[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" matches? ] unit-test
+[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" matches? ] unit-test
+[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" matches? ] unit-test
+
+[ t ] [ "1000" "\\d{4,6}" matches? ] unit-test
+[ t ] [ "1000" "[0-9]{4,6}" matches? ] unit-test
+
+[ t ] [ "abc" "\\p{Lower}{3}" matches? ] unit-test
+[ f ] [ "ABC" "\\p{Lower}{3}" matches? ] unit-test
+[ t ] [ "ABC" "\\p{Upper}{3}" matches? ] unit-test
+[ f ] [ "abc" "\\p{Upper}{3}" matches? ] unit-test
+
+[ f ] [ "abc" "[\\p{Upper}]{3}" matches? ] unit-test
+[ t ] [ "ABC" "[\\p{Upper}]{3}" matches? ] unit-test
+
+[ t ] [ "" "\\Q\\E" matches? ] unit-test
+[ f ] [ "a" "\\Q\\E" matches? ] unit-test
+[ t ] [ "|*+" "\\Q|*+\\E" matches? ] unit-test
+[ f ] [ "abc" "\\Q|*+\\E" matches? ] unit-test
+
+[ t ] [ "S" "\\0123" matches? ] unit-test
+[ t ] [ "SXY" "\\0123XY" matches? ] unit-test
+[ t ] [ "x" "\\x78" matches? ] unit-test
+[ f ] [ "y" "\\x78" matches? ] unit-test
+[ t ] [ "x" "\\u0078" matches? ] unit-test
+[ f ] [ "y" "\\u0078" matches? ] unit-test
+
+[ t ] [ "ab" "a+b" matches? ] unit-test
+[ f ] [ "b" "a+b" matches? ] unit-test
+[ t ] [ "aab" "a+b" matches? ] unit-test
+[ f ] [ "abb" "a+b" matches? ] unit-test
+
+[ t ] [ "abbbb" "ab*" matches? ] unit-test
+[ t ] [ "a" "ab*" matches? ] unit-test
+[ f ] [ "abab" "ab*" matches? ] unit-test
+
+[ f ] [ "x" "\\." matches? ] unit-test
+[ t ] [ "." "\\." matches? ] unit-test

extra/regexp/regexp.factor

@@ -0,0 +1,243 @@
+USING: arrays combinators kernel lazy-lists math math.parser
+namespaces parser parser-combinators parser-combinators.simple
+promises quotations sequences combinators.lib strings macros
+assocs prettyprint.backend ;
+USE: io
+IN: regexp
+
+: or-predicates ( quots -- quot )
+    [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
+
+MACRO: fast-member? ( str -- quot )
+    [ dup ] H{ } map>assoc [ key? ] curry ;
+
+: octal-digit? ( n -- ? )
+    CHAR: 0 CHAR: 7 between? ;
+
+: decimal-digit? ( n -- ? )
+    CHAR: 0 CHAR: 9 between? ;
+
+: hex-digit? ( n -- ? )
+    dup decimal-digit?
+    swap CHAR: a CHAR: f between? or ;
+
+: control-char? ( n -- ? )
+    dup 0 HEX: 1f between?
+    swap HEX: 7f = or ;
+
+: punct? ( n -- ? )
+    "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" fast-member? ;
+
+: c-identifier-char? ( ch -- ? )
+    dup alpha? swap CHAR: _ = or ;
+
+: java-blank? ( n -- ? )
+    {
+        CHAR: \t CHAR: \n CHAR: \r
+        HEX: c HEX: 7 HEX: 1b
+    } fast-member? ;
+
+: java-printable? ( n -- ? )
+    dup alpha? swap punct? or ;
+
+: 'ordinary-char' ( -- parser )
+    [ "\\^*+?|(){}[$" fast-member? not ] satisfy
+    [ [ = ] curry ] <@ ;
+
+: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
+
+: 'octal' ( -- parser )
+    "0" token 'octal-digit' 1 3 from-m-to-n &>
+    [ oct> ] <@ ;
+
+: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
+
+: 'hex' ( -- parser )
+    "x" token 'hex-digit' 2 exactly-n &>
+    "u" token 'hex-digit' 4 exactly-n &> <|>
+    [ hex> ] <@ ;
+
+: satisfy-tokens ( assoc -- parser )
+    [ >r token r> [ nip ] curry <@ ] { } assoc>map <or-parser> ;
+
+: 'simple-escape-char' ( -- parser )
+    {
+        { "\\" CHAR: \\ }
+        { "t"  CHAR: \t }
+        { "n"  CHAR: \n }
+        { "r"  CHAR: \r }
+        { "f"  HEX: c   }
+        { "a"  HEX: 7   }
+        { "e"  HEX: 1b  }
+    } [ [ = ] curry ] assoc-map satisfy-tokens ;
+
+: 'predefined-char-class' ( -- parser )
+    {
+        { "d" [ digit? ] }
+        { "D" [ digit? not ] }
+        { "s" [ java-blank? ] }
+        { "S" [ java-blank? not ] }
+        { "w" [ c-identifier-char? ] }
+        { "W" [ c-identifier-char? not ] }
+    } satisfy-tokens ;
+
+: 'posix-character-class' ( -- parser )
+    {
+        { "Lower" [ letter? ] }
+        { "Upper" [ LETTER? ] }
+        { "ASCII" [ 0 HEX: 7f between? ] }
+        { "Alpha" [ Letter? ] }
+        { "Digit" [ digit? ] }
+        { "Alnum" [ alpha? ] }
+        { "Punct" [ punct? ] }
+        { "Graph" [ java-printable? ] }
+        { "Print" [ java-printable? ] }
+        { "Blank" [ " \t" member? ] }
+        { "Cntrl" [ control-char? ] }
+        { "XDigit" [ hex-digit? ] }
+        { "Space" [ java-blank? ] }
+    } satisfy-tokens "p{" "}" surrounded-by ;
+
+: 'simple-escape' ( -- parser )
+    'octal'
+    'hex' <|>
+    "c" token [ LETTER? ] satisfy &> <|>
+    any-char-parser <|>
+    [ [ = ] curry ] <@ ;
+
+: 'escape' ( -- parser )
+    "\\" token
+    'simple-escape-char'
+    'predefined-char-class' <|>
+    'posix-character-class' <|>
+    'simple-escape' <|> &> ;
+
+: 'any-char'
+    "." token [ drop [ drop t ] ] <@ ;
+
+: 'char'
+    'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
+
+DEFER: 'regexp'
+
+TUPLE: group-result str ;
+
+C: <group-result> group-result
+
+: 'grouping'
+    'regexp' [ [ <group-result> ] <@ ] <@
+    "(" ")" surrounded-by ;
+
+: 'range' ( -- parser )
+    any-char-parser "-" token <& any-char-parser <&>
+    [ first2 [ between? ] 2curry ] <@ ;
+
+: 'character-class-term' ( -- parser )
+    'range'
+    'escape' <|>
+    [ "\\]" member? not ] satisfy [ [ = ] curry ] <@ <|> ;
+
+: 'positive-character-class' ( -- parser )
+    "]" token [ drop [ CHAR: ] = ] ] <@ 'character-class-term' <*> <&:>
+    'character-class-term' <+> <|>
+    [ or-predicates ] <@ ;
+
+: 'negative-character-class' ( -- parser )
+    "^" token 'positive-character-class' &>
+    [ [ not ] append ] <@ ;
+
+: 'character-class' ( -- parser )
+    'negative-character-class' 'positive-character-class' <|>
+    "[" "]" surrounded-by [ satisfy ] <@ ;
+
+: 'escaped-seq' ( -- parser )
+    any-char-parser <*> [ token ] <@ "\\Q" "\\E" surrounded-by ;
+
+: 'simple' ( -- parser )
+    'escaped-seq'
+    'grouping' <|>
+    'char' <|>
+    'character-class' <|> ;
+
+: 'greedy-interval' ( -- parser )
+    'simple' 'integer' "{" "}" surrounded-by <&> [ first2 exactly-n ] <@
+    'simple' 'integer' "{" ",}" surrounded-by <&> [ first2 at-least-n ] <@ <|>
+    'simple' 'integer' "{," "}" surrounded-by <&> [ first2 at-most-n ] <@ <|>
+    'simple' 'integer' "," token <& 'integer' <&> "{" "}" surrounded-by <&> [ first2 first2 from-m-to-n ] <@ <|> ;
+
+: 'interval' ( -- parser )
+    'greedy-interval'
+    'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|>
+    'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|> ;
+
+: 'greedy-repetition' ( -- parser )
+    'simple' "*" token <& [ <*> ] <@
+    'simple' "+" token <& [ <+> ] <@ <|>
+    'simple' "?" token <& [ <?> ] <@ <|> ;
+
+: 'repetition' ( -- parser )
+    'greedy-repetition'
+    'greedy-repetition' "?" token <& [ "reluctant" print ] <@ <|>
+    'greedy-repetition' "+" token <& [ "possessive" print ] <@ <|> ;
+
+: 'term' ( -- parser )
+    'simple' 'repetition' 'interval' <|> <|>
+    <+> [ <and-parser> ] <@ ;
+
+LAZY: 'regexp' ( -- parser )
+    'term' "|" token nonempty-list-of [ <or-parser> ] <@
+    "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
+        &> [ "caret" print ] <@ <|>
+    'term' "|" token nonempty-list-of [ <or-parser> ] <@
+        "$" token <& [ "dollar" print ] <@ <|>
+    "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
+        "$" token [ "caret dollar" print ] <@ <& <|> ;
+
+TUPLE: regexp source parser ;
+
+: <regexp> dup 'regexp' just parse-1 regexp construct-boa ;
+
+GENERIC: >regexp ( obj -- parser )
+
+M: string >regexp <regexp> ;
+
+M: object >regexp ;
+
+: matches? ( string regexp -- ? )
+    >regexp regexp-parser just parse nil? not ;
+
+! Literal syntax for regexps
+: 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
+: 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
+: R| CHAR: | parse-regexp ; parsing
+
+: find-regexp-syntax ( string -- prefix suffix )
+    {
+        { "R/ "  "/"  }
+        { "R! "  "!"  }
+        { "R\" " "\"" }
+        { "R# "  "#"  }
+        { "R' "  "'"  }
+        { "R( "  ")"  }
+        { "R@ "  "@"  }
+        { "R[ "  "]"  }
+        { "R` "  "`"  }
+        { "R{ "  "}"  }
+        { "R| "  "|"  }
+    } swap [ subseq? not nip ] curry assoc-find drop ;
+
+M: regexp pprint*
+    dup regexp-source dup find-regexp-syntax pprint-string ;

extra/rss/rss-tests.factor

@@ -1,5 +1,9 @@
-USING: rss io.files tools.test ;
+USING: rss io kernel io.files tools.test ;
-IN: temporary
+
+: load-news-file ( filename -- feed )
+    #! Load an news syndication file and process it, returning
+    #! it as an feed tuple.
+    <file-reader> read-feed ;
 
 [ T{
     feed
@@ -34,4 +38,3 @@ IN: temporary
         }
     }
 } ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test
-[ " &amp; &amp; hi" ] [ " & &amp; hi" &>&amp; ] unit-test

extra/rss/rss.factor

@@ -1,24 +1,14 @@
-! Copyright (C) 2006 Chris Double.
+! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: rss
-! USING: kernel http-client xml xml-utils xml-data errors io strings
+USING: xml.utilities kernel assocs
-!    sequences xml-writer parser-combinators lazy-lists entities ;
+    strings sequences xml.data xml.writer
-USING: xml.utilities kernel promises parser-combinators assocs
-    parser-combinators.replace strings sequences xml.data xml.writer
     io.streams.string combinators xml xml.entities io.files io
-    http.client ;
+    http.client namespaces xml.generator hashtables ;
 
 : ?children>string ( tag/f -- string/f )
     [ children>string ] [ f ] if* ;
 
-LAZY: '&' ( -- parser )
-    "&" token
-    [ blank? ] satisfy &>
-    [ "&amp;" swap add ] <@ ;
-
-: &>&amp; ( string -- string )
-    '&amp;' replace ;
-
 TUPLE: feed title link entries ;
 
 C: <feed> feed
@@ -72,26 +62,42 @@ C: <entry> entry
         children>string <entry>
     ] map <feed> ;
 
-: feed ( xml -- feed )
+: xml>feed ( xml -- feed )
     dup name-tag {
         { "RDF" [ rss1.0 ] }
         { "rss" [ rss2.0 ] }
         { "feed" [ atom1.0 ] }
     } case ;
 
-: read-feed ( string -- feed )
+: read-feed ( stream -- feed )
-    ! &>&amp; ! this will be uncommented when parser-combinators are fixed
+    [ read-xml ] with-html-entities xml>feed ;
-    [ string>xml ] with-html-entities feed ;
 
-: load-news-file ( filename -- feed )
+: download-feed ( url -- feed )
-    #! Load an news syndication file and process it, returning
-    #! it as an feed tuple.
-    <file-reader> [ contents read-feed ] keep stream-close ;
-
-: news-get ( url -- feed )
     #! Retrieve an news syndication file, return as a feed tuple.
     http-get rot 200 = [
         nip read-feed
     ] [
         2drop "Error retrieving newsfeed file" throw
     ] if ;
+
+! Atom generation
+: simple-tag, ( content name -- )
+    [ , ] tag, ;
+
+: entry, ( entry -- )
+    "entry" [
+        dup entry-title "title" simple-tag,
+        "link" over entry-link "href" associate contained*,
+        dup entry-pub-date "published" simple-tag,
+        entry-description "content" simple-tag,
+    ] tag, ;
+
+: feed>xml ( feed -- xml )
+    "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
+        dup feed-title "title" simple-tag,
+        "link" over feed-link "href" associate contained*,
+        feed-entries [ entry, ] each
+    ] make-xml* ;
+
+: write-feed ( feed -- )
+    feed>xml write-xml ;

extra/sequences/lib/lib-tests.factor

@@ -39,3 +39,6 @@ math.functions tools.test ;
 
 [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
 [ V{ } [ delete-random drop ] keep length ] unit-test-fails
+
+[ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test
+[ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test

extra/sequences/lib/lib.factor

@@ -62,3 +62,15 @@ IN: sequences.lib
 
 : delete-random ( seq -- value )
     [ length random ] keep [ nth ] 2keep delete-nth ;
+
+: (map-until) ( quot pred -- quot )
+    [ dup ] swap 3compose
+    [ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
+
+: map-until ( seq quot pred -- newseq )
+    (map-until) { } make ;
+
+: take-while ( seq quot -- newseq )
+    [ not ] compose
+    [ find drop [ head-slice ] when* ] curry
+    [ dup ] swap compose keep like ;

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/browser/browser-docs.factor

@@ -1,6 +1,10 @@
 USING: help.markup help.syntax io strings ;
 IN: tools.browser
 
+ARTICLE: "vocab-index" "Vocabulary index"
+{ $tags,authors }
+{ $describe-vocab "" } ;
+
 ARTICLE: "tools.browser" "Vocabulary browser"
 "Getting and setting vocabulary meta-data:"
 { $subsection vocab-summary }

extra/tools/browser/browser.factor

@@ -303,10 +303,6 @@ C: <vocab-author> vocab-author
     "Authors" $heading
     all-authors authors. ;
 
-ARTICLE: "vocab-index" "Vocabulary index"
-{ $tags,authors }
-{ $describe-vocab "" } ;
-
 M: vocab-spec article-title vocab-name " vocabulary" append ;
 
 M: vocab-spec article-name vocab-name ;

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

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/tools/debugger/debugger.factor

@@ -52,7 +52,7 @@ debugger "gestures" f {
 
 \ :help H{ { +nullary+ t } { +listener+ t } } define-command
 
-\ :edit H{ { +nullary+ t } } define-command
+\ :edit H{ { +nullary+ t } { +listener+ t } } define-command
 
 debugger "toolbar" f {
     { T{ key-down f f "s" } com-traceback }

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/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
@@ -114,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 ;

extra/ui/windows/windows.factor

@@ -257,14 +257,12 @@ M: windows-ui-backend (close-window)
 : prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
     nip >r mouse-event>gesture r> >lo-hi rot window ;
 
-: mouse-captured? ( -- ? )
-    mouse-captured get ;
-
 : set-capture ( hwnd -- )
     mouse-captured get [
         drop
     ] [
-        [ SetCapture drop ] keep mouse-captured set
+        [ SetCapture drop ] keep
+        mouse-captured set
     ] if ;
 
 : release-capture ( -- )
@@ -276,7 +274,7 @@ M: windows-ui-backend (close-window)
     prepare-mouse send-button-down ;
 
 : handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
-    mouse-captured? [ release-capture ] when
+    mouse-captured get [ release-capture ] when
     prepare-mouse send-button-up ;
 
 : make-TRACKMOUSEEVENT ( hWnd -- alien )
@@ -434,7 +432,7 @@ M: windows-ui-backend flush-gl-context ( handle -- )
 ! Move window to front
 M: windows-ui-backend raise-window ( world -- )
     world-handle [
-        win-hWnd SetFocus drop release-capture
+        win-hWnd SetFocus drop
     ] when* ;
 
 M: windows-ui-backend set-title ( string world -- )

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 ;