--- /dev/null
+One-time and recurring events
--- /dev/null
+Defining multiple words with the same name
{ $subsection printable? }\r
{ $subsection control? }\r
{ $subsection quotable? }\r
-"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode" } ")." ;\r
+"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ;\r
\r
ABOUT: "ascii"\r
--- /dev/null
+Fast searching of sorted arrays
"x86.32"
"x86.64"
"linux-ppc" "macosx-ppc"
- ! "arm"
} ;
<PRIVATE
all-words [ emit-word ] each ;
: emit-global ( -- )
- [
- {
- dictionary source-files builtins
- update-map implementors-map class<=-cache
- class-not-cache classes-intersect-cache class-and-cache
- class-or-cache
- } [ dup get swap bootstrap-word set ] each
- ] H{ } make-assoc
+ {
+ dictionary source-files builtins
+ update-map implementors-map
+ } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
+ {
+ class<=-cache class-not-cache classes-intersect-cache
+ class-and-cache class-or-cache
+ } [ H{ } clone ] H{ } map>assoc assoc-union
bootstrap-global set
bootstrap-global emit-userenv ;
[
[ 32 random-bits ] with-system-random
<mersenne-twister> random-generator set-global
-] "generator.random" add-init-hook
+] "bootstrap.random" add-init-hook
--- /dev/null
+An abstraction for enforcing a mutual-exclusion invariant
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
{ $examples
{ $example "USING: calendar prettyprint ;"
- "2010 12 25 <date> ."
- "T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}"
+ "2010 12 25 <date> >gmt midnight ."
+ "T{ timestamp { year 2010 } { month 12 } { day 25 } }"
}
} ;
T{ duration f 0 0 0 -5 0 0 }\r
}\r
] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test\r
+\r
+[\r
+ T{ timestamp\r
+ { year 2008 }\r
+ { month 10 }\r
+ { day 2 }\r
+ { hour 23 }\r
+ { minute 59 }\r
+ { second 59 }\r
+ { gmt-offset T{ duration f 0 0 0 0 0 0 } }\r
+ }\r
+] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test\r
: rfc822>timestamp ( str -- timestamp )\r
[ (rfc822>timestamp) ] with-string-reader ;\r
\r
+: check-day-name ( str -- )\r
+ [ day-abbreviations3 member? ] [ day-names member? ] bi or\r
+ check-timestamp drop ;\r
+\r
: (cookie-string>timestamp-1) ( -- timestamp )\r
timestamp new\r
- "," read-token day-abbreviations3 member? check-timestamp drop\r
+ "," read-token check-day-name\r
read1 CHAR: \s assert=\r
"-" read-token checked-number >>day\r
"-" read-token month-abbreviations index 1+ check-timestamp >>month\r
\r
: (cookie-string>timestamp-2) ( -- timestamp )\r
timestamp new\r
- read-sp day-abbreviations3 member? check-timestamp drop\r
+ read-sp check-day-name\r
read-sp month-abbreviations index 1+ check-timestamp >>month\r
read-sp checked-number >>day\r
":" read-token checked-number >>hour\r
" It will block the calling thread until there is data in the channel."
}
{ $see-also <channel> to } ;
+
+ARTICLE: "channels" "Channels"
+"The " { $vocab-link "channels" } " vocabulary provides a simple abstraction to send and receive objects." $nl
+"Opening a channel:"
+{ $subsection <channel> }
+"Sending a message:"
+{ $subsection to }
+"Receiving a message:"
+{ $subsection from } ;
+
+ABOUT: "channels"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string sequences
+math kernel ;
+IN: circular
+
+HELP: <circular-string>
+{ $values
+ { "n" integer }
+ { "circular" circular } }
+{ $description "Creates a new circular string object. A circular string is a string object that can be accessed out of bounds and the index will wrap around to the start of the string." } ;
+
+HELP: <circular>
+{ $values
+ { "seq" sequence }
+ { "circular" circular } }
+{ $description "Creates a new " { $link circular } " object that wraps an existing sequence. By default, the index is set to zero." } ;
+
+HELP: <growing-circular>
+{ $values
+ { "capacity" integer }
+ { "growing-circular" growing-circular } }
+{ $description "Creates a new growing-circular object." } ;
+
+HELP: change-circular-start
+{ $values
+ { "n" integer } { "circular" circular } }
+{ $description "Changes the start index of a circular object." } ;
+
+HELP: circular
+{ $description "A tuple class that stores a sequence and its start index." } ;
+
+HELP: growing-circular
+{ $description "A circular sequence that is growable." } ;
+
+HELP: push-circular
+{ $values
+ { "elt" object } { "circular" circular } }
+{ $description "Pushes an element to a " { $link circular } " object." } ;
+
+HELP: push-growing-circular
+{ $values
+ { "elt" object } { "circular" circular } }
+{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
+
+ARTICLE: "circular" "Circular sequences"
+"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
+"Creating a new circular object:"
+{ $subsection <circular> }
+{ $subsection <circular-string> }
+{ $subsection <growing-circular> }
+"Changing the start index:"
+{ $subsection change-circular-start }
+"Pushing new elements:"
+{ $subsection push-circular }
+{ $subsection push-growing-circular } ;
+
+ABOUT: "circular"
: <circular> ( seq -- circular )
0 circular boa ;
+<PRIVATE
: circular-wrap ( n circular -- n circular )
[ start>> + ] keep
[ seq>> length rem ] keep ; inline
+PRIVATE>
M: circular length seq>> length ;
M: growing-circular length length>> ;
+<PRIVATE
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
: set-peek ( elt seq -- )
[ length 1- ] keep set-nth ;
+PRIVATE>
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]
ARTICLE: "objc-calling" "Calling Objective C code"
"Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
{ $subsection import-objc-class }
-"Every imported Objective C class has as corresponding class word in the " { $vocab-link "objc-classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
+"Every imported Objective C class has as corresponding class word in the " { $vocab-link "cocoa.classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
$nl
"Messages can be sent to classes and instances using a pair of parsing words:"
{ $subsection POSTPONE: -> }
--- /dev/null
+Colors as a first-class data type
USING: help.markup help.syntax sequences ;
IN: columns
-ARTICLE: "columns" "Column sequences"
-"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
-{ $subsection column }
-{ $subsection <column> }
-"A utility word:"
-{ $subsection <flipped> } ;
-
HELP: column
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
{ $description "Outputs a new virtual sequence which presents the transpose of " { $snippet "seq" } "." }
{ $notes "This is the virtual sequence equivalent of " { $link flip } "." } ;
+ARTICLE: "columns" "Column sequences"
+"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
+{ $subsection column }
+{ $subsection <column> }
+"A utility word:"
+{ $subsection <flipped> } ;
+
ABOUT: "columns"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string quotations
+math ;
+IN: combinators.short-circuit
+
+HELP: 0&&
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Returns true if every quotation in the sequence of quotations returns true." } ;
+
+HELP: 0||
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Returns true if any quotation in the sequence returns true." } ;
+
+HELP: 1&&
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ;
+
+HELP: 1||
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
+
+HELP: 2&&
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ;
+
+HELP: 2||
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
+
+HELP: 3&&
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ;
+
+HELP: 3||
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
+
+HELP: n&&-rewrite
+{ $values
+ { "quots" "a sequence of quotations" } { "N" integer }
+ { "quot" quotation } }
+{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ;
+
+HELP: n||-rewrite
+{ $values
+ { "quots" "a sequence of quotations" } { "N" integer }
+ { "quot" quotation } }
+{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
+
+ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
+"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
+"AND combinators:"
+{ $subsection 0&& }
+{ $subsection 1&& }
+{ $subsection 2&& }
+{ $subsection 3&& }
+"OR combinators:"
+{ $subsection 0|| }
+{ $subsection 1|| }
+{ $subsection 2|| }
+{ $subsection 3|| }
+"Generalized combinators:"
+{ $subsection n&&-rewrite }
+{ $subsection n||-rewrite }
+;
+
+ABOUT: "combinators.short-circuit"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string quotations ;
+IN: combinators.short-circuit.smart
+
+HELP: &&
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Infers the number of arguments that each quotation takes from the stack. Eacn quotation must take the same number of arguments. Returns true if every quotation yields true, and stops early if one yields false." }
+{ $examples "Smart combinators will infer the two inputs:"
+ { $example "USING: prettyprint kernel math combinators.short-circuit.smart ;"
+ "2 3 { [ + 5 = ] [ - -1 = ] } && ."
+ "t"
+ }
+} ;
+
+HELP: ||
+{ $values
+ { "quots" "a sequence of quotations" }
+ { "quot" quotation } }
+{ $description "Infers the number of arguments that each quotation takes from the stack. Eacn quotation must take the same number of arguments. Returns true if any quotation yields true, and stops early when one yields true." }
+{ $examples "Smart combinators will infer the two inputs:"
+ { $example "USING: prettyprint kernel math combinators.short-circuit.smart ;"
+ "2 3 { [ - 1 = ] [ + 5 = ] } || ."
+ "t"
+ }
+} ;
+
+ARTICLE: "combinators.short-circuit.smart" "Smart short-circuit combinators"
+"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary is similar to " { $vocab-link "combinators.short-circuit" } " except the combinators here infer the number of inputs that the sequence of quotations takes."
+$nl
+"Generalized AND:"
+{ $subsection && }
+"Generalized OR:"
+{ $subsection || } ;
+
+ABOUT: "combinators.short-circuit.smart"
USING: help.markup help.syntax parser vocabs.loader strings ;
IN: command-line
+HELP: run-bootstrap-init
+{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
+
+HELP: run-user-init
+{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
+
+HELP: cli-param
+{ $values { "param" string } }
+{ $description "Process a command-line switch."
+$nl
+"If the parameter contains " { $snippet "=" } ", the global variable named by the string before the equals sign is set to the string after the equals sign."
+$nl
+"If the parameter begins with " { $snippet "no-" } ", sets the global variable named by the parameter with the prefix removed to " { $link f } "."
+$nl
+"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
+
+HELP: cli-args
+{ $values { "args" "a sequence of strings" } }
+{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
+
+HELP: main-vocab-hook
+{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
+
+HELP: main-vocab
+{ $values { "vocab" string } }
+{ $description "Outputs the name of the vocabulary which is to be run on startup using the " { $link run } " word. The " { $snippet "-run" } " command line switch overrides this setting." } ;
+
+HELP: default-cli-args
+{ $description "Sets global variables corresponding to default command line arguments." } ;
+
+HELP: ignore-cli-args?
+{ $values { "?" "a boolean" } }
+{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
+
+HELP: parse-command-line
+{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;
+
ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table
{ $subsection main-vocab-hook } ;
ABOUT: "cli"
-
-HELP: run-bootstrap-init
-{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
-
-HELP: run-user-init
-{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
-
-HELP: cli-param
-{ $values { "param" string } }
-{ $description "Process a command-line switch."
-$nl
-"If the parameter contains " { $snippet "=" } ", the global variable named by the string before the equals sign is set to the string after the equals sign."
-$nl
-"If the parameter begins with " { $snippet "no-" } ", sets the global variable named by the parameter with the prefix removed to " { $link f } "."
-$nl
-"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
-
-HELP: cli-args
-{ $values { "args" "a sequence of strings" } }
-{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
-
-HELP: main-vocab-hook
-{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
-
-HELP: main-vocab
-{ $values { "vocab" string } }
-{ $description "Outputs the name of the vocabulary which is to be run on startup using the " { $link run } " word. The " { $snippet "-run" } " command line switch overrides this setting." } ;
-
-HELP: default-cli-args
-{ $description "Sets global variables corresponding to default command line arguments." } ;
-
-HELP: ignore-cli-args?
-{ $values { "?" "a boolean" } }
-{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
-
-HELP: parse-command-line
-{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
+
+! Relocation classes
+: rc-absolute-cell 0 ;
+: rc-absolute 1 ;
+: rc-relative 2 ;
+: rc-absolute-ppc-2/2 3 ;
+: rc-relative-ppc-2 4 ;
+: rc-relative-ppc-3 5 ;
+: rc-relative-arm-3 6 ;
+: rc-indirect-arm 7 ;
+: rc-indirect-arm-pc 8 ;
+
+! Relocation types
+: rt-primitive 0 ;
+: rt-dlsym 1 ;
+: rt-literal 2 ;
+: rt-dispatch 3 ;
+: rt-xt 4 ;
+: rt-here 5 ;
+: rt-label 6 ;
+: rt-immediate 7 ;
+
+: rc-absolute? ( n -- ? )
+ [ rc-absolute-ppc-2/2 = ]
+ [ rc-absolute-cell = ]
+ [ rc-absolute = ]
+ tri or or ;
IN: compiler.generator
ARTICLE: "generator" "Compiled code generator"
-"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
+"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
$nl
"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
{ $subsection compiled-stack-traces? }
byte-arrays words stack-checker.known-words ;
IN: compiler.intrinsics
-: (tuple) ( layout -- tuple )
- "BUG: missing (tuple) intrinsic" throw ;
+ERROR: missing-intrinsic ;
+
+: (tuple) ( n -- tuple ) missing-intrinsic ;
\ (tuple) { tuple-layout } { tuple } define-primitive
\ (tuple) make-flushable
-: (array) ( n -- array )
- "BUG: missing (array) intrinsic" throw ;
+: (array) ( n -- array ) missing-intrinsic ;
\ (array) { integer } { array } define-primitive
\ (array) make-flushable
-: (byte-array) ( n -- byte-array )
- "BUG: missing (byte-array) intrinsic" throw ;
+: (byte-array) ( n -- byte-array ) missing-intrinsic ;
\ (byte-array) { integer } { byte-array } define-primitive
\ (byte-array) make-flushable
+
+: (ratio) ( -- ratio ) missing-intrinsic ;
+
+\ (ratio) { } { ratio } define-primitive
+\ (ratio) make-flushable
+
+: (complex) ( -- complex ) missing-intrinsic ;
+
+\ (complex) { } { complex } define-primitive
+\ (complex) make-flushable
+
+: (wrapper) ( -- wrapper ) missing-intrinsic ;
+
+\ (wrapper) { } { wrapper } define-primitive
+\ (wrapper) make-flushable
+
+: (set-slot) ( val obj n -- ) missing-intrinsic ;
+
+\ (set-slot) { object object fixnum } { } define-primitive
+
+: (write-barrier) ( obj -- ) missing-intrinsic ;
+
+\ (write-barrier) { object } { } define-primitive
: node-output-infos ( node -- seq )
dup out-d>> [ node-value-info ] with map ;
+: first-literal ( #call -- obj )
+ dup in-d>> first node-value-info literal>> ;
+
+: last-literal ( #call -- obj )
+ dup out-d>> peek node-value-info literal>> ;
+
: immutable-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
dup in-d>> peek node-value-info
kernel ;\r
IN: concurrency.combinators\r
\r
+<PRIVATE\r
: (parallel-each) ( n quot -- )\r
>r <count-down> r> keep await ; inline\r
+PRIVATE>\r
\r
: parallel-each ( seq quot -- )\r
over length [\r
: parallel-filter ( seq quot -- newseq )\r
over >r pusher >r each r> r> like ; inline\r
\r
+<PRIVATE\r
: future-values dup [ ?future ] change-each ; inline\r
+PRIVATE>\r
\r
: parallel-map ( seq quot -- newseq )\r
[ curry future ] curry map future-values ;\r
--- /dev/null
+concurrency
--- /dev/null
+concurrency
: count-down-check ( count-down -- )\r
dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;\r
\r
+ERROR: invalid-count-down-count count ;\r
+\r
: <count-down> ( n -- count-down )\r
- dup 0 < [ "Invalid count for count down" throw ] when\r
+ dup 0 < [ invalid-count-down-count ] when\r
<promise> \ count-down boa\r
dup count-down-check ;\r
\r
+ERROR: count-down-already-done ;\r
+\r
: count-down ( count-down -- )\r
dup n>> dup zero?\r
- [ "Count down already done" throw ]\r
+ [ count-down-already-done ]\r
[ 1- >>n count-down-check ] if ;\r
\r
: await-timeout ( count-down timeout -- )\r
--- /dev/null
+concurrency
+concurrency
enterprise
-extensions
--- /dev/null
+concurrency
--- /dev/null
+concurrency
--- /dev/null
+concurrency
--- /dev/null
+concurrency
--- /dev/null
+concurrency
! Concurrency library for Factor, based on Erlang/Termite style\r
! concurrency.\r
USING: kernel threads concurrency.mailboxes continuations\r
-namespaces assocs random accessors ;\r
+namespaces assocs random accessors summary ;\r
IN: concurrency.messaging\r
\r
GENERIC: send ( message thread -- )\r
[ >r tag>> r> tag>> = ]\r
[ 2drop f ] if ;\r
\r
+ERROR: cannot-send-synchronous-to-self message thread ;\r
+\r
+M: cannot-send-synchronous-to-self summary\r
+ drop "Cannot synchronous send to myself" ;\r
+\r
: send-synchronous ( message thread -- reply )\r
dup self eq? [\r
- "Cannot synchronous send to myself" throw\r
+ cannot-send-synchronous-to-self\r
] [\r
>r <synchronous> dup r> send\r
[ synchronous-reply? ] curry receive-if\r
--- /dev/null
+concurrency
: promise-fulfilled? ( promise -- ? )\r
mailbox>> mailbox-empty? not ;\r
\r
+ERROR: promise-already-fulfilled promise ;\r
: fulfill ( value promise -- )\r
dup promise-fulfilled? [ \r
- "Promise already fulfilled" throw\r
+ promise-already-fulfilled\r
] [\r
mailbox>> mailbox-put\r
] if ;\r
--- /dev/null
+concurrency
--- /dev/null
+concurrency
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
continuations combinators core-foundation
-core-foundation.run-loop io.encodings.utf8 destructors ;
+core-foundation.run-loop core-foundation.run-loop.thread
+io.encodings.utf8 destructors ;
IN: core-foundation.fsevents
-! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
-! FSEventStream API, Leopard only !
-! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
-
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
: kFSEventStreamCreateFlagWatchRoot 4 ; inline
: start-run-loop-thread ( -- )
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
-
-[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: init core-foundation.run-loop ;
+IN: core-foundation.run-loop.thread
+
+! Load this vocabulary if you need a run loop running.
+
+[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel help.markup help.syntax sequences
-alien assocs strings math multiline ;
+alien assocs strings math multiline quotations ;
IN: db
HELP: db
{ $description } ;
HELP: result-set
-{ $description } ;
+{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use."
+ { $subsection "db-random-access-result-set" }
+ { $subsection "db-sequential-result-set" }
+} ;
+
+HELP: init-result-set
+{ $values
+ { "result-set" result-set } }
+{ $description "" } ;
+
+HELP: new-result-set
+{ $values
+ { "query" "a query" } { "handle" alien } { "class" class }
+ { "result-set" result-set } }
+{ $description "Creates a new " { $link result-set } " object of type " { $snippet "class" } "." } ;
+
HELP: new-statement
{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
{ $values { "query" object }
{ "result-set" result-set }
}
-{ $description "" } ;
+{ $description "Returns a " { $link result-set } " object representing the reults of a SQL query." } ;
HELP: #rows
{ $values { "result-set" result-set } { "n" integer } }
{ $values { "result-set" result-set } { "column" integer }
{ "obj" object }
}
-{ $description "" } ;
+{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } "." } ;
HELP: row-column-typed
{ $values { "result-set" result-set } { "column" integer }
{ "sql" "sql" } }
-{ $description "" } ;
+{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } " and converts the result based on a type stored in the " { $link result-set } "'s " { $slot "out-params" } "." } ;
HELP: advance-row
{ $values { "result-set" result-set } }
-;
+{ $description "Advanced the pointer to an underlying SQL result set stored in a " { $link result-set } " object." } ;
HELP: more-rows?
{ $values { "result-set" result-set } { "?" "a boolean" } }
-;
+{ $description "Returns true if the " { $link result-set } " has more rows to traverse." } ;
HELP: execute-statement*
{ $values { "statement" statement } { "type" object } }
{ $description } ;
+HELP: execute-one-statement
+{ $values
+ { "statement" null } }
+{ $description "" } ;
+
HELP: execute-statement
{ $values { "statement" statement } }
-{ $description } ;
+{ $description "" } ;
+
+
+
+
+
+
+HELP: begin-transaction
+{ $description "Begins a new transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
+
+HELP: bind-statement
+{ $values
+ { "obj" object } { "statement" null } }
+{ $description "" } ;
+
+HELP: commit-transaction
+{ $description "Commits a transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
-ARTICLE: "db" "Low-level database library"
+HELP: default-query
+{ $values
+ { "query" null }
+ { "result-set" null } }
+{ $description "" } ;
+
+HELP: in-transaction
+{ $description "A variable that is set true when a transaction is in progress." } ;
+
+HELP: in-transaction?
+{ $values
+ { "?" "a boolean" } }
+{ $description "Returns true if there is currently a transaction in progress in this scope." } ;
+
+HELP: query-each
+{ $values
+ { "statement" null } { "quot" quotation } }
+{ $description "" } ;
+
+HELP: query-map
+{ $values
+ { "statement" null } { "quot" quotation }
+ { "seq" sequence } }
+{ $description "" } ;
+
+HELP: rollback-transaction
+{ $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ;
+
+HELP: sql-command
+{ $values
+ { "sql" string } }
+{ $description "Executes a SQL string using the databse in the " { $link db } " symbol." } ;
+
+HELP: sql-query
+{ $values
+ { "sql" string }
+ { "rows" "an array of arrays of strings" } }
+{ $description "Runs a SQL query of raw text in the database in the " { $link db } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ;
+
+{ sql-command sql-query } related-words
+
+HELP: sql-row
+{ $values
+ { "result-set" result-set }
+ { "seq" sequence } }
+{ $description "Returns the current row in a " { $link result-set } " as an array of strings." } ;
+
+HELP: sql-row-typed
+{ $values
+ { "result-set" result-set }
+ { "seq" sequence } }
+{ $description "Returns the current row in a " { $link result-set } " as an array of typed Factor objects." } ;
+
+{ sql-row sql-row-typed } related-words
+
+HELP: with-db
+{ $values
+ { "seq" sequence } { "class" class } { "quot" quotation } }
+{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ;
+
+HELP: with-transaction
+{ $values
+ { "quot" quotation } }
+{ $description "" } ;
+
+ARTICLE: "db" "Database library"
{ $subsection "db-custom-database-combinators" }
{ $subsection "db-protocol" }
+{ $subsection "db-result-sets" }
{ $subsection "db-lowlevel-tutorial" }
"Higher-level database:"
{ $vocab-subsection "Database types" "db.types" }
{ $vocab-subsection "High-level tuple/database integration" "db.tuples" }
+! { $subsection "db-tuples" }
+! { $subsection "db-tuples-protocol" }
+! { $subsection "db-tuples-tutorial" }
"Supported database backends:"
{ $vocab-subsection "SQLite" "db.sqlite" }
{ $vocab-subsection "PostgreSQL" "db.postgresql" }
{ $subsection "db-porting-the-library" }
;
+ARTICLE: "db-random-access-result-set" "Random access result sets"
+"Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates."
+$nl
+"Databases which work in this way must provide methods for the following traversal words:"
+{ $subsection #rows }
+{ $subsection #columns }
+{ $subsection row-column }
+{ $subsection row-column-typed } ;
+
+ARTICLE: "db-sequential-result-set" "Sequential result sets"
+"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal."
+$nl
+"Databases which work in this way must provide methods for the following traversal words:"
+{ $subsection more-rows? }
+{ $subsection advance-row }
+{ $subsection row-column }
+{ $subsection row-column-typed } ;
+
+ARTICLE: "db-result-sets" "Result sets"
+"Result sets are the encapsulated, database-specific results from a SQL query."
+$nl
+"Two possible protocols for iterating over result sets exist:"
+{ $subsection "db-random-access-result-set" }
+{ $subsection "db-sequential-result-set" }
+"Query the number of rows or columns:"
+{ $subsection #rows }
+{ $subsection #columns }
+"Traversing a result set:"
+{ $subsection advance-row }
+{ $subsection more-rows? }
+"Pulling out a single row of results:"
+{ $subsection row-column }
+{ $subsection row-column-typed } ;
+
ARTICLE: "db-protocol" "Low-level database protocol"
"The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries."
;
"This section is not yet written."
;
-
ARTICLE: "db-custom-database-combinators" "Custom database combinators"
"Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl
{ "my-database.db" temp-file } sqlite-db rot with-db ;
"> }
-
;
ABOUT: "db"
M: object execute-statement* ( statement type -- )
drop query-results dispose ;
+: execute-one-statement ( statement -- )
+ dup type>> execute-statement* ;
+
: execute-statement ( statement -- )
dup sequence? [
- [ execute-statement ] each
+ [ execute-one-statement ] each
] [
- dup type>> execute-statement*
+ execute-one-statement
] if ;
: bind-statement ( obj statement -- )
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators classes locals words tools.walker
-nmake accessors random db.queries destructors ;
+nmake accessors random db.queries destructors db.tuples.private ;
USE: tools.walker
IN: db.postgresql
M: postgresql-db dispose ( db -- )
handle>> PQfinish ;
-M: postgresql-statement bind-statement* ( statement -- )
- drop ;
+M: postgresql-statement bind-statement* ( statement -- ) drop ;
GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
[ handle>> ] [ n>> ] bi ;
M: postgresql-result-set row-column ( result-set column -- object )
- >r result-handle-n r> pq-get-string ;
+ [ result-handle-n ] dip pq-get-string ;
M: postgresql-result-set row-column-typed ( result-set column -- object )
dup pick out-params>> nth type>>
- >r >r result-handle-n r> r> postgresql-column-typed ;
+ [ result-handle-n ] 2dip postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
dup bind-params>> [
: create-table-sql ( class -- statement )
[
+ dupd
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
dup type>> lookup-create-type 0%
modifiers 0%
- ] interleave ");" 0%
+ ] interleave
+
+ ", " 0%
+ find-primary-key
+ "primary key(" 0%
+ [ "," 0% ] [ column-name>> 0% ] interleave
+ "));" 0%
] query-make ;
: create-function-sql ( class -- statement )
M: postgresql-db create-sql-statement ( class -- seq )
[
[ create-table-sql , ] keep
- dup db-columns find-primary-key db-assigned-id-spec?
- [ create-function-sql , ] [ drop ] if
+ dup db-assigned? [ create-function-sql , ] [ drop ] if
] { } make ;
: drop-function-sql ( class -- statement )
M: postgresql-db drop-sql-statement ( class -- seq )
[
[ drop-table-sql , ] keep
- dup db-columns find-primary-key db-assigned-id-spec?
- [ drop-function-sql , ] [ drop ] if
+ dup db-assigned? [ drop-function-sql , ] [ drop ] if
] { } make ;
M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
[
"select add_" 0% 0%
"(" 0%
- dup find-primary-key 2,
+ dup find-primary-key first 2,
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
");" 0%
] query-make ;
-M: postgresql-db insert-tuple* ( tuple statement -- )
+M: postgresql-db insert-tuple-set-key ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db persistent-table ( -- hashtable )
H{
- { +db-assigned-id+ { "integer" "serial primary key" f } }
- { +user-assigned-id+ { f f "primary key" } }
- { +random-id+ { "bigint" "bigint primary key" f } }
+ { +db-assigned-id+ { "integer" "serial" f } }
+ { +user-assigned-id+ { f f f } }
+ { +random-id+ { "bigint" "bigint" f } }
+
+ { +foreign-id+ { f f "references" } }
+
+ { +on-delete+ { f f "on delete" } }
+ { +restrict+ { f f "restrict" } }
+ { +cascade+ { f f "cascade" } }
+ { +set-null+ { f f "set null" } }
+ { +set-default+ { f f "set default" } }
+
{ TEXT { "text" "text" f } }
{ VARCHAR { "varchar" "varchar" f } }
{ INTEGER { "integer" "integer" f } }
{ BLOB { "bytea" "bytea" f } }
{ FACTOR-BLOB { "bytea" "bytea" f } }
{ URL { "varchar" "varchar" f } }
- { +foreign-id+ { f f "references" } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }
{ +default+ { f f "default" } }
over {
{ "default" [ first number>string join-space ] }
{ "varchar" [ first number>string paren append ] }
- { "references" [
- first2 >r [ unparse join-space ] keep db-columns r>
- swap [ slot-name>> = ] with find nip
- column-name>> paren append
- ] }
+ { "references" [ >reference-string ] }
[ drop no-compound-found ]
} case ;
USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types db.sql classes words shuffle arrays
-destructors continuations ;
+destructors continuations db.tuples.private ;
IN: db.queries
GENERIC: where ( specs obj -- )
[ db-columns ] [ db-table ] bi ;
: query-make ( class quot -- )
- >r sql-props r>
- [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
+ [ sql-props ] dip
+ [ 0 sql-counter rot with-variable ] curry
+ { "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
: where-primary-key% ( specs -- )
" where " 0%
- find-primary-key dup column-name>> 0% " = " 0% bind% ;
+ find-primary-key [
+ " and " 0%
+ ] [
+ dup column-name>> 0% " = " 0% bind%
+ ] interleave ;
M: db <update-tuple-statement> ( class -- statement )
[
dup double-infinite-interval? [ drop f ] when
] with filter ;
-: where-clause ( tuple specs -- )
- dupd filter-slots [
- drop
+: many-where ( tuple seq -- )
+ " where " 0% [
+ " and " 0%
] [
- " where " 0% [
- " and " 0%
- ] [
- 2dup slot-name>> swap get-slot-named where
- ] interleave drop
- ] if-empty ;
+ 2dup slot-name>> swap get-slot-named where
+ ] interleave drop ;
+
+: where-clause ( tuple specs -- )
+ dupd filter-slots [ drop ] [ many-where ] if-empty ;
M: db <delete-tuples-statement> ( tuple table -- sql )
[
number>string " limit " swap 3append
] curry change-sql drop ;
-: make-query ( tuple query -- tuple' )
+: make-query* ( tuple query -- tuple' )
dupd
{
[ group>> [ drop ] [ do-group ] if-empty ]
[ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ;
-M: db <query> ( tuple class query -- tuple )
- [ <select-by-slots-statement> ] dip make-query ;
+M: db query>statement ( query -- tuple )
+ [ tuple>> dup class ] keep
+ [ <select-by-slots-statement> ] dip make-query* ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
-M: db <count-statement> ( tuple class groups -- statement )
- \ query new
- swap >>group
+M: db <count-statement> ( query -- statement )
+ [ tuple>> dup class ] keep
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
- dip make-query ;
+ dip make-query* ;
: create-index ( index-name table-name columns -- )
[
sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
-math.bitwise db.queries destructors ;
+math.bitwise db.queries destructors db.tuples.private ;
IN: db.sqlite
TUPLE: sqlite-db < db path ;
db get handle>> sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
-M: sqlite-db insert-tuple* ( tuple statement -- )
+M: sqlite-db insert-tuple-set-key ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
M: sqlite-db create-sql-statement ( class -- statement )
[
+ dupd
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
dup type>> lookup-create-type 0%
modifiers 0%
- ] interleave ");" 0%
+ ] interleave
+
+ ", " 0%
+ find-primary-key
+ "primary key(" 0%
+ [ "," 0% ] [ column-name>> 0% ] interleave
+ "));" 0%
] query-make ;
M: sqlite-db drop-sql-statement ( class -- statement )
M: sqlite-db persistent-table ( -- assoc )
H{
- { +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
- { +user-assigned-id+ { f f "primary key" } }
- { +random-id+ { "integer primary key" "integer primary key" "primary key" } }
- { INTEGER { "integer" "integer" "primary key" } }
- { BIG-INTEGER { "bigint" "bigint" } }
- { SIGNED-BIG-INTEGER { "bigint" "bigint" } }
- { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
- { TEXT { "text" "text" } }
- { VARCHAR { "text" "text" } }
- { DATE { "date" "date" } }
- { TIME { "time" "time" } }
- { DATETIME { "datetime" "datetime" } }
- { TIMESTAMP { "timestamp" "timestamp" } }
- { DOUBLE { "real" "real" } }
- { BLOB { "blob" "blob" } }
- { FACTOR-BLOB { "blob" "blob" } }
- { URL { "text" "text" } }
+ { +db-assigned-id+ { "integer" "integer" f } }
+ { +user-assigned-id+ { f f f } }
+ { +random-id+ { "integer" "integer" f } }
+ { +foreign-id+ { "integer" "integer" "references" } }
+
+ { +on-delete+ { f f "on delete" } }
+ { +restrict+ { f f "restrict" } }
+ { +cascade+ { f f "cascade" } }
+ { +set-null+ { f f "set null" } }
+ { +set-default+ { f f "set default" } }
+
+ { INTEGER { "integer" "integer" f } }
+ { BIG-INTEGER { "bigint" "bigint" f } }
+ { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { TEXT { "text" "text" f } }
+ { VARCHAR { "text" "text" f } }
+ { DATE { "date" "date" f } }
+ { TIME { "time" "time" f } }
+ { DATETIME { "datetime" "datetime" f } }
+ { TIMESTAMP { "timestamp" "timestamp" f } }
+ { DOUBLE { "real" "real" f } }
+ { BLOB { "blob" "blob" f } }
+ { FACTOR-BLOB { "blob" "blob" f } }
+ { URL { "text" "text" f } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }
{ +default+ { f f "default" } }
{ random-generator { f f f } }
} ;
-M: sqlite-db compound ( str seq -- str' )
+M: sqlite-db compound ( string seq -- new-string )
over {
{ "default" [ first number>string join-space ] }
- [ 2drop ]
+ { "references" [ >reference-string ] }
+ [ 2drop ]
} case ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel
-quotations sequences strings multiline math ;
+quotations sequences strings multiline math db.types ;
IN: db.tuples
HELP: define-persistent
{ $list
{ "a slot name from the " { $snippet "tuple class" } }
{ "the name of a database column that maps to the slot" } { "a database type (see " { $link "db.types" } ")" }
-} } ;
+} "Throws an error if the slot name (column one from each row) is not a slot in the tuple or its superclases." }
+{ $examples
+ { $unchecked-example "USING: db.tuples db.types ;"
+ "TUPLE: boat id year name ;"
+ "boat \"BOAT\" {"
+ " { \"id\" \"ID\" +db-assigned-id+ }"
+ " { \"year\" \"YEAR\" INTEGER }"
+ " { \"name\" \"NAME\" TEXT }"
+ "} define-persistent"
+ ""
+ }
+} ;
HELP: create-table
{ $values
HELP: select-tuple
{ $values
- { "tuple" tuple }
+ { "query/tuple" tuple }
{ "tuple/f" "a tuple or f" } }
{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a single tuple from the database if it matches the query constructed from the exemplar tuple." } ;
HELP: select-tuples
{ $values
- { "tuple" tuple }
+ { "query/tuple" tuple }
{ "tuples" "an array of tuples" } }
{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a multiple tuples from the database that match the query constructed from the exemplar tuple." } ;
HELP: count-tuples
{ $values
- { "tuple" tuple } { "groups" "an array of slots to group by" }
+ { "query/tuple" tuple }
{ "n" integer } }
-{ $description "" } ;
+{ $description "Returns the number of items that would be returned if the query were a select query. Counting the tuples with this word is more efficient than calling " { $link length } " on the result of " { $link select-tuples } "." } ;
+
+{ select-tuple select-tuples count-tuples } related-words
-HELP: query
-{ $values
- { "tuple" tuple } { "query" query }
- { "tuples" "a sequence of tuples" } }
-{ $description "Allows for queries with group by, order by, limit, and offset clauses. " } ;
-{ select-tuple select-tuples count-tuples query } related-words
ARTICLE: "db-tuples" "High-level tuple/database integration"
"Start with a tutorial:"
{ $subsection "db-tuples-tutorial" }
+"Database types supported:"
+{ $subsection "db.types" }
"Useful words:"
{ $subsection "db-tuples-words" }
-
+"For porting db.tuples to other databases:"
+{ $subsection "db-tuples-protocol" }
;
ARTICLE: "db-tuples-words" "High-level tuple/database words"
"Querying tuples:"
{ $subsection select-tuple }
{ $subsection select-tuples }
-{ $subsection count-tuples }
-"Advanced querying of tuples:"
-{ $subsection query } ;
-
+{ $subsection count-tuples } ;
-ARTICLE: "db-tuples-protocol" "High-level tuple/database protocol"
+ARTICLE: "db-tuples-protocol" "Tuple database protocol"
;
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise
-math.ranges strings urls fry ;
+math.ranges strings urls fry db.tuples.private ;
IN: db.tuples.tests
+: test-sqlite ( quot -- )
+ [ ] swap '[
+ "tuples-test.db" temp-file sqlite-db _ with-db
+ ] unit-test ;
+
+: test-postgresql ( quot -- )
+ [ ] swap '[
+ { "localhost" "postgres" "foob" "factor-test" }
+ postgresql-db _ with-db
+ ] unit-test ;
+
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob url ;
{ "channel" "CHANNEL" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
- { "date" "DATE" TIMESTAMP }
+ { "timestamp" "DATE" TIMESTAMP }
{ "annotations" { +has-many+ annotation } }
} define-persistent
annotation "ANNOTATION"
{
{ "n" "ID" +db-assigned-id+ }
- { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
+ { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" }
+ +on-delete+ +cascade+ }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
} define-persistent ;
-! { "localhost" "postgres" "" "factor-test" } postgresql-db [
- ! [ paste drop-table ] [ drop ] recover
- ! [ annotation drop-table ] [ drop ] recover
- ! [ paste drop-table ] [ drop ] recover
- ! [ annotation drop-table ] [ drop ] recover
- ! [ ] [ paste create-table ] unit-test
- ! [ ] [ annotation create-table ] unit-test
-! ] with-db
+: test-paste-schema ( -- )
+ [ ] [ db-assigned-paste-schema ] unit-test
+ [ ] [ paste ensure-table ] unit-test
+ [ ] [ annotation ensure-table ] unit-test
+ [ ] [ annotation drop-table ] unit-test
+ [ ] [ paste drop-table ] unit-test
+ [ ] [ paste create-table ] unit-test
+ [ ] [ annotation create-table ] unit-test
-: test-sqlite ( quot -- )
- [ ] swap '[ "tuples-test.db" temp-file sqlite-db _ with-db ] unit-test ;
+ [ ] [
+ paste new
+ "summary1" >>summary
+ "erg" >>author
+ "#lol" >>channel
+ "contents1" >>contents
+ now >>timestamp
+ insert-tuple
+ ] unit-test
-: test-postgresql ( quot -- )
- [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db _ with-db ] unit-test ;
+ [ ] [
+ annotation new
+ 1 >>paste-id
+ "annotation1" >>summary
+ "erg" >>author
+ "annotation contents" >>contents
+ insert-tuple
+ ] unit-test
+
+ [ ] [
+ ] unit-test
+ ;
+
+[ test-paste-schema ] test-sqlite
+[ test-paste-schema ] test-postgresql
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
exam boa ;
: test-intervals ( -- )
+ [
+ exam "EXAM"
+ {
+ { "idd" "ID" +db-assigned-id+ }
+ { "named" "NAME" TEXT }
+ { "score" "SCORE" INTEGER }
+ } define-persistent
+ ] [
+ seq>> { "idd" "named" } =
+ ] must-fail-with
+
exam "EXAM"
{
{ "id" "ID" +db-assigned-id+ }
T{ exam } select-tuples
] unit-test
- [ 4 ] [ T{ exam } f count-tuples ] unit-test ;
+ [ 4 ] [ T{ exam } count-tuples ] unit-test ;
TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )
\ ensure-table must-infer
\ create-table must-infer
\ drop-table must-infer
+
+: test-queries ( -- )
+ [ ] [ exam ensure-table ] unit-test
+ [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
+ [ 5 ] [
+ <query>
+ T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
+ >>tuple
+ 5 >>limit select-tuples length
+ ] unit-test ;
+
+TUPLE: compound-foo a b c ;
+
+compound-foo "COMPOUND_FOO"
+{
+ { "a" "A" INTEGER +user-assigned-id+ }
+ { "b" "B" INTEGER +user-assigned-id+ }
+ { "c" "C" INTEGER }
+} define-persistent
+
+: test-compound-primary-key ( -- )
+ [ ] [ compound-foo ensure-table ] unit-test
+ [ ] [ compound-foo drop-table ] unit-test
+ [ ] [ compound-foo create-table ] unit-test
+ [ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
+ [ 1 2 3 compound-foo boa insert-tuple ] must-fail
+ [ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
+ [ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
+ [ compound-foo new 4 >>c select-tuple ] unit-test ;
+
+[ test-compound-primary-key ] test-sqlite
+[ test-compound-primary-key ] test-postgresql
+
+: sqlite-test-db ( -- )
+ "tuples-test.db" temp-file sqlite-db make-db db-open db set ;
+
+: postgresql-test-db ( -- )
+ { "localhost" "postgres" "foob" "factor-test" } postgresql-db
+ make-db db-open db set ;
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
-destructors mirrors ;
+destructors mirrors sets db.types ;
IN: db.tuples
-: define-persistent ( class table columns -- )
- >r dupd "db-table" set-word-prop dup r>
- [ relation? ] partition swapd
- dupd [ spec>tuple ] with map
- "db-columns" set-word-prop
- "db-relations" set-word-prop ;
-
-ERROR: not-persistent class ;
-
-: db-table ( class -- object )
- dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
-
-: db-columns ( class -- object )
- superclasses [ "db-columns" word-prop ] map concat ;
-
-: db-relations ( class -- object )
- "db-relations" word-prop ;
-
-: set-primary-key ( key tuple -- )
- [
- class db-columns find-primary-key slot-name>>
- ] keep set-slot-named ;
-
-SYMBOL: sql-counter
-: next-sql-counter ( -- str )
- sql-counter [ inc ] [ get ] bi number>string ;
-
+<PRIVATE
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- object )
HOOK: drop-sql-statement db ( class -- object )
HOOK: <update-tuple-statement> db ( class -- object )
HOOK: <delete-tuples-statement> db ( tuple class -- object )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
-TUPLE: query group order offset limit ;
-HOOK: <query> db ( tuple class query -- statement' )
-HOOK: <count-statement> db ( tuple class groups -- n )
+HOOK: <count-statement> db ( query -- statement )
+HOOK: query>statement db ( query -- statement )
-HOOK: insert-tuple* db ( tuple statement -- )
+HOOK: insert-tuple-set-key db ( tuple statement -- )
+
+SYMBOL: sql-counter
+: next-sql-counter ( -- str )
+ sql-counter [ inc ] [ get ] bi number>string ;
GENERIC: eval-generator ( singleton -- object )
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
rot class new [
- [
- [ slot-name>> ] dip set-slot-named
- ] curry 2each
+ [ [ slot-name>> ] dip set-slot-named ] curry 2each
] keep ;
: query-tuples ( exemplar-tuple statement -- seq )
with-disposal
] if ; inline
+: insert-db-assigned-statement ( tuple -- )
+ dup class
+ db get insert-statements>> [ <insert-db-assigned-statement> ] cache
+ [ bind-tuple ] 2keep insert-tuple-set-key ;
+
+: insert-user-assigned-statement ( tuple -- )
+ dup class
+ db get insert-statements>> [ <insert-user-assigned-statement> ] cache
+ [ bind-tuple ] keep execute-statement ;
+
+: do-select ( exemplar-tuple statement -- tuples )
+ [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
+
+: do-count ( exemplar-tuple statement -- tuples )
+ [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
+PRIVATE>
+
+
+! High level
+ERROR: no-slots-named class seq ;
+: check-columns ( class columns -- )
+ tuck
+ [ [ first ] map ]
+ [ all-slots [ name>> ] map ] bi* diff
+ [ drop ] [ no-slots-named ] if-empty ;
+
+: define-persistent ( class table columns -- )
+ pick dupd
+ check-columns
+ [ dupd "db-table" set-word-prop dup ] dip
+ [ relation? ] partition swapd
+ dupd [ spec>tuple ] with map
+ "db-columns" set-word-prop
+ "db-relations" set-word-prop ;
+
+TUPLE: query tuple group order offset limit ;
+
+: <query> ( -- query ) \ query new ;
+
+GENERIC: >query ( object -- query )
+
+M: query >query clone ;
+
+M: tuple >query <query> swap >>tuple ;
+
: create-table ( class -- )
create-sql-statement [ execute-statement ] with-disposals ;
] curry ignore-errors
] [ create-table ] bi ;
-: ensure-table ( class -- )
- [ create-table ] curry ignore-errors ;
-
-: ensure-tables ( classes -- )
- [ ensure-table ] each ;
+: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
-: insert-db-assigned-statement ( tuple -- )
- dup class
- db get insert-statements>> [ <insert-db-assigned-statement> ] cache
- [ bind-tuple ] 2keep insert-tuple* ;
-
-: insert-user-assigned-statement ( tuple -- )
- dup class
- db get insert-statements>> [ <insert-user-assigned-statement> ] cache
- [ bind-tuple ] keep execute-statement ;
+: ensure-tables ( classes -- ) [ ensure-table ] each ;
: insert-tuple ( tuple -- )
dup class db-columns find-primary-key db-assigned-id-spec?
[ bind-tuple ] keep execute-statement
] with-disposal ;
-: do-select ( exemplar-tuple statement -- tuples )
- [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
-
-: query ( tuple query -- tuples )
- [ dup dup class ] dip <query> do-select ;
-
-: select-tuples ( tuple -- tuples )
- dup dup class <select-by-slots-statement> do-select ;
+: select-tuples ( query/tuple -- tuples )
+ >query [ tuple>> ] [ query>statement ] bi do-select ;
-: select-tuple ( tuple -- tuple/f )
- dup dup class \ query new 1 >>limit <query> do-select
+: select-tuple ( query/tuple -- tuple/f )
+ >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
[ f ] [ first ] if-empty ;
-: do-count ( exemplar-tuple statement -- tuples )
- [
- [ bind-tuple ] [ nip default-query ] 2bi
- ] with-disposal ;
-
-: count-tuples ( tuple groups -- n )
- >r dup dup class r> <count-statement> do-count
+: count-tuples ( query/tuple -- n )
+ >query [ tuple>> ] [ <count-statement> ] bi do-count
dup length 1 =
[ first first string>number ] [ [ first string>number ] map ] if ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes hashtables help.markup help.syntax io.streams.string kernel sequences strings ;
+USING: classes hashtables help.markup help.syntax io.streams.string
+kernel sequences strings math ;
IN: db.types
-HELP: (lookup-type)
-{ $values
- { "obj" object }
- { "string" string } }
-{ $description "" } ;
-
HELP: +autoincrement+
{ $description "" } ;
{ $description "" } ;
HELP: BIG-INTEGER
-{ $description "A 64-bit integer." } ;
+{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
HELP: BLOB
{ $description "A serialized Factor object. The database library automatically serializes the object for a SQL insert or update and deserializes it on a tuple query." } ;
{ $description "Corresponds to Factor's 64bit floating-point numbers." } ;
HELP: FACTOR-BLOB
-{ $description "" } ;
+{ $description "A serialized Factor object." } ;
HELP: INTEGER
-{ $description "" } ;
+{ $description "A small integer, at least 32 bits in length. Whether this number is signed or unsigned depends on the database backend." } ;
HELP: NULL
-{ $description "" } ;
+{ $description "The SQL null type." } ;
HELP: REAL
{ $description "" } ;
{ $description "" } ;
HELP: TIMESTAMP
-{ $description "" } ;
+{ $description "A Factor timestamp." } ;
HELP: UNSIGNED-BIG-INTEGER
-{ $description "" } ;
+{ $description "For portability, if a number is known to be 64bit, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
+
+{ INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER } related-words
HELP: URL
-{ $description "" } ;
+{ $description "A Factor " { $link "urls" } " object." } ;
HELP: VARCHAR
-{ $description "" } ;
+{ $description "The SQL varchar type. This type can take an integer as an argument." } ;
-HELP: assigned-id-spec?
+HELP: user-assigned-id-spec?
{ $values
- { "spec" null }
+ { "specs" "a sequence of sql specs" }
{ "?" "a boolean" } }
-{ $description "" } ;
+{ $description "Tests if any of the sql specs has the type " { $link +user-assigned-id+ } "." } ;
HELP: bind#
{ $values
HELP: db-assigned-id-spec?
{ $values
- { "spec" null }
+ { "specs" "a sequence of sql specs" }
{ "?" "a boolean" } }
-{ $description "" } ;
+{ $description "Tests if any of the sql specs has the type " { $link +db-assigned-id+ } "." } ;
HELP: find-primary-key
{ $values
- { "specs" null }
- { "obj" object } }
-{ $description "" } ;
+ { "specs" "a sequence of sql-specs" }
+ { "seq" "a sequence of sql-specs" } }
+{ $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
+{ $notes "This is a low-level word." } ;
HELP: generator-bind
{ $description "" } ;
HELP: get-slot-named
{ $values
- { "name" null } { "obj" object }
- { "value" null } }
-{ $description "" } ;
+ { "name" "a slot name" } { "tuple" tuple }
+ { "value" "the value stored in the slot" } }
+{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
HELP: join-space
{ $values
{ $description "" } ;
HELP: no-sql-type
-{ $description "" } ;
+{ $values
+ { "type" "a sql type" } }
+{ $description "Throws an error containing a sql type that is unsupported or the result of a typo." } ;
HELP: normalize-spec
{ $values
{ "spec" null } }
{ $description "" } ;
-HELP: number>string*
-{ $values
- { "n/string" null }
- { "string" string } }
-{ $description "" } ;
-
HELP: offset-of-slot
{ $values
- { "string" string } { "obj" object }
- { "n" null } }
-{ $description "" } ;
-
-HELP: paren
-{ $values
- { "string" string }
- { "new-string" null } }
-{ $description "" } ;
+ { "string" string } { "tuple" tuple }
+ { "n" integer } }
+{ $description "Returns the offset of a tuple slot accessed by name." } ;
HELP: persistent-table
{ $values
{ $description "" } ;
HELP: unknown-modifier
-{ $description "" } ;
+{ $values { "modifier" string } }
+{ $description "Throws an error containing an unknown sql modifier." } ;
ARTICLE: "db.types" "Database types"
"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl
{ $subsection BLOB }
{ $subsection FACTOR-BLOB }
"Factor URLs:"
-{ $subsection URL }
-;
+{ $subsection URL } ;
ABOUT: "db.types"
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
-sequences continuations sequences.deep
+sequences continuations sequences.deep prettyprint
words namespaces slots slots.private classes mirrors
classes.tuple combinators calendar.format symbols
classes.singleton accessors quotations random ;
TUPLE: low-level-binding value ;
C: <low-level-binding> low-level-binding
-SINGLETON: +db-assigned-id+
-SINGLETON: +user-assigned-id+
-SINGLETON: +random-id+
+SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
-+foreign-id+ +has-many+ ;
++foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
++set-default+ ;
+
+: offset-of-slot ( string tuple -- n )
+ class superclasses [ "slots" word-prop ] map concat
+ slot-named offset>> ;
+
+: get-slot-named ( name tuple -- value )
+ tuck offset-of-slot slot ;
+
+: set-slot-named ( value name obj -- )
+ tuck offset-of-slot set-slot ;
+
+ERROR: not-persistent class ;
+
+: db-table ( class -- object )
+ dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
+
+: db-columns ( class -- object )
+ superclasses [ "db-columns" word-prop ] map concat ;
+
+: db-relations ( class -- object )
+ "db-relations" word-prop ;
+
+: find-primary-key ( specs -- seq )
+ [ primary-key>> ] filter ;
+
+: set-primary-key ( value tuple -- )
+ [
+ class db-columns
+ find-primary-key first slot-name>>
+ ] keep set-slot-named ;
: primary-key? ( spec -- ? )
primary-key>> +primary-key+? ;
-: db-assigned-id-spec? ( spec -- ? )
- primary-key>> +db-assigned-id+? ;
+: db-assigned-id-spec? ( specs -- ? )
+ [ primary-key>> +db-assigned-id+? ] contains? ;
-: assigned-id-spec? ( spec -- ? )
- primary-key>> +user-assigned-id+? ;
+: user-assigned-id-spec? ( specs -- ? )
+ [ primary-key>> +user-assigned-id+? ] contains? ;
: normalize-spec ( spec -- )
dup type>> dup +primary-key+? [
[ >>primary-key drop ] [ drop ] if*
] if ;
-: find-primary-key ( specs -- obj )
- [ primary-key>> ] find nip ;
+: db-assigned? ( class -- ? )
+ db-columns find-primary-key db-assigned-id-spec? ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
-ERROR: unknown-modifier ;
+
+: ?at ( obj assoc -- value/obj ? )
+ dupd at* [ [ nip ] [ drop ] if ] keep ;
+
+ERROR: unknown-modifier modifier ;
: lookup-modifier ( obj -- string )
{
{ [ dup array? ] [ unclip lookup-modifier swap compound ] }
- [ persistent-table at* [ unknown-modifier ] unless third ]
+ [ persistent-table ?at [ unknown-modifier ] unless third ]
} cond ;
-ERROR: no-sql-type ;
+ERROR: no-sql-type type ;
: (lookup-type) ( obj -- string )
- persistent-table at* [ no-sql-type ] unless ;
+ persistent-table ?at [ no-sql-type ] unless ;
: lookup-type ( obj -- string )
dup array? [
(lookup-type) second
] if ;
-: paren ( string -- new-string )
- "(" swap ")" 3append ;
+: modifiers ( spec -- string )
+ modifiers>> [ lookup-modifier ] map " " join
+ [ "" ] [ " " prepend ] if-empty ;
: join-space ( string1 string2 -- new-string )
" " swap 3append ;
-: modifiers ( spec -- string )
- modifiers>> [ lookup-modifier ] map " " join
- [ "" ] [ " " prepend ] if-empty ;
+: paren ( string -- new-string )
+ "(" swap ")" 3append ;
HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )
-: offset-of-slot ( string obj -- n )
- class superclasses [ "slots" word-prop ] map concat
- slot-named offset>> ;
-
-: get-slot-named ( name obj -- value )
- tuck offset-of-slot slot ;
-
-: set-slot-named ( value name obj -- )
- tuck offset-of-slot set-slot ;
+: >reference-string ( string pair -- string )
+ first2
+ [ [ unparse join-space ] [ db-columns ] bi ] dip
+ swap [ slot-name>> = ] with find nip
+ column-name>> paren append ;
M: string error. print ;
+: :error ( -- )
+ error get error. ;
+
: :s ( -- )
error-continuation get data>> stack. ;
drop "Bad stack effect declaration" ;
M: bad-escape summary drop "Bad escape code" ;
+
+M: bad-literal-tuple summary drop "Bad literal tuple" ;
{ $subsection define-consult }
"The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ;
-IN: delegate
ABOUT: { "delegate" "intro" }
protocol-consult keys ;
: lost-words ( protocol wordlist -- lost-words )
- >r protocol-words r> diff ;
+ [ protocol-words ] dip diff ;
: forget-old-definitions ( protocol new-wordlist -- )
[ drop protocol-users ] [ lost-words ] 2bi
+USING: help.markup help.syntax kernel math sequences
+quotations ;
IN: deques
-USING: help.markup help.syntax kernel ;
-
-ARTICLE: "deques" "Dequeues"
-"A deque is a data structure with constant-time insertion and removal of elements at both ends. Dequeue operations are defined in the " { $vocab-link "deques" } " vocabulary."
-$nl
-"Dequeues must be instances of a mixin class:"
-{ $subsection deque }
-"Dequeues must implement a protocol."
-$nl
-"Querying the deque:"
-{ $subsection peek-front }
-{ $subsection peek-back }
-{ $subsection deque-length }
-{ $subsection deque-member? }
-"Adding and removing elements:"
-{ $subsection push-front* }
-{ $subsection push-back* }
-{ $subsection pop-front* }
-{ $subsection pop-back* }
-{ $subsection clear-deque }
-"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":"
-{ $subsection delete-node }
-{ $subsection node-value }
-"Utility operations built in terms of the above:"
-{ $subsection deque-empty? }
-{ $subsection push-front }
-{ $subsection push-all-front }
-{ $subsection push-back }
-{ $subsection push-all-back }
-{ $subsection pop-front }
-{ $subsection pop-back }
-{ $subsection slurp-deque }
-"When using a deque as a queue, the convention is to queue elements with " { $link push-front } " and deque them with " { $link pop-back } "." ;
-
-ABOUT: "deques"
HELP: deque-empty?
-{ $values { "deque" { $link deque } } { "?" "a boolean" } }
+{ $values { "deque" deque } { "?" "a boolean" } }
{ $description "Returns true if a deque is empty." }
{ $notes "This operation is O(1)." } ;
+HELP: clear-deque
+{ $values
+ { "deque" deque } }
+{ $description "Removes all elements from a deque." } ;
+
+HELP: deque-length
+{ $values
+ { "deque" deque }
+ { "n" integer } }
+{ $description "Returns the number of elements in a deque." } ;
+
+HELP: deque-member?
+{ $values
+ { "value" object } { "deque" deque }
+ { "?" "a boolean" } }
+{ $description "Returns true if the " { $snippet "value" } " is found in the deque." } ;
+
HELP: push-front
{ $values { "obj" object } { "deque" deque } }
{ $description "Push the object onto the front of the deque." }
{ $description "Push the object onto the back of the deque and return the newly created node." }
{ $notes "This operation is O(1)." } ;
+HELP: push-all-back
+{ $values
+ { "seq" sequence } { "deque" deque } }
+{ $description "Pushes a sequence of elements onto the back of a deque." } ;
+
+HELP: push-all-front
+{ $values
+ { "seq" sequence } { "deque" deque } }
+{ $description "Pushes a sequence of elements onto the front of a deque." } ;
+
HELP: peek-front
{ $values { "deque" deque } { "obj" object } }
{ $description "Returns the object at the front of the deque." } ;
{ $values { "deque" deque } }
{ $description "Pop the object off the back of the deque." }
{ $notes "This operation is O(1)." } ;
+
+HELP: delete-node
+{ $values
+ { "node" object } { "deque" deque } }
+{ $description "Deletes the node from the deque." } ;
+
+HELP: deque
+{ $description "A data structure that has constant-time insertion and removal of elements at both ends." } ;
+
+HELP: node-value
+{ $values
+ { "node" object }
+ { "value" object } }
+{ $description "Accesses the value stored at a node." } ;
+
+HELP: slurp-deque
+{ $values
+ { "deque" deque } { "quot" quotation } }
+{ $description "Pops off the back element of the deque and calls the quotation in a loop until the deque is empty." } ;
+
+ARTICLE: "deques" "Deques"
+"The " { $vocab-link "deques" } " vocabulary implements the deque data structure which has constant-time insertion and removal of elements at both ends."
+$nl
+"Deques must be instances of a mixin class:"
+{ $subsection deque }
+"Deques must implement a protocol."
+$nl
+"Querying the deque:"
+{ $subsection peek-front }
+{ $subsection peek-back }
+{ $subsection deque-length }
+{ $subsection deque-member? }
+"Adding and removing elements:"
+{ $subsection push-front* }
+{ $subsection push-back* }
+{ $subsection pop-front* }
+{ $subsection pop-back* }
+{ $subsection clear-deque }
+"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":"
+{ $subsection delete-node }
+{ $subsection node-value }
+"Utility operations built in terms of the above:"
+{ $subsection deque-empty? }
+{ $subsection push-front }
+{ $subsection push-all-front }
+{ $subsection push-back }
+{ $subsection push-all-back }
+{ $subsection pop-front }
+{ $subsection pop-back }
+{ $subsection slurp-deque }
+"When using a deque as a queue, the convention is to queue elements with " { $link push-front } " and deque them with " { $link pop-back } "." ;
+
+ABOUT: "deques"
} ;
ARTICLE: "disjoint-sets" "Disjoint sets"
-"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set."
+"The " { $vocab-link "disjoint-sets" } " vocabulary implements the " { $emphasis "disjoint set" } " data structure (also known as " { $emphasis "union-find" } ", after the two main operations which it supports) that represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set."
$nl
"The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time."
$nl
--- /dev/null
+John Benediktsson
--- /dev/null
+USING: definitions io.launcher kernel math math.parser parser
+namespaces prettyprint editors make ;
+
+IN: editors.macvim
+
+: macvim-location ( file line -- )
+ drop
+ [ "open" , "-a" , "MacVim", , ] { } make
+ try-process ;
+
+[ macvim-location ] edit-hook set-global
+
+
--- /dev/null
+MacVim editor integration
--- /dev/null
+unportable
--- /dev/null
+John Benediktsson
--- /dev/null
+TextEdit editor integration
--- /dev/null
+unportable
--- /dev/null
+USING: definitions io.launcher kernel math math.parser parser
+namespaces prettyprint editors make ;
+
+IN: editors.textedit
+
+: textedit-location ( file line -- )
+ drop
+ [ "open" , "-a" , "TextEdit", , ] { } make
+ try-process ;
+
+[ textedit-location ] edit-hook set-global
+
+
--- /dev/null
+Slava Pestov
--- /dev/null
+Ad-hoc evaluation of strings of code
{ $values { "string" string } }
{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
-HELP: farkup ( string -- farkup )
+HELP: parse-farkup ( string -- farkup )
{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
-"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
+"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
{ $subsection heading1 }
{ $subsection heading2 }
{ $subsection heading3 }
{ $subsection inline-code }
{ $subsection paragraph }
{ $subsection list-item }
-{ $subsection list }
+{ $subsection unordered-list }
+{ $subsection ordered-list }
{ $subsection table }
{ $subsection table-row }
{ $subsection link }
{ $subsection convert-farkup }
{ $subsection write-farkup }
"The syntax tree of a piece of Farkup can also be inspected and modified:"
-{ $subsection farkup }
+{ $subsection parse-farkup }
{ $subsection (write-farkup) }
{ $subsection "farkup-ast" } ;
[ "Baz" ] [ "Baz" simple-link-title ] unit-test
[ ] [
- "abcd-*strong*\nasdifj\nweouh23ouh23"
- "paragraph" \ farkup rule parse drop
+ "abcd-*strong*\nasdifj\nweouh23ouh23" parse-farkup drop
] unit-test
[ ] [
- "abcd-*strong*\nasdifj\nweouh23ouh23\n"
- "paragraph" \ farkup rule parse drop
+ "abcd-*strong*\nasdifj\nweouh23ouh23\n" parse-farkup drop
] unit-test
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+[ "<ol><li>a-b</li></ol>" ] [ "#a-b" convert-farkup ] unit-test
+[ "<ol><li>foo</li></ol>" ] [ "#foo" convert-farkup ] unit-test
+[ "<ol><li>foo</li>\n</ol>" ] [ "#foo\n" convert-farkup ] unit-test
+[ "<ol><li>foo</li>\n<li>bar</li></ol>" ] [ "#foo\n#bar" convert-farkup ] unit-test
+[ "<ol><li>foo</li>\n<li>bar</li>\n</ol>" ] [ "#foo\n#bar\n" convert-farkup ] unit-test
+
+[ "<ol><li>foo</li>\n</ol><p>bar\n</p>" ] [ "#foo\nbar\n" convert-farkup ] unit-test
+
[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
-[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
-[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
-[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
-[ "<p>foo</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
+[ "<p>foo
\n</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
+[ "<p>foo
\n</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
+[ "<p>foo
\n</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
+[ "<p>foo
\n</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\nbar\n" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
-[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
+[ "<p>foo
\n</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
[ "" ] [ "" convert-farkup ] unit-test
] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
[
- "<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
+ "<p>Feature comparison:
\n</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
[
] unit-test
[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
+
+[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
+
+[ "<p><foo></p>" ] [ "<foo>" convert-farkup ] unit-test
+
+[ "<p>asdf\n<ul><li>lol</li>\n<li>haha</li></ul></p>" ] [ "asdf\n-lol\n-haha" convert-farkup ] unit-test
+
+[ "<p>asdf\n</p><ul><li>lol</li>\n<li>haha</li></ul>" ]
+ [ "asdf\n\n-lol\n-haha" convert-farkup ] unit-test
+
+[ "<hr/>" ] [ "___" convert-farkup ] unit-test
+[ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
+
+[ "<p>before:\n<pre><span class='OPERATOR'>{</span> <span class='DIGIT'>1</span> <span class='DIGIT'>2</span> <span class='DIGIT'>3</span> <span class='OPERATOR'>}</span> <span class='DIGIT'>1</span> tail\n</pre></p>" ]
+[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
+
+[ "<p><a href='Factor'>Factor</a>-rific!</p>" ]
+[ "[[Factor]]-rific!" convert-farkup ] unit-test
+
+[ "<p>[ factor { 1 2 3 }]</p>" ]
+[ "[ factor { 1 2 3 }]" convert-farkup ] unit-test
+
+[ "<p>paragraph\n<hr/></p>" ]
+[ "paragraph\n___" convert-farkup ] unit-test
+
+[ "<p>paragraph\n a ___ b</p>" ]
+[ "paragraph\n a ___ b" convert-farkup ] unit-test
+
+[ "\n<ul><li> a</li>\n</ul><hr/>" ]
+[ "\n- a\n___" convert-farkup ] unit-test
+
+[ "<p>hello_world how are you today?\n<ul><li> hello_world how are you today?</li></ul></p>" ]
+[ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators html.elements io io.streams.string
-kernel math memoize namespaces peg peg.ebnf prettyprint
-sequences sequences.deep strings xml.entities vectors splitting
-xmode.code2html ;
+USING: accessors arrays combinators html.elements io
+io.streams.string kernel math namespaces peg peg.ebnf
+sequences sequences.deep strings xml.entities
+vectors splitting xmode.code2html urls.encoding ;
IN: farkup
SYMBOL: relative-link-prefix
SYMBOL: disable-images?
SYMBOL: link-no-follow?
-TUPLE: heading1 obj ;
-TUPLE: heading2 obj ;
-TUPLE: heading3 obj ;
-TUPLE: heading4 obj ;
-TUPLE: strong obj ;
-TUPLE: emphasis obj ;
-TUPLE: superscript obj ;
-TUPLE: subscript obj ;
-TUPLE: inline-code obj ;
-TUPLE: paragraph obj ;
-TUPLE: list-item obj ;
-TUPLE: list obj ;
-TUPLE: table obj ;
-TUPLE: table-row obj ;
+TUPLE: heading1 child ;
+TUPLE: heading2 child ;
+TUPLE: heading3 child ;
+TUPLE: heading4 child ;
+TUPLE: strong child ;
+TUPLE: emphasis child ;
+TUPLE: superscript child ;
+TUPLE: subscript child ;
+TUPLE: inline-code child ;
+TUPLE: paragraph child ;
+TUPLE: list-item child ;
+TUPLE: unordered-list child ;
+TUPLE: ordered-list child ;
+TUPLE: table child ;
+TUPLE: table-row child ;
TUPLE: link href text ;
TUPLE: image href text ;
TUPLE: code mode string ;
+TUPLE: line ;
: absolute-url? ( string -- ? )
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
: simple-link-title ( string -- string' )
dup absolute-url? [ "/" last-split1 swap or ] unless ;
-EBNF: farkup
+EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
-2nl = nl nl
+whitespace = " " | "\t" | nl
heading1 = "=" (!("=" | nl).)+ "="
=> [[ second >string heading1 boa ]]
heading4 = "====" (!("=" | nl).)+ "===="
=> [[ second >string heading4 boa ]]
+heading = heading4 | heading3 | heading2 | heading1
+
+
+
strong = "*" (!("*" | nl).)+ "*"
=> [[ second >string strong boa ]]
inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]]
-escaped-char = "\" . => [[ second ]]
-
link-content = (!("|"|"]").)+
image-link = "[[image:" link-content "|" link-content "]]"
link = image-link | labelled-link | simple-link
-heading = heading4 | heading3 | heading2 | heading1
+escaped-char = "\" .
+ => [[ second 1string ]]
inline-tag = strong | emphasis | superscript | subscript | inline-code
| link | escaped-char
+
+
inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
-table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|'
+cell = (!(inline-delimiter | '|' | nl).)+
+ => [[ >string ]]
+
+table-column = (list | cell | inline-tag | inline-delimiter ) '|'
=> [[ first ]]
table-row = "|" (table-column)+
=> [[ second table-row boa ]]
table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
=> [[ table boa ]]
-paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
-paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
- | (paragraph-item nl)+ paragraph-item?
+text = (!(nl | code | heading | inline-delimiter | table ).)+
+ => [[ >string ]]
+
+paragraph-nl-item = nl (list | line)?
+paragraph-item = (table | code | text | inline-tag | inline-delimiter)+
+paragraph = ((paragraph-item paragraph-nl-item)+ nl+ => [[ first ]]
+ | (paragraph-item paragraph-nl-item)+ paragraph-item?
| paragraph-item)
=> [[ paragraph boa ]]
-
-list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
+
+
+list-item = (cell | inline-tag | inline-delimiter)*
+
+ordered-list-item = '#' list-item
+ => [[ second list-item boa ]]
+ordered-list = ((ordered-list-item nl)+ ordered-list-item? | ordered-list-item)
+ => [[ ordered-list boa ]]
+
+unordered-list-item = '-' list-item
=> [[ second list-item boa ]]
-list = ((list-item nl)+ list-item? | list-item)
- => [[ list boa ]]
+unordered-list = ((unordered-list-item nl)+ unordered-list-item? | unordered-list-item)
+ => [[ unordered-list boa ]]
+
+list = ordered-list | unordered-list
+
+
+line = '___'
+ => [[ drop line new ]]
-code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
+
+named-code
+ = '[' (!('{' | whitespace | '[').)+ '{' (!("}]").)+ "}]"
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
simple-code
= "[{" (!("}]").)+ "}]"
=> [[ second f swap code boa ]]
-stand-alone
- = (code | simple-code | heading | list | table | paragraph | nl)*
-;EBNF
+code = named-code | simple-code
+stand-alone
+ = (line | code | heading | list | table | paragraph | nl)*
+;EBNF
: invalid-url "javascript:alert('Invalid URL in farkup');" ;
: write-link ( href text -- )
escape-link
- [ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
+ [ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
[ write </a> ]
bi* ;
<strong> "Images are not allowed" write </strong>
] [
escape-link
- [ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
+ [ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
] if ;
: render-code ( string mode -- string' )
: <foo.> ( string -- ) <foo> write ;
: </foo.> ( string -- ) </foo> write ;
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
-M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
-M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
-M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
-M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
-M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
-M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
-M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
-M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
-M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
-M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
-M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
-M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
-M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
-M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
-M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
+M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
+M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
+M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
+M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
+M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
+M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
+M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
+M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
+M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
+M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
+M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ;
+M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
+M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
+M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
+M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
+M: line (write-farkup) drop <hr/> ;
M: table-row (write-farkup) ( obj -- )
- obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
-M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
-M: fixnum (write-farkup) ( obj -- ) write1 ;
-M: string (write-farkup) ( obj -- ) write ;
-M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
-M: f (write-farkup) ( obj -- ) drop ;
+ child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
+M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
+M: string (write-farkup) escape-string write ;
+M: vector (write-farkup) [ (write-farkup) ] each ;
+M: f (write-farkup) drop ;
: write-farkup ( string -- )
- farkup (write-farkup) ;
+ parse-farkup (write-farkup) ;
: convert-farkup ( string -- string' )
- farkup [ (write-farkup) ] with-string-writer ;
+ parse-farkup [ (write-farkup) ] with-string-writer ;
html.components\r
html.components\r
html.templates.chloe\r
-html.templates.chloe.syntax ;\r
+html.templates.chloe.syntax\r
+html.templates.chloe.compiler ;\r
IN: furnace.actions\r
\r
SYMBOL: params\r
</ul>\r
] unless-empty ;\r
\r
-CHLOE: validation-messages drop render-validation-messages ;\r
+CHLOE: validation-messages\r
+ drop [ render-validation-messages ] [code] ;\r
\r
TUPLE: action rest authorize init display validate submit ;\r
\r
\r
: revalidate-url ( -- url/f )\r
revalidate-url-key param\r
- dup [ >url [ same-host? ] keep and ] when ;\r
+ dup [ >url ensure-port [ same-host? ] keep and ] when ;\r
\r
: validation-failed ( -- * )\r
post-request? revalidate-url and [\r
begin-conversation\r
nested-forms-key param " " split harvest nested-forms cset\r
form get form cset\r
- <redirect>\r
+ <continue-conversation>\r
] [ <400> ] if*\r
exit-with ;\r
\r
--- /dev/null
+Slava Pestov
--- /dev/null
+Actions and form validation
USING: kernel sequences db.tuples alarms calendar db fry
furnace.db
furnace.cache
+furnace.asides
furnace.referrer
furnace.sessions
furnace.conversations
furnace.auth.login.permits ;
IN: furnace.alloy
-: <alloy> ( responder db params -- responder' )
- '[
- <conversations>
- <sessions>
- _ _ <db-persistence>
- <check-form-submissions>
- ] call ;
-
-: state-classes { session conversation permit } ; inline
+: state-classes { session aside conversation permit } ; inline
: init-furnace-tables ( -- )
state-classes ensure-tables
user ensure-table ;
+: <alloy> ( responder db params -- responder' )
+ [ [ init-furnace-tables ] with-db ]
+ [
+ [
+ <asides>
+ <conversations>
+ <sessions>
+ ] 2dip
+ <db-persistence>
+ <check-form-submissions>
+ ] 2bi ;
+
: start-expiring ( db params -- )
'[
_ _ [ state-classes [ expire-state ] each ] with-db
--- /dev/null
+Slava Pestov
--- /dev/null
+Convenience responder combines several features
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs kernel sequences accessors hashtables
+urls db.types db.tuples math.parser fry logging combinators
+html.templates.chloe.syntax
+http http.server http.server.filters http.server.redirection
+furnace
+furnace.cache
+furnace.sessions
+furnace.redirection ;
+IN: furnace.asides
+
+TUPLE: aside < server-state
+session method url post-data ;
+
+: <aside> ( id -- aside )
+ aside new-server-state ;
+
+aside "ASIDES" {
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "method" "METHOD" { VARCHAR 10 } }
+ { "url" "URL" URL }
+ { "post-data" "POST_DATA" FACTOR-BLOB }
+} define-persistent
+
+: aside-id-key "__a" ;
+
+TUPLE: asides < server-state-manager ;
+
+: <asides> ( responder -- responder' )
+ asides new-server-state-manager ;
+
+SYMBOL: aside-id
+
+: get-aside ( id -- aside )
+ dup [ aside get-state ] when check-session ;
+
+: request-aside-id ( request -- id )
+ aside-id-key swap request-params at string>number ;
+
+: request-aside ( request -- aside )
+ request-aside-id get-aside ;
+
+: set-aside ( aside -- )
+ [ id>> aside-id set ] when* ;
+
+: init-asides ( asides -- )
+ asides set
+ request get request-aside-id
+ get-aside
+ set-aside ;
+
+M: asides call-responder*
+ [ init-asides ] [ asides set ] [ call-next-method ] tri ;
+
+: touch-aside ( aside -- )
+ asides get touch-state ;
+
+: begin-aside ( url -- )
+ f <aside>
+ swap >>url
+ session get id>> >>session
+ request get method>> >>method
+ request get post-data>> >>post-data
+ [ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
+
+: end-aside-post ( aside -- response )
+ [ url>> ] [ post-data>> ] bi
+ request [
+ clone
+ swap >>post-data
+ over >>url
+ ] change
+ [ url set ] [ path>> split-path ] bi
+ asides get responder>> call-responder ;
+
+\ end-aside-post DEBUG add-input-logging
+
+ERROR: end-aside-in-get-error ;
+
+: move-on ( id -- response )
+ post-request? [ end-aside-in-get-error ] unless
+ dup method>> {
+ { "GET" [ url>> <redirect> ] }
+ { "HEAD" [ url>> <redirect> ] }
+ { "POST" [ end-aside-post ] }
+ } case ;
+
+: end-aside ( default -- response )
+ aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
+
+M: asides link-attr ( tag -- )
+ drop
+ "aside" optional-attr {
+ { "none" [ aside-id off ] }
+ { "begin" [ url get begin-aside ] }
+ { "current" [ ] }
+ { f [ ] }
+ } case ;
+
+M: asides modify-query ( query asides -- query' )
+ drop
+ aside-id get [
+ aside-id-key associate assoc-union
+ ] when* ;
+
+M: asides modify-form ( asides -- )
+ drop
+ aside-id get
+ aside-id-key
+ hidden-form-field ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Asides start an interaction which can return to the original page
USING: accessors assocs namespaces kernel sequences sets\r
destructors combinators fry logging\r
io.encodings.utf8 io.encodings.string io.binary random\r
-checksums checksums.sha2\r
+checksums checksums.sha2 urls\r
html.forms\r
http.server\r
http.server.filters\r
\r
GENERIC: login-required* ( description capabilities realm -- response )\r
\r
+GENERIC: user-registered ( user realm -- response )\r
+\r
+M: object user-registered 2drop URL" $realm" <redirect> ;\r
+\r
GENERIC: init-realm ( realm -- )\r
\r
GENERIC: logged-in-username ( realm -- username )\r
--- /dev/null
+Slava Pestov
--- /dev/null
+Basic client authentication
--- /dev/null
+Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs namespaces accessors db db.tuples urls
http.server.dispatchers
-furnace.conversations
+furnace.asides
furnace.actions
furnace.auth
furnace.auth.providers ;
--- /dev/null
+Allow users to deactivate their accounts
--- /dev/null
+Slava Pestov
USING: kernel accessors namespaces sequences assocs
validators urls html.forms http.server.dispatchers
furnace.auth
-furnace.actions
-furnace.conversations ;
+furnace.asides
+furnace.actions ;
IN: furnace.auth.features.edit-profile
: <edit-profile-action> ( -- action )
<t:title>Edit Profile</t:title>
- <t:form t:action="$realm/edit-profile">
+ <t:form t:action="$realm/edit-profile" autocomplete="off">
<table>
</table>
<p>
- <input type="submit" value="Update" />
+ <button>Update</button>
<t:validation-messages />
</p>
--- /dev/null
+Allow users to edit account info
--- /dev/null
+Slava Pestov
</table>
- <input type="submit" value="Recover password" />
+ <button>Recover password</button>
</t:form>
</table>
<p>
- <input type="submit" value="Set password" />
+ <button>Set password</button>
<t:validation-messages />
</p>
[ username>> "username" set-query-param ]
[ ticket>> "ticket" set-query-param ]
bi
- adjust-url relative-to-request ;
+ adjust-url ;
: password-email ( user -- email )
<email>
--- /dev/null
+Allow users to receive a new password
--- /dev/null
+Slava Pestov
<t:title>New User Registration</t:title>
- <t:form t:action="register">
+ <t:form t:action="register" autocomplete="off">
<table>
<p>
- <input type="submit" value="Register" />
+ <button>Register</button>
<t:validation-messages />
</p>
users new-user [ user-exists ] unless*
realm get init-user-profile
-
- URL" $realm" <redirect>
+ realm get user-registered
] >>submit
<auth-boilerplate>
<secure-realm-only> ;
--- /dev/null
+Allow new users to register from the login page
--- /dev/null
+Slava Pestov
http http.server http.server.dispatchers\r
furnace\r
furnace.auth\r
+furnace.asides\r
furnace.actions\r
furnace.sessions\r
furnace.utilities\r
[ logout ] >>submit ;\r
\r
M: login-realm login-required* ( description capabilities login -- response )\r
- begin-aside\r
- [ description cset ] [ capabilities cset ] [ drop ] tri*\r
- URL" $realm/login" >secure-url <redirect> ;\r
+ begin-conversation\r
+ [ description cset ] [ capabilities cset ] [ secure>> ] tri*\r
+ [\r
+ url get >secure-url begin-aside\r
+ URL" $realm/login" >secure-url <continue-conversation>\r
+ ] [\r
+ url get begin-aside\r
+ URL" $realm/login" <continue-conversation>\r
+ ] if ;\r
+\r
+M: login-realm user-registered ( user realm -- )\r
+ drop successful-login ;\r
\r
: <login-realm> ( responder name -- auth )\r
login-realm new-realm\r
<p>
- <input type="submit" value="Log in" />
+ <button>Log in</button>
<t:validation-messages />
</p>
--- /dev/null
+Slava Pestov
--- /dev/null
+Login page authentication
--- /dev/null
+Look up user credentials in an assoc object
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+Look up user credentials in the database
--- /dev/null
+Refuse all authentication requests
--- /dev/null
+Pluggable authentication backends
--- /dev/null
+Authentication
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
[ ] >>init ;
: wrap-boilerplate? ( response -- ? )
- {
- [ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ]
- [ content-type>> "text/html" = ]
- } 1&& ;
+ { [ code>> 200 = ] [ content-type>> "text/html" = ] } 1&& ;
M:: boilerplate call-responder* ( path responder -- )
begin-form
path responder call-next-method
responder init>> call
- dup content-type>> "text/html" = [
+ dup wrap-boilerplate? [
clone [| body |
[
body
--- /dev/null
+Adding common headers/footers to pages
--- /dev/null
+Slava Pestov
--- /dev/null
+Shared code for storing session state in the database
--- /dev/null
+Slava Pestov
<url>
swap parse-query-attr >>query
-rot a-url-path >>path
- adjust-url relative-to-request
+ adjust-url
] if ;
: compile-a-url ( tag -- )
{
- [ "href" required-attr compile-attr ]
+ [ "href" optional-attr compile-attr ]
[ "rest" optional-attr compile-attr ]
[ "query" optional-attr compile-attr ]
[ "value" optional-attr compile-attr ]
attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
- [ compile-link-attrs ] [ compile-a-url ] bi
- [ <a =href a> ] [code] ;
+ [ <a ] [code]
+ [ non-chloe-attrs-only compile-attrs ]
+ [ compile-link-attrs ]
+ [ compile-a-url ]
+ tri
+ [ =href a> ] [code] ;
: a-end-tag ( tag -- )
drop [ </a> ] [code] ;
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
] compile-with-scope ;
+CHLOE: base
+ compile-a-url [ <base =href base/> ] [code] ;
+
: compile-hidden-form-fields ( for -- )
'[
- _ [ "," split [ hidden render ] each ] when*
- nested-forms get " " join f like nested-forms-key hidden-form-field
- [ modify-form ] each-responder
+ <div "display: none;" =style div>
+ _ [ "," split [ hidden render ] each ] when*
+ nested-forms get " " join f like nested-forms-key hidden-form-field
+ [ modify-form ] each-responder
+ </div>
] [code] ;
: compile-form-attrs ( method action attrs -- )
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
- <button type="submit"></button>
+ <div style="display: inline;"><button type="submit"></button></div>
</t:form>
;
button-tag-markup string>xml body>>
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
- [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
- [ [ children>> ] dip "button" tag-named (>>children) ]
+ [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]
+ [ [ children>> ] dip "button" deep-tag-named (>>children) ]
[ nip ]
} 2cleave compile-chloe-tag ;
--- /dev/null
+Furnace-specific Chloe tags
--- /dev/null
+Slava Pestov
furnace.redirection ;
IN: furnace.conversations
-TUPLE: conversation < scope
-session
-method url post-data ;
+TUPLE: conversation < scope session ;
-: <conversation> ( id -- aside )
+: <conversation> ( id -- conversation )
conversation new-server-state ;
conversation "CONVERSATIONS" {
{ "session" "SESSION" BIG-INTEGER +not-null+ }
- { "method" "METHOD" { VARCHAR 10 } }
- { "url" "URL" URL }
- { "post-data" "POST_DATA" FACTOR-BLOB }
} define-persistent
: conversation-id-key "__c" ;
conversation get scope-change ; inline
: get-conversation ( id -- conversation )
- dup [ conversation get-state ] when
- dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
+ dup [ conversation get-state ] when check-session ;
: request-conversation-id ( request -- id )
conversation-id-key swap request-params at string>number ;
: add-conversation ( conversation -- )
[ touch-conversation ] [ insert-tuple ] bi ;
-: begin-conversation* ( -- conversation )
- empty-conversastion dup add-conversation ;
-
: begin-conversation ( -- )
conversation get [
- begin-conversation*
- set-conversation
+ empty-conversastion
+ [ add-conversation ]
+ [ set-conversation ] bi
] unless ;
: end-conversation ( -- )
conversation off
conversation-id off ;
-: <conversation-redirect> ( url seq -- response )
- begin-conversation
- [ [ get ] keep cset ] each
+: <continue-conversation> ( url -- response )
+ conversation-id get
+ conversation-id-key
+ set-query-param
<redirect> ;
: restore-conversation ( seq -- )
bi
] [ 2drop ] if ;
-: begin-aside ( -- )
- begin-conversation
- conversation get
- request get
- [ method>> >>method ]
- [ url>> >>url ]
- [ post-data>> >>post-data ]
- tri
- touch-conversation ;
-
-: end-aside-post ( aside -- response )
- request [
- clone
- over post-data>> >>post-data
- over url>> >>url
- ] change
- [ url>> url set ]
- [ url>> path>> split-path ] bi
- conversations get responder>> call-responder ;
-
-\ end-aside-post DEBUG add-input-logging
-
-ERROR: end-aside-in-get-error ;
-
-: move-on ( id -- response )
- post-request? [ end-aside-in-get-error ] unless
- dup method>> {
- { "GET" [ url>> <redirect> ] }
- { "HEAD" [ url>> <redirect> ] }
- { "POST" [ end-aside-post ] }
- } case ;
-
-: get-aside ( id -- conversation )
- get-conversation dup [ dup method>> [ drop f ] unless ] when ;
-
-: end-aside* ( url id -- response )
- get-aside [ move-on ] [ <redirect> ] ?if ;
-
-: end-aside ( default -- response )
- conversation-id get
- end-conversation
- end-aside* ;
-
-M: conversations link-attr ( tag -- )
- drop
- "aside" optional-attr {
- { "none" [ conversation-id off ] }
- { "begin" [ begin-aside ] }
- { "current" [ ] }
- { f [ ] }
- } case ;
-
-M: conversations modify-query ( query conversations -- query' )
- drop
- conversation-id get [
- conversation-id-key associate assoc-union
- ] when* ;
-
M: conversations modify-form ( conversations -- )
drop
conversation-id get
--- /dev/null
+Retaining state between form submissions and redirects
--- /dev/null
+Slava Pestov
--- /dev/null
+Database connection pooling
IN: furnace.tests
-USING: http.server.dispatchers http.server.responses
+USING: http http.server.dispatchers http.server.responses
http.server furnace tools.test kernel namespaces accessors
-io.streams.string ;
+io.streams.string urls ;
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
[ "<input type='hidden' name='foo' value='&&&'/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test
+
+[ f ] [ <request> request [ referrer ] with-variable ] unit-test
+
+[ t ] [ URL" http://foo" dup url [ same-host? ] with-variable ] unit-test
+
+[ f ] [ f URL" http://foo" url [ same-host? ] with-variable ] unit-test
vocabs.loader accessors strings combinators arrays
continuations present fry
urls html.elements
-http http.server http.server.redirection ;
+http http.server http.server.redirection http.server.remapping ;
IN: furnace
: nested-responders ( -- seq )
M: object modify-query drop ;
+GENERIC: modify-redirect-query ( query responder -- query' )
+
+M: object modify-redirect-query drop ;
+
GENERIC: adjust-url ( url -- url' )
M: url adjust-url
M: string adjust-url ;
+GENERIC: adjust-redirect-url ( url -- url' )
+
+M: url adjust-redirect-url
+ adjust-url
+ [ [ modify-redirect-query ] each-responder ] change-query ;
+
+M: string adjust-redirect-url ;
+
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
] }
} case ;
-: referrer ( -- referrer )
+: referrer ( -- referrer/f )
#! Typo is intentional, its in the HTTP spec!
- "referer" request get header>> at >url ;
+ "referer" request get header>> at
+ dup [ >url ensure-port [ remap-port ] change-port ] when ;
: user-agent ( -- user-agent )
"user-agent" request get header>> at "" or ;
: same-host? ( url -- ? )
- url get
- [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
+ dup [
+ url get [
+ [ protocol>> ]
+ [ host>> ]
+ [ port>> remap-port ]
+ tri 3array
+ ] bi@ =
+ ] when ;
: cookie-client-state ( key request -- value/f )
swap get-cookie dup [ value>> ] when ;
--- /dev/null
+Sending JSON responses to the client
--- /dev/null
+Slava Pestov
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators namespaces fry
-io.servers.connection urls http http.server
-http.server.redirection http.server.responses
-http.server.filters furnace ;
+USING: kernel accessors combinators namespaces fry urls http
+http.server http.server.redirection http.server.responses
+http.server.remapping http.server.filters furnace ;
IN: furnace.redirection
: <redirect> ( url -- response )
- adjust-url request get method>> {
+ adjust-redirect-url request get method>> {
{ "GET" [ <temporary-redirect> ] }
{ "HEAD" [ <temporary-redirect> ] }
{ "POST" [ <permanent-redirect> ] }
: >secure-url ( url -- url' )
clone
"https" >>protocol
- secure-port >>port ;
+ secure-http-port >>port ;
: <secure-redirect> ( url -- response )
>secure-url <redirect> ;
--- /dev/null
+Various forms of URL redirection
--- /dev/null
+Slava Pestov
[ 2drop 403 "Bad referrer" <trivial-response> ] if ;
: <check-form-submissions> ( responder -- responder' )
- [ same-host? post-request? not or ] <referrer-check> ;
+ [ post-request? [ same-host? ] [ drop t ] if ] <referrer-check> ;
--- /dev/null
+Referrer checking
--- /dev/null
+Slava Pestov
--- /dev/null
+Shared code for storing scopes in the database
Doug Coleman
+Slava Pestov
sessions set
request-session [ begin-session ] unless*
existing-session put-session-cookie ;
+
+SLOT: session
+
+: check-session ( state/f -- state/f )
+ dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
--- /dev/null
+Session management
--- /dev/null
+Slava Pestov
--- /dev/null
+Atom feed syndication
: process-entries ( seq -- seq' )
20 short head-slice [
>entry clone
- [ adjust-url relative-to-request ] change-url
+ [ adjust-url ] change-url
] map ;
: <feed-content> ( body -- response )
feed new
_
[ title>> call >>title ]
- [ url>> call adjust-url relative-to-request >>url ]
+ [ url>> call adjust-url >>url ]
[ entries>> call process-entries >>entries ]
tri
<feed-content>
--- /dev/null
+Slava Pestov
--- /dev/null
+Odds and ends
--- /dev/null
+Chris Double
+Doug Coleman
+Eduardo Cavazos
+Slava Pestov
--- /dev/null
+Generalized stack shufflers and combinators to arbitrary numbers of inputs
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser-combinators regexp lists sequences kernel
+USING: parser-combinators parser-combinators.regexp lists sequences kernel
promises strings unicode.case ;
IN: globs
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
[ ] produce nip ;
+
+: slurp-heap ( heap quot: ( elt -- ) -- )
+ over heap-empty? [ 2drop ] [
+ [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
+ ] if ; inline recursive
{ "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The parser prints warnings when vocabularies shadow words from other vocabularies; see " { $link "vocabulary-search-shadow" } ". The " { $vocab-link "qualified" } " vocabulary implements qualified naming, which can be used to resolve ambiguities." }
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
- { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by ``multiple inheritance'' in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, method precedence is undefined for objects that are instances of both classes. See " { $link "method-order" } " for details." }
+ { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by ``multiple inheritance'' in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
{ "Performance-sensitive code should have a static stack effect so that it can be compiled by the optimizing word compiler, which generates more efficient code than the non-optimizing quotation compiler. See " { $link "inference" } " and " { $link "compiler" } "."
$nl
"This means that methods defined on performance sensitive, frequently-called core generic words such as " { $link nth } " should have static stack effects which are consistent with each other, since a generic word will only have a static stack effect if all methods do."
$nl
- "Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
- { $code "\"inference\" test" }
+ "Unit tests for the " { $vocab-link "stack-checker" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
+ { $code "\"stack-checker\" test" }
"In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
USING: help help.markup help.syntax help.definitions help.topics
namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
-strings sbufs vectors byte-arrays
-quotations io.streams.byte-array
-classes.builtin parser lexer classes.predicate classes.union
-classes.intersection classes.singleton classes.tuple ;
+strings sbufs vectors byte-arrays quotations
+io.streams.byte-array classes.builtin parser lexer
+classes.predicate classes.union classes.intersection
+classes.singleton classes.tuple tools.vocabs.browser ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
ARTICLE: "collections" "Collections"
{ $heading "Sequences" }
{ $subsection "sequences" }
+{ $subsection "virtual-sequences" }
{ $subsection "namespaces-make" }
"Fixed-length sequences:"
{ $subsection "arrays" }
{ $subsection "heaps" }
{ $subsection "graphs" }
{ $subsection "buffers" }
-"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-sets" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
+"There are also many other vocabularies tagged " { $link T{ vocab-tag { name "collections" } } } " in the library." ;
USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;
{ $subsection "program-org" }
{ $subsection "numbers" }
{ $subsection "collections" }
-{ $subsection "io" } ;
+{ $subsection "io" }
+"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
ARTICLE: "handbook-environment-reference" "Environment reference"
{ $subsection "prettyprint" }
--- /dev/null
+IN: help.html.tests
+USING: html.streams classes.predicate help.topics help.markup
+io.streams.string accessors prettyprint kernel tools.test ;
+
+[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
+io.files html.streams html.elements html.components help kernel
+assocs sequences make words accessors arrays help.topics vocabs
+tools.vocabs tools.vocabs.browser namespaces prettyprint io
+vocabs.loader serialize fry memoize unicode.case math.order
+sorting ;
IN: help.html
+: escape-char ( ch -- )
+ dup H{
+ { CHAR: " "__quote__" }
+ { CHAR: * "__star__" }
+ { CHAR: : "__colon__" }
+ { CHAR: < "__lt__" }
+ { CHAR: > "__gt__" }
+ { CHAR: ? "__question__" }
+ { CHAR: \\ "__backslash__" }
+ { CHAR: | "__pipe__" }
+ { CHAR: _ "__underscore__" }
+ { CHAR: / "__slash__" }
+ { CHAR: \\ "__backslash__" }
+ { CHAR: , "__comma__" }
+ } at [ % ] [ , ] ?if ;
+: escape-filename ( string -- filename )
+ [ [ escape-char ] each ] "" make ;
+
+GENERIC: topic>filename* ( topic -- name prefix )
+
+M: word topic>filename*
+ dup vocabulary>> [
+ [ name>> ] [ vocabulary>> ] bi 2array "word"
+ ] [ drop f f ] if ;
+
+M: link topic>filename* name>> dup [ "article" ] [ topic>filename* ] if ;
+M: word-link topic>filename* name>> topic>filename* ;
+M: vocab-spec topic>filename* vocab-name "vocab" ;
+M: vocab-tag topic>filename* name>> "tag" ;
+M: vocab-author topic>filename* name>> "author" ;
+M: f topic>filename* drop \ f topic>filename* ;
+
+: topic>filename ( topic -- filename )
+ topic>filename* dup [
+ [
+ % "-" %
+ dup array?
+ [ [ escape-filename ] map "," join ]
+ [ escape-filename ]
+ if % ".html" %
+ ] "" make
+ ] [ 2drop f ] if ;
+
+M: topic browser-link-href topic>filename ;
+
+: help-stylesheet ( -- )
+ "resource:basis/help/html/stylesheet.css" ascii file-contents write ;
+
+: help>html ( topic -- )
+ dup topic>filename utf8 [
+ dup article-title
+ [ <style> help-stylesheet </style> ]
+ [ [ help ] with-html-writer ] simple-page
+ ] with-file-writer ;
+
+: all-vocabs-really ( -- seq )
+ #! Hack.
+ all-vocabs values concat
+ vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
+
+: all-topics ( -- topics )
+ [
+ articles get keys [ >link ] map %
+ all-words [ >link ] map %
+ all-authors [ <vocab-author> ] map %
+ all-tags [ <vocab-tag> ] map %
+ all-vocabs-really %
+ ] { } make ;
+
+: serialize-index ( index file -- )
+ [ [ [ topic>filename ] dip ] { } assoc-map-as object>bytes ] dip
+ binary set-file-contents ;
+
+: generate-indices ( -- )
+ articles get keys [ [ >link ] [ article-title ] bi ] { } map>assoc "articles.idx" serialize-index
+ all-words [ dup name>> ] { } map>assoc "words.idx" serialize-index
+ all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
+
+: generate-help-files ( -- )
+ all-topics [ help>html ] each ;
+
+: generate-help ( -- )
+ { "resource:core" "resource:basis" "resource:extra" } vocab-roots [
+ load-everything
+
+ "/tmp/docs/" make-directory
+
+ "/tmp/docs/" [
+ generate-indices
+ generate-help-files
+ ] with-directory
+ ] with-variable ;
+
+MEMO: load-index ( name -- index )
+ binary file-contents bytes>object ;
+
+TUPLE: result title href ;
+
+M: result link-title title>> ;
+
+M: result link-href href>> ;
+
+: offline-apropos ( string index -- results )
+ load-index swap >lower
+ '[ [ drop _ ] dip >lower subseq? ] assoc-filter
+ [ swap result boa ] { } assoc>map
+ [ [ title>> ] compare ] sort ;
+
+: article-apropos ( string -- results )
+ "articles.idx" offline-apropos ;
+
+: word-apropos ( string -- results )
+ "words.idx" offline-apropos ;
+
+: vocab-apropos ( string -- results )
+ "vocabs.idx" offline-apropos ;
--- /dev/null
+a:link { text-decoration: none; color: #00004c; }
+a:visited { text-decoration: none; color: #00004c; }
+a:active { text-decoration: none; color: #00004c; }
+a:hover { text-decoration: underline; color: #00004c; }
: vocab-exists? ( name -- ? )
dup vocab swap "all-vocabs" get member? or ;
-: check-modules ( word element -- )
- nip \ $vocab-link swap elements [
+: check-modules ( element -- )
+ \ $vocab-link swap elements [
second
- vocab-exists? [ "Missing vocabulary" throw ] unless
+ vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
] each ;
: check-rendering ( word element -- )
2dup check-examples
2dup check-values
2dup check-see-also
- 2dup check-modules
+ 2dup nip check-modules
2dup drop check-rendering
] assert-depth 2drop
] check-something
: check-article ( article -- )
[
- [ dup check-rendering ] assert-depth drop
+ dup article-content [
+ 2dup check-modules check-rendering
+ ] assert-depth 2drop
] check-something ;
+: files>vocabs ( -- assoc )
+ vocabs
+ [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
+ [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
+ bi assoc-union ;
+
: group-articles ( -- assoc )
articles get keys
- vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
+ files>vocabs
H{ } clone [
'[
dup >link where dup
[ strong-style get print-element* ] ($span) ;
: $url ( children -- )
- [ url-style get print-element* ] ($span) ;
+ [
+ dup first href associate url-style get assoc-union
+ print-element*
+ ] ($span) ;
: $nl ( children -- )
nl nl drop ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string kernel strings
+urls lcs inspector present io ;
+IN: html.components
+
+HELP: checkbox
+{ $class-description "Checkbox components render a boolean value. The " { $slot "label" } " slot must be set to a string." } ;
+
+HELP: choice
+{ $class-description "Choice components render a popup menu or list box with either single or multiple selection."
+$nl
+"The " { $slot "multiple" } " slot determines whether multiple elements may be selected at once; if this is set to a true value, then the component value must be a sequence of strings, otherwise it must be a single string."
+$nl
+"The " { $slot "size" } " slot determines the number of items visible at one time; if neither this nor " { $slot "multiple" } " is set, the component is rendered as a popup menu rather than a list."
+$nl
+"The " { $slot "choices" } " slot determines all possible choices which may be selected. It names a value, rather than storing the choices directly." } ;
+
+HELP: code
+{ $class-description "Code components render string value with the " { $vocab-link "xmode.code2html" } " syntax highlighting vocabulary. The " { $slot "mode" } " slot names a value holding an XMode mode name." } ;
+
+HELP: field
+{ $class-description "Field components display a one-line editor for a string value. The " { $slot "size" } " slot determines the maximum displayed width of the field." } ;
+
+HELP: password
+{ $class-description "Password field components display a one-line editor which obscures the user's input. The " { $slot "size" } " slot determines the maximum displayed width of the field. Unlike other components, on failed validation, the contents of a password field are not sent back to the client. This is a security feature, intended to avoid revealing the password to potential snoopers who use the " { $strong "View Source" } " feature." } ;
+
+HELP: textarea
+{ $class-description "Text area components display a multi-line editor for a string value. The " { $slot "rows" } " and " { $slot "cols" } " properties determine the size of the text area." } ;
+
+HELP: link
+{ $description "Link components render a link to an object stored at a value, with the link title and URL determined by the " { $link link-title } " and " { $link link-href } " generic words. The optional " { $slot "target" } " slot is a target frame to open the link in." } ;
+
+HELP: link-title
+{ $values { "obj" object } { "string" string } }
+{ $description "Outputs the title to render for a link to the object." } ;
+
+HELP: link-href
+{ $values { "obj" object } { "url" "a " { $link string } " or " { $link url } } }
+{ $description "Outputs the URL to render for a link to the object." } ;
+
+ARTICLE: "html.components.links" "Link components"
+"Link components render a link to an object."
+{ $subsection link }
+"The link title and URL are determined by passing the object to a pair of generic words:"
+{ $subsection link-title }
+{ $subsection link-href }
+"The generic words provide methods on the " { $link string } " and " { $link url } " classes which treat the object as a URL. New methods can be defined for rendering links to custom data types." ;
+
+HELP: comparison
+{ $description "Comparison components render diffs output by the " { $link diff } " word." } ;
+
+HELP: farkup
+{ $description "Farkup components render " { $link "farkup" } "." } ;
+
+HELP: hidden
+{ $description "Hidden components render as a hidden form field. For example, a page for editing a weblog post might contain a hidden field with the post ID." } ;
+
+HELP: html
+{ $description "HTML components render HTML verbatim, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
+
+HELP: inspector
+{ $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ;
+
+HELP: label
+{ $description "Label components render an object as a piece of text by passing it to the " { $link present } " word." } ;
+
+HELP: render
+{ $values { "name" "a value name" } { "renderer" "a component renderer" } }
+{ $description "Renders an HTML component to the " { $link output-stream } "." } ;
+
+HELP: render*
+{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } }
+{ $contract "Renders an HTML component to the " { $link output-stream } "." } ;
+
+ARTICLE: "html.components" "HTML components"
+"The " { $vocab-link "html.components" } " vocabulary provides various HTML form components."
+$nl
+"Most web applications can use the " { $vocab-link "html.templates.chloe" } " templating framework instead of using this vocabulary directly. Where maximum flexibility is required, this vocabulary can be used together with the " { $vocab-link "html.templates.fhtml" } " templating framework."
+$nl
+"Rendering components:"
+{ $subsection render }
+"Components render a named value, and the name of the value is passed in every time the component is rendered, rather than being associated with the component itself. Named values are taken from the current HTML form (see " { $link "html.forms" } ")."
+$nl
+"Component come in two varieties: singletons and tuples. Components with no configuration are singletons; they do not have to instantiated, rather the class word represents the component. Tuple components have to be instantiated and offer configuration options."
+$nl
+"Singleton components:"
+{ $subsection hidden }
+{ $subsection link }
+{ $subsection inspector }
+{ $subsection comparison }
+{ $subsection html }
+"Tuple components:"
+{ $subsection field }
+{ $subsection password }
+{ $subsection textarea }
+{ $subsection choice }
+{ $subsection checkbox }
+{ $subsection code }
+{ $subsection farkup }
+"Creating custom components:"
+{ $subsection render* }
+"Custom components can emit HTML using the " { $vocab-link "html.elements" } " vocabulary." ;
+
+ABOUT: "html.components"
[ ] [ link-test "link" set-value ] unit-test
[ "<a href='http://www.apple.com/foo&bar'><Link Title></a>" ] [
- [ "link" link render ] with-string-writer
+ [ "link" link new render ] with-string-writer
] unit-test
[ ] [
[ t ] [
[ "object" inspector render ] with-string-writer
- [ "object" value [ describe ] with-html-stream ] with-string-writer
+ [ "object" value [ describe ] with-html-writer ] with-string-writer
=
] unit-test
html.elements html.streams html.forms ;
IN: html.components
-GENERIC: render* ( value name render -- )
+GENERIC: render* ( value name renderer -- )
: render ( name renderer -- )
prepare-value
choice new ;
: render-option ( text selected? -- )
- <option [ "true" =selected ] when option>
+ <option [ "selected" =selected ] when option>
present escape-string write
</option> ;
M: url link-title ;
M: url link-href ;
-SINGLETON: link
+TUPLE: link target ;
M: link render*
- 2drop
- <a dup link-href =href a>
+ nip
+ <a target>> [ =target ] when* dup link-href =href a>
link-title present escape-string write
</a> ;
[ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
! Farkup component
-TUPLE: farkup no-follow disable-images ;
+TUPLE: farkup no-follow disable-images parsed ;
+
+: <farkup> ( -- farkup )
+ farkup new ;
: string>boolean ( string -- boolean )
{
{ "true" [ t ] }
{ "false" [ f ] }
+ { f [ f ] }
} case ;
M: farkup render*
[
+ nip
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
- [ disable-images>> [ string>boolean disable-images? set ] when* ] bi
- drop string-lines "\n" join write-farkup
+ [ disable-images>> [ string>boolean disable-images? set ] when* ]
+ [ parsed>> string>boolean [ (write-farkup) ] [ write-farkup ] if ]
+ tri
] with-scope ;
! Inspector component
SINGLETON: inspector
M: inspector render*
- 2drop [ describe ] with-html-stream ;
+ 2drop [ describe ] with-html-writer ;
! Diff component
SINGLETON: comparison
--- /dev/null
+HTML components for form rendering and validation
--- /dev/null
+IN: html.elements
+USING: help.markup help.syntax io present ;
+
+ARTICLE: "html.elements" "HTML elements"
+"The " { $vocab-link "html.elements" } " vocabulary provides words for writing HTML tags to the " { $link output-stream } " with a familiar look and feel in the code."
+$nl
+"HTML tags can be used in a number of different ways. The simplest is a tag with no attributes:"
+{ $code "<p> \"someoutput\" write </p>" }
+"In the above, " { $link <p> } " will output the opening tag with no attributes. and " { $link </p> } " will output the closing tag."
+{ $code "<p \"red\" =class p> \"someoutput\" write </p>" }
+"This time the opening tag does not have the '>'. Any attribute words used between the calls to " { $link <p } " and " { $link p> } " will write an attribute whose value is the top of the stack. Attribute values can be any object supported by the " { $link present } " word."
+$nl
+"Values for attributes can be used directly without any stack operations. Assuming we have a string on the stack, all three of the below will output a link:"
+{ $code "<a =href a> \"Click me\" write </a>" }
+{ $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
+{ $code "<a [ \"http://\" % % ] \"\" make =href a> \"click\" write </a>" }
+"Tags that have no ``closing'' equivalent have a trailing " { $snippet "tag/>" } " form:"
+{ $code "<input \"text\" =type \"name\" =name 20 =size input/>" }
+"For the full list of HTML tags and attributes, consult the word list for the " { $vocab-link "html.elements" } " vocabulary. In addition to HTML tag and attribute words, a few utilities are provided."
+$nl
+"Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
+{ $subsection write-html }
+{ $subsection print-html }
+"Writing some common HTML patterns:"
+{ $subsection xhtml-preamble }
+{ $subsection simple-page }
+{ $subsection render-error } ;
+
+ABOUT: "html.elements"
IN: html.elements
-! These words are used to provide a means of writing
-! formatted HTML to standard output with a familiar 'html' look
-! and feel in the code.
-!
-! HTML tags can be used in a number of different ways. The highest
-! level involves a similar syntax to HTML:
-!
-! <p> "someoutput" write </p>
-!
-! <p> will output the opening tag and </p> will output the closing
-! tag with no attributes.
-!
-! <p "red" =class p> "someoutput" write </p>
-!
-! This time the opening tag does not have the '>'. It pushes
-! a namespace on the stack to hold the attributes and values.
-! Any attribute words used will store the attribute and values
-! in that namespace. Before the attribute word should come the
-! value of that attribute.
-! The finishing word will print out the operning tag including
-! attributes.
-! Any writes after this will appear after the opening tag.
-!
-! Values for attributes can be used directly without any stack
-! operations:
-!
-! (url -- )
-! <a =href a> "Click me" write </a>
-!
-! (url -- )
-! <a "http://" prepend =href a> "click" write </a>
-!
-! (url -- )
-! <a [ "http://" % % ] "" make =href a> "click" write </a>
-!
-! Tags that have no 'closing' equivalent have a trailing tag/> form:
-!
-! <input "text" =type "name" =name "20" =size input/>
-
-: elements-vocab ( -- vocab-name ) "html.elements" ;
-
SYMBOL: html
: write-html ( str -- )
<<
+: elements-vocab ( -- vocab-name ) "html.elements" ;
+
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
[
"input"
"br"
+ "hr"
"link"
"img"
+ "base"
] [ define-open-html-word ] each
! Define some attributes
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple" "checked"
"summary" "cellspacing" "align" "scope" "abbr"
- "nofollow" "alt"
+ "nofollow" "alt" "target"
] [ define-attribute-word ] each
>>
: xhtml-preamble ( -- )
"<?xml version=\"1.0\"?>" write-html
- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
-: simple-page ( title quot -- )
+: simple-page ( title head-quot body-quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
+ spin
xhtml-preamble
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
- <head> <title> swap write </title> </head>
+ <head>
+ <title> write </title>
+ call
+ </head>
<body> call </body>
</html> ; inline
--- /dev/null
+Rendering HTML with a familiar look and feel
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: html.forms
+USING: help.markup help.syntax strings quotations kernel assocs ;
+
+HELP: <form>
+{ $values { "form" form } }
+{ $description "Creates a new form. Usually " { $link with-form } " is used instead." } ;
+
+HELP: form
+{ $var-description "Variable holding current form. Bound by " { $link with-form } ", " { $link nest-form } " and " { $link begin-form } "." }
+{ $class-description "The class of HTML forms. New instances are created by " { $link <form> } "." } ;
+
+HELP: with-form
+{ $values { "name" string } { "quot" quotation } }
+{ $description "Runs the quotation in a new dynamic scope with the " { $link form } " variable rebound to the form stored in the value named " { $snippet "name" } "." } ;
+
+HELP: nest-form
+{ $values { "name" string } { "quot" quotation } }
+{ $description "Runs the quotation in a new dynamic scope with the " { $link form } " variable rebound to a new form, which is subsequently stored in the value named " { $snippet "name" } "." }
+{ $examples
+ "The " { $vocab-link "webapps.pastebin" } " uses a form to display pastes; inside this form it nests another form for creating annotations, and fills in some default values for new annotations:"
+ { $code
+ "<page-action>"
+ " ["
+ " validate-integer-id"
+ " \"id\" value paste from-object"
+ ""
+ " \"id\" value"
+ " \"new-annotation\" ["
+ " \"parent\" set-value"
+ " mode-names \"modes\" set-value"
+ " \"factor\" \"mode\" set-value"
+ " ] nest-form"
+ " ] >>init"
+ }
+} ;
+
+HELP: begin-form
+{ $description "Begins a new form." } ;
+
+HELP: value
+{ $values { "name" string } { "value" object } }
+{ $description "Gets a form value. This word is used to get form field values after validation." } ;
+
+HELP: set-value
+{ $values { "value" object } { "name" string } }
+{ $description "Sets a form value. This word is used to preset form field values before rendering." } ;
+
+HELP: from-object
+{ $values { "object" object } }
+{ $description "Sets the current form's values to the object's slot values." }
+{ $examples
+ "Here is a typical action implementation, which selects a golf course object from the database with the ID specified in the HTTP request, and renders a form with values from this object:"
+ { $code
+ "<page-action>"
+ ""
+ " ["
+ " validate-integer-id"
+ " \"id\" value <golf-course>"
+ " select-tuple from-object"
+ " ] >>init"
+ ""
+ " { golf \"view-course\" } >>template"
+ }
+} ;
+
+HELP: to-object
+{ $values { "destination" object } { "names" "a sequence of value names" } }
+{ $description "Stores the given sequence of form values into the slots of the object having the same names. This word is used to extract form field values after validation." } ;
+
+HELP: with-each-value
+{ $values { "name" string } { "quot" quotation } }
+{ $description "Calls the quotation with each element of the value named " { $snippet "name" } "; the value must be a sequence. The quotation is called in a new dynamic scope with the " { $snippet "index" } " and " { $snippet "value" } " values set to the one-based index, and the sequence element in question, respectively." }
+{ $notes "This word is used to implement the " { $snippet "t:each" } " tag of the " { $vocab-link "html.templates.chloe" } " templating system. It can also be called directly from " { $vocab-link "html.templates.fhtml" } " templates." } ;
+
+HELP: with-each-object
+{ $values { "name" string } { "quot" quotation } }
+{ $description "Calls the quotation with each element of the value named " { $snippet "name" } "; the value must be a sequence. The quotation is called in a new dynamic scope where the object's slots become named values, as if " { $link from-object } " was called." }
+{ $notes "This word is used to implement the " { $snippet "t:bind-each" } " tag of the " { $vocab-link "html.templates.chloe" } " templating system. It can also be called directly from " { $vocab-link "html.templates.fhtml" } " templates." } ;
+
+HELP: validation-failed?
+{ $values { "?" "a boolean" } }
+{ $description "Tests if validation of the current form failed." } ;
+
+HELP: validate-values
+{ $values { "assoc" assoc } { "validators" "an assoc mapping value names to quotations" } }
+{ $description "Validates values in the assoc by looking up the corresponding validation quotation, and storing the results in named values of the current form." } ;
+
+ARTICLE: "html.forms.forms" "HTML form infrastructure"
+"The below words are used to implement the " { $vocab-link "furnace.actions" } " vocabulary. Calling them directly is rarely necessary."
+$nl
+"Creating a new form:"
+{ $subsection <form> }
+"Variable holding current form:"
+{ $subsection form }
+"Working with forms:"
+{ $subsection with-form }
+{ $subsection begin-form }
+"Validation:"
+{ $subsection validation-error }
+{ $subsection validation-failed? }
+{ $subsection validate-values } ;
+
+ARTICLE: "html.forms.values" "HTML form values"
+"Form values are a central concept in the Furnace framework. Web actions primarily concern themselves with validating values, marshalling values to a database, and setting values for display in a form."
+$nl
+"Getting and setting values:"
+{ $subsection value }
+{ $subsection set-value }
+{ $subsection from-object }
+{ $subsection to-object }
+"Iterating over values; these words are used by " { $vocab-link "html.templates.chloe" } " to implement the " { $snippet "t:each" } " and " { $snippet "t:bind-each" } " tags:"
+{ $subsection with-each-value }
+{ $subsection with-each-object }
+"Nesting a form inside another form as a value:"
+{ $subsection nest-form } ;
+
+ARTICLE: "html.forms" "HTML forms"
+"The " { $vocab-link "html.forms" } " vocabulary implements support for rendering and validating HTML forms. The definition of a " { $emphasis "form" } " is a bit more general than the content of an " { $snippet "<form>" } " tag. Namely, a page which displays a database record without offering any editing capability is considered a form too; it consists entirely of read-only components."
+$nl
+"This vocabulary is an integral part of the " { $vocab-link "furnace" } " web framework. The " { $vocab-link "html.templates.chloe" } " vocabulary uses the HTML form words to implement various template tags. The words are also often used directly from web action implementations."
+$nl
+"This vocabulary can be used without either the Furnace framework or the HTTP server; for example, as part of a static HTML generation tool."
+{ $subsection "html.forms.forms" }
+{ $subsection "html.forms.values" } ;
+
+ABOUT: "html.forms"
dup validation-error? [ form get t >>validation-failed drop ] when
swap set-value ;
-: validate-values ( assoc validators -- assoc' )
+: validate-values ( assoc validators -- )
swap '[ [ dup _ at ] dip validate-value ] assoc-each ;
--- /dev/null
+HTML form rendering and validation
--- /dev/null
+IN: html.streams
+USING: help.markup help.syntax kernel strings io io.styles
+quotations ;
+
+HELP: browser-link-href
+{ $values { "presented" object } { "href" string } }
+{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-stream } " instances." } ;
+
+HELP: html-stream
+{ $class-description "A formatted output stream which emits HTML markup." } ;
+
+HELP: <html-stream>
+{ $values { "stream" "an output stream" } { "html-stream" html-stream } }
+{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ;
+
+HELP: with-html-writer
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." }
+{ $examples
+ { $example
+ "USING: io io.styles html.streams ;"
+ "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer"
+ "<span style='font-style: normal; font-weight: bold; '>Hello</span><br/>"
+ }
+} ;
+
+ARTICLE: "html.streams" "HTML streams"
+"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream."
+{ $subsection html-stream }
+{ $subsection <html-stream> }
+{ $subsection with-html-writer } ;
+
+ABOUT: "html.streams"
IN: html.streams.tests
: make-html-string
- [ with-html-stream ] with-string-writer ; inline
+ [ with-html-writer ] with-string-writer ; inline
[ [ ] make-html-string ] must-infer
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
-[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test
+[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test
io.files continuations io.streams.string kernel math math.order
math.parser namespaces make quotations assocs sequences strings
words html.elements xml.entities sbufs continuations destructors
-accessors arrays ;
+accessors arrays urls.encoding ;
IN: html.streams
GENERIC: browser-link-href ( presented -- href )
: not-a-div ( stream -- stream )
f >>last-div ; inline
-: a-div ( stream -- straem )
+: a-div ( stream -- stream )
t >>last-div ; inline
-: <html-stream> ( stream -- stream )
+: <html-stream> ( stream -- html-stream )
f html-stream boa ;
<PRIVATE
: object-link-tag ( style quot -- )
presented pick at [
browser-link-href [
- <a =href a> call </a>
+ <a url-encode =href a> call </a>
] [ call ] if*
] [ call ] if* ; inline
+: href-link-tag ( style quot -- )
+ href pick at [
+ <a url-encode =href a> call </a>
+ ] [ call ] if* ; inline
+
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
[ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
: format-html-span ( string style stream -- )
stream>> [
- [ [ drop write ] span-tag ] object-link-tag
+ [ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag
] with-output-stream* ;
TUPLE: html-span-stream < html-sub-stream ;
M: html-stream dispose stream>> dispose ;
-: with-html-stream ( quot -- )
+: with-html-writer ( quot -- )
output-stream get <html-stream> swap with-output-stream* ; inline
-HTML reader, writer and utilities
+HTML implementation of formatted output stream protocol
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: html.templates.chloe
+USING: help.markup help.syntax html.components html.forms
+html.templates html.templates.chloe.syntax
+html.templates.chloe.compiler html.templates.chloe.components
+math xml.data strings quotations namespaces ;
+
+HELP: <chloe> ( path -- template )
+{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "template" chloe } }
+{ $description "Creates a new Chloe template object which can be passed to " { $link call-template } "." } ;
+
+HELP: required-attr
+{ $values { "tag" tag } { "name" string } { "value" string } }
+{ $description "Extracts an attribute from a tag." }
+{ $errors "Throws an error if the attribute is not specified." } ;
+
+HELP: optional-attr
+{ $values { "tag" tag } { "name" string } { "value" "a " { $link string } " or " { $link f } } }
+{ $description "Extracts an attribute from a tag." }
+{ $notes "Outputs " { $link f } " if the attribute is not specified." } ;
+
+HELP: compile-attr
+{ $values { "value" "an attribute value" } }
+{ $description "Compiles code which pushes an attribute value previously extracted by " { $link required-attr } " or " { $link optional-attr } " on the stack. If the attribute value begins with " { $snippet "@" } ", compiles into code which pushes the a form value." } ;
+
+HELP: CHLOE:
+{ $syntax "name definition... ;" }
+{ $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } }
+{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
+
+HELP: COMPONENT:
+{ $syntax "COMPONENT: name" }
+{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering the HTML component with class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
+
+HELP: reset-cache
+{ $description "Resets the compiled template cache. Chloe automatically recompiles templates when their file changes on disk, however other when redefining Chloe tags or words which they call, the cache may have to be reset manually for the changes to take effect." } ;
+
+HELP: tag-stack
+{ $var-description "During template compilation, holds the current nesting of XML element names. Can be used from " { $link POSTPONE: CHLOE: } " definitions to make a custom tag behave differently depending on how it is nested." } ;
+
+HELP: [write]
+{ $values { "string" string } }
+{ $description "Compiles code which writes the string when the template is called." } ;
+
+HELP: [code]
+{ $values { "quot" quotation } }
+{ $description "Compiles the quotation. It will be called when the template is called." } ;
+
+HELP: process-children
+{ $values { "tag" tag } { "quot" "a quotation with stack effect " { $snippet "( compiled-tag -- )" } } }
+{ $description "Compiles the tag. The quotation will be applied to the resulting quotation when the template is called." }
+{ $examples "See " { $link "html.templates.chloe.extend.tags.example" } " for an example which uses this word to implement a custom control flow tag." } ;
+
+HELP: compile-children>string
+{ $values { "tag" tag } }
+{ $description "Compiles the tag so that the output it generates is written to a string, which is pushed on the stack when the template runs. A subsequent " { $link [code] } " call must be made with a quotation which consumes the string." } ;
+
+HELP: compile-with-scope
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation and wraps any output it compiles in a " { $link with-scope } " form." } ;
+
+ARTICLE: "html.templates.chloe.tags.component" "Component Chloe tags"
+"The following Chloe tags correspond exactly to " { $link "html.components" } ". Singleton component tags do not allow any attributes. Attributes of tuple component tags are mapped to tuple slot values of the component instance."
+{ $table
+ { "Tag" "Component class" }
+ { { $snippet "t:checkbox" } { $link checkbox } }
+ { { $snippet "t:choice" } { $link choice } }
+ { { $snippet "t:code" } { $link code } }
+ { { $snippet "t:comparison" } { $link comparison } }
+ { { $snippet "t:farkup" } { $link farkup } }
+ { { $snippet "t:field" } { $link field } }
+ { { $snippet "t:hidden" } { $link hidden } }
+ { { $snippet "t:html" } { $link html } }
+ { { $snippet "t:inspector" } { $link inspector } }
+ { { $snippet "t:label" } { $link label } }
+ { { $snippet "t:link" } { $link link } }
+ { { $snippet "t:password" } { $link password } }
+ { { $snippet "t:textarea" } { $link textarea } }
+} ;
+
+ARTICLE: "html.templates.chloe.tags.boilerplate" "Boilerplate Chloe tags"
+"The following Chloe tags interface with the HTML templating " { $link "html.templates.boilerplate" } "."
+$nl
+"The tags marked with (*) are only available if the " { $vocab-link "furnace.chloe-tags" } " vocabulary is loaded."
+{ $table
+ { { $snippet "t:title" } "Sets the title from a child template" }
+ { { $snippet "t:write-title" } "Renders the child's title from a master template" }
+ { { $snippet "t:style" } "Adds CSS markup from a child template" }
+ { { $snippet "t:write-style" } "Renders the children's CSS from a master template" }
+ { { $snippet "t:atom" } "Adds an Atom feed link from a child template (*)" }
+ { { $snippet "t:write-atom" } "Renders the children's list of Atom feed links (*)" }
+ { { $snippet "t:call-next-template" } "Calls the child template from a master template" }
+} ;
+
+ARTICLE: "html.templates.chloe.tags.control" "Control-flow Chloe tags"
+"While most control flow and logic should be embedded in the web actions themselves and not in the template, Chloe templates do support a minimal amount of control flow."
+{ $table
+ { { $snippet "t:comment" } "All markup within a comment tag is ignored by the compiler." }
+ { { $snippet "t:bind" } { "Renders child content bound to a nested form named by the " { $snippet "t:name" } " attribute. See " { $link with-form } "." } }
+ { { $snippet "t:each" } { "Renders child content once for each element of the sequence in the value named by the " { $snippet "t:name" } " attribute. The sequence element and index are bound to the " { $snippet "value" } " and " { $snippet "index" } " values, respectively. See " { $link with-each-value } "." } }
+ { { $snippet "t:bind-each" } { "Renders child content once for each element of the sequence in the value named by the " { $snippet "t:name" } " attribute. The sequence element's slots are bound to values. See " { $link with-each-object } "." } }
+ { { $snippet "t:even" } { "Only valid inside a " { $snippet "t:each" } " or " { $snippet "t:bind-each" } ". Only renders child content if the " { $snippet "index" } " value is even." } }
+ { { $snippet "t:odd" } "As above, but only if the index value is odd." }
+ { { $snippet "t:if" } { "Renders child content if a boolean condition evaluates to true. The condition value is determined by the " { $snippet "t:code" } " or " { $snippet "t:value" } " attribute, exactly one of which must be specified. The former is a string of the form " { $snippet "vocabulary:word" } " denoting a word to execute with stack effect " { $snippet "( -- ? )" } ". The latter is a value name." } }
+} ;
+
+ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
+"The following tags are only available if the " { $vocab-link "furnace.chloe-tags" } " vocabulary is loaded."
+{ $table
+ { { $snippet "t:a" } { "Renders a link; extends the standard XHTML " { $snippet "a" } " tag by providing some integration with other web framework features. The following attributes are supported:"
+ { $list
+ { { $snippet "href" } " - a URL. If it begins with " { $snippet "$" } ", then it is interpreted as a responder-relative path." }
+ { { $snippet "rest" } " - a value to add at the end of the URL." }
+ { { $snippet "query" } " - a comma-separated list of value names defined in the current form which are to be passed to the link as query parameters." }
+ { { $snippet "value" } " - a value name holding a URL. If this attribute is specified, it overrides all others." }
+ }
+ "Any attributes not in the Chloe XML namespace are passed on to the generated " { $snippet "a" } " tag."
+ $nl
+ "An example:"
+ { $code
+ "<t:a t:href=\"$wiki/view/\""
+ " t:rest=\"title\""
+ " class=\"small-link\">"
+ " View"
+ "</t:a>"
+ }
+ "The above might render as"
+ { $code
+ "<a href=\"http://mysite.org/wiki/view/Factor\""
+ " class=\"small-link\">"
+ " View"
+ "s</a>"
+ }
+ } }
+ { { $snippet "t:base" } { "Outputs an HTML " { $snippet "<base>" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } }
+ { { $snippet "t:form" } {
+ "Renders a form; extends the standard XHTML " { $snippet "form" } " tag by providing some integration with other web framework features, for example by adding hidden fields for authentication credentials and session management allowing those features to work with form submission transparently. The following attributes are supported:"
+ { $list
+ { { $snippet "t:method" } " - just like the " { $snippet "method" } " attribute of an HTML " { $snippet "form" } " tag, this can equal " { $snippet "get" } " or " { $snippet "post" } ". Unlike the HTML tag, the default is " { $snippet "post" } "." }
+ { { $snippet "t:action" } " - a URL. If it begins with " { $snippet "$" } ", then it is interpreted as a responder-relative path." }
+ { { $snippet "t:for" } " - a comma-separated list of form values which are to be inserted in the form as hidden fields. Other than being more concise, this is equivalent to nesting a series of " { $snippet "t:hidden" } " tags inside the form." }
+ }
+ "Any attributes not in the Chloe XML namespace are passed on to the generated " { $snippet "form" } " tag."
+ } }
+ { { $snippet "t:button" } {
+ "Shorthand for a form with a single button, whose label is the text child of the " { $snippet "t:button" } " tag. Attributes are processed as with the " { $snippet "t:form" } " tag, with the exception that any attributes not in the Chloe XML namespace are passed on to the generated " { $snippet "button" } " tag, rather than the " { $snippet "form" } " tag surrounding it."
+ $nl
+ "An example:"
+ { $code
+ "<t:button t:method=\"POST\""
+ " t:action=\"$wiki/delete\""
+ " t:for=\"id\">"
+ " class=\"link-button\""
+ " Delete"
+ "</t:button>"
+ }
+ } }
+} ;
+
+ARTICLE: "html.templates.chloe.tags" "Standard Chloe tags"
+"A Chloe template is an XML file with a mix of standard XHTML and Chloe tags."
+$nl
+"XHTML tags are rendered verbatim, except attribute values which begin with " { $snippet "@" } " are replaced with the corresponding " { $link "html.forms.values" } "."
+$nl
+"Chloe tags are defined in the " { $snippet "http://factorcode.org/chloe/1.0" } " namespace; by convention, it is bound with a prefix of " { $snippet "t" } ". The top-level tag must always be the " { $snippet "t:chloe" } " tag. A typical Chloe template looks like so:"
+{ $code
+ "<?xml version=\"1.0\"?>"
+ ""
+ "<t:chloe xmlns:t=\"http://factorcode.org/chloe/1.0\">"
+ " ..."
+ "</t:chloe>"
+}
+{ $subsection "html.templates.chloe.tags.component" }
+{ $subsection "html.templates.chloe.tags.boilerplate" }
+{ $subsection "html.templates.chloe.tags.control" }
+{ $subsection "html.templates.chloe.tags.form" } ;
+
+ARTICLE: "html.templates.chloe.extend" "Extending Chloe"
+"The " { $vocab-link "html.templates.chloe.syntax" } " and " { $vocab-link "html.templates.chloe.compiler" } " vocabularies contain the heart of the Chloe implementation."
+$nl
+"Chloe is implemented as a compiler which converts XML templates into Factor quotations. The template only has to be parsed and compiled once, and not on every HTTP request. This helps improve performance and memory usage."
+$nl
+"These vocabularies provide various hooks by which Chloe can be extended. First of all, new " { $link "html.components" } " can be wired in. If further flexibility is needed, entirely new tags can be defined by hooking into the Chloe compiler."
+{ $subsection "html.templates.chloe.extend.components" }
+{ $subsection "html.templates.chloe.extend.tags" } ;
+
+ARTICLE: "html.templates.chloe.extend.tags" "Extending Chloe with custom tags"
+"Syntax for defining custom tags:"
+{ $subsection POSTPONE: CHLOE: }
+"A number of compiler words can be used from the " { $link POSTPONE: CHLOE: } " body to emit compiled template code."
+$nl
+"Extracting attributes from the XML tag:"
+{ $subsection required-attr }
+{ $subsection optional-attr }
+{ $subsection compile-attr }
+"Examining tag nesting:"
+{ $subsection tag-stack }
+"Generating code for printing strings and calling quotations:"
+{ $subsection [write] }
+{ $subsection [code] }
+"Generating code from child elements:"
+{ $subsection process-children }
+{ $subsection compile-children>string }
+{ $subsection compile-with-scope }
+"Examples which illustrate some of the above:"
+{ $subsection "html.templates.chloe.extend.tags.example" } ;
+
+ARTICLE: "html.templates.chloe.extend.tags.example" "Examples of custom Chloe tags"
+"As a first example, let's develop a custom Chloe tag which simply renders a random number. The tag will be used as follows:"
+{ $code
+ "<t:random t:min='10' t:max='20' t:generator='system' />"
+}
+"The " { $snippet "t:min" } " and " { $snippet "t:max" } " parameters are required, and " { $snippet "t:generator" } ", which can equal one of " { $snippet "default" } ", " { $snippet "system" } " or " { $snippet "secure" } ", is optional, with the default being " { $snippet "default" } "."
+$nl
+"Here is the " { $link POSTPONE: USING: } " form that we need for the below code to work:"
+{ $code
+ "USING: combinators kernel math.parser math.ranges random"
+ "html.templates.chloe.compiler html.templates.chloe.syntax ;"
+}
+"We write a word which extracts the relevant attributes from an XML tag:"
+{ $code
+ ": random-attrs ( tag -- min max generator )"
+ " [ \"min\" required-attr string>number ]"
+ " [ \"max\" required-attr string>number ]"
+ " [ \"generator\" optional-attr ]"
+ " tri ;"
+}
+"Next, we convert a random generator name into a random generator object:"
+{ $code
+ ": string>random-generator ( string -- generator )"
+ " {"
+ " { \"default\" [ random-generator ] }"
+ " { \"system\" [ system-random-generator ] }"
+ " { \"secure\" [ secure-random-generator ] }"
+ " } case ;"
+}
+"Finally, we can write our Chloe tag:"
+{ $code
+ "CHLOE: random"
+ " random-attrs string>random-generator"
+ " '["
+ " _ _ _"
+ " [ [a,b] random present write ]"
+ " with-random-generator"
+ " ] [code] ;"
+}
+"For the second example, let's develop a Chloe tag which repeatedly renders its child several times, where the number comes from a form value. The tag will be used as follows:"
+{ $code
+ "<t:repeat t:times='n'>Hello world.<br /></t:repeat>"
+}
+"This time, we cannot simply extract the " { $snippet "t:times" } " attribute at compile time since its value cannot be determined then. Instead, we execute " { $link compile-attr } " to generate code which pushes the value of that attribute on the stack. We then use " { $link process-children } " to compile child elements as a nested quotation which we apply " { $link times } " to."
+{ $code
+ "CHLOE: repeat"
+ " [ \"times\" required-attr compile-attr ]"
+ " [ [ times ] process-children ]"
+ " bi ;"
+} ;
+
+ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component"
+"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
+{ $code "SINGLETON: image" }
+"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":"
+{ $code "M: image render* 2drop <img =src img/> ;" }
+"Finally, we can define a Chloe component:"
+{ $code "COMPONENT: image" }
+"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"
+{ $code "<t:image t:name='image' />" } ;
+
+ARTICLE: "html.templates.chloe.extend.components" "Extending Chloe with custom components"
+"Custom HTML components implementing the " { $link render* } " word can be wired up with Chloe using the following syntax from " { $vocab-link "html.templates.chloe.components" } ":"
+{ $subsection POSTPONE: COMPONENT: }
+{ $subsection "html.templates.chloe.extend.components.example" } ;
+
+ARTICLE: "html.templates.chloe" "Chloe templates"
+"The " { $vocab-link "html.templates.chloe" } " vocabulary implements an XHTML templating engine. Unlike " { $vocab-link "html.templates.fhtml" } ", Chloe templates are always well-formed XML, and no Factor code can be embedded in them, enforcing proper separation of concerns. Chloe templates can be edited using standard XML editing tools; they are less flexible than FHTML, but often simpler as a result."
+{ $subsection <chloe> }
+{ $subsection reset-cache }
+{ $subsection "html.templates.chloe.tags" }
+{ $subsection "html.templates.chloe.extend" } ;
+
+ABOUT: "html.templates.chloe"
splitting unicode.categories furnace accessors ;
IN: html.templates.chloe.tests
-reset-templates
-
: run-template
with-string-writer [ "\r\n\t" member? not ] filter
"?>" split1 nip ; inline
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
-[ "<form method='post' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
+[ "<form method='post' action='foo'><div style='display: none;'><input type='hidden' name='__n' value='a'/></div></form>" ] [
[
"test10" test-template call-template
] run-template
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel fry
-namespaces make classes.tuple assocs splitting words arrays
-memoize io io.files io.encodings.utf8 io.streams.string
-unicode.case mirrors math urls present multiline quotations xml
+namespaces make classes.tuple assocs splitting words arrays io
+io.files io.encodings.utf8 io.streams.string unicode.case
+mirrors math urls present multiline quotations xml logging
xml.data
html.forms
html.elements
] ?if ;
CHLOE: write-style
- drop [ <style> write-style </style> ] [code] ;
+ drop [
+ <style "text/css" =type style>
+ write-style
+ </style>
+ ] [code] ;
CHLOE: even
[ "index" value even? swap when ] process-children ;
CHLOE: if dup if>quot [ swap when ] append process-children ;
-CHLOE-SINGLETON: label
-CHLOE-SINGLETON: link
-CHLOE-SINGLETON: inspector
-CHLOE-SINGLETON: comparison
-CHLOE-SINGLETON: html
-CHLOE-SINGLETON: hidden
-
-CHLOE-TUPLE: farkup
-CHLOE-TUPLE: field
-CHLOE-TUPLE: textarea
-CHLOE-TUPLE: password
-CHLOE-TUPLE: choice
-CHLOE-TUPLE: checkbox
-CHLOE-TUPLE: code
-
-: read-template ( chloe -- xml )
- path>> ".xml" append utf8 <file-reader> read-xml ;
-
-MEMO: template-quot ( chloe -- quot )
- read-template compile-template ;
-
-MEMO: nested-template-quot ( chloe -- quot )
- read-template compile-nested-template ;
-
-: reset-templates ( -- )
- { template-quot nested-template-quot } [ reset-memoized ] each ;
+COMPONENT: label
+COMPONENT: link
+COMPONENT: inspector
+COMPONENT: comparison
+COMPONENT: html
+COMPONENT: hidden
+COMPONENT: farkup
+COMPONENT: field
+COMPONENT: textarea
+COMPONENT: password
+COMPONENT: choice
+COMPONENT: checkbox
+COMPONENT: code
+
+SYMBOL: template-cache
+
+H{ } template-cache set-global
+
+TUPLE: cached-template path last-modified quot ;
+
+: load-template ( chloe -- cached-template )
+ path>> ".xml" append
+ [ ]
+ [ file-info modified>> ]
+ [ utf8 <file-reader> read-xml compile-template ] tri
+ \ cached-template boa ;
+
+\ load-template DEBUG add-input-logging
+
+: cached-template ( chloe -- cached-template/f )
+ template-cache get at* [
+ [
+ [ path>> file-info modified>> ]
+ [ last-modified>> ]
+ bi =
+ ] keep and
+ ] when ;
+
+: template-quot ( chloe -- quot )
+ dup cached-template [ ] [
+ [ load-template dup ] keep
+ template-cache get set-at
+ ] ?if quot>> ;
+
+: reset-cache ( -- )
+ template-cache get clear-assoc ;
M: chloe call-template*
- nested-template? get
- [ nested-template-quot ] [ template-quot ] if
- assert-depth ;
+ template-quot assert-depth ;
INSTANCE: chloe template
USING: assocs namespaces make kernel sequences accessors
combinators strings splitting io io.streams.string present
xml.writer xml.data xml.entities html.forms
-html.templates.chloe.syntax ;
+html.templates html.templates.chloe.syntax ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )
reset-buffer
] [ ] make ; inline
-: compile-nested-template ( xml -- quot )
- [ compile-element ] with-compiler ;
-
: compile-chunk ( seq -- )
[ compile-element ] each ;
: compile-with-scope ( quot -- )
compile-quot [ with-scope ] [code] ; inline
+: if-not-nested ( quot -- )
+ nested-template? get swap unless ; inline
+
+: compile-prologue ( xml -- )
+ [
+ [ prolog>> [ write-prolog ] [code-with] ]
+ [ before>> compile-chunk ]
+ bi
+ ] compile-quot
+ [ if-not-nested ] [code] ;
+
+: compile-epilogue ( xml -- )
+ [ after>> compile-chunk ] compile-quot
+ [ if-not-nested ] [code] ;
+
: compile-template ( xml -- quot )
[
- {
- [ prolog>> [ write-prolog ] [code-with] ]
- [ before>> compile-chunk ]
- [ compile-element ]
- [ after>> compile-chunk ]
- } cleave
+ [ compile-prologue ]
+ [ compile-element ]
+ [ compile-epilogue ]
+ tri
] with-compiler ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel parser fry quotations
-classes.tuple
+classes.tuple classes.singleton
html.components
html.templates.chloe.compiler
html.templates.chloe.syntax ;
IN: html.templates.chloe.components
+
+GENERIC: component-tag ( tag class -- )
-: singleton-component-tag ( tag class -- )
+M: singleton-class component-tag ( tag class -- )
[ "name" required-attr compile-attr ]
[ literalize [ render ] [code-with] ]
bi* ;
-: CHLOE-SINGLETON:
- scan-word
- [ name>> ] [ '[ _ singleton-component-tag ] ] bi
- define-chloe-tag ;
- parsing
-
: compile-component-attrs ( tag class -- )
[ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip
[ all-slots swap '[ name>> _ at compile-attr ] each ]
[ [ boa ] [code-with] ]
bi ;
-: tuple-component-tag ( tag class -- )
+M: tuple-class component-tag ( tag class -- )
[ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
[ render ] [code] ;
-: CHLOE-TUPLE:
+: COMPONENT:
scan-word
- [ name>> ] [ '[ _ tuple-component-tag ] ] bi
+ [ name>> ] [ '[ _ component-tag ] ] bi
define-chloe-tag ;
parsing
--- /dev/null
+XHTML templating engine with extensible compiler and separation of concerns
Slava Pestov
-Matthew Willis
+Alex Chapman
--- /dev/null
+IN: html.templates.fhtml
+USING: help.markup help.syntax ;
+
+HELP: <fhtml> ( path -- fhtml )
+{ $values { "path" "a pathname string" } { "fhtml" fhtml } }
+{ $description "Creates an FHTML template descriptor." } ;
+
+ARTICLE: "html.templates.fhtml" "FHTML templates"
+"The " { $vocab-link "html.templates.fhtml" } " vocabulary implements a templating engine which mixes markup with Factor code."
+$nl
+"FHTML provides an alternative to " { $vocab-link "html.templates.chloe" } " for situations where complex logic must be embedded in the presentation layer of a web application. While this is discouraged for larger applications, it is useful for prototyping as well as simpler applications."
+$nl
+"The entire syntax of an FHTML template can be summarized as thus: text outside of " { $snippet "<%" } " and " { $snippet "%>" } " is rendered literally. Text inside " { $snippet "<%" } " and " { $snippet "%>" } " is interpreted as Factor source code."
+{ $subsection <fhtml> } ;
+
+ABOUT: "html.templates.fhtml"
--- /dev/null
+Simple templating engine mixing Factor code with content
--- /dev/null
+HTML templating engine interface
--- /dev/null
+IN: html.templates
+USING: help.markup help.syntax io strings quotations xml.data
+continuations urls ;
+
+HELP: template
+{ $class-description "The class of HTML templates." } ;
+
+HELP: call-template*
+{ $values { "template" template } }
+{ $contract "Writes a template to " { $link output-stream } ", possibly using " { $vocab-link "html.forms" } " state."
+$nl
+"In addition to methods added by other vocabularies, this generic word has methods on the following classes:"
+{ $list
+ { { $link string } " - the simplest type of template; simply written to " { $link output-stream } }
+ { { $link callable } " - a custom quotation, called to yield output" }
+ { { $link xml } " - written to " { $link output-stream } }
+ { "an input stream - copied to " { $link output-stream } }
+} } ;
+
+HELP: call-template
+{ $values { "template" template } }
+{ $description "Writes a template to " { $link output-stream } ", possibly using " { $vocab-link "html.forms" } " state."
+$nl
+"This word calls " { $link call-template* } ", wrapping it in a " { $link recover } " form which improves error reporting by combining the underlying error with the template object." } ;
+
+HELP: set-title
+{ $values { "string" string } }
+{ $description "Sets the title of the current page. This is usually called by child templates, and a master template calls " { $link write-title } "." } ;
+
+HELP: write-title
+{ $description "Writes the title of the current page, previously set by " { $link set-title } ". This is usually called by a master template after rendering a child template." } ;
+
+HELP: add-style
+{ $values { "string" string } }
+{ $description "Adds some CSS markup to the CSS stylesheet of a master template. Usually called by child templates which need to insert CSS style information in the " { $snippet "<head>" } " tag of the resulting HTML page." } ;
+
+HELP: write-style
+{ $description "Writes a CSS stylesheet assembled from " { $link add-style } " calls by child templates. Usually called by the master template to emit a CSS style in the " { $snippet "<head>" } " tag of the resulting HTML page." } ;
+
+HELP: add-atom-feed
+{ $values { "title" string } { "url" "a " { $link string } " or " { $link url } } }
+{ $description "Adds an Atom feed link to the list of feeds in a master template. Usually called by child templates which need to insert an Atom feed link information in the " { $snippet "<head>" } " tag of the resulting HTML page." } ;
+
+HELP: write-atom-feeds
+{ $description "Writes a list of Atom feed links assembled from " { $link add-atom-feed } " calls by child templates. Usually called by the master template to emit a list of Atom feed links in the " { $snippet "<head>" } " tag of the resulting HTML page." } ;
+
+HELP: nested-template?
+{ $var-description "Set to a true value if the current call to " { $link call-template } " is nested inside a " { $link with-boilerplate } " and will therefore appear as part of another template. In this case, XML processing instructions and document type declarations should be omitted." } ;
+
+HELP: call-next-template
+{ $description "Calls the next innermost child template from a master template. This is used to implement the " { $snippet "t:call-next-template" } " tag in the " { $vocab-link "html.templates.chloe" } " templating engine." } ;
+
+HELP: with-boilerplate
+{ $values { "child" template } { "master" template } }
+{ $description "Calls the child template, storing its output in a string, then calls the master template. The master template may call " { $link call-next-template } " to insert the output of the child template at any point; both templates may also use the master/child interface words documented in " { $link "html.templates.boilerplate" } "." } ;
+
+HELP: template-convert
+{ $values { "template" template } { "output" "a pathname string" } }
+{ $description "Calls the template and writes its output to a file with UTF8 encoding." } ;
+
+ARTICLE: "html.templates.boilerplate" "Boilerplate support"
+"The following words define the interface between a templating engine and the " { $vocab-link "furnace.boilerplate" } " vocabulary."
+$nl
+"The master/child template interface follows a pattern where for each concept there is a word called by the child to store an entity, and another word to write the entity out; this solves the problem where certain HTML tags, such as " { $snippet "<title>" } " and " { $snippet "<link>" } " must appear inside the " { $snippet "<head>" } " tag, even though those tags are usually precisely those that the child template will want to set."
+{ $subsection set-title }
+{ $subsection write-title }
+{ $subsection add-style }
+{ $subsection write-style }
+{ $subsection add-atom-feed }
+{ $subsection write-atom-feeds }
+"Processing a master template with a child:"
+{ $subsection with-boilerplate }
+{ $subsection call-next-template } ;
+
+ARTICLE: "html.templates" "HTML template interface"
+"The " { $vocab-link "html.templates" } " vocabulary implements an abstract interface to HTML templating engines. The " { $vocab-link "html.templates.fhtml" } " and " { $vocab-link "html.templates.chloe" } " vocabularies are two implementations of this."
+$nl
+"An HTML template is an instance of a mixin:"
+{ $subsection template }
+"HTML templates must also implement a method on a generic word:"
+{ $subsection call-template* }
+"Calling an HTML template:"
+{ $subsection call-template }
+"Usually HTML templates are invoked dynamically by the Furnace web framework and HTTP server. They can also be used in static HTML generation tools:"
+{ $subsection template-convert }
+{ $subsection "html.templates.boilerplate" } ;
+
+ABOUT: "html.templates"
M: f call-template* drop call-next-template ;
-: with-boilerplate ( body template -- )
+: with-boilerplate ( child master -- )
[
title [ <box> or ] change
style [ SBUF" " clone or ] change
--- /dev/null
+USING: http help.markup help.syntax io.files io.streams.string
+io.encodings.8-bit io.encodings.binary kernel strings urls
+urls.encoding byte-arrays strings assocs sequences ;
+IN: http.client
+
+HELP: download-failed
+{ $error-description "Thrown by " { $link http-request } " if the server returns a status code other than 200. The " { $slot "response" } " and " { $slot "body" } " slots can be inspected for the underlying cause of the problem." } ;
+
+HELP: too-many-redirects
+{ $error-description "Thrown by " { $link http-request } " if the server returns a chain of than " { $link max-redirects } " redirections." } ;
+
+HELP: <get-request>
+{ $values { "url" "a " { $link url } " or " { $link string } } { "request" request } }
+{ $description "Constructs an HTTP GET request for retrieving the URL." }
+{ $notes "The request can be passed on to " { $link http-request } ", possibly after cookies and headers are set." } ;
+
+HELP: <post-request>
+{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "request" request } }
+{ $description "Constructs an HTTP POST request for submitting post data to the URL." }
+{ $notes "The request can be passed on to " { $link http-request } ", possibly after cookies and headers are set." } ;
+
+HELP: download
+{ $values { "url" "a " { $link url } " or " { $link string } } }
+{ $description "Downloads the contents of the URL to a file in the " { $link current-directory } " having the same file name." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
+HELP: download-to
+{ $values { "url" "a " { $link url } " or " { $link string } } { "file" "a pathname string" } }
+{ $description "Downloads the contents of the URL to a file with the given pathname." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
+HELP: http-get
+{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
+{ $description "Downloads the contents of a URL." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
+HELP: http-post
+{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
+{ $description "Submits a form at a URL." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
+HELP: http-request
+{ $values { "request" request } { "response" response } { "data" sequence } }
+{ $description "Sends an HTTP request to an HTTP server, and reads the response." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
+ARTICLE: "http.client.get" "GET requests with the HTTP client"
+"Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
+{ $subsection http-get }
+"Utilities to retrieve a " { $link url } " and save the contents to a file:"
+{ $subsection download }
+{ $subsection download-to }
+"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
+{ $subsection <get-request> }
+{ $subsection http-request } ;
+
+ARTICLE: "http.client.post" "POST requests with the HTTP client"
+"As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":"
+{ $subsection http-post }
+{ $subsection <post-request> }
+"Both words take a post data parameter, which can be one of the following:"
+{ $list
+ { "a " { $link byte-array } " or " { $link string } " is sent the server without further encoding" }
+ { "an " { $link assoc } " is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } }
+ { { $link f } " denotes that there is no post data" }
+} ;
+
+ARTICLE: "http.client.encoding" "Character encodings and the HTTP client"
+"The " { $link http-request } ", " { $link http-get } " and " { $link http-post } " words output a sequence containing data that was sent by the server."
+$nl
+"If the server specifies a " { $snippet "content-type" } " header with a character encoding, the HTTP client decodes the data using this character encoding, and the sequence will be a string."
+$nl
+"If no encoding was specified but the MIME type is a text type, the " { $link latin1 } " encoding is assumed, and the sequence will be a string."
+$nl
+"For any other MIME type, the " { $link binary } " encoding is assumed, and thus the data is returned literally in a byte array." ;
+
+ARTICLE: "http.client.errors" "HTTP client errors"
+"HTTP operations may fail for one of two reasons. The first is an I/O error resulting from a network problem; a name server lookup failure, or a refused connection. The second is a protocol-level error returned by the server. There are two such errors:"
+{ $subsection download-failed }
+{ $subsection too-many-redirects } ;
+
+ARTICLE: "http.client" "HTTP client"
+"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
+$nl
+"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
+{ $subsection "http.client.get" }
+{ $subsection "http.client.post" }
+"More esoteric use-cases, for example HTTP methods other than the above, are accomodated by constructing an empty request object with " { $link <request> } " and filling everything in by hand."
+{ $subsection "http.client.encoding" }
+{ $subsection "http.client.errors" }
+{ $see-also "urls" } ;
+
+ABOUT: "http.client"
io.encodings.8-bit
io.encodings.binary
io.streams.duplex
-fry debugger summary ascii urls present
+fry debugger summary ascii urls urls.encoding present
http http.parsers ;
IN: http.client
[ content-type>> "content-type" pick set-at ]
bi
] when*
- over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
+ over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty
write-header ;
GENERIC: >post-data ( object -- post-data )
--- /dev/null
+USING: assocs help.markup help.syntax io.streams.string sequences strings present math kernel byte-arrays urls
+calendar ;
+IN: http
+
+HELP: <request>
+{ $values { "request" request } }
+{ $description "Creates an empty request." } ;
+
+HELP: request
+{ $description "An HTTP request."
+$nl
+"Instances contain the following slots:"
+{ $table
+ { { $slot "method" } { "The HTTP method as a " { $link string } ". The most frequently-used HTTP methods are " { $snippet "GET" } ", " { $snippet "HEAD" } " and " { $snippet "POST" } "." } }
+ { { $slot "url" } { "The " { $link url } " being requested" } }
+ { { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
+ { { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
+ { { $slot "post-data" } { "See " { $link "http.post-data" } } }
+ { { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
+} } ;
+
+HELP: <response>
+{ $values { "response" response } }
+{ $description "Creates an empty response." } ;
+
+HELP: response
+{ $class-description "An HTTP response."
+$nl
+"Instances contain the following slots:"
+{ $table
+ { { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
+ { { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
+ { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
+ { { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
+ { { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
+ { { $slot "content-type" } { "an HTTP content type" } }
+ { { $slot "content-charset" } { "an encoding descriptor. See " { $link "io.encodings" } } }
+ { { $slot "body" } { "an HTTP response body" } }
+} } ;
+
+HELP: <raw-response>
+{ $values { "response" raw-response } }
+{ $description "Creates an empty raw response." } ;
+
+HELP: raw-response
+{ $class-description "A minimal HTTP response used by webapps which need full control over all output sent to the client. Most webapps can use " { $link response } " instead."
+$nl
+"Instances contain the following slots:"
+{ $table
+ { { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
+ { { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
+ { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
+ { { $slot "body" } { "an HTTP response body" } }
+} } ;
+
+HELP: <cookie>
+{ $values { "value" object } { "name" string } { "cookie" cookie } }
+{ $description "Creates a cookie with the specified name and value. The value can be any object supported by the " { $link present } " word." } ;
+
+HELP: cookie
+{ $class-description
+"An HTTP cookie."
+$nl
+"Instances contain a number of slots which correspond exactly to the fields of a cookie in the cookie specification:"
+{ $table
+ { { $slot "name" } { "The cookie name, a " { $link string } } }
+ { { $slot "value" } { "The cookie value, an object supported by " { $link present } } }
+ { { $slot "comment" } { "A " { $link string } } }
+ { { $slot "path" } { "The pathname prefix where the cookie is valid, a " { $link string } } }
+ { { $slot "domain" } { "The domain name where the cookie is valid, a " { $link string } } }
+ { { $slot "expires" } { "The expiry time, a " { $link timestamp } " or " { $link f } " for a session cookie" } }
+ { { $slot "max-age" } { "The expiry duration, a " { $link duration } " or " { $link f } " for a session cookie" } }
+ { { $slot "http-only" } { "If set to a true value, JavaScript code cannot see the cookie" } }
+ { { $slot "secure" } { "If set to a true value, the cookie is only sent for " { $snippet "https" } " protocol connections" } }
+}
+"Only one of " { $snippet "expires" } " and " { $snippet "max-age" } " can be set; the latter is preferred and is supported by all modern browsers." } ;
+
+HELP: delete-cookie
+{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } }
+{ $description "Deletes a cookie from a request or response." }
+{ $side-effects "request/response" } ;
+
+HELP: get-cookie
+{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" "a " { $link cookie } " or " { $link f } } }
+{ $description "Gets a named cookie from a request or response." } ;
+
+HELP: put-cookie
+{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "cookie" cookie } }
+{ $description "Stores a cookie in a request or response." }
+{ $side-effects "request/response" } ;
+
+HELP: <post-data>
+{ $values { "raw" byte-array } { "content-type" "a MIME type string" } { "post-data" post-data } }
+{ $description "Creates a new " { $link post-data } "." } ;
+
+HELP: header
+{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "key" string } { "value" string } }
+{ $description "Obtains an HTTP header value from a request or response." } ;
+
+HELP: post-data
+{ $class-description "HTTP POST data passed in a POST request."
+$nl
+"Instances contain the following slots:"
+{ $table
+ { { $slot "raw" } { "The raw bytes of the POST data" } }
+ { { $slot "content" } { "The POST data. This can be in a higher-level form, such as an assoc of POST parameters, a string, or an XML document" } }
+ { { $slot "content-type" } "A MIME type" }
+} } ;
+
+HELP: set-header
+{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "value" object } { "key" string } }
+{ $description "Stores a value into the HTTP header of a request or response. The value can be any object supported by " { $link present } "." }
+{ $notes "This word always returns the same object that was input. This allows for a ``pipeline'' coding style, where several header parameters are set in a row." }
+{ $side-effects "request/response" } ;
+
+ARTICLE: "http.cookies" "HTTP cookies"
+"Every " { $link request } " and " { $link response } " instance can contain cookies."
+$nl
+"The " { $vocab-link "furnace.sessions" } " vocabulary implements session management using cookies, thus the most common use case can be taken care of without working with cookies directly."
+$nl
+"The class of cookies:"
+{ $subsection cookie }
+"Creating cookies:"
+{ $subsection <cookie> }
+"Getting, adding, and deleting cookies in " { $link request } " and " { $link response } " objects:"
+{ $subsection get-cookie }
+{ $subsection put-cookie }
+{ $subsection delete-cookie } ;
+
+ARTICLE: "http.headers" "HTTP headers"
+"Every " { $link request } " and " { $link response } " has a set of HTTP headers stored in the " { $slot "header" } " slot. Header names are normalized to lower-case when a request or response is being parsed."
+{ $subsection header }
+{ $subsection set-header } ;
+
+ARTICLE: "http.post-data" "HTTP post data"
+"Every " { $link request } " where the " { $slot "method" } " slot is " { $snippet "POST" } " can contain post data."
+{ $subsection post-data }
+{ $subsection <post-data> } ;
+
+ARTICLE: "http.requests" "HTTP requests"
+"HTTP requests:"
+{ $subsection request }
+{ $subsection <request> }
+"Requests can contain form submissions:"
+{ $subsection "http.post-data" } ;
+
+ARTICLE: "http.responses" "HTTP responses"
+"HTTP responses:"
+{ $subsection response }
+{ $subsection <response> }
+"Raw responses only contain a status line, with no header. They are used by webapps which need full control over the HTTP response, for example " { $vocab-link "http.server.cgi" } ":"
+{ $subsection raw-response }
+{ $subsection <raw-response> } ;
+
+ARTICLE: "http" "HTTP protocol objects"
+"The " { $vocab-link "http" } " vocabulary contains data types shared by " { $vocab-link "http.client" } " and " { $vocab-link "http.server" } "."
+$nl
+"The HTTP client sends an HTTP request to the server and receives an HTTP response back. The HTTP server receives HTTP requests from clients and sends HTTP responses back."
+{ $subsection "http.requests" }
+{ $subsection "http.responses" }
+"Both requests and responses support some common functionality:"
+{ $subsection "http.headers" }
+{ $subsection "http.cookies" }
+{ $see-also "urls" } ;
+
+ABOUT: "http"
"" add-responder
add-quit-action
<dispatcher>
- <action> "a" add-main-responder
+ <action> "" add-responder
"d" add-responder
test-db <db-persistence>
main-responder set
USING: accessors kernel combinators math namespaces make
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
-math.parser calendar calendar.format present
+math.parser calendar calendar.format present urls logging
io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit
unicode.case unicode.categories qualified
-urls
-
http.parsers ;
EXCLUDE: fry => , ;
drop
] { } make ;
+\ parse-cookie DEBUG add-input-logging
+
: check-cookie-string ( string -- string' )
dup "=;'\"\r\n" intersect empty?
[ "Bad cookie name or value" throw ] unless ;
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit math math.order math.parser
kernel sequences sequences.deep peg peg.parsers assocs arrays
-hashtables strings unicode.case namespaces make ascii ;
+hashtables strings unicode.case namespaces make ascii logging ;
IN: http.parsers
: except ( quot -- parser )
'space' ,
] seq* just ;
+\ parse-request-line DEBUG add-input-logging
+
: 'text' ( -- parser )
[ ctl? ] except ;
--- /dev/null
+USING: help.markup help.syntax http.server.static multiline ;
+IN: http.server.cgi
+
+HELP: enable-cgi
+{ $values { "responder" file-responder } }
+{ $description "Enables the responder to serve " { $snippet ".cgi" } " scripts by executing them as per the CGI specification." }
+{ $examples
+ { $code
+ <" <dispatcher>
+ "/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder" ">
+ }
+}
+{ $side-effects "responder" } ;
+
+ARTICLE: "http.server.cgi" "Serving CGI scripts"
+"The " { $vocab-link "http.server.cgi" } " implements CGI support. It is used in conjunction with a " { $link <static> } " responder."
+{ $subsection enable-cgi } ;
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: namespaces kernel assocs io.files io.streams.duplex\r
-combinators arrays io.launcher io http.server.static http.server\r
-http accessors sequences strings math.parser fry urls ;\r
+combinators arrays io.launcher io.encodings.binary io\r
+http.server.static http.server http accessors sequences strings\r
+math.parser fry urls urls.encoding calendar ;\r
IN: http.server.cgi\r
\r
: cgi-variables ( script-path -- assoc )\r
: <cgi-process> ( name -- desc )\r
<process>\r
over 1array >>command\r
- swap cgi-variables >>environment ;\r
+ swap cgi-variables >>environment\r
+ 1 minutes >>timeout ;\r
\r
: serve-cgi ( name -- response )\r
<raw-response>\r
200 >>code\r
"CGI output follows" >>message\r
swap '[\r
- _ output-stream get swap <cgi-process> <process-stream> [\r
+ _ output-stream get swap <cgi-process>
binary <process-stream> [
\r post-request? [ request get post-data>> raw>> write flush ] when\r
input-stream get swap (stream-copy)\r
] with-stream\r
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes help.markup help.syntax io.streams.string
+multiline ;
+IN: http.server.dispatchers
+
+HELP: new-dispatcher
+{ $values { "class" class } { "dispatcher" dispatcher } }
+{ $description "Creates a new instance of a subclass of " { $link dispatcher } "." } ;
+
+HELP: dispatcher
+{ $description "The class of dispatchers. May be subclassed, in which case subclasses should be constructed by calling " { $link new-dispatcher } "." } ;
+
+HELP: <dispatcher>
+{ $values { "dispatcher" dispatcher } }
+{ $description "Creates a new pathname dispatcher." } ;
+
+HELP: vhost-dispatcher
+{ $description "The class of virtual host dispatchers." } ;
+
+HELP: <vhost-dispatcher>
+{ $values { "dispatcher" vhost-dispatcher } }
+{ $description "Creates a new virtual host dispatcher." } ;
+
+HELP: add-responder
+{ $values
+ { "dispatcher" dispatcher } { "responder" "a responder" } { "path" "a pathname string or hostname" } }
+{ $description "Adds a responder to a dispatcher." }
+{ $notes "The " { $snippet "path" } " parameter is interpreted differently depending on the dispatcher type." }
+{ $side-effects "dispatcher" } ;
+
+ARTICLE: "http.server.dispatchers.example" "HTTP dispatcher examples"
+{ $heading "Simple pathname dispatcher" }
+{ $code
+ <" <dispatcher>
+ <new-action> "new" add-responder
+ <edit-action> "edit" add-responder
+ <delete-action> "delete" add-responder
+ <list-action> "" add-responder
+main-responder set-global">
+}
+"In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error."
+{ $heading "Another pathname dispatcher" }
+"On the other hand, suppose we wanted to route all unrecognized paths to a ``view'' action:"
+{ $code
+ <" <dispatcher>
+ <new-action> "new" add-responder
+ <edit-action> "edit" add-responder
+ <delete-action> "delete" add-responder
+ <view-action> >>default
+main-responder set-global">
+}
+"The " { $slot "default" } " slot holds a responder to which all unrecognized paths are sent to."
+{ $heading "Dispatcher subclassing example" }
+{ $code
+ <" TUPLE: golf-courses < dispatcher ;
+
+: <golf-courses> ( -- golf-courses )
+ golf-courses new-dispatcher ;
+
+<golf-courses>
+ <new-action> "new" add-responder
+ <edit-action> "edit" add-responder
+ <delete-action> "delete" add-responder
+ <list-action> "" add-responder
+main-responder set-global">
+}
+"The action templates can now emit links to responder-relative URLs prefixed by " { $snippet "$golf-courses/" } "."
+{ $heading "Virtual hosting example" }
+{ $code
+ <" <vhost-dispatcher>
+ <casino> "concatenative-casino.com" add-responder
+ <dating> "raptor-dating.com" add-responder
+main-responder set-global">
+}
+"Note that the virtual host dispatcher strips off a " { $snippet "www." } " prefix, so " { $snippet "www.concatenative-casino.com" } " would be routed to the " { $snippet "<casino>" } " responder instead of receiving a 404." ;
+
+ARTICLE: "http.server.dispatchers" "HTTP dispatchers and virtual hosting"
+"The " { $vocab-link "http.server.dispatchers" } " vocabulary implements two responders which route HTTP requests to one or more child responders."
+{ $subsection "http.server.dispatchers.example" }
+"Pathname dispatchers implement a directory hierarchy where each subdirectory is its own responder:"
+{ $subsection dispatcher }
+{ $subsection <dispatcher> }
+"Virtual host dispatchers dispatch each virtual host to a different responder:"
+{ $subsection vhost-dispatcher }
+{ $subsection <vhost-dispatcher> }
+"Adding responders to dispatchers:"
+{ $subsection add-responder }
+"The " { $slot "default" } " slot holds a responder which receives all unrecognized URLs. By default, it responds with 404 messages." ;
+
+ABOUT: "http.server.dispatchers"
--- /dev/null
+USING: help.markup help.syntax http.server ;
+IN: http.server.filters
+
+HELP: filter-responder
+{ $description "The class of filter responders. This class is intended to be subclassed." } ;
+
+ARTICLE: "http.server.filters" "HTTP responder filters"
+"The " { $vocab-link "http.server.filters" } " vocabulary implements the common pattern where one responder wraps another, doing some processing before calling the wrapped responder."
+{ $subsection filter-responder }
+"To use it, simply subclass " { $link filter-responder } ", and call " { $link POSTPONE: call-next-method } " from your " { $link call-responder* } " method to pass control to the wrapped responder." ;
+
+ABOUT: "http.server.filters"
--- /dev/null
+USING: help.markup help.syntax urls strings http ;
+IN: http.server.redirection
+
+HELP: relative-to-request
+{ $values { "url" "a " { $link url } " or " { $link string } } { "url'" "a " { $link url } " or " { $link string } } }
+{ $description "If the input is a relative " { $link url } ", makes it an absolute URL by resolving it to the current request's URL. If the input is a string, does nothing." } ;
+
+HELP: <permanent-redirect>
+{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } }
+{ $description "Redirects to the user to the URL after applying " { $link relative-to-request } "." }
+{ $notes "This redirect type should always be used with POST requests, and with GET requests in cases where the new URL always supercedes the old one. This is due to browsers caching the new URL with permanent redirects." } ;
+
+HELP: <temporary-redirect>
+{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } }
+{ $description "Redirects to the user to the URL after applying " { $link relative-to-request } "." }
+{ $notes "This redirect type should be used with GET requests where the new URL does not always supercede the old one. Use from POST requests with care, since this will cause the browser to resubmit the form to the new URL." } ;
+
+ARTICLE: "http.server.redirection" "HTTP responder redirection"
+"The " { $vocab-link "http.server.redirection" } " defines some " { $link response } " types which redirect the user's client to a new page."
+{ $subsection <permanent-redirect> }
+{ $subsection <temporary-redirect> }
+"A utility used by the above:"
+{ $subsection relative-to-request }
+"The " { $vocab-link "furnace.redirection" } " vocabulary provides a higher-level implementation of this. The " { $vocab-link "furnace.conversations" } " vocabulary allows state to be maintained between redirects." ;
+
+ABOUT: "http.server.redirection"
>>url
request set
- [ "http://www.apple.com:80/xxx/bar" ] [
+ [ "http://www.apple.com/xxx/bar" ] [
<url> relative-to-request present
] unit-test
- [ "http://www.apple.com:80/xxx/baz" ] [
+ [ "http://www.apple.com/xxx/baz" ] [
<url> "baz" >>path relative-to-request present
] unit-test
- [ "http://www.apple.com:80/xxx/baz?c=d" ] [
+ [ "http://www.apple.com/xxx/baz?c=d" ] [
<url> "baz" >>path { { "c" "d" } } >>query relative-to-request present
] unit-test
- [ "http://www.apple.com:80/xxx/bar?c=d" ] [
+ [ "http://www.apple.com/xxx/bar?c=d" ] [
<url> { { "c" "d" } } >>query relative-to-request present
] unit-test
- [ "http://www.apple.com:80/flip" ] [
+ [ "http://www.apple.com/flip" ] [
<url> "/flip" >>path relative-to-request present
] unit-test
- [ "http://www.apple.com:80/flip?c=d" ] [
+ [ "http://www.apple.com/flip?c=d" ] [
<url> "/flip" >>path { { "c" "d" } } >>query relative-to-request present
] unit-test
- [ "http://www.jedit.org:80/" ] [
+ [ "http://www.jedit.org/" ] [
"http://www.jedit.org" >url relative-to-request present
] unit-test
- [ "http://www.jedit.org:80/?a=b" ] [
+ [ "http://www.jedit.org/?a=b" ] [
"http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present
] unit-test
+
+ [ "http://www.jedit.org:1234/?a=b" ] [
+ "http://www.jedit.org:1234" >url { { "a" "b" } } >>query relative-to-request present
+ ] unit-test
] with-scope
--- /dev/null
+USING: help.markup help.syntax ;
+IN: http.server.remapping
+
+HELP: port-remapping
+{ $var-description "An assoc mapping port numbers that the HTTP server listens on to external port numbers presented to the user." } ;
+
+ARTICLE: "http.server.remapping" "HTTP server port remapping"
+"On Unix systems, non-root processes cannot bind to sockets on port numbers under 1024. Since running an HTTP server as root is a potential security risk, a typical setup runs an HTTP server under an ordinary user account, set up to listen on a higher port number such as 8080. Then, the HTTP port is redirected to 8080. On Linux, this might be done using commands such as the following:"
+{ $code
+ "echo 1 > /proc/sys/net/ipv4/ip_forward"
+ "iptables -t nat -F"
+ "iptables -A PREROUTING -t nat -i eth0 -p tcp --dport 443 -j DNAT --to :8443"
+ "iptables -A PREROUTING -t nat -i eth0 -p tcp --dport 80 -j DNAT --to :8080"
+}
+"However, the HTTP server is unaware of the forwarding, and still believes that it is listening on port 8080 and 8443, respectively. This can be a problem if a responder wishes to redirect the user to a secure page; they will be sent to port 8443 and not 443 as one would expect."
+$nl
+"The " { $vocab-link "http.server.remapping" } " vocabulary defines a variable which may store an assoc of port mappings:"
+{ $subsection port-remapping }
+"For example, with the above setup, we would set it as follows:"
+{ $code
+ "{ { 8080 80 } { 8443 443 } } port-remapping set-global"
+} ;
+
+ABOUT: "http.server.remapping"
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs kernel io.servers.connection ;
+IN: http.server.remapping
+
+SYMBOL: port-remapping
+
+: remap-port ( n -- n' )
+ [ port-remapping get at ] keep or ;
+
+: secure-http-port ( -- n )
+ secure-port remap-port ;
--- /dev/null
+USING: help.markup help.syntax io.streams.string strings
+http math ;
+IN: http.server.responses
+
+HELP: <content>
+{ $values { "body" "a response body" } { "content-type" string } { "response" response } }
+{ $description "Creates a successful HTTP response which sends a response body with the specified content type to the client." } ;
+
+HELP: <trivial-response>
+{ $values { "code" integer } { "message" string } { "response" response } }
+{ $description "Creates an HTTP error response." }
+{ $examples
+ { $code
+ "USE: http.server.responses"
+ "415 \"Unsupported Media Type\" <trivial-response>"
+ }
+} ;
+
+ARTICLE: "http.server.responses" "Canned HTTP responses"
+"The " { $vocab-link "http.server.responses" } " vocabulary provides constructors for a few useful " { $link response } " objects."
+{ $subsection <content> }
+{ $subsection <304> }
+{ $subsection <403> }
+{ $subsection <400> }
+{ $subsection <404> }
+"New error responses like the above can be created for other error codes too:"
+{ $subsection <trivial-response> } ;
+
+ABOUT: "http.server.responses"
--- /dev/null
+USING: help.markup help.syntax io.streams.string quotations strings urls http tools.vocabs math io.servers.connection ;
+IN: http.server
+
+HELP: trivial-responder
+{ $description "The class of trivial responders, which output the same response for every request. New instances are created by calling " { $link <trivial-responder> } "." } ;
+
+HELP: <trivial-responder> ( response -- responder )
+{ $values { "response" response } { "responder" trivial-responder } }
+{ $description "Creates a new trivial responder which outputs the same response for every request." } ;
+
+HELP: benchmark?
+{ $var-description "If set to a true value, the HTTP server will log the time taken to process each request." } ;
+
+HELP: call-responder
+{ $values
+ { "path" "a sequence of strings" } { "responder" "a responder" }
+ { "response" response } }
+{ $description "Calls a responder." } ;
+
+HELP: call-responder*
+{ $values
+ { "path" "a sequence of strings" } { "responder" "a responder" }
+ { "response" response } }
+{ $contract "Processes an HTTP request and returns a response." }
+{ $notes "When this word is called, various dynamic variables are set; see " { $link "http.server.requests" } "." } ;
+
+HELP: development?
+{ $var-description "If set to a true value, the HTTP server will call " { $link refresh-all } " on each request, and error pages will contain stack traces." } ;
+
+HELP: main-responder
+{ $var-description "The responder which will handle HTTP requests." } ;
+
+HELP: post-request?
+{ $values { "?" "a boolean" } }
+{ $description "Outputs if the current request is a POST request.s" } ;
+
+HELP: responder-nesting
+{ $description "A sequence of " { $snippet "{ path responder }" } " pairs." } ;
+
+HELP: http-server
+{ $class-description "The class of HTTP servers. New instances are created by calling " { $link <http-server> } "." } ;
+
+HELP: <http-server>
+{ $values { "server" http-server } }
+{ $description "Creates a new HTTP server with default parameters." } ;
+
+HELP: httpd
+{ $values { "port" integer } }
+{ $description "Starts an HTTP server on the specified port number." }
+{ $notes "For more flexibility, use " { $link <http-server> } " and fill in the tuple slots before calling " { $link start-server } "." } ;
+
+HELP: http-insomniac
+{ $description "Starts a thread which rotates the logs and e-mails a summary of HTTP requests every 24 hours. See " { $link "logging.insomniac" } "." } ;
+
+ARTICLE: "http.server.requests" "HTTP request variables"
+"The following variables are set by the HTTP server at the beginning of a request."
+{ $subsection request }
+{ $subsection url }
+{ $subsection post-request? }
+{ $subsection responder-nesting }
+"Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
+
+ARTICLE: "http.server.responders" "HTTP server responders"
+"The HTTP server dispatches requests to a main responder:"
+{ $subsection main-responder }
+"The main responder may in turn dispatch it a subordinate dispatcher, and so on."
+$nl
+"Responders process requests and output " { $link "http.responses" } "; concretely are instances of classes which implement a generic word:"
+{ $subsection call-responder* }
+"To actually call a subordinate responder, use the following word instead:"
+{ $subsection call-responder }
+"A simple implementation of a responder which always outputs the same response:"
+{ $subsection trivial-responder }
+{ $subsection <trivial-responder> }
+{ $vocab-subsection "Furnace actions" "furnace.actions" }
+"In particular, writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead." ;
+
+ARTICLE: "http.server.variables" "HTTP server variables"
+"The following global variables control the behavior of the HTTP server. Both are off by default."
+{ $subsection development? }
+{ $subsection benchmark? } ;
+
+ARTICLE: "http.server" "HTTP server"
+"The " { $vocab-link "http.server" } " vocabulary implements an HTTP and HTTPS server on top of " { $vocab-link "io.servers.connection" } "."
+{ $subsection "http.server.responders" }
+{ $subsection "http.server.requests" }
+"Various types of responders are defined in other vocabularies:"
+{ $subsection "http.server.dispatchers" }
+{ $subsection "http.server.filters" }
+"Useful canned responses:"
+{ $subsection "http.server.responses" }
+{ $subsection "http.server.redirection" }
+"Configuration:"
+{ $subsection "http.server.variables" }
+{ $subsection "http.server.remapping" }
+"Features:"
+{ $subsection "http.server.static" }
+{ $subsection "http.server.cgi" }
+"The " { $vocab-link "furnace" } " framework implements high-level abstractions which make developing web applications much easier than writing responders by hand." ;
+
+ABOUT: "http.server"
io.streams.limited
io.servers.connection
io.timeouts
-fry logging logging.insomniac calendar urls
+fry logging logging.insomniac calendar urls urls.encoding
http
http.parsers
http.server.responses
+http.server.remapping
html.templates
html.elements
html.streams ;
[ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- )
- "Internal server error" [
- [ print-error nl :c ] with-html-stream
+ "Internal server error" [ ] [
+ [ print-error nl :c ] with-html-writer
] simple-page ;
: <500> ( error -- response )
[
local-address get
[ secure? "https" "http" ? >>protocol ]
- [ port>> '[ _ or ] change-port ]
+ [ port>> remap-port '[ _ or ] change-port ]
bi
] change-url drop ;
: valid-request? ( request -- ? )
- url>> port>> local-address get port>> = ;
+ url>> port>> remap-port
+ local-address get port>> remap-port = ;
: do-request ( request -- response )
'[
_
{
- [ init-request ]
[ prepare-request ]
+ [ init-request ]
[ log-request ]
[ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
} cleave
: http-insomniac ( -- )
"http.server" { "httpd-hit" } schedule-insomniac ;
+
+USE: vocabs.loader
+
+"http.server.filters" require
+"http.server.dispatchers" require
+"http.server.redirection" require
+"http.server.static" require
+"http.server.cgi" require
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string ;
+IN: http.server.static
+
+HELP: <file-responder>
+{ $values { "root" "a pathname string" } { "hook" "a quotation with stack effect " { $snippet "( path mime-type -- response )" } } { "responder" file-responder } }
+{ $description "Creates a file responder which serves content from " { $snippet "path" } " by using the hook to generate a response." } ;
+
+HELP: <static>
+{ $values
+ { "root" "a pathname string" }
+ { "responder" file-responder } }
+ { $description "Creates a file responder which serves content from " { $snippet "path" } "." } ;
+
+HELP: enable-fhtml
+{ $values { "responder" file-responder } }
+{ $description "Enables the responder to serve " { $snippet ".fhtml" } " files by running them." }
+{ $notes "See " { $link "html.templates.fhtml" } "." }
+{ $side-effects "responder" } ;
+
+ARTICLE: "http.server.static" "Serving static content"
+"The " { $vocab-link "http.server.static" } " vocabulary implements a responder for serving static files."
+{ $subsection <static> }
+"The static responder does not serve directory listings by default, as a security measure. Directory listings can be enabled by storing a true value in the " { $slot "allow-listings" } " slot."
+$nl
+"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- )" } "."
+$nl
+"A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:"
+{ $subsection enable-fhtml }
+"This feature is also used by " { $vocab-link "http.server.cgi" } " to run " { $snippet ".cgi" } " files."
+$nl
+"It is also possible to override the hook used when serving static files to the client:"
+{ $subsection <file-responder> }
+"The default just sends the file's contents with the request; " { $vocab-link "xmode.code2html.responder" } " provides an alternate hook which sends a syntax-highlighted version of the file." ;
+
+ABOUT: "http.server.static"
http.server.redirection ;\r
IN: http.server.static\r
\r
-! special maps mime types to quots with effect ( path -- )\r
TUPLE: file-responder root hook special allow-listings ;\r
\r
: modified-since? ( filename -- ? )\r
dup <a =href a> escape-string write </a> ;\r
\r
: directory. ( path -- )\r
- dup file-name [\r
+ dup file-name [ ] [\r
[ <h1> file-name escape-string write </h1> ]\r
[\r
<ul>\r
+web
enterprise
network
-web
$nl
"Buffers are used to implement native I/O backends."
$nl
-"Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
+"Buffer words are found in the " { $vocab-link "io.buffers" } " vocabulary."
{ $subsection buffer }
{ $subsection <buffer> }
"Buffers must be manually deallocated by calling " { $link dispose } "."
PRIVATE>
"resource:basis/io/encodings/iana/character-sets"
-ascii <file-reader> make-n>e \ n>e-table set-value
+ascii <file-reader> make-n>e to: n>e-table
GENERIC: >process ( obj -- process )
-ERROR: process-already-started ;
+ERROR: process-already-started process ;
-M: process-already-started summary
- drop "Process has already been started once" ;
+M: process-already-started error.
+ "Process has already been started" print nl
+ "Launch descriptor:" print nl
+ process>> . ;
M: process >process
dup process-started? [
HOOK: run-process* io-backend ( process -- handle )
-ERROR: process-was-killed ;
+ERROR: process-was-killed process ;
+
+M: process-was-killed error.
+ "Process was killed as a result of a call to" print
+ "kill-process, or a timeout" print
+ nl
+ "Launch descriptor:" print nl
+ process>> . ;
: wait-for-process ( process -- status )
[
"Launch descriptor:" print nl
process>> . ;
-: try-process ( desc -- )
- run-process dup wait-for-process dup zero?
+: wait-for-success ( process -- )
+ dup wait-for-process dup zero?
[ 2drop ] [ process-failed ] if ;
+: try-process ( desc -- )
+ run-process wait-for-success ;
+
HOOK: kill-process* io-backend ( handle -- )
: kill-process ( process -- )
3bi
wait-for-process ;
-: <process-reader*> ( process encoding -- process stream )
+: <process-reader*> ( desc encoding -- stream process )
[
>r (pipe) {
[ |dispose drop ]
]
[ out>> dispose ]
[ in>> <input-port> ]
- } cleave r> <decoder>
+ } cleave r> <decoder> swap
] with-destructors ;
: <process-reader> ( desc encoding -- stream )
- <process-reader*> nip ; inline
+ <process-reader*> drop ; inline
+
+: with-process-reader ( desc encoding quot -- )
+ [ <process-reader*> ] dip
+ swap [ with-input-stream ] dip
+ wait-for-success ; inline
-: <process-writer*> ( process encoding -- process stream )
+: <process-writer*> ( desc encoding -- stream process )
[
>r (pipe) {
[ |dispose drop ]
]
[ in>> dispose ]
[ out>> <output-port> ]
- } cleave r> <encoder>
+ } cleave r> <encoder> swap
] with-destructors ;
: <process-writer> ( desc encoding -- stream )
- <process-writer*> nip ; inline
+ <process-writer*> drop ; inline
-: <process-stream*> ( process encoding -- process stream )
+: with-process-writer ( desc encoding quot -- )
+ [ <process-writer*> ] dip
+ swap [ with-output-stream ] dip
+ wait-for-success ; inline
+
+: <process-stream*> ( desc encoding -- stream process )
[
>r (pipe) (pipe) {
[ [ |dispose drop ] bi@ ]
]
[ [ out>> dispose ] [ in>> dispose ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
- } 2cleave r> <encoder-duplex>
+ } 2cleave r> <encoder-duplex> swap
] with-destructors ;
: <process-stream> ( desc encoding -- stream )
- <process-stream*> nip ; inline
+ <process-stream*> drop ; inline
+
+: with-process-stream ( desc encoding quot -- )
+ [ <process-stream*> ] dip
+ swap [ with-stream ] dip
+ wait-for-success ; inline
: notify-exit ( process status -- )
>>status
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint debugger
-quotations combinators logging calendar assocs
+quotations combinators logging calendar assocs present
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
-io.encodings threads concurrency.combinators
+io.encodings threads make concurrency.combinators
concurrency.semaphores concurrency.flags
combinators.short-circuit ;
IN: io.servers.connection
[ secure>> >secure ] [ insecure>> >insecure ] bi
[ resolve-host ] bi@ append ;
-LOG: accepted-connection NOTICE
+: accepted-connection ( remote local -- )
+ [
+ [ "remote: " % present % ", " % ]
+ [ "local: " % present % ]
+ bi*
+ ] "" make
+ \ accepted-connection NOTICE log-message ;
: log-connection ( remote local -- )
+ [ accepted-connection ]
[ [ remote-address set ] [ local-address set ] bi* ]
- [ 2array accepted-connection ]
2bi ;
M: threaded-server handle-client* handler>> call ;
[ timeout>> timeouts ] [ handle-client* ] bi
] with-stream ;
+\ handle-client ERROR add-error-logging
+
: thread-name ( server-name addrspec -- string )
unparse-short " connection from " swap 3append ;
dup secure-config>> [
dup threaded-server [
dup name>> [
- listen-on [
- start-accept-loop
- ] parallel-each
+ [ listen-on [ start-accept-loop ] parallel-each ]
+ [ ready>> raise-flag ]
+ bi
] with-logging
] with-variable
] with-secure-context ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
destructors io.sockets sequences summary calendar delegate
-system vocabs.loader combinators ;
+system vocabs.loader combinators present ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
C: <secure> secure
+M: secure present addrspec>> present " (secure)" append ;
+
CONSULT: inet secure addrspec>> ;
M: secure resolve-host ( secure -- seq )
sequences arrays io.encodings io.ports io.streams.duplex
io.encodings.ascii alien.strings io.binary accessors destructors
classes debugger byte-arrays system combinators parser
-alien.c-types math.parser splitting grouping
-math assocs summary system vocabs.loader combinators ;
+alien.c-types math.parser splitting grouping math assocs summary
+system vocabs.loader combinators present ;
IN: io.sockets
<< {
: <local> ( path -- addrspec )
normalize-path local boa ;
-TUPLE: inet4 host port ;
+M: local present path>> "Unix domain socket: " prepend ;
+
+TUPLE: abstract-inet host port ;
+
+M: abstract-inet present
+ [ host>> ":" ] [ port>> number>string ] bi 3append ;
+
+TUPLE: inet4 < abstract-inet ;
C: <inet4> inet4
>r dup sockaddr-in-addr <uint> r> inet-ntop
swap sockaddr-in-port ntohs <inet4> ;
-TUPLE: inet6 host port ;
+TUPLE: inet6 < abstract-inet ;
C: <inet6> inet6
GENERIC: resolve-host ( addrspec -- seq )
-TUPLE: inet host port ;
+TUPLE: inet < abstract-inet ;
C: <inet> inet
ARTICLE: "styles" "Formatted output"
"The " { $link stream-format } ", " { $link with-style } ", " { $link with-nesting } " and " { $link tabular-output } " words take a hashtable of style attributes. Output stream implementations are free to ignore style information."
$nl
-"Style hashtables are keyed by symbols from the " { $vocab-link "styles" } " vocabulary."
+"Style hashtables are keyed by symbols from the " { $vocab-link "io.styles" } " vocabulary."
{ $subsection "character-styles" }
{ $subsection "paragraph-styles" }
{ $subsection "table-styles" }
SYMBOL: presented-path
SYMBOL: presented-printer
+SYMBOL: href
+
! Paragraph styles
SYMBOL: page-color
SYMBOL: border-color
! Non-recursive
[ ] [ "monitor-test-self" temp-file f <monitor> "m" set ] unit-test
+ [ ] [ 3 seconds "m" get set-timeout ] unit-test
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
! Recursive
[ ] [ "monitor-test-self" temp-file t <monitor> "m" set ] unit-test
+ [ ] [ 3 seconds "m" get set-timeout ] unit-test
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
{
{ SSL_ERROR_NONE [ 2drop f ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
+ { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
+ { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;
[ f ] [ "\\foo" absolute-path? ] unit-test
[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test
[ t ] [ "c:\\foo" absolute-path? ] unit-test
[ t ] [ "c:" absolute-path? ] unit-test
+[ t ] [ "c:\\" absolute-path? ] unit-test
+[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
+[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test
+[ t ] [ "\\\\?\\c:" root-directory? ] unit-test
+[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test
[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
M: winnt root-directory? ( path -- ? )
{
- { [ dup empty? ] [ f ] }
- { [ dup [ path-separator? ] all? ] [ t ] }
- { [ dup trim-right-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
- [ f ]
- } cond nip ;
+ { [ dup empty? ] [ drop f ] }
+ { [ dup [ path-separator? ] all? ] [ drop t ] }
+ { [ dup trim-right-separators { [ length 2 = ]
+ [ second CHAR: : = ] } 1&& ] [ drop t ] }
+ { [ dup unicode-prefix head? ]
+ [ trim-right-separators length unicode-prefix length 2 + = ] }
+ [ drop f ]
+ } cond ;
ERROR: not-absolute-path ;
} ;
HELP: [let*
-{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
+{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated sequentially, and may refer to previous bindings from the same " { $link POSTPONE: [let* } " form; for Lisp programmers, this means that " { $link POSTPONE: [let* } " is equivalent to the Lisp " { $snippet "let*" } ", not " { $snippet "let" } "." }
{ $examples
{ $example
HELP: ::
{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
-{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
+{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." }
{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." }
{ $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ;
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
ARTICLE: "locals-mutable" "Mutable locals"
-"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's with the " { $snippet "!" } " suffix."
+"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's with the " { $snippet "!" } " suffix."
$nl
"Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:"
{ $code
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
-combinators.short-circuit.smart ;
+combinators.short-circuit.smart math.order ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
[ T{ slice f 0 3 "abc" } ]
[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
-{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
\ No newline at end of file
+{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
+
+:: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
+ obj1 obj2 <=> {
+ { +lt+ [ lt-quot call ] }
+ { +eq+ [ eq-quot call ] }
+ { +gt+ [ gt-quot call ] }
+ } case ; inline
+
+[ [ ] [ ] [ ] compare-case ] must-infer
\ No newline at end of file
{ $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
ARTICLE: "logging.analysis" "Log analysis"
-"The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logger.insomniac" } " vocabulary to e-mail daily reports."
+"The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logging.insomniac" } " vocabulary to e-mail daily reports."
$nl
"Print log file summary:"
{ $subsection analyze-log }
"The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ;
ARTICLE: "logging.server" "Log implementation"
-"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead it uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion."
+"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency.messaging" } ". User code never interacts with the server directly, instead it uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion."
$nl
"The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:"
{ $subsection (log-message) }
IN: macros.expander.tests
USING: macros.expander tools.test math combinators.short-circuit
-kernel ;
+kernel combinators ;
[ t ] [ 20 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test
[ f ] [ 15 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test
[ f ] [ 5.0 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test
+
+[ [ no-case ] ] [ [ { } case ] expand-macros ] unit-test
stack get pop >quotation end (expand-macros) ;
: expand-macro? ( word -- quot ? )
- dup [ "macro" word-prop ] [ "transform-quot" word-prop ] bi or dup [
- swap [ stack-effect in>> length ] [ "transform-n" word-prop ] bi or
+ dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
+ swap [ "transform-n" word-prop ] [ stack-effect in>> length ] bi or
stack get length <=
] [ 2drop f f ] if ;
ARTICLE: "ranges" "Ranges"
"A " { $emphasis "range" } " is a virtual sequence with real number elements "
-"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
+"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } ". Ascending as well as descending ranges are supported."
$nl
"The class of ranges:"
{ $subsection range }
"Creating general ranges:"
{ $subsection <range> }
"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example,"
-{ $code
- "3 10 [a,b] [ sqrt ] map"
-}
+{ $code "3 10 [a,b] [ sqrt ] map" }
+"Computing the factorial of 100 with a descending range:"
+{ $code "100 1 [a,b] product" }
"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
ABOUT: "ranges"
\ No newline at end of file
\r
! should be able to move by a page of 10\r
[ 10 ] [ \r
- setup-range 10 over set-range-page-value \r
- 1 over move-by-page range-value \r
+ setup-range 10 over set-range-page-value \r
+ 1 over move-by-page range-value \r
] unit-test\r
[ "foo\nbar\n" ] [ test-it ] unit-test
[ "foo\nbar\n" ] [ <" foo
bar
- "> ] unit-test
+"> ] unit-test
+
+[ "hello\nworld" ] [ <" hello
+world"> ] unit-test
: parse-multiline-string ( end-text -- str )
[
lexer get [ swap (parse-multiline-string) ] change-column drop
- ] "" make rest-slice but-last ;
+ ] "" make rest ;
: <"
"\">" parse-multiline-string parsed ; parsing
--- /dev/null
+Doug Coleman
--- /dev/null
+Generalization of make for constructing several sequences simultaneously
--- /dev/null
+collections
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
[ first2 [ >fixnum ] bi@ ] bi@ ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: gl-color ( color -- ) first4 glColor4d ; inline
: gl-clear-color ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
: color>raw ( object -- r g b a )
- >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
+ >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
-: set-color ( object -- ) color>raw glColor4d ;
+: set-color ( object -- ) color>raw glColor4d ;
: set-clear-color ( object -- ) color>raw glClearColor ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: gl-error ( -- )
glGetError dup zero? [
"GL error: " over gluErrorString append throw
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
: (all-enabled-client-state) ( seq quot -- )
- over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline
+ [ dup [ glEnableClientState ] each ] dip
+ dip
+ [ glDisableClientState ] each ; inline
MACRO: all-enabled ( seq quot -- )
>r words>values r> [ (all-enabled) ] 2curry ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: present
+USING: help.markup help.syntax kernel strings ;
+
+ARTICLE: "present" "Converting objects to human-readable strings"
+"A word for converting an object into a human-readable string:"
+{ $subsection present } ;
+
+HELP: present
+{ $values { "object" object } { "string" string } }
+{ $contract "Outputs a human-readable string from an object." }
+{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $link "html.components" } " or " { $link "urls" } " vocabularies." } ;
+
+ABOUT: "present"
--- /dev/null
+Generic word for converting objects to strings for human consumption
: callstack. ( callstack -- )
callstack>array 2 <groups> [
remove-breakpoints
- 3 nesting-limit [ . ] with-variable
+ [
+ 3 nesting-limit set
+ 100 length-limit set
+ .
+ ] with-scope
] assoc-each ;
: .c ( -- ) callstack callstack. ;
: pprint-; ( -- ) \ ; pprint-word ;
-: (see) ( spec -- )
- <colon dup synopsis*
- <block dup definition pprint-elements block>
- dup definer nip [ pprint-word ] when* declarations.
- block> ;
-
M: object see
- [ (see) ] with-use nl ;
+ [
+ 12 nesting-limit set
+ 100 length-limit set
+ <colon dup synopsis*
+ <block dup definition pprint-elements block>
+ dup definer nip [ pprint-word ] when* declarations.
+ block>
+ ] with-use nl ;
GENERIC: see-class* ( word -- )
dup class? over symbol? not and [
nl
] when
- dup class? over symbol? and not [
- [ dup (see) ] with-use nl
- ] when
- drop ;
+ dup [ class? ] [ symbol? ] bi and
+ [ drop ] [ call-next-method ] if ;
: see-all ( seq -- )
natural-sort [ nl ] [ see ] interleave ;
--- /dev/null
+Doug Coleman
+Slava Pestov
--- /dev/null
+Random number generator protocol and implementations
+! Copyright (C) 2008 Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io io.files kernel namespaces random
io.encodings.binary init accessors system ;
IN: random.unix
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors hashtables kernel math state-tables vars vectors ;
+IN: regexp.backend
+
+TUPLE: regexp
+ raw
+ { stack vector }
+ parse-tree
+ { options hashtable }
+ nfa-table
+ dfa-table
+ minimized-table
+ { nfa-traversal-flags hashtable }
+ { dfa-traversal-flags hashtable }
+ { state integer }
+ { new-states vector }
+ { visited-states hashtable } ;
+
+: reset-regexp ( regexp -- regexp )
+ 0 >>state
+ V{ } clone >>stack
+ V{ } clone >>new-states
+ H{ } clone >>visited-states ;
+
+SYMBOL: current-regexp
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math math.order symbols regexp.parser
+words regexp.utils unicode.categories combinators.short-circuit ;
+IN: regexp.classes
+
+GENERIC: class-member? ( obj class -- ? )
+
+M: word class-member? ( obj class -- ? ) 2drop f ;
+M: integer class-member? ( obj class -- ? ) 2drop f ;
+
+M: character-class-range class-member? ( obj class -- ? )
+ [ from>> ] [ to>> ] bi between? ;
+
+M: any-char class-member? ( obj class -- ? )
+ 2drop t ;
+
+M: letter-class class-member? ( obj class -- ? )
+ drop letter? ;
+
+M: LETTER-class class-member? ( obj class -- ? )
+ drop LETTER? ;
+
+M: Letter-class class-member? ( obj class -- ? )
+ drop Letter? ;
+
+M: ascii-class class-member? ( obj class -- ? )
+ drop ascii? ;
+
+M: digit-class class-member? ( obj class -- ? )
+ drop digit? ;
+
+M: alpha-class class-member? ( obj class -- ? )
+ drop alpha? ;
+
+M: punctuation-class class-member? ( obj class -- ? )
+ drop punct? ;
+
+M: java-printable-class class-member? ( obj class -- ? )
+ drop java-printable? ;
+
+M: non-newline-blank-class class-member? ( obj class -- ? )
+ drop { [ blank? ] [ CHAR: \n = not ] } 1&& ;
+
+M: control-character-class class-member? ( obj class -- ? )
+ drop control-char? ;
+
+M: hex-digit-class class-member? ( obj class -- ? )
+ drop hex-digit? ;
+
+M: java-blank-class class-member? ( obj class -- ? )
+ drop java-blank? ;
+
+M: unmatchable-class class-member? ( obj class -- ? )
+ 2drop f ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators fry kernel locals
+math math.order regexp.nfa regexp.transition-tables sequences
+sets sorting vectors regexp.utils sequences.deep ;
+USING: io prettyprint threads ;
+IN: regexp.dfa
+
+: find-delta ( states transition regexp -- new-states )
+ nfa-table>> transitions>>
+ rot [ swap at at ] with with gather sift ;
+
+: (find-epsilon-closure) ( states regexp -- new-states )
+ eps swap find-delta ;
+
+: find-epsilon-closure ( states regexp -- new-states )
+ '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
+ natural-sort ;
+
+: find-closure ( states transition regexp -- new-states )
+ [ find-delta ] 2keep nip find-epsilon-closure ;
+
+: find-start-state ( regexp -- state )
+ [ nfa-table>> start-state>> 1vector ] keep find-epsilon-closure ;
+
+: find-transitions ( seq1 regexp -- seq2 )
+ nfa-table>> transitions>>
+ [ at keys ] curry gather
+ eps swap remove ;
+
+: add-todo-state ( state regexp -- )
+ 2dup visited-states>> key? [
+ 2drop
+ ] [
+ [ visited-states>> conjoin ]
+ [ new-states>> push ] 2bi
+ ] if ;
+
+: new-transitions ( regexp -- )
+ dup new-states>> [
+ drop
+ ] [
+ dupd pop dup pick find-transitions rot
+ [
+ [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
+ >r swapd transition make-transition r> dfa-table>> add-transition
+ ] curry with each
+ new-transitions
+ ] if-empty ;
+
+: states ( hashtable -- array )
+ [ keys ]
+ [ values [ values concat ] map concat append ] bi ;
+
+: set-final-states ( regexp -- )
+ dup
+ [ nfa-table>> final-states>> keys ]
+ [ dfa-table>> transitions>> states ] bi
+ [ intersect empty? not ] with filter
+
+ swap dfa-table>> final-states>>
+ [ conjoin ] curry each ;
+
+: set-initial-state ( regexp -- )
+ dup
+ [ dfa-table>> ] [ find-start-state ] bi
+ [ >>start-state drop ] keep
+ 1vector >>new-states drop ;
+
+: set-traversal-flags ( regexp -- )
+ dup
+ [ nfa-traversal-flags>> ]
+ [ dfa-table>> transitions>> keys ] bi
+ [ tuck [ swap at ] with map concat ] with H{ } map>assoc
+ >>dfa-traversal-flags drop ;
+
+: construct-dfa ( regexp -- )
+ {
+ [ set-initial-state ]
+ [ new-transitions ]
+ [ set-final-states ]
+ [ set-traversal-flags ]
+ } cleave ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs grouping kernel regexp.backend
+locals math namespaces regexp.parser sequences state-tables fry
+quotations math.order math.ranges vectors unicode.categories
+regexp.utils regexp.transition-tables words sets ;
+IN: regexp.nfa
+
+SYMBOL: negation-mode
+: negated? ( -- ? ) negation-mode get 0 or odd? ;
+
+SINGLETON: eps
+
+MIXIN: traversal-flag
+SINGLETON: lookahead-on INSTANCE: lookahead-on traversal-flag
+SINGLETON: lookahead-off INSTANCE: lookahead-off traversal-flag
+SINGLETON: lookbehind-on INSTANCE: lookbehind-on traversal-flag
+SINGLETON: lookbehind-off INSTANCE: lookbehind-off traversal-flag
+SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
+SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
+
+: next-state ( regexp -- state )
+ [ state>> ] [ [ 1+ ] change-state drop ] bi ;
+
+: set-start-state ( regexp -- )
+ dup stack>> [
+ drop
+ ] [
+ [ nfa-table>> ] [ pop first ] bi* >>start-state drop
+ ] if-empty ;
+
+GENERIC: nfa-node ( node -- )
+
+:: add-simple-entry ( obj class -- )
+ [let* | regexp [ current-regexp get ]
+ s0 [ regexp next-state ]
+ s1 [ regexp next-state ]
+ stack [ regexp stack>> ]
+ table [ regexp nfa-table>> ] |
+ negated? [
+ s0 f obj class make-transition table add-transition
+ s0 s1 <default-transition> table add-transition
+ ] [
+ s0 s1 obj class make-transition table add-transition
+ ] if
+ s0 s1 2array stack push
+ t s1 table final-states>> set-at ] ;
+
+: add-traversal-flag ( flag -- )
+ stack peek second
+ current-regexp get nfa-traversal-flags>> push-at ;
+
+:: concatenate-nodes ( -- )
+ [let* | regexp [ current-regexp get ]
+ stack [ regexp stack>> ]
+ table [ regexp nfa-table>> ]
+ s2 [ stack peek first ]
+ s3 [ stack pop second ]
+ s0 [ stack peek first ]
+ s1 [ stack pop second ] |
+ s1 s2 eps <literal-transition> table add-transition
+ s1 table final-states>> delete-at
+ s0 s3 2array stack push ] ;
+
+:: alternate-nodes ( -- )
+ [let* | regexp [ current-regexp get ]
+ stack [ regexp stack>> ]
+ table [ regexp nfa-table>> ]
+ s2 [ stack peek first ]
+ s3 [ stack pop second ]
+ s0 [ stack peek first ]
+ s1 [ stack pop second ]
+ s4 [ regexp next-state ]
+ s5 [ regexp next-state ] |
+ s4 s0 eps <literal-transition> table add-transition
+ s4 s2 eps <literal-transition> table add-transition
+ s1 s5 eps <literal-transition> table add-transition
+ s3 s5 eps <literal-transition> table add-transition
+ s1 table final-states>> delete-at
+ s3 table final-states>> delete-at
+ t s5 table final-states>> set-at
+ s4 s5 2array stack push ] ;
+
+M: kleene-star nfa-node ( node -- )
+ term>> nfa-node
+ [let* | regexp [ current-regexp get ]
+ stack [ regexp stack>> ]
+ s0 [ stack peek first ]
+ s1 [ stack pop second ]
+ s2 [ regexp next-state ]
+ s3 [ regexp next-state ]
+ table [ regexp nfa-table>> ] |
+ s1 table final-states>> delete-at
+ t s3 table final-states>> set-at
+ s1 s0 eps <literal-transition> table add-transition
+ s2 s0 eps <literal-transition> table add-transition
+ s2 s3 eps <literal-transition> table add-transition
+ s1 s3 eps <literal-transition> table add-transition
+ s2 s3 2array stack push ] ;
+
+M: concatenation nfa-node ( node -- )
+ seq>>
+ [ [ nfa-node ] each ]
+ [ length 1- [ concatenate-nodes ] times ] bi ;
+
+M: alternation nfa-node ( node -- )
+ seq>>
+ [ [ nfa-node ] each ]
+ [ length 1- [ alternate-nodes ] times ] bi ;
+
+M: constant nfa-node ( node -- )
+ char>> literal-transition add-simple-entry ;
+
+M: epsilon nfa-node ( node -- )
+ drop eps literal-transition add-simple-entry ;
+
+M: word nfa-node ( node -- )
+ class-transition add-simple-entry ;
+
+M: character-class-range nfa-node ( node -- )
+ class-transition add-simple-entry ;
+
+M: capture-group nfa-node ( node -- )
+ eps literal-transition add-simple-entry
+ capture-group-on add-traversal-flag
+ term>> nfa-node
+ eps literal-transition add-simple-entry
+ capture-group-off add-traversal-flag
+ 2 [ concatenate-nodes ] times ;
+
+! xyzzy
+M: non-capture-group nfa-node ( node -- )
+ term>> nfa-node ;
+
+M: reluctant-kleene-star nfa-node ( node -- )
+ term>> <kleene-star> nfa-node ;
+
+!
+
+M: negation nfa-node ( node -- )
+ negation-mode inc
+ term>> nfa-node
+ negation-mode dec ;
+
+M: lookahead nfa-node ( node -- )
+ eps literal-transition add-simple-entry
+ lookahead-on add-traversal-flag
+ term>> nfa-node
+ eps literal-transition add-simple-entry
+ lookahead-off add-traversal-flag
+ 2 [ concatenate-nodes ] times ;
+
+M: lookbehind nfa-node ( node -- )
+ eps literal-transition add-simple-entry
+ lookbehind-on add-traversal-flag
+ term>> nfa-node
+ eps literal-transition add-simple-entry
+ lookbehind-off add-traversal-flag
+ 2 [ concatenate-nodes ] times ;
+
+: construct-nfa ( regexp -- )
+ [
+ reset-regexp
+ negation-mode off
+ [ current-regexp set ]
+ [ parse-tree>> nfa-node ]
+ [ set-start-state ] tri
+ ] with-scope ;
--- /dev/null
+USING: kernel tools.test regexp.backend regexp ;
+IN: regexp.parser
+
+: test-regexp ( string -- )
+ default-regexp parse-regexp ;
+
+! [ "(" ] [ unmatched-parentheses? ] must-fail-with
+
+[ ] [ "a|b" test-regexp ] unit-test
+[ ] [ "a.b" test-regexp ] unit-test
+[ ] [ "a|b|c" test-regexp ] unit-test
+[ ] [ "abc|b" test-regexp ] unit-test
+[ ] [ "a|bcd" test-regexp ] unit-test
+[ ] [ "a|(b)" test-regexp ] unit-test
+[ ] [ "(a)|b" test-regexp ] unit-test
+[ ] [ "(a|b)" test-regexp ] unit-test
+[ ] [ "((a)|(b))" test-regexp ] unit-test
+
+[ ] [ "(?:a)" test-regexp ] unit-test
+[ ] [ "(?i:a)" test-regexp ] unit-test
+[ ] [ "(?-i:a)" test-regexp ] unit-test
+[ "(?z:a)" test-regexp ] [ bad-option? ] must-fail-with
+[ "(?-z:a)" test-regexp ] [ bad-option? ] must-fail-with
+
+[ ] [ "(?=a)" test-regexp ] unit-test
+
+[ ] [ "[abc]" test-regexp ] unit-test
+[ ] [ "[a-c]" test-regexp ] unit-test
+[ ] [ "[^a-c]" test-regexp ] unit-test
+[ "[^]" test-regexp ] must-fail
+
+[ ] [ "|b" test-regexp ] unit-test
+[ ] [ "b|" test-regexp ] unit-test
+[ ] [ "||" test-regexp ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators io io.streams.string
+kernel math math.parser namespaces qualified sets
+quotations sequences splitting symbols vectors math.order
+unicode.categories strings regexp.backend regexp.utils
+unicode.case words ;
+IN: regexp.parser
+
+FROM: math.ranges => [a,b] ;
+
+MIXIN: node
+TUPLE: concatenation seq ; INSTANCE: concatenation node
+TUPLE: alternation seq ; INSTANCE: alternation node
+TUPLE: kleene-star term ; INSTANCE: kleene-star node
+
+! !!!!!!!!
+TUPLE: possessive-question term ; INSTANCE: possessive-question node
+TUPLE: possessive-kleene-star term ; INSTANCE: possessive-kleene-star node
+
+! !!!!!!!!
+TUPLE: reluctant-question term ; INSTANCE: reluctant-question node
+TUPLE: reluctant-kleene-star term ; INSTANCE: reluctant-kleene-star node
+
+TUPLE: negation term ; INSTANCE: negation node
+TUPLE: constant char ; INSTANCE: constant node
+TUPLE: range from to ; INSTANCE: range node
+
+MIXIN: parentheses-group
+TUPLE: lookahead term ; INSTANCE: lookahead node
+INSTANCE: lookahead parentheses-group
+TUPLE: lookbehind term ; INSTANCE: lookbehind node
+INSTANCE: lookbehind parentheses-group
+TUPLE: capture-group term ; INSTANCE: capture-group node
+INSTANCE: capture-group parentheses-group
+TUPLE: non-capture-group term ; INSTANCE: non-capture-group node
+INSTANCE: non-capture-group parentheses-group
+TUPLE: independent-group term ; INSTANCE: independent-group node ! atomic group
+INSTANCE: independent-group parentheses-group
+TUPLE: comment-group term ; INSTANCE: comment-group node
+INSTANCE: comment-group parentheses-group
+
+TUPLE: character-class-range from to ; INSTANCE: character-class-range node
+SINGLETON: epsilon INSTANCE: epsilon node
+SINGLETON: any-char INSTANCE: any-char node
+SINGLETON: front-anchor INSTANCE: front-anchor node
+SINGLETON: back-anchor INSTANCE: back-anchor node
+
+TUPLE: option-on option ; INSTANCE: option-on node
+TUPLE: option-off option ; INSTANCE: option-off node
+SINGLETONS: unix-lines dotall multiline comments case-insensitive unicode-case reversed-regexp ;
+
+SINGLETONS: letter-class LETTER-class Letter-class digit-class
+alpha-class non-newline-blank-class
+ascii-class punctuation-class java-printable-class blank-class
+control-character-class hex-digit-class java-blank-class c-identifier-class
+unmatchable-class ;
+
+SINGLETONS: beginning-of-group end-of-group
+beginning-of-character-class end-of-character-class
+left-parenthesis pipe caret dash ;
+
+: get-option ( option -- ? ) current-regexp get options>> at ;
+: get-unix-lines ( -- ? ) unix-lines get-option ;
+: get-dotall ( -- ? ) dotall get-option ;
+: get-multiline ( -- ? ) multiline get-option ;
+: get-comments ( -- ? ) comments get-option ;
+: get-case-insensitive ( -- ? ) case-insensitive get-option ;
+: get-unicode-case ( -- ? ) unicode-case get-option ;
+: get-reversed-regexp ( -- ? ) reversed-regexp get-option ;
+
+: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
+: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;
+: <possessive-question> ( obj -- kleene ) possessive-question boa ;
+: <reluctant-question> ( obj -- kleene ) reluctant-question boa ;
+
+: <negation> ( obj -- negation ) negation boa ;
+: <concatenation> ( seq -- concatenation )
+ >vector get-reversed-regexp [ reverse ] when
+ [ epsilon ] [ concatenation boa ] if-empty ;
+: <alternation> ( seq -- alternation ) >vector alternation boa ;
+: <capture-group> ( obj -- capture-group ) capture-group boa ;
+: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
+: <constant> ( obj -- constant )
+ dup Letter? get-case-insensitive and [
+ [ ch>lower constant boa ]
+ [ ch>upper constant boa ] bi 2array <alternation>
+ ] [
+ constant boa
+ ] if ;
+
+: first|concatenation ( seq -- first/concatenation )
+ dup length 1 = [ first ] [ <concatenation> ] if ;
+
+: first|alternation ( seq -- first/alternation )
+ dup length 1 = [ first ] [ <alternation> ] if ;
+
+: <character-class-range> ( from to -- obj )
+ 2dup [ Letter? ] bi@ or get-case-insensitive and [
+ [ [ ch>lower ] bi@ character-class-range boa ]
+ [ [ ch>upper ] bi@ character-class-range boa ] 2bi
+ 2array [ [ from>> ] [ to>> ] bi < ] filter
+ [ unmatchable-class ] [ first|alternation ] if-empty
+ ] [
+ 2dup <
+ [ character-class-range boa ] [ 2drop unmatchable-class ] if
+ ] if ;
+
+ERROR: unmatched-parentheses ;
+
+ERROR: bad-option ch ;
+
+: option ( ch -- singleton )
+ {
+ { CHAR: i [ case-insensitive ] }
+ { CHAR: d [ unix-lines ] }
+ { CHAR: m [ multiline ] }
+ { CHAR: n [ multiline ] }
+ { CHAR: r [ reversed-regexp ] }
+ { CHAR: s [ dotall ] }
+ { CHAR: u [ unicode-case ] }
+ { CHAR: x [ comments ] }
+ [ bad-option ]
+ } case ;
+
+: option-on ( option -- ) current-regexp get options>> conjoin ;
+: option-off ( option -- ) current-regexp get options>> delete-at ;
+
+: toggle-option ( ch ? -- ) [ option ] dip [ option-on ] [ option-off ] if ;
+: (parse-options) ( string ? -- ) [ toggle-option ] curry each ;
+
+: parse-options ( string -- )
+ "-" split1 [ t (parse-options) ] [ f (parse-options) ] bi* ;
+
+ERROR: bad-special-group string ;
+
+DEFER: (parse-regexp)
+: nested-parse-regexp ( token ? -- )
+ [ push-stack (parse-regexp) pop-stack ] dip
+ [ <negation> ] when pop-stack boa push-stack ;
+
+! non-capturing groups
+: (parse-special-group) ( -- )
+ read1 {
+ { [ dup CHAR: # = ] ! comment
+ [ drop comment-group f nested-parse-regexp pop-stack drop ] }
+ { [ dup CHAR: : = ]
+ [ drop non-capture-group f nested-parse-regexp ] }
+ { [ dup CHAR: = = ]
+ [ drop lookahead f nested-parse-regexp ] }
+ { [ dup CHAR: ! = ]
+ [ drop lookahead t nested-parse-regexp ] }
+ { [ dup CHAR: > = ]
+ [ drop non-capture-group f nested-parse-regexp ] }
+ { [ dup CHAR: < = peek1 CHAR: = = and ]
+ [ drop drop1 lookbehind f nested-parse-regexp ] }
+ { [ dup CHAR: < = peek1 CHAR: ! = and ]
+ [ drop drop1 lookbehind t nested-parse-regexp ] }
+ [
+ ":)" read-until
+ [ swap prefix ] dip
+ {
+ { CHAR: : [ parse-options non-capture-group f nested-parse-regexp ] }
+ { CHAR: ) [ parse-options ] }
+ [ drop bad-special-group ]
+ } case
+ ]
+ } cond ;
+
+: handle-left-parenthesis ( -- )
+ peek1 CHAR: ? =
+ [ drop1 (parse-special-group) ]
+ [ capture-group f nested-parse-regexp ] if ;
+
+: handle-dot ( -- ) any-char push-stack ;
+: handle-pipe ( -- ) pipe push-stack ;
+: (handle-star) ( obj -- kleene-star )
+ peek1 {
+ { CHAR: + [ drop1 <possessive-kleene-star> ] }
+ { CHAR: ? [ drop1 <reluctant-kleene-star> ] }
+ [ drop <kleene-star> ]
+ } case ;
+: handle-star ( -- ) stack pop (handle-star) push-stack ;
+: handle-question ( -- )
+ stack pop peek1 {
+ { CHAR: + [ drop1 <possessive-question> ] }
+ { CHAR: ? [ drop1 <reluctant-question> ] }
+ [ drop epsilon 2array <alternation> ]
+ } case push-stack ;
+: handle-plus ( -- )
+ stack pop dup (handle-star)
+ 2array <concatenation> push-stack ;
+
+ERROR: unmatched-brace ;
+: parse-repetition ( -- start finish ? )
+ "}" read-until [ unmatched-brace ] unless
+ [ "," split1 [ string>number ] bi@ ]
+ [ CHAR: , swap index >boolean ] bi ;
+
+: replicate/concatenate ( n obj -- obj' )
+ over zero? [ 2drop epsilon ]
+ [ <repetition> first|concatenation ] if ;
+
+: exactly-n ( n -- )
+ stack pop replicate/concatenate push-stack ;
+
+: at-least-n ( n -- )
+ stack pop
+ [ replicate/concatenate ] keep
+ <kleene-star> 2array <concatenation> push-stack ;
+
+: at-most-n ( n -- )
+ 1+
+ stack pop
+ [ replicate/concatenate ] curry map <alternation> push-stack ;
+
+: from-m-to-n ( m n -- )
+ [a,b]
+ stack pop
+ [ replicate/concatenate ] curry map
+ <alternation> push-stack ;
+
+ERROR: invalid-range a b ;
+
+: handle-left-brace ( -- )
+ parse-repetition
+ >r 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ r>
+ [
+ 2dup and [ from-m-to-n ]
+ [ [ nip at-most-n ] [ at-least-n ] if* ] if
+ ] [ drop 0 max exactly-n ] if ;
+
+SINGLETON: beginning-of-input
+SINGLETON: end-of-input
+
+! : beginning-of-input ( -- obj )
+: handle-front-anchor ( -- ) front-anchor push-stack ;
+: end-of-line ( -- obj )
+ end-of-input
+ CHAR: \r <constant>
+ CHAR: \n <constant>
+ 2dup 2array <concatenation> 4array <alternation> lookahead boa ;
+
+: handle-back-anchor ( -- ) end-of-line push-stack ;
+
+ERROR: bad-character-class obj ;
+ERROR: expected-posix-class ;
+
+: parse-posix-class ( -- obj )
+ read1 CHAR: { = [ expected-posix-class ] unless
+ "}" read-until [ bad-character-class ] unless
+ {
+ { "Lower" [ get-case-insensitive Letter-class letter-class ? ] }
+ { "Upper" [ get-case-insensitive Letter-class LETTER-class ? ] }
+ { "Alpha" [ Letter-class ] }
+ { "ASCII" [ ascii-class ] }
+ { "Digit" [ digit-class ] }
+ { "Alnum" [ alpha-class ] }
+ { "Punct" [ punctuation-class ] }
+ { "Graph" [ java-printable-class ] }
+ { "Print" [ java-printable-class ] }
+ { "Blank" [ non-newline-blank-class ] }
+ { "Cntrl" [ control-character-class ] }
+ { "XDigit" [ hex-digit-class ] }
+ { "Space" [ java-blank-class ] }
+ ! TODO: unicode-character-class, fallthrough in unicode is bad-char-clss
+ [ bad-character-class ]
+ } case ;
+
+: parse-octal ( -- n ) 3 read oct> check-octal ;
+: parse-short-hex ( -- n ) 2 read hex> check-hex ;
+: parse-long-hex ( -- n ) 6 read hex> check-hex ;
+: parse-control-character ( -- n ) read1 ;
+
+ERROR: bad-escaped-literals seq ;
+: parse-escaped-literals ( -- obj )
+ "\\E" read-until [ bad-escaped-literals ] unless
+ drop1
+ [ epsilon ] [
+ [ <constant> ] V{ } map-as
+ first|concatenation
+ ] if-empty ;
+
+ERROR: unrecognized-escape char ;
+
+: parse-escaped ( -- obj )
+ read1
+ {
+ { CHAR: \ [ CHAR: \ <constant> ] }
+ { CHAR: ^ [ CHAR: ^ <constant> ] }
+ { CHAR: $ [ CHAR: $ <constant> ] }
+ { CHAR: - [ CHAR: - <constant> ] }
+ { CHAR: { [ CHAR: { <constant> ] }
+ { CHAR: } [ CHAR: } <constant> ] }
+ { CHAR: [ [ CHAR: [ <constant> ] }
+ { CHAR: ] [ CHAR: ] <constant> ] }
+ { CHAR: ( [ CHAR: ( <constant> ] }
+ { CHAR: ) [ CHAR: ) <constant> ] }
+ { CHAR: @ [ CHAR: @ <constant> ] }
+ { CHAR: * [ CHAR: * <constant> ] }
+ { CHAR: + [ CHAR: + <constant> ] }
+ { CHAR: ? [ CHAR: ? <constant> ] }
+ { CHAR: . [ CHAR: . <constant> ] }
+ { CHAR: : [ CHAR: : <constant> ] }
+ { CHAR: t [ CHAR: \t <constant> ] }
+ { CHAR: n [ CHAR: \n <constant> ] }
+ { CHAR: r [ CHAR: \r <constant> ] }
+ { CHAR: f [ HEX: c <constant> ] }
+ { CHAR: a [ HEX: 7 <constant> ] }
+ { CHAR: e [ HEX: 1b <constant> ] }
+
+ { CHAR: d [ digit-class ] }
+ { CHAR: D [ digit-class <negation> ] }
+ { CHAR: s [ java-blank-class ] }
+ { CHAR: S [ java-blank-class <negation> ] }
+ { CHAR: w [ c-identifier-class ] }
+ { CHAR: W [ c-identifier-class <negation> ] }
+
+ { CHAR: p [ parse-posix-class ] }
+ { CHAR: P [ parse-posix-class <negation> ] }
+ { CHAR: x [ parse-short-hex <constant> ] }
+ { CHAR: u [ parse-long-hex <constant> ] }
+ { CHAR: 0 [ parse-octal <constant> ] }
+ { CHAR: c [ parse-control-character ] }
+
+ ! { CHAR: b [ handle-word-boundary ] }
+ ! { CHAR: B [ handle-word-boundary <negation> ] }
+ ! { CHAR: A [ handle-beginning-of-input ] }
+ ! { CHAR: G [ end of previous match ] }
+ ! { CHAR: Z [ handle-end-of-input ] }
+ ! { CHAR: z [ handle-end-of-input ] } ! except for terminator
+
+ ! { CHAR: 1 [ CHAR: 1 <constant> ] }
+ ! { CHAR: 2 [ CHAR: 2 <constant> ] }
+ ! { CHAR: 3 [ CHAR: 3 <constant> ] }
+ ! { CHAR: 4 [ CHAR: 4 <constant> ] }
+ ! { CHAR: 5 [ CHAR: 5 <constant> ] }
+ ! { CHAR: 6 [ CHAR: 6 <constant> ] }
+ ! { CHAR: 7 [ CHAR: 7 <constant> ] }
+ ! { CHAR: 8 [ CHAR: 8 <constant> ] }
+ ! { CHAR: 9 [ CHAR: 9 <constant> ] }
+
+ { CHAR: Q [ parse-escaped-literals ] }
+ [ unrecognized-escape ]
+ } case ;
+
+: handle-escape ( -- ) parse-escaped push-stack ;
+
+: handle-dash ( vector -- vector' )
+ H{ { dash CHAR: - } } substitute ;
+
+: character-class>alternation ( seq -- alternation )
+ [ dup number? [ <constant> ] when ] map first|alternation ;
+
+: handle-caret ( vector -- vector' )
+ dup [ length 2 >= ] [ first caret eq? ] bi and [
+ rest-slice character-class>alternation <negation>
+ ] [
+ character-class>alternation
+ ] if ;
+
+: make-character-class ( -- character-class )
+ [ beginning-of-character-class swap cut-stack ] change-whole-stack
+ handle-dash handle-caret ;
+
+: apply-dash ( -- )
+ stack [ pop3 nip <character-class-range> ] keep push ;
+
+: apply-dash? ( -- ? )
+ stack dup length 3 >=
+ [ [ length 2 - ] keep nth dash eq? ] [ drop f ] if ;
+
+ERROR: empty-negated-character-class ;
+DEFER: handle-left-bracket
+: (parse-character-class) ( -- )
+ read1 [ empty-negated-character-class ] unless* {
+ { CHAR: [ [ handle-left-bracket t ] }
+ { CHAR: ] [ make-character-class push-stack f ] }
+ { CHAR: - [ dash push-stack t ] }
+ { CHAR: \ [ parse-escaped push-stack t ] }
+ [ push-stack apply-dash? [ apply-dash ] when t ]
+ } case
+ [ (parse-character-class) ] when ;
+
+: parse-character-class-second ( -- )
+ read1 {
+ { CHAR: [ [ CHAR: [ <constant> push-stack ] }
+ { CHAR: ] [ CHAR: ] <constant> push-stack ] }
+ { CHAR: - [ CHAR: - <constant> push-stack ] }
+ [ push1 ]
+ } case ;
+
+: parse-character-class-first ( -- )
+ read1 {
+ { CHAR: ^ [ caret push-stack parse-character-class-second ] }
+ { CHAR: [ [ CHAR: [ <constant> push-stack ] }
+ { CHAR: ] [ CHAR: ] <constant> push-stack ] }
+ { CHAR: - [ CHAR: - <constant> push-stack ] }
+ [ push1 ]
+ } case ;
+
+: handle-left-bracket ( -- )
+ beginning-of-character-class push-stack
+ parse-character-class-first (parse-character-class) ;
+
+: finish-regexp-parse ( stack -- obj )
+ { pipe } split
+ [ first|concatenation ] map first|alternation ;
+
+: handle-right-parenthesis ( -- )
+ stack dup [ parentheses-group "members" word-prop member? ] find-last -rot cut rest
+ [ [ push ] keep current-regexp get (>>stack) ]
+ [ finish-regexp-parse push-stack ] bi* ;
+
+
+: parse-regexp-token ( token -- ? )
+ {
+! todo: only match these at beginning/end of regexp
+ { CHAR: ^ [ handle-front-anchor t ] }
+ { CHAR: $ [ handle-back-anchor t ] }
+
+ { CHAR: . [ handle-dot t ] }
+ { CHAR: ( [ handle-left-parenthesis t ] }
+ { CHAR: ) [ handle-right-parenthesis f ] }
+ { CHAR: | [ handle-pipe t ] }
+ { CHAR: ? [ handle-question t ] }
+ { CHAR: * [ handle-star t ] }
+ { CHAR: + [ handle-plus t ] }
+ { CHAR: { [ handle-left-brace t ] }
+ { CHAR: [ [ handle-left-bracket t ] }
+ { CHAR: \ [ handle-escape t ] }
+ [ <constant> push-stack t ]
+ } case ;
+
+: (parse-regexp) ( -- )
+ read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
+
+: parse-regexp ( regexp -- )
+ dup current-regexp [
+ raw>> [
+ <string-reader> [ (parse-regexp) ] with-input-stream
+ ] unless-empty
+ current-regexp get
+ stack finish-regexp-parse
+ >>parse-tree drop
+ ] with-variable ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel strings help.markup help.syntax regexp.backend ;
+IN: regexp
+
+HELP: <regexp>
+{ $values { "string" string } { "regexp" regexp } }
+{ $description "Compiles a regular expression into a DFA and returns this object. Regular expressions only have to be compiled once and can then be used multiple times to match input strings." } ;
+
+HELP: <iregexp>
+{ $values { "string" string } { "regexp" regexp } }
+{ $description "Compiles a case-insensitive regular expression into a DFA and returns this object. Otherwise, exactly the same as " { $link <regexp> } } ;
+
+{ <regexp> <iregexp> } related-words
--- /dev/null
+USING: regexp tools.test kernel sequences regexp.parser
+regexp.traversal eval ;
+IN: regexp-tests
+
+[ f ] [ "b" "a*" <regexp> matches? ] unit-test
+[ t ] [ "" "a*" <regexp> matches? ] unit-test
+[ t ] [ "a" "a*" <regexp> matches? ] unit-test
+[ t ] [ "aaaaaaa" "a*" <regexp> matches? ] unit-test
+[ f ] [ "ab" "a*" <regexp> matches? ] unit-test
+
+[ t ] [ "abc" "abc" <regexp> matches? ] unit-test
+[ t ] [ "a" "a|b|c" <regexp> matches? ] unit-test
+[ t ] [ "b" "a|b|c" <regexp> matches? ] unit-test
+[ t ] [ "c" "a|b|c" <regexp> matches? ] unit-test
+[ f ] [ "c" "d|e|f" <regexp> matches? ] unit-test
+
+[ t ] [ "b" "|b" <regexp> matches? ] unit-test
+[ t ] [ "b" "b|" <regexp> matches? ] unit-test
+[ t ] [ "" "b|" <regexp> matches? ] unit-test
+[ t ] [ "" "b|" <regexp> matches? ] unit-test
+[ f ] [ "" "|" <regexp> matches? ] unit-test
+[ f ] [ "" "|||||||" <regexp> matches? ] unit-test
+
+[ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
+[ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
+[ f ] [ "cc" "a|b|c" <regexp> matches? ] unit-test
+[ f ] [ "cc" "d|e|f" <regexp> matches? ] unit-test
+
+[ f ] [ "" "a+" <regexp> matches? ] unit-test
+[ t ] [ "a" "a+" <regexp> matches? ] unit-test
+[ t ] [ "aa" "a+" <regexp> matches? ] unit-test
+
+[ t ] [ "" "a?" <regexp> matches? ] unit-test
+[ t ] [ "a" "a?" <regexp> matches? ] unit-test
+[ f ] [ "aa" "a?" <regexp> matches? ] unit-test
+
+[ f ] [ "" "." <regexp> matches? ] unit-test
+[ t ] [ "a" "." <regexp> matches? ] unit-test
+[ t ] [ "." "." <regexp> matches? ] unit-test
+! [ f ] [ "\n" "." <regexp> matches? ] unit-test
+
+[ f ] [ "" ".+" <regexp> matches? ] unit-test
+[ t ] [ "a" ".+" <regexp> matches? ] unit-test
+[ t ] [ "ab" ".+" <regexp> matches? ] unit-test
+
+
+[ t ] [ "" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ t ] [ "a" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ t ] [ "c" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ t ] [ "cc" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ f ] [ "ccd" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ t ] [ "d" "a|b*|c+|d?" <regexp> matches? ] unit-test
+
+[ t ] [ "foo" "foo|bar" <regexp> matches? ] unit-test
+[ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
+[ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
+
+[ f ] [ "" "(a)" <regexp> matches? ] unit-test
+[ t ] [ "a" "(a)" <regexp> matches? ] unit-test
+[ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
+[ t ] [ "aa" "(a*)" <regexp> matches? ] unit-test
+
+[ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
+[ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
+
+[ f ] [ "" "a{1}" <regexp> matches? ] unit-test
+[ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
+[ f ] [ "aa" "a{1}" <regexp> matches? ] unit-test
+
+[ f ] [ "a" "a{2,}" <regexp> matches? ] unit-test
+[ t ] [ "aaa" "a{2,}" <regexp> matches? ] unit-test
+[ t ] [ "aaaa" "a{2,}" <regexp> matches? ] unit-test
+[ t ] [ "aaaaa" "a{2,}" <regexp> matches? ] unit-test
+
+[ t ] [ "" "a{,2}" <regexp> matches? ] unit-test
+[ t ] [ "a" "a{,2}" <regexp> matches? ] unit-test
+[ t ] [ "aa" "a{,2}" <regexp> matches? ] unit-test
+[ f ] [ "aaa" "a{,2}" <regexp> matches? ] unit-test
+[ f ] [ "aaaa" "a{,2}" <regexp> matches? ] unit-test
+[ f ] [ "aaaaa" "a{,2}" <regexp> matches? ] unit-test
+
+[ f ] [ "" "a{1,3}" <regexp> matches? ] unit-test
+[ t ] [ "a" "a{1,3}" <regexp> matches? ] unit-test
+[ t ] [ "aa" "a{1,3}" <regexp> matches? ] unit-test
+[ t ] [ "aaa" "a{1,3}" <regexp> matches? ] unit-test
+[ f ] [ "aaaa" "a{1,3}" <regexp> matches? ] unit-test
+
+[ f ] [ "" "[a]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[a]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[abc]" <regexp> matches? ] unit-test
+[ f ] [ "b" "[a]" <regexp> matches? ] unit-test
+[ f ] [ "d" "[abc]" <regexp> matches? ] unit-test
+[ t ] [ "ab" "[abc]{1,2}" <regexp> matches? ] unit-test
+[ f ] [ "abc" "[abc]{1,2}" <regexp> matches? ] unit-test
+
+[ f ] [ "" "[^a]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[^a]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[^abc]" <regexp> matches? ] unit-test
+[ t ] [ "b" "[^a]" <regexp> matches? ] unit-test
+[ t ] [ "d" "[^abc]" <regexp> matches? ] unit-test
+[ f ] [ "ab" "[^abc]{1,2}" <regexp> matches? ] unit-test
+[ f ] [ "abc" "[^abc]{1,2}" <regexp> matches? ] unit-test
+
+[ t ] [ "]" "[]]" <regexp> matches? ] unit-test
+[ f ] [ "]" "[^]]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^]]" <regexp> matches? ] unit-test
+
+[ "^" "[^]" <regexp> matches? ] must-fail
+[ t ] [ "^" "[]^]" <regexp> matches? ] unit-test
+[ t ] [ "]" "[]^]" <regexp> matches? ] unit-test
+
+[ t ] [ "[" "[[]" <regexp> matches? ] unit-test
+[ f ] [ "^" "[^^]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^^]" <regexp> matches? ] unit-test
+
+[ t ] [ "-" "[-]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[-]" <regexp> matches? ] unit-test
+[ f ] [ "-" "[^-]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^-]" <regexp> matches? ] unit-test
+
+[ t ] [ "-" "[-a]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[-a]" <regexp> matches? ] unit-test
+[ t ] [ "-" "[a-]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[a-]" <regexp> matches? ] unit-test
+[ f ] [ "b" "[a-]" <regexp> matches? ] unit-test
+[ f ] [ "-" "[^-]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^-]" <regexp> matches? ] unit-test
+
+[ f ] [ "-" "[a-c]" <regexp> matches? ] unit-test
+[ t ] [ "-" "[^a-c]" <regexp> matches? ] unit-test
+[ t ] [ "b" "[a-c]" <regexp> matches? ] unit-test
+[ f ] [ "b" "[^a-c]" <regexp> matches? ] unit-test
+
+[ t ] [ "-" "[a-c-]" <regexp> matches? ] unit-test
+[ f ] [ "-" "[^a-c-]" <regexp> matches? ] unit-test
+
+[ t ] [ "\\" "[\\\\]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[\\\\]" <regexp> matches? ] unit-test
+[ f ] [ "\\" "[^\\\\]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^\\\\]" <regexp> matches? ] unit-test
+
+[ t ] [ "0" "[\\d]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[\\d]" <regexp> matches? ] unit-test
+[ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
+
+[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
+[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
+[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
+
+[ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
+[ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
+
+[ t ] [ "abc" "\\p{Lower}{3}" <regexp> matches? ] unit-test
+[ f ] [ "ABC" "\\p{Lower}{3}" <regexp> matches? ] unit-test
+[ t ] [ "ABC" "\\p{Upper}{3}" <regexp> matches? ] unit-test
+[ f ] [ "abc" "\\p{Upper}{3}" <regexp> matches? ] unit-test
+!
+[ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
+[ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
+
+[ f ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
+[ f ] [ "a" "\\Q\\E" <regexp> matches? ] unit-test
+[ t ] [ "|*+" "\\Q|*+\\E" <regexp> matches? ] unit-test
+[ f ] [ "abc" "\\Q|*+\\E" <regexp> matches? ] unit-test
+[ t ] [ "s" "\\Qs\\E" <regexp> matches? ] unit-test
+
+[ t ] [ "S" "\\0123" <regexp> matches? ] unit-test
+[ t ] [ "SXY" "\\0123XY" <regexp> matches? ] unit-test
+[ t ] [ "x" "\\x78" <regexp> matches? ] unit-test
+[ f ] [ "y" "\\x78" <regexp> matches? ] unit-test
+[ t ] [ "x" "\\u000078" <regexp> matches? ] unit-test
+[ f ] [ "y" "\\u000078" <regexp> matches? ] unit-test
+
+[ t ] [ "ab" "a+b" <regexp> matches? ] unit-test
+[ f ] [ "b" "a+b" <regexp> matches? ] unit-test
+[ t ] [ "aab" "a+b" <regexp> matches? ] unit-test
+[ f ] [ "abb" "a+b" <regexp> matches? ] unit-test
+
+[ t ] [ "abbbb" "ab*" <regexp> matches? ] unit-test
+[ t ] [ "a" "ab*" <regexp> matches? ] unit-test
+[ f ] [ "abab" "ab*" <regexp> matches? ] unit-test
+
+[ f ] [ "x" "\\." <regexp> matches? ] unit-test
+[ t ] [ "." "\\." <regexp> matches? ] unit-test
+
+[ t ] [ "aaaab" "a+ab" <regexp> matches? ] unit-test
+[ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
+[ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
+
+[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
+[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
+
+[ t ] [ "aaa" "AAA" <iregexp> matches? ] unit-test
+[ f ] [ "aax" "AAA" <iregexp> matches? ] unit-test
+[ t ] [ "aaa" "A*" <iregexp> matches? ] unit-test
+[ f ] [ "aaba" "A*" <iregexp> matches? ] unit-test
+[ t ] [ "b" "[AB]" <iregexp> matches? ] unit-test
+[ f ] [ "c" "[AB]" <iregexp> matches? ] unit-test
+[ t ] [ "c" "[A-Z]" <iregexp> matches? ] unit-test
+[ f ] [ "3" "[A-Z]" <iregexp> matches? ] unit-test
+
+[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
+[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
+[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
+[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
+
+[ t ] [ "a" "(?-i)a" <iregexp> matches? ] unit-test
+[ t ] [ "a" "(?-i)a" <iregexp> matches? ] unit-test
+[ f ] [ "A" "(?-i)a" <iregexp> matches? ] unit-test
+[ f ] [ "A" "(?-i)a" <iregexp> matches? ] unit-test
+
+[ f ] [ "A" "[a-z]" <regexp> matches? ] unit-test
+[ t ] [ "A" "[a-z]" <iregexp> matches? ] unit-test
+
+[ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
+[ t ] [ "A" "\\p{Lower}" <iregexp> matches? ] unit-test
+
+[ t ] [ "abc" <reversed> "abc" <rregexp> matches? ] unit-test
+[ t ] [ "abc" <reversed> "a[bB][cC]" <rregexp> matches? ] unit-test
+[ t ] [ "adcbe" "a(?r)(bcd)(?-r)e" <rregexp> matches? ] unit-test
+
+[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
+[ t ] [ ".o" "\\.[a-z]" <regexp> matches? ] unit-test
+
+[ t ] [ "abc*" "[^\\*]*\\*" <regexp> matches? ] unit-test
+[ t ] [ "bca" "[^a]*a" <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]))"
+ <regexp> drop
+] unit-test
+
+[ ] [ "(\\$[\\p{XDigit}]|[\\p{Digit}])" <regexp> drop ] unit-test
+
+! Comment
+[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
+
+
+
+! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
+
+! [ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
+! [ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
+! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
+! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
+! [ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
+! [ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
+
+! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
+! [ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
+
+[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
+[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
+
+! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
+! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
+
+! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
+! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
+! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
+! [ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
+! [ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
+! [ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
+
+! [ f ] [ "foo bar" "foo\\B" <regexp> matches? ] unit-test
+! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-head ] unit-test
+! [ t ] [ "foo" "foo\\B" <regexp> matches? ] unit-test
+! [ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
+! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
+! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
+
+[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test
+
+[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test
+
+[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
+
+! Bug in parsing word
+! [ t ] [ "a" R' a' matches? ] unit-test
+
+! ((A)(B(C)))
+! 1. ((A)(B(C)))
+! 2. (A)
+! 3. (B(C))
+! 4. (C)
+
+! clear "a(?=b*)" <regexp> "ab" over match
+! clear "a(?=b*c)" <regexp> "abbbbbc" over match
+! clear "a(?=b*)" <regexp> "ab" over match
+
+! clear "^a" <regexp> "a" over match
+! clear "^a" <regexp> "\na" over match
+! clear "^a" <regexp> "\r\na" over match
+! clear "^a" <regexp> "\ra" over match
+
+! clear "a$" <regexp> "a" over match
+! clear "a$" <regexp> "a\n" over match
+! clear "a$" <regexp> "a\r" over match
+! clear "a$" <regexp> "a\r\n" over match
+
+! "(az)(?<=b)" <regexp> "baz" over first-match
+! "a(?<=b*)" <regexp> "cbaz" over first-match
+! "a(?<=b)" <regexp> "baz" over first-match
+
+! "a(?<!b)" <regexp> "baz" over first-match
+! "a(?<!b)" <regexp> "caz" over first-match
+
+! "a(?=bcdefg)bcd" <regexp> "abcdefg" over first-match
+! "a(?#bcdefg)bcd" <regexp> "abcdefg" over first-match
+! "a(?:bcdefg)" <regexp> "abcdefg" over first-match
+
+[ { 0 1 } ] [ "ac" "a(?!b)" <regexp> first-match ] unit-test
+[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
+
+! "a(?<=b)" <regexp> "caba" over first-match
+
+[ { 0 1 } ] [ "ab" "a(?=b)(?=b)" <regexp> first-match ] unit-test
+[ { 1 2 } ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match ] unit-test
+[ { 1 2 } ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match ] unit-test
+
+! capture group 1: "aaaa" 2: ""
+! "aaaa" "(a*)(a*)" <regexp> match*
+! "aaaa" "(a*)(a+)" <regexp> match*
+
+[ { 0 2 } ] [ "ab" "(a|ab)(bc)?" <regexp> first-match ] unit-test
+[ { 0 3 } ] [ "abc" "(a|ab)(bc)?" <regexp> first-match ] unit-test
+
+[ { 0 2 } ] [ "ab" "(ab|a)(bc)?" <regexp> first-match ] unit-test
+[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
+
+[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
+
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel math math.ranges sequences
+sets assocs prettyprint.backend make lexer namespaces parser
+arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
+regexp.dfa regexp.traversal regexp.transition-tables ;
+IN: regexp
+
+: default-regexp ( string -- regexp )
+ regexp new
+ swap >>raw
+ <transition-table> >>nfa-table
+ <transition-table> >>dfa-table
+ <transition-table> >>minimized-table
+ H{ } clone >>nfa-traversal-flags
+ H{ } clone >>dfa-traversal-flags
+ H{ } clone >>options
+ reset-regexp ;
+
+: construct-regexp ( regexp -- regexp' )
+ {
+ [ parse-regexp ]
+ [ construct-nfa ]
+ [ construct-dfa ]
+ [ ]
+ } cleave ;
+
+: match ( string regexp -- pair )
+ <dfa-traverser> do-match return-match ;
+
+: match* ( string regexp -- pair )
+ <dfa-traverser> do-match [ return-match ] [ captured-groups>> ] bi ;
+
+: matches? ( string regexp -- ? )
+ dupd match
+ [ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ;
+
+: match-head ( string regexp -- end/f ) match [ length>> 1- ] [ f ] if* ;
+
+: match-at ( string m regexp -- n/f finished? )
+ [
+ 2dup swap length > [ 2drop f f ] [ tail-slice t ] if
+ ] dip swap [ match-head f ] [ 2drop f t ] if ;
+
+: match-range ( string m regexp -- a/f b/f )
+ 3dup match-at over [
+ drop nip rot drop dupd +
+ ] [
+ [ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
+ ] if ;
+
+: first-match ( string regexp -- pair/f )
+ 0 swap match-range dup [ 2array ] [ 2drop f ] if ;
+
+: re-cut ( string regexp -- end/f start )
+ dupd first-match
+ [ [ second tail-slice ] [ first head ] 2bi ]
+ [ "" like f swap ]
+ if* ;
+
+: re-split ( string regexp -- seq )
+ [ dup ] swap '[ _ re-cut ] [ ] produce nip ;
+
+: re-replace ( string regexp replacement -- result )
+ [ re-split ] dip join ;
+
+: next-match ( string regexp -- end/f match/f )
+ dupd first-match dup
+ [ [ second tail-slice ] keep ]
+ [ 2drop f f ]
+ if ;
+
+: all-matches ( string regexp -- seq )
+ [ dup ] swap '[ _ next-match ] [ ] produce nip ;
+
+: count-matches ( string regexp -- n )
+ all-matches length 1- ;
+
+: initial-option ( regexp option -- regexp' )
+ over options>> conjoin ;
+
+: <regexp> ( string -- regexp )
+ default-regexp construct-regexp ;
+
+: <iregexp> ( string -- regexp )
+ default-regexp
+ case-insensitive initial-option
+ construct-regexp ;
+
+: <rregexp> ( string -- regexp )
+ default-regexp
+ reversed-regexp initial-option
+ construct-regexp ;
+
+
+: parsing-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) ] [ drop f ] if
+ "i" = [ <iregexp> ] [ <regexp> ] if parsed ;
+
+: R! CHAR: ! parsing-regexp ; parsing
+: R" CHAR: " parsing-regexp ; parsing
+: R# CHAR: # parsing-regexp ; parsing
+: R' CHAR: ' parsing-regexp ; parsing
+: R( CHAR: ) parsing-regexp ; parsing
+: R/ CHAR: / parsing-regexp ; parsing
+: R@ CHAR: @ parsing-regexp ; parsing
+: R[ CHAR: ] parsing-regexp ; parsing
+: R` CHAR: ` parsing-regexp ; parsing
+: R{ CHAR: } parsing-regexp ; parsing
+: R| CHAR: | parsing-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 ;
+
+: option? ( option regexp -- ? )
+ options>> key? ;
+
+USE: multiline
+/*
+M: regexp pprint*
+ [
+ [
+ dup raw>>
+ dup find-regexp-syntax swap % swap % %
+ case-insensitive swap option? [ "i" % ] when
+ ] "" make
+ ] keep present-text ;
+*/
--- /dev/null
+Regular expressions
--- /dev/null
+parsing
+text
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs fry hashtables kernel sequences
+vectors regexp.utils ;
+IN: regexp.transition-tables
+
+TUPLE: transition from to obj ;
+TUPLE: literal-transition < transition ;
+TUPLE: class-transition < transition ;
+TUPLE: default-transition < transition ;
+
+TUPLE: literal obj ;
+TUPLE: class obj ;
+TUPLE: default ;
+: make-transition ( from to obj class -- obj )
+ new
+ swap >>obj
+ swap >>to
+ swap >>from ;
+
+: <literal-transition> ( from to obj -- transition )
+ literal-transition make-transition ;
+: <class-transition> ( from to obj -- transition )
+ class-transition make-transition ;
+: <default-transition> ( from to -- transition )
+ t default-transition make-transition ;
+
+TUPLE: transition-table transitions start-state final-states ;
+
+: <transition-table> ( -- transition-table )
+ transition-table new
+ H{ } clone >>transitions
+ H{ } clone >>final-states ;
+
+: maybe-initialize-key ( key hashtable -- )
+ 2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
+
+: set-transition ( transition hash -- )
+ #! set the state as a key
+ 2dup [ to>> ] dip maybe-initialize-key
+ [ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
+ 2dup at* [ 2nip insert-at ]
+ [ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ;
+
+: add-transition ( transition transition-table -- )
+ transitions>> set-transition ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators kernel math math.ranges
+quotations sequences regexp.parser regexp.classes fry arrays
+combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
+IN: regexp.traversal
+
+TUPLE: dfa-traverser
+ dfa-table
+ traversal-flags
+ traverse-forward
+ lookahead-counters
+ lookbehind-counters
+ capture-counters
+ captured-groups
+ capture-group-index
+ last-state current-state
+ text
+ start-index current-index
+ matches ;
+
+: <dfa-traverser> ( text regexp -- match )
+ [ dfa-table>> ] [ dfa-traversal-flags>> ] bi
+ dfa-traverser new
+ swap >>traversal-flags
+ swap [ start-state>> >>current-state ] keep
+ >>dfa-table
+ swap >>text
+ t >>traverse-forward
+ 0 >>start-index
+ 0 >>current-index
+ 0 >>capture-group-index
+ V{ } clone >>matches
+ V{ } clone >>capture-counters
+ V{ } clone >>lookbehind-counters
+ V{ } clone >>lookahead-counters
+ H{ } clone >>captured-groups ;
+
+: final-state? ( dfa-traverser -- ? )
+ [ current-state>> ] [ dfa-table>> final-states>> ] bi
+ key? ;
+
+: text-finished? ( dfa-traverser -- ? )
+ {
+ [ current-state>> empty? ]
+ [ [ current-index>> ] [ text>> length ] bi >= ]
+ ! [ current-index>> 0 < ]
+ } 1|| ;
+
+: save-final-state ( dfa-straverser -- )
+ [ current-index>> ] [ matches>> ] bi push ;
+
+: match-done? ( dfa-traverser -- ? )
+ dup final-state? [
+ dup save-final-state
+ ] when text-finished? ;
+
+GENERIC: flag-action ( dfa-traverser flag -- )
+
+M: lookahead-on flag-action ( dfa-traverser flag -- )
+ drop
+ lookahead-counters>> 0 swap push ;
+
+M: lookahead-off flag-action ( dfa-traverser flag -- )
+ drop
+ dup lookahead-counters>>
+ [ drop ] [ pop '[ _ - ] change-current-index drop ] if-empty ;
+
+M: lookbehind-on flag-action ( dfa-traverser flag -- )
+ drop
+ f >>traverse-forward
+ [ 2 - ] change-current-index
+ lookbehind-counters>> 0 swap push ;
+
+M: lookbehind-off flag-action ( dfa-traverser flag -- )
+ drop
+ t >>traverse-forward
+ dup lookbehind-counters>>
+ [ drop ] [ pop '[ _ + 2 + ] change-current-index drop ] if-empty ;
+
+M: capture-group-on flag-action ( dfa-traverser flag -- )
+ drop
+ [ current-index>> 0 2array ]
+ [ capture-counters>> ] bi push ;
+
+M: capture-group-off flag-action ( dfa-traverser flag -- )
+ drop
+ dup capture-counters>> empty? [
+ drop
+ ] [
+ {
+ [ capture-counters>> pop first2 dupd + ]
+ [ text>> <slice> ]
+ [ [ 1+ ] change-capture-group-index capture-group-index>> ]
+ [ captured-groups>> set-at ]
+ } cleave
+ ] if ;
+
+: process-flags ( dfa-traverser -- )
+ [ [ 1+ ] map ] change-lookahead-counters
+ [ [ 1+ ] map ] change-lookbehind-counters
+ [ [ first2 1+ 2array ] map ] change-capture-counters
+ ! dup current-state>> .
+ dup [ current-state>> ] [ traversal-flags>> ] bi
+ at [ dup . flag-action ] with each ;
+
+: increment-state ( dfa-traverser state -- dfa-traverser )
+ [
+ dup traverse-forward>>
+ [ 1+ ] [ 1- ] ? change-current-index
+ dup current-state>> >>last-state
+ ] dip
+ first >>current-state ;
+
+: match-failed ( dfa-traverser -- dfa-traverser )
+ V{ } clone >>matches ;
+
+: match-literal ( transition from-state table -- to-state/f )
+ transitions>> at* [ at ] [ 2drop f ] if ;
+
+: match-class ( transition from-state table -- to-state/f )
+ transitions>> at* [
+ [ drop class-member? ] assoc-with assoc-find [ nip ] [ drop ] if
+ ] [ drop ] if ;
+
+: match-default ( transition from-state table -- to-state/f )
+ [ nip ] dip transitions>> at*
+ [ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
+
+: match-transition ( obj from-state dfa -- to-state/f )
+ { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
+
+: setup-match ( match -- obj state dfa-table )
+ {
+ [ current-index>> ] [ text>> ]
+ [ current-state>> ] [ dfa-table>> ]
+ } cleave
+ [ nth ] 2dip ;
+
+: do-match ( dfa-traverser -- dfa-traverser )
+ dup process-flags
+ dup match-done? [
+ dup setup-match match-transition
+ [ increment-state do-match ] when*
+ ] unless ;
+
+: return-match ( dfa-traverser -- interval/f )
+ dup matches>>
+ [ drop f ]
+ [ [ start-index>> ] [ peek ] bi* 1 <range> ] if-empty ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs io kernel math math.order
+namespaces regexp.backend sequences unicode.categories
+math.ranges fry combinators.short-circuit vectors ;
+IN: regexp.utils
+
+: (while-changes) ( obj quot pred pred-ret -- obj )
+ ! quot: ( obj -- obj' )
+ ! pred: ( obj -- <=> )
+ [ [ dup slip ] dip pick over call ] dip dupd =
+ [ 3drop ] [ (while-changes) ] if ; inline recursive
+
+: while-changes ( obj quot pred -- obj' )
+ pick over call (while-changes) ; inline
+
+: assoc-with ( param assoc quot -- assoc curry )
+ swapd [ [ -rot ] dip call ] 2curry ; inline
+
+: insert-at ( value key hash -- )
+ 2dup at* [
+ 2nip push
+ ] [
+ drop
+ [ dup vector? [ 1vector ] unless ] 2dip set-at
+ ] if ;
+
+: ?insert-at ( value key hash/f -- hash )
+ [ H{ } clone ] unless* [ insert-at ] keep ;
+
+: last-state ( regexp -- range ) stack>> peek first2 [a,b] ;
+: push1 ( obj -- ) input-stream get stream>> push ;
+: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
+: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
+: drop1 ( -- ) read1 drop ;
+
+: stack ( -- obj ) current-regexp get stack>> ;
+: change-whole-stack ( quot -- )
+ current-regexp get
+ [ stack>> swap call ] keep (>>stack) ; inline
+: push-stack ( obj -- ) stack push ;
+: pop-stack ( -- obj ) stack pop ;
+: cut-out ( vector n -- vector' vector ) cut rest ;
+ERROR: cut-stack-error ;
+: cut-stack ( obj vector -- vector' vector )
+ tuck last-index [ cut-stack-error ] unless* cut-out swap ;
+
+ERROR: bad-octal number ;
+ERROR: bad-hex number ;
+: check-octal ( octal -- octal ) dup 255 > [ bad-octal ] when ;
+: check-hex ( hex -- hex ) dup number? [ bad-hex ] unless ;
+
+: 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 -- ? )
+ [
+ [ decimal-digit? ]
+ [ CHAR: a CHAR: f between? ]
+ [ CHAR: A CHAR: F between? ]
+ ] 1|| ;
+
+: control-char? ( n -- ? )
+ [
+ [ 0 HEX: 1f between? ]
+ [ HEX: 7f = ]
+ ] 1|| ;
+
+: punct? ( n -- ? )
+ "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
+
+: c-identifier-char? ( ch -- ? )
+ [ [ alpha? ] [ CHAR: _ = ] ] 1|| ;
+
+: java-blank? ( n -- ? )
+ {
+ CHAR: \s CHAR: \t CHAR: \n
+ HEX: b HEX: 7 CHAR: \r
+ } member? ;
+
+: java-printable? ( n -- ? )
+ [ [ alpha? ] [ punct? ] ] 1|| ;
}
} ;
-ARTICLE: "smtp" "SMTP Client Library"
+ARTICLE: "smtp" "SMTP client library"
"Configuring SMTP:"
{ $subsection smtp-server }
{ $subsection smtp-read-timeout }
M: effect-error error.
"Stack effects of the word " write
[ word>> pprint " do not match." print ]
- [ "Inferred: " write inferred>> effect>string . ]
- [ "Declared: " write declared>> effect>string . ] tri ;
+ [ "Inferred: " write inferred>> . ]
+ [ "Declared: " write declared>> . ] tri ;
TUPLE: recursive-quotation-error quot ;
\ boa [
dup tuple-class? [
dup inlined-dependency depends-on
- [ "boa-check" word-prop ]
+ [ "boa-check" word-prop [ ] or ]
[ tuple-layout '[ _ <tuple-boa> ] ]
bi append
] [ drop f ] if
--- /dev/null
+Slava Pestov
IN: summary
USING: kernel strings help.markup help.syntax ;
-ARTICLE: "summary" "Summary"
+ARTICLE: "summary" "Converting objects to summary strings"
"A word for getting very brief descriptions of words and general objects:"
{ $subsection summary } ;
HELP: summary
{ $values { "object" object } { "string" string } }
-{ $contract "Outputs a brief description of the object." } ;
+{ $contract "Outputs a brief description of the object." }
+{ $notes "New methods can be defined by user code. Most often, this is used with error classes so that " { $link "debugger" } " can print friendlier error messages." } ;
ABOUT: "summary"
--- /dev/null
+Generic word for converting an object into a brief one-line string
--- /dev/null
+Utility for defining multiple symbols at a time
--- /dev/null
+extensions
+++ /dev/null
-This library is a simple RSS2 parser and RSS reader web
-application. To run the web application you'll need to make sure you
-have the sqlite library working. This can be tested with
-
- "contrib/sqlite" require
- "contrib/sqlite" test-module
-
-Remember that to use "sqlite" you need to have done the following
-somewhere:
-
- USE: alien
- "sqlite" "/usr/lib/libsqlite3.so" "cdecl" add-library
-
-Replacing "libsqlite3.so" with the path to the sqlite shared library
-or DLL. I put this in my ~/.factor-rc.
-
-The RSS reader web application creates a database file called
-'rss-reader.db' in the same directory as the Factor executable when
-first started. This database contains all the feed information.
-
-To load the web application use:
-
- "contrib/rss" require
-
-Fire up the web server and navigate to the URL:
-
- http://localhost:8888/responder/maintain-feeds
-
-Add any RSS2 compatible feed. Use 'Update Feeds' to retrieve them and
-update the sqlite database with the feed contains. Use 'Database' to
-view the entries from the database for that feed.
-
--- /dev/null
+USING: help.markup help.syntax io.streams.string strings urls
+calendar xml.data xml.writer present ;
+IN: syndication
+
+HELP: entry
+{ $description "An Atom or RSS feed entry. Has the following slots:"
+ { $table
+ { "Name" "Class" }
+ { "title" { $link string } }
+ { "url" { "any class supported by " { $link present } } }
+ { "description" { $link string } }
+ { "date" { $link timestamp } }
+ }
+} ;
+
+HELP: <entry>
+{ $values { "entry" entry } }
+{ $description "Creates a new entry." } ;
+
+HELP: feed
+{ $description "An Atom or RSS feed. Has the following slots:"
+ { $table
+ { "Name" "Class" }
+ { "title" { $link string } }
+ { "url" { "any class supported by " { $link present } } }
+ { "entries" { "a sequence of " { $link entry } " instances" } }
+ }
+} ;
+
+HELP: <feed>
+{ $values { "feed" feed } }
+{ $description "Creates a new feed." } ;
+
+HELP: download-feed
+{ $values { "url" url } { "feed" feed } }
+{ $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
+
+HELP: string>feed
+{ $values { "string" string } { "feed" feed } }
+{ $description "Parses a feed in string form." } ;
+
+HELP: xml>feed
+{ $values { "xml" xml } { "feed" feed } }
+{ $description "Parses a feed in XML form." } ;
+
+HELP: feed>xml
+{ $values { "feed" feed } { "xml" xml } }
+{ $description "Converts a feed to Atom XML form." }
+{ $notes "The result of this word can then be passed to " { $link write-xml } ", or stored in an HTTP response object." } ;
+
+ARTICLE: "syndication" "Atom and RSS feed syndication"
+"The " { $vocab-link "syndication" } " vocabulary implements support for reading Atom and RSS feeds, and writing Atom feeds."
+$nl
+"Data types:"
+{ $subsection feed }
+{ $subsection <feed> }
+{ $subsection entry }
+{ $subsection <entry> }
+"Reading feeds:"
+{ $subsection download-feed }
+{ $subsection string>feed }
+{ $subsection xml>feed }
+"Writing feeds:"
+{ $subsection feed>xml }
+"The " { $vocab-link "furnace.syndication" } " vocabulary builds on top of this vocabulary to enable easy generation of Atom feeds from web applications. The " { $vocab-link "webapps.planet" } " vocabulary is a complete example of a web application which reads and exports feeds."
+{ $see-also "urls" } ;
+
+ABOUT: "syndication"
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
- utf8 file-contents read-feed ;
+ utf8 file-contents string>feed ;
[ T{
feed
[ "item" tags-named [ rss2.0-entry ] map set-entries ]
tri ;
+: atom-entry-link ( tag -- url/f )
+ "link" tags-named [ "rel" swap at "alternate" = ] find nip
+ dup [ "href" swap at >url ] when ;
+
: atom1.0-entry ( tag -- entry )
entry new
swap {
[ "title" tag-named children>string >>title ]
- [ "link" tag-named "href" swap at >url >>url ]
+ [ atom-entry-link >>url ]
[
{ "content" "summary" } any-tag-named
dup children>> [ string? not ] contains?
{ "feed" [ atom1.0 ] }
} case ;
-: read-feed ( string -- feed )
+: string>feed ( string -- feed )
[ string>xml xml>feed ] with-html-entities ;
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
- http-get nip read-feed ;
+ http-get nip string>feed ;
! Atom generation
: simple-tag, ( content name -- )
: image-name ( vocab bundle-name -- str )
prepend-path ".image" append ;
-: (copy-lines) ( stream -- )
- dup stream-readln dup
- [ print flush (copy-lines) ] [ 2drop ] if ;
-
-: copy-lines ( stream -- )
- [ (copy-lines) ] with-disposal ;
+: copy-lines ( -- )
+ readln [ print flush copy-lines ] when* ;
: run-with-output ( arguments -- )
<process>
+stdout+ >>stderr
+closed+ >>stdin
+low-priority+ >>priority
- utf8 <process-reader*>
- copy-lines
- wait-for-process zero? [ "Deployment failed" throw ] unless ;
+ utf8 [ copy-lines ] with-process-reader ;
: make-boot-image ( -- )
#! If stage1 image doesn't exist, create one.
\r
[ t ] [ 2500000 small-enough? ] unit-test\r
\r
+: run-temp-image ( -- )\r
+ vm\r
+ "-i=" "test.image" temp-file append\r
+ 2array try-process ;\r
+\r
{\r
"tools.deploy.test.1"\r
"tools.deploy.test.2"\r
} [\r
[ ] swap [\r
shake-and-bake\r
- vm\r
- "-i=" "test.image" temp-file append\r
- 2array try-process\r
+ run-temp-image\r
] curry unit-test\r
] each\r
\r
\r
[ ] [\r
"tools.deploy.test.5" shake-and-bake\r
- vm\r
- "-i=" "test.image" temp-file append\r
- 2array try-process\r
+ run-temp-image\r
] unit-test\r
\r
[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test\r
+\r
+[ ] [\r
+ "tools.deploy.test.6" shake-and-bake\r
+ run-temp-image\r
+] unit-test\r
assocs kernel parser lexer strings.parser tools.deploy.config
vocabs sequences words words.private memory kernel.private
continuations io prettyprint vocabs.loader debugger system
-strings sets vectors quotations byte-arrays ;
+strings sets vectors quotations byte-arrays sorting ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
"cpu.x86" init-hooks get delete-at
"command-line" init-hooks get delete-at
"libc" init-hooks get delete-at
+ "system" init-hooks get delete-at
deploy-threads? get [
"threads" init-hooks get delete-at
] unless
"io.thread" init-hooks get delete-at
] unless
strip-io? [
+ "io.files" init-hooks get delete-at
"io.backend" init-hooks get delete-at
+ ] when
+ strip-dictionary? [
+ "compiler.units" init-hooks get delete-at
+ "tools.vocabs" init-hooks get delete-at
] when ;
: strip-debugger ( -- )
: strip-word-props ( stripped-props words -- )
"Stripping word properties" show
[
- [
- props>> swap
- '[ drop _ member? not ] assoc-filter sift-assoc
- dup assoc-empty? [ drop f ] [ >alist >vector ] if
- ] keep (>>props)
- ] with each ;
+ swap '[
+ [
+ [ drop _ member? not ] assoc-filter sift-assoc
+ >alist f like
+ ] change-props drop
+ ] each
+ ] [
+ "Remaining word properties:" print
+ [ props>> keys ] gather .
+ ] [
+ H{ } clone '[
+ [ [ _ [ ] cache ] map ] change-props drop
+ ] each
+ ] tri ;
: stripped-word-props ( -- seq )
[
+ strip-dictionary? deploy-compiler? get and [
+ {
+ "combination"
+ "members"
+ "methods"
+ } %
+ ] when
+
strip-dictionary? [
{
+ "alias"
+ "boa-check"
"cannot-infer"
"coercer"
- "combination"
"compiled-effect"
"compiled-generic-uses"
"compiled-uses"
"constraints"
+ "custom-inlining"
"declared-effect"
"default"
"default-method"
"default-output-classes"
"derived-from"
"engines"
+ "forgotten"
+ "identities"
"if-intrinsics"
"infer"
"inferred-effect"
"local-writer?"
"local?"
"macro"
- "members"
"memo-quot"
+ "mixin"
"method-class"
"method-generic"
- "methods"
+ "modular-arithmetic"
"no-compile"
"optimizer-hooks"
"outputs"
"predicate"
"predicate-definition"
"predicating"
+ "primitive"
"reader"
"reading"
"recursive"
+ "register"
+ "register-size"
"shuffle"
"slot-names"
"slots"
"alarms"
"tools"
"io.launcher"
+ "random"
} strip-vocab-globals %
strip-dictionary? [
+ "libraries" "alien" lookup ,
+
{ } { "cpu" } strip-vocab-globals %
{
compiled-generic-crossref
compiler.units:recompile-hook
compiler.units:update-tuples-hook
+ compiler.units:definition-observers
definitions:crossref
interactive-vocabs
layouts:num-tags
vocabs:dictionary
vocabs:load-vocab-hook
word
+ parser-notes
} %
{ } { "math.partial-dispatch" } strip-vocab-globals %
+
+ "peg-cache" "peg" lookup ,
] when
strip-prettyprint? [
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
- "<computer>" "inference.dataflow" lookup [ , ] when*
+ "<value>" "stack-checker.state" lookup [ , ] when*
"windows-messages" "windows.messages" lookup [ , ] when*
-USING: cocoa cocoa.messages cocoa.application cocoa.nibs
-assocs namespaces kernel words compiler.units sequences
-ui ui.cocoa ;
+! Copyright (C) 2007, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
+namespaces kernel kernel.private words compiler.units sequences
+ui ui.cocoa init ;
+IN: tools.deploy.shaker.cocoa
+
+: pool ( obj -- obj' ) \ pool get [ ] cache ;
+
+: pool-array ( obj -- obj' ) [ pool ] map pool ;
+
+: pool-keys ( assoc -- assoc' ) [ [ pool-array ] dip ] assoc-map ;
+
+: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
+
+IN: cocoa.application
+
+: objc-error ( error -- ) die ;
+
+[ [ die ] 19 setenv ] "cocoa.application" add-init-hook
"stop-after-last-window?" get
-global [
- stop-after-last-window? set
- [ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
+H{ } clone \ pool [
+ global [
+ stop-after-last-window? set
+
+ [ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
- ! Only keeps those methods that we actually call
- sent-messages get super-sent-messages get assoc-union
- objc-methods [ assoc-intersect ] change
+ ! Only keeps those methods that we actually call
+ sent-messages get super-sent-messages get assoc-union
+ objc-methods [ assoc-intersect pool-values ] change
- sent-messages get
- super-sent-messages get
- [ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
- super-message-senders [ assoc-intersect ] change
- message-senders [ assoc-intersect ] change
+ sent-messages get
+ super-sent-messages get
+ [ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
+ super-message-senders [ assoc-intersect pool-keys ] change
+ message-senders [ assoc-intersect pool-keys ] change
- sent-messages off
- super-sent-messages off
+ sent-messages off
+ super-sent-messages off
- alien>objc-types off
- objc>alien-types off
+ alien>objc-types off
+ objc>alien-types off
- ! We need this for strip-stack-traces to work fully
- { message-senders super-message-senders }
- [ get values compile ] each
-] bind
+ ! We need this for strip-stack-traces to work fully
+ { message-senders super-message-senders }
+ [ get values compile ] each
+ ] bind
+] with-variable
--- /dev/null
+IN: tools.deploy.test.6
+USING: values math kernel ;
+
+VALUE: x
+
+VALUE: y
+
+: deploy-test-6 ( -- )
+ 1 to: x
+ 2 to: y
+ x y + 3 assert= ;
+
+MAIN: deploy-test-6
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-threads? f }
+ { deploy-ui? f }
+ { deploy-io 1 }
+ { deploy-c-types? f }
+ { deploy-name "tools.deploy.test.6" }
+ { deploy-compiler? t }
+ { deploy-reflection 1 }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-random? f }
+ { deploy-math? f }
+}
vocabs.loader io combinators io.encodings.utf8 calendar accessors
math.parser io.streams.string ui.tools.operations quotations
strings arrays prettyprint words vocabs sorting sets
-classes math alien ;
+classes math alien urls splitting ascii ;
IN: tools.scaffold
SYMBOL: developer-name
] if ;
: lookup-type ( string -- object/string ? )
+ "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-right
H{
{ "object" object } { "obj" object }
- { "obj1" object } { "obj2" object }
- { "obj3" object } { "obj4" object }
- { "quot" quotation } { "quot1" quotation }
- { "quot2" quotation } { "quot3" quotation }
- { "quot'" quotation }
- { "string" string } { "string1" string }
- { "string2" string } { "string3" string }
+ { "quot" quotation }
+ { "string" string }
{ "str" string }
- { "str1" string } { "str2" string } { "str3" string }
{ "hash" hashtable }
{ "hashtable" hashtable }
{ "?" "a boolean" }
{ "vocab" "a vocabulary specifier" }
{ "vocab-root" "a vocabulary root string" }
{ "c-ptr" c-ptr }
- { "seq" sequence } { "seq1" sequence } { "seq2" sequence }
- { "seq3" sequence } { "seq4" sequence }
- { "seq1'" sequence } { "seq2'" sequence }
- { "newseq" sequence }
- { "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc }
- { "assoc3" assoc } { "newassoc" assoc }
+ { "seq" sequence }
+ { "assoc" assoc }
{ "alist" "an array of key/value pairs" }
{ "keys" sequence } { "values" sequence }
{ "class" class } { "tuple" tuple }
+ { "url" url }
} at* ;
: add-using ( object -- )
: interesting-words. ( vocab -- )
interesting-words [ (help.) nl ] each ;
-: help-file-string ( str1 -- str2 )
+: help-file-string ( vocab -- str2 )
[
{
[ "IN: " write print nl ]
} cleave
] with-string-writer ;
-: write-using ( -- )
+: write-using ( vocab -- )
"USING:" write
using get keys
- { "help.markup" "help.syntax" } append natural-sort
+ { "help.markup" "help.syntax" } append natural-sort remove
[ bl write ] each
" ;" print ;
: set-scaffold-help-file ( path vocab -- )
swap utf8 <file-writer> [
- scaffold-copyright help-file-string write-using write
+ scaffold-copyright
+ [ help-file-string ] [ write-using ] bi
+ write
] with-output-stream ;
: check-scaffold ( vocab-root string -- vocab-root string )
relayout ;
: new-book ( pages model class -- book )
- new-gadget
- swap >>model
- swap add-gadgets ; inline
+ new-gadget
+ swap >>model
+ swap add-gadgets ; inline
: <book> ( pages model -- book ) book new-book ;
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
M: book layout* ( book -- )
- [ dim>> ] [ children>> ] bi [ (>>dim) ] with each ;
+ [ children>> ] [ dim>> ] bi [ >>dim drop ] curry each ;
M: book focusable-child* ( book -- child/t ) current-page ;
{ align initial: { 1/2 1/2 } } ;
: new-border ( child class -- border )
- new-gadget [ swap add-gadget drop ] keep ; inline
+ new-gadget swap add-gadget ; inline
: <border> ( child gap -- border )
swap border new-border
M: border layout*
dup border-child-rect swap gadget-child
over loc>> >>loc
- swap dim>> swap (>>dim) ;
+ swap dim>> >>dim
+ drop ;
M: border focusable-child*
gadget-child ;
dup mouse-clicked?
over button-rollover? and
buttons-down? and
- over (>>pressed?)
+ >>pressed?
relayout-1 ;
: if-clicked ( button quot -- )
dup { 0 1 } v* swap { 1 0 } v* gl-line
] with-translation ;
-: checkmark-theme ( gadget -- )
+: checkmark-theme ( gadget -- gadget )
f
f
black <solid>
black <checkmark-paint>
- <button-paint>
- over (>>interior)
- black <solid>
- swap (>>boundary) ;
+ <button-paint> >>interior
+ black <solid> >>boundary ;
: <checkmark> ( -- gadget )
<gadget>
- dup checkmark-theme
- { 14 14 } over (>>dim) ;
+ checkmark-theme
+ { 14 14 } >>dim ;
: toggle-model ( model -- )
[ not ] change-model ;
align-left ;
M: checkbox model-changed
- swap value>> over (>>selected?) relayout-1 ;
+ swap value>> >>selected? relayout-1 ;
TUPLE: radio-paint color ;
color>> set-color
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
-: radio-knob-theme ( gadget -- )
+: radio-knob-theme ( gadget -- gadget )
f
f
black <radio-paint>
black <radio-paint>
- <button-paint>
- over (>>interior)
- black <radio-paint>
- swap (>>boundary) ;
+ <button-paint> >>interior
+ black <radio-paint> >>boundary ;
: <radio-knob> ( -- gadget )
<gadget>
- dup radio-knob-theme
- { 16 16 } over (>>dim) ;
+ radio-knob-theme
+ { 16 16 } >>dim ;
TUPLE: radio-control < button value ;
M: radio-control model-changed
swap value>>
- over value>> =
- over (>>selected?)
+ over value>> = >>selected?
relayout-1 ;
: <radio-controls> ( parent model assoc quot -- parent )
- #! quot has stack effect ( value model label -- )
- swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
+ #! quot has stack effect ( value model label -- )
+ swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
<radio-knob> label-on-right radio-button-theme <radio-control> ;
: <radio-buttons> ( model assoc -- gadget )
- <filled-pile>
- -rot
- [ <radio-button> ] <radio-controls>
- { 5 5 } >>gap ;
+ <filled-pile>
+ -rot
+ [ <radio-button> ] <radio-controls>
+ { 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget )
<radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget )
- <shelf>
- -rot
- [ <toggle-button> ] <radio-controls> ;
+ <shelf>
+ -rot
+ [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ;
<bevel-button> ;
: <toolbar> ( target -- toolbar )
- <shelf>
- swap
- "toolbar" over class command-map commands>> swap
- [ -rot <command-button> add-gadget ] curry assoc-each ;
+ <shelf>
+ swap
+ "toolbar" over class command-map commands>> swap
+ [ -rot <command-button> add-gadget ] curry assoc-each ;
: click-loc ( editor model -- )
>r clicked-loc r> set-model ;
-: focus-editor ( editor -- ) t over (>>focused?) relayout-1 ;
+: focus-editor ( editor -- ) t >>focused? relayout-1 ;
-: unfocus-editor ( editor -- ) f over (>>focused?) relayout-1 ;
+: unfocus-editor ( editor -- ) f >>focused? relayout-1 ;
: (offset>x) ( font col# str -- x )
swap head-slice string-width ;
! c contains b contains a
<gadget> "a" set
<gadget> "b" set
- "a" get "b" get swap add-gadget drop
+ "b" get "a" get add-gadget drop
<gadget> "c" set
- "b" get "c" get swap add-gadget drop
+ "c" get "b" get add-gadget drop
! position a and b
"a" get { 100 200 } >>loc drop
<gadget> "g3" set
"g3" get { 100 200 } >>dim drop
-"g1" get "g2" get swap add-gadget drop
-"g2" get "g3" get swap add-gadget drop
+"g2" get "g1" get add-gadget drop
+"g3" get "g2" get add-gadget drop
[ { 30 30 } ] [ "g1" get screen-loc ] unit-test
[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
<gadget> "g1" set
"g1" get { 300 300 } >>dim drop
<gadget> "g2" set
-"g2" get "g1" get swap add-gadget drop
+"g1" get "g2" get add-gadget drop
"g2" get { 20 20 } >>loc
{ 20 20 } >>dim drop
<gadget> "g3" set
-"g3" get "g1" get swap add-gadget drop
+"g1" get "g3" get add-gadget drop
"g3" get { 100 100 } >>loc
{ 20 20 } >>dim drop
[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
<gadget> "g4" set
-"g4" get "g2" get swap add-gadget drop
+"g2" get "g4" get add-gadget drop
"g4" get { 5 5 } >>loc
{ 1 1 } >>dim drop
: add-some-children
3 [
<mock-gadget> over <model> >>model
- dup "g" get swap add-gadget drop
+ "g" get over add-gadget drop
swap 1+ number>string set
] each ;
: nth-gadget ( n gadget -- child ) children>> nth ;
: init-gadget ( gadget -- gadget )
- init-rect
- { 0 1 } >>orientation
- t >>visible?
- { f f } >>graft-state ; inline
+ init-rect
+ { 0 1 } >>orientation
+ t >>visible?
+ { f f } >>graft-state ; inline
: new-gadget ( class -- gadget ) new init-gadget ; inline
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
: invalidate ( gadget -- )
- \ invalidate swap (>>layout-state) ;
+ \ invalidate >>layout-state drop ;
-: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
+: forget-pref-dim ( gadget -- ) f >>pref-dim drop ;
: layout-queue ( -- queue ) \ layout-queue get ;
DEFER: relayout
: invalidate* ( gadget -- )
- \ invalidate* over (>>layout-state)
+ \ invalidate* >>layout-state
dup forget-pref-dim
dup root?>>
[ layout-later ] [ parent>> [ relayout ] when* ] if ;
dup layout-state>>
[ drop ] [ dup invalidate layout-later ] if ;
-: show-gadget ( gadget -- ) t swap (>>visible?) ;
-
-: hide-gadget ( gadget -- ) f swap (>>visible?) ;
+: show-gadget ( gadget -- ) t >>visible? drop ;
+
+: hide-gadget ( gadget -- ) f >>visible? drop ;
DEFER: in-layout?
-: do-invalidate ( gadget -- gadget )
- in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
+GENERIC: dim-changed ( gadget -- )
+
+M: gadget dim-changed
+ in-layout? get [ invalidate ] [ invalidate* ] if ;
M: gadget (>>dim) ( dim gadget -- )
- 2dup dim>> =
- [ 2drop ]
- [ tuck call-next-method do-invalidate drop ]
- if ;
+ 2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ;
GENERIC: pref-dim* ( gadget -- dim )
M: gadget layout* drop ;
-: prefer ( gadget -- ) dup pref-dim swap (>>dim) ;
+: prefer ( gadget -- ) dup pref-dim >>dim drop ;
-: validate ( gadget -- ) f swap (>>layout-state) ;
+: validate ( gadget -- ) f >>layout-state drop ;
: layout ( gadget -- )
dup layout-state>> [
: (unparent) ( gadget -- )
dup ungraft
dup forget-pref-dim
- f swap (>>parent) ;
+ f >>parent drop ;
: unfocus-gadget ( child gadget -- )
- tuck focus>> eq?
- [ f swap (>>focus) ] [ drop ] if ;
+ tuck focus>> eq? [ f >>focus ] when drop ;
SYMBOL: in-layout?
: (clear-gadget) ( gadget -- )
dup [ (unparent) ] each-child
- f over (>>focus)
- f swap (>>children) ;
+ f >>focus f >>children drop ;
: clear-gadget ( gadget -- )
not-in-layout
not-in-layout
(add-gadget)
dup relayout ;
-
+
: add-gadgets ( parent children -- parent )
not-in-layout
[ (add-gadget) ] each
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
io.streams.string math.vectors ui.gadgets columns accessors
-math.geometry.rect ;
+math.geometry.rect locals ;
IN: ui.gadgets.grids
TUPLE: grid < gadget
: new-grid ( children class -- grid )
new-gadget
- [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
- inline
+ swap >>grid
+ dup grid>> concat add-gadgets ; inline
: <grid> ( children -- grid )
grid new-grid ;
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
-: grid-add ( grid child i j -- grid )
- >r >r dupd swap r> r>
- >r >r 2dup swap add-gadget drop r> r>
- 3dup grid-child unparent rot grid>> nth set-nth ;
+:: grid-add ( grid child i j -- grid )
+ grid i j grid-child unparent
+ grid child add-gadget
+ child i j grid grid>> nth set-nth ;
: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
: compute-grid ( grid -- horiz vert )
- pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
+ pref-dim-grid [ flip (compute-grid) ] [ (compute-grid) ] bi ;
: (pair-up) ( horiz vert -- dim )
- >r first r> second 2array ;
+ [ first ] [ second ] bi* 2array ;
: pair-up ( horiz vert -- dims )
[ [ (pair-up) ] curry map ] with map ;
$nl
"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
$nl
-"Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for " { $snippet "align" } ", " { $snippet "fill" } ", and " { $snippet "gap" } "." } ;
+"Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for the " { $slot "align" } ", " { $slot "fill" } ", and " { $slot "gap" } " slots." } ;
HELP: <incremental>
{ $values { "incremental" "a new instance of " { $link incremental } } }
ui.gadgets.packs accessors math.geometry.rect ;
IN: ui.gadgets.incremental
-! Incremental layout allows adding lines to panes to be O(1).
-! Note that incremental packs are distinct from ordinary packs
-! defined in layouts.factor, since you don't want all packs to
-! be incremental. In particular, incremental packs do not
-! support non-default values for pack-align, pack-fill and
-! pack-gap.
-
-! The cursor is the current size of the incremental pack.
-! New gadgets are added at
-! incremental-cursor gadget-orientation v*
-
TUPLE: incremental < pack cursor ;
: <incremental> ( -- incremental )
M: incremental pref-dim*
dup layout-state>> [
- dup call-next-method over (>>cursor)
+ dup call-next-method >>cursor
] when cursor>> ;
: next-cursor ( gadget incremental -- cursor )
[
- swap rect-dim swap cursor>>
- 2dup v+ >r vmax r>
+ [ rect-dim ] [ cursor>> ] bi*
+ [ vmax ] [ v+ ] 2bi
] keep orientation>> set-axis ;
: update-cursor ( gadget incremental -- )
- [ next-cursor ] keep (>>cursor) ;
+ tuck next-cursor >>cursor drop ;
: incremental-loc ( gadget incremental -- )
[ cursor>> ] [ orientation>> ] bi v*
>>loc drop ;
-: prefer-incremental ( gadget -- )
+: prefer-incremental ( gadget -- ) USE: slots.private
dup forget-pref-dim dup pref-dim >>dim drop ;
+M: incremental dim-changed drop ;
+
: add-incremental ( gadget incremental -- )
not-in-layout
2dup swap (add-gadget) drop
- over prefer-incremental
- over layout-later
- 2dup incremental-loc
- tuck update-cursor
- dup prefer-incremental
- parent>> [ invalidate* ] when* ;
+ t in-layout? [
+ over prefer-incremental
+ over layout-later
+ 2dup incremental-loc
+ tuck update-cursor
+ dup prefer-incremental
+ parent>> [ invalidate* ] when*
+ ] with-variable ;
: clear-incremental ( incremental -- )
not-in-layout
dup (clear-gadget)
dup forget-pref-dim
- { 0 0 } over (>>cursor)
+ { 0 0 } >>cursor
parent>> [ relayout ] when* ;
TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget )
- { 0 1 } labelled-gadget new-track
- swap <label> reverse-video-theme f track-add
- swap >>content
- dup content>> 1 track-add ;
+ { 0 1 } labelled-gadget new-track
+ swap <label> reverse-video-theme f track-add
+ swap >>content
+ dup content>> 1 track-add ;
M: labelled-gadget focusable-child* content>> ;
>r <scroller> r> <labelled-gadget> ;
: <labelled-pane> ( model quot scrolls? title -- gadget )
- >r >r <pane-control> r> over (>>scrolls?) r>
+ >r >r <pane-control> r> >>scrolls? r>
<labelled-scroller> ;
: <close-box> ( quot -- button/f )
gray close-box <polygon-gadget> swap <bevel-button> ;
-: title-theme ( gadget -- )
- { 1 0 } over (>>orientation)
+: title-theme ( gadget -- gadget )
+ { 1 0 } >>orientation
T{ gradient f {
T{ rgba f 0.65 0.65 1.0 1.0 }
T{ rgba f 0.65 0.45 1.0 1.0 }
- } } swap (>>interior) ;
+ } } >>interior ;
-: <title-label> ( text -- label ) <label> dup title-theme ;
+: <title-label> ( text -- label ) <label> title-theme ;
: <title-bar> ( title quot -- gadget )
- <frame>
- swap dup [ <close-box> @left grid-add ] [ drop ] if
- swap <title-label> @center grid-add ;
+ <frame>
+ swap dup [ <close-box> @left grid-add ] [ drop ] if
+ swap <title-label> @center grid-add ;
TUPLE: closable-gadget < frame content ;
[ closable-gadget? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget )
- closable-gadget new-frame
- -rot <title-bar> @top grid-add
- swap >>content
- dup content>> @center grid-add ;
+ closable-gadget new-frame
+ -rot <title-bar> @top grid-add
+ swap >>content
+ dup content>> @center grid-add ;
M: closable-gadget focusable-child* content>> ;
M: f >label drop <gadget> ;
: label-on-left ( gadget label -- button )
- { 1 0 } <track>
- swap >label f track-add
- swap 1 track-add ;
-
+ { 1 0 } <track>
+ swap >label f track-add
+ swap 1 track-add ;
+
: label-on-right ( label gadget -- button )
- { 1 0 } <track>
- swap f track-add
- swap >label 1 track-add ;
+ { 1 0 } <track>
+ swap f track-add
+ swap >label 1 track-add ;
control-value length 1- min 0 max ;
: bound-index ( list -- )
- dup index>> over calc-bounded-index
- swap (>>index) ;
+ dup index>> over calc-bounded-index >>index drop ;
: list-presentation-hook ( list -- quot )
hook>> [ [ list? ] find-parent ] prepend ;
M: list model-changed
nip
dup clear-gadget
- dup <list-items> over swap add-gadgets drop
+ dup <list-items> add-gadgets
bound-index ;
: selected-rect ( list -- rect )
2drop
] [
[ control-value length rem ] keep
- [ (>>index) ] keep
- [ relayout-1 ] keep
+ swap >>index
+ dup relayout-1
scroll>selected
] if ;
: <menu-glass> ( menu world -- glass )
menu-glass new-gadget
>r over menu-loc >>loc r>
- [ swap add-gadget drop ] keep ;
+ swap add-gadget ;
M: menu-glass layout* gadget-child prefer ;
: hide-glass ( world -- )
- dup glass>> [ unparent ] when*
- f swap (>>glass) ;
+ [ [ unparent ] when* f ] change-glass drop ;
: show-glass ( gadget world -- )
- over hand-clicked set-global
- [ hide-glass ] keep
- [ swap add-gadget drop ] 2keep
- (>>glass) ;
+ dup hide-glass
+ swap [ hand-clicked set-global ] [ >>glass ] bi
+ dup glass>> add-gadget drop ;
: show-menu ( gadget owner -- )
find-world [ <menu-glass> ] keep show-glass ;
faint-boundary ;
: <commands-menu> ( hook target commands -- gadget )
- <filled-pile>
- -roll
- [ <menu-item> add-gadget ] with with each
- 5 <border> menu-theme ;
+ <filled-pile>
+ -roll
+ [ <menu-item> add-gadget ] with with each
+ 5 <border> menu-theme ;
IN: ui.gadgets.packs
TUPLE: pack < gadget
- { align initial: 0 }
- { fill initial: 0 }
- { gap initial: { 0 0 } } ;
+ { align initial: 0 }
+ { fill initial: 0 }
+ { gap initial: { 0 0 } } ;
: packed-dim-2 ( gadget sizes -- list )
[ over rect-dim over v- rot fill>> v*n v+ ] with map ;
: <pile> ( -- pack ) { 0 1 } <pack> ;
-: <filled-pile> ( -- pack ) <pile> 1 over (>>fill) ;
+: <filled-pile> ( -- pack ) <pile> 1 >>fill ;
: <shelf> ( -- pack ) { 1 0 } <pack> ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
- ui.gadgets.labels ui.gadgets.scrollers
- ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
- ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
- hashtables io kernel namespaces sequences io.styles strings
- quotations math opengl combinators math.vectors
- sorting splitting io.streams.nested assocs
- ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
- ui.gadgets.grid-lines classes.tuple models continuations
- destructors accessors math.geometry.rect ;
+ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
+ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
+ui.clipboards ui.gestures ui.traverse ui.render hashtables io
+kernel namespaces sequences io.styles strings quotations math
+opengl combinators math.vectors sorting splitting
+io.streams.nested assocs ui.gadgets.presentations
+ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
+classes.tuple models continuations destructors accessors
+math.geometry.rect ;
IN: ui.gadgets.panes
TUPLE: pane < pack
- output current prototype scrolls?
- selection-color caret mark selecting? ;
+output current prototype scrolls?
+selection-color caret mark selecting? ;
-: clear-selection ( pane -- pane ) f >>caret f >>mark ;
+: clear-selection ( pane -- pane )
+ f >>caret f >>mark ;
-: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
-: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
+: add-output ( pane current -- pane )
+ [ >>output ] [ add-gadget ] bi ;
+
+: add-current ( pane current -- pane )
+ [ >>current ] [ add-gadget ] bi ;
: prepare-line ( pane -- pane )
- clear-selection
- dup prototype>> clone add-current ;
+ clear-selection
+ dup prototype>> clone add-current ;
-: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ;
+: pane-caret&mark ( pane -- caret mark )
+ [ caret>> ] [ mark>> ] bi ;
: selected-children ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
M: pane gadget-selection? pane-caret&mark and ;
-M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
+M: pane gadget-selection ( pane -- string/f )
+ selected-children gadget-text ;
: pane-clear ( pane -- )
- clear-selection
- [ output>> clear-incremental ]
- [ current>> clear-gadget ]
- bi ;
+ clear-selection
+ [ output>> clear-incremental ]
+ [ current>> clear-gadget ]
+ bi ;
: new-pane ( class -- pane )
new-gadget
GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget ( gadget pane-stream -- )
- pane>> current>> swap add-gadget drop ;
+ pane>> current>> swap add-gadget drop ;
M: style-stream write-gadget
stream>> write-gadget ;
: make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline
-: <scrolling-pane> ( -- pane ) <pane> t over (>>scrolls?) ;
+: <scrolling-pane> ( -- pane ) <pane> t >>scrolls? ;
TUPLE: pane-control < pane quot ;
M: pane-control model-changed ( model pane-control -- )
- [ value>> ] [ dup quot>> ] bi* with-pane ;
+ [ value>> ] [ dup quot>> ] bi* with-pane ;
: <pane-control> ( model quot -- pane )
pane-control new-pane
>r pick at r> when* ; inline
: apply-foreground-style ( style gadget -- style gadget )
- foreground [ over (>>color) ] apply-style ;
+ foreground [ >>color ] apply-style ;
: apply-background-style ( style gadget -- style gadget )
background [ solid-interior ] apply-style ;
font-size swap at 12 or 3array ;
: apply-font-style ( style gadget -- style gadget )
- over specified-font over (>>font) ;
+ over specified-font >>font ;
: apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ;
! Tables
: apply-table-gap-style ( style grid -- style grid )
- table-gap [ over (>>gap) ] apply-style ;
+ table-gap [ >>gap ] apply-style ;
: apply-table-border-style ( style grid -- style grid )
- table-border [ <grid-lines> over (>>boundary) ]
+ table-border [ <grid-lines> >>boundary ]
apply-style ;
: styled-grid ( style grid -- grid )
<grid>
- f over (>>fill?)
+ f >>fill?
apply-table-gap-style
apply-table-border-style
nip ;
M: paragraph dispose drop ;
: gadget-write ( string gadget -- )
- over empty?
- [ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
+ swap dup empty?
+ [ 2drop ] [ <label> text-theme add-gadget drop ] if ;
M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- )
- >r " " <word-break-gadget> style-label r> swap add-gadget drop ;
+ swap " " <word-break-gadget> style-label add-gadget drop ;
M: paragraph stream-write
swap " " split
[ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
: gadget-format ( string style stream -- )
- pick empty?
- [ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
+ spin dup empty?
+ [ 3drop ] [ <styled-label> add-gadget drop ] if ;
M: pack stream-format
gadget-format ;
] if ;
: caret>mark ( pane -- pane )
- dup caret>> >>mark
- dup relayout-1 ;
+ dup caret>> >>mark
+ dup relayout-1 ;
GENERIC: sloppy-pick-up* ( loc gadget -- n )
M: pack sloppy-pick-up* ( loc gadget -- n )
- [ orientation>> ] [ children>> ] bi (fast-children-on) ;
+ [ orientation>> ] [ children>> ] bi (fast-children-on) ;
M: gadget sloppy-pick-up*
children>> [ inside? ] with find-last drop ;
if ;
: move-caret ( pane -- pane )
- dup hand-rel
- over sloppy-pick-up
- over (>>caret)
- dup relayout-1 ;
+ dup hand-rel over sloppy-pick-up >>caret
+ dup relayout-1 ;
-: begin-selection ( pane -- ) move-caret f swap (>>mark) ;
+: begin-selection ( pane -- ) move-caret f >>mark drop ;
: extend-selection ( pane -- )
hand-moved? [
: <paragraph> ( margin -- gadget )
paragraph new-gadget
- { 1 0 } over (>>orientation)
- [ (>>margin) ] keep ;
+ { 1 0 } >>orientation
+ swap >>margin ;
SYMBOL: x SYMBOL: max-x
<gadget> { 600 400 } >>dim "g1" set
<gadget> { 600 10 } >>dim "g2" set
-"g2" get "g1" get swap add-gadget drop
+"g1" get "g2" get add-gadget drop
"g1" get <scroller>
{ 300 300 } >>dim
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
: new-scroller ( gadget class -- scroller )
- new-frame
- t >>root?
- <scroller-model> >>model
- faint-boundary
+ new-frame
+ t >>root?
+ <scroller-model> >>model
+ faint-boundary
- dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
- dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
+ dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
+ dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
+
+ swap over model>> <viewport> >>viewport
+ dup viewport>> @center grid-add ;
- swap over model>> <viewport> >>viewport
- dup viewport>> @center grid-add ;
-
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
: scroll ( value scroller -- )
: scroll>rect ( rect gadget -- )
dup find-scroller* dup [
[ relative-scroll-rect ] keep
- [ (>>follows) ] keep
+ swap >>follows
relayout
] [
3drop
: scroll>gadget ( gadget -- )
dup find-scroller* dup [
- [ (>>follows) ] keep
+ swap >>follows
relayout
] [
2drop
dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
: scroll>bottom ( gadget -- )
- find-scroller [
- t over (>>follows) relayout-1
- ] when* ;
+ find-scroller [ t >>follows relayout-1 ] when* ;
: scroll>top ( gadget -- )
<zero-rect> swap scroll>rect ;
M: scroller layout*
dup call-next-method
dup follows>>
- [ update-scroller ] 2keep
- swap (>>follows) ;
+ 2dup update-scroller
+ >>follows drop ;
M: scroller focusable-child*
viewport>> ;
M: scroller model-changed
- nip f swap (>>follows) ;
+ nip f >>follows drop ;
TUPLE: limited-scroller < scroller fixed-dim ;
TUPLE: thumb < gadget ;
: begin-drag ( thumb -- )
- find-slider dup slider-value swap (>>saved) ;
+ find-slider dup slider-value >>saved drop ;
: do-drag ( thumb -- )
find-slider drag-loc over orientation>> v.
dup direction>> swap find-slider slide-by-page ;
: elevator-click ( elevator -- )
- dup compute-direction over (>>direction)
+ dup compute-direction >>direction
elevator-hold ;
elevator H{
: <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r>
[ swap find-slider slide-by-line ] curry <repeat-button>
- [ (>>orientation) ] keep ;
+ swap >>orientation ;
: elevator, ( gadget orientation -- gadget )
- tuck <elevator> >>elevator
- swap <thumb> >>thumb
- dup elevator>> over thumb>> add-gadget
- @center grid-add ;
+ tuck <elevator> >>elevator
+ swap <thumb> >>thumb
+ dup elevator>> over thumb>> add-gadget
+ @center grid-add ;
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
32 >>line ;
: <x-slider> ( range -- slider )
- { 1 0 } <slider>
- <left-button> @left grid-add
- { 0 1 } elevator,
- <right-button> @right grid-add ;
+ { 1 0 } <slider>
+ <left-button> @left grid-add
+ { 0 1 } elevator,
+ <right-button> @right grid-add ;
: <y-slider> ( range -- slider )
- { 0 1 } <slider>
- <up-button> @top grid-add
- { 1 0 } elevator,
- <down-button> @bottom grid-add ;
+ { 0 1 } <slider>
+ <up-button> @top grid-add
+ { 1 0 } elevator,
+ <down-button> @bottom grid-add ;
M: slider pref-dim*
dup call-next-method
} define-command
: <slot-editor> ( ref -- gadget )
- { 0 1 } slot-editor new-track
- swap >>ref
- dup <toolbar> f track-add
- <source-editor> >>text
- dup text>> <scroller> 1 track-add
- dup revert ;
+ { 0 1 } slot-editor new-track
+ swap >>ref
+ dup <toolbar> f track-add
+ <source-editor> >>text
+ dup text>> <scroller> 1 track-add
+ dup revert ;
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
IN: ui.gadgets.tracks.tests
[ { 100 100 } ] [
- { 0 1 } <track>
- <gadget> { 100 100 } >>dim 1 track-add
- pref-dim
+ { 0 1 } <track>
+ <gadget> { 100 100 } >>dim 1 track-add
+ pref-dim
] unit-test
[ { 100 110 } ] [
- { 0 1 } <track>
- <gadget> { 10 10 } >>dim f track-add
- <gadget> { 100 100 } >>dim 1 track-add
- pref-dim
+ { 0 1 } <track>
+ <gadget> { 10 10 } >>dim f track-add
+ <gadget> { 100 100 } >>dim 1 track-add
+ pref-dim
] unit-test
TUPLE: track < pack sizes ;
: normalized-sizes ( track -- seq )
- sizes>> dup sift sum '[ dup [ _ / ] when ] map ;
+ sizes>> dup sift sum '[ dup [ _ / ] when ] map ;
: init-track ( track -- track )
- init-gadget
- V{ } clone >>sizes
- 1 >>fill ;
+ init-gadget
+ V{ } clone >>sizes
+ 1 >>fill ;
: new-track ( orientation class -- track )
- new
- init-track
- swap >>orientation ;
+ new
+ init-track
+ swap >>orientation ;
: <track> ( orientation -- track ) track new-track ;
: alloted-dim ( track -- dim )
- [ children>> ] [ sizes>> ] bi { 0 0 }
- [ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
+ [ children>> ] [ sizes>> ] bi { 0 0 }
+ [ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
: track-pref-dims-2 ( track -- dim )
- [ children>> pref-dims ] [ normalized-sizes ] bi
- [ [ v/n ] when* ] 2map
- max-dim
- [ >fixnum ] map ;
+ [ children>> pref-dims ] [ normalized-sizes ] bi
+ [ [ v/n ] when* ] 2map
+ max-dim
+ [ >fixnum ] map ;
M: track pref-dim* ( gadget -- dim )
- [ track-pref-dims-1 ]
- [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
- [ orientation>> ]
- tri
- set-axis ;
+ [ track-pref-dims-1 ]
+ [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
+ [ orientation>> ]
+ tri
+ set-axis ;
: track-add ( track gadget constraint -- track )
- pick sizes>> push add-gadget ;
+ pick sizes>> push add-gadget ;
: track-remove ( track gadget -- track )
- dupd dup
- [
- [ swap children>> index ]
- [ unparent sizes>> ] 2bi
- delete-nth
- ]
- [ 2drop ]
- if ;
+ dupd dup [
+ [ swap children>> index ]
+ [ unparent sizes>> ] 2bi
+ delete-nth
+ ] [ 2drop ] if ;
: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;
viewport new-gadget
swap >>model
t >>clipped?
- [ swap add-gadget drop ] keep ;
+ swap add-gadget ;
M: viewport layout*
dup rect-dim viewport-gap 2 v*n v-
<gadget> "g1" set
<gadget> "g2" set
-"g1" get "g2" get swap add-gadget drop
+"g2" get "g1" get add-gadget drop
[ ] [
"g2" get <test-world> "w" set
<gadget> "g1" set
<gadget> "g2" set
<gadget> "g3" set
-"g1" get "g3" get swap add-gadget drop
-"g2" get "g3" get swap add-gadget drop
+"g3" get "g1" get add-gadget drop
+"g3" get "g2" get add-gadget drop
[ ] [
"g3" get <test-world> "w" set
: <focus-test>
focus-test new-gadget
- <focusing> over swap add-gadget drop ;
+ dup <focusing> add-gadget drop ;
M: focus-test focusable-child* gadget-child ;
(draw-world)
] [
over <world-error> ui-error
- f swap (>>active?)
+ f >>active? drop
] recover
] with-variable
] [
swap >>predicate ;
PREDICATE: listener-operation < operation
- dup command>> listener-command?
- swap listener?>> or ;
+ [ command>> listener-command? ] [ listener?>> ] bi or ;
M: operation command-name
command>> command-name ;
: modify-operation ( hook translator operation -- operation )
clone
- tuck (>>translator)
- tuck (>>hook)
- t over (>>listener?) ;
+ swap >>translator
+ swap >>hook
+ t >>listener? ;
: modify-operations ( operations hook translator -- operations )
- rot [ >r 2dup r> modify-operation ] map 2nip ;
+ rot [ modify-operation ] with with map ;
: operations>commands ( object hook translator -- pairs )
- >r >r object-operations r> r> modify-operations
+ [ object-operations ] 2dip modify-operations
[ [ operation-gesture ] keep ] { } map>assoc ;
: define-operation-map ( class group blurb object hook translator -- )
: <polygon-gadget> ( color points -- gadget )
dup max-dim
>r <polygon> <gadget> r> >>dim
- [ (>>interior) ] keep ;
+ swap >>interior ;
! Font rendering
SYMBOL: font-renderer
"handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget )
- { 0 1 } browser-gadget new-track
- dup init-history
- dup <toolbar> f track-add
- dup <help-pane> >>pane
- dup pane>> <scroller> 1 track-add ;
+ { 0 1 } browser-gadget new-track
+ dup init-history
+ dup <toolbar> f track-add
+ dup <help-pane> >>pane
+ dup pane>> <scroller> 1 track-add ;
M: browser-gadget call-tool* show-help ;
deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
: deploy-settings-theme ( gadget -- gadget )
- { 10 10 } >>gap
- 1 >>fill ;
+ { 10 10 } >>gap
+ 1 >>fill ;
: <deploy-settings> ( vocab -- control )
default-config [ <model> ] assoc-map
advanced-settings
deploy-settings-theme
- namespace <mapping> over (>>model)
+ namespace <mapping> >>model
]
bind ;
] with-pane ;
: <inspector-gadget> ( -- gadget )
- { 0 1 } inspector-gadget new-track
- dup <toolbar> f track-add
- <pane> >>pane
- dup pane>> <scroller> 1 track-add ;
-
+ { 0 1 } inspector-gadget new-track
+ dup <toolbar> f track-add
+ dup pane>> <scroller> 1 track-add ;
+
: inspect-object ( obj mirror keys inspector -- )
2nip swap >>object refresh ;
[ "dup" ] [
\ dup word-completion-string
] unit-test
-
+
[ "equal?" ]
[ \ array \ equal? method word-completion-string ] unit-test
TUPLE: listener-gadget < track input output stack ;
: listener-output, ( listener -- listener )
- <scrolling-pane> >>output
- dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
+ <scrolling-pane> >>output
+ dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
output>> <pane-stream> <interactor> ;
: listener-input, ( listener -- listener )
- dup <listener-input> >>input
- dup input>>
- { 0 100 } <limited-scroller>
- "Input" <labelled-gadget>
- f track-add ;
+ dup <listener-input> >>input
+ dup input>>
+ { 0 100 } <limited-scroller>
+ "Input" <labelled-gadget>
+ f track-add ;
: welcome. ( -- )
- "If this is your first time with Factor, please read the " print
- "handbook" ($link) "." print nl ;
+ "If this is your first time with Factor, please read the " print
+ "handbook" ($link) "." print nl ;
M: listener-gadget focusable-child*
input>> ;
TUPLE: stack-display < track ;
: <stack-display> ( workspace -- gadget )
- listener>>
- { 0 1 } stack-display new-track
+ listener>>
+ { 0 1 } stack-display new-track
over <toolbar> f track-add
- swap
- stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
+ swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add ;
M: stack-display tool-scroller
} cleave ;
: init-listener ( listener -- )
- f <model> swap (>>stack) ;
+ f <model> >>stack drop ;
: <listener-gadget> ( -- gadget )
- { 0 1 } listener-gadget new-track
- dup init-listener
- listener-output,
- listener-input, ;
-
+ { 0 1 } listener-gadget new-track
+ dup init-listener
+ listener-output,
+ listener-input, ;
+
: listener-help ( -- ) "ui-listener" help-window ;
\ listener-help H{ { +nullary+ t } } define-command
TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget )
- { 0 1 } profiler-gadget new-track
- dup <toolbar> f track-add
- <pane> >>pane
- dup pane>> <scroller> 1 track-add ;
-
+ { 0 1 } profiler-gadget new-track
+ dup <toolbar> f track-add
+ dup pane>> <scroller> 1 track-add ;
+
: with-profiler-pane ( gadget quot -- )
>r pane>> r> with-pane ;
] with-grafted-gadget ;
: test-live-search ( gadget quot -- ? )
- >r update-live-search dup assert-non-empty r> all? ;
+ >r update-live-search dup assert-non-empty r> all? ;
[ t ] [
"swp" all-words f <definition-search>
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
- { 0 1 } live-search new-track
- <search-field> >>field
- dup field>> f track-add
- -roll <search-list> >>list
- dup list>> <scroller> 1 track-add
-
- swap
- over field>> set-editor-string
- dup field>> end-of-document ;
+ { 0 1 } live-search new-track
+ <search-field> >>field
+ dup field>> f track-add
+ -roll <search-list> >>list
+ dup list>> <scroller> 1 track-add
+ swap
+ over field>> set-editor-string
+ dup field>> end-of-document ;
M: live-search focusable-child* field>> ;
[ f ]
[
- <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
+ <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
] unit-test
[ ] [ <workspace> "w" set ] unit-test
IN: ui.tools
: <workspace-tabs> ( workspace -- tabs )
- model>>
- "tool-switching" workspace command-map commands>>
- [ command-string ] { } assoc>map <enum> >alist
- <toggle-buttons> ;
+ model>>
+ "tool-switching" workspace command-map commands>>
+ [ command-string ] { } assoc>map <enum> >alist
+ <toggle-buttons> ;
: <workspace-book> ( workspace -- gadget )
-
- dup
- <stack-display>
- <browser-gadget>
- <inspector-gadget>
- <profiler-gadget>
- 4array
-
- swap model>>
-
- <book> ;
+ dup
+ <stack-display>
+ <browser-gadget>
+ <inspector-gadget>
+ <profiler-gadget>
+ 4array
+ swap model>> <book> ;
: <workspace> ( -- workspace )
- { 0 1 } workspace new-track
-
- 0 <model> >>model
- <listener-gadget> >>listener
- dup <workspace-book> >>book
-
- dup <workspace-tabs> f track-add
- dup book>> 1/5 track-add
- dup listener>> 4/5 track-add
- dup <toolbar> f track-add ;
+ { 0 1 } workspace new-track
+ 0 <model> >>model
+ <listener-gadget> >>listener
+ dup <workspace-book> >>book
+
+ dup <workspace-tabs> f track-add
+ dup book>> 1/5 track-add
+ dup listener>> 4/5 track-add
+ dup <toolbar> f track-add ;
: resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [
M: traceback-gadget pref-dim* drop { 550 600 } ;
: <traceback-gadget> ( model -- gadget )
- { 0 1 } traceback-gadget new-track
- swap >>model
+ { 0 1 } traceback-gadget new-track
+ swap >>model
dup model>>
- { 1 0 } <track>
- over <datastack-display> 1/2 track-add
- swap <retainstack-display> 1/2 track-add
- 1/3 track-add
+ { 1 0 } <track>
+ over <datastack-display> 1/2 track-add
+ swap <retainstack-display> 1/2 track-add
+ 1/3 track-add
dup model>> <callstack-display> 2/3 track-add
M: gadget tool-scroller drop f ;
: find-tool ( class workspace -- index tool )
- book>> children>> [ class eq? ] with find ;
+ book>> children>> [ class eq? ] with find ;
: show-tool ( class workspace -- tool )
[ find-tool swap ] keep book>> model>>
article-title open-window ;
: hide-popup ( workspace -- )
- dup popup>> track-remove
- f >>popup
- request-focus ;
+ dup popup>> track-remove
+ f >>popup
+ request-focus ;
: show-popup ( gadget workspace -- )
- dup hide-popup
- over >>popup
- over f track-add drop
- request-focus ;
+ dup hide-popup
+ over >>popup
+ over f track-add drop
+ request-focus ;
: show-titled-popup ( workspace gadget title -- )
[ find-workspace hide-popup ] <closable-gadget>
T{ gain-focus } swap each-gesture ;
: focus-world ( world -- )
- t over (>>focused?)
+ t >>focused?
dup raised-window
focus-path f focus-gestures ;
: unfocus-world ( world -- )
- f over (>>focused?)
+ f >>focused?
focus-path f swap focus-gestures ;
M: world graft*
#! when restoring saved worlds on image startup.
dup fonts>> clear-assoc
dup unfocus-world
- f swap (>>handle) ;
+ f >>handle drop ;
M: world ungraft*
dup free-fonts
dup graft-state>> {
{ { f f } [ ] }
{ { f t } [ ] }
- { { t t } [
- { f f } over (>>graft-state)
- ] }
- { { t f } [
- dup unqueue-graft
- { f f } over (>>graft-state)
- ] }
+ { { t t } [ { f f } >>graft-state ] }
+ { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
} case graft-later ;
: restore-gadget ( gadget -- )
"UI update" spawn drop ;
: open-world-window ( world -- )
- dup pref-dim over (>>dim) dup relayout graft ;
+ dup pref-dim >>dim dup relayout graft ;
: open-window ( gadget title -- )
f <world> open-world-window ;
M: world expose-event nip relayout ;
M: world configure-event
- over configured-loc over (>>window-loc)
- swap configured-dim over (>>dim)
+ over configured-loc >>window-loc
+ swap configured-dim >>dim
! In case dimensions didn't change
relayout-1 ;
dup window-loc>> over rect-dim glx-window
over "Factor" create-xic <x11-handle>
2dup window>> register-window
- swap (>>handle) ;
+ >>handle drop ;
: wait-event ( -- event )
QueuedAfterFlush events-queued 0 > [
init-grapheme-table table
[ make-grapheme-table finish-table ] with-variable
-\ grapheme-table set-value
-
+to: grapheme-table
[ parse-line ] H{ } map>assoc ;\r
\r
"resource:basis/unicode/collation/allkeys.txt"\r
-ascii <file-reader> parse-ducet \ ducet set-value\r
+ascii <file-reader> parse-ducet to: ducet\r
\r
! Fix up table for long contractions\r
: help-one ( assoc key -- )\r
[ [ set-code-point ] each ] H{ } make-assoc ;
load-data {
- [ process-names \ name-map set-value ]
- [ 13 swap process-data \ simple-lower set-value ]
- [ 12 swap process-data \ simple-upper set-value ]
- [ 14 swap process-data
- simple-upper assoc-union \ simple-title set-value ]
- [ process-combining \ class-map set-value ]
- [ process-canonical \ canonical-map set-value
- \ combine-map set-value ]
- [ process-compatibility \ compatibility-map set-value ]
- [ process-category \ category-map set-value ]
+ [ process-names to: name-map ]
+ [ 13 swap process-data to: simple-lower ]
+ [ 12 swap process-data to: simple-upper ]
+ [ 14 swap process-data simple-upper assoc-union to: simple-title ]
+ [ process-combining to: class-map ]
+ [ process-canonical to: canonical-map to: combine-map ]
+ [ process-compatibility to: compatibility-map ]
+ [ process-category to: category-map ]
} cleave
-load-special-casing \ special-casing set-value
+load-special-casing to: special-casing
-load-properties \ properties set-value
+load-properties to: properties
: process-script ( ranges -- )
dup values prune >symbols interned [
- expand-ranges \ script-table set-value
+ expand-ranges to: script-table
] with-variable ;
: load-script ( -- )
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: urls.encoding
+USING: strings help.markup help.syntax assocs multiline ;
+
+HELP: url-decode
+{ $values { "str" string } { "decoded" string } }
+{ $description "Decodes a URL-encoded string." } ;
+
+HELP: url-encode
+{ $values { "str" string } { "encoded" string } }
+{ $description "URL-encodes a string." } ;
+
+HELP: url-quotable?
+{ $values { "ch" "a character" } { "?" "a boolean" } }
+{ $description "Tests if a character be used without URL-encoding in a URL." } ;
+
+HELP: assoc>query
+{ $values { "assoc" assoc } { "str" string } }
+{ $description "Converts an assoc of query parameters into a query string, performing URL encoding." }
+{ $notes "This word is used by the implementation of " { $link "urls" } ". It is also used by the HTTP client to encode POST requests." }
+{ $examples
+ { $example
+ "USING: io urls.encoding ;"
+ "{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
+ "assoc>query print"
+ "from=Lead&to=Gold%2c%20please"
+ }
+} ;
+
+HELP: query>assoc
+{ $values { "query" string } { "assoc" assoc } }
+{ $description "Parses a URL query string and URL-decodes each component." }
+{ $notes "This word is used by the implementation of " { $link "urls" } ". It is also used by the HTTP server to parse POST requests." }
+{ $examples
+ { $unchecked-example
+ "USING: prettyprint urls.encoding ;"
+ "\"gender=female&agefrom=22&ageto=28&location=Omaha+NE\""
+ "query>assoc ."
+ <" H{
+ { "gender" "female" }
+ { "agefrom" "22" }
+ { "ageto" "28" }
+ { "location" "Omaha NE" }
+}">
+ }
+} ;
+
+ARTICLE: "url-encoding" "URL encoding and decoding"
+"URL encoding and decoding strings:"
+{ $subsection url-encode }
+{ $subsection url-decode }
+{ $subsection url-quotable? }
+"Encoding and decoding queries:"
+{ $subsection assoc>query }
+{ $subsection query>assoc }
+"See " { $url "http://en.wikipedia.org/wiki/Percent-encoding" } " for a description of URL encoding." ;
+
+ABOUT: "url-encoding"
--- /dev/null
+IN: urls.encoding.tests
+USING: urls.encoding tools.test arrays kernel assocs present accessors ;
+
+[ "~hello world" ] [ "%7ehello world" url-decode ] unit-test
+[ f ] [ "%XX%XX%XX" url-decode ] unit-test
+[ f ] [ "%XX%XX%X" url-decode ] unit-test
+
+[ "hello world" ] [ "hello%20world" url-decode ] unit-test
+[ " ! " ] [ "%20%21%20" url-decode ] unit-test
+[ "hello world" ] [ "hello world%" url-decode ] unit-test
+[ "hello world" ] [ "hello world%x" url-decode ] unit-test
+[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+
+[ "hello world" ] [ "hello+world" query-decode ] unit-test
+
+[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
+
+[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
+
+[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
+
+[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
+
+[ H{ { "a" { "b" "c" } } } ] [ "a=b;a=c" query>assoc ] unit-test
+
+[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
+
+[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ascii combinators combinators.short-circuit
+sequences splitting fry namespaces make assocs arrays strings
+io.encodings.string io.encodings.utf8 math math.parser accessors
+hashtables present ;
+IN: urls.encoding
+
+: url-quotable? ( ch -- ? )
+ {
+ [ letter? ]
+ [ LETTER? ]
+ [ digit? ]
+ [ "/_-.:" member? ]
+ } 1|| ; foldable
+
+<PRIVATE
+
+: push-utf8 ( ch -- )
+ 1string utf8 encode
+ [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+
+PRIVATE>
+
+: url-encode ( str -- encoded )
+ [
+ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
+ ] "" make ;
+
+<PRIVATE
+
+: url-decode-hex ( index str -- )
+ 2dup length 2 - >= [
+ 2drop
+ ] [
+ [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
+ ] if ;
+
+: url-decode-% ( index str -- index str )
+ 2dup url-decode-hex ;
+
+: url-decode-iter ( index str -- )
+ 2dup length >= [
+ 2drop
+ ] [
+ 2dup nth dup CHAR: % = [
+ drop url-decode-% [ 3 + ] dip
+ ] [
+ , [ 1+ ] dip
+ ] if url-decode-iter
+ ] if ;
+
+PRIVATE>
+
+: url-decode ( str -- decoded )
+ [ 0 swap url-decode-iter ] "" make utf8 decode ;
+
+: query-decode ( str -- decoded )
+ [ dup CHAR: + = [ drop "%20" ] [ 1string ] if ] { } map-as
+ concat url-decode ;
+
+<PRIVATE
+
+: add-query-param ( value key assoc -- )
+ [
+ at [
+ {
+ { [ dup string? ] [ swap 2array ] }
+ { [ dup array? ] [ swap suffix ] }
+ { [ dup not ] [ drop ] }
+ } cond
+ ] when*
+ ] 2keep set-at ;
+
+PRIVATE>
+
+: query>assoc ( query -- assoc )
+ dup [
+ "&;" split H{ } clone [
+ [
+ [ "=" split1 [ dup [ query-decode ] when ] bi@ swap ] dip
+ add-query-param
+ ] curry each
+ ] keep
+ ] when ;
+
+: assoc>query ( assoc -- str )
+ [
+ dup array? [ [ present ] map ] [ present 1array ] if
+ ] assoc-map
+ [
+ [
+ [ url-encode ] dip
+ [ url-encode "=" swap 3append , ] with each
+ ] assoc-each
+ ] { } make "&" join ;
--- /dev/null
+URL and form encoding/decoding
--- /dev/null
+USING: assocs hashtables help.markup help.syntax
+io.streams.string io.files kernel strings present math multiline
+;
+IN: urls
+
+HELP: url
+{ $class-description "The class of URLs. The slots correspond to the standard components of a URL." } ;
+
+HELP: <url>
+{ $values { "url" url } }
+{ $description "Creates an empty URL." } ;
+
+HELP: >url
+{ $values { "obj" object } { "url" url } }
+{ $description "Converts an object into a URL. If the object is already a URL, does nothing; if it is a string, then it is parsed as a URL." }
+{ $errors "Throws an error if the object is of the wrong type, or if it is a string which is not a valid URL." }
+{ $examples
+ "If we convert a string to a URL and print it out again, it will print similarly to the input string, except some normalization may have occurred:"
+ { $example
+ "USING: accessors prettyprint urls ;"
+ "\"http://www.apple.com\" >url ."
+ "URL\" http://www.apple.com/\""
+ }
+ "We can examine the URL object:"
+ { $example
+ "USING: accessors io urls ;"
+ "\"http://www.apple.com\" >url host>> print"
+ "www.apple.com"
+ }
+ "A relative URL does not have a protocol, host or port:"
+ { $example
+ "USING: accessors prettyprint urls ;"
+ "\"file.txt\" >url protocol>> ."
+ "f"
+ }
+} ;
+
+HELP: URL"
+{ $syntax "URL\" url...\"" }
+{ $description "URL literal syntax." }
+{ $examples
+ { $example
+ "USING: accessors prettyprint urls ;"
+ "URL\" http://factorcode.org:80\" port>> ."
+ "80"
+ }
+} ;
+
+HELP: derive-url
+{ $values { "base" url } { "url" url } { "url'" url } }
+{ $description "Builds a URL by filling in missing components of " { $snippet "url" } " from " { $snippet "base" } "." }
+{ $examples
+ { $example
+ "USING: prettyprint urls ;"
+ "URL\" http://factorcode.org\""
+ "URL\" binaries.fhtml\" derive-url ."
+ "URL\" http://factorcode.org/binaries.fhtml\""
+ }
+ { $example
+ "USING: prettyprint urls ;"
+ "URL\" http://www.truecasey.com/drinks/kombucha\""
+ "URL\" master-cleanser\" derive-url ."
+ "URL\" http://www.truecasey.com/drinks/master-cleanser\""
+ }
+} ;
+
+HELP: ensure-port
+{ $values { "url" url } }
+{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." }
+{ $side-effects "url" }
+{ $examples
+ { $example
+ "USING: accessors prettyprint urls ;"
+ "URL\" https://concatenative.org\" ensure-port port>> ."
+ "443"
+ }
+} ;
+
+HELP: parse-host
+{ $values { "string" string } { "host" string } { "port" "an " { $link integer } " or " { $link f } } }
+{ $description "Splits a string of the form " { $snippet "host:port" } " into a host and a port number. If the port number is not specified, outputs " { $link f } "." }
+{ $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." }
+{ $examples
+ { $example
+ "USING: prettyprint urls ;"
+ "\"sbcl.org:80\" parse-host .s"
+ "\"sbcl.org\"\n80"
+ }
+} ;
+
+HELP: protocol-port
+{ $values { "protocol" "a protocol string" } { "port" "an " { $link integer } " or " { $link f } } }
+{ $description "Outputs the port number associated with a protocol, or " { $link f } " if the protocol is unknown." } ;
+
+HELP: query-param
+{ $values
+ { "url" url } { "key" string }
+ { "value" "a " { $link string } " or " { $link f } } }
+{ $description "Outputs the URL-decoded value of a URL query parameter." }
+{ $examples
+ { $example
+ "USING: io urls ;"
+ "URL\" http://food.com/calories?item=French+Fries\""
+ "\"item\" query-param print"
+ "French Fries"
+ }
+} ;
+
+HELP: set-query-param
+{ $values { "url" url } { "value" object } { "key" string } }
+{ $description "Sets a query parameter. The value can be any object supported by " { $link present } ", or " { $link f } ", in which case the key is removed." }
+{ $notes "This word always returns the same URL object that was input. This allows for a ``pipeline'' coding style, where several query parameters are set in a row. Since it mutates the input object, you must " { $link clone } " it first if it is literal, as in the below example."
+}
+{ $examples
+ { $code
+ <" USING: kernel http.client urls ;
+URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" clone
+ "concatenative programming (NSFW)" "query" set-query-param
+ "1" "adult_ok" set-query-param
+http-get">
+ }
+ "(For a complete Yahoo! search web service implementation, see the " { $vocab-link "yahoo" } " vocabulary.)"
+}
+{ $side-effects "url" } ;
+
+HELP: relative-url
+{ $values { "url" url } { "url'" url } }
+{ $description "Outputs a new URL with the same path and query components as the input value, but with the protocol, host and port set to " { $link f } "." }
+{ $examples
+ { $example
+ "USING: prettyprint urls ;"
+ "URL\" http://factorcode.org/binaries.fhtml\""
+ "relative-url ."
+ "URL\" /binaries.fhtml\""
+ }
+} ;
+
+HELP: secure-protocol?
+{ $values { "protocol" string } { "?" "a boolean" } }
+{ $description "Tests if protocol connections must be made with secure sockets (SSL/TLS)." }
+{ $examples
+ { $example
+ "USING: prettyprint urls ;"
+ "\"https\" secure-protocol? ."
+ "t"
+ }
+} ;
+
+HELP: url-addr
+{ $values { "url" url } { "addr" "an address specifier" } }
+{ $description "Outputs an address specifier for use with " { $link "network-connection" } "." }
+{ $examples
+ { $example
+ "USING: prettyprint urls ;"
+ "URL\" ftp://ftp.cdrom.com\" url-addr ."
+ "T{ inet { host \"ftp.cdrom.com\" } { port 21 } }"
+ }
+} ;
+
+HELP: url-append-path
+{ $values { "path1" string } { "path2" string } { "path" string } }
+{ $description "Like " { $link append-path } ", but intended for use with URL paths and not filesystem paths." } ;
+
+ARTICLE: "url-utilities" "URL implementation utilities"
+{ $subsection parse-host }
+{ $subsection secure-protocol? }
+{ $subsection url-append-path } ;
+
+ARTICLE: "urls" "URL objects"
+"The " { $vocab-link "urls" } " vocabulary implements a URL data type. The benefit of using a data type to prepresent URLs rather than a string is that the parsing, printing and escaping logic is encapsulated and reused, rather than re-implemented in a potentially buggy manner every time."
+$nl
+"URL objects are used heavily by the " { $vocab-link "http" } " and " { $vocab-link "furnace" } " vocabularies, and are also useful on their own."
+$nl
+"The class of URLs, and a constructor:"
+{ $subsection url }
+{ $subsection <url> }
+"Converting strings to URLs:"
+{ $subsection >url }
+"URLs can be converted back to strings using the " { $link present } " word."
+$nl
+"URL literal syntax:"
+{ $subsection POSTPONE: URL" }
+"Manipulating URLs:"
+{ $subsection derive-url }
+{ $subsection relative-url }
+{ $subsection ensure-port }
+{ $subsection query-param }
+{ $subsection set-query-param }
+"Creating " { $link "network-addressing" } " from URLs:"
+{ $subsection url-addr }
+"The URL implemention encodes and decodes components of " { $link url } " instances automatically, but sometimes this functionality is needed for non-URL strings."
+{ $subsection "url-encoding" }
+"Utility words used by the URL implementation:"
+{ $subsection "url-utilities" } ;
+
+ABOUT: "urls"
USING: urls urls.private tools.test
arrays kernel assocs present accessors ;
-[ "hello%20world" ] [ "hello world" url-encode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
-[ f ] [ "%XX%XX%XX" url-decode ] unit-test
-[ f ] [ "%XX%XX%X" url-decode ] unit-test
-
-[ "hello world" ] [ "hello+world" url-decode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ " ! " ] [ "%20%21%20" url-decode ] unit-test
-[ "hello world" ] [ "hello world%" url-decode ] unit-test
-[ "hello world" ] [ "hello world%x" url-decode ] unit-test
-[ "hello%20world" ] [ "hello world" url-encode ] unit-test
-[ "%20%21%20" ] [ " ! " url-encode ] unit-test
-
-[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
-
-[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
-
-[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
-
-[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
-
-[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
-
: urls
{
{
] unit-test
[ "foo#3" ] [ URL" foo" clone 3 >>anchor present ] unit-test
+
+[ "http://www.foo.com/" ] [ "http://www.foo.com:80" >url present ] unit-test
+
+[ f ] [ URL" /gp/redirect.html/002-7009742-0004012?location=http://advantage.amazon.com/gp/vendor/public/join%26token%3d77E3769AB3A5B6CF611699E150DC33010761CE12" protocol>> ] unit-test
+
+[
+ T{ url
+ { protocol "http" }
+ { host "localhost" }
+ { query H{ { "foo" "bar" } } }
+ { path "/" }
+ }
+]
+[ "http://localhost?foo=bar" >url ] unit-test
+
+[
+ T{ url
+ { protocol "http" }
+ { host "localhost" }
+ { query H{ { "foo" "bar" } } }
+ { path "/" }
+ }
+]
+[ "http://localhost/?foo=bar" >url ] unit-test
+
+[ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test
sequences splitting fry namespaces make assocs arrays strings
io.sockets io.sockets.secure io.encodings.string
io.encodings.utf8 math math.parser accessors parser
-strings.parser lexer prettyprint.backend hashtables present ;
+strings.parser lexer prettyprint.backend hashtables present
+peg.ebnf urls.encoding ;
IN: urls
-: url-quotable? ( ch -- ? )
- #! In a URL, can this character be used without
- #! URL-encoding?
- {
- [ letter? ]
- [ LETTER? ]
- [ digit? ]
- [ "/_-." member? ]
- } 1|| ; foldable
-
-<PRIVATE
-
-: push-utf8 ( ch -- )
- 1string utf8 encode
- [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
-
-PRIVATE>
-
-: url-encode ( str -- str )
- [
- [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
- ] "" make ;
-
-<PRIVATE
-
-: url-decode-hex ( index str -- )
- 2dup length 2 - >= [
- 2drop
- ] [
- [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
- ] if ;
-
-: url-decode-% ( index str -- index str )
- 2dup url-decode-hex [ 3 + ] dip ;
-
-: url-decode-+-or-other ( index str ch -- index str )
- dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
-
-: url-decode-iter ( index str -- )
- 2dup length >= [
- 2drop
- ] [
- 2dup nth dup CHAR: % = [
- drop url-decode-%
- ] [
- url-decode-+-or-other
- ] if url-decode-iter
- ] if ;
-
-PRIVATE>
-
-: url-decode ( str -- str )
- [ 0 swap url-decode-iter ] "" make utf8 decode ;
-
-<PRIVATE
-
-: add-query-param ( value key assoc -- )
- [
- at [
- {
- { [ dup string? ] [ swap 2array ] }
- { [ dup array? ] [ swap suffix ] }
- { [ dup not ] [ drop ] }
- } cond
- ] when*
- ] 2keep set-at ;
-
-PRIVATE>
-
-: query>assoc ( query -- assoc )
- dup [
- "&" split H{ } clone [
- [
- [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
- add-query-param
- ] curry each
- ] keep
- ] when ;
-
-: assoc>query ( hash -- str )
- [
- dup array? [ [ present ] map ] [ present 1array ] if
- ] assoc-map
- [
- [
- [ url-encode ] dip
- [ url-encode "=" swap 3append , ] with each
- ] assoc-each
- ] { } make "&" join ;
-
TUPLE: url protocol username password host port path query anchor ;
: <url> ( -- url ) url new ;
: query-param ( url key -- value )
swap query>> at ;
+: delete-query-param ( url key -- url )
+ over query>> delete-at ;
+
: set-query-param ( url value key -- url )
- '[ [ _ _ ] dip ?set-at ] change-query ;
+ over [
+ '[ [ _ _ ] dip ?set-at ] change-query
+ ] [
+ nip delete-query-param
+ ] if ;
: parse-host ( string -- host port )
":" split1 [ url-decode ] [
] when
] bi* ;
+GENERIC: >url ( obj -- url )
+
+M: f >url drop <url> ;
+
+M: url >url ;
+
<PRIVATE
-: parse-host-part ( url protocol rest -- url string' )
- [ >>protocol ] [
- "//" ?head [ "Invalid URL" throw ] unless
- "@" split1 [
- [
- ":" split1 [ >>username ] [ >>password ] bi*
- ] dip
- ] when*
- "/" split1 [
- parse-host [ >>host ] [ >>port ] bi*
- ] [ "/" prepend ] bi*
- ] bi* ;
+EBNF: parse-url
-PRIVATE>
+protocol = [a-z]+ => [[ url-decode ]]
+username = [^/:@#?]+ => [[ url-decode ]]
+password = [^/:@#?]+ => [[ url-decode ]]
+pathname = [^#?]+ => [[ url-decode ]]
+query = [^#]+ => [[ query>assoc ]]
+anchor = .+ => [[ url-decode ]]
-GENERIC: >url ( obj -- url )
+hostname = [^/#?]+ => [[ url-decode ]]
-M: f >url drop <url> ;
+hostname-spec = hostname ("/"|!(.)) => [[ first ]]
-M: url >url ;
+auth = (username (":" password => [[ second ]])? "@"
+ => [[ first2 2array ]])?
+
+url = ((protocol "://") => [[ first ]] auth hostname)?
+ (pathname)?
+ ("?" query => [[ second ]])?
+ ("#" anchor => [[ second ]])?
+
+;EBNF
+
+PRIVATE>
M: string >url
- <url> swap
- ":" split1 [ parse-host-part ] when*
- "#" split1 [
- "?" split1
- [ url-decode >>path ]
- [ [ query>assoc >>query ] when* ] bi*
- ]
- [ url-decode >>anchor ] bi* ;
+ parse-url {
+ [
+ first [
+ [ first ] ! protocol
+ [
+ second
+ [ first [ first2 ] [ f f ] if* ] ! username, password
+ [ second parse-host ] ! host, port
+ bi
+ ] bi
+ ] [ f f f f f ] if*
+ ]
+ [ second ] ! pathname
+ [ third ] ! query
+ [ fourth ] ! anchor
+ } cleave url boa
+ dup host>> [ [ "/" or ] change-path ] when ;
+
+: protocol-port ( protocol -- port )
+ {
+ { "http" [ 80 ] }
+ { "https" [ 443 ] }
+ { "ftp" [ 21 ] }
+ [ drop f ]
+ } case ;
<PRIVATE
% password>> [ ":" % % ] when* "@" %
] [ 2drop ] if ;
+: url-port ( url -- port/f )
+ [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
+ [ drop f ] when ;
+
: unparse-host-part ( url protocol -- )
%
"://" %
{
[ unparse-username-password ]
[ host>> url-encode % ]
- [ port>> [ ":" % # ] when* ]
+ [ url-port [ ":" % # ] when* ]
[ path>> "/" head? [ "/" % ] unless ]
} cleave ;
+PRIVATE>
+
M: url present
[
{
: derive-url ( base url -- url' )
[ clone ] dip over {
- [ [ protocol>> ] either? >>protocol ]
- [ [ username>> ] either? >>username ]
- [ [ password>> ] either? >>password ]
- [ [ host>> ] either? >>host ]
- [ [ port>> ] either? >>port ]
- [ [ path>> ] bi@ swap url-append-path >>path ]
- [ [ query>> ] either? >>query ]
- [ [ anchor>> ] either? >>anchor ]
+ [ [ protocol>> ] either? >>protocol ]
+ [ [ username>> ] either? >>username ]
+ [ [ password>> ] either? >>password ]
+ [ [ host>> ] either? >>host ]
+ [ [ port>> ] either? >>port ]
+ [ [ path>> ] bi@ swap url-append-path >>path ]
+ [ [ query>> ] either? >>query ]
+ [ [ anchor>> ] either? >>anchor ]
} 2cleave ;
: relative-url ( url -- url' )
"https" = ;
: url-addr ( url -- addr )
- [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
+ [
+ [ host>> ]
+ [ port>> ]
+ [ protocol>> protocol-port ]
+ tri or <inet>
+ ] [ protocol>> ] bi
secure-protocol? [ <secure> ] when ;
-: protocol-port ( protocol -- port )
- {
- { "http" [ 80 ] }
- { "https" [ 443 ] }
- { "ftp" [ 21 ] }
- } case ;
-
-: ensure-port ( url -- url' )
+: ensure-port ( url -- url )
dup protocol>> '[ _ protocol-port or ] change-port ;
! Literal syntax
--- /dev/null
+Slava Pestov
--- /dev/null
+Value validation for the web framework
--- /dev/null
+USING: help.markup help.syntax io.streams.string quotations
+strings math parser-combinators.regexp ;
+IN: validators
+
+HELP: v-captcha
+{ $values { "str" string } }
+{ $description "Throws a validation error if the string is non-empty. This is used to create bait fields for spam-bots to fill in." } ;
+
+HELP: v-credit-card
+{ $values { "str" string } { "n" integer } }
+{ $description "If the credit card number passes the Luhn algorithm, converts it to an integer, otherwise throws an error." }
+{ $notes "See " { $url "http://en.wikipedia.org/wiki/Luhn_algorithm" } " for a description of this algorithm." } ;
+
+HELP: v-default
+{ $values { "str" string } { "def" string } { "str/def" string } }
+{ $description "If the input string is not specified, replaces it with the default value." } ;
+
+HELP: v-email
+{ $values { "str" string } }
+{ $description "Throws a validation error if the string is not a valid e-mail address, as determined by a regular expression." } ;
+
+HELP: v-integer
+{ $values { "str" string } { "n" integer } }
+{ $description "Converts the string into an integer, throwing a validation error if the string is not a valid integer." } ;
+
+HELP: v-min-length
+{ $values { "str" string } { "n" integer } }
+{ $description "Throws a validation error if the string is shorter than " { $snippet "n" } " characters." } ;
+
+HELP: v-max-length
+{ $values { "str" string } { "n" integer } }
+{ $description "Throws a validation error if the string is longer than " { $snippet "n" } " characters." } ;
+
+HELP: v-max-value
+{ $values { "x" integer } { "n" integer } }
+{ $description "Throws an error if " { $snippet "x" } " is larger than " { $snippet "n" } "." } ;
+
+HELP: v-min-value
+{ $values { "x" integer } { "n" integer } }
+{ $description "Throws an error if " { $snippet "x" } " is smaller than " { $snippet "n" } "." } ;
+
+HELP: v-mode
+{ $values { "str" string } }
+{ $description "Throws an error if " { $snippet "str" } " is not a valid XMode mode name." } ;
+
+HELP: v-number
+{ $values { "str" string } { "n" real } }
+{ $description "Converts the string into a real number, throwing a validation error if the string is not a valid real number." } ;
+
+HELP: v-one-line
+{ $values { "str" string } }
+{ $description "Throws a validation error if the string contains line breaks." } ;
+
+HELP: v-one-word
+{ $values { "str" string } }
+{ $description "Throws a validation error if the string contains word breaks." } ;
+
+HELP: v-optional
+{ $values { "str" string } { "quot" quotation } { "result" string } }
+{ $description "If the string is non-empty, applies the quotation to the string, otherwise outputs the empty string." } ;
+
+HELP: v-password
+{ $values { "str" string } }
+{ $description "A reasonable default validator for passwords." } ;
+
+HELP: v-regexp
+{ $values { "str" string } { "what" string } { "regexp" regexp } }
+{ $description "Throws a validation error that " { $snippet "what" } " failed if the string does not match the regular expression." } ;
+
+HELP: v-required
+{ $values { "str" string } }
+{ $description "Throws a validation error if the string is empty." } ;
+
+HELP: v-url
+{ $values { "str" string } }
+{ $description "Throws an error if the string is not a valid URL, as determined by a regular expression." } ;
+
+HELP: v-username
+{ $values { "str" string } }
+{ $description "A reasonable default validator for usernames." } ;
+
+ARTICLE: "validators" "Form validators"
+"The " { $vocab-link "validators" } " vocabulary provides a set of words which are intended to be used with the form validation functionality offered by " { $vocab-link "furnace.actions" } ". They can also be used independently of the web framework."
+$nl
+"Note that validators which take numbers must be preceded by " { $link v-integer } " or " { $link v-number } " if the original input is a string."
+$nl
+"Higher-order validators which require additional parameters:"
+{ $subsection v-default }
+{ $subsection v-optional }
+{ $subsection v-min-length }
+{ $subsection v-max-length }
+{ $subsection v-min-value }
+{ $subsection v-max-value }
+{ $subsection v-regexp }
+"Simple validators:"
+{ $subsection v-required }
+{ $subsection v-number }
+{ $subsection v-integer }
+{ $subsection v-one-line }
+{ $subsection v-one-word }
+{ $subsection v-captcha }
+"More complex validators:"
+{ $subsection v-email }
+{ $subsection v-url }
+{ $subsection v-username }
+{ $subsection v-password }
+{ $subsection v-credit-card }
+{ $subsection v-mode } ;
+
+ABOUT: "validators"
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets
-math.parser math.ranges assocs regexp unicode.categories arrays
-hashtables words classes quotations xmode.catalog ;
+math.parser math.ranges assocs parser-combinators.regexp
+unicode.categories arrays hashtables words classes quotations
+xmode.catalog ;
IN: validators
-: v-default ( str def -- str )
+: v-default ( str def -- str/def )
over empty? spin ? ;
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
-: v-optional ( str quot -- str )
+: v-optional ( str quot -- result )
over empty? [ 2drop f ] [ call ] if ; inline
: v-min-length ( str n -- str )
"not a valid syntax mode" throw
] unless ;
-: luhn? ( n -- ? )
+: luhn? ( str -- ? )
string>digits <reversed>
[ odd? [ 2 * 10 /mod + ] when ] map-index
sum 10 mod 0 = ;
"To get the value, just call the word. The following words manipulate values:"\r
{ $subsection get-value }\r
{ $subsection set-value }\r
+{ $subsection POSTPONE: to: }\r
{ $subsection change-value } ;\r
\r
HELP: VALUE:\r
\r
HELP: set-value\r
{ $values { "value" "a new value" } { "word" "a value word" } }\r
-{ $description "Sets the value word." } ;\r
+{ $description "Sets a value word." } ;\r
+\r
+HELP: to:\r
+{ $syntax "... to: value" }\r
+{ $values { "word" "a value word" } }\r
+{ $description "Sets a value word." }\r
+{ $notes\r
+ "Note that"\r
+ { $code "foo to: value" }\r
+ "is just sugar for"\r
+ { $code "foo \\ value set-value" }\r
+} ;\r
\r
HELP: change-value\r
-{ $values { "word" "a value word" } { "quot" "a quotation ( oldvalue -- newvalue )" } }\r
+{ $values { "word" "a value word" } { "quot" "a quotation with stack effect " { $snippet "( oldvalue -- newvalue )" } } }\r
{ $description "Changes the value using the given quotation." } ;\r
\r
VALUE: foo\r
[ f ] [ foo ] unit-test\r
-[ ] [ 3 \ foo set-value ] unit-test\r
+[ ] [ 3 to: foo ] unit-test\r
[ 3 ] [ foo ] unit-test\r
[ ] [ \ foo [ 1+ ] change-value ] unit-test\r
[ 4 ] [ foo ] unit-test\r
-USING: accessors kernel parser sequences words effects ;
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel parser words sequences quotations ;
IN: values
+! Mutating literals in word definitions is not really allowed,
+! and the deploy tool takes advantage of this fact to perform
+! some aggressive stripping and compression. However, this
+! breaks a naive implementation of values. We need to do two
+! things:
+! 1) Store the value in a subclass of identity-tuple, so that
+! two quotations from different value words are never equal.
+! This avoids bogus merging of values.
+! 2) Set the "no-def-strip" word-prop, so that the shaker leaves
+! the def>> slot alone, allowing us to introspect it. Otherwise,
+! it will get set to [ ] and we would lose access to the
+! value-holder.
+
+<PRIVATE
+
+TUPLE: value-holder < identity-tuple obj ;
+
+PRIVATE>
+
: VALUE:
- CREATE-WORD { f } clone [ first ] curry
+ CREATE-WORD
+ dup t "no-def-strip" set-word-prop
+ T{ value-holder } clone [ obj>> ] curry
(( -- value )) define-declared ; parsing
: set-value ( value word -- )
- def>> first set-first ;
+ def>> first (>>obj) ;
+
+: to:
+ scan-word literalize parsed
+ \ set-value parsed ; parsing
: get-value ( word -- value )
- def>> first first ;
+ def>> first obj>> ;
: change-value ( word quot -- )
- over >r >r get-value r> call r> set-value ; inline
+ [ [ get-value ] dip call ] [ drop ] 2bi set-value ; inline
USING: xmode.loader.syntax xmode.tokens xmode.rules
xmode.keyword-map xml.data xml.utilities xml assocs kernel
combinators sequences math.parser namespaces parser
-xmode.utilities regexp io.files accessors ;
+xmode.utilities parser-combinators.regexp io.files accessors ;
IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler
! See http://factorcode.org/license.txt for BSD license.
USING: accessors xmode.tokens xmode.rules xmode.keyword-map
xml.data xml.utilities xml assocs kernel combinators sequences
-math.parser namespaces make parser lexer xmode.utilities regexp
-io.files ;
+math.parser namespaces make parser lexer xmode.utilities
+parser-combinators.regexp io.files ;
IN: xmode.loader.syntax
SYMBOL: ignore-case?
IN: xmode.marker
USING: kernel namespaces make xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
-xmode.catalog sequences math assocs combinators
-strings regexp splitting parser-combinators ascii unicode.case
-combinators.short-circuit accessors ;
+xmode.catalog sequences math assocs combinators strings
+parser-combinators.regexp splitting parser-combinators ascii
+unicode.case combinators.short-circuit accessors ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker
USING: accessors xmode.tokens xmode.keyword-map kernel
-sequences vectors assocs strings memoize regexp unicode.case ;
+sequences vectors assocs strings memoize unicode.case
+parser-combinators.regexp ;
IN: xmode.rules
TUPLE: string-matcher string ignore-case? ;
*FreeBSD*) OS=freebsd;;
*OpenBSD*) OS=openbsd;;
*DragonFly*) OS=dragonflybsd;;
+ SunOS) OS=solaris;;
esac
}
case $uname_m in
i386) ARCH=x86;;
i686) ARCH=x86;;
+ i86pc) ARCH=x86;;
amd64) ARCH=x86;;
ppc64) ARCH=ppc;;
*86) ARCH=x86;;
$ECHO -n "Testing if your Intel Mac supports 64bit binaries..."
sysctl machdep.cpu.extfeatures | grep EM64T >/dev/null
if [[ $? -eq 0 ]] ; then
- WORD=32
+ WORD=64
$ECHO "yes!"
- $ECHO "Defaulting to 32bit for now though..."
else
WORD=32
$ECHO "no."
$ECHO "ARCH: $ARCH"
$ECHO "WORD: $WORD"
$ECHO "OS, ARCH, or WORD is empty. Please report this."
+
+ echo $MAKE_TARGET
exit 5
fi
}
}
install_build_system_apt() {
- sudo apt-get --yes install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
+ sudo apt-get --yes install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
check_ret sudo
}
echo " $0 update macosx-x86-32"
}
+MAKE_TARGET=unknown
+
# -n is nonzero length, -z is zero length
if [[ -n "$2" ]] ; then
parse_build_info $2
--- /dev/null
+Slava Pestov
--- /dev/null
+Checksum protocol and implementations
: parse-slot-value ( -- )
scan scan-object 2array , scan "}" assert= ;
+ERROR: bad-literal-tuple ;
+
: (parse-slot-values) ( -- )
parse-slot-value
scan {
{ "{" [ (parse-slot-values) ] }
{ "}" [ ] }
+ [ bad-literal-tuple ]
} case ;
: parse-slot-values ( -- )
{ "f" [ \ } parse-until boa>tuple ] }
{ "{" [ parse-slot-values assoc>tuple ] }
{ "}" [ new ] }
+ [ bad-literal-tuple ]
} case ;
} cond ;
: boa-check-quot ( class -- quot )
- all-slots [ class>> instance-check-quot ] map spread>quot ;
+ all-slots [ class>> instance-check-quot ] map spread>quot
+ f like ;
: define-boa-check ( class -- )
dup boa-check-quot "boa-check" set-word-prop ;
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
- [ "boa-check" word-prop call ]
+ [ "boa-check" word-prop [ call ] when* ]
[ tuple-layout ]
bi <tuple-boa> ;
"Another two words resume continuations:"
{ $subsection continue }
{ $subsection continue-with }
+"Continuations as control-flow:"
+{ $subsection attempt-all }
+{ $subsection with-return }
"Reflecting the datastack:"
{ $subsection with-datastack }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $examples
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
} ;
+
+HELP: <continuation>
+{ $description "Constructs a new continuation." }
+{ $notes "User code should call " { $link continuation } " instead." } ;
+
+HELP: attempt-all
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "obj" object } }
+{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }
+{ $examples "The first two numbers throw, the last one doesn't:"
+ { $example
+ "USING: prettyprint continuations kernel math ;"
+ "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."
+ "6" }
+ "All quotations throw, the last exception is rethrown:"
+ { $example
+ "USING: prettyprint continuations kernel math ;"
+ "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."
+ "5"
+ }
+} ;
+
+HELP: return
+{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
+
+HELP: with-return
+{ $values
+ { "quot" quotation } }
+{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }
+{ $examples
+ "Only \"Hi\" will print:"
+ { $example
+ "USING: prettyprint continuations io ;"
+ "[ \"Hi\" print return \"Bye\" print ] with-return"
+ "Hi"
+} } ;
+
+{ return with-return } related-words
-USING: help.markup help.syntax libc kernel continuations io ;
+USING: help.markup help.syntax libc kernel continuations io
+sequences ;
IN: destructors
HELP: dispose
{ $values { "disposable" "a disposable object" } }
{ $description "Marks the object for disposal in the event of an error at the end of the current " { $link with-destructors } " scope." } ;
+HELP: dispose-each
+{ $values
+ { "seq" sequence } }
+{ $description "Attempts to dispose of each element of a sequence and collects all of the errors into a sequence. If any errors are thrown during disposal, the last error is rethrown after all objects have been disposed." } ;
+
ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns"
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
{ $code
{ $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } }
{ $description "Create a new hashtable holding one key/value pair." } ;
+HELP: ?set-at
+{ $values
+ { "value" object } { "key" object } { "assoc/f" "an assoc or " { $link f } }
+ { "assoc" assoc } }
+{ $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ;
+
HELP: >hashtable
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
{ $description "Constructs a hashtable from any assoc." } ;
! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend io.files.private io hashtables kernel math
-memory namespaces sequences strings assocs arrays definitions
-system combinators splitting sbufs continuations destructors
-io.encodings io.encodings.binary init accessors math.order ;
+USING: io.backend io.files.private io hashtables kernel
+kernel.private math memory namespaces sequences strings assocs
+arrays definitions system combinators splitting sbufs
+continuations destructors io.encodings io.encodings.binary init
+accessors math.order ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
SYMBOL: current-directory
-[ cwd current-directory set-global ] "io.files" add-init-hook
+[
+ cwd current-directory set-global
+ 13 getenv cwd prepend-path \ image set-global
+ 14 getenv cwd prepend-path \ vm set-global
+ image parent-directory "resource-path" set-global
+] "io.files" add-init-hook
: resource-path ( path -- newpath )
- "resource-path" get [ image parent-directory ] unless*
- prepend-path ;
+ "resource-path" get prepend-path ;
: (normalize-path) ( path -- path' )
"resource:" ?head [
USING: help.markup help.syntax quotations hashtables kernel
-classes strings continuations destructors ;
+classes strings continuations destructors math ;
IN: io
-ARTICLE: "stream-protocol" "Stream protocol"
-"The stream protocol consists of a large number of generic words, many of which are optional."
-$nl
-"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "."
-$nl
-"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
-$nl
-"Three words are required for input streams:"
-{ $subsection stream-read1 }
-{ $subsection stream-read }
-{ $subsection stream-read-until }
-{ $subsection stream-readln }
-"Seven words are required for output streams:"
-{ $subsection stream-flush }
-{ $subsection stream-write1 }
-{ $subsection stream-write }
-{ $subsection stream-format }
-{ $subsection stream-nl }
-{ $subsection make-span-stream }
-{ $subsection make-block-stream }
-{ $subsection make-cell-stream }
-{ $subsection stream-write-table }
-{ $see-also "io.timeouts" } ;
-
-ARTICLE: "stdio" "Default input and output streams"
-"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:"
-{ $list
- { "Code becomes simpler because there is no need to keep a stream around on the stack." }
- { "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." }
- { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." }
-}
-"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
-{ $code
- "USING: continuations kernel io io.files math.parser splitting ;"
- "\"data.txt\" utf8 <file-reader>"
- "dup stream-readln number>string over stream-read 16 group"
- "swap dispose"
-}
-"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
-{ $code
- "USING: continuations kernel io io.files math.parser splitting ;"
- "\"data.txt\" utf8 <file-reader> ["
- " dup stream-readln number>string over stream-read"
- " 16 group"
- "] with-disposal"
-}
-"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
-{ $code
- "USING: continuations kernel io io.files math.parser splitting ;"
- "\"data.txt\" utf8 <file-reader> ["
- " readln number>string read 16 group"
- "] with-input-stream"
-}
-"An even better implementation that takes advantage of a utility word:"
-{ $code
- "USING: continuations kernel io io.files math.parser splitting ;"
- "\"data.txt\" utf8 ["
- " readln number>string read 16 group"
- "] with-file-reader"
-}
-"The default input stream is stored in a dynamically-scoped variable:"
-{ $subsection input-stream }
-"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
-$nl
-"Words reading from the default input stream:"
-{ $subsection read1 }
-{ $subsection read }
-{ $subsection read-until }
-{ $subsection readln }
-"A pair of combinators for rebinding the " { $link input-stream } " variable:"
-{ $subsection with-input-stream }
-{ $subsection with-input-stream* }
-"The default output stream is stored in a dynamically-scoped variable:"
-{ $subsection output-stream }
-"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
-$nl
-"Words writing to the default input stream:"
-{ $subsection flush }
-{ $subsection write1 }
-{ $subsection write }
-{ $subsection print }
-{ $subsection nl }
-{ $subsection bl }
-"Formatted output:"
-{ $subsection format }
-{ $subsection with-style }
-{ $subsection with-nesting }
-"Tabular output:"
-{ $subsection tabular-output }
-{ $subsection with-row }
-{ $subsection with-cell }
-{ $subsection write-cell }
-"A pair of combinators for rebinding the " { $link output-stream } " variable:"
-{ $subsection with-output-stream }
-{ $subsection with-output-stream* }
-"A pair of combinators for rebinding both default streams at once:"
-{ $subsection with-streams }
-{ $subsection with-streams* } ;
-
-ARTICLE: "stream-utils" "Stream utilities"
-"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
-$nl
-"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
-{ $subsection stream-print }
-"Sluring an entire stream into memory all at once:"
-{ $subsection lines }
-{ $subsection contents }
-"Copying the contents of one stream to another:"
-{ $subsection stream-copy } ;
-
-ARTICLE: "streams" "Streams"
-"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium."
-$nl
-"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "."
-{ $subsection "stream-protocol" }
-{ $subsection "stdio" }
-{ $subsection "stream-utils" }
-{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ;
-
-ABOUT: "streams"
-
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." }
$io-error ;
+HELP: stream-read-partial
+{ $values
+ { "n" integer } { "stream" "an input stream" }
+ { "str/f" "a string or " { $link f } } }
+{ $description "Reads at most " { $snippet "n" } " characters from a stream and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ;
+
HELP: stream-write1
{ $values { "ch" "a character" } { "stream" "an output stream" } }
{ $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
{ $contract "Reads characters from " { $link input-stream } ". until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
$io-error ;
+HELP: read-partial
+{ $values
+ { "n" null }
+ { "str/f" null } }
+{ $description "Reads at most " { $snippet "n" } " characters from " { $link input-stream } " and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ;
+
HELP: write1
{ $values { "ch" "a character" } }
{ $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $values { "stream" "an input stream" } { "str" string } }
{ $description "Reads the entire contents of a stream into a string." }
$io-error ;
+
+ARTICLE: "stream-protocol" "Stream protocol"
+"The stream protocol consists of a large number of generic words, many of which are optional."
+$nl
+"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "."
+$nl
+"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
+$nl
+"These words are required for input streams:"
+{ $subsection stream-read1 }
+{ $subsection stream-read }
+{ $subsection stream-read-until }
+{ $subsection stream-readln }
+{ $subsection stream-read-partial }
+"These words are required for output streams:"
+{ $subsection stream-flush }
+{ $subsection stream-write1 }
+{ $subsection stream-write }
+{ $subsection stream-format }
+{ $subsection stream-nl }
+{ $subsection make-span-stream }
+{ $subsection make-block-stream }
+{ $subsection make-cell-stream }
+{ $subsection stream-write-table }
+{ $see-also "io.timeouts" } ;
+
+ARTICLE: "stdio" "Default input and output streams"
+"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:"
+{ $list
+ { "Code becomes simpler because there is no need to keep a stream around on the stack." }
+ { "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." }
+ { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." }
+}
+"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
+{ $code
+ "USING: continuations kernel io io.files math.parser splitting ;"
+ "\"data.txt\" utf8 <file-reader>"
+ "dup stream-readln number>string over stream-read 16 group"
+ "swap dispose"
+}
+"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
+{ $code
+ "USING: continuations kernel io io.files math.parser splitting ;"
+ "\"data.txt\" utf8 <file-reader> ["
+ " dup stream-readln number>string over stream-read"
+ " 16 group"
+ "] with-disposal"
+}
+"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
+{ $code
+ "USING: continuations kernel io io.files math.parser splitting ;"
+ "\"data.txt\" utf8 <file-reader> ["
+ " readln number>string read 16 group"
+ "] with-input-stream"
+}
+"An even better implementation that takes advantage of a utility word:"
+{ $code
+ "USING: continuations kernel io io.files math.parser splitting ;"
+ "\"data.txt\" utf8 ["
+ " readln number>string read 16 group"
+ "] with-file-reader"
+}
+"The default input stream is stored in a dynamically-scoped variable:"
+{ $subsection input-stream }
+"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
+$nl
+"Words reading from the default input stream:"
+{ $subsection read1 }
+{ $subsection read }
+{ $subsection read-until }
+{ $subsection readln }
+{ $subsection read-partial }
+"A pair of combinators for rebinding the " { $link input-stream } " variable:"
+{ $subsection with-input-stream }
+{ $subsection with-input-stream* }
+"The default output stream is stored in a dynamically-scoped variable:"
+{ $subsection output-stream }
+"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
+$nl
+"Words writing to the default input stream:"
+{ $subsection flush }
+{ $subsection write1 }
+{ $subsection write }
+{ $subsection print }
+{ $subsection nl }
+{ $subsection bl }
+"Formatted output:"
+{ $subsection format }
+{ $subsection with-style }
+{ $subsection with-nesting }
+"Tabular output:"
+{ $subsection tabular-output }
+{ $subsection with-row }
+{ $subsection with-cell }
+{ $subsection write-cell }
+"A pair of combinators for rebinding the " { $link output-stream } " variable:"
+{ $subsection with-output-stream }
+{ $subsection with-output-stream* }
+"A pair of combinators for rebinding both default streams at once:"
+{ $subsection with-streams }
+{ $subsection with-streams* } ;
+
+ARTICLE: "stream-utils" "Stream utilities"
+"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
+$nl
+"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
+{ $subsection stream-print }
+"Sluring an entire stream into memory all at once:"
+{ $subsection lines }
+{ $subsection contents }
+"Copying the contents of one stream to another:"
+{ $subsection stream-copy } ;
+
+ARTICLE: "streams" "Streams"
+"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium."
+$nl
+"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "."
+{ $subsection "stream-protocol" }
+{ $subsection "stdio" }
+{ $subsection "stream-utils" }
+{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ;
+
+ABOUT: "streams"
GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f )
GENERIC: stream-read-until ( seps stream -- str/f sep/f )
-GENERIC: stream-read-partial ( max stream -- str/f )
+GENERIC: stream-read-partial ( n stream -- str/f )
GENERIC: stream-write1 ( ch stream -- )
GENERIC: stream-write ( str stream -- )
GENERIC: stream-flush ( stream -- )
assocs arrays math.order ;
IN: kernel
-ARTICLE: "shuffle-words" "Shuffle words"
-"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
-$nl
-"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
-$nl
-"Removing stack elements:"
-{ $subsection drop }
-{ $subsection 2drop }
-{ $subsection 3drop }
-{ $subsection nip }
-{ $subsection 2nip }
-"Duplicating stack elements:"
-{ $subsection dup }
-{ $subsection 2dup }
-{ $subsection 3dup }
-{ $subsection dupd }
-{ $subsection over }
-{ $subsection 2over }
-{ $subsection pick }
-{ $subsection tuck }
-"Permuting stack elements:"
-{ $subsection swap }
-{ $subsection swapd }
-{ $subsection rot }
-{ $subsection -rot }
-{ $subsection spin }
-{ $subsection roll }
-{ $subsection -roll }
-"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
-{ $subsection >r }
-{ $subsection r> }
-"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
-{ $example "1 2 3 >r .s r>" "1\n2" }
-"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning."
-$nl
-"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ;
-
-ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
-"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
-$nl
-"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
-{ $code
- ": keep [ ] bi ;"
- ": 2keep [ ] 2bi ;"
- ": 3keep [ ] 3bi ;"
- ""
- ": dup [ ] [ ] bi ;"
- ": 2dup [ ] [ ] 2bi ;"
- ": 3dup [ ] [ ] 3bi ;"
- ""
- ": tuck [ nip ] [ ] 2bi ;"
- ": swap [ nip ] [ drop ] 2bi ;"
- ""
- ": over [ ] [ drop ] 2bi ;"
- ": pick [ ] [ 2drop ] 3bi ;"
- ": 2over [ ] [ drop ] 3bi ;"
-} ;
-
-ARTICLE: "cleave-combinators" "Cleave combinators"
-"The cleave combinators apply multiple quotations to a single value."
-$nl
-"Two quotations:"
-{ $subsection bi }
-{ $subsection 2bi }
-{ $subsection 3bi }
-"Three quotations:"
-{ $subsection tri }
-{ $subsection 2tri }
-{ $subsection 3tri }
-"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
-{ $code
- "! First alternative; uses keep"
- "[ 1 + ] keep"
- "[ 1 - ] keep"
- "2 *"
- "! Second alternative: uses tri"
- "[ 1 + ]"
- "[ 1 - ]"
- "[ 2 * ] tri"
-}
-"The latter is more aesthetically pleasing than the former."
-$nl
-"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
-{ $subsection "cleave-shuffle-equivalence" } ;
-
-ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
-"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
-$nl
-"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
-{ $code
- ": dip [ ] bi* ;"
- ": 2dip [ ] [ ] tri* ;"
- ""
- ": slip [ call ] [ ] bi* ;"
- ": 2slip [ call ] [ ] [ ] tri* ;"
- ""
- ": nip [ drop ] [ ] bi* ;"
- ": 2nip [ drop ] [ drop ] [ ] tri* ;"
- ""
- ": rot"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " 3tri ;"
- ""
- ": -rot"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " 3tri ;"
- ""
- ": spin"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " 3tri ;"
-} ;
-
-ARTICLE: "spread-combinators" "Spread combinators"
-"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
-$nl
-"Two quotations:"
-{ $subsection bi* }
-{ $subsection 2bi* }
-"Three quotations:"
-{ $subsection tri* }
-"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
-{ $code
- "! First alternative; uses retain stack explicitly"
- ">r >r 1 +"
- "r> 1 -"
- "r> 2 *"
- "! Second alternative: uses tri*"
- "[ 1 + ]"
- "[ 1 - ]"
- "[ 2 * ] tri*"
-}
-
-$nl
-"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
-{ $subsection "spread-shuffle-equivalence" } ;
-
-ARTICLE: "apply-combinators" "Apply combinators"
-"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
-$nl
-"Two quotations:"
-{ $subsection bi@ }
-{ $subsection 2bi@ }
-"Three quotations:"
-{ $subsection tri@ }
-"A pair of utility words built from " { $link bi@ } ":"
-{ $subsection both? }
-{ $subsection either? } ;
-
-ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators"
-"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
-{ $subsection dip }
-{ $subsection 2dip }
-"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
-{ $subsection slip }
-{ $subsection 2slip }
-{ $subsection 3slip }
-"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
-{ $subsection keep }
-{ $subsection 2keep }
-{ $subsection 3keep } ;
-
-ARTICLE: "compositional-combinators" "Compositional combinators"
-"Quotations can be composed using efficient quotation-specific operations:"
-{ $subsection curry }
-{ $subsection 2curry }
-{ $subsection 3curry }
-{ $subsection with }
-{ $subsection compose }
-{ $subsection 3compose }
-{ $subsection prepose }
-"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
-
-ARTICLE: "implementing-combinators" "Implementing combinators"
-"The following pair of words invoke words and quotations reflectively:"
-{ $subsection call }
-{ $subsection execute }
-"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
-{ $code
- ": keep ( x quot -- x )"
- " over >r call r> ; inline"
-}
-"Word inlining is documented in " { $link "declarations" } "." ;
-
-ARTICLE: "booleans" "Booleans"
-"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
-{ $subsection f }
-{ $subsection t }
-"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
-$nl
-"Here is the " { $link f } " object:"
-{ $example "f ." "f" }
-"Here is the " { $link f } " class:"
-{ $example "\\ f ." "POSTPONE: f" }
-"They are not equal:"
-{ $example "f \\ f = ." "f" }
-"Here is an array containing the " { $link f } " object:"
-{ $example "{ f } ." "{ f }" }
-"Here is an array containing the " { $link f } " class:"
-{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
-"The " { $link f } " object is an instance of the " { $link f } " class:"
-{ $example "f class ." "POSTPONE: f" }
-"The " { $link f } " class is an instance of " { $link word } ":"
-{ $example "\\ f class ." "word" }
-"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
-{ $example "t \\ t eq? ." "t" }
-"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
-
-ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
-"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
-$nl
-"The following two lines are equivalent:"
-{ $code "[ drop f ] unless" "swap and" }
-"The following two lines are equivalent:"
-{ $code "[ ] [ ] ?if" "swap or" }
-"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
-{ $code "[ L ] unless*" "L or" } ;
-
-ARTICLE: "conditionals" "Conditionals and logic"
-"The basic conditionals:"
-{ $subsection if }
-{ $subsection when }
-{ $subsection unless }
-"Forms abstracting a common stack shuffle pattern:"
-{ $subsection if* }
-{ $subsection when* }
-{ $subsection unless* }
-"Another form abstracting a common stack shuffle pattern:"
-{ $subsection ?if }
-"Sometimes instead of branching, you just need to pick one of two values:"
-{ $subsection ? }
-"There are some logical operations on booleans:"
-{ $subsection >boolean }
-{ $subsection not }
-{ $subsection and }
-{ $subsection or }
-{ $subsection xor }
-{ $subsection "conditionals-boolean-equivalence" }
-"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
-{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
-
-ARTICLE: "equality" "Equality"
-"There are two distinct notions of ``sameness'' when it comes to objects."
-$nl
-"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:"
-{ $subsection eq? }
-"You can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "):"
-{ $subsection = }
-"A third form of equality is provided by " { $link number= } ". It compares numeric value while disregarding types."
-$nl
-"Custom value comparison methods for use with " { $link = } " can be defined on a generic word:"
-{ $subsection equal? }
-"Utility class:"
-{ $subsection identity-tuple }
-"An object can be cloned; the clone has distinct identity but equal value:"
-{ $subsection clone } ;
-
-ARTICLE: "dataflow" "Data and control flow"
-{ $subsection "evaluator" }
-{ $subsection "words" }
-{ $subsection "effects" }
-{ $subsection "booleans" }
-{ $subsection "shuffle-words" }
-"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
-{ $subsection "cleave-combinators" }
-{ $subsection "spread-combinators" }
-{ $subsection "apply-combinators" }
-{ $subsection "slip-keep-combinators" }
-{ $subsection "conditionals" }
-{ $subsection "compositional-combinators" }
-{ $subsection "combinators" }
-"Advanced topics:"
-{ $subsection "implementing-combinators" }
-{ $subsection "errors" }
-{ $subsection "continuations" } ;
-
-ABOUT: "dataflow"
-
HELP: eq? ( obj1 obj2 -- ? )
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if two references point at the same object." } ;
{ $example "USING: kernel math prettyprint ;" "5 4 [ + ] 2curry ." "[ 5 4 + ]" }
} ;
-HELP: 3curry
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" callable } { "curry" curry } }
-{ $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } ", and then calls " { $snippet "quot" } "." }
-{ $notes "This operation is efficient and does not copy the quotation." } ;
-
-HELP: with
-{ $values { "param" object } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
-{ $description "Partial application on the left. The following two lines are equivalent:"
- { $code "swap [ swap A ] curry B" }
- { $code "[ A ] with B" }
-
+HELP: 3curry
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" callable } { "curry" curry } }
+{ $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } ", and then calls " { $snippet "quot" } "." }
+{ $notes "This operation is efficient and does not copy the quotation." } ;
+
+HELP: with
+{ $values { "param" object } { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
+{ $description "Partial application on the left. The following two lines are equivalent:"
+ { $code "swap [ swap A ] curry B" }
+ { $code "[ A ] with B" }
+
+}
+{ $notes "This operation is efficient and does not copy the quotation." }
+{ $examples
+ { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
+} ;
+
+HELP: compose
+{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
+{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
+{ $notes
+ "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
+ { $code
+ "[ 3 >r ] [ r> . ] compose"
+ }
+ "Except for this restriction, the following two lines are equivalent:"
+ { $code
+ "compose call"
+ "append call"
+ }
+ "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
+} ;
+
+
+HELP: prepose
+{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
+{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot2" } " followed by " { $snippet "quot1" } "." }
+{ $notes "See " { $link compose } " for details." } ;
+
+{ compose prepose } related-words
+
+HELP: 3compose
+{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
+{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
+{ $notes
+ "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
+ { $code
+ "[ >r ] swap [ r> ] 3compose"
+ }
+ "The correct way to achieve the effect of the above is the following:"
+ { $code
+ "[ dip ] curry"
+ }
+ "Excepting the retain stack restriction, the following two lines are equivalent:"
+ { $code
+ "3compose call"
+ "3append call"
+ }
+ "However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
+} ;
+
+HELP: dip
+{ $values { "obj" object } { "quot" quotation } }
+{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
+{ $notes "The following are equivalent:"
+ { $code ">r foo bar r>" }
+ { $code "[ foo bar ] dip" }
+} ;
+
+HELP: 2dip
+{ $values { "obj1" object } { "obj2" object } { "quot" quotation } }
+{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." }
+{ $notes "The following are equivalent:"
+ { $code ">r >r foo bar r> r>" }
+ { $code "[ foo bar ] 2dip" }
+} ;
+
+HELP: while
+{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
+{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
+$nl
+"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
+{ $code
+ "[ P ] [ Q ] [ T ] while"
+ "[ P ] [ Q ] [ ] while T"
+}
+"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ;
+
+HELP: loop
+{ $values
+ { "pred" quotation } }
+{ $description "Calls the quotation repeatedly until the output is true." }
+{ $examples "Loop until we hit a zero:"
+ { $unchecked-example "USING: kernel random math io ; "
+ " [ \"hi\" write bl 10 random zero? not ] loop"
+ "hi hi hi" }
+ "A fun loop:"
+ { $example "USING: kernel prettyprint math ; "
+ "3 [ dup . 7 + 11 mod dup 3 = not ] loop"
+ "3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" }
+} ;
+
+HELP: assert
+{ $values { "got" "the obtained value" } { "expect" "the expected value" } }
+{ $description "Throws an " { $link assert } " error." }
+{ $error-description "Thrown when a unit test or other assertion fails." } ;
+
+HELP: assert=
+{ $values { "a" object } { "b" object } }
+{ $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ;
+
+
+ARTICLE: "shuffle-words" "Shuffle words"
+"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
+$nl
+"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
+$nl
+"Removing stack elements:"
+{ $subsection drop }
+{ $subsection 2drop }
+{ $subsection 3drop }
+{ $subsection nip }
+{ $subsection 2nip }
+"Duplicating stack elements:"
+{ $subsection dup }
+{ $subsection 2dup }
+{ $subsection 3dup }
+{ $subsection dupd }
+{ $subsection over }
+{ $subsection 2over }
+{ $subsection pick }
+{ $subsection tuck }
+"Permuting stack elements:"
+{ $subsection swap }
+{ $subsection swapd }
+{ $subsection rot }
+{ $subsection -rot }
+{ $subsection spin }
+{ $subsection roll }
+{ $subsection -roll }
+"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
+{ $subsection >r }
+{ $subsection r> }
+"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
+{ $example "1 2 3 >r .s r>" "1\n2" }
+"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning."
+$nl
+"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ;
+
+ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
+"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
+{ $code
+ ": keep [ ] bi ;"
+ ": 2keep [ ] 2bi ;"
+ ": 3keep [ ] 3bi ;"
+ ""
+ ": dup [ ] [ ] bi ;"
+ ": 2dup [ ] [ ] 2bi ;"
+ ": 3dup [ ] [ ] 3bi ;"
+ ""
+ ": tuck [ nip ] [ ] 2bi ;"
+ ": swap [ nip ] [ drop ] 2bi ;"
+ ""
+ ": over [ ] [ drop ] 2bi ;"
+ ": pick [ ] [ 2drop ] 3bi ;"
+ ": 2over [ ] [ drop ] 3bi ;"
+} ;
+
+ARTICLE: "cleave-combinators" "Cleave combinators"
+"The cleave combinators apply multiple quotations to a single value."
+$nl
+"Two quotations:"
+{ $subsection bi }
+{ $subsection 2bi }
+{ $subsection 3bi }
+"Three quotations:"
+{ $subsection tri }
+{ $subsection 2tri }
+{ $subsection 3tri }
+"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
+{ $code
+ "! First alternative; uses keep"
+ "[ 1 + ] keep"
+ "[ 1 - ] keep"
+ "2 *"
+ "! Second alternative: uses tri"
+ "[ 1 + ]"
+ "[ 1 - ]"
+ "[ 2 * ] tri"
+}
+"The latter is more aesthetically pleasing than the former."
+$nl
+"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "cleave-shuffle-equivalence" } ;
+
+ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
+"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
+{ $code
+ ": dip [ ] bi* ;"
+ ": 2dip [ ] [ ] tri* ;"
+ ""
+ ": slip [ call ] [ ] bi* ;"
+ ": 2slip [ call ] [ ] [ ] tri* ;"
+ ""
+ ": nip [ drop ] [ ] bi* ;"
+ ": 2nip [ drop ] [ drop ] [ ] tri* ;"
+ ""
+ ": rot"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": -rot"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": spin"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
+} ;
+
+ARTICLE: "spread-combinators" "Spread combinators"
+"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
+$nl
+"Two quotations:"
+{ $subsection bi* }
+{ $subsection 2bi* }
+"Three quotations:"
+{ $subsection tri* }
+"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
+{ $code
+ "! First alternative; uses retain stack explicitly"
+ ">r >r 1 +"
+ "r> 1 -"
+ "r> 2 *"
+ "! Second alternative: uses tri*"
+ "[ 1 + ]"
+ "[ 1 - ]"
+ "[ 2 * ] tri*"
}
-{ $notes "This operation is efficient and does not copy the quotation." }
-{ $examples
- { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
-} ;
-HELP: compose
-{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
-{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
-{ $notes
- "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
- { $code
- "[ 3 >r ] [ r> . ] compose"
- }
- "Except for this restriction, the following two lines are equivalent:"
- { $code
- "compose call"
- "append call"
- }
- "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
-} ;
+$nl
+"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "spread-shuffle-equivalence" } ;
+ARTICLE: "apply-combinators" "Apply combinators"
+"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
+$nl
+"Two quotations:"
+{ $subsection bi@ }
+{ $subsection 2bi@ }
+"Three quotations:"
+{ $subsection tri@ }
+"A pair of utility words built from " { $link bi@ } ":"
+{ $subsection both? }
+{ $subsection either? } ;
-HELP: prepose
-{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
-{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot2" } " followed by " { $snippet "quot1" } "." }
-{ $notes "See " { $link compose } " for details." } ;
+ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators"
+"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
+{ $subsection dip }
+{ $subsection 2dip }
+"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
+{ $subsection slip }
+{ $subsection 2slip }
+{ $subsection 3slip }
+"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
+{ $subsection keep }
+{ $subsection 2keep }
+{ $subsection 3keep } ;
-{ compose prepose } related-words
+ARTICLE: "compositional-combinators" "Compositional combinators"
+"Quotations can be composed using efficient quotation-specific operations:"
+{ $subsection curry }
+{ $subsection 2curry }
+{ $subsection 3curry }
+{ $subsection with }
+{ $subsection compose }
+{ $subsection 3compose }
+{ $subsection prepose }
+"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
-HELP: 3compose
-{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
-{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
-{ $notes
- "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
- { $code
- "[ >r ] swap [ r> ] 3compose"
- }
- "The correct way to achieve the effect of the above is the following:"
- { $code
- "[ dip ] curry"
- }
- "Excepting the retain stack restriction, the following two lines are equivalent:"
- { $code
- "3compose call"
- "3append call"
- }
- "However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
-} ;
+ARTICLE: "implementing-combinators" "Implementing combinators"
+"The following pair of words invoke words and quotations reflectively:"
+{ $subsection call }
+{ $subsection execute }
+"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
+{ $code
+ ": keep ( x quot -- x )"
+ " over >r call r> ; inline"
+}
+"Word inlining is documented in " { $link "declarations" } "." ;
-HELP: dip
-{ $values { "obj" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
-{ $notes "The following are equivalent:"
- { $code ">r foo bar r>" }
- { $code "[ foo bar ] dip" }
-} ;
+ARTICLE: "booleans" "Booleans"
+"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
+{ $subsection f }
+{ $subsection t }
+"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
+$nl
+"Here is the " { $link f } " object:"
+{ $example "f ." "f" }
+"Here is the " { $link f } " class:"
+{ $example "\\ f ." "POSTPONE: f" }
+"They are not equal:"
+{ $example "f \\ f = ." "f" }
+"Here is an array containing the " { $link f } " object:"
+{ $example "{ f } ." "{ f }" }
+"Here is an array containing the " { $link f } " class:"
+{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
+"The " { $link f } " object is an instance of the " { $link f } " class:"
+{ $example "f class ." "POSTPONE: f" }
+"The " { $link f } " class is an instance of " { $link word } ":"
+{ $example "\\ f class ." "word" }
+"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
+{ $example "t \\ t eq? ." "t" }
+"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
-HELP: 2dip
-{ $values { "obj1" object } { "obj2" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." }
-{ $notes "The following are equivalent:"
- { $code ">r >r foo bar r> r>" }
- { $code "[ foo bar ] 2dip" }
-} ;
+ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
+"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
+$nl
+"The following two lines are equivalent:"
+{ $code "[ drop f ] unless" "swap and" }
+"The following two lines are equivalent:"
+{ $code "[ ] [ ] ?if" "swap or" }
+"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
+{ $code "[ L ] unless*" "L or" } ;
-HELP: while
-{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
-{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
-{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
+ARTICLE: "conditionals" "Conditionals and logic"
+"The basic conditionals:"
+{ $subsection if }
+{ $subsection when }
+{ $subsection unless }
+"Forms abstracting a common stack shuffle pattern:"
+{ $subsection if* }
+{ $subsection when* }
+{ $subsection unless* }
+"Another form abstracting a common stack shuffle pattern:"
+{ $subsection ?if }
+"Sometimes instead of branching, you just need to pick one of two values:"
+{ $subsection ? }
+"There are some logical operations on booleans:"
+{ $subsection >boolean }
+{ $subsection not }
+{ $subsection and }
+{ $subsection or }
+{ $subsection xor }
+{ $subsection "conditionals-boolean-equivalence" }
+"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
+{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
+
+ARTICLE: "equality" "Equality"
+"There are two distinct notions of ``sameness'' when it comes to objects."
$nl
-"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
-{ $code
- "[ P ] [ Q ] [ T ] while"
- "[ P ] [ Q ] [ ] while T"
-}
-"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ;
+"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:"
+{ $subsection eq? }
+"You can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "):"
+{ $subsection = }
+"A third form of equality is provided by " { $link number= } ". It compares numeric value while disregarding types."
+$nl
+"Custom value comparison methods for use with " { $link = } " can be defined on a generic word:"
+{ $subsection equal? }
+"Utility class:"
+{ $subsection identity-tuple }
+"An object can be cloned; the clone has distinct identity but equal value:"
+{ $subsection clone } ;
-HELP: assert
-{ $values { "got" "the obtained value" } { "expect" "the expected value" } }
-{ $description "Throws an " { $link assert } " error." }
-{ $error-description "Thrown when a unit test or other assertion fails." } ;
+ARTICLE: "dataflow" "Data and control flow"
+{ $subsection "evaluator" }
+{ $subsection "words" }
+{ $subsection "effects" }
+{ $subsection "booleans" }
+{ $subsection "shuffle-words" }
+"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
+{ $subsection "cleave-combinators" }
+{ $subsection "spread-combinators" }
+{ $subsection "apply-combinators" }
+{ $subsection "slip-keep-combinators" }
+{ $subsection "conditionals" }
+{ $subsection "compositional-combinators" }
+{ $subsection "combinators" }
+"Advanced topics:"
+{ $subsection "implementing-combinators" }
+{ $subsection "errors" }
+{ $subsection "continuations" } ;
+
+ABOUT: "dataflow"
-HELP: assert=
-{ $values { "a" object } { "b" object } }
-{ $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel assocs classes
math.order kernel.private ;
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
+! We do this in its own compilation unit so that they can be
+! folded below
+<<
: cell ( -- n ) 7 getenv ; foldable
+: (first-bignum) ( m -- n ) tag-bits get - 1 - 2^ ; foldable
+>>
+
: cells ( m -- n ) cell * ; inline
: cell-bits ( -- n ) 8 cells ; inline
: bootstrap-cell-bits 8 bootstrap-cells ; inline
-: (first-bignum) ( m -- n )
- tag-bits get - 1 - 2^ ;
-
: first-bignum ( -- n )
- cell-bits (first-bignum) ;
+ cell-bits (first-bignum) ; inline
: most-positive-fixnum ( -- n )
- first-bignum 1- ;
+ first-bignum 1- ; inline
: most-negative-fixnum ( -- n )
- first-bignum neg ;
+ first-bignum neg ; inline
: (max-array-capacity) ( b -- n )
- 5 - 2^ 1- ;
+ 5 - 2^ 1- ; inline
: max-array-capacity ( -- n )
- cell-bits (max-array-capacity) ;
+ cell-bits (max-array-capacity) ; inline
: bootstrap-first-bignum ( -- n )
bootstrap-cell-bits (first-bignum) ;
M: real >integer
dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] [ >bignum ] if ;
+
+UNION: immediate fixnum POSTPONE: f ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Factor source code lexer
--- /dev/null
+Slava Pestov
--- /dev/null
+Sequence construction utility
--- /dev/null
+collections
math.private ;
IN: math
-ARTICLE: "division-by-zero" "Division by zero"
-"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
-$nl
-"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero."
-$nl
-"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
-
-ARTICLE: "number-protocol" "Number protocol"
-"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float."
-$nl
-"Two examples where you should note the types of the inputs and outputs:"
-{ $example "3 >fixnum 6 >bignum * class ." "bignum" }
-{ $example "1/2 2.0 + ." "4.5" }
-"The following usual operations are supported by all numbers."
-{ $subsection + }
-{ $subsection - }
-{ $subsection * }
-{ $subsection / }
-"Non-commutative operations take operands from the stack in the natural order; " { $snippet "6 2 /" } " divides 6 by 2."
-{ $subsection "division-by-zero" }
-"Real numbers (but not complex numbers) can be ordered:"
-{ $subsection < }
-{ $subsection <= }
-{ $subsection > }
-{ $subsection >= }
-"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
-{ $subsection number= } ;
-
-ARTICLE: "modular-arithmetic" "Modular arithmetic"
-{ $subsection mod }
-{ $subsection rem }
-{ $subsection /mod }
-{ $subsection /i }
-{ $see-also "integer-functions" } ;
-
-ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
-"There are two ways of looking at an integer -- as an abstract mathematical entity, or as a string of bits. The latter representation motivates " { $emphasis "bitwise operations" } "."
-{ $subsection bitand }
-{ $subsection bitor }
-{ $subsection bitxor }
-{ $subsection bitnot }
-{ $subsection shift }
-{ $subsection 2/ }
-{ $subsection 2^ }
-{ $subsection bit? }
-{ $see-also "conditionals" } ;
-
-ARTICLE: "arithmetic" "Arithmetic"
-"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers."
-$nl
-"Math words are in the " { $vocab-link "math" } " vocabulary. Implementation details are in the " { $vocab-link "math.private" } " vocabulary."
-{ $subsection "number-protocol" }
-{ $subsection "modular-arithmetic" }
-{ $subsection "bitwise-arithmetic" }
-{ $see-also "integers" "rationals" "floats" "complex-numbers" } ;
-
-ABOUT: "arithmetic"
-
HELP: number=
{ $values { "x" number } { "y" number } { "?" "a boolean" } }
{ $description "Tests if two numbers have the same numeric value." }
{ $code "1-" "1 -" }
} ;
+HELP: ?1+
+{ $description "If the input is not " { $link f } ", adds one. Otherwise, outputs a " { $snippet "0" } "." } ;
+
HELP: sq
{ $values { "x" number } { "y" number } }
{ $description "Multiplies a number by itself." } ;
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find-last } "." } ;
+
+ARTICLE: "division-by-zero" "Division by zero"
+"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
+$nl
+"The behavior of integer division is hardware specific. On x86 processors, " { $link /i } " and " { $link mod } " raise an error if both inputs are integers and the denominator is zero. On PowerPC, integer division by zero yields a result of zero."
+$nl
+"On the other hand, the " { $link / } " word, when given integer arguments, implements a much more expensive division algorithm which always yields an exact rational answer, and this word always tests for division by zero explicitly." ;
+
+ARTICLE: "number-protocol" "Number protocol"
+"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float."
+$nl
+"Two examples where you should note the types of the inputs and outputs:"
+{ $example "3 >fixnum 6 >bignum * class ." "bignum" }
+{ $example "1/2 2.0 + ." "4.5" }
+"The following usual operations are supported by all numbers."
+{ $subsection + }
+{ $subsection - }
+{ $subsection * }
+{ $subsection / }
+"Non-commutative operations take operands from the stack in the natural order; " { $snippet "6 2 /" } " divides 6 by 2."
+{ $subsection "division-by-zero" }
+"Real numbers (but not complex numbers) can be ordered:"
+{ $subsection < }
+{ $subsection <= }
+{ $subsection > }
+{ $subsection >= }
+"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
+{ $subsection number= } ;
+
+ARTICLE: "modular-arithmetic" "Modular arithmetic"
+{ $subsection mod }
+{ $subsection rem }
+{ $subsection /mod }
+{ $subsection /i }
+{ $see-also "integer-functions" } ;
+
+ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
+"There are two ways of looking at an integer -- as an abstract mathematical entity, or as a string of bits. The latter representation motivates " { $emphasis "bitwise operations" } "."
+{ $subsection bitand }
+{ $subsection bitor }
+{ $subsection bitxor }
+{ $subsection bitnot }
+{ $subsection shift }
+{ $subsection 2/ }
+{ $subsection 2^ }
+{ $subsection bit? }
+{ $see-also "conditionals" } ;
+
+ARTICLE: "arithmetic" "Arithmetic"
+"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers."
+$nl
+"Math words are in the " { $vocab-link "math" } " vocabulary. Implementation details are in the " { $vocab-link "math.private" } " vocabulary."
+{ $subsection "number-protocol" }
+{ $subsection "modular-arithmetic" }
+{ $subsection "bitwise-arithmetic" }
+{ $see-also "integers" "rationals" "floats" "complex-numbers" } ;
+
+ABOUT: "arithmetic"
+
[ "-1.0e-2" string>number number>string ]
unit-test
-[ "-1.0e-12" ]
-[ "-1.0e-12" string>number number>string ]
+[ t ]
+[ "-1.0e-12" string>number number>string { "-1.0e-12" "-1.0e-012" } member? ]
unit-test
[ f ]
[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
[ "-0.0" ] [ -0.0 number>string ] unit-test
+
+[ "-3/4" ] [ -3/4 number>string ] unit-test
+[ "-1-1/4" ] [ -5/4 number>string ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.private namespaces make sequences strings
-arrays combinators splitting math assocs ;
+USING: kernel math.private namespaces sequences strings
+arrays combinators splitting math assocs make ;
IN: math.parser
: digit> ( ch -- n )
: >digit ( n -- ch )
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
-: integer, ( num radix -- )
+: positive>base ( num radix -- str )
dup 1 <= [ "Invalid radix" throw ] when
- [ /mod >digit , ] keep over 0 >
- [ integer, ] [ 2drop ] if ;
+ [ dup 0 > ] swap [ /mod >digit ] curry [ ] "" produce-as nip
+ dup reverse-here ; inline
PRIVATE>
<PRIVATE
-: (>base) ( n -- str ) radix get >base ;
+: (>base) ( n -- str ) radix get positive>base ;
PRIVATE>
M: integer >base
- [
- over 0 < [
- swap neg swap integer, CHAR: - ,
+ over 0 = [
+ 2drop "0"
+ ] [
+ over 0 > [
+ positive>base
] [
- integer,
+ [ neg ] dip positive>base CHAR: - prefix
] if
- ] "" make reverse ;
+ ] if ;
M: ratio >base
[
+ dup 0 < negative? set
+ abs 1 /mod
+ [ dup zero? [ drop "" ] [ (>base) sign append ] if ]
[
- dup 0 < dup negative? set [ "-" % neg ] when
- 1 /mod
- >r dup zero? [ drop ] [ (>base) % sign % ] if r>
- dup numerator (>base) %
- "/" %
- denominator (>base) %
- ] "" make
+ [ numerator (>base) ]
+ [ denominator (>base) ] bi
+ "/" swap 3append
+ ] bi* append
+ negative? get [ CHAR: - prefix ] when
] with-radix ;
: fix-float ( str -- newstr )
-USING: help.markup help.syntax debugger sequences kernel ;
+USING: help.markup help.syntax debugger sequences kernel
+quotations math ;
IN: memory
-ARTICLE: "images" "Images"
-"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
-{ $subsection save }
-{ $subsection save-image }
-{ $subsection save-image-and-exit }
-"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
-$nl
-"New images can be created from scratch:"
-{ $subsection "bootstrap.image" }
-{ $see-also "tools.memory" "tools.deploy" } ;
-
-ABOUT: "images"
-
HELP: begin-scan ( -- )
{ $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
$nl
HELP: save
{ $description "Saves a snapshot of the heap to the current image file." } ;
+
+HELP: count-instances
+{ $values
+ { "quot" quotation }
+ { "n" integer } }
+{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." }
+{ $examples { $unchecked-example
+ "USING: memory words prettyprint ;"
+ "[ word? ] count-instances ."
+ "24210"
+} } ;
+
+ARTICLE: "images" "Images"
+"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
+{ $subsection save }
+{ $subsection save-image }
+{ $subsection save-image-and-exit }
+"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
+$nl
+"New images can be created from scratch:"
+{ $subsection "bootstrap.image" }
+{ $see-also "tools.memory" "tools.deploy" } ;
+
+ABOUT: "images"
-USING: generic kernel kernel.private math memory prettyprint
+USING: generic kernel kernel.private math memory prettyprint io
sequences tools.test words namespaces layouts classes
classes.builtin arrays quotations ;
IN: memory.tests
[ ] [
num-types get [
type>class [
+ dup . flush
"predicate" word-prop instances [
class drop
] each
quotations ;
IN: sequences
-ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
-"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
-$nl
-"These words assume the sequence index given is within bounds; if it is not, memory corruption can occur. Great care must be exercised when using these words. First, make sure the code in question is actually a bottleneck; next, try improving the algorithm first. If all else fails, then the unsafe sequence words can be used."
-$nl
-"There is a very important invariant these word must preserve: if at some point in time, the length of a sequence was " { $snippet "n" } ", then any future lookups of elements with indices below " { $snippet "n" } " must not crash the VM, even if the sequence length is now less than " { $snippet "n" } ". For example, vectors preserve this invariant by never shrinking the underlying storage, only growing it as necessary."
-$nl
-"The justification for this is that the VM should not crash if a resizable sequence is resized during the execution of an iteration combinator."
-$nl
-"Indeed, iteration combinators are the primary use-case for these words; if the iteration index is already guarded by a loop test which ensures it is within bounds, then additional bounds checks are redundant. For example, see the implementation of " { $link each } "." ;
+HELP: sequence
+{ $class-description "A mixin class whose instances are sequences. Custom implementations of the sequence protocol should be declared as instances of this mixin for all sequence functionality to work correctly:"
+ { $code "INSTANCE: my-sequence sequence" }
+} ;
-ARTICLE: "sequence-protocol" "Sequence protocol"
-"All sequences must be instances of a mixin class:"
-{ $subsection sequence }
-{ $subsection sequence? }
-"All sequences must know their length:"
-{ $subsection length }
-"At least one of the following two generic words must have a method for accessing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
-{ $subsection nth }
-{ $subsection nth-unsafe }
-"At least one of the following two generic words must have a method for storing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
-{ $subsection set-nth }
-{ $subsection set-nth-unsafe }
-"Note that even if the sequence is immutable, at least one of the generic words must be specialized, otherwise calling them will result in an infinite recursion. There is a standard word which throws an error indicating a sequence is immutable:"
-{ $subsection immutable }
-"The following two generic words are optional, as not all sequences are resizable:"
-{ $subsection set-length }
-{ $subsection lengthen }
-"An optional generic word for creating sequences of the same class as a given sequence:"
-{ $subsection like }
-"Optional generic words for optimization purposes:"
-{ $subsection new-sequence }
-{ $subsection new-resizable }
-{ $see-also "sequences-unsafe" } ;
+HELP: length
+{ $values { "seq" sequence } { "n" "a non-negative integer" } }
+{ $contract "Outputs the length of the sequence. All sequences support this operation." } ;
-ARTICLE: "sequences-integers" "Integer sequences and counted loops"
-"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
-$nl
-"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
-{ $example "3 [ . ] each" "0\n1\n2" }
-"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
-$nl
-"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
+HELP: set-length
+{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
+{ $contract "Resizes the sequence. Not all sequences are resizable." }
+{ $errors "Throws a " { $link bounds-error } " if the new length is negative." }
+{ $side-effects "seq" } ;
-ARTICLE: "sequences-access" "Accessing sequence elements"
-{ $subsection ?nth }
-"Concise way of extracting one of the first four elements:"
-{ $subsection first }
-{ $subsection second }
-{ $subsection third }
-{ $subsection fourth }
-"Unpacking sequences:"
-{ $subsection first2 }
-{ $subsection first3 }
-{ $subsection first4 }
-{ $see-also nth peek } ;
+HELP: lengthen
+{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
+{ $contract "Ensures the sequence has a length of at least " { $snippet "n" } " elements. This word differs from " { $link set-length } " in two respects:"
+ { $list
+ { "This word does not shrink the sequence if " { $snippet "n" } " is less than its length." }
+ { "The word doubles the underlying storage of " { $snippet "seq" } ", whereas " { $link set-length } " is permitted to set it to equal " { $snippet "n" } ". This ensures that repeated calls to this word with constant increments of " { $snippet "n" } " do not result in a quadratic amount of copying, so that for example " { $link push-all } " can run efficiently when used in a loop." }
+ }
+} ;
-ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
-"Adding elements:"
-{ $subsection prefix }
-{ $subsection suffix }
-"Removing elements:"
-{ $subsection remove } ;
+HELP: nth
+{ $values { "n" "a non-negative integer" } { "seq" sequence } { "elt" "the element at the " { $snippet "n" } "th index" } }
+{ $contract "Outputs the " { $snippet "n" } "th element of the sequence. Elements are numbered from zero, so the last element has an index one less than the length of the sequence. All sequences support this operation." }
+{ $errors "Throws a " { $link bounds-error } " if the index is negative, or greater than or equal to the length of the sequence." } ;
-ARTICLE: "sequences-reshape" "Reshaping sequences"
-"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
-{ $subsection repetition }
-{ $subsection <repetition> }
-"Reversing a sequence:"
-{ $subsection reverse }
-"A " { $emphasis "reversal" } " presents a reversed view of an underlying sequence:"
-{ $subsection reversed }
-{ $subsection <reversed> }
-"Transposing a matrix:"
-{ $subsection flip } ;
+HELP: set-nth
+{ $values { "elt" object } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
+{ $contract "Sets the " { $snippet "n" } "th element of the sequence. Storing beyond the end of a resizable sequence such as a vector or string buffer grows the sequence." }
+{ $errors "Throws an error if the index is negative, or if the sequence is not resizable and the index is greater than or equal to the length of the sequence."
+$nl
+"Throws an error if the sequence cannot hold elements of the given type." }
+{ $side-effects "seq" } ;
-ARTICLE: "sequences-appending" "Appending sequences"
-{ $subsection append }
-{ $subsection prepend }
-{ $subsection 3append }
-{ $subsection concat }
-{ $subsection join }
-"A pair of words useful for aligning strings:"
-{ $subsection pad-left }
-{ $subsection pad-right } ;
+HELP: nths
+{ $values
+ { "indices" sequence } { "seq" sequence }
+ { "seq'" sequence } }
+{ $description "Ouptuts a sequence of elements from the input sequence indexed by the indices." }
+{ $examples
+ { $example "USING: prettyprint sequences ;"
+ "{ 0 2 } { \"a\" \"b\" \"c\" } nths ."
+ "{ \"a\" \"c\" }"
+ }
+} ;
-ARTICLE: "sequences-slices" "Subsequences and slices"
-"Extracting a subsequence:"
-{ $subsection subseq }
-{ $subsection head }
-{ $subsection tail }
-{ $subsection head* }
-{ $subsection tail* }
-"Removing the first or last element:"
-{ $subsection rest }
-{ $subsection but-last }
-"Taking a sequence apart into a head and a tail:"
-{ $subsection unclip }
-{ $subsection unclip-last }
-{ $subsection cut }
-{ $subsection cut* }
-"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
-{ $subsection slice }
-{ $subsection slice? }
-"Creating slices:"
-{ $subsection <slice> }
-{ $subsection head-slice }
-{ $subsection tail-slice }
-{ $subsection but-last-slice }
-{ $subsection rest-slice }
-{ $subsection head-slice* }
-{ $subsection tail-slice* }
-"Taking a sequence apart into a head and a tail:"
-{ $subsection unclip-slice }
-{ $subsection cut-slice }
-"A utility for words which use slices as iterators:"
-{ $subsection <flat-slice> } ;
+HELP: immutable
+{ $values { "seq" sequence } }
+{ $description "Throws an " { $link immutable } " error." }
+{ $error-description "Thrown if an attempt is made to modify an immutable sequence." } ;
-ARTICLE: "sequences-combinators" "Sequence combinators"
-"Iteration:"
-{ $subsection each }
-{ $subsection reduce }
-{ $subsection interleave }
-{ $subsection replicate }
-{ $subsection replicate-as }
-"Mapping:"
-{ $subsection map }
-{ $subsection map-as }
-{ $subsection accumulate }
-{ $subsection produce }
-"Filtering:"
-{ $subsection push-if }
-{ $subsection filter }
-"Testing if a sequence contains elements satisfying a predicate:"
-{ $subsection contains? }
-{ $subsection all? }
-"Testing how elements are related:"
-{ $subsection monotonic? }
-{ $subsection "sequence-2combinators" } ;
+HELP: new-sequence
+{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
+{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
-ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
-"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
-{ $subsection 2each }
-{ $subsection 2reduce }
-{ $subsection 2map }
-{ $subsection 2map-as }
-{ $subsection 2all? } ;
+HELP: new-resizable
+{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } }
+{ $contract "Outputs a resizable mutable sequence with an initial capacity of " { $snippet "n" } " elements and zero length, which can hold the elements of " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences ;" "300 V{ } new-resizable ." "V{ }" }
+ { $example "USING: prettyprint sequences ;" "300 SBUF\" \" new-resizable ." "SBUF\" \"" }
+} ;
-ARTICLE: "sequences-tests" "Testing sequences"
-"Testing for an empty sequence:"
-{ $subsection empty? }
-"Testing indices:"
-{ $subsection bounds-check? }
-"Testing if a sequence contains an object:"
-{ $subsection member? }
-{ $subsection memq? }
-"Testing if a sequence contains a subsequence:"
-{ $subsection head? }
-{ $subsection tail? }
-{ $subsection subseq? }
-"Testing how elements are related:"
-{ $subsection all-eq? }
-{ $subsection all-equal? } ;
+HELP: like
+{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $contract "Outputs a sequence with the same elements as " { $snippet "seq" } ", but " { $emphasis "like" } " the template sequence, in the sense that it either has the same class as the template sequence, or if the template sequence is a virtual sequence, the same class as the template sequence's underlying sequence."
+$nl
+"The default implementation does nothing." }
+{ $notes "Unlike " { $link clone-like } ", the output sequence might share storage with the input sequence." } ;
-ARTICLE: "sequences-search" "Searching sequences"
-"Finding the index of an element:"
-{ $subsection index }
-{ $subsection index-from }
-{ $subsection last-index }
-{ $subsection last-index-from }
-"Finding the start of a subsequence:"
-{ $subsection start }
-{ $subsection start* }
-"Finding the index of an element satisfying a predicate:"
-{ $subsection find }
-{ $subsection find-from }
-{ $subsection find-last }
-{ $subsection find-last-from } ;
+HELP: empty?
+{ $values { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests if the sequence has zero length." } ;
-ARTICLE: "sequences-trimming" "Trimming sequences"
-"Trimming words:"
-{ $subsection trim }
-{ $subsection trim-left }
-{ $subsection trim-right }
-"Potentially more efficient trim:"
-{ $subsection trim-slice }
-{ $subsection trim-left-slice }
-{ $subsection trim-right-slice } ;
-
-ARTICLE: "sequences-destructive" "Destructive operations"
-"These words modify their input, instead of creating a new sequence."
-$nl
-"In-place variant of " { $link reverse } ":"
-{ $subsection reverse-here }
-"In-place variant of " { $link append } ":"
-{ $subsection push-all }
-"In-place variant of " { $link remove } ":"
-{ $subsection delete }
-"In-place variant of " { $link map } ":"
-{ $subsection change-each }
-"Changing elements:"
-{ $subsection change-nth }
-{ $subsection cache-nth }
-"Deleting elements:"
-{ $subsection delete-nth }
-{ $subsection delete-slice }
-{ $subsection delete-all }
-"Other destructive words:"
-{ $subsection move }
-{ $subsection exchange }
-{ $subsection copy }
-{ $subsection replace-slice }
-{ $see-also set-nth push pop "sequences-stacks" } ;
-
-ARTICLE: "sequences-stacks" "Treating sequences as stacks"
-"The classical stack operations, modifying a sequence in place:"
-{ $subsection peek }
-{ $subsection push }
-{ $subsection pop }
-{ $subsection pop* }
-{ $see-also empty? } ;
-
-ARTICLE: "sequences-comparing" "Comparing sequences"
-"Element equality testing:"
-{ $subsection sequence= }
-{ $subsection mismatch }
-{ $subsection drop-prefix }
-"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
-
-ARTICLE: "sequences-f" "The f object as a sequence"
-"The " { $link f } " object supports the sequence protocol in a trivial way. It responds with a length of zero and throws an out of bounds error when an attempt is made to access elements." ;
-
-ARTICLE: "sequences" "Sequence operations"
-"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
-$nl
-"Sequences implement a protocol:"
-{ $subsection "sequence-protocol" }
-{ $subsection "sequences-f" }
-{ $subsection "sequences-integers" }
-"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $emphasis "virtual sequences" } "."
-{ $subsection "sequences-access" }
-{ $subsection "sequences-combinators" }
-{ $subsection "sequences-add-remove" }
-{ $subsection "sequences-appending" }
-{ $subsection "sequences-slices" }
-{ $subsection "sequences-reshape" }
-{ $subsection "sequences-tests" }
-{ $subsection "sequences-search" }
-{ $subsection "sequences-comparing" }
-{ $subsection "sequences-split" }
-{ $subsection "grouping" }
-{ $subsection "sequences-destructive" }
-{ $subsection "sequences-stacks" }
-{ $subsection "sequences-sorting" }
-{ $subsection "binary-search" }
-{ $subsection "sets" }
-{ $subsection "sequences-trimming" }
-"For inner loops:"
-{ $subsection "sequences-unsafe" } ;
-
-ABOUT: "sequences"
-
-HELP: sequence
-{ $class-description "A mixin class whose instances are sequences. Custom implementations of the sequence protocol should be declared as instances of this mixin for all sequence functionality to work correctly:"
- { $code "INSTANCE: my-sequence sequence" }
-} ;
-
-HELP: length
-{ $values { "seq" sequence } { "n" "a non-negative integer" } }
-{ $contract "Outputs the length of the sequence. All sequences support this operation." } ;
-
-HELP: set-length
-{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
-{ $contract "Resizes the sequence. Not all sequences are resizable." }
-{ $errors "Throws a " { $link bounds-error } " if the new length is negative." }
-{ $side-effects "seq" } ;
-
-HELP: lengthen
-{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
-{ $contract "Ensures the sequence has a length of at least " { $snippet "n" } " elements. This word differs from " { $link set-length } " in two respects:"
- { $list
- { "This word does not shrink the sequence if " { $snippet "n" } " is less than its length." }
- { "The word doubles the underlying storage of " { $snippet "seq" } ", whereas " { $link set-length } " is permitted to set it to equal " { $snippet "n" } ". This ensures that repeated calls to this word with constant increments of " { $snippet "n" } " do not result in a quadratic amount of copying, so that for example " { $link push-all } " can run efficiently when used in a loop." }
- }
-} ;
-
-HELP: nth
-{ $values { "n" "a non-negative integer" } { "seq" sequence } { "elt" "the element at the " { $snippet "n" } "th index" } }
-{ $contract "Outputs the " { $snippet "n" } "th element of the sequence. Elements are numbered from zero, so the last element has an index one less than the length of the sequence. All sequences support this operation." }
-{ $errors "Throws a " { $link bounds-error } " if the index is negative, or greater than or equal to the length of the sequence." } ;
-
-HELP: set-nth
-{ $values { "elt" object } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
-{ $contract "Sets the " { $snippet "n" } "th element of the sequence. Storing beyond the end of a resizable sequence such as a vector or string buffer grows the sequence." }
-{ $errors "Throws an error if the index is negative, or if the sequence is not resizable and the index is greater than or equal to the length of the sequence."
-$nl
-"Throws an error if the sequence cannot hold elements of the given type." }
-{ $side-effects "seq" } ;
-
-HELP: immutable
-{ $values { "seq" sequence } }
-{ $description "Throws an " { $link immutable } " error." }
-{ $error-description "Thrown if an attempt is made to modify an immutable sequence." } ;
-
-HELP: new-sequence
-{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
-{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
-
-HELP: new-resizable
-{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } }
-{ $contract "Outputs a resizable mutable sequence with an initial capacity of " { $snippet "n" } " elements and zero length, which can hold the elements of " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: prettyprint sequences ;" "300 V{ } new-resizable ." "V{ }" }
- { $example "USING: prettyprint sequences ;" "300 SBUF\" \" new-resizable ." "SBUF\" \"" }
-} ;
-
-HELP: like
-{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" "a new sequence" } }
-{ $contract "Outputs a sequence with the same elements as " { $snippet "seq" } ", but " { $emphasis "like" } " the template sequence, in the sense that it either has the same class as the template sequence, or if the template sequence is a virtual sequence, the same class as the template sequence's underlying sequence."
-$nl
-"The default implementation does nothing." }
-{ $notes "Unlike " { $link clone-like } ", the output sequence might share storage with the input sequence." } ;
-
-HELP: empty?
-{ $values { "seq" sequence } { "?" "a boolean" } }
-{ $description "Tests if the sequence has zero length." } ;
-
-HELP: if-empty
-{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
-{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
-{ $example
- "USING: kernel prettyprint sequences ;"
- "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
- "6"
-} ;
+HELP: if-empty
+{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
+{ $example
+ "USING: kernel prettyprint sequences ;"
+ "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
+ "6"
+} ;
HELP: when-empty
{ $values
{ $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" }
} ;
+HELP: reduce-index
+{ $values
+ { "seq" sequence } { "identity" object } { "quot" quotation } }
+{ $description "Combines successive elements of the sequence and their indices binary operations, and outputs the final result. On the first iteration, the three inputs to the quotation are " { $snippet "identity" } ", the first element of the sequence, and its index, 0. On successive iterations, the first input is the result of the previous iteration, the second input is the corresponding element of the sequence, and the third is its index." }
+{ $examples { $example "USING: sequences prettyprint math ;"
+ "{ 10 50 90 } 0 [ + + ] reduce-index ."
+ "153"
+} } ;
+
HELP: accumulate
{ $values { "identity" object } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
"Note that " { $link map } " could not be used here, because it would create another string to hold results, and one-element strings cannot themselves be elements of strings."
} ;
+HELP: each-index
+{ $values
+ { "seq" sequence } { "quot" quotation } }
+{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack." }
+{ $examples { $example "USING: sequences prettyprint math ;"
+"{ 10 20 30 } [ + . ] each-index"
+"10\n21\n32"
+} } ;
+
+HELP: map-index
+{ $values
+ { "seq" sequence } { "quot" quotation } }
+{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." }
+{ $examples { $example "USING: sequences prettyprint math ;"
+"{ 10 20 30 } [ + ] map-index ."
+"{ 10 21 32 }"
+} } ;
+
HELP: change-nth
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }
{ $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." }
{ $values { "obj" object } { "seq" sequence } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." } ;
+HELP: remove-nth
+{ $values
+ { "n" integer } { "seq" sequence }
+ { "seq'" sequence } }
+{ $description "Creates a new sequence without the element at index " { $snippet "n" } "." }
+{ $examples "Notice that the original sequence is left intact:" { $example "USING: sequences prettyprint kernel ;"
+ "{ 1 2 3 } 1 over remove-nth . ."
+ "{ 1 3 }\n{ 1 2 3 }"
+} } ;
+
HELP: move
{ $values { "from" "an index in " { $snippet "seq" } } { "to" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } }
{ $description "Sets the element with index " { $snippet "m" } " to the element with index " { $snippet "n" } "." }
HELP: <reversed> ( seq -- reversed )
{ $values { "seq" sequence } { "reversed" "a new sequence" } }
-{ $description "Creates an instance of the " { $link reversed } " virtual sequence." } ;
+{ $description "Creates an instance of the " { $link reversed } " class." }
+{ $see-also "virtual-sequences" } ;
HELP: slice-error
{ $values { "str" "a reason" } }
{ delete-nth remove delete } related-words
HELP: cut-slice
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before" sequence } { "after" "a slice" } }
+{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before-slice" sequence } { "after-slice" "a slice" } }
{ $description "Outputs a pair of sequences, where " { $snippet "before" } " consists of the first " { $snippet "n" } " elements of " { $snippet "seq" } " and has the same type, while " { $snippet "after" } " is a slice of the remaining elements." }
{ $notes "Unlike " { $link cut } ", the run time of this word is proportional to the length of " { $snippet "before" } ", not " { $snippet "after" } ", so it is suitable for use in an iterative algorithm which cuts successive pieces off a sequence." } ;
} ;
HELP: unclip-slice
-{ $values { "seq" sequence } { "rest" slice } { "first" object } }
+{ $values { "seq" sequence } { "rest-slice" slice } { "first" object } }
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
HELP: unclip-last
} ;
HELP: unclip-last-slice
-{ $values { "seq" sequence } { "butlast" slice } { "last" object } }
+{ $values { "seq" sequence } { "butlast-slice" slice } { "last" object } }
{ $description "Outputs a head sequence and the last element of " { $snippet "seq" } "; the head sequence consists of all elements of " { $snippet "seq" } " but the last Unlike " { $link unclip-last } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
HELP: sum
"{ 2 4 }\n{ 1 3 5 }"
}
} ;
+
+HELP: virtual-seq
+{ $values
+ { "seq" sequence }
+ { "seq'" sequence } }
+{ $description "Part of the virtual sequence protocol, this word is used to return an underlying array from which to look up a value at an index given by " { $link virtual@ } "." } ;
+
+HELP: virtual@
+{ $values
+ { "n" integer } { "seq" sequence }
+ { "n'" integer } { "seq'" sequence } }
+{ $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index into the underlying storage returned by " { $link virtual-seq } "." } ;
+
+HELP: 2change-each
+{ $values
+ { "seq1" sequence } { "seq2" sequence } { "quot" quotation } }
+{ $description "Calls the quotation on subsequent pairs of objects from the two input sequences. The resulting computation replaces the element in the first sequence." }
+{ $examples { $example "USING: kernel math sequences prettyprint ;"
+ "{ 10 20 30 } dup { 60 70 80 } [ + ] 2change-each ."
+ "{ 70 90 110 }"
+} } ;
+
+HELP: 2map-reduce
+{ $values
+ { "seq1" sequence } { "seq2" sequence } { "map-quot" quotation } { "reduce-quot" quotation }
+ { "result" object } }
+{ $description "Unclips the first element of each sequence and calls " { $snippet "map-quot" } " on both objects. The result of this calculation is passed, along with the rest of both sequences, to " { $link 2reduce } ", with the computed object as the identity." }
+{ $examples { $example "USING: sequences prettyprint math ;"
+ "{ 10 30 50 } { 200 400 600 } [ + ] [ + ] 2map-reduce ."
+ "1290"
+} } ;
+
+HELP: 2pusher
+{ $values
+ { "quot" quotation }
+ { "quot" quotation } { "accum1" vector } { "accum2" vector } }
+{ $description "Creates two new vectors to accumultate values based on a predicate. The first vector accumulates values for which the predicate yields true; the second for false." } ;
+
+HELP: 2reverse-each
+{ $values
+ { "seq1" sequence } { "seq2" sequence } { "quot" quotation } }
+{ $description "Reverse the sequences using the " { $link <reversed> } " word and calls " { $link 2each } " on the reversed sequences." }
+{ $examples { $example "USING: sequences math prettyprint ;"
+ "{ 10 20 30 } { 1 2 3 } [ + . ] 2reverse-each"
+ "33\n22\n11"
+} } ;
+
+HELP: 2unclip-slice
+{ $values
+ { "seq1" sequence } { "seq2" sequence }
+ { "rest-slice1" sequence } { "rest-slice2" sequence } { "first1" object } { "first2" object } }
+{ $description "Unclips the first element of each sequence and leaves two slice elements and the two unclipped objects on the stack." }
+{ $examples { $example "USING: sequences prettyprint kernel arrays ;"
+ "{ 1 2 } { 3 4 } 2unclip-slice 4array [ . ] each"
+ "T{ slice { from 1 } { to 2 } { seq { 1 2 } } }\nT{ slice { from 1 } { to 2 } { seq { 3 4 } } }\n1\n3"
+} } ;
+
+HELP: accumulator
+{ $values
+ { "quot" quotation }
+ { "quot'" quotation } { "vec" vector } }
+{ $description "Creates a new quotation that pushes its result to a vector and outputs that vector on the stack." }
+{ $examples { $example "USING: sequences prettyprint kernel math ;"
+ "{ 1 2 } [ 30 + ] accumulator [ each ] dip ."
+ "V{ 31 32 }"
+} } ;
+
+HELP: binary-reduce
+{ $values
+ { "seq" sequence } { "start" integer } { "quot" quotation }
+ { "value" object } }
+{ $description "Like " { $link reduce } ", but splits the sequence in half recursively until each sequence is small enough, and calls the quotation on these smaller sequences. If the quotation computes values that depend on the size of their input, such as bignum arithmetic, then this algorithm can be more efficient than using " { $link reduce } "." }
+{ $examples "Computing factorial:"
+ { $example "USING: prettyprint sequences math ;"
+ "40 rest-slice 1 [ * ] binary-reduce ."
+ "20397882081197443358640281739902897356800000000" }
+} ;
+
+HELP: follow
+{ $values
+ { "obj" object } { "quot" quotation }
+ { "seq" sequence } }
+{ $description "Outputs a sequence containing the input object and all of the objects generated by successively feeding the result of the quotation called on the input object to the quotation recursuively. Objects yielded by the quotation are added to the output sequence until the quotation yields " { $link f } ", at which point the recursion terminates." }
+{ $examples "Get random numbers until zero is reached:"
+ { $unchecked-example
+ "USING: random sequences prettyprint math ;"
+ "100 [ random dup zero? [ drop f ] when ] follow ."
+ "{ 100 86 34 32 24 11 7 2 }"
+} } ;
+
+HELP: halves
+{ $values
+ { "seq" sequence }
+ { "first-slice" slice } { "second-slice" slice } }
+{ $description "Splits a sequence into two slices at the midpoint. If the sequence has an odd number of elements, the extra element is returned in the second slice." }
+{ $examples { $example "USING: arrays sequences prettyprint kernel ;"
+ "{ 1 2 3 4 5 } halves [ >array . ] bi@"
+ "{ 1 2 }\n{ 3 4 5 }"
+} } ;
+
+HELP: indices
+{ $values
+ { "obj" object } { "seq" sequence }
+ { "indices" sequence } }
+{ $description "Compares the input object to every element in the sequence and returns a vector containing the index of every position where the element was found." }
+{ $examples { $example "USING: sequences prettyprint ;"
+ "2 { 2 4 2 6 2 8 2 10 } indices ."
+ "V{ 0 2 4 6 }"
+} } ;
+
+HELP: insert-nth
+{ $values
+ { "elt" object } { "n" integer } { "seq" sequence }
+ { "seq'" sequence } }
+{ $description "Creates a new sequence where the " { $snippet "n" } "th index is set to the input object." }
+{ $examples { $example "USING: prettyprint sequences ;"
+ "40 3 { 10 20 30 50 } insert-nth ."
+ "{ 10 20 30 40 50 }"
+} } ;
+
+HELP: map-reduce
+{ $values
+ { "seq" sequence } { "map-quot" quotation } { "reduce-quot" quotation }
+ { "result" object } }
+{ $description "Unclips the first element of the sequence, calls " { $snippet "map-quot" } " on that element, and proceeds like a " { $link reduce } ", where the calculated element is the identity element and the rest of the sequence is the sequence to reduce." }
+{ $examples { $example "USING: sequences prettyprint math ;"
+ "{ 1 3 5 } [ sq ] [ + ] map-reduce ."
+ "35"
+} } ;
+
+HELP: new-like
+{ $values
+ { "len" integer } { "exemplar" "an exemplar sequence" } { "quot" quotation }
+ { "seq" sequence } }
+{ $description "Creates a new sequence of length " { $snippet "len" } " and calls the quotation with this sequence on the stack. The output of the quotation and the original exemplar are then passed to " { $link like } " so that the output sequence is the exemplar's type." } ;
+
+HELP: push-either
+{ $values
+ { "elt" object } { "quot" quotation } { "accum1" vector } { "accum2" vector } }
+{ $description "Pushes the input object onto one of the accumualators; the first if the quotation yields true, the second if false." } ;
+
+HELP: sequence-hashcode
+{ $values
+ { "n" integer } { "seq" sequence }
+ { "x" integer } }
+{ $description "Iterates over a sequence, computes a hashcode with " { $link hashcode* } " for each element, and combines them using " { $link sequence-hashcode-step } "." } ;
+
+HELP: sequence-hashcode-step
+{ $values
+ { "oldhash" integer } { "newpart" integer }
+ { "newhash" integer } }
+{ $description "An implementation word that computes a running hashcode of a sequence using some bit-twiddling. The resulting hashcode is always a fixnum." } ;
+
+HELP: short
+{ $values
+ { "seq" sequence } { "n" integer }
+ { "seq" sequence } { "n'" integer } }
+{ $description "Returns the input sequence and its length or " { $snippet "n" } ", whichever is less." }
+{ $examples { $example "USING: sequences kernel prettyprint ;"
+ "\"abcd\" 3 short [ . ] bi@"
+ "\"abcd\"\n3"
+} } ;
+
+HELP: shorten
+{ $values
+ { "n" integer } { "seq" sequence } }
+{ $description "Shortens a " { $link "growable" } " sequence to by " { $snippet "n" } " elements long." }
+{ $examples { $example "USING: sequences prettyprint kernel ;"
+ "V{ 1 2 3 4 5 } 3 over shorten ."
+ "V{ 1 2 3 }"
+} } ;
+
+ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
+"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
+$nl
+"These words assume the sequence index given is within bounds; if it is not, memory corruption can occur. Great care must be exercised when using these words. First, make sure the code in question is actually a bottleneck; next, try improving the algorithm first. If all else fails, then the unsafe sequence words can be used."
+$nl
+"There is a very important invariant these word must preserve: if at some point in time, the length of a sequence was " { $snippet "n" } ", then any future lookups of elements with indices below " { $snippet "n" } " must not crash the VM, even if the sequence length is now less than " { $snippet "n" } ". For example, vectors preserve this invariant by never shrinking the underlying storage, only growing it as necessary."
+$nl
+"The justification for this is that the VM should not crash if a resizable sequence is resized during the execution of an iteration combinator."
+$nl
+"Indeed, iteration combinators are the primary use-case for these words; if the iteration index is already guarded by a loop test which ensures it is within bounds, then additional bounds checks are redundant. For example, see the implementation of " { $link each } "." ;
+
+ARTICLE: "sequence-protocol" "Sequence protocol"
+"All sequences must be instances of a mixin class:"
+{ $subsection sequence }
+{ $subsection sequence? }
+"All sequences must know their length:"
+{ $subsection length }
+"At least one of the following two generic words must have a method for accessing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
+{ $subsection nth }
+{ $subsection nth-unsafe }
+"Note that sequences are always indexed starting from zero."
+$nl
+"At least one of the following two generic words must have a method for storing elements; the " { $link sequence } " mixin has default definitions which are mutually recursive:"
+{ $subsection set-nth }
+{ $subsection set-nth-unsafe }
+"Note that even if the sequence is immutable, at least one of the generic words must be specialized, otherwise calling them will result in an infinite recursion. There is a standard word which throws an error indicating a sequence is immutable:"
+{ $subsection immutable }
+"The following two generic words are optional, as not all sequences are resizable:"
+{ $subsection set-length }
+{ $subsection lengthen }
+"An optional generic word for creating sequences of the same class as a given sequence:"
+{ $subsection like }
+"Optional generic words for optimization purposes:"
+{ $subsection new-sequence }
+{ $subsection new-resizable }
+{ $see-also "sequences-unsafe" } ;
+
+ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol"
+"Virtual sequences must know their length:"
+{ $subsection length }
+"The underlying sequence to look up a value in:"
+{ $subsection virtual-seq }
+"The index of the value in the underlying sequence:"
+{ $subsection virtual@ } ;
+
+ARTICLE: "virtual-sequences" "Virtual sequences"
+"Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "virtual-sequences-protocol" } "."
+{ $subsection "virtual-sequences-protocol" } ;
+
+ARTICLE: "sequences-integers" "Integer sequences and counted loops"
+"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
+$nl
+"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
+{ $example "3 [ . ] each" "0\n1\n2" }
+"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
+$nl
+"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
+
+ARTICLE: "sequences-access" "Accessing sequence elements"
+{ $subsection ?nth }
+"Concise way of extracting one of the first four elements:"
+{ $subsection first }
+{ $subsection second }
+{ $subsection third }
+{ $subsection fourth }
+"Unpacking sequences:"
+{ $subsection first2 }
+{ $subsection first3 }
+{ $subsection first4 }
+{ $see-also nth peek } ;
+
+ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
+"Adding elements:"
+{ $subsection prefix }
+{ $subsection suffix }
+"Removing elements:"
+{ $subsection remove }
+{ $subsection remove-nth } ;
+
+ARTICLE: "sequences-reshape" "Reshaping sequences"
+"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
+{ $subsection repetition }
+{ $subsection <repetition> }
+"Reversing a sequence:"
+{ $subsection reverse }
+"A " { $emphasis "reversal" } " presents a reversed view of an underlying sequence:"
+{ $subsection reversed }
+{ $subsection <reversed> }
+"Transposing a matrix:"
+{ $subsection flip } ;
+
+ARTICLE: "sequences-appending" "Appending sequences"
+{ $subsection append }
+{ $subsection prepend }
+{ $subsection 3append }
+{ $subsection concat }
+{ $subsection join }
+"A pair of words useful for aligning strings:"
+{ $subsection pad-left }
+{ $subsection pad-right } ;
+
+ARTICLE: "sequences-slices" "Subsequences and slices"
+"Extracting a subsequence:"
+{ $subsection subseq }
+{ $subsection head }
+{ $subsection tail }
+{ $subsection head* }
+{ $subsection tail* }
+"Removing the first or last element:"
+{ $subsection rest }
+{ $subsection but-last }
+"Taking a sequence apart into a head and a tail:"
+{ $subsection unclip }
+{ $subsection unclip-last }
+{ $subsection cut }
+{ $subsection cut* }
+"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
+{ $subsection slice }
+{ $subsection slice? }
+"Extracting a slice:"
+{ $subsection <slice> }
+{ $subsection head-slice }
+{ $subsection tail-slice }
+{ $subsection head-slice* }
+{ $subsection tail-slice* }
+"Removing the first or last element:"
+{ $subsection rest-slice }
+{ $subsection but-last-slice }
+"Taking a sequence apart into a head and a tail:"
+{ $subsection unclip-slice }
+{ $subsection unclip-last-slice }
+{ $subsection cut-slice }
+"A utility for words which use slices as iterators:"
+{ $subsection <flat-slice> } ;
+
+ARTICLE: "sequences-combinators" "Sequence combinators"
+"Iteration:"
+{ $subsection each }
+{ $subsection each-index }
+{ $subsection reduce }
+{ $subsection interleave }
+{ $subsection replicate }
+{ $subsection replicate-as }
+"Mapping:"
+{ $subsection map }
+{ $subsection map-as }
+{ $subsection map-index }
+{ $subsection accumulate }
+{ $subsection produce }
+"Filtering:"
+{ $subsection push-if }
+{ $subsection filter }
+"Testing if a sequence contains elements satisfying a predicate:"
+{ $subsection contains? }
+{ $subsection all? }
+"Testing how elements are related:"
+{ $subsection monotonic? }
+{ $subsection "sequence-2combinators" } ;
+
+ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
+"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
+{ $subsection 2each }
+{ $subsection 2reduce }
+{ $subsection 2map }
+{ $subsection 2map-as }
+{ $subsection 2all? } ;
+
+ARTICLE: "sequences-tests" "Testing sequences"
+"Testing for an empty sequence:"
+{ $subsection empty? }
+"Testing indices:"
+{ $subsection bounds-check? }
+"Testing if a sequence contains an object:"
+{ $subsection member? }
+{ $subsection memq? }
+"Testing if a sequence contains a subsequence:"
+{ $subsection head? }
+{ $subsection tail? }
+{ $subsection subseq? }
+"Testing how elements are related:"
+{ $subsection all-eq? }
+{ $subsection all-equal? } ;
+
+ARTICLE: "sequences-search" "Searching sequences"
+"Finding the index of an element:"
+{ $subsection index }
+{ $subsection index-from }
+{ $subsection last-index }
+{ $subsection last-index-from }
+"Finding the start of a subsequence:"
+{ $subsection start }
+{ $subsection start* }
+"Finding the index of an element satisfying a predicate:"
+{ $subsection find }
+{ $subsection find-from }
+{ $subsection find-last }
+{ $subsection find-last-from } ;
+
+ARTICLE: "sequences-trimming" "Trimming sequences"
+"Trimming words:"
+{ $subsection trim }
+{ $subsection trim-left }
+{ $subsection trim-right }
+"Potentially more efficient trim:"
+{ $subsection trim-slice }
+{ $subsection trim-left-slice }
+{ $subsection trim-right-slice } ;
+
+ARTICLE: "sequences-destructive" "Destructive operations"
+"These words modify their input, instead of creating a new sequence."
+$nl
+"In-place variant of " { $link reverse } ":"
+{ $subsection reverse-here }
+"In-place variant of " { $link append } ":"
+{ $subsection push-all }
+"In-place variant of " { $link remove } ":"
+{ $subsection delete }
+"In-place variant of " { $link map } ":"
+{ $subsection change-each }
+"Changing elements:"
+{ $subsection change-nth }
+{ $subsection cache-nth }
+"Deleting elements:"
+{ $subsection delete-nth }
+{ $subsection delete-slice }
+{ $subsection delete-all }
+"Other destructive words:"
+{ $subsection move }
+{ $subsection exchange }
+{ $subsection copy }
+{ $subsection replace-slice }
+{ $see-also set-nth push pop "sequences-stacks" } ;
+
+ARTICLE: "sequences-stacks" "Treating sequences as stacks"
+"The classical stack operations, modifying a sequence in place:"
+{ $subsection peek }
+{ $subsection push }
+{ $subsection pop }
+{ $subsection pop* }
+{ $see-also empty? } ;
+
+ARTICLE: "sequences-comparing" "Comparing sequences"
+"Element equality testing:"
+{ $subsection sequence= }
+{ $subsection mismatch }
+{ $subsection drop-prefix }
+"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
+
+ARTICLE: "sequences-f" "The f object as a sequence"
+"The " { $link f } " object supports the sequence protocol in a trivial way. It responds with a length of zero and throws an out of bounds error when an attempt is made to access elements." ;
+
+ARTICLE: "sequences" "Sequence operations"
+"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
+$nl
+"Sequences implement a protocol:"
+{ $subsection "sequence-protocol" }
+{ $subsection "sequences-f" }
+{ $subsection "sequences-integers" }
+"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "."
+{ $subsection "sequences-access" }
+{ $subsection "sequences-combinators" }
+{ $subsection "sequences-add-remove" }
+{ $subsection "sequences-appending" }
+{ $subsection "sequences-slices" }
+{ $subsection "sequences-reshape" }
+{ $subsection "sequences-tests" }
+{ $subsection "sequences-search" }
+{ $subsection "sequences-comparing" }
+{ $subsection "sequences-split" }
+{ $subsection "grouping" }
+{ $subsection "sequences-destructive" }
+{ $subsection "sequences-stacks" }
+{ $subsection "sequences-sorting" }
+{ $subsection "binary-search" }
+{ $subsection "sets" }
+{ $subsection "sequences-trimming" }
+"For inner loops:"
+{ $subsection "sequences-unsafe" } ;
+
+ABOUT: "sequences"
: push-all ( src dest -- ) [ length ] [ copy ] bi ;
+<PRIVATE
+
: ((append)) ( seq1 seq2 accum -- accum )
[ >r over length r> copy ]
[ 0 swap copy ]
[ ((append)) ] bi
] new-like ; inline
+PRIVATE>
+
: append ( seq1 seq2 -- newseq ) over (append) ;
: prepend ( seq1 seq2 -- newseq ) swap append ; inline
: 2map ( seq1 seq2 quot -- newseq )
pick 2map-as ; inline
-: 2change-each ( seq1 seq2 quot -- newseq )
+: 2change-each ( seq1 seq2 quot -- )
pick 2map-into ; inline
: 2all? ( seq1 seq2 quot -- ? )
: accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
+: produce-as ( pred quot tail exemplar -- seq )
+ >r swap accumulator >r swap while r> r> like ; inline
+
: produce ( pred quot tail -- seq )
- swap accumulator >r swap while r> { } like ; inline
+ { } produce-as ; inline
: follow ( obj quot -- seq )
>r [ dup ] r> [ keep ] curry [ ] produce nip ; inline
2over number=
[ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
+<PRIVATE
+
: (delete) ( elt store scan seq -- elt store scan seq )
2dup length < [
3dup move
[ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
] when ;
+PRIVATE>
+
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
: prefix ( seq elt -- newseq )
: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
+<PRIVATE
+
: move-backward ( shift from to seq -- )
2over number= [
2drop 2drop
>r >r over - r> r> move-backward
] if ;
+PRIVATE>
+
: open-slice ( shift from seq -- )
pick zero? [
3drop
first like
] if-empty ;
+<PRIVATE
+
: joined-length ( seq glue -- n )
>r dup sum-lengths swap length 1 [-] r> length * + ;
+PRIVATE>
+
: join ( seq glue -- newseq )
[
2dup joined-length over new-resizable spin
: pad-right ( seq n elt -- padded )
[ append ] padding ;
-: shorter? ( seq1 seq2 -- ? ) >r length r> length < ;
+: shorter? ( seq1 seq2 -- ? ) [ length ] bi@ < ;
: head? ( seq begin -- ? )
2dup shorter? [
tuck length tail-slice* sequence=
] if ;
-: cut-slice ( seq n -- before after )
+: cut-slice ( seq n -- before-slice after-slice )
[ head-slice ] [ tail-slice ] 2bi ;
: insert-nth ( elt n seq -- seq' )
: midpoint@ ( seq -- n ) length 2/ ; inline
-: halves ( seq -- first second )
+: halves ( seq -- first-slice second-slice )
dup midpoint@ cut-slice ;
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
: unclip-last ( seq -- butlast last )
[ but-last ] [ peek ] bi ;
-: unclip-slice ( seq -- rest first )
+: unclip-slice ( seq -- rest-slice first )
[ rest-slice ] [ first ] bi ; inline
-: 2unclip-slice ( seq1 seq2 -- seq1' seq2' elt1 elt2 )
+: 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
[ unclip-slice ] bi@ swapd ; inline
: map-reduce ( seq map-quot reduce-quot -- result )
[ [ 2unclip-slice ] dip [ call ] keep ] dip
compose 2reduce ; inline
-: unclip-last-slice ( seq -- butlast last )
+: unclip-last-slice ( seq -- butlast-slice last )
[ but-last-slice ] [ peek ] bi ; inline
: <flat-slice> ( seq -- slice )
-USING: kernel help.markup help.syntax sequences ;
+USING: kernel help.markup help.syntax sequences quotations ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
HELP: set=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;
+
+HELP: gather
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "newseq" sequence } }
+{ $description "Maps a quotation onto a sequence, concatenates the results of the mapping, and removes duplicates." } ;
"Since strings are sequences, basic string manipulation can be performed using sequence operations (" { $link "sequences" } "). More advanced functionality can be found in other vocabularies, including but not limited to:"
{ $list
{ { $vocab-link "ascii" } " - traditional ASCII character classes" }
- { { $vocab-link "unicode" } " - Unicode 5.0-aware character classes, case conversion, word breaks, ..." }
+ { { $vocab-link "unicode.categories" } " - Unicode character classes" }
+ { { $vocab-link "unicode.case" } " - Unicode case conversion" }
{ { $vocab-link "regexp" } " - regular expressions" }
{ { $vocab-link "peg" } " - parser expression grammars" }
} ;
HELP: INTERSECTION:
{ $syntax "INTERSECTION: class participants... ;" }
{ $values { "class" "a new class word to define" } { "participants" "a list of class words separated by whitespace" } }
-{ $description "Defines an intersection class. An object is an instance of a union class if it is an instance of all of its participants." } ;
+{ $description "Defines an intersection class. An object is an instance of an intersection class if it is an instance of all of its participants." } ;
HELP: MIXIN:
{ $syntax "MIXIN: class" }
} ;
HELP: initial:
-{ $syntax "TUPLE: ... { \"slot\" initial: value } ... ;" }
+{ $syntax "TUPLE: ... { slot initial: value } ... ;" }
{ $values { "slot" "a slot name" } { "value" "any literal" } }
{ $description "Specifies an initial value for a tuple slot." } ;
HELP: read-only
-{ $syntax "TUPLE: ... { \"slot\" read-only } ... ;" }
+{ $syntax "TUPLE: ... { slot read-only } ... ;" }
{ $values { "slot" "a slot name" } }
{ $description "Defines a tuple slot to be read-only. If a tuple has read-only slots, instances of the tuple should only be created by calling " { $link boa } ", instead of " { $link new } ". Using " { $link boa } " is the only way to set the value of a read-only slot." } ;
PRIVATE>
+: image ( -- path ) \ image get-global ;
+
+: vm ( -- path ) \ vm get-global ;
+
[
8 getenv string>cpu \ cpu set-global
9 getenv string>os \ os set-global
] "system" add-init-hook
-: image ( -- path ) 13 getenv ;
-
-: vm ( -- path ) 14 getenv ;
-
: embedded? ( -- ? ) 15 getenv ;
: os-envs ( -- assoc )
--- /dev/null
+>ONE Homo sapiens alu
+GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA
+TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT
+AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG
+GCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCG
+CCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGT
+GGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCA
+GGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAA
+TTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAG
+AATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCA
+GCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGT
+AATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACC
+AGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTG
+GTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACC
+CGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAG
+AGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTT
+TGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACA
+TGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCT
+GTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGG
+TTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGT
+CTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGG
+CGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCG
+TCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTA
+CTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCG
+AGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCG
+GGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC
+TGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAA
+TACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGA
+GGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACT
+GCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTC
+ACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGT
+TCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGC
+CGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCG
+CTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTG
+GGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCC
+CAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCT
+GGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGC
+GCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGA
+GGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGA
+GACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGA
+GGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTG
+AAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAAT
+CCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCA
+GTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAA
+AAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGC
+GGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCT
+ACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGG
+GAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATC
+GCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGC
+GGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG
+TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAA
+AAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAG
+GAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACT
+CCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCC
+TGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAG
+ACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGC
+GTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGA
+ACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGA
+CAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCA
+CTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCA
+ACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCG
+CCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGG
+AGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTC
+CGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCG
+AGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACC
+CCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAG
+CTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAG
+CCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGG
+CCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATC
+ACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAA
+AAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGC
+TGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCC
+ACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGG
+CTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGG
+AGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATT
+AGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAA
+TCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGC
+CTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAA
+TCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAG
+CCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGT
+GGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCG
+GGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAG
+CGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTG
+GGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATG
+GTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGT
+AATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTT
+GCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCT
+CAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCG
+GGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTC
+TCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACT
+CGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAG
+ATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGG
+CGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTG
+AGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATA
+CAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGG
+CAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGC
+ACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCAC
+GCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTC
+GAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCG
+GGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCT
+TGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGG
+CGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCA
+GCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGG
+CCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGC
+GCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGG
+CGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGA
+CTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGG
+CCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAA
+ACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCC
+CAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGT
+GAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAA
+AGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGG
+ATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTAC
+TAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGA
+GGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGC
+GCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGG
+TGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTC
+AGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAA
+ATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGA
+GAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC
+AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTG
+TAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGAC
+CAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGT
+GGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAAC
+CCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACA
+GAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACT
+TTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAAC
+ATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCC
+TGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAG
+GTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCG
+TCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAG
+GCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCC
+GTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCT
+ACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCC
+GAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCC
+GGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCAC
+CTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAA
+ATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTG
+AGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCAC
+TGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCT
+CACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAG
+TTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAG
+CCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATC
+GCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCT
+GGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATC
+CCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCC
+TGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGG
+CGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG
+AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCG
+AGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGG
+AGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGT
+GAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAA
+TCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGC
+AGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCA
+AAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGG
+CGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTC
+TACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCG
+GGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGAT
+CGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCG
+CGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAG
+GTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACA
+AAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCA
+GGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCAC
+TCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGC
+CTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGA
+GACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG
+CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTG
+AACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCG
+ACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGC
+ACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCC
+AACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGC
+GCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCG
+GAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACT
+CCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCC
+GAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAAC
+CCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA
+GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGA
+GCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAG
+GCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGAT
+CACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTA
+AAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGG
+CTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGC
+CACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTG
+GCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAG
+GAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAAT
+TAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGA
+ATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAG
+CCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTA
+ATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCA
+GCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGG
+TGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCC
+GGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGA
+GCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTT
+GGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACAT
+GGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTG
+TAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGT
+TGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTC
+TCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGC
+GGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGT
+CTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTAC
+TCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGA
+GATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGG
+GCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCT
+GAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT
+ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAG
+GCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTG
+CACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCA
+CGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTT
+CGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCC
+GGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGC
+TTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGG
+GCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCC
+AGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTG
+GCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCG
+CGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAG
+GCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAG
+ACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAG
+GCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGA
+AACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATC
+CCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAG
+TGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAA
+AAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCG
+GATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTA
+CTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGG
+AGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCG
+CGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCG
+GTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGT
+CAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAA
+AATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGG
+AGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTC
+CAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCT
+GTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA
+CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCG
+TGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAA
+CCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGAC
+AGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCAC
+TTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAA
+CATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGC
+CTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGA
+GGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCC
+GTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGA
+GGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCC
+CGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGC
+TACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGC
+CGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGC
+CGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCA
+CCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAA
+AATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCT
+GAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCA
+CTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGC
+TCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGA
+GTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTA
+GCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAAT
+CGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCC
+TGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAAT
+CCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGC
+CTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTG
+GCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGG
+GAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGC
+GAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG
+GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGG
+TGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTA
+ATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTG
+CAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTC
+AAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGG
+GCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCT
+CTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTC
+GGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGA
+TCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGC
+GCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGA
+GGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATAC
+AAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGC
+AGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCA
+CTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACG
+CCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCG
+AGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGG
+GCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTT
+GAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGC
+GACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAG
+CACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGC
+CAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCG
+CGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC
+GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGAC
+TCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGC
+CGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAA
+CCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCC
+AGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTG
+AGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA
+GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA
+TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT
+AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG
+GCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCG
+CCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGT
+GGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCA
+GGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAA
+TTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAG
+AATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCA
+GCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGT
+AATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACC
+AGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTG
+GTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACC
+CGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAG
+AGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTT
+TGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACA
+TGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCT
+GTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGG
+TTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGT
+CTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGG
+CGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCG
+TCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTA
+CTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCG
+AGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCG
+GGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC
+TGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAA
+TACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGA
+GGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACT
+GCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTC
+ACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGT
+TCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGC
+CGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCG
+CTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTG
+GGCGACAGAGCGAGACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCC
+CAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCT
+GGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGC
+GCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGA
+GGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGA
+GACTCCGTCTCAAAAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGA
+GGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTG
+AAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAAT
+CCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCA
+GTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAA
+AAAGGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGC
+GGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCT
+ACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGG
+GAGGCTGAGGCAGGAGAATC
+>TWO IUB ambiguity codes
+cttBtatcatatgctaKggNcataaaSatgtaaaDcDRtBggDtctttataattcBgtcg
+tactDtDagcctatttSVHtHttKtgtHMaSattgWaHKHttttagacatWatgtRgaaa
+NtactMcSMtYtcMgRtacttctWBacgaaatatagScDtttgaagacacatagtVgYgt
+cattHWtMMWcStgttaggKtSgaYaaccWStcgBttgcgaMttBYatcWtgacaYcaga
+gtaBDtRacttttcWatMttDBcatWtatcttactaBgaYtcttgttttttttYaaScYa
+HgtgttNtSatcMtcVaaaStccRcctDaataataStcYtRDSaMtDttgttSagtRRca
+tttHatSttMtWgtcgtatSSagactYaaattcaMtWatttaSgYttaRgKaRtccactt
+tattRggaMcDaWaWagttttgacatgttctacaaaRaatataataaMttcgDacgaSSt
+acaStYRctVaNMtMgtaggcKatcttttattaaaaagVWaHKYagtttttatttaacct
+tacgtVtcVaattVMBcttaMtttaStgacttagattWWacVtgWYagWVRctDattBYt
+gtttaagaagattattgacVatMaacattVctgtBSgaVtgWWggaKHaatKWcBScSWa
+accRVacacaaactaccScattRatatKVtactatatttHttaagtttSKtRtacaaagt
+RDttcaaaaWgcacatWaDgtDKacgaacaattacaRNWaatHtttStgttattaaMtgt
+tgDcgtMgcatBtgcttcgcgaDWgagctgcgaggggVtaaScNatttacttaatgacag
+cccccacatYScaMgtaggtYaNgttctgaMaacNaMRaacaaacaKctacatagYWctg
+ttWaaataaaataRattagHacacaagcgKatacBttRttaagtatttccgatctHSaat
+actcNttMaagtattMtgRtgaMgcataatHcMtaBSaRattagttgatHtMttaaKagg
+YtaaBataSaVatactWtataVWgKgttaaaacagtgcgRatatacatVtHRtVYataSa
+KtWaStVcNKHKttactatccctcatgWHatWaRcttactaggatctataDtDHBttata
+aaaHgtacVtagaYttYaKcctattcttcttaataNDaaggaaaDYgcggctaaWSctBa
+aNtgctggMBaKctaMVKagBaactaWaDaMaccYVtNtaHtVWtKgRtcaaNtYaNacg
+gtttNattgVtttctgtBaWgtaattcaagtcaVWtactNggattctttaYtaaagccgc
+tcttagHVggaYtgtNcDaVagctctctKgacgtatagYcctRYHDtgBattDaaDgccK
+tcHaaStttMcctagtattgcRgWBaVatHaaaataYtgtttagMDMRtaataaggatMt
+ttctWgtNtgtgaaaaMaatatRtttMtDgHHtgtcattttcWattRSHcVagaagtacg
+ggtaKVattKYagactNaatgtttgKMMgYNtcccgSKttctaStatatNVataYHgtNa
+BKRgNacaactgatttcctttaNcgatttctctataScaHtataRagtcRVttacDSDtt
+aRtSatacHgtSKacYagttMHtWataggatgactNtatSaNctataVtttRNKtgRacc
+tttYtatgttactttttcctttaaacatacaHactMacacggtWataMtBVacRaSaatc
+cgtaBVttccagccBcttaRKtgtgcctttttRtgtcagcRttKtaaacKtaaatctcac
+aattgcaNtSBaaccgggttattaaBcKatDagttactcttcattVtttHaaggctKKga
+tacatcBggScagtVcacattttgaHaDSgHatRMaHWggtatatRgccDttcgtatcga
+aacaHtaagttaRatgaVacttagattVKtaaYttaaatcaNatccRttRRaMScNaaaD
+gttVHWgtcHaaHgacVaWtgttScactaagSgttatcttagggDtaccagWattWtRtg
+ttHWHacgattBtgVcaYatcggttgagKcWtKKcaVtgaYgWctgYggVctgtHgaNcV
+taBtWaaYatcDRaaRtSctgaHaYRttagatMatgcatttNattaDttaattgttctaa
+ccctcccctagaWBtttHtBccttagaVaatMcBHagaVcWcagBVttcBtaYMccagat
+gaaaaHctctaacgttagNWRtcggattNatcRaNHttcagtKttttgWatWttcSaNgg
+gaWtactKKMaacatKatacNattgctWtatctaVgagctatgtRaHtYcWcttagccaa
+tYttWttaWSSttaHcaaaaagVacVgtaVaRMgattaVcDactttcHHggHRtgNcctt
+tYatcatKgctcctctatVcaaaaKaaaagtatatctgMtWtaaaacaStttMtcgactt
+taSatcgDataaactaaacaagtaaVctaggaSccaatMVtaaSKNVattttgHccatca
+cBVctgcaVatVttRtactgtVcaattHgtaaattaaattttYtatattaaRSgYtgBag
+aHSBDgtagcacRHtYcBgtcacttacactaYcgctWtattgSHtSatcataaatataHt
+cgtYaaMNgBaatttaRgaMaatatttBtttaaaHHKaatctgatWatYaacttMctctt
+ttVctagctDaaagtaVaKaKRtaacBgtatccaaccactHHaagaagaaggaNaaatBW
+attccgStaMSaMatBttgcatgRSacgttVVtaaDMtcSgVatWcaSatcttttVatag
+ttactttacgatcaccNtaDVgSRcgVcgtgaacgaNtaNatatagtHtMgtHcMtagaa
+attBgtataRaaaacaYKgtRccYtatgaagtaataKgtaaMttgaaRVatgcagaKStc
+tHNaaatctBBtcttaYaBWHgtVtgacagcaRcataWctcaBcYacYgatDgtDHccta
+aagacYRcaggattHaYgtKtaatgcVcaataMYacccatatcacgWDBtgaatcBaata
+cKcttRaRtgatgaBDacggtaattaaYtataStgVHDtDctgactcaaatKtacaatgc
+gYatBtRaDatHaactgtttatatDttttaaaKVccYcaaccNcBcgHaaVcattHctcg
+attaaatBtatgcaaaaatYMctSactHatacgaWacattacMBgHttcgaatVaaaaca
+BatatVtctgaaaaWtctRacgBMaatSgRgtgtcgactatcRtattaScctaStagKga
+DcWgtYtDDWKRgRtHatRtggtcgaHgggcgtattaMgtcagccaBggWVcWctVaaat
+tcgNaatcKWagcNaHtgaaaSaaagctcYctttRVtaaaatNtataaccKtaRgtttaM
+tgtKaBtRtNaggaSattHatatWactcagtgtactaKctatttgRYYatKatgtccgtR
+tttttatttaatatVgKtttgtatgtNtataRatWYNgtRtHggtaaKaYtKSDcatcKg
+taaYatcSRctaVtSMWtVtRWHatttagataDtVggacagVcgKWagBgatBtaaagNc
+aRtagcataBggactaacacRctKgttaatcctHgDgttKHHagttgttaatgHBtatHc
+DaagtVaBaRccctVgtgDtacRHSctaagagcggWYaBtSaKtHBtaaactYacgNKBa
+VYgtaacttagtVttcttaatgtBtatMtMtttaattaatBWccatRtttcatagVgMMt
+agctStKctaMactacDNYgKYHgaWcgaHgagattacVgtttgtRaSttaWaVgataat
+gtgtYtaStattattMtNgWtgttKaccaatagNYttattcgtatHcWtctaaaNVYKKt
+tWtggcDtcgaagtNcagatacgcattaagaccWctgcagcttggNSgaNcHggatgtVt
+catNtRaaBNcHVagagaaBtaaSggDaatWaatRccaVgggStctDaacataKttKatt
+tggacYtattcSatcttagcaatgaVBMcttDattctYaaRgatgcattttNgVHtKcYR
+aatRKctgtaaacRatVSagctgtWacBtKVatctgttttKcgtctaaDcaagtatcSat
+aWVgcKKataWaYttcccSaatgaaaacccWgcRctWatNcWtBRttYaattataaNgac
+acaatagtttVNtataNaYtaatRaVWKtBatKagtaatataDaNaaaaataMtaagaaS
+tccBcaatNgaataWtHaNactgtcDtRcYaaVaaaaaDgtttRatctatgHtgttKtga
+aNSgatactttcgagWaaatctKaaDaRttgtggKKagcDgataaattgSaacWaVtaNM
+acKtcaDaaatttctRaaVcagNacaScRBatatctRatcctaNatWgRtcDcSaWSgtt
+RtKaRtMtKaatgttBHcYaaBtgatSgaSWaScMgatNtctcctatttctYtatMatMt
+RRtSaattaMtagaaaaStcgVgRttSVaScagtgDtttatcatcatacRcatatDctta
+tcatVRtttataaHtattcYtcaaaatactttgVctagtaaYttagatagtSYacKaaac
+gaaKtaaatagataatSatatgaaatSgKtaatVtttatcctgKHaatHattagaaccgt
+YaaHactRcggSBNgtgctaaBagBttgtRttaaattYtVRaaaattgtaatVatttctc
+ttcatgBcVgtgKgaHaaatattYatagWacNctgaaMcgaattStagWaSgtaaKagtt
+ttaagaDgatKcctgtaHtcatggKttVDatcaaggtYcgccagNgtgcVttttagagat
+gctaccacggggtNttttaSHaNtatNcctcatSaaVgtactgBHtagcaYggYVKNgta
+KBcRttgaWatgaatVtagtcgattYgatgtaatttacDacSctgctaaaStttaWMagD
+aaatcaVYctccgggcgaVtaaWtStaKMgDtttcaaMtVgBaatccagNaaatcYRMBg
+gttWtaaScKttMWtYataRaDBMaDataatHBcacDaaKDactaMgagttDattaHatH
+taYatDtattDcRNStgaatattSDttggtattaaNSYacttcDMgYgBatWtaMagact
+VWttctttgYMaYaacRgHWaattgRtaagcattctMKVStatactacHVtatgatcBtV
+NataaBttYtSttacKgggWgYDtgaVtYgatDaacattYgatggtRDaVDttNactaSa
+MtgNttaacaaSaBStcDctaccacagacgcaHatMataWKYtaYattMcaMtgSttDag
+cHacgatcaHttYaKHggagttccgatYcaatgatRaVRcaagatcagtatggScctata
+ttaNtagcgacgtgKaaWaactSgagtMYtcttccaKtStaacggMtaagNttattatcg
+tctaRcactctctDtaacWYtgaYaSaagaWtNtatttRacatgNaatgttattgWDDcN
+aHcctgaaHacSgaataaRaataMHttatMtgaSDSKatatHHaNtacagtccaYatWtc
+actaactatKDacSaStcggataHgYatagKtaatKagStaNgtatactatggRHacttg
+tattatgtDVagDVaRctacMYattDgtttYgtctatggtKaRSttRccRtaaccttaga
+gRatagSaaMaacgcaNtatgaaatcaRaagataatagatactcHaaYKBctccaagaRa
+BaStNagataggcgaatgaMtagaatgtcaKttaaatgtaWcaBttaatRcggtgNcaca
+aKtttScRtWtgcatagtttWYaagBttDKgcctttatMggNttattBtctagVtacata
+aaYttacacaaRttcYtWttgHcaYYtaMgBaBatctNgcDtNttacgacDcgataaSat
+YaSttWtcctatKaatgcagHaVaacgctgcatDtgttaSataaaaYSNttatagtaNYt
+aDaaaNtggggacttaBggcHgcgtNtaaMcctggtVtaKcgNacNtatVaSWctWtgaW
+cggNaBagctctgaYataMgaagatBSttctatacttgtgtKtaattttRagtDtacata
+tatatgatNHVgBMtKtaKaNttDHaagatactHaccHtcatttaaagttVaMcNgHata
+tKtaNtgYMccttatcaaNagctggacStttcNtggcaVtattactHaSttatgNMVatt
+MMDtMactattattgWMSgtHBttStStgatatRaDaagattttctatMtaaaaaggtac
+taaVttaSacNaatactgMttgacHaHRttgMacaaaatagttaatatWKRgacDgaRta
+tatttattatcYttaWtgtBRtWatgHaaattHataagtVaDtWaVaWtgStcgtMSgaS
+RgMKtaaataVacataatgtaSaatttagtcgaaHtaKaatgcacatcggRaggSKctDc
+agtcSttcccStYtccRtctctYtcaaKcgagtaMttttcRaYDttgttatctaatcata
+NctctgctatcaMatactataggDaHaaSttMtaDtcNatataattctMcStaaBYtaNa
+gatgtaatHagagSttgWHVcttatKaYgDctcttggtgttMcRaVgSgggtagacaata
+aDtaattSaDaNaHaBctattgNtaccaaRgaVtKNtaaYggHtaKKgHcatctWtctDt
+ttctttggSDtNtaStagttataaacaattgcaBaBWggHgcaaaBtYgctaatgaaatW
+cDcttHtcMtWWattBHatcatcaaatctKMagtDNatttWaBtHaaaNgMttaaStagt
+tctctaatDtcRVaYttgttMtRtgtcaSaaYVgSWDRtaatagctcagDgcWWaaaBaa
+RaBctgVgggNgDWStNaNBKcBctaaKtttDcttBaaggBttgaccatgaaaNgttttt
+tttatctatgttataccaaDRaaSagtaVtDtcaWatBtacattaWacttaSgtattggD
+gKaaatScaattacgWcagKHaaccaYcRcaRttaDttRtttHgaHVggcttBaRgtccc
+tDatKaVtKtcRgYtaKttacgtatBtStaagcaattaagaRgBagSaattccSWYttta
+ttVaataNctgHgttaaNBgcVYgtRtcccagWNaaaacaDNaBcaaaaRVtcWMgBagM
+tttattacgDacttBtactatcattggaaatVccggttRttcatagttVYcatYaSHaHc
+ttaaagcNWaHataaaRWtctVtRYtagHtaaaYMataHYtNBctNtKaatattStgaMc
+BtRgctaKtgcScSttDgYatcVtggaaKtaagatWccHccgKYctaNNctacaWctttt
+gcRtgtVcgaKttcMRHgctaHtVaataaDtatgKDcttatBtDttggNtacttttMtga
+acRattaaNagaactcaaaBBVtcDtcgaStaDctgaaaSgttMaDtcgttcaccaaaag
+gWtcKcgSMtcDtatgtttStaaBtatagDcatYatWtaaaBacaKgcaDatgRggaaYc
+taRtccagattDaWtttggacBaVcHtHtaacDacYgtaatataMagaatgHMatcttat
+acgtatttttatattacHactgttataMgStYaattYaccaattgagtcaaattaYtgta
+tcatgMcaDcgggtcttDtKgcatgWRtataatatRacacNRBttcHtBgcRttgtgcgt
+catacMtttBctatctBaatcattMttMYgattaaVYatgDaatVagtattDacaacDMa
+tcMtHcccataagatgBggaccattVWtRtSacatgctcaaggggYtttDtaaNgNtaaB
+atggaatgtctRtaBgBtcNYatatNRtagaacMgagSaSDDSaDcctRagtVWSHtVSR
+ggaacaBVaccgtttaStagaacaMtactccagtttVctaaRaaHttNcttagcaattta
+ttaatRtaaaatctaacDaBttggSagagctacHtaaRWgattcaaBtctRtSHaNtgta
+cattVcaHaNaagtataccacaWtaRtaaVKgMYaWgttaKggKMtKcgWatcaDatYtK
+SttgtacgaccNctSaattcDcatcttcaaaDKttacHtggttHggRRaRcaWacaMtBW
+VHSHgaaMcKattgtaRWttScNattBBatYtaNRgcggaagacHSaattRtttcYgacc
+BRccMacccKgatgaacttcgDgHcaaaaaRtatatDtatYVtttttHgSHaSaatagct
+NYtaHYaVYttattNtttgaaaYtaKttWtctaNtgagaaaNctNDctaaHgttagDcRt
+tatagccBaacgcaRBtRctRtggtaMYYttWtgataatcgaataattattataVaaaaa
+ttacNRVYcaaMacNatRttcKatMctgaagactaattataaYgcKcaSYaatMNctcaa
+cgtgatttttBacNtgatDccaattattKWWcattttatatatgatBcDtaaaagttgaa
+VtaHtaHHtBtataRBgtgDtaataMttRtDgDcttattNtggtctatctaaBcatctaR
+atgNacWtaatgaagtcMNaacNgHttatactaWgcNtaStaRgttaaHacccgaYStac
+aaaatWggaYaWgaattattcMaactcBKaaaRVNcaNRDcYcgaBctKaacaaaaaSgc
+tccYBBHYaVagaatagaaaacagYtctVccaMtcgtttVatcaatttDRtgWctagtac
+RttMctgtDctttcKtWttttataaatgVttgBKtgtKWDaWagMtaaagaaattDVtag
+gttacatcatttatgtcgMHaVcttaBtVRtcgtaYgBRHatttHgaBcKaYWaatcNSc
+tagtaaaaatttacaatcactSWacgtaatgKttWattagttttNaggtctcaagtcact
+attcttctaagKggaataMgtttcataagataaaaatagattatDgcBVHWgaBKttDgc
+atRHaagcaYcRaattattatgtMatatattgHDtcaDtcaaaHctStattaatHaccga
+cNattgatatattttgtgtDtRatagSacaMtcRtcattcccgacacSattgttKaWatt
+NHcaacttccgtttSRtgtctgDcgctcaaMagVtBctBMcMcWtgtaacgactctcttR
+ggRKSttgYtYatDccagttDgaKccacgVatWcataVaaagaataMgtgataaKYaaat
+cHDaacgataYctRtcYatcgcaMgtNttaBttttgatttaRtStgcaacaaaataccVg
+aaDgtVgDcStctatatttattaaaaRKDatagaaagaKaaYYcaYSgKStctccSttac
+agtcNactttDVttagaaagMHttRaNcSaRaMgBttattggtttaRMggatggcKDgWR
+tNaataataWKKacttcKWaaagNaBttaBatMHtccattaacttccccYtcBcYRtaga
+ttaagctaaYBDttaNtgaaaccHcaRMtKtaaHMcNBttaNaNcVcgVttWNtDaBatg
+ataaVtcWKcttRggWatcattgaRagHgaattNtatttctctattaattaatgaDaaMa
+tacgttgggcHaYVaaNaDDttHtcaaHtcVVDgBVagcMacgtgttaaBRNtatRtcag
+taagaggtttaagacaVaaggttaWatctccgtVtaDtcDatttccVatgtacNtttccg
+tHttatKgScBatgtVgHtYcWagcaKtaMYaaHgtaattaSaHcgcagtWNaatNccNN
+YcacgVaagaRacttctcattcccRtgtgtaattagcSttaaStWaMtctNNcSMacatt
+ataaactaDgtatWgtagtttaagaaaattgtagtNagtcaataaatttgatMMYactaa
+tatcggBWDtVcYttcDHtVttatacYaRgaMaacaStaatcRttttVtagaDtcacWat
+ttWtgaaaagaaagNRacDtttStVatBaDNtaactatatcBSMcccaSttccggaMatg
+attaaWatKMaBaBatttgataNctgttKtVaagtcagScgaaaDggaWgtgttttKtWt
+atttHaatgtagttcactaaKMagttSYBtKtaYgaactcagagRtatagtVtatcaaaW
+YagcgNtaDagtacNSaaYDgatBgtcgataacYDtaaactacagWDcYKaagtttatta
+gcatcgagttKcatDaattgattatDtcagRtWSKtcgNtMaaaaacaMttKcaWcaaSV
+MaaaccagMVtaMaDtMaHaBgaacataBBVtaatVYaNSWcSgNtDNaaKacacBttta
+tKtgtttcaaHaMctcagtaacgtcgYtactDcgcctaNgagagcYgatattttaaattt
+ccattttacatttDaaRctattttWctttacgtDatYtttcagacgcaaVttagtaaKaa
+aRtgVtccataBggacttatttgtttaWNtgttVWtaWNVDaattgtatttBaagcBtaa
+BttaaVatcHcaVgacattccNggtcgacKttaaaRtagRtctWagaYggtgMtataatM
+tgaaRttattttgWcttNtDRRgMDKacagaaaaggaaaRStcccagtYccVattaNaaK
+StNWtgacaVtagaagcttSaaDtcacaacgDYacWDYtgtttKatcVtgcMaDaSKStV
+cgtagaaWaKaagtttcHaHgMgMtctataagBtKaaaKKcactggagRRttaagaBaaN
+atVVcgRcKSttDaactagtSttSattgttgaaRYatggttVttaataaHttccaagDtg
+atNWtaagHtgcYtaactRgcaatgMgtgtRaatRaNaacHKtagactactggaatttcg
+ccataacgMctRgatgttaccctaHgtgWaYcactcacYaattcttaBtgacttaaacct
+gYgaWatgBttcttVttcgttWttMcNYgtaaaatctYgMgaaattacNgaHgaacDVVM
+tttggtHtctaaRgtacagacgHtVtaBMNBgattagcttaRcttacaHcRctgttcaaD
+BggttKaacatgKtttYataVaNattccgMcgcgtagtRaVVaattaKaatggttRgaMc
+agtatcWBttNtHagctaatctagaaNaaacaYBctatcgcVctBtgcaaagDgttVtga
+HtactSNYtaaNccatgtgDacgaVtDcgKaRtacDcttgctaagggcagMDagggtBWR
+tttSgccttttttaacgtcHctaVtVDtagatcaNMaVtcVacatHctDWNaataRgcgt
+aVHaggtaaaaSgtttMtattDgBtctgatSgtRagagYtctSaKWaataMgattRKtaa
+catttYcgtaacacattRWtBtcggtaaatMtaaacBatttctKagtcDtttgcBtKYYB
+aKttctVttgttaDtgattttcttccacttgSaaacggaaaNDaattcYNNaWcgaaYat
+tttMgcBtcatRtgtaaagatgaWtgaccaYBHgaatagataVVtHtttVgYBtMctaMt
+cctgaDcYttgtccaaaRNtacagcMctKaaaggatttacatgtttaaWSaYaKttBtag
+DacactagctMtttNaKtctttcNcSattNacttggaacaatDagtattRtgSHaataat
+gccVgacccgatactatccctgtRctttgagaSgatcatatcgDcagWaaHSgctYYWta
+tHttggttctttatVattatcgactaagtgtagcatVgtgHMtttgtttcgttaKattcM
+atttgtttWcaaStNatgtHcaaaDtaagBaKBtRgaBgDtSagtatMtaacYaatYtVc
+KatgtgcaacVaaaatactKcRgtaYtgtNgBBNcKtcttaccttKgaRaYcaNKtactt
+tgagSBtgtRagaNgcaaaNcacagtVtttHWatgttaNatBgtttaatNgVtctgaata
+tcaRtattcttttttttRaaKcRStctcggDgKagattaMaaaKtcaHacttaataataK
+taRgDtKVBttttcgtKaggHHcatgttagHggttNctcgtatKKagVagRaaaggaaBt
+NatttVKcRttaHctaHtcaaatgtaggHccaBataNaNaggttgcWaatctgatYcaaa
+HaatWtaVgaaBttagtaagaKKtaaaKtRHatMaDBtBctagcatWtatttgWttVaaa
+ScMNattRactttgtYtttaaaagtaagtMtaMaSttMBtatgaBtttaKtgaatgagYg
+tNNacMtcNRacMMHcttWtgtRtctttaacaacattattcYaMagBaacYttMatcttK
+cRMtgMNccattaRttNatHaHNaSaaHMacacaVaatacaKaSttHatattMtVatWga
+ttttttaYctttKttHgScWaacgHtttcaVaaMgaacagNatcgttaacaaaaagtaca
+HBNaattgttKtcttVttaaBtctgctacgBgcWtttcaggacacatMgacatcccagcg
+gMgaVKaBattgacttaatgacacacaaaaaatRKaaBctacgtRaDcgtagcVBaacDS
+BHaaaaSacatatacagacRNatcttNaaVtaaaataHattagtaaaaSWccgtatWatg
+gDttaactattgcccatcttHaSgYataBttBaactattBtcHtgatcaataSttaBtat
+KSHYttWggtcYtttBttaataccRgVatStaHaKagaatNtagRMNgtcttYaaSaact
+cagDSgagaaYtMttDtMRVgWKWtgMaKtKaDttttgactatacataatcNtatNaHat
+tVagacgYgatatatttttgtStWaaatctWaMgagaRttRatacgStgattcttaagaD
+taWccaaatRcagcagaaNKagtaaDggcgccBtYtagSBMtactaaataMataBSacRM
+gDgattMMgtcHtcaYDtRaDaacggttDaggcMtttatgttaNctaattaVacgaaMMt
+aatDccSgtattgaRtWWaccaccgagtactMcgVNgctDctaMScatagcgtcaactat
+acRacgHRttgctatttaatgaattataYKttgtaagWgtYttgcHgMtaMattWaWVta
+RgcttgYgttBHtYataSccStBtgtagMgtDtggcVaaSBaatagDttgBgtctttctc
+attttaNagtHKtaMWcYactVcgcgtatMVtttRacVagDaatcttgctBBcRDgcaac
+KttgatSKtYtagBMagaRtcgBattHcBWcaactgatttaatttWDccatttatcgagS
+KaWttataHactaHMttaatHtggaHtHagaatgtKtaaRactgtttMatacgatcaagD
+gatKaDctataMggtHDtggHacctttRtatcttYattttgacttgaaSaataaatYcgB
+aaaaccgNatVBttMacHaKaataagtatKgtcaagactcttaHttcggaattgttDtct
+aaccHttttWaaatgaaatataaaWattccYDtKtaaaacggtgaggWVtctattagtga
+ctattaagtMgtttaagcatttgSgaaatatccHaaggMaaaattttcWtatKctagDtY
+tMcctagagHcactttactatacaaacattaacttaHatcVMYattYgVgtMttaaRtga
+aataaDatcaHgtHHatKcDYaatcttMtNcgatYatgSaMaNtcttKcWataScKggta
+tcttacgcttWaaagNatgMgHtctttNtaacVtgttcMaaRatccggggactcMtttaY
+MtcWRgNctgNccKatcttgYDcMgattNYaRagatHaaHgKctcataRDttacatBatc
+cattgDWttatttaWgtcggagaaaaatacaatacSNtgggtttccttacSMaagBatta
+caMaNcactMttatgaRBacYcYtcaaaWtagctSaacttWgDMHgaggatgBVgcHaDt
+ggaactttggtcNatNgtaKaBcccaNtaagttBaacagtatacDYttcctNgWgcgSMc
+acatStctHatgRcNcgtacacaatRttMggaNKKggataaaSaYcMVcMgtaMaHtgat
+tYMatYcggtcttcctHtcDccgtgRatcattgcgccgatatMaaYaataaYSggatagc
+gcBtNtaaaScaKgttBgagVagttaKagagtatVaactaSacWactSaKatWccaKaaa
+atBKgaaKtDMattttgtaaatcRctMatcaaMagMttDgVatggMaaWgttcgaWatga
+aatttgRtYtattaWHKcRgctacatKttctaccaaHttRatctaYattaaWatVNccat
+NgagtcKttKataStRaatatattcctRWatDctVagttYDgSBaatYgttttgtVaatt
+taatagcagMatRaacttBctattgtMagagattaaactaMatVtHtaaatctRgaaaaa
+aaatttWacaacaYccYDSaattMatgaccKtaBKWBattgtcaagcHKaagttMMtaat
+ttcKcMagNaaKagattggMagaggtaatttYacatcWaaDgatMgKHacMacgcVaaca
+DtaDatatYggttBcgtatgWgaSatttgtagaHYRVacaRtctHaaRtatgaactaata
+tctSSBgggaaHMWtcaagatKgagtDaSatagttgattVRatNtctMtcSaagaSHaat
+aNataataRaaRgattctttaataaagWaRHcYgcatgtWRcttgaaggaMcaataBRaa
+ccagStaaacNtttcaatataYtaatatgHaDgcStcWttaacctaRgtYaRtataKtgM
+ttttatgactaaaatttacYatcccRWtttHRtattaaatgtttatatttgttYaatMca
+RcSVaaDatcgtaYMcatgtagacatgaaattgRtcaaYaaYtRBatKacttataccaNa
+aattVaBtctggacaagKaaYaaatatWtMtatcYaaVNtcgHaactBaagKcHgtctac
+aatWtaDtSgtaHcataHtactgataNctRgttMtDcDttatHtcgtacatcccaggStt
+aBgtcacacWtccNMcNatMVaVgtccDYStatMaccDatggYaRKaaagataRatttHK
+tSaaatDgataaacttaHgttgVBtcttVttHgDacgaKatgtatatNYataactctSat
+atatattgcHRRYttStggaactHgttttYtttaWtatMcttttctatctDtagVHYgMR
+BgtHttcctaatYRttKtaagatggaVRataKDctaMtKBNtMtHNtWtttYcVtattMc
+gRaacMcctNSctcatttaaagDcaHtYccSgatgcaatYaaaaDcttcgtaWtaattct
+cgttttScttggtaatctttYgtctaactKataHacctMctcttacHtKataacacagcN
+RatgKatttttSaaatRYcgDttaMRcgaaattactMtgcgtaagcgttatBtttttaat
+taagtNacatHgttcRgacKcBBtVgatKttcgaBaatactDRgtRtgaNacWtcacYtt
+aaKcgttctHaKttaNaMgWgWaggtctRgaKgWttSttBtDcNtgtttacaaatYcDRt
+gVtgcctattcNtctaaaDMNttttNtggctgagaVctDaacVtWccaagtaacacaNct
+gaScattccDHcVBatcgatgtMtaatBgHaatDctMYgagaatgYWKcctaatNaStHa
+aaKccgHgcgtYaaYtattgtStgtgcaaRtattaKatattagaWVtcaMtBagttatta
+gNaWHcVgcaattttDcMtgtaRHVYtHtctgtaaaaHVtMKacatcgNaatttMatatg
+ttgttactagWYtaRacgataKagYNKcattataNaRtgaacKaYgcaaYYacaNccHat
+MatDcNgtHttRaWttagaaDcaaaaaatagggtKDtStaDaRtaVtHWKNtgtattVct
+SVgRgataDaRaWataBgaagaaKtaataaYgDcaStaNgtaDaaggtattHaRaWMYaY
+aWtggttHYgagVtgtgcttttcaaDKcagVcgttagacNaaWtagtaataDttctggtt
+VcatcataaagtgKaaaNaMtaBBaattaatWaattgctHaVKaSgDaaVKaHtatatat
+HatcatSBagNgHtatcHYMHgttDgtaHtBttWatcgtttaRaattgStKgSKNWKatc
+agDtctcagatttctRtYtBatBgHHtKaWtgYBgacVVWaKtacKcDttKMaKaVcggt
+gttataagaataaHaatattagtataatMHgttYgaRttagtaRtcaaVatacggtcMcg
+agtaaRttacWgactKRYataaaagSattYaWgagatYagKagatgSaagKgttaatMgg
+tataatgttWYttatgagaaacctNVataatHcccKtDctcctaatactggctHggaSag
+gRtKHaWaattcgSatMatttagaggcYtctaMcgctcataSatatgRagacNaaDagga
+VBagaYttKtacNaKgtSYtagttggaWcatcWttaatctatgaVtcgtgtMtatcaYcg
+tRccaaYgDctgcMgtgtWgacWtgataacacgcgctBtgttaKtYDtatDcatcagKaV
+MctaatcttgVcaaRgcRMtDcgattaHttcaNatgaatMtactacVgtRgatggaWttt
+actaaKatgagSaaKggtaNtactVaYtaaKRagaacccacaMtaaMtKtatBcttgtaa
+WBtMctaataaVcDaaYtcRHBtcgttNtaaHatttBNgRStVDattBatVtaagttaYa
+tVattaagaBcacggtSgtVtatttaRattgatgtaHDKgcaatattKtggcctatgaWD
+KRYcggattgRctatNgatacaatMNttctgtcRBYRaaaHctNYattcHtaWcaattct
+BtMKtVgYataatMgYtcagcttMDataVtggRtKtgaatgccNcRttcaMtRgattaac
+attRcagcctHtWMtgtDRagaKaBtgDttYaaaaKatKgatctVaaYaacWcgcatagB
+VtaNtRtYRaggBaaBtgKgttacataagagcatgtRattccacttaccatRaaatgWgD
+aMHaYVgVtaSctatcgKaatatattaDgacccYagtgtaYNaaatKcagtBRgagtcca
+tgKgaaaccBgaagBtgSttWtacgatWHaYatcgatttRaaNRgcaNaKVacaNtDgat
+tgHVaatcDaagcgtatgcNttaDataatcSataaKcaataaHWataBtttatBtcaKtK
+tatagttaDgSaYctacaRatNtaWctSaatatttYaKaKtaccWtatcRagacttaYtt
+VcKgSDcgagaagatccHtaattctSttatggtKYgtMaHagVaBRatttctgtRgtcta
+tgggtaHKgtHacHtSYacgtacacHatacKaaBaVaccaDtatcSaataaHaagagaat
+ScagactataaRttagcaaVcaHataKgDacatWccccaagcaBgagWatctaYttgaaa
+tctVNcYtttWagHcgcgcDcVaaatgttKcHtNtcaatagtgtNRaactttttcaatgg
+WgBcgDtgVgtttctacMtaaataaaRggaaacWaHttaRtNtgctaaRRtVBctYtVta
+tDcattDtgaccYatagatYRKatNYKttNgcctagtaWtgaactaMVaacctgaStttc
+tgaKVtaaVaRKDttVtVctaDNtataaaDtccccaagtWtcgatcactDgYaBcatcct
+MtVtacDaaBtYtMaKNatNtcaNacgDatYcatcgcaRatWBgaacWttKttagYtaat
+tcggttgSWttttDWctttacYtatatWtcatDtMgtBttgRtVDggttaacYtacgtac
+atgaattgaaWcttMStaDgtatattgaDtcRBcattSgaaVBRgagccaaKtttcDgcg
+aSMtatgWattaKttWtgDBMaggBBttBaatWttRtgcNtHcgttttHtKtcWtagHSt
+aacagttgatatBtaWSaWggtaataaMttaKacDaatactcBttcaatatHttcBaaSa
+aatYggtaRtatNtHcaatcaHtagVtgtattataNggaMtcttHtNagctaaaggtaga
+YctMattNaMVNtcKtactBKcaHHcBttaSagaKacataYgctaKaYgttYcgacWVtt
+WtSagcaacatcccHaccKtcttaacgaKttcacKtNtacHtatatRtaaatacactaBt
+ttgaHaRttggttWtatYagcatYDatcggagagcWBataagRtacctataRKgtBgatg
+aDatataSttagBaHtaatNtaDWcWtgtaattacagKttcNtMagtattaNgtctcgtc
+ctcttBaHaKcKccgtRcaaYagSattaagtKataDatatatagtcDtaacaWHcaKttD
+gaaRcgtgYttgtcatatNtatttttatggccHtgDtYHtWgttatYaacaattcaWtat
+NgctcaaaSttRgctaatcaaatNatcgtttaBtNNVtgttataagcaaagattBacgtD
+atttNatttaaaDcBgtaSKgacgtagataatttcHMVNttgttBtDtgtaWKaaRMcKM
+tHtaVtagataWctccNNaSWtVaHatctcMgggDgtNHtDaDttatatVWttgttattt
+aacctttcacaaggaSaDcggttttttatatVtctgVtaacaStDVaKactaMtttaSNa
+gtgaaattaNacttSKctattcctctaSagKcaVttaagNaVcttaVaaRNaHaaHttat
+gtHttgtgatMccaggtaDcgaccgtWgtWMtttaHcRtattgScctatttKtaaccaag
+tYagaHgtWcHaatgccKNRtttagtMYSgaDatctgtgaWDtccMNcgHgcaaacNDaa
+aRaStDWtcaaaaHKtaNBctagBtgtattaactaattttVctagaatggcWSatMaccc
+ttHttaSgSgtgMRcatRVKtatctgaaaccDNatYgaaVHNgatMgHRtacttaaaRta
+tStRtDtatDttYatattHggaBcttHgcgattgaKcKtttcRataMtcgaVttWacatN
+catacctRataDDatVaWNcggttgaHtgtMacVtttaBHtgagVttMaataattatgtt
+cttagtttgtgcDtSatttgBtcaacHattaaBagVWcgcaSYttMgcttacYKtVtatc
+aYaKctgBatgcgggcYcaaaaacgNtctagKBtattatctttKtaVttatagtaYtRag
+NtaYataaVtgaatatcHgcaaRataHtacacatgtaNtgtcgYatWMatttgaactacR
+ctaWtWtatacaatctBatatgYtaagtatgtgtatSttactVatcttYtaBcKgRaSgg
+RaaaaatgcagtaaaWgtaRgcgataatcBaataccgtatttttccatcNHtatWYgatH
+SaaaDHttgctgtccHtggggcctaataatttttctatattYWtcattBtgBRcVttaVM
+RSgctaatMagtYtttaaaaatBRtcBttcaaVtaacagctccSaaSttKNtHtKYcagc
+agaaaccccRtttttaaDcDtaStatccaagcgctHtatcttaDRYgatDHtWcaaaBcW
+gKWHttHataagHacgMNKttMKHccaYcatMVaacgttaKgYcaVaaBtacgcaacttt
+MctaaHaatgtBatgagaSatgtatgSRgHgWaVWgataaatatttccKagVgataattW
+aHNcYggaaatgctHtKtaDtctaaagtMaatVDVactWtSaaWaaMtaHtaSKtcBRaN
+cttStggtBttacNagcatagRgtKtgcgaacaacBcgKaatgataagatgaaaattgta
+ctgcgggtccHHWHaaNacaBttNKtKtcaaBatatgctaHNgtKcDWgtttatNgVDHg
+accaacWctKaaggHttgaRgYaatHcaBacaatgagcaaattactgtaVaaYaDtagat
+tgagNKggtggtgKtWKaatacagDRtatRaMRtgattDggtcaaYRtatttNtagaDtc
+acaaSDctDtataatcgtactaHttatacaatYaacaaHttHatHtgcgatRRttNgcat
+SVtacWWgaaggagtatVMaVaaattScDDKNcaYBYaDatHgtctatBagcaacaagaa
+tgagaaRcataaKNaRtBDatcaaacgcattttttaaBtcSgtacaRggatgtMNaattg
+gatatWtgagtattaaaVctgcaYMtatgatttttYgaHtgtcttaagWBttHttgtctt
+attDtcgtatWtataataSgctaHagcDVcNtaatcaagtaBDaWaDgtttagYctaNcc
+DtaKtaHcttaataacccaRKtacaVaatNgcWRaMgaattatgaBaaagattVYaHMDc
+aDHtcRcgYtcttaaaWaaaVKgatacRtttRRKYgaatacaWVacVcRtatMacaBtac
+tggMataaattttHggNagSctacHgtBagcgtcgtgattNtttgatSaaggMttctttc
+ttNtYNagBtaaacaaatttMgaccttacataattgYtcgacBtVMctgStgMDtagtaR
+ctHtatgttcatatVRNWataDKatWcgaaaaagttaaaagcacgHNacgtaatctttMR
+tgacttttDacctataaacgaaatatgattagaactccSYtaBctttaataacWgaaaYa
+tagatgWttcatKtNgatttttcaagHtaYgaaRaDaagtaggagcttatVtagtctttc
+attaaaatcgKtattaRttacagVaDatgcatVgattgggtctttHVtagKaaRBtaHta
+aggccccaaaaKatggtttaMWgtBtaaacttcactttKHtcgatctccctaYaBacMgt
+cttBaBaNgcgaaacaatctagtHccHtKttcRtRVttccVctttcatacYagMVtMcag
+aMaaacaataBctgYtaatRaaagattaaccatVRatHtaRagcgcaBcgDttStttttc
+VtttaDtKgcaaWaaaaatSccMcVatgtKgtaKgcgatatgtagtSaaaDttatacaaa
+catYaRRcVRHctKtcgacKttaaVctaDaatgttMggRcWaacttttHaDaKaDaBctg
+taggcgtttaHBccatccattcNHtDaYtaataMttacggctNVaacDattgatatttta
+cVttSaattacaaRtataNDgacVtgaacataVRttttaDtcaaacataYDBtttaatBa
+DtttYDaDaMccMttNBttatatgagaaMgaNtattHccNataattcaHagtgaaggDga
+tgtatatatgYatgaStcataaBStWacgtcccataRMaaDattggttaaattcMKtctM
+acaBSactcggaatDDgatDgcWctaacaccgggaVcacWKVacggtaNatatacctMta
+tgatagtgcaKagggVaDtgtaacttggagtcKatatcgMcttRaMagcattaBRaStct
+YSggaHYtacaactMBaagDcaBDRaaacMYacaHaattagcattaaaHgcgctaaggSc
+cKtgaaKtNaBtatDDcKBSaVtgatVYaagVtctSgMctacgttaacWaaattctSgtD
+actaaStaaattgcagBBRVctaatatacctNttMcRggctttMttagacRaHcaBaacV
+KgaataHttttMgYgattcYaNRgttMgcVaaacaVVcDHaatttgKtMYgtatBtVVct
+WgVtatHtacaaHttcacgatagcagtaaNattBatatatttcVgaDagcggttMaagtc
+ScHagaaatgcYNggcgtttttMtStggtRatctacttaaatVVtBacttHNttttaRca
+aatcacagHgagagtMgatcSWaNRacagDtatactaaDKaSRtgattctccatSaaRtt
+aaYctacacNtaRtaactggatgaccYtacactttaattaattgattYgttcagDtNKtt
+agDttaaaaaaaBtttaaNaYWKMBaaaacVcBMtatWtgBatatgaacVtattMtYatM
+NYDKNcKgDttDaVtaaaatgggatttctgtaaatWtctcWgtVVagtcgRgacttcccc
+taDcacagcRcagagtgtWSatgtacatgttaaSttgtaaHcgatgggMagtgaacttat
+RtttaVcaccaWaMgtactaatSSaHtcMgaaYtatcgaaggYgggcgtgaNDtgttMNg
+aNDMtaattcgVttttaacatgVatgtWVMatatcaKgaaattcaBcctccWcttgaaWH
+tWgHtcgNWgaRgctcBgSgaattgcaaHtgattgtgNagtDttHHgBttaaWcaaWagc
+aSaHHtaaaVctRaaMagtaDaatHtDMtcVaWMtagSagcttHSattaacaaagtRacM
+tRtctgttagcMtcaBatVKtKtKacgagaSNatSactgtatatcBctgagVtYactgta
+aattaaaggcYgDHgtaacatSRDatMMccHatKgttaacgactKtgKagtcttcaaHRV
+tccttKgtSataatttacaactggatDNgaacttcaRtVaagDcaWatcBctctHYatHa
+DaaatttagYatSatccaWtttagaaatVaacBatHcatcgtacaatatcgcNYRcaata
+YaRaYtgattVttgaatgaVaactcRcaNStgtgtattMtgaggtNttBaDRcgaaaagc
+tNgBcWaWgtSaDcVtgVaatMKBtttcgtttctaaHctaaagYactgMtatBDtcStga
+ccgtSDattYaataHctgggaYYttcggttaWaatctggtRagWMaDagtaacBccacta
+cgHWMKaatgatWatcctgHcaBaSctVtcMtgtDttacctaVgatYcWaDRaaaaRtag
+atcgaMagtggaRaWctctgMgcWttaagKBRtaaDaaWtctgtaagYMttactaHtaat
+cttcataacggcacBtSgcgttNHtgtHccatgttttaaagtatcgaKtMttVcataYBB
+aKtaMVaVgtattNDSataHcagtWMtaggtaSaaKgttgBtVtttgttatcatKcgHac
+acRtctHatNVagSBgatgHtgaRaSgttRcctaacaaattDNttgacctaaYtBgaaaa
+tagttattactcttttgatgtNNtVtgtatMgtcttRttcatttgatgacacttcHSaaa
+ccaWWDtWagtaRDDVNacVaRatgttBccttaatHtgtaaacStcVNtcacaSRttcYa
+gacagaMMttttgMcNttBcgWBtactgVtaRttctccaaYHBtaaagaBattaYacgat
+ttacatctgtaaMKaRYtttttactaaVatWgctBtttDVttctggcDaHaggDaagtcg
+aWcaagtagtWttHtgKtVataStccaMcWcaagataagatcactctHatgtcYgaKcat
+cagatactaagNSStHcctRRNtattgtccttagttagMVgtatagactaactctVcaat
+MctgtttgtgttgccttatWgtaBVtttctggMcaaKgDWtcgtaaYStgSactatttHg
+atctgKagtagBtVacRaagRtMctatgggcaaaKaaaatacttcHctaRtgtDcttDat
+taggaaatttcYHaRaaBttaatggcacKtgctHVcaDcaaaVDaaaVcgMttgtNagcg
+taDWgtcgttaatDgKgagcSatatcSHtagtagttggtgtHaWtaHKtatagctgtVga
+ttaBVaatgaataagtaatVatSttaHctttKtttgtagttaccttaatcgtagtcctgB
+cgactatttVcMacHaaaggaatgDatggKtaHtgStatattaaSagctWcctccRtata
+BaDYcgttgcNaagaggatRaaaYtaWgNtSMcaatttactaacatttaaWttHtatBat
+tgtcgacaatNgattgcNgtMaaaKaBDattHacttggtRtttaYaacgVactBtaBaKt
+gBttatgVttgtVttcaatcWcNctDBaaBgaDHacBttattNtgtDtatttVSaaacag
+gatgcRatSgtaSaNtgBatagttcHBgcBBaaattaHgtDattatDaKaatBaaYaaMa
+ataaataKtttYtagtBgMatNcatgtttgaNagtgttgtgKaNaSagtttgaSMaYBca
+aaacDStagttVacaaaaactaaWttBaagtctgtgcgtMgtaattctcctacctcaNtt
+taaccaaaaVtBcacataacaccccBcWMtatVtggaatgaWtcaaWaaaaaaaaWtDta
+atatRcctDWtcctaccMtVVatKttaWaaKaaatataaagScHBagaggBaSMtaWaVt
+atattactSaaaKNaactatNatccttgaYctattcaaaVgatttYHcRagattttaSat
+aggttattcVtaaagaKgtattattKtRttNcggcRgtgtgtWYtaacHgKatKgatYta
+cYagDtWcHBDctctgRaYKaYagcactKcacSaRtBttttBHKcMtNtcBatttatttt
+tgSatVgaaagaWtcDtagDatatgMacaacRgatatatgtttgtKtNRaatatNatgYc
+aHtgHataacKtgagtagtaacYttaNccaaatHcacaacaVDtagtaYtccagcattNt
+acKtBtactaaagaBatVtKaaHBctgStgtBgtatgaSNtgDataaccctgtagcaBgt
+gatcttaDataStgaMaccaSBBgWagtacKcgattgaDgNNaaaacacagtSatBacKD
+gcgtataBKcatacactaSaatYtYcDaactHttcatRtttaatcaattataRtttgtaa
+gMcgNttcatcBtYBagtNWNMtSHcattcRctttttRWgaKacKttgggagBcgttcgc
+MaWHtaatactgtctctatttataVgtttaBScttttaBMaNaatMacactYtBMggtHa
+cMagtaRtctgcatttaHtcaaaatttgagKtgNtactBacaHtcgtatttctMaSRagc
+agttaatgtNtaaattgagagWcKtaNttagVtacgatttgaatttcgRtgtWcVatcgt
+taaDVctgtttBWgaccagaaagtcSgtVtatagaBccttttcctaaattgHtatcggRa
+ttttcaaggcYSKaagWaWtRactaaaacccBatMtttBaatYtaagaactSttcgaaSc
+aatagtattgaccaagtgttttctaacatgtttNVaatcaaagagaaaNattaaRtttta
+VaaaccgcaggNMtatattVctcaagaggaacgBgtttaacaagttcKcYaatatactaa
+ccBaaaSggttcNtattctagttRtBacgScVctcaatttaatYtaaaaaaatgSaatga
+tagaMBRatgRcMcgttgaWHtcaVYgaatYtaatctttYttatRaWtctgBtDcgatNa
+tcKaBaDgatgtaNatWKctccgatattaacattNaaacDatgBgttctgtDtaaaMggt
+gaBaSHataacgccSctaBtttaRBtcNHcDatcDcctagagtcRtaBgWttDRVHagat
+tYatgtatcWtaHtttYcattWtaaagtctNgtStggRNcgcggagSSaaagaaaatYcH
+DtcgctttaatgYcKBVSgtattRaYBaDaaatBgtatgaHtaaRaRgcaSWNtagatHa
+acttNctBtcaccatctMcatattccaSatttgcgaDagDgtatYtaaaVDtaagtttWV
+aagtagYatRttaagDcNgacKBcScagHtattatcDaDactaaaaaYgHttBcgaDttg
+gataaaKSRcBMaBcgaBSttcWtgNBatRaccgattcatttataacggHVtaattcaca
+agagVttaaRaatVVRKcgWtVgacctgDgYaaHaWtctttcacMagggatVgactagMa
+aataKaaNWagKatagNaaWtaaaatttgaattttatttgctaaVgaHatBatcaaBWcB
+gttcMatcgBaaNgttcgSNaggSaRtttgHtRtattaNttcDcatSaVttttcgaaaaa
+ttgHatctaRaggSaNatMDaaatDcacgattttagaHgHaWtYgattaatHNSttatMS
+gggNtcKtYatRggtttgtMWVtttaYtagcagBagHaYagttatatggtBacYcattaR
+SataBatMtttaaatctHcaaaSaaaagttNSaaWcWRccRtKaagtBWtcaaattSttM
+tattggaaaccttaacgttBtWatttatatWcDaatagattcctScacctaagggRaaYt
+aNaatgVtBcttaaBaacaMVaaattatStYgRcctgtactatcMcVKatttcgSgatRH
+MaaaHtagtaaHtVgcaaataatatcgKKtgccaatBNgaaWcVttgagttaKatagttc
+aggKDatDtattgaKaVcaKtaataDataataHSaHcattagttaatRVYcNaHtaRcaa
+ggtNHcgtcaaccaBaaagYtHWaaaRcKgaYaaDttgcWYtataRgaatatgtYtgcKt
+aNttWacatYHctRaDtYtattcBttttatcSataYaYgttWaRagcacHMgtttHtYtt
+YaatcggtatStttcgtRSattaaDaKMaatatactaNBaWgctacacYtgaYVgtgHta
+aaRaaRgHtagtWattataaaSDaaWtgMattatcgaaaagtaYRSaWtSgNtBgagcRY
+aMDtactaacttaWgtatctagacaagNtattHggataatYttYatcataDcgHgttBtt
+ctttVttgccgaaWtaaaacgKgtatctaaaaaNtccDtaDatBMaMggaatNKtatBaa
+atVtccRaHtaSacataHattgtttKVYattcataVaattWtcgtgMttcttKtgtctaa
+cVtatctatatBRataactcgKatStatattcatHHRttKtccaacgtgggtgRgtgaMt
+attattggctatcgtgacMtRcBDtcttgtactaatRHttttaagatcgVMDStattatY
+BtttDttgtBtNttgRcMtYtgBacHaWaBaatDKctaagtgaaactaatgRaaKgatcc
+aagNaaaatattaggWNtaagtatacttttKcgtcggSYtcttgRctataYcttatataa
+agtatattaatttataVaacacaDHatctatttttKYVatHRactttaBHccaWagtact
+BtcacgaVgcgttRtttttttSVgtSagtBaaattctgaHgactcttgMcattttagVta
+agaattHctHtcaDaaNtaacRggWatagttcgtSttgaDatcNgNagctagDgatcNtt
+KgttgtaDtctttRaaYStRatDtgMggactSttaDtagSaVtBDttgtDgccatcacaM
+attaaaMtNacaVcgSWcVaaDatcaHaatgaattaMtatccVtctBtaattgtWattat
+BRcWcaatgNNtactWYtDaKttaaatcactcagtRaaRgatggtKgcgccaaHgaggat
+StattYcaNMtcaBttacttatgagDaNtaMgaaWtgtttcttctaHtMNgttatctaWW
+atMtBtaaatagDVatgtBYtatcggcttaagacMRtaHScgatatYgRDtcattatSDa
+HggaaataNgaWSRRaaaBaatagBattaDctttgHWNttacaataaaaaaatacggttt
+gHgVtaHtWMttNtBtctagtMcgKMgHgYtataHaNagWtcaacYattaataYRgtaWK
+gaBctataaccgatttaHaNBRaRaMtccggtNgacMtctcatttgcaattcWgMactta
+caaDaaNtactWatVtttagccttMaatcagVaagtctVaaDaBtattaattaYtNaYtg
+gattaKtaKctYaMtattYgatattataatKtVgDcttatatNBtcgttgtStttttMag
+aggttaHYSttcKgtcKtDNtataagttataagSgttatDtRttattgttttSNggRtca
+aKMNatgaatattgtBWtaMacctgggYgaSgaagYataagattacgagaatBtggtRcV
+HtgYggaDgaYaKagWagctatagacgaaHgtWaNgacttHRatVaWacKYtgRVNgVcS
+gRWctacatcKSactctgWYtBggtataagcttNRttVtgRcaWaaatDMatYattaact
+ttcgaagRatSctgccttgcRKaccHtttSNVagtagHagBagttagaccaRtataBcca
+taatSHatRtcHagacBWatagcaMtacaRtgtgaaBatctKRtScttccaNaatcNgta
+atatWtcaMgactctBtWtaaNactHaaaaRctcgcatggctMcaaNtcagaaaaacaca
+gtggggWttRttagtaagaVctVMtcgaatcttcMaaaHcaHBttcgattatgtcaDagc
+YRtBtYcgacMgtDcagcgaNgttaataatagcagKYYtcgtaBtYctMaRtaRtDagaa
+aacacatgYaBttgattattcgaaNttBctSataaMataWRgaHtttccgtDgaYtatgg
+tDgHKgMtatttVtMtVagttaRatMattRagataaccctKctMtSttgaHagtcStcta
+tttccSagatgttccacgaggYNttHRacgattcDatatDcataaaatBBttatcgaHtN
+HaaatatDNaggctgaNcaaggagttBttMgRagVatBcRtaWgatgBtSgaKtcgHttt
+gaatcaaDaHttcSBgHcagtVaaSttDcagccgttNBtgttHagYtattctttRWaaVt
+SttcatatKaaRaaaNacaVtVctMtSDtDtRHRcgtaatgctcttaaatSacacaatcg
+HattcaWcttaaaatHaaatcNctWttaNMcMtaKctVtcctaagYgatgatcYaaaRac
+tctaRDaYagtaacgtDgaggaaatctcaaacatcaScttcKttNtaccatNtaNataca
+tttHaaDHgcaDatMWaaBttcRggctMaagctVYcacgatcaDttatYtaatcKatWat
+caatVYtNagatttgattgaYttttYgacttVtcKaRagaaaHVgDtaMatKYagagttN
+atWttaccNtYtcDWgSatgaRgtMatgKtcgacaagWtacttaagtcgKtgatccttNc
+ttatagMatHVggtagcgHctatagccctYttggtaattKNaacgaaYatatVctaataM
+aaaYtgVtcKaYtaataacagaatHcacVagatYWHttagaaSMaatWtYtgtaaagNaa
+acaVgaWtcacNWgataNttcaSagctMDaRttgNactaccgataMaaatgtttattDtc
+aagacgctDHYYatggttcaagccNctccttcMctttagacBtaaWtaWVHggaaaaNat
+ttaDtDtgctaaHHtMtatNtMtagtcatttgcaaaRatacagRHtatDNtgtDgaatVg
+tVNtcaaatYBMaaaagcaKgtgatgatMgWWMaHttttMgMagatDtataaattaacca
+actMtacataaattgRataatacgBtKtaataattRgtatDagDtcRDacctatRcagag
+cSHatNtcaScNtttggacNtaaggaccgtgKNttgttNcttgaaRgYgRtNtcagttBc
+ttttcHtKtgcttYaaNgYagtaaatgaatggWaMattBHtatctatSgtcYtgcHtaat
+tHgaaMtHcagaaSatggtatgccaHBtYtcNattWtgtNgctttaggtttgtWatNtgH
+tgcDttactttttttgcNtactKtWRaVcttcatagtgSNKaNccgaataaBttataata
+YtSagctttaaatSttggctaaKSaatRccgWHgagDttaaatcatgagMtcgagtVtaD
+ggaBtatttgDacataaacgtagYRagBWtgDStKDgatgaagttcattatttaKWcata
+aatWRgatataRgttRacaaNKttNtKagaaYaStaactScattattaacgatttaaatg
+DtaattagatHgaYataaactatggggatVHtgccgtNgatNYcaStRtagaccacWcaM
+tatRagHgVactYtWHtcttcatgatWgagaKggagtatgaWtDtVtNaNtcgYYgtaaa
+ctttaDtBactagtaDctatagtaatatttatatataacgHaaaRagKattSagttYtSt
+>THREE Homo sapiens frequency
+agagagacgatgaaaattaatcgtcaatacgctggcgaacactgagggggacccaatgct
+cttctcggtctaaaaaggaatgtgtcagaaattggtcagttcaaaagtagaccggatctt
+tgcggagaacaattcacggaacgtagcgttgggaaatatcctttctaccacacatcggat
+tttcgccctctcccattatttattgtgttctcacatagaattattgtttagacatccctc
+gttgtatggagagttgcccgagcgtaaaggcataatccatataccgccgggtgagtgacc
+tgaaattgtttttagttgggatttcgctatggattagcttacacgaagagattctaatgg
+tactataggataattataatgctgcgtggcgcagtacaccgttacaaacgtcgttcgcat
+atgtggctaacacggtgaaaatacctacatcgtatttgcaatttcggtcgtttcatagag
+cgcattgaattactcaaaaattatatatgttgattatttgattagactgcgtggaaagaa
+ggggtactcaagccatttgtaaaagctgcatctcgcttaagtttgagagcttacattagt
+ctatttcagtcttctaggaaatgtctgtgtgagtggttgtcgtccataggtcactggcat
+atgcgattcatgacatgctaaactaagaaagtagattactattaccggcatgcctaatgc
+gattgcactgctatgaaggtgcggacgtcgcgcccatgtagccctgataataccaatact
+tacatttggtcagcaattctgacattatacctagcacccataaatttactcagacttgag
+gacaggctcttggagtcgatcttctgtttgtatgcatgtgatcatatagatgaataagcg
+atgcgactagttagggcatagtatagatctgtgtatacagttcagctgaacgtccgcgag
+tggaagtacagctgagatctatcctaaaatgcaaccatatcgttcacacatgatatgaac
+ccagggggaaacattgagttcagttaaattggcagcgaatcccccaagaagaaggcggag
+tgacgttgaacgggcttatggtttttcagtacttcctccgtataagttgagcgaaatgta
+aacagaataatcgttgtgttaacaacattaaaatcgcggaatatgatgagaatacacagt
+gtgagcatttcacttgtaaaatatctttggtagaacttactttgctttaaatatgttaaa
+ccgatctaataatctacaaaacggtagattttgcctagcacattgcgtccttctctattc
+agatagaggcaatactcagaaggttttatccaaagcactgtgttgactaacctaagtttt
+agtctaataatcatgattgattataggtgccgtggactacatgactcgtccacaaataat
+acttagcagatcagcaattggccaagcacccgacttttatttaatggttgtgcaatagtc
+cagattcgtattcgggactctttcaaataatagtttcctggcatctaagtaagaaaagct
+cataaggaagcgatattatgacacgctcttccgccgctgttttgaaacttgagtattgct
+cgtccgaaattgagggtcacttcaaaatttactgagaagacgaagatcgactaaagttaa
+aatgctagtccacagttggtcaagttgaattcatccacgagttatatagctattttaatt
+tatagtcgagtgtacaaaaaacatccacaataagatttatcttagaataacaacccccgt
+atcatcgaaatcctccgttatggcctgactcctcgagcttatagcatttgtgctggcgct
+cttgccaggaacttgctcgcgaggtggtgacgagtgagatgatcagtttcattatgatga
+tacgattttatcgcgactagttaatcatcatagcaagtaaaatttgaattatgtcattat
+catgctccattaacaggttatttaattgatactgacgaaattttttcacaatgggttttc
+tagaatttaatatcagtaattgaagccttcataggggtcctactagtatcctacacgacg
+caggtccgcagtatcctggagggacgtgttactgattaaaagggtcaaaggaatgaaggc
+tcacaatgttacctgcttcaccatagtgagccgatgagttttacattagtactaaatccc
+aaatcatactttacgatgaggcttgctagcgctaaagagaatacatacaccaccacatag
+aattgttagcgatgatatcaaatagactcctggaagtgtcagggggaaactgttcaatat
+ttcgtccacaggactgaccaggcatggaaaagactgacgttggaaactataccatctcac
+gcccgacgcttcactaattgatgatccaaaaaatatagcccggattcctgattagcaaag
+ggttcacagagaaagatattatcgacgtatatcccaaaaaacagacgtaatgtgcatctt
+cgaatcgggatgaatacttgtatcataaaaatgtgacctctagtatacaggttaatgtta
+gtgatacacaatactcgtgggccatgggttctcaaataaaatgtaatattgcgtcgatca
+ctcacccacgtatttggtctaattatgttttatttagtgacaatccaatagataaccggt
+cctattaagggctatatttttagcgaccacgcgtttaaacaaaggattgtatgtagatgg
+taccagtttaattgccagtgggcaatcctaagcaaaatgagattctatcctaaagtttgg
+gcttgatataagatttcggatgtatgggttttataatcgttggagagctcaatcatgagc
+taatacatggatttcgctacctcaccgagagaccttgcatgaagaattctaaccaaaagt
+ttaataggccggattggattgagttaattaagaccttgttcagtcatagtaaaaaccctt
+aaattttaccgattgacaaagtgagcagtcgcaataccctatgcgaaacgcctcgatagt
+gactaggtatacaaggtttttgagttcctttgaaatagttaactaatttaaaattaatta
+acgacatggaaatcacagaacctaatgctttgtaggagttatttatgctgtttactgcct
+ctacaaccctaataaagcagtcctaagaatgaaacgcatcttttagttcagaaagtggta
+tccagggtggtcaatttaataaattcaacatcgggtctcaggatattcggtcatataatt
+tattaagggctcttcgagtcttactctgagtgaaattggaaacagtcatccttttcgttg
+tgaggcatcttacaccgctatcgatatacaatgcattccaccgcggtgtcccgtacacaa
+ggaaacttgttaccttggggatataagaaaactcacacgtctcattattaaactgagtac
+aatttttgcacgagaaagtaatgcaatacaatatgatgaaagccagctaatgaaaaggga
+tggaacgcacctcggatctgttgcactggattaaaatccgattatttttaaaaatattca
+gtgctagagcatatcaggtctacttttttatctggtatgtaaagcccacggagcgatagt
+gagatccttacgactcaacgaaaagttataacataactcccgttagccaaagcccaatcc
+cgattactgccctaccctaacgtctgccatctaaatatcgaacttgttatgatcaatgtg
+actacctcccaccctttccccttcatttgttccactggggataagctagcgttttcagaa
+tcaatgcaataagaatagccaattgtctcacttcatcagagctcttggcaattccaggcg
+ctacgtggttctggaatatattcatttttcaaatagtaatacgtttagtgttgctattgt
+ctacacgtttggatattacgttatgtgagcggacatcaatagttgtctaactctttagta
+agccagagatagcactcttagcgaatggataccatcttccataagtttagttaatagtcc
+gaaacaactgcttcgagcatatttgaacctccttgtaggcaaatagcctcttcaaagcaa
+tcttactaatagatagagtttgttttaagggactactagaaatgggacaatcttaatagt
+atgacctaaactgacatttaaagatatatccaggtggcaagcataaagatcattgcgcca
+cctccaccgtgggattacttatcagtcgatatcctatatgctaagtttgcgacggcagaa
+tacaaactaagctgagttgatgctaaccttacctatgataccccattggaccggttaaca
+gccctacttattccaaataaaagaacttttatgctgtagaagctattatagtgatgcctg
+gtaacttcagtatattaaaatgacacacatacgccatatagagctcctggaactttgaat
+aatgagcgaacttcgaagttgaagagcaagaaaccatatgtcacggttgcctaaagcccg
+gtaaccagacatgtgctatcattgatcattatcgaggttttcataaccttgacccattat
+cggctgtgcgcggacaagtacttaaatcactagtttcttcacctgcttatcggtaagaaa
+taaggttggcaaagaatcgcataagacggacgtagagccgcagcgttgtgcgagtccagg
+tgcatgcgcagcaataggattttaaattttgttccatttttaatttagccgtaaggatgt
+ccgtaaatgattgaaaattggattcaatctttgggcctatgctactggaacctgatcgac
+aaaatttcaaacatacgttaactccgaaagaccgtatttttgcggctagaatagtcagtc
+gcttggagccatataccttaccacttaaacgacgtgctcctgtagttgaaatataaacag
+aacacaaagactaccgatcatatcaactgaagatctttgtaactttgaggcgaagcaccc
+tcttcgagacaactaagagtaaagtaccgggcgccgcaaggagtcgattgggaccctaaa
+tcttgacgaattgctaagaggctcagagctaccactgtaatttctctagagcccataata
+aatgaacgatacatccgtaggtagcacctaagggattataatggaagccaaatgcagtta
+ataatattatatactggcgtacacgattcgacggatctctcacatagtgattcacgaccc
+ccccctttgattgacacagcgtcagcattttgcaagaacgatcttctgcatagggtgcgc
+caccgtaaggatgacgtcgaagctacaactgggtataatttaccatgcttccctgatgct
+gagtgcaatacactaagaatgagtttttaccccatatcaccagtatttgttctgttattg
+cgaagaaatggctatgctgagttggcgactaaagtcacccatcctttttattaggtaacc
+ccctcccttaaactaactgatttgctggagctgccctgcatacatatactttatcattta
+tggacgtccgtgacgcttattatccaccatagtcgatatgctacacggattcattaatgg
+atcgtaggagtttaagttatatttactaagatcggtctcggctactatcccgccttaccc
+ggcgctatttacggccatttttaatatattgacggtaattattcctatggtttcgaccgc
+acgtccttggacaagaaagaatggcaaaaaaaatgtaaaagaaaaaaaatattgagtccc
+taccatcatataaaaaatatgtgatgagtaacttgacgaaatgttagtggttattaaaga
+ctatctattacaccttttgttttctgtcgtagtatattaaagtctagaagccttacagga
+aaatcagggttatacagccgatactccgcagcatgaatcatcgaggaggtgtcctaccat
+cgcgccttgtaatcttgtctgtgtatactgtatttagaccttttatacaaagtaaatatc
+tcggctttatgtgattgggaggggcctactcaaacatgatgacttgacctaataatcact
+gtgcgggcgtcttatgactagctattccttgaaatccaccaccaaatggttaatatgtaa
+aaactttgacgatgaaacaaggtgaatgtgtagttactttgtgtaattagctgcgtcgag
+cattgcttgtaaaaccgtcaatcgcacacgttacttccataaaatttctacgaatacacc
+cttcttaaaaaaaacgtaggaattcacgagtttaacaaacgataactgtataaagtggaa
+gtccgaagaaagcagatgcccgaactactcgaagatgtttcgttttcttaaccatagggg
+cttcttaatggcccactacgcacattttgttcaagcccgagagggacatccccattacgg
+gagtattactaaaactgttccgtaatacgttcagcaagggatgaaaaaggccactgctca
+agttattgacgtgggagtattacatcggaagcctgaatcccacactatgatggtctgtac
+aggcctagggactgcgtctagacggtattaccggcttctaatcatacgatcgtgagtctt
+aacgggaagtaaggctcacacctaccccaaaccatttatctatgtaagtataaaattgtg
+cgtaagtgttcaaagtggacaataaagacgtggcaaaaacccccgcacataagccgcttt
+agatttcacaaataccaatgcggttaaaaacatccttgagtcgtacatacaccatactcg
+cgttaaacggatataacagaagataataaatccggatgtggagtcggtgtaactatagaa
+agccaagtgaaataatgcttaccagtcatttagctatacggctttcatttcatgtcaaga
+gggtggagtttgacctgtacagttgatatatcaccgatacttagaactcacctaaagcta
+aaattgctcgcagcgtgtaatccgcatattacaaacaatagatgggattcattatacata
+agacacgatgatctgctttttcaggttgcgagatgttgcctatcgtcaatcgagtcctgc
+cttacaccacttaaacaaaagtattgacagggaacctattttcgaggtattatatagtcc
+agcttgaatatcaatttgacagttaacctagtgaaaatcagtaagaggaaatacgccaca
+ttctccagtgaaattctacgggttatcgtctagtccaactatcaattataactcacgaga
+tataagtaaattctcgtacttggcctgatttttattatactttggatccttagtaaacag
+gaagggagaaaccttcaacgaaaaacactggattttgttttactctcaaagctcttatat
+gacggaaataccctgtcaagtcttaactttattactagactaatgaaatgggcttggggt
+ggccagaatcatagtacaatttagcggatacactattcggactttcctatcggctgtctg
+gttggataagtatggggactaataggctagacatacctatacttaaactatacaggcgtc
+atctatctctgcaactttggagttccctgatgttctcccgccctttgggttcacatcttc
+tataccgacacccctaataacgattagtttgtgggttagagtaaattaatacggttaata
+ttaatgtatcgttgaaaagctggtgtcgccaataaggtaaccggctaggcagagtatatg
+tcacgaagtataactaccctaatgataagctgtaggaataaaattaatgctgtctctaag
+cgaagagatatttccgactctgttttaatgacgaatctcattacttctgacttgcaaatg
+ttcaatatggcacggtttcacggcacctttgtgacgcatataatgaacttagaagattat
+aacgacggaactttatatgataatccgttacgattaaagaatctgttaaatatcataatg
+gcattcagttctagaccgtgcatcatggtaaacttactttctctgcatggcgacatacat
+ttcgctattcaaattcgcgtgtggttacacccactcgcacctttggaatattaagagaag
+atgatcagaaaatccattcgctcaatttttctgacgtacgtctaatttatcctaggagac
+aaatcgttttatgtctctcacatttttgaagaaaggttcgagagacaatactcaggtcct
+gaactgctagaagatactcggtggagcgtggcaacaatgaaaaactcgtgacataaatga
+atgatacttttccaagttcagttaagtgaatatgtttaacatacccggcttttcgatctt
+aagctgacgctggacgtgcgagtaatgtcagtctcttacatacactagtgactccaagtt
+tcgtcaaaaacgccccctcccttctcgagcccactcacgctatgtattgacgcgaacttg
+ttcgggatcagacttttcaggagttcggtcgcgtgtccctatgtgctaatatataagtta
+gatcgcattagatgctaatctgaatacttatagacgaccttcaacgagaacgggtaccac
+cttgaggctagagttaggtgtgaaacgacaggtagggacatataaaatttgagtgcggct
+ttagttaagggtttaattacctactcaaacatcacgctcgcgcccttcgtacgtaatcga
+ccatctagaggctaaggggactgtactaggtagtgattaatgatatcctagacgcacgtg
+ccttagatcttcagactctgatggtccgcgatcaccgtaattgtagtcctccaactcgat
+cactttgttggcgtcaaagaaattacgatatctaaatacttataatacaataaccaagga
+tgagaatgactcatcgcgttggagttatattgcttgaagttctatggaatgaaagcacgt
+tatctgccgtcccaatatctccagtgagctaattcattggacggtccactttgatcaatc
+cccgaggagatgttcggacactttagtctgtaacacttagcgttgagaccacgaacaatt
+gattactcagtcttgaaggtgttttccaaagttcattttaaataagactacgataggcct
+ttcctattgatataaactacccggctctgttgttcgtgtgagtcgtacttctctgtgttt
+ttctgattatagcaagattcgattcttagtgtaaacagcgatttttatttgacccgtcaa
+tgagaagcgcataggatctaagcaaaattatcaagttgtgccacaaggtaagatctttcc
+agttattgcaggtaggatgtatcccacgttgatagtatgaggtctgacgtcaactgtcta
+ggagagttgaccgcgtgcgggtacaccggatttgcatcgatgttgagaacgcagaactcc
+cactgtcgtggcggcgttcctgatatttagcaagaggcgttgataaagccctcatcatct
+agatctcgacctcatctgccctcttgctccatcattttctacacagactactttcctatc
+tacgttagtataattgctttctatcttagtatcatttagagcttctccgtcaacaggttc
+gtgctattaaagttagtacgaaagggacaacttgtagcaacgcatttaatcggttttcga
+ctacttcgcacaaaatcagataaagaagtttgtcattctattagacattgaattgcgcaa
+ttgacttgtaccacttatgatcgaacactgaatcaagactgtgattaactaaaatagaca
+agccactatatcaactaataaaaacgcccctggtggtcgaacatagttgactacaggata
+attaattggactggagccattacattctctacaatcgtatcacttcccaagtagacaact
+ttgaccttgtagtttcatgtacaaaaaaatgctttcgcaggagcacattggtagttcaat
+agtttcatgggaacctcttgagccgtcttctgtgggtgtgttcggatagtaggtactgat
+aaagtcgtgtcgctttcgatgagagggaattcaccggaaaacaccttggttaacaggata
+gtctatgtaaacttcgagacatgtttaagagttaccagcttaatccacggtgctctacta
+gtatcatcagctgtcttgcctcgcctagaaatatgcattctatcgttatcctatcaacgg
+ttgccgtactgagcagccttattgtggaagagtaatatataaatgtagtcttgtctttac
+gaagcagacgtaagtaataatgacttggaataccaaaactaaacatagtggattatcata
+ctcaagaactctccagataaataacagtttttacgatacgtcaccaatgagcttaaagat
+taggatcctcaaaactgatacaaacgctaattcatttgttattggatccagtatcagtta
+aactgaatggagtgaagattgtagaatgttgttctggcctcgcatggggtctaggtgata
+tacaatttctcatacttacacggtagtggaaatctgattctagcttcgtagctgactata
+ctcaaggaaccactgctcaaggtaggagactagttccgaccctacagtcaaagtggccga
+agcttaaactatagactagttgttaaatgctgatttcaagatatcatctatatacagttt
+ggacaattatgtgtgcgaaactaaaattcatgctattcagatggatttcacttatgcctt
+agaaacagatattgcccgagctcaatcaacagttttagccggaaacaatcgaagcatagg
+gacaatgtatcttttcctaaattgccatgtgcagatttctgagtgtcacgaagcgcataa
+tagaatcttgtgttgcctcaactcgttgaaaagtttaaaacaatcgcagcagtctttttg
+gggtctactgtgtgtttgcaaaataactgaaagaaacgcttgaacaactctgaagtagct
+cgagtactcattaaagtgtaacacattagtgaatatcggccaatgaaccaaacgcttccc
+ggtacgctatctctctcatcgggaggcgatgtgcaggttatctacgaaagcatcccttta
+cgttgagagtgtcgatgcatgaacctcattgtaacaatagcccagcaaattctcatacgt
+gcctcagggtccgggcgtactcctccatggaagggcgcgcatctagtgttataccaactc
+gctttttaactactatgctgtagttctacaggcatagtggccagtattttctaacttctc
+tggatagatgctctcactcctcatccatcacggcttcagtttacgtcttacttgcttgtt
+cagcaacggatggaggcattaagtatcttcactgttccctaaaattgctgttcaatatca
+aagtaaggacgatacagggaaagctcaagcacactcattgaatactgccccagttgcaac
+ctcacttaatctgacaaaaataatgactactctaagtgttgcggaagcagtctcttccac
+gagcttgtctgtatcacttcgtataggcatgtaactcgatagacacgaacaccgagtgag
+aaactatattcttgcttccgtgtgtgtgacaccaggtaattgatgcggatataagctgga
+gatcactcacgcccacacaaggcgctgctacctctttattccaatgtgtaagaatttgct
+aacttcatttctagaccgcagctttgcggtcataatttcacggtacggacccttgggtta
+gagacttgataacacacttcgcagtttccaccgcgcacatgttttagtggcttctaacat
+agaatttttgttgtgacataaagagtgcgtgggagacttgcccgaccgttaagccataat
+caattgaaagccccgtgagtcacatctaattggttgtactgcgcatttagctatccttta
+gctgactcgaagagattcgattcctaatataggttaattagatggctgccgcgcgaagta
+aaacgtgaaaaacgtagtgcgcagatctgcataactcgcgcttaattacttatgagtagt
+tccaagttcgctacgttatgagagagattggaattaagcaaatatgttttatggtgattt
+tgggatgagaaggactgctaagtacggctactaaacaaatttctaaaaccgccatctacc
+ttatcttggagacatttaagttgtatatgtcactagtctagcttttgtctgtgggacgcg
+ttctcggaatgagggaaatgcaagagccgattcatcaaatgcttatctaagaaagtagtg
+gactattacaccaagcacgaatgccagggaactgctttcttgctcaggacctcgcgacaa
+ggtaccccgcataagtcctagaattacatttggtcagcaatgctgacatttgaccgtgaa
+aacataattttaatcagaaggcagctcacccgcttgctctagatcttatctttgtatgaa
+tgtcagaatttactgcaatatccgttccgaatagtgagggcttagtatagttctctgtat
+acaggtcacatcaaactccccctgtcctagtacagctctgagctttaattaattgcatac
+atttccttcaatcatcagatgaaaacaccgcgaatcatgctcttctcgtatagggcaaga
+gaagcaacaaacaactagcccgactcacgttcatccgccgtatccttgttcagttcttac
+tccgtattaggtcagcgaaatctaatcagaataatcggtcgcgtatcaaaattaaaatcc
+cgcttgaggttgacaattaaaacgctgagcagttatcggctattagatagtggggtgaaa
+gtaattggctggaattatgttaaaacgtgatattaagctaaaatacgctacttgttgccg
+acctaattcagtcattcgatattcagttagagccaagaataacaagcttgtataaattga
+acggggtgcactaaacgatgtgttactctaatattcagcttggagtatacctgaaggcga
+attcatgtatcggccaataataagacgttgaagatcacaatttggactagcaaaagaagg
+tgatttatgcgtggggattgagtccactgtacgagtacggtctctggaaaattataggtt
+cagggaatataaggaagtaaagataattaccaagagatttttggtatcgctatgacccag
+aggtgttctaacgtctgttttgatccgcagaatttctgcctcaatgcatatttgacggac
+ttgaactagagcctctaaagttaaatggcgacgcaactgttcctaaacttcaattattac
+tactctttttttcctagggtattgtagaggccagtggacaaaataaatcaaatttaagat
+gtttcggacattaacatcccccgtagcatagaaatcatcagttatccaatctctcatcga
+gcttttacaatttctgctggcgctatggacagcatatgccgcgagacctccgcaagactc
+acttgatcactgtaagtatcttcattagaggttagagcctatagttaagctgctgaccta
+gtaaaattggtattttctaattttattgctcaagttaaaggttagtgaagggataatgac
+gttatttttgaacaatgggttgtattcaattttatatcacgaatggaacccttcattccc
+ggcataatactagacgacacgaacaagctccgatctatcagccaggcacgtgttaaggtt
+taattccggcaaaccaatgaagcatcaaaaggtgacctgatgcaacttagggtcacgatg
+agtttttcaggactacttattacctattaataagttaacatgagccttcataccccgtaa
+gacaatacatactccaccaattagaattctgagccatcttatctttttgtatcatcgaag
+ggtatggccgaataggttaattagttactcctaacgtctctacaggcatgcatttgacgc
+accttcgaaaatagtcaatctctcgccacacgcgtctagtatgcagcatcaaaaatatag
+tccacggtttccggattaccaaacgcggcaaagagaaacattgtatcgacggagataact
+taatacagaaggaaggggcatcttcgaatacggatgaataattctatctgtttattctga
+catcttgttttcaggttaatcttacgcattcaaatgacgcctgccccatgcgtgcgcaat
+tattttctaatattgacgagagcaatctcactccttttgggtctatttatgttttattga
+ggcacaagcctatacagaacaggtactattaaggccgtgagtgtgagactcaaaccgtgg
+aaacaaaggatgggttgttcttggtacaagttttagtgcatgtgggcaatccttaccaaa
+atcagatgctatccttaactttgggctgcatttaagatggcggttggaggcctgtgagaa
+tcctgcgtgtcatctttaatgaccgaattcatccatgtagattcagatcacacactcatt
+ccttgatgttgtctaaacaaaagttgttgtggacgcattggagggagttaagtaacaact
+tgggatcgcatacttataaaaattatatgttaaactttcacaaacgctgaagtccaaagt
+aactagcccaaacgcctcgagagtcactaggtattaatggtgtttgagttcctgtgaaat
+agtgttcgaaggtaaaatttatgtaccaaatcgaaagaacacttaataaggcttgcttgc
+acggaggtatgatgtttactgactctacaaccctaattttccagtacgtacattcattcc
+aataggttagttctcaaagtgctatacaggctcctcaattgatgatatgcttcagccgct
+ctatggatattagctcattttatttaggaagcccgcttagaggcttactatgagggaaat
+gccaaaatgtcatacttttcggtgtgtcccatatgacaccgctttacatagaatttgaat
+taaaacgcgctctcccgttcactaccatacttggtaccgtgcgcatattacatatagata
+taggatcattttttaaagctgtactaggtttgatcgacaatcttatgctatactatatga
+tgtaaccctcataatcaataccgatcgtacgatcctagcataggtggcaagcgattttat
+gccgattattgtgttaaatagtctgtgagtgtgattatcagggctacgttggtagagggg
+ttgtatagacctcgcacacattgtgacatacttaacaatatacgaaaactgatataataa
+atccccttacccaaacaccaatcccgttgaatcaactaccataacgtctcccatataaat
+tgcctacttgtttgcataaatctgaatacataacaccattgcaccttcttgtgttccaat
+cccgttaagattgccttgtcagatgatatgcaagaacaatagcatttgctagcaattatt
+aacagctcttcgaattgcctccacataacgcgggagggtatattttaatttggcaaatac
+taagtactgttggcgtcatatgctattaacggttggatattaagttatgtcagccgtaag
+caagagtgggcgaaatattttgttacccagtgagagcactcttagagtttggatacaata
+ggccatatgttgacttaagaggacgtaactacgccgtacaccattgttcaaccgacttct
+tggcaaatagaatcgtattagcaatcttaagaatagagacacgttcgtgttagggtatac
+tacaaatccgaaaatcttaagaggatcacctaaactgaaatttatacatatttcaacgtg
+gatagatttaacataattcagccacctccaacctgggagtaattttcagtagatttacta
+gatgattagtggcccaacgcacttgactatataagatctggggatcctaacctgacctat
+gagacaaaattggaaacgttaacagcccttatgtgtacaaagaaaagtaagttgttgctg
+ttcaacagatgatagtcatgacgcgtaacttcactatagtaaattgaaacaaatacgcaa
+tttagacagaatggtacggtcatgaatgacagtaattcgaagtgctagaccaacttaaaa
+taggtaaacgtgcccgaaaccccccttaacagaaagctgctatcatggtgcagtatcgac
+gtgttcagaaacttgtaacttttgagcaggtccgagcacatggaagtatatcacgtgttt
+ctgaaccggcttatccctaagatatatccgtcgcaaactttcgatttagtcccacgtaga
+gcccaagcgttgtgcgactccacgtgcatgcccagaaatacgagtttaaatttggttaca
+tggttaattttgaccgaagcatcgcactttatgattgataattggattcaatatgtcgcc
+ctatgcgaatgcaacatgatccacaatttggctataagacgtttaatccgtatcacactt
+tgtttgcggctagtatagtaacgcccgtgcaccaagagtcagtaacaattataagtactc
+cgcaggtacttcaaatataaaaactaatcaaacacgacccatatgatcatctgaagatat
+ttggaactttctcgacaaccaccctcgtactcaatacttacactaatcgacaggcacacg
+caacgtgtacagtcgcaccatattgagtcaagatttgcttagtggcgatgagcgtacacg
+cttatttctctagtcacaattagttatctacgagacatcacgagggagcaaataagcgat
+gttatggctacacataggcacgtatgaatatgatataagccagttaaacagtcgaaccat
+cgagcaaattctcatgcaccaacccacacgttgaggcacaaagagtaagctgtttgaatg
+taacttcttctgctgagcgggccccaacgtaaggatcaactagaagagaaaactcggtat
+tagtttaaatgcgtcacggagcatgagtgcatttcactaagaatgtctgtgtaaccaata
+taacatctatttgttatctgattgcctacttatggctttgcggtcgtggcgactaatgtc
+tccaatccttttgaggtcggtaccaactccctttaaattacgctgtgcaggctcatgcac
+tgcatacatatacggtagcaggtagggacctcacgcacccttattataatcaatagtagt
+tatcagtcaacgaggcaggaatgctgaggtcgaggtgttggtatattttctatgtgccgt
+ctaggcgactatcacgcattaccaggcgagatttaagccaattttgaatatagtcaacgt
+aatttttactatgggttccaccgaaacgccttgcacaactaagaatcccataaaatatcg
+atatcaaataaaagattgtgtcaataccttcatatatattttttcggttgactaacgtga
+actaaggttaggggttttgtatgtctatataggaaacagtttcttttctgtcctacttta
+gtaaagtcttcaagccttactccaaaatcacggtgattaagccgttactcagcagcatga
+ttctgcctgctcgggtcctaaaatccagccttgtaagagtcgctgtgtattagctaggga
+gacctttgttaaaaaggatatatcgcggcgggatgtgagtgcgtggcgcatactcaatct
+tcagctcgtgtcattataatatctctcccccacgcttttcactagatatgccgtgtaagc
+aaacaccttatgcttaatttcgaaaatattggtacttgaaaaaagctgtaggggtactta
+atgtctggtaggagatcaggagagaattgagtgtaaaaccgtaaagccctcacctgactt
+catgtaaatggcttagaagactccatgatttaataaatactacgaaggaaagactggatc
+taaagataactctagtaaggccaactcccttcaatgctgttgccagttataatccaagag
+ctgtccttttctgaaccatagcggcttctgaagcgaactagaagcaaagttggttctagc
+cagacagccacataccctgtacgggtgtattactaaaactggtccggtattagttcacca
+agggaggaattaggcaaaggatctaggtatgcaagtcggagtattacatccctaccctga
+atccatcaataggttcctctgtactggccttcgcaatgagtattcaaggttgtacagccg
+tataataataagatagtgactatgaacgggaagtaacccgctcaccttccccaaaacatt
+gttatatctaagtattaaagtctgccgtagtgttaatactcgaaaataaacaactggcaa
+attacaccgcacttaagccgcttttgatttatatttttccaatgcgcttttaaaaataat
+tcagtcctacatactaattaagacccttaaacggagatatcacaagttaagttttaacca
+tctcgactaggtggaactatagatacccaactcaatttatcattacctgtaatgttccta
+gaaggattgcatttcatgtcaagacggtggagtttcacagcgaaacttcagtgtgaacag
+attctgagaaatcacctaaacctattagtcagagcacccggttagaaccagttgtcaaaa
+aatagagcggttgcatgagacagaagtaacgatgagatccgttgtaacgttgagacatct
+ggcctatcgtcaatacagtcctcccttaaaaatatttttaaatactaggcaaacccaaca
+taggttagtcctatgtgatacgccacatggtatatcattttgtaacgttacctagggata
+atcaggaagtggaattacgcaaaagtagacagtgaaatgcttagggttatagtctagtcc
+aaagataaaggataaagcacgtcagagaactatattagccgaatgggaatcattgttagg
+agactgtggatcatgtctaaaaagcaacgcagaaacagtcatcgaaaaaatctcgttttt
+gtttgaatctaaaagagctttgatgaccgatagtacctgtatactagttactgtattacg
+tgtctaatgatttcggattggggtccccagaatcagacgtcattgtagacgattcaagtt
+taccaatttaatttcccagctctccttggagaactatcgccaataattgcagtcactttc
+cttttctgaaacgataaagccgtcagagttctctgcaacgttggacttacctgaggttct
+aacccactttcggttctaatagtagttaacgacacaacgaataacctttactgtggggct
+ttcacgatattttttcgcttattattaatggttacgtcataagctggtgtccaaattaag
+gttaccggcttcgcagagtagttgtatccaagtataacttccctaatcataagatcgagg
+tagaaaattaatgctgtctctaaccgaacagatatgtcccactatgtggtatggacgttg
+ctaattacttctgaagggaaattggtcattatggatacgtgtctaccatcaggtcggacg
+cagatatggttctgtcttcagttgatccaccgttctttataggataataactgacgatta
+aagattatggtaaatagattaagccaattctcttcttgtcagtgaagcatccttaactga
+cttgctctgcagcccctcatacatttagctattcaaagtaccggctcgtttcaaactctc
+ccacctttggaagaggttgtcaacttgataagtatatcatttacagcattttttcggacg
+tacctctaatgtttcattgcagaaaattagttttttctatcgcacattttgcaagtaacg
+ttagagacacaattatctgcgaatgaactgctagatctgacgaccgggagcctcgcaaat
+atcaaaaaagactgacatatatcaaggagtcgttgacaagtgctggtaagtcaattggtt
+tatctgtcccggcgtttcgatcttaagctgaccatgcacggcagagtaatgtcactctcg
+ttcttacaagtctgtctccaagggtcggcaaaaaagacccctccattctcgagcccactc
+acgatatgtagggacgacaacttgtgcggcttatgaattgtctggactgcgggcgagggt
+ccatatctccgaagttagaagggacatacctttagatgataagatcaattcttattgacg
+aaattcatccacaacggggaacaacttcaccctagacttacgtctgaaaagacacctagc
+gtcttataaaaggtcagtgccccgtttcgtaaggctggaattacctacgcaaacttaaac
+ctcgcgcccttccttacgtatcgacaagatagaggctatcgcgaatgtactacggaggca
+tgaatcatatactagaaccaagtgcctgtgatattaacaagatgatccgacgcgagcacc
+gtaattctaggcataaaactccagcaatttgggggccgaaaacaaatgacgttagctaat
+taattatatgacatgatcaaaggaggtcaatcacgcatcgagttcgacgtatattcattg
+aacttcgtgcgtttgaaagaaacttttatgaaggcaaaattgatcctgtctcctatttca
+tgcgtacctcctagttgataattccccgagcagtggttaggacacttttgtcggtatcaa
+gttccggtctcaaaacgtaaaattctgtaatctgtatggatggtctgtgaattagttaat
+ttttatgaagtcgtcgagacgcagttcctattgatttattctaaacggagatgtgcttcg
+tgggactcggaagtagatctgtgtttatgattattgctactttagatgctgactgttaac
+tccgtgttgtttttcaaccgtatatcacaaccgaattggatagaacctatagtttcaagt
+tctgccacaaggtatcatatttacagttagtgctggttgcttctttcaaacgtggtgagt
+ttgtgctatcacgtcaacggtagagctcagtggaccgagtgcgcgttcaaccctgttcca
+gagagggtgtgatagcacatataccacgctcgtcgaggcgttcatgatagtttgcaagag
+ccggtgttaaacacatattattattgttatccaactaatcggacctatgcataaagcatt
+gtctaaacagaataattgcctatatacggtagttttagtgatttatatcttagtatcagt
+tagagcttcgaactcttcaggttcctcatatttaacgttcttcgaaagcgaaaacttcta
+caaacgaatgtaagcggttttccaagtagtacctataaatcacagaaagatctgtctcag
+tatagttgaaatggtattcagctagtgacgtgtaccaattatcatagttcactcaagcaa
+gacgctcattaacgaatatagacaagacactatatcatataataaaaaagaacatggtgc
+tcgaacatagttgaattcaccatattgaaggggaatgctgacatgtaattcgctactaga
+cgatcaattccctacttgtcaaagttgaactggtacgttcttggaattaaatatgattgc
+gctggaccaaattgcgacttcttgagtttcagggcaaacgattgagccggaggatgtccg
+tctcttacctttcttgcttatgataaacgacggtccctgtacatcactgggaattctcag
+caaaaataattgggtaaatcgagactcgatgtattcggccacaaaggtgttagacgttaa
+agattattcaacggggcgataataggatcataaccggtatgcaagcgcattgaaagagcc
+atgagatccttatccgataaacgctgcacggtatgtgcagccttattgtcgatcacgaat
+ttataaatgtagtctgggctgtaagttgaagacctaagttataatgaagtgcaataccaa
+atcgattcatagtggattatcagactcaagatatctcctgataaattacagttgttaaga
+tacggataaaatgagatttaagattagcagcctctaatctgtttcaatcccgttggaatg
+tggtatgcgatcaaggttaagttaaaatcaagcctgtcttcagtcttgattcttgttctg
+ccatcgcatgcggtctacgtgagttaatatgtagcttacgttctagcttgtgctaatctg
+agtatagattcgtagaggaatattatcaagcttccacgcctcaacgtacgtgtattggtc
+acacaagacactaaaagtggaagtagcgtaaactatagtctagttgttaaatgctcagtt
+cttgttatattcgatatactcttggctaatttatgtctgagtatataaaattaatgatat
+taacttgcatttcacggatcccttagaaaaagattttgaccgagcgcattataaacggtt
+acaccgaatcaatagaagcatacccaatagctttctttgaatttattgcctgcgcaactt
+ggctgactctctagatccgaataattctatatggtcgtgacgaaactagttcattactgt
+ttaaaatgccaacatgtcttttgggccgataatggctctttgcaaaattactcaatgata
+cgattgatcaaagcggtagttgctagtggtagcatgtaagtctatcaaatgtctgattat
+ccgaaaatcttccaaaagagtccacgtaccatatctatctcatagcgacgcgaggggaac
+cttatctaactatcattccatttaccgggtgactctcgatgcaggatccgattgggataa
+attgcccagaaatggctcattcctgactaagggtaaggccgttctcagcaagggaacccc
+gcgaatctaggcttataccatctagattgttaactacttgcctgtagttctacagccata
+ctggacagttgtttctaaatgatcgggattcatgctagcactcctctgaatgcaccgcgt
+aagtttaactattacgtccgtgggcagataaggatggaggctgtatgtatcttaactgtt
+acctaatatggctggtaattatcaaagtaaggaccttaatgccatagcgctagcaatcgc
+tttgtatactgaccatgtgccaacctctcttaatctgtaaaatataatgtcttagctaac
+tgtggacgatcatgtctctgcctagagcttcgctgtatcaattcctatagccagcgtact
+agtgacacaacaacaccgtgtgagaaaagatattagtccttacgtctgtctctctacagc
+ttattgatgaggattgaacatggacatatagctccccctcaaaagcagatgctacctctt
+tattccattctcgaacatttgccgaacttaatttcgacaaacctgaggtcacgtcttaat
+ttatcggtaacgtcacgtccctttgagactggataaatatattaccaggggccaacgagc
+aattgttggaggcgcttctataatacaaggtgtcttgtcaaagaaagacggcgtgcgtct
+cgtgcaactcacttaaccaatattaatgtgaaacccccctctctcacatcttatgcggtg
+tactgccctggtacatttcctgtacaggactccaacagtgtagattcctaagatagctgt
+tggagttgcctcacgccagatcgaaaaactgaataaactagtgagctgagctgcagaaat
+accgcttaattacttatgactagttcaaagggacctacgtgatgtcagacattgcaagga
+agaaattaggtttgtgcgtcattttggctggactagcactccttacttcccctactattc
+aaatgtcgtaaacagcatgagacaggatcgtgctgacatttaaggtctattgggaacgag
+gctacctttggtcgcgcgctcgcgttctccgaatgaccgaaatgcatgagcacagtatgc
+aattgcttatagatctaaggtctggtcgttgaaaccaagcacgtaggcctgggaaatcag
+ttcttcctcagcaactacacaaaagcgtccaagcattagtacttgtagtaaatgtccgaa
+cctatgcgctcatttgaaagtcaaaaaatatttttaagcagtaggcacctaacccgattc
+ctctacttagtagctttctttgattctcagaattgactgcaatatcactgcacaattctg
+tgccattactagacttctctgtattaacgtctcatcttactaacactcgcctaggacaca
+tctgagagtgaagtatttcaatacatttactgaaatcttcagttctaaaatccccgaata
+aggctcttatcggtttggccaacacaagaaaaaaacttcttgcaccactcaccttcatac
+gcaggagcctggggaacttagtaataactatttcggcagacaaagcttataacaagttgc
+cggcgcgtataatatttaaaagaccccttgagctgctcaattaaaacgctcacctggtat
+aggctattagatagtgccgtcttagtaaggggcgggaattatcggataaactgatatttt
+gataaaataaccgacttgttcacgacataagtcactaaggagattttatctttctccaaa
+gtatatcttccttggataatttcaaagcgctgcaatttaagttctgttactagtttatgc
+tgctgggaggtgaccggaaggcgtagtaatctagaggcaaattataagaagttcatcata
+tcattttcgactacaaaaacaaggtgttgtatgccggcgcattgtgtaaactggacgagt
+accctagatggaaaattatacgttaagccaagatttcgatgtaatgataattacctacac
+atttttgctatccataggaacaagagctgttctataggctcgtggcatacgaacatttgc
+tgccgctatgaatattggaagctcttcaactacagactctattcttaattgccgtcgaaa
+atgggccgaatcggctattattaatactcggtttttccgaggggattgttgtcgacagtc
+gtaattattattaatattgatgttggtgaggtcatttaaatacaaccttgcagacaatga
+ataagggatccaatctctcatactccttttacaattgctcatgcccctatgcaaacctta
+tgccgccacacctccgcaactctctcttctgaactgtaagtagcttcattactggtttga
+gactatactgaagctgatgacattctaaaatggctattttcgaatgtgattcataatgtt
+tatcgtttgggatggcagaatcacgttatttttgatatagcccgggtattctattgtata
+gaacgtatgctacaagtcattccccgaagaagactagaagtaaacaacatgcgaccatcg
+ttaagccacgcaaggctgtagctttatttcccgataacctatcttccataaatagcggac
+agcaggatactgacgctcaacatcagtggttatggtctaatttttaacttttaataaggt
+aacttcagcaggcatacacagtaactctttaatttataatcaaattagaagtctgacact
+tcttatatttttctatcatccaacgcgatcgcccattagcttattgtgttactaataacg
+tatctaaaccaatccttttcaagctactgcctatattgtcaatatatacaaacaacagga
+tagtaggctgcttaaaaaatattgtcaaccgtgtacgctttacaatacccggaaatcaca
+aactttgtagacaacgagtgaaatttatacactacgaagggccagcgtacaagacccatg
+aattaggcgatatgtttattctgacatattggtttatccttaatctgtcgctgtaaaatg
+aagccgcccccatccctgcgaattttttttcgaagattcacgactgaaatataaatacgt
+ttggctatatttatgttggagggaggcaatagcctttactgttaaccgaagatttagcca
+gtgagtgtgacactaaaacactggaataaatgcaggcgttcttctgggtaaaaggtttag
+tcaatctcgcctataagttcatatagctctggatataattatctggcccatgcatttatc
+atggcgcttggtgccctgtgtgaagccggcctctcatattgaaggtccgaagtattccat
+gtacattaagatcactctctcattcatgcatcttggcttaacaaatctggttgtccaagc
+tttccaggcacgtatggtacaaattcggatcgaatacttataaaaatgatatgttaaact
+gtctaaaacgctcatctacaaagtaaagtgcactaaccaatagagtctcaagaccgtgta
+atgctggtgcactgaatgtgtaatacggttagaagggattagttatgttacaaatccatt
+gaaaacttaagaagcattgcgtgctcggagggtgcatcttttatcaagagactaacatta
+ttttcaacgacgtacatgctttacaatagggtacttatcaaacgccgagaaacgcgccta
+tagtgatgttatgattatgacccgatatccattggaccgaattttatgtaggttcccagc
+gtactcgcgtaatatctcggtattgccataatgtaatacttgtcggtctctcccagatga
+aaaagcgttacagagtatttcaatgaaaaacagcgcgcaacgtcaatacctttaggggta
+acggccgctgatttcatatagatatacgataagttggtatagctctactaggtggcatcc
+acaatcgttgcatttactatagctggttacaatcataatctataccgttccttacatact
+accatagcgggatagcgtttttttgccgttgattgggtttaagaggatgtcagtctcatt
+atatccgattcggtgggagagccgttgttttcaaatcgcacactttgtgacataatgtac
+aagataacaaaactgatataagatataaactgtcaatatcaccttgacacttgaatcaaa
+gtaaattaactcgcaaatataatttgactaattgggtgcagatttctcaattaataaaaa
+aatggcaccggatgggcttacaagccccttatcattcacttgtatcatgatttccaagaa
+caatagaatttgctagcaagtatgaacagagattcgaattgcatccacagtacgccggag
+cgtttattttaatgtggatatgacgatgtactgttggcggcatttgctagtaaccggtcc
+ttatttacgtagcgcacacgtaagcatgtctgggagaaatatggtggtacaatctcagag
+aaagattacagtttggtttaaataggacttatcgggtcggaagtggaacttaataagcag
+tacacaattgggcaacagacgtcttgcctattacaataggattacaatgcgttagatttc
+agacacgttcgtgtttggctattcgtcaattccctaaatagttagacgatcaactattat
+caaagtgattctttgttcatcctccattcatgtaacagatggcacactacgcataacgcc
+gaggaattttaacgagatttaagagagcagttcgggcacaacccacttgactttataaca
+gctcggcagcataaacggtaatatgtgacaaatttccaaacgttataagaacgtatgtgt
+acttagaaaactaagtggttcatgttcaacagatgtgacgcagcaagcctaacttatcta
+ttggttttgctataaaagaacaaagttacacagaatcctaagggcttgtttcacacttat
+gcctagtgcttcaccatcttaaaatagcgaaaccggcacgaatcaaaccttaaaacaatg
+cgcagatattggtgatggtgactccgggtatgataatggtaactgttgaccagcgcccac
+ctcatcgaagtatagaaagtggttaggataaggatgagaccgaacttatttccggccata
+actttagattttctacctagtacacaacatcagggcggacacgaaaccgccatcacatca
+tataccaggtttaatttgcttaatgggggaagtgtcaacgaaccttcgaactttagcagg
+catatggccattatatatggccccagagcagaatgctacagcagacaaaatttggattta
+tgtagtttaatacctatcaaacttggtgtgaccatacttgtctaacgacagtgcacaaag
+tgtaagttacaattattactactcagcagcttctgcaatgataaaatcttatcatacacg
+tcacatatgataatatctacttagggggaacgggctccacaacctacatagtactcaata
+cttacactattcgacaggcacaccaaacctgtacagtcccaaaagattgagtcaactttg
+cagtactgcagatcacagtaatagcttagttagcgagtcaaaattagttttctacgagac
+tgcacgaccgtgcaaatttccgatgtgttggctacaaatagcaacgtatgaatttgtttg
+aagccacgtaaactgtacaaccttagagataagtctcaggctactaaaaacacgttgtgg
+cactaacaggatcatggttgattcttacttattcggctgaccggcccaataagtaacctt
+caactagaacagaataatcgggagtagtttaattcagtcaaggtgcaggtctcattgtaa
+ctaacaagctctgtgtaaccaagttaaaatcgttttcttagcggattccctacttatgga
+tttgagctcgtccacaatattcgatacaagaagtttgtggtccgtaacaacgaaatttta
+attacgctgtgcagcctcatccaaggaattaatagaaggttgatggtaggctccgaacgc
+tccatgattataatcaagtggactgtgcagtaaacgaggaaggtatcctgacgtcgtggt
+gttcgtttttgttatttgtgccctatacgagtagataaaccatgaacagcacagtgtgaa
+cccatggttgattttaggctaccttatttttaatttccgttacacagaaacgaattccac
+aactaacatgccattaatttttcgatatcttataaaagatggtcgaaattcattcattta
+ttttttttcggttctcgaaagtcaactaagctgtcgcgttttgtttctctttagaggtaa
+aagtggctttgatctcctacgtttggatactagtcaaccattactccatttgatccgtga
+gtatcacctgtctaacatccagcattatgactcctcggcgaagaaaagacacacttctta
+gagtcgatgtgtattagctagggacacagttgtttaatacgatagtgagcccagggaggg
+cagtgcgtcccccagtagatttattcagctagtgtaagtataagatatctcacccacgag
+gttcaagtgatatgcagtcttagaataatacttatcctgaatttcgatattatgggtact
+tcaataatccgctagcgctactttatgtctcgttggacagcaggacacatggcagtctta
+aacactaaagacatcacctgaatgaatgtaatgggattacaagaatcaatgaggtattat
+atacgacgtaggaaactctggatatatacagtaatctagttacgccatcgcacttcattc
+ctctggaaacttagaagacatcagctgtacgtggaggaaccagacccccgtatgtagcca
+aatagaaccaaagttgcttatacaaacacacccaatgacaatggaccgctggagttcgta
+aactcggaacgtagtactgcacaaacccagcatttagcaataggagctacgtatgcaact
+cccacgtggtaataccttcaagctatcaatatataggtgcctagctaatcgcattcgcaa
+gcagtattcaagcttgtaaaccagtataataattacagaggctctatgaaacccaacttt
+ccagctaaaagtcccaattaaatggttatttcgtacttttaaagtcgcccgttctgttat
+tacgcgaattgattctactccaaaattaaacacaaattatcaaccgtttcatttatattt
+gtcaatgcagctgtttaaaataaggctctactaaattataattaagacacttattaccag
+atttctctagttaagtttgaaccagctcgactaccgcgaaagatacattcccttctctat
+ttttcagttcatctatgggtcagagaagcattgaatttattctattcaccctcgtcgttc
+acagcgaatcgtcagtgtgatcagtgtatgagaaatatcctaaaccgtttagtcagacca
+cacgcttagaacaagtggtctaaaaagactgccctggaaggagtaagaagtatacagctg
+atccggtgtatccttcagtcatctgccctatactaattacacgacgcaaggaaaaatagg
+tttattttctaggcaaacccttcataggtgactccgatgtgttacgaatcatgcttgaga
+atgtgctatcgttaccgacggataataacgatctccaatgaaccaaatgtagaatgtcta
+ttgattacccttttactattcgacttagagataggagatagaacctcagtgtactttttt
+agccgaatgggaatctttgggaggtgaatggccataaggtcgtaaatccaaccctcttaa
+agtcttccatattatatcgttgttcgtggaatcgataacagatttgttgacccatagtaa
+atgtatactagtttatgttgtaagtgtagattgttttccgattgccgtccaaactttatg
+tcgtaattgtagaccagtaaagttgaccaaggtaagtgcccagcgatcctgcgagatcga
+tcgccaatttttccagtcactgtaagtgtaggtttagataaagccgtatgagttatatca
+taagggcctcggaaagcagcttcgaaccaaagttcccttataatagtagtttaactataa
+aagtatatactggtctgtcgccctttcacgatttgttttaccggtttatgaagcgttacg
+tcattagagcggctccaatttaaggttaacggcttccatgtgtagttgtatacaaggata
+acttaaagtatctgttcagcgagctagttaagttatcctcgatagaacacaactcagagg
+tcccaagatcgggtttgcaacttgctaatttattctcaaggcaaattgggaattatcgat
+acctgtataccataaggtcgctcgatgtgatgcttatgtcttctggtgatcctaccttag
+ttagtgctgattaacggaacattaatgtttatcgttttgagatttagccaattctctgat
+tctaactcaagatgccttatctgacgtgctatgcagcccctaagtattttacattgtaat
+aggacacgctcctttaaaactcgccaaaaggtcgttgtggttctctactggttaactata
+taatttacagctttgttgagctagttcctctttggtttaagtcctcaatattagttggtt
+cgagcgataagttggctagttaccttagtcactatattagatccgaatgttatgcttcat
+ctgaagaccgccaccctccaaaatttcttttaagactcacttattgcaaggtgtaggtga
+attcggctcgtttctcaagtggtgtatctgtacacgagtttccatattttcatcaacagc
+caccgcacacttatgtcactctaggtattaaaagtcgctctacaaggggacgcaattaag
+aaacagacatgctagtcaaaaataaacatagcgaggcaccactaattcggccgcttatca
+atgggatgctctgcgcgagacgcgccagagctcagtagttagttcggacatacatttact
+tcagatgatcaattagttttctacaaatgcttactctaccccgaaaaaagtcaccagact
+cttacgtctctttagtatccttccgtcttatataaggtcagtcccccgtttcggtaccct
+ggaatttactaagaataatgaaacagcccccaaggacgtacgtttacaaatgatagacca
+gatcgcctagcttattccgacgcatgttgcatagaattgaaccaacggaatgtgagagta
+actagatgagccgaccacagcacccgtttgcgtcgcagaatacgcctgatagttcggcca
+cgaaatcatatgtcctttgagtattaagtatttgtaatgatcaatcgagctcaagcaagc
+ttacacttcctcggatattcagggaacttagtgcctttgaaagatacgttgatcaacgaa
+aaattgataatggctcatatggaatgcctacctcatagtgctgaattaacacagcactgc
+ggacctaacttttcgaggtttcaagttcacgtctcaaaacctaataggctggaatatgta
+gggatcctcggtgaatttgtgattgggtttgttgtagtactgaccaagtgaatattcttt
+ttttctaaaagcagatctgctgccgggcactacgaaggagatctctgtgtatcattattg
+cttcttgacatgatgactcttaaatcactgtgggtgtgcaaaacgatagcacaacccaat
+tcgatagtacatattgttgatacttcgcactaaaccgttcatatttaaaggttgtgctcc
+ttccttcgttaaatactggtgacttggtcctatctactattagctagacctctggggaac
+cacgcccccgtaaaacctgtgcaagagagggggtcatacatcttagacatcgcgcctcca
+ccagggaagcattgggtgattgaccaggtgtgtaacaaatatgattattcttatactaat
+attagcaaagatgcataatgatttgtattaaatgtataattgaattgataagggtctttt
+agtcagtgatagagtagtataaggtagacattagaactcttaaccggacgcagatttttc
+ggtcttagtaagccaattagtcgacaaaacaaggtaagagcggttactagtagtacctat
+aatgcactgaatcttcggtcgaagtatagttctaatgctatgcagattgtgacggcgaca
+aatgttcagacttatatcatgaaacaagctcttgtaagtattgacaaatgaaaagattga
+atatttttaaatacaaaatgcgcctacttattaggggaattaaccagattgaaggccaat
+cctcacatgtaatgagataatagacgataaatgaaattcttgtaatagttgaactgctac
+gtgatgggtattatatatgattgagatcctccaattgccgacgtcttgtcttgatgccca
+aaagattgtcaacgaggagctccctcgcgtacctgtcgtccgtatcataaacgacgcgac
+atgtacagcactccgaagtataagcaataataatgcgggtaatccagactagatcttttc
+ggactcaatgcggtttcacggtaaacatgattaataccggagagtagtcgagcttatcag
+cgatgcaagcgaattcattgtgccaggagatacgttgcagataaaaccggcaacgtatgt
+caacaagttttggcgatctcgttgtttgtattcgacgaggcgcgggaacttcaagaacta
+tcgtatattcaagtccattaccttttagtttcagactggtggagctgactaaagttatat
+catcattttgtacactggtttagttaacgataatttcagatttaacatgaccagacgata
+atcgctgtatatccagttggaatgtggtttgccagaaaggttaacttataatcaagcctc
+tcttcagtcttgattcgtcgtatcccatccattgcgctatacctcagtgtatttggagct
+gtagttataccgtgtgctaagatcagtagacatgacgagagcaatattatctaccttaca
+agcatcaacggacgtctagtcggaacaaaagactctaaaactcgaacttcaggttaatat
+actatagttctgtattcagcagttattcttatattcgatattatcttgcctattggatgt
+ctgactttagtatattaatcatagtatctgccatgtaaaggtgccagtactaaatctgtt
+tcacagtgcgaattataaacggttacaaccattaaagacaacaagaccctatagctttat
+ttgaattttgtcaatgcgcaacttggagctcgcgatacatcccaattagtctatagggtc
+gggacgattctacggcatttctggttataatgacaacatggattgtggcccgagaatcgc
+tctttcattaattaagcaatcattacagtcttataagcgctacttccgagtggtagcagg
+taactcgatataaggtcgcatgagccgaatagcttaaaaaacaggccaccgaacattgat
+agagaataccgaccacagcgcaacctttgattactttcattaaattgtacggctcactcg
+acatcaagcttaagattgcgataatgtgaactcaaatggatcagtactgaagaaccgtaa
+cccacttcgcagaaagcgtacccagagaagatacgctgttacaatatacagggtgaaatt
+attgcctgttcttcgtaaccatttcgccaaacttggttagaaatgatagccattcatgat
+agaaataagctgaatgataccagtatctttaactatgtagtcagggggaagataacgatg
+gtccatgtatgtttctgatatgtgacagtattggccgcgtaatttgctaacgaagctact
+taatgcctttgagcttcatatagatttctttaatcaaaatcggcaaaaagatagtatgag
+ctataatatatgctagtagagaactctggaccatcatctatatgaatactgattcgagcg
+tgcaattactttagcctgcgtactactgactctacaaaacactctgagataagtttgtag
+tcagtaagtcgctctctataaaccttttggatgaccattgtacagccacttatagatccc
+aataaatagcacaggagacagagtttttcaatgctcgatcatttgccgatagtattttcg
+tctaacctcagggcacctattatttgatacctaacctaacggccctttcacaatggagaa
+atatatgacatcgggacaaacacaaatggtgggtggccaggagatatgacatggtggcgt
+ctctaagaaacacggactccctctaggcaaactcacgtaaccaattttaatgtcaaacaa
+aacgctcgaaaagattttgccgtgtaatgacctggtacattgactggtcaggaatacatc
+actgtagttgccgtagtgtcctgttggtgttccatcaagacacatcgtataacgcaattt
+acgacggacatcagatcaagttatacagattatttaagtatcacgtgtgcattgggacat
+aagggatctcacacatgccttggaacatttttgctttgtgccgctttttcgctgcactac
+caatccttacttaccagtatattcaaaggtcgttaacagaatgagaaaggttagggctct
+aagttatcgtcgattgggatagacgagacatttgcgagcgccctccacggatacgaatct
+cccatatcaatgtgaactggatgctatgcagtttagttcttacgtctcctagtggtaaaa
+atcaaagtagcactcgcatagcagttattcagaacctaatacacaaaaccgtcaaacatt
+ttctaattctaggtatgggccgatcataggagctaaggtgaaactcataaatgttttgtt
+agatctagcatcctaaaaagatgcatatactgagtagctggcgtgcattctctcaattgt
+atcctttttaactgaactagtcggtcccatttcgtgactgagatctattaaccgataaga
+ttaataacactcgcattcgtatcagctcagagtgaagtttttcaataatttgactgatat
+attaacttctaaaataaccctttaagcctcggatccgtttcccaatcacatcaaaaattc
+ttattccaactatctacggattaacaacgtgcatggggatcgtagtaagaacttgttccg
+atcactttgagtatatcaagttgacggcccggttattattgaatagaaacattcacctgc
+taaattaaataccgcacatcggatacccgatttcagagggccgtcttactaagggcaggc
+tttgttcggtttaactgagatgttcattattttacagtatgcttcaactaatatgtaacg
+aaggacagtggatctgtctccatagtagatcttcagtcgtgaatttcataccgctcctat
+ttaagttcgcgttcgagttgttgatcatggcacgtgaaagcaacccctagtattctagac
+gaaaattttttctagttcatctgataatttgccaattcaaaaacaaccgctggtttcccg
+gcgcattctctaaaatggaagtcgaacctagagccattatttgtcggtaacccatgagtt
+ccttcttttcagaagttaatacactgtggtcctatacagaggaaaaacagcggttatata
+cgatcgtggcataacaacattggatcaagatagcaatttggctacctattctaattctca
+ctagattcggtattccactacaatatcggcagattaggattggatgaataatcggtgttt
+aagtccggttgcgtctccaatctcctaatttttattaatattgatcttggtgacctattg
+taaataaaaacttcaagactttgaataacggtgaaaagatagaagactcatttgaaaatg
+gatcatccacagatccaaacattagcaagacactaatccccaactagctattctgatcgc
+gatcgtgctgcagtactcctgtcacaatagtctgttcatgatctaattctttttgggctt
+tgttcgatggtgattcagaatctttatccggtcgcttccctgtagctactttgtggggat
+attgcccggggattatagggttgagatcgtttcctaaaagtatttaaaccaagtagactt
+caactaaactacatcagaacatcgtgaagacaccatacgcggtacctttatttaccgata
+acatttcttcaagaaataccggtaagcagcataatgaccctaaacagctcggggtatcgt
+cgtagttttaaattttatttaggttactgctcaaggaataaaaactaactatttaattta
+taataatattacaaggctcacactgattagatttgtctataagacttcgcgatcccccat
+taccggattgtcttaagaataaactagataaaccatgcattttctagataaggcctttag
+tctaattagatacaaaaaacacgatagttgcatccttaatttattgtgtcaaacctggaa
+ccttttaattacccgcaaatcactttatgtcgagactacctctgaaatttattatctacc
+taccgcatgaggacttgaaccatcttgtaggagttatgtttattagctaagattcgttta
+tcctgtagcggtccatgtatattcaacaagcaaaaagcactcagaattgtttttagttga
+gtcaagactgatatataaataagtttccctagttttttcgtggtgggacgatattgaatt
+gaatcttaaccgaagagtttcccactctgtcgcacaataatacacgccaatatttccagc
+cctgcttatgccttaatcggttactcaatctcccattgaagttcattttgatctgcatag
+aagtttcgggcccagccttttttctgccaccttcctccaagctctgtagacgcactctaa
+gattgatgctcacatgtattaattctacattaacataaatatataagtcatgcatcttcg
+agtaaaatatctggttctccaacatgtcctggcacgtatcgttataatgcccatacatgt
+agtattaaaatgattgggttaactggatattaagatcatcgaaattgtaaagtcaaatta
+acaatactgtctcaagaccgtgtattcctcgtgctcggaagggctattacgcttacttcc
+gttttggtatcttaatatgactttcaaaaattaagttgcagtgagtcctacctgcgtgca
+tcggttagcaagagtataaaagttgtttaaacgaactacttgctttacaataccggtcgt
+atatatcgccgtgaatccagaagattgtcttctttggattatcaaccgagatcctgtgga
+ccgatgttttgggaccttcacagaggactccaggtagagctcgcttttgcattaatctaa
+gaattgtacctctctaaaagatctaaaacagtgaatgtgtatttcatggaaaaacacaga
+gaaacgtaaattactttaggccgaaaggcacatgagttattatacatatacgagatggtg
+gtatacatcgaattcggggcatacactatagttgcattgtatttagctgctttaaataat
+atgatattaccttccttacataagacattaccggcataccctggttttcaacttgtgggg
+ctttttgacgatcgcactctcatttgatccgagtagggcggtgacccctgcttttcaaat
+acaaaaatttcgctatgaaggtaatagattacttttcgctgttatgatagaaacggtaaa
+tttaaaattgaaacttctagaaaagtaaagtaacgagaaatgattttgtgaataatgcgg
+tcatgattgcgcaagtaagaaaaaaaggcaaaaggatgcgcggaatagaaacttatcagt
+cacgggtatcttgatttcattcttcttgtcaattgccgacataggatgaaatcagattcc
+aatgcaatacacagtaacccccacccttgattgtaatgtcgatttgaagttgtacgcgtc
+gacgaagtggatagtatacgggccttttgtacggtgcgatcaactatgaatctcggcgag
+ttagatggtcgtacaatctcacacatagaggtcacttgcctgtaatgacgaattttcggc
+taggtactcgaactttattagaagtaaaaatgtgggcaaaagaaggattccattttacaa
+gacgattacaatgagttacatgtctctcaacgtagtctttccctagtagtctttgaacta
+tttaggtactccagaaaattttagcaaagggtttctgtgtgaatccgccattcatgttta
+tgatggaacaataagaataacgccctcgtatgttatcgacagtgaagtcagcagttcggc
+caaaaacatattcaatttagtacagatccccagaagttaagctaagtgctctaaaatggc
+ctaaacggttatcaaagtaggtctaattactatactaacgggtgcatcgtaataactgct
+gtcgatgcaacactatatgatagtgtcgttttgctatatatgtacaatgtgacaaagaag
+ccttagcgattcttgcaaacttaggacttcggattctcaatcttaaatgtccgaaaacgc
+aaagattcaaaaatttaatctatgagcagatatgcctgatggtgactacgcgtatgttaa
+ggctaaatgttgacaaccgcacacataatcgaactattgatagtcgggagcataaccagg
+tgaacgtactttgttcacgacatttattgacatgttctaaatacgtctcaaaatcacggc
+gcactagaaaacgcaatcaaatcattgtcctggtttaagggccgtaatgccggtagtgtc
+aaacttcatgagaactttagctggcttttggccagtatttagggaccaagagcactagcc
+ttaagctgaatattttgccatttatctactgttataactttaaaacttggtggcaccaga
+cttgtcgatacacacgcatcaatctgtaacgtaaaaggtttactaagaacaagcgtagga
+attgagtttatattatatttaaactaaaagatgatattagcttctgagggcgatagggct
+ccaaatcataaagaggaatatattattacacgattagaaacccacaacatacctcgaatc
+gcccaaaagtttgacgaaacttggcagtactccacatctcagtaatacagttgggagagt
+ctcaaatgttgttttattactcaatgaaccaccctcataatttcactgctgttccattaa
+atttgcaaacgatcatttgctttgaagaaacgtaaaatcgacaaaattacagataagtag
+atgcataataaaaaaaactgctcgctataacacgatcatcgtgcattcttacttaggagc
+atcacccgcacaataacgtaccttaaactacaacactattagaccgagtactgtaattca
+cgaaagctcaagctcgcattgtaaagaacttgctctctcgtaaaatgtgataatagtttg
+cggagaggattcaattattttccattgcacctactccactagattcgataaaagaaggtg
+gtcctcccttaaaaagaaatgttaagtaacatcggaaccataagcaaagcatgtaagtga
+accgtcatccttccctaagaaacataaaggtttttaataatgtcgactgtgaactataac
+tgcatcctttcctgacctactccggttccttgttgttatttctgaacgagaccagtagat
+aaacaatgtaaaccacagtgggtaccaatggtgcatgtgacgctaccgttgttttaagtg
+cccgtacaaacataagaagtcataatcttacttgaaattaattttgccttttattttttt
+tcaggctcgaaattaatgatttgttttttttgaccttctagttacgctaatatgcggtcg
+cctgtggtttctattgagtcctataacgggatgggatctaatacgtttggttactagtaa
+acaaggtataaatttgataccggagtatcaactgtataacatcaagctttatgactcata
+cgcgaagtaatgacacaaggctttcaggagatcgcgagtacagagccactaaggggtgta
+ttacgatagtgacaccaccgagcgcactcactccccaagtagatttatgatcctacgcta
+agtattagatatataaccaaagaggttctagtcagtgcaactcttagaataataattagc
+cggttttgcctttttaggcctaatgcaatattcagctagcccttatgtatctcgcgttcc
+acagcaccactcatggcacgcgtttaaactaatcaaatataatctatgaatgttatgcca
+gtacttgaataaatcaggttttttataagtccttgcatactctcgttatatactgttaga
+gtcttaccccatagaaattctttcatctgcaaacttagaagaattctcagctacggggag
+cataaagtccccaggatgttgacaaatacaacaaatgtggcttatacaaacactccatat
+gaaaatcgaaccctcgtggtagttttagccgaaccttgtacggataaatccctccatttt
+ccaatagcagatacctatcctactacctcgtggtattaaattaaagcttgaaatatagag
+ctgcatagcttatccaattcccaagcacgagtctaccgtcgtaaccacgatttgatttac
+agacgctagagcaaacccatctttaaacatataagtaaaaattaaagggtgagtgcgtac
+gtgtttactagcaacttcgcttattaagacaattgtttataagccataattaaaaacata
+tgttcaacaggttcattgatatttgtaattgcacaggtttttaataaggatctacgtaag
+tataatgaacaaactttttaccagagttatattctgtactttgaaaatgctcctctaccg
+ccttagagactttcaattagattttttgcagttaatctatgcgtaagtgaaccatgcaag
+ggatgcgattcaaccgcctcgtgctaaccctatcgtctgtctcataactgtaggtctaat
+ataattttcagttttcgaacacataaccctttgaaaatctgctatttaatgtctcacctg
+catgcactatcttctatactgctcagaacggctatacgtcactatgctccaagtgacgat
+ttaaacgaagcaaggaataataggtttattttagtgcaaaacaattaagtgcggactacg
+tgctctttacaataagccttgtgattgggctataggttaagtcccatattaacgatctcc
+aatgtacaaaatcgacaatcgctttgcattacccggttactagtcgaattacagatagct
+gttagatactcactctaattttggacaacaatcccaatcttggggtcgtctatcgcctga
+agctcgtaaatccttccatcttaaacgattacatattatagacttgttcggggtagagat
+atcacagttgtgcaaacattgtaaatcgatactagtttatgttggtagtctagttgcttt
+taccattccccgaaaaacttgatctactatttcgacaacagtaaacttgaactaggtaag
+tgaaaacagagaatgcctcatagtgccactatttgtccactatatgtaagtgtagcttta
+cataatccactatgactgagatcattacggcctaggaaagcagcgtagaaaaaaagggcc
+cggatattacgactgtaactataaaactagttactggtagcgcgccatgtatagatttgt
+tttaccggttgtggttgcgttaacgaatttcagccgcgaaaattgatccgttaaccagtc
+catctcgacttctataaaacgataaagtaaagttgatgttcagcctccttcttatggttg
+catcgagagtacactactcagtgggaaatagatcggggttcctacttcagattgtattat
+ctaggcaattgccgattgtgccatacctggataaaataagctacctacatgtgatgctta
+tctattatcgtcatactaccttagggtgtcctgttgaacgctacattaatctttagccgt
+ttgagatgttccaatggataggagtctaacgcatgatgaagtttaggaaggcagagcatc
+ccactaagtatgtgacagtgtatttcgaaacgagacgttataaatagaaaaaaggtcctt
+ctggttctattctgctgaactattgaatggaaagattggttgacctacgtactatttgct
+tgaagtcatcaatttgacggggtgagagacatatggtgcatactttacggactctatatt
+ttagatcagaagcttagcagtcttctctacaccccctcacgacataattgcttttaagaa
+tctatgtttgattcctctacgggaattcggatccgttcgcatgtgcggtttatctaaacc
+aggggacatatgttcagctaaagcatacgaacactttgctaactagacgtatgtatagta
+gctataaatcccgacgatatttacaaaaagaaatgagactcaaatatatacatagcgacc
+ctacacttattcgcaccctgatctaggcgatcctagcacccacacccgaaagtgagcact
+agtgtcttccgtattaaatttactgcagttgagattttagttgtctactaaggattactc
+taacccgtaataaggatcaagactcggtactagctttactatcattccctatgtgttttc
+ctaactcacaagggtacgtaccagcctatgtaattacaataatgataaagacacaaagga
+agtaactttacaaatgagtctccagttacactagcttagtccctcccatcttgctttgaa
+gtctaaatacgcaatctctgaggatatacagcagaagaacactcataacgttggagtcca
+agaattagactcatagggcccccaacatttaatatgtactgtgagtttgaaggtgttcta
+ttgttaattcctgctcttgatacatgacacgtactccgtgtttaaggcttcggactgact
+ttctttcataagttgagcaacgaaaatttcagaatcgataagttggattcactaactaat
+acggctgattgaaaactccactccggacctatatggtcgacctttatacgtaaccgatat
+aaaacttataggctggtatatcgagccttcctagcgcaatttcggatggggtttcttcta
+ctactcaacaacggaatagtctttgtttagtaaaccagagctcaggacgcccaatacgta
+ggagagcgctgtggagcatgtgtcattatggactggagcactcttaaatcactctgcgtg
+tgctaaacgatagatcataacatgtcctgagtaaattttcttgatacgtcgcaatatacc
+gttattagttaaacgttctcatccgtcatgcgtgaaatacggctgtcgtgctcagatata
+ctattagcgactcatctcgcctaacacgcacacgtataaactcggaatgactgccgctct
+tacatattagaaatacagactacaccacggaagcattgggtcattctcaaccgctgtata
+aaagatgattagtcttataataagattaccaaagaggcagaatcatgggtagtaaatcta
+ttattcaagtgattaccgtcgtgtaggcagggagtgaggacgagatggtactcaggacaa
+atattaaccggacgaagtggtttacgtcgtactttcactattagtagtaaatacaaggta
+acaccggggaatagtactaaatataatgatatctatcttcgggagaacgagtcgtctatt
+gctttgaacattctcaaggcgtaaaatgtgctgacttatagcatgatacaaccgattgtt
+acttttgtctattcaaaagattgaatagttttttatacaaaagccgcatacttatgacgg
+ctagtatacagtttcatcccctagcatcaatgctatggacagtattgaacttataggaaa
+ttcttctaatagggcaaatccgtcgtgatgcctattttttttcagtcacatcctcaaatg
+gcactagtattgtcgggatcccattaacaggctcaaccacgagctcacgcgaggacatgt
+agtccgtatctttaacgaagcgacagcgacagaactcccatggataaccaattataaggc
+ccgtaatcctctagacatcgtttaccaataaatccgctttctccgtaatcatgttgaata
+ccccagagtagtccagatgataaccgatgaaacacaagtctttctcaatgcacttacggt
+gaacttattaccgccaacgtagctcatcaaggttgcgacatctagttgtgtgtttgcgac
+gagcccagcgaacttcatcaactttcgtatattcaacgccttgtaattttactttaagac
+gcctggtgatgtagattcttagataatcagtttgttatcggctgtactttaccataattt
+cacaggtttcaggtcaagaagattatagctgtatatacagttccatgctcggtgcacaga
+aacgtgatcggataataatcaatcgcttatgtcgtctttaggcgtatccaatacatgccc
+cgataccgcagtgtatttcgacatgtaggtataccgtcgcatttgagctcgagtcaggac
+gtcagctagattagattccttaatagaatataccgacctctagtccgaactaaactatag
+ataacgccaacttcaggttaattgtctagtcgtctgtttgcagatgggattcttagatga
+gtgagtatcggccatattggttcgagcactttagtttttgatgcataggatatgcaatgt
+atagctgaaagtactttatctgtttcaaactcacattgattaaaccggtaaacctttaaa
+gactacaagaaaatattcagtgagggcaattttgtcaatcacaatcttccagctagagat
+acttcacaatttgtcttgaggctacgcaacattagacggattttcgcgttttattgaaat
+aatcgaggggcccaagagtatccatagttcattttgtaagatttctttacaggcttatta
+cagcttcttcagactcctacatgcttacgagttatatgctagcatgtgaacaatagatta
+atatacaggaaaacgtacattgagagagatgaccctacacagcgcaaccgttgagtactt
+tcattaaagggtaacgctctcgagacagcatccttaagatggccttattgtcaaatcatt
+tgcagaagtacgcaagatccctaaccaacgtagaagaatccctacaaacacatgagacgc
+ggtgaaaatagacagggtgttagtattcaatcttcggagtatcaatttcgccaatcttgg
+tgagaaagcataccctttcttcagagaaagaagatcaatcataacactatctttaacgag
+gtacgcacgcgcatcattacctgcctccatggatctttaggatagcggaaagtattggca
+gcgtattgtgatttcgttcctactttatcaatttcacattcatatacatgtcttttatca
+aaatcgccaataagataggatgagctatattagatgctagtagagttcgcgccaacatca
+tcgataggaatactcaggacagcgtgataggacttttcaatccctaatactctctataat
+tataactctctcttaagtttggaggcagtaacgcgctctatataatcagtttgctgcacc
+attcttcagcctctgatacatacaaataaattccacagcagtaagagggtttaattgaga
+catcttgggaacttaggattttactctaacatcaccgaaacgattattggataccgtacc
+taaacgaactttctcaaggcagtaatataggacatccgcaataacacaaatgctgcctcc
+ccaggagttatgtcttcctggaggctatatcttacacccactcactataggcaaactaaa
+gtttaaatgttgattgtctaaaaaaaagatagataagagttggccggcgtagcacatgcg
+aaagtgaatcgtaagctataattctctggacttgaagttctgtcctgttcctctgcaaga
+aacaaacttcctttaaagctatttacgacgcacatctcagcaagttataaacatgttgga
+agtttctagtcggaattcccaaagaacggatctatctaatgcattcctacatttttcctg
+tctgccgatggtgccatcctattcaaagaatttcttaaaagtagattaaatgggactttt
+aacaatgagtaaccttacgcctctaagggttcctcgagtgccatacaccagtcaggtccg
+agccacatacacggagaacattctaacatagcattctcaactcgatcatttgcaggttac
+ttctttcctatcctagtgctaaaaatcatacttgcaatcccatagcacggattaagaacc
+taagaaacaattcagtaaaacatgttcgaattcttggtatgggaacatcattgcagctat
+ggtctaacgcattaatgtttgggtacatcttccatcatataaacaggaagagtctgacga
+cagggagtgcttgcgatcatgtctatcattgtgaaatcaaattgtagctcacatgtcgtc
+tatgagagcgtgtatccgataagatttagaaaaatagaagtcgtataagatctcactgaa
+cttttgaatgaatgtgaagcatatatgatctgctttaataaaactttatccataggatac
+gtttccaaatcaattcaataattattagtcaaaatagataaggatgaacaacctgaaggc
+cgatcggacgtagaaagtggtcccatcactttgagttgatattgttgaaccacacgttat
+tatggttttcaaacagtctcaggatattgtatatacagataatccgataccagttgtctg
+acgcccctcttacgtaccccaccctttgtgacgtttaaagcagttgttcagtattttaaa
+ctaggcggcaactaatttggaaagaagcacagtggatatgtctaaattcttgttattcag
+gcctgaatttaatacaccgcatagttaacttcgcggtagagttgttcatcatgcctcctc
+taagctaccacttctatgatacaccaatagttgttctacggaatctgataattggccaag
+tcataaacttccgctgcgttcaacccccttgctcgaatatccaactcgaaaagacagcct
+tttggtgtccggaacaaatcagttacttcttttctgatgttaattctctgtggtcagata
+cagaccaaaaactccgcggatttaccatcctccaagaacaaatttgcatcaacatagcat
+tttggctacatattctaagtctcaatagtttaggttttcaactacattatcccaacatta
+ggattggaggaataatagctgggtaagtccccttgcgtctacaatcgactattttttatg
+aatatgcttctgccgcacctatggttattaaaaaagtcatgactttgaagaaccctgaaa
+agatagatgaatcaggtgtaatggcagcagccaaagagcatataattagcaacactctaa
+gaacattatagatatgatgatagcgatcgtcatgatgttatccggtcacaatagtagctt
+catcagctaattcgttttgccagtggtgacttgcgctggaagaatcgttatacggtccct
+tccctcttgatacggtgggggcttattcaaccgcgtggattgggttgtcatacttgcatt
+aaacgatgtaaaccatctagtagtcaactatactaaatcacaaaatagtgatcaatacat
+acccgcttcatggttttaaccatttaattgattaaagatattccgctaagaaccattatc
+tacctaaactgatcgccgtatcctagtagtttgaaatttgatgtaccgtaatgatcaacg
+aagtaaaacgttatattgtatgtagaataataggtcttggagctaaatgatgtgattggt
+agtgaagacttacccttacaactttaccggtttctcggaagaatatactagagaatcaat
+gcatgggctacataagcactttagtctaatgagataaaaaatacacgagtcttccatcat
+gaattttttgtcgaaaaactcgaacctggtaatttaaaccatatatctttatgtcgtcaa
+taactctcatatgttttatataacttcccaatcacgacttgtaactgcttgttcgactga
+gctgtttgagctatgaggccgggatccggttgagctacatctatttgctacaagaaaaat
+gaaagcacatttgttgggagttctggctacactcatagagaaataagtggcccgagtggg
+tgcggcctgcctccatattcaagtgtatcttaaaccaagtggttccaacgctcgcgctaa
+agaattaaagcctttatttcctccacggagtagcccgtaatccggttcgaaagagaccat
+tgaagttaattttcatatccagtgaagtttaggcacaagcatgtgttctgccacatgcct
+caaagcgctcttcaaccaagatatgattcatcctaacttcgatgaatgcgtctgtaacat
+aaatatagaaggaatgattcggcgagttaattttcgccttctccaacatggcatccctac
+gttcgttataaggaccatacatgtaggttttaaaggtttgcggttaatcgatatttacat
+catagaaattctatagtcaaatttacaagactctagatactcactcgttgcagccggcta
+ggaagcgctttgtaccttacttcccttttcgttgcgtaatatgaatttcatatagtaagt
+tcaaggcactcatacctccgtgaagagggtagatagactattaaagttgtttaatagtac
+gtattgatggaaatgacccgtaggagatttaccactcaatccacaagattcgctgctgtg
+cattatcaaaacagtgcatgtcgaaacatgggttgggtccttcaaacacgaatccaggta
+gagatacctttgcaattttt
--- /dev/null
+agggtaaa|tttaccct 0
+[cgt]gggtaaa|tttaccc[acg] 3
+a[act]ggtaaa|tttacc[agt]t 9
+ag[act]gtaaa|tttac[agt]ct 8
+agg[act]taaa|ttta[agt]cct 10
+aggg[acg]aaa|ttt[cgt]ccct 3
+agggt[cgt]aa|tt[acg]accct 4
+agggta[cgt]a|t[acg]taccct 3
+agggtaa[cgt]|[acg]ttaccct 5
+
+101745
+100000
+133640
--- /dev/null
+USING: benchmark.regex-dna io io.files io.encodings.ascii
+io.streams.string kernel tools.test ;
+IN: benchmark.regex-dna.tests
+
+[ t ] [
+ "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt"
+ [ regex-dna ] with-string-writer
+ "resource:extra/benchmark/regex-dna/regex-dna-test-out.txt"
+ ascii file-contents =
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors regexp prettyprint io io.encodings.ascii
+io.files kernel sequences assocs namespaces ;
+IN: benchmark.regex-dna
+
+! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1
+
+: strip-line-breaks ( string -- string' )
+ R/ >.*\n|\n/ "" re-replace ;
+
+: count-patterns ( string -- )
+ {
+ R/ agggtaaa|tttaccct/i,
+ R/ [cgt]gggtaaa|tttaccc[acg]/i,
+ R/ a[act]ggtaaa|tttacc[agt]t/i,
+ R/ ag[act]gtaaa|tttac[agt]ct/i,
+ R/ agg[act]taaa|ttta[agt]cct/i,
+ R/ aggg[acg]aaa|ttt[cgt]ccct/i,
+ R/ agggt[cgt]aa|tt[acg]accct/i,
+ R/ agggta[cgt]a|t[acg]taccct/i,
+ R/ agggtaa[cgt]|[acg]ttaccct/i
+ } [
+ [ raw>> write bl ]
+ [ count-matches . ]
+ bi
+ ] with each ;
+
+: do-replacements ( string -- string' )
+ {
+ { R/ B/ "(c|g|t)" }
+ { R/ D/ "(a|g|t)" }
+ { R/ H/ "(a|c|t)" }
+ { R/ K/ "(g|t)" }
+ { R/ M/ "(a|c)" }
+ { R/ N/ "(a|c|g|t)" }
+ { R/ R/ "(a|g)" }
+ { R/ S/ "(c|t)" }
+ { R/ V/ "(a|c|g)" }
+ { R/ W/ "(a|t)" }
+ { R/ Y/ "(c|t)" }
+ } [ re-replace ] assoc-each ;
+
+SYMBOL: ilen
+SYMBOL: clen
+
+: regex-dna ( file -- )
+ ascii file-contents dup length ilen set
+ strip-line-breaks dup length clen set
+ dup count-patterns
+ do-replacements
+ nl
+ ilen get .
+ clen get .
+ length . ;
+
+: regex-dna-main ( -- )
+ "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" regex-dna ;
+
+MAIN: regex-dna-main
USING: tools.deploy.config ;
H{
- { deploy-word-props? f }
- { deploy-random? f }
- { deploy-compiler? f }
{ deploy-c-types? f }
- { deploy-ui? f }
- { deploy-reflection 1 }
+ { deploy-name "Hello world (console)" }
{ deploy-threads? f }
+ { deploy-word-props? f }
+ { deploy-reflection 2 }
+ { deploy-random? f }
{ deploy-io 2 }
- { deploy-word-defs? f }
- { "stop-after-last-window?" t }
- { deploy-name "Hello world (console)" }
{ deploy-math? f }
+ { deploy-ui? f }
+ { deploy-compiler? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-defs? f }
}
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle unicode.case namespaces make
-splitting http sequences.lib accessors io combinators
-http.client urls ;
+splitting http accessors io combinators http.client urls
+urls.encoding fry sequences.lib ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
: scrape-html ( url -- vector )
http-get nip parse-html ;
-: (find-relative)
- [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline
+: find-all ( seq quot -- alist )
+ [ <enum> >alist ] [ '[ second @ ] ] bi* filter ; inline
-: find-relative ( seq quot n -- i elt )
- >r over [ find drop ] dip r> swap pick
- (find-relative) ; inline
+: find-nth ( seq quot n -- i elt )
+ [ <enum> >alist ] 2dip -rot
+ '[ _ [ second @ ] find-from rot drop swap 1+ ]
+ [ f 0 ] 2dip times drop first2 ; inline
-: (find-all) ( n seq quot -- )
- 2dup >r >r find-from [
- dupd 2array , 1+ r> r> (find-all)
- ] [
- r> r> 3drop
- ] if* ; inline
+: find-first-name ( str vector -- i/f tag/f )
+ [ >lower ] dip [ name>> = ] with find ; inline
-: find-all ( seq quot -- alist )
- [ 0 -rot (find-all) ] { } make ; inline
-
-: (find-nth) ( offset seq quot n count -- obj )
- >r >r [ find-from ] 2keep 4 npick [
- r> r> 1+ 2dup <= [
- 4drop
- ] [
- >r >r >r >r drop 1+ r> r> r> r>
- (find-nth)
- ] if
+: find-matching-close ( str vector -- i/f tag/f )
+ [ >lower ] dip
+ [ [ name>> = ] [ closing?>> ] bi and ] with find ; inline
+
+: find-between* ( i/f tag/f vector -- vector )
+ pick integer? [
+ rot tail-slice
+ >r name>> r>
+ [ find-matching-close drop dup [ 1+ ] when ] keep
+ swap [ head ] [ first ] if*
] [
- 2drop r> r> 2drop
+ 3drop V{ } clone
] if ; inline
+
+: find-between ( i/f tag/f vector -- vector )
+ find-between* dup length 3 >= [
+ [ rest-slice but-last-slice ] keep like
+ ] when ; inline
-: find-nth ( seq quot n -- i elt )
- 0 -roll 0 (find-nth) ; inline
+: find-between-first ( string vector -- vector' )
+ [ find-first-name ] keep find-between ; inline
+
+: find-between-all ( vector quot -- seq )
+ [ [ [ closing?>> not ] bi and ] curry find-all ] curry
+ [ [ >r first2 r> find-between* ] curry map ] bi ; inline
-: find-nth-relative ( seq quot n offest -- i elt )
- >r [ find-nth ] 3keep 2drop nip r> swap pick
- (find-relative) ; inline
: remove-blank-text ( vector -- vector' )
[
- dup name>> text = [
- text>> [ blank? ] all? not
- ] [
- drop t
- ] if
+ dup name>> text =
+ [ text>> [ blank? ] all? not ] [ drop t ] if
] filter ;
: trim-text ( vector -- vector' )
[
- dup name>> text = [
- [ [ blank? ] trim ] change-text
- ] when
+ dup name>> text =
+ [ [ [ blank? ] trim ] change-text ] when
] map ;
: find-by-id ( id vector -- vector )
[ attributes>> "class" swap at = ] with filter ;
: find-by-name ( str vector -- vector )
- >r >lower r>
- [ name>> = ] with filter ;
-
-: find-first-name ( str vector -- i/f tag/f )
- >r >lower r>
- [ name>> = ] with find ;
-
-: find-matching-close ( str vector -- i/f tag/f )
- >r >lower r>
- [ [ name>> = ] keep closing?>> and ] with find ;
+ [ >lower ] dip [ name>> = ] with filter ;
: find-by-attribute-key ( key vector -- vector )
- >r >lower r>
+ [ >lower ] dip
[ attributes>> at ] with filter
sift ;
: find-by-attribute-key-value ( value key vector -- vector )
- >r >lower r>
+ [ >lower ] dip
[ attributes>> at over = ] with filter nip
sift ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
- >r >lower r>
+ [ >lower ] dip
[ attributes>> at over = ] with find rot drop ;
-: find-between* ( i/f tag/f vector -- vector )
- pick integer? [
- rot tail-slice
- >r name>> r>
- [ find-matching-close drop dup [ 1+ ] when ] keep
- swap [ head ] [ first ] if*
- ] [
- 3drop V{ } clone
- ] if ;
-
-: find-between ( i/f tag/f vector -- vector )
- find-between* dup length 3 >= [
- [ rest-slice but-last-slice ] keep like
- ] when ;
-
-: find-between-first ( string vector -- vector' )
- [ find-first-name ] keep find-between ;
-
-: find-between-all ( vector quot -- seq )
- [ [ [ closing?>> not ] bi and ] curry find-all ] curry
- [ [ >r first2 r> find-between* ] curry map ] bi ;
-
: tag-link ( tag -- link/f )
attributes>> [ "href" swap at ] [ f ] if* ;
[ dup name>> text = ] prepose find drop ;
: find-opening-tags-by-name ( name seq -- seq )
- [ [ name>> = ] keep closing?>> not and ] with find-all ;
+ [ [ name>> = ] [ closing?>> not ] bi and ] with find-all ;
: href-contains? ( str tag -- ? )
attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ;
: find-html-objects ( string vector -- vector' )
[ find-opening-tags-by-name ] keep
- [ >r first2 r> find-between* ] curry map ;
+ [ [ first2 ] dip find-between* ] curry map ;
: form-action ( vector -- string )
[ name>> "form" = ] find nip
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays html.parser.utils hashtables io kernel
namespaces make prettyprint quotations sequences splitting
-state-parser strings unicode.categories unicode.case
-sequences.lib ;
+state-parser strings unicode.categories unicode.case ;
IN: html.parser
TUPLE: tag name attributes text closing? ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: assocs circular combinators continuations hashtables
-hashtables.private io kernel math
-namespaces prettyprint quotations sequences splitting
-state-parser strings sequences.lib ;
+hashtables.private io kernel math namespaces prettyprint
+quotations sequences splitting state-parser strings ;
IN: html.parser.utils
: string-parse-end? ( -- ? ) get-next not ;
[ [ last-line>> concat ] [ lines>> ] bi push ] keep
V{ } clone >>last-line drop ;
-: spawn-client ( lines listeners -- irc-client )
+: spawn-client ( -- irc-client )
"someserver" irc-port "factorbot" f <irc-profile>
<irc-client>
t >>is-running
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
+<PRIVATE
+: end-loops ( irc-client -- )
+ [ listeners>> values [ out-messages>> ] map ]
+ [ in-messages>> ]
+ [ out-messages>> ] tri 2array prepend
+ [ irc-end swap mailbox-put ] each ;
+PRIVATE>
+
: terminate-irc ( irc-client -- )
[ is-running>> ] keep and [
- [ [ irc-end ] dip in-messages>> mailbox-put ]
- [ [ f ] dip (>>is-running) ]
- [ stream>> dispose ]
- tri
+ [ end-loops ] [ [ f ] dip (>>is-running) ] bi
] when* ;
<PRIVATE
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: listener> ( name -- listener/f ) irc> listeners>> at ;
-
-: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
- [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
+: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
+: me? ( string -- ? ) irc> profile>> nickname>> = ;
GENERIC: to-listener ( message obj -- )
swap dup listeners-with-participant [ rename-participant ] with with each ;
: add-participant ( mode nick channel -- )
- listener> [
- [ participants>> set-at ]
- [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
- ] [ 2drop ] if* ;
+ listener>
+ [ participants>> set-at ]
+ [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi ;
+
+: change-participant-mode ( channel mode nick -- )
+ rot listener>
+ [ participants>> set-at ]
+ [ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME
DEFER: me?
! Server message handling
! ======================================
-: me? ( string -- ? )
- irc> profile>> nickname>> = ;
-
GENERIC: forward-name ( irc-message -- name )
M: join forward-name ( join -- name ) trailing>> ;
M: part forward-name ( part -- name ) channel>> ;
M: kick forward-name ( kick -- name ) channel>> ;
-M: mode forward-name ( mode -- name ) channel>> ;
+M: mode forward-name ( mode -- name ) name>> ;
M: privmsg forward-name ( privmsg -- name )
dup name>> me? [ irc-message-sender ] [ name>> ] if ;
name>> "_" append /NICK ;
M: join process-message ( join -- )
- [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
+ [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
+ dup listener> [ add-participant ] [ 3drop ] if ;
M: part process-message ( part -- )
[ irc-message-sender ] [ channel>> ] bi remove-participant ;
M: nick process-message ( nick -- )
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
+! M: mode process-message ( mode -- )
+! [ channel-mode? ] keep and [
+! [ name>> ] [ mode>> ] [ parameter>> ] tri
+! [ change-participant-mode ] [ 2drop ] if*
+! ] when* ;
+
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
[ [ f f f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ;
-: handle-incoming-irc ( irc-message -- )
- [ forward-message ] [ process-message ] bi ;
-
! ======================================
! Client message handling
! ======================================
-: handle-outgoing-irc ( irc-message -- )
- irc-message>client-line irc-print ;
+GENERIC: handle-outgoing-irc ( irc-message -- ? )
+M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ;
+M: irc-message handle-outgoing-irc ( irc-message -- ? )
+ irc-message>client-line irc-print t ;
! ======================================
! Reader/Writer
: handle-disconnect ( error -- )
drop irc> is-running>> [ (handle-disconnect) ] when ;
-: (reader-loop) ( -- )
+: (reader-loop) ( -- ? )
irc> stream>> [
|dispose stream-readln [
- parse-irc-line handle-reader-message
+ parse-irc-line handle-reader-message t
] [
- irc> terminate-irc
+ irc> terminate-irc f
] if*
] with-destructors ;
: reader-loop ( -- ? )
- [ (reader-loop) ] [ handle-disconnect ] recover t ;
+ [ (reader-loop) ] [ handle-disconnect t ] recover ;
: writer-loop ( -- ? )
- irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;
+ irc> out-messages>> mailbox-get handle-outgoing-irc ;
! ======================================
! Processing loops
! ======================================
: in-multiplexer-loop ( -- ? )
- irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ;
+ irc> in-messages>> mailbox-get
+ [ forward-message ] [ process-message ] [ irc-end? not ] tri ;
: strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
[ nip ]
} cond ;
+GENERIC: handle-listener-out ( irc-message -- ? )
+M: irc-end handle-listener-out ( irc-end -- ? ) drop f ;
+M: irc-message handle-listener-out ( irc-message -- ? )
+ irc> out-messages>> mailbox-put t ;
+
: listener-loop ( name -- ? )
dup listener> [
- out-messages>> [ maybe-annotate-with-name
- irc> out-messages>> mailbox-put ] with
- maybe-mailbox-get t
+ out-messages>> mailbox-get
+ maybe-annotate-with-name handle-listener-out
] [ drop f ] if* ;
-: spawn-irc-loop ( quot: ( -- ? ) name -- )
- [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
- spawn-server drop ;
-
: spawn-irc ( -- )
- [ reader-loop ] "irc-reader-loop" spawn-irc-loop
- [ writer-loop ] "irc-writer-loop" spawn-irc-loop
- [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
+ [ reader-loop ] "irc-reader-loop" spawn-server
+ [ writer-loop ] "irc-writer-loop" spawn-server
+ [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
+ 3drop ;
! ======================================
! Listener join request handling
: set+run-listener ( name irc-listener -- )
over irc> listeners>> set-at
- '[ _ listener-loop ] "listener" spawn-irc-loop ;
+ '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ;
GENERIC: (add-listener) ( irc-listener -- )
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
-irc-message new
- ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
- "someuser!n=user@some.where" >>prefix
- "PRIVMSG" >>command
- { "#factortest" } >>parameters
- "hi" >>trailing
-1array
+{ T{ irc-message
+ { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
+ { prefix "someuser!n=user@some.where" }
+ { command "PRIVMSG" }
+ { parameters { "#factortest" } }
+ { trailing "hi" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
string>irc-message f >>timestamp ] unit-test
-privmsg new
- ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
- "someuser!n=user@some.where" >>prefix
- "PRIVMSG" >>command
- { "#factortest" } >>parameters
- "hi" >>trailing
- "#factortest" >>name
-1array
+{ T{ privmsg
+ { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
+ { prefix "someuser!n=user@some.where" }
+ { command "PRIVMSG" }
+ { parameters { "#factortest" } }
+ { trailing "hi" }
+ { name "#factortest" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line f >>timestamp ] unit-test
-join new
- ":someuser!n=user@some.where JOIN :#factortest" >>line
- "someuser!n=user@some.where" >>prefix
- "JOIN" >>command
- { } >>parameters
- "#factortest" >>trailing
-1array
+{ T{ join
+ { line ":someuser!n=user@some.where JOIN :#factortest" }
+ { prefix "someuser!n=user@some.where" }
+ { command "JOIN" }
+ { parameters { } }
+ { trailing "#factortest" } } }
[ ":someuser!n=user@some.where JOIN :#factortest"
parse-irc-line f >>timestamp ] unit-test
-mode new
- ":ircserver.net MODE #factortest +ns" >>line
- "ircserver.net" >>prefix
- "MODE" >>command
- { "#factortest" "+ns" } >>parameters
- "#factortest" >>channel
- "+ns" >>mode
-1array
+{ T{ mode
+ { line ":ircserver.net MODE #factortest +ns" }
+ { prefix "ircserver.net" }
+ { command "MODE" }
+ { parameters { "#factortest" "+ns" } }
+ { name "#factortest" }
+ { mode "+ns" } } }
[ ":ircserver.net MODE #factortest +ns"
parse-irc-line f >>timestamp ] unit-test
-nick new
- ":someuser!n=user@some.where NICK :someuser2" >>line
- "someuser!n=user@some.where" >>prefix
- "NICK" >>command
- { } >>parameters
- "someuser2" >>trailing
-1array
+{ T{ mode
+ { line ":ircserver.net MODE #factortest +o someuser" }
+ { prefix "ircserver.net" }
+ { command "MODE" }
+ { parameters { "#factortest" "+o" "someuser" } }
+ { name "#factortest" }
+ { mode "+o" }
+ { parameter "someuser" } } }
+[ ":ircserver.net MODE #factortest +o someuser"
+ parse-irc-line f >>timestamp ] unit-test
+
+{ T{ nick
+ { line ":someuser!n=user@some.where NICK :someuser2" }
+ { prefix "someuser!n=user@some.where" }
+ { command "NICK" }
+ { parameters { } }
+ { trailing "someuser2" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
parse-irc-line f >>timestamp ] unit-test
\ No newline at end of file
! Copyright (C) 2008 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators qualified
- arrays classes.tuple math.order quotations ;
+ arrays classes.tuple math.order ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
+EXCLUDE: inverse => _ ;
IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: roomlist < irc-message channel names ;
TUPLE: nick-in-use < irc-message asterisk name ;
TUPLE: notice < irc-message type ;
-TUPLE: mode < irc-message channel mode ;
-TUPLE: names-reply < irc-message who = channel ;
+TUPLE: mode < irc-message name mode parameter ;
+TUPLE: names-reply < irc-message who channel ;
TUPLE: unhandled < irc-message ;
: <irc-client-message> ( command parameters trailing -- irc-message )
<PRIVATE
-GENERIC: irc-command-string ( irc-message -- string )
-
-M: irc-message irc-command-string ( irc-message -- string ) command>> ;
-M: ping irc-command-string ( ping -- string ) drop "PING" ;
-M: join irc-command-string ( join -- string ) drop "JOIN" ;
-M: part irc-command-string ( part -- string ) drop "PART" ;
-M: quit irc-command-string ( quit -- string ) drop "QUIT" ;
-M: nick irc-command-string ( nick -- string ) drop "NICK" ;
-M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ;
-M: notice irc-command-string ( notice -- string ) drop "NOTICE" ;
-M: mode irc-command-string ( mode -- string ) drop "MODE" ;
-M: kick irc-command-string ( kick -- string ) drop "KICK" ;
-
-GENERIC: irc-command-parameters ( irc-message -- seq )
-
-M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ;
-M: ping irc-command-parameters ( ping -- seq ) drop { } ;
-M: join irc-command-parameters ( join -- seq ) drop { } ;
-M: part irc-command-parameters ( part -- seq ) channel>> 1array ;
-M: quit irc-command-parameters ( quit -- seq ) drop { } ;
-M: nick irc-command-parameters ( nick -- seq ) drop { } ;
-M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ;
-M: notice irc-command-parameters ( norice -- seq ) type>> 1array ;
-M: kick irc-command-parameters ( kick -- seq )
+GENERIC: command-string>> ( irc-message -- string )
+
+M: irc-message command-string>> ( irc-message -- string ) command>> ;
+M: ping command-string>> ( ping -- string ) drop "PING" ;
+M: join command-string>> ( join -- string ) drop "JOIN" ;
+M: part command-string>> ( part -- string ) drop "PART" ;
+M: quit command-string>> ( quit -- string ) drop "QUIT" ;
+M: nick command-string>> ( nick -- string ) drop "NICK" ;
+M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
+M: notice command-string>> ( notice -- string ) drop "NOTICE" ;
+M: mode command-string>> ( mode -- string ) drop "MODE" ;
+M: kick command-string>> ( kick -- string ) drop "KICK" ;
+
+GENERIC: command-parameters>> ( irc-message -- seq )
+
+M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
+M: ping command-parameters>> ( ping -- seq ) drop { } ;
+M: join command-parameters>> ( join -- seq ) drop { } ;
+M: part command-parameters>> ( part -- seq ) channel>> 1array ;
+M: quit command-parameters>> ( quit -- seq ) drop { } ;
+M: nick command-parameters>> ( nick -- seq ) drop { } ;
+M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ;
+M: notice command-parameters>> ( norice -- seq ) type>> 1array ;
+M: kick command-parameters>> ( kick -- seq )
[ channel>> ] [ who>> ] bi 2array ;
-M: mode irc-command-parameters ( mode -- seq )
+M: mode command-parameters>> ( mode -- seq )
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
+GENERIC: (>>command-parameters) ( params irc-message -- )
+
+M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ;
+M: logged-in (>>command-parameters) ( params part -- ) [ first ] dip (>>name) ;
+M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ;
+M: notice (>>command-parameters) ( params notice -- ) [ first ] dip (>>type) ;
+M: part (>>command-parameters) ( params part -- )
+ [ first ] dip (>>channel) ;
+M: kick (>>command-parameters) ( params kick -- )
+ [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ;
+M: names-reply (>>command-parameters) ( params names-reply -- )
+ [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
+M: mode (>>command-parameters) ( params mode -- )
+ { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] }
+ { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
+ } switch ;
+
PRIVATE>
GENERIC: irc-message>client-line ( irc-message -- string )
M: irc-message irc-message>client-line ( irc-message -- string )
- [ irc-command-string ]
- [ irc-command-parameters " " sjoin ]
+ [ command-string>> ]
+ [ command-parameters>> " " sjoin ]
[ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
tri 3array " " sjoin ;
! ======================================
: split-at-first ( seq separators -- before after )
- dupd '[ _ member? ] find
- [ cut 1 tail ]
- [ swap ]
- if ;
+ dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
: split-trailing ( string -- string string/f )
":" split1 ;
+: copy-message-in ( origin dest -- )
+ { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ]
+ [ [ line>> ] dip (>>line) ]
+ [ [ prefix>> ] dip (>>prefix) ]
+ [ [ command>> ] dip (>>command) ]
+ [ [ trailing>> ] dip (>>trailing) ]
+ [ [ timestamp>> ] dip (>>timestamp) ]
+ } 2cleave ;
+
PRIVATE>
UNION: sender-in-prefix privmsg join part quit kick mode nick ;
: parse-irc-line ( string -- message )
string>irc-message
dup command>> {
- { "PING" [ ping ] }
- { "NOTICE" [ notice ] }
- { "001" [ logged-in ] }
- { "433" [ nick-in-use ] }
- { "353" [ names-reply ] }
- { "JOIN" [ join ] }
- { "PART" [ part ] }
- { "NICK" [ nick ] }
+ { "PING" [ ping ] }
+ { "NOTICE" [ notice ] }
+ { "001" [ logged-in ] }
+ { "433" [ nick-in-use ] }
+ { "353" [ names-reply ] }
+ { "JOIN" [ join ] }
+ { "PART" [ part ] }
+ { "NICK" [ nick ] }
{ "PRIVMSG" [ privmsg ] }
- { "QUIT" [ quit ] }
- { "MODE" [ mode ] }
- { "KICK" [ kick ] }
+ { "QUIT" [ quit ] }
+ { "MODE" [ mode ] }
+ { "KICK" [ kick ] }
[ drop unhandled ]
- } case
- [ [ tuple-slots ] [ parameters>> ] bi append ] dip
- [ all-slots over [ length ] bi@ min head >quotation ] keep
- '[ @ _ boa ] call ;
+ } case new [ copy-message-in ] keep ;
--- /dev/null
+Eduardo Cavazos
+Slava Pestov
--- /dev/null
+USING: mason.build tools.test sequences ;
+IN: mason.build.tests
+
+{ create-build-dir enter-build-dir clone-builds-factor record-id }
+[ must-infer ] each
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files io.launcher io.encodings.utf8 prettyprint arrays
+calendar namespaces mason.common mason.child
+mason.release mason.report mason.email mason.cleanup ;
+IN: mason.build
+
+: create-build-dir ( -- )
+ now datestamp stamp set
+ build-dir make-directory ;
+
+: enter-build-dir ( -- ) build-dir set-current-directory ;
+
+: clone-builds-factor ( -- )
+ "git" "clone" builds/factor 3array try-process ;
+
+: record-id ( -- )
+ "factor" [ git-id ] with-directory "git-id" to-file ;
+
+: build ( -- )
+ create-build-dir
+ enter-build-dir
+ clone-builds-factor
+ record-id
+ build-child
+ release
+ email-report
+ cleanup ;
+
+MAIN: build
\ No newline at end of file
--- /dev/null
+IN: mason.child.tests
+USING: mason.child mason.config tools.test namespaces ;
+
+[ { "make" "clean" "winnt-x86-32" } ] [
+ [
+ "winnt" target-os set
+ "x86.32" target-cpu set
+ make-cmd
+ ] with-scope
+] unit-test
+
+[ { "make" "clean" "macosx-x86-32" } ] [
+ [
+ "macosx" target-os set
+ "x86.32" target-cpu set
+ make-cmd
+ ] with-scope
+] unit-test
+
+[ { "gmake" "clean" "netbsd-ppc" } ] [
+ [
+ "netbsd" target-os set
+ "ppc" target-cpu set
+ make-cmd
+ ] with-scope
+] unit-test
+
+[ { "./factor" "-i=boot.macosx-ppc.image" "-no-user-init" } ] [
+ [
+ "macosx" target-os set
+ "ppc" target-cpu set
+ boot-cmd
+ ] with-scope
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces make debugger sequences io.files
+io.launcher arrays accessors calendar continuations
+combinators.short-circuit mason.common mason.report mason.platform ;
+IN: mason.child
+
+: make-cmd ( -- args )
+ [ gnu-make , "clean" , platform , ] { } make ;
+
+: make-vm ( -- )
+ "factor" [
+ <process>
+ make-cmd >>command
+ "../compile-log" >>stdout
+ +stdout+ >>stderr
+ try-process
+ ] with-directory ;
+
+: builds-factor-image ( -- img )
+ builds/factor boot-image-name append-path ;
+
+: copy-image ( -- )
+ builds-factor-image "." copy-file-into
+ builds-factor-image "factor" copy-file-into ;
+
+: boot-cmd ( -- cmd )
+ "./factor"
+ "-i=" boot-image-name append
+ "-no-user-init"
+ 3array ;
+
+: boot ( -- )
+ "factor" [
+ <process>
+ boot-cmd >>command
+ +closed+ >>stdin
+ "../boot-log" >>stdout
+ +stdout+ >>stderr
+ 1 hours >>timeout
+ try-process
+ ] with-directory ;
+
+: test-cmd ( -- cmd ) { "./factor" "-run=mason.test" } ;
+
+: test ( -- )
+ "factor" [
+ <process>
+ test-cmd >>command
+ +closed+ >>stdin
+ "../test-log" >>stdout
+ +stdout+ >>stderr
+ 4 hours >>timeout
+ try-process
+ ] with-directory ;
+
+: return-with ( obj -- ) return-continuation get continue-with ;
+
+: build-clean? ( -- ? )
+ {
+ [ load-everything-vocabs-file eval-file empty? ]
+ [ test-all-vocabs-file eval-file empty? ]
+ [ help-lint-vocabs-file eval-file empty? ]
+ } 0&& ;
+
+: build-child ( -- )
+ [
+ return-continuation set
+
+ copy-image
+
+ [ make-vm ] [ compile-failed-report status-error return-with ] recover
+ [ boot ] [ boot-failed-report status-error return-with ] recover
+ [ test ] [ test-failed-report status-error return-with ] recover
+
+ successful-report
+
+ build-clean? status-clean status-dirty ? return-with
+ ] callcc1
+ status set ;
\ No newline at end of file
--- /dev/null
+USING: tools.test mason.cleanup ;
+IN: mason.cleanup.tests
+
+\ cleanup must-infer
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces arrays continuations io.files io.launcher
+mason.common mason.platform mason.config ;
+IN: mason.cleanup
+
+: compress-image ( -- )
+ "bzip2" boot-image-name 2array try-process ;
+
+: compress-test-log ( -- )
+ "test-log" exists? [
+ { "bzip2" "test-log" } try-process
+ ] when ;
+
+: cleanup ( -- )
+ builder-debug get [
+ build-dir [
+ compress-image
+ compress-test-log
+ "factor" delete-tree
+ ] with-directory
+ ] unless ;
--- /dev/null
+IN: mason.common.tests
+USING: prettyprint mason.common mason.config
+namespaces calendar tools.test io.files io.encodings.utf8 ;
+
+[ "00:01:01" ] [ 61000 milli-seconds>time ] unit-test
+
+[ "/home/bobby/builds/factor" ] [
+ [
+ "/home/bobby/builds" builds-dir set
+ builds/factor
+ ] with-scope
+] unit-test
+
+[ "/home/bobby/builds/2008-09-11-12-23" ] [
+ [
+ "/home/bobby/builds" builds-dir set
+ T{ timestamp
+ { year 2008 }
+ { month 9 }
+ { day 11 }
+ { hour 12 }
+ { minute 23 }
+ } datestamp stamp set
+ build-dir
+ ] with-scope
+] unit-test
+
+[ ] [ "empty-test" temp-file utf8 [ ] with-file-writer ] unit-test
+
+[ "empty-test" temp-file eval-file ] must-fail
+
+[ ] [ "eval-file-test" temp-file utf8 [ { 1 2 3 } . ] with-file-writer ] unit-test
+
+[ { 1 2 3 } ] [ "eval-file-test" temp-file eval-file ] unit-test
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces sequences splitting system accessors
+math.functions make io io.files io.launcher io.encodings.utf8
+prettyprint combinators.short-circuit parser combinators
+calendar calendar.format arrays mason.config ;
+IN: mason.common
+
+: short-running-process ( command -- )
+ #! Give network operations at most 15 minutes to complete.
+ <process>
+ swap >>command
+ 15 minutes >>timeout
+ try-process ;
+
+: eval-file ( file -- obj )
+ dup utf8 file-lines parse-fresh
+ [ "Empty file: " swap append throw ] [ nip first ] if-empty ;
+
+: cat ( file -- ) utf8 file-contents print ;
+
+: cat-n ( file n -- ) [ utf8 file-lines ] dip short tail* [ print ] each ;
+
+: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
+
+: datestamp ( timestamp -- string )
+ [
+ {
+ [ year>> , ]
+ [ month>> , ]
+ [ day>> , ]
+ [ hour>> , ]
+ [ minute>> , ]
+ } cleave
+ ] { } make [ pad-00 ] map "-" join ;
+
+: milli-seconds>time ( n -- string )
+ millis>timestamp
+ [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
+ [ pad-00 ] map ":" join ;
+
+SYMBOL: stamp
+
+: builds/factor ( -- path ) builds-dir get "factor" append-path ;
+: build-dir ( -- path ) builds-dir get stamp get append-path ;
+
+: prepare-build-machine ( -- )
+ builds-dir get make-directories
+ builds-dir get
+ [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
+ with-directory ;
+
+: git-id ( -- id )
+ { "git" "show" } utf8 [ readln ] with-process-reader
+ " " split second ;
+
+: ?prepare-build-machine ( -- )
+ builds/factor exists? [ prepare-build-machine ] unless ;
+
+: load-everything-vocabs-file "load-everything-vocabs" ;
+: load-everything-errors-file "load-everything-errors" ;
+
+: test-all-vocabs-file "test-all-vocabs" ;
+: test-all-errors-file "test-all-errors" ;
+
+: help-lint-vocabs-file "help-lint-vocabs" ;
+: help-lint-errors-file "help-lint-errors" ;
+
+: boot-time-file "boot-time" ;
+: load-time-file "load-time" ;
+: test-time-file "test-time" ;
+: help-lint-time-file "help-lint-time" ;
+: benchmark-time-file "benchmark-time" ;
+
+: benchmarks-file "benchmarks" ;
+
+SYMBOL: status
+
+SYMBOL: status-error ! didn't bootstrap, or crashed
+SYMBOL: status-dirty ! bootstrapped but not all tests passed
+SYMBOL: status-clean ! everything good
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system io.files namespaces kernel accessors ;
+IN: mason.config
+
+! (Optional) Location for build directories
+SYMBOL: builds-dir
+
+builds-dir get-global [
+ home "builds" append-path builds-dir set-global
+] unless
+
+! Who sends build reports.
+SYMBOL: builder-from
+
+! Who receives build reports.
+SYMBOL: builder-recipients
+
+! (Optional) CPU architecture to build for.
+SYMBOL: target-cpu
+
+target-cpu get-global [
+ cpu name>> target-cpu set-global
+] unless
+
+! (Optional) OS to build for.
+SYMBOL: target-os
+
+target-os get-global [
+ os name>> target-os set-global
+] unless
+
+! Keep test-log around?
+SYMBOL: builder-debug
+
+! Boolean. Do we release binaries and update the clean branch?
+SYMBOL: upload-to-factorcode
+
+! The below are only needed if upload-to-factorcode is true.
+
+! Host with clean git repo.
+SYMBOL: branch-host
+
+! Username to log in.
+SYMBOL: branch-username
+
+! Directory with git repo.
+SYMBOL: branch-directory
+
+! Host to upload clean image to.
+SYMBOL: image-host
+
+! Username to log in.
+SYMBOL: image-username
+
+! Directory with clean images.
+SYMBOL: image-directory
+
+! Host to upload binary package to.
+SYMBOL: upload-host
+
+! Username to log in.
+SYMBOL: upload-username
+
+! Directory with binary packages.
+SYMBOL: upload-directory
--- /dev/null
+IN: mason.email.tests
+USING: mason.email mason.common mason.config namespaces tools.test ;
+
+[ "mason on linux-x86-64: error" ] [
+ [
+ "linux" target-os set
+ "x86.64" target-cpu set
+ status-error status set
+ subject prefix-subject
+ ] with-scope
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces accessors combinators make smtp
+debugger prettyprint io io.streams.string io.encodings.utf8
+io.files io.sockets
+mason.common mason.platform mason.config ;
+IN: mason.email
+
+: prefix-subject ( str -- str' )
+ [ "mason on " % platform % ": " % % ] "" make ;
+
+: email-status ( body subject -- )
+ <email>
+ builder-from get >>from
+ builder-recipients get >>to
+ swap prefix-subject >>subject
+ swap >>body
+ send-email ;
+
+: subject ( -- str )
+ status get {
+ { status-clean [ "clean" ] }
+ { status-dirty [ "dirty" ] }
+ { status-error [ "error" ] }
+ } case ;
+
+: email-report ( -- )
+ "report" utf8 file-contents subject email-status ;
+
+: email-error ( error callstack -- )
+ [
+ "Fatal error on " write host-name print nl
+ [ error. ] [ callstack. ] bi*
+ ] with-string-writer "fatal error"
+ email-status ;
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel debugger io io.files threads debugger continuations
+namespaces accessors calendar mason.common mason.updates
+mason.build mason.email ;
+IN: mason
+
+: build-loop-error ( error -- )
+ error-continuation get call>> email-error ;
+
+: build-loop-fatal ( error -- )
+ "FATAL BUILDER ERROR:" print
+ error. flush ;
+
+: build-loop ( -- )
+ ?prepare-build-machine
+ [
+ [
+ builds/factor set-current-directory
+ new-code-available? [ build ] when
+ ] [
+ build-loop-error
+ ] recover
+ ] [
+ build-loop-fatal
+ ] recover
+ 5 minutes sleep
+ build-loop ;
+
+MAIN: build-loop
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel system accessors namespaces splitting sequences make
+mason.config ;
+IN: mason.platform
+
+: platform ( -- string )
+ target-os get "-" target-cpu get "." split "-" join 3append ;
+
+: gnu-make ( -- string )
+ target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
+
+: boot-image-name ( -- string )
+ [
+ "boot." %
+ target-cpu get "ppc" = [ target-os get % "-" % ] when
+ target-cpu get %
+ ".image" %
+ ] "" make ;
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel combinators sequences make namespaces io.files
+io.launcher prettyprint arrays
+mason.common mason.platform mason.config ;
+IN: mason.release.archive
+
+: base-name ( -- string )
+ [ "factor-" % platform % "-" % stamp get % ] "" make ;
+
+: extension ( -- extension )
+ target-os get {
+ { "winnt" [ ".zip" ] }
+ { "macosx" [ ".dmg" ] }
+ [ drop ".tar.gz" ]
+ } case ;
+
+: archive-name ( -- string ) base-name extension append ;
+
+: make-windows-archive ( -- )
+ [ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ;
+
+: make-macosx-archive ( -- )
+ { "mkdir" "dmg-root" } try-process
+ { "cp" "-R" "factor" "dmg-root" } try-process
+ { "hdiutil" "create"
+ "-srcfolder" "dmg-root"
+ "-fs" "HFS+"
+ "-volname" "factor" }
+ archive-name suffix try-process
+ "dmg-root" delete-tree ;
+
+: make-unix-archive ( -- )
+ [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ;
+
+: make-archive ( -- )
+ target-os get {
+ { "winnt" [ make-windows-archive ] }
+ { "macosx" [ make-macosx-archive ] }
+ [ drop make-unix-archive ]
+ } case ;
+
+: releases ( -- path )
+ builds-dir get "releases" append-path dup make-directories ;
+
+: save-archive ( -- )
+ archive-name releases move-file-into ;
\ No newline at end of file
--- /dev/null
+IN: mason.release.branch.tests
+USING: mason.release.branch mason.config tools.test namespaces ;
+
+[ { "git" "push" "joe@blah.com:/my/git" "master:clean-linux-x86-32" } ] [
+ [
+ "joe" branch-username set
+ "blah.com" branch-host set
+ "/my/git" branch-directory set
+ "linux" target-os set
+ "x86.32" target-cpu set
+ push-to-clean-branch-cmd
+ ] with-scope
+] unit-test
+
+[ { "scp" "boot.x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
+ [
+ "joe" image-username set
+ "blah.com" image-host set
+ "/stuff/clean" image-directory set
+ "netbsd" target-os set
+ "x86.64" target-cpu set
+ upload-clean-image-cmd
+ ] with-scope
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces sequences prettyprint io.files
+io.launcher make
+mason.common mason.platform mason.config ;
+IN: mason.release.branch
+
+: branch-name ( -- string ) "clean-" platform append ;
+
+: refspec ( -- string ) "master:" branch-name append ;
+
+: push-to-clean-branch-cmd ( -- args )
+ [
+ "git" , "push" ,
+ [
+ branch-username get % "@" %
+ branch-host get % ":" %
+ branch-directory get %
+ ] "" make ,
+ refspec ,
+ ] { } make ;
+
+: push-to-clean-branch ( -- )
+ push-to-clean-branch-cmd short-running-process ;
+
+: upload-clean-image-cmd ( -- args )
+ [
+ "scp" ,
+ boot-image-name ,
+ [
+ image-username get % "@" %
+ image-host get % ":" %
+ image-directory get % "/" %
+ platform %
+ ] "" make ,
+ ] { } make ;
+
+: upload-clean-image ( -- )
+ upload-clean-image-cmd short-running-process ;
+
+: (update-clean-branch) ( -- )
+ "factor" [
+ push-to-clean-branch
+ upload-clean-image
+ ] with-directory ;
+
+: update-clean-branch ( -- )
+ upload-to-factorcode get [ (update-clean-branch) ] when ;
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel debugger namespaces sequences splitting
+combinators io io.files io.launcher prettyprint bootstrap.image
+mason.common mason.release.branch mason.release.tidy
+mason.release.archive mason.release.upload ;
+IN: mason.release
+
+: (release) ( -- )
+ update-clean-branch
+ tidy
+ make-archive
+ upload
+ save-archive ;
+
+: release ( -- ) status get status-clean eq? [ (release) ] when ;
\ No newline at end of file
--- /dev/null
+IN: mason.release.tidy.tests
+USING: mason.release.tidy tools.test ;
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces continuations debugger sequences fry
+io.files io.launcher mason.common mason.platform
+mason.config ;
+IN: mason.release.tidy
+
+: common-files ( -- seq )
+ {
+ "boot.x86.32.image"
+ "boot.x86.64.image"
+ "boot.macosx-ppc.image"
+ "boot.linux-ppc.image"
+ "vm"
+ "temp"
+ "logs"
+ ".git"
+ ".gitignore"
+ "Makefile"
+ "unmaintained"
+ "unfinished"
+ "build-support"
+ } ;
+
+: remove-common-files ( -- )
+ common-files [ delete-tree ] each ;
+
+: remove-factor-app ( -- )
+ target-os get "macosx" =
+ [ "Factor.app" delete-tree ] unless ;
+
+: tidy ( -- )
+ "factor" [ remove-factor-app remove-common-files ] with-directory ;
--- /dev/null
+IN: mason.release.upload.tests
+USING: mason.release.upload mason.common mason.config
+mason.common namespaces calendar tools.test ;
+
+[
+ {
+ "scp"
+ "factor-linux-ppc-2008-09-11-23-12.tar.gz"
+ "slava@www.apple.com:/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete"
+ }
+ {
+ "ssh"
+ "www.apple.com"
+ "-l" "slava"
+ "mv"
+ "/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz.incomplete"
+ "/uploads/linux-ppc/factor-linux-ppc-2008-09-11-23-12.tar.gz"
+ }
+] [
+ [
+ "slava" upload-username set
+ "www.apple.com" upload-host set
+ "/uploads" upload-directory set
+ "linux" target-os set
+ "ppc" target-cpu set
+ T{ timestamp
+ { year 2008 }
+ { month 09 }
+ { day 11 }
+ { hour 23 }
+ { minute 12 }
+ } datestamp stamp set
+ upload-command
+ rename-command
+ ] with-scope
+] unit-test
+
+\ upload must-infer
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces make sequences arrays io io.files
+io.launcher mason.common mason.platform
+mason.release.archive mason.config ;
+IN: mason.release.upload
+
+: remote-location ( -- dest )
+ upload-directory get "/" platform 3append ;
+
+: remote-archive-name ( -- dest )
+ remote-location "/" archive-name 3append ;
+
+: temp-archive-name ( -- dest )
+ remote-archive-name ".incomplete" append ;
+
+: upload-command ( -- args )
+ "scp"
+ archive-name
+ [
+ upload-username get % "@" %
+ upload-host get % ":" %
+ temp-archive-name %
+ ] "" make
+ 3array ;
+
+: rename-command ( -- args )
+ [
+ "ssh" ,
+ upload-host get ,
+ "-l" ,
+ upload-username get ,
+ "mv" ,
+ temp-archive-name ,
+ remote-archive-name ,
+ ] { } make ;
+
+: upload-temp-file ( -- )
+ upload-command short-running-process ;
+
+: rename-temp-file ( -- )
+ rename-command short-running-process ;
+
+: upload ( -- )
+ upload-to-factorcode get
+ [ upload-temp-file rename-temp-file ]
+ when ;
--- /dev/null
+IN: mason.report.tests
+USING: mason.report tools.test ;
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces debugger fry io io.files io.sockets
+io.encodings.utf8 prettyprint benchmark mason.common
+mason.platform mason.config ;
+IN: mason.report
+
+: time. ( file -- )
+ [ write ": " write ] [ eval-file milli-seconds>time print ] bi ;
+
+: common-report ( -- )
+ "Build machine: " write host-name print
+ "CPU: " write target-cpu get print
+ "OS: " write target-os get print
+ "Build directory: " write build-dir print
+ "git id: " write "git-id" eval-file print nl ;
+
+: with-report ( quot -- )
+ [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ;
+
+: compile-failed-report ( error -- )
+ [
+ "VM compile failed:" print nl
+ "compile-log" cat nl
+ error.
+ ] with-report ;
+
+: boot-failed-report ( error -- )
+ [
+ "Bootstrap failed:" print nl
+ "boot-log" 100 cat-n nl
+ error.
+ ] with-report ;
+
+: test-failed-report ( error -- )
+ [
+ "Tests failed:" print nl
+ "test-log" 100 cat-n nl
+ error.
+ ] with-report ;
+
+: successful-report ( -- )
+ [
+ boot-time-file time.
+ load-time-file time.
+ test-time-file time.
+ help-lint-time-file time.
+ benchmark-time-file time.
+
+ nl
+
+ "Did not pass load-everything:" print
+ load-everything-vocabs-file cat
+ load-everything-errors-file cat
+
+ "Did not pass test-all:" print
+ test-all-vocabs-file cat
+ test-all-errors-file cat
+
+ "Did not pass help-lint:" print
+ help-lint-vocabs-file cat
+ help-lint-errors-file cat
+
+ "Benchmarks:" print
+ benchmarks-file eval-file benchmarks.
+ ] with-report ;
\ No newline at end of file
--- /dev/null
+Continuous build system for Factor
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs io.files io.encodings.utf8
+prettyprint help.lint benchmark tools.time bootstrap.stage2
+tools.test tools.vocabs mason.common ;
+IN: mason.test
+
+: do-load ( -- )
+ try-everything
+ [ keys load-everything-vocabs-file to-file ]
+ [ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ]
+ bi ;
+
+: do-tests ( -- )
+ run-all-tests
+ [ keys test-all-vocabs-file to-file ]
+ [ test-all-errors-file utf8 [ test-failures. ] with-file-writer ]
+ bi ;
+
+: do-help-lint ( -- )
+ "" run-help-lint
+ [ keys help-lint-vocabs-file to-file ]
+ [ help-lint-errors-file utf8 [ typos. ] with-file-writer ]
+ bi ;
+
+: do-benchmarks ( -- )
+ run-benchmarks benchmarks-file to-file ;
+
+: do-all ( -- )
+ ".." [
+ bootstrap-time get boot-time-file to-file
+ [ do-load ] benchmark load-time-file to-file
+ [ do-tests ] benchmark test-time-file to-file
+ [ do-help-lint ] benchmark help-lint-time-file to-file
+ [ do-benchmarks ] benchmark benchmark-time-file to-file
+ ] with-directory ;
+
+MAIN: do-all
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io.launcher bootstrap.image.download
+mason.common mason.platform ;
+IN: mason.updates
+
+: git-pull-cmd ( -- cmd )
+ {
+ "git"
+ "pull"
+ "--no-summary"
+ "git://factorcode.org/git/factor.git"
+ "master"
+ } ;
+
+: updates-available? ( -- ? )
+ git-id
+ git-pull-cmd short-running-process
+ git-id
+ = not ;
+
+: new-image-available? ( -- ? )
+ boot-image-name need-new-image? [ download-my-image t ] [ f ] if ;
+
+: new-code-available? ( -- ? )
+ updates-available?
+ new-image-available?
+ or ;
\ No newline at end of file
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.markup help.syntax ;
+
+IN: math.compare
+
+HELP: absmin
+{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
+{ $description
+ "Returns the smaller absolute number with the original sign."
+} ;
+
+HELP: absmax
+{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
+{ $description
+ "Returns the larger absolute number with the original sign."
+} ;
+
+HELP: posmax
+{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
+{ $description
+ "Returns the most-positive value, or zero if both are negative."
+} ;
+
+HELP: negmin
+{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
+{ $description
+ "Returns the most-negative value, or zero if both are positive."
+} ;
+
+HELP: clamp
+{ $values { "a" "a number" } { "value" "a number" } { "b" "a number" } { "x" "a number" } }
+{ $description
+ "Returns the value when between 'a' and 'b', 'a' if <= 'a', or 'b' if >= 'b'."
+} ;
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel math math.functions math.compare tools.test ;
+
+IN: math.compare.tests
+
+[ -1 ] [ -1 5 absmin ] unit-test
+[ -1 ] [ -1 -5 absmin ] unit-test
+
+[ -5 ] [ 1 -5 absmax ] unit-test
+[ 5 ] [ 1 5 absmax ] unit-test
+
+[ 0 ] [ -1 -3 posmax ] unit-test
+[ 1 ] [ 1 -3 posmax ] unit-test
+[ 3 ] [ -1 3 posmax ] unit-test
+
+[ 0 ] [ 1 3 negmin ] unit-test
+[ -3 ] [ 1 -3 negmin ] unit-test
+[ -1 ] [ -1 3 negmin ] unit-test
+
+[ 0 ] [ 0 -1 2 clamp ] unit-test
+[ 1 ] [ 0 1 2 clamp ] unit-test
+[ 2 ] [ 0 3 2 clamp ] unit-test
+
+
+
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: math math.order kernel ;
+
+IN: math.compare
+
+: absmin ( a b -- x )
+ [ [ abs ] bi@ < ] 2keep ? ;
+
+: absmax ( a b -- x )
+ [ [ abs ] bi@ > ] 2keep ? ;
+
+: posmax ( a b -- x )
+ 0 max max ;
+
+: negmin ( a b -- x )
+ 0 min min ;
+
+: clamp ( a value b -- x )
+ min max ;
+
--- /dev/null
+Comparison functions.
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.markup help.syntax ;
+
+IN: math.finance
+
+HELP: sma
+{ $values { "seq" "a sequence" } { "n" "number of periods" } { "newseq" "a sequence" } }
+{ $description "Returns the Simple Moving Average with the specified periodicity." } ;
+
+HELP: ema
+{ $values { "seq" "a sequence" } { "n" "number of periods" } { "newseq" "a sequence" } }
+{ $description
+ "Returns the Exponential Moving Average with the specified periodicity, calculated by:\n"
+ { $list
+ "A = 2.0 / (N + 1)"
+ "EMA[t] = (A * SEQ[t]) + ((1-A) * EMA[t-1])" }
+} ;
+
+HELP: macd
+{ $values { "seq" "a sequence" } { "n1" "short number of periods" } { "n2" "long number of periods" } { "newseq" "a sequence" } }
+{ $description
+ "Returns the Moving Average Converge of the sequence, calculated by:\n"
+ { $list "MACD[t] = EMA2[t] - EMA1[t]" }
+} ;
+
+HELP: momentum
+{ $values { "seq" "a sequence" } { "n" "number of periods" } { "newseq" "a sequence" } }
+{ $description
+ "Returns the Momentum of the sequence, calculated by:\n"
+ { $list "MOM[t] = SEQ[t] - SEQ[t-n]" }
+} ;
+
--- /dev/null
+USING: kernel math math.functions math.finance tools.test ;
+
+IN: math.finance.tests
+
+[ { 2 4 } ] [ { 1 3 5 } 2 sma ] unit-test
+
+[ { 1 3 1 } ] [ { 1 3 2 6 3 } 2 momentum ] unit-test
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays assocs kernel grouping sequences shuffle
+math math.functions math.statistics math.vectors ;
+
+IN: math.finance
+
+<PRIVATE
+
+: weighted ( x y a -- z )
+ tuck [ * ] [ 1 swap - * ] 2bi* + ;
+
+: a ( n -- a )
+ 1 + 2 swap / ;
+
+PRIVATE>
+
+: ema ( seq n -- newseq )
+ a swap unclip [ [ dup ] 2dip swap rot weighted ] accumulate 2nip ;
+
+: sma ( seq n -- newseq )
+ clump [ mean ] map ;
+
+: macd ( seq n1 n2 -- newseq )
+ rot dup ema [ swap ema ] dip v- ;
+
+: momentum ( seq n -- newseq )
+ 2dup tail-slice -rot swap [ length ] keep
+ [ - neg ] dip swap head-slice v- ;
+
--- /dev/null
+Moving averages and other calculations useful for finance.
: mean ( seq -- n )
#! arithmetic mean, sum divided by length
- [ sum ] keep length / ;
+ [ sum ] [ length ] bi / ;
: geometric-mean ( seq -- n )
#! geometric mean, nth root of product
- [ product ] keep length swap nth-root ;
+ [ length ] [ product ] bi nth-root ;
: harmonic-mean ( seq -- n )
#! harmonic mean, reciprocal of sum of reciprocals.
#! positive reals only
- 0 [ recip + ] reduce recip ;
+ [ recip ] sigma recip ;
: median ( seq -- n )
#! middle number if odd, avg of two middle numbers if even
natural-sort dup length dup even? [
- 1- 2 / swap [ nth ] 2keep >r 1+ r> nth + 2 /
+ 1- 2 / swap [ nth ] [ >r 1+ r> nth ] 2bi + 2 /
] [
2 / swap nth
] if ;
--- /dev/null
+Doug Coleman
+Slava Pestov
--- /dev/null
+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
--- /dev/null
+USING: arrays combinators kernel lists math math.parser
+namespaces parser lexer parser-combinators parser-combinators.simple
+promises quotations sequences combinators.lib strings math.order
+assocs prettyprint.backend memoize unicode.case 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@ [ >r >r ch>upper r> r> 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 )
+ [ >r token r> <@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?>> [ >r >upper r> ] 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 ;
--- /dev/null
+Regular expressions
--- /dev/null
+parsing
+text
for(var i=0; i< seq.length; ++i)
initial = f(initial, seq[i]);
return initial;
-}
-"> main \ javascript rule (parse) remaining>> length zero?
+}"> main \ javascript rule (parse) remaining>> length zero?
] unit-test
{ t } [
r.cache = this.cache;
r.length = this.length - index;
return r;
-}
-"> main \ javascript rule (parse) remaining>> length zero?
+}"> main \ javascript rule (parse) remaining>> length zero?
] unit-test
CALL square;
x := x + 1;
END
-END.
-"> main \ pl0 rule (parse) remaining>> empty?
+END."> main \ pl0 rule (parse) remaining>> empty?
] unit-test
{ f } [
--- /dev/null
+John Benediktsson
--- /dev/null
+
+USING: help.syntax help.markup kernel prettyprint sequences strings ;
+
+IN: printf
+
+HELP: printf
+{ $values { "format-string" string } }
+{ $description "Writes the arguments (specified on the stack) formatted according to the format string." }
+{ $examples
+ { $example
+ "USING: printf ;"
+ "123 \"%05d\" printf"
+ "00123" }
+ { $example
+ "USING: printf ;"
+ "HEX: ff \"%04X\" printf"
+ "00FF" }
+ { $example
+ "USING: printf ;"
+ "1.23456789 \"%.3f\" printf"
+ "1.234" }
+ { $example
+ "USING: printf ;"
+ "1234567890 \"%.5e\" printf"
+ "1.23456e+09" }
+ { $example
+ "USING: printf ;"
+ "12 \"%'#4d\" printf"
+ "##12" }
+ { $example
+ "USING: printf ;"
+ "1234 \"%+d\" printf"
+ "+1234" }
+} ;
+
+HELP: sprintf
+{ $values { "format-string" string } { "result" string } }
+{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." }
+{ $see-also printf } ;
+
+ARTICLE: "printf" "Formatted printing"
+"The " { $vocab-link "printf" } " vocabulary is used for formatted printing.\n"
+{ $subsection printf }
+{ $subsection sprintf }
+"\n"
+"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n"
+{ $table
+ { "%%" "Single %" "" }
+ { "%P.Ds" "String format" "string" }
+ { "%P.DS" "String format uppercase" "string" }
+ { "%c" "Character format" "char" }
+ { "%C" "Character format uppercase" "char" }
+ { "%+Pd" "Integer format" "fixnum" }
+ { "%+P.De" "Scientific notation" "fixnum, float" }
+ { "%+P.DE" "Scientific notation" "fixnum, float" }
+ { "%+P.Df" "Fixed format" "fixnum, float" }
+ { "%+Px" "Hexadecimal" "hex" }
+ { "%+PX" "Hexadecimal uppercase" "hex" }
+}
+"\n"
+"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive.\n"
+"\n"
+"Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n"
+{ $list
+ "\"%5s\" formats a string padding with spaces up to 5 characters wide."
+ "\"%08d\" formats an integer padding with zeros up to 3 characters wide."
+ "\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
+ "\"%-10d\" formats an integer to 10 characters wide and left-aligns."
+}
+"\n"
+"Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n"
+{ $list
+ "\"%.3s\" formats a string to truncate at 3 characters (from the left)."
+ "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
+ "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
+} ;
+
+ABOUT: "printf"
+
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel printf tools.test ;
+
+[ "%s" printf ] must-infer
+
+[ "%s" sprintf ] must-infer
+
+[ t ] [ "" "" sprintf = ] unit-test
+
+[ t ] [ "asdf" "asdf" sprintf = ] unit-test
+
+[ t ] [ "10" 10 "%d" sprintf = ] unit-test
+
+[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test
+
+[ t ] [ "-10" -10 "%d" sprintf = ] unit-test
+
+[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test
+
+[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test
+
+[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
+
+[ t ] [ "123.456" 123.456 "%f" sprintf = ] unit-test
+
+[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
+
+[ t ] [ "1.2345" 1.23456789 "%.4f" sprintf = ] unit-test
+
+[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
+
+[ t ] [ "1.234e+08" 123400000 "%e" sprintf = ] unit-test
+
+[ t ] [ "-1.234e+08" -123400000 "%e" sprintf = ] unit-test
+
+[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
+
+[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
+
+[ t ] [ "2.5e-03" 0.0025 "%e" sprintf = ] unit-test
+
+[ t ] [ "2.5E-03" 0.0025 "%E" sprintf = ] unit-test
+
+[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test
+
+[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test
+
+[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test
+
+[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test
+
+[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test
+
+[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test
+
+[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test
+
+[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test
+
+[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test
+
+[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
+
+[ t ] [ "2008-09-10"
+ 2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
+
+[ t ] [ "Hello, World!"
+ "Hello, World!" "%s" sprintf = ] unit-test
+
+[ t ] [ "printf test"
+ "printf test" sprintf = ] unit-test
+
+[ t ] [ "char a = 'a'"
+ CHAR: a "char %c = 'a'" sprintf = ] unit-test
+
+[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
+
+[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
+
+[ t ] [ "0 message(s)"
+ 0 "message" "%d %s(s)" sprintf = ] unit-test
+
+[ t ] [ "0 message(s) with %"
+ 0 "message" "%d %s(s) with %%" sprintf = ] unit-test
+
+[ t ] [ "justif: \"left \""
+ "left" "justif: \"%-10s\"" sprintf = ] unit-test
+
+[ t ] [ "justif: \" right\""
+ "right" "justif: \"%10s\"" sprintf = ] unit-test
+
+[ t ] [ " 3: 0003 zero padded"
+ 3 " 3: %04d zero padded" sprintf = ] unit-test
+
+[ t ] [ " 3: 3 left justif"
+ 3 " 3: %-4d left justif" sprintf = ] unit-test
+
+[ t ] [ " 3: 3 right justif"
+ 3 " 3: %4d right justif" sprintf = ] unit-test
+
+[ t ] [ " -3: -003 zero padded"
+ -3 " -3: %04d zero padded" sprintf = ] unit-test
+
+[ t ] [ " -3: -3 left justif"
+ -3 " -3: %-4d left justif" sprintf = ] unit-test
+
+[ t ] [ " -3: -3 right justif"
+ -3 " -3: %4d right justif" sprintf = ] unit-test
+
+[ t ] [ "There are 10 monkeys in the kitchen"
+ 10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
+
+[ f ] [ "%d" 10 "%d" sprintf = ] unit-test
+
+[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test
+
+[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test
+
+[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test
+
+[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
+
+[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
+
+[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
+
+
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: io io.encodings.ascii io.files io.streams.string combinators
+kernel sequences splitting strings math math.parser macros
+fry peg.ebnf ascii unicode.case arrays quotations vectors ;
+
+IN: printf
+
+<PRIVATE
+
+: compose-all ( seq -- quot )
+ [ ] [ compose ] reduce ;
+
+: fix-sign ( string -- string )
+ dup CHAR: 0 swap index 0 =
+ [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
+ [ dup 1- rot dup [ nth ] dip swap
+ {
+ { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
+ { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
+ [ drop swap drop ]
+ } case
+ ] [ drop ] if
+ ] when ;
+
+: >digits ( string -- digits )
+ [ 0 ] [ string>number ] if-empty ;
+
+: max-digits ( string digits -- string )
+ [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ;
+
+: max-width ( string length -- string )
+ short head ;
+
+: >exponential ( n -- base exp )
+ [ 0 < ] keep abs 0
+ [ swap dup [ 10.0 >= ] keep 1.0 < or ]
+ [ dup 10.0 >=
+ [ 10.0 / [ 1+ ] dip swap ]
+ [ 10.0 * [ 1- ] dip swap ] if
+ ] [ swap ] while
+ [ number>string ] dip
+ dup abs number>string 2 CHAR: 0 pad-left
+ [ 0 < "-" "+" ? ] dip append
+ "e" prepend
+ rot [ [ "-" prepend ] dip ] when ;
+
+EBNF: parse-format-string
+
+zero = "0" => [[ CHAR: 0 ]]
+char = "'" (.) => [[ second ]]
+
+pad-char = (zero|char)? => [[ CHAR: \s or 1quotation ]]
+pad-align = ("-")? => [[ [ pad-right ] [ pad-left ] ? ]]
+pad-width = ([0-9])* => [[ >digits 1quotation ]]
+pad = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]]
+
+sign = ("+")? => [[ [ dup CHAR: - swap index not [ "+" prepend ] when ] [ ] ? ]]
+
+width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]]
+width = (width_)? => [[ [ ] or ]]
+
+digits_ = "." ([0-9])* => [[ second >digits '[ _ max-digits ] ]]
+digits = (digits_)? => [[ [ ] or ]]
+
+fmt-% = "%" => [[ [ "%" ] ]]
+fmt-c = "c" => [[ [ 1string ] ]]
+fmt-C = "C" => [[ [ 1string >upper ] ]]
+fmt-s = "s" => [[ [ ] ]]
+fmt-S = "S" => [[ [ >upper ] ]]
+fmt-d = "d" => [[ [ >fixnum number>string ] ]]
+fmt-e = "e" => [[ [ >exponential ] ]]
+fmt-E = "E" => [[ [ >exponential >upper ] ]]
+fmt-f = "f" => [[ [ >float number>string ] ]]
+fmt-x = "x" => [[ [ >hex ] ]]
+fmt-X = "X" => [[ [ >hex >upper ] ]]
+unknown = (.)* => [[ "Unknown directive" throw ]]
+
+chars = fmt-c | fmt-C
+strings = pad width (fmt-s|fmt-S) => [[ reverse compose-all ]]
+decimals = fmt-d
+exps = digits (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]]
+floats = digits fmt-f => [[ reverse compose-all ]]
+hex = fmt-x | fmt-X
+numbers = sign pad (decimals|floats|hex|exps) => [[ reverse first3 swap 3append [ fix-sign ] append ]]
+
+formats = "%" (chars|strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
+
+text = (formats|plain-text)* => [[ reverse [ [ dup [ push ] dip ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: printf ( format-string -- )
+ parse-format-string [ length ] keep compose-all '[ _ <vector> @ reverse [ write ] each ] ;
+
+: sprintf ( format-string -- result )
+ [ printf ] with-string-writer ; inline
+
+
--- /dev/null
+Format data according to a specified format string, and writes (or returns) the result string.
+++ /dev/null
-Doug Coleman
-Slava Pestov
+++ /dev/null
-USING: regexp tools.test kernel ;
-IN: 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
+++ /dev/null
-USING: arrays combinators kernel lists math math.parser
-namespaces parser lexer parser-combinators parser-combinators.simple
-promises quotations sequences combinators.lib strings math.order
-assocs prettyprint.backend memoize unicode.case unicode.categories
-combinators.short-circuit accessors make io ;
-IN: 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@ [ >r >r ch>upper r> r> 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 )
- [ >r token r> <@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?>> [ >r >upper r> ] 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 ;
+++ /dev/null
-Regular expressions
+++ /dev/null
-parsing
-text
"passed to the quotation given to each-withn for each element in the sequence."\r
} \r
{ $see-also map-withn } ;\r
+\r
+HELP: randomize\r
+{ $values { "seq" sequence } { "seq'" sequence } }\r
+{ $description "Shuffle the elements in the sequence randomly, returning the new sequence." } ;\r
+\r
+HELP: enumerate\r
+{ $values { "seq" sequence } { "seq'" sequence } }\r
+{ $description "Returns a new sequence where each element is an array of { index, value }" } ;\r
+\r
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
+
+[ { { 0 1 } { 1 2 } { 2 3 } } ] [ { 1 2 3 } enumerate ] unit-test
+
: ?nth* ( n seq -- elt/f ? )
2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: math.ranges
+USE: random
+: randomize ( seq -- seq' )
+ dup length 1 (a,b] [ dup random pick exchange ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: enumerate ( seq -- seq' )
+ <enum> >alist ;
+
: list-posts ( -- posts )
f <post> "author" value >>author
- select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
+ select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
reverse-chronological-order ;
: <list-posts-action> ( -- action )
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: furnace.actions furnace.redirection
+http.server.dispatchers html.forms validators urls accessors
+math ;
+IN: webapps.calculator
+
+TUPLE: calculator < dispatcher ;
+
+: <calculator-action> ( -- action )
+ <page-action>
+
+ [
+ { { "z" [ [ v-number ] v-optional ] } } validate-params
+ ] >>init
+
+ { calculator "calculator" } >>template
+
+ [
+ {
+ { "x" [ v-number ] }
+ { "y" [ v-number ] }
+ } validate-params
+
+ URL" $calculator" "x" value "y" value + "z" set-query-param
+ <redirect>
+ ] >>submit ;
+
+: <calculator> ( -- responder )
+ calculator new-dispatcher
+ <calculator-action> >>default ;
+
+! Deployment example
+USING: db.sqlite furnace.alloy namespaces http.server ;
+
+: calculator-db ( -- params db ) "calculator.db" sqlite-db ;
+
+: run-calculator ( -- )
+ <calculator>
+ calculator-db <alloy>
+ main-responder set-global
+ 8080 httpd ;
+
+MAIN: run-calculator
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <head> <title>Calculator</title> </head>
+
+ <body>
+ <h1>Calculator</h1>
+
+ <t:form t:action="$calculator">
+
+ <table>
+ <tr><td>First value:</td><td> <t:field t:name="x" /> </td></tr>
+ <tr><td>Second value:</td><td> <t:field t:name="y" /> </td></tr>
+ </table>
+
+ <input type="SUBMIT" value="Compute" />
+
+ <t:if t:value="z">
+ <br/>
+
+ Result: <t:label t:name="z" />
+ </t:if>
+
+ </t:form>
+ </body>
+
+</t:chloe>
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: math kernel accessors http.server http.server.dispatchers
furnace furnace.actions furnace.sessions furnace.redirection
-html.components html.forms html.templates.chloe
-fry urls ;
+html.components html.forms fry urls ;
IN: webapps.counter
SYMBOL: count
counter-app new-dispatcher
[ 1+ ] <counter-action> "inc" add-responder
[ 1- ] <counter-action> "dec" add-responder
- <display-action> "" add-responder
- <sessions> ;
+ <display-action> "" add-responder ;
+
+! Deployment example
+USING: db.sqlite furnace.alloy namespaces ;
+
+: counter-db ( -- params db ) "counter.db" sqlite-db ;
+
+: run-counter ( -- )
+ <counter-app>
+ counter-db <alloy>
+ main-responder set-global
+ 8080 httpd ;
+
+MAIN: run-counter
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors http.server.dispatchers
+http.server.static furnace.actions furnace.redirection urls
+validators locals io.files html.forms help.html ;
+IN: webapps.help
+
+TUPLE: help-webapp < dispatcher ;
+
+:: <search-action> ( help-dir -- action )
+ <page-action>
+ { help-webapp "search" } >>template
+
+ [
+ {
+ { "search" [ 1 v-min-length 50 v-max-length v-one-line ] }
+ } validate-params
+
+ help-dir set-current-directory
+
+ "search" value article-apropos "articles" set-value
+ "search" value word-apropos "words" set-value
+ "search" value vocab-apropos "vocabs" set-value
+
+ { help-webapp "search" } <chloe-content>
+ ] >>submit ;
+
+: <main-action> ( -- action )
+ <page-action>
+ { help-webapp "help" } >>template ;
+
+: <help-webapp> ( help-dir -- webapp )
+ help-webapp new-dispatcher
+ <main-action> "" add-responder
+ over <search-action> "search" add-responder
+ swap <static> "content" add-responder ;
+
+
--- /dev/null
+<?xml version="1.0"?>
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>Factor Documentation</title>
+ <t:base t:href="$help-webapp" />
+ </head>
+
+ <frameset cols="30%, 70%">
+ <frame src="search" name="search" />
+ <frame src="content/article-handbook.html" name="content" />
+ </frameset>
+ </html>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <t:base t:href="$help-webapp/content/" />
+
+ <style>
+ body { font-family: sans-serif; font-size: 85%; }
+ a:link { text-decoration: none; color: #00004c; }
+ a:visited { text-decoration: none; color: #00004c; }
+ a:active { text-decoration: none; color: #00004c; }
+ a:hover { text-decoration: underline; color: #00004c; }
+ </style>
+ </head>
+
+ <body>
+ <h1><t:a t:href="$help-webapp/content/article-handbook.html"
+ target="content">Factor documentation</t:a></h1>
+
+ <p>This is the <a href="http://factorcode.org" target="_top">Factor</a>
+ documentation, generated offline from a
+ <code>load-everything</code> image. If you want, you can also browse the
+ documentation from within the <a href="http://factorcode.org" target="_top">Factor</a> UI.</p>
+
+ <p>You may search article titles below; for example, try searching for "HTTP".</p>
+
+ <t:form t:action="$help-webapp/search">
+ <t:field t:name="search" />
+ <button>Search</button>
+ </t:form>
+
+ <t:if t:value="articles">
+ <hr/>
+
+ <h2>Articles</h2>
+
+ <ul>
+ <t:each t:name="articles">
+ <li> <t:link t:name="value" t:target="content" /> </li>
+ </t:each>
+ </ul>
+ </t:if>
+
+ <t:if t:value="vocabs">
+ <hr/>
+
+ <h2>Vocabularies</h2>
+
+ <ul>
+ <t:each t:name="vocabs">
+ <li> <t:link t:name="value" t:target="content" /> </li>
+ </t:each>
+ </ul>
+ </t:if>
+
+ <t:if t:value="words">
+ <hr/>
+
+ <h2>Words</h2>
+
+ <ul>
+ <t:each t:name="words">
+ <li> <t:link t:name="value" t:target="content" /> </li>
+ </t:each>
+ </ul>
+ </t:if>
+
+ </body>
+</html>
+
+</t:chloe>
</tr>
</table>
- <input type="SUBMIT" value="Submit" />
+ <p> <button>Submit</button> </p>
</t:form>
</t:chloe>
<t:bind-each t:name="annotations">
- <a name="@id"><h2>Annotation: <t:label t:name="summary" /></h2></a>
+ <h2><a name="@id">Annotation: <t:label t:name="summary" /></a></h2>
<table>
<tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
</tr>
</table>
- <input type="SUBMIT" value="Done" />
+ <p> <button>Done</button> </p>
</t:form>
<div class="navbar">
- <t:a t:href="$pastebin/list">Pastes</t:a>
+ <t:a t:href="$pastebin">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
<t:if t:code="furnace.auth:logged-in?">
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
hashtables sequences.lib db.types db.tuples db combinators
-calendar calendar.format math.parser syndication urls xml.writer
-xmode.catalog validators
+calendar calendar.format math.parser math.order syndication urls
+xml.writer xmode.catalog validators
html.forms
html.components
html.templates.chloe
swap >>id ;
: pastes ( -- pastes )
- f <paste> select-tuples ;
+ f <paste> select-tuples
+ [ [ date>> ] compare ] sort
+ reverse ;
TUPLE: annotation < entity parent ;
<feed-action>
[ pastebin-url ] >>url
[ "Factor Pastebin" ] >>title
- [ pastes <reversed> ] >>entries ;
+ [ pastes ] >>entries ;
! ! !
! PASTES
: <pastebin> ( -- responder )
pastebin new-dispatcher
- <pastebin-action> "list" add-main-responder
+ <pastebin-action> "" add-responder
<pastebin-feed-action> "list.atom" add-responder
<paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder
<t:title>Pastebin</t:title>
<table width="100%">
- <th align="left" width="50%">Summary:</th>
- <th align="left" width="100">Paste by:</th>
- <th align="left" width="200">Date:</th>
+ <tr>
+ <th align="left" width="50%">Summary:</th>
+ <th align="left" width="100">Paste by:</th>
+ <th align="left" width="200">Date:</th>
+ </tr>
<t:bind-each t:name="pastes">
<tr>
<tr>
<th class="field-label">Home page:</th>
- <td><t:field t:name="www-url" /></td>
+ <td><t:field t:name="www-url" t:size="40" /></td>
</tr>
<tr>
<th class="field-label">Feed:</th>
- <td><t:field t:name="feed-url" /></td>
+ <td><t:field t:name="feed-url" t:size="40" /></td>
</tr>
</table>
<tr>
<th class="field-label">Home page:</th>
- <td><t:field t:name="www-url" /></td>
+ <td><t:field t:name="www-url" t:size="40" /></td>
</tr>
<tr>
<th class="field-label">Feed:</th>
- <td><t:field t:name="feed-url" /></td>
+ <td><t:field t:name="feed-url" t:size="40" /></td>
</tr>
</table>
<t:style t:include="resource:extra/webapps/planet/planet.css" />
<div class="navbar">
- <t:a t:href="$planet/list">Front Page</t:a>
+ <t:a t:href="$planet">Front Page</t:a>
| <t:a t:href="$planet/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet/admin">Admin</t:a>
f <blog>
[ deposit-blog-slots ]
[ insert-tuple ]
- [
- <url>
- "$planet/admin/edit-blog" >>path
- swap id>> "id" set-query-param
- <redirect>
- ]
- tri
+ bi
+ URL" $planet/admin" <redirect>
] >>submit ;
: <edit-blog-action> ( -- action )
[
f <blog>
[ deposit-blog-slots ]
+ [ "id" value >>id ]
[ update-tuple ]
- [
- <url>
- "$planet/admin" >>path
- swap id>> "id" set-query-param
- <redirect>
- ]
tri
+
+ <url>
+ "$planet/admin" >>path
+ "id" value "id" set-query-param
+ <redirect>
] >>submit ;
: <planet-admin> ( -- responder )
planet-admin new-dispatcher
- <edit-blogroll-action> "blogroll" add-main-responder
+ <edit-blogroll-action> "" add-responder
<update-action> "update" add-responder
<new-blog-action> "new-blog" add-responder
<edit-blog-action> "edit-blog" add-responder
: <planet> ( -- responder )
planet new-dispatcher
- <planet-action> "list" add-main-responder
+ <planet-action> "" add-responder
<planet-feed-action> "feed.xml" add-responder
<planet-admin> "admin" add-responder
<boilerplate>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Concatenative Planet</t:title>
+ <t:title>[ planet-factor ]</t:title>
<table width="100%" cellpadding="10">
<tr>
</t:each>
</ul>
+ <hr/>
+
+ <p>
+ <strong>planet-factor</strong> is an Atom/RSS aggregator that collects the
+ contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It is inspired by
+ <a href="http://planet.lisp.org">Planet Lisp</a>.
+ </p>
+ <p>
+ <img src="http://factorcode.org/feed-icon-14x14.png" />
+ <t:a t:href="$planet/feed.xml">Syndicate</t:a>
+ </p>
</td>
</tr>
</table>
: <todo-list> ( -- responder )
todo-list new-dispatcher
- <list-action> "list" add-main-responder
+ <list-action> "" add-responder
<view-action> "view" add-responder
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<t:title>Edit User</t:title>
- <t:form t:action="$user-admin/edit" t:for="username">
+ <t:form t:action="$user-admin/edit" t:for="username" autocomplete="off">
<table>
<t:title>New User</t:title>
- <t:form t:action="$user-admin/new">
+ <t:form t:action="$user-admin/new" autocomplete="off">
<table>
: <user-admin> ( -- responder )
user-admin new-dispatcher
- <user-list-action> "list" add-main-responder
+ <user-list-action> "" add-responder
<new-user-action> "new" add-responder
<edit-user-action> "edit" add-responder
<delete-user-action> "delete" add-responder
<t:form t:action="$wee-url">
<p>Shorten URL: <t:field t:name="url" t:size="40" /></p>
- <input type="submit" value="Shorten" />
+ <button>Shorten</button>
</t:form>
</t:chloe>
</p>
<p>
- <input type="submit" value="Save" />
+ <button>Save</button>
</p>
</t:form>
[[image:http://factorcode.org/graphics/logo.png]]
-Lists:
+Unordered lists:
- a list
- with three
- items
+Ordered lists:
+
+# a list
+# with three
+# numbered items
+
+Horizontal lines:
+
+___
+
Tables:
|a table|with|four|columns|
This Wiki uses [[Farkup]] to mark up text.
-Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
+Two special article names are recognized by the Wiki: [[Contents]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
The Wiki supports hierarchical article organization. You can separate components in article names with slashes, and Wiki links only display the last component. An example: [[Factor/Features]].
</tr>
</table>
- <input type="submit" value="View" />
+ <button>View</button>
</t:form>
</t:chloe>
<t:title><t:label t:name="title" /></t:title>
<div class="description">
- <t:html t:name="html" />
+ <t:farkup t:name="parsed" t:parsed="true" />
</div>
<p>
<table width="100%">
<tr>
- <t:if t:value="sidebar">
+ <t:if t:value="contents">
<td valign="top" style="width: 210px;">
- <div class="sidebar">
- <t:bind t:name="sidebar">
+ <div class="contents">
+ <t:bind t:name="contents">
<h2>
<t:a t:href="$wiki/view" t:query="title">
<t:label t:name="title" />
</t:a>
</h2>
- <t:html t:name="html" />
+ <t:farkup t:name="parsed" t:parsed="true" />
</t:bind>
</div>
</td>
<t:if t:value="footer">
<tr>
- <td colspan="2">
+ <td colspan="2" class="footer">
<t:bind t:name="footer">
- <small>
- <t:html t:name="html" />
- </small>
+ <t:farkup t:name="parsed" t:parsed="true" />
</t:bind>
</td>
</tr>
border-width: 1px 1px 0 0;
}
-.sidebar {
+.contents {
padding: 4px;
margin: 4px;
- border: 1px dashed grey;
+ border: 1px dashed gray;
background: #f5f1fd;
width: 200px;
}
+
+.footer {
+ font-size: 75%;
+}
IN: webapps.wiki
: wiki-url ( rest path -- url )
- [ "$wiki/" % % "/" % % ] "" make
+ [ "$wiki/" % % "/" % present % ] "" make
<url> swap >>path ;
: view-url ( title -- url ) "view" wiki-url ;
: <article> ( title -- article ) article new swap >>title ;
-TUPLE: revision id title author date content html description ;
+TUPLE: revision id title author date content parsed description ;
revision "REVISIONS" {
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
{ "date" "DATE" TIMESTAMP +not-null+ }
{ "content" "CONTENT" TEXT +not-null+ }
- { "html" "HTML" TEXT +not-null+ } ! Farkup converted to HTML
+ { "parsed" "PARSED" FACTOR-BLOB +not-null+ } ! Farkup AST
{ "description" "DESCRIPTION" TEXT }
} define-persistent
revision new swap >>id ;
: compute-html ( revision -- )
- dup content>> convert-farkup >>html drop ;
+ dup content>> parse-farkup >>parsed drop ;
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
[ "author" value user-edits-url ] >>url
[ list-user-edits ] >>entries ;
-: init-sidebar ( -- )
- "Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when*
+: init-sidebars ( -- )
+ "Contents" latest-revision [ "contents" [ from-object ] nest-form ] when*
"Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;
+: init-relative-link-prefix ( -- )
+ URL" $wiki/view/" adjust-url present relative-link-prefix set ;
+
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<main-article-action> "" add-responder
<list-changes-feed-action> "changes.atom" add-responder
<delete-action> "delete" add-responder
<boilerplate>
- [ init-sidebar ] >>init
+ [ init-sidebars init-relative-link-prefix ] >>init
{ wiki "wiki-common" } >>template ;
: init-wiki ( -- )
http.server
http.server.dispatchers
http.server.redirection
+http.server.static
+http.server.cgi
furnace.alloy
furnace.auth.login
furnace.auth.providers.db
furnace.auth.features.deactivate-user
furnace.boilerplate
furnace.redirection
-webapps.blogs
webapps.pastebin
webapps.planet
-webapps.todo
webapps.wiki
-webapps.wee-url
-webapps.user-admin ;
+webapps.user-admin
+webapps.help ;
IN: websites.concatenative
: test-db ( -- params db ) "resource:test.db" sqlite-db ;
init-furnace-tables
{
- post comment
paste annotation
blog posting
- todo
- short-url
article revision
} ensure-tables
] with-db ;
TUPLE: factor-website < dispatcher ;
-: <factor-website> ( -- responder )
- factor-website new-dispatcher
- <blogs> "blogs" add-responder
- <todo-list> "todo" add-responder
- <pastebin> "pastebin" add-responder
- <planet> "planet" add-responder
- <wiki> "wiki" add-responder
- <wee-url> "wee-url" add-responder
- <user-admin> "user-admin" add-responder
- URL" /wiki/view/Front Page" <redirect-responder> "" add-responder
+: <factor-boilerplate> ( responder -- responder' )
+ <boilerplate>
+ { factor-website "page" } >>template ;
+
+: <login-config> ( responder -- responder' )
"Factor website" <login-realm>
"Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
- allow-deactivation
- <boilerplate>
- { factor-website "page" } >>template
- test-db <alloy> ;
+ allow-deactivation ;
+
+: <factor-website> ( -- responder )
+ factor-website new-dispatcher
+ <wiki> "wiki" add-responder
+ <user-admin> "user-admin" add-responder
+ URL" /wiki/view/Front Page" <redirect-responder> "" add-responder ;
SYMBOL: key-password
SYMBOL: key-file
SYMBOL: dh-file
: common-configuration ( -- )
- reset-templates
"concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global
"resource:basis/openssl/test/server.pem" key-file set-global
"password" key-password set-global
common-configuration
- <factor-website> main-responder set-global ;
+ <factor-website>
+ <pastebin> <factor-boilerplate> <login-config> "pastebin" add-responder
+ <planet> <factor-boilerplate> <login-config> "planet" add-responder
+ "/tmp/docs/" <help-webapp> "docs" add-responder
+ test-db <alloy>
+ main-responder set-global ;
-: no-www-prefix ( -- responder )
- "http://concatenative.org" <permanent-redirect> <trivial-responder> ;
+: <gitweb> ( path -- responder )
+ <dispatcher>
+ swap <static> enable-cgi >>default
+ URL" /gitweb.cgi" <redirect-responder> "" add-responder ;
: init-production ( -- )
common-configuration
<vhost-dispatcher>
- <factor-website> "concatenative.org" add-responder
- no-www-prefix "www.concatenative.org" add-responder
+ <factor-website> <login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
+ <pastebin> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
+ <planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
+ home "docs" append-path <help-webapp> test-db <alloy> "docs.factorcode.org" add-responder
+ home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
main-responder set-global ;
: <factor-secure-config> ( -- config )
<?xml version='1.0' ?>
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
ARTICLE: "wordtimer" "Word Timer"
-"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $vocab-link "profile-vocab" } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then use " { $link wordtimer-call } " to invoke a quotation and print out the timings." ;
+"The " { $vocab-link "wordtimer" } " vocabulary measures accumulated execution time for words. If you just want to profile the accumulated time taken by all words in a vocab you can use " { $link profile-vocab } ". If you need more fine grained control then do the following: First annotate individual words with the " { $link add-timer } " word or whole vocabularies with " { $link add-timers } ". Then use " { $link wordtimer-call } " to invoke a quotation and print out the timings." ;
ABOUT: "wordtimer"
(modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
(defvar factor-mode-map (make-sparse-keymap))
-
+
(defcustom factor-mode-hook nil
"Hook run when entering Factor mode."
:type 'hook
(use-local-map factor-mode-map)
(setq major-mode 'factor-mode)
(setq mode-name "Factor")
+ (set (make-local-variable 'indent-line-function) #'factor-indent-line)
(make-local-variable 'comment-start)
(setq comment-start "! ")
(make-local-variable 'font-lock-defaults)
(defun factor-clear ()
(interactive)
(factor-send-string "clear"))
-
+
(defun factor-comment-line ()
(interactive)
(beginning-of-line)
(define-key factor-mode-map "\C-c\C-h" 'factor-help)
(define-key factor-mode-map "\C-cc" 'comment-region)
(define-key factor-mode-map [return] 'newline-and-indent)
+(define-key factor-mode-map [tab] 'indent-for-tab-command)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; indentation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst factor-word-starting-keywords
+ '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))
+
+(defmacro factor-word-start-re (keywords)
+ `(format
+ "^\\(%s\\): "
+ (mapconcat 'identity ,keywords "\\|")))
+
+(defun factor-calculate-indentation ()
+ "Calculate Factor indentation for line at point."
+ (let ((not-indented t)
+ (cur-indent 0))
+ (save-excursion
+ (beginning-of-line)
+ (if (bobp)
+ (setq cur-indent 0)
+ (save-excursion
+ (while not-indented
+ ;; Check that we are inside open brackets
+ (save-excursion
+ (let ((cur-depth (factor-brackets-depth)))
+ (forward-line -1)
+ (setq cur-indent (+ (current-indentation)
+ (* default-tab-width
+ (- cur-depth (factor-brackets-depth)))))
+ (setq not-indented nil)))
+ (forward-line -1)
+ ;; Check that we are after the end of previous word
+ (if (looking-at ".*;[ \t]*$")
+ (progn
+ (setq cur-indent (- (current-indentation) default-tab-width))
+ (setq not-indented nil))
+ ;; Check that we are after the start of word
+ (if (looking-at (factor-word-start-re factor-word-starting-keywords))
+; (if (looking-at "^[A-Z:]*: ")
+ (progn
+ (message "inword")
+ (setq cur-indent (+ (current-indentation) default-tab-width))
+ (setq not-indented nil))
+ (if (bobp)
+ (setq not-indented nil))))))))
+ cur-indent))
+
+(defun factor-brackets-depth ()
+ "Returns number of brackets, not closed on previous lines."
+ (syntax-ppss-depth
+ (save-excursion
+ (syntax-ppss (line-beginning-position)))))
+
+(defun factor-indent-line ()
+ "Indent current line as Factor code"
+ (let ((target (factor-calculate-indentation))
+ (pos (- (point-max) (point))))
+ (if (= target (current-indentation))
+ (if (< (current-column) (current-indentation))
+ (back-to-indentation))
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-to target)
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; factor-listener-mode
(defun factor-refresh-all ()
(interactive)
(comint-send-string "*factor*" "refresh-all\n"))
-
-
"adapted from lisp.vim
if exists("g:factor_norainbow")
- syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+ syn region factorQuotation0 matchgroup=factorDelimiter start=/\<\'\?\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.backend.alien
-
-! #alien-invoke
-: set-stack-frame ( n -- )
- dup [ frame-required ] when* \ stack-frame set ;
-
-: with-stack-frame ( n quot -- )
- swap set-stack-frame
- call
- f set-stack-frame ; inline
-
-GENERIC: reg-size ( register-class -- n )
-
-M: int-regs reg-size drop cell ;
-
-M: single-float-regs reg-size drop 4 ;
-
-M: double-float-regs reg-size drop 8 ;
-
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: reg-class inc-reg-class
- dup reg-class-variable inc
- fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: float-regs inc-reg-class
- dup call-next-method
- fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
-
-GENERIC: reg-class-full? ( class -- ? )
-
-M: stack-params reg-class-full? drop t ;
-
-M: object reg-class-full?
- [ reg-class-variable get ] [ param-regs length ] bi >= ;
-
-: spill-param ( reg-class -- n reg-class )
- stack-params get
- >r reg-size stack-params +@ r>
- stack-params ;
-
-: fastcall-param ( reg-class -- n reg-class )
- [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
-
-: alloc-parameter ( parameter -- reg reg-class )
- c-type-reg-class dup reg-class-full?
- [ spill-param ] [ fastcall-param ] if
- [ param-reg ] keep ;
-
-: (flatten-int-type) ( size -- )
- cell /i "void*" c-type <repetition> % ;
-
-GENERIC: flatten-value-type ( type -- )
-
-M: object flatten-value-type , ;
-
-M: struct-type flatten-value-type ( type -- )
- stack-size cell align (flatten-int-type) ;
-
-M: long-long-type flatten-value-type ( type -- )
- stack-size cell align (flatten-int-type) ;
-
-: flatten-value-types ( params -- params )
- #! Convert value type structs to consecutive void*s.
- [
- 0 [
- c-type
- [ parameter-align (flatten-int-type) ] keep
- [ stack-size cell align + ] keep
- flatten-value-type
- ] reduce drop
- ] { } make ;
-
-: each-parameter ( parameters quot -- )
- >r [ parameter-sizes nip ] keep r> 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
- >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
-
-: reset-freg-counts ( -- )
- { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
- #! In quot you can call alloc-parameter
- [ reset-freg-counts call ] with-scope ; inline
-
-: move-parameters ( node word -- )
- #! Moves values from C stack to registers (if word is
- #! %load-param-reg) and registers to C stack (if word is
- #! %save-param-reg).
- >r
- alien-parameters
- flatten-value-types
- r> [ >r alloc-parameter r> execute ] curry each-parameter ;
- inline
-
-: unbox-parameters ( offset node -- )
- parameters>> [
- %prepare-unbox >r over + r> unbox-parameter
- ] reverse-each-parameter drop ;
-
-: prepare-box-struct ( node -- offset )
- #! Return offset on C stack where to store unboxed
- #! parameters. If the C function is returning a structure,
- #! the first parameter is an implicit target area pointer,
- #! so we need to use a different offset.
- return>> dup large-struct?
- [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
-
-: objects>registers ( params -- )
- #! Generate code for unboxing a list of C types, then
- #! generate code for moving these parameters to register on
- #! architectures where parameters are passed in registers.
- [
- [ prepare-box-struct ] keep
- [ unbox-parameters ] keep
- \ %load-param-reg move-parameters
- ] with-param-regs ;
-
-: box-return* ( node -- )
- return>> [ ] [ box-return ] if-void ;
-
-TUPLE: no-such-library name ;
-
-M: no-such-library summary
- drop "Library not found" ;
-
-M: no-such-library compiler-error-type
- drop +linkage+ ;
-
-: no-such-library ( name -- )
- \ no-such-library boa
- compiling-word get compiler-error ;
-
-TUPLE: no-such-symbol name ;
-
-M: no-such-symbol summary
- drop "Symbol not found" ;
-
-M: no-such-symbol compiler-error-type
- drop +linkage+ ;
-
-: no-such-symbol ( name -- )
- \ no-such-symbol boa
- compiling-word get compiler-error ;
-
-: check-dlsym ( symbols dll -- )
- dup dll-valid? [
- dupd [ dlsym ] curry contains?
- [ drop ] [ no-such-symbol ] if
- ] [
- dll-path no-such-library drop
- ] if ;
-
-: stdcall-mangle ( symbol node -- symbol )
- "@"
- swap parameters>> parameter-sizes drop
- number>string 3append ;
-
-: alien-invoke-dlsym ( params -- symbols dll )
- dup function>> dup pick stdcall-mangle 2array
- swap library>> library dup [ dll>> ] when
- 2dup check-dlsym ;
-
-M: #alien-invoke generate-node
- params>>
- dup alien-invoke-frame [
- end-basic-block
- %prepare-alien-invoke
- dup objects>registers
- %prepare-var-args
- dup alien-invoke-dlsym %alien-invoke
- dup %cleanup
- box-return*
- iterate-next
- ] with-stack-frame ;
-
-! #alien-indirect
-M: #alien-indirect generate-node
- params>>
- dup alien-invoke-frame [
- ! Flush registers
- end-basic-block
- ! Save registers for GC
- %prepare-alien-invoke
- ! Save alien at top of stack to temporary storage
- %prepare-alien-indirect
- dup objects>registers
- %prepare-var-args
- ! Call alien in temporary storage
- %alien-indirect
- dup %cleanup
- box-return*
- iterate-next
- ] with-stack-frame ;
-
-! #alien-callback
-: box-parameters ( params -- )
- alien-parameters [ box-parameter ] each-parameter ;
-
-: registers>objects ( node -- )
- [
- dup \ %save-param-reg move-parameters
- "nest_stacks" f %alien-invoke
- box-parameters
- ] with-param-regs ;
-
-TUPLE: callback-context ;
-
-: current-callback 2 getenv ;
-
-: wait-to-return ( token -- )
- dup current-callback eq? [
- drop
- ] [
- yield wait-to-return
- ] if ;
-
-: do-callback ( quot token -- )
- init-catchstack
- dup 2 setenv
- slip
- wait-to-return ; inline
-
-: callback-return-quot ( ctype -- quot )
- return>> {
- { [ dup "void" = ] [ drop [ ] ] }
- { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
- [ c-type c-type-unboxer-quot ]
- } cond ;
-
-: callback-prep-quot ( params -- quot )
- parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
-
-: wrap-callback-quot ( params -- quot )
- [
- [ callback-prep-quot ]
- [ quot>> ]
- [ callback-return-quot ] tri 3append ,
- [ callback-context new do-callback ] %
- ] [ ] make ;
-
-: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
-
-: callback-unwind ( params -- n )
- {
- { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
- { [ dup return>> large-struct? ] [ drop 4 ] }
- [ drop 0 ]
- } cond ;
-
-: %callback-return ( params -- )
- #! All the extra book-keeping for %unwind is only for x86.
- #! On other platforms its an alias for %return.
- dup alien-return
- [ %unnest-stacks ] [ %callback-value ] if-void
- callback-unwind %unwind ;
-
-: generate-callback ( params -- )
- dup xt>> dup [
- init-templates
- %prologue
- dup alien-stack-frame [
- [ registers>objects ]
- [ wrap-callback-quot %alien-callback ]
- [ %callback-return ]
- tri
- ] with-stack-frame
- ] with-cfg-builder ;
-
-M: #alien-callback generate-node
- end-basic-block
- params>> generate-callback iterate-next ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system ;
+USING: accessors assocs arrays generic kernel kernel.private
+math memory namespaces make sequences layouts system hashtables
+classes alien byte-arrays combinators words ;
IN: compiler.backend
-! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( size -- ? )
+! Labels
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
+
+! A pseudo-register class for parameters spilled on the stack
+SINGLETON: stack-params
+
+! Return values of this class go here
+GENERIC: return-reg ( register-class -- reg )
+
+! Sequence of registers used for parameter passing in class
+GENERIC: param-regs ( register-class -- regs )
+
+GENERIC: param-reg ( n register-class -- reg )
+
+M: object param-reg param-regs nth ;
+
+! Load a literal (immediate or indirect)
+GENERIC# load-literal 1 ( obj reg -- )
+
+HOOK: load-indirect cpu ( obj reg -- )
+
+HOOK: stack-frame cpu ( frame-size -- n )
+
+: stack-frame* ( -- n )
+ \ stack-frame get stack-frame ;
+
+! Set up caller stack frame
+HOOK: %prologue cpu ( n -- )
+
+! Tear down stack frame
+HOOK: %epilogue cpu ( n -- )
+
+! Call another word
+HOOK: %call cpu ( word -- )
+
+! Local jump for branches
+HOOK: %jump-label cpu ( label -- )
+
+! Test if vreg is 'f' or not
+HOOK: %jump-f cpu ( label reg -- )
+
+! Test if vreg is 't' or not
+HOOK: %jump-t cpu ( label reg -- )
+
+HOOK: %dispatch cpu ( -- )
+
+HOOK: %dispatch-label cpu ( word -- )
+
+! Return to caller
+HOOK: %return cpu ( -- )
+
+! Change datastack height
+HOOK: %inc-d cpu ( n -- )
+
+! Change callstack height
+HOOK: %inc-r cpu ( n -- )
+
+! Load stack into vreg
+HOOK: %peek cpu ( reg loc -- )
+
+! Store vreg to stack
+HOOK: %replace cpu ( reg loc -- )
+
+! Copy values between vregs
+HOOK: %copy cpu ( dst src -- )
+HOOK: %copy-float cpu ( dst src -- )
+
+! Box and unbox floats
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src -- )
+
+! FFI stuff
+
+! Is this integer small enough to appear in value template
+! slots?
+HOOK: small-enough? cpu ( n -- ? )
+
+! Is this structure small enough to be returned in registers?
+HOOK: struct-small-enough? cpu ( heap-size -- ? )
+
+! Do we pass explode value structs?
+HOOK: value-structs? cpu ( -- ? )
+
+! If t, fp parameters are shadowed by dummy int parameters
+HOOK: fp-shadows-int? cpu ( -- ? )
+
+HOOK: %prepare-unbox cpu ( -- )
+
+HOOK: %unbox cpu ( n reg-class func -- )
+
+HOOK: %unbox-long-long cpu ( n func -- )
+
+HOOK: %unbox-small-struct cpu ( c-type -- )
+
+HOOK: %unbox-large-struct cpu ( n c-type -- )
+
+HOOK: %box cpu ( n reg-class func -- )
+
+HOOK: %box-long-long cpu ( n func -- )
+
+HOOK: %prepare-box-struct cpu ( size -- )
+
+HOOK: %box-small-struct cpu ( c-type -- )
+
+HOOK: %box-large-struct cpu ( n c-type -- )
+
+GENERIC: %save-param-reg ( stack reg reg-class -- )
+
+GENERIC: %load-param-reg ( stack reg reg-class -- )
+
+HOOK: %prepare-alien-invoke cpu ( -- )
+
+HOOK: %prepare-var-args cpu ( -- )
+
+M: object %prepare-var-args ;
+
+HOOK: %alien-invoke cpu ( function library -- )
+
+HOOK: %cleanup cpu ( alien-node -- )
+
+HOOK: %alien-callback cpu ( quot -- )
+
+HOOK: %callback-value cpu ( ctype -- )
+
+! Return to caller with stdcall unwinding (only for x86)
+HOOK: %unwind cpu ( n -- )
+
+HOOK: %prepare-alien-indirect cpu ( -- )
+
+HOOK: %alien-indirect cpu ( -- )
+
+M: stack-params param-reg drop ;
+
+M: stack-params param-regs drop f ;
+
+M: object load-literal load-indirect ;
+
+PREDICATE: small-slot < integer cells small-enough? ;
+
+PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
+
+: if-small-struct ( n size true false -- ? )
+ [ over not over struct-small-enough? and ] 2dip
+ [ [ nip ] prepose ] dip if ;
+ inline
+
+: %unbox-struct ( n c-type -- )
+ [
+ %unbox-small-struct
+ ] [
+ %unbox-large-struct
+ ] if-small-struct ;
+
+: %box-struct ( n c-type -- )
+ [
+ %box-small-struct
+ ] [
+ %box-large-struct
+ ] if-small-struct ;
+
+! Alien accessors
+HOOK: %unbox-byte-array cpu ( dst src -- )
+
+HOOK: %unbox-alien cpu ( dst src -- )
+
+HOOK: %unbox-f cpu ( dst src -- )
+
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
+
+HOOK: %box-alien cpu ( dst src -- )
+
+! Allocation
+HOOK: %allot cpu ( dst size type tag temp -- )
+
+HOOK: %write-barrier cpu ( src temp -- )
+
+! GC check
+HOOK: %gc cpu ( -- )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system cpu.x86.assembler compiler.registers compiler.backend ;
+USING: alien.c-types arrays kernel kernel.private math
+namespaces sequences stack-checker.known-words system layouts
+combinators command-line io vocabs.loader accessors init
+compiler compiler.units compiler.constants compiler.codegen
+compiler.cfg.builder compiler.alien compiler.codegen.fixup
+cpu.x86 compiler.backend compiler.backend.x86 ;
IN: compiler.backend.x86.32
+! We implement the FFI for Linux, OS X and Windows all at once.
+! OS X requires that the stack be 16-byte aligned, and we do
+! this on all platforms, sacrificing some stack space for
+! code simplicity.
+
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
- { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
+ { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
+
+M: x86.32 ds-reg ESI ;
+M: x86.32 rs-reg EDI ;
+M: x86.32 stack-reg ESP ;
+M: x86.32 stack-save-reg EDX ;
+M: x86.32 temp-reg-1 EAX ;
+M: x86.32 temp-reg-2 ECX ;
+
+M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
+
+M: x86.32 %alien-invoke (CALL) rel-dlsym ;
+
+M: x86.32 struct-small-enough? ( size -- ? )
+ heap-size { 1 2 4 8 } member?
+ os { linux netbsd solaris } member? not and ;
+
+! On x86, parameters are never passed in registers.
+M: int-regs return-reg drop EAX ;
+M: int-regs param-regs drop { } ;
+M: int-regs push-return-reg return-reg PUSH ;
+: load/store-int-return ( n reg-class -- src dst )
+ return-reg stack-reg rot [+] ;
+M: int-regs load-return-reg load/store-int-return MOV ;
+M: int-regs store-return-reg load/store-int-return swap MOV ;
+
+M: float-regs param-regs drop { } ;
+
+: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
+
+M: float-regs push-return-reg
+ stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
+
+: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
+
+: load/store-float-return ( n reg-class -- op size )
+ [ stack@ ] [ reg-size ] bi* ;
+M: float-regs load-return-reg load/store-float-return FLD ;
+M: float-regs store-return-reg load/store-float-return FSTP ;
+
+: align-sub ( n -- )
+ dup 16 align swap - ESP swap SUB ;
+
+: align-add ( n -- )
+ 16 align ESP swap ADD ;
+
+: with-aligned-stack ( n quot -- )
+ swap dup align-sub slip align-add ; inline
+
+M: x86.32 fixnum>slot@ 1 SHR ;
+
+M: x86.32 prepare-division CDQ ;
+
+M: x86.32 load-indirect
+ 0 [] MOV rc-absolute-cell rel-literal ;
+
+M: object %load-param-reg 3drop ;
+
+M: object %save-param-reg 3drop ;
+
+: box@ ( n reg-class -- stack@ )
+ #! Used for callbacks; we want to box the values given to
+ #! us by the C function caller. Computes stack location of
+ #! nth parameter; note that we must go back one more stack
+ #! frame, since %box sets one up to call the one-arg boxer
+ #! function. The size of this stack frame so far depends on
+ #! the reg-class of the boxer's arg.
+ reg-size neg + stack-frame* + 20 + ;
+
+: (%box) ( n reg-class -- )
+ #! If n is f, push the return register onto the stack; we
+ #! are boxing a return value of a C function. If n is an
+ #! integer, push [ESP+n] on the stack; we are boxing a
+ #! parameter being passed to a callback from C.
+ over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
+ push-return-reg ;
+
+M: x86.32 %box ( n reg-class func -- )
+ over reg-size [
+ >r (%box) r> f %alien-invoke
+ ] with-aligned-stack ;
+
+: (%box-long-long) ( n -- )
+ #! If n is f, push the return registers onto the stack; we
+ #! are boxing a return value of a C function. If n is an
+ #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
+ #! boxing a parameter being passed to a callback from C.
+ [
+ int-regs box@
+ EDX over stack@ MOV
+ EAX swap cell - stack@ MOV
+ ] when*
+ EDX PUSH
+ EAX PUSH ;
+
+M: x86.32 %box-long-long ( n func -- )
+ 8 [
+ [ (%box-long-long) ] [ f %alien-invoke ] bi*
+ ] with-aligned-stack ;
+
+: struct-return@ ( size n -- n )
+ [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
+
+M: x86.32 %box-large-struct ( n c-type -- )
+ ! Compute destination address
+ heap-size
+ [ swap struct-return@ ] keep
+ ECX ESP roll [+] LEA
+ 8 [
+ ! Push struct size
+ PUSH
+ ! Push destination address
+ ECX PUSH
+ ! Copy the struct from the C stack
+ "box_value_struct" f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %prepare-box-struct ( size -- )
+ ! Compute target address for value struct return
+ EAX ESP rot f struct-return@ [+] LEA
+ ! Store it as the first parameter
+ ESP [] EAX MOV ;
+
+M: x86.32 %box-small-struct ( c-type -- )
+ #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
+ 12 [
+ heap-size PUSH
+ EDX PUSH
+ EAX PUSH
+ "box_small_struct" f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %prepare-unbox ( -- )
+ #! Move top of data stack to EAX.
+ EAX ESI [] MOV
+ ESI 4 SUB ;
+
+: (%unbox) ( func -- )
+ 4 [
+ ! Push parameter
+ EAX PUSH
+ ! Call the unboxer
+ f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %unbox ( n reg-class func -- )
+ #! The value being unboxed must already be in EAX.
+ #! If n is f, we're unboxing a return value about to be
+ #! returned by the callback. Otherwise, we're unboxing
+ #! a parameter to a C function about to be called.
+ (%unbox)
+ ! Store the return value on the C stack
+ over [ store-return-reg ] [ 2drop ] if ;
+
+M: x86.32 %unbox-long-long ( n func -- )
+ (%unbox)
+ ! Store the return value on the C stack
+ [
+ dup stack@ EAX MOV
+ cell + stack@ EDX MOV
+ ] when* ;
+
+: %unbox-struct-1 ( -- )
+ #! Alien must be in EAX.
+ 4 [
+ EAX PUSH
+ "alien_offset" f %alien-invoke
+ ! Load first cell
+ EAX EAX [] MOV
+ ] with-aligned-stack ;
+
+: %unbox-struct-2 ( -- )
+ #! Alien must be in EAX.
+ 4 [
+ EAX PUSH
+ "alien_offset" f %alien-invoke
+ ! Load second cell
+ EDX EAX 4 [+] MOV
+ ! Load first cell
+ EAX EAX [] MOV
+ ] with-aligned-stack ;
+
+M: x86 %unbox-small-struct ( size -- )
+ #! Alien must be in EAX.
+ heap-size cell align cell /i {
+ { 1 [ %unbox-struct-1 ] }
+ { 2 [ %unbox-struct-2 ] }
+ } case ;
+
+M: x86.32 %unbox-large-struct ( n c-type -- )
+ #! Alien must be in EAX.
+ heap-size
+ ! Compute destination address
+ ECX ESP roll [+] LEA
+ 12 [
+ ! Push struct size
+ PUSH
+ ! Push destination address
+ ECX PUSH
+ ! Push source address
+ EAX PUSH
+ ! Copy the struct to the stack
+ "to_value_struct" f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %prepare-alien-indirect ( -- )
+ "unbox_alien" f %alien-invoke
+ cell temp@ EAX MOV ;
+
+M: x86.32 %alien-indirect ( -- )
+ cell temp@ CALL ;
+
+M: x86.32 %alien-callback ( quot -- )
+ 4 [
+ EAX load-indirect
+ EAX PUSH
+ "c_to_factor" f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %callback-value ( ctype -- )
+ ! Align C stack
+ ESP 12 SUB
+ ! Save top of data stack
+ %prepare-unbox
+ EAX PUSH
+ ! Restore data/call/retain stacks
+ "unnest_stacks" f %alien-invoke
+ ! Place top of data stack in EAX
+ EAX POP
+ ! Restore C stack
+ ESP 12 ADD
+ ! Unbox EAX
+ unbox-return ;
+
+M: x86.32 %cleanup ( alien-node -- )
+ #! a) If we just called an stdcall function in Windows, it
+ #! cleaned up the stack frame for us. But we don't want that
+ #! so we 'undo' the cleanup since we do that in %epilogue.
+ #! b) If we just called a function returning a struct, we
+ #! have to fix ESP.
+ {
+ {
+ [ dup abi>> "stdcall" = ]
+ [ alien-stack-frame ESP swap SUB ]
+ } {
+ [ dup return>> large-struct? ]
+ [ drop EAX PUSH ]
+ }
+ [ drop ]
+ } cond ;
+
+M: x86.32 %unwind ( n -- ) RET ;
+
+os windows? [
+ cell "longlong" c-type (>>align)
+ cell "ulonglong" c-type (>>align)
+ 4 "double" c-type (>>align)
+] unless
+
+: (sse2?) ( -- ? ) "Intrinsic" throw ;
+
+<<
+
+\ (sse2?) [
+ { EAX EBX ECX EDX } [ PUSH ] each
+ EAX 1 MOV
+ CPUID
+ EDX 26 SHR
+ EDX 1 AND
+ { EAX EBX ECX EDX } [ POP ] each
+ JE
+] { } define-if-intrinsic
+
+\ (sse2?) { } { object } define-primitive
+
+>>
+
+: sse2? ( -- ? ) (sse2?) ;
+
+"-no-sse2" cli-args member? [
+ "Checking if your CPU supports SSE2..." print flush
+ [ optimized-recompile-hook ] recompile-hook [
+ [ sse2? ] compile-call
+ ] with-variable
+ [
+ " - yes" print
+ "compiler.backend.x86.sse2" require
+ [
+ sse2? [
+ "This image was built to use SSE2, which your CPU does not support." print
+ "You will need to bootstrap Factor again." print
+ flush
+ 1 exit
+ ] unless
+ ] "compiler.backend.x86" add-init-hook
+ ] [
+ " - no" print
+ ] if
+] unless
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays kernel kernel.private math
+namespaces make sequences system layouts alien alien.accessors
+alien.structs slots splitting assocs combinators
+cpu.x86 compiler.codegen compiler.constants
+compiler.codegen.fixup compiler.cfg.registers compiler.backend
+compiler.backend.x86 compiler.backend.x86.sse2 ;
+IN: compiler.backend.x86.64
+
+M: x86.64 machine-registers
+ {
+ { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
+ { double-float-regs {
+ XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
+ XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
+ } }
+ } ;
+
+M: x86.64 ds-reg R14 ;
+M: x86.64 rs-reg R15 ;
+M: x86.64 stack-reg RSP ;
+M: x86.64 stack-save-reg RSI ;
+M: x86.64 temp-reg-1 RAX ;
+M: x86.64 temp-reg-2 RCX ;
+
+M: int-regs return-reg drop RAX ;
+M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
+
+M: float-regs return-reg drop XMM0 ;
+
+M: float-regs param-regs
+ drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+
+M: x86.64 fixnum>slot@ drop ;
+
+M: x86.64 prepare-division CQO ;
+
+M: x86.64 load-indirect ( literal reg -- )
+ 0 [] MOV rc-relative rel-literal ;
+
+M: stack-params %load-param-reg
+ drop
+ >r R11 swap stack@ MOV
+ r> stack@ R11 MOV ;
+
+M: stack-params %save-param-reg
+ >r stack-frame* + cell + swap r> %load-param-reg ;
+
+: with-return-regs ( quot -- )
+ [
+ V{ RDX RAX } clone int-regs set
+ V{ XMM1 XMM0 } clone float-regs set
+ call
+ ] with-scope ; inline
+
+! The ABI for passing structs by value is pretty messed up
+<< "void*" c-type clone "__stack_value" define-primitive-type
+stack-params "__stack_value" c-type (>>reg-class) >>
+
+: struct-types&offset ( struct-type -- pairs )
+ fields>> [
+ [ type>> ] [ offset>> ] bi 2array
+ ] map ;
+
+: split-struct ( pairs -- seq )
+ [
+ [ 8 mod zero? [ t , ] when , ] assoc-each
+ ] { } make { t } split harvest ;
+
+: flatten-small-struct ( c-type -- seq )
+ struct-types&offset split-struct [
+ [ c-type c-type-reg-class ] map
+ int-regs swap member? "void*" "double" ? c-type
+ ] map ;
+
+: flatten-large-struct ( c-type -- seq )
+ heap-size cell align
+ cell /i "__stack_value" c-type <repetition> ;
+
+M: struct-type flatten-value-type ( type -- seq )
+ dup heap-size 16 > [
+ flatten-large-struct
+ ] [
+ flatten-small-struct
+ ] if ;
+
+M: x86.64 %prepare-unbox ( -- )
+ ! First parameter is top of stack
+ RDI R14 [] MOV
+ R14 cell SUB ;
+
+M: x86.64 %unbox ( n reg-class func -- )
+ ! Call the unboxer
+ f %alien-invoke
+ ! Store the return value on the C stack
+ over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+
+M: x86.64 %unbox-long-long ( n func -- )
+ int-regs swap %unbox ;
+
+: %unbox-struct-field ( c-type i -- )
+ ! Alien must be in RDI.
+ RDI swap cells [+] swap reg-class>> {
+ { int-regs [ int-regs get pop swap MOV ] }
+ { double-float-regs [ float-regs get pop swap MOVSD ] }
+ } case ;
+
+M: x86.64 %unbox-small-struct ( c-type -- )
+ ! Alien must be in RDI.
+ "alien_offset" f %alien-invoke
+ ! Move alien_offset() return value to RDI so that we don't
+ ! clobber it.
+ RDI RAX MOV
+ [
+ flatten-small-struct [ %unbox-struct-field ] each-index
+ ] with-return-regs ;
+
+M: x86.64 %unbox-large-struct ( n c-type -- )
+ ! Source is in RDI
+ heap-size
+ ! Load destination address
+ RSI RSP roll [+] LEA
+ ! Load structure size
+ RDX swap MOV
+ ! Copy the struct to the C stack
+ "to_value_struct" f %alien-invoke ;
+
+: load-return-value ( reg-class -- )
+ 0 over param-reg swap return-reg
+ 2dup eq? [ 2drop ] [ MOV ] if ;
+
+M: x86.64 %box ( n reg-class func -- )
+ rot [
+ rot [ 0 swap param-reg ] keep %load-param-reg
+ ] [
+ swap load-return-value
+ ] if*
+ f %alien-invoke ;
+
+M: x86.64 %box-long-long ( n func -- )
+ int-regs swap %box ;
+
+M: x86.64 struct-small-enough? ( size -- ? )
+ heap-size 2 cells <= ;
+
+: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
+
+: %box-struct-field ( c-type i -- )
+ box-struct-field@ swap reg-class>> {
+ { int-regs [ int-regs get pop MOV ] }
+ { double-float-regs [ float-regs get pop MOVSD ] }
+ } case ;
+
+M: x86.64 %box-small-struct ( c-type -- )
+ #! Box a <= 16-byte struct.
+ [
+ [ flatten-small-struct [ %box-struct-field ] each-index ]
+ [ RDX swap heap-size MOV ] bi
+ RDI 0 box-struct-field@ MOV
+ RSI 1 box-struct-field@ MOV
+ "box_small_struct" f %alien-invoke
+ ] with-return-regs ;
+
+: struct-return@ ( size n -- n )
+ [ ] [ \ stack-frame get swap - ] ?if ;
+
+M: x86.64 %box-large-struct ( n c-type -- )
+ ! Struct size is parameter 2
+ heap-size
+ RSI over MOV
+ ! Compute destination address
+ swap struct-return@ RDI RSP rot [+] LEA
+ ! Copy the struct from the C stack
+ "box_value_struct" f %alien-invoke ;
+
+M: x86.64 %prepare-box-struct ( size -- )
+ ! Compute target address for value struct return
+ RAX RSP rot f struct-return@ [+] LEA
+ RSP 0 [+] RAX MOV ;
+
+M: x86.64 %prepare-var-args RAX RAX XOR ;
+
+M: x86.64 %alien-global
+ [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
+
+M: x86.64 %alien-invoke
+ R11 0 MOV
+ rc-absolute-cell rel-dlsym
+ R11 CALL ;
+
+M: x86.64 %prepare-alien-indirect ( -- )
+ "unbox_alien" f %alien-invoke
+ cell temp@ RAX MOV ;
+
+M: x86.64 %alien-indirect ( -- )
+ cell temp@ CALL ;
+
+M: x86.64 %alien-callback ( quot -- )
+ RDI load-indirect "c_to_factor" f %alien-invoke ;
+
+M: x86.64 %callback-value ( ctype -- )
+ ! Save top of data stack
+ %prepare-unbox
+ ! Put former top of data stack in RDI
+ cell temp@ RDI MOV
+ ! Restore data/call/retain stacks
+ "unnest_stacks" f %alien-invoke
+ ! Put former top of data stack in RDI
+ RDI cell temp@ MOV
+ ! Unbox former top of data stack to return registers
+ unbox-return ;
+
+M: x86.64 %cleanup ( alien-node -- ) drop ;
+
+M: x86.64 %unwind ( n -- ) drop 0 RET ;
+
+USE: cpu.x86.intrinsics
+
+! On 64-bit systems, the result of reading 4 bytes from memory
+! is a fixnum.
+\ alien-unsigned-4 small-reg-32 define-unsigned-getter
+\ set-alien-unsigned-4 small-reg-32 define-setter
+
+\ alien-signed-4 small-reg-32 define-signed-getter
+\ set-alien-signed-4 small-reg-32 define-setter
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors arrays generic kernel system
+kernel.private math math.private memory namespaces sequences
+words math.floats.private layouts quotations locals cpu.x86
+compiler.codegen compiler.cfg.templates compiler.cfg.builder
+compiler.cfg.registers compiler.constants compiler.backend
+compiler.backend.x86 ;
+IN: compiler.backend.x86.sse2
+
+M:: x86 %box-float ( dst src temp -- )
+ #! Only called by pentium4 backend, uses SSE2 instruction
+ dst 16 float float temp %allot
+ dst 8 float tag-number - [+] src MOVSD ;
+
+M: x86 %unbox-float ( dst src -- )
+ float-offset [+] MOVSD ;
+
+: define-float-op ( word op -- )
+ [ "x" operand "y" operand ] swap suffix T{ template
+ { input { { float "x" } { float "y" } } }
+ { output { "x" } }
+ } define-intrinsic ;
+
+{
+ { float+ ADDSD }
+ { float- SUBSD }
+ { float* MULSD }
+ { float/f DIVSD }
+} [
+ first2 define-float-op
+] each
+
+: define-float-jump ( word op -- )
+ [ "x" operand "y" operand UCOMISD ] swap suffix
+ { { float "x" } { float "y" } } define-if-intrinsic ;
+
+{
+ { float< JAE }
+ { float<= JA }
+ { float> JBE }
+ { float>= JB }
+ { float= JNE }
+} [
+ first2 define-float-jump
+] each
+
+\ float>fixnum [
+ "out" operand "in" operand CVTTSD2SI
+ "out" operand tag-bits get SHL
+] T{ template
+ { input { { float "in" } } }
+ { scratch { { f "out" } } }
+ { output { "out" } }
+} define-intrinsic
+
+\ fixnum>float [
+ "in" operand %untag-fixnum
+ "out" operand "in" operand CVTSI2SD
+] T{ template
+ { input { { f "in" } } }
+ { scratch { { float "out" } } }
+ { output { "out" } }
+ { clobber { "in" } }
+} define-intrinsic
+
+: alien-float-get-template
+ T{ template
+ { input {
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { scratch { { float "value" } } }
+ { output { "value" } }
+ { clobber { "offset" } }
+ } ;
+
+: alien-float-set-template
+ T{ template
+ { input {
+ { float "value" float }
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { clobber { "offset" } }
+ } ;
+
+: define-alien-float-intrinsics ( word get-quot word set-quot -- )
+ [ "value" operand swap %alien-accessor ] curry
+ alien-float-set-template
+ define-intrinsic
+ [ "value" operand swap %alien-accessor ] curry
+ alien-float-get-template
+ define-intrinsic ;
+
+\ alien-double
+[ MOVSD ]
+\ set-alien-double
+[ swap MOVSD ]
+define-alien-float-intrinsics
+
+\ alien-float
+[ dupd MOVSS dup CVTSS2SD ]
+\ set-alien-float
+[ swap dup dup CVTSD2SS MOVSS ]
+define-alien-float-intrinsics
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays alien.accessors
+compiler.backend kernel kernel.private math memory namespaces
+make sequences words system layouts combinators math.order
+math.private alien alien.c-types slots.private cpu.x86
+cpu.x86.private locals compiler.backend compiler.codegen.fixup
+compiler.constants compiler.intrinsics compiler.cfg.builder
+compiler.cfg.registers compiler.cfg.stacks
+compiler.cfg.templates compiler.codegen ;
+IN: compiler.backend.x86
+
+HOOK: ds-reg cpu ( -- reg )
+HOOK: rs-reg cpu ( -- reg )
+HOOK: stack-reg cpu ( -- reg )
+HOOK: stack-save-reg cpu ( -- reg )
+
+: stack@ ( n -- op ) stack-reg swap [+] ;
+
+: reg-stack ( n reg -- op ) swap cells neg [+] ;
+
+GENERIC: loc>operand ( loc -- operand )
+
+M: ds-loc loc>operand n>> ds-reg reg-stack ;
+M: rs-loc loc>operand n>> rs-reg reg-stack ;
+
+M: int-regs %save-param-reg drop >r stack@ r> MOV ;
+M: int-regs %load-param-reg drop swap stack@ MOV ;
+
+GENERIC: MOVSS/D ( dst src reg-class -- )
+
+M: single-float-regs MOVSS/D drop MOVSS ;
+M: double-float-regs MOVSS/D drop MOVSD ;
+
+M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
+M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
+
+GENERIC: push-return-reg ( reg-class -- )
+GENERIC: load-return-reg ( stack@ reg-class -- )
+GENERIC: store-return-reg ( stack@ reg-class -- )
+
+! Only used by inline allocation
+HOOK: temp-reg-1 cpu ( -- reg )
+HOOK: temp-reg-2 cpu ( -- reg )
+
+HOOK: fixnum>slot@ cpu ( op -- )
+
+HOOK: prepare-division cpu ( -- )
+
+M: f load-literal
+ \ f tag-number MOV drop ;
+
+M: fixnum load-literal
+ swap tag-fixnum MOV ;
+
+M: x86 stack-frame ( n -- i )
+ 3 cells + 16 align cell - ;
+
+: factor-area-size ( -- n ) 4 cells ;
+
+M: x86 %prologue ( n -- )
+ temp-reg-1 0 MOV rc-absolute-cell rel-this
+ dup cell + PUSH
+ temp-reg-1 PUSH
+ stack-reg swap 2 cells - SUB ;
+
+M: x86 %epilogue ( n -- )
+ stack-reg swap ADD ;
+
+HOOK: %alien-global cpu ( symbol dll register -- )
+
+M: x86 %prepare-alien-invoke
+ #! Save Factor stack pointers in case the C code calls a
+ #! callback which does a GC, which must reliably trace
+ #! all roots.
+ "stack_chain" f temp-reg-1 %alien-global
+ temp-reg-1 [] stack-reg MOV
+ temp-reg-1 [] cell SUB
+ temp-reg-1 2 cells [+] ds-reg MOV
+ temp-reg-1 3 cells [+] rs-reg MOV ;
+
+M: x86 %call ( label -- ) CALL ;
+
+M: x86 %jump-label ( label -- ) JMP ;
+
+M: x86 %jump-f ( label vreg -- ) \ f tag-number CMP JE ;
+
+M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
+
+: code-alignment ( -- n )
+ building get length dup cell align swap - ;
+
+: align-code ( n -- )
+ 0 <repetition> % ;
+
+M:: x86 %dispatch ( src temp -- )
+ ! Load jump table base. We use a temporary register
+ ! since on AMD64 we have to load a 64-bit immediate. On
+ ! x86, this is redundant.
+ ! Untag and multiply to get a jump table offset
+ src fixnum>slot@
+ ! Add jump table base
+ temp HEX: ffffffff MOV rc-absolute-cell rel-here
+ src temp ADD
+ src HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ code-alignment dup bootstrap-cell 8 = 15 9 ? +
+ building get dup pop* push
+ align-code ;
+
+M: x86 %dispatch-label ( word -- )
+ 0 cell, rc-absolute-cell rel-word ;
+
+M: x86 %peek loc>operand MOV ;
+
+M: x86 %replace loc>operand swap MOV ;
+
+: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
+
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
+
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
+
+M: x86 fp-shadows-int? ( -- ? ) f ;
+
+M: x86 value-structs? t ;
+
+M: x86 small-enough? ( n -- ? )
+ HEX: -80000000 HEX: 7fffffff between? ;
+
+: %untag ( reg -- ) tag-mask get bitnot AND ;
+
+: %untag-fixnum ( reg -- ) tag-bits get SAR ;
+
+: %tag-fixnum ( reg -- ) tag-bits get SHL ;
+
+: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
+
+M: x86 %return ( -- ) 0 %unwind ;
+
+! Alien intrinsics
+M: x86 %unbox-byte-array ( dst src -- )
+ byte-array-offset [+] LEA ;
+
+M: x86 %unbox-alien ( dst src -- )
+ alien-offset [+] MOV ;
+
+M: x86 %unbox-f ( dst src -- )
+ drop 0 MOV ;
+
+M: x86 %unbox-any-c-ptr ( dst src -- )
+ { "is-byte-array" "end" "start" } [ define-label ] each
+ ! Address is computed in ds-reg
+ ds-reg PUSH
+ ds-reg 0 MOV
+ ! Object is stored in ds-reg
+ rs-reg PUSH
+ rs-reg swap MOV
+ ! We come back here with displaced aliens
+ "start" resolve-label
+ ! Is the object f?
+ rs-reg \ f tag-number CMP
+ "end" get JE
+ ! Is the object an alien?
+ rs-reg header-offset [+] alien type-number tag-fixnum CMP
+ "is-byte-array" get JNE
+ ! If so, load the offset and add it to the address
+ ds-reg rs-reg alien-offset [+] ADD
+ ! Now recurse on the underlying alien
+ rs-reg rs-reg underlying-alien-offset [+] MOV
+ "start" get JMP
+ "is-byte-array" resolve-label
+ ! Add byte array address to address being computed
+ ds-reg rs-reg ADD
+ ! Add an offset to start of byte array's data
+ ds-reg byte-array-offset ADD
+ "end" resolve-label
+ ! Done, store address in destination register
+ ds-reg MOV
+ ! Restore rs-reg
+ rs-reg POP
+ ! Restore ds-reg
+ ds-reg POP ;
+
+M:: x86 %write-barrier ( src temp -- )
+ #! Mark the card pointed to by vreg.
+ ! Mark the card
+ src card-bits SHR
+ "cards_offset" f temp %alien-global
+ temp temp [+] card-mark <byte> MOV
+
+ ! Mark the card deck
+ temp deck-bits card-bits - SHR
+ "decks_offset" f temp %alien-global
+ temp temp [+] card-mark <byte> MOV ;
+
+: load-zone-ptr ( reg -- )
+ #! Load pointer to start of zone array
+ 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+
+: load-allot-ptr ( temp -- )
+ [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
+
+: inc-allot-ptr ( n temp -- )
+ [ POP ] [ cell [+] swap 8 align ADD ] bi ;
+
+: store-header ( temp type -- )
+ [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
+
+: store-tagged ( dst temp tag -- )
+ dupd tag-number OR MOV ;
+
+M:: x86 %allot ( dst size type tag temp -- )
+ temp load-allot-ptr
+ temp type store-header
+ temp size inc-allot-ptr
+ dst temp store-tagged ;
+
+M: x86 %gc ( -- )
+ "end" define-label
+ temp-reg-1 load-zone-ptr
+ temp-reg-2 temp-reg-1 cell [+] MOV
+ temp-reg-2 1024 ADD
+ temp-reg-1 temp-reg-1 3 cells [+] MOV
+ temp-reg-2 temp-reg-1 CMP
+ "end" get JLE
+ %prepare-alien-invoke
+ "minor_gc" f %alien-invoke
+ "end" resolve-label ;
+
+: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
+
+:: %allot-bignum-signed-1 ( dst src temp -- )
+ #! on entry, inreg is a signed 32-bit quantity
+ #! exits with tagged ptr to bignum in outreg
+ #! 1 cell header, 1 cell length, 1 cell sign, + digits
+ #! length is the # of digits + sign
+ [
+ { "end" "nonzero" "positive" "store" } [ define-label ] each
+ src 0 CMP ! is it zero?
+ "nonzero" get JNE
+ ! Use cached zero value
+ 0 >bignum dst load-indirect
+ "end" get JMP
+ "nonzero" resolve-label
+ ! Allocate a bignum
+ dst 4 cells bignum bignum temp %allot
+ ! Write length
+ dst 1 bignum@ 2 MOV
+ ! Test sign
+ src 0 CMP
+ "positive" get JGE
+ dst 2 bignum@ 1 MOV ! negative sign
+ src NEG
+ "store" get JMP
+ "positive" resolve-label
+ dst 2 bignum@ 0 MOV ! positive sign
+ "store" resolve-label
+ dst 3 bignum@ src MOV
+ "end" resolve-label
+ ] with-scope ;
+
+: alien@ ( reg n -- op ) cells object tag-number - [+] ;
+
+M:: x86 %box-alien ( dst src temp -- )
+ [
+ { "end" "f" } [ define-label ] each
+ src 0 CMP
+ "f" get JE
+ dst 4 cells alien object temp %allot
+ dst 1 alien@ \ f tag-number MOV
+ dst 2 alien@ \ f tag-number MOV
+ ! Store src in alien-offset slot
+ dst 3 alien@ src MOV
+ "end" get JMP
+ "f" resolve-label
+ \ f tag-number MOV
+ "end" resolve-label
+ ] with-scope ;
+
+! Type checks
+\ tag [
+ "in" operand tag-mask get AND
+ "in" operand %tag-fixnum
+] T{ template
+ { input { { f "in" } } }
+ { output { "in" } }
+} define-intrinsic
+
+! Slots
+: %slot-literal-known-tag ( -- op )
+ "obj" operand
+ "n" get cells
+ "obj" operand-tag - [+] ;
+
+: %slot-literal-any-tag ( -- op )
+ "obj" operand %untag
+ "obj" operand "n" get cells [+] ;
+
+: %slot-any ( -- op )
+ "obj" operand %untag
+ "n" operand fixnum>slot@
+ "obj" operand "n" operand [+] ;
+
+\ slot {
+ ! Slot number is literal and the tag is known
+ {
+ [ "val" operand %slot-literal-known-tag MOV ] T{ template
+ { input { { f "obj" known-tag } { small-slot "n" } } }
+ { scratch { { f "val" } } }
+ { output { "val" } }
+ }
+ }
+ ! Slot number is literal
+ {
+ [ "obj" operand %slot-literal-any-tag MOV ] T{ template
+ { input { { f "obj" } { small-slot "n" } } }
+ { output { "obj" } }
+ }
+ }
+ ! Slot number in a register
+ {
+ [ "obj" operand %slot-any MOV ] T{ template
+ { input { { f "obj" } { f "n" } } }
+ { output { "obj" } }
+ { clobber { "n" } }
+ }
+ }
+} define-intrinsics
+
+\ (set-slot) {
+ ! Slot number is literal and the tag is known
+ {
+ [ %slot-literal-known-tag "val" operand MOV ] T{ template
+ { input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
+ { scratch { { f "scratch" } } }
+ { clobber { "obj" } }
+ }
+ }
+ ! Slot number is literal
+ {
+ [ %slot-literal-any-tag "val" operand MOV ] T{ template
+ { input { { f "val" } { f "obj" } { small-slot "n" } } }
+ { scratch { { f "scratch" } } }
+ { clobber { "obj" } }
+ }
+ }
+ ! Slot number in a register
+ {
+ [ %slot-any "val" operand MOV ] T{ template
+ { input { { f "val" } { f "obj" } { f "n" } } }
+ { scratch { { f "scratch" } } }
+ { clobber { "obj" "n" } }
+ }
+ }
+} define-intrinsics
+
+! Sometimes, we need to do stuff with operands which are
+! less than the word size. Instead of teaching the register
+! allocator about the different sized registers, with all
+! the complexity this entails, we just push/pop a register
+! which is guaranteed to be unused (the tempreg)
+: small-reg cell 8 = RBX EBX ? ; inline
+: small-reg-8 BL ; inline
+: small-reg-16 BX ; inline
+: small-reg-32 EBX ; inline
+
+! Fixnums
+: fixnum-op ( op hash -- pair )
+ >r [ "x" operand "y" operand ] swap suffix r> 2array ;
+
+: fixnum-value-op ( op -- pair )
+ T{ template
+ { input { { f "x" } { small-tagged "y" } } }
+ { output { "x" } }
+ } fixnum-op ;
+
+: fixnum-register-op ( op -- pair )
+ T{ template
+ { input { { f "x" } { f "y" } } }
+ { output { "x" } }
+ } fixnum-op ;
+
+: define-fixnum-op ( word op -- )
+ [ fixnum-value-op ] keep fixnum-register-op
+ 2array define-intrinsics ;
+
+{
+ { fixnum+fast ADD }
+ { fixnum-fast SUB }
+ { fixnum-bitand AND }
+ { fixnum-bitor OR }
+ { fixnum-bitxor XOR }
+} [
+ first2 define-fixnum-op
+] each
+
+\ fixnum-bitnot [
+ "x" operand NOT
+ "x" operand tag-mask get XOR
+] T{ template
+ { input { { f "x" } } }
+ { output { "x" } }
+} define-intrinsic
+
+\ fixnum*fast {
+ {
+ [
+ "x" operand "y" get IMUL2
+ ] T{ template
+ { input { { f "x" } { [ small-tagged? ] "y" } } }
+ { output { "x" } }
+ }
+ } {
+ [
+ "out" operand "x" operand MOV
+ "out" operand %untag-fixnum
+ "y" operand "out" operand IMUL2
+ ] T{ template
+ { input { { f "x" } { f "y" } } }
+ { scratch { { f "out" } } }
+ { output { "out" } }
+ }
+ }
+} define-intrinsics
+
+: %untag-fixnums ( seq -- )
+ [ %untag-fixnum ] unique-operands ;
+
+\ fixnum-shift-fast [
+ "x" operand "y" get
+ dup 0 < [ neg SAR ] [ SHL ] if
+ ! Mask off low bits
+ "x" operand %untag
+] T{ template
+ { input { { f "x" } { [ ] "y" } } }
+ { output { "x" } }
+} define-intrinsic
+
+: overflow-check ( word -- )
+ "end" define-label
+ "z" operand "x" operand MOV
+ "z" operand "y" operand pick execute
+ ! If the previous arithmetic operation overflowed, then we
+ ! turn the result into a bignum and leave it in EAX.
+ "end" get JNO
+ ! There was an overflow. Recompute the original operand.
+ { "y" "x" } %untag-fixnums
+ "x" operand "y" operand rot execute
+ "z" operand "x" operand "y" operand %allot-bignum-signed-1
+ "end" resolve-label ; inline
+
+: overflow-template ( word insn -- )
+ [ overflow-check ] curry T{ template
+ { input { { f "x" } { f "y" } } }
+ { scratch { { f "z" } } }
+ { output { "z" } }
+ { clobber { "x" "y" } }
+ { gc t }
+ } define-intrinsic ;
+
+\ fixnum+ \ ADD overflow-template
+\ fixnum- \ SUB overflow-template
+
+: fixnum-jump ( op inputs -- pair )
+ >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
+
+: fixnum-value-jump ( op -- pair )
+ { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
+
+: fixnum-register-jump ( op -- pair )
+ { { f "x" } { f "y" } } fixnum-jump ;
+
+: define-fixnum-jump ( word op -- )
+ [ fixnum-value-jump ] keep fixnum-register-jump
+ 2array define-if-intrinsics ;
+
+{
+ { fixnum< JL }
+ { fixnum<= JLE }
+ { fixnum> JG }
+ { fixnum>= JGE }
+ { eq? JE }
+} [
+ first2 define-fixnum-jump
+] each
+
+\ fixnum>bignum [
+ "x" operand %untag-fixnum
+ "x" operand dup "scratch" operand %allot-bignum-signed-1
+] T{ template
+ { input { { f "x" } } }
+ { scratch { { f "scratch" } } }
+ { output { "x" } }
+ { gc t }
+} define-intrinsic
+
+\ bignum>fixnum [
+ "nonzero" define-label
+ "positive" define-label
+ "end" define-label
+ "x" operand %untag
+ "y" operand "x" operand cell [+] MOV
+ ! if the length is 1, its just the sign and nothing else,
+ ! so output 0
+ "y" operand 1 tag-fixnum CMP
+ "nonzero" get JNE
+ "y" operand 0 MOV
+ "end" get JMP
+ "nonzero" resolve-label
+ ! load the value
+ "y" operand "x" operand 3 cells [+] MOV
+ ! load the sign
+ "x" operand "x" operand 2 cells [+] MOV
+ ! is the sign negative?
+ "x" operand 0 CMP
+ "positive" get JE
+ "y" operand -1 IMUL2
+ "positive" resolve-label
+ "y" operand 3 SHL
+ "end" resolve-label
+] T{ template
+ { input { { f "x" } } }
+ { scratch { { f "y" } } }
+ { clobber { "x" } }
+ { output { "y" } }
+} define-intrinsic
+
+! User environment
+: %userenv ( -- )
+ "x" operand 0 MOV
+ "userenv" f rc-absolute-cell rel-dlsym
+ "n" operand fixnum>slot@
+ "n" operand "x" operand ADD ;
+
+\ getenv [
+ %userenv "n" operand dup [] MOV
+] T{ template
+ { input { { f "n" } } }
+ { scratch { { f "x" } } }
+ { output { "n" } }
+} define-intrinsic
+
+\ setenv [
+ %userenv "n" operand [] "val" operand MOV
+] T{ template
+ { input { { f "val" } { f "n" } } }
+ { scratch { { f "x" } } }
+ { clobber { "n" } }
+} define-intrinsic
+
+! Alien intrinsics
+: %alien-accessor ( quot -- )
+ "offset" operand %untag-fixnum
+ "offset" operand "alien" operand ADD
+ "offset" operand [] swap call ; inline
+
+: %alien-integer-get ( quot reg -- )
+ small-reg PUSH
+ swap %alien-accessor
+ "value" operand small-reg MOV
+ "value" operand %tag-fixnum
+ small-reg POP ; inline
+
+: alien-integer-get-template
+ T{ template
+ { input {
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { scratch { { f "value" } } }
+ { output { "value" } }
+ { clobber { "offset" } }
+ } ;
+
+: define-getter ( word quot reg -- )
+ [ %alien-integer-get ] 2curry
+ alien-integer-get-template
+ define-intrinsic ;
+
+: define-unsigned-getter ( word reg -- )
+ [ small-reg dup XOR MOV ] swap define-getter ;
+
+: define-signed-getter ( word reg -- )
+ [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
+
+: %alien-integer-set ( quot reg -- )
+ small-reg PUSH
+ small-reg "value" operand MOV
+ small-reg %untag-fixnum
+ swap %alien-accessor
+ small-reg POP ; inline
+
+: alien-integer-set-template
+ T{ template
+ { input {
+ { f "value" fixnum }
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { clobber { "value" "offset" } }
+ } ;
+
+: define-setter ( word reg -- )
+ [ swap MOV ] swap
+ [ %alien-integer-set ] 2curry
+ alien-integer-set-template
+ define-intrinsic ;
+
+\ alien-unsigned-1 small-reg-8 define-unsigned-getter
+\ set-alien-unsigned-1 small-reg-8 define-setter
+
+\ alien-signed-1 small-reg-8 define-signed-getter
+\ set-alien-signed-1 small-reg-8 define-setter
+
+\ alien-unsigned-2 small-reg-16 define-unsigned-getter
+\ set-alien-unsigned-2 small-reg-16 define-setter
+
+\ alien-signed-2 small-reg-16 define-signed-getter
+\ set-alien-signed-2 small-reg-16 define-setter
+
+\ alien-cell [
+ "value" operand [ MOV ] %alien-accessor
+] T{ template
+ { input {
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { scratch { { unboxed-alien "value" } } }
+ { output { "value" } }
+ { clobber { "offset" } }
+} define-intrinsic
+
+\ set-alien-cell [
+ "value" operand [ swap MOV ] %alien-accessor
+] T{ template
+ { input {
+ { unboxed-c-ptr "value" pinned-c-ptr }
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { clobber { "offset" } }
+} define-intrinsic
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
-math fry namespaces make sequences words stack-checker.inlining
+math fry namespaces make sequences words byte-arrays
+locals layouts
+stack-checker.inlining
+compiler.intrinsics
compiler.tree
compiler.tree.builder
compiler.tree.combinators
compiler.cfg.stacks
compiler.cfg.templates
compiler.cfg.iterator
-compiler.alien
-compiler.instructions
-compiler.registers ;
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.alien ;
IN: compiler.cfg.builder
! Convert tree SSA IR to CFG (not quite SSA yet) IR.
: stop-iterating ( -- next ) end-basic-block f ;
-USE: qualified
-FROM: compiler.generator.registers => +input+ ;
-FROM: compiler.generator.registers => +output+ ;
-FROM: compiler.generator.registers => +scratch+ ;
-FROM: compiler.generator.registers => +clobber+ ;
-
SYMBOL: procedures
-
SYMBOL: current-word
-
SYMBOL: current-label
-
SYMBOL: loops
! Basic block after prologue, makes recursion faster
#! labelled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue.
init-phantoms
- %prologue
- %branch
+ ##prologue
+ ##branch
begin-basic-block
current-label get remember-loop ;
[ emit-nodes ] with-node-iterator
] with-cfg-builder ;
-: build-cfg ( nodes word label -- procedures )
+: build-cfg ( nodes word -- procedures )
V{ } clone [
procedures [
- (build-cfg)
+ dup (build-cfg)
] with-variable
] keep ;
+SYMBOL: +intrinsics+
+SYMBOL: +if-intrinsics+
+
: if-intrinsics ( #call -- quot )
- word>> "if-intrinsics" word-prop ;
+ word>> +if-intrinsics+ word-prop ;
: local-recursive-call ( basic-block -- next )
- %branch
+ ##branch
basic-block get successors>> push
stop-iterating ;
: emit-call ( word -- next )
finalize-phantoms
{
- { [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
+ { [ tail-call? not ] [ 0 ##frame-required ##call iterate-next ] }
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
- [ %epilogue %jump stop-iterating ]
+ [ ##epilogue ##jump stop-iterating ]
} cond ;
! #recursive
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if
-: emit-branch ( nodes -- final-bb )
- [
+: emit-branch ( obj quot -- final-bb )
+ '[
begin-basic-block copy-phantoms
- emit-nodes
- basic-block get dup [ %branch ] when
+ @
+ basic-block get dup [ ##branch ] when
] with-scope ;
-: emit-if ( node -- next )
- children>> [ emit-branch ] map
+: emit-branches ( seq quot -- )
+ '[ _ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each
- init-phantoms
- iterate-next ;
+ init-phantoms ;
+
+: emit-if ( node -- next )
+ children>> [ emit-nodes ] emit-branches ;
M: #if emit-node
- { { f "flag" } } lazy-load first %branch-t
- emit-if ;
+ phantom-pop ##branch-t emit-if iterate-next ;
! #dispatch
: dispatch-branch ( nodes word -- label )
+ #! The order here is important, dispatch-branches must
+ #! run after ##dispatch, so that each branch gets the
+ #! correct register state
gensym [
[
copy-phantoms
- %prologue
+ ##prologue
[ emit-nodes ] with-node-iterator
- %epilogue
- %return
+ ##epilogue
+ ##return
] with-cfg-builder
] keep ;
: dispatch-branches ( node -- )
children>> [
current-word get dispatch-branch
- %dispatch-label
+ ##dispatch-label
] each ;
: emit-dispatch ( node -- )
- %dispatch dispatch-branches init-phantoms ;
+ phantom-pop int-regs next-vreg
+ [ finalize-contents finalize-heights ##epilogue ] 2dip ##dispatch
+ dispatch-branches init-phantoms ;
M: #dispatch emit-node
- #! The order here is important, dispatch-branches must
- #! run after %dispatch, so that each branch gets the
- #! correct register state
tail-call? [
emit-dispatch iterate-next
] [
! #call
: define-intrinsics ( word intrinsics -- )
- "intrinsics" set-word-prop ;
+ +intrinsics+ set-word-prop ;
: define-intrinsic ( word quot assoc -- )
2array 1array define-intrinsics ;
: define-if-intrinsics ( word intrinsics -- )
- [ +input+ associate ] assoc-map
- "if-intrinsics" set-word-prop ;
+ [ template new swap >>input ] assoc-map
+ +if-intrinsics+ set-word-prop ;
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: find-intrinsic ( #call -- pair/f )
- word>> "intrinsics" word-prop find-template ;
+ word>> +intrinsics+ word-prop find-template ;
: find-boolean-intrinsic ( #call -- pair/f )
- word>> "if-intrinsics" word-prop find-template ;
+ word>> +if-intrinsics+ word-prop find-template ;
: find-if-intrinsic ( #call -- pair/f )
node@ {
} cond ;
: do-if-intrinsic ( pair -- next )
- [ %if-intrinsic ] apply-template skip-next emit-if ;
+ [ ##if-intrinsic ] apply-template skip-next emit-if
+ iterate-next ;
: do-boolean-intrinsic ( pair -- next )
- [
- f alloc-vreg [ %boolean-intrinsic ] keep phantom-push
- ] apply-template iterate-next ;
+ [ ##if-intrinsic ] apply-template
+ { t f } [
+ <constant> phantom-push finalize-phantoms
+ ] emit-branches
+ iterate-next ;
: do-intrinsic ( pair -- next )
- [ %intrinsic ] apply-template iterate-next ;
+ [ ##intrinsic ] apply-template iterate-next ;
+
+: setup-value-classes ( #call -- )
+ node-input-infos [ class>> ] map set-value-classes ;
+
+{
+ (tuple) (array) (byte-array)
+ (complex) (ratio) (wrapper)
+ (write-barrier)
+} [ t "intrinsic" set-word-prop ] each
-: setup-operand-classes ( #call -- )
- node-input-infos [ class>> ] map set-operand-classes ;
+: allot-size ( #call -- n )
+ 1 phantom-datastack get phantom-input first value>> ;
+
+:: emit-allot ( size type tag -- )
+ int-regs next-vreg
+ dup fresh-object
+ dup size type tag int-regs next-vreg ##allot
+ type tagged boa phantom-push ;
+
+: emit-write-barrier ( -- )
+ phantom-pop dup >vreg fresh-object? [ drop ] [
+ int-regs next-vreg ##write-barrier
+ ] if ;
+
+: emit-intrinsic ( word -- next )
+ {
+ { \ (tuple) [ allot-size 2 cells + tuple tuple emit-allot ] }
+ { \ (array) [ allot-size 2 cells + array object emit-allot ] }
+ { \ (byte-array) [ allot-size cells 2 + byte-array object emit-allot ] }
+ { \ (complex) [ 3 cells complex complex emit-allot ] }
+ { \ (ratio) [ 3 cells ratio ratio emit-allot ] }
+ { \ (wrapper) [ 2 cells wrapper object emit-allot ] }
+ { \ (write-barrier) [ emit-write-barrier ] }
+ } case
+ iterate-next ;
M: #call emit-node
- dup setup-operand-classes
+ dup setup-value-classes
dup find-if-intrinsic [ do-if-intrinsic ] [
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
dup find-intrinsic [ do-intrinsic ] [
- word>> emit-call
+ word>> dup "intrinsic" word-prop
+ [ emit-intrinsic ] [ emit-call ] if
] ?if
] ?if
] ?if ;
! #return
M: #return emit-node
- drop finalize-phantoms %epilogue %return f ;
+ drop finalize-phantoms ##epilogue ##return f ;
M: #return-recursive emit-node
finalize-phantoms
label>> id>> loops get key?
- [ %epilogue %return ] unless f ;
+ [ ##epilogue ##return ] unless f ;
! #terminate
M: #terminate emit-node drop stop-iterating ;
! FFI
M: #alien-invoke emit-node
params>>
- [ alien-invoke-frame %frame-required ]
- [ %alien-invoke iterate-next ]
+ [ alien-invoke-frame ##frame-required ]
+ [ ##alien-invoke iterate-next ]
bi ;
M: #alien-indirect emit-node
params>>
- [ alien-invoke-frame %frame-required ]
- [ %alien-indirect iterate-next ]
+ [ alien-invoke-frame ##frame-required ]
+ [ ##alien-indirect iterate-next ]
bi ;
M: #alien-callback emit-node
params>> dup xt>> dup
- [ init-phantoms %alien-callback ] with-cfg-builder
+ [ init-phantoms ##alien-callback ] with-cfg-builder
iterate-next ;
! No-op nodes
TUPLE: basic-block < identity-tuple
visited
number
-label
instructions
-successors
-predecessors ;
+successors ;
: <basic-block> ( -- basic-block )
basic-block new
V{ } clone >>instructions
- V{ } clone >>successors
- V{ } clone >>predecessors ;
+ V{ } clone >>successors ;
-TUPLE: mr instructions word label ;
+TUPLE: mr instructions word label frame-size spill-counts ;
-C: <mr> mr
+: <mr> ( instructions word label -- mr )
+ mr new
+ swap >>label
+ swap >>word
+ swap >>instructions ;
GENERIC: test-cfg ( quot -- cfgs )
M: callable test-cfg
- build-tree optimize-tree gensym gensym build-cfg ;
+ build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
- [ build-tree-from-word nip optimize-tree ] keep dup
- build-cfg ;
+ [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors arrays kernel sequences namespaces
+math compiler.cfg.registers compiler.cfg.instructions.syntax ;
+IN: compiler.cfg.instructions
+
+! Virtual CPU instructions, used by CFG and machine IRs
+
+TUPLE: ##cond-branch < insn src ;
+TUPLE: ##unary < insn dst src ;
+TUPLE: ##nullary < insn dst ;
+
+! Stack operations
+INSN: ##load-literal < ##nullary obj ;
+INSN: ##peek < ##nullary loc ;
+INSN: ##replace src loc ;
+INSN: ##inc-d n ;
+INSN: ##inc-r n ;
+
+! Calling convention
+INSN: ##return ;
+
+! Subroutine calls
+INSN: ##call word ;
+INSN: ##jump word ;
+INSN: ##intrinsic quot defs-vregs uses-vregs ;
+
+! Jump tables
+INSN: ##dispatch-label label ;
+INSN: ##dispatch src temp ;
+
+! Boxing and unboxing
+INSN: ##copy < ##unary ;
+INSN: ##copy-float < ##unary ;
+INSN: ##unbox-float < ##unary ;
+INSN: ##unbox-f < ##unary ;
+INSN: ##unbox-alien < ##unary ;
+INSN: ##unbox-byte-array < ##unary ;
+INSN: ##unbox-any-c-ptr < ##unary ;
+INSN: ##box-float < ##unary temp ;
+INSN: ##box-alien < ##unary temp ;
+
+! Memory allocation
+INSN: ##allot < ##nullary size type tag temp ;
+INSN: ##write-barrier src temp ;
+INSN: ##gc ;
+
+! FFI
+INSN: ##alien-invoke params ;
+INSN: ##alien-indirect params ;
+INSN: ##alien-callback params ;
+
+GENERIC: defs-vregs ( insn -- seq )
+GENERIC: uses-vregs ( insn -- seq )
+
+M: ##nullary defs-vregs dst>> >vreg 1array ;
+M: ##unary defs-vregs dst>> >vreg 1array ;
+M: ##write-barrier defs-vregs temp>> >vreg 1array ;
+
+: allot-defs-vregs ( insn -- seq )
+ [ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
+
+M: ##box-float defs-vregs allot-defs-vregs ;
+M: ##box-alien defs-vregs allot-defs-vregs ;
+M: ##allot defs-vregs allot-defs-vregs ;
+M: ##dispatch defs-vregs temp>> >vreg 1array ;
+M: insn defs-vregs drop f ;
+
+M: ##replace uses-vregs src>> >vreg 1array ;
+M: ##unary uses-vregs src>> >vreg 1array ;
+M: ##write-barrier uses-vregs src>> >vreg 1array ;
+M: ##dispatch uses-vregs src>> >vreg 1array ;
+M: insn uses-vregs drop f ;
+
+: intrinsic-vregs ( assoc -- seq' )
+ [ nip >vreg ] { } assoc>map sift ;
+
+: intrinsic-defs-vregs ( insn -- seq )
+ defs-vregs>> intrinsic-vregs ;
+
+: intrinsic-uses-vregs ( insn -- seq )
+ uses-vregs>> intrinsic-vregs ;
+
+M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
+M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
+
+! Instructions used by CFG IR only.
+INSN: ##prologue ;
+INSN: ##epilogue ;
+INSN: ##frame-required n ;
+
+INSN: ##branch ;
+INSN: ##branch-f < ##cond-branch ;
+INSN: ##branch-t < ##cond-branch ;
+INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
+
+M: ##cond-branch uses-vregs src>> >vreg 1array ;
+
+M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
+M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
+
+! Instructions used by machine IR only.
+INSN: _prologue ;
+INSN: _epilogue ;
+
+INSN: _label id ;
+
+TUPLE: _cond-branch < insn src label ;
+
+INSN: _branch label ;
+INSN: _branch-f < _cond-branch ;
+INSN: _branch-t < _cond-branch ;
+INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
+
+M: _cond-branch uses-vregs src>> >vreg 1array ;
+
+M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
+M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
+
+INSN: _spill-integer src n ;
+INSN: _reload-integer dst n ;
+
+INSN: _spill-float src n ;
+INSN: _reload-float dst n ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.tuple classes.tuple.parser kernel words
+make fry sequences parser ;
+IN: compiler.cfg.instructions.syntax
+
+TUPLE: insn ;
+
+: INSN:
+ parse-tuple-definition "regs" suffix
+ [ dup tuple eq? [ drop insn ] when ] dip
+ [ define-tuple-class ]
+ [ 2drop save-location ]
+ [ 2drop dup '[ f _ boa , ] define-inline ]
+ 3tri ; parsing
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry
+accessors vectors fry heaps
+compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals
compiler.backend ;
IN: compiler.cfg.linear-scan.allocation
-! Mapping from vregs to machine registers
-SYMBOL: register-allocation
+! Mapping from register classes to sequences of machine registers
+SYMBOL: free-registers
-! Mapping from vregs to spill locations
-SYMBOL: spill-locations
+: free-registers-for ( vreg -- seq )
+ reg-class>> free-registers get at ;
-! Vector of active live intervals, in order of increasing end point
+: deallocate-register ( live-interval -- )
+ [ reg>> ] [ vreg>> ] bi free-registers-for push ;
+
+! Vector of active live intervals
SYMBOL: active-intervals
: add-active ( live-interval -- )
: delete-active ( live-interval -- )
active-intervals get delete ;
-! Mapping from register classes to sequences of machine registers
-SYMBOL: free-registers
+: expire-old-intervals ( n -- )
+ active-intervals get
+ swap '[ end>> _ < ] partition
+ active-intervals set
+ [ deallocate-register ] each ;
-! Counter of spill locations
-SYMBOL: spill-counter
+: expire-old-uses ( n -- )
+ active-intervals get
+ swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
-: next-spill-location ( -- n )
- spill-counter [ dup 1+ ] change ;
+: update-state ( live-interval -- )
+ start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
-: assign-spill ( live-interval -- )
- next-spill-location swap vreg>> spill-locations get set-at ;
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
-: free-registers-for ( vreg -- seq )
- reg-class>> free-registers get at ;
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than ths one. This ensures that we can catch
+! infinite loop situations.
+SYMBOL: progress
-: free-register ( vreg -- )
- #! Free machine register currently assigned to vreg.
- [ register-allocation get at ] [ free-registers-for ] bi push ;
+: check-progress ( live-interval -- )
+ start>> progress get <= [ "No progress" throw ] when ; inline
-: expire-old-intervals ( live-interval -- )
- active-intervals get
- swap '[ end>> _ start>> < ] partition
- active-intervals set
- [ vreg>> free-register ] each ;
+: add-unhandled ( live-interval -- )
+ [ check-progress ]
+ [ dup start>> unhandled-intervals get heap-push ]
+ bi ;
+
+: init-unhandled ( live-intervals -- )
+ [ [ start>> ] keep ] { } map>assoc
+ unhandled-intervals get heap-push-all ;
+
+: assign-free-register ( live-interval registers -- )
+ #! If the live interval does not have any uses, it means it
+ #! will be spilled immediately, so it still needs a register
+ #! to compute the new value, but we don't add the interval
+ #! to the active set and we don't remove the register from
+ #! the free list.
+ over uses>> empty?
+ [ peek >>reg drop ] [ pop >>reg add-active ] if ;
+
+! Spilling
+SYMBOL: spill-counts
+
+: next-spill-location ( reg-class -- n )
+ spill-counts get [ dup 1+ ] change-at ;
: interval-to-spill ( -- live-interval )
- #! We spill the interval with the longest remaining range.
+ #! We spill the interval with the most distant use location.
active-intervals get unclip-slice [
- [ [ end>> ] bi@ > ] most
+ [ [ uses>> peek ] bi@ > ] most
] reduce ;
-: reuse-register ( live-interval to-spill -- )
- vreg>> swap vreg>>
- register-allocation get
- tuck [ at ] [ set-at ] 2bi* ;
-
-: spill-at-interval ( live-interval -- )
+: check-split ( live-interval -- )
+ [ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
+
+: split-interval ( live-interval -- before after )
+ #! Split the live interval at the location of its first use.
+ #! 'Before' now starts and ends on the same instruction.
+ [ check-split ]
+ [ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ]
+ [ clone f >>reg dup uses>> peek >>start ]
+ tri ;
+
+: record-split ( live-interval before after -- )
+ [ >>split-before ] [ >>split-after ] bi* drop ;
+
+: assign-spill ( before after -- before after )
+ #! If it has been spilled already, reuse spill location.
+ over reload-from>> [ next-spill-location ] unless*
+ tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
+
+: split-and-spill ( live-interval -- before after )
+ dup split-interval [ record-split ] [ assign-spill ] 2bi ;
+
+: reuse-register ( new existing -- )
+ reg>> >>reg
+ dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
+
+: spill-existing ( new existing -- )
+ #! Our new interval will be used before the active interval
+ #! with the most distant use location. Spill the existing
+ #! interval, then process the new interval and the tail end
+ #! of the existing interval again.
+ [ reuse-register ]
+ [ delete-active ]
+ [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
+
+: spill-new ( new existing -- )
+ #! Our new interval will be used after the active interval
+ #! with the most distant use location. Split the new
+ #! interval, then process both parts of the new interval
+ #! again.
+ [ split-and-spill add-unhandled ] dip spill-existing ;
+
+: spill-existing? ( new existing -- ? )
+ over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
+
+: assign-blocked-register ( live-interval -- )
interval-to-spill
- 2dup [ end>> ] bi@ > [
- [ reuse-register ]
- [ nip assign-spill ]
- [ [ add-active ] [ delete-active ] bi* ]
- 2tri
- ] [ drop assign-spill ] if ;
-
-: init-allocator ( -- )
- H{ } clone register-allocation set
- H{ } clone spill-locations set
- V{ } clone active-intervals set
- machine-registers [ >vector ] assoc-map free-registers set
- 0 spill-counter set ;
-
-: assign-register ( live-interval register -- )
- swap vreg>> register-allocation get set-at ;
+ 2dup spill-existing?
+ [ spill-existing ] [ spill-new ] if ;
-: allocate-register ( live-interval -- )
+: assign-register ( live-interval -- )
dup vreg>> free-registers-for [
- spill-at-interval
+ assign-blocked-register
] [
- [ pop assign-register ]
- [ drop add-active ]
- 2bi
+ assign-free-register
] if-empty ;
-: allocate-registers ( live-intervals -- )
+! Main loop
+: init-allocator ( registers -- )
+ V{ } clone active-intervals set
+ <min-heap> unhandled-intervals set
+ [ reverse >vector ] assoc-map free-registers set
+ H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set
+ -1 progress set ;
+
+: handle-interval ( live-interval -- )
+ [ start>> progress set ] [ update-state ] [ assign-register ] tri ;
+
+: (allocate-registers) ( -- )
+ unhandled-intervals get [ handle-interval ] slurp-heap ;
+
+: allocate-registers ( live-intervals machine-registers -- live-intervals )
+ #! This modifies the input live-intervals.
init-allocator
- [ [ expire-old-intervals ] [ allocate-register ] bi ] each ;
+ dup init-unhandled
+ (allocate-registers) ;
--- /dev/null
+USING: compiler.cfg.linear-scan.assignment tools.test ;
+IN: compiler.cfg.linear-scan.assignment.tests
+
+\ assign-registers must-infer
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math assocs namespaces sequences heaps
+fry make combinators
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.assignment
+
+! A vector of live intervals. There is linear searching involved
+! but since we never have too many machine registers (around 30
+! at most) and we probably won't have that many live at any one
+! time anyway, it is not a problem to check each element.
+SYMBOL: active-intervals
+
+: add-active ( live-interval -- )
+ active-intervals get push ;
+
+: lookup-register ( vreg -- reg )
+ active-intervals get [ vreg>> = ] with find nip reg>> ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+: add-unhandled ( live-interval -- )
+ dup split-before>> [
+ [ split-before>> ] [ split-after>> ] bi
+ [ add-unhandled ] bi@
+ ] [
+ dup start>> unhandled-intervals get heap-push
+ ] if ;
+
+: init-unhandled ( live-intervals -- )
+ [ add-unhandled ] each ;
+
+: insert-spill ( live-interval -- )
+ [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri
+ over [
+ {
+ { int-regs [ _spill-integer ] }
+ { double-float-regs [ _spill-float ] }
+ } case
+ ] [ 3drop ] if ;
+
+: expire-old-intervals ( n -- )
+ active-intervals get
+ swap '[ end>> _ = ] partition
+ active-intervals set
+ [ insert-spill ] each ;
+
+: insert-reload ( live-interval -- )
+ [ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri
+ over [
+ {
+ { int-regs [ _reload-integer ] }
+ { double-float-regs [ _reload-float ] }
+ } case
+ ] [ 3drop ] if ;
+
+: activate-new-intervals ( n -- )
+ #! Any live intervals which start on the current instruction
+ #! are added to the active set.
+ unhandled-intervals get dup heap-empty? [ 2drop ] [
+ 2dup heap-peek drop start>> = [
+ heap-pop drop [ add-active ] [ insert-reload ] bi
+ activate-new-intervals
+ ] [ 2drop ] if
+ ] if ;
+
+: (assign-registers) ( insn -- )
+ dup
+ [ defs-vregs ] [ uses-vregs ] bi append
+ active-intervals get swap '[ vreg>> _ member? ] filter
+ [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
+ >>regs drop ;
+
+: init-assignment ( live-intervals -- )
+ V{ } clone active-intervals set
+ <min-heap> unhandled-intervals set
+ init-unhandled ;
+
+: assign-registers ( insns live-intervals -- insns' )
+ [
+ init-assignment
+ [
+ [ activate-new-intervals ]
+ [ drop [ (assign-registers) ] [ , ] bi ]
+ [ expire-old-intervals ]
+ tri
+ ] each-index
+ ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences sets arrays
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation ;
+IN: compiler.cfg.linear-scan.debugger
+
+: check-assigned ( live-intervals -- )
+ [
+ reg>>
+ [ "Not all intervals have registers" throw ] unless
+ ] each ;
+
+: split-children ( live-interval -- seq )
+ dup split-before>> [
+ [ split-before>> ] [ split-after>> ] bi
+ [ split-children ] bi@
+ append
+ ] [ 1array ] if ;
+
+: check-linear-scan ( live-intervals machine-registers -- )
+ [ [ clone ] map ] dip allocate-registers
+ [ split-children ] map concat check-assigned ;
--- /dev/null
+IN: compiler.cfg.linear-scan.tests
+USING: tools.test random sorting sequences sets hashtables assocs
+kernel fry arrays splitting namespaces math accessors vectors
+math.order
+compiler.cfg.registers
+compiler.cfg.linear-scan
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.debugger ;
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 10 } { uses V{ 10 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } } } { start 11 } { end 20 } { uses V{ 20 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 60 } { uses V{ 60 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 200 } { uses V{ 200 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] unit-test
+
+[
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 100 } { uses V{ 100 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] must-fail
+
+SYMBOL: available
+
+SYMBOL: taken
+
+SYMBOL: max-registers
+
+SYMBOL: max-insns
+
+SYMBOL: max-uses
+
+: not-taken ( -- n )
+ available get keys dup empty? [ "Oops" throw ] when
+ random
+ dup taken get nth 1 + max-registers get = [
+ dup available get delete-at
+ ] [
+ dup taken get [ 1 + ] change-nth
+ ] if ;
+
+: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
+ [
+ max-insns set
+ max-registers set
+ max-uses set
+ max-insns get [ 0 ] replicate taken set
+ max-insns get [ dup ] H{ } map>assoc available set
+ [
+ live-interval new
+ swap f swap vreg boa >>vreg
+ max-uses get random 2 max [ not-taken ] replicate natural-sort
+ unclip [ >vector >>uses ] [ >>start ] bi*
+ dup uses>> first >>end
+ ] map
+ ] with-scope ;
+
+: random-test ( num-intervals max-uses max-registers max-insns -- )
+ over >r random-live-intervals r> f associate check-linear-scan ;
+
+[ ] [ 30 2 1 60 random-test ] unit-test
+[ ] [ 60 2 2 60 random-test ] unit-test
+[ ] [ 80 2 3 200 random-test ] unit-test
+[ ] [ 70 2 5 30 random-test ] unit-test
+[ ] [ 60 2 6 30 random-test ] unit-test
+[ ] [ 1 2 10 10 random-test ] unit-test
+
+[ ] [ 10 4 2 60 random-test ] unit-test
+[ ] [ 10 20 2 400 random-test ] unit-test
+[ ] [ 10 20 4 300 random-test ] unit-test
+
+USING: math.private compiler.cfg.debugger ;
+
+[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces
+compiler.backend
+compiler.cfg
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan
-! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+! References:
+! Linear Scan Register Allocation
+! by Massimiliano Poletto and Vivek Sarkar
+! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+
+! Linear Scan Register Allocation for the Java HotSpot Client Compiler
+! by Christian Wimmer
+! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
+
+! Quality and Speed in Linear-scan Register Allocation
+! by Omri Traub, Glenn Holloway, Michael D. Smith
+! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
+
+: linear-scan ( mr -- mr' )
+ [
+ [
+ dup compute-live-intervals
+ machine-registers allocate-registers
+ assign-registers
+ ] change-instructions
+ spill-counts get >>spill-counts
+ ] with-scope ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs accessors sequences math
-math.order sorting compiler.instructions compiler.registers ;
+USING: namespaces kernel assocs accessors sequences math fry
+compiler.cfg.instructions compiler.cfg.registers ;
IN: compiler.cfg.linear-scan.live-intervals
-TUPLE: live-interval < identity-tuple vreg start end ;
+TUPLE: live-interval < identity-tuple
+vreg
+reg spill-to reload-from split-before split-after
+start end uses ;
-M: live-interval hashcode* nip [ start>> ] [ end>> 1000 * ] bi + ;
+: <live-interval> ( start vreg -- live-interval )
+ live-interval new
+ swap >>vreg
+ swap >>start
+ V{ } clone >>uses ;
+
+M: live-interval hashcode*
+ nip [ start>> ] [ end>> 1000 * ] bi + ;
+
+M: live-interval clone
+ call-next-method [ clone ] change-uses ;
! Mapping from vreg to live-interval
SYMBOL: live-intervals
-: update-live-interval ( n vreg -- )
- >vreg
- live-intervals get
- [ over f live-interval boa ] cache
- (>>end) ;
+: add-use ( n vreg live-intervals -- )
+ at [ (>>end) ] [ uses>> push ] 2bi ;
-: compute-live-intervals* ( n insn -- )
- uses-vregs [ update-live-interval ] with each ;
+: new-live-interval ( n vreg live-intervals -- )
+ 2dup key? [ "Multiple defs" throw ] when
+ [ [ <live-interval> ] keep ] dip set-at ;
+
+: compute-live-intervals* ( insn n -- )
+ live-intervals get
+ [ [ uses-vregs ] 2dip '[ _ swap _ add-use ] each ]
+ [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+ 3bi ;
-: sort-live-intervals ( assoc -- seq' )
- #! Sort by increasing start location.
- values [ [ start>> ] compare ] sort ;
+: finalize-live-intervals ( assoc -- seq' )
+ #! Reverse uses lists so that we can pop values off.
+ values dup [ uses>> reverse-here ] each ;
: compute-live-intervals ( instructions -- live-intervals )
H{ } clone [
- live-intervals [
- [ swap compute-live-intervals* ] each-index
- ] with-variable
- ] keep sort-live-intervals ;
+ live-intervals set
+ [ compute-live-intervals* ] each-index
+ ] keep finalize-live-intervals ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
-combinators compiler.cfg compiler.cfg.rpo compiler.instructions
-compiler.instructions.syntax ;
+combinators
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.instructions
+compiler.cfg.instructions.syntax ;
IN: compiler.cfg.linearization
! Convert CFG IR to machine IR.
-SYMBOL: frame-size
-
-: compute-frame-size ( rpo -- )
- [ instructions>> [ %frame-required? ] filter ] map concat
- [ f ] [ [ n>> ] map supremum ] if-empty
- frame-size set ;
-
GENERIC: linearize-insn ( basic-block insn -- )
: linearize-insns ( basic-block -- )
M: insn linearize-insn , drop ;
-M: %frame-required linearize-insn 2drop ;
-
-M: %prologue linearize-insn
- 2drop frame-size get [ _prologue ] when* ;
-
-M: %epilogue linearize-insn
- 2drop frame-size get [ _epilogue ] when* ;
-
: useless-branch? ( basic-block successor -- ? )
#! If our successor immediately follows us in RPO, then we
#! don't need to branch.
: branch-to-return? ( successor -- ? )
#! A branch to a block containing just a return is cloned.
instructions>> dup length 2 = [
- [ first %epilogue? ] [ second %return? ] bi and
+ [ first ##epilogue? ] [ second ##return? ] bi and
] [ drop f ] if ;
: emit-branch ( basic-block successor -- )
{
{ [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-return? ] [ nip linearize-insns ] }
- [ nip label>> _branch ]
+ [ nip number>> _branch ]
} cond ;
-M: %branch linearize-insn
+M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
: conditional ( basic-block -- basic-block successor1 label2 )
- dup successors>> first2 swap label>> ; inline
+ dup successors>> first2 swap number>> ; inline
: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
- [ conditional ] [ vreg>> ] bi* swap ; inline
+ [ conditional ] [ src>> ] bi* swap ; inline
-M: %branch-f linearize-insn
+M: ##branch-f linearize-insn
boolean-conditional _branch-f emit-branch ;
-M: %branch-t linearize-insn
+M: ##branch-t linearize-insn
boolean-conditional _branch-t emit-branch ;
-M: %if-intrinsic linearize-insn
- [ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
- _if-intrinsic emit-branch ;
+: >intrinsic< ( insn -- quot defs uses )
+ [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
-M: %boolean-intrinsic linearize-insn
- [
- "false" define-label
- "end" define-label
- "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
- t over out>> %load-literal
- "end" get _branch
- "false" resolve-label
- f over out>> %load-literal
- "end" resolve-label
- ] with-scope
- 2drop ;
+M: ##if-intrinsic linearize-insn
+ [ conditional ] [ >intrinsic< ] bi*
+ _if-intrinsic emit-branch ;
: linearize-basic-block ( bb -- )
- [ label>> _label ] [ linearize-insns ] bi ;
+ [ number>> _label ] [ linearize-insns ] bi ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;
: build-mr ( cfg -- mr )
- [
- entry>> reverse-post-order [
- [ compute-frame-size ]
- [ linearize-basic-blocks ] bi
- ] with-scope
- ] [ word>> ] [ label>> ] tri <mr> ;
+ [ entry>> reverse-post-order linearize-basic-blocks ]
+ [ word>> ] [ label>> ]
+ tri <mr> ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces math kernel alien classes ;
+IN: compiler.cfg.registers
+
+! Virtual CPU registers, used by CFG and machine IRs
+
+MIXIN: value
+
+GENERIC: >vreg ( obj -- vreg )
+GENERIC: set-value-class ( class obj -- )
+GENERIC: value-class* ( operand -- class )
+
+: value-class ( operand -- class ) value-class* object or ;
+
+M: value >vreg drop f ;
+M: value set-value-class 2drop ;
+M: value value-class* drop f ;
+
+! Register classes
+SINGLETON: int-regs
+SINGLETON: single-float-regs
+SINGLETON: double-float-regs
+UNION: float-regs single-float-regs double-float-regs ;
+UNION: reg-class int-regs float-regs ;
+
+! Virtual registers
+TUPLE: vreg reg-class n ;
+SYMBOL: vreg-counter
+: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
+
+M: vreg >vreg ;
+
+INSTANCE: vreg value
+
+! Stack locations
+TUPLE: loc n class ;
+
+! A data stack location.
+TUPLE: ds-loc < loc ;
+: <ds-loc> ( n -- loc ) f ds-loc boa ;
+
+TUPLE: rs-loc < loc ;
+: <rs-loc> ( n -- loc ) f rs-loc boa ;
+
+INSTANCE: loc value
+
+! A stack location which has been loaded into a register. To
+! read the location, we just read the register, but when time
+! comes to save it back to the stack, we know the register just
+! contains a stack value so we don't have to redundantly write
+! it back.
+TUPLE: cached loc vreg ;
+C: <cached> cached
+
+M: cached set-value-class vreg>> set-value-class ;
+M: cached value-class* vreg>> value-class* ;
+M: cached >vreg vreg>> >vreg ;
+
+INSTANCE: cached value
+
+! A tagged pointer
+TUPLE: tagged vreg class ;
+: <tagged> ( vreg -- tagged ) f tagged boa ;
+
+M: tagged set-value-class (>>class) ;
+M: tagged value-class* class>> ;
+M: tagged >vreg vreg>> ;
+
+INSTANCE: tagged value
+
+! Unboxed value
+TUPLE: unboxed vreg ;
+C: <unboxed> unboxed
+
+M: unboxed >vreg vreg>> ;
+
+INSTANCE: unboxed value
+
+! Unboxed alien pointer
+TUPLE: unboxed-alien < unboxed ;
+C: <unboxed-alien> unboxed-alien
+
+M: unboxed-alien value-class* drop simple-alien ;
+
+! Untagged byte array pointer
+TUPLE: unboxed-byte-array < unboxed ;
+C: <unboxed-byte-array> unboxed-byte-array
+
+M: unboxed-byte-array value-class* drop c-ptr ;
+
+! A register set to f
+TUPLE: unboxed-f < unboxed ;
+C: <unboxed-f> unboxed-f
+
+M: unboxed-f value-class* drop \ f ;
+
+! An alien, byte array or f
+TUPLE: unboxed-c-ptr < unboxed ;
+C: <unboxed-c-ptr> unboxed-c-ptr
+
+M: unboxed-c-ptr value-class* drop c-ptr ;
+
+! A constant value
+TUPLE: constant value ;
+C: <constant> constant
+
+M: constant value-class* value>> class ;
+
+INSTANCE: constant value
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make math sequences
-compiler.instructions ;
+compiler.cfg.instructions ;
IN: compiler.cfg.rpo
: post-order-traversal ( basic-block -- )
dup visited>> [ drop ] [
t >>visited
- <label> >>label
[ successors>> [ post-order-traversal ] each ] [ , ] bi
] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces accessors math.order assocs kernel sequences
+make compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.registers ;
+IN: compiler.cfg.stack-frame
+
+SYMBOL: frame-required?
+
+SYMBOL: frame-size
+
+SYMBOL: spill-counts
+
+: init-stack-frame-builder ( -- )
+ frame-required? off
+ 0 frame-size set ;
+
+GENERIC: compute-frame-size* ( insn -- )
+
+M: ##frame-required compute-frame-size*
+ frame-required? on
+ n>> frame-size [ max ] change ;
+
+M: _spill-integer compute-frame-size*
+ drop frame-required? on ;
+
+M: _spill-float compute-frame-size*
+ drop frame-required? on ;
+
+M: insn compute-frame-size* drop ;
+
+: compute-frame-size ( insns -- )
+ [ compute-frame-size* ] each ;
+
+GENERIC: insert-pro/epilogues* ( insn -- )
+
+M: ##frame-required insert-pro/epilogues* drop ;
+
+M: ##prologue insert-pro/epilogues*
+ drop frame-required? get [ _prologue ] when ;
+
+M: ##epilogue insert-pro/epilogues*
+ drop frame-required? get [ _epilogue ] when ;
+
+M: insn insert-pro/epilogues* , ;
+
+: insert-pro/epilogues ( insns -- insns )
+ [ [ insert-pro/epilogues* ] each ] { } make ;
+
+: build-stack-frame ( mr -- mr )
+ [
+ init-stack-frame-builder
+ [
+ [ compute-frame-size ]
+ [ insert-pro/epilogues ]
+ bi
+ ] change-instructions
+ frame-size get >>frame-size
+ ] with-scope ;
USING: arrays assocs classes classes.private classes.algebra
combinators hashtables kernel layouts math fry namespaces
quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order compiler.instructions
-compiler.registers ;
+byte-arrays accessors sets math.order compiler.backend
+compiler.cfg.instructions compiler.cfg.registers ;
IN: compiler.cfg.stacks
! Converting stack operations into register operations, while
! doing a bit of optimization along the way.
-
-USE: qualified
-FROM: compiler.generator.registers => +input+ ;
-FROM: compiler.generator.registers => +output+ ;
-FROM: compiler.generator.registers => +scratch+ ;
-FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: known-tag
! Value protocol
-GENERIC: set-operand-class ( class obj -- )
-GENERIC: operand-class* ( operand -- class )
GENERIC: move-spec ( obj -- spec )
GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value )
PRIVATE>
-: operand-class ( operand -- class )
- operand-class* object or ;
-
! Default implementation
-M: value set-operand-class 2drop ;
-M: value operand-class* drop f ;
M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
M: vreg move-spec reg-class>> move-spec ;
+M: vreg value-class* reg-class>> value-class* ;
M: int-regs move-spec drop f ;
-M: int-regs operand-class* drop object ;
+M: int-regs value-class* drop object ;
M: float-regs move-spec drop float ;
-M: float-regs operand-class* drop float ;
+M: float-regs value-class* drop float ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
M: rs-loc live-loc?
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-M: loc operand-class* class>> ;
-M: loc set-operand-class (>>class) ;
+M: loc value-class* class>> ;
+M: loc set-value-class (>>class) ;
M: loc move-spec drop loc ;
M: f move-spec drop loc ;
-M: f operand-class* ;
+M: f value-class* ;
-M: cached set-operand-class vreg>> set-operand-class ;
-M: cached operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ;
M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
[ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
-M: tagged set-operand-class (>>class) ;
-M: tagged operand-class* class>> ;
M: tagged move-spec drop f ;
-M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
-M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
-M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
-M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
-M: constant operand-class* value>> class ;
M: constant move-spec class ;
! Moving values between locations and registers
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
- dup operand-class {
- { [ dup \ f class<= ] [ drop %unbox-f ] }
- { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
- { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
- [ drop %unbox-any-c-ptr ]
+ dup value-class {
+ { [ dup \ f class<= ] [ drop ##unbox-f ] }
+ { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
+ [ drop ##unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination.
- int-regs next-vreg [ over %move operand-class ] keep
+ int-regs next-vreg [ over %move value-class ] keep
tagged new
swap >>vreg
swap >>class
%move ;
+! Operands holding pointers to freshly-allocated objects which
+! are guaranteed to be in the nursery
+SYMBOL: fresh-objects
+
+: fresh-object ( vreg/t -- ) fresh-objects get push ;
+
+: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
+
: %move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
- { { f f } [ %copy ] }
- { { unboxed-alien unboxed-alien } [ %copy ] }
- { { unboxed-byte-array unboxed-byte-array } [ %copy ] }
- { { unboxed-f unboxed-f } [ %copy ] }
- { { unboxed-c-ptr unboxed-c-ptr } [ %copy ] }
- { { float float } [ %copy-float ] }
+ { { f f } [ ##copy ] }
+ { { unboxed-alien unboxed-alien } [ ##copy ] }
+ { { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
+ { { unboxed-f unboxed-f } [ ##copy ] }
+ { { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
+ { { float float } [ ##copy-float ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
- { { f constant } [ value>> swap %load-literal ] }
+ { { f constant } [ value>> ##load-literal ] }
- { { f float } [ %box-float ] }
- { { f unboxed-alien } [ %box-alien ] }
- { { f loc } [ %peek ] }
+ { { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
+ { { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
+ { { f loc } [ ##peek ] }
- { { float f } [ %unbox-float ] }
- { { unboxed-alien f } [ %unbox-alien ] }
- { { unboxed-byte-array f } [ %unbox-byte-array ] }
- { { unboxed-f f } [ %unbox-f ] }
+ { { float f } [ ##unbox-float ] }
+ { { unboxed-alien f } [ ##unbox-alien ] }
+ { { unboxed-byte-array f } [ ##unbox-byte-array ] }
+ { { unboxed-f f } [ ##unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
- { { loc f } [ swap %replace ] }
+ { { loc f } [ swap ##replace ] }
[ drop %move-via-temp ]
} case ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
- \ %inc-d (finalize-height) ;
+ \ ##inc-d (finalize-height) ;
TUPLE: phantom-retainstack < phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
M: phantom-retainstack finalize-height
- \ %inc-r (finalize-height) ;
+ \ ##inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack.
: live-locs ( -- seq )
[ (live-locs) ] each-phantom append prune ;
-! Operands holding pointers to freshly-allocated objects which
-! are guaranteed to be in the nursery
-SYMBOL: fresh-objects
-
: reg-spec>class ( spec -- class )
float eq? double-float-regs int-regs ? ;
} cond 2nip ;
: alloc-vreg-for ( value spec -- vreg )
- alloc-vreg swap operand-class
+ alloc-vreg swap value-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
{
- { [ dup quotation? ] [ drop ] }
+ { [ dup { small-slot small-tagged } memq? ] [ drop ] }
{ [ 2dup compatible? ] [ drop ] }
[ (eager-load) ]
} cond ;
dup loc? over cached? or [ 2drop ] [ %move ] if
] each-loc ;
-: reset-phantom ( phantom -- )
- #! Kill register assignments but preserve constants and
- #! class information.
- dup phantom-locs*
- over stack>> [
- dup constant? [ nip ] [
- operand-class over set-operand-class
- ] if
- ] 2map
- over stack>> delete-all
- swap stack>> push-all ;
-
-: reset-phantoms ( -- )
- [ reset-phantom ] each-phantom ;
+: clear-phantoms ( -- )
+ [ stack>> delete-all ] each-phantom ;
: finalize-contents ( -- )
- finalize-locs finalize-vregs reset-phantoms ;
+ finalize-locs finalize-vregs clear-phantoms ;
! Loading stacks to vregs
: vreg-substitution ( value vreg -- pair )
[ substitute-vreg? ] assoc-filter >hashtable
'[ stack>> _ substitute-here ] each-phantom ;
-: clear-phantoms ( -- )
- [ stack>> delete-all ] each-phantom ;
-
-: set-operand-classes ( classes -- )
+: set-value-classes ( classes -- )
phantom-datastack get
over length over add-locs
- stack>> [ set-operand-class ] 2reverse-each ;
+ stack>> [
+ [ value-class class-and ] keep set-value-class
+ ] 2reverse-each ;
: finalize-phantoms ( -- )
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents
- clear-phantoms
finalize-heights
- fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
-
-: fresh-object ( obj -- ) fresh-objects get push ;
-
-: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
+ fresh-objects get [
+ empty? [ 0 ##frame-required ##gc ] unless
+ ] [ delete-all ] bi ;
: init-phantoms ( -- )
V{ } clone fresh-objects set
phantom-datastack [ clone ] change
phantom-retainstack [ clone ] change ;
-: operand-tag ( operand -- tag/f )
- operand-class dup [ class-tag ] when ;
-
-UNION: immediate fixnum POSTPONE: f ;
-
-: operand-immediate? ( operand -- ? )
- operand-class immediate class<= ;
-
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom
phantom-datastack get stack>> push ;
: phantom-rdrop ( n -- )
phantom-retainstack get phantom-input drop ;
+
+: phantom-pop ( -- vreg )
+ 1 phantom-datastack get phantom-input dup first f (lazy-load)
+ [ 1array substitute-vregs ] keep ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors sequences kernel fry namespaces
-quotations combinators classes.algebra compiler.instructions
-compiler.registers compiler.cfg.stacks ;
+quotations combinators classes.algebra compiler.backend
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
IN: compiler.cfg.templates
-USE: qualified
-FROM: compiler.generator.registers => +input+ ;
-FROM: compiler.generator.registers => +output+ ;
-FROM: compiler.generator.registers => +scratch+ ;
-FROM: compiler.generator.registers => +clobber+ ;
-
-: template-input +input+ swap at ; inline
-: template-output +output+ swap at ; inline
-: template-scratch +scratch+ swap at ; inline
-: template-clobber +clobber+ swap at ; inline
+TUPLE: template input output scratch clobber gc ;
: phantom&spec ( phantom specs -- phantom' specs' )
>r stack>> r>
[ stack>> [ >vreg ] map sift ] each-phantom append ;
: clobbered ( template -- seq )
- [ template-output ] [ template-clobber ] bi append ;
+ [ output>> ] [ clobber>> ] bi append ;
: clobbered? ( value name -- ? )
\ clobbered get member? [
[
live-vregs \ live-vregs set
dup clobbered \ clobbered set
- template-input [ values ] [ lazy-load ] bi zip
+ input>> [ values ] [ lazy-load ] bi zip
] with-scope ;
: alloc-scratch ( template -- assoc )
- template-scratch [ swap alloc-vreg ] assoc-map ;
+ scratch>> [ swap alloc-vreg ] assoc-map ;
-: do-template-inputs ( template -- inputs )
+: do-template-inputs ( template -- defs uses )
#! Load input values into registers and allocates scratch
#! registers.
- [ load-inputs ] [ alloc-scratch ] bi assoc-union ;
+ [ alloc-scratch ] [ load-inputs ] bi ;
-: do-template-outputs ( template inputs -- )
- [ template-output ] dip '[ _ at ] map
+: do-template-outputs ( template defs uses -- )
+ [ output>> ] 2dip assoc-union '[ _ at ] map
phantom-datastack get phantom-append ;
: apply-template ( pair quot -- vregs )
[
- first2 dup do-template-inputs
- [ do-template-outputs ] keep
+ first2
+ dup gc>> [ t fresh-object ] when
+ dup do-template-inputs
+ [ do-template-outputs ] 2keep
] dip call ; inline
: value-matches? ( value spec -- ? )
#! to the fixnum. Otherwise, the values don't match. If the
#! spec is not a quotation, its a reg-class, in which case
#! the value is always good.
- dup quotation? [
- over constant?
- [ >r value>> r> 2drop f ] [ 2drop f ] if
- ] [
- 2drop t
- ] if ;
+ {
+ { [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
+ { [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
+ [ 2drop t ]
+ } cond ;
: class-matches? ( actual expected -- ? )
{
: spec-matches? ( value spec -- ? )
2dup first value-matches?
- >r >r operand-class 2 r> ?nth class-matches? r> and ;
+ >r >r value-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( template -- ? )
- template-input phantom-datastack get swap
+ input>> phantom-datastack get swap
[ spec-matches? ] phantom&spec-agree? ;
: find-template ( templates -- pair/f )
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces make math math.parser sequences accessors
+kernel kernel.private layouts assocs words summary arrays
+combinators classes.algebra alien alien.c-types alien.structs
+alien.strings sets threads libc continuations.private
+compiler.errors
+compiler.alien
+compiler.backend
+compiler.codegen.fixup
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers ;
+IN: compiler.codegen
+
+GENERIC: generate-insn ( insn -- )
+
+GENERIC: v>operand ( obj -- operand )
+
+SYMBOL: registers
+
+M: constant v>operand
+ value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+
+M: value v>operand
+ >vreg [ registers get at ] [ "Bad value" throw ] if* ;
+
+: generate-insns ( insns -- code )
+ [
+ [
+ dup regs>> registers set
+ generate-insn
+ ] each
+ ] { } make fixup ;
+
+TUPLE: asm label code calls ;
+
+SYMBOL: calls
+
+: add-call ( word -- )
+ #! Compile this word later.
+ calls get push ;
+
+SYMBOL: compiling-word
+
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
+
+! Mapping _label IDs to label instances
+SYMBOL: labels
+
+: init-generator ( word -- )
+ H{ } clone labels set
+ V{ } clone literal-table set
+ V{ } clone calls set
+ compiling-word set
+ compiled-stack-traces? compiling-word get f ? add-literal drop ;
+
+: generate ( mr -- asm )
+ [
+ [ label>> ]
+ [ word>> init-generator ]
+ [ instructions>> generate-insns ] tri
+ calls get
+ asm boa
+ ] with-scope ;
+
+: lookup-label ( id -- label )
+ labels get [ drop <label> ] cache ;
+
+M: _label generate-insn
+ id>> lookup-label , ;
+
+M: _prologue generate-insn
+ drop %prologue ;
+
+M: _epilogue generate-insn
+ drop %epilogue ;
+
+M: ##load-literal generate-insn
+ [ obj>> ] [ dst>> v>operand ] bi load-literal ;
+
+M: ##peek generate-insn
+ [ dst>> v>operand ] [ loc>> ] bi %peek ;
+
+M: ##replace generate-insn
+ [ src>> ] [ loc>> ] bi %replace ;
+
+M: ##inc-d generate-insn n>> %inc-d ;
+
+M: ##inc-r generate-insn n>> %inc-r ;
+
+M: ##return generate-insn drop %return ;
+
+M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
+
+M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
+
+SYMBOL: operands
+
+: init-intrinsic ( insn -- )
+ [ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
+
+M: ##intrinsic generate-insn
+ [ init-intrinsic ] [ quot>> call ] bi ;
+
+: (operand) ( name -- operand )
+ operands get at* [ "Bad operand name" throw ] unless ;
+
+: operand ( name -- operand )
+ (operand) v>operand ;
+
+: operand-class ( var -- class )
+ (operand) value-class ;
+
+: operand-tag ( operand -- tag/f )
+ operand-class dup [ class-tag ] when ;
+
+: operand-immediate? ( operand -- ? )
+ operand-class immediate class<= ;
+
+: unique-operands ( operands quot -- )
+ >r [ operand ] map prune r> each ; inline
+
+M: _if-intrinsic generate-insn
+ [ init-intrinsic ]
+ [ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
+
+M: _branch generate-insn
+ label>> lookup-label %jump-label ;
+
+M: _branch-f generate-insn
+ [ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
+
+M: _branch-t generate-insn
+ [ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
+
+M: ##dispatch-label generate-insn label>> %dispatch-label ;
+
+M: ##dispatch generate-insn drop %dispatch ;
+
+: dst/src ( insn -- dst src )
+ [ dst>> v>operand ] [ src>> v>operand ] bi ;
+
+M: ##copy generate-insn dst/src %copy ;
+
+M: ##copy-float generate-insn dst/src %copy-float ;
+
+M: ##unbox-float generate-insn dst/src %unbox-float ;
+
+M: ##unbox-f generate-insn dst/src %unbox-f ;
+
+M: ##unbox-alien generate-insn dst/src %unbox-alien ;
+
+M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
+
+M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
+
+M: ##box-float generate-insn dst/src %box-float ;
+
+M: ##box-alien generate-insn dst/src %box-alien ;
+
+M: ##allot generate-insn
+ {
+ [ dst>> v>operand ]
+ [ size>> ]
+ [ type>> ]
+ [ tag>> ]
+ [ temp>> v>operand ]
+ } cleave
+ %allot ;
+
+M: ##write-barrier generate-insn
+ [ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
+
+M: ##gc generate-insn drop %gc ;
+
+! #alien-invoke
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
+ fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: float-regs inc-reg-class
+ dup call-next-method
+ fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+
+GENERIC: reg-class-full? ( class -- ? )
+
+M: stack-params reg-class-full? drop t ;
+
+M: object reg-class-full?
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
+
+: spill-param ( reg-class -- n reg-class )
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
+
+: fastcall-param ( reg-class -- n reg-class )
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+
+: alloc-parameter ( parameter -- reg reg-class )
+ c-type-reg-class dup reg-class-full?
+ [ spill-param ] [ fastcall-param ] if
+ [ param-reg ] keep ;
+
+: (flatten-int-type) ( size -- seq )
+ cell /i "void*" c-type <repetition> ;
+
+GENERIC: flatten-value-type ( type -- types )
+
+M: object flatten-value-type 1array ;
+
+M: struct-type flatten-value-type ( type -- types )
+ stack-size cell align (flatten-int-type) ;
+
+M: long-long-type flatten-value-type ( type -- types )
+ stack-size cell align (flatten-int-type) ;
+
+: flatten-value-types ( params -- params )
+ #! Convert value type structs to consecutive void*s.
+ [
+ 0 [
+ c-type
+ [ parameter-align (flatten-int-type) % ] keep
+ [ stack-size cell align + ] keep
+ flatten-value-type %
+ ] reduce drop
+ ] { } make ;
+
+: each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2each ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+
+: reset-freg-counts ( -- )
+ { int-regs float-regs stack-params } [ 0 swap set ] each ;
+
+: with-param-regs ( quot -- )
+ #! In quot you can call alloc-parameter
+ [ reset-freg-counts call ] with-scope ; inline
+
+: move-parameters ( node word -- )
+ #! Moves values from C stack to registers (if word is
+ #! %load-param-reg) and registers to C stack (if word is
+ #! %save-param-reg).
+ >r
+ alien-parameters
+ flatten-value-types
+ r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+ inline
+
+: unbox-parameters ( offset node -- )
+ parameters>> [
+ %prepare-unbox >r over + r> unbox-parameter
+ ] reverse-each-parameter drop ;
+
+: prepare-box-struct ( node -- offset )
+ #! Return offset on C stack where to store unboxed
+ #! parameters. If the C function is returning a structure,
+ #! the first parameter is an implicit target area pointer,
+ #! so we need to use a different offset.
+ return>> dup large-struct?
+ [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+
+: objects>registers ( params -- )
+ #! Generate code for unboxing a list of C types, then
+ #! generate code for moving these parameters to register on
+ #! architectures where parameters are passed in registers.
+ [
+ [ prepare-box-struct ] keep
+ [ unbox-parameters ] keep
+ \ %load-param-reg move-parameters
+ ] with-param-regs ;
+
+: box-return* ( node -- )
+ return>> [ ] [ box-return ] if-void ;
+
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+ drop "Library not found" ;
+
+M: no-such-library compiler-error-type
+ drop +linkage+ ;
+
+: no-such-library ( name -- )
+ \ no-such-library boa
+ compiling-word get compiler-error ;
+
+TUPLE: no-such-symbol name ;
+
+M: no-such-symbol summary
+ drop "Symbol not found" ;
+
+M: no-such-symbol compiler-error-type
+ drop +linkage+ ;
+
+: no-such-symbol ( name -- )
+ \ no-such-symbol boa
+ compiling-word get compiler-error ;
+
+: check-dlsym ( symbols dll -- )
+ dup dll-valid? [
+ dupd [ dlsym ] curry contains?
+ [ drop ] [ no-such-symbol ] if
+ ] [
+ dll-path no-such-library drop
+ ] if ;
+
+: stdcall-mangle ( symbol node -- symbol )
+ "@"
+ swap parameters>> parameter-sizes drop
+ number>string 3append ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
+ 2dup check-dlsym ;
+
+M: ##alien-invoke generate-insn
+ params>>
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call function
+ dup alien-invoke-dlsym %alien-invoke
+ ! Box return value
+ dup %cleanup
+ box-return* ;
+
+! ##alien-indirect
+M: ##alien-indirect generate-insn
+ params>>
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Save alien at top of stack to temporary storage
+ %prepare-alien-indirect
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call alien in temporary storage
+ %alien-indirect
+ ! Box return value
+ dup %cleanup
+ box-return* ;
+
+! ##alien-callback
+: box-parameters ( params -- )
+ alien-parameters [ box-parameter ] each-parameter ;
+
+: registers>objects ( node -- )
+ [
+ dup \ %save-param-reg move-parameters
+ "nest_stacks" f %alien-invoke
+ box-parameters
+ ] with-param-regs ;
+
+TUPLE: callback-context ;
+
+: current-callback 2 getenv ;
+
+: wait-to-return ( token -- )
+ dup current-callback eq? [
+ drop
+ ] [
+ yield wait-to-return
+ ] if ;
+
+: do-callback ( quot token -- )
+ init-catchstack
+ dup 2 setenv
+ slip
+ wait-to-return ; inline
+
+: callback-return-quot ( ctype -- quot )
+ return>> {
+ { [ dup "void" = ] [ drop [ ] ] }
+ { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+ [ c-type c-type-unboxer-quot ]
+ } cond ;
+
+: callback-prep-quot ( params -- quot )
+ parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+ [
+ [ callback-prep-quot ]
+ [ quot>> ]
+ [ callback-return-quot ] tri 3append ,
+ [ callback-context new do-callback ] %
+ ] [ ] make ;
+
+: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+
+: callback-unwind ( params -- n )
+ {
+ { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
+ [ drop 0 ]
+ } cond ;
+
+: %callback-return ( params -- )
+ #! All the extra book-keeping for %unwind is only for x86.
+ #! On other platforms its an alias for %return.
+ dup alien-return
+ [ %unnest-stacks ] [ %callback-value ] if-void
+ callback-unwind %unwind ;
+
+M: ##alien-callback generate-insn
+ params>>
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ %callback-return ]
+ tri ;
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
-combinators math.bitwise words.private cpu.architecture
-math.order accessors growable ;
-IN: compiler.cfg.fixup
+combinators math.bitwise words.private math.order accessors
+growable compiler.constants compiler.backend ;
+IN: compiler.codegen.fixup
-: no-stack-frame -1 ; inline
-
-TUPLE: frame-required n ;
-
-: frame-required ( n -- ) \ frame-required boa , ;
-
-: stack-frame-size ( code -- n )
- no-stack-frame [
- dup frame-required? [ n>> max ] [ drop ] if
- ] reduce ;
-
-GENERIC: fixup* ( frame-size obj -- frame-size )
+GENERIC: fixup* ( obj -- )
: code-format 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-
-M: label fixup*
- compiled-offset >>offset drop ;
-
-: define-label ( name -- ) <label> swap set ;
-
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
-: if-stack-frame ( frame-size quot -- )
- swap dup no-stack-frame =
- [ 2drop ] [ stack-frame swap call ] if ; inline
-
-M: word fixup*
- {
- { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
- { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
- } case ;
-
SYMBOL: relocation-table
SYMBOL: label-table
-! Relocation classes
-: rc-absolute-cell 0 ;
-: rc-absolute 1 ;
-: rc-relative 2 ;
-: rc-absolute-ppc-2/2 3 ;
-: rc-relative-ppc-2 4 ;
-: rc-relative-ppc-3 5 ;
-: rc-relative-arm-3 6 ;
-: rc-indirect-arm 7 ;
-: rc-indirect-arm-pc 8 ;
-
-: rc-absolute? ( n -- ? )
- dup rc-absolute-cell =
- over rc-absolute =
- rot rc-absolute-ppc-2/2 = or or ;
-
-! Relocation types
-: rt-primitive 0 ;
-: rt-dlsym 1 ;
-: rt-literal 2 ;
-: rt-dispatch 3 ;
-: rt-xt 4 ;
-: rt-here 5 ;
-: rt-label 6 ;
-: rt-immediate 7 ;
+M: label fixup* compiled-offset >>offset drop ;
TUPLE: label-fixup label class ;
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
- dup label>> swap class>> compiled-offset 4 - rot
+ [ label>> ] [ class>> ] bi compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
-M: frame-required fixup* drop ;
-
M: integer fixup* , ;
: adjoin* ( obj table -- n )
3array
] map concat ;
-: fixup ( code -- literals relocation labels code )
+: fixup ( fixup-directives -- code )
[
init-fixup
- dup stack-frame-size swap [ fixup* ] each drop
-
+ [ fixup* ] each
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
- ] { } make ;
+ ] { } make 4array ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors arrays kernel sequences namespaces
-math compiler.instructions.syntax ;
-IN: compiler.instructions
-
-! Virtual CPU instructions, used by CFG and machine IRs
-
-INSN: %cond-branch vreg ;
-INSN: %unary dst src ;
-
-! Stack operations
-INSN: %peek vreg loc ;
-INSN: %replace vreg loc ;
-INSN: %inc-d n ;
-INSN: %inc-r n ;
-INSN: %load-literal obj vreg ;
-
-! Calling convention
-INSN: %return ;
-
-! Subroutine calls
-INSN: %call word ;
-INSN: %jump word ;
-INSN: %intrinsic quot vregs ;
-
-! Jump tables
-INSN: %dispatch-label label ;
-INSN: %dispatch ;
-
-! Boxing and unboxing
-INSN: %copy < %unary ;
-INSN: %copy-float < %unary ;
-INSN: %unbox-float < %unary ;
-INSN: %unbox-f < %unary ;
-INSN: %unbox-alien < %unary ;
-INSN: %unbox-byte-array < %unary ;
-INSN: %unbox-any-c-ptr < %unary ;
-INSN: %box-float < %unary ;
-INSN: %box-alien < %unary ;
-
-INSN: %gc ;
-
-! FFI
-INSN: %alien-invoke params ;
-INSN: %alien-indirect params ;
-INSN: %alien-callback params ;
-
-GENERIC: uses-vregs ( insn -- seq )
-
-M: insn uses-vregs drop f ;
-M: %peek uses-vregs vreg>> 1array ;
-M: %replace uses-vregs vreg>> 1array ;
-M: %load-literal uses-vregs vreg>> 1array ;
-M: %unary uses-vregs [ dst>> ] [ src>> ] bi 2array ;
-M: %intrinsic uses-vregs vregs>> values ;
-
-! Instructions used by CFG IR only.
-INSN: %prologue ;
-INSN: %epilogue ;
-INSN: %frame-required n ;
-
-INSN: %branch ;
-INSN: %branch-f < %cond-branch ;
-INSN: %branch-t < %cond-branch ;
-INSN: %if-intrinsic quot vregs ;
-INSN: %boolean-intrinsic quot vregs out ;
-
-M: %cond-branch uses-vregs vreg>> 1array ;
-M: %if-intrinsic uses-vregs vregs>> values ;
-M: %boolean-intrinsic uses-vregs
- [ vregs>> values ] [ out>> ] bi suffix ;
-
-! Instructions used by machine IR only.
-INSN: _prologue n ;
-INSN: _epilogue n ;
-
-TUPLE: label id ;
-
-INSN: _label label ;
-
-: <label> ( -- label ) \ <label> counter label boa ;
-: define-label ( name -- ) <label> swap set ;
-
-: resolve-label ( label/name -- )
- dup label? [ get ] unless _label ;
-
-TUPLE: _cond-branch vreg label ;
-
-INSN: _branch label ;
-INSN: _branch-f < _cond-branch ;
-INSN: _branch-t < _cond-branch ;
-INSN: _if-intrinsic label quot vregs ;
-
-M: _cond-branch uses-vregs vreg>> 1array ;
-M: _if-intrinsic uses-vregs vregs>> values ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes.tuple classes.tuple.parser kernel words
-make parser ;
-IN: compiler.instructions.syntax
-
-TUPLE: insn ;
-
-: INSN:
- parse-tuple-definition
- [ dup tuple eq? [ drop insn ] when ] dip
- [ define-tuple-class ]
- [ 2drop save-location ]
- [ 2drop dup [ boa , ] curry define-inline ]
- 3tri ; parsing
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces arrays sequences io debugger
+words fry continuations vocabs assocs dlists definitions math
+threads graphs generic combinators deques search-deques
+stack-checker stack-checker.state stack-checker.inlining
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder
+compiler.cfg.linearization compiler.cfg.linear-scan
+compiler.cfg.stack-frame compiler.codegen ;
+IN: compiler.new
+
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+ {
+ { [ dup "forgotten" word-prop ] [ ] }
+ { [ dup compiled get key? ] [ ] }
+ { [ dup inlined-block? ] [ ] }
+ { [ dup primitive? ] [ ] }
+ [ dup compile-queue get push-front ]
+ } cond drop ;
+
+: maybe-compile ( word -- )
+ dup compiled>> [ drop ] [ queue-compile ] if ;
+
+SYMBOL: +failed+
+
+: ripple-up ( words -- )
+ dup "compiled-effect" word-prop +failed+ eq?
+ [ usage [ word? ] filter ] [ compiled-usage keys ] if
+ [ queue-compile ] each ;
+
+: ripple-up? ( word effect -- ? )
+ #! If the word has previously been compiled and had a
+ #! different stack effect, we have to recompile any callers.
+ swap "compiled-effect" word-prop [ = not ] keep and ;
+
+: save-effect ( word effect -- )
+ [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
+ [ "compiled-effect" set-word-prop ]
+ 2bi ;
+
+: start ( word -- )
+ H{ } clone dependencies set
+ H{ } clone generic-dependencies set
+ f swap compiler-error ;
+
+: fail ( word error -- )
+ [ swap compiler-error ]
+ [
+ drop
+ [ compiled-unxref ]
+ [ f swap compiled get set-at ]
+ [ +failed+ save-effect ]
+ tri
+ ] 2bi
+ return ;
+
+: frontend ( word -- effect nodes )
+ [ build-tree-from-word ] [ fail ] recover optimize-tree ;
+
+: finish ( effect word -- )
+ [ swap save-effect ]
+ [ compiled-unxref ]
+ [
+ dup crossref?
+ [
+ dependencies get >alist
+ generic-dependencies get >alist
+ compiled-xref
+ ] [ drop ] if
+ ] tri ;
+
+: save-asm ( asm -- )
+ [ [ code>> ] [ label>> ] bi compiled get set-at ]
+ [ calls>> [ queue-compile ] each ]
+ bi ;
+
+: backend ( nodes word -- )
+ build-cfg [
+ build-mr
+ linear-scan
+ build-stack-frame
+ generate
+ save-asm
+ ] each ;
+
+: (compile) ( word -- )
+ '[
+ _ {
+ [ start ]
+ [ frontend ]
+ [ backend ]
+ [ finish ]
+ } cleave
+ ] with-return ;
+
+: compile-loop ( deque -- )
+ [ (compile) yield ] slurp-deque ;
+
+: decompile ( word -- )
+ f 2array 1array t modify-code-heap ;
+
+: optimized-recompile-hook ( words -- alist )
+ [
+ <hashed-dlist> compile-queue set
+ H{ } clone compiled set
+ [ queue-compile ] each
+ compile-queue get compile-loop
+ compiled get >alist
+ ] with-scope ;
+
+: enable-compiler ( -- )
+ [ optimized-recompile-hook ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+ [ default-recompile-hook ] recompile-hook set-global ;
+
+: recompile-all ( -- )
+ forget-errors all-words compile ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces math kernel ;
-IN: compiler.registers
-
-! Virtual CPU registers, used by CFG and machine IRs
-
-MIXIN: value
-
-GENERIC: >vreg ( obj -- vreg )
-
-M: value >vreg drop f ;
-
-! Register classes
-SINGLETON: int-regs
-SINGLETON: single-float-regs
-SINGLETON: double-float-regs
-UNION: float-regs single-float-regs double-float-regs ;
-UNION: reg-class int-regs float-regs ;
-
-! Virtual registers
-TUPLE: vreg reg-class n ;
-SYMBOL: vreg-counter
-: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
-
-M: vreg >vreg ;
-
-INSTANCE: vreg value
-
-! Stack locations
-TUPLE: loc n class ;
-
-! A data stack location.
-TUPLE: ds-loc < loc ;
-: <ds-loc> ( n -- loc ) f ds-loc boa ;
-
-TUPLE: rs-loc < loc ;
-: <rs-loc> ( n -- loc ) f rs-loc boa ;
-
-INSTANCE: loc value
-
-! A stack location which has been loaded into a register. To
-! read the location, we just read the register, but when time
-! comes to save it back to the stack, we know the register just
-! contains a stack value so we don't have to redundantly write
-! it back.
-TUPLE: cached loc vreg ;
-C: <cached> cached
-
-M: cached >vreg vreg>> >vreg ;
-
-INSTANCE: cached value
-
-! A tagged pointer
-TUPLE: tagged vreg class ;
-: <tagged> ( vreg -- tagged ) f tagged boa ;
-
-M: tagged >vreg vreg>> ;
-
-INSTANCE: tagged value
-
-! Unboxed value
-TUPLE: unboxed vreg ;
-C: <unboxed> unboxed
-
-M: unboxed >vreg vreg>> ;
-
-INSTANCE: unboxed value
-
-! Unboxed alien pointer
-TUPLE: unboxed-alien < unboxed ;
-C: <unboxed-alien> unboxed-alien
-
-! Untagged byte array pointer
-TUPLE: unboxed-byte-array < unboxed ;
-C: <unboxed-byte-array> unboxed-byte-array
-
-! A register set to f
-TUPLE: unboxed-f < unboxed ;
-C: <unboxed-f> unboxed-f
-
-! An alien, byte array or f
-TUPLE: unboxed-c-ptr < unboxed ;
-C: <unboxed-c-ptr> unboxed-c-ptr
-
-! A constant value
-TUPLE: constant value ;
-C: <constant> constant
-
-INSTANCE: constant value
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel words sequences lexer parser fry ;
+IN: cpu.x86.syntax
+
+: define-register ( name num size -- )
+ [ "cpu.x86" create dup define-symbol ]
+ [ dupd "register" set-word-prop ]
+ [ "register-size" set-word-prop ]
+ tri* ;
+
+: define-registers ( names size -- )
+ [ dup length ] dip '[ _ define-register ] 2each ;
+
+: REGISTERS: ( -- )
+ scan-word ";" parse-tokens swap define-registers ; parsing
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays compiler.constants compiler.backend
+compiler.codegen.fixup io.binary kernel combinators
+kernel.private math namespaces make sequences words system
+layouts math.order accessors cpu.x86.syntax ;
+IN: cpu.x86
+
+! A postfix assembler for x86 and AMD64.
+
+! In 32-bit mode, { 1234 } is absolute indirect addressing.
+! In 64-bit mode, { 1234 } is RIP-relative.
+! Beware!
+
+! Register operands -- eg, ECX
+REGISTERS: 8 AL CL DL BL ;
+
+REGISTERS: 16 AX CX DX BX SP BP SI DI ;
+
+REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
+
+REGISTERS: 64
+RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
+
+REGISTERS: 128
+XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
+XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
+
+TUPLE: byte value ;
+
+C: <byte> byte
+
+<PRIVATE
+
+#! Extended AMD64 registers (R8-R15) return true.
+GENERIC: extended? ( op -- ? )
+
+M: object extended? drop f ;
+
+PREDICATE: register < word
+ "register" word-prop ;
+
+PREDICATE: register-8 < register
+ "register-size" word-prop 8 = ;
+
+PREDICATE: register-16 < register
+ "register-size" word-prop 16 = ;
+
+PREDICATE: register-32 < register
+ "register-size" word-prop 32 = ;
+
+PREDICATE: register-64 < register
+ "register-size" word-prop 64 = ;
+
+PREDICATE: register-128 < register
+ "register-size" word-prop 128 = ;
+
+M: register extended? "register" word-prop 7 > ;
+
+! Addressing modes
+TUPLE: indirect base index scale displacement ;
+
+M: indirect extended? base>> extended? ;
+
+: canonicalize-EBP ( indirect -- indirect )
+ #! { EBP } ==> { EBP 0 }
+ dup base>> { EBP RBP R13 } member? [
+ dup displacement>> [ 0 >>displacement ] unless
+ ] when ;
+
+: canonicalize-ESP ( indirect -- indirect )
+ #! { ESP } ==> { ESP ESP }
+ dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
+
+: canonicalize ( indirect -- indirect )
+ #! Modify the indirect to work around certain addressing mode
+ #! quirks.
+ canonicalize-EBP canonicalize-ESP ;
+
+: <indirect> ( base index scale displacement -- indirect )
+ indirect boa canonicalize ;
+
+: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
+
+: indirect-base* ( op -- n ) base>> EBP or reg-code ;
+
+: indirect-index* ( op -- n ) index>> ESP or reg-code ;
+
+: indirect-scale* ( op -- n ) scale>> 0 or ;
+
+GENERIC: sib-present? ( op -- ? )
+
+M: indirect sib-present?
+ [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
+
+M: register sib-present? drop f ;
+
+GENERIC: r/m ( operand -- n )
+
+M: indirect r/m
+ dup sib-present?
+ [ drop ESP reg-code ] [ indirect-base* ] if ;
+
+M: register r/m reg-code ;
+
+! Immediate operands
+UNION: immediate byte integer ;
+
+GENERIC: fits-in-byte? ( value -- ? )
+
+M: byte fits-in-byte? drop t ;
+
+M: integer fits-in-byte? -128 127 between? ;
+
+GENERIC: modifier ( op -- n )
+
+M: indirect modifier
+ dup base>> [
+ displacement>> {
+ { [ dup not ] [ BIN: 00 ] }
+ { [ dup fits-in-byte? ] [ BIN: 01 ] }
+ { [ dup immediate? ] [ BIN: 10 ] }
+ } cond nip
+ ] [
+ drop BIN: 00
+ ] if ;
+
+M: register modifier drop BIN: 11 ;
+
+GENERIC# n, 1 ( value n -- )
+
+M: integer n, >le % ;
+M: byte n, >r value>> r> n, ;
+: 1, ( n -- ) 1 n, ; inline
+: 4, ( n -- ) 4 n, ; inline
+: 2, ( n -- ) 2 n, ; inline
+: cell, ( n -- ) bootstrap-cell n, ; inline
+
+: mod-r/m, ( reg# indirect -- )
+ [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
+
+: sib, ( indirect -- )
+ dup sib-present? [
+ [ indirect-base* ]
+ [ indirect-index* 3 shift ]
+ [ indirect-scale* 6 shift ] tri bitor bitor ,
+ ] [
+ drop
+ ] if ;
+
+GENERIC: displacement, ( op -- )
+
+M: indirect displacement,
+ dup displacement>> dup [
+ swap base>>
+ [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
+ ] [
+ 2drop
+ ] if ;
+
+M: register displacement, drop ;
+
+: addressing ( reg# indirect -- )
+ [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
+
+! Utilities
+UNION: operand register indirect ;
+
+GENERIC: operand-64? ( operand -- ? )
+
+M: indirect operand-64?
+ [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
+
+M: register-64 operand-64? drop t ;
+
+M: object operand-64? drop f ;
+
+: rex.w? ( rex.w reg r/m -- ? )
+ {
+ { [ dup register-128? ] [ drop operand-64? ] }
+ { [ dup not ] [ drop operand-64? ] }
+ [ nip operand-64? ]
+ } cond and ;
+
+: rex.r ( m op -- n )
+ extended? [ BIN: 00000100 bitor ] when ;
+
+: rex.b ( m op -- n )
+ [ extended? [ BIN: 00000001 bitor ] when ] keep
+ dup indirect? [
+ index>> extended? [ BIN: 00000010 bitor ] when
+ ] [
+ drop
+ ] if ;
+
+: rex-prefix ( reg r/m rex.w -- )
+ #! Compile an AMD64 REX prefix.
+ 2over rex.w? BIN: 01001000 BIN: 01000000 ?
+ swap rex.r swap rex.b
+ dup BIN: 01000000 = [ drop ] [ , ] if ;
+
+: 16-prefix ( reg r/m -- )
+ [ register-16? ] either? [ HEX: 66 , ] when ;
+
+: prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
+
+: prefix-1 ( reg rex.w -- ) f swap prefix ;
+
+: short-operand ( reg rex.w n -- )
+ #! Some instructions encode their single operand as part of
+ #! the opcode.
+ >r dupd prefix-1 reg-code r> + , ;
+
+: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
+
+: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
+
+: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
+
+: opcode-or ( opcode mask -- opcode' )
+ swap dup array?
+ [ unclip-last rot bitor suffix ] [ bitor ] if ;
+
+: 1-operand ( op reg,rex.w,opcode -- )
+ #! The 'reg' is not really a register, but a value for the
+ #! 'reg' field of the mod-r/m byte.
+ first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
+
+: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+ pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
+
+: immediate-1 ( imm dst reg,rex.w,opcode -- )
+ immediate-operand-size-bit 1-operand 1, ;
+
+: immediate-4 ( imm dst reg,rex.w,opcode -- )
+ immediate-operand-size-bit 1-operand 4, ;
+
+: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+ pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
+
+: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
+ #! If imm is a byte, compile the opcode and the byte.
+ #! Otherwise, set the 8-bit operand flag in the opcode, and
+ #! compile the cell. The 'reg' is not really a register, but
+ #! a value for the 'reg' field of the mod-r/m byte.
+ pick fits-in-byte? [
+ immediate-fits-in-size-bit immediate-1
+ ] [
+ immediate-4
+ ] if ;
+
+: (2-operand) ( dst src op -- )
+ >r 2dup t rex-prefix r> opcode,
+ reg-code swap addressing ;
+
+: direction-bit ( dst src op -- dst' src' op' )
+ pick register? [ BIN: 10 opcode-or swapd ] when ;
+
+: operand-size-bit ( dst src op -- dst' src' op' )
+ over register-8? [ BIN: 1 opcode-or ] unless ;
+
+: 2-operand ( dst src op -- )
+ #! Sets the opcode's direction bit. It is set if the
+ #! destination is a direct register operand.
+ 2over 16-prefix
+ direction-bit
+ operand-size-bit
+ (2-operand) ;
+
+PRIVATE>
+
+: [] ( reg/displacement -- indirect )
+ dup integer? [ >r f f f r> ] [ f f f ] if <indirect> ;
+
+: [+] ( reg displacement -- indirect )
+ dup integer?
+ [ dup zero? [ drop f ] when >r f f r> ]
+ [ f f ] if
+ <indirect> ;
+
+! Moving stuff
+GENERIC: PUSH ( op -- )
+M: register PUSH f HEX: 50 short-operand ;
+M: immediate PUSH HEX: 68 , 4, ;
+M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
+
+GENERIC: POP ( op -- )
+M: register POP f HEX: 58 short-operand ;
+M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
+
+! MOV where the src is immediate.
+GENERIC: (MOV-I) ( src dst -- )
+M: register (MOV-I) t HEX: b8 short-operand cell, ;
+M: operand (MOV-I)
+ { BIN: 000 t HEX: c6 }
+ pick byte? [ immediate-1 ] [ immediate-4 ] if ;
+
+GENERIC: MOV ( dst src -- )
+M: immediate MOV swap (MOV-I) ;
+M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
+M: operand MOV HEX: 88 2-operand ;
+
+: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
+
+! Control flow
+GENERIC: JMP ( op -- )
+: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
+M: word JMP (JMP) rel-word ;
+M: label JMP (JMP) label-fixup ;
+M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
+
+GENERIC: CALL ( op -- )
+: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
+M: word CALL (CALL) rel-word ;
+M: label CALL (CALL) label-fixup ;
+M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
+
+GENERIC# JUMPcc 1 ( addr opcode -- )
+: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
+M: word JUMPcc (JUMPcc) rel-word ;
+M: label JUMPcc (JUMPcc) label-fixup ;
+
+: JO ( dst -- ) HEX: 80 JUMPcc ;
+: JNO ( dst -- ) HEX: 81 JUMPcc ;
+: JB ( dst -- ) HEX: 82 JUMPcc ;
+: JAE ( dst -- ) HEX: 83 JUMPcc ;
+: JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
+: JNE ( dst -- ) HEX: 85 JUMPcc ;
+: JBE ( dst -- ) HEX: 86 JUMPcc ;
+: JA ( dst -- ) HEX: 87 JUMPcc ;
+: JS ( dst -- ) HEX: 88 JUMPcc ;
+: JNS ( dst -- ) HEX: 89 JUMPcc ;
+: JP ( dst -- ) HEX: 8a JUMPcc ;
+: JNP ( dst -- ) HEX: 8b JUMPcc ;
+: JL ( dst -- ) HEX: 8c JUMPcc ;
+: JGE ( dst -- ) HEX: 8d JUMPcc ;
+: JLE ( dst -- ) HEX: 8e JUMPcc ;
+: JG ( dst -- ) HEX: 8f JUMPcc ;
+
+: LEAVE ( -- ) HEX: c9 , ;
+: NOP ( -- ) HEX: 90 , ;
+
+: RET ( n -- )
+ dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
+
+! Arithmetic
+
+GENERIC: ADD ( dst src -- )
+M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
+M: operand ADD OCT: 000 2-operand ;
+
+GENERIC: OR ( dst src -- )
+M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
+M: operand OR OCT: 010 2-operand ;
+
+GENERIC: ADC ( dst src -- )
+M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
+M: operand ADC OCT: 020 2-operand ;
+
+GENERIC: SBB ( dst src -- )
+M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
+M: operand SBB OCT: 030 2-operand ;
+
+GENERIC: AND ( dst src -- )
+M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
+M: operand AND OCT: 040 2-operand ;
+
+GENERIC: SUB ( dst src -- )
+M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
+M: operand SUB OCT: 050 2-operand ;
+
+GENERIC: XOR ( dst src -- )
+M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
+M: operand XOR OCT: 060 2-operand ;
+
+GENERIC: CMP ( dst src -- )
+M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
+M: operand CMP OCT: 070 2-operand ;
+
+: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
+: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
+: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
+: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
+: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
+: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
+
+: CDQ ( -- ) HEX: 99 , ;
+: CQO ( -- ) HEX: 48 , CDQ ;
+
+: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
+: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
+: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
+: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
+: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
+: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
+: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
+
+GENERIC: IMUL2 ( dst src -- )
+M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
+M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
+
+: MOVSX ( dst src -- )
+ dup register-32? OCT: 143 OCT: 276 extended-opcode ?
+ over register-16? [ BIN: 1 opcode-or ] when
+ swapd
+ (2-operand) ;
+
+! Conditional move
+: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
+
+: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
+: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
+: CMOVB ( dst src -- ) HEX: 42 MOVcc ;
+: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
+: CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
+: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
+: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
+: CMOVA ( dst src -- ) HEX: 47 MOVcc ;
+: CMOVS ( dst src -- ) HEX: 48 MOVcc ;
+: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
+: CMOVP ( dst src -- ) HEX: 4a MOVcc ;
+: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
+: CMOVL ( dst src -- ) HEX: 4c MOVcc ;
+: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
+: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
+: CMOVG ( dst src -- ) HEX: 4f MOVcc ;
+
+! CPU Identification
+
+: CPUID ( -- ) HEX: a2 extended-opcode, ;
+
+! x87 Floating Point Unit
+
+: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
+: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
+
+: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
+: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
+
+! SSE multimedia instructions
+
+<PRIVATE
+
+: direction-bit-sse ( dst src op1 -- dst' src' op1' )
+ pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
+
+: 2-operand-sse ( dst src op1 op2 -- )
+ , direction-bit-sse extended-opcode (2-operand) ;
+
+: 2-operand-int/sse ( dst src op1 op2 -- )
+ , swapd extended-opcode (2-operand) ;
+
+PRIVATE>
+
+: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
+: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
+: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ;
+: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ;
+: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ;
+: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ;
+: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ;
+: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ;
+: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ;
+
+: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ;
+: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ;
+
+: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ;
+: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ;
+: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors hashtables kernel math state-tables vars vectors ;
-IN: regexp2.backend
-
-TUPLE: regexp
- raw
- { stack vector }
- parse-tree
- { options hashtable }
- nfa-table
- dfa-table
- minimized-table
- { nfa-traversal-flags hashtable }
- { dfa-traversal-flags hashtable }
- { state integer }
- { new-states vector }
- { visited-states hashtable } ;
-
-: reset-regexp ( regexp -- regexp )
- 0 >>state
- V{ } clone >>stack
- V{ } clone >>new-states
- H{ } clone >>visited-states ;
-
-SYMBOL: current-regexp
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math math.order symbols regexp2.parser
-words regexp2.utils unicode.categories combinators.short-circuit ;
-IN: regexp2.classes
-
-GENERIC: class-member? ( obj class -- ? )
-
-M: word class-member? ( obj class -- ? ) 2drop f ;
-M: integer class-member? ( obj class -- ? ) 2drop f ;
-
-M: character-class-range class-member? ( obj class -- ? )
- [ from>> ] [ to>> ] bi between? ;
-
-M: any-char class-member? ( obj class -- ? )
- 2drop t ;
-
-M: letter-class class-member? ( obj class -- ? )
- drop letter? ;
-
-M: LETTER-class class-member? ( obj class -- ? )
- drop LETTER? ;
-
-M: Letter-class class-member? ( obj class -- ? )
- drop Letter? ;
-
-M: ascii-class class-member? ( obj class -- ? )
- drop ascii? ;
-
-M: digit-class class-member? ( obj class -- ? )
- drop digit? ;
-
-M: alpha-class class-member? ( obj class -- ? )
- drop alpha? ;
-
-M: punctuation-class class-member? ( obj class -- ? )
- drop punct? ;
-
-M: java-printable-class class-member? ( obj class -- ? )
- drop java-printable? ;
-
-M: non-newline-blank-class class-member? ( obj class -- ? )
- drop { [ blank? ] [ CHAR: \n = not ] } 1&& ;
-
-M: control-character-class class-member? ( obj class -- ? )
- drop control-char? ;
-
-M: hex-digit-class class-member? ( obj class -- ? )
- drop hex-digit? ;
-
-M: java-blank-class class-member? ( obj class -- ? )
- drop java-blank? ;
-
-M: unmatchable-class class-member? ( obj class -- ? )
- 2drop f ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators fry kernel locals
-math math.order regexp2.nfa regexp2.transition-tables sequences
-sets sorting vectors regexp2.utils sequences.lib combinators.lib
-sequences.deep ;
-USING: io prettyprint threads ;
-IN: regexp2.dfa
-
-: find-delta ( states transition regexp -- new-states )
- nfa-table>> transitions>>
- rot [ swap at at ] with with map sift concat prune ;
-
-: (find-epsilon-closure) ( states regexp -- new-states )
- eps swap find-delta ;
-
-: find-epsilon-closure ( states regexp -- new-states )
- '[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
- natural-sort ;
-
-: find-closure ( states transition regexp -- new-states )
- [ find-delta ] 2keep nip find-epsilon-closure ;
-
-: find-start-state ( regexp -- state )
- [ nfa-table>> start-state>> 1vector ] keep find-epsilon-closure ;
-
-: find-transitions ( seq1 regexp -- seq2 )
- nfa-table>> transitions>>
- [ at keys ] curry map concat eps swap remove ;
-
-: add-todo-state ( state regexp -- )
- 2dup visited-states>> key? [
- 2drop
- ] [
- [ visited-states>> conjoin ]
- [ new-states>> push ] 2bi
- ] if ;
-
-: new-transitions ( regexp -- )
- dup new-states>> [
- drop
- ] [
- dupd pop dup pick find-transitions rot
- [
- [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
- >r swapd transition make-transition r> dfa-table>> add-transition
- ] curry with each
- new-transitions
- ] if-empty ;
-
-: states ( hashtable -- array )
- [ keys ]
- [ values [ values concat ] map concat append ] bi ;
-
-: set-final-states ( regexp -- )
- dup
- [ nfa-table>> final-states>> keys ]
- [ dfa-table>> transitions>> states ] bi
- [ intersect empty? not ] with filter
-
- swap dfa-table>> final-states>>
- [ conjoin ] curry each ;
-
-: set-initial-state ( regexp -- )
- dup
- [ dfa-table>> ] [ find-start-state ] bi
- [ >>start-state drop ] keep
- 1vector >>new-states drop ;
-
-: set-traversal-flags ( regexp -- )
- [ dfa-table>> transitions>> keys ]
- [ nfa-traversal-flags>> ]
- bi 2drop ;
-
-: construct-dfa ( regexp -- )
- [ set-initial-state ]
- [ new-transitions ]
- [ set-final-states ] tri ;
- ! [ set-traversal-flags ] quad ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs grouping kernel regexp2.backend
-locals math namespaces regexp2.parser sequences state-tables fry
-quotations math.order math.ranges vectors unicode.categories
-regexp2.utils regexp2.transition-tables words sequences.lib sets ;
-IN: regexp2.nfa
-
-SYMBOL: negation-mode
-: negated? ( -- ? ) negation-mode get 0 or odd? ;
-
-SINGLETON: eps
-
-MIXIN: traversal-flag
-SINGLETON: lookahead-on INSTANCE: lookahead-on traversal-flag
-SINGLETON: lookahead-off INSTANCE: lookahead-off traversal-flag
-SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
-SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
-
-: next-state ( regexp -- state )
- [ state>> ] [ [ 1+ ] change-state drop ] bi ;
-
-: set-start-state ( regexp -- )
- dup stack>> [
- drop
- ] [
- [ nfa-table>> ] [ pop first ] bi* >>start-state drop
- ] if-empty ;
-
-GENERIC: nfa-node ( node -- )
-
-:: add-simple-entry ( obj class -- )
- [let* | regexp [ current-regexp get ]
- s0 [ regexp next-state ]
- s1 [ regexp next-state ]
- stack [ regexp stack>> ]
- table [ regexp nfa-table>> ] |
- negated? [
- s0 f obj class make-transition table add-transition
- s0 s1 <default-transition> table add-transition
- ] [
- s0 s1 obj class make-transition table add-transition
- ] if
- s0 s1 2array stack push
- t s1 table final-states>> set-at ] ;
-
-: add-traversal-flag ( flag -- )
- stack peek second
- current-regexp get nfa-traversal-flags>> push-at ;
-
-:: concatenate-nodes ( -- )
- [let* | regexp [ current-regexp get ]
- stack [ regexp stack>> ]
- table [ regexp nfa-table>> ]
- s2 [ stack peek first ]
- s3 [ stack pop second ]
- s0 [ stack peek first ]
- s1 [ stack pop second ] |
- s1 s2 eps <literal-transition> table add-transition
- s1 table final-states>> delete-at
- s0 s3 2array stack push ] ;
-
-:: alternate-nodes ( -- )
- [let* | regexp [ current-regexp get ]
- stack [ regexp stack>> ]
- table [ regexp nfa-table>> ]
- s2 [ stack peek first ]
- s3 [ stack pop second ]
- s0 [ stack peek first ]
- s1 [ stack pop second ]
- s4 [ regexp next-state ]
- s5 [ regexp next-state ] |
- s4 s0 eps <literal-transition> table add-transition
- s4 s2 eps <literal-transition> table add-transition
- s1 s5 eps <literal-transition> table add-transition
- s3 s5 eps <literal-transition> table add-transition
- s1 table final-states>> delete-at
- s3 table final-states>> delete-at
- t s5 table final-states>> set-at
- s4 s5 2array stack push ] ;
-
-M: kleene-star nfa-node ( node -- )
- term>> nfa-node
- [let* | regexp [ current-regexp get ]
- stack [ regexp stack>> ]
- s0 [ stack peek first ]
- s1 [ stack pop second ]
- s2 [ regexp next-state ]
- s3 [ regexp next-state ]
- table [ regexp nfa-table>> ] |
- s1 table final-states>> delete-at
- t s3 table final-states>> set-at
- s1 s0 eps <literal-transition> table add-transition
- s2 s0 eps <literal-transition> table add-transition
- s2 s3 eps <literal-transition> table add-transition
- s1 s3 eps <literal-transition> table add-transition
- s2 s3 2array stack push ] ;
-
-M: concatenation nfa-node ( node -- )
- seq>>
- [ [ nfa-node ] each ]
- [ length 1- [ concatenate-nodes ] times ] bi ;
-
-M: alternation nfa-node ( node -- )
- seq>>
- [ [ nfa-node ] each ]
- [ length 1- [ alternate-nodes ] times ] bi ;
-
-M: constant nfa-node ( node -- )
- char>> literal-transition add-simple-entry ;
-
-M: epsilon nfa-node ( node -- )
- drop eps literal-transition add-simple-entry ;
-
-M: word nfa-node ( node -- )
- class-transition add-simple-entry ;
-
-M: character-class-range nfa-node ( node -- )
- class-transition add-simple-entry ;
-
-M: capture-group nfa-node ( node -- )
- term>> nfa-node ;
-
-M: negation nfa-node ( node -- )
- negation-mode inc
- term>> nfa-node
- negation-mode dec ;
-
-M: lookahead nfa-node ( node -- )
- eps literal-transition add-simple-entry
- lookahead-on add-traversal-flag
- term>> nfa-node
- eps literal-transition add-simple-entry
- lookahead-off add-traversal-flag
- 2 [ concatenate-nodes ] times ;
-
-: construct-nfa ( regexp -- )
- [
- reset-regexp
- negation-mode off
- [ current-regexp set ]
- [ parse-tree>> nfa-node ]
- [ set-start-state ] tri
- ] with-scope ;
+++ /dev/null
-USING: kernel tools.test regexp2.backend regexp2 ;
-IN: regexp2.parser
-
-: test-regexp ( string -- )
- default-regexp parse-regexp ;
-
-: test-regexp2 ( string -- regexp )
- default-regexp dup parse-regexp ;
-
-[ "(" ] [ unmatched-parentheses? ] must-fail-with
-
-[ ] [ "a|b" test-regexp ] unit-test
-[ ] [ "a.b" test-regexp ] unit-test
-[ ] [ "a|b|c" test-regexp ] unit-test
-[ ] [ "abc|b" test-regexp ] unit-test
-[ ] [ "a|bcd" test-regexp ] unit-test
-[ ] [ "a|(b)" test-regexp ] unit-test
-[ ] [ "(a)|b" test-regexp ] unit-test
-[ ] [ "(a|b)" test-regexp ] unit-test
-[ ] [ "((a)|(b))" test-regexp ] unit-test
-
-[ ] [ "(?:a)" test-regexp ] unit-test
-[ ] [ "(?i:a)" test-regexp ] unit-test
-[ ] [ "(?-i:a)" test-regexp ] unit-test
-[ "(?z:a)" test-regexp ] [ bad-option? ] must-fail-with
-[ "(?-z:a)" test-regexp ] [ bad-option? ] must-fail-with
-
-[ ] [ "(?=a)" test-regexp ] unit-test
-
-[ ] [ "[abc]" test-regexp ] unit-test
-[ ] [ "[a-c]" test-regexp ] unit-test
-[ ] [ "[^a-c]" test-regexp ] unit-test
-[ "[^]" test-regexp ] must-fail
-
-[ ] [ "|b" test-regexp ] unit-test
-[ ] [ "b|" test-regexp ] unit-test
-[ ] [ "||" test-regexp ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators io io.streams.string
-kernel math math.parser multi-methods namespaces qualified sets
-quotations sequences sequences.lib splitting symbols vectors
-dlists math.order combinators.lib unicode.categories strings
-sequences.lib regexp2.backend regexp2.utils unicode.case ;
-IN: regexp2.parser
-
-FROM: math.ranges => [a,b] ;
-
-MIXIN: node
-TUPLE: concatenation seq ; INSTANCE: concatenation node
-TUPLE: alternation seq ; INSTANCE: alternation node
-TUPLE: kleene-star term ; INSTANCE: kleene-star node
-
-! !!!!!!!!
-TUPLE: possessive-question term ; INSTANCE: possessive-question node
-TUPLE: possessive-kleene-star term ; INSTANCE: possessive-kleene-star node
-
-! !!!!!!!!
-TUPLE: reluctant-question term ; INSTANCE: reluctant-question node
-TUPLE: reluctant-kleene-star term ; INSTANCE: reluctant-kleene-star node
-
-TUPLE: negation term ; INSTANCE: negation node
-TUPLE: constant char ; INSTANCE: constant node
-TUPLE: range from to ; INSTANCE: range node
-TUPLE: lookahead term ; INSTANCE: lookahead node
-TUPLE: lookbehind term ; INSTANCE: lookbehind node
-TUPLE: capture-group term ; INSTANCE: capture-group node
-TUPLE: non-capture-group term ; INSTANCE: non-capture-group node
-TUPLE: independent-group term ; INSTANCE: independent-group node ! atomic group
-TUPLE: character-class-range from to ; INSTANCE: character-class-range node
-SINGLETON: epsilon INSTANCE: epsilon node
-SINGLETON: any-char INSTANCE: any-char node
-SINGLETON: front-anchor INSTANCE: front-anchor node
-SINGLETON: back-anchor INSTANCE: back-anchor node
-
-TUPLE: option-on option ; INSTANCE: option-on node
-TUPLE: option-off option ; INSTANCE: option-off node
-SINGLETONS: unix-lines dotall multiline comments case-insensitive unicode-case reversed-regexp ;
-
-SINGLETONS: letter-class LETTER-class Letter-class digit-class
-alpha-class non-newline-blank-class
-ascii-class punctuation-class java-printable-class blank-class
-control-character-class hex-digit-class java-blank-class c-identifier-class
-unmatchable-class ;
-
-SINGLETONS: beginning-of-group end-of-group
-beginning-of-character-class end-of-character-class
-left-parenthesis pipe caret dash ;
-
-: get-option ( option -- ? ) current-regexp get options>> at ;
-: get-unix-lines ( -- ? ) unix-lines get-option ;
-: get-dotall ( -- ? ) dotall get-option ;
-: get-multiline ( -- ? ) multiline get-option ;
-: get-comments ( -- ? ) comments get-option ;
-: get-case-insensitive ( -- ? ) case-insensitive get-option ;
-: get-unicode-case ( -- ? ) unicode-case get-option ;
-: get-reversed-regexp ( -- ? ) reversed-regexp get-option ;
-
-: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
-: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;
-: <possessive-question> ( obj -- kleene ) possessive-question boa ;
-: <reluctant-question> ( obj -- kleene ) reluctant-question boa ;
-
-: <negation> ( obj -- negation ) negation boa ;
-: <concatenation> ( seq -- concatenation )
- >vector get-reversed-regexp [ reverse ] when
- [ epsilon ] [ concatenation boa ] if-empty ;
-: <alternation> ( seq -- alternation ) >vector alternation boa ;
-: <capture-group> ( obj -- capture-group ) capture-group boa ;
-: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
-: <constant> ( obj -- constant )
- dup Letter? get-case-insensitive and [
- [ ch>lower constant boa ]
- [ ch>upper constant boa ] bi 2array <alternation>
- ] [
- constant boa
- ] if ;
-
-: first|concatenation ( seq -- first/concatenation )
- dup length 1 = [ first ] [ <concatenation> ] if ;
-
-: first|alternation ( seq -- first/alternation )
- dup length 1 = [ first ] [ <alternation> ] if ;
-
-: <character-class-range> ( from to -- obj )
- 2dup [ Letter? ] bi@ or get-case-insensitive and [
- [ [ ch>lower ] bi@ character-class-range boa ]
- [ [ ch>upper ] bi@ character-class-range boa ] 2bi
- 2array [ [ from>> ] [ to>> ] bi < ] filter
- [ unmatchable-class ] [ first|alternation ] if-empty
- ] [
- 2dup <
- [ character-class-range boa ] [ 2drop unmatchable-class ] if
- ] if ;
-
-ERROR: unmatched-parentheses ;
-
-: make-positive-lookahead ( string -- )
- lookahead boa push-stack ;
-
-: make-negative-lookahead ( string -- )
- <negation> lookahead boa push-stack ;
-
-: make-independent-group ( string -- )
- #! no backtracking
- independent-group boa push-stack ;
-
-: make-positive-lookbehind ( string -- )
- lookbehind boa push-stack ;
-
-: make-negative-lookbehind ( string -- )
- <negation> lookbehind boa push-stack ;
-
-: make-non-capturing-group ( string -- )
- non-capture-group boa push-stack ;
-
-ERROR: bad-option ch ;
-
-: option ( ch -- singleton )
- {
- { CHAR: i [ case-insensitive ] }
- { CHAR: d [ unix-lines ] }
- { CHAR: m [ multiline ] }
- { CHAR: n [ multiline ] }
- { CHAR: r [ reversed-regexp ] }
- { CHAR: s [ dotall ] }
- { CHAR: u [ unicode-case ] }
- { CHAR: x [ comments ] }
- [ bad-option ]
- } case ;
-
-: option-on ( option -- ) current-regexp get options>> conjoin ;
-: option-off ( option -- ) current-regexp get options>> delete-at ;
-
-: toggle-option ( ch ? -- ) [ option ] dip [ option-on ] [ option-off ] if ;
-: (parse-options) ( string ? -- ) [ toggle-option ] curry each ;
-
-: parse-options ( string -- )
- "-" split1 [ t (parse-options) ] [ f (parse-options) ] bi* ;
-
-DEFER: (parse-regexp)
-: parse-special-group ( -- )
- beginning-of-group push-stack
- (parse-regexp) pop-stack make-non-capturing-group ;
-
-ERROR: bad-special-group string ;
-
-DEFER: nested-parse-regexp
-: (parse-special-group) ( -- )
- read1 {
- { [ dup CHAR: # = ]
- [ drop nested-parse-regexp pop-stack drop ] }
- { [ dup CHAR: : = ]
- [ drop nested-parse-regexp pop-stack make-non-capturing-group ] }
- { [ dup CHAR: = = ]
- [ drop nested-parse-regexp pop-stack make-positive-lookahead ] }
- { [ dup CHAR: ! = ]
- [ drop nested-parse-regexp pop-stack make-negative-lookahead ] }
- { [ dup CHAR: > = ]
- [ drop nested-parse-regexp pop-stack make-independent-group ] }
- { [ dup CHAR: < = peek1 CHAR: = = and ]
- [ drop drop1 nested-parse-regexp pop-stack make-positive-lookbehind ] }
- { [ dup CHAR: < = peek1 CHAR: ! = and ]
- [ drop drop1 nested-parse-regexp pop-stack make-negative-lookbehind ] }
- [
- ":)" read-until
- [ swap prefix ] dip
- {
- { CHAR: : [ parse-options parse-special-group ] }
- { CHAR: ) [ parse-options ] }
- [ drop bad-special-group ]
- } case
- ]
- } cond ;
-
-: handle-left-parenthesis ( -- )
- peek1 CHAR: ? =
- [ drop1 (parse-special-group) ]
- [ nested-parse-regexp ] if ;
-
-: handle-dot ( -- ) any-char push-stack ;
-: handle-pipe ( -- ) pipe push-stack ;
-: (handle-star) ( obj -- kleene-star )
- peek1 {
- { CHAR: + [ drop1 <possessive-kleene-star> ] }
- { CHAR: ? [ drop1 <reluctant-kleene-star> ] }
- [ drop <kleene-star> ]
- } case ;
-: handle-star ( -- ) stack pop (handle-star) push-stack ;
-: handle-question ( -- )
- stack pop peek1 {
- { CHAR: + [ drop1 <possessive-question> ] }
- { CHAR: ? [ drop1 <reluctant-question> ] }
- [ drop epsilon 2array <alternation> ]
- } case push-stack ;
-: handle-plus ( -- )
- stack pop dup (handle-star)
- 2array <concatenation> push-stack ;
-
-ERROR: unmatched-brace ;
-: parse-repetition ( -- start finish ? )
- "}" read-until [ unmatched-brace ] unless
- [ "," split1 [ string>number ] bi@ ]
- [ CHAR: , swap index >boolean ] bi ;
-
-: replicate/concatenate ( n obj -- obj' )
- over zero? [ 2drop epsilon ]
- [ <repetition> first|concatenation ] if ;
-
-: exactly-n ( n -- )
- stack pop replicate/concatenate push-stack ;
-
-: at-least-n ( n -- )
- stack pop
- [ replicate/concatenate ] keep
- <kleene-star> 2array <concatenation> push-stack ;
-
-: at-most-n ( n -- )
- 1+
- stack pop
- [ replicate/concatenate ] curry map <alternation> push-stack ;
-
-: from-m-to-n ( m n -- )
- [a,b]
- stack pop
- [ replicate/concatenate ] curry map
- <alternation> push-stack ;
-
-ERROR: invalid-range a b ;
-
-: handle-left-brace ( -- )
- parse-repetition
- >r 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ r>
- [
- 2dup and [ from-m-to-n ]
- [ [ nip at-most-n ] [ at-least-n ] if* ] if
- ] [ drop 0 max exactly-n ] if ;
-
-: handle-front-anchor ( -- ) front-anchor push-stack ;
-: handle-back-anchor ( -- ) back-anchor push-stack ;
-
-ERROR: bad-character-class obj ;
-ERROR: expected-posix-class ;
-
-: parse-posix-class ( -- obj )
- read1 CHAR: { = [ expected-posix-class ] unless
- "}" read-until [ bad-character-class ] unless
- {
- { "Lower" [ get-case-insensitive Letter-class letter-class ? ] }
- { "Upper" [ get-case-insensitive Letter-class LETTER-class ? ] }
- { "Alpha" [ Letter-class ] }
- { "ASCII" [ ascii-class ] }
- { "Digit" [ digit-class ] }
- { "Alnum" [ alpha-class ] }
- { "Punct" [ punctuation-class ] }
- { "Graph" [ java-printable-class ] }
- { "Print" [ java-printable-class ] }
- { "Blank" [ non-newline-blank-class ] }
- { "Cntrl" [ control-character-class ] }
- { "XDigit" [ hex-digit-class ] }
- { "Space" [ java-blank-class ] }
- ! TODO: unicode-character-class, fallthrough in unicode is bad-char-clss
- [ bad-character-class ]
- } case ;
-
-: parse-octal ( -- n ) 3 read oct> check-octal ;
-: parse-short-hex ( -- n ) 2 read hex> check-hex ;
-: parse-long-hex ( -- n ) 6 read hex> check-hex ;
-: parse-control-character ( -- n ) read1 ;
-
-ERROR: bad-escaped-literals seq ;
-: parse-escaped-literals ( -- obj )
- "\\E" read-until [ bad-escaped-literals ] unless
- drop1
- [ epsilon ] [
- [ <constant> ] V{ } map-as
- first|concatenation
- ] if-empty ;
-
-: parse-escaped ( -- obj )
- read1
- {
- { CHAR: \ [ CHAR: \ <constant> ] }
- { CHAR: . [ CHAR: . <constant> ] }
- { CHAR: t [ CHAR: \t <constant> ] }
- { CHAR: n [ CHAR: \n <constant> ] }
- { CHAR: r [ CHAR: \r <constant> ] }
- { CHAR: f [ HEX: c <constant> ] }
- { CHAR: a [ HEX: 7 <constant> ] }
- { CHAR: e [ HEX: 1b <constant> ] }
- { CHAR: $ [ CHAR: $ <constant> ] }
- { CHAR: ^ [ CHAR: ^ <constant> ] }
-
- { CHAR: d [ digit-class ] }
- { CHAR: D [ digit-class <negation> ] }
- { CHAR: s [ java-blank-class ] }
- { CHAR: S [ java-blank-class <negation> ] }
- { CHAR: w [ c-identifier-class ] }
- { CHAR: W [ c-identifier-class <negation> ] }
-
- { CHAR: p [ parse-posix-class ] }
- { CHAR: P [ parse-posix-class <negation> ] }
- { CHAR: x [ parse-short-hex <constant> ] }
- { CHAR: u [ parse-long-hex <constant> ] }
- { CHAR: 0 [ parse-octal <constant> ] }
- { CHAR: c [ parse-control-character ] }
-
- ! { CHAR: b [ handle-word-boundary ] }
- ! { CHAR: B [ handle-word-boundary <negation> ] }
- ! { CHAR: A [ handle-beginning-of-input ] }
- ! { CHAR: G [ end of previous match ] }
- ! { CHAR: Z [ handle-end-of-input ] }
- ! { CHAR: z [ handle-end-of-input ] } ! except for terminator
-
- { CHAR: Q [ parse-escaped-literals ] }
- } case ;
-
-: handle-escape ( -- ) parse-escaped push-stack ;
-
-: handle-dash ( vector -- vector' )
- H{ { dash CHAR: - } } substitute ;
-
-: character-class>alternation ( seq -- alternation )
- [ dup number? [ <constant> ] when ] map first|alternation ;
-
-: handle-caret ( vector -- vector' )
- dup [ length 2 >= ] [ first caret eq? ] bi and [
- rest-slice character-class>alternation <negation>
- ] [
- character-class>alternation
- ] if ;
-
-: make-character-class ( -- character-class )
- [ beginning-of-character-class swap cut-stack ] change-whole-stack
- handle-dash handle-caret ;
-
-: apply-dash ( -- )
- stack [ pop3 nip <character-class-range> ] keep push ;
-
-: apply-dash? ( -- ? )
- stack dup length 3 >=
- [ [ length 2 - ] keep nth dash eq? ] [ drop f ] if ;
-
-ERROR: empty-negated-character-class ;
-DEFER: handle-left-bracket
-: (parse-character-class) ( -- )
- read1 [ empty-negated-character-class ] unless* {
- { CHAR: [ [ handle-left-bracket t ] }
- { CHAR: ] [ make-character-class push-stack f ] }
- { CHAR: - [ dash push-stack t ] }
- { CHAR: \ [ parse-escaped push-stack t ] }
- [ push-stack apply-dash? [ apply-dash ] when t ]
- } case
- [ (parse-character-class) ] when ;
-
-: parse-character-class-second ( -- )
- read1 {
- { CHAR: [ [ CHAR: [ <constant> push-stack ] }
- { CHAR: ] [ CHAR: ] <constant> push-stack ] }
- { CHAR: - [ CHAR: - <constant> push-stack ] }
- [ push1 ]
- } case ;
-
-: parse-character-class-first ( -- )
- read1 {
- { CHAR: ^ [ caret push-stack parse-character-class-second ] }
- { CHAR: [ [ CHAR: [ <constant> push-stack ] }
- { CHAR: ] [ CHAR: ] <constant> push-stack ] }
- { CHAR: - [ CHAR: - <constant> push-stack ] }
- [ push1 ]
- } case ;
-
-: handle-left-bracket ( -- )
- beginning-of-character-class push-stack
- parse-character-class-first (parse-character-class) ;
-
-: finish-regexp-parse ( stack -- obj )
- { pipe } split
- [ first|concatenation ] map first|alternation ;
-
-: handle-right-parenthesis ( -- )
- stack beginning-of-group over last-index cut rest
- [ current-regexp get swap >>stack drop ]
- [ finish-regexp-parse <capture-group> push-stack ] bi* ;
-
-: nested-parse-regexp ( -- )
- beginning-of-group push-stack (parse-regexp) ;
-
-: ((parse-regexp)) ( token -- ? )
- {
- { CHAR: . [ handle-dot t ] }
- { CHAR: ( [ handle-left-parenthesis t ] }
- { CHAR: ) [ handle-right-parenthesis f ] }
- { CHAR: | [ handle-pipe t ] }
- { CHAR: ? [ handle-question t ] }
- { CHAR: * [ handle-star t ] }
- { CHAR: + [ handle-plus t ] }
- { CHAR: { [ handle-left-brace t ] }
- { CHAR: [ [ handle-left-bracket t ] }
- { CHAR: ^ [ handle-front-anchor t ] }
- { CHAR: $ [ handle-back-anchor t ] }
- { CHAR: \ [ handle-escape t ] }
- [ <constant> push-stack t ]
- } case ;
-
-: (parse-regexp) ( -- )
- read1 [ ((parse-regexp)) [ (parse-regexp) ] when ] when* ;
-
-: parse-regexp ( regexp -- )
- dup current-regexp [
- raw>> [
- <string-reader> [ (parse-regexp) ] with-input-stream
- ] unless-empty
- current-regexp get
- stack finish-regexp-parse
- >>parse-tree drop
- ] with-variable ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings help.markup help.syntax regexp2.backend ;
-IN: regexp2
-
-HELP: <regexp>
-{ $values { "string" string } { "regexp" regexp } }
-{ $description "Compiles a regular expression into a DFA and returns this object. Regular expressions only have to be compiled once and can then be used multiple times to match input strings." } ;
-
-HELP: <iregexp>
-{ $values { "string" string } { "regexp" regexp } }
-{ $description "Compiles a case-insensitive regular expression into a DFA and returns this object. Otherwise, exactly the same as " { $link <regexp> } } ;
-
-{ <regexp> <iregexp> } related-words
+++ /dev/null
-USING: regexp2 tools.test kernel sequences regexp2.parser
-regexp2.traversal ;
-IN: regexp2-tests
-
-[ f ] [ "b" "a*" <regexp> matches? ] unit-test
-[ t ] [ "" "a*" <regexp> matches? ] unit-test
-[ t ] [ "a" "a*" <regexp> matches? ] unit-test
-[ t ] [ "aaaaaaa" "a*" <regexp> matches? ] unit-test
-[ f ] [ "ab" "a*" <regexp> matches? ] unit-test
-
-[ t ] [ "abc" "abc" <regexp> matches? ] unit-test
-[ t ] [ "a" "a|b|c" <regexp> matches? ] unit-test
-[ t ] [ "b" "a|b|c" <regexp> matches? ] unit-test
-[ t ] [ "c" "a|b|c" <regexp> matches? ] unit-test
-[ f ] [ "c" "d|e|f" <regexp> matches? ] unit-test
-
-[ t ] [ "b" "|b" <regexp> matches? ] unit-test
-[ t ] [ "b" "b|" <regexp> matches? ] unit-test
-[ t ] [ "" "b|" <regexp> matches? ] unit-test
-[ t ] [ "" "b|" <regexp> matches? ] unit-test
-[ f ] [ "" "|" <regexp> matches? ] unit-test
-[ f ] [ "" "|||||||" <regexp> matches? ] unit-test
-
-[ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
-[ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
-[ f ] [ "cc" "a|b|c" <regexp> matches? ] unit-test
-[ f ] [ "cc" "d|e|f" <regexp> matches? ] unit-test
-
-[ f ] [ "" "a+" <regexp> matches? ] unit-test
-[ t ] [ "a" "a+" <regexp> matches? ] unit-test
-[ t ] [ "aa" "a+" <regexp> matches? ] unit-test
-
-[ t ] [ "" "a?" <regexp> matches? ] unit-test
-[ t ] [ "a" "a?" <regexp> matches? ] unit-test
-[ f ] [ "aa" "a?" <regexp> matches? ] unit-test
-
-[ f ] [ "" "." <regexp> matches? ] unit-test
-[ t ] [ "a" "." <regexp> matches? ] unit-test
-[ t ] [ "." "." <regexp> matches? ] unit-test
-! [ f ] [ "\n" "." <regexp> matches? ] unit-test
-
-[ f ] [ "" ".+" <regexp> matches? ] unit-test
-[ t ] [ "a" ".+" <regexp> matches? ] unit-test
-[ t ] [ "ab" ".+" <regexp> matches? ] unit-test
-
-
-[ t ] [ "" "a|b*|c+|d?" <regexp> matches? ] unit-test
-[ t ] [ "a" "a|b*|c+|d?" <regexp> matches? ] unit-test
-[ t ] [ "c" "a|b*|c+|d?" <regexp> matches? ] unit-test
-[ t ] [ "cc" "a|b*|c+|d?" <regexp> matches? ] unit-test
-[ f ] [ "ccd" "a|b*|c+|d?" <regexp> matches? ] unit-test
-[ t ] [ "d" "a|b*|c+|d?" <regexp> matches? ] unit-test
-
-[ t ] [ "foo" "foo|bar" <regexp> matches? ] unit-test
-[ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
-[ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
-
-[ f ] [ "" "(a)" <regexp> matches? ] unit-test
-[ t ] [ "a" "(a)" <regexp> matches? ] unit-test
-[ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
-[ t ] [ "aa" "(a*)" <regexp> matches? ] unit-test
-
-[ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
-[ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
-
-[ f ] [ "" "a{1}" <regexp> matches? ] unit-test
-[ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
-[ f ] [ "aa" "a{1}" <regexp> matches? ] unit-test
-
-[ f ] [ "a" "a{2,}" <regexp> matches? ] unit-test
-[ t ] [ "aaa" "a{2,}" <regexp> matches? ] unit-test
-[ t ] [ "aaaa" "a{2,}" <regexp> matches? ] unit-test
-[ t ] [ "aaaaa" "a{2,}" <regexp> matches? ] unit-test
-
-[ t ] [ "" "a{,2}" <regexp> matches? ] unit-test
-[ t ] [ "a" "a{,2}" <regexp> matches? ] unit-test
-[ t ] [ "aa" "a{,2}" <regexp> matches? ] unit-test
-[ f ] [ "aaa" "a{,2}" <regexp> matches? ] unit-test
-[ f ] [ "aaaa" "a{,2}" <regexp> matches? ] unit-test
-[ f ] [ "aaaaa" "a{,2}" <regexp> matches? ] unit-test
-
-[ f ] [ "" "a{1,3}" <regexp> matches? ] unit-test
-[ t ] [ "a" "a{1,3}" <regexp> matches? ] unit-test
-[ t ] [ "aa" "a{1,3}" <regexp> matches? ] unit-test
-[ t ] [ "aaa" "a{1,3}" <regexp> matches? ] unit-test
-[ f ] [ "aaaa" "a{1,3}" <regexp> matches? ] unit-test
-
-[ f ] [ "" "[a]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[a]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[abc]" <regexp> matches? ] unit-test
-[ f ] [ "b" "[a]" <regexp> matches? ] unit-test
-[ f ] [ "d" "[abc]" <regexp> matches? ] unit-test
-[ t ] [ "ab" "[abc]{1,2}" <regexp> matches? ] unit-test
-[ f ] [ "abc" "[abc]{1,2}" <regexp> matches? ] unit-test
-
-[ f ] [ "" "[^a]" <regexp> matches? ] unit-test
-[ f ] [ "a" "[^a]" <regexp> matches? ] unit-test
-[ f ] [ "a" "[^abc]" <regexp> matches? ] unit-test
-[ t ] [ "b" "[^a]" <regexp> matches? ] unit-test
-[ t ] [ "d" "[^abc]" <regexp> matches? ] unit-test
-[ f ] [ "ab" "[^abc]{1,2}" <regexp> matches? ] unit-test
-[ f ] [ "abc" "[^abc]{1,2}" <regexp> matches? ] unit-test
-
-[ t ] [ "]" "[]]" <regexp> matches? ] unit-test
-[ f ] [ "]" "[^]]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[^]]" <regexp> matches? ] unit-test
-
-[ "^" "[^]" <regexp> matches? ] must-fail
-[ t ] [ "^" "[]^]" <regexp> matches? ] unit-test
-[ t ] [ "]" "[]^]" <regexp> matches? ] unit-test
-
-[ t ] [ "[" "[[]" <regexp> matches? ] unit-test
-[ f ] [ "^" "[^^]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[^^]" <regexp> matches? ] unit-test
-
-[ t ] [ "-" "[-]" <regexp> matches? ] unit-test
-[ f ] [ "a" "[-]" <regexp> matches? ] unit-test
-[ f ] [ "-" "[^-]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[^-]" <regexp> matches? ] unit-test
-
-[ t ] [ "-" "[-a]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[-a]" <regexp> matches? ] unit-test
-[ t ] [ "-" "[a-]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-]" <regexp> matches? ] unit-test
-[ f ] [ "b" "[a-]" <regexp> matches? ] unit-test
-[ f ] [ "-" "[^-]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[^-]" <regexp> matches? ] unit-test
-
-[ f ] [ "-" "[a-c]" <regexp> matches? ] unit-test
-[ t ] [ "-" "[^a-c]" <regexp> matches? ] unit-test
-[ t ] [ "b" "[a-c]" <regexp> matches? ] unit-test
-[ f ] [ "b" "[^a-c]" <regexp> matches? ] unit-test
-
-[ t ] [ "-" "[a-c-]" <regexp> matches? ] unit-test
-[ f ] [ "-" "[^a-c-]" <regexp> matches? ] unit-test
-
-[ t ] [ "\\" "[\\\\]" <regexp> matches? ] unit-test
-[ f ] [ "a" "[\\\\]" <regexp> matches? ] unit-test
-[ f ] [ "\\" "[^\\\\]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[^\\\\]" <regexp> matches? ] unit-test
-
-[ t ] [ "0" "[\\d]" <regexp> matches? ] unit-test
-[ f ] [ "a" "[\\d]" <regexp> matches? ] unit-test
-[ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
-[ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
-
-[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
-
-[ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
-[ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
-
-[ t ] [ "abc" "\\p{Lower}{3}" <regexp> matches? ] unit-test
-[ f ] [ "ABC" "\\p{Lower}{3}" <regexp> matches? ] unit-test
-[ t ] [ "ABC" "\\p{Upper}{3}" <regexp> matches? ] unit-test
-[ f ] [ "abc" "\\p{Upper}{3}" <regexp> matches? ] unit-test
-!
-[ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
-[ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
-
-[ f ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
-[ f ] [ "a" "\\Q\\E" <regexp> matches? ] unit-test
-[ t ] [ "|*+" "\\Q|*+\\E" <regexp> matches? ] unit-test
-[ f ] [ "abc" "\\Q|*+\\E" <regexp> matches? ] unit-test
-[ t ] [ "s" "\\Qs\\E" <regexp> matches? ] unit-test
-
-[ t ] [ "S" "\\0123" <regexp> matches? ] unit-test
-[ t ] [ "SXY" "\\0123XY" <regexp> matches? ] unit-test
-[ t ] [ "x" "\\x78" <regexp> matches? ] unit-test
-[ f ] [ "y" "\\x78" <regexp> matches? ] unit-test
-[ t ] [ "x" "\\u000078" <regexp> matches? ] unit-test
-[ f ] [ "y" "\\u000078" <regexp> matches? ] unit-test
-
-[ t ] [ "ab" "a+b" <regexp> matches? ] unit-test
-[ f ] [ "b" "a+b" <regexp> matches? ] unit-test
-[ t ] [ "aab" "a+b" <regexp> matches? ] unit-test
-[ f ] [ "abb" "a+b" <regexp> matches? ] unit-test
-
-[ t ] [ "abbbb" "ab*" <regexp> matches? ] unit-test
-[ t ] [ "a" "ab*" <regexp> matches? ] unit-test
-[ f ] [ "abab" "ab*" <regexp> matches? ] unit-test
-
-[ f ] [ "x" "\\." <regexp> matches? ] unit-test
-[ t ] [ "." "\\." <regexp> matches? ] unit-test
-
-[ t ] [ "aaaab" "a+ab" <regexp> matches? ] unit-test
-[ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
-[ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
-
-[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
-[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
-
-[ t ] [ "aaa" "AAA" <iregexp> matches? ] unit-test
-[ f ] [ "aax" "AAA" <iregexp> matches? ] unit-test
-[ t ] [ "aaa" "A*" <iregexp> matches? ] unit-test
-[ f ] [ "aaba" "A*" <iregexp> matches? ] unit-test
-[ t ] [ "b" "[AB]" <iregexp> matches? ] unit-test
-[ f ] [ "c" "[AB]" <iregexp> matches? ] unit-test
-[ t ] [ "c" "[A-Z]" <iregexp> matches? ] unit-test
-[ f ] [ "3" "[A-Z]" <iregexp> matches? ] unit-test
-
-[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
-[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
-[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
-[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
-
-[ t ] [ "a" "(?-i)a" <iregexp> matches? ] unit-test
-[ t ] [ "a" "(?-i)a" <iregexp> matches? ] unit-test
-[ f ] [ "A" "(?-i)a" <iregexp> matches? ] unit-test
-[ f ] [ "A" "(?-i)a" <iregexp> matches? ] unit-test
-
-[ f ] [ "A" "[a-z]" <regexp> matches? ] unit-test
-[ t ] [ "A" "[a-z]" <iregexp> matches? ] unit-test
-
-[ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
-[ t ] [ "A" "\\p{Lower}" <iregexp> matches? ] unit-test
-
-[ t ] [ "abc" <reversed> "abc" <rregexp> matches? ] unit-test
-[ t ] [ "abc" <reversed> "a[bB][cC]" <rregexp> matches? ] unit-test
-[ t ] [ "adcbe" "a(?r)(bcd)(?-r)e" <rregexp> matches? ] unit-test
-
-[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
-[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
-[ t ] [ ".o" "\\.[a-z]" <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]))"
- <regexp> drop
-] unit-test
-
-[ ] [ "(\\$[\\p{XDigit}]|[\\p{Digit}])" <regexp> drop ] unit-test
-
-! Comment
-[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
-
-
-
-[ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
-
-[ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
-[ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
-[ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
-[ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
-[ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
-[ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
-
-[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
-[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
-
-[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
-[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
-
-! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
-! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
-
-! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
-! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
-! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
-! [ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
-! [ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
-
-! [ f ] [ "foo bar" "foo\\B" <regexp> matches? ] unit-test
-! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-head ] unit-test
-! [ t ] [ "foo" "foo\\B" <regexp> matches? ] unit-test
-! [ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
-! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
-
-! Bug in parsing word
-! [ t ] [ "a" R' a' matches? ] unit-test
-
-! ((A)(B(C)))
-! 1. ((A)(B(C)))
-! 2. (A)
-! 3. (B(C))
-! 4. (C)
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel math math.ranges
-sequences regexp2.backend regexp2.utils memoize sets
-regexp2.parser regexp2.nfa regexp2.dfa regexp2.traversal
-regexp2.transition-tables assocs prettyprint.backend
-make ;
-IN: regexp2
-
-: default-regexp ( string -- regexp )
- regexp new
- swap >>raw
- <transition-table> >>nfa-table
- <transition-table> >>dfa-table
- <transition-table> >>minimized-table
- H{ } clone >>nfa-traversal-flags
- H{ } clone >>dfa-traversal-flags
- H{ } clone >>options
- reset-regexp ;
-
-: construct-regexp ( regexp -- regexp' )
- {
- [ parse-regexp ]
- [ construct-nfa ]
- [ construct-dfa ]
- [ ]
- } cleave ;
-
-: match ( string regexp -- pair )
- <dfa-traverser> do-match return-match ;
-
-: matches? ( string regexp -- ? )
- dupd match
- [ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ;
-
-: match-head ( string regexp -- end ) match length>> 1- ;
-
-: initial-option ( regexp option -- regexp' )
- over options>> conjoin ;
-
-: <regexp> ( string -- regexp )
- default-regexp construct-regexp ;
-
-: <iregexp> ( string -- regexp )
- default-regexp
- case-insensitive initial-option
- construct-regexp ;
-
-: <rregexp> ( string -- regexp )
- default-regexp
- reversed-regexp initial-option
- construct-regexp ;
-
-: R! CHAR: ! <regexp> ; parsing
-: R" CHAR: " <regexp> ; parsing
-: R# CHAR: # <regexp> ; parsing
-: R' CHAR: ' <regexp> ; parsing
-: R( CHAR: ) <regexp> ; parsing
-: R/ CHAR: / <regexp> ; parsing
-: R@ CHAR: @ <regexp> ; parsing
-: R[ CHAR: ] <regexp> ; parsing
-: R` CHAR: ` <regexp> ; parsing
-: R{ CHAR: } <regexp> ; parsing
-: R| CHAR: | <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 ;
-
-: option? ( option regexp -- ? )
- options>> key? ;
-
-M: regexp pprint*
- [
- [
- dup raw>>
- dup find-regexp-syntax swap % swap % %
- case-insensitive swap option? [ "i" % ] when
- ] "" make
- ] keep present-text ;
+++ /dev/null
-Regular expressions
+++ /dev/null
-parsing
-text
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs fry hashtables kernel sequences
-vectors regexp2.utils ;
-IN: regexp2.transition-tables
-
-TUPLE: transition from to obj ;
-TUPLE: literal-transition < transition ;
-TUPLE: class-transition < transition ;
-TUPLE: default-transition < transition ;
-
-TUPLE: literal obj ;
-TUPLE: class obj ;
-TUPLE: default ;
-: make-transition ( from to obj class -- obj )
- new
- swap >>obj
- swap >>to
- swap >>from ;
-
-: <literal-transition> ( from to obj -- transition )
- literal-transition make-transition ;
-: <class-transition> ( from to obj -- transition )
- class-transition make-transition ;
-: <default-transition> ( from to -- transition )
- t default-transition make-transition ;
-
-TUPLE: transition-table transitions start-state final-states ;
-
-: <transition-table> ( -- transition-table )
- transition-table new
- H{ } clone >>transitions
- H{ } clone >>final-states ;
-
-: set-transition ( transition hash -- )
- [ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
- 2dup at* [ 2nip insert-at ]
- [ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ;
-
-: add-transition ( transition transition-table -- )
- transitions>> set-transition ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators combinators.lib kernel
-math math.ranges quotations sequences regexp2.parser
-regexp2.classes combinators.short-circuit assocs.lib
-sequences.lib regexp2.utils ;
-IN: regexp2.traversal
-
-TUPLE: dfa-traverser
- dfa-table
- traversal-flags
- capture-groups
- { capture-group-index integer }
- { lookahead-counter integer }
- last-state current-state
- text
- start-index current-index
- matches ;
-
-: <dfa-traverser> ( text regexp -- match )
- [ dfa-table>> ] [ dfa-traversal-flags>> ] bi
- dfa-traverser new
- swap >>traversal-flags
- swap [ start-state>> >>current-state ] keep
- >>dfa-table
- swap >>text
- 0 >>start-index
- 0 >>current-index
- V{ } clone >>matches
- V{ } clone >>capture-groups ;
-
-: final-state? ( dfa-traverser -- ? )
- [ current-state>> ] [ dfa-table>> final-states>> ] bi
- key? ;
-
-: text-finished? ( dfa-traverser -- ? )
- [ current-index>> ] [ text>> length ] bi >= ;
-
-: save-final-state ( dfa-straverser -- )
- [ current-index>> ] [ matches>> ] bi push ;
-
-: match-done? ( dfa-traverser -- ? )
- dup final-state? [
- dup save-final-state
- ] when text-finished? ;
-
-: increment-state ( dfa-traverser state -- dfa-traverser )
- [
- [ 1+ ] change-current-index dup current-state>> >>last-state
- ] dip
- first >>current-state ;
-
-: match-failed ( dfa-traverser -- dfa-traverser )
- V{ } clone >>matches ;
-
-: match-literal ( transition from-state table -- to-state/f )
- transitions>> [ at ] [ 2drop f ] if-at ;
-
-: match-class ( transition from-state table -- to-state/f )
- transitions>> at* [
- [ drop class-member? ] assoc-with assoc-find [ nip ] [ drop ] if
- ] [ drop ] if ;
-
-: match-default ( transition from-state table -- to-state/f )
- [ nip ] dip transitions>>
- [ t swap [ drop f ] unless-at ] [ drop f ] if-at ;
-
-: match-transition ( obj from-state dfa -- to-state/f )
- { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
-
-: setup-match ( match -- obj state dfa-table )
- {
- [ current-index>> ] [ text>> ]
- [ current-state>> ] [ dfa-table>> ]
- } cleave
- [ nth ] 2dip ;
-
-: do-match ( dfa-traverser -- dfa-traverser )
- dup match-done? [
- dup setup-match match-transition
- [ increment-state do-match ] when*
- ] unless ;
-
-: return-match ( dfa-traverser -- interval/f )
- dup matches>>
- [ drop f ]
- [ [ start-index>> ] [ peek ] bi* 1 <range> ] if-empty ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators.lib io kernel
-math math.order namespaces regexp2.backend sequences
-sequences.lib unicode.categories math.ranges fry
-combinators.short-circuit vectors ;
-IN: regexp2.utils
-
-: (while-changes) ( obj quot pred pred-ret -- obj )
- ! quot: ( obj -- obj' )
- ! pred: ( obj -- <=> )
- [ [ dup slip ] dip pick over call ] dip dupd =
- [ 3drop ] [ (while-changes) ] if ; inline recursive
-
-: while-changes ( obj quot pred -- obj' )
- pick over call (while-changes) ; inline
-
-: assoc-with ( param assoc quot -- assoc curry )
- swapd [ [ -rot ] dip call ] 2curry ; inline
-
-: insert-at ( value key hash -- )
- 2dup at* [
- 2nip push
- ] [
- drop
- [ dup vector? [ 1vector ] unless ] 2dip set-at
- ] if ;
-
-: ?insert-at ( value key hash/f -- hash )
- [ H{ } clone ] unless* [ insert-at ] keep ;
-
-: last-state ( regexp -- range ) stack>> peek first2 [a,b] ;
-: push1 ( obj -- ) input-stream get stream>> push ;
-: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
-: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
-: drop1 ( -- ) read1 drop ;
-
-: stack ( -- obj ) current-regexp get stack>> ;
-: change-whole-stack ( quot -- )
- current-regexp get
- [ stack>> swap call ] keep (>>stack) ; inline
-: push-stack ( obj -- ) stack push ;
-: pop-stack ( -- obj ) stack pop ;
-: cut-out ( vector n -- vector' vector ) cut rest ;
-ERROR: cut-stack-error ;
-: cut-stack ( obj vector -- vector' vector )
- tuck last-index [ cut-stack-error ] unless* cut-out swap ;
-
-ERROR: bad-octal number ;
-ERROR: bad-hex number ;
-: check-octal ( octal -- octal ) dup 255 > [ bad-octal ] when ;
-: check-hex ( hex -- hex ) dup number? [ bad-hex ] unless ;
-
-: 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 -- ? )
- [
- [ decimal-digit? ]
- [ CHAR: a CHAR: f between? ]
- [ CHAR: A CHAR: F between? ]
- ] 1|| ;
-
-: control-char? ( n -- ? )
- [
- [ 0 HEX: 1f between? ]
- [ HEX: 7f = ]
- ] 1|| ;
-
-: punct? ( n -- ? )
- "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
-
-: c-identifier-char? ( ch -- ? )
- [ [ alpha? ] [ CHAR: _ = ] ] 1|| ;
-
-: java-blank? ( n -- ? )
- {
- CHAR: \s CHAR: \t CHAR: \n
- HEX: b HEX: 7 CHAR: \r
- } member? ;
-
-: java-printable? ( n -- ? )
- [ [ alpha? ] [ punct? ] ] 1|| ;
save_image(unbox_native_string());
}
+void strip_compiled_quotations(void)
+{
+ begin_scan();
+ CELL obj;
+ while((obj = next_object()) != F)
+ {
+ if(type_of(obj) == QUOTATION_TYPE)
+ {
+ F_QUOTATION *quot = untag_object(obj);
+ quot->compiledp = F;
+ }
+ }
+ gc_off = false;
+}
+
DEFINE_PRIMITIVE(save_image_and_exit)
{
+ /* We unbox this before doing anything else. This is the only point
+ where we might throw an error, so we have to throw an error here since
+ later steps destroy the current image. */
F_CHAR *path = unbox_native_string();
REGISTER_C_STRING(path);
+ /* This reduces deployed image size */
+ strip_compiled_quotations();
+
/* strip out userenv data which is set on startup anyway */
CELL i;
for(i = 0; i < FIRST_SAVE_ENV; i++)
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
+ write_barrier((CELL)new_string);
new_string->aux = tag_object(new_aux);
F_BYTE_ARRAY *aux = untag_object(string->aux);
}
REGISTER_UNTAGGED(string);
+ REGISTER_UNTAGGED(new_string);
fill_string(new_string,to_copy,capacity,fill);
+ UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
return new_string;
projects / factor.git / commitdiff