From 356ee5ced57cd51c383f03917529b3922bd36717 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 28 Jan 2009 23:56:47 -0600 Subject: [PATCH 01/21] 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 6372395b8a42510e67471043b4c7d39ed4d21ea9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 29 Jan 2009 13:33:04 -0600 Subject: [PATCH 02/21] Fixing everything I broke? --- basis/farkup/farkup.factor | 2 +- basis/html/components/components.factor | 4 +- basis/html/elements/elements.factor | 33 +++-- .../templates/chloe/compiler/compiler.factor | 2 +- basis/http/server/server.factor | 1 + basis/lcs/diff2html/diff2html-tests.factor | 2 +- basis/syndication/syndication.factor | 2 +- basis/xml/errors/errors.factor | 4 +- .../xml/interpolate/interpolate-tests.factor | 4 +- basis/xml/interpolate/interpolate.factor | 4 +- basis/xml/tests/templating.factor | 4 +- basis/xml/tests/xmltest.factor | 2 +- basis/xml/utilities/utilities.factor | 2 +- basis/xml/writer/writer-docs.factor | 45 ++---- basis/xml/writer/writer-tests.factor | 6 +- basis/xml/writer/writer.factor | 128 ++++++++---------- 16 files changed, 108 insertions(+), 137 deletions(-) diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index ccd12b83f2..b9e62717eb 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -236,7 +236,7 @@ M: f (write-farkup) ; parse-farkup (write-farkup) ; : write-farkup ( string -- ) - farkup>xml write-xml-chunk ; + farkup>xml write-xml ; : convert-farkup ( string -- string' ) [ write-farkup ] with-string-writer ; diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index e63447ec55..462c9b3c78 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -19,7 +19,7 @@ GENERIC: render* ( value name renderer -- xml ) [ f swap ] if ] 2dip - render* write-xml-chunk + render* write-xml [ render-error ] when* ; xml-chunk ; +M: html render* 2drop ; diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index 7bca545df5..9e7504d436 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -1,11 +1,9 @@ -! cont-html v0.6 -! -! Copyright (C) 2004 Chris Double. +! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. - USING: io io.styles kernel namespaces prettyprint quotations sequences strings words xml.entities compiler.units effects -urls math math.parser combinators present fry ; +xml.data xml.interpolate urls math math.parser combinators +present fry io.streams.string xml.writer ; IN: html.elements @@ -135,17 +133,18 @@ SYMBOL: html "" write-html ; : simple-page ( title head-quot body-quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. - spin - xhtml-preamble - - - write - call - - call - ; inline + [ with-string-writer ] bi@ + + + + + <-> + <-> + + <-> + + XML> write-xml ; : render-error ( message -- ) - escape-string write ; + [XML <-> XML] write-xml ; diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 4410cd7599..cd5de4ceb6 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -90,7 +90,7 @@ ERROR: unknown-chloe-tag tag ; { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] } { [ dup string? ] [ escape-string [write] ] } { [ dup comment? ] [ drop ] } - [ [ write-xml-chunk ] [code-with] ] + [ [ write-xml ] [code-with] ] } cond ; : with-compiler ( quot -- quot' ) diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index b4af727caa..a886d7bae7 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -12,6 +12,7 @@ io.encodings.utf8 io.encodings.ascii io.encodings.binary io.streams.limited +io.streams.string io.servers.connection io.timeouts io.crlf diff --git a/basis/lcs/diff2html/diff2html-tests.factor b/basis/lcs/diff2html/diff2html-tests.factor index d261a4659a..0c2ed34f45 100644 --- a/basis/lcs/diff2html/diff2html-tests.factor +++ b/basis/lcs/diff2html/diff2html-tests.factor @@ -3,4 +3,4 @@ USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ; IN: lcs.diff2html.tests -[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml-chunk>string drop ] unit-test +[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml>string drop ] unit-test diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index 58b2279cb1..b23910e200 100644 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -81,7 +81,7 @@ TUPLE: entry title url description date ; [ { "content" "summary" } any-tag-named dup children>> [ string? not ] contains? - [ children>> [ write-xml-chunk ] with-string-writer ] + [ children>> xml>string ] [ children>string ] if >>description ] [ diff --git a/basis/xml/errors/errors.factor b/basis/xml/errors/errors.factor index df38724412..304b38f2bd 100644 --- a/basis/xml/errors/errors.factor +++ b/basis/xml/errors/errors.factor @@ -194,7 +194,7 @@ M: bad-prolog summary ( obj -- str ) [ dup call-next-method write "Misplaced XML prolog" print - prolog>> write-prolog nl + prolog>> write-xml nl ] with-string-writer ; TUPLE: capitalized-prolog < xml-error-at name ; @@ -258,7 +258,7 @@ M: misplaced-directive summary ( obj -- str ) [ dup call-next-method write "Misplaced directive:" print - dir>> write-xml-chunk nl + dir>> write-xml nl ] with-string-writer ; TUPLE: bad-name < xml-error-at name ; diff --git a/basis/xml/interpolate/interpolate-tests.factor b/basis/xml/interpolate/interpolate-tests.factor index 35c4e793ea..9be85a11e2 100644 --- a/basis/xml/interpolate/interpolate-tests.factor +++ b/basis/xml/interpolate/interpolate-tests.factor @@ -51,8 +51,8 @@ IN: xml.interpolate.tests false=<-> url=<-> string=<-> word=<->/> XML> pprint-xml>string ] unit-test -[ "3" ] [ 3 [XML <-> XML] xml-chunk>string ] unit-test -[ "" ] [ f [XML <-> XML] xml-chunk>string ] unit-test +[ "3" ] [ 3 [XML <-> XML] xml>string ] unit-test +[ "" ] [ f [XML <-> XML] xml>string ] unit-test \ parsed ] dip [ \ interpolate-xml parsed ] when ; inline diff --git a/basis/xml/tests/templating.factor b/basis/xml/tests/templating.factor index b35d7372e3..618e785d05 100644 --- a/basis/xml/tests/templating.factor +++ b/basis/xml/tests/templating.factor @@ -9,10 +9,10 @@ SYMBOL: ref-table GENERIC: (r-ref) ( xml -- ) M: tag (r-ref) - sub-tag over at* [ + dup sub-tag attr [ ref-table get at >>children drop - ] [ 2drop ] if ; + ] [ drop ] if* ; M: object (r-ref) drop ; : template ( xml -- ) diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index a6a28e15a3..a8024ce151 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -11,7 +11,7 @@ TUPLE: xml-test id uri sections description type ; [ "ID" attr >>id ] [ "URI" attr >>uri ] [ "SECTIONS" attr >>sections ] - [ children>> xml-chunk>string >>description ] + [ children>> xml>string >>description ] } cleave ; : parse-tests ( xml -- tests ) diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor index 48cbeceb22..924ae56aa4 100644 --- a/basis/xml/utilities/utilities.factor +++ b/basis/xml/utilities/utilities.factor @@ -38,7 +38,7 @@ IN: xml.utilities tags@ swap [ tag-named? ] with filter ; : tag-with-attr? ( elem attr-value attr-name -- ? ) - rot dup tag? [ at = ] [ 3drop f ] if ; + rot dup tag? [ swap attr = ] [ 3drop f ] if ; : tag-with-attr ( tag attr-value attr-name -- matching-tag ) assure-name '[ _ _ tag-with-attr? ] find nip ; diff --git a/basis/xml/writer/writer-docs.factor b/basis/xml/writer/writer-docs.factor index b470403e84..a26a7377fd 100644 --- a/basis/xml/writer/writer-docs.factor +++ b/basis/xml/writer/writer-docs.factor @@ -1,56 +1,41 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup io strings ; +USING: help.syntax help.markup io strings xml.data ; IN: xml.writer ABOUT: "xml.writer" ARTICLE: "xml.writer" "Writing XML" - "These words are used in implementing prettyprint" - { $subsection write-xml-chunk } - "These words are used to print XML normally" - { $subsection xml>string } + "These words are used to print XML preserving whitespace in text nodes" { $subsection write-xml } + { $subsection xml>string } "These words are used to prettyprint XML" { $subsection pprint-xml>string } - { $subsection pprint-xml>string-but } { $subsection pprint-xml } - { $subsection pprint-xml-but } ; - -HELP: write-xml-chunk -{ $values { "object" "an XML element" } } -{ $description "writes an XML element to " { $link output-stream } "." } -{ $see-also write-xml-chunk write-xml } ; + "Certain variables can be changed to mainpulate prettyprinting" + { $subsection sensitive-tags } + { $subsection indenter } + "All of these words operate on arbitrary pieces of XML: they can take, as in put, XML documents, comments, tags, strings (text nodes), XML chunks, etc." ; HELP: xml>string -{ $values { "xml" "an xml document" } { "string" "a string" } } -{ $description "converts an XML document into a string" } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; +{ $values { "xml" "an XML document" } { "string" "a string" } } +{ $description "This converts an XML document " { $link xml } " into a string. It can also be used to convert any piece of XML to a string, eg an " { $link xml-chunk } " or " { $link comment } "." } +{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ; HELP: pprint-xml>string -{ $values { "xml" "an xml document" } { "string" "a string" } } +{ $values { "xml" "an XML document" } { "string" "a string" } } { $description "converts an XML document into a string in a prettyprinted form." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; +{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ; HELP: write-xml { $values { "xml" "an XML document" } } { $description "prints the contents of an XML document to " { $link output-stream } "." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; +{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ; HELP: pprint-xml { $values { "xml" "an XML document" } } { $description "prints the contents of an XML document to " { $link output-stream } " in a prettyprinted form." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; +{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. Whitespace is also not preserved." } ; -HELP: pprint-xml-but -{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } } -{ $description "Prettyprints an XML document, leaving the whitespace of the tags with names in sensitive-tags intact." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; - -HELP: pprint-xml>string-but -{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } { "string" string } } -{ $description "Prettyprints an XML document, returning the result as a string and leaving the whitespace of the tags with names in sensitive-tags intact." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; - -{ xml>string write-xml pprint-xml pprint-xml>string pprint-xml>string-but pprint-xml-but } related-words +{ xml>string write-xml pprint-xml pprint-xml>string } related-words diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index dcf7f1023d..d09ae08b3f 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -7,7 +7,7 @@ IN: xml.writer.tests \ write-xml must-infer \ xml>string must-infer \ pprint-xml must-infer -\ pprint-xml-but must-infer +! Add a test for pprint-xml with sensitive-tags [ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test [ "foo" ] [ T{ name { space "" } { main "foo" } } name>string ] unit-test @@ -51,11 +51,11 @@ IN: xml.writer.tests ]> &foo;"} pprint-reprints-as -[ t ] [ "" dup string>xml-chunk xml-chunk>string = ] unit-test +[ t ] [ "" dup string>xml-chunk xml>string = ] unit-test [ "" ] [ "" string>xml xml>string ] unit-test [ "bar baz" ] [ "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 +[ "" ] [ "" xml>string ] unit-test diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 8e2dc4bfbf..600c9d233d 100644 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -5,14 +5,15 @@ assocs combinators io io.streams.string accessors xml.data wrap xml.entities unicode.categories fry ; IN: xml.writer -SYMBOL: xml-pprint? SYMBOL: sensitive-tags -SYMBOL: indentation SYMBOL: indenter " " indenter set-global " write ; -M: contained-tag write-xml-chunk +M: contained-tag write-xml write-tag "/>" write ; : write-children ( tag -- ) indent children>> ?filter-children - [ write-xml-chunk ] each unindent ; + [ write-xml ] each unindent ; : write-end-tag ( tag -- ) ?indent " write1 ; -M: open-tag write-xml-chunk +M: open-tag write-xml xml-pprint? get [ { [ sensitive? not xml-pprint? get and xml-pprint? set ] @@ -98,110 +99,95 @@ M: open-tag write-xml-chunk } cleave ] dip xml-pprint? set ; -M: unescaped write-xml-chunk +M: unescaped write-xml string>> write ; -M: comment write-xml-chunk +M: comment write-xml "" write ; -M: element-decl write-xml-chunk - "> write " " write ] - [ content-spec>> write ">" write ] - bi ; +: write-decl ( decl name quot: ( decl -- slot ) -- ) + "> write bl ] + swap '[ @ write ">" write ] bi ; inline -M: attlist-decl write-xml-chunk - "> write " " write ] - [ att-defs>> write ">" write ] - bi ; +M: element-decl write-xml + "ELEMENT" [ content-spec>> ] write-decl ; -M: notation-decl write-xml-chunk - "> write " " write ] - [ id>> write ">" write ] - bi ; +M: attlist-decl write-xml + "ATTLIST" [ att-defs>> ] write-decl ; -M: entity-decl write-xml-chunk +M: notation-decl write-xml + "NOTATION" [ id>> ] write-decl ; + +M: entity-decl write-xml "> [ " % " write ] when ] [ name>> write " \"" write ] [ def>> f xml-pprint? - [ write-xml-chunk ] with-variable + [ write-xml ] with-variable "\">" write ] tri ; -M: system-id write-xml-chunk - "SYSTEM '" write system-literal>> write "'" write ; +M: system-id write-xml + "SYSTEM" write bl system-literal>> write-quoted ; -M: public-id write-xml-chunk - "PUBLIC '" write - [ pubid-literal>> write "' '" write ] - [ system-literal>> write "'" write ] bi ; +M: public-id write-xml + "PUBLIC" write bl + [ pubid-literal>> write-quoted bl ] + [ system-literal>> write-quoted ] bi ; : write-internal-subset ( dtd -- ) [ "[" write indent - directives>> [ ?indent write-xml-chunk ] each + directives>> [ ?indent write-xml ] each unindent ?indent "]" write ] when* ; -M: doctype-decl write-xml-chunk +M: doctype-decl write-xml ?indent "> write " " write ] - [ external-id>> [ write-xml-chunk " " write ] when* ] + [ external-id>> [ write-xml " " write ] when* ] [ internal-subset>> write-internal-subset ">" write ] tri ; -M: directive write-xml-chunk +M: directive write-xml "> write CHAR: > write1 nl ; -M: instruction write-xml-chunk +M: instruction write-xml "> write "?>" write ; -M: number write-xml-chunk +M: number write-xml "Numbers are not allowed in XML" throw ; -M: sequence write-xml-chunk - [ write-xml-chunk ] each ; +M: sequence write-xml + [ write-xml ] each ; -PRIVATE> +M: prolog write-xml + "> write-quoted ] + [ " encoding=" write encoding>> write-quoted ] + [ standalone>> [ " standalone=\"yes\"" write ] when ] tri + "?>" write ; -: write-prolog ( xml -- ) - "> write - "\" encoding=\"" write dup encoding>> write - standalone>> [ "\" standalone=\"yes" write ] when - "\"?>" write ; - -: write-xml ( xml -- ) +M: xml write-xml { - [ prolog>> write-prolog ] - [ before>> write-xml-chunk ] - [ body>> write-xml-chunk ] - [ after>> write-xml-chunk ] + [ prolog>> write-xml ] + [ before>> write-xml ] + [ body>> write-xml ] + [ after>> write-xml ] } cleave ; -M: xml write-xml-chunk - body>> write-xml-chunk ; +PRIVATE> : xml>string ( xml -- string ) [ write-xml ] with-string-writer ; -: xml-chunk>string ( object -- string ) - [ write-xml-chunk ] with-string-writer ; - -: pprint-xml-but ( xml sensitive-tags -- ) +: pprint-xml ( xml -- ) [ - [ assure-name ] map sensitive-tags set + sensitive-tags [ [ assure-name ] map ] change 0 indentation set xml-pprint? on write-xml ] with-scope ; -: pprint-xml ( xml -- ) - f pprint-xml-but ; - -: pprint-xml>string-but ( xml sensitive-tags -- string ) - [ pprint-xml-but ] with-string-writer ; - : pprint-xml>string ( xml -- string ) - f pprint-xml>string-but ; + [ pprint-xml ] with-string-writer ; From cadbcdc9a49d57ba9a74cebb302273f612fb8ed8 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 29 Jan 2009 15:15:50 -0600 Subject: [PATCH 03/21] Fixing everything now(?) --- basis/html/elements/elements.factor | 2 +- .../templates/chloe/compiler/compiler.factor | 6 ++-- basis/http/http-tests.factor | 4 +-- basis/xml/writer/writer-docs.factor | 28 ++++++++++++++++++- basis/xml/writer/writer.factor | 4 +-- 5 files changed, 35 insertions(+), 9 deletions(-) diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index 9e7504d436..a6e1928f83 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -144,7 +144,7 @@ SYMBOL: html <-> - XML> write-xml ; + XML> write-xml ; inline : render-error ( message -- ) [XML <-> XML] write-xml ; diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index cd5de4ceb6..4034b67d45 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -49,7 +49,7 @@ DEFER: compile-element reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ; : compile-attrs ( assoc -- ) - attrs>> [ + [ " " [write] swap name>string [write] "=\"" [write] @@ -59,7 +59,7 @@ DEFER: compile-element : compile-start-tag ( tag -- ) "<" [write] - [ name>string [write] ] [ compile-attrs ] bi + [ name>string [write] ] [ attrs>> compile-attrs ] bi ">" [write] ; : compile-end-tag ( tag -- ) @@ -126,7 +126,7 @@ ERROR: unknown-chloe-tag tag ; : compile-prologue ( xml -- ) [ - [ prolog>> [ write-prolog ] [code-with] ] + [ prolog>> [ write-xml ] [code-with] ] [ before>> compile-chunk ] bi ] compile-quot diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 6b0bdbe2c0..6103fb622f 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -2,7 +2,7 @@ USING: http http.server http.client http.client.private tools.test multiline io.streams.string io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.encodings.string kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls -hashtables accessors namespaces ; +hashtables accessors namespaces xml.data ; IN: http.tests [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test @@ -322,7 +322,7 @@ SYMBOL: a 3 a set-global -: test-a string>xml "input" tag-named "value" swap at ; +: test-a string>xml "input" tag-named "value" attr ; [ "3" ] [ "http://localhost/" add-port http-get diff --git a/basis/xml/writer/writer-docs.factor b/basis/xml/writer/writer-docs.factor index a26a7377fd..38f97bd5f8 100644 --- a/basis/xml/writer/writer-docs.factor +++ b/basis/xml/writer/writer-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup io strings xml.data ; +USING: help.syntax help.markup io strings xml.data multiline ; IN: xml.writer ABOUT: "xml.writer" @@ -39,3 +39,29 @@ HELP: pprint-xml { xml>string write-xml pprint-xml pprint-xml>string } related-words +HELP: indenter +{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" } +{ $example {" USING: xml.interpolate xml.writer namespaces ; +[XML bar XML] "%%%%" indenter [ pprint-xml ] with-variable "} {" + +%%%%bar +"} } ; + +HELP: sensitive-tags +{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" } +{ $example {" USING: xml.interpolate xml.writer namespaces ; +[XML something
bing
+bang
+   bong
XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {" + + + + something + + + + 
bing
+bang
+   bong
+ +"} } ; diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 600c9d233d..92bc18054a 100644 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -61,7 +61,7 @@ PRIVATE> PRIVATE> -GENERIC: write-xml ( object -- ) +GENERIC: write-xml ( xml -- ) Date: Thu, 29 Jan 2009 16:57:13 -0600 Subject: [PATCH 04/21] Code cleanup in XML --- basis/xml/autoencoding/autoencoding.factor | 39 ++++++++++----- basis/xml/char-classes/char-classes.factor | 2 +- basis/xml/elements/elements.factor | 14 ++---- basis/xml/state/state.factor | 7 +-- basis/xml/tests/test.factor | 20 +++++--- basis/xml/tokenize/tokenize.factor | 7 +-- basis/xml/xml.factor | 57 ++++++++++------------ 7 files changed, 75 insertions(+), 71 deletions(-) diff --git a/basis/xml/autoencoding/autoencoding.factor b/basis/xml/autoencoding/autoencoding.factor index 5dc32958d4..d78342a08c 100644 --- a/basis/xml/autoencoding/autoencoding.factor +++ b/basis/xml/autoencoding/autoencoding.factor @@ -2,14 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces xml.name io.encodings.utf8 xml.elements io.encodings.utf16 xml.tokenize xml.state math ascii sequences -io.encodings.string io.encodings combinators ; +io.encodings.string io.encodings combinators accessors +xml.data io.encodings.iana ; IN: xml.autoencoding : continue-make-tag ( str -- tag ) parse-name-starting middle-tag end-tag ; : start-utf16le ( -- tag ) - utf16le decode-input-if + utf16le decode-input "?\0" expect check instruct ; @@ -17,20 +18,36 @@ IN: xml.autoencoding -6 shift 3 bitand 2 = ; : start> dup "UTF-16" = + [ drop ] [ name>encoding [ decode-input ] when* ] if ; + +: instruct-encoding ( instruct/prolog -- ) + dup prolog? + [ prolog-encoding ] + [ drop utf8 decode-input ] if ; + +: something ( -- ) + check utf8 decode-input next next ; + : start< ( -- tag ) + ! What if first letter of processing instruction is non-ASCII? get-next { { 0 [ next next start-utf16le ] } - { CHAR: ? [ check next next instruct ] } ! XML prolog parsing sets the encoding - { CHAR: ! [ check utf8 decode-input next next direct ] } + { CHAR: ? [ something instruct dup instruct-encoding ] } + { CHAR: ! [ something direct ] } [ check start, in the case of XML chunks? - } case check ; + [ drop utf8 decode-input check f ] + } case ; diff --git a/basis/xml/char-classes/char-classes.factor b/basis/xml/char-classes/char-classes.factor index 03e85e3ea3..b47d4c66df 100644 --- a/basis/xml/char-classes/char-classes.factor +++ b/basis/xml/char-classes/char-classes.factor @@ -26,7 +26,7 @@ CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7: ; ! 1.1: ! [#x1-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF] { - { [ dup HEX: 20 < ] [ "\t\r\n" member? and ] } + { [ dup HEX: 20 < ] [ swap [ "\t\r\n" member? ] [ zero? not ] if ] } { [ nip dup HEX: D800 < ] [ drop t ] } { [ dup HEX: E000 < ] [ drop f ] } [ { HEX: FFFE HEX: FFFF } member? not ] diff --git a/basis/xml/elements/elements.factor b/basis/xml/elements/elements.factor index 116acb076b..b927947329 100644 --- a/basis/xml/elements/elements.factor +++ b/basis/xml/elements/elements.factor @@ -29,7 +29,7 @@ IN: xml.elements parse-name swap ; : (middle-tag) ( -- ) - pass-blank version=1.0? get-char name-start? + pass-blank version-1.0? get-char name-start? [ parse-attr (middle-tag) ] when ; : assure-no-duplicates ( attrs-alist -- attrs-alist ) @@ -66,7 +66,8 @@ IN: xml.elements : prolog-version ( alist -- version ) T{ name { space "" } { main "version" } } swap at - [ good-version ] [ versionless-prolog ] if* ; + [ good-version ] [ versionless-prolog ] if* + dup set-version ; : prolog-encoding ( alist -- encoding ) T{ name { space "" } { main "encoding" } } swap at @@ -89,16 +90,9 @@ IN: xml.elements [ prolog-standalone ] tri ; -SYMBOL: string-input? -: decode-input-if ( encoding -- ) - string-input? get [ drop ] [ decode-input ] if ; - : parse-prolog ( -- prolog ) pass-blank middle-tag "?>" expect - dup assure-no-extra prolog-attrs - dup encoding>> dup "UTF-16" = - [ drop ] [ name>encoding [ decode-input-if ] when* ] if - dup prolog-data set ; + dup assure-no-extra prolog-attrs ; : instruct ( -- instruction ) take-name { diff --git a/basis/xml/state/state.factor b/basis/xml/state/state.factor index 059d8267a0..eba94220e3 100644 --- a/basis/xml/state/state.factor +++ b/basis/xml/state/state.factor @@ -3,7 +3,7 @@ USING: accessors kernel namespaces io ; IN: xml.state -TUPLE: spot char line column next check ; +TUPLE: spot char line column next check version-1.0? ; C: spot @@ -17,11 +17,12 @@ C: spot : set-next ( char -- ) spot get swap >>next drop ; : get-check ( -- ? ) spot get check>> ; : check ( -- ) spot get t >>check drop ; +: version-1.0? ( -- ? ) spot get version-1.0?>> ; +: set-version ( string -- ) + spot get swap "1.0" = >>version-1.0? drop ; SYMBOL: xml-stack -SYMBOL: prolog-data - SYMBOL: depth SYMBOL: interpolating? diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index 97793f2ab2..337c19bfe1 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -51,14 +51,18 @@ SYMBOL: xml-file [ "foo" ] [ "" string>xml children>string ] unit-test [ "" string>xml ] must-fail [ ] [ "" string>xml drop ] unit-test -[ T{ element-decl f "br" "EMPTY" } ] [ "" string>dtd directives>> first ] unit-test -[ T{ element-decl f "p" "(#PCDATA|emph)*" } ] [ "" string>dtd directives>> first ] unit-test -[ T{ element-decl f "%name.para;" "%content.para;" } ] [ "" string>dtd directives>> first ] unit-test -[ T{ element-decl f "container" "ANY" } ] [ "" string>dtd directives>> first ] unit-test -[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk first ] unit-test -[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk first ] unit-test -[ 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 + +: first-thing ( seq -- elt ) + [ "" = not ] filter first ; + +[ T{ element-decl f "br" "EMPTY" } ] [ "" string>dtd directives>> first-thing ] unit-test +[ T{ element-decl f "p" "(#PCDATA|emph)*" } ] [ "" string>dtd directives>> first-thing ] unit-test +[ T{ element-decl f "%name.para;" "%content.para;" } ] [ "" string>dtd directives>> first-thing ] unit-test +[ T{ element-decl f "container" "ANY" } ] [ "" string>dtd directives>> first-thing ] unit-test +[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk first-thing ] unit-test +[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk first-thing ] unit-test +[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first-thing ] unit-test +[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first-thing ] unit-test [ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test [ "x" "<" ] [ "" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test [ "foo" ] [ "]>&bar;" string>xml children>string ] unit-test diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor index b629d46455..50ab43ca7b 100644 --- a/basis/xml/tokenize/tokenize.factor +++ b/basis/xml/tokenize/tokenize.factor @@ -6,12 +6,9 @@ circular xml.entities assocs make splitting math.parser locals combinators arrays ; IN: xml.tokenize -: version=1.0? ( -- ? ) - prolog-data get [ version>> "1.0" = ] [ t ] if* ; - : assure-good-char ( ch -- ch ) [ - version=1.0? over text? not get-check and + version-1.0? over text? not get-check and [ disallowed-char ] when ] [ f ] if* ; @@ -36,7 +33,7 @@ IN: xml.tokenize get-char [ unexpected-end ] unless (next) record ; : init-parser ( -- ) - 0 1 0 f f spot set + 0 1 0 f f t spot set read1 set-next next ; : with-state ( stream quot -- ) diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 5369b04d9c..6b297918c3 100644 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -22,7 +22,7 @@ GENERIC: process ( object -- ) M: object process add-child ; M: prolog process - xml-stack get V{ { f V{ } } } = + xml-stack get { V{ { f V{ "" } } } V{ { f V{ } } } } member? [ bad-prolog ] unless drop ; M: directive process @@ -49,17 +49,14 @@ M: closer process : init-xml-stack ( -- ) V{ } clone xml-stack set - extra-entities [ H{ } assoc-like ] change f push-xml ; : default-prolog ( -- prolog ) "1.0" "UTF-8" f ; -: reset-prolog ( -- ) - default-prolog prolog-data set ; - : init-xml ( -- ) - reset-prolog init-xml-stack init-ns-stack ; + init-ns-stack + extra-entities [ H{ } assoc-like ] change ; : assert-blanks ( seq pre? -- ) swap [ string? ] filter @@ -80,7 +77,11 @@ M: closer process ! this does *not* affect the contents of the stack [ notags ] unless* ; -: make-xml-doc ( prolog seq -- xml-doc ) +: get-prolog ( seq -- prolog ) + first dup prolog? [ drop default-prolog ] unless ; + +: make-xml-doc ( seq -- xml-doc ) + [ get-prolog ] keep dup [ tag? ] find [ assure-tags cut rest no-pre/post no-post-tags ] dip swap ; @@ -95,8 +96,7 @@ TUPLE: pull-xml scope ; : ( -- pull-xml ) [ input-stream [ ] change ! bring var in this scope - init-parser reset-prolog init-ns-stack - text-now? on + init-xml text-now? on ] H{ } make-assoc pull-xml boa ; ! pull-xml needs to call start-document somewhere @@ -135,50 +135,43 @@ PRIVATE> get-char [ make-tag call-under xml-loop ] [ drop ] if ; inline recursive +: read-seq ( stream quot n -- seq ) + rot [ + depth set + init-xml init-xml-stack + call + [ process ] xml-loop + done? [ unclosed ] unless + xml-stack get first second + ] with-state ; inline + PRIVATE> : each-element ( stream quot: ( xml-elem -- ) -- ) swap [ - reset-prolog init-ns-stack + init-xml start-document [ call-under ] when* xml-loop ] with-state ; inline -: (read-xml) ( -- ) - start-document [ process ] when* - [ process ] xml-loop ; inline - -: (read-xml-chunk) ( stream -- prolog seq ) - [ - init-xml (read-xml) - done? [ unclosed ] unless - xml-stack get first second - prolog-data get swap - ] with-state ; - : read-xml ( stream -- xml ) - 0 depth - [ (read-xml-chunk) make-xml-doc ] with-variable ; + [ start-document [ process ] when* ] + 0 read-seq make-xml-doc ; : read-xml-chunk ( stream -- seq ) - 1 depth - [ (read-xml-chunk) nip ] with-variable - ; + [ check ] 1 read-seq ; : string>xml ( string -- xml ) - t string-input? - [ read-xml ] with-variable ; + [ check ] 0 read-seq make-xml-doc ; : string>xml-chunk ( string -- xml ) - t string-input? - [ read-xml-chunk ] with-variable ; + read-xml-chunk ; : file>xml ( filename -- xml ) binary read-xml ; : read-dtd ( stream -- dtd ) [ - reset-prolog H{ } clone extra-entities set take-internal-subset ] with-state ; From b01cd0624560fee05dd5e2de4da957094065575c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 29 Jan 2009 18:25:23 -0600 Subject: [PATCH 05/21] XML docs improvements --- basis/xml/autoencoding/autoencoding.factor | 6 +- basis/xml/data/data-docs.factor | 33 ++++++----- basis/xml/entities/entities-docs.factor | 7 +-- basis/xml/entities/html/html-docs.factor | 8 +-- basis/xml/errors/errors-docs.factor | 64 ++++++++++++++-------- basis/xml/xml-docs.factor | 11 ++-- basis/xml/xml.factor | 17 ++++-- 7 files changed, 84 insertions(+), 62 deletions(-) diff --git a/basis/xml/autoencoding/autoencoding.factor b/basis/xml/autoencoding/autoencoding.factor index d78342a08c..20a661cfa7 100644 --- a/basis/xml/autoencoding/autoencoding.factor +++ b/basis/xml/autoencoding/autoencoding.factor @@ -39,15 +39,15 @@ IN: xml.autoencoding [ prolog-encoding ] [ drop utf8 decode-input ] if ; -: something ( -- ) +: go-utf8 ( -- ) check utf8 decode-input next next ; : start< ( -- tag ) ! What if first letter of processing instruction is non-ASCII? get-next { { 0 [ next next start-utf16le ] } - { CHAR: ? [ something instruct dup instruct-encoding ] } - { CHAR: ! [ something direct ] } + { CHAR: ? [ go-utf8 instruct dup instruct-encoding ] } + { CHAR: ! [ go-utf8 direct ] } [ check start { $values { "prolog" "an XML prolog" } { "before" "a sequence of XML elements" } { "body" tag } { "after" "a sequence of XML elements" } { "xml" "an XML document" } } -{ $description "creates an XML document, delegating to the main tag, with the specified prolog, before, and after" } +{ $description "Creates an XML document. The " { $snippet "before" } " and " { $snippet "after" } " slots store what comes before and after the main tag, and " { $snippet "body" } "contains the main tag itself." } { $see-also xml } ; HELP: prolog @@ -99,47 +99,46 @@ HELP: prolog HELP: { $values { "version" "a string, 1.0 or 1.1" } { "encoding" "a string" } { "standalone" "a boolean" } { "prolog" "an XML prolog" } } -{ $description "creates an XML prolog tuple" } +{ $description "Creates an XML prolog tuple." } { $see-also prolog } ; HELP: comment -{ $class-description "represents a comment in XML. Has one slot, text, which contains the string of the comment" } +{ $class-description "Represents a comment in XML. This tuple has one slot, " { $snippet "text" } ", which contains the string of the comment." } { $see-also } ; HELP: -{ $values { "text" "a string" } { "comment" "a comment" } } -{ $description "creates an XML comment tuple" } +{ $values { "text" string } { "comment" comment } } +{ $description "Creates an XML " { $link comment } " tuple." } { $see-also comment } ; HELP: instruction -{ $class-description "represents an XML instruction, such as . Contains one slot, text, which contains the string between the question marks." } +{ $class-description "Represents an XML instruction, such as " { $snippet "" } ". Contains one slot, " { $snippet "text" } ", which contains the string between the question marks." } { $see-also } ; HELP: { $values { "text" "a string" } { "instruction" "an XML instruction" } } -{ $description "creates an XML parsing instruction, such as ." } +{ $description "Creates an XML parsing instruction, like " { $snippet "" } "." } { $see-also instruction } ; HELP: opener -{ $class-description "describes an opening tag, like . Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." } -{ $see-also closer contained } ; +{ $class-description "Describes an opening tag, like " { $snippet "" } ". Contains two slots, " { $snippet "name" } " and " { $snippet "attrs" } " containing, respectively, the name of the tag and its attributes." } ; HELP: closer -{ $class-description "describes a closing tag, like . Contains one slot, name, containing the tag's name. Usually, the name-url will be f." } -{ $see-also opener contained } ; +{ $class-description "Describes a closing tag, like " { $snippet "" } ". Contains one slot, " { $snippet "name" } ", containing the closer's name." } ; HELP: contained -{ $class-description "represents a self-closing tag, like . Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." } -{ $see-also opener closer } ; +{ $class-description "Represents a self-closing tag, like " { $snippet "" } ". Contains two slots," { $snippet "name" } " and " { $snippet "attrs" } " containing, respectively, the name of the tag and its attributes." } ; + +{ opener closer contained } related-words HELP: open-tag -{ $class-description "represents a tag that does have children, ie is not a contained tag" } -{ $notes "the constructor used for this class is simply " { $link } "." } +{ $class-description "Represents a tag that does have children, ie. is not a contained tag" } +{ $notes "The constructor used for this class is simply " { $link } "." } { $see-also tag contained-tag } ; HELP: names-match? { $values { "name1" "a name" } { "name2" "a name" } { "?" "t or f" } } -{ $description "checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." } +{ $description "Checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." } { $example "USING: prettyprint xml.data ;" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" } { $see-also name } ; @@ -173,7 +172,7 @@ HELP: { $description "Creates an entity declaration object, of the class " { $link entity-decl } ". The pe? slot should be t if the object is a DTD-internal entity, like " { $snippet "" } " and f if the object is like " { $snippet "" } ", that is, it can be used outside of the DTD." } ; HELP: system-id -{ $class-description "Describes the class of system identifiers within an XML DTD directive, such as " { $snippet "" } } ; +{ $class-description "Describes the class of system identifiers within an XML DTD directive, such as " { $snippet "" } "." } ; HELP: { $values { "system-literal" string } { "system-id" system-id } } diff --git a/basis/xml/entities/entities-docs.factor b/basis/xml/entities/entities-docs.factor index ab105300e1..2fccb500a4 100644 --- a/basis/xml/entities/entities-docs.factor +++ b/basis/xml/entities/entities-docs.factor @@ -12,11 +12,10 @@ ARTICLE: "xml.entities" "XML entities" "For entities used in HTML/XHTML, see " { $vocab-link "xml.entities.html" } ; HELP: entities -{ $description "a hash table from default XML entity names (like & and <) to the characters they represent. This is automatically included when parsing any XML document." } +{ $description "A hash table from default XML entity names (like " { $snippet "&" } " and " { $snippet "<" } ") to the characters they represent. This is automatically included when parsing any XML document." } { $see-also with-entities } ; HELP: with-entities -{ $values { "entities" "a hash table of strings to chars" } - { "quot" "a quotation ( -- )" } } -{ $description "calls the quotation using the given table of entity values (symbolizing, eg, that &foo; represents CHAR: a) on top of the default XML entities" } ; +{ $values { "entities" "a hash table of strings to strings" } { "quot" "a quotation ( -- )" } } +{ $description "Calls the quotation using the given table of entity values (symbolizing, eg, that " { $snippet "&foo;" } " represents " { $snippet "\"a\"" } ") on top of the default XML entities" } ; diff --git a/basis/xml/entities/html/html-docs.factor b/basis/xml/entities/html/html-docs.factor index 2e1b67a100..f436944954 100644 --- a/basis/xml/entities/html/html-docs.factor +++ b/basis/xml/entities/html/html-docs.factor @@ -5,14 +5,14 @@ IN: xml.entities.html ARTICLE: "xml.entities.html" "HTML entities" { $vocab-link "xml.entities.html" } " defines words for using entities defined in HTML/XHTML." - { $subsection html-entities } - { $subsection with-html-entities } ; +{ $subsection html-entities } +{ $subsection with-html-entities } ; HELP: html-entities -{ $description "a hash table from HTML entity names to their character values" } +{ $description "A hash table from HTML entity names to their character values." } { $see-also entities with-html-entities } ; HELP: with-html-entities { $values { "quot" "a quotation ( -- )" } } -{ $description "calls the given quotation using HTML entity values" } +{ $description "Calls the given quotation using HTML entity values." } { $see-also html-entities with-entities } ; diff --git a/basis/xml/errors/errors-docs.factor b/basis/xml/errors/errors-docs.factor index 46c4fbe466..01a943eab7 100644 --- a/basis/xml/errors/errors-docs.factor +++ b/basis/xml/errors/errors-docs.factor @@ -3,45 +3,60 @@ USING: help.markup help.syntax ; IN: xml.errors + + HELP: multitags -{ $class-description "XML parsing error describing the case where there is more than one main tag in a document. Contains no slots" } ; +{ $class-description "XML parsing error describing the case where there is more than one main tag in a document." } +{ $xml-error "\n" } ; HELP: notags -{ $class-description "XML parsing error describing the case where an XML document contains no main tag, or any tags at all" } ; +{ $class-description "XML parsing error describing the case where an XML document contains no main tag, or any tags at all" } +{ $xml-error "" } ; HELP: extra-attrs -{ $class-description "XML parsing error describing the case where the XML prolog (" { $snippet "" } ") contains attributes other than the three allowed ones, standalone, version and encoding. Contains one slot, attrs, which is a hashtable of all the extra attributes' names. Delegates to " { $link xml-error-at } "." } ; +{ $class-description "XML parsing error describing the case where the XML prolog (" { $snippet "" } ") contains attributes other than the three allowed ones, " { $snippet "standalone" } ", " { $snippet "version" } " and " { $snippet "encoding" } ". Contains one slot, " { $snippet "attrs" } ", which is a hashtable of all the extra attributes' names. This is a subclass of " { $link xml-error-at } "." } +{ $xml-error "\n" } ; HELP: nonexist-ns -{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, name, which contains the name of the undeclared namespace, and delegates to " { $link xml-error-at } "." } ; +{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, " { $snippet "name" } ", which contains the name of the undeclared namespace, and is a subclass of " { $link xml-error-at } "." } +{ $xml-error "c" } ; HELP: not-yes/no -{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than 'yes' or 'no'. Delegates to " { $link xml-error-at } " and contains one slot, text, which contains offending value." } ; +{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than " { $snippet "yes" } " or " { $snippet "no" } ". This is a subclass of " { $link xml-error-at } " and contains one slot, text, which contains offending value." } +{ $xml-error "\n" } ; HELP: unclosed -{ $class-description "XML parsing error used to describe the case where the XML document contains classes which are not closed by the end of the document. Contains one slot, tags, a sequence of names." } ; +{ $class-description "XML parsing error used to describe the case where the XML document contains classes which are not closed by the end of the document. Contains one slot, " { $snippet "tags" } ", a sequence of names." } +{ $xml-error "some text" } ; HELP: mismatched -{ $class-description "XML parsing error describing mismatched tags, eg " { $snippet "" } ". Contains two slots: open is the name of the opening tag and close is the name of the closing tag. Delegates to " { $link xml-error-at } " showing the location of the closing tag" } ; +{ $class-description "XML parsing error describing mismatched tags. Contains two slots: " { $snippet "open" } " is the name of the opening tag and " { $snippet "close" } " is the name of the closing tag. This is a subclass of " { $link xml-error-at } " showing the location of the closing tag" } +{ $xml-error "" } ; HELP: expected -{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link xml-error-at } ". Contains two slots, should-be, which has the expected string, and was, which has the actual string." } ; +{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link xml-error-at } ". Contains two slots, " { $snippet "should-be" } ", which has the expected string, and " { $snippet "was" } ", which has the actual string." } ; HELP: no-entity -{ $class-description "XML parsing error describing the use of an undefined entity in a case where standalone is marked yes. Delegates to " { $link xml-error-at } ". Contains one slot, thing, containing a string representing the entity." } ; +{ $class-description "XML parsing error describing the use of an undefined entity. This is a subclass of " { $link xml-error-at } ". Contains one slot, thing, containing a string representing the entity." } +{ $xml-error "&foo;" } ; HELP: pre/post-content -{ $class-description "Describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: string contains the offending string, and pre? is t if it occured before the main tag and f if it occured after" } ; - -HELP: unclosed-quote -{ $class-description "Describes the error where a quotation for an attribute value is opened but not closed before the end of the document." } ; +{ $class-description "Describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: " { $snippet "string" } " contains the offending string, and " { $snippet "pre?" } " is " { $snippet "t" } " if it occured before the main tag and " { $snippet "f" } " if it occured after." } +{ $xml-error "hello\n" } ; HELP: bad-name -{ $class-description "Describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } ; +{ $class-description "Describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } +{ $xml-error "<%>\n" } ; HELP: quoteless-attr -{ $class-description "Describes the error where an attribute of an XML tag is missing quotes around a value." } ; +{ $class-description "Describes the error where an attribute of an XML tag is missing quotes around a value." } +{ $xml-error "" } ; HELP: disallowed-char { $class-description "Describes the error where a disallowed character occurs in an XML document." } ; @@ -53,25 +68,30 @@ HELP: unexpected-end { $class-description "Describes the error where a document unexpectedly ends, and the XML parser expected it to continue." } ; HELP: duplicate-attr -{ $class-description "Describes the error where there is more than one attribute of the same key." } ; +{ $class-description "Describes the error where there is more than one attribute of the same key." } +{ $xml-error "" } ; HELP: bad-cdata -{ $class-description "Describes the error where CDATA is used outside of the main tag of an XML document." } ; +{ $class-description "Describes the error where CDATA is used outside of the main tag of an XML document." } +{ $xml-error "y\n" } ; HELP: text-w/]]> -{ $class-description "Describes the error where a text node contains the literal string " { $snippet "]]>" } " which is disallowed." } ; +{ $class-description "Describes the error where a text node contains the literal string " { $snippet "]]>" } " which is disallowed." } +{ $xml-error "Here's some text: ]]> there it was" } ; HELP: attr-w/< -{ $class-description "Describes the error where an attribute value contains the literal character " { $snippet "<" } " which is disallowed." } ; +{ $class-description "Describes the error where an attribute value contains the literal character " { $snippet "<" } " which is disallowed." } +{ $xml-error "" } ; HELP: misplaced-directive -{ $class-description "Describes the error where an internal DTD directive is used outside of a DOCTYPE or DTD file, or where a DOCTYPE occurs somewhere other than before the main tag of an XML document." } ; +{ $class-description "Describes the error where an internal DTD directive is used outside of a DOCTYPE or DTD file, or where a DOCTYPE occurs somewhere other than before the main tag of an XML document." } +{ $xml-error "" } ; HELP: xml-error { $class-description "The exception class that all parsing errors in XML documents are in." } ; ARTICLE: "xml.errors" "XML parsing errors" -"The " { $vocab-link "xml.errors" } " vocabulary provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-error } " but there are many classes contained in that:" +"The " { $vocab-link "xml.errors" } " vocabulary provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-error } "." { $subsection multitags } { $subsection notags } { $subsection extra-attrs } @@ -93,7 +113,7 @@ ARTICLE: "xml.errors" "XML parsing errors" { $subsection text-w/]]> } { $subsection attr-w/< } { $subsection misplaced-directive } - "Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information" + "Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information about where the error occurred." $nl "Note that, in parsing an XML document, only the first error is reported." ; diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor index 26d4319b5e..901fce2dd4 100644 --- a/basis/xml/xml-docs.factor +++ b/basis/xml/xml-docs.factor @@ -20,21 +20,20 @@ HELP: file>xml HELP: read-xml-chunk { $values { "stream" "an input stream" } { "seq" "a sequence of elements" } } -{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag." } +{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag. The encoding is not automatically detected, and a stream with an encoding (ie. one which returns strings from " { $link read } ") should be used as input." } { $see-also read-xml } ; HELP: each-element { $values { "stream" "an input stream" } { "quot" "a quotation ( xml-elem -- )" } } -{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly, and it is advised that generic words be used in dispatching on the event class." } -{ $notes "It is important to note that this is not SAX, merely an event-based XML view" } +{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly. The encoding of the stream is automatically detected, so a binary input stream should be used." } { $see-also read-xml } ; HELP: pull-xml -{ $class-description "Represents the state of a pull-parser for XML. Has one slot, scope, which is a namespace which contains all relevant state information." } +{ $class-description "Represents the state of a pull-parser for XML. Has one slot, " { $snippet "scope" } ", which is a namespace which contains all relevant state information." } { $see-also pull-event pull-elem } ; HELP: -{ $values { "pull-xml" "a pull-xml tuple" } } +{ $values { "pull-xml" pull-xml } } { $description "Creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." } { $see-also pull-xml pull-elem pull-event } ; @@ -87,7 +86,7 @@ ARTICLE: { "xml" "events" } "Event-based XML parsing" { $subsection pull-elem } ; ARTICLE: "xml" "XML parser" -"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa." +"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa. The parser checks for well-formedness but is not validating. There is only partial support for processing DTDs." { $subsection { "xml" "reading" } } { $subsection { "xml" "events" } } { $vocab-subsection "Writing XML" "xml.writer" } diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 6b297918c3..fd749ce905 100644 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -3,7 +3,8 @@ USING: accessors arrays io io.encodings.binary io.files io.streams.string kernel namespaces sequences strings io.encodings.utf8 xml.data xml.errors xml.elements ascii xml.entities -xml.writer xml.state xml.autoencoding assocs xml.tokenize xml.name ; +xml.writer xml.state xml.autoencoding assocs xml.tokenize +combinators.short-circuit xml.name ; IN: xml > ] [ attrs>> ] bi From c253cd854a44078df02c7eaa84445773530d63ad Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 18:33:19 -0600 Subject: [PATCH 06/21] move null streams to core and make them not depend on io.styles and io.timeouts, initialize the std streams to null-streams on windows in win32 mode --- basis/io/backend/windows/nt/nt.factor | 5 ++++- basis/io/timeouts/timeouts.factor | 4 +++- core/io/backend/backend.factor | 21 +++++++++++++------ core/io/streams/c/c.factor | 2 +- {basis => core}/io/streams/null/authors.txt | 0 .../io/streams/null/null-docs.factor | 0 .../io/streams/null/null-tests.factor | 0 {basis => core}/io/streams/null/null.factor | 12 +++-------- 8 files changed, 26 insertions(+), 18 deletions(-) mode change 100644 => 100755 basis/io/timeouts/timeouts.factor rename {basis => core}/io/streams/null/authors.txt (100%) rename {basis => core}/io/streams/null/null-docs.factor (100%) rename {basis => core}/io/streams/null/null-tests.factor (100%) rename {basis => core}/io/streams/null/null.factor (62%) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 493a735f7f..b114cefdc0 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -120,6 +120,9 @@ M: winnt (wait-to-read) ( port -- ) tri ] with-destructors ; -M: winnt (init-stdio) init-c-stdio ; +: console-app? ( -- ? ) GetConsoleWindow ; + +M: winnt (init-stdio) + console-app? [ f f f f ] [ init-c-stdio t ] if ; winnt set-io-backend diff --git a/basis/io/timeouts/timeouts.factor b/basis/io/timeouts/timeouts.factor old mode 100644 new mode 100755 index fd1b14de19..8e69983e9c --- a/basis/io/timeouts/timeouts.factor +++ b/basis/io/timeouts/timeouts.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: kernel calendar alarms io io.encodings accessors -namespaces fry ; +namespaces fry io.streams.null ; IN: io.timeouts GENERIC: timeout ( obj -- dt/f ) @@ -27,3 +27,5 @@ GENERIC: cancel-operation ( obj -- ) : timeouts ( dt -- ) [ input-stream get set-timeout ] [ output-stream get set-timeout ] bi ; + +M: null-stream set-timeout 2drop ; diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 322a603144..fd5567cfa2 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init kernel system namespaces io io.encodings -io.encodings.utf8 init assocs splitting alien ; +io.encodings.utf8 init assocs splitting alien io.streams.null ; IN: io.backend SYMBOL: io-backend @@ -12,13 +12,22 @@ io-backend global [ c-io-backend or ] change-at HOOK: init-io io-backend ( -- ) -HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ) +HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ? ) + +: set-stdio ( input-handle output-handle error-handle -- ) + [ input-stream set-global ] + [ output-stream set-global ] + [ error-stream set-global ] tri* ; : init-stdio ( -- ) - (init-stdio) - [ utf8 input-stream set-global ] - [ utf8 output-stream set-global ] - [ utf8 error-stream set-global ] tri* ; + (init-stdio) [ + [ utf8 ] + [ utf8 ] + [ utf8 ] tri* + ] [ + 3drop + null-reader null-writer null-writer + ] if set-stdio ; HOOK: io-multiplex io-backend ( us -- ) diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 71c9ffd7d9..a93602533d 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -65,7 +65,7 @@ M: c-io-backend init-io ; stdout-handle stderr-handle ; -M: c-io-backend (init-stdio) init-c-stdio ; +M: c-io-backend (init-stdio) init-c-stdio t ; M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ; diff --git a/basis/io/streams/null/authors.txt b/core/io/streams/null/authors.txt similarity index 100% rename from basis/io/streams/null/authors.txt rename to core/io/streams/null/authors.txt diff --git a/basis/io/streams/null/null-docs.factor b/core/io/streams/null/null-docs.factor similarity index 100% rename from basis/io/streams/null/null-docs.factor rename to core/io/streams/null/null-docs.factor diff --git a/basis/io/streams/null/null-tests.factor b/core/io/streams/null/null-tests.factor similarity index 100% rename from basis/io/streams/null/null-tests.factor rename to core/io/streams/null/null-tests.factor diff --git a/basis/io/streams/null/null.factor b/core/io/streams/null/null.factor similarity index 62% rename from basis/io/streams/null/null.factor rename to core/io/streams/null/null.factor index a2224ef306..98729c7abd 100644 --- a/basis/io/streams/null/null.factor +++ b/core/io/streams/null/null.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io io.timeouts io.styles destructors ; +USING: kernel io destructors io.streams.plain ; IN: io.streams.null SINGLETONS: null-reader null-writer ; UNION: null-stream null-reader null-writer ; +INSTANCE: null-writer plain-writer M: null-stream dispose drop ; -M: null-stream set-timeout 2drop ; M: null-reader stream-readln drop f ; M: null-reader stream-read1 drop f ; @@ -16,16 +16,10 @@ M: null-reader stream-read 2drop f ; M: null-writer stream-write1 2drop ; M: null-writer stream-write 2drop ; -M: null-writer stream-nl drop ; M: null-writer stream-flush drop ; -M: null-writer stream-format 3drop ; -M: null-writer make-span-stream nip ; -M: null-writer make-block-stream nip ; -M: null-writer make-cell-stream nip ; -M: null-writer stream-write-table 3drop ; : with-null-reader ( quot -- ) null-reader swap with-input-stream* ; inline : with-null-writer ( quot -- ) - null-writer swap with-output-stream* ; inline \ No newline at end of file + null-writer swap with-output-stream* ; inline From 5e4265507e314468179dceabf2df15254cbee47b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 18:34:50 -0600 Subject: [PATCH 07/21] add a binding to a function --- basis/windows/kernel32/kernel32.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index f14f0fb65f..d3e823f844 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1179,7 +1179,7 @@ ALIAS: GetComputerNameEx GetComputerNameExW ! FUNCTION: GetConsoleSelectionInfo FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ; ALIAS: GetConsoleTitle GetConsoleTitleW -! FUNCTION: GetConsoleWindow +FUNCTION: HWND GetConsoleWindow ( ) ; ! FUNCTION: GetCPFileNameFromRegistry ! FUNCTION: GetCPInfo ! FUNCTION: GetCPInfoExA From 875592b01096943c4d1b70cdfd87858f976e4c0a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 29 Jan 2009 18:38:14 -0600 Subject: [PATCH 08/21] Fixing xml.name for word name change --- basis/xml/name/name.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/xml/name/name.factor b/basis/xml/name/name.factor index 83132d4d29..1907a83a83 100644 --- a/basis/xml/name/name.factor +++ b/basis/xml/name/name.factor @@ -47,7 +47,7 @@ SYMBOL: ns-stack : valid-name? ( str -- ? ) [ f ] [ - version=1.0? swap { + version-1.0? swap { [ first name-start? ] [ rest-slice [ name-char? ] with all? ] } 2&& @@ -66,7 +66,7 @@ SYMBOL: ns-stack ] ?if ; : take-name ( -- string ) - version=1.0? '[ _ get-char name-char? not ] take-until ; + version-1.0? '[ _ get-char name-char? not ] take-until ; : parse-name ( -- name ) take-name interpret-name ; From 33a8f0d87e5071232ea3e078547ad3daa9a19996 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 29 Jan 2009 19:00:31 -0600 Subject: [PATCH 09/21] Docs for some undocumented XML data types --- basis/xml/data/data-docs.factor | 30 ++++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/basis/xml/data/data-docs.factor b/basis/xml/data/data-docs.factor index 9f3d29a90c..639ef5591c 100644 --- a/basis/xml/data/data-docs.factor +++ b/basis/xml/data/data-docs.factor @@ -13,15 +13,17 @@ ARTICLE: "xml.data" "XML data types" "For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ; ARTICLE: { "xml.data" "classes" } "XML data classes" - "Data types that XML documents are made of:" - { $subsection name } + "XML documents and chunks are made of the following classes:" + { $subsection xml } + { $subsection xml-chunk } { $subsection tag } + { $subsection name } { $subsection contained-tag } { $subsection open-tag } - { $subsection xml } { $subsection prolog } { $subsection comment } { $subsection instruction } + { $subsection unescaped } { $subsection element-decl } { $subsection attlist-decl } { $subsection entity-decl } @@ -32,13 +34,15 @@ ARTICLE: { "xml.data" "classes" } "XML data classes" ARTICLE: { "xml.data" "constructors" } "XML data constructors" "These data types are constructed with:" - { $subsection } - { $subsection } - { $subsection } { $subsection } + { $subsection } + { $subsection } + { $subsection } + { $subsection } { $subsection } { $subsection } { $subsection } + { $subsection } { $subsection } { $subsection } { $subsection } @@ -198,3 +202,17 @@ HELP: doctype-decl HELP: { $values { "name" name } { "external-id" id } { "internal-subset" sequence } { "doctype-decl" doctype-decl } } { $description "Creates a new doctype declaration object, of the class " { $link doctype-decl } ". Only one of external-id or internal-subset will be non-null." } ; + +HELP: unescaped +{ $class-description "When constructing XML documents to write to output, it can be useful to splice in a string which is already written. This tuple type allows for that. Printing an " { $snippet "unescaped" } " is the same is printing its " { $snippet "string" } " slot." } ; + +HELP: +{ $values { "string" string } { "unescaped" unescaped } } +{ $description "Constructs an " { $link unescaped } " tuple, given a string." } ; + +HELP: xml-chunk +{ $class-description "Encapsulates a balanced fragment of an XML document. This is a sequence (following the sequence protocol) of XML data types, eg " { $link string } "s and " { $link tag } "s." } ; + +HELP: +{ $values { "seq" sequence } { "xml-chunk" xml-chunk } } +{ $description "Constructs an " { $link xml-chunk } " tuple, given a sequence to be its contents." } ; From c025d9da87ea01a3cca238f0f8a601f3ca1ecbee Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 29 Jan 2009 19:14:34 -0600 Subject: [PATCH 10/21] Fixing formatting errors in db docs --- basis/db/db-docs.factor | 4 ++-- basis/db/tuples/tuples-docs.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index ae7451cb48..08544b3367 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -244,13 +244,13 @@ ARTICLE: "db-protocol" "Low-level database protocol" ! { $subsection bind-tuple } ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial" -"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." +"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." $nl "Executing a SQL command:" { $subsection sql-command } "Executing a query directly:" { $subsection sql-query } "Here's an example usage where we'll make a book table, insert some objects, and query them." $nl -"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details." +"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details." { $code <" USING: db.sqlite db io.files ; : with-book-db ( quot -- ) diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index 51830ee610..e853c55ede 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -199,7 +199,7 @@ ARTICLE: "db-tuples-protocol" "Tuple database protocol" { $subsection } ; ARTICLE: "db-tuples-tutorial" "Tuple database tutorial" -"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl +"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl "We're going to store books in this tutorial." { $code "TUPLE: book id title author date-published edition cover-price condition ;" } "The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl @@ -246,7 +246,7 @@ T{ book { $code <" [ book get update-tuple ] with-book-tutorial "> } -"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "." +"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "." { $code <" [ T{ book { title "Factor for Sheeple" } } select-tuples ] with-book-tutorial "> } From afacfc1a17cb27ded891574cdf5d7a1be7de879e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 29 Jan 2009 19:20:34 -0600 Subject: [PATCH 11/21] Moved things into unmaintained that fail help-lint --- {extra => unmaintained}/4DNav/4DNav-docs.factor | 0 {extra => unmaintained}/4DNav/4DNav.factor | 0 {extra => unmaintained}/4DNav/authors.txt | 0 {extra => unmaintained}/4DNav/camera/authors.txt | 0 {extra => unmaintained}/4DNav/camera/camera-docs.factor | 0 {extra => unmaintained}/4DNav/camera/camera.factor | 0 {extra => unmaintained}/4DNav/deep/deep-docs.factor | 0 {extra => unmaintained}/4DNav/deep/deep.factor | 0 {extra => unmaintained}/4DNav/deploy.factor | 0 {extra => unmaintained}/4DNav/file-chooser/authors.txt | 0 {extra => unmaintained}/4DNav/file-chooser/file-chooser.factor | 0 {extra => unmaintained}/4DNav/hypercube.xml | 0 {extra => unmaintained}/4DNav/light_test.xml | 0 {extra => unmaintained}/4DNav/multi solids.xml | 0 {extra => unmaintained}/4DNav/prismetriagone.xml | 0 {extra => unmaintained}/4DNav/space-file-decoder/authors.txt | 0 .../4DNav/space-file-decoder/space-file-decoder-docs.factor | 0 .../4DNav/space-file-decoder/space-file-decoder.factor | 0 {extra => unmaintained}/4DNav/summary.txt | 0 {extra => unmaintained}/4DNav/tags.txt | 0 {extra => unmaintained}/4DNav/triancube.xml | 0 {extra => unmaintained}/4DNav/turtle/authors.txt | 0 {extra => unmaintained}/4DNav/turtle/turtle-docs.factor | 0 {extra => unmaintained}/4DNav/turtle/turtle.factor | 0 {extra => unmaintained}/4DNav/window3D/authors.txt | 0 {extra => unmaintained}/4DNav/window3D/window3D-docs.factor | 0 {extra => unmaintained}/4DNav/window3D/window3D.factor | 0 {extra => unmaintained}/adsoda/adsoda-docs.factor | 0 {extra => unmaintained}/adsoda/adsoda-tests.factor | 0 {extra => unmaintained}/adsoda/adsoda.factor | 0 {extra => unmaintained}/adsoda/adsoda.tests | 0 {extra => unmaintained}/adsoda/authors.txt | 0 {extra => unmaintained}/adsoda/combinators/authors.txt | 0 .../adsoda/combinators/combinators-docs.factor | 0 .../adsoda/combinators/combinators-tests.factor | 0 {extra => unmaintained}/adsoda/combinators/combinators.factor | 0 {extra => unmaintained}/adsoda/solution2/solution2.factor | 0 {extra => unmaintained}/adsoda/solution2/summary.txt | 0 {extra => unmaintained}/adsoda/summary.txt | 0 {extra => unmaintained}/adsoda/tags.txt | 0 {extra => unmaintained}/adsoda/tools/authors.txt | 0 {extra => unmaintained}/adsoda/tools/tools-docs.factor | 0 {extra => unmaintained}/adsoda/tools/tools-tests.factor | 0 {extra => unmaintained}/adsoda/tools/tools.factor | 0 {extra => unmaintained}/ui/gadgets/plot/plot.factor | 0 {extra => unmaintained}/ui/gadgets/slate/authors.txt | 0 {extra => unmaintained}/ui/gadgets/slate/slate.factor | 0 {extra => unmaintained}/ui/gadgets/tiling/tiling.factor | 0 48 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/4DNav/4DNav-docs.factor (100%) rename {extra => unmaintained}/4DNav/4DNav.factor (100%) rename {extra => unmaintained}/4DNav/authors.txt (100%) rename {extra => unmaintained}/4DNav/camera/authors.txt (100%) rename {extra => unmaintained}/4DNav/camera/camera-docs.factor (100%) rename {extra => unmaintained}/4DNav/camera/camera.factor (100%) rename {extra => unmaintained}/4DNav/deep/deep-docs.factor (100%) rename {extra => unmaintained}/4DNav/deep/deep.factor (100%) rename {extra => unmaintained}/4DNav/deploy.factor (100%) rename {extra => unmaintained}/4DNav/file-chooser/authors.txt (100%) rename {extra => unmaintained}/4DNav/file-chooser/file-chooser.factor (100%) rename {extra => unmaintained}/4DNav/hypercube.xml (100%) rename {extra => unmaintained}/4DNav/light_test.xml (100%) rename {extra => unmaintained}/4DNav/multi solids.xml (100%) rename {extra => unmaintained}/4DNav/prismetriagone.xml (100%) rename {extra => unmaintained}/4DNav/space-file-decoder/authors.txt (100%) rename {extra => unmaintained}/4DNav/space-file-decoder/space-file-decoder-docs.factor (100%) rename {extra => unmaintained}/4DNav/space-file-decoder/space-file-decoder.factor (100%) rename {extra => unmaintained}/4DNav/summary.txt (100%) rename {extra => unmaintained}/4DNav/tags.txt (100%) rename {extra => unmaintained}/4DNav/triancube.xml (100%) rename {extra => unmaintained}/4DNav/turtle/authors.txt (100%) rename {extra => unmaintained}/4DNav/turtle/turtle-docs.factor (100%) rename {extra => unmaintained}/4DNav/turtle/turtle.factor (100%) rename {extra => unmaintained}/4DNav/window3D/authors.txt (100%) rename {extra => unmaintained}/4DNav/window3D/window3D-docs.factor (100%) rename {extra => unmaintained}/4DNav/window3D/window3D.factor (100%) rename {extra => unmaintained}/adsoda/adsoda-docs.factor (100%) rename {extra => unmaintained}/adsoda/adsoda-tests.factor (100%) rename {extra => unmaintained}/adsoda/adsoda.factor (100%) rename {extra => unmaintained}/adsoda/adsoda.tests (100%) rename {extra => unmaintained}/adsoda/authors.txt (100%) rename {extra => unmaintained}/adsoda/combinators/authors.txt (100%) rename {extra => unmaintained}/adsoda/combinators/combinators-docs.factor (100%) rename {extra => unmaintained}/adsoda/combinators/combinators-tests.factor (100%) rename {extra => unmaintained}/adsoda/combinators/combinators.factor (100%) rename {extra => unmaintained}/adsoda/solution2/solution2.factor (100%) rename {extra => unmaintained}/adsoda/solution2/summary.txt (100%) rename {extra => unmaintained}/adsoda/summary.txt (100%) rename {extra => unmaintained}/adsoda/tags.txt (100%) rename {extra => unmaintained}/adsoda/tools/authors.txt (100%) rename {extra => unmaintained}/adsoda/tools/tools-docs.factor (100%) rename {extra => unmaintained}/adsoda/tools/tools-tests.factor (100%) rename {extra => unmaintained}/adsoda/tools/tools.factor (100%) rename {extra => unmaintained}/ui/gadgets/plot/plot.factor (100%) rename {extra => unmaintained}/ui/gadgets/slate/authors.txt (100%) rename {extra => unmaintained}/ui/gadgets/slate/slate.factor (100%) rename {extra => unmaintained}/ui/gadgets/tiling/tiling.factor (100%) diff --git a/extra/4DNav/4DNav-docs.factor b/unmaintained/4DNav/4DNav-docs.factor similarity index 100% rename from extra/4DNav/4DNav-docs.factor rename to unmaintained/4DNav/4DNav-docs.factor diff --git a/extra/4DNav/4DNav.factor b/unmaintained/4DNav/4DNav.factor similarity index 100% rename from extra/4DNav/4DNav.factor rename to unmaintained/4DNav/4DNav.factor diff --git a/extra/4DNav/authors.txt b/unmaintained/4DNav/authors.txt similarity index 100% rename from extra/4DNav/authors.txt rename to unmaintained/4DNav/authors.txt diff --git a/extra/4DNav/camera/authors.txt b/unmaintained/4DNav/camera/authors.txt similarity index 100% rename from extra/4DNav/camera/authors.txt rename to unmaintained/4DNav/camera/authors.txt diff --git a/extra/4DNav/camera/camera-docs.factor b/unmaintained/4DNav/camera/camera-docs.factor similarity index 100% rename from extra/4DNav/camera/camera-docs.factor rename to unmaintained/4DNav/camera/camera-docs.factor diff --git a/extra/4DNav/camera/camera.factor b/unmaintained/4DNav/camera/camera.factor similarity index 100% rename from extra/4DNav/camera/camera.factor rename to unmaintained/4DNav/camera/camera.factor diff --git a/extra/4DNav/deep/deep-docs.factor b/unmaintained/4DNav/deep/deep-docs.factor similarity index 100% rename from extra/4DNav/deep/deep-docs.factor rename to unmaintained/4DNav/deep/deep-docs.factor diff --git a/extra/4DNav/deep/deep.factor b/unmaintained/4DNav/deep/deep.factor similarity index 100% rename from extra/4DNav/deep/deep.factor rename to unmaintained/4DNav/deep/deep.factor diff --git a/extra/4DNav/deploy.factor b/unmaintained/4DNav/deploy.factor similarity index 100% rename from extra/4DNav/deploy.factor rename to unmaintained/4DNav/deploy.factor diff --git a/extra/4DNav/file-chooser/authors.txt b/unmaintained/4DNav/file-chooser/authors.txt similarity index 100% rename from extra/4DNav/file-chooser/authors.txt rename to unmaintained/4DNav/file-chooser/authors.txt diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/unmaintained/4DNav/file-chooser/file-chooser.factor similarity index 100% rename from extra/4DNav/file-chooser/file-chooser.factor rename to unmaintained/4DNav/file-chooser/file-chooser.factor diff --git a/extra/4DNav/hypercube.xml b/unmaintained/4DNav/hypercube.xml similarity index 100% rename from extra/4DNav/hypercube.xml rename to unmaintained/4DNav/hypercube.xml diff --git a/extra/4DNav/light_test.xml b/unmaintained/4DNav/light_test.xml similarity index 100% rename from extra/4DNav/light_test.xml rename to unmaintained/4DNav/light_test.xml diff --git a/extra/4DNav/multi solids.xml b/unmaintained/4DNav/multi solids.xml similarity index 100% rename from extra/4DNav/multi solids.xml rename to unmaintained/4DNav/multi solids.xml diff --git a/extra/4DNav/prismetriagone.xml b/unmaintained/4DNav/prismetriagone.xml similarity index 100% rename from extra/4DNav/prismetriagone.xml rename to unmaintained/4DNav/prismetriagone.xml diff --git a/extra/4DNav/space-file-decoder/authors.txt b/unmaintained/4DNav/space-file-decoder/authors.txt similarity index 100% rename from extra/4DNav/space-file-decoder/authors.txt rename to unmaintained/4DNav/space-file-decoder/authors.txt diff --git a/extra/4DNav/space-file-decoder/space-file-decoder-docs.factor b/unmaintained/4DNav/space-file-decoder/space-file-decoder-docs.factor similarity index 100% rename from extra/4DNav/space-file-decoder/space-file-decoder-docs.factor rename to unmaintained/4DNav/space-file-decoder/space-file-decoder-docs.factor diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/unmaintained/4DNav/space-file-decoder/space-file-decoder.factor similarity index 100% rename from extra/4DNav/space-file-decoder/space-file-decoder.factor rename to unmaintained/4DNav/space-file-decoder/space-file-decoder.factor diff --git a/extra/4DNav/summary.txt b/unmaintained/4DNav/summary.txt similarity index 100% rename from extra/4DNav/summary.txt rename to unmaintained/4DNav/summary.txt diff --git a/extra/4DNav/tags.txt b/unmaintained/4DNav/tags.txt similarity index 100% rename from extra/4DNav/tags.txt rename to unmaintained/4DNav/tags.txt diff --git a/extra/4DNav/triancube.xml b/unmaintained/4DNav/triancube.xml similarity index 100% rename from extra/4DNav/triancube.xml rename to unmaintained/4DNav/triancube.xml diff --git a/extra/4DNav/turtle/authors.txt b/unmaintained/4DNav/turtle/authors.txt similarity index 100% rename from extra/4DNav/turtle/authors.txt rename to unmaintained/4DNav/turtle/authors.txt diff --git a/extra/4DNav/turtle/turtle-docs.factor b/unmaintained/4DNav/turtle/turtle-docs.factor similarity index 100% rename from extra/4DNav/turtle/turtle-docs.factor rename to unmaintained/4DNav/turtle/turtle-docs.factor diff --git a/extra/4DNav/turtle/turtle.factor b/unmaintained/4DNav/turtle/turtle.factor similarity index 100% rename from extra/4DNav/turtle/turtle.factor rename to unmaintained/4DNav/turtle/turtle.factor diff --git a/extra/4DNav/window3D/authors.txt b/unmaintained/4DNav/window3D/authors.txt similarity index 100% rename from extra/4DNav/window3D/authors.txt rename to unmaintained/4DNav/window3D/authors.txt diff --git a/extra/4DNav/window3D/window3D-docs.factor b/unmaintained/4DNav/window3D/window3D-docs.factor similarity index 100% rename from extra/4DNav/window3D/window3D-docs.factor rename to unmaintained/4DNav/window3D/window3D-docs.factor diff --git a/extra/4DNav/window3D/window3D.factor b/unmaintained/4DNav/window3D/window3D.factor similarity index 100% rename from extra/4DNav/window3D/window3D.factor rename to unmaintained/4DNav/window3D/window3D.factor diff --git a/extra/adsoda/adsoda-docs.factor b/unmaintained/adsoda/adsoda-docs.factor similarity index 100% rename from extra/adsoda/adsoda-docs.factor rename to unmaintained/adsoda/adsoda-docs.factor diff --git a/extra/adsoda/adsoda-tests.factor b/unmaintained/adsoda/adsoda-tests.factor similarity index 100% rename from extra/adsoda/adsoda-tests.factor rename to unmaintained/adsoda/adsoda-tests.factor diff --git a/extra/adsoda/adsoda.factor b/unmaintained/adsoda/adsoda.factor similarity index 100% rename from extra/adsoda/adsoda.factor rename to unmaintained/adsoda/adsoda.factor diff --git a/extra/adsoda/adsoda.tests b/unmaintained/adsoda/adsoda.tests similarity index 100% rename from extra/adsoda/adsoda.tests rename to unmaintained/adsoda/adsoda.tests diff --git a/extra/adsoda/authors.txt b/unmaintained/adsoda/authors.txt similarity index 100% rename from extra/adsoda/authors.txt rename to unmaintained/adsoda/authors.txt diff --git a/extra/adsoda/combinators/authors.txt b/unmaintained/adsoda/combinators/authors.txt similarity index 100% rename from extra/adsoda/combinators/authors.txt rename to unmaintained/adsoda/combinators/authors.txt diff --git a/extra/adsoda/combinators/combinators-docs.factor b/unmaintained/adsoda/combinators/combinators-docs.factor similarity index 100% rename from extra/adsoda/combinators/combinators-docs.factor rename to unmaintained/adsoda/combinators/combinators-docs.factor diff --git a/extra/adsoda/combinators/combinators-tests.factor b/unmaintained/adsoda/combinators/combinators-tests.factor similarity index 100% rename from extra/adsoda/combinators/combinators-tests.factor rename to unmaintained/adsoda/combinators/combinators-tests.factor diff --git a/extra/adsoda/combinators/combinators.factor b/unmaintained/adsoda/combinators/combinators.factor similarity index 100% rename from extra/adsoda/combinators/combinators.factor rename to unmaintained/adsoda/combinators/combinators.factor diff --git a/extra/adsoda/solution2/solution2.factor b/unmaintained/adsoda/solution2/solution2.factor similarity index 100% rename from extra/adsoda/solution2/solution2.factor rename to unmaintained/adsoda/solution2/solution2.factor diff --git a/extra/adsoda/solution2/summary.txt b/unmaintained/adsoda/solution2/summary.txt similarity index 100% rename from extra/adsoda/solution2/summary.txt rename to unmaintained/adsoda/solution2/summary.txt diff --git a/extra/adsoda/summary.txt b/unmaintained/adsoda/summary.txt similarity index 100% rename from extra/adsoda/summary.txt rename to unmaintained/adsoda/summary.txt diff --git a/extra/adsoda/tags.txt b/unmaintained/adsoda/tags.txt similarity index 100% rename from extra/adsoda/tags.txt rename to unmaintained/adsoda/tags.txt diff --git a/extra/adsoda/tools/authors.txt b/unmaintained/adsoda/tools/authors.txt similarity index 100% rename from extra/adsoda/tools/authors.txt rename to unmaintained/adsoda/tools/authors.txt diff --git a/extra/adsoda/tools/tools-docs.factor b/unmaintained/adsoda/tools/tools-docs.factor similarity index 100% rename from extra/adsoda/tools/tools-docs.factor rename to unmaintained/adsoda/tools/tools-docs.factor diff --git a/extra/adsoda/tools/tools-tests.factor b/unmaintained/adsoda/tools/tools-tests.factor similarity index 100% rename from extra/adsoda/tools/tools-tests.factor rename to unmaintained/adsoda/tools/tools-tests.factor diff --git a/extra/adsoda/tools/tools.factor b/unmaintained/adsoda/tools/tools.factor similarity index 100% rename from extra/adsoda/tools/tools.factor rename to unmaintained/adsoda/tools/tools.factor diff --git a/extra/ui/gadgets/plot/plot.factor b/unmaintained/ui/gadgets/plot/plot.factor similarity index 100% rename from extra/ui/gadgets/plot/plot.factor rename to unmaintained/ui/gadgets/plot/plot.factor diff --git a/extra/ui/gadgets/slate/authors.txt b/unmaintained/ui/gadgets/slate/authors.txt similarity index 100% rename from extra/ui/gadgets/slate/authors.txt rename to unmaintained/ui/gadgets/slate/authors.txt diff --git a/extra/ui/gadgets/slate/slate.factor b/unmaintained/ui/gadgets/slate/slate.factor similarity index 100% rename from extra/ui/gadgets/slate/slate.factor rename to unmaintained/ui/gadgets/slate/slate.factor diff --git a/extra/ui/gadgets/tiling/tiling.factor b/unmaintained/ui/gadgets/tiling/tiling.factor similarity index 100% rename from extra/ui/gadgets/tiling/tiling.factor rename to unmaintained/ui/gadgets/tiling/tiling.factor From ed7b49df78e876c33c85fd468de5c380d8650a66 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 19:57:01 -0600 Subject: [PATCH 12/21] Windows vm now tries vm-console.image or vm.image first, then removes -console if it exists and tries to find the image again --- Makefile | 11 ++--- misc/factor-cygwin.sh | 2 - vm/Config.windows | 1 - vm/os-windows.c | 100 +++++++++++++++++++++++++----------------- vm/os-windows.h | 1 + 5 files changed, 64 insertions(+), 51 deletions(-) delete mode 100755 misc/factor-cygwin.sh diff --git a/Makefile b/Makefile index 769fdc793d..b41e756729 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ AR = ar LD = ld EXECUTABLE = factor -CONSOLE_EXECUTABLE = factor_console +CONSOLE_EXECUTABLE = factor-console VERSION = 0.92 IMAGE = factor.image @@ -140,15 +140,10 @@ zlib1.dll: winnt-x86-32: freetype6.dll zlib1.dll $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 - $(MAKE) winnt-finish winnt-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 - $(MAKE) winnt-finish - -winnt-finish: - cp misc/factor-cygwin.sh ./factor wince-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm @@ -169,10 +164,10 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) -factor_console: $(DLL_OBJS) $(EXE_OBJS) +factor-console: $(DLL_OBJS) $(EXE_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ - $(CFLAGS) $(CFLAGS_CONSOLE) -o $(EXECUTABLE)$(EXE_SUFFIX)$(CONSOLE_EXE_EXTENSION) $(EXE_OBJS) + $(CFLAGS) $(CFLAGS_CONSOLE) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) clean: rm -f vm/*.o diff --git a/misc/factor-cygwin.sh b/misc/factor-cygwin.sh deleted file mode 100755 index b3a3375919..0000000000 --- a/misc/factor-cygwin.sh +++ /dev/null @@ -1,2 +0,0 @@ -#! /bin/sh -./factor.com "$@" diff --git a/vm/Config.windows b/vm/Config.windows index 63aa396e06..41eca86b5c 100644 --- a/vm/Config.windows +++ b/vm/Config.windows @@ -2,7 +2,6 @@ CFLAGS += -DWINDOWS -mno-cygwin LIBS = -lm PLAF_DLL_OBJS += vm/os-windows.o EXE_EXTENSION=.exe -CONSOLE_EXE_EXTENSION=.com DLL_EXTENSION=.dll LINKER = $(CC) -shared -mno-cygwin -o LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) diff --git a/vm/os-windows.c b/vm/os-windows.c index c3e9e50cee..c4d29ea57f 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -59,39 +59,9 @@ void ffi_dlclose(F_DLL *dll) dll->dll = NULL; } -/* You must free() this yourself. */ -const F_CHAR *default_image_path(void) -{ - F_CHAR full_path[MAX_UNICODE_PATH]; - F_CHAR *ptr; - F_CHAR path_temp[MAX_UNICODE_PATH]; - - if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) - fatal_error("GetModuleFileName() failed", 0); - - if((ptr = wcsrchr(full_path, '.'))) - *ptr = 0; - - snwprintf(path_temp, sizeof(path_temp)-1, L"%s.image", full_path); - path_temp[sizeof(path_temp) - 1] = 0; - - return safe_strdup(path_temp); -} - -/* You must free() this yourself. */ -const F_CHAR *vm_executable_path(void) -{ - F_CHAR full_path[MAX_UNICODE_PATH]; - if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) - fatal_error("GetModuleFileName() failed", 0); - return safe_strdup(full_path); -} - -void primitive_existsp(void) +bool windows_stat(F_CHAR *path) { BY_HANDLE_FILE_INFORMATION bhfi; - - F_CHAR *path = unbox_u16_string(); HANDLE h = CreateFileW(path, GENERIC_READ, FILE_SHARE_READ, @@ -107,17 +77,67 @@ void primitive_existsp(void) HANDLE h; if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st))) - dpush(F); - else - { - FindClose(h); - dpush(T); - } - return; + return false; + FindClose(h); + return true; + } + bool ret; + ret = GetFileInformationByHandle(h, &bhfi); + CloseHandle(h); + return ret; +} + +void windows_image_path(F_CHAR *full_path, F_CHAR *temp_path, unsigned int length) +{ + snwprintf(temp_path, length-1, L"%s.image", full_path); + temp_path[sizeof(temp_path) - 1] = 0; +} + +/* You must free() this yourself. */ +const F_CHAR *default_image_path(void) +{ + F_CHAR full_path[MAX_UNICODE_PATH]; + F_CHAR *ptr; + F_CHAR temp_path[MAX_UNICODE_PATH]; + + if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) + fatal_error("GetModuleFileName() failed", 0); + + if((ptr = wcsrchr(full_path, '.'))) + *ptr = 0; + + snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path); + temp_path[sizeof(temp_path) - 1] = 0; + + if(!windows_stat(temp_path)) { + unsigned int len = wcslen(full_path); + F_CHAR magic[] = L"-console"; + unsigned int magic_len = wcslen(magic); + + if(!wcsncmp(full_path + len - magic_len, magic, MIN(len, magic_len))) + full_path[len - magic_len] = 0; + snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path); + temp_path[sizeof(temp_path) - 1] = 0; } - box_boolean(GetFileInformationByHandle(h, &bhfi)); - CloseHandle(h); + return safe_strdup(temp_path); +} + +/* You must free() this yourself. */ +const F_CHAR *vm_executable_path(void) +{ + F_CHAR full_path[MAX_UNICODE_PATH]; + if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) + fatal_error("GetModuleFileName() failed", 0); + return safe_strdup(full_path); +} + + +void primitive_existsp(void) +{ + + F_CHAR *path = unbox_u16_string(); + box_boolean(windows_stat(path)); } F_SEGMENT *alloc_segment(CELL size) diff --git a/vm/os-windows.h b/vm/os-windows.h index a9c3f6d803..0704459dd0 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -19,6 +19,7 @@ typedef wchar_t F_CHAR; #define STRCMP wcscmp #define STRNCMP wcsncmp #define STRDUP _wcsdup +#define MIN(a,b) ((a)>(b)?(b):(a)) #ifdef WIN64 #define CELL_FORMAT "%Iu" From b21e40fe958517fd09ee08d6327f90bba3038573 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 21:03:16 -0600 Subject: [PATCH 13/21] fix windows backend --- basis/io/backend/unix/unix.factor | 2 +- basis/io/backend/windows/nt/nt.factor | 4 ++-- build-support/factor.sh | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index e25550590f..c4883f54ef 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -164,7 +164,7 @@ M: stdin refill size-read-fd init-fd >>size data-read-fd >>data ; -M: unix (init-stdio) ( -- ) +M: unix (init-stdio) 1 2 ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index b114cefdc0..c6b24a0a11 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -120,9 +120,9 @@ M: winnt (wait-to-read) ( port -- ) tri ] with-destructors ; -: console-app? ( -- ? ) GetConsoleWindow ; +: console-app? ( -- ? ) GetConsoleWindow >boolean ; M: winnt (init-stdio) - console-app? [ f f f f ] [ init-c-stdio t ] if ; + console-app? [ init-c-stdio t ] [ f f f f ] if ; winnt set-io-backend diff --git a/build-support/factor.sh b/build-support/factor.sh index 3517d8f4ba..44c047155d 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -236,7 +236,7 @@ find_word_size() { set_factor_binary() { case $OS in - winnt) FACTOR_BINARY=factor.com;; + winnt) FACTOR_BINARY=factor-console.exe;; *) FACTOR_BINARY=factor;; esac } From c1e09147e393c8d44656dc5ec40f99c07c71d1db Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 21:11:18 -0600 Subject: [PATCH 14/21] fix docs typo --- basis/io/directories/search/search-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index 8944f17dff..99135b7953 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -52,7 +52,7 @@ HELP: find-all-in-directories { find-file find-all-files find-in-directories find-all-in-directories } related-words -ARTICLE: "io.directories.search" "io.directories.search" +ARTICLE: "io.directories.search" "Searching directories" "The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl "Traversing directories:" { $subsection recursive-directory } From 1a1ed1b7a3cd552de43aa16d6fc7546892969231 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 21:11:35 -0600 Subject: [PATCH 15/21] split-last "." on windows --- basis/bootstrap/stage2.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 13f943898c..b521244fe0 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -13,7 +13,7 @@ SYMBOL: core-bootstrap-time SYMBOL: bootstrap-time : default-image-name ( -- string ) - vm file-name os windows? [ "." split1 drop ] when + vm file-name os windows? [ "." split1-last drop ] when ".image" append resource-path ; : do-crossref ( -- ) From 2f9ad7e4921064702efcffb025ca4b154069ac1b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 21:13:49 -0600 Subject: [PATCH 16/21] add using --- basis/io/monitors/linux/linux-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/monitors/linux/linux-tests.factor b/basis/io/monitors/linux/linux-tests.factor index 10b3801ea9..2170bd73a4 100644 --- a/basis/io/monitors/linux/linux-tests.factor +++ b/basis/io/monitors/linux/linux-tests.factor @@ -2,7 +2,7 @@ IN: io.monitors.linux.tests USING: io.monitors tools.test io.files io.files.temp io.directories system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint -destructors io.timeouts ; +destructors io.timeouts accessors ; ! On Linux, a notification on the directory itself would report an invalid ! path name From e4c697741814f452945e1c04f145dc1648c558c3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 21:25:02 -0600 Subject: [PATCH 17/21] fix some db docs --- basis/db/tuples/tuples-docs.factor | 2 +- basis/db/types/types-docs.factor | 51 +++++++++--------------------- 2 files changed, 16 insertions(+), 37 deletions(-) diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index e853c55ede..3d2971bf9c 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -90,7 +90,7 @@ HELP: ensure-table HELP: ensure-tables { $values - { "classes" null } } + { "classes" "a sequence of classes" } } { $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ; HELP: recreate-table diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index d5908740c6..b8ccbd976f 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -4,39 +4,24 @@ USING: classes hashtables help.markup help.syntax io.streams.string kernel sequences strings math ; IN: db.types -HELP: +autoincrement+ -{ $description "" } ; - HELP: +db-assigned-id+ { $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ; HELP: +default+ -{ $description "" } ; - -HELP: +foreign-id+ -{ $description "" } ; - -HELP: +has-many+ -{ $description "" } ; +{ $description "Allows a default value for a column to be provided." } ; HELP: +not-null+ -{ $description "" } ; +{ $description "Ensures that a column is not null." } ; HELP: +null+ -{ $description "" } ; +{ $description "Allows a column to be null." } ; HELP: +primary-key+ -{ $description "" } ; +{ $description "Makes a column a primary key. Only one column may be a primary key." } ; HELP: +random-id+ { $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ; -HELP: +serial+ -{ $description "" } ; - -HELP: +unique+ -{ $description "" } ; - HELP: +user-assigned-id+ { $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ; @@ -114,12 +99,12 @@ HELP: user-assigned-id-spec? HELP: bind# { $values - { "spec" null } { "obj" object } } + { "spec" "a sql spec" } { "obj" object } } { $description "" } ; HELP: bind% { $values - { "spec" null } } + { "spec" "a sql spec" } } { $description "" } ; HELP: compound @@ -176,7 +161,7 @@ HELP: low-level-binding HELP: modifiers { $values - { "spec" null } + { "spec" "a sql spec" } { "string" string } } { $description "" } ; @@ -187,7 +172,7 @@ HELP: no-sql-type HELP: normalize-spec { $values - { "spec" null } } + { "spec" "a sql spec" } } { $description "" } ; HELP: offset-of-slot @@ -204,7 +189,7 @@ HELP: persistent-table HELP: primary-key? { $values - { "spec" null } + { "spec" "a sql spec" } { "?" "a boolean" } } { $description "" } ; @@ -213,37 +198,31 @@ HELP: random-id-generator HELP: relation? { $values - { "spec" null } + { "spec" "a sql spec" } { "?" "a boolean" } } { $description "" } ; HELP: remove-db-assigned-id { $values - { "specs" null } + { "specs" "a sequence of sql specs" } { "obj" object } } { $description "" } ; HELP: remove-id { $values - { "specs" null } + { "specs" "a sequence of sql specs" } { "obj" object } } { $description "" } ; -HELP: remove-relations -{ $values - { "specs" null } - { "newcolumns" null } } -{ $description "" } ; - HELP: set-slot-named { $values - { "value" null } { "name" null } { "obj" object } } + { "value" object } { "name" string } { "obj" object } } { $description "" } ; HELP: spec>tuple { $values - { "class" class } { "spec" null } - { "tuple" null } } + { "class" class } { "spec" "a sql spec" } + { "tuple" tuple } } { $description "" } ; HELP: sql-spec From f9cd01683c4c081443f2dc4adb0b3a87434fa27b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 21:26:27 -0600 Subject: [PATCH 18/21] fix unix bootstrap --- basis/io/backend/unix/unix.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index c4883f54ef..4bc8868a3c 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -167,7 +167,7 @@ M: stdin refill M: unix (init-stdio) 1 - 2 ; + 2 t ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; From 858299c31f5790692d72957583a5661b2bac4f13 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 29 Jan 2009 22:08:28 -0600 Subject: [PATCH 19/21] Add support for GL_BGRA_ext --- basis/opengl/gl/gl.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index c32f62bf33..6181a72ffc 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -356,6 +356,10 @@ CONSTANT: GL_DITHER HEX: 0BD0 CONSTANT: GL_RGB HEX: 1907 CONSTANT: GL_RGBA HEX: 1908 +! GL_BGRA_ext: http://www.opengl.org/registry/specs/EXT/bgra.txt +CONSTANT: GL_BGR_EXT HEX: 80E0 +CONSTANT: GL_BGRA_EXT HEX: 80E1 + ! Implementation limits CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31 CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35 From 3c408342ef76e5ab434ecf43ff72ac80c62c8553 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 29 Jan 2009 22:19:07 -0600 Subject: [PATCH 20/21] renaming: contain? -> any?, deep-contains? -> deep-any?, pad-left -> pad-head, pad-right -> pad-tail, trim-left -> trim-head, trim-right -> trim-tail --- basis/base64/base64.factor | 4 +- basis/bootstrap/image/image.factor | 2 +- basis/calendar/format/format.factor | 6 +-- basis/checksums/sha1/sha1.factor | 2 +- basis/checksums/sha2/sha2.factor | 2 +- .../cfg/linearization/linearization.factor | 2 +- basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/tests/stack-trace.factor | 8 ++-- .../tree/builder/builder-tests.factor | 2 +- basis/compiler/tree/checker/checker.factor | 2 +- .../tree/cleanup/cleanup-tests.factor | 2 +- .../tree/combinators/combinators.factor | 4 +- .../tree/dead-code/simple/simple.factor | 2 +- .../tree/normalization/normalization.factor | 2 +- .../tree/propagation/branches/branches.factor | 0 .../tree/propagation/inlining/inlining.factor | 2 +- .../tree/tuple-unboxing/tuple-unboxing.factor | 2 +- basis/concurrency/mailboxes/mailboxes.factor | 2 +- basis/csv/csv.factor | 2 +- basis/db/queries/queries.factor | 2 +- basis/db/sqlite/sqlite.factor | 2 +- basis/db/types/types.factor | 6 +-- basis/dlists/dlists-docs.factor | 4 +- basis/dlists/dlists-tests.factor | 4 +- basis/dlists/dlists.factor | 4 +- basis/farkup/farkup.factor | 4 +- basis/formatting/formatting-docs.factor | 2 +- basis/formatting/formatting.factor | 10 ++--- .../listing-parser/listing-parser.factor | 2 +- .../features/edit-profile/edit-profile.factor | 2 +- basis/furnace/auth/login/login.factor | 2 +- basis/furnace/utilities/utilities.factor | 2 +- basis/help/lint/lint.factor | 4 +- basis/html/streams/streams.factor | 2 +- basis/http/client/client.factor | 2 +- basis/http/server/static/static.factor | 4 +- basis/io/directories/directories.factor | 4 +- basis/io/files/windows/nt/nt-tests.factor | 4 +- basis/io/files/windows/nt/nt.factor | 4 +- basis/io/monitors/monitors-tests.factor | 4 +- basis/io/styles/styles.factor | 2 +- .../rewrite/point-free/point-free.factor | 2 +- basis/locals/rewrite/sugar/sugar.factor | 4 +- basis/math/combinatorics/combinatorics.factor | 2 +- basis/math/intervals/intervals.factor | 2 +- basis/math/polynomials/polynomials.factor | 14 +++---- basis/peg/peg.factor | 2 +- .../quoted-printable/quoted-printable.factor | 2 +- basis/sequences/deep/deep-docs.factor | 6 +-- basis/sequences/deep/deep-tests.factor | 2 +- basis/sequences/deep/deep.factor | 4 +- basis/soundex/soundex.factor | 2 +- basis/stack-checker/backend/backend.factor | 2 +- basis/stack-checker/branches/branches.factor | 4 +- .../transforms/transforms.factor | 6 +-- basis/syndication/syndication.factor | 2 +- basis/tools/crossref/crossref-tests.factor | 2 +- basis/tools/disassembler/udis/udis.factor | 4 +- basis/tools/files/files.factor | 10 ++--- basis/tools/hexdump/hexdump.factor | 6 +-- basis/tools/scaffold/scaffold.factor | 4 +- basis/tools/vocabs/monitor/monitor.factor | 4 +- basis/ui/x11/x11.factor | 2 +- basis/unicode/collation/collation.factor | 4 +- basis/unicode/data/data.factor | 2 +- basis/unix/utmpx/utmpx.factor | 2 +- basis/urls/encoding/encoding.factor | 2 +- basis/uuid/uuid.factor | 2 +- basis/windows/ole32/ole32.factor | 4 +- basis/xml/utilities/utilities.factor | 2 +- basis/xml/writer/writer.factor | 2 +- basis/xml/xml.factor | 4 +- basis/xmode/marker/marker.factor | 2 +- core/assocs/assocs-docs.factor | 6 +-- core/assocs/assocs.factor | 4 +- core/checksums/checksums.factor | 2 +- core/classes/algebra/algebra.factor | 8 ++-- core/classes/builtin/builtin-tests.factor | 2 +- core/classes/tuple/tuple.factor | 2 +- core/classes/union/union.factor | 2 +- core/combinators/combinators.factor | 4 +- core/generic/generic-tests.factor | 8 ++-- core/io/pathnames/pathnames.factor | 28 ++++++------- core/sequences/sequences-docs.factor | 42 +++++++++---------- core/sequences/sequences-tests.factor | 12 +++--- core/sequences/sequences.factor | 24 +++++------ core/sets/sets-docs.factor | 2 +- core/sets/sets.factor | 2 +- core/strings/strings-tests.factor | 4 +- core/words/words-tests.factor | 2 +- core/words/words.factor | 2 +- extra/automata/automata.factor | 2 +- extra/benchmark/beust2/beust2.factor | 4 +- .../benchmark/knucleotide/knucleotide.factor | 2 +- extra/boolean-expr/boolean-expr.factor | 2 +- extra/crypto/hmac/hmac.factor | 2 +- extra/easy-help/easy-help.factor | 2 +- extra/inverse/inverse.factor | 4 +- extra/lint/lint.factor | 4 +- .../math/floating-point/floating-point.factor | 4 +- extra/money/money.factor | 2 +- .../parser-combinators.factor | 6 +-- extra/project-euler/043/043.factor | 2 +- extra/project-euler/046/046.factor | 2 +- extra/project-euler/059/059.factor | 2 +- extra/project-euler/project-euler.factor | 2 +- extra/sudoku/sudoku.factor | 16 +++---- extra/system-info/linux/linux.factor | 4 +- extra/tar/tar.factor | 4 +- misc/vim/syntax/factor.vim | 4 +- 110 files changed, 233 insertions(+), 233 deletions(-) mode change 100644 => 100755 basis/compiler/cfg/linearization/linearization.factor mode change 100644 => 100755 basis/compiler/codegen/codegen.factor mode change 100644 => 100755 basis/compiler/tests/stack-trace.factor mode change 100644 => 100755 basis/compiler/tree/builder/builder-tests.factor mode change 100644 => 100755 basis/compiler/tree/checker/checker.factor mode change 100644 => 100755 basis/compiler/tree/cleanup/cleanup-tests.factor mode change 100644 => 100755 basis/compiler/tree/combinators/combinators.factor mode change 100644 => 100755 basis/compiler/tree/dead-code/simple/simple.factor mode change 100644 => 100755 basis/compiler/tree/propagation/branches/branches.factor mode change 100644 => 100755 basis/compiler/tree/propagation/inlining/inlining.factor mode change 100644 => 100755 basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor mode change 100644 => 100755 basis/concurrency/mailboxes/mailboxes.factor mode change 100644 => 100755 basis/csv/csv.factor mode change 100644 => 100755 basis/db/queries/queries.factor mode change 100644 => 100755 basis/db/sqlite/sqlite.factor mode change 100644 => 100755 basis/db/types/types.factor mode change 100644 => 100755 basis/dlists/dlists-docs.factor mode change 100644 => 100755 basis/dlists/dlists-tests.factor mode change 100644 => 100755 basis/dlists/dlists.factor mode change 100644 => 100755 basis/farkup/farkup.factor mode change 100644 => 100755 basis/furnace/auth/features/edit-profile/edit-profile.factor mode change 100644 => 100755 basis/furnace/utilities/utilities.factor mode change 100644 => 100755 basis/help/lint/lint.factor mode change 100644 => 100755 basis/locals/rewrite/point-free/point-free.factor mode change 100644 => 100755 basis/locals/rewrite/sugar/sugar.factor mode change 100644 => 100755 basis/math/intervals/intervals.factor mode change 100644 => 100755 basis/sequences/deep/deep-docs.factor mode change 100644 => 100755 basis/sequences/deep/deep-tests.factor mode change 100644 => 100755 basis/sequences/deep/deep.factor mode change 100644 => 100755 basis/stack-checker/backend/backend.factor mode change 100644 => 100755 basis/stack-checker/branches/branches.factor mode change 100644 => 100755 basis/stack-checker/transforms/transforms.factor mode change 100644 => 100755 basis/syndication/syndication.factor mode change 100644 => 100755 basis/tools/crossref/crossref-tests.factor mode change 100644 => 100755 basis/tools/scaffold/scaffold.factor mode change 100644 => 100755 basis/unicode/collation/collation.factor mode change 100644 => 100755 basis/xml/utilities/utilities.factor mode change 100644 => 100755 basis/xml/writer/writer.factor mode change 100644 => 100755 basis/xml/xml.factor mode change 100644 => 100755 basis/xmode/marker/marker.factor mode change 100644 => 100755 core/assocs/assocs-docs.factor mode change 100644 => 100755 core/assocs/assocs.factor mode change 100644 => 100755 core/classes/algebra/algebra.factor mode change 100644 => 100755 core/classes/builtin/builtin-tests.factor mode change 100644 => 100755 core/classes/tuple/tuple.factor mode change 100644 => 100755 core/classes/union/union.factor mode change 100644 => 100755 core/combinators/combinators.factor mode change 100644 => 100755 core/generic/generic-tests.factor mode change 100644 => 100755 core/sequences/sequences-docs.factor mode change 100644 => 100755 core/sequences/sequences.factor mode change 100644 => 100755 core/sets/sets-docs.factor mode change 100644 => 100755 core/sets/sets.factor mode change 100644 => 100755 core/words/words-tests.factor mode change 100644 => 100755 core/words/words.factor mode change 100644 => 100755 extra/benchmark/beust2/beust2.factor mode change 100644 => 100755 extra/lint/lint.factor mode change 100644 => 100755 extra/project-euler/046/046.factor mode change 100644 => 100755 extra/sudoku/sudoku.factor mode change 100644 => 100755 misc/vim/syntax/factor.vim diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index a1668e7ce9..7f96e19430 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -45,8 +45,8 @@ SYMBOL: column ] with each ; inline : encode-pad ( seq n -- ) - [ 3 0 pad-right binary [ encode3 ] with-byte-writer ] - [ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline + [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ] + [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline ERROR: malformed-base64 ; diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 513b8972a6..221ffffb91 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -351,7 +351,7 @@ M: wrapper ' bootstrap-cell native> emit-seq ; : pad-bytes ( seq -- newseq ) - dup length bootstrap-cell align 0 pad-right ; + dup length bootstrap-cell align 0 pad-tail ; : extended-part ( str -- str' ) dup [ 128 < ] all? [ drop f ] [ diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index a7c4410aa5..15a4cb8266 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -5,11 +5,11 @@ sequences io accessors arrays io.streams.string splitting combinators accessors calendar calendar.format.macros present ; IN: calendar.format -: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ; +: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ; -: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ; +: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ; -: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ; +: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ; : write-00 ( n -- ) pad-00 write ; diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor index ede8a8f653..e7aee0dd09 100644 --- a/basis/checksums/sha1/sha1.factor +++ b/basis/checksums/sha1/sha1.factor @@ -128,7 +128,7 @@ M: sha1 checksum-stream ( stream -- sha1 ) [ zip concat ] keep like ; : sha1-interleave ( string -- seq ) - [ zero? ] trim-left + [ zero? ] trim-head dup length odd? [ rest ] when seq>2seq [ sha1 checksum-bytes ] bi@ 2seq>seq ; diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 898a695b34..026c4d6f27 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -62,7 +62,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; [ + + w+ ] 2dip swap set-nth ; inline : prepare-message-schedule ( seq -- w-seq ) - word-size get group [ be> ] map block-size get 0 pad-right + word-size get group [ be> ] map block-size get 0 pad-tail dup 16 64 dup [ process-M-256 ] with each ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor old mode 100644 new mode 100755 index 584c4cd662..8ef3abda39 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -63,7 +63,7 @@ M: ##compare-float-branch linearize-insn ##box-float ##box-alien } memq? - ] contains? ; + ] any? ; : linearize-basic-block ( bb -- ) [ number>> _label ] diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor old mode 100644 new mode 100755 index 3d7f574cf8..71d9c36412 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -400,7 +400,7 @@ M: no-such-symbol compiler-error-type : check-dlsym ( symbols dll -- ) dup dll-valid? [ - dupd '[ _ dlsym ] contains? + dupd '[ _ dlsym ] any? [ drop ] [ no-such-symbol ] if ] [ dll-path no-such-library drop diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor old mode 100644 new mode 100755 index c6cbb79ce5..cfbea3bcb9 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -19,14 +19,14 @@ words splitting grouping sorting accessors ; : bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ; -: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ; +: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ; [ t ] [ - [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains? + [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any? ] unit-test [ t f ] [ [ { "hi" } bleh ] ignore-errors - \ + stack-trace-contains? - \ > stack-trace-contains? + \ + stack-trace-any? + \ > stack-trace-any? ] unit-test diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor old mode 100644 new mode 100755 index 30244725b2..d758e2a34d --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -8,4 +8,4 @@ compiler.tree ; : inline-recursive ( -- ) inline-recursive ; inline recursive -[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test +[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? nip ] unit-test diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor old mode 100644 new mode 100755 index a5f18d6389..e25f152aef --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -175,7 +175,7 @@ M: #branch check-stack-flow* branch-out get [ ] find nip swap head* >vector datastack set ; M: #phi check-stack-flow* - branch-out get [ ] contains? [ + branch-out get [ ] any? [ [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri ] [ drop terminated? on ] if ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor old mode 100644 new mode 100755 index 71c6fb5675..751a335a13 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -498,7 +498,7 @@ cell-bits 32 = [ [ t ] [ [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree - [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains? + [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any? ] unit-test [ ] [ diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor old mode 100644 new mode 100755 index 030df8484f..1fffa06336 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/basis/compiler/tree/combinators/combinators.factor @@ -34,14 +34,14 @@ IN: compiler.tree.combinators dup dup '[ _ keep swap [ drop t ] [ dup #branch? [ - children>> [ _ contains-node? ] contains? + children>> [ _ contains-node? ] any? ] [ dup #recursive? [ child>> _ contains-node? ] [ drop f ] if ] if ] if - ] contains? ; inline recursive + ] any? ; inline recursive : select-children ( seq flags -- seq' ) [ [ drop f ] unless ] 2map ; diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor old mode 100644 new mode 100755 index 185c776c4e..886233a08b --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -79,7 +79,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ; : some-outputs-dead? ( #call -- ? ) - out-d>> [ live-value? not ] contains? ; + out-d>> [ live-value? not ] any? ; : maybe-drop-dead-outputs ( node -- nodes ) dup some-outputs-dead? [ diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index 8c13de296a..3f1e9e2667 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -60,7 +60,7 @@ M: #branch normalize* : eliminate-phi-introductions ( introductions seq terminated -- seq' ) [ [ nip ] [ - dup [ +bottom+ eq? ] trim-left + dup [ +bottom+ eq? ] trim-head [ [ length ] bi@ - tail* ] keep append ] if ] 3map ; diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor old mode 100644 new mode 100755 diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor old mode 100644 new mode 100755 index 7b3135e85c..f3b3238b4e --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -124,7 +124,7 @@ DEFER: (flat-length) [ class-types length 1 = ] [ union-class? not ] bi and - ] contains? ; + ] any? ; : node-count-bias ( -- n ) 45 node-count get [-] 8 /i ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor old mode 100644 new mode 100755 index f6726e4404..1e00efa835 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -118,7 +118,7 @@ M: #return-recursive unbox-tuples* ! These nodes never participate in unboxing : assert-not-unboxed ( values -- ) dup array? - [ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if + [ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if [ "Unboxing wrong value" throw ] when ; M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ; diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor old mode 100644 new mode 100755 index 63707041a2..656fbbb591 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -25,7 +25,7 @@ M: mailbox dispose* threads>> notify-all ; :: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- ) mailbox check-disposed - mailbox data>> pred dlist-contains? [ + mailbox data>> pred dlist-any? [ mailbox timeout wait-for-mailbox mailbox timeout pred block-unless-pred ] unless ; inline recursive diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor old mode 100644 new mode 100755 index 483a5825a9..bc3c25d347 --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -71,7 +71,7 @@ DEFER: quoted-field ( -- endchar ) delimiter swap with-variable ; inline : needs-escaping? ( cell -- ? ) - [ [ "\n\"" member? ] [ delimiter get = ] bi or ] contains? ; inline ! " + [ [ "\n\"" member? ] [ delimiter get = ] bi or ] any? ; inline : escape-quotes ( cell -- cell' ) [ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor old mode 100644 new mode 100755 index 2d7ea67107..495c25ea68 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -19,7 +19,7 @@ SINGLETON: retryable ] if ; : maybe-make-retryable ( statement -- statement ) - dup in-params>> [ generator-bind? ] contains? + dup in-params>> [ generator-bind? ] any? [ make-retryable ] when ; : regenerate-params ( statement -- statement ) diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor old mode 100644 new mode 100755 index 0f545030a3..fe3bb64d45 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -294,7 +294,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) ] with-string-writer ; : can-be-null? ( -- ? ) - "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ; + "sql-spec" get modifiers>> [ +not-null+ = ] any? not ; : delete-cascade? ( -- ? ) "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ; diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor old mode 100644 new mode 100755 index 2d4a6ff5fb..b5a7db987a --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -71,10 +71,10 @@ ERROR: not-persistent class ; primary-key>> +primary-key+? ; : db-assigned-id-spec? ( specs -- ? ) - [ primary-key>> +db-assigned-id+? ] contains? ; + [ primary-key>> +db-assigned-id+? ] any? ; : user-assigned-id-spec? ( specs -- ? ) - [ primary-key>> +user-assigned-id+? ] contains? ; + [ primary-key>> +user-assigned-id+? ] any? ; : normalize-spec ( spec -- ) dup type>> dup +primary-key+? [ @@ -105,7 +105,7 @@ FACTOR-BLOB NULL URL ; dup normalize-spec ; : spec>tuple ( class spec -- tuple ) - 3 f pad-right [ first3 ] keep 3 tail ; + 3 f pad-tail [ first3 ] keep 3 tail ; : number>string* ( n/string -- string ) dup number? [ number>string ] when ; diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor old mode 100644 new mode 100755 index ef6087f852..12e39746c7 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -15,7 +15,7 @@ $nl "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } -{ $subsection dlist-contains? } +{ $subsection dlist-any? } "Deleting a node matching a predicate:" { $subsection delete-node-if* } { $subsection delete-node-if } @@ -40,7 +40,7 @@ HELP: dlist-find "This operation is O(n)." } ; -HELP: dlist-contains? +HELP: dlist-any? { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } { $notes "This operation is O(n)." } ; diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor old mode 100644 new mode 100755 index 084aa0ac89..3689680157 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -46,8 +46,8 @@ IN: dlists.tests [ f f ] [ [ 1 = ] dlist-find ] unit-test [ 1 t ] [ 1 over push-back [ 1 = ] dlist-find ] unit-test [ f f ] [ 1 over push-back [ 2 = ] dlist-find ] unit-test -[ f ] [ 1 over push-back [ 2 = ] dlist-contains? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] dlist-contains? ] unit-test +[ f ] [ 1 over push-back [ 2 = ] dlist-any? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] dlist-any? ] unit-test [ 1 ] [ 1 over push-back [ 1 = ] delete-node-if ] unit-test [ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor old mode 100644 new mode 100755 index 8c575105d1..3d7224ed16 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -117,11 +117,11 @@ M: dlist pop-back* ( dlist -- ) : dlist-find ( dlist quot -- obj/f ? ) '[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline -: dlist-contains? ( dlist quot -- ? ) +: dlist-any? ( dlist quot -- ? ) dlist-find nip ; inline M: dlist deque-member? ( value dlist -- ? ) - [ = ] with dlist-contains? ; + [ = ] with dlist-any? ; M: dlist delete-node ( dlist-node dlist -- ) { diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor old mode 100644 new mode 100755 index b9e62717eb..ebd0bdb748 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -34,7 +34,7 @@ TUPLE: line ; TUPLE: line-break ; : absolute-url? ( string -- ? ) - { "http://" "https://" "ftp://" } [ head? ] with contains? ; + { "http://" "https://" "ftp://" } [ head? ] with any? ; : simple-link-title ( string -- string' ) dup absolute-url? [ "/" split1-last swap or ] unless ; @@ -162,7 +162,7 @@ stand-alone : check-url ( href -- href' ) { { [ dup empty? ] [ drop invalid-url ] } - { [ dup [ 127 > ] contains? ] [ drop invalid-url ] } + { [ dup [ 127 > ] any? ] [ drop invalid-url ] } { [ dup first "/\\" member? ] [ drop invalid-url ] } { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] } [ relative-link-prefix get prepend "" like ] diff --git a/basis/formatting/formatting-docs.factor b/basis/formatting/formatting-docs.factor index 196302f203..cfa322fb53 100644 --- a/basis/formatting/formatting-docs.factor +++ b/basis/formatting/formatting-docs.factor @@ -43,7 +43,7 @@ HELP: printf "string. For example:\n" { $list "\"%.3s\" formats a string to truncate at 3 characters (from the left)." - "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." + "\"%.10f\" formats a float to pad-tail with zeros up to 10 digits beyond the decimal point." "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent." } } diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index 3f12c36bbd..a55f0c77c5 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -29,7 +29,7 @@ IN: formatting [ 0 ] [ string>number ] if-empty ; : pad-digits ( string digits -- string' ) - [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ; + [ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ; : max-digits ( n digits -- n' ) 10 swap ^ [ * round ] keep / ; inline @@ -48,7 +48,7 @@ IN: formatting [ max-digits ] keep -rot [ [ 0 < "-" "+" ? ] - [ abs number>string 2 CHAR: 0 pad-left ] bi + [ abs number>string 2 CHAR: 0 pad-head ] bi "e" -rot 3append ] [ number>string ] bi* @@ -60,7 +60,7 @@ zero = "0" => [[ CHAR: 0 ]] char = "'" (.) => [[ second ]] pad-char = (zero|char)? => [[ CHAR: \s or ]] -pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]] +pad-align = ("-")? => [[ \ pad-tail \ pad-head ? ]] pad-width = ([0-9])* => [[ >digits ]] pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]] @@ -110,9 +110,9 @@ MACRO: printf ( format-string -- ) string 2 CHAR: 0 pad-left ; inline +: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline -: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline +: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-head ; inline : >time ( timestamp -- string ) [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array diff --git a/basis/ftp/client/listing-parser/listing-parser.factor b/basis/ftp/client/listing-parser/listing-parser.factor index 6183165b3a..6e2f9ebec4 100644 --- a/basis/ftp/client/listing-parser/listing-parser.factor +++ b/basis/ftp/client/listing-parser/listing-parser.factor @@ -39,7 +39,7 @@ name target ; : parse-list-11 ( lines -- seq ) [ - 11 f pad-right + 11 f pad-tail swap { [ 0 swap nth parse-permissions ] [ 1 swap nth string>number >>links ] diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor old mode 100644 new mode 100755 index cefb472b22..08c1a1abfe --- a/basis/furnace/auth/features/edit-profile/edit-profile.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile.factor @@ -31,7 +31,7 @@ IN: furnace.auth.features.edit-profile } validate-params { "password" "new-password" "verify-password" } - [ value empty? not ] contains? [ + [ value empty? not ] any? [ "password" value username check-login [ "incorrect password" validation-error ] unless diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index fff301eb2f..0ceafa7f86 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -16,7 +16,7 @@ IN: furnace.auth.login SYMBOL: permit-id : permit-id-key ( realm -- string ) - [ >hex 2 CHAR: 0 pad-left ] { } map-as concat + [ >hex 2 CHAR: 0 pad-head ] { } map-as concat "__p_" prepend ; : client-permit-id ( realm -- id/f ) diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor old mode 100644 new mode 100755 index f84519b9c1..e09047b74a --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -29,7 +29,7 @@ ERROR: no-such-word name vocab ; : base-path ( string -- pair ) dup responder-nesting get - [ second class superclasses [ name>> = ] with contains? ] with find nip + [ second class superclasses [ name>> = ] with any? ] with find nip [ first ] [ "No such responder: " swap append throw ] ?if ; : resolve-base-path ( string -- string' ) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor old mode 100644 new mode 100755 index 30d5ef49df..d3316a0c12 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -43,7 +43,7 @@ SYMBOL: vocabs-quot $predicate $class-description $error-description - } swap '[ _ elements empty? not ] contains? ; + } swap '[ _ elements empty? not ] any? ; : don't-check-word? ( word -- ? ) { @@ -103,7 +103,7 @@ SYMBOL: vocabs-quot [ "Missing whitespace between strings" throw ] unless ; : check-bogus-nl ( element -- ) - { { $nl } { { $nl } } } [ head? ] with contains? + { { $nl } { { $nl } } } [ head? ] with any? [ "Simple element should not begin with a paragraph break" throw ] when ; : check-elements ( element -- ) diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 709b65761e..24d9dceb80 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -55,7 +55,7 @@ TUPLE: html-sub-stream < html-stream style parent ; : hex-color, ( color -- ) [ red>> ] [ green>> ] [ blue>> ] tri - [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ; + [ 255 * >fixnum >hex 2 CHAR: 0 pad-head % ] tri@ ; : fg-css, ( color -- ) "color: #" % hex-color, "; " % ; diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index e7305ed372..cc1c67c31e 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -86,7 +86,7 @@ SYMBOL: redirects ] [ too-many-redirects ] if ; inline recursive : read-chunk-size ( -- n ) - read-crlf ";" split1 drop [ blank? ] trim-right + read-crlf ";" split1 drop [ blank? ] trim-tail hex> [ "Bad chunk size" throw ] unless* ; : read-chunked ( quot: ( chunk -- ) -- ) diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index b19bf2ae55..c910529d73 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -45,9 +45,9 @@ TUPLE: file-responder root hook special allow-listings ; [ file-responder get hook>> call ] [ 2drop <304> ] if ; : serving-path ( filename -- filename ) - file-responder get root>> trim-right-separators + file-responder get root>> trim-tail-separators "/" - rot "" or trim-left-separators 3append ; + rot "" or trim-head-separators 3append ; : serve-file ( filename -- response ) dup mime-type diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor index 6ae55b7f7b..30f4cebf8d 100755 --- a/basis/io/directories/directories.factor +++ b/basis/io/directories/directories.factor @@ -15,7 +15,7 @@ IN: io.directories HOOK: make-directory io-backend ( path -- ) : make-directories ( path -- ) - normalize-path trim-right-separators { + normalize-path trim-tail-separators { { [ dup "." = ] [ ] } { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } @@ -87,4 +87,4 @@ M: object copy-file { { [ os unix? ] [ "io.directories.unix" require ] } { [ os windows? ] [ "io.directories.windows" require ] } -} cond \ No newline at end of file +} cond diff --git a/basis/io/files/windows/nt/nt-tests.factor b/basis/io/files/windows/nt/nt-tests.factor index e934dc8cd2..b3bfecaafc 100644 --- a/basis/io/files/windows/nt/nt-tests.factor +++ b/basis/io/files/windows/nt/nt-tests.factor @@ -25,8 +25,8 @@ IN: io.files.windows.nt.tests [ t ] [ "\\\\" root-directory? ] unit-test [ t ] [ "/" root-directory? ] unit-test [ t ] [ "//" root-directory? ] unit-test -[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test -[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test +[ t ] [ "c:\\" trim-tail-separators root-directory? ] unit-test +[ t ] [ "Z:\\" trim-tail-separators root-directory? ] unit-test [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index 3241d19efa..9e449982fb 100755 --- a/basis/io/files/windows/nt/nt.factor +++ b/basis/io/files/windows/nt/nt.factor @@ -22,10 +22,10 @@ M: winnt root-directory? ( path -- ? ) { { [ dup empty? ] [ drop f ] } { [ dup [ path-separator? ] all? ] [ drop t ] } - { [ dup trim-right-separators { [ length 2 = ] + { [ dup trim-tail-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ drop t ] } { [ dup unicode-prefix head? ] - [ trim-right-separators length unicode-prefix length 2 + = ] } + [ trim-tail-separators length unicode-prefix length 2 + = ] } [ drop f ] } cond ; diff --git a/basis/io/monitors/monitors-tests.factor b/basis/io/monitors/monitors-tests.factor index 7c50a4e637..8252b6ef72 100644 --- a/basis/io/monitors/monitors-tests.factor +++ b/basis/io/monitors/monitors-tests.factor @@ -56,7 +56,7 @@ os { winnt linux macosx } member? [ "m" get next-change path>> dup print flush dup parent-directory - [ trim-right-separators "xyz" tail? ] either? not + [ trim-tail-separators "xyz" tail? ] either? not ] loop "c1" get count-down @@ -65,7 +65,7 @@ os { winnt linux macosx } member? [ "m" get next-change path>> dup print flush dup parent-directory - [ trim-right-separators "yxy" tail? ] either? not + [ trim-tail-separators "yxy" tail? ] either? not ] loop "c2" get count-down diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index 0e07c8bda9..64a28aabee 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -118,7 +118,7 @@ M: plain-writer make-block-stream : format-column ( seq ? -- seq ) [ [ 0 [ length max ] reduce ] keep - swap [ CHAR: \s pad-right ] curry map + swap [ CHAR: \s pad-tail ] curry map ] unless ; : map-last ( seq quot -- seq ) diff --git a/basis/locals/rewrite/point-free/point-free.factor b/basis/locals/rewrite/point-free/point-free.factor old mode 100644 new mode 100755 index 33e0f4d3b3..4e91e3d87b --- a/basis/locals/rewrite/point-free/point-free.factor +++ b/basis/locals/rewrite/point-free/point-free.factor @@ -40,7 +40,7 @@ M: object localize 1quotation ; ! We special-case all the :> at the start of a quotation : load-locals-quot ( args -- quot ) [ [ ] ] [ - dup [ local-reader? ] contains? [ + dup [ local-reader? ] any? [ dup [ local-reader? [ 1array ] [ ] ? ] map spread>quot ] [ [ ] ] if swap length [ load-locals ] curry append diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor old mode 100644 new mode 100755 index 515473c467..f0b8ac7240 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -33,9 +33,9 @@ GENERIC: rewrite-literal? ( obj -- ? ) M: special rewrite-literal? drop t ; -M: array rewrite-literal? [ rewrite-literal? ] contains? ; +M: array rewrite-literal? [ rewrite-literal? ] any? ; -M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; +M: quotation rewrite-literal? [ rewrite-literal? ] any? ; M: wrapper rewrite-literal? wrapped>> rewrite-literal? ; diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 1bc692ca54..d5dff65c35 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -25,7 +25,7 @@ IN: math.combinatorics reverse 1 cut [ (>permutation) ] each ; : permutation-indices ( n seq -- permutation ) - length [ factoradic ] dip 0 pad-left >permutation ; + length [ factoradic ] dip 0 pad-head >permutation ; PRIVATE> diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor old mode 100644 new mode 100755 index 86c3b0de0b..089de35ac5 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -77,7 +77,7 @@ TUPLE: interval { from read-only } { to read-only } ; [ from>> ] [ to>> ] bi ; : points>interval ( seq -- interval ) - dup [ first fp-nan? ] contains? + dup [ first fp-nan? ] any? [ drop [-inf,inf] ] [ dup first [ [ endpoint-min ] reduce ] diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 5783dfdf41..1ece3d915e 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -6,10 +6,10 @@ IN: math.polynomials : p= ( p q -- ? ) pextend = ; : ptrim ( p -- p ) - dup length 1 = [ [ zero? ] trim-right ] unless ; + dup length 1 = [ [ zero? ] trim-tail ] unless ; : 2ptrim ( p q -- p q ) [ ptrim ] bi@ ; : p+ ( p q -- r ) pextend v+ ; @@ -29,7 +29,7 @@ PRIVATE> : n*p ( n p -- n*p ) n*v ; : pextend-conv ( p q -- p q ) - 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ; + 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ; : p* ( p q -- r ) 2unempty pextend-conv dup length @@ -44,7 +44,7 @@ PRIVATE> 2ptrim 2dup [ length ] bi@ - dup 1 < [ drop 1 ] when - [ over length + 0 pad-left pextend ] keep 1+ ; + [ over length + 0 pad-head pextend ] keep 1+ ; : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 206a054d35..5ac62239d7 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -509,7 +509,7 @@ TUPLE: sp-parser p1 ; M: sp-parser (compile) ( peg -- quot ) p1>> compile-parser 1quotation '[ - input-slice [ blank? ] trim-left-slice input-from pos set @ + input-slice [ blank? ] trim-head-slice input-from pos set @ ] ; TUPLE: delay-parser quot ; diff --git a/basis/quoted-printable/quoted-printable.factor b/basis/quoted-printable/quoted-printable.factor index 83fee523a0..3be1a07eab 100644 --- a/basis/quoted-printable/quoted-printable.factor +++ b/basis/quoted-printable/quoted-printable.factor @@ -23,7 +23,7 @@ IN: quoted-printable : char>quoted ( ch -- str ) dup printable? [ 1string ] [ assure-small >hex >upper - 2 CHAR: 0 pad-left + 2 CHAR: 0 pad-head CHAR: = prefix ] if ; diff --git a/basis/sequences/deep/deep-docs.factor b/basis/sequences/deep/deep-docs.factor old mode 100644 new mode 100755 index f067e6ecdd..6193c7a7e8 --- a/basis/sequences/deep/deep-docs.factor +++ b/basis/sequences/deep/deep-docs.factor @@ -21,10 +21,10 @@ HELP: deep-find { $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } { $see-also find } ; -HELP: deep-contains? +HELP: deep-any? { $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } } { $description "Tests whether the given object or any subnode satisfies the given quotation." } -{ $see-also contains? } ; +{ $see-also any? } ; HELP: flatten { $values { "obj" object } { "seq" "a sequence" } } @@ -41,7 +41,7 @@ ARTICLE: "sequences.deep" "Deep sequence combinators" { $subsection deep-map } { $subsection deep-filter } { $subsection deep-find } -{ $subsection deep-contains? } +{ $subsection deep-any? } { $subsection deep-change-each } "A utility word to collapse nested subsequences:" { $subsection flatten } ; diff --git a/basis/sequences/deep/deep-tests.factor b/basis/sequences/deep/deep-tests.factor old mode 100644 new mode 100755 index 2d3260f427..e26241abc3 --- a/basis/sequences/deep/deep-tests.factor +++ b/basis/sequences/deep/deep-tests.factor @@ -19,7 +19,7 @@ IN: sequences.deep.tests [ { { "heyhello" "hihello" } } ] [ "hey" 1array 1array [ [ change-something ] deep-change-each ] keep ] unit-test -[ t ] [ "foo" [ string? ] deep-contains? ] unit-test +[ t ] [ "foo" [ string? ] deep-any? ] unit-test [ "foo" ] [ "foo" [ string? ] deep-find ] unit-test diff --git a/basis/sequences/deep/deep.factor b/basis/sequences/deep/deep.factor old mode 100644 new mode 100755 index d942b3f4c4..bfc102fdc2 --- a/basis/sequences/deep/deep.factor +++ b/basis/sequences/deep/deep.factor @@ -33,10 +33,10 @@ M: object branch? drop f ; : deep-find ( obj quot -- elt ) (deep-find) drop ; inline -: deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline +: deep-any? ( obj quot -- ? ) (deep-find) nip ; inline : deep-all? ( obj quot -- ? ) - '[ @ not ] deep-contains? not ; inline + '[ @ not ] deep-any? not ; inline : deep-member? ( obj seq -- ? ) swap '[ diff --git a/basis/soundex/soundex.factor b/basis/soundex/soundex.factor index 164f634185..2fd928252f 100644 --- a/basis/soundex/soundex.factor +++ b/basis/soundex/soundex.factor @@ -14,7 +14,7 @@ TR: soundex-tr [ 2 [ = not ] assoc-filter values ] [ first ] bi prefix ; : first>upper ( seq -- seq' ) 1 head >upper ; -: trim-first ( seq -- seq' ) dup first [ = ] curry trim-left ; +: trim-first ( seq -- seq' ) dup first [ = ] curry trim-head ; : remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ; : remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ; : pad-4 ( first seq -- seq' ) "000" 3append 4 head ; diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor old mode 100644 new mode 100755 index 9516b8cd7d..b08bdd8436 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -147,7 +147,7 @@ M: object apply-object push-literal ; { { [ dup deferred? ] [ drop f ] } { [ dup crossref? not ] [ drop f ] } - [ def>> [ word? ] contains? ] + [ def>> [ word? ] any? ] } cond ; : ?missing-effect ( word -- ) diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor old mode 100644 new mode 100755 index aa179fe191..2eb4fb46a9 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -17,7 +17,7 @@ SYMBOL: +bottom+ : pad-with-bottom ( seq -- newseq ) dup empty? [ dup [ length ] map supremum - '[ _ +bottom+ pad-left ] map + '[ _ +bottom+ pad-head ] map ] unless ; : phi-inputs ( max-d-in pairs -- newseq ) @@ -108,7 +108,7 @@ M: callable infer-branch (infer-if) ] [ drop 2 consume-d - dup [ known [ curried? ] [ composed? ] bi or ] contains? [ + dup [ known [ curried? ] [ composed? ] bi or ] any? [ output-d [ rot [ drop call ] [ nip call ] if ] infer-quot-here diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor old mode 100644 new mode 100755 index 299dc1b551..7afac0440f --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -125,9 +125,9 @@ IN: stack-checker.transforms #! Can we use a fast byte array test here? { { [ dup length 8 < ] [ f ] } - { [ dup [ integer? not ] contains? ] [ f ] } - { [ dup [ 0 < ] contains? ] [ f ] } - { [ dup [ bit-member-n >= ] contains? ] [ f ] } + { [ dup [ integer? not ] any? ] [ f ] } + { [ dup [ 0 < ] any? ] [ f ] } + { [ dup [ bit-member-n >= ] any? ] [ f ] } [ t ] } cond nip ; diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor old mode 100644 new mode 100755 index b23910e200..76da6f049d --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -80,7 +80,7 @@ TUPLE: entry title url description date ; [ atom-entry-link >>url ] [ { "content" "summary" } any-tag-named - dup children>> [ string? not ] contains? + dup children>> [ string? not ] any? [ children>> xml>string ] [ children>string ] if >>description ] diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor old mode 100644 new mode 100755 index e7e2e55259..3d09802576 --- a/basis/tools/crossref/crossref-tests.factor +++ b/basis/tools/crossref/crossref-tests.factor @@ -10,4 +10,4 @@ M: integer foo + ; "resource:basis/tools/crossref/test/foo.factor" run-file [ t ] [ integer \ foo method \ + usage member? ] unit-test -[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test +[ t ] [ \ foo usage [ pathname? ] any? ] unit-test diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index a915551263..cb52b1d5db 100644 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -59,8 +59,8 @@ SINGLETON: udis-disassembler dup [ second length ] map supremum '[ [ - [ first >hex cell 2 * CHAR: 0 pad-left % ": " % ] - [ second _ CHAR: \s pad-right % " " % ] + [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ] + [ second _ CHAR: \s pad-tail % " " % ] [ third % ] tri ] "" make diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 936c682322..7508c37cac 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -9,22 +9,22 @@ IN: tools.files : dir-or-size ( file-info -- str ) dup directory? [ - drop "" 20 CHAR: \s pad-right + drop "" 20 CHAR: \s pad-tail ] [ - size>> number>string 20 CHAR: \s pad-left + size>> number>string 20 CHAR: \s pad-head ] if ; : listing-time ( timestamp -- string ) [ hour>> ] [ minute>> ] bi - [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ; + [ number>string 2 CHAR: 0 pad-head ] bi@ ":" glue ; : listing-date ( timestamp -- string ) [ month>> month-abbreviation ] - [ day>> number>string 2 CHAR: \s pad-left ] + [ day>> number>string 2 CHAR: \s pad-head ] [ dup year>> dup now year>> = [ drop listing-time ] [ nip number>string ] if - 5 CHAR: \s pad-left + 5 CHAR: \s pad-head ] tri 3array " " join ; : read>string ( ? -- string ) "r" "-" ? ; inline diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index d16d6b2595..b646760889 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -12,13 +12,13 @@ IN: tools.hexdump [ >hex write "h" write nl ] bi ; : write-offset ( lineno -- ) - 16 * >hex 8 CHAR: 0 pad-left write "h: " write ; + 16 * >hex 8 CHAR: 0 pad-head write "h: " write ; : >hex-digit ( digit -- str ) - >hex 2 CHAR: 0 pad-left " " append ; + >hex 2 CHAR: 0 pad-head " " append ; : >hex-digits ( bytes -- str ) - [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ; + [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ; : >ascii ( bytes -- str ) [ [ printable? ] keep CHAR: . ? ] "" map-as ; diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor old mode 100644 new mode 100755 index b6e8eb2a46..acea984700 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -22,7 +22,7 @@ ERROR: no-vocab vocab ; : contains-dot? ( string -- ? ) ".." swap subseq? ; -: contains-separator? ( string -- ? ) [ path-separator? ] contains? ; +: contains-separator? ( string -- ? ) [ path-separator? ] any? ; : check-vocab-name ( string -- string ) dup contains-dot? [ vocab-name-contains-dot ] when @@ -92,7 +92,7 @@ ERROR: no-vocab vocab ; ] if ; : lookup-type ( string -- object/string ? ) - "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-right + "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-tail H{ { "object" object } { "obj" object } { "quot" quotation } diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/tools/vocabs/monitor/monitor.factor index 4091cdd90c..1914da78b2 100644 --- a/basis/tools/vocabs/monitor/monitor.factor +++ b/basis/tools/vocabs/monitor/monitor.factor @@ -9,8 +9,8 @@ IN: tools.vocabs.monitor TR: convert-separators "/\\" ".." ; : vocab-dir>vocab-name ( path -- vocab ) - trim-left-separators - trim-right-separators + trim-head-separators + trim-tail-separators convert-separators ; : path>vocab-name ( path -- vocab ) diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index 666ebf2f18..34cff42777 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -144,7 +144,7 @@ M: world selection-notify-event : supported-type? ( atom -- ? ) { "UTF8_STRING" "STRING" "TEXT" } - [ x-atom = ] with contains? ; + [ x-atom = ] with any? ; : clipboard-for-atom ( atom -- clipboard ) { diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor old mode 100644 new mode 100755 index 69a8c314f6..a8bd788e2a --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -88,7 +88,7 @@ ducet insert-helpers : add ( char -- ) dup blocked? [ 1string , ] [ dup possible-bases dup length - [ ?combine ] with with contains? + [ ?combine ] with with any? [ drop ] [ 1string , ] if ] if ; @@ -138,7 +138,7 @@ PRIVATE> : insensitive= ( str1 str2 levels-removed -- ? ) [ [ collation-key ] dip - [ [ 0 = not ] trim-right but-last ] times + [ [ 0 = not ] trim-tail but-last ] times ] curry bi@ = ; PRIVATE> diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index e78b4c104a..2407b740b0 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -72,7 +72,7 @@ VALUE: properties : exclusions ( -- set ) exclusions-file utf8 file-lines - [ "#" split1 drop [ blank? ] trim-right hex> ] map harvest ; + [ "#" split1 drop [ blank? ] trim-tail hex> ] map harvest ; : remove-exclusions ( alist -- alist ) exclusions [ dup ] H{ } map>assoc assoc-diff ; diff --git a/basis/unix/utmpx/utmpx.factor b/basis/unix/utmpx/utmpx.factor index 6b70ceee2e..9f12bc599b 100644 --- a/basis/unix/utmpx/utmpx.factor +++ b/basis/unix/utmpx/utmpx.factor @@ -33,7 +33,7 @@ HOOK: new-utmpx-record os ( -- utmpx-record ) HOOK: utmpx>utmpx-record os ( utmpx -- utmpx-record ) : memory>string ( alien n -- string ) - memory>byte-array utf8 decode [ 0 = ] trim-right ; + memory>byte-array utf8 decode [ 0 = ] trim-tail ; M: unix new-utmpx-record utmpx-record new ; diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index f621384ede..7fed4b5f58 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -18,7 +18,7 @@ IN: urls.encoding : push-utf8 ( ch -- ) 1string utf8 encode - [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + [ CHAR: % , >hex 2 CHAR: 0 pad-head % ] each ; PRIVATE> diff --git a/basis/uuid/uuid.factor b/basis/uuid/uuid.factor index 337ea22df5..6caeb213a5 100644 --- a/basis/uuid/uuid.factor +++ b/basis/uuid/uuid.factor @@ -43,7 +43,7 @@ IN: uuid ] dip 76 shift bitor ; : uuid>string ( n -- string ) - >hex 32 CHAR: 0 pad-left + >hex 32 CHAR: 0 pad-head [ CHAR: - 20 ] dip insert-nth [ CHAR: - 16 ] dip insert-nth [ CHAR: - 12 ] dip insert-nth diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 05a306640d..3d080817bf 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -163,10 +163,10 @@ M: ole32-error error. ] keep ; : (guid-section%) ( guid quot len -- ) - [ call >hex ] dip CHAR: 0 pad-left % ; inline + [ call >hex ] dip CHAR: 0 pad-head % ; inline : (guid-byte%) ( guid byte -- ) - swap nth >hex 2 CHAR: 0 pad-left % ; inline + swap nth >hex 2 CHAR: 0 pad-head % ; inline : guid>string ( guid -- string ) [ diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor old mode 100644 new mode 100755 index 924ae56aa4..d286072be6 --- a/basis/xml/utilities/utilities.factor +++ b/basis/xml/utilities/utilities.factor @@ -8,7 +8,7 @@ IN: xml.utilities : children>string ( tag -- string ) children>> { { [ dup empty? ] [ drop "" ] } - { [ dup [ string? not ] contains? ] + { [ dup [ string? not ] any? ] [ "XML tag unexpectedly contains non-text children" throw ] } [ concat ] } cond ; diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor old mode 100644 new mode 100755 index 92bc18054a..146e67e70f --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -15,7 +15,7 @@ SYMBOL: xml-pprint? SYMBOL: indentation : sensitive? ( tag -- ? ) - sensitive-tags get swap '[ _ names-match? ] contains? ; + sensitive-tags get swap '[ _ names-match? ] any? ; : indent-string ( -- string ) xml-pprint? get diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor old mode 100644 new mode 100755 index fd749ce905..5ca486a57f --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -30,7 +30,7 @@ M: prolog process : before-main? ( -- ? ) xml-stack get { [ length 1 = ] - [ first second [ tag? ] contains? not ] + [ first second [ tag? ] any? not ] } 1&& ; M: directive process @@ -76,7 +76,7 @@ M: closer process : no-post-tags ( post -- post/* ) ! this does *not* affect the contents of the stack - dup [ tag? ] contains? [ multitags ] when ; + dup [ tag? ] any? [ multitags ] when ; : assure-tags ( seq -- seq ) ! this does *not* affect the contents of the stack diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor old mode 100644 new mode 100755 index 798807f198..cff0af2a98 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -15,7 +15,7 @@ ascii combinators.short-circuit accessors ; : keyword-number? ( keyword -- ? ) { [ current-rule-set highlight-digits?>> ] - [ dup [ digit? ] contains? ] + [ dup [ digit? ] any? ] [ dup [ digit? ] all? [ current-rule-set digit-re>> diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor old mode 100644 new mode 100755 index e088953db8..e5c43f3ed6 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -82,7 +82,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" { $subsection substitute } { $subsection substitute-here } { $subsection extract-keys } -{ $see-also key? assoc-contains? assoc-all? "sets" } ; +{ $see-also key? assoc-any? assoc-all? "sets" } ; ARTICLE: "assocs-mutation" "Storing keys and values in assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" @@ -115,7 +115,7 @@ $nl { $subsection assoc-map } { $subsection assoc-filter } { $subsection assoc-filter-as } -{ $subsection assoc-contains? } +{ $subsection assoc-any? } { $subsection assoc-all? } "Additional combinators:" { $subsection cache } @@ -231,7 +231,7 @@ HELP: assoc-filter-as { assoc-filter assoc-filter-as } related-words -HELP: assoc-contains? +HELP: assoc-any? { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } } { $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor old mode 100644 new mode 100755 index 730c9f6cb8..e46bb7abb6 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -70,11 +70,11 @@ PRIVATE> [ (assoc-each) partition ] [ drop ] 2bi tuck [ assoc-like ] 2bi@ ; inline -: assoc-contains? ( assoc quot -- ? ) +: assoc-any? ( assoc quot -- ? ) assoc-find 2nip ; inline : assoc-all? ( assoc quot -- ? ) - [ not ] compose assoc-contains? not ; inline + [ not ] compose assoc-any? not ; inline : at ( key assoc -- value/f ) at* drop ; inline diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index a3662fcaa6..98d36b21c3 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -25,4 +25,4 @@ M: checksum checksum-lines [ normalize-path (file-reader) ] dip checksum-stream ; : hex-string ( seq -- str ) - [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ; + [ >hex 2 CHAR: 0 pad-head ] { } map-as concat ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor old mode 100644 new mode 100755 index e71379ac1a..825cd67a4d --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -66,10 +66,10 @@ DEFER: (class-or) [ members>> ] dip [ class<= ] curry all? ; : right-anonymous-union<= ( first second -- ? ) - members>> [ class<= ] with contains? ; + members>> [ class<= ] with any? ; : left-anonymous-intersection<= ( first second -- ? ) - [ participants>> ] dip [ class<= ] curry contains? ; + [ participants>> ] dip [ class<= ] curry any? ; : right-anonymous-intersection<= ( first second -- ? ) participants>> [ class<= ] with all? ; @@ -125,7 +125,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; ] if ; M: anonymous-union (classes-intersect?) - members>> [ classes-intersect? ] with contains? ; + members>> [ classes-intersect? ] with any? ; M: anonymous-intersection (classes-intersect?) participants>> [ classes-intersect? ] with all? ; @@ -203,7 +203,7 @@ M: anonymous-complement (classes-intersect?) [ class<= ] [ swap class<= ] 2bi and ; : largest-class ( seq -- n elt ) - dup [ [ class< ] with contains? not ] curry find-last + dup [ [ class< ] with any? not ] curry find-last [ "Topological sort failed" throw ] unless* ; : sort-classes ( seq -- newseq ) diff --git a/core/classes/builtin/builtin-tests.factor b/core/classes/builtin/builtin-tests.factor old mode 100644 new mode 100755 index 32db9a3d6e..6f990d0d62 --- a/core/classes/builtin/builtin-tests.factor +++ b/core/classes/builtin/builtin-tests.factor @@ -6,5 +6,5 @@ USING: tools.test words sequences kernel memory accessors ; [ [ name>> "f?" = ] [ vocabulary>> "syntax" = ] bi and - ] contains? + ] any? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor old mode 100644 new mode 100755 index 4f40d838b7..6147dcfbdc --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -148,7 +148,7 @@ ERROR: bad-superclass class ; : tuple-prototype ( class -- prototype ) [ initial-values ] keep - over [ ] contains? [ slots>tuple ] [ 2drop f ] if ; + over [ ] any? [ slots>tuple ] [ 2drop f ] if ; : define-tuple-prototype ( class -- ) dup tuple-prototype "prototype" set-word-prop ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor old mode 100644 new mode 100755 index 81a0db52be..e0e86e40c0 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -31,7 +31,7 @@ M: union-class update-class define-union-predicate ; M: union-class rank-class drop 2 ; M: union-class instance? - "members" word-prop [ instance? ] with contains? ; + "members" word-prop [ instance? ] with any? ; M: union-class (flatten-class) members (flatten-class) ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor old mode 100644 new mode 100755 index 29a2e7a8bd..c4c18c1c62 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -127,9 +127,9 @@ ERROR: no-case ; : case>quot ( default assoc -- quot ) dup keys { { [ dup empty? ] [ 2drop ] } - { [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] } + { [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] } { [ dup contiguous-range? ] [ drop dispatch-case-quot ] } - { [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] } + { [ dup [ wrapper? ] any? not ] [ drop hash-case-quot ] } { [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] } [ drop linear-case-quot ] } cond ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor old mode 100644 new mode 100755 index aae76184ff..5465ee1b27 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -141,7 +141,7 @@ M: integer generic-forget-test-1 / ; [ t ] [ \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] contains? + [ name>> "integer=>generic-forget-test-1" = ] any? ] unit-test [ ] [ @@ -150,7 +150,7 @@ M: integer generic-forget-test-1 / ; [ f ] [ \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] contains? + [ name>> "integer=>generic-forget-test-1" = ] any? ] unit-test GENERIC: generic-forget-test-2 ( a b -- c ) @@ -159,7 +159,7 @@ M: sequence generic-forget-test-2 = ; [ t ] [ \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] contains? + [ name>> "sequence=>generic-forget-test-2" = ] any? ] unit-test [ ] [ @@ -168,7 +168,7 @@ M: sequence generic-forget-test-2 = ; [ f ] [ \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] contains? + [ name>> "sequence=>generic-forget-test-2" = ] any? ] unit-test GENERIC: generic-forget-test-3 ( a -- b ) diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index e81d8c2bfd..1673e73083 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -10,11 +10,11 @@ SYMBOL: current-directory : path-separator ( -- string ) os windows? "\\" "/" ? ; -: trim-right-separators ( str -- newstr ) - [ path-separator? ] trim-right ; +: trim-tail-separators ( str -- newstr ) + [ path-separator? ] trim-tail ; -: trim-left-separators ( str -- newstr ) - [ path-separator? ] trim-left ; +: trim-head-separators ( str -- newstr ) + [ path-separator? ] trim-head ; : last-path-separator ( path -- n ? ) [ length 1- ] keep [ path-separator? ] find-last-from ; @@ -28,7 +28,7 @@ ERROR: no-parent-directory path ; : parent-directory ( path -- parent ) dup root-directory? [ - trim-right-separators + trim-tail-separators dup last-path-separator [ 1+ cut ] [ @@ -55,7 +55,7 @@ ERROR: no-parent-directory path ; : append-path-empty ( path1 path2 -- path' ) { { [ dup head.? ] [ - rest trim-left-separators append-path-empty + rest trim-head-separators append-path-empty ] } { [ dup head..? ] [ drop no-parent-directory ] } [ nip ] @@ -84,19 +84,19 @@ PRIVATE> { { [ over empty? ] [ append-path-empty ] } { [ dup empty? ] [ drop ] } - { [ over trim-right-separators "." = ] [ nip ] } + { [ over trim-tail-separators "." = ] [ nip ] } { [ dup absolute-path? ] [ nip ] } - { [ dup head.? ] [ rest trim-left-separators append-path ] } + { [ dup head.? ] [ rest trim-head-separators append-path ] } { [ dup head..? ] [ - 2 tail trim-left-separators + 2 tail trim-head-separators [ parent-directory ] dip append-path ] } { [ over absolute-path? over first path-separator? and ] [ [ 2 head ] dip append ] } [ - [ trim-right-separators "/" ] dip - trim-left-separators 3append + [ trim-tail-separators "/" ] dip + trim-head-separators 3append ] } cond ; @@ -105,7 +105,7 @@ PRIVATE> : file-name ( path -- string ) dup root-directory? [ - trim-right-separators + trim-tail-separators dup last-path-separator [ 1+ tail ] [ drop "resource:" ?head [ file-name ] when ] if @@ -121,7 +121,7 @@ GENERIC: (normalize-path) ( path -- path' ) M: string (normalize-path) "resource:" ?head [ - trim-left-separators resource-path + trim-head-separators resource-path (normalize-path) ] [ current-directory get prepend-path @@ -140,4 +140,4 @@ M: pathname <=> [ string>> ] compare ; HOOK: home io-backend ( -- dir ) -M: object home "" resource-path ; \ No newline at end of file +M: object home "" resource-path ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor old mode 100644 new mode 100755 index ea7cf829c4..f213be4fe7 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -393,7 +393,7 @@ HELP: find-last-from { $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } } { $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ; -HELP: contains? +HELP: any? { $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } } { $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ; @@ -575,15 +575,15 @@ HELP: padding { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } } { $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ; -HELP: pad-left +HELP: pad-head { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } } { $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the left with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." } -{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ; +{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-head print ] each" "---ab\n-quux" } } ; -HELP: pad-right +HELP: pad-tail { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } } { $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the right with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." } -{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ; +{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-tail print ] each" "ab---\nquux-" } } ; HELP: sequence= { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } @@ -960,43 +960,43 @@ HELP: pusher } { $notes "Used to implement the " { $link filter } " word." } ; -HELP: trim-left +HELP: trim-head { $values { "seq" sequence } { "quot" quotation } { "newseq" sequence } } { $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." } { $example "" "USING: prettyprint math sequences ;" - "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left ." + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-head ." "{ 1 2 3 0 0 }" } ; -HELP: trim-left-slice +HELP: trim-head-slice { $values { "seq" sequence } { "quot" quotation } { "slice" slice } } { $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice" } { $example "" "USING: prettyprint math sequences ;" - "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left-slice ." + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-head-slice ." "T{ slice { from 2 } { to 7 } { seq { 0 0 1 2 3 0 0 } } }" } ; -HELP: trim-right +HELP: trim-tail { $values { "seq" sequence } { "quot" quotation } { "newseq" sequence } } { $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." } { $example "" "USING: prettyprint math sequences ;" - "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right ." + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail ." "{ 0 0 1 2 3 }" } ; -HELP: trim-right-slice +HELP: trim-tail-slice { $values { "seq" sequence } { "quot" quotation } { "slice" slice } } { $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice." } { $example "" "USING: prettyprint math sequences ;" - "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right-slice ." + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail-slice ." "T{ slice { from 0 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }" } ; @@ -1020,7 +1020,7 @@ HELP: trim-slice "T{ slice { from 2 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }" } ; -{ trim trim-slice trim-left trim-left-slice trim-right trim-right-slice } related-words +{ trim trim-slice trim-head trim-head-slice trim-tail trim-tail-slice } related-words HELP: sift { $values @@ -1407,8 +1407,8 @@ ARTICLE: "sequences-appending" "Appending sequences" { $subsection concat } { $subsection join } "A pair of words useful for aligning strings:" -{ $subsection pad-left } -{ $subsection pad-right } ; +{ $subsection pad-head } +{ $subsection pad-tail } ; ARTICLE: "sequences-slices" "Subsequences and slices" "Extracting a subsequence:" @@ -1463,7 +1463,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators" { $subsection push-if } { $subsection filter } "Testing if a sequence contains elements satisfying a predicate:" -{ $subsection contains? } +{ $subsection any? } { $subsection all? } { $subsection "sequence-2combinators" } { $subsection "sequence-3combinators" } ; @@ -1513,12 +1513,12 @@ ARTICLE: "sequences-search" "Searching sequences" ARTICLE: "sequences-trimming" "Trimming sequences" "Trimming words:" { $subsection trim } -{ $subsection trim-left } -{ $subsection trim-right } +{ $subsection trim-head } +{ $subsection trim-tail } "Potentially more efficient trim:" { $subsection trim-slice } -{ $subsection trim-left-slice } -{ $subsection trim-right-slice } ; +{ $subsection trim-head-slice } +{ $subsection trim-tail-slice } ; ARTICLE: "sequences-destructive-discussion" "When to use destructive operations" "Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:" diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 85c4636822..4ee860f384 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -225,13 +225,13 @@ unit-test [ -1./0. 0 delete-nth ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test -[ "" ] [ "" [ CHAR: \s = ] trim-left ] unit-test -[ "" ] [ "" [ CHAR: \s = ] trim-right ] unit-test -[ "" ] [ " " [ CHAR: \s = ] trim-left ] unit-test -[ "" ] [ " " [ CHAR: \s = ] trim-right ] unit-test +[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test +[ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test +[ "" ] [ " " [ CHAR: \s = ] trim-head ] unit-test +[ "" ] [ " " [ CHAR: \s = ] trim-tail ] unit-test [ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test -[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-left ] unit-test -[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-right ] unit-test +[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test +[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test [ 328350 ] [ 100 [ sq ] sigma ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor old mode 100644 new mode 100755 index 2a5c0c674c..2c30a62fe3 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -524,14 +524,14 @@ PRIVATE> : nths ( indices seq -- seq' ) [ nth ] curry map ; -: contains? ( seq quot -- ? ) +: any? ( seq quot -- ? ) find drop >boolean ; inline : member? ( elt seq -- ? ) - [ = ] with contains? ; + [ = ] with any? ; : memq? ( elt seq -- ? ) - [ eq? ] with contains? ; + [ eq? ] with any? ; : remove ( elt seq -- newseq ) [ = not ] with filter ; @@ -711,10 +711,10 @@ PRIVATE> [ ] curry ] dip compose if ; inline -: pad-left ( seq n elt -- padded ) +: pad-head ( seq n elt -- padded ) [ swap dup append-as ] padding ; -: pad-right ( seq n elt -- padded ) +: pad-tail ( seq n elt -- padded ) [ append ] padding ; : shorter? ( seq1 seq2 -- ? ) [ length ] bi@ < ; @@ -816,22 +816,22 @@ PRIVATE> dup slice? [ { } like ] when 0 over length rot ; inline -: trim-left-slice ( seq quot -- slice ) +: trim-head-slice ( seq quot -- slice ) over [ [ not ] compose find drop ] dip swap [ tail-slice ] [ dup length tail-slice ] if* ; inline -: trim-left ( seq quot -- newseq ) - over [ trim-left-slice ] dip like ; inline +: trim-head ( seq quot -- newseq ) + over [ trim-head-slice ] dip like ; inline -: trim-right-slice ( seq quot -- slice ) +: trim-tail-slice ( seq quot -- slice ) over [ [ not ] compose find-last drop ] dip swap [ 1+ head-slice ] [ 0 head-slice ] if* ; inline -: trim-right ( seq quot -- newseq ) - over [ trim-right-slice ] dip like ; inline +: trim-tail ( seq quot -- newseq ) + over [ trim-tail-slice ] dip like ; inline : trim-slice ( seq quot -- slice ) - [ trim-left-slice ] [ trim-right-slice ] bi ; inline + [ trim-head-slice ] [ trim-tail-slice ] bi ; inline : trim ( seq quot -- newseq ) over [ trim-slice ] dip like ; inline diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor old mode 100644 new mode 100755 index 428bf10401..a122aa1240 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -22,7 +22,7 @@ $nl "Adding elements to sets:" { $subsection adjoin } { $subsection conjoin } -{ $see-also member? memq? contains? all? "assocs-sets" } ; +{ $see-also member? memq? any? all? "assocs-sets" } ; ABOUT: "sets" diff --git a/core/sets/sets.factor b/core/sets/sets.factor old mode 100644 new mode 100755 index 3435298f6e..062b624e8f --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -41,7 +41,7 @@ PRIVATE> tester filter ; : intersects? ( seq1 seq2 -- ? ) - tester contains? ; + tester any? ; : diff ( seq1 seq2 -- newseq ) tester [ not ] compose filter ; diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 810e9051d8..5b71b13552 100644 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -43,8 +43,8 @@ IN: strings.tests ] unit-test -[ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test -[ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test +[ "05" ] [ "5" 2 CHAR: 0 pad-head ] unit-test +[ "666" ] [ "666" 2 CHAR: 0 pad-head ] unit-test [ 1 "" nth ] must-fail [ -6 "hello" nth ] must-fail diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor old mode 100644 new mode 100755 index 10c17a0e79..a22b6a5b97 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -188,7 +188,7 @@ SYMBOL: quot-uses-b [ all-words [ "compiled-uses" word-prop - keys [ "forgotten" word-prop ] contains? + keys [ "forgotten" word-prop ] any? ] filter ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor old mode 100644 new mode 100755 index 6a3b63ab8a..3197d0a6f6 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -144,7 +144,7 @@ SYMBOL: visited crossref get at keys [ word? ] filter [ - [ reset-on-redefine [ word-prop ] with contains? ] + [ reset-on-redefine [ word-prop ] with any? ] [ inline? ] bi or ] filter diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index 9001521490..35f02f8635 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -22,7 +22,7 @@ VAR: rule VAR: rule-number { 0 0 1 } { 0 0 0 } } ; -: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ; +: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-head string>digits ; : set-rule ( n -- ) dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ; diff --git a/extra/benchmark/beust2/beust2.factor b/extra/benchmark/beust2/beust2.factor old mode 100644 new mode 100755 index 2ba6ed9775..f96dc77961 --- a/extra/benchmark/beust2/beust2.factor +++ b/extra/benchmark/beust2/beust2.factor @@ -26,10 +26,10 @@ IN: benchmark.beust2 ] if ] [ f ] if ] - ] contains? ; inline recursive + ] any? ; inline recursive :: count-numbers ( max listener -- ) - 10 [ 1+ 1 1 0 max listener (count-numbers) ] contains? drop ; + 10 [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ; inline :: beust ( -- ) diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index 7e65059643..5264cd26de 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -8,7 +8,7 @@ IN: benchmark.knucleotide swap >float number>string "." split1 rot over length over < - [ CHAR: 0 pad-right ] + [ CHAR: 0 pad-tail ] [ head ] if "." glue ; : discard-lines ( -- ) diff --git a/extra/boolean-expr/boolean-expr.factor b/extra/boolean-expr/boolean-expr.factor index 8cb5acf74b..33e5e92e29 100644 --- a/extra/boolean-expr/boolean-expr.factor +++ b/extra/boolean-expr/boolean-expr.factor @@ -74,7 +74,7 @@ METHOD: satisfiable? { ⊥ } drop f ; [ \ ¬ instance? ] partition [ x>> ] map intersect empty? ; METHOD: satisfiable? { □ } - cnf [ (satisfiable?) ] contains? ; + cnf [ (satisfiable?) ] any? ; GENERIC: (expr.) ( expr -- ) diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 62103bf510..73b15b9473 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -27,7 +27,7 @@ MEMO: ipad ( -- seq ) 64 HEX: 36 ; MEMO: opad ( -- seq ) 64 HEX: 5c ; : init-hmac ( K -- o i ) - 64 0 pad-right + 64 0 pad-tail [ opad seq-bitxor ] keep ipad seq-bitxor ; diff --git a/extra/easy-help/easy-help.factor b/extra/easy-help/easy-help.factor index 151e66380d..37870abb0e 100644 --- a/extra/easy-help/easy-help.factor +++ b/extra/easy-help/easy-help.factor @@ -73,7 +73,7 @@ IN: easy-help string-lines 1 tail [ dup " " head? [ 4 tail ] [ ] if ] map - [ " " split1 [ " " first = ] trim-left 2array ] map + [ " " split1 [ " " first = ] trim-head 2array ] map \ $values prefix parsed diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 924a6d3814..a86e673c9c 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -86,7 +86,7 @@ SYMBOL: visited : flattenable? ( object -- ? ) { [ word? ] [ primitive? not ] [ { "inverse" "math-inverse" "pop-inverse" } - [ word-prop ] with contains? not + [ word-prop ] with any? not ] } 1&& ; : flatten ( quot -- expanded ) @@ -230,7 +230,7 @@ DEFER: _ : empty-inverse ( class -- quot ) deconstruct-pred - [ tuple>array rest [ ] contains? [ fail ] when ] + [ tuple>array rest [ ] any? [ fail ] when ] compose ; \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor old mode 100644 new mode 100755 index d3c8f7217f..998f2d42d7 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -98,8 +98,8 @@ def-hash get-global [ drop empty? not ] assoc-filter [ drop { - [ [ wrapper? ] deep-contains? ] - [ [ hashtable? ] deep-contains? ] + [ [ wrapper? ] deep-any? ] + [ [ hashtable? ] deep-any? ] } 1|| not ] assoc-filter diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor index 522f149bc1..e6e92919e2 100644 --- a/extra/math/floating-point/floating-point.factor +++ b/extra/math/floating-point/floating-point.factor @@ -32,9 +32,9 @@ IN: math.floating-point : double. ( double -- ) double>bits [ (double-sign) .b ] - [ (double-exponent-bits) >bin 11 CHAR: 0 pad-left bl print ] + [ (double-exponent-bits) >bin 11 CHAR: 0 pad-head bl print ] [ - (double-mantissa-bits) >bin 52 CHAR: 0 pad-left + (double-mantissa-bits) >bin 52 CHAR: 0 pad-head 11 [ bl ] times print ] tri ; diff --git a/extra/money/money.factor b/extra/money/money.factor index 553c473cce..1b9dee74b7 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -12,7 +12,7 @@ CHAR: $ \ currency-token set-global : (money>string) ( dollars cents -- string ) [ number>string ] bi@ [ 3 group "," join ] - [ 2 CHAR: 0 pad-left ] bi* "." glue ; + [ 2 CHAR: 0 pad-head ] bi* "." glue ; : money>string ( object -- string ) dollars/cents (money>string) currency-token get prefix ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 69f7a3bb92..8afbb2d03b 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -175,11 +175,11 @@ M: or-parser parse ( input parser1 -- list ) parsers>> 0 swap seq>list [ parse ] lazy-map-with lconcat ; -: trim-left-slice ( string -- string ) +: trim-head-slice ( string -- string ) #! Return a new string without any leading whitespace #! from the original string. dup empty? [ - dup first blank? [ rest-slice trim-left-slice ] when + dup first blank? [ rest-slice trim-head-slice ] when ] unless ; TUPLE: sp-parser p1 ; @@ -191,7 +191,7 @@ C: sp sp-parser ( p1 -- parser ) M: sp-parser parse ( input parser -- list ) #! Skip all leading whitespace from the input then call #! the parser on the remaining input. - [ trim-left-slice ] dip p1>> parse ; + [ trim-head-slice ] dip p1>> parse ; TUPLE: just-parser p1 ; diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index 3b330dbe4b..21e9ec8e60 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -73,7 +73,7 @@ PRIVATE> [ number>digits 3 0 pad-left ] map [ all-unique? ] filter ; + 1000 over [ number>digits 3 0 pad-head ] map [ all-unique? ] filter ; : overlap? ( seq -- ? ) [ first 2 tail* ] [ second 2 head ] bi = ; diff --git a/extra/project-euler/046/046.factor b/extra/project-euler/046/046.factor old mode 100644 new mode 100755 index 7f5ad9e0d8..b5ff6a9b81 --- a/extra/project-euler/046/046.factor +++ b/extra/project-euler/046/046.factor @@ -33,7 +33,7 @@ IN: project-euler.046 2 /i sqrt >integer [1,b] [ sq ] map ; : fits-conjecture? ( n -- ? ) - dup perfect-squares [ 2 * - ] with map [ prime? ] contains? ; + dup perfect-squares [ 2 * - ] with map [ prime? ] any? ; : next-odd-composite ( n -- m ) dup odd? [ 2 + ] [ 1+ ] if dup prime? [ next-odd-composite ] when ; diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor index bbeeff1eec..0abd753c09 100644 --- a/extra/project-euler/059/059.factor +++ b/extra/project-euler/059/059.factor @@ -53,7 +53,7 @@ IN: project-euler.059 : source-059 ( -- seq ) "resource:extra/project-euler/059/cipher1.txt" - ascii file-contents [ blank? ] trim-right "," split + ascii file-contents [ blank? ] trim-tail "," split [ string>number ] map ; TUPLE: rollover seq n ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 318cf8a2bb..f5bc95a8f7 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -31,7 +31,7 @@ IN: project-euler print readln string>number ; : number>euler ( n -- str ) - number>string 3 CHAR: 0 pad-left ; + number>string 3 CHAR: 0 pad-head ; : solution-path ( n -- str/f ) number>euler "project-euler." prepend diff --git a/extra/sudoku/sudoku.factor b/extra/sudoku/sudoku.factor old mode 100644 new mode 100755 index c02242e170..1554d3df20 --- a/extra/sudoku/sudoku.factor +++ b/extra/sudoku/sudoku.factor @@ -13,13 +13,13 @@ SYMBOL: board : >board ( row m n -- ) row set-nth ; : f>board ( m n -- ) f -rot >board ; -: row-contains? ( n y -- ? ) row member? ; -: col-contains? ( n x -- ? ) board get swap member? ; -: cell-contains? ( n x y i -- ? ) 3 /mod pair+ board> = ; +: row-any? ( n y -- ? ) row member? ; +: col-any? ( n x -- ? ) board get swap member? ; +: cell-any? ( n x y i -- ? ) 3 /mod pair+ board> = ; -: box-contains? ( n x y -- ? ) +: box-any? ( n x y -- ? ) [ 3 /i 3 * ] bi@ - 9 [ [ 3dup ] dip cell-contains? ] contains? + 9 [ [ 3dup ] dip cell-any? ] any? [ 3drop ] dip ; DEFER: search @@ -29,9 +29,9 @@ DEFER: search : attempt ( n x y -- ) { - { [ 3dup nip row-contains? ] [ 3drop ] } - { [ 3dup drop col-contains? ] [ 3drop ] } - { [ 3dup box-contains? ] [ 3drop ] } + { [ 3dup nip row-any? ] [ 3drop ] } + { [ 3dup drop col-any? ] [ 3drop ] } + { [ 3dup box-any? ] [ 3drop ] } [ assume ] } cond ; diff --git a/extra/system-info/linux/linux.factor b/extra/system-info/linux/linux.factor index d9c39ca6cf..00a49fb2a2 100644 --- a/extra/system-info/linux/linux.factor +++ b/extra/system-info/linux/linux.factor @@ -10,7 +10,7 @@ IN: system-info.linux : uname ( -- seq ) 65536 "char" [ (uname) io-error ] keep "\0" split harvest [ >string ] map - 6 "" pad-right ; + 6 "" pad-tail ; : sysname ( -- string ) uname first ; : nodename ( -- string ) uname second ; @@ -20,4 +20,4 @@ IN: system-info.linux : domainname ( -- string ) uname 5 swap nth ; : kernel-version ( -- seq ) - release ".-" split harvest 5 "" pad-right ; + release ".-" split harvest 5 "" pad-tail ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index bccaeb0103..a4413c07b3 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -17,7 +17,7 @@ SYMBOLS: base-dir filename ; : tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ; : read-c-string* ( n -- str/f ) - read [ zero? ] trim-right [ f ] when-empty ; + read [ zero? ] trim-tail [ f ] when-empty ; : read-tar-header ( -- obj ) \ tar-header new @@ -139,7 +139,7 @@ M: unknown-typeflag summary ( obj -- str ) : typeflag-L ( header -- ) drop ; ! [ read-data-blocks ] keep - ! >string [ zero? ] trim-right filename set + ! >string [ zero? ] trim-tail filename set ! filename get tar-prepend-path make-directories ; ! Multi volume continuation entry diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim old mode 100644 new mode 100755 index 90a3d46d50..7d847c7238 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -49,10 +49,10 @@ syn keyword factorCompileDirective inline foldable parsing " kernel vocab keywords syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple -syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-contains? assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys +syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-any? assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys syn keyword factorKeyword case dispatch-case-quot with-datastack no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f -syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth second change-each join set-repetition-len all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch +syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek any? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth second change-each join set-repetition-len all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc syn keyword factorKeyword 3array >array 4array pair? array pair 2array 1array resize-array array? syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln From fe886fc8f33b1c340cd4e4931e74cd4ec52d6fbd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 30 Jan 2009 03:45:51 -0600 Subject: [PATCH 21/21] Help lint: check for empty description elements --- basis/help/lint/lint.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index d3316a0c12..b5f8b78ea3 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -114,12 +114,22 @@ SYMBOL: vocabs-quot [ 2 [ [ string? ] all? ] filter [ first2 check-whitespace ] each ] } cleave ; +: check-descriptions ( element -- ) + { $description $class-description $var-description } + swap '[ + _ elements [ + rest { { } { "" } } member? + [ "Empty description" throw ] when + ] each + ] each ; + : check-markup ( element -- ) { [ check-elements ] [ check-rendering ] [ check-examples ] [ check-modules ] + [ check-descriptions ] } cleave ; : all-word-help ( words -- seq )