! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: io io.streams.string kernel math namespaces sequences\r
-strings circular prettyprint debugger ascii ;\r
+strings circular prettyprint debugger ascii sbufs fry inspector\r
+accessors sequences.lib ;\r
IN: state-parser\r
\r
! * Basic underlying words\r
\r
C: <spot> spot\r
\r
-: get-char ( -- char ) spot get spot-char ;\r
-: set-char ( char -- ) spot get set-spot-char ;\r
-: get-line ( -- line ) spot get spot-line ;\r
-: set-line ( line -- ) spot get set-spot-line ;\r
-: get-column ( -- column ) spot get spot-column ;\r
-: set-column ( column -- ) spot get set-spot-column ;\r
-: get-next ( -- char ) spot get spot-next ;\r
-: set-next ( char -- ) spot get set-spot-next ;\r
+: get-char ( -- char ) spot get char>> ;\r
+: set-char ( char -- ) spot get swap >>char drop ;\r
+: get-line ( -- line ) spot get line>> ;\r
+: set-line ( line -- ) spot get swap >>line drop ;\r
+: get-column ( -- column ) spot get column>> ;\r
+: set-column ( column -- ) spot get swap >>column drop ;\r
+: get-next ( -- char ) spot get next>> ;\r
+: set-next ( char -- ) spot get swap >>next drop ;\r
\r
! * Errors\r
TUPLE: parsing-error line column ;\r
-: <parsing-error> ( -- parsing-error )\r
- get-line get-column parsing-error boa ;\r
-\r
-: construct-parsing-error ( ... slots class -- error )\r
- construct <parsing-error> over set-delegate ; inline\r
-\r
-: parsing-error. ( parsing-error -- )\r
- "Parsing error" print\r
- "Line: " write dup parsing-error-line .\r
- "Column: " write parsing-error-column . ;\r
-\r
-TUPLE: expected should-be was ;\r
-: <expected> ( should-be was -- error )\r
- { set-expected-should-be set-expected-was }\r
- expected construct-parsing-error ;\r
-M: expected error.\r
- dup parsing-error.\r
- "Token expected: " write dup expected-should-be print\r
- "Token present: " write expected-was print ;\r
-\r
-TUPLE: unexpected-end ;\r
-: <unexpected-end> ( -- unexpected-end )\r
- { } unexpected-end construct-parsing-error ;\r
-M: unexpected-end error.\r
- parsing-error.\r
- "File unexpectedly ended." print ;\r
-\r
-TUPLE: missing-close ;\r
-: <missing-close> ( -- missing-close )\r
- { } missing-close construct-parsing-error ;\r
-M: missing-close error.\r
- parsing-error.\r
- "Missing closing token." print ;\r
+\r
+: parsing-error ( class -- obj )\r
+ new\r
+ get-line >>line\r
+ get-column >>column ;\r
+M: parsing-error summary ( obj -- str )\r
+ [\r
+ "Parsing error" print\r
+ "Line: " write dup line>> .\r
+ "Column: " write column>> .\r
+ ] with-string-writer ;\r
+\r
+TUPLE: expected < parsing-error should-be was ;\r
+: expected ( should-be was -- * )\r
+ \ expected parsing-error\r
+ swap >>was\r
+ swap >>should-be throw ;\r
+M: expected summary ( obj -- str )\r
+ [\r
+ dup call-next-method write\r
+ "Token expected: " write dup should-be>> print\r
+ "Token present: " write was>> print\r
+ ] with-string-writer ;\r
+\r
+TUPLE: unexpected-end < parsing-error ;\r
+: unexpected-end \ unexpected-end parsing-error throw ;\r
+M: unexpected-end summary ( obj -- str )\r
+ [\r
+ call-next-method write\r
+ "File unexpectedly ended." print\r
+ ] with-string-writer ;\r
+\r
+TUPLE: missing-close < parsing-error ;\r
+: missing-close \ missing-close parsing-error throw ;\r
+M: missing-close summary ( obj -- str )\r
+ [\r
+ call-next-method write\r
+ "Missing closing token." print\r
+ ] with-string-writer ;\r
\r
SYMBOL: prolog-data\r
\r
[ 0 get-line 1+ set-line ] [ get-column 1+ ] if\r
set-column ;\r
\r
-: (next) ( -- char ) ! this normalizes \r\n and \r\r
+! (next) normalizes \r\n and \r\r
+: (next) ( -- char )\r
get-next read1\r
2dup swap CHAR: \r = [\r
CHAR: \n =\r
\r
: next ( -- )\r
#! Increment spot.\r
- get-char [\r
- <unexpected-end> throw\r
- ] unless\r
- (next) record ;\r
+ get-char [ unexpected-end ] unless (next) record ;\r
\r
: next* ( -- )\r
get-char [ (next) record ] when ;\r
#! Take the substring of a string starting at spot\r
#! from code until the quotation given is true and\r
#! advance spot to after the substring.\r
- [ [\r
- dup slip swap dup [ get-char , ] unless\r
- ] skip-until ] "" make nip ; inline\r
+ 10 <sbuf> [\r
+ '[ @ [ t ] [ get-char , push f ] if ] skip-until\r
+ ] keep >string ; inline\r
\r
: take-rest ( -- string )\r
[ f ] take-until ;\r
: take-char ( ch -- string )\r
[ dup get-char = ] take-until nip ;\r
\r
+TUPLE: not-enough-characters < parsing-error ;\r
+: not-enough-characters\r
+ \ not-enough-characters parsing-error throw ;\r
+M: not-enough-characters summary ( obj -- str )\r
+ [\r
+ call-next-method write\r
+ "Not enough characters" print\r
+ ] with-string-writer ;\r
+\r
+: take ( n -- string )\r
+ [ 1- ] [ <sbuf> ] bi [\r
+ '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop\r
+ ] keep get-char [ over push ] when* >string ;\r
+\r
: pass-blank ( -- )\r
#! Advance code past any whitespace, including newlines\r
[ get-char blank? not ] skip-until ;\r
dup length <circular-string>\r
[ 2dup string-matches? ] take-until nip\r
dup length rot length 1- - head\r
- get-char [ <missing-close> throw ] unless next ;\r
+ get-char [ missing-close ] unless next ;\r
\r
: expect ( ch -- )\r
get-char 2dup = [ 2drop ] [\r
- >r 1string r> 1string <expected> throw\r
+ >r 1string r> 1string expected\r
] if next ;\r
\r
: expect-string ( string -- )\r
dup [ drop get-char next ] map 2dup =\r
- [ 2drop ] [ <expected> throw ] if ;\r
+ [ 2drop ] [ expected ] if ;\r
\r
: init-parser ( -- )\r
0 1 0 f <spot> spot set\r
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml.data xml.writer kernel generic io prettyprint math
-debugger sequences state-parser ;
+debugger sequences state-parser accessors inspector
+namespaces io.streams.string xml.backend ;
IN: xml.errors
-TUPLE: no-entity thing ;
-: <no-entity> ( string -- error )
- { set-no-entity-thing } no-entity construct-parsing-error ;
-M: no-entity error.
- dup parsing-error.
- "Entity does not exist: &" write no-entity-thing write ";" print ;
+TUPLE: multitags ;
+C: <multitags> multitags
+M: multitags summary ( obj -- str )
+ drop "XML document contains multiple main tags" ;
-TUPLE: xml-string-error string ; ! this should not exist
+TUPLE: pre/post-content string pre? ;
+C: <pre/post-content> pre/post-content
+M: pre/post-content summary ( obj -- str )
+ [
+ "The text string:" print
+ dup string>> .
+ "was used " write
+ pre?>> "before" "after" ? write
+ " the main tag." print
+ ] with-string-writer ;
+
+TUPLE: no-entity < parsing-error thing ;
+: <no-entity> ( string -- error )
+ \ no-entity parsing-error swap >>thing ;
+M: no-entity summary ( obj -- str )
+ [
+ dup call-next-method write
+ "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 )
- { set-xml-string-error-string }
- xml-string-error construct-parsing-error ;
-M: xml-string-error error.
- dup parsing-error.
- xml-string-error-string print ;
-
-TUPLE: mismatched open close ;
+ \ xml-string-error parsing-error swap >>string ;
+M: xml-string-error summary ( obj -- str )
+ [
+ dup call-next-method write
+ string>> print
+ ] with-string-writer ;
+
+TUPLE: mismatched < parsing-error open close ;
: <mismatched>
- { set-mismatched-open set-mismatched-close }
- mismatched construct-parsing-error ;
-M: mismatched error.
- dup parsing-error.
- "Mismatched tags" print
- "Opening tag: <" write dup mismatched-open print-name ">" print
- "Closing tag: </" write mismatched-close print-name ">" print ;
-
-TUPLE: unclosed tags ;
-! <unclosed> is ( -- unclosed ), see presentation.factor
-M: unclosed error.
- "Unclosed tags" print
- "Tags: " print
- unclosed-tags [ " <" write print-name ">" print ] each ;
-
-TUPLE: bad-uri string ;
+ \ mismatched parsing-error swap >>close swap >>open ;
+M: mismatched summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Mismatched tags" print
+ "Opening tag: <" write dup open>> print-name ">" print
+ "Closing tag: </" write close>> print-name ">" print
+ ] with-string-writer ;
+
+TUPLE: unclosed < parsing-error tags ;
+: <unclosed> ( -- unclosed )
+ unclosed parsing-error
+ xml-stack get rest-slice [ first opener-name ] map >>tags ;
+M: unclosed summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Unclosed tags" print
+ "Tags: " print
+ tags>> [ " <" write print-name ">" print ] each
+ ] with-string-writer ;
+
+TUPLE: bad-uri < parsing-error string ;
: <bad-uri> ( string -- bad-uri )
- { set-bad-uri-string } bad-uri construct-parsing-error ;
-M: bad-uri error.
- dup parsing-error.
- "Bad URI:" print bad-uri-string . ;
-
-TUPLE: nonexist-ns name ;
+ \ bad-uri parsing-error swap >>string ;
+M: bad-uri summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Bad URI:" print string>> .
+ ] with-string-writer ;
+
+TUPLE: nonexist-ns < parsing-error name ;
: <nonexist-ns> ( name-string -- nonexist-ns )
- { set-nonexist-ns-name }
- nonexist-ns construct-parsing-error ;
-M: nonexist-ns error.
- dup parsing-error.
- "Namespace " write nonexist-ns-name write " has not been declared" print ;
-
-TUPLE: unopened ; ! this should give which tag was unopened
+ \ nonexist-ns parsing-error swap >>name ;
+M: nonexist-ns summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Namespace " write name>> write " has not been declared" print
+ ] with-string-writer ;
+
+TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
: <unopened> ( -- unopened )
- { } unopened construct-parsing-error ;
-M: unopened error.
- parsing-error.
- "Closed an unopened tag" print ;
-
-TUPLE: not-yes/no text ;
+ \ unopened parsing-error ;
+M: unopened summary ( obj -- str )
+ [
+ call-next-method write
+ "Closed an unopened tag" print
+ ] with-string-writer ;
+
+TUPLE: not-yes/no < parsing-error text ;
: <not-yes/no> ( text -- not-yes/no )
- { set-not-yes/no-text } not-yes/no construct-parsing-error ;
-M: not-yes/no error.
- dup parsing-error.
- "standalone must be either yes or no, not \"" write
- not-yes/no-text write "\"." print ;
-
-TUPLE: extra-attrs attrs ; ! this should actually print the names
+ \ not-yes/no parsing-error swap >>text ;
+M: not-yes/no summary ( obj -- str )
+ [
+ dup call-next-method write
+ "standalone must be either yes or no, not \"" write
+ text>> write "\"." print
+ ] with-string-writer ;
+
+! this should actually print the names
+TUPLE: extra-attrs < parsing-error attrs ;
: <extra-attrs> ( attrs -- extra-attrs )
- { set-extra-attrs-attrs }
- extra-attrs construct-parsing-error ;
-M: extra-attrs error.
- dup parsing-error.
- "Extra attributes included in xml version declaration:" print
- extra-attrs-attrs . ;
-
-TUPLE: bad-version num ;
+ \ extra-attrs parsing-error swap >>attrs ;
+M: extra-attrs summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Extra attributes included in xml version declaration:" print
+ attrs>> .
+ ] with-string-writer ;
+
+TUPLE: bad-version < parsing-error num ;
: <bad-version>
- { set-bad-version-num }
- bad-version construct-parsing-error ;
-M: bad-version error.
- "XML version must be \"1.0\" or \"1.1\". Version here was " write
- bad-version-num . ;
-
-TUPLE: notags ;
-C: <notags> notags
-M: notags error.
- drop "XML document lacks a main tag" print ;
-
-TUPLE: multitags ;
-C: <multitags> multitags
-M: multitags error.
- drop "XML document contains multiple main tags" print ;
-
-TUPLE: bad-prolog prolog ;
+ \ bad-version parsing-error swap >>num ;
+M: bad-version summary ( obj -- str )
+ [
+ "XML version must be \"1.0\" or \"1.1\". Version here was " write
+ num>> .
+ ] with-string-writer ;
+
+TUPLE: notags < parsing-error ;
+: <notags>
+ \ notags parsing-error ;
+M: notags summary ( obj -- str )
+ drop "XML document lacks a main tag" ;
+
+TUPLE: bad-prolog < parsing-error prolog ;
: <bad-prolog> ( prolog -- bad-prolog )
- { set-bad-prolog-prolog }
- bad-prolog construct-parsing-error ;
-M: bad-prolog error.
- dup parsing-error.
- "Misplaced XML prolog" print
- bad-prolog-prolog write-prolog nl ;
-
-TUPLE: capitalized-prolog name ;
+ \ bad-prolog parsing-error swap >>prolog ;
+M: bad-prolog summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Misplaced XML prolog" print
+ prolog>> write-prolog nl
+ ] with-string-writer ;
+
+TUPLE: capitalized-prolog < parsing-error name ;
: <capitalized-prolog> ( name -- capitalized-prolog )
- { set-capitalized-prolog-name }
- capitalized-prolog construct-parsing-error ;
-M: capitalized-prolog error.
- dup parsing-error.
- "XML prolog name was partially or totally capitalized, using" print
- "<?" write capitalized-prolog-name write "...?>" write
- " instead of <?xml...?>" print ;
-
-TUPLE: pre/post-content string pre? ;
-C: <pre/post-content> pre/post-content
-M: pre/post-content error.
- "The text string:" print
- dup pre/post-content-string .
- "was used " write
- pre/post-content-pre? "before" "after" ? write
- " the main tag." print ;
-
-TUPLE: versionless-prolog ;
+ \ capitalized-prolog parsing-error swap >>name ;
+M: capitalized-prolog summary ( obj -- str )
+ [
+ dup call-next-method write
+ "XML prolog name was partially or totally capitalized, using" print
+ "<?" write name>> write "...?>" write
+ " instead of <?xml...?>" print
+ ] with-string-writer ;
+
+TUPLE: versionless-prolog < parsing-error ;
: <versionless-prolog> ( -- versionless-prolog )
- { } versionless-prolog construct-parsing-error ;
-M: versionless-prolog error.
- parsing-error.
- "XML prolog lacks a version declaration" print ;
-
-TUPLE: bad-instruction inst ;
+ \ versionless-prolog parsing-error ;
+M: versionless-prolog summary ( obj -- str )
+ [
+ call-next-method write
+ "XML prolog lacks a version declaration" print
+ ] with-string-writer ;
+
+TUPLE: bad-instruction < parsing-error instruction ;
: <bad-instruction> ( instruction -- bad-instruction )
- { set-bad-instruction-inst }
- bad-instruction construct-parsing-error ;
-M: bad-instruction error.
- dup parsing-error.
- "Misplaced processor instruction:" print
- bad-instruction-inst write-item nl ;
-
-TUPLE: bad-directive dir ;
+ \ bad-instruction parsing-error swap >>instruction ;
+M: bad-instruction summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Misplaced processor instruction:" print
+ bad-instruction-inst write-item nl
+ ] with-string-writer ;
+
+TUPLE: bad-directive < parsing-error dir ;
: <bad-directive> ( directive -- bad-directive )
- { set-bad-directive-dir }
- bad-directive construct-parsing-error ;
-M: bad-directive error.
- dup parsing-error.
- "Misplaced directive:" print
- bad-directive-dir write-item nl ;
+ \ bad-directive parsing-error swap >>dir ;
+M: bad-directive summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Misplaced directive:" print
+ bad-directive-dir write-item nl
+ ] with-string-writer ;
UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
not-yes/no unclosed mismatched xml-string-error expected no-entity
projects / factor.git / commitdiff