source: project/release/4/htmlprag/htmlprag.scm @ 14509

Last change on this file since 14509 was 14509, checked in by Jim Ursetto, 11 years ago

htmlprag/4: apply Peter Danenberg's object patch (not in upstream)

File size: 81.7 KB
Line 
1;;; @Package     HtmlPrag
2;;; @Subtitle    Pragmatic Parsing and Emitting of HTML using SXML and SHTML
3;;; @HomePage    http://www.neilvandyke.org/htmlprag/
4;;; @Author      Neil W. Van Dyke
5;;; @AuthorEmail neil@@neilvandyke.org
6;;; @Version     0.16
7;;; @Date        2005-12-18
8
9;; $Id: htmlprag.scm,v 1.385 2005/12/19 03:28:28 neil Exp $
10
11;;; Local modifications for Chicken.
12
13(declare
14 (fixnum))
15
16
17(module htmlprag
18
19 (shtml-comment-symbol 
20  shtml-decl-symbol shtml-empty-symbol
21  shtml-end-symbol shtml-entity-symbol shtml-pi-symbol
22  shtml-start-symbol shtml-text-symbol shtml-top-symbol
23  shtml-named-char-id shtml-numeric-char-id make-shtml-entity
24  shtml-entity-value make-html-tokenizer tokenize-html
25  shtml-token-kind parse-html/tokenizer
26  html->sxml-0nf html->sxml-1nf html->sxml-2nf
27  html->sxml html->shtml write-shtml-as-html shtml->html)
28
29 (import scheme chicken)
30
31
32;;; @legal
33;;; Copyright @copyright{} 2003 - 2005 Neil W. Van Dyke.  This program is Free
34;;; Software; you can redistribute it and/or modify it under the terms of the
35;;; GNU Lesser General Public License as published by the Free Software
36;;; Foundation; either version 2.1 of the License, or (at your option) any
37;;; later version.  This program is distributed in the hope that it will be
38;;; useful, but without any warranty; without even the implied warranty of
39;;; merchantability or fitness for a particular purpose.  See
40;;; @indicateurl{http://www.gnu.org/copyleft/lesser.html} for details.  For
41;;; other license options and consulting, contact the author.
42;;; @end legal
43
44;;; @section Introduction
45
46;;; HtmlPrag provides permissive HTML parsing and emitting capability to Scheme
47;;; programs.  The parser is useful for software agent extraction of
48;;; information from Web pages, for programmatically transforming HTML files,
49;;; and for implementing interactive Web browsers.  HtmlPrag emits ``SHTML,''
50;;; which is an encoding of HTML in
51;;; @uref{http://pobox.com/~oleg/ftp/Scheme/SXML.html, SXML}, so that
52;;; conventional HTML may be processed with XML tools such as
53;;; @uref{http://pair.com/lisovsky/query/sxpath/, SXPath}.  Like Oleg
54;;; Kiselyov's @uref{http://pobox.com/~oleg/ftp/Scheme/xml.html#HTML-parser,
55;;; SSAX-based HTML parser}, HtmlPrag provides a permissive tokenizer, but also
56;;; attempts to recover structure.  HtmlPrag also includes procedures for
57;;; encoding SHTML in HTML syntax.
58;;;
59;;; The HtmlPrag parsing behavior is permissive in that it accepts erroneous
60;;; HTML, handling several classes of HTML syntax errors gracefully, without
61;;; yielding a parse error.  This is crucial for parsing arbitrary real-world
62;;; Web pages, since many pages actually contain syntax errors that would
63;;; defeat a strict or validating parser.  HtmlPrag's handling of errors is
64;;; intended to generally emulate popular Web browsers' interpretation of the
65;;; structure of erroneous HTML.  We euphemistically term this kind of parse
66;;; ``pragmatic.''
67;;;
68;;; HtmlPrag also has some support for XHTML, although XML namespace qualifiers
69;;; are currently accepted but stripped from the resulting SHTML.  Note that
70;;; valid XHTML input is of course better handled by a validating XML parser
71;;; like Kiselyov's
72;;; @uref{http://pobox.com/~oleg/ftp/Scheme/xml.html#XML-parser, SSAX}.
73;;;
74;;; HtmlPrag requires R5RS, SRFI-6, and SRFI-23.
75
76;; The following bindings are used internally by HtmlPrag for portability, with
77;; the intention that packagings of HtmlPrag use more efficient procedures for
78;; the particular Scheme implementation.  This is waiting on universal support
79;; of SRFI-0.
80
81;; @defproc %htmlprag:a2c num
82;;
83;; Returns the character with ASCII value @var{num}.  In most Scheme
84;; implementations, this is the same as @code{integer->char}.  Two exceptions
85;; are Scheme 48 0.57 and Scsh 0.6.3, for which the user must manually edit
86;; file @code{htmlprag.scm} to bind this variable to @code{ascii->char}.  A
87;; future version of HtmlPrag will automatically use @code{ascii->char} where
88;; available.
89
90(define %htmlprag:a2c integer->char)
91
92;; @defproc %htmlprag:append! a b
93;;
94;; Returns a concatenation of lists @var{a} and @var{b}, modifying the tail of
95;; @var{a} to point to the head of @var{b} if both lists are non-null.  A
96;; future version should use the more general @code{append!} where available.
97
98(define (%htmlprag:append! a b)
99  (cond ((null? a) b)
100        ((null? b) a)
101        (else      (let loop  ((sub a))
102                     (if (null? (cdr sub))
103                         (begin (set-cdr! sub b)
104                                a)
105                         (loop (cdr sub)))))))
106
107;; @defproc %htmlprag:reverse!ok lst
108;;
109;; Returns a reversed list @var{lst}, possibly destructive.  A future version
110;; will use @code{reverse!} where available, and @code{reverse} elsewhere.
111
112(define %htmlprag:reverse!ok reverse)
113
114;; @defproc %htmlprag:down str
115;;
116;; Returns a string that is equivalent to @var{str} with all characters mapped
117;; to lowercase, as if by @code{char-downcase}, without mutating @var{str}.  A
118;; future version should use the Scheme implementation's native nondestructive
119;; procedure where available.
120
121;; @defproc %htmlprag:error proc-str msg obj
122;;
123;; For Bigloo, this is changed to:
124;;
125;; @lisp
126;; (define %htmlprag:error error)
127;; @end lisp
128
129;; TODO: Maybe go back to requiring a SRFI-23 "error".
130
131(define-syntax %htmlprag:error
132  (syntax-rules ()
133    ((_ p m o) (error (string-append p " : " m) o))
134    ;; ((_ p m o) (error p m o))))
135    ))
136
137(define (%htmlprag:down s)
138  (list->string (map char-downcase (string->list s))))
139
140;; @defproc %htmlprag:down!ok str
141;;
142;; Returns a string that is equivalent to @var{str} with all characters mapped
143;; to lowercase, as if by @code{char-downcase}, possibly mutating @var{str}.
144;; A future version should use the Scheme implementation's native destructive
145;; or nondestructive procedure where available.
146
147(define %htmlprag:down!ok %htmlprag:down)
148
149;; @defproc %htmlprag:gosc os
150;;
151;; One-shot version of the conventional @code{get-output-string}.  The result
152;; of any subsequent attempt to write to the port or get the output string is
153;; undefined.  This may or may not free up resources.
154
155(define (%htmlprag:gosc os)
156  (let ((str (get-output-string os)))
157    ;; Note: By default, we don't call close-output-port, since at least one
158    ;; tested Scheme implementation barfs on that.
159    ;;
160    ;; (close-output-port os)
161    str))
162
163;;; @section SHTML and SXML
164
165;;; SHTML is a variant of SXML, with two minor but useful extensions:
166;;;
167;;; @enumerate
168;;;
169;;; @item
170;;; The SXML keyword symbols, such as @code{*TOP*}, are defined to be in all
171;;; uppercase, regardless of the case-sensitivity of the reader of the hosting
172;;; Scheme implementation in any context.  This avoids several pitfalls.
173;;;
174;;; @item
175;;; Since not all character entity references used in HTML can be converted to
176;;; Scheme characters in all R5RS Scheme implementations, nor represented in
177;;; conventional text files or other common external text formats to which one
178;;; might wish to write SHTML, SHTML adds a special @code{&} syntax for
179;;; non-ASCII (or non-Extended-ASCII) characters.  The syntax is @code{(&
180;;; @var{val})}, where @var{val} is a symbol or string naming with the symbolic
181;;; name of the character, or an integer with the numeric value of the
182;;; character.
183;;;
184;;; @end enumerate
185
186;;; @defvar  shtml-comment-symbol
187;;; @defvarx shtml-decl-symbol
188;;; @defvarx shtml-empty-symbol
189;;; @defvarx shtml-end-symbol
190;;; @defvarx shtml-entity-symbol
191;;; @defvarx shtml-pi-symbol
192;;; @defvarx shtml-start-symbol
193;;; @defvarx shtml-text-symbol
194;;; @defvarx shtml-top-symbol
195;;;
196;;; These variables are bound to the following case-sensitive symbols used in
197;;; SHTML, respectively: @code{*COMMENT*}, @code{*DECL*}, @code{*EMPTY*},
198;;; @code{*END*}, @code{*ENTITY*}, @code{*PI*}, @code{*START*}, @code{*TEXT*},
199;;; and @code{*TOP*}.  These can be used in lieu of the literal symbols in
200;;; programs read by a case-insensitive Scheme reader.@footnote{Scheme
201;;; implementators who have not yet made @code{read} case-sensitive by default
202;;; are encouraged to do so.}
203
204(define shtml-comment-symbol (string->symbol "*COMMENT*"))
205(define shtml-decl-symbol    (string->symbol "*DECL*"))
206(define shtml-empty-symbol   (string->symbol "*EMPTY*"))
207(define shtml-end-symbol     (string->symbol "*END*"))
208(define shtml-entity-symbol  (string->symbol "*ENTITY*"))
209(define shtml-pi-symbol      (string->symbol "*PI*"))
210(define shtml-start-symbol   (string->symbol "*START*"))
211(define shtml-text-symbol    (string->symbol "*TEXT*"))
212(define shtml-top-symbol     (string->symbol "*TOP*"))
213
214;;; @defvar  shtml-named-char-id
215;;; @defvarx shtml-numeric-char-id
216;;;
217;;; These variables are bound to the SHTML entity public identifier strings
218;;; used in SHTML @code{*ENTITY*} named and numeric character entity
219;;; references.
220
221(define shtml-named-char-id   "shtml-named-char")
222(define shtml-numeric-char-id "shtml-numeric-char")
223
224;;; @defproc make-shtml-entity val
225;;;
226;;; Yields an SHTML character entity reference for @var{val}.  For example:
227;;;
228;;; @lisp
229;;; (make-shtml-entity "rArr")                  @result{} (& rArr)
230;;; (make-shtml-entity (string->symbol "rArr")) @result{} (& rArr)
231;;; (make-shtml-entity 151)                     @result{} (& 151)
232;;; @end lisp
233
234(define (make-shtml-entity val)
235  (list '& (cond ((symbol?  val) val)
236                 ((integer? val) val)
237                 ((string?  val) (string->symbol val))
238                 (else (%htmlprag:error "make-shtml-entity"
239                                        "invalid SHTML entity value:"
240                                        val)))))
241
242;; TODO:
243;;
244;; (define (shtml-entity? x)
245;;   (and (shtml-entity-value entity) #t))
246
247;;; @defproc shtml-entity-value obj
248;;;
249;;; Yields the value for the SHTML entity @var{obj}, or @code{#f} if @var{obj}
250;;; is not a recognized entity.  Values of named entities are symbols, and
251;;; values of numeric entities are numbers.  An error may raised if @var{obj}
252;;; is an entity with system ID inconsistent with its public ID.  For example:
253;;;
254;;; @lisp
255;;; (define (f s) (shtml-entity-value (cadr (html->shtml s))))
256;;; (f " ")  @result{} nbsp
257;;; (f "ߐ") @result{} 2000
258;;; @end lisp
259
260(define (shtml-entity-value entity)
261  (cond ((not (pair? entity)) #f)
262        ((null? (cdr entity)) #f)
263        ((eqv? (car entity) '&)
264         ;; TODO: Error-check for extraneous list members?
265         (let ((val (cadr entity)))
266           (cond ((symbol?  val) val)
267                 ((integer? val) val)
268                 ((string?  val) (string->symbol val))
269                 (else           #f))))
270        ((eqv? (car entity) shtml-entity-symbol)
271         (if (null? (cddr entity))
272             #f
273             (let ((public-id (list-ref entity 1))
274                   (system-id (list-ref entity 2)))
275               ;; TODO: Error-check for extraneous list members?
276               (cond ((equal? public-id shtml-named-char-id)
277                      (string->symbol system-id))
278                     ((equal? public-id shtml-numeric-char-id)
279                      (string->number system-id))
280                     (else #f)))))
281        (else #f)))
282
283;;; @section Tokenizing
284
285;;; The tokenizer is used by the higher-level structural parser, but can also
286;;; be called directly for debugging purposes or unusual applications.  Some of
287;;; the list structure of tokens, such as for start tag tokens, is mutated and
288;;; incorporated into the SHTML list structure emitted by the parser.
289
290;; TODO: Document the token format.
291
292;;; @defproc make-html-tokenizer in normalized?
293;;;
294;;; Constructs an HTML tokenizer procedure on input port @var{in}.  If boolean
295;;; @var{normalized?} is true, then tokens will be in a format conducive to use
296;;; with a parser emitting normalized SXML.  Each call to the resulting
297;;; procedure yields a successive token from the input.  When the tokens have
298;;; been exhausted, the procedure returns the null list.  For example:
299;;;
300;;; @lisp
301;;; (define input (open-input-string "<a href=\"foo\">bar</a>"))
302;;; (define next  (make-html-tokenizer input #f))
303;;; (next) @result{} (a (@@ (href "foo")))
304;;; (next) @result{} "bar"
305;;; (next) @result{} (*END* a)
306;;; (next) @result{} ()
307;;; (next) @result{} ()
308;;; @end lisp
309
310(define make-html-tokenizer
311  ;; TODO: Have the tokenizer replace contiguous whitespace within individual
312  ;; text tokens with single space characters (except for when in `pre' and
313  ;; verbatim elements).  The parser will introduce new contiguous whitespace
314  ;; (e.g., when text tokens are concatenated, invalid end tags are removed,
315  ;; whitespace is irrelevant between certain elements), but then the parser
316  ;; only has to worry about the first and last character of each string.
317  ;; Perhaps the text tokens should have both leading and trailing whitespace
318  ;; stripped, and contain flags for whether or not leading and trailing
319  ;; whitespace occurred.
320  (letrec ((no-token '())
321
322           ;; TODO: Maybe make these three variables options.
323
324           (verbatim-to-eof-elems '(plaintext))
325
326           (verbatim-pair-elems '(script server style xmp))
327
328           (ws-chars (list #\space
329                           (%htmlprag:a2c 9)
330                           (%htmlprag:a2c 10)
331                           (%htmlprag:a2c 11)
332                           (%htmlprag:a2c 12)
333                           (%htmlprag:a2c 13)))
334
335           (gosc/string-or-false
336            (lambda (os)
337              (let ((s (%htmlprag:gosc os)))
338                (if (string=? s "") #f s))))
339
340           (gosc/symbol-or-false
341            (lambda (os)
342              (let ((s (gosc/string-or-false os)))
343                (if s (string->symbol s) #f))))
344           )
345    (lambda (in normalized?)
346      ;; TODO: Make a tokenizer option that causes XML namespace qualifiers to
347      ;; be ignored.
348      (letrec
349          (
350           ;; Port buffer with inexpensive unread of one character and slightly
351           ;; more expensive pushback of second character to unread.  The
352           ;; procedures themselves do no consing.  The tokenizer currently
353           ;; needs two-symbol lookahead, due to ambiguous "/" while parsing
354           ;; element and attribute names, which could be either empty-tag
355           ;; syntax or XML qualified names.
356           (c           #f)
357           (next-c      #f)
358           (c-consumed? #t)
359           (read-c      (lambda ()
360                          (if c-consumed?
361                              (if next-c
362                                  (begin (set! c      next-c)
363                                         (set! next-c #f))
364                                  (set! c (read-char in)))
365                              (set! c-consumed? #t))))
366           (unread-c    (lambda ()
367                          (if c-consumed?
368                              (set! c-consumed? #f)
369                              ;; TODO: Procedure name in error message really
370                              ;; isn't "make-html-tokenizer"...
371                              (%htmlprag:error "make-html-tokenizer"
372                                               "already unread:"
373                                               c))))
374           (push-c      (lambda (new-c)
375                          (if c-consumed?
376                              (begin (set! c           new-c)
377                                     (set! c-consumed? #f))
378                              (if next-c
379                                  (%htmlprag:error
380                                   "make-html-tokenizer"
381                                   "pushback full:"
382                                   c)
383                                  (begin (set! next-c      c)
384                                         (set! c           new-c)
385                                         (set! c-consumed? #f))))))
386
387           ;; TODO: These procedures are a temporary convenience for
388           ;; enumerating the pertinent character classes, with an eye towards
389           ;; removing redundant tests of character class.  These procedures
390           ;; should be eliminated in a future version.
391           (c-eof?      (lambda () (eof-object? c)))
392           (c-amp?      (lambda () (eqv? c #\&)))
393           (c-apos?     (lambda () (eqv? c #\')))
394           (c-bang?     (lambda () (eqv? c #\!)))
395           (c-colon?    (lambda () (eqv? c #\:)))
396           (c-quot?     (lambda () (eqv? c #\")))
397           (c-equals?   (lambda () (eqv? c #\=)))
398           (c-gt?       (lambda () (eqv? c #\>)))
399           (c-lsquare?  (lambda () (eqv? c #\[)))
400           (c-lt?       (lambda () (eqv? c #\<)))
401           (c-minus?    (lambda () (eqv? c #\-)))
402           (c-pound?    (lambda () (eqv? c #\#)))
403           (c-ques?     (lambda () (eqv? c #\?)))
404           (c-semi?     (lambda () (eqv? c #\;)))
405           (c-slash?    (lambda () (eqv? c #\/)))
406           (c-splat?    (lambda () (eqv? c #\*)))
407           (c-lf?       (lambda () (eqv? c #\newline)))
408           (c-angle?    (lambda () (memv c '(#\< #\>))))
409           (c-ws?       (lambda () (memv c ws-chars)))
410           (c-alpha?    (lambda () (char-alphabetic? c)))
411           (c-digit?    (lambda () (char-numeric? c)))
412           (c-alphanum? (lambda () (or (c-alpha?) (c-digit?))))
413           (c-hexlet?   (lambda () (memv c '(#\a #\b #\c #\d #\e #\f
414                                             #\A #\B #\C #\D #\E #\F))))
415
416           (skip-ws     (lambda () (read-c) (if (c-ws?) (skip-ws) (unread-c))))
417
418           (if-read-chars
419            (lambda (match-chars yes-thunk no-proc)
420              (let loop ((chars       match-chars)
421                         (match-count 0))
422                (if (null? chars)
423                    (yes-thunk)
424                    (begin (read-c)
425                           (if (eqv? c (car chars))
426                               (begin (loop (cdr chars) (+ 1 match-count)))
427                               (begin (unread-c)
428                                      (no-proc match-chars match-count))))))))
429
430           (write-chars-count
431            (lambda (chars count port)
432              (let loop ((chars chars)
433                         (count count))
434                (or (zero? count)
435                    (begin (write-char (car chars) port)
436                           (loop (cdr chars)
437                                 (- count 1)))))))
438
439           (make-start-token
440            (if normalized?
441                (lambda (name ns attrs)
442                  (list name (cons '@ attrs)))
443                (lambda (name ns attrs)
444                  (if (null? attrs)
445                      (list name)
446                      (list name (cons '@ attrs))))))
447
448           (make-empty-token
449            (lambda (name ns attrs)
450              (cons shtml-empty-symbol
451                    (make-start-token name ns attrs))))
452
453           (make-end-token
454            (if normalized?
455                (lambda (name ns attrs)
456                  (list shtml-end-symbol
457                        name
458                        (cons '@ attrs)))
459                (lambda (name ns attrs)
460                  (if (null? attrs)
461                      (list shtml-end-symbol name)
462                      (list shtml-end-symbol
463                            name
464                            (cons '@ attrs))))))
465
466           (make-comment-token
467            (lambda (str) (list shtml-comment-symbol str)))
468
469           (make-decl-token
470            (lambda (parts) (cons shtml-decl-symbol parts)))
471
472           (scan-qname
473            ;; TODO: Make sure we don't accept local names that have "*", since
474            ;; this can break SXML tools.  Have to validate this afterwards if
475            ;; "verbatim-safe?".  Also check for "@" and maybe "@@".  Check
476            ;; qname parsing code, especially for verbatim mode.  This is
477            ;; important!
478            (lambda (verbatim-safe?)
479              ;; Note: If we accept some invalid local names, we only need two
480              ;; symbols of lookahead to determine the end of a qname.
481              (letrec ((os      #f)
482                       (ns      '())
483                       (vcolons 0)
484                       (good-os (lambda ()
485                                  (or os
486                                      (begin (set! os (open-output-string))
487                                             os)))))
488                (let loop ()
489                  (read-c)
490                  (cond ((c-eof?) #f)
491                        ((or (c-ws?) (c-splat?))
492                         (if verbatim-safe?
493                             (unread-c)))
494                        ((or (c-angle?) (c-equals?) (c-quot?) (c-apos?))
495                         (unread-c))
496                        ((c-colon?)
497                         (or (null? ns)
498                             (set! ns (cons ":" ns)))
499                         (if os
500                             (begin
501                               (set! ns (cons (%htmlprag:gosc os)
502                                              ns))
503                               (set! os #f)))
504                         (loop))
505                        ((c-slash?)
506                         (read-c)
507                         (cond ((or (c-eof?)
508                                    (c-ws?)
509                                    (c-equals?)
510                                    (c-apos?)
511                                    (c-quot?)
512                                    (c-angle?)
513                                    (c-splat?))
514                                (unread-c)
515                                (push-c #\/))
516                               (else (write-char #\/ (good-os))
517                                     (write-char c   os)
518                                     (loop))))
519                        (else (write-char c (good-os))
520                              (loop))))
521                (let ((ns    (if (null? ns)
522                                 #f
523                                 (apply string-append
524                                        (%htmlprag:reverse!ok ns))))
525                      (local (if os (%htmlprag:gosc os) #f)))
526                  (if verbatim-safe?
527                      ;; TODO: Make sure we don't have ambiguous ":" or drop
528                      ;; any characters!
529                      (cons ns local)
530                      ;; Note: We represent "xml:" and "xmlns:" syntax as
531                      ;; normal qnames, for lack of something better to do with
532                      ;; them when we don't support XML namespaces.
533                      ;;
534                      ;; TODO: Local names are currently forced to lowercase,
535                      ;; since HTML is usually case-insensitive.  If XML
536                      ;; namespaces are used, we might wish to keep local names
537                      ;; case-sensitive.
538                      (if local
539                          (if ns
540                              (if (or (string=? ns "xml")
541                                      (string=? ns "xmlns"))
542                                  (string->symbol (string-append ns ":" local))
543                                  (cons ns
544                                        (string->symbol
545                                         (%htmlprag:down!ok
546                                          local))))
547                              (string->symbol
548                               (%htmlprag:down!ok local)))
549                          (if ns
550                              (string->symbol
551                               (%htmlprag:down!ok ns))
552                              ;; TODO: Ensure in rest of code that returning #f
553                              ;; as a name here is OK.
554                              #f)))))))
555
556           (scan-tag
557            (lambda (start?)
558              (skip-ws)
559              (let ((tag-name   (scan-qname #f))
560                    (tag-ns     #f)
561                    (tag-attrs  #f)
562                    (tag-empty? #f))
563                ;; Scan element name.
564                (if (pair? tag-name)
565                    (begin (set! tag-ns   (car tag-name))
566                           (set! tag-name (cdr tag-name))))
567                ;; TODO: Ensure there's no case in which a #f tag-name isn't
568                ;; compensated for later.
569                ;;
570                ;; Scan element attributes.
571                (set! tag-attrs
572                      (let scan-attr-list ()
573                        (read-c)
574                        (cond ((c-eof?)   '())
575                              ((c-angle?) (unread-c) '())
576                              ((c-slash?)
577                               (set! tag-empty? #t)
578                               (scan-attr-list))
579                              ((c-alpha?)
580                               (unread-c)
581                               (let ((attr (scan-attr)))
582                                 (cons attr (scan-attr-list))))
583                              (else (scan-attr-list)))))
584                ;; Find ">" or unnatural end.
585                (let loop ()
586                  (read-c)
587                  (cond ((c-eof?)   no-token)
588                        ((c-slash?) (set! tag-empty? #t) (loop))
589                        ((c-gt?)    #f)
590                        ((c-ws?)    (loop))
591                        (else       (unread-c))))
592                ;; Change the tokenizer mode if necessary.
593                (cond ((not start?) #f)
594                      (tag-empty?   #f)
595                      ;; TODO: Maybe make one alist lookup here, instead of
596                      ;; two.
597                      ((memq tag-name verbatim-to-eof-elems)
598                       (set! nexttok verbeof-nexttok))
599                      ((memq tag-name verbatim-pair-elems)
600                       (set! nexttok (make-verbpair-nexttok tag-name))))
601                ;; Return a token object.
602                (if start?
603                    (if tag-empty?
604                        (make-empty-token tag-name tag-ns tag-attrs)
605                        (make-start-token tag-name tag-ns tag-attrs))
606                    (make-end-token tag-name tag-ns tag-attrs)))))
607
608           (scan-attr
609            (lambda ()
610              (let ((name (scan-qname #f))
611                    (val  #f))
612                (if (pair? name)
613                    (set! name (cdr name)))
614                (let loop-equals-or-end ()
615                  (read-c)
616                  (cond ((c-eof?) no-token)
617                        ((c-ws?)  (loop-equals-or-end))
618                        ((c-equals?)
619                         (let loop-quote-or-unquoted ()
620                           (read-c)
621                           (cond ((c-eof?) no-token)
622                                 ((c-ws?) (loop-quote-or-unquoted))
623                                 ((or (c-apos?) (c-quot?))
624                                  (let ((term c))
625                                    (set! val (open-output-string))
626                                    (let loop-quoted-val ()
627                                      (read-c)
628                                      (cond ((c-eof?)      #f)
629                                            ((eqv? c term) #f)
630                                            (else (write-char c val)
631                                                  (loop-quoted-val))))))
632                                 ((c-angle?) (unread-c))
633                                 (else
634                                  (set! val (open-output-string))
635                                  (write-char c val)
636                                  (let loop-unquoted-val ()
637                                    (read-c)
638                                    (cond ((c-eof?)  no-token)
639                                          ((c-apos?) #f)
640                                          ((c-quot?) #f)
641                                          ((or (c-ws?) (c-angle?)
642                                               ;;(c-slash?)
643                                               )
644                                           (unread-c))
645                                          ;; Note: We can treat a slash in an
646                                          ;; unquoted attribute value as a
647                                          ;; value constituent because the
648                                          ;; slash is specially-handled only
649                                          ;; for XHTML, and XHTML attribute
650                                          ;; values must always be quoted.  We
651                                          ;; could do lookahead for "/>", but
652                                          ;; that wouldn't let us parse HTML
653                                          ;; "<a href=/>" correctly, so this is
654                                          ;; an easier and more correct way to
655                                          ;; do things.
656                                          (else (write-char c val)
657                                                (loop-unquoted-val))))))))
658                        (else (unread-c))))
659                (if normalized?
660                    (list name (if val
661                                   (%htmlprag:gosc val)
662                                   (symbol->string name)))
663                    (if val
664                        (list name (%htmlprag:gosc val))
665                        (list name))))))
666
667           (scan-comment
668            ;; TODO: Rewrite this to use tail recursion rather than a state
669            ;; variable.
670            (lambda ()
671              (let ((os    (open-output-string))
672                    (state 'start-minus))
673                (let loop ()
674                  (read-c)
675                  (cond ((c-eof?) #f)
676                        ((c-minus?)
677                         (set! state
678                               (case state
679                                 ((start-minus)            'start-minus-minus)
680                                 ((start-minus-minus body) 'end-minus)
681                                 ((end-minus)              'end-minus-minus)
682                                 ((end-minus-minus) (write-char #\- os) state)
683                                 (else (%htmlprag:error
684                                        "make-html-tokenizer"
685                                        "invalid state:"
686                                        state))))
687                         (loop))
688                        ((and (c-gt?) (eq? state 'end-minus-minus)) #f)
689                        (else (case state
690                                ((end-minus)       (write-char #\- os))
691                                ((end-minus-minus) (display "--" os)))
692                              (set! state 'body)
693                              (write-char c os)
694                              (loop))))
695                (make-comment-token (%htmlprag:gosc os)))))
696
697           (scan-possible-cdata
698            (lambda ()
699              ;; Read "<!" and current character is "[", so try to read the
700              ;; rest of the CDATA start delimeter.
701              (if-read-chars
702               '(#\C #\D #\A #\T #\A #\[)
703               (lambda ()
704                 ;; Successfully read CDATA section start delimiter, so read
705                 ;; the section.
706                 (scan-cdata))
707               (lambda (chars count)
708                 ;; Did not read rest of CDATA section start delimiter, so
709                 ;; return a string for what we did read.
710                 (let ((os (open-output-string)))
711                   (display "<![" os)
712                   (write-chars-count chars count os)
713                   (%htmlprag:gosc os))))))
714
715           (scan-cdata
716            (lambda ()
717              (let ((os (open-output-string)))
718                (let loop ()
719                  (if-read-chars
720                   '(#\] #\] #\>)
721                   (lambda () (%htmlprag:gosc os))
722                   (lambda (chars count)
723                     (if (zero? count)
724                         (if (eof-object? c)
725                             (%htmlprag:gosc os)
726                             (begin (write-char c os)
727                                    (read-c)
728                                    (loop)))
729                         (begin (write-char #\] os)
730                                (if (= count 2)
731                                    (push-c #\]))
732                                (loop)))))))))
733
734           (scan-pi
735            (lambda ()
736              (skip-ws)
737              (let ((name (open-output-string))
738                    (val  (open-output-string)))
739                (let scan-name ()
740                  (read-c)
741                  (cond ((c-eof?)   #f)
742                        ((c-ws?)    #f)
743                        ((c-alpha?) (write-char c name) (scan-name))
744                        (else       (unread-c))))
745                ;; TODO: Do we really want to emit #f for PI name?
746                (set! name (gosc/symbol-or-false name))
747                (let scan-val ()
748                  (read-c)
749                  (cond ((c-eof?)  #f)
750                        ;; ((c-amp?) (display (scan-entity) val)
751                        ;;           (scan-val))
752                        ((c-ques?)
753                         (read-c)
754                         (cond ((c-eof?) (write-char #\? val))
755                               ((c-gt?)  #f)
756                               (else     (write-char #\? val)
757                                         (unread-c)
758                                         (scan-val))))
759                        (else (write-char c val) (scan-val))))
760                (list shtml-pi-symbol
761                      name
762                      (%htmlprag:gosc val)))))
763
764           (scan-decl
765            ;; TODO: Find if SXML includes declaration forms, and if so, use
766            ;; whatever format SXML wants.
767            ;;
768            ;; TODO: Rewrite to eliminate state variables.
769            (letrec
770                ((scan-parts
771                  (lambda ()
772                    (let ((part       (open-output-string))
773                          (nonsymbol? #f)
774                          (state      'before)
775                          (last?      #f))
776                      (let loop ()
777                        (read-c)
778                        (cond ((c-eof?) #f)
779                              ((c-ws?)
780                               (case state
781                                 ((before) (loop))
782                                 ((quoted) (write-char c part) (loop))))
783                              ((and (c-gt?) (not (eq? state 'quoted)))
784                               (set! last? #t))
785                              ((and (c-lt?) (not (eq? state 'quoted)))
786                               (unread-c))
787                              ((c-quot?)
788                               (case state
789                                 ((before)   (set! state 'quoted) (loop))
790                                 ((unquoted) (unread-c))
791                                 ((quoted)   #f)))
792                              (else
793                               (if (eq? state 'before)
794                                   (set! state 'unquoted))
795                               (set! nonsymbol? (or nonsymbol?
796                                                    (not (c-alphanum?))))
797                               (write-char c part)
798                               (loop))))
799                      (set! part (%htmlprag:gosc part))
800                      (if (string=? part "")
801                          '()
802                          (cons (if (or (eq? state 'quoted) nonsymbol?)
803                                    part
804                                    ;; TODO: Normalize case of things we make
805                                    ;; into symbols here.
806                                    (string->symbol part))
807                                (if last?
808                                    '()
809                                    (scan-parts))))))))
810              (lambda () (make-decl-token (scan-parts)))))
811
812           (scan-entity
813            (lambda ()
814              (read-c)
815              (cond ((c-eof?) "&")
816                    ((c-alpha?)
817                     ;; TODO: Do entity names have a maximum length?
818                     (let ((name (open-output-string)))
819                       (write-char c name)
820                       (let loop ()
821                         (read-c)
822                         (cond ((c-eof?)   #f)
823                               ((c-alpha?) (write-char c name) (loop))
824                               ((c-semi?)  #f)
825                               (else       (unread-c))))
826                       (set! name (%htmlprag:gosc name))
827                       ;; TODO: Make the entity map an option.
828                       (let ((pair (assoc name '(("amp"  . "&")
829                                                 ("apos" . "'")
830                                                 ("gt"   . ">")
831                                                 ("lt"   . "<")
832                                                 ("quot" . "\"")))))
833                         (if pair
834                             (cdr pair)
835                             (make-shtml-entity name)))))
836                    ((c-pound?)
837                     (let ((num  (open-output-string))
838                           (hex? #f))
839                       (read-c)
840                       (cond ((c-eof?)            #f)
841                             ((memv c '(#\x #\X)) (set! hex? #t) (read-c)))
842                       (let loop ()
843                         (cond ((c-eof?)  #f)
844                               ((c-semi?) #f)
845                               ((or (c-digit?) (and hex? (c-hexlet?)))
846                                (write-char c num)
847                                (read-c)
848                                (loop))
849                               (else (unread-c))))
850                       (set! num (%htmlprag:gosc num))
851                       (if (string=? num "")
852                           "&#;"
853                           (let ((n (string->number num (if hex? 16 10))))
854                             (if (<= 32 n 126)
855                                 ;; (and (<= 32 n 255) (not (= n 127)))
856                                 (string (%htmlprag:a2c n))
857                                 (make-shtml-entity n))))))
858                    (else (unread-c) "&"))))
859
860           (normal-nexttok
861            (lambda ()
862              (read-c)
863              (cond ((c-eof?) no-token)
864                    ((c-lt?)
865                     (let loop ()
866                       (read-c)
867                       (cond ((c-eof?)   "<")
868                             ((c-ws?)    (loop))
869                             ((c-slash?) (scan-tag #f))
870                             ((c-ques?)  (scan-pi))
871                             ((c-alpha?) (unread-c) (scan-tag #t))
872                             ((c-bang?)
873                              (read-c)
874                              (if (c-lsquare?)
875                                  (scan-possible-cdata)
876                                  (let loop ()
877                                    (cond ((c-eof?)   no-token)
878                                          ((c-ws?)    (read-c) (loop))
879                                          ((c-minus?) (scan-comment))
880                                          (else       (unread-c)
881                                                      (scan-decl))))))
882                             (else (unread-c) "<"))))
883                    ((c-gt?) ">")
884                    (else (let ((os (open-output-string)))
885                            (let loop ()
886                              (cond ((c-eof?)   #f)
887                                    ((c-angle?) (unread-c))
888                                    ((c-amp?)
889                                     (let ((entity (scan-entity)))
890                                       (if (string? entity)
891                                           (begin (display entity os)
892                                                  (read-c)
893                                                  (loop))
894                                           (let ((saved-nexttok nexttok))
895                                             (set! nexttok
896                                                   (lambda ()
897                                                     (set! nexttok
898                                                           saved-nexttok)
899                                                     entity))))))
900                                    (else (write-char c os)
901                                          (or (c-lf?)
902                                              (begin (read-c) (loop))))))
903                            (let ((text (%htmlprag:gosc os)))
904                              (if (equal? text "")
905                                  (nexttok)
906                                  text)))))))
907
908           (verbeof-nexttok
909            (lambda ()
910              (read-c)
911              (if (c-eof?)
912                  no-token
913                  (let ((os (open-output-string)))
914                    (let loop ()
915                      (or (c-eof?)
916                          (begin (write-char c os)
917                                 (or (c-lf?)
918                                     (begin (read-c) (loop))))))
919                    (%htmlprag:gosc os)))))
920
921           (make-verbpair-nexttok
922            (lambda (elem-name)
923              (lambda ()
924                (let ((os (open-output-string)))
925                  ;; Accumulate up to a newline-terminated line.
926                  (let loop ()
927                    (read-c)
928                    (cond ((c-eof?)
929                           ;; Got EOF in verbatim context, so set the normal
930                           ;; nextok procedure, then fall out of loop.
931                           (set! nexttok normal-nexttok))
932                          ((c-lt?)
933                           ;; Got "<" in verbatim context, so get next
934                           ;; character.
935                           (read-c)
936                           (cond ((c-eof?)
937                                  ;; Got "<" then EOF, so set to the normal
938                                  ;; nexttok procedure, add the "<" to the
939                                  ;; verbatim string, and fall out of loop.
940                                  (set! nexttok normal-nexttok)
941                                  (write-char #\< os))
942                                 ((c-slash?)
943                                  ;; Got "</", so...
944                                  (read-c)
945                                  (cond
946                                   ((c-eof?)
947                                    (display "</" os))
948                                   ((c-alpha?)
949                                    ;; Got "</" followed by alpha, so unread
950                                    ;; the alpha, scan qname, compare...
951                                    (unread-c)
952                                    (let* ((vqname (scan-qname #t))
953                                           (ns     (car vqname))
954                                           (local  (cdr vqname)))
955                                      ;; Note: We ignore XML namespace
956                                      ;; qualifier for purposes of comparison.
957                                      ;;
958                                      ;; Note: We're interning strings here for
959                                      ;; comparison when in theory there could
960                                      ;; be many such unique interned strings
961                                      ;; in a valid HTML document, although in
962                                      ;; practice this should not be a problem.
963                                      (if (and local
964                                               (eqv? (string->symbol
965                                                      (%htmlprag:down
966                                                       local))
967                                                     elem-name))
968                                          ;; This is the terminator tag, so
969                                          ;; scan to the end of it, set the
970                                          ;; nexttok, and fall out of the loop.
971                                          (begin
972                                            (let scan-to-end ()
973                                              (read-c)
974                                              (cond ((c-eof?) #f)
975                                                    ((c-gt?)  #f)
976                                                    ((c-lt?)  (unread-c))
977                                                    ((c-alpha?)
978                                                     (unread-c)
979                                                     ;; Note: This is an
980                                                     ;; expensive way to skip
981                                                     ;; over an attribute, but
982                                                     ;; in practice more
983                                                     ;; verbatim end tags will
984                                                     ;; not have attributes.
985                                                     (scan-attr)
986                                                     (scan-to-end))
987                                                    (else (scan-to-end))))
988                                            (set! nexttok
989                                                  (lambda ()
990                                                    (set! nexttok
991                                                          normal-nexttok)
992                                                    (make-end-token
993                                                     elem-name #f '()))))
994                                          ;; This isn't the terminator tag, so
995                                          ;; add to the verbatim string the
996                                          ;; "</" and the characters of what we
997                                          ;; were scanning as a qname, and
998                                          ;; recurse in the loop.
999                                          (begin
1000                                            (display "</" os)
1001                                            (if ns
1002                                                (begin (display ns os)
1003                                                       (display ":" os)))
1004                                            (if local
1005                                                (display local os))
1006                                            (loop)))))
1007                                   (else
1008                                    ;; Got "</" and non-alpha, so unread new
1009                                    ;; character, add the "</" to verbatim
1010                                    ;; string, then loop.
1011                                    (unread-c)
1012                                    (display "</" os)
1013                                    (loop))))
1014                                 (else
1015                                  ;; Got "<" and non-slash, so unread the new
1016                                  ;; character, write the "<" to the verbatim
1017                                  ;; string, then loop.
1018                                  (unread-c)
1019                                  (write-char #\< os)
1020                                  (loop))))
1021                          (else
1022                           ;; Got non-"<" in verbatim context, so just add it
1023                           ;; to the buffer, then, if it's not a linefeed, fall
1024                           ;; out of the loop so that the token can be
1025                           ;; returned.
1026                           (write-char c os)
1027                           (or (c-lf?) (loop)))))
1028                  ;; Return the accumulated line string, if non-null, or call
1029                  ;; nexttok.
1030                  (or (gosc/string-or-false os) (nexttok))))))
1031
1032           (nexttok #f))
1033
1034        (set! nexttok normal-nexttok)
1035        (lambda () (nexttok))))))
1036
1037;;; @defproc tokenize-html in normalized?
1038;;;
1039;;; Returns a list of tokens from input port @var{in}, normalizing according to
1040;;; boolean @var{normalized?}.  This is probably most useful as a debugging
1041;;; convenience.  For example:
1042;;;
1043;;; @lisp
1044;;; (tokenize-html (open-input-string "<a href=\"foo\">bar</a>") #f)
1045;;; @result{} ((a (@@ (href "foo"))) "bar" (*END* a))
1046;;; @end lisp
1047
1048(define (tokenize-html in normalized?)
1049  (let ((next-tok (make-html-tokenizer in normalized?)))
1050    (let loop ((tok (next-tok)))
1051      (if (null? tok)
1052          '()
1053          (cons tok (loop (next-tok)))))))
1054
1055;;; @defproc shtml-token-kind token
1056;;;
1057;;; Returns a symbol indicating the kind of tokenizer @var{token}:
1058;;; @code{*COMMENT*}, @code{*DECL*}, @code{*EMPTY*}, @code{*END*},
1059;;; @code{*ENTITY*}, @code{*PI*}, @code{*START*}, @code{*TEXT*}.
1060;;; This is used by higher-level parsing code.  For example:
1061;;;
1062;;; @lisp
1063;;; (map shtml-token-kind
1064;;;      (tokenize-html (open-input-string "<a<b>><c</</c") #f))
1065;;; @result{} (*START* *START* *TEXT* *START* *END* *END*)
1066;;; @end lisp
1067
1068(define (shtml-token-kind token)
1069  (cond ((string? token) shtml-text-symbol)
1070        ((list?   token)
1071         (let ((s (list-ref token 0)))
1072           (if (memq s `(,shtml-comment-symbol
1073                         ,shtml-decl-symbol
1074                         ,shtml-empty-symbol
1075                         ,shtml-end-symbol
1076                         ,shtml-entity-symbol
1077                         ,shtml-pi-symbol))
1078               s
1079               shtml-start-symbol)))
1080        (else (%htmlprag:error "shtml-token-kind"
1081                               "unrecognized token kind:"
1082                               token))))
1083
1084;;; @section Parsing
1085
1086;;; Most applications will call a parser procedure such as
1087;;; @code{html->shtml} rather than calling the tokenizer directly.
1088
1089;; @defvar %htmlprag:empty-elements
1090;;
1091;; List of names of HTML element types that have no content, represented as a
1092;; list of symbols.  This is used internally by the parser and encoder.  The
1093;; effect of mutating this list is undefined.
1094
1095;; TODO: Document exactly which elements these are, after we make the new
1096;; parameterized parser constructor.
1097
1098(define %htmlprag:empty-elements
1099  '(& area base br frame hr img input isindex keygen link meta param
1100      spacer wbr))
1101
1102;;; @defproc parse-html/tokenizer tokenizer normalized?
1103;;;
1104;;; Emits a parse tree like @code{html->shtml} and related procedures, except
1105;;; using @var{tokenizer} as a source of tokens, rather than tokenizing from an
1106;;; input port.  This procedure is used internally, and generally should not be
1107;;; called directly.
1108
1109(define parse-html/tokenizer
1110  ;; TODO: Document the algorithm, then see if rewriting as idiomatic Scheme
1111  ;; can make it more clear.
1112  (letrec ((empty-elements
1113            ;; TODO: Maybe make this an option.  This might also be an
1114            ;; acceptable way to parse old HTML that uses the `p' element as a
1115            ;; paragraph terminator.
1116            %htmlprag:empty-elements)
1117           (parent-constraints
1118            ;; TODO: Maybe make this an option.
1119            '((area     . (map))
1120              (body     . (html))
1121              (caption  . (table))
1122              (colgroup . (table))
1123              (dd       . (dl))
1124              (dt       . (dl))
1125              (frame    . (frameset))
1126              (head     . (html))
1127              (isindex  . (head))
1128              (li       . (dir menu ol ul))
1129              (meta     . (head))
1130              (noframes . (frameset))
1131              (option   . (select))
1132              (p        . (body td th))
1133              (param    . (applet))
1134              (tbody    . (table))
1135              (td       . (tr))
1136              (th       . (tr))
1137              (thead    . (table))
1138              (title    . (head))
1139              (tr       . (table tbody thead))))
1140           (start-tag-name (lambda (tag-token) (car tag-token)))
1141           (end-tag-name   (lambda (tag-token) (list-ref tag-token 1))))
1142    (lambda (tokenizer normalized?)
1143      ;; Example `begs' value:
1144      ;;
1145      ;; ( ((head ...) . ( (title ...)                         ))
1146      ;;   ((html ...) . ( (head  ...) (*COMMENT* ...)         ))
1147      ;;   (#f         . ( (html  ...) (*DECL*    doctype ...) )) )
1148      (let ((begs (list (cons #f '()))))
1149        (letrec ((add-to-current-beg
1150                  (lambda (tok)
1151                    (set-cdr! (car begs) (cons tok (cdr (car begs))))))
1152                 (finish-all-begs
1153                  (lambda ()
1154                    (let ((toplist #f))
1155                      (map (lambda (beg) (set! toplist (finish-beg beg)))
1156                           begs)
1157                      toplist)))
1158                 (finish-beg
1159                  (lambda (beg)
1160                    (let ((start-tok (car beg)))
1161                      (if start-tok
1162                          (%htmlprag:append!
1163                           (car beg)
1164                           (%htmlprag:reverse!ok (cdr beg)))
1165                          (%htmlprag:reverse!ok (cdr beg))))))
1166                 (finish-begs-to
1167                  (lambda (name lst)
1168                    (let* ((top      (car lst))
1169                           (starttag (car top)))
1170                      (cond ((not starttag) #f)
1171                            ((eqv? name (start-tag-name starttag))
1172                             (set! begs (cdr lst))
1173                             (finish-beg top)
1174                             #t)
1175                            (else (if (finish-begs-to name (cdr lst))
1176                                      (begin (finish-beg top) #t)
1177                                      #f))))))
1178                 (finish-begs-upto
1179                  (lambda (parents lst)
1180                    (let* ((top      (car lst))
1181                           (starttag (car top)))
1182                      (cond ((not starttag) #f)
1183                            ((memq (start-tag-name starttag) parents)
1184                             (set! begs lst)
1185                             #t)
1186                            (else (if (finish-begs-upto parents (cdr lst))
1187                                      (begin (finish-beg top) #t)
1188                                      #f)))))))
1189          (let loop ()
1190            (let ((tok (tokenizer)))
1191              (if (null? tok)
1192                  (finish-all-begs)
1193                  (let ((kind (shtml-token-kind tok)))
1194                    (cond ((memv kind `(,shtml-comment-symbol
1195                                        ,shtml-decl-symbol
1196                                        ,shtml-entity-symbol
1197                                        ,shtml-pi-symbol
1198                                        ,shtml-text-symbol))
1199                           (add-to-current-beg tok))
1200                          ((eqv? kind shtml-start-symbol)
1201                           (let* ((name (start-tag-name tok))
1202                                  (cell (assq name parent-constraints)))
1203                             (and cell (finish-begs-upto (cons 'div (cdr cell))
1204                                                         begs))
1205                             (add-to-current-beg tok)
1206                             (or (memq name empty-elements)
1207                                 (set! begs (cons (cons tok '()) begs)))))
1208                          ((eqv? kind shtml-empty-symbol)
1209                           ;; Empty tag token, so just add it to current
1210                           ;; beginning while stripping off leading `*EMPTY*'
1211                           ;; symbol so that the token becomes normal SXML
1212                           ;; element syntax.
1213                           (add-to-current-beg (cdr tok)))
1214                          ((eqv? kind shtml-end-symbol)
1215                           (let ((name (end-tag-name tok)))
1216                             (if name
1217                                 ;; Try to finish to a start tag matching this
1218                                 ;; end tag.  If none, just drop the token,
1219                                 ;; though we used to add it to the current
1220                                 ;; beginning.
1221                                 (finish-begs-to name begs)
1222                                 ;; We have an anonymous end tag, so match it
1223                                 ;; with the most recent beginning.  If no
1224                                 ;; beginning to match, then just drop the
1225                                 ;; token, though we used to add it to the
1226                                 ;; current beginning.
1227                                 (and (car (car begs))
1228                                      (begin (finish-beg (car begs))
1229                                             (set! begs (cdr begs)))))))
1230                          (else (%htmlprag:error "parse-html/tokenizer"
1231                                                 "unknown tag kind:"
1232                                                 kind)))
1233                    (loop))))))))))
1234
1235;; @defproc %htmlprag:parse-html input normalized? top?
1236;;
1237;; This procedure is now used internally by @code{html->shtml} and its
1238;; variants, and should not be used directly by programs.  The interface is
1239;; likely to change in future versions of HtmlPrag.
1240
1241(define (%htmlprag:parse-html input normalized? top?)
1242  (let ((parse
1243         (lambda ()
1244           (parse-html/tokenizer
1245            (make-html-tokenizer
1246             (cond ((input-port? input) input)
1247                   ((string?     input) (open-input-string input))
1248                   (else (%htmlprag:error
1249                          "%htmlprag:parse-html"
1250                          "invalid input type:"
1251                          input)))
1252             normalized?)
1253            normalized?))))
1254    (if top?
1255        (cons shtml-top-symbol (parse))
1256        (parse))))
1257
1258;;; @defproc  html->sxml-0nf input
1259;;; @defprocx html->sxml-1nf input
1260;;; @defprocx html->sxml-2nf input
1261;;; @defprocx html->sxml     input
1262;;; @defprocx html->shtml    input
1263;;;
1264;;; Permissively parse HTML from @var{input}, which is either an input port or
1265;;; a string, and emit an SHTML equivalent or approximation.  To borrow and
1266;;; slightly modify an example from Kiselyov's discussion of his HTML parser:
1267;;;
1268;;; @lisp
1269;;; (html->shtml
1270;;;  "<html><head><title></title><title>whatever</title></head><body>
1271;;; <a href=\"url\">link</a><p align=center><ul compact style=\"aa\">
1272;;; <p>BLah<!-- comment <comment> --> <i> italic <b> bold <tt> ened</i>
1273;;; still &lt; bold </b></body><P> But not done yet...")
1274;;; @result{}
1275;;; (*TOP* (html (head (title) (title "whatever"))
1276;;;              (body "\n"
1277;;;                    (a (@@ (href "url")) "link")
1278;;;                    (p (@@ (align "center"))
1279;;;                       (ul (@@ (compact) (style "aa")) "\n"))
1280;;;                    (p "BLah"
1281;;;                       (*COMMENT* " comment <comment> ")
1282;;;                       " "
1283;;;                       (i " italic " (b " bold " (tt " ened")))
1284;;;                       "\n"
1285;;;                       "still < bold "))
1286;;;              (p " But not done yet...")))
1287;;; @end lisp
1288;;;
1289;;; Note that in the emitted SHTML the text token @code{"still < bold"} is
1290;;; @emph{not} inside the @code{b} element, which represents an unfortunate
1291;;; failure to emulate all the quirks-handling behavior of some popular Web
1292;;; browsers.
1293;;;
1294;;; The procedures @code{html->sxml-@var{n}nf} for @var{n} 0 through 2
1295;;; correspond to 0th through 2nd normal forms of SXML as specified in SXML,
1296;;; and indicate the minimal requirements of the emitted SXML.
1297;;;
1298;;; @code{html->sxml} and @code{html->shtml} are currently aliases for
1299;;; @code{html->sxml-0nf}, and can be used in scripts and interactively, when
1300;;; terseness is important and any normal form of SXML would suffice.
1301
1302(define (html->sxml-0nf input) (%htmlprag:parse-html input #f #t))
1303(define (html->sxml-1nf input) (%htmlprag:parse-html input #f #t))
1304(define (html->sxml-2nf input) (%htmlprag:parse-html input #t #t))
1305
1306(define html->sxml  html->sxml-0nf)
1307(define html->shtml html->sxml-0nf)
1308
1309;;; @section Emitting HTML
1310
1311;;; Two procedures encoding the SHTML representation as conventional HTML,
1312;;; @code{write-shtml-as-html} and @code{shtml->html}.  These are perhaps most
1313;;; useful for emitting the result of parsed and transformed input HTML.  They
1314;;; can also be used for emitting HTML from generated or handwritten SHTML.
1315
1316;;; @defproc write-shtml-as-html shtml [out [foreign-filter]]
1317;;;
1318;;; Writes a conventional HTML transliteration of the SHTML @var{shtml} to
1319;;; output port @var{out}.  If @var{out} is not specified, the default is the
1320;;; current output port.  HTML elements of types that are always empty are
1321;;; written using HTML4-compatible XHTML tag syntax.
1322;;;
1323;;; If @var{foreign-filter} is specified, it is a procedure of two argument
1324;;; that is applied to any non-SHTML (``foreign'') object encountered in
1325;;; @var{shtml}, and should yield SHTML.  The first argument is the object, and
1326;;; the second argument is a boolean for whether or not the object is part of
1327;;; an attribute value.
1328;;;
1329;;; No inter-tag whitespace or line breaks not explicit in @var{shtml} is
1330;;; emitted.  The @var{shtml} should normally include a newline at the end of
1331;;; the document.  For example:
1332;;;
1333;;; @lisp
1334;;; (write-shtml-as-html
1335;;;  '((html (head (title "My Title"))
1336;;;          (body (@@ (bgcolor "white"))
1337;;;                (h1 "My Heading")
1338;;;                (p "This is a paragraph.")
1339;;;                (p "This is another paragraph.")))))
1340;;; @print{} <html><head><title>My Title</title></head><body bgcolor="whi
1341;;; @print{} te"><h1>My Heading</h1><p>This is a paragraph.</p><p>This is
1342;;; @print{}  another paragraph.</p></body></html>
1343;;; @end lisp
1344
1345(define (%htmlprag:write-shtml-as-html/fixed shtml out foreign-filter)
1346  (letrec
1347      ((write-shtml-text
1348        (lambda (str out)
1349          (let ((len (string-length str)))
1350            (let loop ((i 0))
1351              (if (< i len)
1352                  (begin (display (let ((c (string-ref str i)))
1353                                    (case c
1354                                      ;; ((#\") "&quot;")
1355                                      ((#\&) "&amp;")
1356                                      ((#\<) "&lt;")
1357                                      ((#\>) "&gt;")
1358                                      (else c)))
1359                                  out)
1360                         (loop (+ 1 i))))))))
1361       (write-dquote-ampified
1362        (lambda (str out)
1363          ;; TODO: If we emit "&quot;", we really should parse it, and HTML
1364          ;; 4.01 says we should, but anachronisms in HTML create the potential
1365          ;; for nasty mutilation of URI in attribute values.
1366          (let ((len (string-length str)))
1367            (let loop ((i 0))
1368              (if (< i len)
1369                  (begin (display (let ((c (string-ref str i)))
1370                                    (if (eqv? c #\") "&quot;" c))
1371                                  out)
1372                         (loop (+ 1 i))))))))
1373       (do-thing
1374        (lambda (thing)
1375          (cond ((string? thing) (write-shtml-text thing out))
1376                ((list? thing)   (if (not (null? thing))
1377                                     (do-list-thing thing)))
1378                (else (do-thing (foreign-filter thing #f))))))
1379       (do-list-thing
1380        (lambda (thing)
1381          (let ((head (car thing)))
1382            (cond ((symbol? head)
1383                   ;; Head is a symbol, so...
1384                   (cond ((eq? head shtml-comment-symbol)
1385                          ;; TODO: Make sure the comment text doesn't contain a
1386                          ;; comment end sequence.
1387                          (display "<!-- " out)
1388                          (let ((text (car (cdr thing))))
1389                            (if (string? text)
1390                                ;; TODO: Enforce whitespace safety without
1391                                ;; padding unnecessarily.
1392                                ;;
1393                                ;; (let ((len (string-length text)))
1394                                ;; (if (= len 0)
1395                                ;; (display #\space out)
1396                                ;; (begin (if (not (eqv?
1397                                ;; (string-ref text 0)
1398                                ;; #\space))
1399                                (display text out)
1400                                (%htmlprag:error
1401                                 "write-shtml-as-html"
1402                                 "invalid SHTML comment text:"
1403                                 thing)))
1404                          (or (null? (cdr (cdr thing)))
1405                              (%htmlprag:error
1406                               "write-shtml-as-html"
1407                               "invalid SHTML comment body:"
1408                               thing))
1409                          (display " -->" out))
1410                         ((eq? head shtml-decl-symbol)
1411                          (let ((head (car (cdr thing))))
1412                            (display "<!" out)
1413                            (display (symbol->string head) out)
1414                            (for-each
1415                             (lambda (n)
1416                               (cond ((symbol? n)
1417                                      (display #\space out)
1418                                      (display (symbol->string n) out))
1419                                     ((string? n)
1420                                      (display " \"" out)
1421                                      (write-dquote-ampified n out)
1422                                      (display #\" out))
1423                                     (else (%htmlprag:error
1424                                            "write-shtml-as-html"
1425                                            "invalid SHTML decl:"
1426                                            thing))))
1427                             (cdr (cdr thing)))
1428                            (display #\> out)))
1429                         ((eq? head shtml-pi-symbol)
1430                          (display "<?" out)
1431                          (display (symbol->string (car (cdr thing))) out)
1432                          (display #\space out)
1433                          (display (car (cdr (cdr thing))) out)
1434                          ;; TODO: Error-check that no more rest of PI.
1435                          (display "?>" out))
1436                         ((eq? head shtml-top-symbol)
1437                          (for-each do-thing (cdr thing)))
1438                         ((eq? head shtml-empty-symbol)
1439                          #f)
1440                         ((eq? head '@)
1441                          (%htmlprag:error
1442                           "write-shtml-as-html"
1443                           "illegal position of SHTML attributes:"
1444                           thing))
1445                         ((or (eq? head '&) (eq? head shtml-entity-symbol))
1446                          (let ((val (shtml-entity-value thing)))
1447                            (if val
1448                                (begin (write-char     #\& out)
1449                                       (if (integer? val)
1450                                           (write-char #\# out))
1451                                       (display        val out)
1452                                       (write-char     #\; out))
1453                                (%htmlprag:error
1454                                 "write-shtml-as-html"
1455                                 "invalid SHTML entity reference:"
1456                                 thing))))
1457                         ((memq head `(,shtml-end-symbol
1458                                       ,shtml-start-symbol
1459                                       ,shtml-text-symbol))
1460                          (%htmlprag:error "write-shtml-as-html"
1461                                           "invalid SHTML symbol:"
1462                                           head))
1463                         (else
1464                          (display #\< out)
1465                          (display head out)
1466                          (let* ((rest   (cdr thing)))
1467                            (if (not (null? rest))
1468                                (let ((second (car rest)))
1469                                  (and (list? second)
1470                                       (not (null? second))
1471                                       (eq? (car second)
1472                                            '@)
1473                                       (begin (for-each do-attr (cdr second))
1474                                              (set! rest (cdr rest))))))
1475                            (if (memq head
1476                                      %htmlprag:empty-elements)
1477                                ;; TODO: Error-check to make sure the element
1478                                ;; has no content other than attributes.  We
1479                                ;; have to test for cases like: (br (@) ()
1480                                ;; (()))
1481                                (display " />" out)
1482                                (begin (display #\> out)
1483                                       (for-each do-thing rest)
1484                                       (display "</" out)
1485                                       (display (symbol->string head) out)
1486                                       (display #\> out)))))))
1487                  ;; ((or (list? head) (string? head))
1488                  ;;
1489                  ;; Head is a list or string, which might occur as the result
1490                  ;; of an SXML transform, so we'll cope.
1491                  (else
1492                   ;; Head is not a symbol, which might occur as the result of
1493                   ;; an SXML transform, so we'll cope.
1494                   (for-each do-thing thing))
1495                  ;;(else
1496                  ;; ;; Head is NOT a symbol, list, or string, so error.
1497                  ;; (%htmlprag:error "write-shtml-as-html"
1498                  ;;                          "invalid SHTML list:"
1499                  ;;                          thing))
1500                  ))))
1501       (write-attr-val-dquoted
1502        (lambda (str out)
1503          (display #\" out)
1504          (display str out)
1505          (display #\" out)))
1506       (write-attr-val-squoted
1507        (lambda (str out)
1508          (display #\' out)
1509          (display str out)
1510          (display #\' out)))
1511       (write-attr-val-dquoted-and-amped
1512        (lambda (str out)
1513          (display #\" out)
1514          (write-dquote-ampified str out)
1515          (display #\" out)))
1516       (write-attr-val
1517        (lambda (str out)
1518          (let ((len (string-length str)))
1519            (let find-dquote-and-squote ((i 0))
1520              (if (= i len)
1521                  (write-attr-val-dquoted str out)
1522                  (let ((c (string-ref str i)))
1523                    (cond ((eqv? c #\")
1524                           (let find-squote ((i (+ 1 i)))
1525                             (if (= i len)
1526                                 (write-attr-val-squoted str out)
1527                                 (if (eqv? (string-ref str i) #\')
1528                                     (write-attr-val-dquoted-and-amped str
1529                                                                       out)
1530                                     (find-squote (+ 1 i))))))
1531                          ((eqv? c #\')
1532                           (let find-dquote ((i (+ 1 i)))
1533                             (if (= i len)
1534                                 (write-attr-val-dquoted str out)
1535                                 (if (eqv? (string-ref str i) #\")
1536                                     (write-attr-val-dquoted-and-amped str
1537                                                                       out)
1538                                     (find-dquote (+ 1 i))))))
1539                          (else (find-dquote-and-squote (+ 1 i))))))))))
1540
1541       (collect-and-write-attr-val
1542        ;; TODO: Take another look at this.
1543        (lambda (lst out)
1544          (let ((os #f))
1545            (let do-list ((lst lst))
1546              (for-each
1547               (lambda (thing)
1548                 (let do-thing ((thing thing))
1549                   (cond ((string? thing)
1550                          (or os (set! os (open-output-string)))
1551                          (display thing os))
1552                         ((list? thing)
1553                          (do-list thing))
1554                         ((eq? thing #t)
1555                          #f)
1556                         (else
1557                          (do-thing (foreign-filter thing #t))))))
1558               lst))
1559            (if os
1560                (begin
1561                  (display #\= out)
1562                  (write-attr-val (%htmlprag:gosc os) out))))))
1563
1564       (do-attr
1565        (lambda (attr)
1566          (or (list? attr)
1567              (%htmlprag:error "write-shtml-as-html"
1568                               "invalid SHTML attribute:"
1569                               attr))
1570          (if (not (null? attr))
1571              (let ((name (car attr)))
1572                (or (symbol? name)
1573                    (%htmlprag:error
1574                     "write-shtml-as-html"
1575                     "invalid name in SHTML attribute:"
1576                     attr))
1577                (if (not (eq? name '@))
1578                    (begin
1579                      (display #\space out)
1580                      (display name    out)
1581                      (collect-and-write-attr-val (cdr attr) out)
1582
1583                      )))))))
1584    (do-thing shtml)
1585    (if #f #f)))
1586
1587(define write-shtml-as-html
1588  (letrec ((error-foreign-filter
1589            (lambda (foreign-object in-attribute-value?)
1590              (%htmlprag:error
1591               "write-shtml-as-html"
1592               (if in-attribute-value?
1593                   "unhandled foreign object in shtml attribute value:"
1594                   "unhandled foreign object in shtml:")
1595               foreign-object))))
1596    (lambda (shtml . rest)
1597      (case (length rest)
1598        ((0) (%htmlprag:write-shtml-as-html/fixed
1599              shtml
1600              (current-output-port)
1601              error-foreign-filter))
1602        ((1) (%htmlprag:write-shtml-as-html/fixed
1603              shtml
1604              (car rest)
1605              error-foreign-filter))
1606        ((2) (%htmlprag:write-shtml-as-html/fixed
1607              shtml
1608              (car rest)
1609              (cadr rest)))
1610        (else
1611         (%htmlprag:error "write-shtml-as-html"
1612                          "extraneous arguments:"
1613                          (cddr rest)))))))
1614
1615;;; @defproc shtml->html shtml
1616;;;
1617;;; Yields an HTML encoding of SHTML @var{shtml} as a string.  For example:
1618;;;
1619;;; @lisp
1620;;; (shtml->html
1621;;;  (html->shtml
1622;;;   "<P>This is<br<b<I>bold </foo>italic</ b > text.</p>"))
1623;;; @result{} "<p>This is<br /><b><i>bold italic</i></b> text.</p>"
1624;;; @end lisp
1625;;;
1626;;; Note that, since this procedure constructs a string, it should normally
1627;;; only be used when the HTML is relatively small.  When encoding HTML
1628;;; documents of conventional size and larger, @code{write-shtml-as-html} is
1629;;; much more efficient.
1630
1631(define (shtml->html shtml)
1632  (let ((os (open-output-string)))
1633    (write-shtml-as-html shtml os)
1634    (%htmlprag:gosc os)))
1635
1636
1637;;; @unnumberedsec History
1638
1639;;; @table @asis
1640;;;
1641;;; @item Version 0.16 --- 2005-12-18
1642;;; Documentation fix.
1643;;;
1644;;; @item Version 0.15 --- 2005-12-18
1645;;; In the HTML parent element constraints that are used for structure
1646;;; recovery, @code{div} is now always permitted as a parent, as a stopgap
1647;;; measure until substantial time can be spent reworking the algorithm to
1648;;; better support @code{div} (bug reported by Corey Sweeney and Jepri).  Also
1649;;; no longer convert to Scheme character any HTML numeric character reference
1650;;; with value above 126, to avoid Unicode problem with PLT 299/300 (bug
1651;;; reported by Corey Sweeney).
1652;;;
1653;;; @item Version 0.14 --- 2005-06-16
1654;;; XML CDATA sections are now tokenized.  Thanks to Alejandro Forero Cuervo
1655;;; for suggesting this feature.  The deprecated procedures @code{sxml->html}
1656;;; and @code{write-sxml-html} have been removed.  Minor documentation changes.
1657;;;
1658;;; @item Version 0.13 --- 2005-02-23
1659;;; HtmlPrag now requires @code{syntax-rules}, and a reader that can read
1660;;; @code{@@} as a symbol.  SHTML now has a special @code{&} element for
1661;;; character entities, and it is emitted by the parser rather than the old
1662;;; @code{*ENTITY*} kludge.  @code{shtml-entity-value} supports both the new
1663;;; and the old character entity representations.  @code{shtml-entity-value}
1664;;; now yields @code{#f} on invalid SHTML entity, rather than raising an error.
1665;;; @code{write-shtml-as-html} now has a third argument, @code{foreign-filter}.
1666;;; @code{write-shtml-as-html} now emits SHTML @code{&} entity references.
1667;;; Changed @code{shtml-named-char-id} and @code{shtml-numeric-char-id}, as
1668;;; previously warned.  Testeez is now used for the test suite.  Test procedure
1669;;; is now the internal @code{%htmlprag:test}.  Documentation changes.
1670;;; Notably, much documentation about using HtmlPrag under various particular
1671;;; Scheme implementations has been removed.
1672;;;
1673;;; @item Version 0.12 --- 2004-07-12
1674;;; Forward-slash in an unquoted attribute value is now considered a value
1675;;; constituent rather than an unconsumed terminator of the value (thanks to
1676;;; Maurice Davis for reporting and a suggested fix).  @code{xml:} is now
1677;;; preserved as a namespace qualifier (thanks to Peter Barabas for
1678;;; reporting).  Output port term of @code{write-shtml-as-html} is now
1679;;; optional.  Began documenting loading for particular implementation-specific
1680;;; packagings.
1681;;;
1682;;; @item Version 0.11 --- 2004-05-13
1683;;; To reduce likely namespace collisions with SXML tools, and in anticipation
1684;;; of a forthcoming set of new features, introduced the concept of ``SHTML,''
1685;;; which will be elaborated upon in a future version of HtmlPrag.  Renamed
1686;;; @code{sxml-@var{x}-symbol} to @code{shtml-@var{x}-symbol},
1687;;; @code{sxml-html-@var{x}} to @code{shtml-@var{x}}, and
1688;;; @code{sxml-token-kind} to @code{shtml-token-kind}.  @code{html->shtml},
1689;;; @code{shtml->html}, and @code{write-shtml-as-html} have been added as
1690;;; names.  Considered deprecated but still defined (see the ``Deprecated''
1691;;; section of this documentation) are @code{sxml->html} and
1692;;; @code{write-sxml-html}.  The growing pains should now be all but over.
1693;;; Internally, @code{htmlprag-internal:error} introduced for Bigloo
1694;;; portability.  SISC returned to the test list; thanks to Scott G.  Miller
1695;;; for his help.  Fixed a new character @code{eq?}  bug, thanks to SISC.
1696;;;
1697;;; @item Version 0.10 --- 2004-05-11
1698;;; All public identifiers have been renamed to drop the ``@code{htmlprag:}''
1699;;; prefix.  The portability identifiers have been renamed to begin with an
1700;;; @code{htmlprag-internal:} prefix, are now considered strictly
1701;;; internal-use-only, and have otherwise been changed.  @code{parse-html} and
1702;;; @code{always-empty-html-elements} are no longer public.
1703;;; @code{test-htmlprag} now tests @code{html->sxml} rather than
1704;;; @code{parse-html}.  SISC temporarily removed from the test list, until an
1705;;; open source Java that works correctly is found.
1706;;;
1707;;; @item Version 0.9 --- 2004-05-07
1708;;; HTML encoding procedures added.  Added
1709;;; @code{htmlprag:sxml-html-entity-value}.  Upper-case @code{X} in hexadecimal
1710;;; character entities is now parsed, in addition to lower-case @code{x}.
1711;;; Added @code{htmlprag:always-empty-html-elements}.  Added additional
1712;;; portability bindings.  Added more test cases.
1713;;;
1714;;; @item Version 0.8 --- 2004-04-27
1715;;; Entity references (symbolic, decimal numeric, hexadecimal numeric) are now
1716;;; parsed into @code{*ENTITY*} SXML.  SXML symbols like @code{*TOP*} are now
1717;;; always upper-case, regardless of the Scheme implementation.  Identifiers
1718;;; such as @code{htmlprag:sxml-top-symbol} are bound to the upper-case
1719;;; symbols.  Procedures @code{htmlprag:html->sxml-0nf},
1720;;; @code{htmlprag:html->sxml-1nf}, and @code{htmlprag:html->sxml-2nf} have
1721;;; been added.  @code{htmlprag:html->sxml} now an alias for
1722;;; @code{htmlprag:html->sxml-0nf}.  @code{htmlprag:parse} has been refashioned
1723;;; as @code{htmlprag:parse-html} and should no longer be directly.  A number
1724;;; of identifiers have been renamed to be more appropriate when the
1725;;; @code{htmlprag:} prefix is dropped in some implementation-specific
1726;;; packagings of HtmlPrag: @code{htmlprag:make-tokenizer} to
1727;;; @code{htmlprag:make-html-tokenizer}, @code{htmlprag:parse/tokenizer} to
1728;;; @code{htmlprag:parse-html/tokenizer}, @code{htmlprag:html->token-list} to
1729;;; @code{htmlprag:tokenize-html}, @code{htmlprag:token-kind} to
1730;;; @code{htmlprag:sxml-token-kind}, and @code{htmlprag:test} to
1731;;; @code{htmlprag:test-htmlprag}.  Verbatim elements with empty-element tag
1732;;; syntax are handled correctly.  New versions of Bigloo and RScheme tested.
1733;;;
1734;;; @item Version 0.7 --- 2004-03-10
1735;;; Verbatim pair elements like @code{script} and @code{xmp} are now parsed
1736;;; correctly.  Two Scheme implementations have temporarily been dropped from
1737;;; regression testing: Kawa, due to a Java bytecode verifier error likely due
1738;;; to a Java installation problem on the test machine; and SXM 1.1, due to
1739;;; hitting a limit on the number of literals late in the test suite code.
1740;;; Tested newer versions of Bigloo, Chicken, Gauche, Guile, MIT Scheme, PLT
1741;;; MzScheme, RScheme, SISC, and STklos.  RScheme no longer requires the
1742;;; ``@code{(define get-output-string close-output-port)}'' workaround.
1743;;;
1744;;; @item Version 0.6 --- 2003-07-03
1745;;; Fixed uses of @code{eq?} in character comparisons, thanks to Scott G.
1746;;; Miller.  Added @code{htmlprag:html->normalized-sxml} and
1747;;; @code{htmlprag:html->nonnormalized-sxml}.  Started to add
1748;;; @code{close-output-port} to uses of output strings, then reverted due to
1749;;; bug in one of the supported dialects.  Tested newer versions of Bigloo,
1750;;; Gauche, PLT MzScheme, RScheme.
1751;;;
1752;;; @item Version 0.5 --- 2003-02-26
1753;;; Removed uses of @code{call-with-values}.  Re-ordered top-level definitions,
1754;;; for portability.  Now tests under Kawa 1.6.99, RScheme 0.7.3.2, Scheme 48
1755;;; 0.57, SISC 1.7.4, STklos 0.54, and SXM 1.1.
1756;;;
1757;;; @item Version 0.4 --- 2003-02-19
1758;;; Apostrophe-quoted element attribute values are now handled.  A bug that
1759;;; incorrectly assumed left-to-right term evaluation order has been fixed
1760;;; (thanks to MIT Scheme for confronting us with this).  Now also tests OK
1761;;; under Gauche 0.6.6 and MIT Scheme 7.7.1.  Portability improvement for
1762;;; implementations (e.g., RScheme 0.7.3.2.b6, Stalin 0.9) that cannot read
1763;;; @code{@@} as a symbol (although those implementations tend to present other
1764;;; portability issues, as yet unresolved).
1765;;;
1766;;; @item Version 0.3 --- 2003-02-05
1767;;; A test suite with 66 cases has been added, and necessary changes have been
1768;;; made for the suite to pass on five popular Scheme implementations.  XML
1769;;; processing instructions are now parsed.  Parent constraints have been added
1770;;; for @code{colgroup}, @code{tbody}, and @code{thead} elements.  Erroneous
1771;;; input, including invalid hexadecimal entity reference syntax and extraneous
1772;;; double quotes in element tags, is now parsed better.
1773;;; @code{htmlprag:token-kind} emits symbols more consistent with SXML.
1774;;;
1775;;; @item Version 0.2 --- 2003-02-02
1776;;; Portability improvements.
1777;;;
1778;;; @item Version 0.1 --- 2003-01-31
1779;;; Dusted off old Guile-specific code from April 2001, converted to emit SXML,
1780;;; mostly ported to R5RS and SRFI-6, added some XHTML support and
1781;;; documentation.  A little preliminary testing has been done, and the package
1782;;; is already useful for some applications, but this release should be
1783;;; considered a preview to invite comments.
1784;;;
1785;;; @end table
1786
1787)
Note: See TracBrowser for help on using the repository browser.