From e92980b9ad3262a4f105dc9eb9ff94996cccc5b1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Jun 2008 00:41:48 -0500 Subject: [PATCH 01/42] fix compiler errors --- extra/html/parser/parser.factor | 2 +- extra/html/parser/utils/utils.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 1ae5768f98..c8aa9aa9e6 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -122,7 +122,7 @@ SYMBOL: tagstack : parse-attributes ( -- hashtable ) [ (parse-attributes) ] { } make >hashtable ; -: (parse-tag) +: (parse-tag) ( string -- string' hashtable ) [ read-token >lower parse-attributes diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 592503e3dd..c3372d750a 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -4,7 +4,7 @@ namespaces prettyprint quotations sequences splitting state-parser strings sequences.lib ; IN: html.parser.utils -: string-parse-end? +: string-parse-end? ( -- ? ) get-next not ; : take-string* ( match -- string ) From 90624a8764c81b8feb420c12fb16d8fb04e92f79 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 27 Jun 2008 19:40:46 -0500 Subject: [PATCH 02/42] monotonic-split works on empty seqs --- extra/sequences/lib/lib.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 56488818ab..324b8d166d 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -106,17 +106,21 @@ MACRO: firstn ( n -- ) : v, ( -- ) V{ } clone , ; : ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ; -: monotonic-split ( seq quot -- newseq ) +: (monotonic-split) ( seq quot -- newseq ) [ >r dup unclip suffix r> v, [ pick ,, call [ v, ] unless ] curry 2each ,v ] { } make ; +: monotonic-split ( seq quot -- newseq ) + over empty? [ 2drop { } ] [ (monotonic-split) ] if ; + : delete-random ( seq -- value ) [ length random ] keep [ nth ] 2keep delete-nth ; +ERROR: element-not-found ; : split-around ( seq quot -- before elem after ) - dupd find over [ "Element not found" throw ] unless + dupd find over [ element-not-found ] unless >r cut rest r> swap ; inline : (map-until) ( quot pred -- quot ) From 294c301877478268e6efa27768a39d26bf4c39f9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Jul 2008 16:34:05 -0500 Subject: [PATCH 03/42] Logging no longer uses parser combinators --- extra/logging/analysis/analysis.factor | 8 +++- extra/logging/insomniac/insomniac.factor | 12 ++---- extra/logging/parser/parser.factor | 53 +++++++++++++++--------- 3 files changed, 43 insertions(+), 30 deletions(-) diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor index a074ccd1b9..8f7f79d81e 100755 --- a/extra/logging/analysis/analysis.factor +++ b/extra/logging/analysis/analysis.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces words assocs logging sorting -prettyprint io io.styles strings logging.parser calendar.format -combinators ; +prettyprint io io.styles io.files io.encodings.utf8 +strings combinators +logging.server logging.parser calendar.format ; IN: logging.analysis SYMBOL: word-names @@ -69,3 +70,6 @@ SYMBOL: message-histogram : analyze-log ( lines word-names -- ) >r parse-log r> analyze-entries analysis. ; + +: analyze-log-file ( service word-names -- ) + >r parse-log-file r> analyze-entries analysis. ; diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index c7d1faf42e..7810a4afad 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp kernel io.files io.streams.string namespaces alarms assocs -io.encodings.utf8 accessors calendar qualified ; +io.encodings.utf8 accessors calendar sequences qualified ; QUALIFIED: io.sockets IN: logging.insomniac @@ -10,11 +10,7 @@ SYMBOL: insomniac-sender SYMBOL: insomniac-recipients : ?analyze-log ( service word-names -- string/f ) - >r log-path 1 log# dup exists? [ - utf8 file-lines r> [ analyze-log ] with-string-writer - ] [ - r> 2drop f - ] if ; + [ analyze-log-file ] with-string-writer ; : email-subject ( service -- string ) [ @@ -22,14 +18,14 @@ SYMBOL: insomniac-recipients ] "" make ; : (email-log-report) ( service word-names -- ) - dupd ?analyze-log dup [ + dupd ?analyze-log dup empty? [ 2drop ] [ swap >>body insomniac-recipients get >>to insomniac-sender get >>from swap email-subject >>subject send-email - ] [ 2drop ] if ; + ] if ; \ (email-log-report) NOTICE add-error-logging diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index 7215f29865..9c9161a15d 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -1,12 +1,15 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors parser-combinators memoize kernel sequences -logging arrays words strings vectors io io.files +USING: accessors peg peg.parsers memoize kernel sequences +logging arrays words strings vectors io io.files io.encodings.utf8 namespaces combinators combinators.lib logging.server calendar calendar.format ; IN: logging.parser -: string-of ( quot -- parser ) satisfy [ >string ] <@ ; +TUPLE: log-entry date level word-name message ; + +: string-of ( quot -- parser ) + satisfy repeat0 [ >string ] action ; inline SYMBOL: multiline @@ -14,13 +17,13 @@ SYMBOL: multiline [ "]" member? not ] string-of [ dup multiline-header = [ drop multiline ] [ rfc3339>timestamp ] if - ] <@ + ] action "[" "]" surrounded-by ; : 'log-level' ( -- parser ) log-levels [ - [ name>> token ] keep [ nip ] curry <@ - ] map ; + [ name>> token ] keep [ nip ] curry action + ] map choice ; : 'word-name' ( -- parser ) [ " :" member? not ] string-of ; @@ -28,36 +31,42 @@ SYMBOL: multiline SYMBOL: malformed : 'malformed-line' ( -- parser ) - [ drop t ] string-of [ malformed swap 2array ] <@ ; + [ drop t ] string-of + [ log-entry new swap >>message malformed >>level ] action ; : 'log-message' ( -- parser ) - [ drop t ] string-of [ 1vector ] <@ ; + [ drop t ] string-of + [ 1vector ] action ; -MEMO: 'log-line' ( -- parser ) - 'date' " " token <& - 'log-level' " " token <& <&> - 'word-name' ": " token <& <:&> - 'log-message' <:&> - 'malformed-line' <|> ; +: 'log-line' ( -- parser ) + [ + 'date' , + " " token hide , + 'log-level' , + " " token hide , + 'word-name' , + ": " token hide , + 'log-message' , + ] seq* [ first4 log-entry boa ] action + 'malformed-line' 2choice ; -: parse-log-line ( string -- entry ) - 'log-line' parse-1 ; +PEG: parse-log-line ( string -- entry ) 'log-line' ; : malformed? ( line -- ? ) - first malformed eq? ; + level>> malformed eq? ; : multiline? ( line -- ? ) - first multiline eq? ; + level>> multiline eq? ; : malformed-line ( line -- ) "Warning: malformed log line:" print - second print ; + message>> print ; : add-multiline ( line -- ) building get empty? [ "Warning: log begins with multiline entry" print drop ] [ - fourth first building get peek fourth push + message>> first building get peek message>> push ] if ; : parse-log ( lines -- entries ) @@ -70,3 +79,7 @@ MEMO: 'log-line' ( -- parser ) } cond ] each ] { } make ; + +: parse-log-file ( service -- entries ) + log-path 1 log# dup exists? + [ utf8 file-lines parse-log ] [ drop f ] if ; From 095a3e984c3205830bfda725d8049469e490cadc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Jul 2008 17:03:16 -0500 Subject: [PATCH 04/42] Fix analysis for recent change --- extra/logging/analysis/analysis.factor | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor index 8f7f79d81e..1e1e31c501 100755 --- a/extra/logging/analysis/analysis.factor +++ b/extra/logging/analysis/analysis.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces words assocs logging sorting prettyprint io io.styles io.files io.encodings.utf8 -strings combinators +strings combinators accessors arrays logging.server logging.parser calendar.format ; IN: logging.analysis @@ -12,11 +12,11 @@ SYMBOL: word-histogram SYMBOL: message-histogram : analyze-entry ( entry -- ) - dup second ERROR eq? [ dup errors get push ] when - dup second CRITICAL eq? [ dup errors get push ] when - 1 over third word-histogram get at+ - dup third word-names get member? [ - 1 over rest message-histogram get at+ + dup level>> { ERROR CRITICAL } memq? [ dup errors get push ] when + 1 over word-name>> word-histogram get at+ + dup word-name>> word-names get member? [ + 1 over [ level>> ] [ word-name>> ] [ message>> ] tri 3array + message-histogram get at+ ] when drop ; @@ -46,10 +46,10 @@ SYMBOL: message-histogram : log-entry. ( entry -- ) "====== " write { - [ first (timestamp>string) bl ] - [ second pprint bl ] - [ third write nl ] - [ fourth "\n" join print ] + [ date>> (timestamp>string) bl ] + [ level>> pprint bl ] + [ word-name>> write nl ] + [ message>> "\n" join print ] } cleave ; : errors. ( errors -- ) @@ -59,7 +59,7 @@ SYMBOL: message-histogram "==== INTERESTING MESSAGES:" print nl "Total: " write dup values sum . nl [ - dup second write ": " write third "\n" join write + dup level>> write ": " write message>> "\n" join write ] histogram. nl "==== WORDS:" print nl From 874b123bb06759de6aa4910f2b217e1cbca4e75f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Jul 2008 17:04:20 -0500 Subject: [PATCH 05/42] Debugging web framework and cleaning things up --- extra/furnace/actions/actions.factor | 2 +- extra/furnace/asides/asides.factor | 17 ++- extra/furnace/auth/auth.factor | 30 +++-- .../features/edit-profile/edit-profile.factor | 4 +- .../recover-password/recover-password.factor | 2 +- extra/furnace/auth/login/login.factor | 12 +- .../furnace/auth/login/permits/permits.factor | 6 +- extra/furnace/boilerplate/boilerplate.factor | 5 +- extra/furnace/flash/flash.factor | 2 +- extra/furnace/furnace.factor | 2 +- extra/furnace/redirection/redirection.factor | 6 +- extra/furnace/sessions/sessions.factor | 4 +- extra/furnace/syndication/syndication.factor | 2 +- extra/http/http.factor | 7 +- extra/http/parsers/parsers.factor | 2 +- extra/http/server/cgi/cgi.factor | 8 +- .../server/dispatchers/dispatchers.factor | 4 +- .../server/redirection/redirection.factor | 2 +- extra/http/server/server.factor | 9 +- extra/http/server/static/static.factor | 4 +- extra/webapps/blogs/blogs.factor | 12 +- extra/webapps/todo/todo.factor | 2 +- extra/webapps/wiki/changes.xml | 22 ---- extra/webapps/wiki/diff.xml | 2 +- extra/webapps/wiki/edit.xml | 7 +- extra/webapps/wiki/revisions-common.xml | 33 ++++++ extra/webapps/wiki/revisions.xml | 18 --- extra/webapps/wiki/user-edits.xml | 10 -- extra/webapps/wiki/view.xml | 8 +- extra/webapps/wiki/wiki-common.xml | 20 ++-- extra/webapps/wiki/wiki.factor | 106 +++++++++++++----- 31 files changed, 217 insertions(+), 153 deletions(-) create mode 100644 extra/webapps/wiki/revisions-common.xml diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 4b431c83bc..6448fcdf07 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -110,7 +110,7 @@ M: action call-responder* ( path action -- response ) } case ; M: action modify-form - drop request get url>> revalidate-url-key hidden-form-field ; + drop url get revalidate-url-key hidden-form-field ; : check-validation ( -- ) validation-failed? [ validation-failed ] when ; diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor index 9f1411188c..6d41c637c6 100644 --- a/extra/furnace/asides/asides.factor +++ b/extra/furnace/asides/asides.factor @@ -1,10 +1,17 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces sequences arrays kernel -assocs assocs.lib hashtables math.parser urls combinators -html.elements html.templates.chloe.syntax db.types db.tuples -http http.server http.server.filters -furnace furnace.cache furnace.sessions furnace.redirection ; +assocs hashtables math.parser urls combinators +logging db.types db.tuples +html.elements +html.templates.chloe.syntax +http +http.server +http.server.filters +furnace +furnace.cache +furnace.sessions +furnace.redirection ; IN: furnace.asides TUPLE: aside < server-state session method url post-data ; @@ -44,6 +51,8 @@ TUPLE: asides < server-state-manager ; url>> path>> split-path asides get responder>> call-responder ; +\ end-aside-post DEBUG add-input-logging + ERROR: end-aside-in-get-error ; : get-aside ( id -- aside ) diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index ae042f05bd..0c21c9f18d 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets -destructors combinators fry +destructors combinators fry logging io.encodings.utf8 io.encodings.string io.binary random checksums checksums.sha2 html.forms @@ -18,7 +18,11 @@ IN: furnace.auth SYMBOL: logged-in-user -: logged-in? ( -- ? ) logged-in-user get >boolean ; +: logged-in? ( -- ? ) + logged-in-user get >boolean ; + +: username ( -- string/f ) + logged-in-user get dup [ username>> ] when ; GENERIC: init-user-profile ( responder -- ) @@ -30,9 +34,6 @@ M: dispatcher init-user-profile M: filter-responder init-user-profile responder>> init-user-profile ; -: have-capability? ( capability -- ? ) - logged-in-user get capabilities>> member? ; - : profile ( -- assoc ) logged-in-user get profile>> ; : user-changed ( -- ) @@ -59,6 +60,8 @@ TUPLE: realm < dispatcher name users checksum secure ; GENERIC: login-required* ( realm -- response ) +GENERIC: init-realm ( realm -- ) + GENERIC: logged-in-username ( realm -- username ) : login-required ( -- * ) realm get login-required* exit-with ; @@ -87,9 +90,16 @@ M: user-saver dispose : init-user ( user -- ) [ [ logged-in-user set ] [ save-user-after ] bi ] when* ; +\ init-user DEBUG add-input-logging + M: realm call-responder* ( path responder -- response ) dup realm set - dup logged-in-username dup [ users get-user ] when init-user + logged-in? [ + dup init-realm + dup logged-in-username + dup [ users get-user ] when + init-user + ] unless call-next-method ; : encode-password ( string salt -- bytes ) @@ -122,18 +132,18 @@ TUPLE: protected < filter-responder description capabilities ; protected new swap >>responder ; -: check-capabilities ( responder user/f -- ? ) - { +: have-capabilities? ( capabilities -- ? ) + logged-in-user get { { [ dup not ] [ 2drop f ] } { [ dup deleted>> 1 = ] [ 2drop f ] } - [ [ capabilities>> ] bi@ subset? ] + [ capabilities>> subset? ] } cond ; M: protected call-responder* ( path responder -- response ) '[ , , dup protected set - dup logged-in-user get check-capabilities + dup capabilities>> have-capabilities? [ call-next-method ] [ 2drop realm get login-required* ] if ] if-secure-realm ; diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.factor b/extra/furnace/auth/features/edit-profile/edit-profile.factor index e03fca99a5..da6acece61 100644 --- a/extra/furnace/auth/features/edit-profile/edit-profile.factor +++ b/extra/furnace/auth/features/edit-profile/edit-profile.factor @@ -22,7 +22,7 @@ IN: furnace.auth.features.edit-profile { realm "features/edit-profile/edit-profile" } >>template [ - logged-in-user get username>> "username" set-value + username "username" set-value { { "realname" [ [ v-one-line ] v-optional ] } @@ -34,7 +34,7 @@ IN: furnace.auth.features.edit-profile { "password" "new-password" "verify-password" } [ value empty? not ] contains? [ - "password" value logged-in-user get username>> check-login + "password" value username check-login [ "incorrect password" validation-error ] unless same-password-twice diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor index 93b3a7ad73..77915f1083 100644 --- a/extra/furnace/auth/features/recover-password/recover-password.factor +++ b/extra/furnace/auth/features/recover-password/recover-password.factor @@ -11,7 +11,7 @@ IN: furnace.auth.features.recover-password SYMBOL: lost-password-from : current-host ( -- string ) - request get url>> host>> host-name or ; + url get host>> host-name or ; : new-password-url ( user -- url ) URL" recover-3" clone diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index ce533bce64..9246780a94 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces sequences math.parser -calendar validators urls html.forms +calendar validators urls logging html.forms http http.server http.server.dispatchers furnace furnace.auth @@ -25,10 +25,8 @@ SYMBOL: permit-id TUPLE: login-realm < realm timeout domain ; -M: login-realm call-responder* - [ name>> client-permit-id permit-id set ] - [ call-next-method ] - bi ; +M: login-realm init-realm + name>> client-permit-id permit-id set ; M: login-realm logged-in-username drop permit-id get dup [ get-permit-uid ] when ; @@ -47,11 +45,15 @@ M: login-realm modify-form ( responder -- ) : put-permit-cookie ( response -- response' ) put-cookie ; +\ put-permit-cookie DEBUG add-input-logging + : successful-login ( user -- response ) [ username>> make-permit permit-id set ] [ init-user ] bi URL" $realm" end-aside put-permit-cookie ; +\ successful-login DEBUG add-input-logging + : logout ( -- ) permit-id get [ delete-permit ] when* URL" $realm" end-aside ; diff --git a/extra/furnace/auth/login/permits/permits.factor b/extra/furnace/auth/login/permits/permits.factor index ae9458f4ac..1a9784f147 100644 --- a/extra/furnace/auth/login/permits/permits.factor +++ b/extra/furnace/auth/login/permits/permits.factor @@ -1,7 +1,5 @@ -USING: accessors namespaces combinators.lib kernel -db.tuples db.types -furnace.auth furnace.sessions furnace.cache -combinators.short-circuit ; +USING: accessors namespaces kernel combinators.short-circuit +db.tuples db.types furnace.auth furnace.sessions furnace.cache ; IN: furnace.auth.login.permits diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index 2bb97e7c14..59f71b1524 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -1,13 +1,12 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.order namespaces combinators.lib +USING: accessors kernel math.order namespaces furnace combinators.short-circuit html.forms html.templates html.templates.chloe locals http.server -http.server.filters -furnace combinators.short-circuit ; +http.server.filters ; IN: furnace.boilerplate TUPLE: boilerplate < filter-responder template init ; diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor index 2149e4fcd7..16d61487e3 100644 --- a/extra/furnace/flash/flash.factor +++ b/extra/furnace/flash/flash.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs assocs.lib kernel sequences accessors +USING: namespaces assocs kernel sequences accessors urls db.types db.tuples math.parser fry http http.server http.server.filters http.server.redirection furnace furnace.cache furnace.sessions furnace.redirection ; diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 242e193013..45aa55f050 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -86,7 +86,7 @@ M: object modify-form drop ; "user-agent" request get header>> at "" or ; : same-host? ( url -- ? ) - request get url>> + url get [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ; : cookie-client-state ( key request -- value/f ) diff --git a/extra/furnace/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor index 88d621b573..83941cd08f 100644 --- a/extra/furnace/redirection/redirection.factor +++ b/extra/furnace/redirection/redirection.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors combinators namespaces fry -io.servers.connection +io.servers.connection urls http http.server http.server.redirection http.server.filters furnace ; IN: furnace.redirection @@ -33,8 +33,8 @@ TUPLE: secure-only < filter-responder ; C: secure-only : if-secure ( quot -- ) - >r request get url>> protocol>> "http" = - [ request get url>> ] + >r url get protocol>> "http" = + [ url get ] r> if ; inline M: secure-only call-responder* diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 5590a9e55e..31711f54e9 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -2,12 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math.intervals math.parser namespaces strings random accessors quotations hashtables sequences continuations -fry calendar combinators combinators.lib destructors alarms +fry calendar combinators combinators.short-circuit destructors alarms io.servers.connection db db.tuples db.types http http.server http.server.dispatchers http.server.filters html.elements -furnace furnace.cache combinators.short-circuit ; +furnace furnace.cache ; IN: furnace.sessions TUPLE: session < server-state namespace user-agent client changed? ; diff --git a/extra/furnace/syndication/syndication.factor b/extra/furnace/syndication/syndication.factor index 7f60bcc746..31a978aef3 100644 --- a/extra/furnace/syndication/syndication.factor +++ b/extra/furnace/syndication/syndication.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences fry sequences.lib +USING: accessors kernel sequences fry combinators syndication http.server.responses http.server.redirection furnace furnace.actions ; diff --git a/extra/http/http.factor b/extra/http/http.factor index bf55cdebfa..90b8b86921 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -114,10 +114,13 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s ] } case ; +: check-cookie-value ( string -- string ) + [ "Cookie value must not be f" throw ] unless* ; + : (unparse-cookie) ( cookie -- strings ) [ dup name>> check-cookie-string >lower - over value>> unparse-cookie-value + over value>> check-cookie-value unparse-cookie-value "$path" over path>> unparse-cookie-value "$domain" over domain>> unparse-cookie-value drop @@ -129,7 +132,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s : unparse-set-cookie ( cookie -- string ) [ dup name>> check-cookie-string >lower - over value>> unparse-cookie-value + over value>> check-cookie-value unparse-cookie-value "path" over path>> unparse-cookie-value "domain" over domain>> unparse-cookie-value "expires" over expires>> unparse-cookie-value diff --git a/extra/http/parsers/parsers.factor b/extra/http/parsers/parsers.factor index bc6e1148c3..746741c894 100644 --- a/extra/http/parsers/parsers.factor +++ b/extra/http/parsers/parsers.factor @@ -1,4 +1,4 @@ -USING: combinators.short-circuit math math.order math.parser kernel combinators.lib +USING: combinators.short-circuit math math.order math.parser kernel sequences sequences.deep peg peg.parsers assocs arrays hashtables strings unicode.case namespaces ascii ; IN: http.parsers diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index 3a13b6de39..354ebd8f70 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -14,10 +14,10 @@ IN: http.server.cgi [ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi - request get url>> path>> "SCRIPT_NAME" set + url get path>> "SCRIPT_NAME" set - request get url>> host>> "SERVER_NAME" set - request get url>> port>> number>string "SERVER_PORT" set + url get host>> "SERVER_NAME" set + url get port>> number>string "SERVER_PORT" set "" "PATH_INFO" set "" "REMOTE_HOST" set "" "REMOTE_ADDR" set @@ -26,7 +26,7 @@ IN: http.server.cgi "" "REMOTE_IDENT" set request get method>> "REQUEST_METHOD" set - request get url>> query>> assoc>query "QUERY_STRING" set + url get query>> assoc>query "QUERY_STRING" set request get "cookie" header "HTTP_COOKIE" set request get "user-agent" header "HTTP_USER_AGENT" set diff --git a/extra/http/server/dispatchers/dispatchers.factor b/extra/http/server/dispatchers/dispatchers.factor index 2da2695992..405d96d1f5 100644 --- a/extra/http/server/dispatchers/dispatchers.factor +++ b/extra/http/server/dispatchers/dispatchers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences assocs accessors splitting -unicode.case http http.server http.server.responses ; +unicode.case urls http http.server http.server.responses ; IN: http.server.dispatchers TUPLE: dispatcher default responders ; @@ -35,7 +35,7 @@ TUPLE: vhost-dispatcher default responders ; >lower "www." ?head drop "." ?tail drop ; : find-vhost ( dispatcher -- responder ) - request get url>> host>> canonical-host over responders>> at* + url get host>> canonical-host over responders>> at* [ nip ] [ drop default>> ] if ; M: vhost-dispatcher call-responder* ( path dispatcher -- response ) diff --git a/extra/http/server/redirection/redirection.factor b/extra/http/server/redirection/redirection.factor index c1d2eaa63a..314c09e33d 100644 --- a/extra/http/server/redirection/redirection.factor +++ b/extra/http/server/redirection/redirection.factor @@ -9,7 +9,7 @@ GENERIC: relative-to-request ( url -- url' ) M: string relative-to-request ; M: url relative-to-request - request get url>> + url get clone f >>query swap derive-url ensure-port ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 6733bb8a41..436d626578 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -81,8 +81,7 @@ GENERIC: write-full-response ( request response -- ) : ensure-domain ( cookie -- cookie ) [ - request get url>> - host>> dup "localhost" = + url get host>> dup "localhost" = [ drop ] [ or ] if ] change-domain ; @@ -189,7 +188,7 @@ LOG: httpd-header NOTICE "/" split harvest ; : init-request ( request -- ) - request set + [ request set ] [ url>> url set ] bi V{ } clone responder-nesting set ; : dispatch-request ( request -- response ) @@ -224,7 +223,7 @@ LOG: httpd-benchmark DEBUG : ?benchmark ( quot -- ) benchmark? get [ - [ benchmark ] [ first ] bi request get url>> rot 3array + [ benchmark ] [ first ] bi url get rot 3array httpd-benchmark ] [ call ] if ; inline @@ -235,7 +234,7 @@ M: http-server handle-client* [ 64 1024 * limit-input ?refresh-all - read-request + [ read-request ] ?benchmark [ do-request ] ?benchmark [ do-response ] ?benchmark ] with-destructors ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 83fcf6f4a9..98510e45fd 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -82,12 +82,12 @@ TUPLE: file-responder root hook special allow-listings ; "index.html" append-path dup exists? [ drop f ] unless ; : serve-directory ( filename -- response ) - request get url>> path>> "/" tail? [ + url get path>> "/" tail? [ dup find-index [ serve-file ] [ list-directory ] ?if ] [ drop - request get url>> clone [ "/" append ] change-path + url get clone [ "/" append ] change-path ] if ; : serve-object ( filename -- response ) diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 10e0ab54c0..972c09f9b8 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -160,13 +160,13 @@ M: comment entity-url [ validate-post - logged-in-user get username>> "author" set-value + username "author" set-value ] >>validate [ f dup { "title" "content" } to-object - logged-in-user get username>> >>author + username >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit @@ -177,8 +177,8 @@ M: comment entity-url "make a new blog post" >>description ; : authorize-author ( author -- ) - logged-in-user get username>> = - can-administer-blogs? have-capability? or + username = + { can-administer-blogs? } have-capabilities? or [ login-required ] unless ; : do-post-action ( -- ) @@ -254,13 +254,13 @@ M: comment entity-url [ validate-comment - logged-in-user get username>> "author" set-value + username "author" set-value ] >>validate [ "parent" value f "content" value >>content - logged-in-user get username>> >>author + username >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 0fb7e7dc89..e726c4ed36 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -32,7 +32,7 @@ todo "TODO" : ( id -- todo ) todo new swap >>id - logged-in-user get username>> >>uid ; + username >>uid ; : ( -- action ) diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 1515c4924a..7004871df3 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -4,26 +4,4 @@ Recent Changes -
- - - - - - - - - - - - - - - - - -
ArticleDateBy
- -
- diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml index 9d65531eb0..75cb4a29fb 100644 --- a/extra/webapps/wiki/diff.xml +++ b/extra/webapps/wiki/diff.xml @@ -13,7 +13,7 @@ New revision: - + Created on by . diff --git a/extra/webapps/wiki/edit.xml b/extra/webapps/wiki/edit.xml index 057b7f8f71..90843a7140 100644 --- a/extra/webapps/wiki/edit.xml +++ b/extra/webapps/wiki/edit.xml @@ -4,12 +4,17 @@ Edit: - +

+

+ Describe this revision: + +

+

diff --git a/extra/webapps/wiki/revisions-common.xml b/extra/webapps/wiki/revisions-common.xml new file mode 100644 index 0000000000..6cf331532a --- /dev/null +++ b/extra/webapps/wiki/revisions-common.xml @@ -0,0 +1,33 @@ + + + + +
+ + + + + + + + + + + + + + + + + + + + + +
ArticleDateByDescriptionRollback
Rollback
+ +
+ + + + diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 0e1af75a8f..68f377e70b 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -4,24 +4,6 @@ Revisions of -
- - - - - - - - - - - - - - -
RevisionByRollback
Rollback
-
-

View Differences

diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml index 6f6ada2dbd..8035c24e24 100644 --- a/extra/webapps/wiki/user-edits.xml +++ b/extra/webapps/wiki/user-edits.xml @@ -8,14 +8,4 @@ Edits by -
    - -
  • - - on - -
    • -     -
- diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml index 7d2c7869b5..38d9d39d55 100644 --- a/extra/webapps/wiki/view.xml +++ b/extra/webapps/wiki/view.xml @@ -8,6 +8,12 @@ -

This revision created on by .

+

+ This revision created on by + + () + + +

diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 5cddcee628..dea79670a3 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -47,15 +47,17 @@ - - - - - - - - - + + + + + + + + + + + diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 3c87f3cd49..623c8aabe5 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -47,7 +47,7 @@ article "ARTICLES" { :
( title -- article ) article new swap >>title ; -TUPLE: revision id title author date content ; +TUPLE: revision id title author date content description ; revision "REVISIONS" { { "id" "ID" INTEGER +db-assigned-id+ } @@ -55,6 +55,7 @@ revision "REVISIONS" { { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid { "date" "DATE" TIMESTAMP +not-null+ } { "content" "CONTENT" TEXT +not-null+ } + { "description" "DESCRIPTION" TEXT } } define-persistent M: revision feed-entry-title @@ -76,6 +77,10 @@ M: revision feed-entry-url id>> revision-url ; : validate-author ( -- ) { { "author" [ v-username ] } } validate-params ; +: ( responder -- responder' ) + + { wiki "page-common" } >>template ; + : ( -- action ) [ "Front Page" view-url ] >>display ; @@ -100,7 +105,9 @@ M: revision feed-entry-url id>> revision-url ; ] [ edit-url ] ?if - ] >>display ; + ] >>display + + ; : ( -- action ) @@ -114,7 +121,9 @@ M: revision feed-entry-url id>> revision-url ; URL" $wiki/view/" adjust-url present relative-link-prefix set ] >>init - { wiki "view" } >>template ; + { wiki "view" } >>template + + ; : ( -- action ) @@ -144,28 +153,47 @@ M: revision feed-entry-url id>> revision-url ; [ validate-title - "title" value
select-tuple [ - revision>> select-tuple from-object - ] when* + + "title" value
select-tuple + [ revision>> select-tuple ] + [ f "title" value >>title ] + if* + + [ title>> "title" set-value ] + [ content>> "content" set-value ] + bi ] >>init { wiki "edit" } >>template + ; + +: ( -- action ) + [ validate-title - { { "content" [ v-required ] } } validate-params + + { + { "content" [ v-required ] } + { "description" [ [ v-one-line ] v-optional ] } + } validate-params f "title" value >>title now >>date - logged-in-user get username>> >>author + username >>author "content" value >>content + "description" value >>description [ add-revision ] [ title>> view-url ] bi ] >>submit "edit wiki articles" >>description ; +: ( responder -- responder ) + + { wiki "revisions-common" } >>template ; + : list-revisions ( -- seq ) f "title" value >>title select-tuples reverse-chronological-order ; @@ -180,7 +208,10 @@ M: revision feed-entry-url id>> revision-url ; list-revisions "revisions" set-value ] >>init - { wiki "revisions" } >>template ; + { wiki "revisions" } >>template + + + ; : ( -- action ) @@ -195,15 +226,26 @@ M: revision feed-entry-url id>> revision-url ; [ list-revisions ] >>entries ; +: rollback-description ( description -- description' ) + [ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ; + : ( -- action ) [ validate-integer-id ] >>validate [ - "id" value select-tuple clone f >>id - [ add-revision ] [ title>> view-url ] bi - ] >>submit ; + "id" value select-tuple + f >>id + now >>date + username >>author + [ rollback-description ] change-description + [ add-revision ] + [ title>> revisions-url ] bi + ] >>submit + + + "rollback wiki articles" >>description ; : list-changes ( -- seq ) f select-tuples @@ -211,8 +253,10 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) - [ list-changes "changes" set-value ] >>init - { wiki "changes" } >>template ; + [ list-changes "revisions" set-value ] >>init + { wiki "changes" } >>template + + ; : ( -- action ) @@ -237,6 +281,7 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + [ { { "old-id" [ v-integer ] } @@ -246,14 +291,18 @@ M: revision feed-entry-url id>> revision-url ; "old-id" "new-id" [ value select-tuple ] bi@ [ - [ [ title>> "title" set-value ] [ "old" [ from-object ] nest-form ] bi ] - [ "new" [ from-object ] nest-form ] bi* + over title>> "title" set-value + [ "old" [ from-object ] nest-form ] + [ "new" [ from-object ] nest-form ] + bi* ] [ [ content>> string-lines ] bi@ diff "diff" set-value ] 2bi ] >>init - { wiki "diff" } >>template ; + { wiki "diff" } >>template + + ; : ( -- action ) @@ -277,10 +326,12 @@ M: revision feed-entry-url id>> revision-url ; [ validate-author - list-user-edits "user-edits" set-value + list-user-edits "revisions" set-value ] >>init - { wiki "user-edits" } >>template ; + { wiki "user-edits" } >>template + + ; : ( -- action ) @@ -290,24 +341,21 @@ M: revision feed-entry-url id>> revision-url ; [ "author" value user-edits-url ] >>url [ list-user-edits ] >>entries ; -: ( responder -- responder' ) - - { wiki "page-common" } >>template ; - : init-sidebar ( -- ) "Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when* "Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ; : ( -- dispatcher ) wiki new-dispatcher - "" add-responder - "view" add-responder - "revision" add-responder + "" add-responder + "view" add-responder + "revision" add-responder "random" add-responder - "revisions" add-responder + "revisions" add-responder "revisions.atom" add-responder - "diff" add-responder - "edit" add-responder + "diff" add-responder + "edit" add-responder + "submit" add-responder "rollback" add-responder "user-edits" add-responder "articles" add-responder From c3ea84a026a8cd1095400889f40b649e041759e3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Jul 2008 18:09:03 -0500 Subject: [PATCH 06/42] use libcblas on openbsd --- extra/math/blas/cblas/cblas.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/math/blas/cblas/cblas.factor b/extra/math/blas/cblas/cblas.factor index 31807b7389..131007b9d0 100644 --- a/extra/math/blas/cblas/cblas.factor +++ b/extra/math/blas/cblas/cblas.factor @@ -4,6 +4,7 @@ IN: math.blas.cblas << "cblas" { { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } + { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] } [ "libblas.so" "cdecl" add-library ] } cond >> From 42f54c8014c7552816e2e49319a47a5f8072f587 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Jul 2008 18:24:28 -0500 Subject: [PATCH 07/42] Fix typedefs for 64-bit OpenBSD and FreeBSD --- extra/unix/types/freebsd/freebsd.factor | 6 ++---- extra/unix/types/openbsd/openbsd.factor | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/extra/unix/types/freebsd/freebsd.factor b/extra/unix/types/freebsd/freebsd.factor index 6e01ae9fd5..e012ebcbd6 100755 --- a/extra/unix/types/freebsd/freebsd.factor +++ b/extra/unix/types/freebsd/freebsd.factor @@ -4,8 +4,6 @@ IN: unix.types ! FreeBSD 7 x86.32 -! Need to verify on 64-bit - TYPEDEF: ushort __uint16_t TYPEDEF: uint __uint32_t TYPEDEF: int __int32_t @@ -21,6 +19,6 @@ TYPEDEF: __int64_t off_t TYPEDEF: __int64_t blkcnt_t TYPEDEF: __uint32_t blksize_t TYPEDEF: __uint32_t fflags_t -TYPEDEF: int ssize_t +TYPEDEF: long ssize_t TYPEDEF: int pid_t -TYPEDEF: int time_t \ No newline at end of file +TYPEDEF: int time_t diff --git a/extra/unix/types/openbsd/openbsd.factor b/extra/unix/types/openbsd/openbsd.factor index 5bdda212d8..a07e6f1c6a 100755 --- a/extra/unix/types/openbsd/openbsd.factor +++ b/extra/unix/types/openbsd/openbsd.factor @@ -27,6 +27,6 @@ TYPEDEF: __int64_t off_t TYPEDEF: __int64_t blkcnt_t TYPEDEF: __uint32_t blksize_t TYPEDEF: __uint32_t fflags_t -TYPEDEF: int ssize_t +TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t From 839ebfb3785287a46b4e90a34654dc490b877e1d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Jul 2008 19:11:38 -0500 Subject: [PATCH 08/42] fix encoding bug with text fields in sqlite --- extra/db/sqlite/lib/lib.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 4c440acc55..d14e975ae1 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -4,7 +4,8 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary -io.backend db.errors present urls ; +io.backend db.errors present urls io.encodings.utf8 +io.encodings.string ; IN: db.sqlite.lib ERROR: sqlite-error < db-error n string ; @@ -33,7 +34,7 @@ ERROR: sqlite-sql-error < sql-error n string ; sqlite3_close sqlite-check-result ; : sqlite-prepare ( db sql -- handle ) - dup length "void*" "void*" + utf8 encode dup length "void*" "void*" [ sqlite3_prepare_v2 sqlite-check-result ] 2keep drop *void* ; @@ -44,7 +45,7 @@ ERROR: sqlite-sql-error < sql-error n string ; >r dupd sqlite-bind-parameter-index r> ; : sqlite-bind-text ( handle index text -- ) - dup length SQLITE_TRANSIENT + utf8 encode dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ; : sqlite-bind-int ( handle i n -- ) From eba4b990af02ad7c77438d95e2deb5bcea0cd456 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Jul 2008 19:23:35 -0500 Subject: [PATCH 09/42] Fix stdin --- extra/io/unix/backend/backend.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index b984b1f156..aa27b21d98 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -159,9 +159,9 @@ M: unix io-multiplex ( ms/f -- ) ! pipe to non-blocking, and read from it instead of the real ! stdin. Very crufty, but it will suffice until we get native ! threading support at the language level. -TUPLE: stdin control size data ; +TUPLE: stdin control size data disposed ; -M: stdin dispose +M: stdin dispose* [ [ control>> &dispose drop ] [ size>> &dispose drop ] @@ -194,10 +194,10 @@ M: stdin refill : data-read-fd ( -- fd ) "stdin_read" f dlsym *uint ; : ( -- stdin ) - control-write-fd - size-read-fd init-fd - data-read-fd - stdin boa ; + stdin new + control-write-fd >>control + size-read-fd init-fd >>size + data-read-fd >>data ; M: unix (init-stdio) ( -- ) From 442bde22e581e01fb493070e66f976fc66892f80 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Jul 2008 19:25:24 -0500 Subject: [PATCH 10/42] New extra/tr/ vocab for fast translation of ASCII strings; improves reverse-complement performance by 11%; add soundex vocab which uses tr --- .../reverse-complement.factor | 22 ++++-------- extra/soundex/author.txt | 1 + extra/soundex/soundex-tests.factor | 4 +++ extra/soundex/soundex.factor | 33 +++++++++++++++++ extra/soundex/summary.txt | 1 + extra/tr/authors.txt | 1 + extra/tr/summary.txt | 1 + extra/tr/tr-tests.factor | 7 ++++ extra/tr/tr.factor | 35 +++++++++++++++++++ 9 files changed, 89 insertions(+), 16 deletions(-) create mode 100644 extra/soundex/author.txt create mode 100644 extra/soundex/soundex-tests.factor create mode 100644 extra/soundex/soundex.factor create mode 100644 extra/soundex/summary.txt create mode 100644 extra/tr/authors.txt create mode 100644 extra/tr/summary.txt create mode 100644 extra/tr/tr-tests.factor create mode 100644 extra/tr/tr.factor diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index b7c1db043c..665cbba30d 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,30 +1,20 @@ USING: io io.files io.streams.duplex kernel sequences sequences.private strings vectors words memoize splitting -grouping hints unicode.case continuations io.encodings.ascii ; +grouping hints tr continuations io.encodings.ascii +unicode.case ; IN: benchmark.reverse-complement -MEMO: trans-map ( -- str ) - 256 >string - "TGCAAKYRMBDHV" "ACGTUMRYKVHDB" - [ pick set-nth ] 2each ; - -: do-trans-map ( str -- ) - [ ch>upper trans-map nth ] change-each ; - -HINTS: do-trans-map string ; +TR: trans-map ch>upper "ACGTUMRYKVHDB" "TGCAAKYRMBDHV" ; : translate-seq ( seq -- str ) - concat dup reverse-here dup do-trans-map ; + concat dup reverse-here dup trans-map-fast ; : show-seq ( seq -- ) translate-seq 60 [ print ] each ; : do-line ( seq line -- seq ) - dup first ">;" memq? [ - over show-seq print dup delete-all - ] [ - over push - ] if ; + dup first ">;" memq? + [ over show-seq print dup delete-all ] [ over push ] if ; HINTS: do-line vector string ; diff --git a/extra/soundex/author.txt b/extra/soundex/author.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/soundex/author.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/soundex/soundex-tests.factor b/extra/soundex/soundex-tests.factor new file mode 100644 index 0000000000..df6338c4ec --- /dev/null +++ b/extra/soundex/soundex-tests.factor @@ -0,0 +1,4 @@ +IN: soundex.tests +USING: soundex tools.test ; + +[ "S162" ] [ "supercalifrag" soundex ] unit-test diff --git a/extra/soundex/soundex.factor b/extra/soundex/soundex.factor new file mode 100644 index 0000000000..c82825d814 --- /dev/null +++ b/extra/soundex/soundex.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences sequences.lib grouping assocs kernel ascii +unicode.case tr ; +IN: soundex + +TR: soundex-tr + ch>upper + "AEHIOUWYBFPVCGJKQSXZDTLMNR" + "00000000111122222222334556" ; + +: remove-duplicates ( seq -- seq' ) + #! Remove _consecutive_ duplicates (unlike prune which removes + #! all duplicates). + [ 2 [ = not ] assoc-filter values ] [ first ] bi prefix ; + +: first>upper ( seq -- seq' ) 1 head >upper ; +: trim-first ( seq -- seq' ) dup first [ = ] curry left-trim ; +: remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ; +: remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ; +: pad-4 ( first seq -- seq' ) "000" 3append 4 head ; + +: soundex ( string -- soundex ) + remove-non-alpha [ f ] [ + [ first>upper ] + [ + soundex-tr + trim-first + remove-duplicates + remove-zeroes + ] bi + pad-4 + ] if-empty ; diff --git a/extra/soundex/summary.txt b/extra/soundex/summary.txt new file mode 100644 index 0000000000..95a271d911 --- /dev/null +++ b/extra/soundex/summary.txt @@ -0,0 +1 @@ +Soundex is a phonetic algorithm for indexing names by sound diff --git a/extra/tr/authors.txt b/extra/tr/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tr/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tr/summary.txt b/extra/tr/summary.txt new file mode 100644 index 0000000000..8678446951 --- /dev/null +++ b/extra/tr/summary.txt @@ -0,0 +1 @@ +Fast character-to-character translation of ASCII strings diff --git a/extra/tr/tr-tests.factor b/extra/tr/tr-tests.factor new file mode 100644 index 0000000000..1eea69ba07 --- /dev/null +++ b/extra/tr/tr-tests.factor @@ -0,0 +1,7 @@ +IN: tr.tests +USING: tr tools.test unicode.case ; + +TR: tr-test ch>upper "ABC" "XYZ" ; + +[ "XXYY" ] [ "aabb" tr-test ] unit-test +[ "XXYY" ] [ "AABB" tr-test ] unit-test diff --git a/extra/tr/tr.factor b/extra/tr/tr.factor new file mode 100644 index 0000000000..a95d308d36 --- /dev/null +++ b/extra/tr/tr.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: byte-arrays strings sequences sequences.private +fry kernel words parser lexer assocs ; +IN: tr + + + +: TR: + scan parse-definition + unclip-last [ unclip-last ] dip compute-tr + [ [ create-tr ] dip define-tr ] + [ [ "-fast" append create-tr ] dip define-fast-tr ] 2bi ; + parsing From 34c0cf61113ee18a774b48d599048210fb69e215 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Jul 2008 19:43:46 -0500 Subject: [PATCH 11/42] Use tr instead of substitute in a few places --- extra/io/windows/nt/files/files.factor | 6 ++++-- extra/json/writer/writer.factor | 7 ++----- extra/sequences/lib/lib.factor | 3 --- extra/tools/disassembler/disassembler.factor | 5 ++--- extra/tools/vocabs/monitor/monitor.factor | 10 +++++++--- extra/ui/commands/commands.factor | 6 ++++-- extra/unicode/data/data.factor | 2 +- 7 files changed, 20 insertions(+), 19 deletions(-) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 2a39cea479..6a890f6392 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -4,7 +4,7 @@ io.windows.nt.backend windows windows.kernel32 kernel libc math threads system alien.c-types alien.arrays alien.strings sequences combinators combinators.short-circuit ascii splitting alien strings -assocs namespaces io.files.private accessors ; +assocs namespaces io.files.private accessors tr ; IN: io.windows.nt.files M: winnt cwd @@ -40,9 +40,11 @@ ERROR: not-absolute-path ; unicode-prefix prepend ] unless ; +TR: normalize-separators "/" "\\" ; + M: winnt normalize-path ( string -- string' ) (normalize-path) - { { CHAR: / CHAR: \\ } } substitute + normalize-separators prepend-prefix ; M: winnt CreateFile-flags ( DWORD -- DWORD ) diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor index a68c65087e..0d22494b13 100644 --- a/extra/json/writer/writer.factor +++ b/extra/json/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.streams.string io strings splitting sequences math math.parser assocs classes words namespaces prettyprint - hashtables mirrors ; + hashtables mirrors tr ; IN: json.writer #! Writes the object out to a stream in JSON format @@ -24,10 +24,7 @@ M: number json-print ( num -- ) M: sequence json-print ( array -- ) CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ; -: jsvar-encode ( string -- string ) - #! Convert the string so that it contains characters usable within - #! javascript variable names. - { { CHAR: - CHAR: _ } } substitute ; +TR: jsvar-encode "-" "_" ; : tuple>fields ( object -- seq ) [ diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 90bca7cef9..0049320b94 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -210,9 +210,6 @@ PRIVATE> : nths ( seq indices -- seq' ) swap [ nth ] curry map ; -: replace ( str oldseq newseq -- str' ) - zip >hashtable substitute ; - : remove-nth ( seq n -- seq' ) cut-slice rest-slice append ; diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index a7d9da4840..4a345e2345 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -3,7 +3,7 @@ USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified system math generator.fixup io.encodings.ascii accessors -generic ; +generic tr ; IN: tools.disassembler : in-file ( -- path ) "gdb-in.txt" temp-file ; @@ -36,8 +36,7 @@ M: method-spec make-disassemble-cmd try-process out-file ascii file-lines ; -: tabs>spaces ( str -- str' ) - { { CHAR: \t CHAR: \s } } substitute ; +TR: tabs>spaces "\t" "\s" ; : disassemble ( obj -- ) make-disassemble-cmd run-gdb diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index ee5198a8f4..12b2e41d36 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -2,12 +2,16 @@ ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel vocabs vocabs.loader tools.vocabs namespaces continuations -sequences splitting assocs command-line concurrency.messaging io.backend sets ; +sequences splitting assocs command-line concurrency.messaging +io.backend sets tr ; IN: tools.vocabs.monitor +TR: convert-separators "/\\" ".." ; + : vocab-dir>vocab-name ( path -- vocab ) - left-trim-separators right-trim-separators - { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ; + left-trim-separators + right-trim-separators + convert-separators ; : path>vocab-name ( path -- vocab ) dup ".factor" tail? [ parent-directory ] when ; diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor index 6a5a4d2c42..39eed24ada 100755 --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel sequences strings math assocs words generic namespaces assocs quotations splitting -ui.gestures unicode.case unicode.categories ; +ui.gestures unicode.case unicode.categories tr ; IN: ui.commands SYMBOL: +nullary+ @@ -50,8 +50,10 @@ GENERIC: command-word ( command -- word ) swap pick commands set-at update-gestures ; +TR: convert-command-name "-" " " ; + : (command-name) ( string -- newstring ) - { { CHAR: - CHAR: \s } } substitute >title ; + convert-command-name >title ; M: word command-name ( word -- str ) name>> diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index f74e2e0473..fdcf495307 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -125,7 +125,7 @@ VALUE: properties : process-names ( data -- names-hash ) 1 swap (process-data) [ ascii-lower { { CHAR: \s CHAR: - } } substitute swap - ] assoc-map >hashtable ; + ] H{ } assoc-map-as ; : multihex ( hexstring -- string ) " " split [ hex> ] map sift ; From bf47ff4007801c5a47ee1ce0ed78d48cab5277c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Jul 2008 19:48:40 -0500 Subject: [PATCH 12/42] Working on conversation scope to supercede asides and flash scopes --- extra/furnace/actions/actions.factor | 11 +- extra/furnace/auth/auth.factor | 4 +- extra/furnace/auth/login/login.factor | 2 +- .../conversations/conversations.factor | 151 ++++++++++++++++++ extra/furnace/scopes/scopes.factor | 42 +++++ extra/furnace/sessions/sessions.factor | 37 +---- 6 files changed, 209 insertions(+), 38 deletions(-) create mode 100644 extra/furnace/conversations/conversations.factor create mode 100644 extra/furnace/scopes/scopes.factor diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 6448fcdf07..ad8a36cca5 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -75,12 +75,11 @@ TUPLE: action rest authorize init display validate submit ; revalidate-url-key param dup [ >url [ same-host? ] keep and ] when ; -: validation-failed ( -- * ) - post-request? revalidate-url and - [ +: validation-failed ( flashed -- * ) + post-request? revalidate-url and dup [ nested-forms-key param " " split harvest nested-forms set - { form nested-forms } - ] [ <400> ] if* + swap { form nested-forms } append + ] [ 2drop <400> ] if exit-with ; : handle-post ( action -- response ) @@ -113,7 +112,7 @@ M: action modify-form drop url get revalidate-url-key hidden-form-field ; : check-validation ( -- ) - validation-failed? [ validation-failed ] when ; + validation-failed? [ { } validation-failed ] when ; : validate-params ( validators -- ) params get swap validate-values check-validation ; diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index 0c21c9f18d..4fae10c30d 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -152,7 +152,7 @@ M: protected call-responder* ( path responder -- response ) : password-mismatch ( -- * ) "passwords do not match" validation-error - validation-failed ; + { } validation-failed ; : same-password-twice ( -- ) "new-password" value "verify-password" value = @@ -160,4 +160,4 @@ M: protected call-responder* ( path responder -- response ) : user-exists ( -- * ) "username taken" validation-error - validation-failed ; + { } validation-failed ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 9246780a94..f2ac81c066 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -65,7 +65,7 @@ SYMBOL: capabilities : login-failed ( -- * ) "invalid username or password" validation-error - validation-failed ; + flashed-variables validation-failed ; : ( -- action ) diff --git a/extra/furnace/conversations/conversations.factor b/extra/furnace/conversations/conversations.factor new file mode 100644 index 0000000000..cbc4e4b233 --- /dev/null +++ b/extra/furnace/conversations/conversations.factor @@ -0,0 +1,151 @@ +! 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.scopes +furnace.sessions +furnace.redirection ; +IN: furnace.conversations + +TUPLE: conversation < scope +session +method url post-data ; + +: ( id -- aside ) + 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 "__f" ; + +TUPLE: conversations < server-state-manager ; + +: ( responder -- responder' ) + conversations new-server-state-manager ; + +SYMBOL: conversation + +SYMBOL: conversation-id + +: cget ( key -- value ) + conversation get scope-get ; + +: cset ( value key -- ) + conversation get scope-set ; + +: cchange ( key quot -- ) + conversation get scope-change ; inline + +: get-conversation ( id -- conversation ) + dup [ conversation get-state ] when + dup [ dup session>> session get id>> = [ drop f ] unless ] when ; + +: request-conversation-id ( request -- id ) + conversation-id-key swap request-params at string>number ; + +: request-conversation ( request -- conversation ) + request-conversation-id get-conversation ; + +: init-conversations ( -- ) + request get request-conversation-id + [ conversation-id set ] + [ get-conversation conversation set ] + bi ; + +M: conversations call-responder* + init-conversations + [ conversations set ] [ call-next-method ] bi ; + +: empty-conversastion ( -- conversation ) + conversation empty-scope + session get id>> >>session ; + +: add-conversation ( conversation -- id ) + [ conversations get touch-state ] [ insert-tuple ] [ id>> ] tri ; + +: begin-conversation* ( -- id ) + empty-conversastion add-conversation ; + +: begin-conversation ( -- ) + conversation-id [ [ begin-conversation* ] unless* ] change ; + +: ( url seq -- response ) + begin-conversation + [ [ get ] keep cset ] each + ; + +: restore-conversation ( seq -- ) + conversation get dup [ + namespace>> + [ '[ , key? ] filter ] + [ '[ [ , at ] keep set ] each ] + bi + ] [ 2drop ] if ; + +: begin-aside* ( -- id ) + empty-conversastion + request get + [ method>> >>method ] + [ url>> >>url ] + [ post-data>> >>post-data ] + tri + add-conversation ; + +: begin-aside ( -- ) + begin-aside* conversation-id set ; + +: end-aside-post ( aside -- response ) + request [ + clone + over post-data>> >>post-data + over url>> >>url + ] change + url>> path>> split-path + conversations get responder>> call-responder ; + +\ end-aside-post DEBUG add-input-logging + +ERROR: end-aside-in-get-error ; + +: end-aside* ( url id -- response ) + post-request? [ end-aside-in-get-error ] unless + get-conversation [ + dup method>> { + { "GET" [ url>> ] } + { "HEAD" [ url>> ] } + { "POST" [ end-aside-post ] } + } case + ] [ ] ?if ; + +: end-aside ( default -- response ) + conversation-id [ f ] change 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 + conversation-id-key + hidden-form-field ; diff --git a/extra/furnace/scopes/scopes.factor b/extra/furnace/scopes/scopes.factor new file mode 100644 index 0000000000..daad0dcf91 --- /dev/null +++ b/extra/furnace/scopes/scopes.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors assocs destructors +db.tuples db.types furnace.cache ; +IN: furnace.scopes + +TUPLE: scope < server-state namespace changed? ; + +: empty-scope ( class -- scope ) + f swap new-server-state + H{ } clone >>namespace ; inline + +scope f +{ + { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ } +} define-persistent + +: scope-changed ( scope -- ) + t >>changed? drop ; + +: scope-get ( key scope -- value ) + dup [ namespace>> at ] [ 2drop f ] if ; + +: scope-set ( value key scope -- ) + [ namespace>> set-at ] [ scope-changed ] bi ; + +: scope-change ( key quot scope -- ) + [ namespace>> swap change-at ] [ scope-changed ] bi ; inline + +! Destructor +TUPLE: scope-saver scope manager ; + +C: scope-saver + +M: scope-saver dispose + [ manager>> ] [ scope>> ] bi + dup changed?>> [ + [ swap touch-state ] [ update-tuple ] bi + ] [ 2drop ] if ; + +: save-scope-after ( scope manager -- ) + &dispose drop ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 31711f54e9..3aafadaf68 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -7,17 +7,16 @@ io.servers.connection db db.tuples db.types http http.server http.server.dispatchers http.server.filters html.elements -furnace furnace.cache ; +furnace furnace.cache furnace.scopes ; IN: furnace.sessions -TUPLE: session < server-state namespace user-agent client changed? ; +TUPLE: session < scope user-agent client ; : ( id -- session ) session new-server-state ; session "SESSIONS" { - { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ } { "user-agent" "USER_AGENT" TEXT +not-null+ } { "client" "CLIENT" TEXT +not-null+ } } define-persistent @@ -39,23 +38,14 @@ TUPLE: sessions < server-state-manager domain verify? ; sessions new-server-state-manager t >>verify? ; -: (session-changed) ( session -- ) - t >>changed? drop ; - : session-changed ( -- ) - session get (session-changed) ; + session get scope-changed ; -: sget ( key -- value ) - session get namespace>> at ; +: sget ( key -- value ) session get scope-get ; -: sset ( value key -- ) - session get - [ namespace>> set-at ] [ (session-changed) ] bi ; +: sset ( value key -- ) session get scope-set ; -: schange ( key quot -- ) - session get - [ namespace>> swap change-at ] keep - (session-changed) ; inline +: schange ( key quot -- ) session get scope-change ; inline : init-session ( session -- ) session [ sessions get init-session* ] with-variable ; @@ -70,8 +60,7 @@ TUPLE: sessions < server-state-manager domain verify? ; } 0|| ; : empty-session ( -- session ) - f - H{ } clone >>namespace + session empty-scope remote-host >>client user-agent >>user-agent dup touch-session ; @@ -79,18 +68,8 @@ TUPLE: sessions < server-state-manager domain verify? ; : begin-session ( -- session ) empty-session [ init-session ] [ insert-tuple ] [ ] tri ; -! Destructor -TUPLE: session-saver session ; - -C: session-saver - -M: session-saver dispose - session>> dup changed?>> [ - [ touch-session ] [ update-tuple ] bi - ] [ drop ] if ; - : save-session-after ( session -- ) - &dispose drop ; + sessions get &dispose drop ; : existing-session ( path session -- response ) [ session set ] [ save-session-after ] bi From e58f41da407daa31fafcd23c5d9243b1dfd9c991 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Jul 2008 20:42:59 -0500 Subject: [PATCH 13/42] Fix tr for chars > 255 --- extra/tr/tr-tests.factor | 1 + extra/tr/tr.factor | 16 +++++++++------- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/extra/tr/tr-tests.factor b/extra/tr/tr-tests.factor index 1eea69ba07..c168f5384d 100644 --- a/extra/tr/tr-tests.factor +++ b/extra/tr/tr-tests.factor @@ -5,3 +5,4 @@ TR: tr-test ch>upper "ABC" "XYZ" ; [ "XXYY" ] [ "aabb" tr-test ] unit-test [ "XXYY" ] [ "AABB" tr-test ] unit-test +[ { 12345 } ] [ { 12345 } tr-test ] unit-test diff --git a/extra/tr/tr.factor b/extra/tr/tr.factor index a95d308d36..b5ad2ba430 100644 --- a/extra/tr/tr.factor +++ b/extra/tr/tr.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays strings sequences sequences.private -fry kernel words parser lexer assocs ; +fry kernel words parser lexer assocs math.order ; IN: tr From 37ade561a95a7bf10883336b5c6b9fd11acf9236 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 25 Jun 2008 12:29:16 +1200 Subject: [PATCH 14/42] Fix unary expression in js grammar --- extra/peg/javascript/parser/parser.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor index b7df9908da..002804dcd8 100644 --- a/extra/peg/javascript/parser/parser.factor +++ b/extra/peg/javascript/parser/parser.factor @@ -64,14 +64,14 @@ MulExpr = MulExpr:x "*" Unary:y => [[ x y "*" ast-binop | MulExpr:x "/" Unary:y => [[ x y "/" ast-binop boa ]] | MulExpr:x "%" Unary:y => [[ x y "%" ast-binop boa ]] | Unary -Unary = "-" Postfix:p => [[ p "-" ast-unop boa ]] - | "+" Postfix:p => [[ p ]] - | "++" Postfix:p => [[ p "++" ast-preop boa ]] - | "--" Postfix:p => [[ p "--" ast-preop boa ]] - | "!" Postfix:p => [[ p "!" ast-unop boa ]] - | "typeof" Postfix:p => [[ p "typeof" ast-unop boa ]] - | "void" Postfix:p => [[ p "void" ast-unop boa ]] - | "delete" Postfix:p => [[ p "delete" ast-unop boa ]] +Unary = "-" Unary:p => [[ p "-" ast-unop boa ]] + | "+" Unary:p => [[ p ]] + | "++" Unary:p => [[ p "++" ast-preop boa ]] + | "--" Unary:p => [[ p "--" ast-preop boa ]] + | "!" Unary:p => [[ p "!" ast-unop boa ]] + | "typeof" Unary:p => [[ p "typeof" ast-unop boa ]] + | "void" Unary:p => [[ p "void" ast-unop boa ]] + | "delete" Unary:p => [[ p "delete" ast-unop boa ]] | Postfix Postfix = PrimExpr:p SpacesNoNl "++" => [[ p "++" ast-postop boa ]] | PrimExpr:p SpacesNoNl "--" => [[ p "--" ast-postop boa ]] From 00827d3b12bcca1f7e7706914592da5cc4d4202a Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 25 Jun 2008 13:14:15 +1200 Subject: [PATCH 15/42] Throw error on failed parse, returning relevant error information --- extra/peg/peg.factor | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 54c25778de..0d0d8ed72c 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -9,20 +9,31 @@ IN: peg USE: prettyprint TUPLE: parse-result remaining ast ; - +TUPLE: parse-error details ; +TUPLE: error-details remaining message ; TUPLE: parser id compiled ; - M: parser equal? [ id>> ] bi@ = ; M: parser hashcode* id>> hashcode* ; -C: parser +C: parse-result +C: error-details +C: parser +SYMBOL: errors + +: ( -- parse-error ) + V{ } clone parse-error boa ; + +: add-error ( remaining message -- ) + errors get [ + [ ] [ details>> ] bi* push + ] [ + 2drop + ] if* ; + SYMBOL: ignore -: ( remaining ast -- parse-result ) - parse-result boa ; - SYMBOL: packrat SYMBOL: pos SYMBOL: input @@ -207,6 +218,7 @@ C: peg-head input set 0 pos set f lrstack set + errors set H{ } clone heads set H{ } clone packrat set ] H{ } make-assoc swap bind ; inline @@ -257,7 +269,7 @@ SYMBOL: delayed ] with-compilation-unit ; : compiled-parse ( state word -- result ) - swap [ execute ] with-packrat ; inline + swap [ execute [ errors get throw ] unless* ] with-packrat ; inline : parse ( input parser -- result ) dup word? [ compile ] unless compiled-parse ; @@ -288,7 +300,7 @@ TUPLE: token-parser symbol ; dup >r ?head-slice [ r> ] [ - r> 2drop f + drop input-slice "Expected token '" r> append "'" append add-error f ] if ; M: token-parser (compile) ( parser -- quot ) From e14bb84a5a7fe860c3550bf7de9427917914e875 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 25 Jun 2008 19:37:58 +1200 Subject: [PATCH 16/42] More error handling for pegs --- extra/peg/peg.factor | 51 +++++++++++++++++++++++++++----------------- 1 file changed, 32 insertions(+), 19 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 0d0d8ed72c..a0f5fc05e8 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,36 +1,47 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces math assocs shuffle debugger io - vectors arrays math.parser math.order - unicode.categories compiler.units parser + vectors arrays math.parser math.order vectors combinators combinators.lib + sets unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting ; IN: peg USE: prettyprint TUPLE: parse-result remaining ast ; -TUPLE: parse-error details ; -TUPLE: error-details remaining message ; +TUPLE: parse-error position messages ; TUPLE: parser id compiled ; M: parser equal? [ id>> ] bi@ = ; M: parser hashcode* id>> hashcode* ; C: parse-result -C: error-details +C: parse-error C: parser -SYMBOL: errors +SYMBOL: error-stack -: ( -- parse-error ) - V{ } clone parse-error boa ; +: (merge-errors) ( a b -- c ) + { + { [ over position>> not ] [ nip ] } + { [ dup position>> not ] [ drop ] } + [ 2dup [ position>> ] bi@ <=> { + { +lt+ [ nip ] } + { +gt+ [ drop ] } + { +eq+ [ messages>> over messages>> union [ position>> ] dip ] } + } case + ] + } cond ; + +: merge-errors ( -- ) + error-stack get dup length 1 > [ + dup pop over pop swap (merge-errors) swap push + ] [ + drop + ] if ; : add-error ( remaining message -- ) - errors get [ - [ ] [ details>> ] bi* push - ] [ - 2drop - ] if* ; + error-stack get push ; SYMBOL: ignore @@ -218,7 +229,7 @@ C: peg-head input set 0 pos set f lrstack set - errors set + V{ } clone error-stack set H{ } clone heads set H{ } clone packrat set ] H{ } make-assoc swap bind ; inline @@ -269,7 +280,7 @@ SYMBOL: delayed ] with-compilation-unit ; : compiled-parse ( state word -- result ) - swap [ execute [ errors get throw ] unless* ] with-packrat ; inline + swap [ execute [ error-stack get throw ] unless* ] with-packrat ; inline : parse ( input parser -- result ) dup word? [ compile ] unless compiled-parse ; @@ -298,9 +309,9 @@ TUPLE: token-parser symbol ; : parse-token ( input string -- result ) #! Parse the string, returning a parse result dup >r ?head-slice [ - r> + r> f f add-error ] [ - drop input-slice "Expected token '" r> append "'" append add-error f + drop input-slice input-from "Expected token '" r> append "'" append 1vector add-error f ] if ; M: token-parser (compile) ( parser -- quot ) @@ -366,7 +377,8 @@ TUPLE: seq-parser parsers ; M: seq-parser (compile) ( parser -- quot ) [ [ input-slice V{ } clone ] % - parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each + parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [ + compiled-parser 1quotation [ merge-errors ] compose , \ parse-seq-element , ] each ] [ ] make ; TUPLE: choice-parser parsers ; @@ -374,7 +386,8 @@ TUPLE: choice-parser parsers ; M: choice-parser (compile) ( parser -- quot ) [ f , - parsers>> [ compiled-parser 1quotation , \ unless* , ] each + parsers>> [ compiled-parser ] map + unclip 1quotation , \ unless* , [ 1quotation [ merge-errors ] compose , \ unless* , ] each ] [ ] make ; TUPLE: repeat0-parser p1 ; From 9c96edb805ecd81cc0c2c60f93aa918f739940e6 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 30 Jun 2008 11:29:57 +1200 Subject: [PATCH 17/42] Fix 'For' statement in JavaScript parser --- extra/peg/javascript/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor index 002804dcd8..de6e2bae32 100644 --- a/extra/peg/javascript/parser/parser.factor +++ b/extra/peg/javascript/parser/parser.factor @@ -105,7 +105,7 @@ Binding = Name:n "=" Expr:v => [[ n v ast-var | Name:n => [[ n "undefined" ast-get boa ast-var boa ]] Block = "{" SrcElems:ss "}" => [[ ss ]] Bindings = (Binding ("," Binding => [[ second ]])* => [[ first2 swap prefix ]])? -For1 = "var" Binding => [[ second ]] +For1 = "var" Bindings => [[ second ]] | Expr | Spaces => [[ "undefined" ast-get boa ]] For2 = Expr From cf00bc8a0c0d5e3d211e81a099a57ba3374cabac Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 30 Jun 2008 11:54:47 +1200 Subject: [PATCH 18/42] Add flags to regexp tokenizer in JavaScript --- extra/peg/javascript/ast/ast.factor | 2 +- extra/peg/javascript/parser/parser.factor | 12 ++++++------ extra/peg/javascript/tokenizer/tokenizer.factor | 3 ++- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/peg/javascript/ast/ast.factor b/extra/peg/javascript/ast/ast.factor index b857dc51bb..47ab6da864 100644 --- a/extra/peg/javascript/ast/ast.factor +++ b/extra/peg/javascript/ast/ast.factor @@ -7,7 +7,7 @@ TUPLE: ast-keyword value ; TUPLE: ast-name value ; TUPLE: ast-number value ; TUPLE: ast-string value ; -TUPLE: ast-regexp value ; +TUPLE: ast-regexp body flags ; TUPLE: ast-cond-expr condition then else ; TUPLE: ast-set lhs rhs ; TUPLE: ast-get value ; diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor index de6e2bae32..41387d0a5c 100644 --- a/extra/peg/javascript/parser/parser.factor +++ b/extra/peg/javascript/parser/parser.factor @@ -26,9 +26,9 @@ End = !(.) Space = " " | "\t" | "\n" Spaces = Space* => [[ ignore ]] Name = . ?[ ast-name? ]? => [[ value>> ]] -Number = . ?[ ast-number? ]? => [[ value>> ]] -String = . ?[ ast-string? ]? => [[ value>> ]] -RegExp = . ?[ ast-regexp? ]? => [[ value>> ]] +Number = . ?[ ast-number? ]? +String = . ?[ ast-string? ]? +RegExp = . ?[ ast-regexp? ]? SpacesNoNl = (!(nl) Space)* => [[ ignore ]] Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-expr boa ]] @@ -85,9 +85,9 @@ PrimExpr = PrimExpr:p "[" Expr:i "]" => [[ i p ast-getp PrimExprHd = "(" Expr:e ")" => [[ e ]] | "this" => [[ ast-this boa ]] | Name => [[ ast-get boa ]] - | Number => [[ ast-number boa ]] - | String => [[ ast-string boa ]] - | RegExp => [[ ast-regexp boa ]] + | Number + | String + | RegExp | "function" FuncRest:fr => [[ fr ]] | "new" PrimExpr:n "(" Args:as ")" => [[ n as ast-new boa ]] | "new" PrimExpr:n => [[ n f ast-new boa ]] diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor index 195184a16c..825c8f03d1 100644 --- a/extra/peg/javascript/tokenizer/tokenizer.factor +++ b/extra/peg/javascript/tokenizer/tokenizer.factor @@ -57,8 +57,9 @@ StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]] Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]] | '"' StringChars2:cs '"' => [[ cs ast-string boa ]] | "'" StringChars3:cs "'" => [[ cs ast-string boa ]] +RegExpFlags = NameRest* RegExpBody = (!("/" | "\n" | "\r") .)* => [[ >string ]] -RegExp = "/" RegExpBody:r "/" => [[ r ast-regexp boa ]] +RegExp = "/" RegExpBody:b "/" RegExpFlags:fl => [[ b fl ast-regexp boa ]] Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";" | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">=" | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-=" From acb6d3a312dff4450f37a4ffafc1132010a92578 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 30 Jun 2008 14:32:20 +1200 Subject: [PATCH 19/42] Fix peg.ebnf tests. Handle \ in EBNF --- extra/peg/ebnf/ebnf-tests.factor | 60 ++++++++++--------- extra/peg/ebnf/ebnf.factor | 1 + .../peg/javascript/tokenizer/tokenizer.factor | 9 ++- 3 files changed, 41 insertions(+), 29 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 2269af6625..a2807d20db 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -132,21 +132,21 @@ IN: peg.ebnf.tests "Z" [EBNF foo=[A-Z] EBNF] call ast>> ] unit-test -{ f } [ +[ "0" [EBNF foo=[A-Z] EBNF] call -] unit-test +] must-fail { CHAR: 0 } [ "0" [EBNF foo=[^A-Z] EBNF] call ast>> ] unit-test -{ f } [ +[ "A" [EBNF foo=[^A-Z] EBNF] call -] unit-test +] must-fail -{ f } [ +[ "Z" [EBNF foo=[^A-Z] EBNF] call -] unit-test +] must-fail { V{ "1" "+" "foo" } } [ "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call ast>> @@ -176,17 +176,17 @@ IN: peg.ebnf.tests { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>> ] unit-test -{ f } [ +[ { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call -] unit-test +] must-fail { 3 } [ { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>> ] unit-test -{ f } [ +[ "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call -] unit-test +] must-fail { V{ "a" " " "b" } } [ "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>> @@ -229,9 +229,9 @@ IN: peg.ebnf.tests "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>> ] unit-test -{ f } [ +[ "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call -] unit-test +] must-fail { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. @@ -314,41 +314,41 @@ main = Primary "abc" [EBNF a="a" "b" foo=a "c" EBNF] call ast>> ] unit-test -{ f } [ +[ "a bc" [EBNF a="a" "b" foo=(a "c") EBNF] call -] unit-test +] must-fail -{ f } [ +[ "a bc" [EBNF a="a" "b" foo=a "c" EBNF] call -] unit-test +] must-fail -{ f } [ +[ "a bc" [EBNF a="a" "b" foo={a "c"} EBNF] call -] unit-test +] must-fail -{ f } [ +[ "ab c" [EBNF a="a" "b" foo=a "c" EBNF] call -] unit-test +] must-fail { V{ V{ "a" "b" } "c" } } [ "ab c" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>> ] unit-test -{ f } [ +[ "ab c" [EBNF a="a" "b" foo=(a "c") EBNF] call -] unit-test +] must-fail -{ f } [ +[ "a b c" [EBNF a="a" "b" foo=a "c" EBNF] call -] unit-test +] must-fail -{ f } [ +[ "a b c" [EBNF a="a" "b" foo=(a "c") EBNF] call -] unit-test +] must-fail -{ f } [ +[ "a b c" [EBNF a="a" "b" foo={a "c"} EBNF] call -] unit-test +] must-fail { V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [ "ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>> @@ -515,4 +515,8 @@ Tok = Spaces (Number | Special ) { "++" } [ "++--" [EBNF tokenizer=("++" | "--") main="++" EBNF] call ast>> +] unit-test + +{ "\\" } [ + "\\" [EBNF foo="\\" EBNF] call ast>> ] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 3d48665c8c..610cffd273 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -99,6 +99,7 @@ PEG: escaper ( string -- ast ) "\\t" token [ drop "\t" ] action , "\\n" token [ drop "\n" ] action , "\\r" token [ drop "\r" ] action , + "\\\\" token [ drop "\\" ] action , ] choice* any-char-parser 2array choice repeat0 ; : replace-escapes ( string -- string ) diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor index 825c8f03d1..256e478571 100644 --- a/extra/peg/javascript/tokenizer/tokenizer.factor +++ b/extra/peg/javascript/tokenizer/tokenizer.factor @@ -58,7 +58,14 @@ Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]] | '"' StringChars2:cs '"' => [[ cs ast-string boa ]] | "'" StringChars3:cs "'" => [[ cs ast-string boa ]] RegExpFlags = NameRest* -RegExpBody = (!("/" | "\n" | "\r") .)* => [[ >string ]] +NonTerminator = !("\n" | "\r") . +BackslashSequence = "\\" NonTerminator +RegExpFirstChar = !("*" | "\\" | "/") NonTerminator + | BackslashSequence +RegExpChar = !("\\" | "/") NonTerminator + | BackslashSequence +RegExpChars = RegExpChar* +RegExpBody = RegExpFirstChar RegExpChars RegExp = "/" RegExpBody:b "/" RegExpFlags:fl => [[ b fl ast-regexp boa ]] Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";" | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">=" From 4394cb08f69896f86b0712931610b6465d9c9b58 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 30 Jun 2008 15:20:12 +1200 Subject: [PATCH 20/42] RegExp fix for javascript tokenizer --- extra/peg/javascript/tokenizer/tokenizer-tests.factor | 4 ++++ extra/peg/javascript/tokenizer/tokenizer.factor | 6 +++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/extra/peg/javascript/tokenizer/tokenizer-tests.factor b/extra/peg/javascript/tokenizer/tokenizer-tests.factor index 509ff4a0fe..a61125d08c 100644 --- a/extra/peg/javascript/tokenizer/tokenizer-tests.factor +++ b/extra/peg/javascript/tokenizer/tokenizer-tests.factor @@ -21,3 +21,7 @@ IN: peg.javascript.tokenizer.tests } [ "123; 'hello'; foo(x);" tokenize-javascript ast>> ] unit-test + +{ V{ T{ ast-regexp f "<(w+)[^>]*?)/>" "g" } } } [ + "/<(\\w+)[^>]*?)\\/>/g" tokenize-javascript ast>> +] unit-test \ No newline at end of file diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor index 256e478571..f65b0b2ad6 100644 --- a/extra/peg/javascript/tokenizer/tokenizer.factor +++ b/extra/peg/javascript/tokenizer/tokenizer.factor @@ -57,15 +57,15 @@ StringChars3 = (EscapeChar | !("'") .)* => [[ >string ]] Str = '"""' StringChars1:cs '"""' => [[ cs ast-string boa ]] | '"' StringChars2:cs '"' => [[ cs ast-string boa ]] | "'" StringChars3:cs "'" => [[ cs ast-string boa ]] -RegExpFlags = NameRest* +RegExpFlags = NameRest* => [[ >string ]] NonTerminator = !("\n" | "\r") . -BackslashSequence = "\\" NonTerminator +BackslashSequence = "\\" NonTerminator => [[ second ]] RegExpFirstChar = !("*" | "\\" | "/") NonTerminator | BackslashSequence RegExpChar = !("\\" | "/") NonTerminator | BackslashSequence RegExpChars = RegExpChar* -RegExpBody = RegExpFirstChar RegExpChars +RegExpBody = RegExpFirstChar RegExpChars => [[ first2 swap prefix >string ]] RegExp = "/" RegExpBody:b "/" RegExpFlags:fl => [[ b fl ast-regexp boa ]] Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";" | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">=" From 7404c5dc01026b19b1f69bf7d8e4181758cdfc20 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 30 Jun 2008 16:04:57 +1200 Subject: [PATCH 21/42] Add ShiftExpr to JavaScript parser --- extra/peg/javascript/parser/parser.factor | 14 +++++++++----- extra/peg/javascript/tokenizer/tokenizer.factor | 6 +++--- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor index 41387d0a5c..e491c35d2b 100644 --- a/extra/peg/javascript/parser/parser.factor +++ b/extra/peg/javascript/parser/parser.factor @@ -51,11 +51,15 @@ EqExpr = EqExpr:x "==" RelExpr:y => [[ x y "==" ast-binop | EqExpr:x "===" RelExpr:y => [[ x y "===" ast-binop boa ]] | EqExpr:x "!==" RelExpr:y => [[ x y "!==" ast-binop boa ]] | RelExpr -RelExpr = RelExpr:x ">" AddExpr:y => [[ x y ">" ast-binop boa ]] - | RelExpr:x ">=" AddExpr:y => [[ x y ">=" ast-binop boa ]] - | RelExpr:x "<" AddExpr:y => [[ x y "<" ast-binop boa ]] - | RelExpr:x "<=" AddExpr:y => [[ x y "<=" ast-binop boa ]] - | RelExpr:x "instanceof" AddExpr:y => [[ x y "instanceof" ast-binop boa ]] +RelExpr = RelExpr:x ">" ShiftExpr:y => [[ x y ">" ast-binop boa ]] + | RelExpr:x ">=" ShiftExpr:y => [[ x y ">=" ast-binop boa ]] + | RelExpr:x "<" ShiftExpr:y => [[ x y "<" ast-binop boa ]] + | RelExpr:x "<=" ShiftExpr:y => [[ x y "<=" ast-binop boa ]] + | RelExpr:x "instanceof" ShiftExpr:y => [[ x y "instanceof" ast-binop boa ]] + | ShiftExpr +ShiftExpr = ShiftExpr:x "<<" AddExpr:y => [[ x y "<<" ast-binop boa ]] + | ShiftExpr:x ">>>" AddExpr:y => [[ x y ">>>" ast-binop boa ]] + | ShiftExpr:x ">>" AddExpr:y => [[ x y ">>" ast-binop boa ]] | AddExpr AddExpr = AddExpr:x "+" MulExpr:y => [[ x y "+" ast-binop boa ]] | AddExpr:x "-" MulExpr:y => [[ x y "-" ast-binop boa ]] diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor index f65b0b2ad6..0698c8427e 100644 --- a/extra/peg/javascript/tokenizer/tokenizer.factor +++ b/extra/peg/javascript/tokenizer/tokenizer.factor @@ -69,9 +69,9 @@ RegExpBody = RegExpFirstChar RegExpChars => [[ first2 swap prefix >strin RegExp = "/" RegExpBody:b "/" RegExpFlags:fl => [[ b fl ast-regexp boa ]] Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";" | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">=" - | ">" | "<=" | "<" | "++" | "+=" | "+" | "--" | "-=" - | "-" | "*=" | "*" | "/=" | "/" | "%=" | "%" | "&&=" - | "&&" | "||=" | "||" | "." | "!" + | ">>>" | ">>" | ">" | "<=" | "<<" | "<" | "++" | "+=" + | "+" | "--" | "-=" | "-" | "*=" | "*" | "/=" | "/" + | "%=" | "%" | "&&=" | "&&" | "||=" | "||" | "." | "!" Tok = Spaces (Name | Keyword | Number | Str | RegExp | Special ) Toks = Tok* Spaces ;EBNF From bf664e7ec895b07ae1c7f3fc00ca54e67de5c5b3 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 30 Jun 2008 16:16:13 +1200 Subject: [PATCH 22/42] Add ShiftExpr to JavaScript parser --- extra/peg/javascript/parser/parser.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor index e491c35d2b..39bab79ea9 100644 --- a/extra/peg/javascript/parser/parser.factor +++ b/extra/peg/javascript/parser/parser.factor @@ -56,6 +56,7 @@ RelExpr = RelExpr:x ">" ShiftExpr:y => [[ x y ">" ast-bino | RelExpr:x "<" ShiftExpr:y => [[ x y "<" ast-binop boa ]] | RelExpr:x "<=" ShiftExpr:y => [[ x y "<=" ast-binop boa ]] | RelExpr:x "instanceof" ShiftExpr:y => [[ x y "instanceof" ast-binop boa ]] + | RelExpr:x "in" ShiftExpr:y => [[ x y "in" ast-binop boa ]] | ShiftExpr ShiftExpr = ShiftExpr:x "<<" AddExpr:y => [[ x y "<<" ast-binop boa ]] | ShiftExpr:x ">>>" AddExpr:y => [[ x y ">>>" ast-binop boa ]] From 87bbe8cae162c828e04a7af15ac5f3fa2d0f4b4e Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 30 Jun 2008 18:24:59 +1200 Subject: [PATCH 23/42] Get for(x in y) { } working in js parser --- extra/peg/javascript/parser/parser.factor | 32 ++++++++++++++++++++--- 1 file changed, 29 insertions(+), 3 deletions(-) diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor index 39bab79ea9..2736496cc7 100644 --- a/extra/peg/javascript/parser/parser.factor +++ b/extra/peg/javascript/parser/parser.factor @@ -42,15 +42,35 @@ Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-exp | OrExpr:e "||=" Expr:rhs => [[ e rhs "||" ast-mset boa ]] | OrExpr:e => [[ e ]] +ExprNoIn = OrExprNoIn:e "?" ExprNoIn:t ":" ExprNoIn:f => [[ e t f ast-cond-expr boa ]] + | OrExprNoIn:e "=" ExprNoIn:rhs => [[ e rhs ast-set boa ]] + | OrExprNoIn:e "+=" ExprNoIn:rhs => [[ e rhs "+" ast-mset boa ]] + | OrExprNoIn:e "-=" ExprNoIn:rhs => [[ e rhs "-" ast-mset boa ]] + | OrExprNoIn:e "*=" ExprNoIn:rhs => [[ e rhs "*" ast-mset boa ]] + | OrExprNoIn:e "/=" ExprNoIn:rhs => [[ e rhs "/" ast-mset boa ]] + | OrExprNoIn:e "%=" ExprNoIn:rhs => [[ e rhs "%" ast-mset boa ]] + | OrExprNoIn:e "&&=" ExprNoIn:rhs => [[ e rhs "&&" ast-mset boa ]] + | OrExprNoIn:e "||=" ExprNoIn:rhs => [[ e rhs "||" ast-mset boa ]] + | OrExprNoIn:e => [[ e ]] + OrExpr = OrExpr:x "||" AndExpr:y => [[ x y "||" ast-binop boa ]] | AndExpr +OrExprNoIn = OrExprNoIn:x "||" AndExprNoIn:y => [[ x y "||" ast-binop boa ]] + | AndExprNoIn AndExpr = AndExpr:x "&&" EqExpr:y => [[ x y "&&" ast-binop boa ]] | EqExpr +AndExprNoIn = AndExprNoIn:x "&&" EqExprNoIn:y => [[ x y "&&" ast-binop boa ]] + | EqExprNoIn EqExpr = EqExpr:x "==" RelExpr:y => [[ x y "==" ast-binop boa ]] | EqExpr:x "!=" RelExpr:y => [[ x y "!=" ast-binop boa ]] | EqExpr:x "===" RelExpr:y => [[ x y "===" ast-binop boa ]] | EqExpr:x "!==" RelExpr:y => [[ x y "!==" ast-binop boa ]] | RelExpr +EqExprNoIn = EqExprNoIn:x "==" RelExprNoIn:y => [[ x y "==" ast-binop boa ]] + | EqExprNoIn:x "!=" RelExprNoIn:y => [[ x y "!=" ast-binop boa ]] + | EqExprNoIn:x "===" RelExprNoIn:y => [[ x y "===" ast-binop boa ]] + | EqExprNoIn:x "!==" RelExprNoIn:y => [[ x y "!==" ast-binop boa ]] + | RelExprNoIn RelExpr = RelExpr:x ">" ShiftExpr:y => [[ x y ">" ast-binop boa ]] | RelExpr:x ">=" ShiftExpr:y => [[ x y ">=" ast-binop boa ]] | RelExpr:x "<" ShiftExpr:y => [[ x y "<" ast-binop boa ]] @@ -58,6 +78,12 @@ RelExpr = RelExpr:x ">" ShiftExpr:y => [[ x y ">" ast-bino | RelExpr:x "instanceof" ShiftExpr:y => [[ x y "instanceof" ast-binop boa ]] | RelExpr:x "in" ShiftExpr:y => [[ x y "in" ast-binop boa ]] | ShiftExpr +RelExprNoIn = RelExprNoIn:x ">" ShiftExpr:y => [[ x y ">" ast-binop boa ]] + | RelExprNoIn:x ">=" ShiftExpr:y => [[ x y ">=" ast-binop boa ]] + | RelExprNoIn:x "<" ShiftExpr:y => [[ x y "<" ast-binop boa ]] + | RelExprNoIn:x "<=" ShiftExpr:y => [[ x y "<=" ast-binop boa ]] + | RelExprNoIn:x "instanceof" ShiftExpr:y => [[ x y "instanceof" ast-binop boa ]] + | ShiftExpr ShiftExpr = ShiftExpr:x "<<" AddExpr:y => [[ x y "<<" ast-binop boa ]] | ShiftExpr:x ">>>" AddExpr:y => [[ x y ">>>" ast-binop boa ]] | ShiftExpr:x ">>" AddExpr:y => [[ x y ">>" ast-binop boa ]] @@ -98,7 +124,7 @@ PrimExprHd = "(" Expr:e ")" => [[ e ]] | "new" PrimExpr:n => [[ n f ast-new boa ]] | "[" Args:es "]" => [[ es ast-array boa ]] | Json -JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])? +JsonBindings = (JsonBinding ("," JsonBinding => [[ second ]])* => [[ first2 swap prefix ]])? Json = "{" JsonBindings:bs "}" => [[ bs ast-json boa ]] JsonBinding = JsonPropName:n ":" Expr:v => [[ n v ast-binding boa ]] JsonPropName = Name | Number | String | RegExp @@ -111,14 +137,14 @@ Binding = Name:n "=" Expr:v => [[ n v ast-var Block = "{" SrcElems:ss "}" => [[ ss ]] Bindings = (Binding ("," Binding => [[ second ]])* => [[ first2 swap prefix ]])? For1 = "var" Bindings => [[ second ]] - | Expr + | ExprNoIn | Spaces => [[ "undefined" ast-get boa ]] For2 = Expr | Spaces => [[ "true" ast-get boa ]] For3 = Expr | Spaces => [[ "undefined" ast-get boa ]] ForIn1 = "var" Name:n => [[ n "undefined" ast-get boa ast-var boa ]] - | Expr + | PrimExprHd Switch1 = "case" Expr:c ":" SrcElems:cs => [[ c cs ast-case boa ]] | "default" ":" SrcElems:cs => [[ cs ast-default boa ]] SwitchBody = Switch1* From 8f718fa41eab364708867cc60d2a8f9644b1b765 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 30 Jun 2008 19:05:18 +1200 Subject: [PATCH 24/42] Parse more valid JavaScript --- extra/peg/javascript/parser/parser.factor | 28 +++++++++++++++++-- .../peg/javascript/tokenizer/tokenizer.factor | 12 ++++---- 2 files changed, 33 insertions(+), 7 deletions(-) diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor index 2736496cc7..45da7c3bb4 100644 --- a/extra/peg/javascript/parser/parser.factor +++ b/extra/peg/javascript/parser/parser.factor @@ -40,6 +40,12 @@ Expr = OrExpr:e "?" Expr:t ":" Expr:f => [[ e t f ast-cond-exp | OrExpr:e "%=" Expr:rhs => [[ e rhs "%" ast-mset boa ]] | OrExpr:e "&&=" Expr:rhs => [[ e rhs "&&" ast-mset boa ]] | OrExpr:e "||=" Expr:rhs => [[ e rhs "||" ast-mset boa ]] + | OrExpr:e "^=" Expr:rhs => [[ e rhs "^" ast-mset boa ]] + | OrExpr:e "&=" Expr:rhs => [[ e rhs "&" ast-mset boa ]] + | OrExpr:e "|=" Expr:rhs => [[ e rhs "|" ast-mset boa ]] + | OrExpr:e "<<=" Expr:rhs => [[ e rhs "<<" ast-mset boa ]] + | OrExpr:e ">>=" Expr:rhs => [[ e rhs ">>" ast-mset boa ]] + | OrExpr:e ">>>=" Expr:rhs => [[ e rhs ">>>" ast-mset boa ]] | OrExpr:e => [[ e ]] ExprNoIn = OrExprNoIn:e "?" ExprNoIn:t ":" ExprNoIn:f => [[ e t f ast-cond-expr boa ]] @@ -51,15 +57,33 @@ ExprNoIn = OrExprNoIn:e "?" ExprNoIn:t ":" ExprNoIn:f => [[ e t f as | OrExprNoIn:e "%=" ExprNoIn:rhs => [[ e rhs "%" ast-mset boa ]] | OrExprNoIn:e "&&=" ExprNoIn:rhs => [[ e rhs "&&" ast-mset boa ]] | OrExprNoIn:e "||=" ExprNoIn:rhs => [[ e rhs "||" ast-mset boa ]] + | OrExprNoIn:e "^=" ExprNoIn:rhs => [[ e rhs "^" ast-mset boa ]] + | OrExprNoIn:e "&=" ExprNoIn:rhs => [[ e rhs "&" ast-mset boa ]] + | OrExprNoIn:e "|=" ExprNoIn:rhs => [[ e rhs "|" ast-mset boa ]] + | OrExprNoIn:e "<<=" ExprNoIn:rhs => [[ e rhs "<<" ast-mset boa ]] + | OrExprNoIn:e ">>=" ExprNoIn:rhs => [[ e rhs ">>" ast-mset boa ]] + | OrExprNoIn:e ">>>=" ExprNoIn:rhs => [[ e rhs ">>>" ast-mset boa ]] | OrExprNoIn:e => [[ e ]] OrExpr = OrExpr:x "||" AndExpr:y => [[ x y "||" ast-binop boa ]] | AndExpr OrExprNoIn = OrExprNoIn:x "||" AndExprNoIn:y => [[ x y "||" ast-binop boa ]] | AndExprNoIn -AndExpr = AndExpr:x "&&" EqExpr:y => [[ x y "&&" ast-binop boa ]] +AndExpr = AndExpr:x "&&" BitOrExpr:y => [[ x y "&&" ast-binop boa ]] + | BitOrExpr +AndExprNoIn = AndExprNoIn:x "&&" BitOrExprNoIn:y => [[ x y "&&" ast-binop boa ]] + | BitOrExprNoIn +BitOrExpr = BitOrExpr:x "|" BitXORExpr:y => [[ x y "|" ast-binop boa ]] + | BitXORExpr +BitOrExprNoIn = BitOrExprNoIn:x "|" BitXORExprNoIn:y => [[ x y "|" ast-binop boa ]] + | BitXORExprNoIn +BitXORExpr = BitXORExpr:x "^" BitANDExpr:y => [[ x y "^" ast-binop boa ]] + | BitANDExpr +BitXORExprNoIn = BitXORExprNoIn:x "^" BitANDExprNoIn:y => [[ x y "^" ast-binop boa ]] + | BitANDExprNoIn +BitANDExpr = BitANDExpr:x "&" EqExpr:y => [[ x y "&" ast-binop boa ]] | EqExpr -AndExprNoIn = AndExprNoIn:x "&&" EqExprNoIn:y => [[ x y "&&" ast-binop boa ]] +BitANDExprNoIn = BitANDExprNoIn:x "&" EqExprNoIn:y => [[ x y "&" ast-binop boa ]] | EqExprNoIn EqExpr = EqExpr:x "==" RelExpr:y => [[ x y "==" ast-binop boa ]] | EqExpr:x "!=" RelExpr:y => [[ x y "!=" ast-binop boa ]] diff --git a/extra/peg/javascript/tokenizer/tokenizer.factor b/extra/peg/javascript/tokenizer/tokenizer.factor index 0698c8427e..30a3b5e7a5 100644 --- a/extra/peg/javascript/tokenizer/tokenizer.factor +++ b/extra/peg/javascript/tokenizer/tokenizer.factor @@ -67,11 +67,13 @@ RegExpChar = !("\\" | "/") NonTerminator RegExpChars = RegExpChar* RegExpBody = RegExpFirstChar RegExpChars => [[ first2 swap prefix >string ]] RegExp = "/" RegExpBody:b "/" RegExpFlags:fl => [[ b fl ast-regexp boa ]] -Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";" - | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">=" - | ">>>" | ">>" | ">" | "<=" | "<<" | "<" | "++" | "+=" - | "+" | "--" | "-=" | "-" | "*=" | "*" | "/=" | "/" - | "%=" | "%" | "&&=" | "&&" | "||=" | "||" | "." | "!" +Special = "(" | ")" | "{" | "}" | "[" | "]" | "," | ";" + | "?" | ":" | "!==" | "!=" | "===" | "==" | "=" | ">=" + | ">>>=" | ">>>" | ">>=" | ">>" | ">" | "<=" | "<<=" | "<<" + | "<" | "++" | "+=" | "+" | "--" | "-=" | "-" | "*=" + | "*" | "/=" | "/" | "%=" | "%" | "&&=" | "&&" | "||=" + | "||" | "." | "!" | "&=" | "&" | "|=" | "|" | "^=" + | "^" Tok = Spaces (Name | Keyword | Number | Str | RegExp | Special ) Toks = Tok* Spaces ;EBNF From c8511b483fa911f63e58f4ed171df76186632346 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 30 Jun 2008 19:25:23 +1200 Subject: [PATCH 25/42] Add support for 'with' in js parser. Now parses jquery successfully --- extra/peg/javascript/ast/ast.factor | 1 + extra/peg/javascript/parser/parser.factor | 1 + 2 files changed, 2 insertions(+) diff --git a/extra/peg/javascript/ast/ast.factor b/extra/peg/javascript/ast/ast.factor index 47ab6da864..9f67af86aa 100644 --- a/extra/peg/javascript/ast/ast.factor +++ b/extra/peg/javascript/ast/ast.factor @@ -38,5 +38,6 @@ TUPLE: ast-continue ; TUPLE: ast-throw e ; TUPLE: ast-try t e c f ; TUPLE: ast-return e ; +TUPLE: ast-with expr body ; TUPLE: ast-case c cs ; TUPLE: ast-default cs ; diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor index 45da7c3bb4..7ace528150 100644 --- a/extra/peg/javascript/parser/parser.factor +++ b/extra/peg/javascript/parser/parser.factor @@ -189,6 +189,7 @@ Stmt = Block | "try" Block:t "catch" "(" Name:e ")" Block:c Finally:f => [[ t e c f ast-try boa ]] | "return" Expr:e Sc => [[ e ast-return boa ]] | "return" Sc => [[ "undefined" ast-get boa ast-return boa ]] + | "with" "(" Expr:e ")" Stmt:b => [[ e b ast-with boa ]] | Expr:e Sc => [[ e ]] | ";" => [[ "undefined" ast-get boa ]] SrcElem = "function" Name:n FuncRest:f => [[ n f ast-var boa ]] From b5cef674b1f99dbb3d763cd162f1891857c40c76 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 3 Jul 2008 16:52:22 +1200 Subject: [PATCH 26/42] Pegs throw exceptions on error now --- extra/peg/parsers/parsers-tests.factor | 65 ++++++++++++-------------- extra/peg/peg-tests.factor | 60 ++++++++++++------------ extra/peg/peg.factor | 2 +- 3 files changed, 62 insertions(+), 65 deletions(-) diff --git a/extra/peg/parsers/parsers-tests.factor b/extra/peg/parsers/parsers-tests.factor index e80baf3c4f..0cf3ad8b17 100644 --- a/extra/peg/parsers/parsers-tests.factor +++ b/extra/peg/parsers/parsers-tests.factor @@ -1,54 +1,51 @@ -USING: kernel peg peg.parsers tools.test ; +USING: kernel peg peg.parsers tools.test accessors ; IN: peg.parsers.tests -[ V{ "a" } ] -[ "a" "a" token "," token list-of parse parse-result-ast ] unit-test +{ V{ "a" } } +[ "a" "a" token "," token list-of parse ast>> ] unit-test -[ V{ "a" "a" "a" "a" } ] -[ "a,a,a,a" "a" token "," token list-of parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" "a" } } +[ "a,a,a,a" "a" token "," token list-of parse ast>> ] unit-test -[ f ] -[ "a" "a" token "," token list-of-many parse ] unit-test +[ "a" "a" token "," token list-of-many parse ] must-fail -[ V{ "a" "a" "a" "a" } ] -[ "a,a,a,a" "a" token "," token list-of-many parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" "a" } } +[ "a,a,a,a" "a" token "," token list-of-many parse ast>> ] unit-test -[ f ] -[ "aaa" "a" token 4 exactly-n parse ] unit-test +[ "aaa" "a" token 4 exactly-n parse ] must-fail -[ V{ "a" "a" "a" "a" } ] -[ "aaaa" "a" token 4 exactly-n parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" "a" } } +[ "aaaa" "a" token 4 exactly-n parse ast>> ] unit-test -[ f ] -[ "aaa" "a" token 4 at-least-n parse ] unit-test +[ "aaa" "a" token 4 at-least-n parse ] must-fail -[ V{ "a" "a" "a" "a" } ] -[ "aaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" "a" } } +[ "aaaa" "a" token 4 at-least-n parse ast>> ] unit-test -[ V{ "a" "a" "a" "a" "a" } ] -[ "aaaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" "a" "a" } } +[ "aaaaa" "a" token 4 at-least-n parse ast>> ] unit-test -[ V{ "a" "a" "a" "a" } ] -[ "aaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" "a" } } +[ "aaaa" "a" token 4 at-most-n parse ast>> ] unit-test -[ V{ "a" "a" "a" "a" } ] -[ "aaaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" "a" } } +[ "aaaaa" "a" token 4 at-most-n parse ast>> ] unit-test -[ V{ "a" "a" "a" } ] -[ "aaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" } } +[ "aaa" "a" token 3 4 from-m-to-n parse ast>> ] unit-test -[ V{ "a" "a" "a" "a" } ] -[ "aaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" "a" } } +[ "aaaa" "a" token 3 4 from-m-to-n parse ast>> ] unit-test -[ V{ "a" "a" "a" "a" } ] -[ "aaaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test +{ V{ "a" "a" "a" "a" } } +[ "aaaaa" "a" token 3 4 from-m-to-n parse ast>> ] unit-test -[ 97 ] -[ "a" any-char parse parse-result-ast ] unit-test +{ 97 } +[ "a" any-char parse ast>> ] unit-test -[ V{ } ] -[ "" epsilon parse parse-result-ast ] unit-test +{ V{ } } +[ "" epsilon parse ast>> ] unit-test { "a" } [ - "a" "a" token just parse parse-result-ast + "a" "a" token just parse ast>> ] unit-test \ No newline at end of file diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 1beeb51678..466da83b6e 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -5,9 +5,9 @@ USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math accessors ; IN: peg.tests -{ f } [ +[ "endbegin" "begin" token parse -] unit-test +] must-fail { "begin" "end" } [ "beginend" "begin" token parse @@ -15,13 +15,13 @@ IN: peg.tests >string ] unit-test -{ f } [ +[ "" CHAR: a CHAR: z range parse -] unit-test +] must-fail -{ f } [ +[ "1bcd" CHAR: a CHAR: z range parse -] unit-test +] must-fail { CHAR: a } [ "abcd" CHAR: a CHAR: z range parse ast>> @@ -31,9 +31,9 @@ IN: peg.tests "zbcd" CHAR: a CHAR: z range parse ast>> ] unit-test -{ f } [ +[ "bad" "a" token "b" token 2array seq parse -] unit-test +] must-fail { V{ "g" "o" } } [ "good" "g" token "o" token 2array seq parse ast>> @@ -47,13 +47,13 @@ IN: peg.tests "bbcd" "a" token "b" token 2array choice parse ast>> ] unit-test -{ f } [ +[ "cbcd" "a" token "b" token 2array choice parse -] unit-test +] must-fail -{ f } [ +[ "" "a" token "b" token 2array choice parse -] unit-test +] must-fail { 0 } [ "" "a" token repeat0 parse ast>> length @@ -67,13 +67,13 @@ IN: peg.tests "aaab" "a" token repeat0 parse ast>> ] unit-test -{ f } [ +[ "" "a" token repeat1 parse -] unit-test +] must-fail -{ f } [ +[ "b" "a" token repeat1 parse -] unit-test +] must-fail { V{ "a" "a" "a" } } [ "aaab" "a" token repeat1 parse ast>> @@ -87,17 +87,17 @@ IN: peg.tests "b" "a" token optional "b" token 2array seq parse ast>> ] unit-test -{ f } [ +[ "cb" "a" token optional "b" token 2array seq parse -] unit-test +] must-fail { V{ CHAR: a CHAR: b } } [ "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse ast>> ] unit-test -{ f } [ +[ "bb" "a" token ensure CHAR: a CHAR: z range 2array seq parse -] unit-test +] must-fail { t } [ "a+b" @@ -117,11 +117,11 @@ IN: peg.tests parse [ t ] [ f ] if ] unit-test -{ f } [ +[ "a++b" "a" token "+" token "++" token 2array choice "b" token 3array seq parse [ t ] [ f ] if -] unit-test +] must-fail { 1 } [ "a" "a" token [ drop 1 ] action parse ast>> @@ -131,13 +131,13 @@ IN: peg.tests "aa" "a" token [ drop 1 ] action dup 2array seq parse ast>> ] unit-test -{ f } [ +[ "b" "a" token [ drop 1 ] action parse -] unit-test +] must-fail -{ f } [ +[ "b" [ CHAR: a = ] satisfy parse -] unit-test +] must-fail { CHAR: a } [ "a" [ CHAR: a = ] satisfy parse ast>> @@ -155,9 +155,9 @@ IN: peg.tests "[a]" "[" token hide "a" token "]" token hide 3array seq parse ast>> ] unit-test -{ f } [ +[ "a]" "[" token hide "a" token "]" token hide 3array seq parse -] unit-test +] must-fail { V{ "1" "-" "1" } V{ "1" "+" "1" } } [ @@ -185,9 +185,9 @@ IN: peg.tests dupd 0 swap set-nth compile word? ] unit-test -{ f } [ +[ "A" [ drop t ] satisfy [ 66 >= ] semantic parse -] unit-test +] must-fail { CHAR: B } [ "B" [ drop t ] satisfy [ 66 >= ] semantic parse ast>> diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index a0f5fc05e8..a9695f90d8 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -280,7 +280,7 @@ SYMBOL: delayed ] with-compilation-unit ; : compiled-parse ( state word -- result ) - swap [ execute [ error-stack get throw ] unless* ] with-packrat ; inline + swap [ execute [ error-stack get first throw ] unless* ] with-packrat ; inline : parse ( input parser -- result ) dup word? [ compile ] unless compiled-parse ; From e47f944ccab3571c3fbc37700a5adf0954472f8b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 3 Jul 2008 17:38:28 +1200 Subject: [PATCH 27/42] Print error message nicely --- extra/peg/peg.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index a9695f90d8..d388bbd124 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -19,6 +19,10 @@ C: parse-result C: parse-error C: parser +M: parse-error error. + "Peg parsing error at character position " write dup position>> number>string write + "." print "Expected " write messages>> [ " or " write ] [ write ] interleave nl ; + SYMBOL: error-stack : (merge-errors) ( a b -- c ) @@ -311,7 +315,7 @@ TUPLE: token-parser symbol ; dup >r ?head-slice [ r> f f add-error ] [ - drop input-slice input-from "Expected token '" r> append "'" append 1vector add-error f + drop input-slice input-from "token '" r> append "'" append 1vector add-error f ] if ; M: token-parser (compile) ( parser -- quot ) From 8aa7bc6d78a0c6d64b56a0a5fa78253961665671 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 4 Jul 2008 12:32:02 +1200 Subject: [PATCH 28/42] [EBNF ... EBNF] now does an implicit call --- extra/peg/ebnf/ebnf-tests.factor | 126 +++++++++++++++---------------- extra/peg/ebnf/ebnf.factor | 3 +- 2 files changed, 65 insertions(+), 64 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index a2807d20db..ba34248159 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -113,142 +113,142 @@ IN: peg.ebnf.tests ] unit-test { V{ "a" "b" } } [ - "ab" [EBNF foo='a' 'b' EBNF] call ast>> + "ab" [EBNF foo='a' 'b' EBNF] ast>> ] unit-test { V{ 1 "b" } } [ - "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call ast>> + "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] ast>> ] unit-test { V{ 1 2 } } [ - "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call ast>> + "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] ast>> ] unit-test { CHAR: A } [ - "A" [EBNF foo=[A-Z] EBNF] call ast>> + "A" [EBNF foo=[A-Z] EBNF] ast>> ] unit-test { CHAR: Z } [ - "Z" [EBNF foo=[A-Z] EBNF] call ast>> + "Z" [EBNF foo=[A-Z] EBNF] ast>> ] unit-test [ - "0" [EBNF foo=[A-Z] EBNF] call + "0" [EBNF foo=[A-Z] EBNF] ] must-fail { CHAR: 0 } [ - "0" [EBNF foo=[^A-Z] EBNF] call ast>> + "0" [EBNF foo=[^A-Z] EBNF] ast>> ] unit-test [ - "A" [EBNF foo=[^A-Z] EBNF] call + "A" [EBNF foo=[^A-Z] EBNF] ] must-fail [ - "Z" [EBNF foo=[^A-Z] EBNF] call + "Z" [EBNF foo=[^A-Z] EBNF] ] must-fail { V{ "1" "+" "foo" } } [ - "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call ast>> + "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] ast>> ] unit-test { "foo" } [ - "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] call ast>> + "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] ast>> ] unit-test { "foo" } [ - "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>> + "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] ast>> ] unit-test { "bar" } [ - "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>> + "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] ast>> ] unit-test { 6 } [ - "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ x y + ]] EBNF] call ast>> + "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ x y + ]] EBNF] ast>> ] unit-test { 6 } [ - "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ x digit> y digit> + ]] EBNF] call ast>> + "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ x digit> y digit> + ]] EBNF] ast>> ] unit-test { 10 } [ - { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>> + { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] ast>> ] unit-test [ - { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call + { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] ] must-fail { 3 } [ - { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] call ast>> + { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] ast>> ] unit-test [ - "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call + "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ] must-fail { V{ "a" " " "b" } } [ - "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>> + "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ast>> ] unit-test { V{ "a" "\t" "b" } } [ - "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>> + "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ast>> ] unit-test { V{ "a" "\n" "b" } } [ - "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>> + "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ast>> ] unit-test { V{ "a" f "b" } } [ - "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>> + "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ast>> ] unit-test { V{ "a" " " "b" } } [ - "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>> + "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ast>> ] unit-test { V{ "a" "\t" "b" } } [ - "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>> + "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ast>> ] unit-test { V{ "a" "\n" "b" } } [ - "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>> + "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ast>> ] unit-test { V{ "a" "b" } } [ - "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>> + "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ast>> ] unit-test { V{ "a" "b" } } [ - "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>> + "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ast>> ] unit-test { V{ "a" "b" } } [ - "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>> + "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ast>> ] unit-test [ - "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call + "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ] must-fail { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used - "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>> + "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] ast>> ] unit-test { V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [ #! Test direct left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used - "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>> + "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] ast>> ] unit-test { V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [ #! Test indirect left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used - "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ast>> + "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] ast>> ] unit-test { t } [ @@ -303,85 +303,85 @@ main = Primary 'ebnf' compile must-infer { V{ V{ "a" "b" } "c" } } [ - "abc" [EBNF a="a" "b" foo=(a "c") EBNF] call ast>> + "abc" [EBNF a="a" "b" foo=(a "c") EBNF] ast>> ] unit-test { V{ V{ "a" "b" } "c" } } [ - "abc" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>> + "abc" [EBNF a="a" "b" foo={a "c"} EBNF] ast>> ] unit-test { V{ V{ "a" "b" } "c" } } [ - "abc" [EBNF a="a" "b" foo=a "c" EBNF] call ast>> + "abc" [EBNF a="a" "b" foo=a "c" EBNF] ast>> ] unit-test [ - "a bc" [EBNF a="a" "b" foo=(a "c") EBNF] call + "a bc" [EBNF a="a" "b" foo=(a "c") EBNF] ] must-fail [ - "a bc" [EBNF a="a" "b" foo=a "c" EBNF] call + "a bc" [EBNF a="a" "b" foo=a "c" EBNF] ] must-fail [ - "a bc" [EBNF a="a" "b" foo={a "c"} EBNF] call + "a bc" [EBNF a="a" "b" foo={a "c"} EBNF] ] must-fail [ - "ab c" [EBNF a="a" "b" foo=a "c" EBNF] call + "ab c" [EBNF a="a" "b" foo=a "c" EBNF] ] must-fail { V{ V{ "a" "b" } "c" } } [ - "ab c" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>> + "ab c" [EBNF a="a" "b" foo={a "c"} EBNF] ast>> ] unit-test [ - "ab c" [EBNF a="a" "b" foo=(a "c") EBNF] call + "ab c" [EBNF a="a" "b" foo=(a "c") EBNF] ] must-fail [ - "a b c" [EBNF a="a" "b" foo=a "c" EBNF] call + "a b c" [EBNF a="a" "b" foo=a "c" EBNF] ] must-fail [ - "a b c" [EBNF a="a" "b" foo=(a "c") EBNF] call + "a b c" [EBNF a="a" "b" foo=(a "c") EBNF] ] must-fail [ - "a b c" [EBNF a="a" "b" foo={a "c"} EBNF] call + "a b c" [EBNF a="a" "b" foo={a "c"} EBNF] ] must-fail { V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [ - "ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>> + "ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF] ast>> ] unit-test { V{ } } [ - "ab cab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>> + "ab cab c" [EBNF a="a" "b" foo=(a "c")* EBNF] ast>> ] unit-test { V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [ - "ab c ab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>> + "ab c ab c" [EBNF a="a" "b" foo={a "c"}* EBNF] ast>> ] unit-test { V{ } } [ - "ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>> + "ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] ast>> ] unit-test { V{ "a" "a" "a" } } [ - "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] call ast>> + "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] ast>> ] unit-test { t } [ - "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] call ast>> - "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ x ]] EBNF] call ast>> = + "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] ast>> + "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ x ]] EBNF] ast>> = ] unit-test { V{ "a" "a" "a" } } [ - "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] call ast>> + "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] ast>> ] unit-test { t } [ - "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] call ast>> - "aaa" [EBNF a=('a')* b=(a):x => [[ x ]] EBNF] call ast>> = + "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] ast>> + "aaa" [EBNF a=('a')* b=(a):x => [[ x ]] EBNF] ast>> = ] unit-test { t } [ @@ -445,11 +445,11 @@ foo= 'd' ] unit-test { t } [ - "USING: kernel peg.ebnf ; [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t + "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t ] unit-test [ - "USING: peg.ebnf ; [EBNF foo='a' foo='b' EBNF]" eval drop + "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop ] must-fail { t } [ @@ -460,7 +460,7 @@ foo= 'd' #! Tokenizer tests { V{ "a" CHAR: b } } [ - "ab" [EBNF tokenizer=default foo="a" . EBNF] call ast>> + "ab" [EBNF tokenizer=default foo="a" . EBNF] ast>> ] unit-test TUPLE: ast-number value ; @@ -488,7 +488,7 @@ Tok = Spaces (Number | Special ) tokenizer = foo=. tokenizer=default baz=. main = bar foo foo baz - EBNF] call ast>> + EBNF] ast>> ] unit-test { V{ CHAR: 5 "+" CHAR: 2 } } [ @@ -499,7 +499,7 @@ Tok = Spaces (Number | Special ) spaces=space* => [[ ignore ]] tokenizer=spaces (number | operator) main= . . . - EBNF] call ast>> + EBNF] ast>> ] unit-test { V{ CHAR: 5 "+" CHAR: 2 } } [ @@ -510,13 +510,13 @@ Tok = Spaces (Number | Special ) spaces=space* => [[ ignore ]] tokenizer=spaces (number | operator) main= . . . - EBNF] call ast>> + EBNF] ast>> ] unit-test { "++" } [ - "++--" [EBNF tokenizer=("++" | "--") main="++" EBNF] call ast>> + "++--" [EBNF tokenizer=("++" | "--") main="++" EBNF] ast>> ] unit-test { "\\" } [ - "\\" [EBNF foo="\\" EBNF] call ast>> + "\\" [EBNF foo="\\" EBNF] ast>> ] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 610cffd273..2a6b55ad9d 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -523,7 +523,8 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) parse-result-ast transform dup dup parser [ main swap at compile ] with-variable [ compiled-parse ] curry [ with-scope ] curry ; -: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip parsed reset-tokenizer ; parsing +: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip + parsed \ call parsed reset-tokenizer ; parsing : EBNF: reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string From 4c1fe8f0b30b7adabb819cbb74fddce6f75bdf9f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 4 Jul 2008 12:40:42 +1200 Subject: [PATCH 29/42] Add syntax to return a parser object --- extra/peg/ebnf/ebnf.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 2a6b55ad9d..ff4bd2db61 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -518,11 +518,16 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) "Could not parse EBNF" throw ] if ; +: parse-ebnf ( string -- hashtable ) + 'ebnf' parse check-parse-result ast>> transform ; + : ebnf>quot ( string -- hashtable quot ) - 'ebnf' parse check-parse-result - parse-result-ast transform dup dup parser [ main swap at compile ] with-variable + parse-ebnf dup dup parser [ main swap at compile ] with-variable [ compiled-parse ] curry [ with-scope ] curry ; +: " reset-tokenizer parse-multiline-string parse-ebnf main swap at + parsed reset-tokenizer ; parsing + : [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip parsed \ call parsed reset-tokenizer ; parsing From 72bd6b4dc852cc46b9c9a73946f19e78f7fd5e82 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 4 Jul 2008 14:20:19 +1200 Subject: [PATCH 30/42] Fix peg tests --- extra/peg/ebnf/ebnf-tests.factor | 44 ++++++++++++------------ extra/peg/ebnf/ebnf.factor | 4 +-- extra/peg/parsers/parsers-tests.factor | 28 ++++++++-------- extra/peg/parsers/parsers.factor | 14 ++++---- extra/peg/peg-tests.factor | 46 +++++++++++++------------- extra/peg/peg.factor | 5 ++- extra/peg/pl0/pl0-tests.factor | 18 +++++----- extra/peg/search/search.factor | 11 +++--- 8 files changed, 85 insertions(+), 85 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index ba34248159..ef90929b79 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -7,11 +7,11 @@ USING: kernel tools.test peg peg.ebnf words math math.parser IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ - "abc" 'non-terminal' parse ast>> + "abc" 'non-terminal' parse ] unit-test { T{ ebnf-terminal f "55" } } [ - "'55'" 'terminal' parse ast>> + "'55'" 'terminal' parse ] unit-test { @@ -22,7 +22,7 @@ IN: peg.ebnf.tests } } } [ - "digit = '1' | '2'" 'rule' parse ast>> + "digit = '1' | '2'" 'rule' parse ] unit-test { @@ -33,7 +33,7 @@ IN: peg.ebnf.tests } } } [ - "digit = '1' '2'" 'rule' parse ast>> + "digit = '1' '2'" 'rule' parse ] unit-test { @@ -46,7 +46,7 @@ IN: peg.ebnf.tests } } } [ - "one two | three" 'choice' parse ast>> + "one two | three" 'choice' parse ] unit-test { @@ -61,7 +61,7 @@ IN: peg.ebnf.tests } } } [ - "one {two | three}" 'choice' parse ast>> + "one {two | three}" 'choice' parse ] unit-test { @@ -81,7 +81,7 @@ IN: peg.ebnf.tests } } } [ - "one ((two | three) four)*" 'choice' parse ast>> + "one ((two | three) four)*" 'choice' parse ] unit-test { @@ -93,23 +93,23 @@ IN: peg.ebnf.tests } } } [ - "one ( two )? three" 'choice' parse ast>> + "one ( two )? three" 'choice' parse ] unit-test { "foo" } [ - "\"foo\"" 'identifier' parse ast>> + "\"foo\"" 'identifier' parse ] unit-test { "foo" } [ - "'foo'" 'identifier' parse ast>> + "'foo'" 'identifier' parse ] unit-test { "foo" } [ - "foo" 'non-terminal' parse ast>> ebnf-non-terminal-symbol + "foo" 'non-terminal' parse ebnf-non-terminal-symbol ] unit-test { "foo" } [ - "foo]" 'non-terminal' parse ast>> ebnf-non-terminal-symbol + "foo]" 'non-terminal' parse ebnf-non-terminal-symbol ] unit-test { V{ "a" "b" } } [ @@ -252,7 +252,7 @@ IN: peg.ebnf.tests ] unit-test { t } [ - "abcd='9' | ('8'):x => [[ x ]]" 'ebnf' parse parse-result-remaining empty? + "abcd='9' | ('8'):x => [[ x ]]" 'ebnf' (parse) remaining>> empty? ] unit-test EBNF: primary @@ -385,29 +385,29 @@ main = Primary ] unit-test { t } [ - "number=(digit)+:n 'a'" 'ebnf' parse remaining>> length zero? + "number=(digit)+:n 'a'" 'ebnf' (parse) remaining>> length zero? ] unit-test { t } [ - "number=(digit)+ 'a'" 'ebnf' parse remaining>> length zero? + "number=(digit)+ 'a'" 'ebnf' (parse) remaining>> length zero? ] unit-test { t } [ - "number=digit+ 'a'" 'ebnf' parse remaining>> length zero? + "number=digit+ 'a'" 'ebnf' (parse) remaining>> length zero? ] unit-test { t } [ - "number=digit+:n 'a'" 'ebnf' parse remaining>> length zero? + "number=digit+:n 'a'" 'ebnf' (parse) remaining>> length zero? ] unit-test { t } [ - "foo=(name):n !(keyword) => [[ n ]]" 'rule' parse ast>> - "foo=name:n !(keyword) => [[ n ]]" 'rule' parse ast>> = + "foo=(name):n !(keyword) => [[ n ]]" 'rule' parse + "foo=name:n !(keyword) => [[ n ]]" 'rule' parse = ] unit-test { t } [ - "foo=!(keyword) (name):n => [[ n ]]" 'rule' parse ast>> - "foo=!(keyword) name:n => [[ n ]]" 'rule' parse ast>> = + "foo=!(keyword) (name):n => [[ n ]]" 'rule' parse + "foo=!(keyword) name:n => [[ n ]]" 'rule' parse = ] unit-test << @@ -455,7 +455,7 @@ foo= 'd' { t } [ #! Rule lookup occurs in a namespace. This causes an incorrect duplicate rule #! if a var in a namespace is set. This unit test is to remind me to fix this. - [ "fail" "foo" set "foo='a'" 'ebnf' parse ast>> transform drop t ] with-scope + [ "fail" "foo" set "foo='a'" 'ebnf' parse transform drop t ] with-scope ] unit-test #! Tokenizer tests diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index ff4bd2db61..2a57015fa6 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -504,7 +504,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) ] [ ] make box ; : transform-ebnf ( string -- object ) - 'ebnf' parse parse-result-ast transform ; + 'ebnf' parse transform ; : check-parse-result ( result -- result ) dup [ @@ -519,7 +519,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) ] if ; : parse-ebnf ( string -- hashtable ) - 'ebnf' parse check-parse-result ast>> transform ; + 'ebnf' (parse) check-parse-result ast>> transform ; : ebnf>quot ( string -- hashtable quot ) parse-ebnf dup dup parser [ main swap at compile ] with-variable diff --git a/extra/peg/parsers/parsers-tests.factor b/extra/peg/parsers/parsers-tests.factor index 0cf3ad8b17..20d19c9a64 100644 --- a/extra/peg/parsers/parsers-tests.factor +++ b/extra/peg/parsers/parsers-tests.factor @@ -2,50 +2,50 @@ USING: kernel peg peg.parsers tools.test accessors ; IN: peg.parsers.tests { V{ "a" } } -[ "a" "a" token "," token list-of parse ast>> ] unit-test +[ "a" "a" token "," token list-of parse ] unit-test { V{ "a" "a" "a" "a" } } -[ "a,a,a,a" "a" token "," token list-of parse ast>> ] unit-test +[ "a,a,a,a" "a" token "," token list-of parse ] unit-test [ "a" "a" token "," token list-of-many parse ] must-fail { V{ "a" "a" "a" "a" } } -[ "a,a,a,a" "a" token "," token list-of-many parse ast>> ] unit-test +[ "a,a,a,a" "a" token "," token list-of-many parse ] unit-test [ "aaa" "a" token 4 exactly-n parse ] must-fail { V{ "a" "a" "a" "a" } } -[ "aaaa" "a" token 4 exactly-n parse ast>> ] unit-test +[ "aaaa" "a" token 4 exactly-n parse ] unit-test [ "aaa" "a" token 4 at-least-n parse ] must-fail { V{ "a" "a" "a" "a" } } -[ "aaaa" "a" token 4 at-least-n parse ast>> ] unit-test +[ "aaaa" "a" token 4 at-least-n parse ] unit-test { V{ "a" "a" "a" "a" "a" } } -[ "aaaaa" "a" token 4 at-least-n parse ast>> ] unit-test +[ "aaaaa" "a" token 4 at-least-n parse ] unit-test { V{ "a" "a" "a" "a" } } -[ "aaaa" "a" token 4 at-most-n parse ast>> ] unit-test +[ "aaaa" "a" token 4 at-most-n parse ] unit-test { V{ "a" "a" "a" "a" } } -[ "aaaaa" "a" token 4 at-most-n parse ast>> ] unit-test +[ "aaaaa" "a" token 4 at-most-n parse ] unit-test { V{ "a" "a" "a" } } -[ "aaa" "a" token 3 4 from-m-to-n parse ast>> ] unit-test +[ "aaa" "a" token 3 4 from-m-to-n parse ] unit-test { V{ "a" "a" "a" "a" } } -[ "aaaa" "a" token 3 4 from-m-to-n parse ast>> ] unit-test +[ "aaaa" "a" token 3 4 from-m-to-n parse ] unit-test { V{ "a" "a" "a" "a" } } -[ "aaaaa" "a" token 3 4 from-m-to-n parse ast>> ] unit-test +[ "aaaaa" "a" token 3 4 from-m-to-n parse ] unit-test { 97 } -[ "a" any-char parse ast>> ] unit-test +[ "a" any-char parse ] unit-test { V{ } } -[ "" epsilon parse ast>> ] unit-test +[ "" epsilon parse ] unit-test { "a" } [ - "a" "a" token just parse ast>> + "a" "a" token just parse ] unit-test \ No newline at end of file diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index da44c12e8f..351e3b5fc1 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings namespaces math assocs shuffle vectors arrays math.parser unicode.categories sequences.deep peg peg.private - peg.search math.ranges words memoize ; + peg.search math.ranges words ; IN: peg.parsers TUPLE: just-parser p1 ; @@ -19,7 +19,7 @@ TUPLE: just-parser p1 ; M: just-parser (compile) ( parser -- quot ) just-parser-p1 compiled-parser just-pattern curry ; -MEMO: just ( parser -- parser ) +: just ( parser -- parser ) just-parser boa init-parser ; : 1token ( ch -- parser ) 1string token ; @@ -45,10 +45,10 @@ MEMO: just ( parser -- parser ) PRIVATE> -MEMO: exactly-n ( parser n -- parser' ) +: exactly-n ( parser n -- parser' ) swap seq ; -MEMO: at-most-n ( parser n -- parser' ) +: at-most-n ( parser n -- parser' ) dup zero? [ 2drop epsilon ] [ @@ -56,15 +56,15 @@ MEMO: at-most-n ( parser n -- parser' ) -rot 1- at-most-n 2choice ] if ; -MEMO: at-least-n ( parser n -- parser' ) +: at-least-n ( parser n -- parser' ) dupd exactly-n swap repeat0 2seq [ flatten-vectors ] action ; -MEMO: from-m-to-n ( parser m n -- parser' ) +: from-m-to-n ( parser m n -- parser' ) >r [ exactly-n ] 2keep r> swap - at-most-n 2seq [ flatten-vectors ] action ; -MEMO: pack ( begin body end -- parser ) +: pack ( begin body end -- parser ) >r >r hide r> r> hide 3seq [ first ] action ; : surrounded-by ( parser begin end -- parser' ) diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 466da83b6e..f9e4a0d4a6 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -10,7 +10,7 @@ IN: peg.tests ] must-fail { "begin" "end" } [ - "beginend" "begin" token parse + "beginend" "begin" token (parse) { ast>> remaining>> } get-slots >string ] unit-test @@ -24,11 +24,11 @@ IN: peg.tests ] must-fail { CHAR: a } [ - "abcd" CHAR: a CHAR: z range parse ast>> + "abcd" CHAR: a CHAR: z range parse ] unit-test { CHAR: z } [ - "zbcd" CHAR: a CHAR: z range parse ast>> + "zbcd" CHAR: a CHAR: z range parse ] unit-test [ @@ -36,15 +36,15 @@ IN: peg.tests ] must-fail { V{ "g" "o" } } [ - "good" "g" token "o" token 2array seq parse ast>> + "good" "g" token "o" token 2array seq parse ] unit-test { "a" } [ - "abcd" "a" token "b" token 2array choice parse ast>> + "abcd" "a" token "b" token 2array choice parse ] unit-test { "b" } [ - "bbcd" "a" token "b" token 2array choice parse ast>> + "bbcd" "a" token "b" token 2array choice parse ] unit-test [ @@ -56,15 +56,15 @@ IN: peg.tests ] must-fail { 0 } [ - "" "a" token repeat0 parse ast>> length + "" "a" token repeat0 parse length ] unit-test { 0 } [ - "b" "a" token repeat0 parse ast>> length + "b" "a" token repeat0 parse length ] unit-test { V{ "a" "a" "a" } } [ - "aaab" "a" token repeat0 parse ast>> + "aaab" "a" token repeat0 parse ] unit-test [ @@ -76,15 +76,15 @@ IN: peg.tests ] must-fail { V{ "a" "a" "a" } } [ - "aaab" "a" token repeat1 parse ast>> + "aaab" "a" token repeat1 parse ] unit-test { V{ "a" "b" } } [ - "ab" "a" token optional "b" token 2array seq parse ast>> + "ab" "a" token optional "b" token 2array seq parse ] unit-test { V{ f "b" } } [ - "b" "a" token optional "b" token 2array seq parse ast>> + "b" "a" token optional "b" token 2array seq parse ] unit-test [ @@ -92,7 +92,7 @@ IN: peg.tests ] must-fail { V{ CHAR: a CHAR: b } } [ - "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse ast>> + "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse ] unit-test [ @@ -124,11 +124,11 @@ IN: peg.tests ] must-fail { 1 } [ - "a" "a" token [ drop 1 ] action parse ast>> + "a" "a" token [ drop 1 ] action parse ] unit-test { V{ 1 1 } } [ - "aa" "a" token [ drop 1 ] action dup 2array seq parse ast>> + "aa" "a" token [ drop 1 ] action dup 2array seq parse ] unit-test [ @@ -140,19 +140,19 @@ IN: peg.tests ] must-fail { CHAR: a } [ - "a" [ CHAR: a = ] satisfy parse ast>> + "a" [ CHAR: a = ] satisfy parse ] unit-test { "a" } [ - " a" "a" token sp parse ast>> + " a" "a" token sp parse ] unit-test { "a" } [ - "a" "a" token sp parse ast>> + "a" "a" token sp parse ] unit-test { V{ "a" } } [ - "[a]" "[" token hide "a" token "]" token hide 3array seq parse ast>> + "[a]" "[" token hide "a" token "]" token hide 3array seq parse ] unit-test [ @@ -165,8 +165,8 @@ IN: peg.tests [ "1" token , "-" token , "1" token , ] seq* , [ "1" token , "+" token , "1" token , ] seq* , ] choice* - "1-1" over parse ast>> swap - "1+1" swap parse ast>> + "1-1" over parse swap + "1+1" swap parse ] unit-test : expr ( -- parser ) @@ -175,7 +175,7 @@ IN: peg.tests [ expr ] delay "+" token "1" token 3seq "1" token 2choice ; { V{ V{ "1" "+" "1" } "+" "1" } } [ - "1+1+1" expr parse ast>> + "1+1+1" expr parse ] unit-test { t } [ @@ -190,6 +190,6 @@ IN: peg.tests ] must-fail { CHAR: B } [ - "B" [ drop t ] satisfy [ 66 >= ] semantic parse ast>> + "B" [ drop t ] satisfy [ 66 >= ] semantic parse ] unit-test diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index d388bbd124..0847c57299 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -286,9 +286,12 @@ SYMBOL: delayed : compiled-parse ( state word -- result ) swap [ execute [ error-stack get first throw ] unless* ] with-packrat ; inline -: parse ( input parser -- result ) +: (parse) ( input parser -- result ) dup word? [ compile ] unless compiled-parse ; +: parse ( input parser -- ast ) + (parse) ast>> ; + > empty? + "CONST foo = 1;" "block" \ pl0 rule (parse) remaining>> empty? ] unit-test { t } [ - "VAR foo;" "block" \ pl0 rule parse remaining>> empty? + "VAR foo;" "block" \ pl0 rule (parse) remaining>> empty? ] unit-test { t } [ - "VAR foo,bar , baz;" "block" \ pl0 rule parse remaining>> empty? + "VAR foo,bar , baz;" "block" \ pl0 rule (parse) remaining>> empty? ] unit-test { t } [ - "foo := 5" "statement" \ pl0 rule parse remaining>> empty? + "foo := 5" "statement" \ pl0 rule (parse) remaining>> empty? ] unit-test { t } [ - "BEGIN foo := 5 END" "statement" \ pl0 rule parse remaining>> empty? + "BEGIN foo := 5 END" "statement" \ pl0 rule (parse) remaining>> empty? ] unit-test { t } [ - "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse remaining>> empty? + "IF 1=1 THEN foo := 5" "statement" \ pl0 rule (parse) remaining>> empty? ] unit-test { t } [ - "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty? + "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule (parse) remaining>> empty? ] unit-test { t } [ - "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty? + "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule (parse) remaining>> empty? ] unit-test { t } [ - "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse remaining>> empty? + "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule (parse) remaining>> empty? ] unit-test { t } [ diff --git a/extra/peg/search/search.factor b/extra/peg/search/search.factor index 7ab7e83d12..04e4affe39 100755 --- a/extra/peg/search/search.factor +++ b/extra/peg/search/search.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math io io.streams.string sequences strings -combinators peg memoize arrays ; +combinators peg memoize arrays continuations ; IN: peg.search : tree-write ( object -- ) @@ -16,15 +16,12 @@ MEMO: any-char-parser ( -- parser ) [ drop t ] satisfy ; : search ( string parser -- seq ) - any-char-parser [ drop f ] action 2array choice repeat0 parse dup [ - parse-result-ast sift - ] [ - drop { } - ] if ; + any-char-parser [ drop f ] action 2array choice repeat0 + [ parse sift ] [ 3drop { } ] recover ; : (replace) ( string parser -- seq ) - any-char-parser 2array choice repeat0 parse parse-result-ast sift ; + any-char-parser 2array choice repeat0 parse sift ; : replace ( string parser -- result ) [ (replace) [ tree-write ] each ] with-string-writer ; From f3145c5961dab694f51ba8a1845362d5dcb6a1f9 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 4 Jul 2008 15:48:52 +1200 Subject: [PATCH 31/42] [EBNF and EBNF: now return ast --- extra/peg/ebnf/ebnf-tests.factor | 112 +++++++++--------- extra/peg/ebnf/ebnf.factor | 2 +- extra/peg/javascript/javascript.factor | 6 +- .../peg/javascript/parser/parser-tests.factor | 10 +- .../tokenizer/tokenizer-tests.factor | 4 +- 5 files changed, 65 insertions(+), 69 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index ef90929b79..7f14293a15 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -113,23 +113,23 @@ IN: peg.ebnf.tests ] unit-test { V{ "a" "b" } } [ - "ab" [EBNF foo='a' 'b' EBNF] ast>> + "ab" [EBNF foo='a' 'b' EBNF] ] unit-test { V{ 1 "b" } } [ - "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] ast>> + "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] ] unit-test { V{ 1 2 } } [ - "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] ast>> + "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] ] unit-test { CHAR: A } [ - "A" [EBNF foo=[A-Z] EBNF] ast>> + "A" [EBNF foo=[A-Z] EBNF] ] unit-test { CHAR: Z } [ - "Z" [EBNF foo=[A-Z] EBNF] ast>> + "Z" [EBNF foo=[A-Z] EBNF] ] unit-test [ @@ -137,7 +137,7 @@ IN: peg.ebnf.tests ] must-fail { CHAR: 0 } [ - "0" [EBNF foo=[^A-Z] EBNF] ast>> + "0" [EBNF foo=[^A-Z] EBNF] ] unit-test [ @@ -149,31 +149,31 @@ IN: peg.ebnf.tests ] must-fail { V{ "1" "+" "foo" } } [ - "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] ast>> + "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] ] unit-test { "foo" } [ - "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] ast>> + "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] ] unit-test { "foo" } [ - "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] ast>> + "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] ] unit-test { "bar" } [ - "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] ast>> + "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] ] unit-test { 6 } [ - "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ x y + ]] EBNF] ast>> + "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ x y + ]] EBNF] ] unit-test { 6 } [ - "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ x digit> y digit> + ]] EBNF] ast>> + "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ x digit> y digit> + ]] EBNF] ] unit-test { 10 } [ - { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] ast>> + { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] ] unit-test [ @@ -181,7 +181,7 @@ IN: peg.ebnf.tests ] must-fail { 3 } [ - { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] ast>> + { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ x y + ]] | num EBNF] ] unit-test [ @@ -189,44 +189,44 @@ IN: peg.ebnf.tests ] must-fail { V{ "a" " " "b" } } [ - "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ast>> + "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ] unit-test { V{ "a" "\t" "b" } } [ - "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ast>> + "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ] unit-test { V{ "a" "\n" "b" } } [ - "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ast>> + "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] ] unit-test { V{ "a" f "b" } } [ - "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ast>> + "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ] unit-test { V{ "a" " " "b" } } [ - "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ast>> + "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ] unit-test { V{ "a" "\t" "b" } } [ - "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ast>> + "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ] unit-test { V{ "a" "\n" "b" } } [ - "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ast>> + "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] ] unit-test { V{ "a" "b" } } [ - "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ast>> + "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ] unit-test { V{ "a" "b" } } [ - "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ast>> + "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ] unit-test { V{ "a" "b" } } [ - "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ast>> + "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] ] unit-test [ @@ -236,19 +236,19 @@ IN: peg.ebnf.tests { V{ V{ 49 } "+" V{ 49 } } } [ #! Test direct left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used - "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] ast>> + "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] ] unit-test { V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [ #! Test direct left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used - "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] ast>> + "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] ] unit-test { V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [ #! Test indirect left recursion. #! Using packrat, so first part of expr fails, causing 2nd choice to be used - "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] ast>> + "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] ] unit-test { t } [ @@ -281,37 +281,37 @@ main = Primary ;EBNF { "this" } [ - "this" primary ast>> + "this" primary ] unit-test { V{ "this" "." "x" } } [ - "this.x" primary ast>> + "this.x" primary ] unit-test { V{ V{ "this" "." "x" } "." "y" } } [ - "this.x.y" primary ast>> + "this.x.y" primary ] unit-test { V{ V{ "this" "." "x" } "." "m" "(" ")" } } [ - "this.x.m()" primary ast>> + "this.x.m()" primary ] unit-test { V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [ - "x[i][j].y" primary ast>> + "x[i][j].y" primary ] unit-test 'ebnf' compile must-infer { V{ V{ "a" "b" } "c" } } [ - "abc" [EBNF a="a" "b" foo=(a "c") EBNF] ast>> + "abc" [EBNF a="a" "b" foo=(a "c") EBNF] ] unit-test { V{ V{ "a" "b" } "c" } } [ - "abc" [EBNF a="a" "b" foo={a "c"} EBNF] ast>> + "abc" [EBNF a="a" "b" foo={a "c"} EBNF] ] unit-test { V{ V{ "a" "b" } "c" } } [ - "abc" [EBNF a="a" "b" foo=a "c" EBNF] ast>> + "abc" [EBNF a="a" "b" foo=a "c" EBNF] ] unit-test [ @@ -331,7 +331,7 @@ main = Primary ] must-fail { V{ V{ "a" "b" } "c" } } [ - "ab c" [EBNF a="a" "b" foo={a "c"} EBNF] ast>> + "ab c" [EBNF a="a" "b" foo={a "c"} EBNF] ] unit-test [ @@ -351,37 +351,37 @@ main = Primary ] must-fail { V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [ - "ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF] ast>> + "ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF] ] unit-test { V{ } } [ - "ab cab c" [EBNF a="a" "b" foo=(a "c")* EBNF] ast>> + "ab cab c" [EBNF a="a" "b" foo=(a "c")* EBNF] ] unit-test { V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [ - "ab c ab c" [EBNF a="a" "b" foo={a "c"}* EBNF] ast>> + "ab c ab c" [EBNF a="a" "b" foo={a "c"}* EBNF] ] unit-test { V{ } } [ - "ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] ast>> + "ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] ] unit-test { V{ "a" "a" "a" } } [ - "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] ast>> + "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] ] unit-test { t } [ - "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] ast>> - "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ x ]] EBNF] ast>> = + "aaa" [EBNF a=('a')* b=!('b') a:x => [[ x ]] EBNF] + "aaa" [EBNF a=('a')* b=!('b') (a):x => [[ x ]] EBNF] = ] unit-test { V{ "a" "a" "a" } } [ - "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] ast>> + "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] ] unit-test { t } [ - "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] ast>> - "aaa" [EBNF a=('a')* b=(a):x => [[ x ]] EBNF] ast>> = + "aaa" [EBNF a=('a')* b=a:x => [[ x ]] EBNF] + "aaa" [EBNF a=('a')* b=(a):x => [[ x ]] EBNF] = ] unit-test { t } [ @@ -429,19 +429,19 @@ foo= 'd' ;EBNF { "a" } [ - "a" parser1 ast>> + "a" parser1 ] unit-test { V{ "a" "b" } } [ - "ab" parser2 ast>> + "ab" parser2 ] unit-test { V{ "a" "c" } } [ - "ac" parser3 ast>> + "ac" parser3 ] unit-test { V{ CHAR: a "d" } } [ - "ad" parser4 ast>> + "ad" parser4 ] unit-test { t } [ @@ -460,7 +460,7 @@ foo= 'd' #! Tokenizer tests { V{ "a" CHAR: b } } [ - "ab" [EBNF tokenizer=default foo="a" . EBNF] ast>> + "ab" [EBNF tokenizer=default foo="a" . EBNF] ] unit-test TUPLE: ast-number value ; @@ -488,7 +488,7 @@ Tok = Spaces (Number | Special ) tokenizer = foo=. tokenizer=default baz=. main = bar foo foo baz - EBNF] ast>> + EBNF] ] unit-test { V{ CHAR: 5 "+" CHAR: 2 } } [ @@ -499,7 +499,7 @@ Tok = Spaces (Number | Special ) spaces=space* => [[ ignore ]] tokenizer=spaces (number | operator) main= . . . - EBNF] ast>> + EBNF] ] unit-test { V{ CHAR: 5 "+" CHAR: 2 } } [ @@ -510,13 +510,13 @@ Tok = Spaces (Number | Special ) spaces=space* => [[ ignore ]] tokenizer=spaces (number | operator) main= . . . - EBNF] ast>> + EBNF] ] unit-test { "++" } [ - "++--" [EBNF tokenizer=("++" | "--") main="++" EBNF] ast>> + "++--" [EBNF tokenizer=("++" | "--") main="++" EBNF] ] unit-test { "\\" } [ - "\\" [EBNF foo="\\" EBNF] ast>> + "\\" [EBNF foo="\\" EBNF] ] unit-test \ No newline at end of file diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 2a57015fa6..2a75fcccc0 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -523,7 +523,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : ebnf>quot ( string -- hashtable quot ) parse-ebnf dup dup parser [ main swap at compile ] with-variable - [ compiled-parse ] curry [ with-scope ] curry ; + [ compiled-parse ] curry [ with-scope ast>> ] curry ; : " reset-tokenizer parse-multiline-string parse-ebnf main swap at parsed reset-tokenizer ; parsing diff --git a/extra/peg/javascript/javascript.factor b/extra/peg/javascript/javascript.factor index 8fe0538eae..4a919cf39f 100644 --- a/extra/peg/javascript/javascript.factor +++ b/extra/peg/javascript/javascript.factor @@ -4,8 +4,4 @@ USING: kernel accessors peg.javascript.tokenizer peg.javascript.parser ; IN: peg.javascript : parse-javascript ( string -- ast ) - javascript [ - ast>> - ] [ - "Unable to parse JavaScript" throw - ] if* ; + javascript ; diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor index fd0e27b6d4..769dc41f78 100644 --- a/extra/peg/javascript/parser/parser-tests.factor +++ b/extra/peg/javascript/parser/parser-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser - accessors multiline sequences math ; + accessors multiline sequences math peg.ebnf ; IN: peg.javascript.parser.tests \ javascript must-infer @@ -23,14 +23,14 @@ IN: peg.javascript.parser.tests } } } [ - "123; 'hello'; foo(x);" javascript ast>> + "123; 'hello'; foo(x);" javascript ] unit-test { t } [ <" var x=5 var y=10 -"> javascript remaining>> length zero? +"> main \ javascript rule (parse) remaining>> length zero? ] unit-test @@ -41,7 +41,7 @@ function foldl(f, initial, seq) { initial = f(initial, seq[i]); return initial; } -"> javascript remaining>> length zero? +"> main \ javascript rule (parse) remaining>> length zero? ] unit-test { t } [ @@ -52,6 +52,6 @@ ParseState.prototype.from = function(index) { r.length = this.length - index; return r; } -"> javascript remaining>> length zero? +"> main \ javascript rule (parse) remaining>> length zero? ] unit-test diff --git a/extra/peg/javascript/tokenizer/tokenizer-tests.factor b/extra/peg/javascript/tokenizer/tokenizer-tests.factor index a61125d08c..f0080a31b2 100644 --- a/extra/peg/javascript/tokenizer/tokenizer-tests.factor +++ b/extra/peg/javascript/tokenizer/tokenizer-tests.factor @@ -19,9 +19,9 @@ IN: peg.javascript.tokenizer.tests ";" } } [ - "123; 'hello'; foo(x);" tokenize-javascript ast>> + "123; 'hello'; foo(x);" tokenize-javascript ] unit-test { V{ T{ ast-regexp f "<(w+)[^>]*?)/>" "g" } } } [ - "/<(\\w+)[^>]*?)\\/>/g" tokenize-javascript ast>> + "/<(\\w+)[^>]*?)\\/>/g" tokenize-javascript ] unit-test \ No newline at end of file From 7f4fe7669861497137569e36130854dc77b5b872 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 4 Jul 2008 15:55:23 +1200 Subject: [PATCH 32/42] More peg test fixes --- extra/peg/expr/expr-tests.factor | 10 +++++----- extra/peg/expr/expr.factor | 4 ---- extra/peg/pl0/pl0-tests.factor | 4 ++-- 3 files changed, 7 insertions(+), 11 deletions(-) diff --git a/extra/peg/expr/expr-tests.factor b/extra/peg/expr/expr-tests.factor index b6f3163bf4..59c70cd358 100644 --- a/extra/peg/expr/expr-tests.factor +++ b/extra/peg/expr/expr-tests.factor @@ -5,21 +5,21 @@ USING: kernel tools.test peg peg.expr multiline sequences ; IN: peg.expr.tests { 5 } [ - "2+3" eval-expr + "2+3" expr ] unit-test { 6 } [ - "2*3" eval-expr + "2*3" expr ] unit-test { 14 } [ - "2+3*4" eval-expr + "2+3*4" expr ] unit-test { 17 } [ - "2+3*4+3" eval-expr + "2+3*4+3" expr ] unit-test { 23 } [ - "2+3*(4+3)" eval-expr + "2+3*(4+3)" expr ] unit-test diff --git a/extra/peg/expr/expr.factor b/extra/peg/expr/expr.factor index e2df60ea9a..8b10b4fc0c 100644 --- a/extra/peg/expr/expr.factor +++ b/extra/peg/expr/expr.factor @@ -18,7 +18,3 @@ exp = exp "+" fac => [[ first3 nip + ]] | exp "-" fac => [[ first3 nip - ]] | fac ;EBNF - -: eval-expr ( string -- number ) - expr ast>> ; - diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index 4ba550a26c..e84d37e5d4 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -58,7 +58,7 @@ BEGIN x := x + 1; END END. -"> pl0 remaining>> empty? +"> main \ pl0 rule (parse) remaining>> empty? ] unit-test { f } [ @@ -124,5 +124,5 @@ BEGIN y := 36; CALL gcd; END. - "> pl0 remaining>> empty? + "> main \ pl0 rule (parse) remaining>> empty? ] unit-test \ No newline at end of file From d92c19f694057eccc8aa8656a5a73ef46f26c3ab Mon Sep 17 00:00:00 2001 From: Chris Double Date: Tue, 8 Jul 2008 16:10:06 +1200 Subject: [PATCH 33/42] Remove delegate usage from pegs --- extra/peg/peg.factor | 106 ++++++++++++++++++++++--------------------- 1 file changed, 54 insertions(+), 52 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 0847c57299..3882315dc9 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -10,14 +10,13 @@ USE: prettyprint TUPLE: parse-result remaining ast ; TUPLE: parse-error position messages ; -TUPLE: parser id compiled ; -M: parser equal? [ id>> ] bi@ = ; +TUPLE: parser peg compiled id ; +M: parser equal? [ id>> ] bi@ = ; M: parser hashcode* id>> hashcode* ; -C: parse-result -C: parse-error -C: parser +C: parse-result +C: parse-error M: parse-error error. "Peg parsing error at character position " write dup position>> number>string write @@ -59,11 +58,16 @@ SYMBOL: heads : failed? ( obj -- ? ) fail = ; -: delegates ( -- cache ) - \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; +: peg-cache ( -- cache ) + #! Holds a hashtable mapping a peg tuple to + #! the parser tuple for that peg. The parser tuple + #! holds a unique id and the compiled form of that peg. + \ peg-cache get-global [ + H{ } clone dup \ peg-cache set-global + ] unless* ; : reset-pegs ( -- ) - H{ } clone \ delegates set-global ; + H{ } clone \ peg-cache set-global ; reset-pegs @@ -239,7 +243,7 @@ C: peg-head ] H{ } make-assoc swap bind ; inline -GENERIC: (compile) ( parser -- quot ) +GENERIC: (compile) ( peg -- quot ) : execute-parser ( word -- result ) pos get apply-rule dup failed? [ @@ -251,7 +255,7 @@ GENERIC: (compile) ( parser -- quot ) : parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - gensym 2dup swap (compile) 0 1 define-declared swap dupd "peg" set-word-prop + gensym 2dup swap peg>> (compile) 0 1 define-declared swap dupd "peg" set-word-prop [ execute-parser ] curry ; : compiled-parser ( parser -- word ) @@ -304,12 +308,13 @@ SYMBOL: id 1 id set-global 0 ] if* ; -: init-parser ( parser -- parser ) - #! Set the delegate for the parser. Equivalent parsers - #! get a delegate with the same id. - dup clone delegates [ - drop next-id f - ] cache over set-delegate ; +: wrap-peg ( peg -- parser ) + #! Wrap a parser tuple around the peg object. + #! Look for an existing parser tuple for that + #! peg object. + peg-cache [ + f next-id parser boa + ] cache ; TUPLE: token-parser symbol ; @@ -321,7 +326,7 @@ TUPLE: token-parser symbol ; drop input-slice input-from "token '" r> append "'" append 1vector add-error f ] if ; -M: token-parser (compile) ( parser -- quot ) +M: token-parser (compile) ( peg -- quot ) symbol>> '[ input-slice , parse-token ] ; TUPLE: satisfy-parser quot ; @@ -338,7 +343,7 @@ TUPLE: satisfy-parser quot ; ] if ; inline -M: satisfy-parser (compile) ( parser -- quot ) +M: satisfy-parser (compile) ( peg -- quot ) quot>> '[ input-slice , parse-satisfy ] ; TUPLE: range-parser min max ; @@ -354,7 +359,7 @@ TUPLE: range-parser min max ; ] if ] if ; -M: range-parser (compile) ( parser -- quot ) +M: range-parser (compile) ( peg -- quot ) [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ; TUPLE: seq-parser parsers ; @@ -381,7 +386,7 @@ TUPLE: seq-parser parsers ; 2drop f ] if ; inline -M: seq-parser (compile) ( parser -- quot ) +M: seq-parser (compile) ( peg -- quot ) [ [ input-slice V{ } clone ] % parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [ @@ -390,7 +395,7 @@ M: seq-parser (compile) ( parser -- quot ) TUPLE: choice-parser parsers ; -M: choice-parser (compile) ( parser -- quot ) +M: choice-parser (compile) ( peg -- quot ) [ f , parsers>> [ compiled-parser ] map @@ -408,7 +413,7 @@ TUPLE: repeat0-parser p1 ; nip ] if* ; inline -M: repeat0-parser (compile) ( parser -- quot ) +M: repeat0-parser (compile) ( peg -- quot ) p1>> compiled-parser 1quotation '[ input-slice V{ } clone , swap (repeat) ] ; @@ -422,7 +427,7 @@ TUPLE: repeat1-parser p1 ; f ] if* ; -M: repeat1-parser (compile) ( parser -- quot ) +M: repeat1-parser (compile) ( peg -- quot ) p1>> compiled-parser 1quotation '[ input-slice V{ } clone , swap (repeat) repeat1-empty-check ] ; @@ -432,7 +437,7 @@ TUPLE: optional-parser p1 ; : check-optional ( result -- result ) [ input-slice f ] unless* ; -M: optional-parser (compile) ( parser -- quot ) +M: optional-parser (compile) ( peg -- quot ) p1>> compiled-parser 1quotation '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; @@ -444,7 +449,7 @@ TUPLE: semantic-parser p1 quot ; drop ] if ; inline -M: semantic-parser (compile) ( parser -- quot ) +M: semantic-parser (compile) ( peg -- quot ) [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-semantic ] ; @@ -453,7 +458,7 @@ TUPLE: ensure-parser p1 ; : check-ensure ( old-input result -- result ) [ ignore ] [ drop f ] if ; -M: ensure-parser (compile) ( parser -- quot ) +M: ensure-parser (compile) ( peg -- quot ) p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ; TUPLE: ensure-not-parser p1 ; @@ -461,7 +466,7 @@ TUPLE: ensure-not-parser p1 ; : check-ensure-not ( old-input result -- result ) [ drop f ] [ ignore ] if ; -M: ensure-not-parser (compile) ( parser -- quot ) +M: ensure-not-parser (compile) ( peg -- quot ) p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ; TUPLE: action-parser p1 quot ; @@ -473,7 +478,7 @@ TUPLE: action-parser p1 quot ; drop ] if ; inline -M: action-parser (compile) ( parser -- quot ) +M: action-parser (compile) ( peg -- quot ) [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; : left-trim-slice ( string -- string ) @@ -485,14 +490,14 @@ M: action-parser (compile) ( parser -- quot ) TUPLE: sp-parser p1 ; -M: sp-parser (compile) ( parser -- quot ) +M: sp-parser (compile) ( peg -- quot ) p1>> compiled-parser 1quotation '[ input-slice left-trim-slice input-from pos set @ ] ; TUPLE: delay-parser quot ; -M: delay-parser (compile) ( parser -- quot ) +M: delay-parser (compile) ( peg -- quot ) #! For efficiency we memoize the quotation. #! This way it is run only once and the #! parser constructed once at run time. @@ -500,29 +505,26 @@ M: delay-parser (compile) ( parser -- quot ) TUPLE: box-parser quot ; -M: box-parser (compile) ( parser -- quot ) +M: box-parser (compile) ( peg -- quot ) #! Calls the quotation at compile time #! to produce the parser to be compiled. #! This differs from 'delay' which calls - #! it at run time. Due to using the runtime - #! environment at compile time, this parser - #! must not be cached, so we clear out the - #! delgates cache. - f >>compiled quot>> call compiled-parser 1quotation ; + #! it at run time. + quot>> call compiled-parser 1quotation ; PRIVATE> : token ( string -- parser ) - token-parser boa init-parser ; + token-parser boa wrap-peg ; : satisfy ( quot -- parser ) - satisfy-parser boa init-parser ; + satisfy-parser boa wrap-peg ; : range ( min max -- parser ) - range-parser boa init-parser ; + range-parser boa wrap-peg ; : seq ( seq -- parser ) - seq-parser boa init-parser ; + seq-parser boa wrap-peg ; : 2seq ( parser1 parser2 -- parser ) 2array seq ; @@ -537,7 +539,7 @@ PRIVATE> { } make seq ; inline : choice ( seq -- parser ) - choice-parser boa init-parser ; + choice-parser boa wrap-peg ; : 2choice ( parser1 parser2 -- parser ) 2array choice ; @@ -552,38 +554,38 @@ PRIVATE> { } make choice ; inline : repeat0 ( parser -- parser ) - repeat0-parser boa init-parser ; + repeat0-parser boa wrap-peg ; : repeat1 ( parser -- parser ) - repeat1-parser boa init-parser ; + repeat1-parser boa wrap-peg ; : optional ( parser -- parser ) - optional-parser boa init-parser ; + optional-parser boa wrap-peg ; : semantic ( parser quot -- parser ) - semantic-parser boa init-parser ; + semantic-parser boa wrap-peg ; : ensure ( parser -- parser ) - ensure-parser boa init-parser ; + ensure-parser boa wrap-peg ; : ensure-not ( parser -- parser ) - ensure-not-parser boa init-parser ; + ensure-not-parser boa wrap-peg ; : action ( parser quot -- parser ) - action-parser boa init-parser ; + action-parser boa wrap-peg ; : sp ( parser -- parser ) - sp-parser boa init-parser ; + sp-parser boa wrap-peg ; : hide ( parser -- parser ) [ drop ignore ] action ; : delay ( quot -- parser ) - delay-parser boa init-parser ; + delay-parser boa wrap-peg ; : box ( quot -- parser ) #! because a box has its quotation run at compile time - #! it must always have a new parser delgate created, + #! it must always have a new parser wrapper created, #! not a cached one. This is because the same box, #! compiled twice can have a different compiled word #! due to running at compile time. @@ -593,7 +595,7 @@ PRIVATE> #! parse. The action adds an indirection with a parser type #! that gets memoized and fixes this. Need to rethink how #! to fix boxes so this isn't needed... - box-parser boa next-id f over set-delegate [ ] action ; + box-parser boa f next-id parser boa [ ] action ; ERROR: parse-failed input word ; From ec896eeba8c32a974e84ab431e6673b6f591d438 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Tue, 8 Jul 2008 16:56:12 +1200 Subject: [PATCH 34/42] peg fixes --- extra/peg/parsers/parsers.factor | 2 +- extra/peg/peg-tests.factor | 2 +- extra/peg/peg.factor | 11 +++++++---- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 351e3b5fc1..f6c2820ac2 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -20,7 +20,7 @@ M: just-parser (compile) ( parser -- quot ) just-parser-p1 compiled-parser just-pattern curry ; : just ( parser -- parser ) - just-parser boa init-parser ; + just-parser boa wrap-peg ; : 1token ( ch -- parser ) 1string token ; diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index f9e4a0d4a6..62e041441f 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -181,7 +181,7 @@ IN: peg.tests { t } [ #! Ensure a circular parser doesn't loop infinitely [ f , "a" token , ] seq* - dup parsers>> + dup peg>> parsers>> dupd 0 swap set-nth compile word? ] unit-test diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3882315dc9..871db21084 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -245,12 +245,15 @@ C: peg-head GENERIC: (compile) ( peg -- quot ) -: execute-parser ( word -- result ) - pos get apply-rule dup failed? [ +: process-parser-result ( result -- result ) + dup failed? [ drop f ] [ input-slice swap - ] if ; inline + ] if ; + +: execute-parser ( word -- result ) + pos get apply-rule process-parser-result ; inline : parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version @@ -323,7 +326,7 @@ TUPLE: token-parser symbol ; dup >r ?head-slice [ r> f f add-error ] [ - drop input-slice input-from "token '" r> append "'" append 1vector add-error f + drop pos get "token '" r> append "'" append 1vector add-error f ] if ; M: token-parser (compile) ( peg -- quot ) From 4135f81514c91257c901a1c2819c204955714d10 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 9 Jul 2008 11:45:51 +1200 Subject: [PATCH 35/42] Fix comment in peg eval-rule --- extra/peg/peg.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 871db21084..4cfa94ce48 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -109,7 +109,7 @@ C: peg-head : eval-rule ( rule -- ast ) #! Evaluate a rule, return an ast resulting from it. #! Return fail if the rule failed. The rule has - #! stack effect ( input -- parse-result ) + #! stack effect ( -- parse-result ) pos get swap execute process-rule-result ; inline : memo ( pos rule -- memo-entry ) From 9e78bb70f2216c8582827a9a880b2fca8ca32e1d Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 9 Jul 2008 12:07:17 +1200 Subject: [PATCH 36/42] packrat refactoring --- extra/peg/peg.factor | 72 +++++++++++++++++++++++++++----------------- 1 file changed, 45 insertions(+), 27 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 4cfa94ce48..9540b1fd70 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -48,12 +48,27 @@ SYMBOL: error-stack SYMBOL: ignore -SYMBOL: packrat +: packrat ( id -- cache ) + #! The packrat cache is a mapping of parser-id->cache. + #! For each parser it maps to a cache holding a mapping + #! of position->result. The packrat cache therefore keeps + #! track of all parses that have occurred at each position + #! of the input string and the results obtained from that + #! parser. + \ packrat get [ drop H{ } clone ] cache ; + SYMBOL: pos SYMBOL: input SYMBOL: fail SYMBOL: lrstack -SYMBOL: heads + +: heads ( -- cache ) + #! A mapping from position->peg-head. It maps a + #! position in the input string being parsed to + #! the head of the left recursion which is currently + #! being grown. It is 'f' at any position where + #! left recursion growth is not underway. + \ heads get ; : failed? ( obj -- ? ) fail = ; @@ -71,19 +86,20 @@ SYMBOL: heads reset-pegs +#! An entry in the table of memoized parse results +#! ast = an AST produced from the parse +#! or the symbol 'fail' +#! or a left-recursion object +#! pos = the position in the input string of this entry TUPLE: memo-entry ans pos ; -C: memo-entry -TUPLE: left-recursion seed rule head next ; -C: left-recursion - +TUPLE: left-recursion seed rule head next ; TUPLE: peg-head rule involved-set eval-set ; -C: peg-head -: rule-parser ( rule -- parser ) +: rule-id ( word -- id ) #! A rule is the parser compiled down to a word. It has - #! a "peg" property containing the original parser. - "peg" word-prop ; + #! a "peg-id" property containing the id of the original parser. + "peg-id" word-prop ; : input-slice ( -- slice ) #! Return a slice of the input from the current parse position @@ -94,11 +110,6 @@ C: peg-head #! input slice is based on. dup slice? [ slice-from ] [ drop 0 ] if ; -: input-cache ( parser -- cache ) - #! From the packrat cache, obtain the cache for the parser - #! that maps the position to the parser result. - id>> packrat get [ drop H{ } clone ] cache ; - : process-rule-result ( p result -- result ) [ nip [ ast>> ] [ remaining>> ] bi input-from pos set @@ -114,11 +125,13 @@ C: peg-head : memo ( pos rule -- memo-entry ) #! Return the result from the memo cache. - rule-parser input-cache at ; + rule-id packrat at +! " memo result " write dup . + ; : set-memo ( memo-entry pos rule -- ) #! Store an entry in the cache - rule-parser input-cache set-at ; + rule-id packrat set-at ; : update-m ( ast m -- ) swap >>ans pos get >>pos drop ; @@ -141,9 +154,9 @@ C: peg-head ] if ; inline : grow-lr ( h p r m -- ast ) - >r >r [ heads get set-at ] 2keep r> r> + >r >r [ heads set-at ] 2keep r> r> pick over >r >r (grow-lr) r> r> - swap heads get delete-at + swap heads delete-at dup pos>> pos set ans>> ; inline @@ -156,7 +169,7 @@ C: peg-head :: setup-lr ( r l -- ) l head>> [ - r V{ } clone V{ } clone l (>>head) + r V{ } clone V{ } clone peg-head boa l (>>head) ] unless r l lrstack get (setup-lr) ; @@ -179,11 +192,11 @@ C: peg-head :: recall ( r p -- memo-entry ) [let* | m [ p r memo ] - h [ p heads get at ] + h [ p heads at ] | h [ m r h involved-set>> h rule>> suffix member? not and [ - fail p + fail p memo-entry boa ] [ r h eval-set>> member? [ h [ r swap remove ] change-eval-set drop @@ -201,8 +214,8 @@ C: peg-head :: apply-non-memo-rule ( r p -- ast ) [let* | - lr [ fail r f lrstack get ] - m [ lr lrstack set lr p dup p r set-memo ] + lr [ fail r f lrstack get left-recursion boa ] + m [ lr lrstack set lr p memo-entry boa dup p r set-memo ] ans [ r eval-rule ] | lrstack get next>> lrstack set @@ -224,10 +237,15 @@ C: peg-head nip ] if ; +USE: prettyprint + : apply-rule ( r p -- ast ) +! 2dup [ rule-id ] dip 2array "apply-rule: " write . 2dup recall [ +! " memoed" print nip apply-memo-rule ] [ +! " not memoed" print apply-non-memo-rule ] if* ; inline @@ -238,8 +256,8 @@ C: peg-head 0 pos set f lrstack set V{ } clone error-stack set - H{ } clone heads set - H{ } clone packrat set + H{ } clone \ heads set + H{ } clone \ packrat set ] H{ } make-assoc swap bind ; inline @@ -258,7 +276,7 @@ GENERIC: (compile) ( peg -- quot ) : parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - gensym 2dup swap peg>> (compile) 0 1 define-declared swap dupd "peg" set-word-prop + gensym 2dup swap peg>> (compile) 0 1 define-declared swap dupd id>> "peg-id" set-word-prop [ execute-parser ] curry ; : compiled-parser ( parser -- word ) From 2ed0d561aef1338abf2f0ad1f34990e0360c66fe Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 9 Jul 2008 14:26:11 +1200 Subject: [PATCH 37/42] Store peg rules by their id rather than word in left recursion handling --- extra/peg/peg.factor | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 9540b1fd70..11d36f032c 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -93,8 +93,8 @@ reset-pegs #! pos = the position in the input string of this entry TUPLE: memo-entry ans pos ; -TUPLE: left-recursion seed rule head next ; -TUPLE: peg-head rule involved-set eval-set ; +TUPLE: left-recursion seed rule-id head next ; +TUPLE: peg-head rule-id involved-set eval-set ; : rule-id ( word -- id ) #! A rule is the parser compiled down to a word. It has @@ -123,15 +123,15 @@ TUPLE: peg-head rule involved-set eval-set ; #! stack effect ( -- parse-result ) pos get swap execute process-rule-result ; inline -: memo ( pos rule -- memo-entry ) +: memo ( pos id -- memo-entry ) #! Return the result from the memo cache. - rule-id packrat at + packrat at ! " memo result " write dup . ; -: set-memo ( memo-entry pos rule -- ) +: set-memo ( memo-entry pos id -- ) #! Store an entry in the cache - rule-id packrat set-at ; + packrat set-at ; : update-m ( ast m -- ) swap >>ans pos get >>pos drop ; @@ -163,13 +163,13 @@ TUPLE: peg-head rule involved-set eval-set ; :: (setup-lr) ( r l s -- ) s head>> l head>> eq? [ l head>> s (>>head) - l head>> [ s rule>> suffix ] change-involved-set drop + l head>> [ s rule-id>> suffix ] change-involved-set drop r l s next>> (setup-lr) ] unless ; :: setup-lr ( r l -- ) l head>> [ - r V{ } clone V{ } clone peg-head boa l (>>head) + r rule-id V{ } clone V{ } clone peg-head boa l (>>head) ] unless r l lrstack get (setup-lr) ; @@ -177,7 +177,7 @@ TUPLE: peg-head rule involved-set eval-set ; [let* | h [ m ans>> head>> ] | - h rule>> r eq? [ + h rule-id>> r rule-id eq? [ m ans>> seed>> m (>>ans) m ans>> failed? [ fail @@ -191,15 +191,15 @@ TUPLE: peg-head rule involved-set eval-set ; :: recall ( r p -- memo-entry ) [let* | - m [ p r memo ] + m [ p r rule-id memo ] h [ p heads at ] | h [ - m r h involved-set>> h rule>> suffix member? not and [ + m r rule-id h involved-set>> h rule-id>> suffix member? not and [ fail p memo-entry boa ] [ - r h eval-set>> member? [ - h [ r swap remove ] change-eval-set drop + r rule-id h eval-set>> member? [ + h [ r rule-id swap remove ] change-eval-set drop r eval-rule m update-m m @@ -214,8 +214,8 @@ TUPLE: peg-head rule involved-set eval-set ; :: apply-non-memo-rule ( r p -- ast ) [let* | - lr [ fail r f lrstack get left-recursion boa ] - m [ lr lrstack set lr p memo-entry boa dup p r set-memo ] + lr [ fail r rule-id f lrstack get left-recursion boa ] + m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ] ans [ r eval-rule ] | lrstack get next>> lrstack set From 2a1aa7b019bd386312c7fe7dc6d4119490ddecce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Jul 2008 23:41:45 -0500 Subject: [PATCH 38/42] Conversation scope work in progress --- extra/furnace/actions/actions.factor | 36 +++--- extra/furnace/alloy/alloy.factor | 14 +-- extra/furnace/asides/asides.factor | 104 ------------------ extra/furnace/auth/auth.factor | 14 ++- extra/furnace/auth/basic/basic.factor | 4 +- .../deactivate-user/deactivate-user.factor | 5 +- .../features/edit-profile/edit-profile.factor | 10 +- extra/furnace/auth/login/login.factor | 22 ++-- .../conversations/conversations.factor | 81 +++++++++----- extra/furnace/flash/flash.factor | 61 ---------- extra/furnace/sessions/sessions.factor | 2 +- extra/http/http-tests.factor | 4 +- .../redirection/redirection-tests.factor | 3 +- extra/webapps/blogs/blogs.factor | 2 +- 14 files changed, 114 insertions(+), 248 deletions(-) delete mode 100644 extra/furnace/asides/asides.factor delete mode 100644 extra/furnace/flash/flash.factor diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index ad8a36cca5..d42972c360 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -7,7 +7,8 @@ xml.entities http.server http.server.responses furnace -furnace.flash +furnace.redirection +furnace.conversations html.forms html.elements html.components @@ -38,20 +39,23 @@ TUPLE: action rest authorize init display validate submit ; : ( -- action ) action new-action ; +: merge-forms ( form -- ) + form get + [ [ errors>> ] bi@ push-all ] + [ [ values>> ] bi@ swap update ] + [ swap validation-failed>> >>validation-failed drop ] + 2tri ; + : set-nested-form ( form name -- ) dup empty? [ - drop form set + drop merge-forms ] [ - dup length 1 = [ - first set-value - ] [ - unclip [ set-nested-form ] nest-form - ] if + unclip [ set-nested-form ] nest-form ] if ; : restore-validation-errors ( -- ) - form fget [ - nested-forms fget set-nested-form + form cget [ + nested-forms cget set-nested-form ] when* ; : handle-get ( action -- response ) @@ -75,11 +79,13 @@ TUPLE: action rest authorize init display validate submit ; revalidate-url-key param dup [ >url [ same-host? ] keep and ] when ; -: validation-failed ( flashed -- * ) - post-request? revalidate-url and dup [ - nested-forms-key param " " split harvest nested-forms set - swap { form nested-forms } append - ] [ 2drop <400> ] if +: validation-failed ( -- * ) + post-request? revalidate-url and [ + begin-conversation + nested-forms-key param " " split harvest nested-forms cset + form get form cset + + ] [ <400> ] if* exit-with ; : handle-post ( action -- response ) @@ -112,7 +118,7 @@ M: action modify-form drop url get revalidate-url-key hidden-form-field ; : check-validation ( -- ) - validation-failed? [ { } validation-failed ] when ; + validation-failed? [ validation-failed ] when ; : validate-params ( validators -- ) params get swap validate-values check-validation ; diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor index 28c34e6715..29cb37b557 100644 --- a/extra/furnace/alloy/alloy.factor +++ b/extra/furnace/alloy/alloy.factor @@ -1,26 +1,24 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences db.tuples alarms calendar db fry -furnace.cache -furnace.asides -furnace.flash -furnace.sessions -furnace.referrer furnace.db +furnace.cache +furnace.referrer +furnace.sessions +furnace.conversations furnace.auth.providers furnace.auth.login.permits ; IN: furnace.alloy : ( responder db params -- responder' ) '[ - - + , , ] call ; -: state-classes { session flash-scope aside permit } ; inline +: state-classes { session conversation permit } ; inline : init-furnace-tables ( -- ) state-classes ensure-tables diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor deleted file mode 100644 index 6d41c637c6..0000000000 --- a/extra/furnace/asides/asides.factor +++ /dev/null @@ -1,104 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces sequences arrays kernel -assocs hashtables math.parser urls combinators -logging db.types db.tuples -html.elements -html.templates.chloe.syntax -http -http.server -http.server.filters -furnace -furnace.cache -furnace.sessions -furnace.redirection ; -IN: furnace.asides - -TUPLE: aside < server-state session method url post-data ; - -: