Merge branch 'master' of git://factorcode.org/git/factor

basis/bootstrap/image/image.factor

@@ -515,7 +515,7 @@ M: quotation '
     20000 <hashtable> objects set
     emit-header t, 0, 1, -1,
     "Building generic words..." print flush
-    call-remake-generics-hook
+    remake-generics
     "Serializing words..." print flush
     emit-words
     "Serializing JIT data..." print flush

basis/call/authors.txt

@@ -0,0 +1,2 @@
+Daniel Ehrenberg
+Slava Pestov

basis/call/tags.txt

@@ -0,0 +1 @@
+extensions

basis/compiler/compiler-docs.factor

@@ -12,8 +12,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
 "Normally, new word definitions are recompiled automatically. This can be changed:"
 { $subsection disable-compiler }
 { $subsection enable-compiler }
-"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
-{ $subsection optimized-recompile-hook }
 "Removing a word's optimized definition:"
 { $subsection decompile }
 "Compiling a single quotation:"
@@ -46,9 +44,8 @@ HELP: (compile)
 { $description "Compile a single word." }
 { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
 
-HELP: optimized-recompile-hook
+HELP: optimizing-compiler
-{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
+{ $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." }
-{ $description "Compile a set of words." }
 { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
 
 HELP: compile-call

basis/compiler/compiler.factor

@@ -111,7 +111,7 @@ t compile-dependencies? set-global
     ] with-return ;
 
 : compile-loop ( deque -- )
-    [ (compile) yield-hook get call ] slurp-deque ;
+    [ (compile) yield-hook get assert-depth ] slurp-deque ;
 
 : decompile ( word -- )
     f 2array 1array modify-code-heap ;
@@ -119,7 +119,9 @@ t compile-dependencies? set-global
 : compile-call ( quot -- )
     [ dup infer define-temp ] with-compilation-unit execute ;
 
-: optimized-recompile-hook ( words -- alist )
+SINGLETON: optimizing-compiler
+
+M: optimizing-compiler recompile ( words -- alist )
     [
         <hashed-dlist> compile-queue set
         H{ } clone compiled set
@@ -129,10 +131,10 @@ t compile-dependencies? set-global
     ] with-scope ;
 
 : enable-compiler ( -- )
-    [ optimized-recompile-hook ] recompile-hook set-global ;
+    optimizing-compiler compiler-impl set-global ;
 
 : disable-compiler ( -- )
-    [ default-recompile-hook ] recompile-hook set-global ;
+    f compiler-impl set-global ;
 
 : recompile-all ( -- )
     forget-errors all-words compile ;

basis/cpu/x86/32/32.factor

@@ -309,8 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
     check_sse2 ;
 
 "-no-sse2" (command-line) member? [
-    [ optimized-recompile-hook ] recompile-hook
+    optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
-    [ { check_sse2 } compile ] with-variable
 
     "Checking if your CPU supports SSE2..." print flush
     sse2? [

basis/globs/authors.txt

@@ -1 +1,2 @@
 Slava Pestov
+Daniel Ehrenberg

basis/images/bitmap/bitmap-tests.factor

@@ -1,18 +1,15 @@
 USING: images.bitmap images.viewer io.encodings.binary
-io.files io.files.unique kernel tools.test images.loader ;
+io.files io.files.unique kernel tools.test images.loader
+literals sequences ;
 IN: images.bitmap.tests
 
-: test-bitmap24 ( -- path )
+CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
-    "vocab:images/test-images/thiswayup24.bmp" ;
 
-: test-bitmap8 ( -- path )
+CONSTANT: test-bitmap8 "vocab:images/test-images/rgb8bit.bmp"
-    "vocab:images/test-images/rgb8bit.bmp" ;
 
-: test-bitmap4 ( -- path )
+CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp"
-    "vocab:images/test-images/rgb4bit.bmp" ;
 
-: test-bitmap1 ( -- path )
+CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
-    "vocab:images/test-images/1bit.bmp" ;
 
 [ t ]
 [
@@ -22,3 +19,9 @@ IN: images.bitmap.tests
     "test-bitmap24" unique-file
     [ save-bitmap ] [ binary file-contents ] bi =
 ] unit-test
+
+{
+    $ test-bitmap8
+    $ test-bitmap24
+    "vocab:ui/render/test/reference.bmp"
+} [ [ ] swap [ load-image drop ] curry unit-test ] each

basis/regexp/combinators/combinators-docs.factor

@@ -5,16 +5,32 @@ IN: regexp.combinators
 
 ABOUT: "regexp.combinators"
 
+ARTICLE: "regexp.combinators.intro" "Regular expression combinator rationale"
+"Regular expression combinators are useful when part of the regular expression contains user input. For example, given a sequence of strings on the stack, a regular expression which matches any one of them can be constructed:"
+{ $code
+  "[ <literal> ] map <or>"
+}
+"Without combinators, a naive approach would look as follows:"
+{ $code
+  "\"|\" join <regexp>"
+}
+"However, this code is incorrect, because one of the strings in the sequence might contain characters which have special meaning inside a regular expression. Combinators avoid this problem by building a regular expression syntax tree directly, without any parsing." ;
+
 ARTICLE: "regexp.combinators" "Regular expression combinators"
-"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This is in addition to the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
+"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This complements the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
+{ $subsection "regexp.combinators.intro" }
+"Basic combinators:"
 { $subsection <literal> }
 { $subsection <nothing> }
+"Higher-order combinators for building new regular expressions from existing ones:"
 { $subsection <or> }
 { $subsection <and> }
 { $subsection <not> }
 { $subsection <sequence> }
 { $subsection <zero-or-more> }
+"Derived combinators implemented in terms of the above:"
 { $subsection <one-or-more> }
+"Setting options:"
 { $subsection <option> } ;
 
 HELP: <literal>

basis/regexp/compiler/compiler.factor

@@ -3,7 +3,7 @@
 USING: regexp.classes kernel sequences regexp.negation
 quotations assocs fry math locals combinators
 accessors words compiler.units kernel.private strings
-sequences.private arrays call namespaces unicode.breaks
+sequences.private arrays namespaces unicode.breaks
 regexp.transition-tables combinators.short-circuit ;
 IN: regexp.compiler
 
@@ -104,15 +104,13 @@ C: <box> box
     transitions>quot ;
 
 : states>code ( words dfa -- )
-    [ ! with-compilation-unit doesn't compile, so we need call( -- )
+    [
-        [
+        '[
-            '[
+            dup _ word>quot
-                dup _ word>quot
+            (( last-match index string -- ? ))
-                (( last-match index string -- ? ))
+            define-declared
-                define-declared
+        ] each
-            ] each
+    ] with-compilation-unit ;
-        ] with-compilation-unit
-    ] call( words dfa -- ) ;
 
 : states>words ( dfa -- words dfa )
     dup transitions>> keys [ gensym ] H{ } map>assoc
@@ -126,7 +124,7 @@ C: <box> box
 PRIVATE>
 
 : simple-define-temp ( quot effect -- word )
-    [ [ define-temp ] with-compilation-unit ] call( quot effect -- word ) ;
+    [ define-temp ] with-compilation-unit ;
 
 : dfa>word ( dfa -- quot )
     dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]

basis/regexp/nfa/nfa.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs grouping kernel
+USING: accessors arrays assocs grouping kernel locals math namespaces
-locals math namespaces sequences fry quotations
+sequences fry quotations math.order math.ranges vectors
-math.order math.ranges vectors unicode.categories
+unicode.categories regexp.transition-tables words sets hashtables
-regexp.transition-tables words sets hashtables combinators.short-circuit
+combinators.short-circuit unicode.case unicode.case.private regexp.ast
-unicode.case.private regexp.ast regexp.classes ;
+regexp.classes ;
 IN: regexp.nfa
 
 ! This uses unicode.case.private for ch>upper and ch>lower

basis/regexp/regexp-docs.factor

@@ -1,34 +1,70 @@
 ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings help.markup help.syntax math ;
+USING: kernel strings help.markup help.syntax math regexp.parser regexp.ast ;
 IN: regexp
 
 ABOUT: "regexp"
 
 ARTICLE: "regexp" "Regular expressions"
 "The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions."
-{ $subsection { "regexp" "syntax" } }
+{ $subsection { "regexp" "intro" } }
-{ $subsection { "regexp" "construction" } }
+"The class of regular expressions:"
-{ $vocab-subsection "regexp.combinators" "Regular expression combinators" }
-{ $subsection { "regexp" "operations" } }
 { $subsection regexp }
-{ $subsection { "regexp" "theory" } } ;
+"Basic usage:"
+{ $subsection { "regexp" "syntax" } }
+{ $subsection { "regexp" "options" } }
+{ $subsection { "regexp" "construction" } }
+{ $subsection { "regexp" "operations" } }
+"Advanced topics:"
+{ $vocab-subsection "Regular expression combinators" "regexp.combinators" }
+{ $subsection { "regexp" "theory" } }
+{ $subsection { "regexp" "deploy" } } ;
+
+ARTICLE: { "regexp" "intro" } "A quick introduction to regular expressions"
+
+;
 
 ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
-"Words which are useful for creating regular expressions:"
+"Most of the time, regular expressions are literals and the parsing word should be used, to construct them at parse time. This ensures that they are only compiled once, and gives parse time syntax checking."
 { $subsection POSTPONE: R/ }
+"Sometimes, regular expressions need to be constructed at run time instead; for example, in a text editor, the user might input a regular expression to search for in a document."
 { $subsection <regexp> } 
 { $subsection <optioned-regexp> }
-{ $heading "See also" }
+"Another approach is to use " { $vocab-link "regexp.combinators" } "." ;
-{ $vocab-link "regexp.combinators" } ;
 
 ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
-"Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely." $nl
+"Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely. A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "."
-"A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "." $nl
+{ $heading "Characters" }
+{ $heading "Character classes" }
+{ $heading "Predefined character classes" }
+{ $heading "Boundaries" }
+{ $heading "Greedy quantifiers" }
+{ $heading "Reluctant quantifiers" }
+{ $heading "Posessive quantifiers" }
+{ $heading "Logical operations" }
+{ $heading "Lookaround" }
+{ $heading "Unsupported features" }
 "One missing feature is backreferences. This is because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } ". You can create a new regular expression to match a particular string using " { $vocab-link "regexp.combinators" } " and group capture is available to extract parts of a regular expression match." $nl
-"A distinction from Perl is that " { $snippet "\\G" } ", which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl
+"Another feature is Perl's " { $snippet "\\G" } " syntax, which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl
 "Additionally, none of the operations which embed code into a regexp are supported, as this would require the inclusion of the Factor parser and compiler in any application which wants to expose regexps to the user. None of the casing operations are included, for simplicity." ; ! Also describe syntax, from the beginning
 
+ARTICLE: { "regexp" "options" } "Regular expression options"
+"When " { $link { "regexp" "construction" } } ", various options can be provided. Options have single-character names. A string of options has one of the following two forms:"
+{ $code "on" "on-off" }
+"The latter syntax allows some options to be disabled. The " { $snippet "on" } " and " { $snippet "off" } " strings name options to be enabled and disabled, respectively."
+$nl
+"The following options are supported:"
+{ $table
+  { "i" { $link case-insensitive } }
+  { "d" { $link unix-lines } }
+  { "m" { $link multiline } }
+  { "n" { $link multiline } }
+  { "r" { $link reversed-regexp } }
+  { "s" { $link dotall } }
+  { "u" { $link unicode-case } }
+  { "x" { $link comments } }
+} ;
+
 ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
 "Far from being just a practical tool invented by Unix hackers, regular expressions were studied formally before computer programs were written to process them." $nl
 "A regular language is a set of strings that is matched by a regular expression, which is defined to have characters and the empty string, along with the operations concatenation, disjunction and Kleene star. Another way to define the class of regular languages is as the class of languages which can be recognized with constant space overhead, ie with a DFA. These two definitions are provably equivalent." $nl
@@ -39,26 +75,41 @@ ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
 "The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex also use this algorithm, but in the Factor regular expression engine, all other features of regexps are still present." ;
 
 ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions"
+"Testing if a string matches a regular expression:"
 { $subsection matches? }
+"Finding a match inside a string:"
 { $subsection re-contains? }
 { $subsection first-match }
+"Finding all matches inside a string:"
+{ $subsection count-matches }
 { $subsection all-matching-slices }
 { $subsection all-matching-subseqs }
+"Splitting a string into tokens delimited by a regular expression:"
 { $subsection re-split }
-{ $subsection re-replace }
+"Replacing occurrences of a regular expression with a string:"
-{ $subsection count-matches } ;
+{ $subsection re-replace } ;
+
+ARTICLE: { "regexp" "deploy" } "Regular expressions and the deploy tool"
+"The " { $link "tools.deploy" } " tool has the option to strip out the optimizing compiler from the resulting image. Since regular expressions compile to Factor code, this creates a minor performance-related caveat."
+$nl
+"Regular expressions constructed at runtime from a deployed application will be compiled with the non-optimizing compiler, which is always available because it is built into the Factor VM. This will result in lower performance than when using the optimizing compiler."
+$nl
+"Literal regular expressions constructed at parse time do not suffer from this restriction, since the deployed application is loaded and compiled before anything is stripped out."
+$nl
+"None of this applies to deployed applications which include the optimizing compiler, or code running inside a development image."
+{ $see-also "compiler" { "regexp" "construction" } "deploy-flags" } ;
 
 HELP: <regexp>
 { $values { "string" string } { "regexp" regexp } }
 { $description "Creates a regular expression object, given a string in regular expression syntax. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
 
 HELP: <optioned-regexp>
-{ $values { "string" string } { "options" string } { "regexp" regexp } }
+{ $values { "string" string } { "options" "a string of " { $link { "regexp" "options" } } } { "regexp" regexp } }
 { $description "Given a string in regular expression syntax, and a string of options, creates a regular expression object. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
 
 HELP: R/
-{ $syntax "R/ foo.*|[a-zA-Z]bar/i" }
+{ $syntax "R/ foo.*|[a-zA-Z]bar/options" }
-{ $description "Literal syntax for a regular expression. When this syntax is used, the DFA is compiled at compile-time, rather than on first use." } ;
+{ $description "Literal syntax for a regular expression. When this syntax is used, the DFA is compiled at compile-time, rather than on first use. The syntax for the " { $snippet "options" } " string is documented in " { $link { "regexp" "options" } } "." } ;
 
 HELP: regexp
 { $class-description "The class of regular expressions. To construct these, see " { $link { "regexp" "construction" } } "." } ;

basis/tools/deploy/deploy-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax words alien.c-types assocs
-kernel ;
+kernel call call.private tools.deploy.config ;
 IN: tools.deploy
 
 ARTICLE: "prepare-deploy" "Preparing to deploy an application"
@@ -7,25 +7,43 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application"
 { $subsection "deploy-config" }
 { $subsection "deploy-flags" } ;
 
-ARTICLE: "tools.deploy" "Application deployment"
+ARTICLE: "tools.deploy.usage" "Deploy tool usage"
-"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
+"Once the necessary deployment flags have been set, the application can be deployed:"
-$nl
+{ $subsection deploy }
-"For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
+"For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:"
 { $code "\"hello-ui\" deploy" }
 { $list
    { "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
    { "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
    { "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
 }
-"In all cases, running the program displays a window with a message."
+"On all platforms, running the program will display a window with a message." ;
-$nl
+
+ARTICLE: "tools.deploy.impl" "Deploy tool implementation"
 "The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
 $nl
+"The deploy tool generates " { $emphasis "staging images" } " containing major subsystems, and uses the staging images to derive the final application image. The first time an application is deployed using a major subsystem, such as the UI, a new staging image is made, which can take a few minutes. Subsequent deployments of applications using this subsystem will be much faster." ;
+
+ARTICLE: "tools.deploy.caveats" "Deploy tool caveats"
+{ $heading "Behavior of " { $link boa } }
+"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
+{ $heading "Behavior of " { $link POSTPONE: execute( } }
+"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-unsafe( } "."
+{ $heading "Error reporting" }
+"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
+{ $heading "Choosing the right deploy flags" }
+"Finding the correct deploy flags is a trial and error process; you must find a tradeoff between deployed image size and correctness. If your program uses dynamic language features, you may need to elect to strip out fewer subsystems in order to have full functionality." ;
+
+ARTICLE: "tools.deploy" "Application deployment"
+"The stand-alone application deployment tool, implemented in the " { $vocab-link "tools.deploy" } " vocablary, compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
+$nl
+"Most of the time, the words in the " { $vocab-link "tools.deploy" } " vocabulary should not be used directly; instead, use " { $link "ui.tools.deploy" } "."
+$nl
 "You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment."
 { $subsection "prepare-deploy" }
-"Once the necessary deployment flags have been set, the application can be deployed:"
+{ $subsection "tools.deploy.usage" }
-{ $subsection deploy }
+{ $subsection "tools.deploy.impl" }
-{ $see-also "ui.tools.deploy" } ;
+{ $subsection "tools.deploy.caveats" } ;
 
 ABOUT: "tools.deploy"
 

basis/tools/deploy/deploy-tests.factor

@@ -80,32 +80,17 @@ M: quit-responder call-responder*
 
 [ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
 
-[ ] [
+{
-    "tools.deploy.test.6" shake-and-bake
+    "tools.deploy.test.6"
-    run-temp-image
+    "tools.deploy.test.7"
-] unit-test
+    "tools.deploy.test.8"
-
+    "tools.deploy.test.9"
-[ ] [
+    "tools.deploy.test.10"
-    "tools.deploy.test.7" shake-and-bake
+    "tools.deploy.test.11"
-    run-temp-image
+    "tools.deploy.test.12"
-] unit-test
+} [
-
+    [ ] swap [
-[ ] [
+        shake-and-bake
-    "tools.deploy.test.8" shake-and-bake
+        run-temp-image
-    run-temp-image
+    ] curry unit-test
-] unit-test
+] each
-
-[ ] [
-    "tools.deploy.test.9" shake-and-bake
-    run-temp-image
-] unit-test
-
-[ ] [
-    "tools.deploy.test.10" shake-and-bake
-    run-temp-image
-] unit-test
-
-[ ] [
-    "tools.deploy.test.11" shake-and-bake
-    run-temp-image
-] unit-test

basis/tools/deploy/shaker/shaker.factor

@@ -53,6 +53,13 @@ IN: tools.deploy.shaker
         run-file
     ] when ;
 
+: strip-call ( -- )
+    "call" vocab [
+        "Stripping stack effect checking from call( and execute(" show
+        "vocab:tools/deploy/shaker/strip-call.factor"
+        run-file
+    ] when ;
+
 : strip-cocoa ( -- )
     "cocoa" vocab [
         "Stripping unused Cocoa methods" show
@@ -256,9 +263,7 @@ IN: tools.deploy.shaker
                 command-line:main-vocab-hook
                 compiled-crossref
                 compiled-generic-crossref
-                recompile-hook
+                compiler-impl
-                update-tuples-hook
-                remake-generics-hook
                 definition-observers
                 definitions:crossref
                 interactive-vocabs
@@ -399,6 +404,7 @@ SYMBOL: deploy-vocab
     init-stripper
     strip-default-methods
     strip-libc
+    strip-call
     strip-cocoa
     strip-debugger
     compute-next-methods

basis/tools/deploy/shaker/strip-call.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+IN: tools.deploy.shaker.call
+
+IN: call
+USE: call.private
+
+: execute-effect ( word effect -- ) execute-effect-unsafe ; inline

basis/tools/deploy/test/12/12.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: call math.parser io math ;
+IN: tools.deploy.test.12
+
+: execute-test ( a b w -- c ) execute( a b -- c ) ;
+
+: foo ( -- ) 1 2 \ + execute-test number>string print ;
+
+MAIN: foo

basis/tools/deploy/test/12/authors.txt

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

basis/tools/deploy/test/12/deploy.factor

@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-c-types? f }
+    { deploy-reflection 1 }
+    { "stop-after-last-window?" t }
+    { deploy-word-props? f }
+    { deploy-math? f }
+    { deploy-unicode? f }
+    { deploy-io 2 }
+    { deploy-ui? f }
+    { deploy-name "tools.deploy.test.12" }
+    { deploy-compiler? f }
+    { deploy-word-defs? f }
+    { deploy-threads? f }
+}

basis/tools/deploy/test/13/13.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp kernel io ;
+IN: tools.deploy.test.13
+
+: regexp-test ( a -- b ) <regexp> "xyz" swap matches? ;
+
+: main ( -- ) "x.z" regexp-test "X" "Y" ? print ;
+
+MAIN: main

basis/tools/deploy/test/13/authors.txt

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

basis/tools/deploy/test/13/deploy.factor

@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-threads? t }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { "stop-after-last-window?" t }
+    { deploy-c-types? f }
+    { deploy-name "tools.deploy.test.13" }
+    { deploy-word-props? f }
+    { deploy-unicode? f }
+    { deploy-word-defs? f }
+    { deploy-reflection 4 }
+    { deploy-ui? f }
+}

basis/ui/gadgets/corners/authors.txt

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

basis/ui/gadgets/corners/corners.factor

@@ -0,0 +1,43 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences namespaces ui.gadgets.frames
+ui.pens.image ui.gadgets.icons ui.gadgets.grids ;
+IN: ui.gadgets.corners
+
+CONSTANT: @center { 1 1 }
+CONSTANT: @left { 0 1 }
+CONSTANT: @right { 2 1 }
+CONSTANT: @top { 1 0 }
+CONSTANT: @bottom { 1 2 }
+
+CONSTANT: @top-left { 0 0 }
+CONSTANT: @top-right { 2 0 }
+CONSTANT: @bottom-left { 0 2 }
+CONSTANT: @bottom-right { 2 2 }
+
+SYMBOL: name
+
+: corner-image ( name -- image )
+    [ name get "-" ] dip 3append theme-image ;
+
+: corner-icon ( name -- icon )
+    corner-image <icon> ;
+
+: /-----\ ( corner -- corner )
+    "top-left" corner-icon @top-left grid-add
+    "top-middle" corner-icon @top grid-add
+    "top-right" corner-icon @top-right grid-add ;
+
+: |-----| ( gadget corner -- corner )
+    "left-edge" corner-icon @left grid-add
+    swap @center grid-add
+    "right-edge" corner-icon @right grid-add ;
+
+: \-----/ ( corner -- corner )
+    "bottom-left" corner-icon @bottom-left grid-add
+    "bottom-middle" corner-icon @bottom grid-add
+    "bottom-right" corner-icon @bottom-right grid-add ;
+
+: make-corners ( class name quot -- corners )
+    [ [ [ 3 3 ] dip new-frame { 1 1 } >>filled-cell ] dip name ] dip
+    with-variable ; inline

basis/ui/gadgets/labeled/labeled-tests.factor

@@ -0,0 +1,4 @@
+IN: ui.gadgets.labeled.tests
+USING: ui.gadgets ui.gadgets.labeled accessors tools.test ;
+
+[ t ] [ <gadget> "Hey" <labeled-gadget> content>> gadget? ] unit-test

basis/ui/gadgets/labeled/labeled.factor

@@ -2,67 +2,33 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences colors fonts ui.gadgets
 ui.gadgets.frames ui.gadgets.grids ui.gadgets.icons ui.gadgets.labels
-ui.gadgets.borders ui.pens.image ;
+ui.gadgets.borders ui.pens.image ui.gadgets.corners ui.render ;
 IN: ui.gadgets.labeled
 
 TUPLE: labeled-gadget < frame content ;
 
 <PRIVATE
 
-CONSTANT: @center { 1 1 }
-CONSTANT: @left { 0 1 }
-CONSTANT: @right { 2 1 }
-CONSTANT: @top { 1 0 }
-CONSTANT: @bottom { 1 2 }
-
-CONSTANT: @top-left { 0 0 }
-CONSTANT: @top-right { 2 0 }
-CONSTANT: @bottom-left { 0 2 }
-CONSTANT: @bottom-right { 2 2 }
-
-: labeled-image ( name -- image )
-    "labeled-block-" prepend theme-image ;
-
-: labeled-icon ( name -- icon )
-    labeled-image <icon> ;
-
-CONSTANT: labeled-title-background
-    T{ rgba f
-        0.7843137254901961
-        0.7686274509803922
-        0.7176470588235294
-        1.0
-    }
-
 : <labeled-title> ( gadget -- label )
     >label
-    [ labeled-title-background font-with-background ] change-font
+    [ panel-background-color font-with-background ] change-font
     { 0 2 } <border>
-    "title-middle" labeled-image
+    "title-middle" corner-image
     <image-pen> t >>fill? >>interior ;
 
 : /-FOO-\ ( title labeled -- labeled )
-    "title-left" labeled-icon @top-left grid-add
+    "title-left" corner-icon @top-left grid-add
     swap <labeled-title> @top grid-add
-    "title-right" labeled-icon @top-right grid-add ;
+    "title-right" corner-icon @top-right grid-add ;
-
-: |-----| ( gadget labeled -- labeled )
-    "left-edge" labeled-icon @left grid-add
-    swap [ >>content ] [ @center grid-add ] bi
-    "right-edge" labeled-icon @right grid-add ;
-
-: \-----/ ( labeled -- labeled )
-    "bottom-left" labeled-icon @bottom-left grid-add
-    "bottom-middle" labeled-icon @bottom grid-add
-    "bottom-right" labeled-icon @bottom-right grid-add ;
 
 M: labeled-gadget focusable-child* content>> ;
 
 PRIVATE>
 
 : <labeled-gadget> ( gadget title -- newgadget )
-    3 3 labeled-gadget new-frame
+    labeled-gadget "labeled-block" [
-        { 1 1 } >>filled-cell
+        pick >>content
         /-FOO-\
         |-----|
-        \-----/ ;
+        \-----/
+    ] make-corners ;

basis/ui/gadgets/menus/menus.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: colors.constants kernel locals math.rectangles
+USING: colors.constants kernel locals math.rectangles namespaces
-namespaces sequences ui.commands ui.gadgets ui.gadgets.borders
+sequences ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.buttons ui.gadgets.glass ui.gadgets.packs
+ui.gadgets.glass ui.gadgets.packs ui.gadgets.frames ui.gadgets.worlds
-ui.gadgets.worlds ui.gestures ui.operations ui.pens ui.pens.solid
+ui.gadgets.frames ui.gadgets.corners ui.gestures ui.operations
-opengl math.vectors words accessors math math.order sorting ;
+ui.render ui.pens ui.pens.solid opengl math.vectors words accessors
+math math.order sorting ;
 IN: ui.gadgets.menus
 
 : show-menu ( owner menu -- )
@@ -30,6 +31,10 @@ M: separator-pen draw-interior
     dim>> [ { 0 0.5 } v* ] [ { 1 0.5 } v* ] bi
     [ [ >integer ] map ] bi@ gl-line ;
 
+: <menu-items> ( items -- gadget )
+    [ <filled-pile> ] dip add-gadgets
+    panel-background-color <solid> >>interior ;
+
 PRIVATE>
 
 SINGLETON: ----
@@ -43,10 +48,16 @@ M: ---- <menu-item>
 : menu-theme ( gadget -- gadget )
     COLOR: light-gray <solid> >>interior ;
 
+: <menu> ( gadgets -- menu )
+    <menu-items>
+    frame "menu-background" [
+        /-----\
+        |-----|
+        \-----/
+    ] make-corners ;
+
 : <commands-menu> ( target hook commands -- menu )
-    [ <filled-pile> ] 3dip
+    [ <menu-item> ] with with map <menu> ;
-    [ <menu-item> add-gadget ] with with each
-    { 5 5 } <border> menu-theme ;
 
 : show-commands-menu ( target commands -- )
     [ dup [ ] ] dip <commands-menu> show-menu ;

basis/ui/render/render.factor

@@ -112,4 +112,12 @@ M: gadget draw-children
 
 CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
 
+CONSTANT: panel-background-color
+    T{ rgba f
+        0.7843137254901961
+        0.7686274509803922
+        0.7176470588235294
+        1.0
+    }
+
 CONSTANT: focus-border-color COLOR: dark-gray

core/bootstrap/primitives.factor

@@ -36,7 +36,7 @@ H{ } clone sub-primitives set
     dictionary
     new-classes
     changed-definitions changed-generics
-    remake-generics forgotten-definitions
+    outdated-generics forgotten-definitions
     root-cache source-files update-map implementors-map
 } [ H{ } clone swap set ] each
 
@@ -47,7 +47,9 @@ init-caches
 
 ! Trivial recompile hook. We don't want to touch the code heap
 ! during stage1 bootstrap, it would just waste time.
-[ drop { } ] recompile-hook set
+SINGLETON: dummy-compiler
+M: dummy-compiler recompile drop { } ;
+dummy-compiler compiler-impl set
 
 call
 call

core/classes/tuple/tuple.factor

@@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel kernel.private math
 namespaces make sequences sequences.private strings vectors
 words quotations memory combinators generic classes
 classes.algebra classes.builtin classes.private slots.private
-slots compiler.units math.private accessors assocs effects ;
+slots math.private accessors assocs effects ;
 IN: classes.tuple
 
 PREDICATE: tuple-class < class
@@ -188,6 +188,8 @@ ERROR: bad-superclass class ;
 : apply-slot-permutation ( old-values triples -- new-values )
     [ first3 update-slot ] with map ;
 
+SYMBOL: outdated-tuples
+
 : permute-slots ( old-values layout -- new-values )
     [ first all-slots ] [ outdated-tuples get at ] bi
     compute-slot-permutation
@@ -212,8 +214,6 @@ ERROR: bad-superclass class ;
         dup [ update-tuple ] map become
     ] if ;
 
-[ update-tuples ] update-tuples-hook set-global
-
 : update-tuples-after ( class -- )
     [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
 

core/compiler/units/units-docs.factor

@@ -17,7 +17,7 @@ $nl
 "Forward reference checking (see " { $link "definition-checking" } "):"
 { $subsection forward-reference? }
 "A hook to be called at the end of the compilation unit. If the optimizing compiler is loaded, this compiles new words with the " { $link "compiler" } ":"
-{ $subsection recompile-hook }
+{ $subsection recompile }
 "Low-level compiler interface exported by the Factor VM:"
 { $subsection modify-code-heap } ;
 
@@ -47,8 +47,9 @@ $nl
 $nl
 "Since compilation is relatively expensive, you should try to batch up as many definitions into one compilation unit as possible." } ;
 
-HELP: recompile-hook
+HELP: recompile
-{ $var-description "Quotation with stack effect " { $snippet "( words -- )" } ", called at the end of " { $link with-compilation-unit } "." } ;
+{ $values { "words" "a sequence of words" } { "alist" "an association list mapping words to compiled definitions" } }
+{ $contract "Internal word which compiles words. Called at the end of " { $link with-compilation-unit } "." } ;
 
 HELP: no-compilation-unit
 { $values { "word" word } }

core/compiler/units/units-tests.factor

@@ -2,6 +2,9 @@ IN: compiler.units.tests
 USING: definitions compiler.units tools.test arrays sequences words kernel
 accessors namespaces fry ;
 
+[ [ [ ] define-temp ] with-compilation-unit ] must-infer
+[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
+
 [ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
 [ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
 [ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test

core/compiler/units/units.factor

@@ -1,8 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel continuations assocs namespaces
 sequences words vocabs definitions hashtables init sets
-math math.order classes classes.algebra ;
+math math.order classes classes.algebra classes.tuple
+classes.tuple.private generic ;
 IN: compiler.units
 
 SYMBOL: old-definitions
@@ -35,7 +36,11 @@ TUPLE: redefine-error def ;
     [ new-definitions get assoc-stack not ]
     [ drop f ] if ;
 
-SYMBOL: recompile-hook
+SYMBOL: compiler-impl
+
+HOOK: recompile compiler-impl ( words -- alist )
+
+M: f recompile [ f ] { } map>assoc ;
 
 : <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
 
@@ -68,12 +73,7 @@ GENERIC: definitions-changed ( assoc obj -- )
     dup changed-definitions get update
     dup dup changed-vocabs update ;
 
-: compile ( words -- )
+: compile ( words -- ) recompile modify-code-heap ;
-    recompile-hook get call modify-code-heap ;
-
-SYMBOL: outdated-tuples
-SYMBOL: update-tuples-hook
-SYMBOL: remake-generics-hook
 
 : index>= ( obj1 obj2 seq -- ? )
     [ index ] curry bi@ >= ;
@@ -125,24 +125,15 @@ SYMBOL: remake-generics-hook
     changed-generics get compiled-generic-usages
     append assoc-combine keys ;
 
-: call-recompile-hook ( -- )
-    to-recompile recompile-hook get call ;
-
-: call-remake-generics-hook ( -- )
-    remake-generics-hook get call ;
-
-: call-update-tuples-hook ( -- )
-    update-tuples-hook get call ;
-
 : unxref-forgotten-definitions ( -- )
     forgotten-definitions get
     keys [ word? ] filter
     [ delete-compiled-xref ] each ;
 
 : finish-compilation-unit ( -- )
-    call-remake-generics-hook
+    remake-generics
-    call-recompile-hook
+    to-recompile recompile
-    call-update-tuples-hook
+    update-tuples
     unxref-forgotten-definitions
     modify-code-heap ;
 
@@ -150,7 +141,7 @@ SYMBOL: remake-generics-hook
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
-        H{ } clone remake-generics set
+        H{ } clone outdated-generics set
         H{ } clone outdated-tuples set
         H{ } clone new-classes set
         [ finish-compilation-unit ] [ ] cleanup
@@ -160,7 +151,7 @@ SYMBOL: remake-generics-hook
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
-        H{ } clone remake-generics set
+        H{ } clone outdated-generics set
         H{ } clone forgotten-definitions set
         H{ } clone outdated-tuples set
         H{ } clone new-classes set
@@ -172,8 +163,3 @@ SYMBOL: remake-generics-hook
             notify-definition-observers
         ] [ ] cleanup
     ] with-scope ; inline
-
-: default-recompile-hook ( words -- alist )
-    [ f ] { } map>assoc ;
-
-recompile-hook [ [ default-recompile-hook ] ] initialize

core/definitions/definitions.factor

@@ -19,7 +19,7 @@ SYMBOL: changed-definitions
 
 SYMBOL: changed-generics
 
-SYMBOL: remake-generics
+SYMBOL: outdated-generics
 
 SYMBOL: new-classes
 

core/generic/generic.factor

@@ -3,7 +3,7 @@
 USING: accessors words kernel sequences namespaces make assocs
 hashtables definitions kernel.private classes classes.private
 classes.algebra quotations arrays vocabs effects combinators
-sets compiler.units ;
+sets ;
 IN: generic
 
 ! Method combination protocol
@@ -21,11 +21,6 @@ M: generic definition drop f ;
     [ dup "combination" word-prop perform-combination ]
     bi ;
 
-[
-    remake-generics get keys
-    [ generic? ] filter [ make-generic ] each
-] remake-generics-hook set-global
-
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
@@ -76,7 +71,10 @@ TUPLE: check-method class generic ;
     [ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
 
 : remake-generic ( generic -- )
-    dup remake-generics get set-in-unit ;
+    dup outdated-generics get set-in-unit ;
+
+: remake-generics ( -- )
+    outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
 
 : with-methods ( class generic quot -- )
     [ drop changed-generic ]

extra/parser-combinators/regexp/authors.txt

@@ -1,2 +0,0 @@
-Doug Coleman
-Slava Pestov

extra/parser-combinators/regexp/regexp-tests.factor

@@ -1,235 +0,0 @@
-USING: parser-combinators.regexp tools.test kernel ;
-IN: parser-combinators.regexp.tests
-
-[ f ] [ "b" "a*" f <regexp> matches? ] unit-test
-[ t ] [ "" "a*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a*" f <regexp> matches? ] unit-test
-[ t ] [ "aaaaaaa" "a*" f <regexp> matches? ] unit-test
-[ f ] [ "ab" "a*" f <regexp> matches? ] unit-test
-
-[ t ] [ "abc" "abc" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a|b|c" f <regexp> matches? ] unit-test
-[ t ] [ "b" "a|b|c" f <regexp> matches? ] unit-test
-[ t ] [ "c" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "c" "d|e|f" f <regexp> matches? ] unit-test
-
-[ f ] [ "aa" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "bb" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "cc" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "cc" "d|e|f" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "a+" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a+" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "a+" f <regexp> matches? ] unit-test
-
-[ t ] [ "" "a?" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a?" f <regexp> matches? ] unit-test
-[ f ] [ "aa" "a?" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "." f <regexp> matches? ] unit-test
-[ t ] [ "a" "." f <regexp> matches? ] unit-test
-[ t ] [ "." "." f <regexp> matches? ] unit-test
-! [ f ] [ "\n" "." f <regexp> matches? ] unit-test
-
-[ f ] [ "" ".+" f <regexp> matches? ] unit-test
-[ t ] [ "a" ".+" f <regexp> matches? ] unit-test
-[ t ] [ "ab" ".+" f <regexp> matches? ] unit-test
-
-[ t ] [ "" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "c" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "cc" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ f ] [ "ccd" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "d" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-
-[ t ] [ "foo" "foo|bar" f <regexp> matches? ] unit-test
-[ t ] [ "bar" "foo|bar" f <regexp> matches? ] unit-test
-[ f ] [ "foobar" "foo|bar" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "(a)" f <regexp> matches? ] unit-test
-[ t ] [ "a" "(a)" f <regexp> matches? ] unit-test
-[ f ] [ "aa" "(a)" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "(a*)" f <regexp> matches? ] unit-test
-
-[ f ] [ "aababaaabbac" "(a|b)+" f <regexp> matches? ] unit-test
-[ t ] [ "ababaaabba" "(a|b)+" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "a{1}" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a{1}" f <regexp> matches? ] unit-test
-[ f ] [ "aa" "a{1}" f <regexp> matches? ] unit-test
-
-[ f ] [ "a" "a{2,}" f <regexp> matches? ] unit-test
-[ t ] [ "aaa" "a{2,}" f <regexp> matches? ] unit-test
-[ t ] [ "aaaa" "a{2,}" f <regexp> matches? ] unit-test
-[ t ] [ "aaaaa" "a{2,}" f <regexp> matches? ] unit-test
-
-[ t ] [ "" "a{,2}" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a{,2}" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "a{,2}" f <regexp> matches? ] unit-test
-[ f ] [ "aaa" "a{,2}" f <regexp> matches? ] unit-test
-[ f ] [ "aaaa" "a{,2}" f <regexp> matches? ] unit-test
-[ f ] [ "aaaaa" "a{,2}" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "a{1,3}" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a{1,3}" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "a{1,3}" f <regexp> matches? ] unit-test
-[ t ] [ "aaa" "a{1,3}" f <regexp> matches? ] unit-test
-[ f ] [ "aaaa" "a{1,3}" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "[a]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[abc]" f <regexp> matches? ] unit-test
-[ f ] [ "b" "[a]" f <regexp> matches? ] unit-test
-[ f ] [ "d" "[abc]" f <regexp> matches? ] unit-test
-[ t ] [ "ab" "[abc]{1,2}" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "[abc]{1,2}" f <regexp> matches? ] unit-test
-
-[ f ] [ "" "[^a]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[^a]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[^abc]" f <regexp> matches? ] unit-test
-[ t ] [ "b" "[^a]" f <regexp> matches? ] unit-test
-[ t ] [ "d" "[^abc]" f <regexp> matches? ] unit-test
-[ f ] [ "ab" "[^abc]{1,2}" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "[^abc]{1,2}" f <regexp> matches? ] unit-test
-
-[ t ] [ "]" "[]]" f <regexp> matches? ] unit-test
-[ f ] [ "]" "[^]]" f <regexp> matches? ] unit-test
-
-! [ "^" "[^]" f <regexp> matches? ] must-fail
-[ t ] [ "^" "[]^]" f <regexp> matches? ] unit-test
-[ t ] [ "]" "[]^]" f <regexp> matches? ] unit-test
-
-[ t ] [ "[" "[[]" f <regexp> matches? ] unit-test
-[ f ] [ "^" "[^^]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^^]" f <regexp> matches? ] unit-test
-
-[ t ] [ "-" "[-]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[-]" f <regexp> matches? ] unit-test
-[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
-
-[ t ] [ "-" "[-a]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[-a]" f <regexp> matches? ] unit-test
-[ t ] [ "-" "[a-]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-]" f <regexp> matches? ] unit-test
-[ f ] [ "b" "[a-]" f <regexp> matches? ] unit-test
-[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
-
-[ f ] [ "-" "[a-c]" f <regexp> matches? ] unit-test
-[ t ] [ "-" "[^a-c]" f <regexp> matches? ] unit-test
-[ t ] [ "b" "[a-c]" f <regexp> matches? ] unit-test
-[ f ] [ "b" "[^a-c]" f <regexp> matches? ] unit-test
-
-[ t ] [ "-" "[a-c-]" f <regexp> matches? ] unit-test
-[ f ] [ "-" "[^a-c-]" f <regexp> matches? ] unit-test
-
-[ t ] [ "\\" "[\\\\]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[\\\\]" f <regexp> matches? ] unit-test
-[ f ] [ "\\" "[^\\\\]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^\\\\]" f <regexp> matches? ] unit-test
-
-[ t ] [ "0" "[\\d]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[\\d]" f <regexp> matches? ] unit-test
-[ f ] [ "0" "[^\\d]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^\\d]" f <regexp> matches? ] unit-test
-
-[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" f <regexp> matches? ] unit-test
-
-[ t ] [ "1000" "\\d{4,6}" f <regexp> matches? ] unit-test
-[ t ] [ "1000" "[0-9]{4,6}" f <regexp> matches? ] unit-test
-
-[ t ] [ "abc" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
-[ f ] [ "ABC" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
-[ t ] [ "ABC" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
-
-[ f ] [ "abc" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
-[ t ] [ "ABC" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
-
-[ t ] [ "" "\\Q\\E" f <regexp> matches? ] unit-test
-[ f ] [ "a" "\\Q\\E" f <regexp> matches? ] unit-test
-[ t ] [ "|*+" "\\Q|*+\\E" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "\\Q|*+\\E" f <regexp> matches? ] unit-test
-
-[ t ] [ "S" "\\0123" f <regexp> matches? ] unit-test
-[ t ] [ "SXY" "\\0123XY" f <regexp> matches? ] unit-test
-[ t ] [ "x" "\\x78" f <regexp> matches? ] unit-test
-[ f ] [ "y" "\\x78" f <regexp> matches? ] unit-test
-[ t ] [ "x" "\\u000078" f <regexp> matches? ] unit-test
-[ f ] [ "y" "\\u000078" f <regexp> matches? ] unit-test
-
-[ t ] [ "ab" "a+b" f <regexp> matches? ] unit-test
-[ f ] [ "b" "a+b" f <regexp> matches? ] unit-test
-[ t ] [ "aab" "a+b" f <regexp> matches? ] unit-test
-[ f ] [ "abb" "a+b" f <regexp> matches? ] unit-test
-
-[ t ] [ "abbbb" "ab*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "ab*" f <regexp> matches? ] unit-test
-[ f ] [ "abab" "ab*" f <regexp> matches? ] unit-test
-
-[ f ] [ "x" "\\." f <regexp> matches? ] unit-test
-[ t ] [ "." "\\." f <regexp> matches? ] unit-test
-
-[ t ] [ "aaaab" "a+ab" f <regexp> matches? ] unit-test
-[ f ] [ "aaaxb" "a+ab" f <regexp> matches? ] unit-test
-[ t ] [ "aaacb" "a+cb" f <regexp> matches? ] unit-test
-[ f ] [ "aaaab" "a++ab" f <regexp> matches? ] unit-test
-[ t ] [ "aaacb" "a++cb" f <regexp> matches? ] unit-test
-
-[ 3 ] [ "aaacb" "a*" f <regexp> match-head ] unit-test
-[ 1 ] [ "aaacb" "a+?" f <regexp> match-head ] unit-test
-[ 2 ] [ "aaacb" "aa?" f <regexp> match-head ] unit-test
-[ 1 ] [ "aaacb" "aa??" f <regexp> match-head ] unit-test
-[ 3 ] [ "aacb" "aa?c" f <regexp> match-head ] unit-test
-[ 3 ] [ "aacb" "aa??c" f <regexp> match-head ] unit-test
-
-[ t ] [ "aaa" "AAA" t <regexp> matches? ] unit-test
-[ f ] [ "aax" "AAA" t <regexp> matches? ] unit-test
-[ t ] [ "aaa" "A*" t <regexp> matches? ] unit-test
-[ f ] [ "aaba" "A*" t <regexp> matches? ] unit-test
-[ t ] [ "b" "[AB]" t <regexp> matches? ] unit-test
-[ f ] [ "c" "[AB]" t <regexp> matches? ] unit-test
-[ t ] [ "c" "[A-Z]" t <regexp> matches? ] unit-test
-[ f ] [ "3" "[A-Z]" t <regexp> matches? ] unit-test
-
-[ ] [ 
-    "(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
-    f <regexp> drop
-] unit-test
-
-[ t ] [ "fxxbar" "(?!foo).{3}bar" f <regexp> matches? ] unit-test
-[ f ] [ "foobar" "(?!foo).{3}bar" f <regexp> matches? ] unit-test
-
-[ 3 ] [ "foobar" "foo(?=bar)" f <regexp> match-head ] unit-test
-[ f ] [ "foobxr" "foo(?=bar)" f <regexp> match-head ] unit-test
-
-[ f ] [ "foobxr" "foo\\z" f <regexp> match-head ] unit-test
-[ 3 ] [ "foo" "foo\\z" f <regexp> match-head ] unit-test
-
-[ 3 ] [ "foo bar" "foo\\b" f <regexp> match-head ] unit-test
-[ f ] [ "fooxbar" "foo\\b" f <regexp> matches? ] unit-test
-[ t ] [ "foo" "foo\\b" f <regexp> matches? ] unit-test
-[ t ] [ "foo bar" "foo\\b bar" f <regexp> matches? ] unit-test
-[ f ] [ "fooxbar" "foo\\bxbar" f <regexp> matches? ] unit-test
-[ f ] [ "foo" "foo\\bbar" f <regexp> matches? ] unit-test
-
-[ f ] [ "foo bar" "foo\\B" f <regexp> matches? ] unit-test
-[ 3 ] [ "fooxbar" "foo\\B" f <regexp> match-head ] unit-test
-[ t ] [ "foo" "foo\\B" f <regexp> matches? ] unit-test
-[ f ] [ "foo bar" "foo\\B bar" f <regexp> matches? ] unit-test
-[ t ] [ "fooxbar" "foo\\Bxbar" f <regexp> matches? ] unit-test
-[ f ] [ "foo" "foo\\Bbar" f <regexp> matches? ] unit-test
-
-[ t ] [ "s@f" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
-[ t ] [ ".o" "\\.[a-z]" f <regexp> matches? ] unit-test
-
-! Bug in parsing word
-[ t ] [
-    "a"
-    R' a'
-    matches?
-] unit-test

extra/parser-combinators/regexp/regexp.factor

@@ -1,330 +0,0 @@
-USING: arrays combinators kernel lists math math.parser
-namespaces parser lexer parser-combinators
-parser-combinators.simple promises quotations sequences strings
-math.order assocs prettyprint.backend prettyprint.custom memoize
-ascii unicode.categories combinators.short-circuit
-accessors make io ;
-IN: parser-combinators.regexp
-
-<PRIVATE
-
-SYMBOL: ignore-case?
-
-: char=-quot ( ch -- quot )
-    ignore-case? get
-    [ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
-    curry ;
-
-: char-between?-quot ( ch1 ch2 -- quot )
-    ignore-case? get
-    [ [ ch>upper ] bi@ [ [ ch>upper ] 2dip between? ] ]
-    [ [ between? ] ]
-    if 2curry ;
-
-: <@literal ( parser obj -- action ) [ nip ] curry <@ ;
-
-: <@delay ( parser quot -- action ) [ curry ] curry <@ ;
-
-PRIVATE>
-
-: ascii? ( n -- ? ) 
-    0 HEX: 7f between? ;
-
-: octal-digit? ( n -- ? )
-    CHAR: 0 CHAR: 7 between? ;
-
-: decimal-digit? ( n -- ? )
-    CHAR: 0 CHAR: 9 between? ;
-
-: hex-digit? ( n -- ? )
-    dup decimal-digit?
-    over CHAR: a CHAR: f between? or
-    swap CHAR: A CHAR: F between? or ;
-
-: control-char? ( n -- ? )
-    dup 0 HEX: 1f between?
-    swap HEX: 7f = or ;
-
-: punct? ( n -- ? )
-    "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
-
-: c-identifier-char? ( ch -- ? )
-    dup alpha? swap CHAR: _ = or ;
-
-: java-blank? ( n -- ? )
-    {
-        CHAR: \s
-        CHAR: \t CHAR: \n CHAR: \r
-        HEX: c HEX: 7 HEX: 1b
-    } member? ;
-
-: java-printable? ( n -- ? )
-    dup alpha? swap punct? or ;
-
-: 'ordinary-char' ( -- parser )
-    [ "\\^*+?|(){}[$" member? not ] satisfy
-    [ char=-quot ] <@ ;
-
-: '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' 6 exactly-n &> <|>
-    [ hex> ] <@ ;
-
-: satisfy-tokens ( assoc -- parser )
-    [ [ token ] dip <@literal ] { } 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  }
-    } [ char=-quot ] 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" [ ascii? ] }
-        { "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 <|>
-    [ char=-quot ] <@ ;
-
-: 'escape' ( -- parser )
-    "\\" token
-    'simple-escape-char'
-    'predefined-char-class' <|>
-    'posix-character-class' <|>
-    'simple-escape' <|> &> ;
-
-: 'any-char' ( -- parser )
-    "." token [ drop t ] <@literal ;
-
-: 'char' ( -- parser )
-    'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
-
-DEFER: 'regexp'
-
-TUPLE: group-result str ;
-
-C: <group-result> group-result
-
-: 'non-capturing-group' ( -- parser )
-    "?:" token 'regexp' &> ;
-
-: 'positive-lookahead-group' ( -- parser )
-    "?=" token 'regexp' &> [ ensure ] <@ ;
-
-: 'negative-lookahead-group' ( -- parser )
-    "?!" token 'regexp' &> [ ensure-not ] <@ ;
-
-: 'simple-group' ( -- parser )
-    'regexp' [ [ <group-result> ] <@ ] <@ ;
-
-: 'group' ( -- parser )
-    'non-capturing-group'
-    'positive-lookahead-group'
-    'negative-lookahead-group'
-    'simple-group' <|> <|> <|>
-    "(" ")" surrounded-by ;
-
-: 'range' ( -- parser )
-    [ CHAR: ] = not ] satisfy "-" token <&
-    [ CHAR: ] = not ] satisfy <&>
-    [ first2 char-between?-quot ] <@ ;
-
-: 'character-class-term' ( -- parser )
-    'range'
-    'escape' <|>
-    [ "\\]" member? not ] satisfy [ char=-quot ] <@ <|> ;
-
-: 'positive-character-class' ( -- parser )
-    "]" token [ CHAR: ] = ] <@literal 'character-class-term' <*> <&:>
-    'character-class-term' <+> <|>
-    [ [ 1|| ] curry ] <@ ;
-
-: '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 <*>
-    [ ignore-case? get <token-parser> ] <@
-    "\\Q" "\\E" surrounded-by ;
-
-: 'break' ( quot -- parser )
-    satisfy ensure epsilon just <|> ;
-
-: 'break-escape' ( -- parser )
-    "$" token [ "\r\n" member? ] 'break' <@literal
-    "\\b" token [ blank? ] 'break' <@literal <|>
-    "\\B" token [ blank? not ] 'break' <@literal <|>
-    "\\z" token epsilon just <@literal <|> ;
-
-: 'simple' ( -- parser )
-    'escaped-seq'
-    'break-escape' <|>
-    'group' <|>
-    'character-class' <|>
-    'char' <|> ;
-
-: 'exactly-n' ( -- parser )
-    'integer' [ exactly-n ] <@delay ;
-
-: 'at-least-n' ( -- parser )
-    'integer' "," token <& [ at-least-n ] <@delay ;
-
-: 'at-most-n' ( -- parser )
-    "," token 'integer' &> [ at-most-n ] <@delay ;
-
-: 'from-m-to-n' ( -- parser )
-    'integer' "," token <& 'integer' <&> [ first2 from-m-to-n ] <@delay ;
-
-: 'greedy-interval' ( -- parser )
-    'exactly-n' 'at-least-n' <|> 'at-most-n' <|> 'from-m-to-n' <|> ;
-
-: 'interval' ( -- parser )
-    'greedy-interval'
-    'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|>
-    'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|>
-    "{" "}" surrounded-by ;
-
-: 'repetition' ( -- parser )
-    ! Posessive
-    "*+" token [ <!*> ] <@literal
-    "++" token [ <!+> ] <@literal <|>
-    "?+" token [ <!?> ] <@literal <|>
-    ! Reluctant
-    "*?" token [ <(*)> ] <@literal <|>
-    "+?" token [ <(+)> ] <@literal <|>
-    "??" token [ <(?)> ] <@literal <|>
-    ! Greedy
-    "*" token [ <*> ] <@literal <|>
-    "+" token [ <+> ] <@literal <|>
-    "?" token [ <?> ] <@literal <|> ;
-
-: 'dummy' ( -- parser )
-    epsilon [ ] <@literal ;
-
-MEMO: 'term' ( -- parser )
-    'simple'
-    'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@
-    <!+> [ <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 ignore-case? ;
-
-: <regexp> ( string ignore-case? -- regexp )
-    [
-        ignore-case? [
-            dup 'regexp' just parse-1
-        ] with-variable
-    ] keep regexp boa ;
-
-: do-ignore-case ( string regexp -- string regexp )
-    dup ignore-case?>> [ [ >upper ] dip ] when ;
-
-: matches? ( string regexp -- ? )
-    do-ignore-case parser>> just parse nil? not ;
-
-: match-head ( string regexp -- end )
-    do-ignore-case parser>> parse dup nil?
-    [ drop f ] [ car unparsed>> from>> ] if ;
-
-! Literal syntax for regexps
-: parse-options ( string -- ? )
-    #! Lame
-    {
-        { "" [ f ] }
-        { "i" [ t ] }
-    } case ;
-
-: parse-regexp ( accum end -- accum )
-    lexer get dup skip-blank
-    [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
-    lexer get dup still-parsing-line?
-    [ (parse-token) parse-options ] [ drop f ] if
-    <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 source>>
-        dup find-regexp-syntax swap % swap % %
-        dup ignore-case?>> [ "i" % ] when
-    ] "" make
-    swap present-text ;

extra/parser-combinators/regexp/summary.txt

@@ -1 +0,0 @@
-Regular expressions

extra/parser-combinators/regexp/tags.txt

@@ -1,2 +0,0 @@
-parsing
-text