--- /dev/null
+! Copyright (C) 2020 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+combinators.short-circuit io io.encodings.utf8 io.files
+json.reader kernel math math.order memoize modern.slices
+prettyprint sequences sequences.extras strings suffix-arrays
+words ;
+IN: html5
+
+: 1sbuf ( ch -- sbuf ) [ SBUF" " clone ] dip over push ; inline
+: ?1sbuf ( ch -- sbuf ) [ SBUF" " clone ] dip [ over push ] when* ; inline
+
+! https://html.spec.whatwg.org/multipage/parsing.html#tokenization
+
+! https://infra.spec.whatwg.org/#namespaces
+CONSTANT: html-namespace "http://www.w3.org/1999/xhtml"
+CONSTANT: mathml-namespace "http://www.w3.org/1998/Math/MathML"
+CONSTANT: svg-namespace "http://www.w3.org/2000/svg"
+CONSTANT: xlink-namespace "http://www.w3.org/1999/xlink"
+CONSTANT: xml-namespace "http://www.w3.org/XML/1998/namespace"
+CONSTANT: xmlns-namespace "http://www.w3.org/2000/xmlns/"
+
+DEFER: data-state
+DEFER: (data-state)
+DEFER: rcdata-state
+DEFER: (rcdata-state)
+DEFER: rawtext-state
+DEFER: (rawtext-state)
+DEFER: script-data-state
+DEFER: (script-data-state)
+DEFER: plaintext-state
+DEFER: (plaintext-state)
+DEFER: tag-open-state
+DEFER: (tag-open-state)
+DEFER: end-tag-open-state
+DEFER: (end-tag-open-state)
+DEFER: tag-name-state
+DEFER: (tag-name-state)
+DEFER: rcdata-less-than-sign-state
+DEFER: (rcdata-less-than-sign-state)
+DEFER: rcdata-end-tag-open-state
+DEFER: (rcdata-end-tag-open-state)
+DEFER: rcdata-end-tag-name-state
+DEFER: (rcdata-end-tag-name-state)
+DEFER: rawtext-less-than-sign-state
+DEFER: (rawtext-less-than-sign-state)
+DEFER: rawtext-end-tag-open-state
+DEFER: (rawtext-end-tag-open-state)
+DEFER: rawtext-end-tag-name-state
+DEFER: (rawtext-end-tag-name-state)
+DEFER: script-data-less-than-sign-state
+DEFER: (script-data-less-than-sign-state)
+DEFER: script-data-end-tag-open-state
+DEFER: (script-data-end-tag-open-state)
+DEFER: script-data-end-tag-name-state
+DEFER: (script-data-end-tag-name-state)
+DEFER: script-data-escape-start-state
+DEFER: (script-data-escape-start-state)
+DEFER: script-data-escape-start-dash-state
+DEFER: (script-data-escape-start-dash-state)
+DEFER: script-data-escaped-state
+DEFER: (script-data-escaped-state)
+DEFER: script-data-escaped-dash-state
+DEFER: (script-data-escaped-dash-state)
+DEFER: script-data-escaped-dash-dash-state
+DEFER: (script-data-escaped-dash-dash-state)
+DEFER: script-data-escaped-less-than-sign-state
+DEFER: (script-data-escaped-less-than-sign-state)
+DEFER: script-data-escaped-end-tag-open-state
+DEFER: (script-data-escaped-end-tag-open-state)
+DEFER: script-data-escaped-end-tag-name-state
+DEFER: (script-data-escaped-end-tag-name-state)
+DEFER: script-data-double-escape-start-state
+DEFER: (script-data-double-escape-start-state)
+DEFER: script-data-double-escaped-state
+DEFER: (script-data-double-escaped-state)
+DEFER: script-data-double-escaped-dash-state
+DEFER: (script-data-double-escaped-dash-state)
+DEFER: script-data-double-escaped-dash-dash-state
+DEFER: (script-data-double-escaped-dash-dash-state)
+DEFER: script-data-double-escaped-less-than-sign-state
+DEFER: (script-data-double-escaped-less-than-sign-state)
+DEFER: script-data-double-escape-end-state
+DEFER: (script-data-double-escape-end-state)
+DEFER: before-attribute-name-state
+DEFER: (before-attribute-name-state)
+DEFER: attribute-name-state
+DEFER: (attribute-name-state)
+DEFER: after-attribute-name-state
+DEFER: (after-attribute-name-state)
+DEFER: before-attribute-value-state
+DEFER: (before-attribute-value-state)
+DEFER: attribute-value-double-quoted-state
+DEFER: (attribute-value-double-quoted-state)
+DEFER: attribute-value-single-quoted-state
+DEFER: (attribute-value-single-quoted-state)
+DEFER: attribute-value-unquoted-state
+DEFER: (attribute-value-unquoted-state)
+DEFER: after-attribute-value-quoted-state
+DEFER: (after-attribute-value-quoted-state)
+DEFER: self-closing-start-tag-state
+DEFER: (self-closing-start-tag-state)
+DEFER: bogus-comment-state
+DEFER: (bogus-comment-state)
+DEFER: markup-declaration-open-state
+DEFER: (markup-declaration-open-state)
+DEFER: comment-start-state
+DEFER: (comment-start-state)
+DEFER: comment-start-dash-state
+DEFER: (comment-start-dash-state)
+DEFER: comment-state
+DEFER: (comment-state)
+DEFER: comment-less-than-sign-state
+DEFER: (comment-less-than-sign-state)
+DEFER: comment-less-than-sign-bang-state
+DEFER: (comment-less-than-sign-bang-state)
+DEFER: comment-less-than-sign-bang-dash-state
+DEFER: (comment-less-than-sign-bang-dash-state)
+DEFER: comment-less-than-sign-bang-dash-dash-state
+DEFER: (comment-less-than-sign-bang-dash-dash-state)
+DEFER: comment-end-dash-state
+DEFER: (comment-end-dash-state)
+DEFER: comment-end-state
+DEFER: (comment-end-state)
+DEFER: comment-end-bang-state
+DEFER: (comment-end-bang-state)
+DEFER: doctype-state
+DEFER: (doctype-state)
+DEFER: before-doctype-name-state
+DEFER: (before-doctype-name-state)
+DEFER: doctype-name-state
+DEFER: (doctype-name-state)
+DEFER: after-doctype-name-state
+DEFER: (after-doctype-name-state)
+DEFER: after-doctype-public-keyword-state
+DEFER: (after-doctype-public-keyword-state)
+DEFER: before-doctype-public-identifier-state
+DEFER: (before-doctype-public-identifier-state)
+DEFER: doctype-public-identifier-double-quoted-state
+DEFER: (doctype-public-identifier-double-quoted-state)
+DEFER: doctype-public-identifier-single-quoted-state
+DEFER: (doctype-public-identifier-single-quoted-state)
+DEFER: after-doctype-public-identifier-state
+DEFER: (after-doctype-public-identifier-state)
+DEFER: between-doctype-public-and-system-identifiers-state
+DEFER: (between-doctype-public-and-system-identifiers-state)
+DEFER: after-doctype-system-keyword-state
+DEFER: (after-doctype-system-keyword-state)
+DEFER: before-doctype-system-identifier-state
+DEFER: (before-doctype-system-identifier-state)
+DEFER: doctype-system-identifier-double-quoted-state
+DEFER: (doctype-system-identifier-double-quoted-state)
+DEFER: doctype-system-identifier-single-quoted-state
+DEFER: (doctype-system-identifier-single-quoted-state)
+DEFER: after-doctype-system-identifier-state
+DEFER: (after-doctype-system-identifier-state)
+DEFER: bogus-doctype-state
+DEFER: (bogus-doctype-state)
+DEFER: cdata-section-state
+DEFER: (cdata-section-state)
+DEFER: cdata-section-bracket-state
+DEFER: (cdata-section-bracket-state)
+DEFER: cdata-section-end-state
+DEFER: (cdata-section-end-state)
+DEFER: character-reference-state
+DEFER: (character-reference-state)
+DEFER: named-character-reference-state
+DEFER: (named-character-reference-state)
+DEFER: ambiguous-ampersand-state
+DEFER: (ambiguous-ampersand-state)
+DEFER: numeric-character-reference-state
+DEFER: (numeric-character-reference-state)
+DEFER: hexadecimal-character-reference-start-state
+DEFER: (hexadecimal-character-reference-start-state)
+DEFER: decimal-character-reference-start-state
+DEFER: (decimal-character-reference-start-state)
+DEFER: hexadecimal-character-reference-state
+DEFER: (hexadecimal-character-reference-state)
+DEFER: decimal-character-reference-state
+DEFER: (decimal-character-reference-state)
+DEFER: numeric-character-reference-end-state
+DEFER: (numeric-character-reference-end-state)
+
+
+ERROR: unimplemented string ;
+ERROR: unimplemented* ;
+
+! Errors: https://html.spec.whatwg.org/multipage/parsing.html#parse-errors
+ERROR: abrupt-closing-of-empty-comment ;
+ERROR: abrupt-doctype-public-identifier ;
+ERROR: abrupt-doctype-system-identifier ;
+ERROR: absence-of-digits-in-numeric-character-reference ;
+ERROR: cdata-in-html-content ;
+ERROR: character-reference-outside-unicode-range ;
+ERROR: control-character-in-input-stream ;
+ERROR: control-character-reference ;
+ERROR: end-tag-with-attributes ;
+ERROR: duplicate-attribute ;
+ERROR: end-tag-with-trailing-solidus ;
+ERROR: eof-before-tag-name ;
+ERROR: eof-in-cdata ;
+ERROR: eof-in-comment ;
+ERROR: eof-in-doctype ;
+ERROR: eof-in-script-html-comment-like-text ;
+ERROR: eof-in-tag ;
+ERROR: incorrectly-closed-comment ;
+ERROR: incorrectly-opened-comment ;
+ERROR: invalid-character-sequence-after-doctype-name ;
+ERROR: invalid-first-character-of-tag-name ;
+ERROR: missing-attribute-value ;
+ERROR: missing-doctype-name ;
+ERROR: missing-doctype-public-identifier ;
+ERROR: missing-doctype-system-identifier ;
+ERROR: missing-end-tag-name ;
+ERROR: missing-quote-before-doctype-public-identifier ;
+
+ERROR: missing-quote-before-doctype-system-identifier ;
+ERROR: missing-semicolon-after-character-reference ;
+ERROR: missing-whitespace-after-doctype-public-keyword ;
+ERROR: missing-whitespace-after-doctype-system-keyword ;
+ERROR: missing-whitespace-before-doctype-name ;
+ERROR: missing-whitespace-between-attributes ;
+ERROR: missing-whitespace-between-doctype-public-and-system-identifiers ;
+ERROR: nested-comment ;
+ERROR: noncharacter-character-reference ;
+ERROR: noncharacter-in-input-stream ;
+ERROR: non-void-html-element-start-tag-with-trailing-solidus ;
+ERROR: null-character-reference ;
+ERROR: surrogate-character-reference ;
+ERROR: surrogate-in-input-stream ;
+ERROR: unexpected-character-after-doctype-system-identifier ;
+ERROR: unexpected-character-in-attribute-name ;
+ERROR: unexpected-character-in-unquoted-attribute-value ;
+ERROR: unexpected-equals-sign-before-attribute-name ;
+ERROR: unexpected-null-character ;
+ERROR: unexpected-question-mark-instead-of-tag-name ;
+ERROR: unexpected-solidus-in-tag ;
+ERROR: unknown-named-character-reference ;
+
+! Tree insertion modes
+SINGLETONS: initial-mode before-html-mode before-head-mode
+in-head-mode in-head-noscript-mode after-head-mode
+in-body-mode text-mode in-table-mode in-table-text-mode
+in-caption-mode in-column-group-mode in-table-body-mode
+in-row-mode in-cell-mode in-select-mode in-select-in-table-mode in-template-mode
+after-body-mode in-frameset-mode after-frameset-mode after-after-body-mode
+after-after-frameset-mode ;
+
+TUPLE: document
+quirks-mode?
+limited-quirks-mode?
+iframe-srcdoc?
+scripting? ! set in constructor
+frameset-ok? ! frameset-ok? but we want default to f
+fostering-parent?
+tree
+tree-doctype
+head-element-pointer ! set during insertion time
+parser-cannot-change-mode-flag
+insertion-mode
+original-insertion-mode
+last
+node
+context
+doctype
+tag
+end-tag
+
+tag-name
+end-tag-name
+attribute-name
+attribute-value
+temporary-buffer
+comment-token
+open-elements
+return-state ;
+
+! "reset the insertion mode appropriately"
+! : reset-insertion-mode ( document -- document )
+! f >>last
+! dup open-elements>> ?last >>node
+! dup [ open-elements>> ?first ] [ node>> ] bi = [
+! t >>last dup node>> >>context
+! ] when
+! dup node>> {
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! { [
+! dup name>> >lower { "td" "th" } member?
+! pick last>> f = and
+! ] [ drop in-select >>insertion-mode ] }
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! { [ dup name>> >lower "select" = ] [ drop in-select >>insertion-mode ] }
+! } cond
+! ;
+
+: temporary-buffer-attribute? ( document -- ? )
+ return-state>>
+ {
+ attribute-value-unquoted-state
+ attribute-value-single-quoted-state
+ attribute-value-double-quoted-state
+ } member? ;
+
+! name, public/system identifier should not be empty strings
+! until the state machine demands it
+TUPLE: doctype
+ name
+ public-identifier
+ system-identifier
+ quirks? ;
+
+: <doctype> ( -- doctype )
+ doctype new ; inline
+
+: new-doctype-from-ch ( ch document -- )
+ [
+ doctype new
+ swap ?1sbuf >>name
+ ] dip doctype<< ; inline
+
+: new-doctype-with-quirks ( document -- )
+ <doctype> t >>quirks? >>doctype drop ;
+
+TUPLE: tag self-closing? name attributes children end-tag ;
+
+: <tag> ( -- tag )
+ tag new
+ SBUF" " clone >>name
+ V{ } clone >>attributes
+ V{ } clone >>children ;
+
+TUPLE: end-tag self-closing? name attributes ;
+
+: <end-tag> ( -- tag )
+ end-tag new
+ SBUF" " clone >>name
+ V{ } clone >>attributes ;
+
+: new-tag ( document -- )
+ <tag> >>tag drop ;
+
+: new-end-tag ( document -- )
+ <end-tag> >>tag drop ;
+
+: set-self-closing ( document -- )
+ tag>> t >>self-closing? drop ;
+
+: <document> ( -- document )
+ document new
+ V{ } clone >>tree
+ initial-mode >>insertion-mode
+ <doctype> >>doctype
+ t >>frameset-ok?
+ ! SBUF" " clone >>tag-name
+ SBUF" " clone >>attribute-name
+ SBUF" " clone >>attribute-value
+ SBUF" " clone >>temporary-buffer
+ SBUF" " clone >>comment-token
+ V{ } clone >>open-elements
+ ; inline
+
+TUPLE: comment open payload close ;
+
+: <comment> ( payload -- comment )
+ comment new
+ swap >>payload ; inline
+
+: force-quirks ( document -- )
+ doctype>> t >>quirks? drop ;
+
+: initialize-doctype-name ( document -- )
+ [ SBUF" " clone ] dip doctype>> name<< ;
+
+: initialize-doctype-public-identifier ( document -- )
+ [ SBUF" " clone ] dip doctype>> public-identifier<< ;
+
+: initialize-doctype-system-identifier ( document -- )
+ [ SBUF" " clone ] dip doctype>> system-identifier<< ;
+
+: push-doctype-name ( ch document -- )
+ doctype>> name>> push ;
+
+: push-doctype-public-identifier ( ch document -- )
+ doctype>> public-identifier>> push ;
+
+: push-doctype-system-identifier ( ch document -- )
+ doctype>> system-identifier>> push ;
+
+! XXX: not html5 spec, fix
+ERROR: unmatched-closing-tag-error stack tag ;
+
+: unclosed-tag? ( obj -- ? )
+ { [ tag? ] [ end-tag>> not ] } 1&& ; inline
+
+:: find-matching-tag ( name stack -- seq )
+ stack [ { [ unclosed-tag? ] [ name>> name = ] } 1&& ] find-last drop [
+ stack swap shorten*
+ ] [
+ stack name unmatched-closing-tag-error
+ ] if* ;
+
+DEFER: tree-insert
+GENERIC: tree-insert* ( document obj insertion-mode -- document )
+
+: limited-quirks-mode? ( doctype -- ? )
+ {
+ [ public-identifier>> "-//W3C//DTD XHTML 1.0 Frameset//" head? ]
+ [ public-identifier>> "-//W3C//DTD XHTML 1.0 Transitional//" head? ]
+ [ { [ system-identifier>> ] [ public-identifier>> "-//W3C//DTD HTML 4.01 Frameset//" head? ] } 1&& ]
+ [ { [ system-identifier>> ] [ public-identifier>> "-//W3C//DTD HTML 4.01 Transitional//" head? ] } 1&& ]
+ } 1|| ;
+
+! https://html.spec.whatwg.org/multipage/parsing.html#the-initial-insertion-mode
+M: initial-mode tree-insert*
+ drop {
+ { [ dup "\t\n\f\r\s" member? ] [ drop ] }
+ { [ dup doctype? ] [
+ >>tree-doctype before-html-mode >>insertion-mode
+ ] }
+ { [ dup comment? ] [ over tree>> push ] }
+ { [ dup tag? ] [ over tree>> push ] }
+ { [ dup end-tag? ] [
+ dup name>> pick tree>> find-matching-tag
+ unclip
+ swap >>children
+ swap >>end-tag
+ over tree>> push
+ ] }
+ [
+ over iframe-srcdoc?>> [
+ over parser-cannot-change-mode-flag>> [
+ [ t >>quirks-mode? ] dip
+ ] unless
+ ] [
+ "must be iframe-srcdoc here" throw
+ ] if
+ ! reprocess the token
+ before-html-mode >>insertion-mode tree-insert
+ ]
+ } cond ;
+
+! https://html.spec.whatwg.org/multipage/parsing.html#the-before-html-insertion-mode
+M: before-html-mode tree-insert*
+ drop {
+ { [ dup doctype? ] [ drop ] }
+ { [ dup comment? ] [ over tree>> push ] }
+ { [ dup "\t\n\f\r\s" member? ] [ drop ] }
+ { [ dup { [ tag? ] [ name>> "html" = ] } 1&& ] [
+ over tree>> push
+ before-head-mode >>insertion-mode
+ ] }
+ ! these tags are handled in the default case
+ { [ dup { [ end-tag? ] [ name>> { "head" "body" "html" "br" } member? not ] } 1&& ] [
+ ! error end-tag, ignore
+ drop
+ ] }
+ [
+ ! Create missing html tag and reprocess the token
+ <tag> "html" >>name pick tree>> push
+ before-head-mode >>insertion-mode tree-insert
+ ]
+ } cond ;
+
+M: before-head-mode tree-insert*
+ drop {
+ { [ dup "\t\n\f\r\s" member? ] [ drop ] }
+ { [ dup comment? ] [ over tree>> push ] }
+ { [ dup doctype? ] [ drop ] }
+ { [ dup { [ tag? ] [ name>> "html" = ] } 1&& ] [
+ ! XXX: in-body-mode rules here for html tag
+ ! B
+ ! over tree>> push
+ ! before-head-mode >>insertion-mode
+ "handle html in-body-mode here" throw
+ ] }
+ { [ dup { [ tag? ] [ name>> "head" = ] } 1&& ] [
+ [ swap tree>> push ]
+ [ >>head-element-pointer drop ]
+ [ drop in-head-mode >>insertion-mode ] 2tri
+ ] }
+ ! these tags are handled in the default case
+ { [ dup { [ end-tag? ] [ name>> { "head" "body" "html" "br" } member? not ] } 1&& ] [
+ ! error end-tag, ignore
+ drop
+ ] }
+ ! ignore tag
+ { [ dup tag? ] [ drop ] }
+ [
+ ! Create missing html tag and reprocess the token
+ <tag>
+ [ "head" >>name pick tree>> push ]
+ [ >>head-element-pointer ] bi
+ in-head-mode >>insertion-mode tree-insert
+ ]
+ } cond ;
+
+M: in-head-mode tree-insert*
+ drop {
+ { [ dup "\t\n\f\r\s" member? ] [ over tree>> push ] }
+ { [ dup comment? ] [ over tree>> push ] }
+ { [ dup doctype? ] [ drop ] }
+ { [ dup { [ tag? ] [ name>> "html" = ] } 1&& ] [
+ ! XXX: in-body-mode rules here for html tag
+ ! B
+ ! over tree>> push
+ ! before-head-mode >>insertion-mode
+ "handle html in-body-mode here" throw
+ unimplemented*
+ ] }
+ { [ dup { [ tag? ] [ name>> { "base" "basefont" "bgsound" "link" } member? ] } 1&& ] [
+ ! non-void-html-element-start-tag-with-trailing-solidus soft error if not self-closing
+ unimplemented*
+ ] }
+ { [ dup { [ tag? ] [ name>> "meta" = ] } 1&& ] [
+ unimplemented*
+ ] }
+ { [ dup { [ tag? ] [ name>> "title" = ] } 1&& ] [
+ ! https://html.spec.whatwg.org/multipage/parsing.html#generic-rcdata-element-parsing-algorithm
+ "insert title node" throw
+ unimplemented*
+ ] }
+ { [
+ dup {
+ [ { [ tag? ] [ name>> "noscript" = ] [ scripting?>> ] } 1&& ]
+ [ { [ tag? ] [ name>> { "noframes" "style" } member? ] } 1&& ]
+ } 1||
+ ] [
+ ! https://html.spec.whatwg.org/multipage/parsing.html#generic-raw-text-element-parsing-algorithm
+ unimplemented*
+ ] }
+ { [ dup { [ tag? ] [ name>> "noscript" = ] [ scripting?>> not ] } 1&& ] [
+ unimplemented*
+ over tree>> push
+ in-head-noscript-mode >>insertion-mode
+ ] }
+ { [ dup { [ tag? ] [ name>> "script" = ] } 1&& ] [
+ unimplemented*
+ text-mode >>insertion-mode
+ ] }
+ { [ dup { [ end-tag? ] [ name>> "head" = ] } 1&& ] [
+ over tree>> last end-tag<<
+ after-head-mode >>insertion-mode
+ ] }
+ { [ dup { [ end-tag? ] [ name>> { "body" "html" "br" } member? ] } 1&& ] [
+ ! non-void-html-element-start-tag-with-trailing-solidus soft error if not self-closing
+ unimplemented*
+ ] }
+ { [ dup { [ tag? ] [ name>> "template" = ] } 1&& ] [
+ unimplemented*
+ in-template-mode >>insertion-mode
+ ] }
+ { [ dup { [ end-tag? ] [ name>> "template" = ] } 1&& ] [
+ unimplemented*
+ ] }
+ ! XXX: revisit this
+ { [ dup {
+ [ { [ tag? ] [ name>> "head" = ] } 1&& ]
+ [ end-tag? ]
+ } 1|| ] [ drop "ignore here" throw ] }
+ [
+ ! end head tag should be here, pop off, reprocess
+ over tree>> pop swap >>end-tag
+ after-head-mode >>insertion-mode "omg" throw
+ ]
+ } cond ;
+
+M: in-head-noscript-mode tree-insert* drop unimplemented* ;
+
+M: after-head-mode tree-insert*
+ drop {
+ { [ dup "\t\n\f\r\s" member? ] [ over tree>> push ] }
+ { [ dup comment? ] [ over tree>> push ] }
+ { [ dup doctype? ] [ drop ] }
+ { [ dup { [ tag? ] [ name>> "html" = ] } 1&& ] [
+ ! XXX: in-body-mode rules here for html tag
+ ! B
+ ! over tree>> push
+ ! before-head-mode >>insertion-mode
+ "handle html in-body-mode here" throw
+ unimplemented*
+ ] }
+ { [ dup { [ tag? ] [ name>> "html" = ] } 1&& ] [
+ unimplemented*
+ ] }
+ { [ dup { [ tag? ] [ name>> "body" = ] } 1&& ] [
+ over tree>> push
+ f >>frameset-ok?
+ in-body-mode >>insertion-mode
+ ] }
+ { [ dup { [ tag? ] [ name>> "frameset" = ] } 1&& ] [
+ unimplemented*
+ ] }
+ { [ dup { [ tag? ] [
+ name>> {
+ "base" "basefont" "bgsound" "link" "meta"
+ "noframes" "script" "style" "template" "title"
+ } member? ] } 1&&
+ ] [
+ unimplemented*
+ ] }
+ { [ dup { [ end-tag? ] [ name>> "template" = ] } 1&& ] [
+ unimplemented*
+ ] }
+ ! same as default case
+ ! { [ dup { [ end-tag? ] [ name>> { "body" "html" "br" } member? not ] } 1&& ] [
+ ! unimplemented*
+ ! ] }
+ { [
+ dup {
+ [ { [ tag? ] [ name>> "head" = ] } 1&& ]
+ [ { [ end-tag? ] [ name>> { "body" "html" "br" } member? not ] } 1&& ]
+ } 1||
+ ] [
+ "omg revisit this" throw
+ unimplemented*
+ ] }
+ [
+ B
+ <tag> "body" >>name pick tree>> push
+ in-body-mode >>insertion-mode tree-insert
+ ]
+ } cond ;
+
+M: in-body-mode tree-insert*
+ drop {
+ { [ dup CHAR: \0 = ] [ drop ] }
+ { [ dup "\t\n\f\r\s" member? ] [ over tree>> push ] }
+ { [ dup comment? ] [ over tree>> push ] }
+ { [ dup doctype? ] [ drop ] }
+ { [ dup { [ tag? ] [ name>> "html" = ] } 1&& ] [ drop ] }
+ { [ dup {
+ [
+ {
+ [ tag? ]
+ [
+ name>> {
+ "base" "basefont" "bgsound" "link" "meta"
+ "noframes" "script" "style" "template" "title"
+ } member?
+ ]
+ } 1&&
+ ] [
+ { [ end-tag? ] [ name>> "template" = ] } 1&&
+ ] } 1||
+ ] [
+ unimplemented*
+ ] }
+ ! XXX: parse error
+ { [ dup { [ tag? ] [ name>> "body" = ] } 1&& ] [ drop unimplemented* ] }
+ { [ dup { [ tag? ] [ name>> "frameset" = ] } 1&& ] [ drop unimplemented* ] }
+ ! XXX: eof
+ ! { [ ] [ ] }
+ { [ dup { [ end-tag? ] [ name>> "body" = ] } 1&& ] [
+ "body" pick tree>> find-matching-tag
+ unclip
+ swap >>children
+ swap >>end-tag
+ over tree>> push
+
+ after-body-mode >>insertion-mode
+ ] }
+ { [ dup { [ end-tag? ] [ name>> "html" = ] } 1&& ] [ drop unimplemented* ] }
+ ! { [ ] [ ] }
+ [
+ unimplemented*
+ ]
+ } cond ;
+
+M: text-mode tree-insert* drop unimplemented* ;
+M: in-table-mode tree-insert* drop unimplemented* ;
+M: in-table-text-mode tree-insert* drop unimplemented* ;
+M: in-caption-mode tree-insert* drop unimplemented* ;
+M: in-column-group-mode tree-insert* drop unimplemented* ;
+M: in-table-body-mode tree-insert* drop unimplemented* ;
+M: in-row-mode tree-insert* drop unimplemented* ;
+M: in-cell-mode tree-insert* drop unimplemented* ;
+M: in-select-mode tree-insert* drop unimplemented* ;
+M: in-select-in-table-mode tree-insert* drop unimplemented* ;
+M: in-template-mode tree-insert* drop unimplemented* ;
+M: after-body-mode tree-insert*
+ drop {
+ { [ dup "\t\n\f\r\s" member? ] [ over tree>> push ] }
+ { [ dup comment? ] [ over tree>> push ] }
+ { [ dup doctype? ] [ drop ] }
+ { [ dup { [ tag? ] [ name>> "html" = ] } 1&& ] [
+ unimplemented*
+ ] }
+ { [ dup { [ end-tag? ] [ name>> "html" = ] } 1&& ] [
+ ! XXX: make this a function
+ "html" pick tree>> find-matching-tag
+ unclip
+ swap >>children
+ swap >>end-tag
+ over tree>> push
+
+ after-after-body-mode >>insertion-mode
+ ] }
+ [
+ unimplemented*
+ ]
+ } cond ;
+M: in-frameset-mode tree-insert* drop unimplemented* ;
+M: after-frameset-mode tree-insert* drop unimplemented* ;
+
+M: after-after-body-mode tree-insert*
+ drop {
+ { [ dup comment? ] [ over tree>> push ] }
+ { [ dup doctype? ] [ unimplemented* ] }
+ { [ dup "\t\n\f\r\s" member? ] [ unimplemented* ] }
+ { [ dup { [ tag? ] [ name>> "html" = ] } 1&& ] [ unimplemented* ] }
+ ! eof
+ { [ dup f = ] [ drop ] }
+ [
+ ! XXX: parse error
+ [ in-body-mode >>insertion-mode ] dip tree-insert
+ ]
+ } cond ;
+
+M: after-after-frameset-mode tree-insert* drop unimplemented* ;
+
+: tree-insert ( document obj -- document )
+ over insertion-mode>> tree-insert* ;
+
+MEMO: load-entities ( -- assoc )
+ "vocab:html5/entities.json" utf8 file-contents json> ;
+
+MEMO: entities-suffix-array ( -- assoc )
+ load-entities keys >suffix-array ;
+
+: lookup-entity ( string -- entity/string ? )
+ load-entities ?at ;
+
+: named-character-match? ( document -- prefix? exact? )
+ temporary-buffer>>
+ [ entities-suffix-array query f like ]
+ [ last CHAR: ; = ] bi ;
+
+ERROR: unknown-named-entity entity ;
+: take-named-character ( document -- )
+ dup
+ temporary-buffer>> >string lookup-entity [
+ "characters" of
+ SBUF" " clone-like >>temporary-buffer drop
+ ] [
+ unknown-named-entity
+ ] if ;
+
+! XXX: remove the tag>> name>> push part
+: push-tag-name ( ch document -- )
+ [ tag>> name>> push ]
+ [
+ 2drop ! tag-name>> push
+ ] 2bi ;
+: push-attribute-name ( ch document -- ) attribute-name>> push ;
+: push-attribute-value ( ch document -- ) attribute-value>> push ;
+: push-comment-token ( ch document -- ) comment-token>> push ;
+: push-all-comment-token ( string document -- ) comment-token>> push-all ;
+
+ERROR: invalid-return-state obj ;
+: check-return-state ( obj -- return-state )
+ dup word? [ invalid-return-state ] unless ;
+
+: current-attribute ( document -- attribute/f )
+ [ attribute-name>> >string f like ]
+ [ attribute-value>> >string f like ] bi
+ 2dup or [ 2array ] [ 2drop f ] if ;
+
+: push-when ( obj/f seq -- )
+ over [ push ] [ 2drop ] if ; inline
+
+: reset-attribute ( document -- )
+ SBUF" " clone >>attribute-name
+ SBUF" " clone >>attribute-value drop ;
+
+: push-attribute ( document -- )
+ [ current-attribute ]
+ [ tag>> attributes>> push-when ]
+ [ reset-attribute ] tri ;
+
+: emit-eof ( document -- )
+ "emit-eof" print
+ f tree-insert drop ;
+: emit-char ( char document -- ) drop "emit-char: " write 1string . ;
+: emit-string ( char document -- ) drop "emit-string: " write . ;
+: emit-tag ( document -- )
+ "emit-tag: " write
+ {
+ [ tag>> [ name>> >string ] [ name<< ] bi ]
+ [ push-attribute ]
+ [ tag>> . ]
+ [ dup tag>> tree-insert drop ]
+ [ f >>tag drop ]
+ } cleave ;
+: emit-end-tag ( document -- )
+ "emit-end-tag: " write
+ [ tag>> . ]
+ [ f >>tag drop ] bi ;
+: emit-comment-token ( document -- )
+ "emit-comment-token: " write
+ {
+ [ comment-token>> >string . ]
+ [ dup comment-token>> >string <comment> tree-insert drop ]
+ [ SBUF" " clone >>comment-token drop ]
+ } cleave ;
+: emit-doctype ( document -- )
+ "emit-doctype: " write dup doctype>> .
+ {
+ [ doctype>> [ >string ] change-name drop ]
+ [
+ ! XXX: handle iframe srcdoc document
+ dup { [ doctype>> name>> "html" = not ] [ parser-cannot-change-mode-flag>> not ] } 1&& [
+ t >>quirks-mode?
+ ] [
+ dup { [ iframe-srcdoc?>> not ] [ parser-cannot-change-mode-flag>> not ] } 1&& [
+ dup doctype>> limited-quirks-mode? [ t >>limited-quirks-mode? ] when
+ ] when
+ ] if
+ drop
+ ]
+ [ dup doctype>> tree-insert drop ]
+ [ f >>doctype drop ]
+ } cleave ;
+
+: reset-temporary-buffer ( document -- ) SBUF" " clone temporary-buffer<< ;
+: ch>new-temporary-buffer ( ch document -- ) [ 1sbuf ] dip temporary-buffer<< ;
+: string>new-temporary-buffer ( string document -- ) [ SBUF" " clone-like ] dip temporary-buffer<< ;
+: temporary-buffer-last ( document -- ch/f ) temporary-buffer>> ?last ;
+: push-temporary-buffer ( ch document -- ) temporary-buffer>> push ;
+: push-all-temporary-buffer ( string document -- ) temporary-buffer>> push-all ;
+
+: flush-temporary-buffer ( document -- )
+ "flush-temporary-buffer: " write
+ [ [ temporary-buffer>> ] keep [ emit-char ] curry each ]
+ [ SBUF" " clone >>temporary-buffer drop ] bi ;
+
+: emit-temporary-buffer-with ( string document -- )
+ [ temporary-buffer>> push-all ]
+ [ flush-temporary-buffer ] bi ;
+
+! check if matches open tag
+: appropriate-end-tag-token? ( document -- ? )
+ drop f ;
+
+: ascii-upper-alpha? ( ch -- ? ) [ CHAR: A CHAR: Z between? ] [ f ] if* ; inline
+: ascii-lower-alpha? ( ch -- ? ) [ CHAR: a CHAR: z between? ] [ f ] if* ; inline
+: ascii-upper-hex-digit? ( ch -- ? ) [ CHAR: A CHAR: F between? ] [ f ] if* ; inline
+: ascii-lower-hex-digit? ( ch -- ? ) [ CHAR: a CHAR: f between? ] [ f ] if* ; inline
+: ascii-hex-alpha? ( ch -- ? ) { [ ascii-upper-hex-digit? ] [ ascii-lower-hex-digit? ] } 1|| ; inline
+
+: ascii-digit? ( ch/f -- ? ) [ CHAR: 0 CHAR: 9 between? ] [ f ] if* ;
+: ascii-alpha? ( ch/f -- ? ) { [ ascii-lower-alpha? ] [ ascii-upper-alpha? ] } 1|| ;
+: ascii-alphanumeric? ( ch/f -- ? ) { [ ascii-alpha? ] [ ascii-digit? ] } 1|| ;
+: ascii-hex-digit? ( ch/f -- ? ) { [ ascii-digit? ] [ ascii-hex-alpha? ] } 1|| ;
+
+: (return-state) ( document n/f string ch/f -- document n'/f string )
+ reach [ f ] change-return-state drop check-return-state
+ execute( document n/f string ch/f -- document n'/f string ) ;
+
+: return-state ( document n/f string -- document n'/f string )
+ pick [ f ] change-return-state drop check-return-state
+ execute( document n/f string -- document n'/f string ) ;
+
+: (data-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: & = ] [ drop [ \ data-state >>return-state ] 2dip character-reference-state ] }
+ { [ dup CHAR: < = ] [ drop tag-open-state ] }
+ { [ dup CHAR: \0 = ] [ unexpected-null-character ] }
+ { [ dup f = ] [ drop pick emit-eof ] }
+ [ reach emit-char data-state ]
+ } cond ;
+
+: data-state ( document n/f string -- document n'/f string )
+ take-char (data-state) ;
+
+
+: (rcdata-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: & = ] [ drop [ \ rcdata-state >>return-state ] 2dip character-reference-state ] }
+ { [ dup CHAR: < = ] [ drop rcdata-less-than-sign-state ] }
+ { [ dup CHAR: \0 = ] [ unexpected-null-character ] }
+ { [ dup f = ] [ drop pick emit-eof ] }
+ [ reach emit-char rcdata-state ]
+ } cond ;
+
+: rcdata-state ( document n/f string -- document n'/f string )
+ take-char (rcdata-state) ;
+
+
+: (rawtext-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: < = ] [ drop rawtext-less-than-sign-state ] }
+ { [ dup CHAR: \0 = ] [ drop unexpected-null-character ] }
+ { [ dup f = ] [ drop pick emit-eof ] }
+ [ reach emit-char rawtext-state ]
+ } cond ;
+
+: rawtext-state ( document n/f string -- document n'/f string )
+ take-char (rawtext-state) ;
+
+
+: (script-data-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: < = ] [ drop script-data-less-than-sign-state ] }
+ { [ dup CHAR: \0 = ] [ drop unexpected-null-character ] }
+ { [ dup f = ] [ drop pick emit-eof ] }
+ [ reach emit-char script-data-state ]
+ } cond ;
+
+: script-data-state ( document n/f string -- document n'/f string )
+ take-char (script-data-state) ;
+
+
+: (plaintext-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: \0 = ] [ drop unexpected-null-character ] }
+ { [ dup f = ] [ drop pick emit-eof ] }
+ [ reach emit-char plaintext-state ]
+ } cond ;
+
+: plaintext-state ( document n/f string -- document n'/f string )
+ take-char (plaintext-state) ;
+
+
+: (tag-open-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-alpha? ] [ reach new-tag (tag-name-state) ] }
+ { [ dup CHAR: ! = ] [ drop markup-declaration-open-state ] }
+ { [ dup CHAR: / = ] [ drop end-tag-open-state ] }
+ { [ dup CHAR: ? = ] [ unexpected-question-mark-instead-of-tag-name ] }
+ { [ dup f = ] [ eof-before-tag-name ] }
+ [ invalid-first-character-of-tag-name ]
+ } cond ;
+
+: tag-open-state ( document n/f string -- document n'/f string )
+ take-char (tag-open-state) ;
+
+
+: (end-tag-open-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-alpha? ] [ reach new-end-tag (tag-name-state) ] }
+ { [ dup CHAR: > = ] [ missing-end-tag-name ] }
+ { [ dup f = ] [ eof-before-tag-name ] }
+ [ invalid-first-character-of-tag-name ]
+ } cond ;
+
+: end-tag-open-state ( document n/f string -- document n'/f string )
+ take-char (end-tag-open-state) ;
+
+
+: (tag-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-upper-alpha? ] [ 0x20 + reach push-tag-name tag-name-state ] }
+ { [ dup "\t\n\f\s" member? ] [ drop before-attribute-name-state ] }
+ { [ dup CHAR: / = ] [ drop self-closing-start-tag-state ] }
+ { [ dup CHAR: > = ] [ drop pick emit-tag data-state ] }
+ { [ dup CHAR: \0 = ] [ unexpected-null-character ] }
+ { [ dup f = ] [ eof-before-tag-name ] }
+ [ reach push-tag-name tag-name-state ]
+ } cond ;
+
+: tag-name-state ( document n/f string -- document n'/f string )
+ take-char (tag-name-state) ;
+
+
+: (rcdata-less-than-sign-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: / = ] [ drop pick reset-temporary-buffer rcdata-end-tag-open-state ] }
+ [ [ CHAR: < reach emit-char ] dip (rcdata-state) ]
+ } cond ;
+
+: rcdata-less-than-sign-state ( document n/f string -- document n'/f string )
+ take-char (rcdata-less-than-sign-state) ;
+
+
+: (rcdata-end-tag-open-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-alpha? ] [ reach new-end-tag (rcdata-end-tag-name-state) ] }
+ [ [ CHAR: < reach emit-char ] dip (rcdata-state) ]
+ } cond ;
+
+: rcdata-end-tag-open-state ( document n/f string -- document n'/f string )
+ take-char (rcdata-end-tag-open-state) ;
+
+
+: (rcdata-end-tag-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [
+ drop pick appropriate-end-tag-token?
+ [ before-attribute-name-state ] [ "</" reach emit-temporary-buffer-with rcdata-state ] if
+ ] }
+ { [ dup CHAR: / = ] [
+ drop pick appropriate-end-tag-token?
+ [ self-closing-start-tag-state ] [ "</" reach emit-temporary-buffer-with rcdata-state ] if
+ ] }
+ { [ dup CHAR: > = ] [
+ drop pick appropriate-end-tag-token?
+ [ pick emit-end-tag data-state ] [ "</" reach emit-temporary-buffer-with rcdata-state ] if
+ ] }
+ { [ dup ascii-upper-alpha? ] [ [ 0x20 + reach push-tag-name ] [ reach push-temporary-buffer ] bi rcdata-end-tag-name-state ] }
+ { [ dup ascii-lower-alpha? ] [ [ reach push-tag-name ] [ reach push-temporary-buffer ] bi rcdata-end-tag-name-state ] }
+ [ [ "</" reach emit-temporary-buffer-with ] dip (rcdata-state) ]
+ } cond ;
+
+: rcdata-end-tag-name-state ( document n/f string -- document n'/f string )
+ take-char (rcdata-end-tag-name-state) ;
+
+
+: (rawtext-less-than-sign-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: / = ] [ drop pick reset-temporary-buffer rawtext-end-tag-open-state ] }
+ [ [ CHAR: < reach emit-char ] dip (rawtext-state) ]
+ } cond ;
+
+: rawtext-less-than-sign-state ( document n/f string -- document n'/f string )
+ take-char (rawtext-less-than-sign-state) ;
+
+
+: (rawtext-end-tag-open-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-alpha? ] [ reach new-end-tag (rawtext-end-tag-name-state) ] }
+ [ [ CHAR: < reach emit-char ] dip (rawtext-state) ]
+ } cond ;
+
+: rawtext-end-tag-open-state ( document n/f string -- document n'/f string )
+ take-char (rawtext-end-tag-open-state) ;
+
+
+: (rawtext-end-tag-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [
+ drop pick appropriate-end-tag-token?
+ [ before-attribute-name-state ] [ "</" reach emit-temporary-buffer-with rawtext-state ] if
+ ] }
+ { [ dup CHAR: / = ] [
+ drop pick appropriate-end-tag-token?
+ [ self-closing-start-tag-state ] [ "</" reach emit-temporary-buffer-with rawtext-state ] if
+ ] }
+ { [ dup CHAR: > = ] [
+ drop pick appropriate-end-tag-token?
+ [ pick emit-end-tag data-state ] [ "</" reach emit-temporary-buffer-with rawtext-state ] if
+ ] }
+ { [ dup ascii-upper-alpha? ] [ [ 0x20 + reach push-tag-name ] [ reach push-temporary-buffer ] bi rawtext-end-tag-name-state ] }
+ { [ dup ascii-lower-alpha? ] [ [ reach push-tag-name ] [ reach push-temporary-buffer ] bi rawtext-end-tag-name-state ] }
+ [ [ "</" reach emit-temporary-buffer-with ] dip (rawtext-state) ]
+ } cond ;
+
+: rawtext-end-tag-name-state ( document n/f string -- document n'/f string )
+ take-char (rawtext-end-tag-name-state) ;
+
+
+: (script-data-less-than-sign-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: / = ] [ drop pick reset-temporary-buffer script-data-end-tag-open-state ] }
+ { [ dup CHAR: ! = ] [ drop "<!" reach emit-string script-data-escape-start-state ] }
+ [ [ CHAR: < reach emit-char ] dip (script-data-state) ]
+ } cond ;
+
+: script-data-less-than-sign-state ( document n/f string -- document n'/f string )
+ take-char (script-data-less-than-sign-state) ;
+
+
+: (script-data-end-tag-open-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-alpha? ] [ reach new-end-tag (script-data-end-tag-name-state) ] }
+ [ [ "</" reach emit-string ] dip (script-data-state) ]
+ } cond ;
+
+: script-data-end-tag-open-state ( document n/f string -- document n'/f string )
+ take-char (script-data-end-tag-open-state) ;
+
+
+: (script-data-end-tag-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [
+ drop pick appropriate-end-tag-token?
+ [ before-attribute-name-state ] [ "</" reach emit-temporary-buffer-with script-data-state ] if
+ ] }
+ { [ dup CHAR: / = ] [
+ drop pick appropriate-end-tag-token?
+ [ self-closing-start-tag-state ] [ "</" reach emit-temporary-buffer-with script-data-state ] if
+ ] }
+ { [ dup CHAR: > = ] [
+ drop pick appropriate-end-tag-token?
+ [ pick emit-end-tag data-state ] [ "</" reach emit-temporary-buffer-with script-data-state ] if
+ ] }
+ { [ dup ascii-upper-alpha? ] [ [ 0x20 + reach push-tag-name ] [ reach push-temporary-buffer ] bi rawtext-end-tag-name-state ] }
+ { [ dup ascii-lower-alpha? ] [ [ reach push-tag-name ] [ reach push-temporary-buffer ] bi rawtext-end-tag-name-state ] }
+ [ [ "</" reach emit-temporary-buffer-with ] dip (script-data-state) ]
+ } cond ;
+
+: script-data-end-tag-name-state ( document n/f string -- document n'/f string )
+ take-char (script-data-end-tag-name-state) ;
+
+
+: (script-data-escape-start-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ drop script-data-escape-start-dash-state ] }
+ [ (script-data-state) ]
+ } cond ;
+
+: script-data-escape-start-state ( document n/f string -- document n'/f string )
+ take-char (script-data-escape-start-state) ;
+
+
+: (script-data-escape-start-dash-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ drop script-data-escaped-dash-dash-state ] }
+ [ (script-data-state) ]
+ } cond ;
+
+: script-data-escape-start-dash-state ( document n/f string -- document n'/f string )
+ take-char (script-data-escape-start-dash-state) ;
+
+
+: (script-data-escaped-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ drop script-data-escaped-dash-state ] }
+ { [ dup CHAR: < = ] [ drop script-data-escaped-less-than-sign-state ] }
+ { [ dup CHAR: \0 = ] [ unexpected-null-character CHAR: replacement-character unimplemented* ] }
+ { [ dup f = ] [ eof-in-script-html-comment-like-text ] }
+ [ reach emit-char script-data-escaped-state ]
+ } cond ;
+
+: script-data-escaped-state ( document n/f string -- document n'/f string )
+ take-char (script-data-escaped-state) ;
+
+
+: (script-data-escaped-dash-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ drop script-data-escaped-dash-dash-state ] }
+ { [ dup CHAR: < = ] [ drop script-data-escaped-less-than-sign-state ] }
+ { [ dup CHAR: \0 = ] [ unexpected-null-character script-data-escaped-state ] }
+ { [ dup f = ] [ eof-in-script-html-comment-like-text ] }
+ [ reach emit-char script-data-escaped-state ]
+ } cond ;
+
+: script-data-escaped-dash-state ( document n/f string -- document n'/f string )
+ take-char (script-data-escaped-dash-state) ;
+
+
+: (script-data-escaped-dash-dash-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ reach emit-char script-data-escaped-dash-dash-state ] }
+ { [ dup CHAR: < = ] [ drop script-data-escaped-less-than-sign-state ] }
+ { [ dup CHAR: > = ] [ reach emit-char script-data-state ] }
+ { [ dup CHAR: \0 = ] [ unexpected-null-character script-data-escaped-state ] }
+ { [ dup f = ] [ eof-in-script-html-comment-like-text ] }
+ [ reach emit-char script-data-escaped-state ]
+ } cond ;
+
+: script-data-escaped-dash-dash-state ( document n/f string -- document n'/f string )
+ take-char (script-data-escaped-dash-dash-state) ;
+
+
+: (script-data-escaped-less-than-sign-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: / = ] [ drop pick reset-temporary-buffer script-data-escaped-end-tag-open-state ] }
+ { [ dup ascii-alpha? ] [ [ pick reset-temporary-buffer CHAR: < reach emit-char ] dip (script-data-double-escape-start-state) ] }
+ [ [ CHAR: < reach emit-char ] dip (script-data-escaped-state) ]
+ } cond ;
+
+: script-data-escaped-less-than-sign-state ( document n/f string -- document n'/f string )
+ take-char (script-data-escaped-less-than-sign-state) ;
+
+
+: (script-data-escaped-end-tag-open-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-alpha? ] [ [ pick new-end-tag ] dip (script-data-escaped-end-tag-name-state) ] }
+ [ [ "</" reach emit-string ] dip (script-data-escaped-state) ]
+ } cond ;
+
+: script-data-escaped-end-tag-open-state ( document n/f string -- document n'/f string )
+ take-char (script-data-escaped-end-tag-open-state) ;
+
+
+: (script-data-escaped-end-tag-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [
+ drop pick appropriate-end-tag-token?
+ [ before-attribute-name-state ] [ "</" reach emit-temporary-buffer-with script-data-escaped-state ] if
+ ] }
+ { [ dup CHAR: / = ] [
+ drop pick appropriate-end-tag-token?
+ [ self-closing-start-tag-state ] [ "</" reach emit-temporary-buffer-with script-data-escaped-state ] if
+ ] }
+ { [ dup CHAR: > = ] [
+ drop pick appropriate-end-tag-token?
+ [ pick emit-end-tag data-state ] [ "</" reach emit-temporary-buffer-with script-data-escaped-state ] if
+ ] }
+ { [ dup ascii-upper-alpha? ] [ [ 0x20 + reach push-tag-name ] [ reach push-temporary-buffer ] bi script-data-escaped-end-tag-name-state ] }
+ { [ dup ascii-lower-alpha? ] [ [ reach push-tag-name ] [ reach push-temporary-buffer ] bi script-data-escaped-end-tag-name-state ] }
+ [ [ "</" reach emit-temporary-buffer-with ] dip (script-data-escaped-state) ]
+ } cond ;
+
+: script-data-escaped-end-tag-name-state ( document n/f string -- document n'/f string )
+ take-char (script-data-escaped-end-tag-name-state) ;
+
+
+: (script-data-double-escape-start-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s/>" member? ] [
+ reach emit-char
+ pick temporary-buffer>> "script" sequence=
+ [ script-data-double-escaped-state ] [ script-data-escaped-state ] if
+ ] }
+ { [ dup ascii-upper-alpha? ] [ [ 0x20 + reach push-tag-name ] [ reach push-temporary-buffer ] bi script-data-double-escape-start-state ] }
+ { [ dup ascii-lower-alpha? ] [ [ reach push-tag-name ] [ reach push-temporary-buffer ] bi script-data-double-escape-start-state ] } ! todo
+ [ (script-data-escaped-state) ]
+ } cond ;
+
+: script-data-double-escape-start-state ( document n/f string -- document n'/f string )
+ take-char (script-data-double-escape-start-state) ;
+
+
+: (script-data-double-escaped-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ reach emit-char script-data-double-escaped-dash-state ] }
+ { [ dup CHAR: < = ] [ reach emit-char script-data-double-escaped-less-than-sign-state ] }
+ { [ dup CHAR: \0 = ] [
+ unexpected-null-character
+ CHAR: replacement-character reach emit-char
+ script-data-double-escaped-state
+ ] }
+ { [ dup f = ] [ eof-in-script-html-comment-like-text ] }
+ [ reach emit-char script-data-double-escaped-state ]
+ } cond ;
+
+: script-data-double-escaped-state ( document n/f string -- document n'/f string )
+ take-char (script-data-double-escaped-state) ;
+
+
+: (script-data-double-escaped-dash-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ reach emit-char script-data-double-escaped-dash-dash-state ] }
+ { [ dup CHAR: < = ] [ reach emit-char script-data-double-escaped-less-than-sign-state ] }
+ { [ dup CHAR: \0 = ] [
+ unexpected-null-character
+ CHAR: replacement-character reach emit-char
+ script-data-double-escaped-state
+ ] }
+ { [ dup f = ] [ eof-in-script-html-comment-like-text ] }
+ [ reach emit-char script-data-double-escaped-state ]
+ } cond ;
+
+: script-data-double-escaped-dash-state ( document n/f string -- document n'/f string )
+ take-char (script-data-double-escaped-dash-state) ;
+
+
+: (script-data-double-escaped-dash-dash-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ reach emit-char script-data-double-escaped-dash-dash-state ] }
+ { [ dup CHAR: < = ] [ reach emit-char script-data-double-escaped-less-than-sign-state ] }
+ { [ dup CHAR: > = ] [ reach emit-char script-data-state ] }
+ { [ dup CHAR: \0 = ] [
+ unexpected-null-character
+ CHAR: replacement-character reach emit-char
+ script-data-double-escaped-state
+ ] }
+ { [ dup f = ] [ eof-in-script-html-comment-like-text ] }
+ [ reach emit-char script-data-escaped-state ]
+ } cond ;
+
+: script-data-double-escaped-dash-dash-state ( document n/f string -- document n'/f string )
+ take-char (script-data-double-escaped-dash-dash-state) ;
+
+
+: (script-data-double-escaped-less-than-sign-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: / = ] [ reach emit-char pick reset-temporary-buffer script-data-double-escape-end-state ] }
+ [ (script-data-double-escaped-state) ]
+ } cond ;
+
+: script-data-double-escaped-less-than-sign-state ( document n/f string -- document n'/f string )
+ take-char (script-data-double-escaped-less-than-sign-state) ;
+
+
+: (script-data-double-escape-end-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s/>" member? ] [
+ reach emit-char
+ pick temporary-buffer>> "script" sequence=
+ [ script-data-escaped-state ] [ script-data-double-escaped-state ] if
+ ] }
+ { [ dup ascii-upper-alpha? ] [ [ 0x20 + reach push-tag-name ] [ reach push-temporary-buffer ] bi script-data-double-escape-end-state ] }
+ { [ dup ascii-lower-alpha? ] [ [ reach push-tag-name ] [ reach push-temporary-buffer ] bi script-data-double-escape-end-state ] } ! todo
+ [ (script-data-double-escaped-state) ]
+ } cond ;
+
+: script-data-double-escape-end-state ( document n/f string -- document n'/f string )
+ take-char (script-data-double-escape-end-state) ;
+
+
+: (before-attribute-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop before-attribute-name-state ] }
+ { [ dup "/>" member? ] [ (after-attribute-name-state) ] }
+ { [ dup f = ] [ (after-attribute-name-state) ] }
+ { [ dup CHAR: = = ] [ unexpected-equals-sign-before-attribute-name ] }
+ [ reach push-attribute (attribute-name-state) ]
+ } cond ;
+
+: before-attribute-name-state ( document n/f string -- document n'/f string )
+ take-char (before-attribute-name-state) ;
+
+
+: (attribute-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s/>" member? ] [ (after-attribute-name-state) ] }
+ { [ dup f = ] [ (after-attribute-name-state) ] }
+ { [ dup CHAR: = = ] [ drop before-attribute-value-state ] }
+ { [ dup ascii-upper-alpha? ] [
+ 0x20 + reach push-attribute-name
+ attribute-name-state
+ ] }
+ { [ dup CHAR: \0 = ] [ unexpected-null-character ] }
+ { [ dup "\"'<" member? ] [
+ unexpected-character-in-attribute-name
+ reach push-attribute-name attribute-name-state
+ ] }
+ [ reach push-attribute-name attribute-name-state ]
+ } cond ;
+
+: attribute-name-state ( document n/f string -- document n'/f string )
+ take-char (attribute-name-state) ;
+
+
+: (after-attribute-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop after-attribute-name-state ] }
+ { [ dup CHAR: / = ] [ drop self-closing-start-tag-state ] }
+ { [ dup CHAR: = = ] [ drop before-attribute-value-state ] }
+ { [ dup CHAR: > = ] [ drop pick emit-tag data-state ] }
+ { [ dup f = ] [ eof-in-tag ] }
+ [ [ pick push-attribute ] dip (attribute-name-state) ]
+ } cond ;
+
+: after-attribute-name-state ( document n/f string -- document n'/f string )
+ take-char (after-attribute-name-state) ;
+
+
+: (before-attribute-value-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop before-attribute-name-state ] }
+ { [ dup CHAR: " = ] [ drop attribute-value-double-quoted-state ] }
+ { [ dup CHAR: ' = ] [ drop attribute-value-single-quoted-state ] }
+ { [ dup CHAR: > = ] [ drop missing-attribute-value ] }
+ [ (attribute-value-unquoted-state) ]
+ } cond ;
+
+: before-attribute-value-state ( document n/f string -- document n'/f string )
+ take-char (before-attribute-value-state) ;
+
+
+: (attribute-value-double-quoted-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: " = ] [ drop after-attribute-value-quoted-state ] }
+ { [ dup CHAR: & = ] [
+ drop
+ [ \ attribute-value-double-quoted-state >>return-state ] 2dip character-reference-state
+ ] }
+ { [ dup CHAR: \0 = ] [ unexpected-null-character ] }
+ { [ dup f = ] [ eof-in-tag ] }
+ [ reach push-attribute-value attribute-value-double-quoted-state ]
+ } cond ;
+
+: attribute-value-double-quoted-state ( document n/f string -- document n'/f string )
+ take-char (attribute-value-double-quoted-state) ;
+
+
+: (attribute-value-single-quoted-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: ' = ] [ drop after-attribute-value-quoted-state ] }
+ { [ dup CHAR: & = ] [
+ drop [ \ attribute-value-single-quoted-state >>return-state ] 2dip
+ character-reference-state
+ ] }
+ { [ dup CHAR: \0 = ] [
+ drop unexpected-null-character
+ CHAR: replacement-character reach push-attribute-value
+ ] }
+ { [ dup f = ] [ eof-in-tag ] }
+ [ reach push-attribute-value attribute-value-single-quoted-state ]
+ } cond ;
+
+: attribute-value-single-quoted-state ( document n/f string -- document n'/f string )
+ take-char (attribute-value-single-quoted-state) ;
+
+
+: (attribute-value-unquoted-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop before-attribute-name-state ] }
+ { [ dup CHAR: & = ] [
+ drop
+ [ \ attribute-value-unquoted-state >>return-state ] 2dip character-reference-state
+ ] }
+ { [ dup CHAR: > = ] [ drop pick emit-tag data-state ] }
+ { [ dup CHAR: \0 = ] [ drop unexpected-null-character CHAR: replacement-character reach push-attribute-value ] }
+ { [ dup "\"'<=`" member? ] [
+ unexpected-character-in-unquoted-attribute-value
+ reach push-attribute-value
+ attribute-value-unquoted-state
+ ] }
+ { [ dup f = ] [ eof-in-tag ] }
+ [ reach push-attribute-value attribute-value-unquoted-state ]
+ } cond ;
+
+: attribute-value-unquoted-state ( document n/f string -- document n'/f string )
+ take-char (attribute-value-unquoted-state) ;
+
+
+: (after-attribute-value-quoted-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop before-attribute-name-state ] }
+ { [ dup CHAR: / = ] [ drop self-closing-start-tag-state ] }
+ { [ dup CHAR: > = ] [ drop pick emit-tag data-state ] }
+ { [ dup f = ] [ eof-in-tag ] }
+ [ missing-whitespace-between-attributes (before-attribute-name-state) ]
+ } cond ;
+
+: after-attribute-value-quoted-state ( document n/f string -- document n'/f string )
+ take-char (after-attribute-value-quoted-state) ;
+
+
+: (self-closing-start-tag-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: > = ] [ drop pick [ set-self-closing ] [ emit-tag ] bi data-state ] }
+ { [ dup f = ] [ eof-in-tag ] }
+ [ unexpected-solidus-in-tag ]
+ } cond ;
+
+: self-closing-start-tag-state ( document n/f string -- document n'/f string )
+ take-char (self-closing-start-tag-state) ;
+
+
+: (bogus-comment-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: > = ] [ drop pick emit-comment-token data-state ] }
+ { [ dup f = ] [ drop pick [ emit-comment-token ] [ emit-eof ] bi ] }
+ { [ dup CHAR: \0 = ] [ drop unexpected-null-character CHAR: replacement-character reach push-comment-token ] }
+ [ reach push-comment-token bogus-comment-state ]
+ } cond ;
+
+: bogus-comment-state ( document n/f string -- document n'/f string )
+ take-char (bogus-comment-state) ;
+
+
+: markup-declaration-open-state ( document n/f string -- document n'/f string )
+ {
+ { [ "--" take-from? ] [ comment-start-state ] }
+ { [ "DOCTYPE" take-from-insensitive? ] [ doctype-state ] }
+ { [ "[CDATA[" take-from-insensitive? ] [ unimplemented* ] }
+ [
+ incorrectly-opened-comment ! bogus-comment-state
+ ]
+ } cond ;
+
+: (comment-start-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ drop comment-start-dash-state ] }
+ { [ dup CHAR: > = ] [ drop abrupt-closing-of-empty-comment pick emit-comment-token data-state ] }
+ [ (comment-state) ]
+ } cond ;
+
+: comment-start-state ( document n/f string -- document n'/f string )
+ take-char (comment-start-state) ;
+
+
+: (comment-start-dash-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ drop comment-end-state ] }
+ { [ dup CHAR: > = ] [ drop abrupt-closing-of-empty-comment ] }
+ { [ dup f = ] [ eof-in-comment ] }
+ [ [ CHAR: - reach push-comment-token ] dip (comment-state) ]
+ } cond ;
+
+: comment-start-dash-state ( document n/f string -- document n'/f string )
+ take-char (comment-start-dash-state) ;
+
+
+: (comment-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: < = ] [ reach push-comment-token comment-less-than-sign-state ] }
+ { [ dup CHAR: - = ] [ drop comment-end-dash-state ] }
+ { [ dup CHAR: \0 = ] [ drop unexpected-null-character ] }
+ { [ dup f = ] [ eof-in-comment ] }
+ [ reach push-comment-token comment-state ]
+ } cond ;
+
+: comment-state ( document n/f string -- document n'/f string )
+ take-char (comment-state) ;
+
+
+: (comment-less-than-sign-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: ! = ] [ reach push-comment-token comment-less-than-sign-bang-state ] }
+ { [ dup CHAR: < = ] [ reach push-comment-token comment-less-than-sign-state ] }
+ [ (comment-state) ]
+ } cond ;
+
+: comment-less-than-sign-state ( document n/f string -- document n'/f string )
+ take-char (comment-less-than-sign-state) ;
+
+
+: (comment-less-than-sign-bang-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ reach push-comment-token comment-less-than-sign-bang-dash-state ] }
+ [ (comment-state) ]
+ } cond ;
+
+: comment-less-than-sign-bang-state ( document n/f string -- document n'/f string )
+ take-char (comment-less-than-sign-bang-state) ;
+
+
+: (comment-less-than-sign-bang-dash-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ drop comment-less-than-sign-bang-dash-dash-state ] }
+ [ (comment-end-dash-state) ]
+ } cond ;
+
+: comment-less-than-sign-bang-dash-state ( document n/f string -- document n'/f string )
+ take-char (comment-less-than-sign-bang-dash-state) ;
+
+
+: (comment-less-than-sign-bang-dash-dash-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: > = ] [ (comment-end-state) ] }
+ { [ dup f = ] [ (comment-end-state) ] }
+ [ nested-comment (comment-end-state) ]
+ } cond ;
+
+: comment-less-than-sign-bang-dash-dash-state ( document n/f string -- document n'/f string )
+ take-char (comment-less-than-sign-bang-dash-dash-state) ;
+
+
+: (comment-end-dash-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ drop comment-end-state ] }
+ { [ dup f = ] [ eof-in-comment ] }
+ [ [ CHAR: - reach push-comment-token ] dip (comment-state) ]
+ } cond ;
+
+: comment-end-dash-state ( document n/f string -- document n'/f string )
+ take-char (comment-end-dash-state) ;
+
+
+: (comment-end-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: > = ] [ drop pick emit-comment-token data-state ] }
+ { [ dup CHAR: ! = ] [ drop comment-end-bang-state ] }
+ { [ dup CHAR: - = ] [ reach push-comment-token comment-end-state ] }
+ { [ dup f = ] [ drop eof-in-comment pick [ emit-comment-token ] [ emit-eof ] bi ] }
+ [ [ "--" reach push-all-comment-token ] dip (comment-state) ]
+ } cond ;
+
+: comment-end-state ( document n/f string -- document n'/f string )
+ take-char (comment-end-state) ;
+
+
+: (comment-end-bang-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: - = ] [ drop comment-end-dash-state ] }
+ { [ dup CHAR: > = ] [ drop incorrectly-closed-comment pick emit-comment-token data-state ] }
+ { [ dup f = ] [ eof-in-comment ] }
+ [ [ "--!" reach push-all-comment-token ] dip (comment-state) ]
+ } cond ;
+
+: comment-end-bang-state ( document n/f string -- document n'/f string )
+ take-char (comment-end-bang-state) ;
+
+
+: (doctype-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop before-doctype-name-state ] }
+ { [ dup CHAR: > = ] [ (before-doctype-name-state) ] }
+ { [ dup f = ] [ drop eof-in-doctype pick [ new-doctype-with-quirks ] [ emit-doctype ] [ emit-eof ] tri ] }
+ [ missing-whitespace-before-doctype-name ]
+ } cond ;
+
+: doctype-state ( document n/f string -- document n'/f string )
+ take-char (doctype-state) ;
+
+
+: (before-doctype-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop before-doctype-name-state ] }
+ { [ dup ascii-upper-alpha? ] [ 0x20 + reach new-doctype-from-ch doctype-name-state ] }
+ { [ dup CHAR: \0 = ] [
+ drop
+ unexpected-null-character
+ CHAR: replacement-character reach new-doctype-from-ch
+ doctype-name-state
+ ] }
+ { [ dup CHAR: > = ] [
+ drop missing-doctype-name
+ pick [ new-doctype-with-quirks ] [ emit-doctype ] bi
+ ] }
+ { [ dup f = ] [
+ drop eof-in-doctype
+ pick [ new-doctype-with-quirks ] [ emit-doctype ] [ emit-eof ] tri
+ ] }
+ [ reach new-doctype-from-ch doctype-name-state ]
+ } cond ;
+
+: before-doctype-name-state ( document n/f string -- document n'/f string )
+ take-char (before-doctype-name-state) ;
+
+
+: (doctype-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop after-doctype-name-state ] }
+ { [ dup CHAR: > = ] [ drop pick emit-doctype data-state ] }
+ { [ dup ascii-upper-alpha? ] [ 0x20 + reach push-doctype-name doctype-name-state ] }
+ { [ dup CHAR: \0 = ] [
+ drop unexpected-null-character
+ CHAR: replacement-character pick push-doctype-name
+ doctype-name-state
+ ] }
+ { [ dup f = ] [ drop eof-in-doctype pick [ emit-doctype ] [ emit-eof ] bi ] } ! force-quirks on for doctype
+ [ reach push-doctype-name doctype-name-state ]
+ } cond ;
+
+: doctype-name-state ( document n/f string -- document n'/f string )
+ take-char (doctype-name-state) ;
+
+
+: (after-doctype-name-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop after-doctype-name-state ] }
+ { [ dup CHAR: > = ] [ drop pick emit-doctype data-state ] }
+ { [ dup f = ] [ eof-in-doctype ] }
+ { [ [ "PUBLIC" take-from-insensitive? ] dip swap ] [ drop after-doctype-public-keyword-state ] }
+ { [ [ "SYSTEM" take-from-insensitive? ] dip swap ] [ drop after-doctype-system-keyword-state ] }
+ [ invalid-character-sequence-after-doctype-name ]
+ } cond ;
+
+: after-doctype-name-state ( document n/f string -- document n'/f string )
+ take-char (after-doctype-name-state) ;
+
+
+: (after-doctype-public-keyword-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop before-doctype-public-identifier-state ] }
+ { [ dup CHAR: " = ] [ missing-whitespace-after-doctype-public-keyword ] }
+ { [ dup CHAR: ' = ] [ missing-whitespace-after-doctype-public-keyword ] }
+ { [ dup CHAR: > = ] [ drop missing-doctype-public-identifier force-quirks data-state ] }
+ { [ dup f = ] [ drop eof-in-doctype pick [ emit-doctype ] [ emit-eof ] bi ] }
+ [
+ missing-quote-before-doctype-public-identifier
+ [ reach force-quirks ] dip
+ (bogus-doctype-state)
+ ]
+ } cond ;
+
+: after-doctype-public-keyword-state ( document n/f string -- document n'/f string )
+ take-char (after-doctype-public-keyword-state) ;
+
+
+: (before-doctype-public-identifier-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop before-doctype-public-identifier-state ] }
+ { [ dup CHAR: " = ] [
+ drop pick initialize-doctype-public-identifier
+ doctype-public-identifier-double-quoted-state
+ ] }
+ { [ dup CHAR: ' = ] [
+ drop pick initialize-doctype-public-identifier
+ doctype-public-identifier-single-quoted-state
+ ] }
+ { [ dup CHAR: > = ] [
+ drop missing-doctype-public-identifier
+ pick [ force-quirks ] [ emit-doctype ] bi
+ data-state
+ ] }
+ { [ dup f = ] [ drop eof-in-doctype pick [ emit-doctype ] [ emit-eof ] bi ] }
+ [
+ missing-quote-before-doctype-public-identifier
+ [ reach force-quirks ] dip
+ (bogus-doctype-state)
+ ]
+ } cond ;
+
+: before-doctype-public-identifier-state ( document n/f string -- document n'/f string )
+ take-char (before-doctype-public-identifier-state) ;
+
+
+: (doctype-public-identifier-double-quoted-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: " = ] [ drop after-doctype-public-identifier-state ] }
+ { [ dup CHAR: \0 = ] [
+ drop
+ unexpected-null-character
+ CHAR: replacement-character pick push-doctype-public-identifier
+ doctype-public-identifier-double-quoted-state
+ ] }
+ { [ dup CHAR: > = ] [
+ drop abrupt-doctype-public-identifier
+ pick [ force-quirks ] [ emit-doctype ] bi
+ data-state
+ ] }
+ { [ dup f = ] [
+ drop eof-in-doctype
+ pick [ force-quirks ] [ emit-doctype ] [ emit-eof ] tri
+ ] }
+ [ reach push-doctype-public-identifier doctype-public-identifier-double-quoted-state ]
+ } cond ;
+
+: doctype-public-identifier-double-quoted-state ( document n/f string -- document n'/f string )
+ take-char (doctype-public-identifier-double-quoted-state) ;
+
+
+: (doctype-public-identifier-single-quoted-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: ' = ] [ drop after-doctype-public-identifier-state ] }
+ { [ dup CHAR: \0 = ] [
+ drop
+ unexpected-null-character
+ CHAR: replacement-character pick push-doctype-public-identifier
+ doctype-public-identifier-double-quoted-state
+ ] }
+ { [ dup CHAR: > = ] [
+ drop abrupt-doctype-public-identifier
+ pick [ force-quirks ] [ emit-doctype ] bi
+ data-state
+ ] }
+ { [ dup f = ] [
+ drop eof-in-doctype
+ pick [ force-quirks ] [ emit-doctype ] [ emit-eof ] tri
+ ] }
+ [ reach push-doctype-public-identifier doctype-public-identifier-single-quoted-state ]
+ } cond ;
+
+: doctype-public-identifier-single-quoted-state ( document n/f string -- document n'/f string )
+ take-char (doctype-public-identifier-single-quoted-state) ;
+
+
+: (after-doctype-public-identifier-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop between-doctype-public-and-system-identifiers-state ] }
+ { [ dup CHAR: > = ] [
+ drop pick emit-doctype
+ data-state
+ ] }
+ { [ dup CHAR: " = ] [
+ drop missing-whitespace-between-doctype-public-and-system-identifiers
+ pick initialize-doctype-system-identifier
+ doctype-system-identifier-double-quoted-state
+ ] }
+ { [ dup CHAR: ' = ] [
+ drop missing-whitespace-between-doctype-public-and-system-identifiers
+ pick initialize-doctype-system-identifier
+ doctype-system-identifier-single-quoted-state
+ ] }
+ { [ dup f = ] [ drop eof-in-doctype pick [ force-quirks ] [ emit-doctype ] [ emit-eof ] tri ] }
+ [
+ missing-quote-before-doctype-system-identifier
+ [ reach force-quirks ] dip
+ (bogus-doctype-state)
+ ]
+ } cond ;
+
+: after-doctype-public-identifier-state ( document n/f string -- document n'/f string )
+ take-char (after-doctype-public-identifier-state) ;
+
+
+: (between-doctype-public-and-system-identifiers-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop between-doctype-public-and-system-identifiers-state ] }
+ { [ dup CHAR: > = ] [
+ drop pick emit-doctype
+ data-state
+ ] }
+ { [ dup CHAR: " = ] [
+ drop pick initialize-doctype-system-identifier
+ doctype-system-identifier-double-quoted-state
+ ] }
+ { [ dup CHAR: ' = ] [
+ drop pick initialize-doctype-system-identifier
+ doctype-system-identifier-single-quoted-state
+ ] }
+ { [ dup f = ] [ drop eof-in-doctype pick [ force-quirks ] [ emit-doctype ] [ emit-eof ] tri ] }
+ [
+ missing-quote-before-doctype-system-identifier
+ [ reach force-quirks ] dip
+ (bogus-doctype-state)
+ ]
+ } cond ;
+
+: between-doctype-public-and-system-identifiers-state ( document n/f string -- document n'/f string )
+ take-char (between-doctype-public-and-system-identifiers-state) ;
+
+
+: (after-doctype-system-keyword-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop between-doctype-public-and-system-identifiers-state ] }
+ { [ dup CHAR: " = ] [
+ drop missing-whitespace-after-doctype-system-keyword
+ pick initialize-doctype-system-identifier
+ doctype-system-identifier-double-quoted-state
+ ] }
+ { [ dup CHAR: ' = ] [
+ drop missing-whitespace-after-doctype-system-keyword
+ pick initialize-doctype-system-identifier
+ doctype-system-identifier-single-quoted-state
+ ] }
+ { [ dup CHAR: > = ] [
+ drop missing-doctype-system-identifier
+ pick [ force-quirks ] [ emit-doctype ] bi
+ data-state
+ ] }
+ { [ dup f = ] [ drop eof-in-doctype pick [ force-quirks ] [ emit-doctype ] [ emit-eof ] tri ] }
+ [
+ missing-quote-before-doctype-system-identifier
+ [ reach force-quirks ] dip
+ (bogus-doctype-state)
+ ]
+ } cond ;
+
+: after-doctype-system-keyword-state ( document n/f string -- document n'/f string )
+ take-char (after-doctype-system-keyword-state) ;
+
+
+: (before-doctype-system-identifier-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop before-doctype-system-identifier-state ] }
+ { [ dup CHAR: " = ] [
+ drop pick initialize-doctype-system-identifier
+ doctype-system-identifier-double-quoted-state
+ ] }
+ { [ dup CHAR: ' = ] [
+ drop pick initialize-doctype-system-identifier
+ doctype-system-identifier-single-quoted-state
+ ] }
+ { [ dup CHAR: > = ] [
+ drop missing-doctype-system-identifier
+ pick [ force-quirks ] [ emit-doctype ] bi
+ data-state
+ ] }
+ { [ dup f = ] [ drop eof-in-doctype pick [ emit-doctype ] [ emit-eof ] bi ] }
+ [
+ missing-quote-before-doctype-system-identifier
+ [ reach force-quirks ] dip
+ (bogus-doctype-state)
+ ]
+ } cond ;
+
+: before-doctype-system-identifier-state ( document n/f string -- document n'/f string )
+ take-char (before-doctype-system-identifier-state) ;
+
+
+: (doctype-system-identifier-double-quoted-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: " = ] [ drop after-doctype-system-identifier-state ] }
+ { [ dup CHAR: \0 = ] [
+ drop
+ unexpected-null-character
+ CHAR: replacement-character pick push-doctype-system-identifier
+ doctype-system-identifier-double-quoted-state
+ ] }
+ { [ dup CHAR: > = ] [
+ drop abrupt-doctype-system-identifier
+ pick [ force-quirks ] [ emit-doctype ] bi
+ data-state
+ ] }
+ { [ dup f = ] [
+ drop eof-in-doctype
+ pick [ force-quirks ] [ emit-doctype ] [ emit-eof ] tri
+ ] }
+ [ reach push-doctype-system-identifier doctype-system-identifier-double-quoted-state ]
+ } cond ;
+
+: doctype-system-identifier-double-quoted-state ( document n/f string -- document n'/f string )
+ take-char (doctype-system-identifier-double-quoted-state) ;
+
+
+: (doctype-system-identifier-single-quoted-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: ' = ] [ drop after-doctype-system-identifier-state ] }
+ { [ dup CHAR: \0 = ] [
+ drop
+ unexpected-null-character
+ CHAR: replacement-character pick push-doctype-system-identifier
+ doctype-system-identifier-double-quoted-state
+ ] }
+ { [ dup CHAR: > = ] [
+ drop abrupt-doctype-system-identifier
+ pick [ force-quirks ] [ emit-doctype ] bi
+ data-state
+ ] }
+ { [ dup f = ] [
+ drop eof-in-doctype
+ pick [ force-quirks ] [ emit-doctype ] [ emit-eof ] tri
+ ] }
+ [ reach push-doctype-system-identifier doctype-system-identifier-single-quoted-state ]
+ } cond ;
+
+: doctype-system-identifier-single-quoted-state ( document n/f string -- document n'/f string )
+ take-char (doctype-system-identifier-single-quoted-state) ;
+
+
+: (after-doctype-system-identifier-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "\t\n\f\s" member? ] [ drop after-doctype-system-identifier-state ] }
+ { [ dup CHAR: > = ] [
+ drop pick emit-doctype
+ data-state
+ ] }
+ { [ dup f = ] [ drop eof-in-doctype pick [ force-quirks ] [ emit-doctype ] [ emit-eof ] tri ] }
+ [
+ unexpected-character-after-doctype-system-identifier
+ [ reach force-quirks ] dip
+ (bogus-doctype-state)
+ ]
+ } cond ;
+
+: after-doctype-system-identifier-state ( document n/f string -- document n'/f string )
+ take-char (after-doctype-system-identifier-state) ;
+
+
+: (bogus-doctype-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: > = ] [ drop pick emit-doctype data-state ] }
+ { [ dup CHAR: \0 = ] [ drop unexpected-null-character bogus-doctype-state ] }
+ { [ dup f = ] [ drop eof-in-doctype pick emit-eof ] }
+ [ drop bogus-doctype-state ]
+ } cond ;
+
+: bogus-doctype-state ( document n/f string -- document n'/f string )
+ take-char (bogus-doctype-state) ;
+
+
+: (cdata-section-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: ] = ] [ drop cdata-section-bracket-state ] }
+ { [ dup f = ] [ drop eof-in-cdata pick emit-eof ] }
+ [ reach emit-char cdata-section-state ]
+ } cond ;
+
+: cdata-section-state ( document n/f string -- document n'/f string )
+ take-char (cdata-section-state) ;
+
+
+: (cdata-section-bracket-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: ] = ] [ drop cdata-section-end-state ] }
+ [ [ CHAR: ] reach emit-char ] dip (cdata-section-state) ]
+ } cond ;
+
+: cdata-section-bracket-state ( document n/f string -- document n'/f string )
+ take-char (cdata-section-bracket-state) ;
+
+
+: (cdata-section-end-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup CHAR: ] = ] [ reach emit-char cdata-section-end-state ] }
+ { [ dup CHAR: > = ] [ drop data-state ] }
+ [ [ "]]" reach emit-string ] dip (cdata-section-state) ]
+ } cond ;
+
+: cdata-section-end-state ( document n/f string -- document n'/f string )
+ take-char (cdata-section-end-state) ;
+
+
+: (character-reference-state) ( document n/f string ch/f -- document n'/f string )
+ [ CHAR: & reach ch>new-temporary-buffer ] dip
+ {
+ { [ dup ascii-alphanumeric? ] [ (named-character-reference-state) ] }
+ { [ dup CHAR: # = ] [ reach push-temporary-buffer numeric-character-reference-state ] }
+ [ reach flush-temporary-buffer (return-state) ]
+ } cond ;
+
+: character-reference-state ( document n/f string -- document n'/f string )
+ take-char (character-reference-state) ;
+
+
+: (named-character-reference-state) ( document n/f string ch/f -- document n'/f string )
+ reach push-temporary-buffer
+ pick named-character-match?
+ [
+ drop ! exact match, drop prefix match
+ ! XXX: check me
+ {
+ [ pick temporary-buffer-attribute? ]
+ [ pick temporary-buffer>> ?last CHAR: ; = not ]
+ [ 3dup peek-from { [ CHAR: = = ] [ ascii-alphanumeric? ] } 1|| ]
+ } 0&& [
+ unimplemented*
+ flush-temporary-buffer
+ return-state
+ ] [
+ pick [ take-named-character ] [ flush-temporary-buffer ] bi return-state
+ ] if
+ ] [
+ ! prefix match?
+ [ named-character-reference-state ]
+ [ pick flush-temporary-buffer ambiguous-ampersand-state ] if
+ ] if ;
+
+: named-character-reference-state ( document n/f string -- document n'/f string )
+ take-char (named-character-reference-state) ;
+
+
+: (ambiguous-ampersand-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-alphanumeric? ] [
+ unimplemented*
+ ] }
+ { [ dup CHAR: ; = ] [ unknown-named-character-reference (return-state) ] }
+ [ (return-state) ]
+ } cond ;
+
+: ambiguous-ampersand-state ( document n/f string -- document n'/f string )
+ take-char (ambiguous-ampersand-state) ;
+
+
+: (numeric-character-reference-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup "xX" member? ] [ reach push-temporary-buffer hexadecimal-character-reference-start-state ] }
+ [ (decimal-character-reference-start-state) ]
+ } cond ;
+
+: numeric-character-reference-state ( document n/f string -- document n'/f string )
+ take-char (numeric-character-reference-state) ;
+
+
+: (hexadecimal-character-reference-start-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-hex-digit? ] [ (hexadecimal-character-reference-state) ] }
+ [ absence-of-digits-in-numeric-character-reference reach flush-temporary-buffer (return-state) ]
+ } cond ;
+
+: hexadecimal-character-reference-start-state ( document n/f string -- document n'/f string )
+ take-char (hexadecimal-character-reference-start-state) ;
+
+
+: (decimal-character-reference-start-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-digit? ] [ (decimal-character-reference-state) ] }
+ [ absence-of-digits-in-numeric-character-reference reach flush-temporary-buffer (return-state) ]
+ } cond ;
+
+: decimal-character-reference-start-state ( document n/f string -- document n'/f string )
+ take-char (decimal-character-reference-start-state) ;
+
+
+: (hexadecimal-character-reference-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-digit? ] [ unimplemented* ] }
+ { [ dup ascii-upper-hex-digit? ] [ unimplemented* ] }
+ { [ dup ascii-lower-hex-digit? ] [ unimplemented* ] }
+ { [ dup CHAR: ; = ] [ drop numeric-character-reference-end-state ] }
+ [ missing-semicolon-after-character-reference ]
+ } cond ;
+
+: hexadecimal-character-reference-state ( document n/f string -- document n'/f string )
+ take-char (hexadecimal-character-reference-state) ;
+
+
+: (decimal-character-reference-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ { [ dup ascii-digit? ] [ unimplemented* ] }
+ { [ dup CHAR: ; = ] [ drop numeric-character-reference-end-state ] }
+ [ missing-semicolon-after-character-reference ]
+ } cond ;
+
+: decimal-character-reference-state ( document n/f string -- document n'/f string )
+ take-char (decimal-character-reference-state) ;
+
+
+: (numeric-character-reference-end-state) ( document n/f string ch/f -- document n'/f string )
+ {
+ [ missing-semicolon-after-character-reference ]
+ } cond ;
+
+: numeric-character-reference-end-state ( document n/f string -- document n'/f string )
+ take-char (numeric-character-reference-end-state) ;
+
+
+
+: parse-html5 ( string -- document )
+ [ <document> 0 ] dip data-state 2drop ;
\ No newline at end of file
projects / factor.git / blobdiff