From be4915ee9c6b91d8e7878a8f5af4821a36d7e0f4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 14:44:58 -0500 Subject: [PATCH 01/11] Fix save-image-and-exit bug --- core/memory/memory-tests.factor | 3 ++- vm/image.c | 9 ++++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 9fded3eb3a..1c23e700ca 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,4 +1,4 @@ -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 @@ -19,6 +19,7 @@ TUPLE: testing x y z ; [ ] [ num-types get [ type>class [ + dup . flush "predicate" word-prop instances [ class drop ] each diff --git a/vm/image.c b/vm/image.c index a668cb7913..62f9e1c906 100755 --- a/vm/image.c +++ b/vm/image.c @@ -186,13 +186,16 @@ void strip_compiled_quotations(void) DEFINE_PRIMITIVE(save_image_and_exit) { - /* This reduces deployed image size */ - strip_compiled_quotations(); - + /* 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++) From 40009dac8793f6f1972c120446512b0078f08f61 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 19 Sep 2008 15:14:05 -0500 Subject: [PATCH 02/11] add match-range to regexp --- unfinished/regexp/regexp.factor | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/unfinished/regexp/regexp.factor b/unfinished/regexp/regexp.factor index 47c6e52c39..85bdccc2f4 100644 --- a/unfinished/regexp/regexp.factor +++ b/unfinished/regexp/regexp.factor @@ -33,7 +33,19 @@ IN: regexp dupd match [ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ; -: match-head ( string regexp -- end ) match length>> 1- ; +: 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 ; : initial-option ( regexp option -- regexp' ) over options>> conjoin ; From 65e88f70b99f9973153f59154bac1861305b065c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 15:45:27 -0500 Subject: [PATCH 03/11] Make counter runnable to demonstrate web app deployment --- extra/webapps/counter/counter.factor | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index f3efb3868f..a0ee3a1b29 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,3 +1,5 @@ +! 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 @@ -28,3 +30,20 @@ M: counter-app init-session* drop 0 count sset ; [ 1- ] "dec" add-responder "" add-responder ; + +! Deployment example +USING: db.sqlite db.tuples db furnace.db namespaces ; + +: counter-db ( -- params db ) "counter.db" sqlite-db ; + +: init-counter-db ( -- ) + counter-db [ session ensure-table ] with-db ; + +: run-counter ( -- ) + init-counter-db + + counter-db + main-responder set-global + 8080 httpd ; + +MAIN: run-counter From 90e440bf60ccfdc5164a4a81971166b28249b600 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 15:45:45 -0500 Subject: [PATCH 04/11] Fix html.elements load problem --- basis/html/elements/elements.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index ab9d987b67..ad75b58df3 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -48,8 +48,6 @@ IN: html.elements ! ! -: elements-vocab ( -- vocab-name ) "html.elements" ; - SYMBOL: html : write-html ( str -- ) @@ -60,6 +58,8 @@ SYMBOL: html << +: elements-vocab ( -- vocab-name ) "html.elements" ; + : html-word ( name def effect -- ) #! Define 'word creating' word to allow #! dynamically creating words. From 5647d08f5905b8b35d539ffbef7ffed64e044c6b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 15:46:02 -0500 Subject: [PATCH 05/11] Fix some farkup bugs --- basis/farkup/farkup-docs.factor | 6 +- basis/farkup/farkup-tests.factor | 4 ++ basis/farkup/farkup.factor | 103 ++++++++++++++++--------------- 3 files changed, 61 insertions(+), 52 deletions(-) diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor index f2d53d2362..6e7a5ddcb0 100644 --- a/basis/farkup/farkup-docs.factor +++ b/basis/farkup/farkup-docs.factor @@ -9,7 +9,7 @@ HELP: write-farkup { $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" } "." } ; @@ -18,7 +18,7 @@ HELP: (write-farkup) { $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 } @@ -44,7 +44,7 @@ $nl { $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" } ; diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index e25fa34960..cc032913b7 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -118,3 +118,7 @@ link-no-follow? off ] unit-test [ "

a c

" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test + +[ "

C++

" ] [ "[[C++]]" convert-farkup ] unit-test + +[ "

<foo>

" ] [ "" convert-farkup ] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 4d6ac127ad..cc56f48949 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -1,29 +1,29 @@ ! 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 memoize namespaces peg peg.ebnf +prettyprint sequences sequences.deep strings xml.entities +vectors splitting xmode.code2html urls ; 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: list child ; +TUPLE: table child ; +TUPLE: table-row child ; TUPLE: link href text ; TUPLE: image href text ; TUPLE: code mode string ; @@ -34,7 +34,7 @@ TUPLE: code mode string ; : 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 @@ -65,7 +65,7 @@ subscript = "~" (!("~" | nl).)+ "~" inline-code = "%" (!("%" | nl).)+ "%" => [[ second >string inline-code boa ]] -escaped-char = "\" . => [[ second ]] +escaped-char = "\" . => [[ second 1string ]] link-content = (!("|"|"]").)+ @@ -89,20 +89,26 @@ inline-tag = strong | emphasis | superscript | subscript | inline-code 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)+ +text = (!(nl | code | heading | inline-delimiter | table ).)+ + => [[ >string ]] + +paragraph-item = (table | text | inline-tag | inline-delimiter)+ paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]] | (paragraph-item nl)+ paragraph-item? | paragraph-item) => [[ paragraph boa ]] - -list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)* + +list-item = '-' (cell | inline-tag)* => [[ second list-item boa ]] list = ((list-item nl)+ list-item? | list-item) => [[ list boa ]] @@ -136,7 +142,7 @@ stand-alone : write-link ( href text -- ) escape-link - [ ] + [ ] [ write ] bi* ; @@ -146,7 +152,7 @@ stand-alone "Images are not allowed" write ] [ escape-link - [ ] bi* + [ ] bi* ] if ; : render-code ( string mode -- string' ) @@ -161,31 +167,30 @@ GENERIC: (write-farkup) ( farkup -- ) : ( string -- ) write ; : ( string -- ) write ; : in-tag. ( obj quot string -- ) [ call ] keep ; 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: list (write-farkup) [ child>> (write-farkup) ] "ul" 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: 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 ; From ad1c520d13ad01d40617b80783e7866e0ecf4acf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 15:46:12 -0500 Subject: [PATCH 06/11] Fix stack effects --- basis/urls/urls.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index e16f62d1f1..4f2639975b 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -14,7 +14,7 @@ IN: urls [ letter? ] [ LETTER? ] [ digit? ] - [ "/_-." member? ] + [ "/_-.:" member? ] } 1|| ; foldable -: url-encode ( str -- str ) +: url-encode ( str -- encoded ) [ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; @@ -58,7 +58,7 @@ PRIVATE> PRIVATE> -: url-decode ( str -- str ) +: url-decode ( str -- decoded ) [ 0 swap url-decode-iter ] "" make utf8 decode ; Date: Fri, 19 Sep 2008 16:36:31 -0500 Subject: [PATCH 07/11] Fix validation-messages tag --- basis/furnace/actions/actions.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index cce098f208..6e55ca44a0 100755 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -14,7 +14,8 @@ html.elements html.components html.components html.templates.chloe -html.templates.chloe.syntax ; +html.templates.chloe.syntax +html.templates.chloe.compiler ; IN: furnace.actions SYMBOL: params @@ -29,7 +30,8 @@ SYMBOL: rest ] unless-empty ; -CHLOE: validation-messages drop render-validation-messages ; +CHLOE: validation-messages + drop [ render-validation-messages ] [code] ; TUPLE: action rest authorize init display validate submit ; From 0f284816c1fd90cbd7d09bbeb8b090022bdf7771 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 16:37:27 -0500 Subject: [PATCH 08/11] Fix docs --- core/sequences/sequences-docs.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 789837ea47..b8be31c55c 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1356,16 +1356,18 @@ ARTICLE: "sequences-slices" "Subsequences and slices" "A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:" { $subsection slice } { $subsection slice? } -"Creating slices:" +"Extracting a slice:" { $subsection } { $subsection head-slice } { $subsection tail-slice } -{ $subsection but-last-slice } -{ $subsection rest-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 } ; From 7b8be1222f87475b8aae1dd648aa369542d6fe70 Mon Sep 17 00:00:00 2001 From: "U-WSCHLIEP-PC\\wschliep" Date: Fri, 19 Sep 2008 18:32:49 -0400 Subject: [PATCH 09/11] irc.client: Got rid of the annoying 100% CPU --- extra/irc/client/client.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) mode change 100644 => 100755 extra/irc/client/client.factor diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor old mode 100644 new mode 100755 index 2474fd643a..76382edf1b --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -91,8 +91,6 @@ SYMBOL: current-irc-client : 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 GENERIC: to-listener ( message obj -- ) @@ -294,14 +292,14 @@ DEFER: (connect-irc) [ (reader-loop) ] [ handle-disconnect ] recover t ; : writer-loop ( -- ? ) - irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ; + irc> out-messages>> mailbox-get handle-outgoing-irc t ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ? ) - irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ; + irc> in-messages>> mailbox-get handle-incoming-irc t ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -314,9 +312,10 @@ DEFER: (connect-irc) : 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 + irc> out-messages>> mailbox-put + t ] [ drop f ] if* ; : spawn-irc-loop ( quot: ( -- ? ) name -- ) From 19b2f6a6f31c70c77a51959d008f2d536267c4f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 19 Sep 2008 17:48:32 -0500 Subject: [PATCH 10/11] Fix farkup tests --- basis/farkup/farkup-tests.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index cc032913b7..571d333359 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -11,13 +11,11 @@ link-no-follow? off [ "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 [ "

a-b

" ] [ "a-b" convert-farkup ] unit-test From 9643ad1b9ea1bf829c71029daa24c34eca6b2a05 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 19 Sep 2008 17:54:34 -0500 Subject: [PATCH 11/11] work for lookahead --- unfinished/regexp/dfa/dfa.factor | 1 - unfinished/regexp/transition-tables/transition-tables.factor | 5 +++++ unfinished/regexp/traversal/traversal.factor | 4 ++++ 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/unfinished/regexp/dfa/dfa.factor b/unfinished/regexp/dfa/dfa.factor index 6f244dc8af..6200a1b3c0 100644 --- a/unfinished/regexp/dfa/dfa.factor +++ b/unfinished/regexp/dfa/dfa.factor @@ -27,7 +27,6 @@ IN: regexp.dfa nfa-table>> transitions>> [ at keys ] curry map concat eps swap remove ; - ! dup t member? [ t swap remove t suffix ] when ; : add-todo-state ( state regexp -- ) 2dup visited-states>> key? [ diff --git a/unfinished/regexp/transition-tables/transition-tables.factor b/unfinished/regexp/transition-tables/transition-tables.factor index 82e2db8496..1c9a3e3001 100644 --- a/unfinished/regexp/transition-tables/transition-tables.factor +++ b/unfinished/regexp/transition-tables/transition-tables.factor @@ -32,7 +32,12 @@ TUPLE: transition-table transitions start-state final-states ; 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 ; diff --git a/unfinished/regexp/traversal/traversal.factor b/unfinished/regexp/traversal/traversal.factor index 752323de91..cfc97aff29 100644 --- a/unfinished/regexp/traversal/traversal.factor +++ b/unfinished/regexp/traversal/traversal.factor @@ -43,6 +43,10 @@ TUPLE: dfa-traverser dup save-final-state ] when text-finished? ; +: print-flags ( dfa-traverser -- dfa-traverser ) + dup [ current-state>> ] [ traversal-flags>> ] bi + ; + : increment-state ( dfa-traverser state -- dfa-traverser ) [ [ 1+ ] change-current-index dup current-state>> >>last-state