From 8bb9429589055b51434a8147a5b1ddb93313253e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 26 Jan 2009 15:47:52 -0800 Subject: [PATCH 01/75] ensure accumulator comes back as a vector from literals --- extra/literals/literals-tests.factor | 6 ++++++ extra/literals/literals.factor | 6 +++--- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor index 185d672dd3..34ea4d6415 100644 --- a/extra/literals/literals-tests.factor +++ b/extra/literals/literals-tests.factor @@ -11,4 +11,10 @@ IN: literals.tests [ { 7 11 } ] [ { $ seven-eleven } ] unit-test [ { 6 6 6 } ] [ { $ six-six-six } ] unit-test +[ { 6 6 6 7 } ] [ { $ six-six-six 7 } ] unit-test + [ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test + +[ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test + +[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index a450c2118e..6df51a35ef 100644 --- a/extra/literals/literals.factor +++ b/extra/literals/literals.factor @@ -1,6 +1,6 @@ ! (c) Joe Groff, see license for details -USING: continuations kernel parser words quotations ; +USING: continuations kernel parser words quotations vectors ; IN: literals -: $ scan-word [ execute ] curry with-datastack ; parsing -: $[ \ ] parse-until >quotation with-datastack ; parsing +: $ scan-word [ execute ] curry with-datastack >vector ; parsing +: $[ \ ] parse-until >quotation with-datastack >vector ; parsing From dceae3df93ccaecb84f67d17444acd756933a2d6 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 27 Jan 2009 23:15:08 +0100 Subject: [PATCH 02/75] FUEL: Better handling of scaped characters inside strings. --- misc/fuel/fuel-syntax.el | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 7f3e0c46f5..ad5a025a88 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -233,16 +233,11 @@ ;; Default is word constituent (dotimes (i 256) (modify-syntax-entry i "w" table)) - ;; Whitespace (TAB is not whitespace) (modify-syntax-entry ?\f " " table) (modify-syntax-entry ?\r " " table) (modify-syntax-entry ?\ " " table) (modify-syntax-entry ?\n " " table) - - ;; Char quote - (modify-syntax-entry ?\\ "/" table) - table)) (defconst fuel-syntax--syntactic-keywords @@ -254,9 +249,9 @@ (" \\((\\)( \\([^\n]*\\) )\\()\\)\\( \\|\n\\)" (1 "b")) (" \\((\\) \\([^\n]*\\) \\()\\)\\( \\|\n\\)" (1 "b")) ;; Strings - ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)[^\n\r\f]*?\\(\"\\)\\( \\|\n\\)" - (3 "\"") (4 "\"")) - ("\\(\"\\)[^\n\r\f]*?\\(\"\\)\\( \\|\n\\|$\\)" (1 "\"") (2 "\"")) + ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" + (3 "\"") (5 "\"")) + ("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\"")) ("\\_<<\\(\"\\)\\_>" (1 "\\_>" (1 ">b")) ;; Multiline constructs From ac1ddfcc6c1670c2042ea1aeb4c71f03b3a04cab Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 27 Jan 2009 16:54:41 -0600 Subject: [PATCH 03/75] Random minor fixes; html.components doesn't duplicate parsing anymore --- basis/eval/eval-tests.factor | 2 +- basis/html/components/components.factor | 22 +++++++++++++--------- basis/xml/data/data.factor | 3 +++ basis/xml/writer/writer-tests.factor | 1 + basis/xml/writer/writer.factor | 3 +++ basis/xmode/code2html/code2html.factor | 2 +- 6 files changed, 22 insertions(+), 11 deletions(-) diff --git a/basis/eval/eval-tests.factor b/basis/eval/eval-tests.factor index db4b95acdc..675921944a 100644 --- a/basis/eval/eval-tests.factor +++ b/basis/eval/eval-tests.factor @@ -1,4 +1,4 @@ IN: eval.tests USING: eval tools.test ; -[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-testv \ No newline at end of file +[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index c8a4b20ca7..e63447ec55 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -3,7 +3,7 @@ USING: accessors kernel namespaces io math.parser assocs classes classes.tuple words arrays sequences splitting mirrors hashtables combinators continuations math strings inspector -fry locals calendar calendar.format xml.entities +fry locals calendar calendar.format xml.entities xml.data validators urls present xml.writer xml.interpolate xml xmode.code2html lcs.diff2html farkup io.streams.string html.elements html.streams html.forms ; @@ -65,12 +65,15 @@ TUPLE: textarea rows cols ; : XML] ; +M:: textarea render* ( value name area -- xml ) + area rows>> :> rows + area cols>> :> cols + [XML + + XML] ; ! Choice TUPLE: choice size multiple choices ; @@ -160,8 +163,9 @@ M: farkup render* SINGLETON: inspector M: inspector render* - 2drop [ [ describe ] with-html-writer ] with-string-writer - string>xml-chunk ; + 2drop [ + [ describe ] with-html-writer + ] with-string-writer ; ! Diff component SINGLETON: comparison diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index c44250035a..5dc13adf16 100644 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -219,3 +219,6 @@ PREDICATE: open-tag < tag children>> ; UNION: xml-data tag comment string directive instruction ; + +TUPLE: unescaped string ; +C: unescaped diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index 2d3a90cc15..e9959c1ef4 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -59,3 +59,4 @@ IN: xml.writer.tests [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test [ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test +[ "" ] [ "" xml-chunk>string ] unit-test diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index a19fe69444..8e2dc4bfbf 100644 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -98,6 +98,9 @@ M: open-tag write-xml-chunk } cleave ] dip xml-pprint? set ; +M: unescaped write-xml-chunk + string>> write ; + M: comment write-xml-chunk "" write ; diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor index 4cdef4043e..962b0e9fbf 100644 --- a/basis/xmode/code2html/code2html.factor +++ b/basis/xmode/code2html/code2html.factor @@ -15,7 +15,7 @@ IN: xmode.code2html tokenize-line htmlize-tokens ; : htmlize-lines ( lines mode -- xml ) - f -rot load-mode [ htmlize-line ] curry map nip ; + [ f ] 2dip load-mode [ htmlize-line ] curry map nip ; : default-stylesheet ( -- xml ) "resource:basis/xmode/code2html/stylesheet.css" From 69c509a29f32aed9040516f9a893d55e35b4641b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 27 Jan 2009 18:16:35 -0600 Subject: [PATCH 04/75] Removing outdated comments in xml.utilities --- basis/xml/utilities/utilities.factor | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor index 60460e3f46..48cbeceb22 100644 --- a/basis/xml/utilities/utilities.factor +++ b/basis/xml/utilities/utilities.factor @@ -19,10 +19,6 @@ IN: xml.utilities : first-child-tag ( tag -- tag ) children>> [ tag? ] find nip ; -! * Accessing part of an XML document -! for tag- words, a start means that it searches all children -! and no star searches only direct children - : tag-named? ( name elem -- ? ) dup tag? [ names-match? ] [ 2drop f ] if ; @@ -36,8 +32,6 @@ IN: xml.utilities tags@ '[ _ swap tag-named? ] deep-filter ; : tag-named ( tag name/string -- matching-tag ) - ! like get-name-tag but only looks at direct children, - ! not all the children down the tree. assure-name swap [ tag-named? ] with find nip ; : tags-named ( tag name/string -- tags-seq ) @@ -58,7 +52,7 @@ IN: xml.utilities : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq ) tags@ '[ _ _ tag-with-attr? ] deep-filter ; -: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) +: get-id ( tag id -- elem ) "id" deep-tag-with-attr ; : deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags ) From fcb56cf6dbe80832c7ae47350f883529196c8790 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 27 Jan 2009 18:42:17 -0600 Subject: [PATCH 05/75] Factored out io.crlf --- basis/base64/base64.factor | 4 ++-- basis/http/http.factor | 8 +------- basis/io/crlf/crlf-docs.factor | 12 ++++++++++++ basis/io/crlf/crlf.factor | 11 +++++++++++ basis/smtp/server/server.factor | 2 +- basis/smtp/smtp.factor | 8 +------- 6 files changed, 28 insertions(+), 17 deletions(-) create mode 100644 basis/io/crlf/crlf-docs.factor create mode 100644 basis/io/crlf/crlf.factor diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index e5972991e5..a1668e7ce9 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators io io.binary io.encodings.binary io.streams.byte-array io.streams.string kernel math namespaces -sequences strings ; +sequences strings io.crlf ; IN: base64 , ; IN: http -: crlf ( -- ) "\r\n" write ; - -: read-crlf ( -- bytes ) - "\r" read-until - [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; - : (read-header) ( -- alist ) [ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ; diff --git a/basis/io/crlf/crlf-docs.factor b/basis/io/crlf/crlf-docs.factor new file mode 100644 index 0000000000..ac7c8c324e --- /dev/null +++ b/basis/io/crlf/crlf-docs.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup sequences ; +IN: io.crlf + +HELP: crlf +{ $values } +{ $description "Prints a carriage return and line feed to the current output stream, used to indicate a newline for certain network protocols." } ; + +HELP: read-crlf +{ $values { "seq" sequence } } +{ $description "Reads until the next CRLF (carriage return followed by line feed) from the current input stream, throwing an error if there is not a CRLF remaining, or if CR is present without immediately being followed by LF." } ; diff --git a/basis/io/crlf/crlf.factor b/basis/io/crlf/crlf.factor new file mode 100644 index 0000000000..53dddce199 --- /dev/null +++ b/basis/io/crlf/crlf.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: io kernel ; +IN: io.crlf + +: crlf ( -- ) + "\r\n" write ; + +: read-crlf ( -- seq ) + "\r" read-until + [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor index f986404404..5d7791292b 100644 --- a/basis/smtp/server/server.factor +++ b/basis/smtp/server/server.factor @@ -4,7 +4,7 @@ USING: combinators kernel prettyprint io io.timeouts sequences namespaces io.sockets io.sockets.secure continuations calendar io.encodings.ascii io.streams.duplex destructors locals concurrency.promises threads accessors smtp.private -io.sockets.secure.unix.debug ; +io.sockets.secure.unix.debug io.crlf ; IN: smtp.server ! Mock SMTP server for testing purposes. diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 2ffc2e6db3..03b9d8af11 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -6,7 +6,7 @@ io.encodings.utf8 io.timeouts io.sockets io.sockets.secure io.encodings.ascii kernel logging sequences combinators splitting assocs strings math.order math.parser random system calendar summary calendar.format accessors sets hashtables -base64 debugger classes prettyprint ; +base64 debugger classes prettyprint io.crlf ; IN: smtp SYMBOL: smtp-domain @@ -50,12 +50,6 @@ TUPLE: email Date: Tue, 27 Jan 2009 18:43:20 -0600 Subject: [PATCH 06/75] Summary and author for io.crlf --- basis/io/crlf/authors.txt | 2 ++ basis/io/crlf/summary.txt | 1 + 2 files changed, 3 insertions(+) create mode 100644 basis/io/crlf/authors.txt create mode 100644 basis/io/crlf/summary.txt diff --git a/basis/io/crlf/authors.txt b/basis/io/crlf/authors.txt new file mode 100644 index 0000000000..33616a2d6a --- /dev/null +++ b/basis/io/crlf/authors.txt @@ -0,0 +1,2 @@ +Daniel Ehrenberg +Slava Pestov diff --git a/basis/io/crlf/summary.txt b/basis/io/crlf/summary.txt new file mode 100644 index 0000000000..2fa6a6e2c1 --- /dev/null +++ b/basis/io/crlf/summary.txt @@ -0,0 +1 @@ +Writing and reading until \r\n From 9b57ff6540fe656c256aa38f35c50d301d4594cd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 12:16:00 -0600 Subject: [PATCH 07/75] Fix typo in GENERIC# docs --- core/syntax/syntax-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index c99c226a0c..e08821bddd 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -557,7 +557,7 @@ HELP: GENERIC: HELP: GENERIC# { $syntax "GENERIC# word n" } -{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on, either 0, 1 or 2" } } +{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } } { $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } { $notes "The following two definitions are equivalent:" From 371b919abc8fc5b174fd0922970d38c831d1f346 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 12:29:25 -0600 Subject: [PATCH 08/75] Quoted printable vocab --- basis/base64/tags.txt | 2 + basis/quoted-printable/authors.txt | 1 + .../quoted-printable-docs.factor | 27 ++++++++ .../quoted-printable-tests.factor | 30 +++++++++ .../quoted-printable/quoted-printable.factor | 62 +++++++++++++++++++ basis/quoted-printable/summary.txt | 1 + basis/quoted-printable/tags.txt | 2 + 7 files changed, 125 insertions(+) create mode 100644 basis/base64/tags.txt create mode 100644 basis/quoted-printable/authors.txt create mode 100644 basis/quoted-printable/quoted-printable-docs.factor create mode 100644 basis/quoted-printable/quoted-printable-tests.factor create mode 100644 basis/quoted-printable/quoted-printable.factor create mode 100644 basis/quoted-printable/summary.txt create mode 100644 basis/quoted-printable/tags.txt diff --git a/basis/base64/tags.txt b/basis/base64/tags.txt new file mode 100644 index 0000000000..8fd3eccc9a --- /dev/null +++ b/basis/base64/tags.txt @@ -0,0 +1,2 @@ +parsing +web diff --git a/basis/quoted-printable/authors.txt b/basis/quoted-printable/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/basis/quoted-printable/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/basis/quoted-printable/quoted-printable-docs.factor b/basis/quoted-printable/quoted-printable-docs.factor new file mode 100644 index 0000000000..81219a3f84 --- /dev/null +++ b/basis/quoted-printable/quoted-printable-docs.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax strings byte-arrays io.encodings.string ; +IN: quoted-printable + +ABOUT: "quoted-printable" + +ARTICLE: "quoted-printable" "Quoted printable encoding" +"The " { $vocab-link "quoted-printable" } " vocabulary implements RFC 2045 part 6.7, providing words for reading and generating quotable printed text." +{ $subsection >quoted } +{ $subsection >quoted-lines } +{ $subsection quoted> } ; + +HELP: >quoted +{ $values { "byte-array" byte-array } { "string" string } } +{ $description "Encodes a byte array as quoted printable, on a single line." } +{ $warning "To encode a string in quoted printable, first use the " { $link encode } " word." } ; + +HELP: >quoted-lines +{ $values { "byte-array" byte-array } { "string" string } } +{ $description "Encodes a byte array as quoted printable, with soft line breaks inserted so the output lines are no longer than 76 characters." } +{ $warning "To encode a string in quoted printable, first use the " { $link encode } " word with a specific encoding." } ; + +HELP: quoted> +{ $values { "string" string } { "byte-array" byte-array } } +{ $description "Decodes a quoted printable string into an array of the bytes represented." } +{ $warning "When decoding something in quoted printable form and using it as a string, be sure to use the " { $link decode } " word rather than simply converting the byte array to a string." } ; diff --git a/basis/quoted-printable/quoted-printable-tests.factor b/basis/quoted-printable/quoted-printable-tests.factor new file mode 100644 index 0000000000..6f42a48b37 --- /dev/null +++ b/basis/quoted-printable/quoted-printable-tests.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test quoted-printable multiline io.encodings.string +sequences io.encodings.8-bit splitting kernel ; +IN: quoted-printable.tests + +[ <" José was the +person who knew how to write the letters: + ő and ü +and we didn't know hów tö do thât"> ] +[ <" Jos=E9 was the +person who knew how to write the letters: + =F5 and =FC=20 +and w= +e didn't know h=F3w t=F6 do th=E2t"> quoted> latin2 decode ] unit-test + +[ <" Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t"> ] +[ <" José was the +person who knew how to write the letters: + ő and ü +and we didn't know hów tö do thât"> latin2 encode >quoted ] unit-test + +: message ( -- str ) + 55 [ "hello" ] replicate concat ; + +[ f ] [ message >quoted "=\r\n" swap subseq? ] unit-test +[ 1 ] [ message >quoted string-lines length ] unit-test +[ t ] [ message >quoted-lines "=\r\n" swap subseq? ] unit-test +[ 4 ] [ message >quoted-lines string-lines length ] unit-test +[ "===o" ] [ message >quoted-lines string-lines [ peek ] "" map-as ] unit-test diff --git a/basis/quoted-printable/quoted-printable.factor b/basis/quoted-printable/quoted-printable.factor new file mode 100644 index 0000000000..83fee523a0 --- /dev/null +++ b/basis/quoted-printable/quoted-printable.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: sequences strings kernel io.encodings.string +math.order ascii math io io.encodings.utf8 io.streams.string +combinators.short-circuit math.parser arrays ; +IN: quoted-printable + +! This implements RFC 2045 section 6.7 + + CHAR: ~ between? ] + [ CHAR: \t = ] + } 1|| ; + +: char>quoted ( ch -- str ) + dup printable? [ 1string ] [ + assure-small >hex >upper + 2 CHAR: 0 pad-left + CHAR: = prefix + ] if ; + +: take-some ( seqs -- seqs seq ) + 0 over [ length + dup 76 >= ] find drop nip + [ 1- cut-slice swap ] [ f swap ] if* concat ; + +: divide-lines ( strings -- strings ) + [ dup ] [ take-some ] [ ] produce nip ; + +PRIVATE> + +: >quoted ( byte-array -- string ) + [ char>quoted ] { } map-as concat "" like ; + +: >quoted-lines ( byte-array -- string ) + [ char>quoted ] { } map-as + divide-lines "=\r\n" join ; + + ] if + ] when ; + +: read-quoted ( -- bytes ) + [ read1 dup ] [ read-char ] [ drop ] B{ } produce-as ; + +PRIVATE> + +: quoted> ( string -- byte-array ) + ! Input should already be normalized to make \r\n into \n + [ read-quoted ] with-string-reader ; diff --git a/basis/quoted-printable/summary.txt b/basis/quoted-printable/summary.txt new file mode 100644 index 0000000000..c32ac1fc80 --- /dev/null +++ b/basis/quoted-printable/summary.txt @@ -0,0 +1 @@ +Quoted printable encoding/decoding diff --git a/basis/quoted-printable/tags.txt b/basis/quoted-printable/tags.txt new file mode 100644 index 0000000000..8fd3eccc9a --- /dev/null +++ b/basis/quoted-printable/tags.txt @@ -0,0 +1,2 @@ +parsing +web From af9d70c65ad67e46e18cb7d5edb37f23c260e667 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 14:33:33 -0600 Subject: [PATCH 09/75] XML chunks are a separate datatype; XML tags are no longer assocs --- basis/syndication/syndication.factor | 6 +++--- basis/xml/data/data.factor | 20 +++++++++++++------ basis/xml/elements/elements.factor | 7 ++++--- .../xml/interpolate/interpolate-tests.factor | 4 ++-- basis/xml/interpolate/interpolate.factor | 3 ++- basis/xml/tests/test.factor | 15 ++++++++------ basis/xml/tests/xmltest.factor | 12 ++++++----- basis/xml/writer/writer-tests.factor | 1 - basis/xml/xml.factor | 3 ++- basis/xmode/loader/loader.factor | 4 ++-- basis/xmode/marker/marker.factor | 2 +- 11 files changed, 46 insertions(+), 31 deletions(-) diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index fadb4f4fb3..58b2279cb1 100644 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -70,8 +70,8 @@ TUPLE: entry title url description date ; tri ; : atom-entry-link ( tag -- url/f ) - "link" tags-named [ "rel" swap at "alternate" = ] find nip - dup [ "href" swap at >url ] when ; + "link" tags-named [ "rel" attr "alternate" = ] find nip + dup [ "href" attr >url ] when ; : atom1.0-entry ( tag -- entry ) entry new @@ -95,7 +95,7 @@ TUPLE: entry title url description date ; feed new swap [ "title" tag-named children>string >>title ] - [ "link" tag-named "href" swap at >url >>url ] + [ "link" tag-named "href" attr >url >>url ] [ "entry" tags-named [ atom1.0-entry ] map set-entries ] tri ; diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 5dc13adf16..74ad348bab 100644 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -150,9 +150,11 @@ TUPLE: tag [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri* tag boa ; -! For convenience, tags follow the assoc protocol too (for attrs) -CONSULT: assoc-protocol tag attrs>> ; -INSTANCE: tag assoc +: attr ( tag name -- string ) + swap attrs>> at ; + +: set-attr ( tag value name -- ) + rot attrs>> set-at ; ! They also follow the sequence protocol (for children) CONSULT: sequence-protocol tag children>> ; @@ -217,8 +219,14 @@ M: xml like PREDICATE: contained-tag < tag children>> not ; PREDICATE: open-tag < tag children>> ; -UNION: xml-data - tag comment string directive instruction ; - TUPLE: unescaped string ; C: unescaped + +UNION: xml-data + tag comment string directive instruction unescaped ; + +TUPLE: xml-chunk seq ; +C: xml-chunk + +CONSULT: sequence-protocol xml-chunk seq>> ; +INSTANCE: xml-chunk sequence diff --git a/basis/xml/elements/elements.factor b/basis/xml/elements/elements.factor index 57e91cc24e..116acb076b 100644 --- a/basis/xml/elements/elements.factor +++ b/basis/xml/elements/elements.factor @@ -65,11 +65,12 @@ IN: xml.elements dup { "1.0" "1.1" } member? [ bad-version ] unless ; : prolog-version ( alist -- version ) - T{ name f "" "version" f } swap at + T{ name { space "" } { main "version" } } swap at [ good-version ] [ versionless-prolog ] if* ; : prolog-encoding ( alist -- encoding ) - T{ name f "" "encoding" f } swap at "UTF-8" or ; + T{ name { space "" } { main "encoding" } } swap at + "UTF-8" or ; : yes/no>bool ( string -- t/f ) { @@ -79,7 +80,7 @@ IN: xml.elements } case ; : prolog-standalone ( alist -- version ) - T{ name f "" "standalone" f } swap at + T{ name { space "" } { main "standalone" } } swap at [ yes/no>bool ] [ f ] if* ; : prolog-attrs ( alist -- prolog ) diff --git a/basis/xml/interpolate/interpolate-tests.factor b/basis/xml/interpolate/interpolate-tests.factor index 817cb453fa..4a7c64dd16 100644 --- a/basis/xml/interpolate/interpolate-tests.factor +++ b/basis/xml/interpolate/interpolate-tests.factor @@ -2,14 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test xml.interpolate multiline kernel assocs sequences accessors xml.writer xml.interpolate.private -locals splitting urls ; +locals splitting urls xml.data ; IN: xml.interpolate.tests [ "a" "c" { "a" "c" f } ] [ "<-a->/><->" string>doc [ second var>> ] - [ fourth "val" swap at var>> ] + [ fourth "val" attr var>> ] [ extract-variables ] tri ] unit-test diff --git a/basis/xml/interpolate/interpolate.factor b/basis/xml/interpolate/interpolate.factor index 0b3bb15456..b9535fba39 100644 --- a/basis/xml/interpolate/interpolate.factor +++ b/basis/xml/interpolate/interpolate.factor @@ -33,8 +33,9 @@ M: string push-item , ; M: xml-data push-item , ; M: object push-item present , ; M: sequence push-item - [ dup array? [ % ] [ , ] if ] each ; + dup xml-data? [ , ] [ [ push-item ] each ] if ; M: number push-item present , ; +M: xml-chunk push-item % ; GENERIC: interpolate-item ( table item -- ) M: object interpolate-item nip , ; diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index e3a7fdbc7a..97793f2ab2 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -19,7 +19,7 @@ SYMBOL: xml-file [ "a" ] [ xml-file get space>> ] unit-test [ "http://www.hello.com" ] [ xml-file get url>> ] unit-test [ "that" ] [ - xml-file get T{ name f "" "this" "http://d.de" } swap at + xml-file get T{ name f "" "this" "http://d.de" } attr ] unit-test [ t ] [ xml-file get children>> second contained-tag? ] unit-test [ "" string>xml ] [ xml-error? ] must-fail-with @@ -30,7 +30,7 @@ SYMBOL: xml-file xml-file get after>> [ instruction? ] find nip text>> ] unit-test [ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test -[ "that" ] [ xml-file get "this" swap at ] unit-test +[ "that" ] [ xml-file get "this" attr ] unit-test [ "abcd" ] [ "
abcd
" string>xml [ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make @@ -43,9 +43,11 @@ SYMBOL: xml-file "foo" string>xml "c" get-id children>string ] unit-test -[ "foo" ] [ "" string>xml "y" over - at swap "z" [ tuck ] dip swap set-at - T{ name f "blah" "z" f } swap at ] unit-test +[ "foo" ] [ + "" string>xml + dup dup "y" attr "z" set-attr + T{ name { space "blah" } { main "z" } } attr +] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test [ "" string>xml ] must-fail [ ] [ "" string>xml drop ] unit-test @@ -58,5 +60,6 @@ SYMBOL: xml-file [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first ] unit-test [ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first ] unit-test [ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test -[ "x" "<" ] [ "" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test +[ "x" "<" ] [ "" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test [ "foo" ] [ "]>&bar;" string>xml children>string ] unit-test +[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index 8caa5e8a75..a6a28e15a3 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -1,16 +1,16 @@ USING: accessors assocs combinators continuations fry generalizations io.pathnames kernel macros sequences stack-checker tools.test xml -xml.utilities xml.writer arrays ; +xml.utilities xml.writer arrays xml.data ; IN: xml.tests.suite TUPLE: xml-test id uri sections description type ; : >xml-test ( tag -- test ) xml-test new swap { - [ "TYPE" swap at >>type ] - [ "ID" swap at >>id ] - [ "URI" swap at >>uri ] - [ "SECTIONS" swap at >>sections ] + [ "TYPE" attr >>type ] + [ "ID" attr >>id ] + [ "URI" attr >>uri ] + [ "SECTIONS" attr >>sections ] [ children>> xml-chunk>string >>description ] } cleave ; @@ -51,3 +51,5 @@ MACRO: drop-input ( quot -- newquot ) : failing-valids ( -- tests ) partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ; + +[ ] [ partition-xml-tests 2drop ] unit-test diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index e9959c1ef4..dcf7f1023d 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -52,7 +52,6 @@ IN: xml.writer.tests &foo;"} pprint-reprints-as [ t ] [ "" dup string>xml-chunk xml-chunk>string = ] unit-test -[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test [ "" ] [ "" string>xml xml>string ] unit-test [ "bar baz" ] diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index b043d5771e..5369b04d9c 100644 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -162,7 +162,8 @@ PRIVATE> : read-xml-chunk ( stream -- seq ) 1 depth - [ (read-xml-chunk) nip ] with-variable ; + [ (read-xml-chunk) nip ] with-variable + ; : string>xml ( string -- xml ) t string-input? diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor index 8639c93e71..64c4234bd3 100644 --- a/basis/xmode/loader/loader.factor +++ b/basis/xmode/loader/loader.factor @@ -13,10 +13,10 @@ TAG: PROPS parse-props-tag >>props drop ; TAG: IMPORT - "DELEGATE" swap at swap import-rule-set ; + "DELEGATE" attr swap import-rule-set ; TAG: TERMINATE - "AT_CHAR" swap at string>number >>terminate-char drop ; + "AT_CHAR" attr string>number >>terminate-char drop ; RULE: SEQ seq-rule shared-tag-attrs delegate-attr literal-start ; diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index 798807f198..5d10d2ed02 100644 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -297,7 +297,7 @@ M: mark-previous-rule handle-rule-start : tokenize-line ( line-context line rules -- line-context' seq ) [ - "MAIN" swap at -rot + "MAIN" attr -rot init-token-marker mark-token-loop mark-remaining From f438bd5157f32c4dea0d6c5220ae9492fc3a1fb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 15:04:36 -0600 Subject: [PATCH 10/75] Better handling of wrappers in locals --- basis/locals/locals-tests.factor | 4 +++- basis/locals/rewrite/sugar/sugar.factor | 11 ++++++----- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 982674694a..e3aa504fbc 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -494,4 +494,6 @@ M:: integer lambda-method-forget-test ( a -- b ) ; ! Discovered by littledan [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test -[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test \ No newline at end of file +[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test + +[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test \ No newline at end of file diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index 835fa6e421..6e7e156ced 100644 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -37,7 +37,7 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ; M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; -M: wrapper rewrite-literal? drop t ; +M: wrapper rewrite-literal? wrapped>> rewrite-literal? ; M: hashtable rewrite-literal? drop t ; @@ -53,7 +53,7 @@ GENERIC: rewrite-element ( obj -- ) [ rewrite-element ] each ; : rewrite-sequence ( seq -- ) - [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ; + [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ; M: array rewrite-element dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; @@ -63,7 +63,7 @@ M: vector rewrite-element rewrite-sequence ; M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; M: tuple rewrite-element - [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ; + [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ; M: quotation rewrite-element rewrite-sugar* ; @@ -84,7 +84,7 @@ M: local-word rewrite-element M: word rewrite-element literalize , ; M: wrapper rewrite-element - dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; + dup rewrite-literal? [ wrapped>> rewrite-element \ literalize , ] [ , ] if ; M: object rewrite-element , ; @@ -98,7 +98,8 @@ M: def rewrite-sugar* , ; M: hashtable rewrite-sugar* rewrite-element ; -M: wrapper rewrite-sugar* rewrite-element ; +M: wrapper rewrite-sugar* + dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; M: word rewrite-sugar* dup { load-locals get-local drop-locals } memq? From 16181f818b5ad90dade709e8c48f2bcf2b5641bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 15:07:16 -0600 Subject: [PATCH 11/75] Clean up functors so that the generated code looks sane with 'see' --- basis/functors/functors-tests.factor | 2 +- basis/functors/functors.factor | 33 ++++++++++-- basis/io/mmap/functor/functor.factor | 4 +- basis/math/blas/cblas/tags.txt | 1 - basis/math/blas/matrices/matrices.factor | 26 +++++----- basis/math/blas/matrices/tags.txt | 1 - basis/math/blas/syntax/syntax.factor | 2 +- basis/math/blas/syntax/tags.txt | 1 - basis/math/blas/vectors/tags.txt | 1 - basis/math/blas/vectors/vectors.factor | 52 +++++++++---------- .../specialized-arrays/functor/functor.factor | 6 +-- .../functor/functor.factor | 10 ++-- 12 files changed, 80 insertions(+), 59 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 39923afee7..577debd398 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -34,7 +34,7 @@ WW DEFINES ${W}${W} WHERE -: WW W twice ; inline +: WW ( a -- b ) \ W twice ; inline ;FUNCTOR diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 28bedc8360..b13ee8ff7c 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,17 +1,42 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel quotations classes.tuple make combinators generic words interpolate namespaces sequences io.streams.string fry classes.mixin effects lexer parser classes.tuple.parser effects.parser locals.types locals.parser -locals.rewrite.closures vocabs.parser ; +locals.rewrite.closures vocabs.parser arrays accessors ; IN: functors +! This is a hack + : scan-param ( -- obj ) scan-object dup special? [ literalize ] unless ; : define* ( word def effect -- ) pick set-word define-declared ; +TUPLE: fake-quotation seq ; + +GENERIC: >fake-quotations ( quot -- fake ) + +M: callable >fake-quotations + >array >fake-quotations fake-quotation boa ; + +M: array >fake-quotations [ >fake-quotations ] { } map-as ; + +M: object >fake-quotations ; + +GENERIC: fake-quotations> ( fake -- quot ) + +M: fake-quotation fake-quotations> + seq>> [ fake-quotations> ] map >quotation ; + +M: array fake-quotations> [ fake-quotations> ] map ; + +M: object fake-quotations> ; + +: parse-definition* ( -- ) + parse-definition >fake-quotations parsed \ fake-quotations> parsed ; + : DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ; : `TUPLE: @@ -32,7 +57,7 @@ IN: functors scan-param parsed scan-param parsed \ create-method parsed - parse-definition parsed + parse-definition* DEFINE* ; parsing : `C: @@ -45,7 +70,7 @@ IN: functors : `: effect off scan-param parsed - parse-definition parsed + parse-definition* DEFINE* ; parsing : `INSTANCE: diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor index 4587a75fd9..954d8b43c7 100644 --- a/basis/io/mmap/functor/functor.factor +++ b/basis/io/mmap/functor/functor.factor @@ -20,9 +20,9 @@ with-mapped-A-file DEFINES with-mapped-${T}-file WHERE : ( mapped-file -- direct-array ) - T mapped-file>direct execute ; inline + T mapped-file>direct ; inline : with-mapped-A-file ( path length quot -- ) - '[ execute @ ] with-mapped-file ; inline + '[ @ ] with-mapped-file ; inline ;FUNCTOR diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/cblas/tags.txt +++ b/basis/math/blas/cblas/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 75ab07709a..f6b98e3ae2 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -268,28 +268,28 @@ TUPLE: MATRIX < blas-matrix-base ; M: MATRIX element-type drop TYPE ; M: MATRIX (blas-matrix-like) - drop execute ; + drop ; M: VECTOR (blas-matrix-like) - drop execute ; + drop ; M: MATRIX (blas-vector-like) - drop execute ; + drop ; : >MATRIX ( arrays -- matrix ) - [ >ARRAY execute underlying>> ] (>matrix) - execute ; + [ >ARRAY underlying>> ] (>matrix) + ; M: VECTOR n*M.V+n*V! - [ TYPE>ARG execute ] (prepare-gemv) - [ XGEMV execute ] dip ; + [ TYPE>ARG ] (prepare-gemv) + [ XGEMV ] dip ; M: MATRIX n*M.M+n*M! - [ TYPE>ARG execute ] (prepare-gemm) - [ XGEMM execute ] dip ; + [ TYPE>ARG ] (prepare-gemm) + [ XGEMM ] dip ; M: MATRIX n*V(*)V+M! - [ TYPE>ARG execute ] (prepare-ger) - [ XGERU execute ] dip ; + [ TYPE>ARG ] (prepare-ger) + [ XGERU ] dip ; M: MATRIX n*V(*)Vconj+M! - [ TYPE>ARG execute ] (prepare-ger) - [ XGERC execute ] dip ; + [ TYPE>ARG ] (prepare-ger) + [ XGERC ] dip ; ;FUNCTOR diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/syntax/syntax.factor b/basis/math/blas/syntax/syntax.factor index 95f9f7bd08..2d171a801b 100644 --- a/basis/math/blas/syntax/syntax.factor +++ b/basis/math/blas/syntax/syntax.factor @@ -1,5 +1,5 @@ USING: kernel math.blas.vectors math.blas.matrices parser -arrays prettyprint.backend sequences ; +arrays prettyprint.backend prettyprint.custom sequences ; IN: math.blas.syntax : svector{ diff --git a/basis/math/blas/syntax/tags.txt b/basis/math/blas/syntax/tags.txt index 6a932d96d2..ede10ab61b 100644 --- a/basis/math/blas/syntax/tags.txt +++ b/basis/math/blas/syntax/tags.txt @@ -1,2 +1 @@ math -unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index 6a932d96d2..ede10ab61b 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1,2 +1 @@ math -unportable diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index db027b0ffd..c86fa30115 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -144,26 +144,26 @@ TUPLE: VECTOR < blas-vector-base ; : ( underlying length inc -- vector ) VECTOR boa ; inline : >VECTOR ( seq -- v ) - [ >ARRAY execute underlying>> ] [ length ] bi 1 execute ; + [ >ARRAY underlying>> ] [ length ] bi 1 ; M: VECTOR clone TYPE heap-size (prepare-copy) - [ XCOPY execute ] 3dip execute ; + [ XCOPY ] 3dip ; M: VECTOR element-type drop TYPE ; M: VECTOR Vswap - (prepare-swap) [ XSWAP execute ] 2dip ; + (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX execute ; + (prepare-nrm2) IXAMAX ; M: VECTOR (blas-vector-like) - drop execute ; + drop ; M: VECTOR (blas-direct-array) [ underlying>> ] [ [ length>> ] [ inc>> ] bi * ] bi - execute ; + ; ;FUNCTOR @@ -180,17 +180,17 @@ XSCAL IS cblas_${T}scal WHERE M: VECTOR V. - (prepare-dot) XDOT execute ; + (prepare-dot) XDOT ; M: VECTOR V.conj - (prepare-dot) XDOT execute ; + (prepare-dot) XDOT ; M: VECTOR Vnorm - (prepare-nrm2) XNRM2 execute ; + (prepare-nrm2) XNRM2 ; M: VECTOR Vasum - (prepare-nrm2) XASUM execute ; + (prepare-nrm2) XASUM ; M: VECTOR n*V+V! - (prepare-axpy) [ XAXPY execute ] dip ; + (prepare-axpy) [ XAXPY ] dip ; M: VECTOR n*V! - (prepare-scal) [ XSCAL execute ] dip ; + (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR @@ -207,13 +207,13 @@ COMPLEX>ARG DEFINES ${TYPE}-complex>arg WHERE : ( alien len -- sequence ) - 1 shift execute ; + 1 shift ; : >COMPLEX-ARRAY ( sequence -- sequence ) - >ARRAY execute ; + >ARRAY ; : COMPLEX>ARG ( complex -- alien ) - >rect 2array >ARRAY execute underlying>> ; + >rect 2array >ARRAY underlying>> ; : ARG>COMPLEX ( alien -- complex ) - 2 execute first2 rect> ; + 2 first2 rect> ; ;FUNCTOR @@ -234,22 +234,22 @@ WHERE M: VECTOR V. (prepare-dot) TYPE - [ XDOTU_SUB execute ] keep - ARG>TYPE execute ; + [ XDOTU_SUB ] keep + ARG>TYPE ; M: VECTOR V.conj (prepare-dot) TYPE - [ XDOTC_SUB execute ] keep - ARG>TYPE execute ; + [ XDOTC_SUB ] keep + ARG>TYPE ; M: VECTOR Vnorm - (prepare-nrm2) XXNRM2 execute ; + (prepare-nrm2) XXNRM2 ; M: VECTOR Vasum - (prepare-nrm2) XXASUM execute ; + (prepare-nrm2) XXASUM ; M: VECTOR n*V+V! - [ TYPE>ARG execute ] 2dip - (prepare-axpy) [ XAXPY execute ] dip ; + [ TYPE>ARG ] 2dip + (prepare-axpy) [ XAXPY ] dip ; M: VECTOR n*V! - [ TYPE>ARG execute ] dip - (prepare-scal) [ XSCAL execute ] dip ; + [ TYPE>ARG ] dip + (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 579da5b84a..718a1a7aa1 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -49,9 +49,9 @@ M: A set-nth-unsafe underlying>> SET-NTH call ; : >A ( seq -- specialized-array ) A new clone-like ; inline -M: A like drop dup A instance? [ >A execute ] unless ; +M: A like drop dup A instance? [ >A ] unless ; -M: A new-sequence drop (A) execute ; +M: A new-sequence drop (A) ; M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; @@ -70,7 +70,7 @@ M: A >pprint-sequence ; M: A pprint* pprint-object ; -: A{ \ } [ >A execute ] parse-literal ; parsing +: A{ \ } [ >A ] parse-literal ; parsing INSTANCE: A sequence diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 6069a4cb4a..e6f1986874 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -18,16 +18,16 @@ WHERE TUPLE: V { underlying A } { length array-capacity } ; -: ( capacity -- vector ) execute 0 V boa ; inline +: ( capacity -- vector ) 0 V boa ; inline M: V like drop dup V instance? [ - dup A instance? [ dup length V boa ] [ >V execute ] if + dup A instance? [ dup length V boa ] [ >V ] if ] unless ; -M: V new-sequence drop [ execute ] [ >fixnum ] bi V boa ; +M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; -M: A new-resizable drop execute ; +M: A new-resizable drop ; M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; @@ -39,7 +39,7 @@ M: V >pprint-sequence ; M: V pprint* pprint-object ; -: V{ \ } [ >V execute ] parse-literal ; parsing +: V{ \ } [ >V ] parse-literal ; parsing INSTANCE: V growable From 1a409b92138cf072f876fbf622a657ced8fda59a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 15:46:04 -0600 Subject: [PATCH 12/75] Fix specialized-arrays.direct.functor --- basis/specialized-arrays/direct/functor/functor.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 14fb739947..ce23186fc6 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -27,8 +27,8 @@ TUPLE: A M: A length length>> ; M: A nth-unsafe underlying>> NTH call ; M: A set-nth-unsafe underlying>> SET-NTH call ; -M: A like drop dup A instance? [ >A' execute ] unless ; -M: A new-sequence drop execute ; +M: A like drop dup A instance? [ >A' ] unless ; +M: A new-sequence drop ; INSTANCE: A sequence From d5160ce79198521f8ad3eb00776849d53331ab6b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 15:46:34 -0600 Subject: [PATCH 13/75] Fixing USING: lines --- basis/http/client/client.factor | 2 +- basis/http/server/server.factor | 1 + basis/xml/data/data.factor | 7 ++----- basis/xmode/marker/marker.factor | 2 +- 4 files changed, 5 insertions(+), 7 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index edfc6e312b..e7305ed372 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -5,7 +5,7 @@ sequences strings splitting calendar continuations accessors vectors math.order hashtables byte-arrays destructors io io.sockets io.streams.string io.files io.timeouts io.pathnames io.encodings io.encodings.string io.encodings.ascii -io.encodings.utf8 io.encodings.8-bit io.encodings.binary +io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf io.streams.duplex fry ascii urls urls.encoding present http http.parsers http.client.post-data ; IN: http.client diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index c9ec2c7f3e..b4af727caa 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -14,6 +14,7 @@ io.encodings.binary io.streams.limited io.servers.connection io.timeouts +io.crlf fry logging logging.insomniac calendar urls urls.encoding mime.multipart unicode.categories diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 74ad348bab..6cd975d42d 100644 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -150,10 +150,10 @@ TUPLE: tag [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri* tag boa ; -: attr ( tag name -- string ) +: attr ( tag/xml name -- string ) swap attrs>> at ; -: set-attr ( tag value name -- ) +: set-attr ( tag/xml value name -- ) rot attrs>> set-at ; ! They also follow the sequence protocol (for children) @@ -188,9 +188,6 @@ C: xml CONSULT: sequence-protocol xml body>> ; INSTANCE: xml sequence -CONSULT: assoc-protocol xml body>> ; -INSTANCE: xml assoc - CONSULT: tag xml body>> ; CONSULT: name xml body>> ; diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index 5d10d2ed02..ce942fbc67 100644 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -5,7 +5,7 @@ USING: kernel namespaces make xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities xmode.catalog sequences math assocs combinators strings parser-combinators.regexp splitting parser-combinators ascii -ascii combinators.short-circuit accessors ; +ascii combinators.short-circuit accessors xml.data ; ! Based on org.gjt.sp.jedit.syntax.TokenMarker From 940a0853252387c18c0cf9a8a1e946511b66cca9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 16:17:20 -0600 Subject: [PATCH 14/75] XML interpolation efficiency/cleanup --- .../xml/interpolate/interpolate-tests.factor | 15 ++++++-- basis/xml/interpolate/interpolate.factor | 38 ++++++++++--------- 2 files changed, 32 insertions(+), 21 deletions(-) diff --git a/basis/xml/interpolate/interpolate-tests.factor b/basis/xml/interpolate/interpolate-tests.factor index 4a7c64dd16..35c4e793ea 100644 --- a/basis/xml/interpolate/interpolate-tests.factor +++ b/basis/xml/interpolate/interpolate-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test xml.interpolate multiline kernel assocs sequences accessors xml.writer xml.interpolate.private -locals splitting urls xml.data ; +locals splitting urls xml.data classes ; IN: xml.interpolate.tests [ "a" "c" { "a" "c" f } ] [ @@ -54,6 +54,15 @@ IN: xml.interpolate.tests [ "3" ] [ 3 [XML <-> XML] xml-chunk>string ] unit-test [ "" ] [ f [XML <-> XML] xml-chunk>string ] unit-test -\ parse-def must-infer -[ "" interpolate-chunk ] must-infer +\ <-> /> XML] ] must-infer + +[ xml-chunk ] [ [ [XML XML] ] first class ] unit-test +[ xml ] [ [ XML> ] first class ] unit-test +[ xml-chunk ] [ [ [XML /> XML] ] third class ] unit-test +[ xml ] [ [ /> XML> ] third class ] unit-test +[ 1 ] [ [ [XML XML] ] length ] unit-test +[ 1 ] [ [ XML> ] length ] unit-test + +[ "" ] [ [XML XML] concat ] unit-test diff --git a/basis/xml/interpolate/interpolate.factor b/basis/xml/interpolate/interpolate.factor index b9535fba39..e28e83e47f 100644 --- a/basis/xml/interpolate/interpolate.factor +++ b/basis/xml/interpolate/interpolate.factor @@ -64,14 +64,18 @@ M: interpolated interpolate-item : number<-> ( doc -- dup ) 0 over [ - dup var>> [ over >>var [ 1+ ] dip ] unless drop + dup var>> [ + over >>var [ 1+ ] dip + ] unless drop ] each-interpolated drop ; -MACRO: interpolate-xml ( string -- doc ) - string>doc number<-> '[ _ interpolate-xml-doc ] ; +GENERIC: interpolate-xml ( table xml -- xml ) -MACRO: interpolate-chunk ( string -- chunk ) - string>chunk number<-> '[ _ interpolate-sequence ] ; +M: xml interpolate-xml + interpolate-xml-doc ; + +M: xml-chunk interpolate-xml + interpolate-sequence ; : >search-hash ( seq -- hash ) [ dup search ] H{ } map>assoc ; @@ -82,26 +86,24 @@ MACRO: interpolate-chunk ( string -- chunk ) : nenum ( ... n -- assoc ) narray ; inline -: collect ( accum seq -- accum ) +: collect ( accum variables -- accum ? ) { - { [ dup [ ] all? ] [ >search-hash parsed ] } ! locals - { [ dup [ not ] all? ] [ ! fry - length parsed \ nenum parsed - ] } + { [ dup empty? ] [ drop f ] } ! Just a literal + { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals + { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry [ drop "XML interpolation contains both fry and locals" throw ] ! mixed } cond ; -: parse-def ( accum delimiter word -- accum ) - [ - parse-multiline-string but-last - [ string>chunk extract-variables collect ] keep - parsed - ] dip parsed ; +: parse-def ( accum delimiter quot -- accum ) + [ parse-multiline-string 1 short head* ] dip call + [ extract-variables collect ] keep swap + [ number<-> parsed ] dip + [ \ interpolate-xml parsed ] when ; inline PRIVATE> : " \ interpolate-xml parse-def ; parsing + "XML>" [ string>doc ] parse-def ; parsing : [XML - "XML]" \ interpolate-chunk parse-def ; parsing + "XML]" [ string>chunk ] parse-def ; parsing From 88e8b95cf7ef4a3a39554ef1f4332611adcc34c0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 16:25:41 -0600 Subject: [PATCH 15/75] Reverting xmode.marker (it's not using XML!) --- basis/xmode/marker/marker.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index ce942fbc67..798807f198 100644 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -5,7 +5,7 @@ USING: kernel namespaces make xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities xmode.catalog sequences math assocs combinators strings parser-combinators.regexp splitting parser-combinators ascii -ascii combinators.short-circuit accessors xml.data ; +ascii combinators.short-circuit accessors ; ! Based on org.gjt.sp.jedit.syntax.TokenMarker @@ -297,7 +297,7 @@ M: mark-previous-rule handle-rule-start : tokenize-line ( line-context line rules -- line-context' seq ) [ - "MAIN" attr -rot + "MAIN" swap at -rot init-token-marker mark-token-loop mark-remaining From 4de41f94e91529b828bbbeab690c18525a20beda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 17:07:31 -0600 Subject: [PATCH 16/75] Fixing wrappers with locals --- basis/functors/functors-tests.factor | 18 ++++++++++++++++++ basis/functors/functors.factor | 11 +++++++++-- basis/locals/locals-docs.factor | 6 ++++-- basis/locals/locals-tests.factor | 6 +++++- basis/locals/rewrite/sugar/sugar.factor | 10 +++++++--- basis/locals/types/types.factor | 9 +++++++-- .../specialized-arrays/functor/functor.factor | 2 +- core/quotations/quotations-docs.factor | 4 ++++ core/syntax/syntax.factor | 2 +- 9 files changed, 56 insertions(+), 12 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 577debd398..a5f3042b38 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -45,3 +45,21 @@ WHERE \ sqsq must-infer [ 16 ] [ 2 sqsq ] unit-test + +<< + +FUNCTOR: wrapper-test-2 ( W -- ) + +W DEFINES ${W} + +WHERE + +: W ( a b -- c ) \ + execute ; + +;FUNCTOR + +"blah" wrapper-test-2 + +>> + +[ 4 ] [ 1 3 blah ] unit-test \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index b13ee8ff7c..f4d35b6932 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -9,8 +9,9 @@ IN: functors ! This is a hack -: scan-param ( -- obj ) - scan-object dup special? [ literalize ] unless ; + ; [ scan interpolate-locals ] dip '[ _ with-string-writer @ ] parsed ; +PRIVATE> + : IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing : DEFINES [ create-in ] (INTERPOLATE) ; parsing DEFER: ;FUNCTOR delimiter + rewrite-closures first ; +PRIVATE> + : FUNCTOR: (FUNCTOR:) define ; parsing diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index efaad748cf..a4a9ca448b 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -113,7 +113,7 @@ HELP: MEMO:: { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words -ARTICLE: "locals-literals" "Locals in array and hashtable literals" +ARTICLE: "locals-literals" "Locals in literals" "Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables." $nl "The data types which receive this special handling are the following:" @@ -122,7 +122,9 @@ $nl { $link "hashtables" } { $link "vectors" } { $link "tuples" } + { $link "wrappers" } } +{ $heading "Object identity" } "This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:" { $example "IN: scratchpad" @@ -143,7 +145,7 @@ $nl "f" } "One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time." -$nl +{ $heading "Example" } "For example, here is an implementation of the " { $link 3array } " word which uses this feature:" { $code ":: 3array ( x y z -- array ) { x y z } ;" } ; diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index e3aa504fbc..bd9e7cf103 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -496,4 +496,8 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test [ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test -[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test \ No newline at end of file +[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test + +[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test + +[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test \ No newline at end of file diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index 6e7e156ced..515473c467 100644 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -81,10 +81,14 @@ M: local-writer rewrite-element M: local-word rewrite-element local-word-in-literal-error ; -M: word rewrite-element literalize , ; +M: word rewrite-element , ; + +: rewrite-wrapper ( wrapper -- ) + dup rewrite-literal? + [ wrapped>> rewrite-element ] [ , ] if ; M: wrapper rewrite-element - dup rewrite-literal? [ wrapped>> rewrite-element \ literalize , ] [ , ] if ; + rewrite-wrapper \ , ; M: object rewrite-element , ; @@ -99,7 +103,7 @@ M: def rewrite-sugar* , ; M: hashtable rewrite-sugar* rewrite-element ; M: wrapper rewrite-sugar* - dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; + rewrite-wrapper ; M: word rewrite-sugar* dup { load-locals get-local drop-locals } memq? diff --git a/basis/locals/types/types.factor b/basis/locals/types/types.factor index 7a8dac1947..3ed753e094 100644 --- a/basis/locals/types/types.factor +++ b/basis/locals/types/types.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators kernel sequences words ; +USING: accessors combinators kernel sequences words +quotations ; IN: locals.types TUPLE: lambda vars body ; @@ -38,6 +39,8 @@ PREDICATE: local < word "local?" word-prop ; f dup t "local?" set-word-prop ; +M: local literalize ; + PREDICATE: local-word < word "local-word?" word-prop ; : ( name -- word ) @@ -49,6 +52,8 @@ PREDICATE: local-reader < word "local-reader?" word-prop ; f dup t "local-reader?" set-word-prop ; +M: local-reader literalize ; + PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 718a1a7aa1..9a56346be4 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -64,7 +64,7 @@ M: A resize M: A byte-length underlying>> length ; -M: A pprint-delims drop A{ \ } ; +M: A pprint-delims drop \ A{ \ } ; M: A >pprint-sequence ; diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 1a16d0f92a..f2629a36c4 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -14,6 +14,10 @@ $nl "Quotations implement the " { $link "sequence-protocol" } ", and existing sequences can be converted into quotations:" { $subsection >quotation } { $subsection 1quotation } +"Wrappers:" +{ $subsection "wrappers" } ; + +ARTICLE: "wrappers" "Wrappers" "Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:" { $subsection wrapper } { $subsection literalize } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index c81fc9201e..af5fa38aeb 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -103,7 +103,7 @@ IN: bootstrap.syntax "W{" [ \ } [ first ] parse-literal ] define-syntax "POSTPONE:" [ scan-word parsed ] define-syntax - "\\" [ scan-word literalize parsed ] define-syntax + "\\" [ scan-word parsed ] define-syntax "inline" [ word make-inline ] define-syntax "recursive" [ word make-recursive ] define-syntax "foldable" [ word make-foldable ] define-syntax From 9dc60a552dfcf56d08e70eb7e00d04284d670c1e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 17:18:14 -0600 Subject: [PATCH 17/75] Fixing xmode bug --- basis/xmode/utilities/utilities.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/xmode/utilities/utilities.factor b/basis/xmode/utilities/utilities.factor index 871767ccf5..d6407d8180 100644 --- a/basis/xmode/utilities/utilities.factor +++ b/basis/xmode/utilities/utilities.factor @@ -22,7 +22,7 @@ IN: xmode.utilities ] } { [ dup length 3 = ] [ first3 '[ - _ tag get at + tag get _ attr _ [ execute ] when* object get _ execute ] ] } From dcad3ad2258ab2b026fdfb9a2f06e18a6315e9c7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 17:49:21 -0600 Subject: [PATCH 18/75] Un-breaking Chloe --- .../html/templates/chloe/compiler/compiler.factor | 8 ++++---- basis/html/templates/chloe/syntax/syntax.factor | 14 +++++++------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 331b565b98..4410cd7599 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -7,16 +7,16 @@ html.templates html.templates.chloe.syntax continuations ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = ] assoc-filter ; + [ drop chloe-name? ] assoc-filter ; : non-chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = not ] assoc-filter ; + [ drop chloe-name? not ] assoc-filter ; : chloe-tag? ( tag -- ? ) dup xml? [ body>> ] when { { [ dup tag? not ] [ f ] } - { [ dup url>> chloe-ns = not ] [ f ] } + { [ dup chloe-name? not ] [ f ] } [ t ] } cond nip ; @@ -49,7 +49,7 @@ DEFER: compile-element reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ; : compile-attrs ( assoc -- ) - [ + attrs>> [ " " [write] swap name>string [write] "=\"" [write] diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index 90c171917b..fb457ff1df 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -21,14 +21,14 @@ tags global [ H{ } clone or ] change-at : chloe-ns "http://factorcode.org/chloe/1.0" ; inline -: chloe-name ( string -- name ) - name new - swap >>main - chloe-ns >>url ; +: chloe-name? ( name -- ? ) + url>> chloe-ns = ; + +XML-NS: chloe-name http://factorcode.org/chloe/1.0 : required-attr ( tag name -- value ) - dup chloe-name rot at* - [ nip ] [ drop " attribute is required" append throw ] if ; + tuck chloe-name attr + [ nip ] [ " attribute is required" append throw ] if* ; : optional-attr ( tag name -- value ) - chloe-name swap at ; + chloe-name attr ; From dc49f138c4a684e84e3a8758e89db35372f9e1fc Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 18:21:37 -0600 Subject: [PATCH 19/75] Fix to xmode --- basis/xmode/catalog/catalog.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index f8f1788bcf..8a8e5fad4a 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -1,6 +1,6 @@ USING: xmode.loader xmode.utilities xmode.rules namespaces strings splitting assocs sequences kernel io.files xml memoize -words globs combinators io.encodings.utf8 sorting accessors ; +words globs combinators io.encodings.utf8 sorting accessors xml.data ; IN: xmode.catalog TUPLE: mode file file-name-glob first-line-glob ; @@ -8,7 +8,7 @@ TUPLE: mode file file-name-glob first-line-glob ; >file) } { "FILE_NAME_GLOB" f (>>file-name-glob) } From e5760bf64428db4e650b6b0c9bb554093e99b8b3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 18:48:07 -0600 Subject: [PATCH 20/75] Slava is a hack, and specialized-vectors might work now --- basis/specialized-vectors/functor/functor.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index e6f1986874..2410cc284e 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -33,7 +33,7 @@ M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; : >V ( seq -- vector ) V new clone-like ; inline -M: V pprint-delims drop V{ \ } ; +M: V pprint-delims drop \ V{ \ } ; M: V >pprint-sequence ; From 41af194074bc56a5534dd5e69f31edcc68d6e074 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 19:19:25 -0600 Subject: [PATCH 21/75] Update io.files docs --- core/io/files/files-docs.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 7948a2e912..263b5c19b0 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -22,16 +22,19 @@ ABOUT: "io.files" HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an input stream" } } { $description "Outputs an input stream for reading from the specified pathname using the given encoding." } +{ $notes "Most code should use " { $link with-file-reader } " instead, to ensure the stream is properly disposed of after." } { $errors "Throws an error if the file is unreadable." } ; HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } { $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." } +{ $notes "Most code should use " { $link with-file-writer } " instead, to ensure the stream is properly disposed of after." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } { $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." } +{ $notes "Most code should use " { $link with-file-appender } " instead, to ensure the stream is properly disposed of after." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: with-file-reader From a45c91659ac4e0185998b53add41a613d6012804 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 23:33:10 -0600 Subject: [PATCH 22/75] Update mmap docs --- basis/io/mmap/mmap-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index bd971656d4..5ef3400a6d 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -19,6 +19,7 @@ HELP: HELP: with-mapped-file { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } { $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; HELP: close-mapped-file From 87e0110ff15b92169a2d985b5fd805342de7b339 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 23:33:26 -0600 Subject: [PATCH 23/75] O(1) equal? and hashcode* for ranges --- basis/math/ranges/ranges-tests.factor | 8 ++++++-- basis/math/ranges/ranges.factor | 10 ++++++++-- core/classes/tuple/tuple.factor | 24 ++++++++++++++---------- 3 files changed, 28 insertions(+), 14 deletions(-) diff --git a/basis/math/ranges/ranges-tests.factor b/basis/math/ranges/ranges-tests.factor index 825c68d1b9..aedd2f7933 100644 --- a/basis/math/ranges/ranges-tests.factor +++ b/basis/math/ranges/ranges-tests.factor @@ -1,4 +1,4 @@ -USING: math.ranges sequences tools.test arrays ; +USING: math math.ranges sequences sets tools.test arrays ; IN: math.ranges.tests [ { } ] [ 1 1 (a,b) >array ] unit-test @@ -11,7 +11,7 @@ IN: math.ranges.tests [ { 1 } ] [ 1 2 [a,b) >array ] unit-test [ { 1 2 } ] [ 1 2 [a,b] >array ] unit-test -[ { } ] [ 2 1 (a,b) >array ] unit-test +[ { } ] [ 2 1 (a,b) >array ] unit-test [ { 1 } ] [ 2 1 (a,b] >array ] unit-test [ { 2 } ] [ 2 1 [a,b) >array ] unit-test [ { 2 1 } ] [ 2 1 [a,b] >array ] unit-test @@ -32,3 +32,7 @@ IN: math.ranges.tests [ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test [ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test [ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test + +[ 100 ] [ + 1 100 [a,b] [ 2^ [1,b] ] map prune length +] unit-test \ No newline at end of file diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 1a28904705..068f599b6f 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel layouts math math.order namespaces sequences -sequences.private accessors ; +sequences.private accessors classes.tuple arrays ; IN: math.ranges TUPLE: range @@ -18,6 +18,12 @@ M: range length ( seq -- n ) M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; +! For ranges with many elements, the default element-wise methods +! sequences define are unsuitable because they're O(n) +M: range equal? over range? [ tuple= ] [ 2drop f ] if ; + +M: range hashcode* tuple-hashcode ; + INSTANCE: range immutable-sequence : twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 3ee9b8e40b..4f40d838b7 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -79,16 +79,16 @@ M: tuple-class slots>tuple ERROR: bad-superclass class ; - ] ?if ; From 3e685b2eb44c027cb5a2e9bb8ab832dedef77531 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 28 Jan 2009 23:35:41 -0600 Subject: [PATCH 24/75] Add test case for bug discovered by erg --- basis/compiler/tests/codegen.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 8ee120012d..bb3f9d6aa7 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -276,3 +276,9 @@ TUPLE: id obj ; [ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test [ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test + +SINGLETON: cucumber + +M: cucumber equal? "The cucumber has no equal" throw ; + +[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test \ No newline at end of file From 1e5259198ce6cb10fc8ee0fd89a955ca163579b4 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 23:45:00 -0600 Subject: [PATCH 25/75] Fixing Farkup tests --- basis/farkup/farkup-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index ee09486a03..49c4dab0db 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: farkup kernel peg peg.ebnf tools.test namespaces xml -urls.encoding assocs xml.utilities ; +urls.encoding assocs xml.utilities xml.data ; IN: farkup.tests relative-link-prefix off @@ -161,7 +161,7 @@ link-no-follow? off : check-link-escaping ( string -- link ) convert-farkup string>xml-chunk - "a" deep-tag-named "href" swap at url-decode ; + "a" deep-tag-named "href" attr url-decode ; [ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test [ "" ] [ "[[]]" check-link-escaping ] unit-test From 391d6db9fe57287a2c2168d1574962d1649378af Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 23:45:12 -0600 Subject: [PATCH 26/75] Cleaning up Unicode docs --- basis/unicode/collation/collation-docs.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/basis/unicode/collation/collation-docs.factor b/basis/unicode/collation/collation-docs.factor index 183ca85b69..990390e82f 100644 --- a/basis/unicode/collation/collation-docs.factor +++ b/basis/unicode/collation/collation-docs.factor @@ -1,11 +1,12 @@ -USING: help.syntax help.markup strings byte-arrays ; +USING: help.syntax help.markup strings byte-arrays math.order ; IN: unicode.collation ARTICLE: "unicode.collation" "Collation and weak comparison" -"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:" +"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are useful for collation directly:" { $subsection sort-strings } { $subsection collation-key } { $subsection string<=> } +"Predicates for weak equality testing:" { $subsection primary= } { $subsection secondary= } { $subsection tertiary= } @@ -14,12 +15,12 @@ ARTICLE: "unicode.collation" "Collation and weak comparison" ABOUT: "unicode.collation" HELP: sort-strings -{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } } -{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ; +{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in lexicographical order" } } +{ $description "This word takes a sequence of strings and sorts them according to the Unicode Collation Algorithm with the default collation order described in the DUCET. It uses code point order as a tie-breaker." } ; HELP: collation-key { $values { "string" string } { "key" byte-array } } -{ $description "This takes a string and gives a representation of the collation key, which can be compared with <=>" } ; +{ $description "This takes a string and gives a representation of the collation key, which can be compared with " { $link <=> } ". The representation is according to the DUCET." } ; HELP: string<=> { $values { "str1" string } { "str2" string } { "<=>" "one of +lt+, +gt+ or +eq+" } } @@ -27,16 +28,16 @@ HELP: string<=> HELP: primary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "This checks whether the first level of collation is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation and accent marks." } ; +{ $description "This checks whether the first level of collation key is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation, whitespace and accent marks." } ; HELP: secondary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "This checks whether the first two levels of collation are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to primary=." } ; +{ $description "This checks whether the first two levels of collation key are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to " { $link primary= } "." } ; HELP: tertiary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "Along the same lines as secondary=, but case is significant." } ; +{ $description "This checks if the first three levels of collation key are equal. For Latin-based scripts, it can be understood as testing for what " { $link secondary= } " tests for, but case is significant." } ; HELP: quaternary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "This is similar to tertiary= but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ; +{ $description "This checks if the first four levels of collation key are equal. This is similar to " { $link tertiary= } " but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ; From 356ee5ced57cd51c383f03917529b3922bd36717 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 23:56:47 -0600 Subject: [PATCH 27/75] Fixing xmode? --- basis/xmode/loader/syntax/syntax.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index 9b53000e02..f63191d5f6 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -31,7 +31,7 @@ SYMBOL: ignore-case? ! PROP, PROPS : parse-prop-tag ( tag -- key value ) - "NAME" over at "VALUE" rot at ; + [ "NAME" attr ] [ "VALUE" attr ] bi ; : parse-props-tag ( tag -- assoc ) child-tags @@ -40,7 +40,7 @@ SYMBOL: ignore-case? : position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? ) ! XXX Wrong logic! { "AT_LINE_START" "AT_WHITESPACE_END" "AT_WORD_START" } - swap [ at string>boolean ] curry map first3 ; + [ attr string>boolean ] with map first3 ; : parse-literal-matcher ( tag -- matcher ) dup children>string From d684e24ee8891571790203e0da57b543a85da74a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 00:08:40 -0600 Subject: [PATCH 28/75] file-contents and set-file-contents deal in sequences, not strings --- core/io/files/files-docs.factor | 10 +++++----- core/io/files/files-tests.factor | 7 +++---- core/io/files/files.factor | 6 +++--- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 263b5c19b0..cf0aea787b 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io strings arrays io.backend -io.files.private quotations ; +io.files.private quotations sequences ; IN: io.files ARTICLE: "io.files" "Reading and writing files" @@ -63,13 +63,13 @@ HELP: file-lines { $errors "Throws an error if the file cannot be opened for reading." } ; HELP: set-file-contents -{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } } -{ $description "Sets the contents of a file to a string with the given encoding." } +{ $values { "seq" sequence } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } } +{ $description "Sets the contents of a file to a sequence with the given encoding." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: file-contents -{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } } -{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" sequence } } +{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a sequence." } { $errors "Throws an error if the file cannot be opened for reading." } ; { set-file-lines file-lines set-file-contents file-contents } related-words diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index d2611d73a9..f9702fd133 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,9 +1,8 @@ USING: tools.test io.files io.files.private io.files.temp io.directories io.encodings.8-bit arrays make system -io.encodings.binary io -threads kernel continuations io.encodings.ascii sequences -strings accessors io.encodings.utf8 math destructors namespaces -; +io.encodings.binary io threads kernel continuations +io.encodings.ascii sequences strings accessors +io.encodings.utf8 math destructors namespaces ; IN: io.files.tests \ exists? must-infer diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 19659ee5bb..1bc282e956 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -25,7 +25,7 @@ HOOK: (file-appender) io-backend ( path -- stream ) : with-file-reader ( path encoding quot -- ) [ ] dip with-input-stream ; inline -: file-contents ( path encoding -- str ) +: file-contents ( path encoding -- seq ) contents ; : with-file-writer ( path encoding quot -- ) @@ -34,7 +34,7 @@ HOOK: (file-appender) io-backend ( path -- stream ) : set-file-lines ( seq path encoding -- ) [ [ print ] each ] with-file-writer ; -: set-file-contents ( str path encoding -- ) +: set-file-contents ( seq path encoding -- ) [ write ] with-file-writer ; : with-file-appender ( path encoding quot -- ) @@ -58,4 +58,4 @@ PRIVATE> 13 getenv cwd prepend-path \ image set-global 14 getenv cwd prepend-path \ vm set-global image parent-directory "resource-path" set-global -] "io.files" add-init-hook \ No newline at end of file +] "io.files" add-init-hook From 31e662043b3c60ea6d2ce903b50834cbf22ad3f9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 Jan 2009 01:44:09 -0600 Subject: [PATCH 29/75] Add unit test for xmode bug discovered by anonymous pastebin user --- basis/xmode/code2html/code2html-tests.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 basis/xmode/code2html/code2html-tests.factor diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor new file mode 100644 index 0000000000..cd11ba50d0 --- /dev/null +++ b/basis/xmode/code2html/code2html-tests.factor @@ -0,0 +1,12 @@ +IN: xmode.code2html.tests +USING: xmode.code2html xmode.catalog +tools.test multiline splitting memoize +kernel ; + +[ ] [ \ (load-mode) reset-memoized ] unit-test + +[ ] [ + <"