Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
4302e36424
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
Daniel Ehrenberg
|
||||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
extensions
|
||||
|
|
@ -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
|
||||
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
|
||||
{ $description "Compile a set of words." }
|
||||
HELP: optimizing-compiler
|
||||
{ $description "Singleton class implementing " { $link recompile } " to call the optimizing compiler." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
||||
HELP: compile-call
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -309,8 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
|
|||
check_sse2 ;
|
||||
|
||||
"-no-sse2" (command-line) member? [
|
||||
[ optimized-recompile-hook ] recompile-hook
|
||||
[ { check_sse2 } compile ] with-variable
|
||||
optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
|
||||
|
||||
"Checking if your CPU supports SSE2..." print flush
|
||||
sse2? [
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
"vocab:images/test-images/thiswayup24.bmp" ;
|
||||
CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
|
||||
|
||||
: test-bitmap8 ( -- path )
|
||||
"vocab:images/test-images/rgb8bit.bmp" ;
|
||||
CONSTANT: test-bitmap8 "vocab:images/test-images/rgb8bit.bmp"
|
||||
|
||||
: test-bitmap4 ( -- path )
|
||||
"vocab:images/test-images/rgb4bit.bmp" ;
|
||||
CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp"
|
||||
|
||||
: test-bitmap1 ( -- path )
|
||||
"vocab:images/test-images/1bit.bmp" ;
|
||||
CONSTANT: test-bitmap1 "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
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(( last-match index string -- ? ))
|
||||
define-declared
|
||||
] each
|
||||
] with-compilation-unit
|
||||
] call( words dfa -- ) ;
|
||||
[
|
||||
'[
|
||||
dup _ word>quot
|
||||
(( last-match index string -- ? ))
|
||||
define-declared
|
||||
] each
|
||||
] with-compilation-unit ;
|
||||
|
||||
: 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 @ ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
locals math namespaces sequences fry quotations
|
||||
math.order math.ranges vectors unicode.categories
|
||||
regexp.transition-tables words sets hashtables combinators.short-circuit
|
||||
unicode.case.private regexp.ast regexp.classes ;
|
||||
USING: accessors arrays assocs grouping kernel locals math namespaces
|
||||
sequences fry quotations math.order math.ranges vectors
|
||||
unicode.categories regexp.transition-tables words sets hashtables
|
||||
combinators.short-circuit unicode.case unicode.case.private regexp.ast
|
||||
regexp.classes ;
|
||||
IN: regexp.nfa
|
||||
|
||||
! This uses unicode.case.private for ch>upper and ch>lower
|
||||
|
|
|
|||
|
|
@ -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" "construction" } }
|
||||
{ $vocab-subsection "regexp.combinators" "Regular expression combinators" }
|
||||
{ $subsection { "regexp" "operations" } }
|
||||
{ $subsection { "regexp" "intro" } }
|
||||
"The class of regular expressions:"
|
||||
{ $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" }
|
||||
{ $vocab-link "regexp.combinators" } ;
|
||||
"Another approach is to use " { $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
|
||||
"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
|
||||
"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" } "."
|
||||
{ $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 }
|
||||
{ $subsection count-matches } ;
|
||||
"Replacing occurrences of a regular expression with a string:"
|
||||
{ $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" }
|
||||
{ $description "Literal syntax for a regular expression. When this syntax is used, the DFA is compiled at compile-time, rather than on first use." } ;
|
||||
{ $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. 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" } } "." } ;
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
"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."
|
||||
$nl
|
||||
"For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
|
||||
ARTICLE: "tools.deploy.usage" "Deploy tool usage"
|
||||
"Once the necessary deployment flags have been set, the application can be deployed:"
|
||||
{ $subsection deploy }
|
||||
"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."
|
||||
$nl
|
||||
"On all platforms, running the program will display a window with a message." ;
|
||||
|
||||
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 deploy }
|
||||
{ $see-also "ui.tools.deploy" } ;
|
||||
{ $subsection "tools.deploy.usage" }
|
||||
{ $subsection "tools.deploy.impl" }
|
||||
{ $subsection "tools.deploy.caveats" } ;
|
||||
|
||||
ABOUT: "tools.deploy"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.7" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"tools.deploy.test.8" shake-and-bake
|
||||
run-temp-image
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"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
|
||||
{
|
||||
"tools.deploy.test.6"
|
||||
"tools.deploy.test.7"
|
||||
"tools.deploy.test.8"
|
||||
"tools.deploy.test.9"
|
||||
"tools.deploy.test.10"
|
||||
"tools.deploy.test.11"
|
||||
"tools.deploy.test.12"
|
||||
} [
|
||||
[ ] swap [
|
||||
shake-and-bake
|
||||
run-temp-image
|
||||
] curry unit-test
|
||||
] each
|
||||
|
|
@ -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
|
||||
update-tuples-hook
|
||||
remake-generics-hook
|
||||
compiler-impl
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 }
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 }
|
||||
}
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
: |-----| ( 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 ;
|
||||
"title-right" corner-icon @top-right grid-add ;
|
||||
|
||||
M: labeled-gadget focusable-child* content>> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <labeled-gadget> ( gadget title -- newgadget )
|
||||
3 3 labeled-gadget new-frame
|
||||
{ 1 1 } >>filled-cell
|
||||
labeled-gadget "labeled-block" [
|
||||
pick >>content
|
||||
/-FOO-\
|
||||
|-----|
|
||||
\-----/ ;
|
||||
\-----/
|
||||
] make-corners ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
namespaces sequences ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.buttons ui.gadgets.glass ui.gadgets.packs
|
||||
ui.gadgets.worlds ui.gestures ui.operations ui.pens ui.pens.solid
|
||||
opengl math.vectors words accessors math math.order sorting ;
|
||||
USING: colors.constants kernel locals math.rectangles namespaces
|
||||
sequences ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
|
||||
ui.gadgets.glass ui.gadgets.packs ui.gadgets.frames ui.gadgets.worlds
|
||||
ui.gadgets.frames ui.gadgets.corners ui.gestures ui.operations
|
||||
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> add-gadget ] with with each
|
||||
{ 5 5 } <border> menu-theme ;
|
||||
[ <menu-item> ] with with map <menu> ;
|
||||
|
||||
: show-commands-menu ( target commands -- )
|
||||
[ dup [ ] ] dip <commands-menu> show-menu ;
|
||||
|
|
|
|||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{ $var-description "Quotation with stack effect " { $snippet "( words -- )" } ", called at the end of " { $link with-compilation-unit } "." } ;
|
||||
HELP: recompile
|
||||
{ $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 } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
recompile-hook get call modify-code-heap ;
|
||||
|
||||
SYMBOL: outdated-tuples
|
||||
SYMBOL: update-tuples-hook
|
||||
SYMBOL: remake-generics-hook
|
||||
: compile ( words -- ) recompile modify-code-heap ;
|
||||
|
||||
: 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
|
||||
call-recompile-hook
|
||||
call-update-tuples-hook
|
||||
remake-generics
|
||||
to-recompile recompile
|
||||
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
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ SYMBOL: changed-definitions
|
|||
|
||||
SYMBOL: changed-generics
|
||||
|
||||
SYMBOL: remake-generics
|
||||
SYMBOL: outdated-generics
|
||||
|
||||
SYMBOL: new-classes
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -1,2 +0,0 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Regular expressions
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
parsing
|
||||
text
|
||||
Loading…
Reference in New Issue