Merge branch 'master' of git://factorcode.org/git/factor

basis/unicode/breaks/breaks.factor

@@ -199,8 +199,8 @@ to: word-table
 : walk-down ( str i -- j )
     dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ;
 
-: word-break? ( table-entry i str -- ? )
-    spin {
+: word-break? ( str i table-entry -- ? )
+    {
         { t [ 2drop f ] }
         { f [ 2drop t ] }
         { check-letter-after
@@ -214,10 +214,10 @@ to: word-table
     } case ;
 
 :: word-break-next ( old-class new-char i str -- next-class ? )
-    new-char dup format/extended?
-    [ drop old-class dup { 1 2 3 } member? ] [
-        word-break-prop old-class over word-table-nth
-        i str word-break?
+    new-char format/extended?
+    [ old-class dup { 1 2 3 } member? ] [
+        new-char word-break-prop old-class over word-table-nth
+        [ str i ] dip word-break?
     ] if ;
 
 PRIVATE>

basis/xml/errors/errors-tests.factor

@@ -6,22 +6,27 @@ IN: xml.errors.tests
     '[ _ string>xml ] swap '[ _ = ] must-fail-with ;
 
 T{ no-entity f 1 10 "nbsp" } "<x>&nbsp;</x>" xml-error-test
-T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" }
-} "<x></y>" xml-error-test
+T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" } }
+    "<x></y>" xml-error-test
 T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
 T{ nonexist-ns f 1 5 "x" } "<x:y/>" xml-error-test
 T{ unopened f 1 5 } "</x>" xml-error-test
-T{ not-yes/no f 1 41 "maybe" } "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
+T{ not-yes/no f 1 41 "maybe" }
+    "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
 T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
 } "<?xml version='1.1' foo='bar'?><x/>" xml-error-test
-T{ bad-version f 1 28 "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
+T{ bad-version f 1 28 "5 million" }
+    "<?xml version='5 million'?><x/>" xml-error-test
 T{ notags f } "" xml-error-test
 T{ multitags } "<x/><y/>" xml-error-test
-T{ bad-prolog  f 1 26 T{ prolog f "1.0" "UTF-8" f }
-} "<x/><?xml version='1.0'?>" xml-error-test
+T{ bad-prolog  f 1 26 T{ prolog f "1.0" "UTF-8" f } }
+    "<x/><?xml version='1.0'?>" xml-error-test
 T{ capitalized-prolog f 1 6 "XmL" } "<?XmL version='1.0'?><x/>"
-xml-error-test
+    xml-error-test
 T{ pre/post-content f "x" t } "x<y/>" xml-error-test
 T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
-T{ bad-instruction f 1 11 T{ instruction f "xsl" }
-} "<x><?xsl?></x>" xml-error-test
+T{ bad-instruction f 1 11 T{ instruction f "xsl" } }
+    "<x><?xsl?></x>" xml-error-test
+T{ unclosed-quote f 1 13 } "<x value='/>" xml-error-test
+T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
+T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test

basis/xml/errors/errors.factor

@@ -32,17 +32,6 @@ M: no-entity summary ( obj -- str )
         "Entity does not exist: &" write thing>> write ";" print
     ] with-string-writer ;
 
-TUPLE: xml-string-error < parsing-error string ; ! this should not exist
-
-: xml-string-error ( string -- * )
-    \ xml-string-error parsing-error swap >>string throw ;
-
-M: xml-string-error summary ( obj -- str )
-    [
-        dup call-next-method write
-        string>> print
-    ] with-string-writer ;
-
 TUPLE: mismatched < parsing-error open close ;
 
 : mismatched ( open close -- * )
@@ -233,7 +222,34 @@ M: misplaced-directive summary ( obj -- str )
         dir>> write-xml-chunk nl
     ] with-string-writer ;
 
+TUPLE: bad-name < parsing-error name ;
+
+: bad-name ( name -- * )
+    \ bad-name parsing-error swap >>name throw ;
+
+M: bad-name summary ( obj -- str )
+    [ call-next-method ]
+    [ "Invalid name: " swap name>> "\n" 3append ]
+    bi append ;
+
+TUPLE: unclosed-quote < parsing-error ;
+
+: unclosed-quote ( -- * )
+    \ unclosed-quote parsing-error throw ;
+
+M: unclosed-quote summary
+    call-next-method
+    "XML document ends with quote still open\n" append ;
+
+TUPLE: quoteless-attr < parsing-error ;
+
+: quoteless-attr ( -- * )
+    \ quoteless-attr parsing-error throw ;
+
+M: quoteless-attr summary
+    call-next-method "Attribute lacks quotes around value\n" append ;
+
 UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
-       not-yes/no unclosed mismatched xml-string-error expected no-entity
+       not-yes/no unclosed mismatched expected no-entity
        bad-prolog versionless-prolog capitalized-prolog bad-instruction
-       bad-directive ;
+       bad-directive bad-name unclosed-quote quoteless-attr ;

basis/xml/tokenize/tokenize.factor

@@ -58,7 +58,7 @@ SYMBOL: ns-stack
     over {
         [ first name-start? ]
         [ rest-slice [ name-char? ] with all? ]
-    } 2&& [ "Malformed name" xml-string-error ] unless ;
+    } 2&& [ bad-name ] unless ;
 
 : (parse-name) ( start -- str )
     version=1.0?
@@ -102,7 +102,7 @@ SYMBOL: ns-stack
 
 : parse-quot ( ch -- string )
     parse-char get-char
-    [ "XML file ends in a quote" xml-string-error ] unless ;
+    [ unclosed-quote ] unless ;
 
 : parse-text ( -- string )
     CHAR: < parse-char ;
@@ -115,11 +115,8 @@ SYMBOL: ns-stack
     parse-name swap ;
 
 : parse-attr-value ( -- seq )
-    get-char dup "'\"" member? [
-        next parse-quot
-    ] [
-        "Attribute lacks quote" xml-string-error
-    ] if ;
+    get-char dup "'\"" member?
+    [ next parse-quot ] [ quoteless-attr ] if ;
 
 : parse-attr ( -- )
     [ parse-name ] with-scope
@@ -358,6 +355,6 @@ SYMBOL: string-input?
         { f [ "" ] }
         [ dup blank?
           [ drop pass-blank utf8 decode-input-if CHAR: < expect make-tag ]
-          [ 1string ] if ! Replace with proper error
+          [ 1string ] if ! Replace with proper error?
         ]
     } case ;

basis/xml/xml-docs.factor

@@ -295,9 +295,6 @@ HELP: expected
 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 parsing-error } ". Contains one slot, thing, containing a string representing the entity." } ;
 
-HELP: xml-string-error
-{ $class-description "XML parsing error that delegates to " { $link parsing-error } " and represents an other, unspecified error, which is represented by the slot string, containing a string describing the error." } ;
-
 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 <tag> } "." }
@@ -324,6 +321,15 @@ HELP: state-parse
 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." } ;
+
+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." } ;
+
+HELP: quoteless-attr
+{ $class-description "describes the error where an attribute of an XML tag is missing quotes around a value." } ;
+
 HELP: entities
 { $description "a hash table from default XML entity names (like &amp; and &lt;) to the characters they represent. This is automatically included when parsing any XML document." }
 { $see-also html-entities } ;
@@ -444,6 +450,9 @@ ARTICLE: { "xml" "errors" } "XML parsing errors"
     { $subsection expected }
     { $subsection no-entity }
     { $subsection pre/post-content }
+    { $subsection unclosed-quote }
+    { $subsection bad-name }
+    { $subsection quoteless-attr }
     "Additionally, most of these errors delegate to " { $link parsing-error } " in order to provide more information"
     $nl
     "Note that, in parsing an XML document, only the first error is reported." ;
@@ -456,7 +465,7 @@ ARTICLE: { "xml" "entities" } "XML entities"
     { $subsection with-html-entities } ;
 
 ARTICLE: "xml" "XML parser"
-"The " { $vocab-link "xml" } " vocabulary implements the XML 1.1 standard, 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."
     { $subsection { "xml" "reading" } }
     { $subsection { "xml" "writing" } }
     { $subsection { "xml" "classes" } }

extra/fuel/fuel.factor

@@ -141,7 +141,7 @@ PRIVATE>
 
 : fuel-get-article ( name -- ) article fuel-eval-set-result ;
 
-MEMO: fuel-get-article-title ( name -- )
+: fuel-get-article-title ( name -- )
     articles get at [ article-title ] [ f ] if* fuel-eval-set-result ;
 
 : fuel-word-help ( name -- ) (fuel-word-help) fuel-eval-set-result ;

misc/fuel/fuel-eval.el

@@ -31,6 +31,7 @@
         ((listp sexp)
          (case (car sexp)
            (:array (factor--seq 'V{ '} (cdr sexp)))
+           (:seq (factor--seq '{ '} (cdr sexp)))
            (:quote (format "\\ %s" (factor `(:factor ,(cadr sexp)))))
            (:quotation (factor--seq '\[ '\] (cdr sexp)))
            (:using (factor `(USING: ,@(cdr sexp) :end)))

misc/fuel/fuel-help.el

@@ -137,7 +137,8 @@
 
 (defun fuel-help--get-article (name label)
   (message "Retrieving article ...")
-  (let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t))
+  (let* ((name (if (listp name) (cons :seq name) name))
+         (cmd `(:fuel* ((,name fuel-get-article)) "fuel" t))
          (ret (fuel-eval--send/wait cmd))
          (res (fuel-eval--retort-result ret)))
     (if (not res)

misc/fuel/fuel-markup.el

@@ -61,7 +61,7 @@
 
 (defun fuel-markup--insert-button (label link type)
   (let ((label (format "%s" label))
-        (link (format "%s" link)))
+        (link (if (listp link) link (format "%s" link))))
     (insert-text-button label
                         :type 'fuel-markup--button
                         'markup-link link
@@ -70,8 +70,9 @@
                         'help-echo (format "%s (%s)" label type))))
 
 (defun fuel-markup--article-title (name)
-  (fuel-eval--retort-result
-   (fuel-eval--send/wait `(:fuel* ((,name fuel-get-article-title)) "fuel"))))
+  (let ((name (if (listp name) (cons :seq name) name)))
+    (fuel-eval--retort-result
+     (fuel-eval--send/wait `(:fuel* ((,name fuel-get-article-title)) "fuel")))))
 
 (defun fuel-markup--link-at-point ()
   (let ((button (condition-case nil (forward-button 0) (error nil))))