guile-lib-0.2.1/0000775000076400007640000000000011546130323010374 500000000000000guile-lib-0.2.1/AUTHORS0000664000076400007640000000445511137322547011403 00000000000000Project Maintainer: Andreas Rottmann (math primes) SLIB code by Aubrey Jaffer (math minima) golden-section-search by Lars Arvestad (os process) Gary Houston (text lalr-parser) Richard Todd (started with Domonique Boucher's code) (string soundex) Public domain code by jjb@isye.gatech.edu (string transform) Richard Todd (string wrap) Richard Todd (idea from python module) (term ansi-color) Richard Todd (idea from perl module) (unit-test) Found in a net posting. Original code by John Maxwell . Improvements by Richard Todd and Andreas Rottmann . (email mailbox-protocol) Richard Todd (email maildir) Richard Todd (config load) Andreas Rottmann (container nodal-tree) Andy Wingo (container delay-tree) Andy Wingo (debugging time) Andy Wingo (scheme documentation) Andy Wingo (texinfo) Andy Wingo (texinfo html) Andy Wingo (texinfo indexing) Andy Wingo (texinfo nodal-tree) Andy Wingo (texinfo plain-text) Andy Wingo (texinfo reflection) Andy Wingo (texinfo serialization) Andy Wingo (sxml simple) Andy Wingo (htmlprag) http://neilvandyke.org/htmlprag/ (sxml ssax) http://ssax.sourceforge.net/ (sxml xpath) http://ssax.sourceforge.net/ (sxml transform) http://ssax.sourceforge.net/ (sxml apply-templates) http://ssax.sourceforge.net/ (sxml ssax input-parse) Oleg's input-parse.scm, but with some routines sped up by use of (ice-9 rdelim). (debugging assert) Oleg's assert macro that will print out values of variables referenced in the assert expression. (statprof) Code taken from Guile CVS and improved by Andy Wingo . (io string) SLIB code by Aubrey Jaffer. (scheme session) Guile's (ice-9 session), enhanced by Andy Wingo . ;;; arch-tag: 29b8be7d-0f09-4a3e-b8c6-fc1443dff4dd guile-lib-0.2.1/src/0000775000076400007640000000000011546130323011163 500000000000000guile-lib-0.2.1/src/search/0000775000076400007640000000000011546130323012430 500000000000000guile-lib-0.2.1/src/search/basic.scm0000664000076400007640000001123411137623072014142 00000000000000;; (search basic) -- basic search functions ;; Copyright (C) 2003 Richard Todd ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ; This module has the classic search functions in it. ;;; Code: (define-module (search basic) #:export (depth-first-search breadth-first-search binary-search-sorted-vector) #:use-module (ice-9 optargs)) (define (depth-first-search init done? expander) "Performs a depth-first search from initial state @var{init}. It will return the first state it sees for which predicate @var{done?} returns @code{#t}. It will use function @var{expander} to get a list of all states reacheable from a given state. @var{init} can take any form the user wishes. This function treats it as opaque data to pass to @var{done?} and @var{expander}. @var{done?} takes one argument, of the same type as @var{init}, and returns either @code{#t} or @code{#f}. @var{expander} takes one argument, of the same type as @var{init}, and returns a list of states that can be reached from there." (let loop ((working (list init))) (if (done? (car working)) (car working) (loop (append (expander (car working)) (cdr working)))))) (define (breadth-first-search init done? expander) "Performs a breadth-first search from initial state @var{init}. It will return the first state it sees for which predicate @var{done?} returns @code{#t}. It will use function @var{expander} to get a list of all states reacheable from a given state. @var{init} can take any form the user wishes. This function treats it as opaque data to pass to @var{done?} and @var{expander}. @var{done?} takes one argument, of the same type as @var{init}, and returns either @code{#t} or @code{#f}. @var{expander} takes one argument, of the same type as @var{init}, and returns a list of states that can be reached from there." (let loop ((working (list init))) (if (done? (car working)) (car working) (loop (append (cdr working) (expander (car working))))))) (define (alpha-beta-search init evaluator evaluator-favors-current-player? expander depth) " " (let loop ((current init) (evaluator-favors evaluator-favors-current-player?) (d depth)) (if (= d 0) (evaluator c) (apply (if evaluator-favors max min) (map (lambda (c) (loop c (not evaluator-favors) (- d 1))) (expander c)))))) (define* (binary-search-sorted-vector vec target #:optional (cmp -) (default #f)) "Searches a sorted vector @var{vec} for item @var{target}. A binary search is employed which should find an item in O(log n) time if it is present. If @var{target} is found, the index into @var{vec} is returned. As part of the search, the function @var{cmp} is applied to determine whether a vector item is less than, greater than, or equal to the @var{target}. If @var{target} cannot be found in the vector, then @var{default} is returned. @var{cmp} defaults to @code{-}, which gives a correct comparison for vectors of numbers. @var{default} will be @code{#f} if another value is not given. @lisp (binary-search-sorted-vector #(10 20 30) 20) @result{} 1 @end lisp" (let loop ((low-index 0) (high-index (vector-length vec))) ;; if the low index crosses the high index, then we didn't find the entry (if (>= low-index high-index) default (let* ((middle-index (quotient (+ low-index high-index) 2)) (comparison (cmp target (vector-ref vec middle-index)))) (cond ;; target was less than the current... ((< comparison 0) (loop low-index middle-index)) ;; target was greater than the current... ((> comparison 0) (loop (+ middle-index 1) high-index)) ;; we must have found it! (else middle-index)))))) ;;; arch-tag: 1ecf547d-ffdd-4cae-b37f-215a825aa293 guile-lib-0.2.1/src/term/0000775000076400007640000000000011546130323012132 500000000000000guile-lib-0.2.1/src/term/ansi-color.scm0000664000076400007640000001017611137632667014647 00000000000000;; (term ansi-color) -- color output using ANSI escape sequences ;; Copyright (C) 2003 Richard Todd ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . #! ;;; Commentary: @cindex terminals, ANSI color codes for @cindex ANSI color codes @cindex color codes, ANSI The @samp{(term ansi-color)} module generates ANSI escape sequences for colors. Here is an example of the module's use: @lisp ;; method one: safer, since you know the colors ;; will get reset (display (colorize-string "Hello!\n" 'RED 'BOLD 'ON-BLUE)) ;; method two: insert the colors by hand (for-each display (list (color 'RED 'BOLD 'ON-BLUE) "Hello!" (color 'RESET))) @end lisp ;;; Code: !# (define-module (term ansi-color) #:export (color colorize-string) #:use-module (srfi srfi-1) ; for 'remove' #:use-module (srfi srfi-13)) ; for 'string-join' (define ansi-color-tables (let ((table (make-hash-table 23))) (hashq-set! table 'CLEAR "0") (hashq-set! table 'RESET "0") (hashq-set! table 'BOLD "1") (hashq-set! table 'DARK "2") (hashq-set! table 'UNDERLINE "4") (hashq-set! table 'UNDERSCORE "4") (hashq-set! table 'BLINK "5") (hashq-set! table 'REVERSE "6") (hashq-set! table 'CONCEALED "8") (hashq-set! table 'BLACK "30") (hashq-set! table 'RED "31") (hashq-set! table 'GREEN "32") (hashq-set! table 'YELLOW "33") (hashq-set! table 'BLUE "34") (hashq-set! table 'MAGENTA "35") (hashq-set! table 'CYAN "36") (hashq-set! table 'WHITE "37") (hashq-set! table 'ON-BLACK "40") (hashq-set! table 'ON-RED "41") (hashq-set! table 'ON-GREEN "42") (hashq-set! table 'ON-YELLOW "43") (hashq-set! table 'ON-BLUE "44") (hashq-set! table 'ON-MAGENTA "45") (hashq-set! table 'ON-CYAN "46") (hashq-set! table 'ON-WHITE "47") table)) (define (color . lst) "Returns a string containing the ANSI escape sequence for producing the requested set of attributes. The allowed values for the attributes are listed below. Unknown attributes are ignored. @table @asis @item Reset Attributes @samp{CLEAR} and @samp{RESET} are allowed and equivalent. @item Non-Color Attributes @samp{BOLD} makes text bold, and @samp{DARK} reverses this. @samp{UNDERLINE} and @samp{UNDERSCORE} are equivalent. @samp{BLINK} makes the text blink. @samp{REVERSE} invokes reverse video. @samp{CONCEALED} hides output (as for getting passwords, etc.). @item Foregrond Color Attributes @samp{BLACK}, @samp{RED}, @samp{GREEN}, @samp{YELLOW}, @samp{BLUE}, @samp{MAGENTA}, @samp{CYAN}, @samp{WHITE} @item Background Color Attributes @samp{ON-BLACK}, @samp{ON-RED}, @samp{ON-GREEN}, @samp{ON-YELLOW}, @samp{ON-BLUE}, @samp{ON-MAGENTA}, @samp{ON-CYAN}, @samp{ON-WHITE} @end table" (let ((color-list (remove not (map (lambda (color) (hashq-ref ansi-color-tables color)) lst)))) (if (null? color-list) "" (string-append (string #\esc #\[) (string-join color-list ";" 'infix) "m")))) (define (colorize-string str . color-list) "Returns a copy of @var{str} colorized using ANSI escape sequences according to the attributes specified in @var{color-list}. At the end of the returned string, the color attributes will be reset such that subsequent output will not have any colors in effect. The allowed values for the attributes are listed in the documentation for the @code{color} function." (string-append (apply color color-list) str (color 'RESET))) ;;; arch-tag: e8dd6a14-490c-417e-a7fe-983939293db1 guile-lib-0.2.1/src/texinfo/0000775000076400007640000000000011546130323012637 500000000000000guile-lib-0.2.1/src/texinfo/plain-text.scm0000664000076400007640000002274311137622107015362 00000000000000;; (texinfo plain-text) -- rendering stexinfo as plain text ;; Copyright (C) 2003,2004 Andy Wingo ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; ;;Transformation from stexi to plain-text. Strives to re-create the ;;output from @code{info}; comes pretty damn close. ;; ;;; Code: (define-module (texinfo plain-text) #:use-module (texinfo) #:use-module (sxml transform) #:use-module (scheme documentation) #:use-module (string wrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:export (stexi->plain-text)) ;; The return value is a string. (define (arg-ref key %-args) (and=> (and=> (assq key (cdr %-args)) cdr) stexi->plain-text)) (define (arg-req key %-args) (or (arg-ref key %-args) (error "Missing argument:" key %-args))) (define *indent* (make-fluid)) (define *itemizer* (make-fluid)) (define (make-ticker str) (lambda () str)) (define (make-enumerator n) (lambda () (let ((last n)) (set! n (1+ n)) (format #f "~A. " last)))) (fluid-set! *indent* "") ;; Shouldn't be necessary to do this, but just in case. (fluid-set! *itemizer* (make-ticker "* ")) (define-macro (with-indent n . body) `(with-fluids ((*indent* (string-append (fluid-ref *indent*) (make-string ,n #\space)))) ,@body)) (define (make-indenter n proc) (lambda args (with-indent n (apply proc args)))) (define (string-indent str) (string-append (fluid-ref *indent*) str "\n")) (define-macro (with-itemizer itemizer . body) `(with-fluids ((*itemizer* ,itemizer)) ,@body)) (define (wrap* . strings) (let ((indent (fluid-ref *indent*))) (fill-string (string-concatenate strings) #:width 72 #:initial-indent indent #:subsequent-indent indent))) (define (wrap . strings) (string-append (apply wrap* strings) "\n\n")) (define (wrap-heading . strings) (string-append (apply wrap* strings) "\n")) (define (ref tag args) (let* ((node (arg-req 'node args)) (name (or (arg-ref 'name args) node)) (manual (arg-ref 'manual args))) (string-concatenate (cons* (or (and=> (assq tag '((xref "See ") (pxref "see "))) cadr) "") name (if manual `(" in manual " ,manual) '()))))) (define (uref tag args) (let ((url (arg-req 'url args)) (title (arg-ref 'title args))) (if title (string-append title " (" url ")") (string-append "`" url "'")))) (define (def tag args . body) (define (list/spaces . elts) (let lp ((in elts) (out '())) (cond ((null? in) (reverse! out)) ((null? (car in)) (lp (cdr in) out)) (else (lp (cdr in) (cons (car in) (if (null? out) out (cons " " out)))))))) (define (first-line) (string-join (filter identity (map (lambda (x) (arg-ref x args)) '(data-type class name arguments))) " ")) (let* ((category (case tag ((defun) "Function") ((defspec) "Special Form") ((defvar) "Variable") (else (arg-req 'category args))))) (string-append (wrap-heading (string-append " - " category ": " (first-line))) (with-indent 5 (stexi->plain-text body))))) (define (enumerate tag . elts) (define (tonumber start) (let ((c (string-ref start 0))) (cond ((number? c) (string->number start)) (else (1+ (- (char->integer c) (char->integer (if (char-upper? c) #\A #\a)))))))) (let* ((args? (and (pair? elts) (pair? (car elts)) (eq? (caar elts) '%))) (start (and args? (arg-ref 'start (car elts))))) (with-itemizer (make-enumerator (if start (tonumber start) 1)) (with-indent 5 (stexi->plain-text (if start (cdr elts) elts)))))) (define (itemize tag args . elts) (with-itemizer (make-ticker "* ") (with-indent 5 (stexi->plain-text elts)))) (define (item tag . elts) (let* ((ret (stexi->plain-text elts)) (tick ((fluid-ref *itemizer*))) (tick-pos (- (string-length (fluid-ref *indent*)) (string-length tick)))) (if (and (not (string-null? ret)) (not (negative? tick-pos))) (string-copy! ret tick-pos tick)) ret)) (define (table tag args . body) (stexi->plain-text body)) (define (entry tag args . body) (let ((heading (wrap-heading (stexi->plain-text (arg-req 'heading args))))) (string-append heading (with-indent 5 (stexi->plain-text body))))) (define (make-underliner char) (lambda (tag . body) (let ((str (stexi->plain-text body))) (string-append "\n" (string-indent str) (string-indent (make-string (string-length str) char)) "\n")))) (define chapter (make-underliner #\*)) (define section (make-underliner #\=)) (define subsection (make-underliner #\-)) (define subsubsection (make-underliner #\.)) (define (example tag . body) (let ((ret (stexi->plain-text body))) (string-append (string-concatenate (with-indent 5 (map string-indent (string-split ret #\newline)))) "\n"))) (define (verbatim tag . body) (let ((ret (stexi->plain-text body))) (string-append (string-concatenate (map string-indent (string-split ret #\newline))) "\n"))) (define (fragment tag . body) (string-concatenate (map-in-order stexi->plain-text body))) (define (para tag . body) (wrap (stexi->plain-text body))) (define (make-surrounder str) (lambda (tag . body) (string-append str (stexi->plain-text body) str))) (define (code tag . body) (string-append "`" (stexi->plain-text body) "'")) (define (key tag . body) (string-append "<" (stexi->plain-text body) ">")) (define (var tag . body) (string-upcase (stexi->plain-text body))) (define (passthrough tag . body) (stexi->plain-text body)) (define (ignore . args) "") (define (texinfo tag args . body) (let ((title (chapter 'foo (arg-req 'title args)))) (string-append title (stexi->plain-text body)))) (define ignore-list '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip menu ignore syncodeindex comment c % node anchor)) (define (ignored? tag) (memq tag ignore-list)) (define tag-handlers `((title ,chapter) (chapter ,chapter) (section ,section) (subsection ,subsection) (subsubsection ,subsubsection) (appendix ,chapter) (appendixsec ,section) (appendixsubsec ,subsection) (appendixsubsubsec ,subsubsection) (unnumbered ,chapter) (unnumberedsec ,section) (unnumberedsubsec ,subsection) (unnumberedsubsubsec ,subsubsection) (majorheading ,chapter) (chapheading ,chapter) (heading ,section) (subheading ,subsection) (subsubheading ,subsubsection) (strong ,(make-surrounder "*")) (sample ,code) (samp ,code) (code ,code) (kbd ,code) (key ,key) (var ,var) (env ,code) (file ,code) (command ,code) (option ,code) (url ,code) (dfn ,(make-surrounder "\"")) (cite ,(make-surrounder "\"")) (acro ,passthrough) (email ,key) (emph ,(make-surrounder "_")) (sc ,var) (copyright ,(lambda args "(C)")) (result ,(lambda args "==>")) (xref ,ref) (ref ,ref) (pxref ,ref) (uref ,uref) (texinfo ,texinfo) (quotation ,(make-indenter 5 para)) (itemize ,itemize) (enumerate ,enumerate) (item ,item) (table ,table) (entry ,entry) (example ,example) (lisp ,example) (smallexample ,example) (smalllisp ,example) (verbatim ,verbatim) (*fragment* ,fragment) (deftp ,def) (defcv ,def) (defivar ,def) (deftypeivar ,def) (defop ,def) (deftypeop ,def) (defmethod ,def) (deftypemethod ,def) (defopt ,def) (defvr ,def) (defvar ,def) (deftypevr ,def) (deftypevar ,def) (deffn ,def) (deftypefn ,def) (defmac ,def) (defspec ,def) (defun ,def) (deftypefun ,def))) (define-with-docs stexi->plain-text "Transform @var{tree} into plain text. Returns a string." (lambda (tree) (cond ((null? tree) "") ((string? tree) tree) ((pair? tree) (cond ((symbol? (car tree)) (let ((handler (and (not (ignored? (car tree))) (or (and=> (assq (car tree) tag-handlers) cadr) para)))) (if handler (apply handler tree) ""))) (else (string-concatenate (map-in-order stexi->plain-text tree))))) (else "")))) ;;; arch-tag: f966c3f6-3b46-4790-bbf9-3ad27e4917c2 guile-lib-0.2.1/src/texinfo/docbook.scm0000664000076400007640000001776111137621660014724 00000000000000;; (texinfo docbook) -- translating sdocbook into stexinfo ;; Copyright (C) 2007 Andy Wingo ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; ;; @c ;; This module exports procedures for transforming a limited subset of ;; the SXML representation of docbook into stexi. It is not complete by ;; any means. The intention is to gather a number of routines and ;; stylesheets so that external modules can parse specific subsets of ;; docbook, for example that set generated by certain tools. ;; ;;; Code: (define-module (texinfo docbook) :use-module (sxml fold) :use-module (scheme documentation) :export (*sdocbook->stexi-rules* *sdocbook-block-commands* sdocbook-flatten filter-empty-elements replace-titles)) (define (identity . args) args) (define (identity-deattr tag . body) `(,tag ,@(if (and (pair? body) (pair? (car body)) (eq? (caar body) '@)) (cdr body) body))) (define (detag-one tag body) body) (define tag-replacements '((parameter var) (replaceable var) (type code) (function code) (literal samp) (emphasis emph) (simpara para) (programlisting example) (firstterm dfn) (filename file) (quote cite) (application cite) (symbol code) (note cartouche) (envar env))) (define ignore-list '()) (define (stringify exp) (with-output-to-string (lambda () (write exp)))) (define-with-docs *sdocbook->stexi-rules* "A stylesheet for use with SSAX's @code{pre-post-order}, which defines a number of generic rules for transforming docbook into texinfo." `((@ *preorder* . ,identity) (% *preorder* . ,identity) (para . ,identity-deattr) (orderedlist ((listitem . ,(lambda (tag . body) `(item ,@body)))) . ,(lambda (tag . body) `(enumerate ,@body))) (itemizedlist ((listitem . ,(lambda (tag . body) `(item ,@body)))) . ,(lambda (tag . body) `(itemize ,@body))) (term . ,detag-one) (informalexample . ,detag-one) (section . ,identity) (subsection . ,identity) (subsubsection . ,identity) (ulink . ,(lambda (tag attrs . body) `(uref (% ,(assq 'url (cdr attrs)) (title ,@body))))) (*text* . ,detag-one) (*default* . ,(lambda (tag . body) (let ((subst (assq tag tag-replacements))) (cond (subst (if (and (pair? body) (pair? (car body)) (eq? (caar body) '@)) (begin (warn "Ignoring" tag "attributes" (car body)) (append (cdr subst) (cdr body))) (append (cdr subst) body))) ((memq tag ignore-list) #f) (else (warn "Don't know how to convert" tag "to stexi") `(c (% (all ,(stringify (cons tag body)))))))))))) ;; (variablelist ;; ((varlistentry ;; . ,(lambda (tag term . body) ;; `(entry (% (heading ,@(cdr term))) ,@body))) ;; (listitem ;; . ,(lambda (tag simpara) ;; simpara))) ;; . ,(lambda (tag attrs . body) ;; `(table (% (formatter (var))) ,@body))) (define-with-docs *sdocbook-block-commands* "The set of sdocbook element tags that should not be nested inside each other. @xref{texinfo docbook sdocbook-flatten,,sdocbook-flatten}, for more information." '(para programlisting informalexample indexterm variablelist orderedlist refsect1 refsect2 refsect3 refsect4 title example note itemizedlist)) (define (inline-command? command) (not (memq command *sdocbook-block-commands*))) (define (sdocbook-flatten sdocbook) "\"Flatten\" a fragment of sdocbook so that block elements do not nest inside each other. Docbook is a nested format, where e.g. a @code{refsect2} normally appears inside a @code{refsect1}. Logical divisions in the document are represented via the tree topology; a @code{refsect2} element @emph{contains} all of the elements in its section. On the contrary, texinfo is a flat format, in which sections are marked off by standalone section headers like @code{@@chapter}, and block elements do not nest inside each other. This function takes a nested sdocbook fragment @var{sdocbook} and flattens all of the sections, such that e.g. @example (refsect1 (refsect2 (para \"Hello\"))) @end example becomes @example ((refsect1) (refsect2) (para \"Hello\")) @end example Oftentimes (always?) sectioning elements have @code{} as their first element child; users interested in processing the @code{refsect*} elements into proper sectioning elements like @code{chapter} might be interested in @code{replace-titles} and @code{filter-empty-elements}. @xref{texinfo docbook replace-titles,,replace-titles}, and @ref{texinfo docbook filter-empty-elements,,filter-empty-elements}. Returns a nodeset, as described in @ref{sxml xpath}. That is to say, this function returns an untagged list of stexi elements." (define (fhere str accum block cont) (values (cons str accum) block cont)) (define (fdown node accum block cont) (let ((command (car node)) (attrs (and (pair? (cdr node)) (pair? (cadr node)) (eq? (caadr node) '%) (cadr node)))) (values (if attrs (cddr node) (cdr node)) '() '() (lambda (accum block) (values `(,command ,@(if attrs (list attrs) '()) ,@(reverse accum)) block))))) (define (fup node paccum pblock pcont kaccum kblock kcont) (call-with-values (lambda () (kcont kaccum kblock)) (lambda (ret block) (if (inline-command? (car ret)) (values (cons ret paccum) (append kblock pblock) pcont) (values paccum (append kblock (cons ret pblock)) pcont))))) (call-with-values (lambda () (foldts*-values fdown fup fhere sdocbook '() '() #f)) (lambda (accum block cont) (reverse block)))) (define (filter-empty-elements sdocbook) "Filters out empty elements in an sdocbook nodeset. Mostly useful after running @code{sdocbook-flatten}." (reverse (fold (lambda (x rest) (if (and (pair? x) (null? (cdr x))) rest (cons x rest))) '() sdocbook))) (define (replace-titles sdocbook-fragment) "Iterate over the sdocbook nodeset @var{sdocbook-fragment}, transforming contiguous @code{refsect} and @code{title} elements into the appropriate texinfo sectioning command. Most useful after having run @code{sdocbook-flatten}. For example: @example (replace-titles '((refsect1) (title \"Foo\") (para \"Bar.\"))) @result{} '((chapter \"Foo\") (para \"Bar.\")) @end example " (define sections '((refsect1 . chapter) (refsect2 . section) (refsect3 . subsection) (refsect4 . subsubsection))) (let lp ((in sdocbook-fragment) (out '())) (cond ((null? in) (reverse out)) ((and (pair? (car in)) (assq (caar in) sections)) ;; pull out the title => (lambda (pair) (lp (cddr in) (cons `(,(cdr pair) ,@(cdadr in)) out)))) (else (lp (cdr in) (cons (car in) out)))))) ���������������guile-lib-0.2.1/src/texinfo/indexing.scm������������������������������������������������������������0000664�0000764�0000764�00000005606�11137623344�015105� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (texinfo indexing) -- indexing stexinfo ;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;@c texinfo formatting ;;Given a piece of stexi, return an index of a specified variety. ;; ;;Note that currently, @code{stexi-extract-index} doesn't differentiate ;;between different kinds of index entries. That's a bug ;) ;;; Code: (define-module (texinfo indexing) #:use-module (sxml simple) #:use-module (scheme documentation) #:use-module (srfi srfi-13) #:export (stexi-extract-index)) (define (def-name def) (cadr (assq 'name (cdadr def)))) (define defines '(deftp defcv defivar deftypeivar defop deftypeop defmethod deftypemethod defopt defvr defvar deftypevr deftypevar deffn deftypefn defspec defmac defun deftypefun)) (define indices '(cindex findex vindex kindex pindex tindex)) (define (stexi-extract-index tree manual-name kind) "Given an stexi tree @var{tree}, index all of the entries of type @var{kind}. @var{kind} can be one of the predefined texinfo indices (@code{concept}, @code{variable}, @code{function}, @code{key}, @code{program}, @code{type}) or one of the special symbols @code{auto} or @code{all}. @code{auto} will scan the stext for a @code{(printindex)} statement, and @code{all} will generate an index from all entries, regardless of type. The returned index is a list of pairs, the @sc{car} of which is the entry (a string) and the @sc{cdr} of which is a node name (a string)." (let loop ((in tree) (entries '())) (cond ((null? in) entries) ((pair? (car in)) (cond ((and (pair? (cdr in)) (pair? (cadr in)) (eq? (caar in) 'anchor) (memq (caadr in) defines)) (loop (cddr in) (acons (cadr (assq 'name (cdr (cadadr in)))) (cadr (assq 'name (cdadar in))) entries))) ((and (pair? (cdr in)) (pair? (cadr in)) (eq? (caar in) 'anchor) (memq (caadr in) indices)) (loop (cddr in) (acons (sxml->string (cadr in)) (cadr (assq 'name (cdadar in))) entries))) (else (loop (cdr in) (loop (car in) entries))))) (else (loop (cdr in) entries))))) ;;; arch-tag: 216d29d3-1ed9-433f-9c19-0dc4d6b439b6 ��������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/texinfo/reflection.scm����������������������������������������������������������0000664�0000764�0000764�00000046154�11436604547�015443� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (texinfo reflection) -- documenting Scheme as stexinfo ;; Copyright (C) 2003,2004,2010 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;Routines to generare @code{stexi} documentation for objects and ;;modules. ;; ;;Note that in this context, an @dfn{object} is just a value associated ;;with a location. It has nothing to do with GOOPS. ;; ;;; Code: (define-module (texinfo reflection) #:use-module ((srfi srfi-1) #:select (append-map)) #:use-module (oop goops) #:use-module (texinfo) #:use-module (texinfo plain-text) #:use-module (srfi srfi-13) #:use-module (scheme kwargs) #:use-module (ice-9 session) #:use-module (ice-9 documentation) #:use-module (ice-9 optargs) #:use-module ((sxml transform) #:select (pre-post-order)) #:export (module-stexi-documentation script-stexi-documentation object-stexi-documentation package-stexi-standard-copying package-stexi-standard-titlepage package-stexi-generic-menu package-stexi-standard-menu package-stexi-extended-menu package-stexi-standard-prologue package-stexi-documentation)) ;; List for sorting the definitions in a module (define defs '(deftp defcv defivar deftypeivar defop deftypeop defmethod deftypemethod defopt defvr defvar deftypevr deftypevar deffn deftypefn defmac defspec defun deftypefun)) (define (sort-defs ordering a b) (define (def x) ;; a and b are lists of the form ((anchor ...) (def* ...)...) (cadr x)) (define (name x) (cadr (assq 'name (cdadr (def x))))) (define (priority x) (list-index defs (car (def x)))) (define (order x) (or (list-index ordering (string->symbol (name x))) ;; if the def is not in the list, a big number 1234567890)) (define (compare-in-order proc eq? < . args) (if (not (eq? (proc a) (proc b))) (< (proc a) (proc b)) (or (null? args) (apply compare-in-order args)))) (compare-in-order order = < priority = < name string=? string<=?)) (define (list*-join l infix restfix) (let lp ((in l) (out '())) (cond ((null? in) (reverse! out)) ((symbol? in) (reverse! (cons* in restfix out))) (else (lp (cdr in) (if (null? out) (list (car in)) (cons* (car in) infix out))))))) (define (process-args args) (map (lambda (x) (if (symbol? x) (symbol->string x) x)) (list*-join (or args '()) " " " . "))) (define (get-proc-args proc) (cond ((procedure-property proc 'arglist) => (lambda (arglist) (let ((required-args (car arglist)) (optional-args (cadr arglist)) (keyword-args (caddr arglist)) (rest-arg (car (cddddr arglist)))) (process-args (append ;; start with the required args... (map symbol->string required-args) ;; add any optional args if needed... (map (lambda (a) (if (list? a) (format #f "[~a = ~s]" (car a) (cadr a)) (format #f "[~a]" a))) optional-args) ;; now the keyword args.. (map (lambda (a) (if (list? a) (format #f "[#:~a = ~s]" (car a) (cadr a)) (format #f "[#:~a]" a))) keyword-args) ;; now the rest arg... (if rest-arg (list "." (symbol->string rest-arg)) '())))))) (else (process-args (and=> (procedure-source proc) cadr))))) ;; This is really nasty, I wish guile gave a better way to get this... (define (get-macro-args macro) (process-args (false-if-exception (local-eval ;; f is the local name given to the procedure we want '(cadr (procedure-source f)) (procedure-environment (macro-transformer macro)))))) (define <class> (module-ref (resolve-interface '(oop goops)) '<class>)) ;; HACK! (define many-space? (make-regexp "[[:space:]][[:space:]][[:space:]]")) (define initial-space? (make-regexp "^[[:space:]]")) (define (string->stexi str) (or (and (or (not str) (string-null? str)) '(*fragment*)) (and (or (string-index str #\@) (and (not (regexp-exec many-space? str)) (not (regexp-exec initial-space? str)))) (false-if-exception (texi-fragment->stexi str))) `(*fragment* (verbatim ,str)))) (define method-formals (and (defined? 'method-formals) method-formals)) (define (method-stexi-arguments method) (cond (method-formals (let lp ((formals (method-formals method)) (specializers (method-specializers method)) (out '())) (define (arg-texinfo formal specializer) `(" (" (var ,(symbol->string formal)) " " (code ,(symbol->string (class-name specializer))) ")")) (cond ((null? formals) (reverse out)) ((pair? formals) (lp (cdr formals) (cdr specializers) (append (reverse (arg-texinfo (car formals) (car specializers))) out))) (else (append (reverse out) (arg-texinfo formals specializers) (list "...")))))) ((method-source method) (let lp ((bindings (cadr (method-source method))) (out '())) (define (arg-texinfo arg) `(" (" (var ,(symbol->string (car arg))) " " (code ,(symbol->string (cadr arg))) ")")) (cond ((null? bindings) (reverse out)) ((not (pair? (car bindings))) (append (reverse out) (arg-texinfo bindings) (list "..."))) (else (lp (cdr bindings) (append (reverse (arg-texinfo (car bindings))) out)))))) (else (warn method) '()))) (define/kwargs (object-stexi-documentation object (name "[unknown]") (force #f)) (if (symbol? name) (set! name (symbol->string name))) (let ((stexi ((lambda (x) (cond ((string? x) (string->stexi x)) ((and (pair? x) (eq? (car x) '*fragment*)) x) (force `(*fragment*)) (else #f))) (object-documentation (if (is-a? object <method>) (method-procedure object) object))))) (define (make-def type args) `(,type (% ,@args) ,@(cdr stexi))) (cond ((not stexi) #f) ;; stexi is now a list, headed by *fragment*. ((and (pair? (cdr stexi)) (pair? (cadr stexi)) (memq (caadr stexi) defs)) ;; it's already a deffoo. stexi) ((is-a? object <class>) (make-def 'deftp `((name ,name) (category "Class")))) ((is-a? object <macro>) (make-def 'defspec `((name ,name) (arguments ,@(get-macro-args object))))) ((is-a? object <procedure>) (make-def 'defun `((name ,name) (arguments ,@(get-proc-args object))))) ((is-a? object <method>) (make-def 'deffn `((category "Method") (name ,name) (arguments ,@(method-stexi-arguments object))))) ((is-a? object <generic>) `(*fragment* ,(make-def 'deffn `((name ,name) (category "Generic"))) ,@(map (lambda (method) (object-stexi-documentation method name #:force force)) (generic-function-methods object)))) (else (make-def 'defvar `((name ,name))))))) (define (module-name->node-name sym-name) (string-join (map symbol->string sym-name) " ")) ;; this copied from (ice-9 session); need to find a better way (define (module-filename name) (let* ((name (map symbol->string name)) (reverse-name (reverse name)) (leaf (car reverse-name)) (dir-hint-module-name (reverse (cdr reverse-name))) (dir-hint (apply string-append (map (lambda (elt) (string-append elt "/")) dir-hint-module-name)))) (%search-load-path (in-vicinity dir-hint leaf)))) (define (read-module name) (let ((filename (module-filename name))) (if filename (let ((port (open-input-file filename))) (let lp ((out '()) (form (read port))) (if (eof-object? form) (reverse out) (lp (cons form out) (read port))))) '()))) (define (module-export-list sym-name) (define (module-form-export-list form) (and (pair? form) (eq? (car form) 'define-module) (equal? (cadr form) sym-name) (and=> (memq #:export (cddr form)) cadr))) (let lp ((forms (read-module sym-name))) (cond ((null? forms) '()) ((module-form-export-list (car forms)) => identity) (else (lp (cdr forms)))))) (define/kwargs (module-stexi-documentation sym-name (docs-resolver (lambda (name def) def))) "Return documentation for the module named @var{sym-name}. The documentation will be formatted as @code{stexi} (@pxref{texinfo,texinfo})." (let* ((commentary (and=> (module-commentary sym-name) (lambda (x) (string-trim-both x #\newline)))) (stexi (string->stexi commentary)) (node-name (module-name->node-name sym-name)) (name-str (with-output-to-string (lambda () (display sym-name)))) (module (resolve-interface sym-name)) (export-list (module-export-list sym-name))) (define (anchor-name sym) (string-append node-name " " (symbol->string sym))) (define (make-defs) (sort! (module-map (lambda (sym var) `((anchor (% (name ,(anchor-name sym)))) ,@((lambda (x) (if (eq? (car x) '*fragment*) (cdr x) (list x))) (if (variable-bound? var) (docs-resolver sym (object-stexi-documentation (variable-ref var) sym #:force #t)) (begin (warn "variable unbound!" sym) `(defvar (% (name ,(symbol->string sym))) "[unbound!]")))))) module) (lambda (a b) (sort-defs export-list a b)))) `(texinfo (% (title ,name-str)) (node (% (name ,node-name))) (section "Overview") ,@(cdr stexi) (section "Usage") ,@(apply append! (make-defs))))) (define (script-stexi-documentation scriptpath) "Return documentation for given script. The documentation will be taken from the script's commentary, and will be returned in the @code{stexi} format (@pxref{texinfo,texinfo})." (let ((commentary (file-commentary scriptpath))) `(texinfo (% (title ,(basename scriptpath))) (node (% (name ,(basename scriptpath)))) ,@(if commentary (cdr (string->stexi (string-trim-both commentary #\newline))) '())))) (cond ((defined? 'add-value-help-handler!) (add-value-help-handler! (lambda (name value) (stexi->plain-text (object-stexi-documentation value name #:force #t)))) (add-name-help-handler! (lambda (name) (and (list? name) (and-map symbol? name) (stexi->plain-text (module-stexi-documentation name))))))) ;; we could be dealing with an old (ice-9 session); fondle it to get ;; module-commentary (define module-commentary (@@ (ice-9 session) module-commentary)) (define (package-stexi-standard-copying name version updated years copyright-holder permissions) "Create a standard texinfo @code{copying} section. @var{years} is a list of years (as integers) in which the modules being documented were released. All other arguments are strings." `(copying (para "This manual is for " ,name " (version " ,version ", updated " ,updated ")") (para "Copyright " ,(string-join (map number->string years) ",") " " ,copyright-holder) (quotation (para ,permissions)))) (define (package-stexi-standard-titlepage name version updated authors) "Create a standard GNU title page. @var{authors} is a list of @code{(@var{name} . @var{email})} pairs. All other arguments are strings. Here is an example of the usage of this procedure: @smallexample (package-stexi-standard-titlepage \"Foolib\" \"3.2\" \"26 September 2006\" '((\"Alyssa P Hacker\" . \"alyssa@@example.com\")) '(2004 2005 2006) \"Free Software Foundation, Inc.\" \"Standard GPL permissions blurb goes here\") @end smallexample " `(;(setchapternewpage (% (all "odd"))) makes manuals too long (titlepage (title ,name) (subtitle "version " ,version ", updated " ,updated) ,@(map (lambda (pair) `(author ,(car pair) " (" (email ,(cdr pair)) ")")) authors) (page) (vskip (% (all "0pt plus 1filll"))) (insertcopying)))) (define (package-stexi-generic-menu name entries) "Create a menu from a generic alist of entries, the car of which should be the node name, and the cdr the description. As an exception, an entry of @code{#f} will produce a separator." (define (make-entry node description) `("* " ,node "::" ,(make-string (max (- 21 (string-length node)) 2) #\space) ,@description "\n")) `((ifnottex (node (% (name "Top"))) (top (% (title ,name))) (insertcopying) (menu ,@(apply append (map (lambda (entry) (if entry (make-entry (car entry) (cdr entry)) '("\n"))) entries)))) (iftex (shortcontents)))) (define (package-stexi-standard-menu name modules module-descriptions extra-entries) "Create a standard top node and menu, suitable for processing by makeinfo." (package-stexi-generic-menu name (let ((module-entries (map cons (map module-name->node-name modules) module-descriptions)) (separate-sections (lambda (x) (if (null? x) x (cons #f x))))) `(,@module-entries ,@(separate-sections extra-entries))))) (define (package-stexi-extended-menu name module-pairs script-pairs extra-entries) "Create an \"extended\" menu, like the standard menu but with a section for scripts." (package-stexi-generic-menu name (let ((module-entries (map cons (map module-name->node-name (map car module-pairs)) (map cdr module-pairs))) (script-entries (map cons (map basename (map car script-pairs)) (map cdr script-pairs))) (separate-sections (lambda (x) (if (null? x) x (cons #f x))))) `(,@module-entries ,@(separate-sections script-entries) ,@(separate-sections extra-entries))))) (define (package-stexi-standard-prologue name filename category description copying titlepage menu) "Create a standard prologue, suitable for later serialization to texinfo and .info creation with makeinfo. Returns a list of stexinfo forms suitable for passing to @code{package-stexi-documentation} as the prologue. @xref{texinfo reflection package-stexi-documentation}, @ref{texinfo reflection package-stexi-standard-titlepage,package-stexi-standard-titlepage}, @ref{texinfo reflection package-stexi-standard-copying,package-stexi-standard-copying}, and @ref{texinfo reflection package-stexi-standard-menu,package-stexi-standard-menu}." `(,copying (dircategory (% (category ,category))) (direntry "* " ,name ": (" ,filename "). " ,description ".") ,@titlepage ,@menu)) (define (stexi->chapter stexi) (pre-post-order stexi `((texinfo . ,(lambda (tag attrs node . body) `(,node (chapter ,@(assq-ref (cdr attrs) 'title)) ,@body))) (*text* . ,(lambda (tag text) text)) (*default* . ,(lambda args args))))) (define/kwargs (package-stexi-documentation modules name filename prologue epilogue (module-stexi-documentation-args '()) (scripts '())) "Create stexi documentation for a @dfn{package}, where a package is a set of modules that is released together. @var{modules} is expected to be a list of module names, where a module name is a list of symbols. The stexi that is returned will be titled @var{name} and a texinfo filename of @var{filename}. @var{prologue} and @var{epilogue} are lists of stexi forms that will be spliced into the output document before and after the generated modules documentation, respectively. @xref{texinfo reflection package-stexi-standard-prologue}, to create a conventional GNU texinfo prologue. @var{module-stexi-documentation-args} is an optional argument that, if given, will be added to the argument list when @code{module-texi-documentation} is called. For example, it might be useful to define a @code{#:docs-resolver} argument." (define (verify-modules-list l) (define (all pred l) (and (pred (car l)) (or (null? (cdr l)) (all pred (cdr l))))) (false-if-exception (all (lambda (x) (all symbol? x)) modules))) (if (not (verify-modules-list modules)) (error "expected modules to be a list of a list of symbols" modules)) `(texinfo (% (title ,name) (filename ,filename)) ,@prologue ,@(append-map (lambda (mod) (stexi->chapter (apply module-stexi-documentation mod module-stexi-documentation-args))) modules) ,@(append-map (lambda (script) (stexi->chapter (script-stexi-documentation script))) scripts) ,@epilogue)) ;;; arch-tag: bbe2bc03-e16d-4a9e-87b9-55225dc9836c ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/texinfo/nodal-tree.scm����������������������������������������������������������0000664�0000764�0000764�00000010376�11137622030�015321� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (texinfo nodal-tree) -- rendering stexinfo to a nodal tree ;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;This module exports a procedure to chunk a stexi doument into pieces, ;;delimited by sectioning commands (@code{@@chapter}, ;;@code{@@appendixsec}, etc.). Note that the sectioning commands must be ;;preceded by a @code{@@node}, a condition that the output of ;;@code{(sxml texinfo)} respects. ;; ;;The output is a nodal tree (see (container nodal-tree)), with the ;;following fields defined for each node: ;; ;;; Code: (define-module (texinfo nodal-tree) #:use-module (container nodal-tree) #:use-module (sxml simple) #:use-module (scheme kwargs) #:use-module (texinfo) ;; texi-command-depth #:export (stexi->nodal-tree)) (define (node? elt) (and (pair? elt) (eq? (car elt) 'node))) (define (chunking-section? elt max-depth) (and (pair? elt) (texi-command-depth (car elt) max-depth))) (define (append-child! parent kid) (if parent (node-set! parent 'children (append! (node-ref parent 'children) (list kid))))) (define (find-parent node) (or (and=> (node-ref node 'parent) find-parent) node)) ;; There has to be a more functional way to do this! Probably involves ;; building up from the leaves, instead of building down from the root. ;; Thankfully, the ugliness of this code isn't exported. (define/kwargs (stexi->nodal-tree (stexi #f) (max-depth 4) (initial-depth 0)) "Break @var{stexi} into a nodal tree. Only break until sectioning identifiers of depth @var{max-depth}. The following fields are defined for each node: @table @code @item name The name of the section. @item value The content of the section, as @code{stexi}. The containing element is @code{texinfo}. @item parent A reference to the parent node. @item children A list of subnodes, corresponding to the subsections of the current section. @end table" (define (make-node* parent tree-title) (let ((node (make-node 'name (sxml->string tree-title) 'value #f 'parent parent 'children '()))) (append-child! parent node) node)) (or (eq? (car stexi) 'texinfo) (error "Invalid stexi")) (let lp ((in stexi) (val '()) (node (make-node* #f (cadr stexi))) (parent #f) (depth initial-depth)) ;(pk (or (null? in) (car in)) val node parent depth) (cond ((null? in) (node-set! node 'value (reverse! val)) (find-parent node)) ((or (chunking-section? (car in) max-depth) (and (node? (car in)) (pair? in) (pair? (cdr in)) (chunking-section? (cadr in) max-depth))) (node-set! node 'value (reverse! val)) (let* ((node-statement (if (node? (car in)) (car in) #f)) (in (if node-statement (cdr in) in)) (new-depth (texi-command-depth (caar in) max-depth))) (let new-parent ((parent node) (diff (- new-depth depth))) (cond ((not parent) (error "invalid stexi")) ((positive? diff) (or (eq? diff 1) (error "can only descend by one depth level at a time" (car in))) (lp (cdr in) `(,(car in) ,@(if node-statement (list node-statement) '()) (% (title ,(sxml->string (car in)))) texinfo) (make-node* parent (car in)) parent new-depth)) (else (new-parent (node-ref parent 'parent) (1+ diff))))))) (else (lp (cdr in) (cons (car in) val) node parent depth))))) ;;; arch-tag: aff19153-493d-4755-ba6f-22cc7fb43c60 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/texinfo/html.scm����������������������������������������������������������������0000664�0000764�0000764�00000022503�11137621705�014236� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (texinfo html) -- translating stexinfo into shtml ;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;This module implements transformation from @code{stexi} to HTML. Note ;;that the output of @code{stexi->shtml} is actually SXML with the HTML ;;vocabulary. This means that the output can be further processed, and ;;that it must eventually be serialized by ;;@ref{sxml simple sxml->xml,sxml->xml}. ;; ;;References (i.e., the @code{@@ref} family of commands) are resolved by ;;a @dfn{ref-resolver}. ;;@xref{texinfo html add-ref-resolver!,add-ref-resolver!}, for more ;;information. ;; ;;; Code: ;; TODO: nice ref resolving API, default CSS stylesheet (esp. to remove ;; margin-top on dd > p) (define-module (texinfo html) :use-module (texinfo) :use-module (sxml transform) :use-module (scheme documentation) :use-module (srfi srfi-13) :export (stexi->shtml add-ref-resolver! urlify)) ;; The caller is responsible for carring the returned list. (define (arg-ref key %-args) (and=> (assq key (cdr %-args)) (lambda (x) (stexi->shtml (cdr x))))) (define (arg-req key %-args) (or (arg-ref key %-args) (error "Missing argument:" key %-args))) (define (car* x) (and x (car x))) (define (urlify str) (string-downcase (string-map (lambda (c) (case c ((#\space #\/ #\:) #\-) (else c))) str))) (define ref-resolvers (list (lambda (node-name manual-name) ;; the default (urlify (string-append (or manual-name "") "#" node-name))))) (define (add-ref-resolver! proc) "Add @var{proc} to the head of the list of ref-resolvers. @var{proc} will be expected to take the name of a node and the name of a manual and return the URL of the referent, or @code{#f} to pass control to the next ref-resolver in the list. The default ref-resolver will return the concatenation of the manual name, @code{#}, and the node name." (set! ref-resolvers (cons proc ref-resolvers))) (define (resolve-ref node manual) (or (or-map (lambda (x) (x node manual)) ref-resolvers) (error "Could not resolve reference" node manual))) (define (ref tag args) (let* ((node (car (arg-req 'node args))) (section (or (car* (arg-ref 'section args)) node)) (manual (car* (arg-ref 'manual args))) (target (resolve-ref node manual))) `(span ,(and=> (assq tag '((xref "See ") (pxref "see "))) cdr) (a (@ (href ,target)) ,section)))) (define (uref tag args) (let ((url (car (arg-req 'url args)))) `(a (@ (href ,url)) ,(or (car* (arg-ref 'title args)) url)))) ;; @!*&%( Mozilla gets confused at an empty ("<a .. />") a tag. Put an ;; empty string here to placate the reptile. (define (node tag args) `(a (@ (name ,(urlify (car (arg-req 'name args))))) "")) (define (def tag args . body) (define (code x) (and x (cons 'code x))) (define (var x) (and x (cons 'var x))) (define (b x) (and x (cons 'b x))) (define (list/spaces . elts) (let lp ((in elts) (out '())) (cond ((null? in) (reverse! out)) ((null? (car in)) (lp (cdr in) out)) (else (lp (cdr in) (cons (car in) (if (null? out) out (cons " " out)))))))) (define (left-td-contents) (list/spaces (code (arg-ref 'data-type args)) (b (list (code (arg-ref 'class args)))) ;; is this right? (b (list (code (arg-ref 'name args)))) (if (memq tag '(deftypeop deftypefn deftypefun)) (code (arg-ref 'arguments args)) (var (list (code (arg-ref 'arguments args))))))) (let* ((category (case tag ((defun) "Function") ((defspec) "Special Form") ((defvar) "Variable") (else (car (arg-req 'category args)))))) `(div (table (@ (cellpadding "0") (cellspacing "0") (width "100%") (class "def")) (tr (td ,@(left-td-contents)) (td (div (@ (class "right")) "[" ,category "]")))) (div (@ (class "description")) ,@body)))) (define (enumerate tag . elts) (define (tonumber start) (let ((c (string-ref start 0))) (cond ((number? c) (string->number start)) (else (1+ (- (char->integer c) (char->integer (if (char-upper? c) #\A #\a)))))))) `(ol ,@(if (and (pair? elts) (pair? (car elts)) (eq? (caar elts) '%)) (cons `(@ (start ,@(tonumber (arg-req 'start (car elts))))) ;; (type ,(type (arg-ref 'start (car elts))))) (cdr elts)) elts))) (define (table tag args . body) (let ((formatter (caar (arg-req 'formatter args)))) (cons 'dl (map (lambda (x) (cond ((and (pair? x) (eq? (car x) 'dt)) (list (car x) (cons formatter (cdr x)))) (else x))) (apply append body))))) (define (entry tag args . body) `((dt ,@(arg-req 'heading args)) (dd ,@body))) (define tag-replacements '((titlepage div (@ (class "titlepage"))) (title h2 (@ (class "title"))) (subtitle h3 (@ (class "subtitle"))) (author h3 (@ (class "author"))) (example pre) (lisp pre) (smallexample pre (@ (class "smaller"))) (smalllisp pre (@ (class "smaller"))) (cartouche div (@ (class "cartouche"))) (verbatim pre (@ (class "verbatim"))) (chapter h2) (section h3) (subsection h4) (subsubsection h5) (appendix h2) (appendixsec h3) (appendixsubsec h4) (appendixsubsubsec h5) (unnumbered h2) (unnumberedsec h3) (unnumberedsubsec h4) (unnumberedsubsubsec h5) (majorheading h2) (chapheading h2) (heading h3) (subheading h4) (subsubheading h5) (quotation blockquote) (itemize ul) (item li) ;; itemx ? (para p) (*fragment* div) ;; should be ok (asis span) (bold b) (sample samp) (samp samp) (code code) (kbd kbd) (key code (@ (class "key"))) (var var) (env code (@ (class "env"))) (file code (@ (class "file"))) (command code (@ (class "command"))) (option code (@ (class "option"))) (url code (@ (class "url"))) (dfn dfn) (cite cite) (acro acronym) (email code (@ (class "email"))) (emph em) (strong strong) (sc span (@ (class "small-caps"))))) (define ignore-list '(page setfilename setchapternewpage iftex ifinfo ifplaintext ifxml sp vskip menu ignore syncodeindex comment c dircategory direntry top shortcontents cindex printindex)) (define (ignored? tag) (memq tag ignore-list)) (define rules `((% *preorder* . ,(lambda args args)) ;; Keep these around... (texinfo . ,(lambda (tag args . body) (pre-post-order `(html (@ (xmlns "http://www.w3.org/1999/xhtml")) (head (title ,(car (arg-req 'title args)))) (body ,@body)) `((% *preorder* . ,(lambda args #f)) ;; ... filter out. (*text* . ,(lambda (tag x) x)) (*default* . ,(lambda (tag . body) (cons tag body))))))) (copyright . ,(lambda args '(*ENTITY* "copy"))) (result . ,(lambda args '(*ENTITY* "rArr"))) (xref . ,ref) (ref . ,ref) (pxref . ,ref) (uref . ,uref) (node . ,node) (anchor . ,node) (table . ,table) (enumerate . ,enumerate) (entry . ,entry) (deftp . ,def) (defcv . ,def) (defivar . ,def) (deftypeivar . ,def) (defop . ,def) (deftypeop . ,def) (defmethod . ,def) (deftypemethod . ,def) (defopt . ,def) (defvr . ,def) (defvar . ,def) (deftypevr . ,def) (deftypevar . ,def) (deffn . ,def) (deftypefn . ,def) (defmac . ,def) (defspec . ,def) (defun . ,def) (deftypefun . ,def) (ifnottex . ,(lambda (tag . body) body)) (*text* . ,(lambda (tag x) x)) (*default* . ,(lambda (tag . body) (let ((subst (assq tag tag-replacements))) (cond (subst (append (cdr subst) body)) ((memq tag ignore-list) #f) (else (warn "Don't know how to convert" tag "to HTML") body))))))) (define (stexi->shtml tree) "Transform the stexi @var{tree} into shtml, resolving references via ref-resolvers. See the module commentary for more details." (pre-post-order tree rules)) ;;; arch-tag: ab05f3fe-9981-4a78-b64c-48efcd9983a6 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/texinfo/serialize.scm�����������������������������������������������������������0000664�0000764�0000764�00000021642�11436643574�015276� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (texinfo serialize) -- rendering stexinfo as texinfo ;; Copyright (C) 2003,2004,2010 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;Serialization of @code{stexi} to plain texinfo. ;; ;;; Code: (define-module (texinfo serialize) #:use-module (texinfo) #:use-module (sxml transform) #:use-module (scheme documentation) #:use-module (string wrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:use-module (compat guile-2) #:export (stexi->texi)) (define (list-intersperse src-l elem) (if (null? src-l) src-l (let loop ((l (cdr src-l)) (dest (cons (car src-l) '()))) (if (null? l) (reverse dest) (loop (cdr l) (cons (car l) (cons elem dest))))))) ;; converts improper lists to proper lists. (define (filter* pred l) (let lp ((in l) (out '())) (cond ((null? in) (reverse! out)) ((pair? in) (lp (cdr in) (if (pred (car in)) (cons (car in) out) out))) (else (lp '() (if (pred in) (cons in out) out)))))) ;; (list* 'a '(b c) 'd '(e f g)) => '(a b c d e f g) (define (list* . args) (let* ((args (reverse args)) (tail (car args))) (let lp ((in (cdr args)) (out tail)) (cond ((null? in) out) ((pair? (car in)) (lp (cdr in) (append (car in) out))) ((null? (car in)) (lp (cdr in) out)) (else (lp (cdr in) (cons (car in) out))))))) ;; Why? Well, because syntax-case defines `include', and carps about its ;; wrong usage below... (eval-when (eval load compile) (define (include exp lp command type formals args accum) (list* "\n" (list-intersperse args " ") " " command "@" accum))) (define (empty-command exp lp command type formals args accum) (list* " " command "@" accum)) (define (inline-text exp lp command type formals args accum) (if (not (string=? command "*braces*")) ;; fixme :( (list* "}" (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) "{" command "@" accum) (list* "@}" (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) "@{" accum))) (define (inline-args exp lp command type formals args accum) (list* "}" (if (not args) "" (list-intersperse (map (lambda (x) (cond ((not x) "") ((pair? x) (if (pair? (cdr x)) (warn "Strange inline-args!" args)) (car x)) (else (error "Invalid inline-args" args)))) (drop-while not (map (lambda (x) (assq-ref args x)) (reverse formals)))) ",")) "{" command "@" accum)) (define (serialize-text-args lp formals args) (apply append (list-intersperse (map (lambda (arg) (append-map (lambda (x) (lp x '())) arg)) (map reverse (drop-while not (map (lambda (x) (assq-ref args x)) (reverse formals))))) '(" ")))) (define (eol-text-args exp lp command type formals args accum) (list* "\n" (serialize-text-args lp formals args) " " command "@" accum)) (define (eol-text exp lp command type formals args accum) (list* "\n" (append-map (lambda (x) (lp x '())) (reverse (if args (cddr exp) (cdr exp)))) " " command "@" accum)) (define (eol-args exp lp command type formals args accum) (list* "\n" (list-intersperse (apply append (drop-while not (map (lambda (x) (assq-ref args x)) (reverse formals)))) ", ") " " command "@" accum)) (define (environ exp lp command type formals args accum) (case (car exp) ((texinfo) (list* "@bye\n" (append-map (lambda (x) (lp x '())) (reverse (cddr exp))) "\n@c %**end of header\n\n" (reverse (assq-ref args 'title)) "@settitle " (or (and=> (assq-ref args 'filename) (lambda (filename) (cons "\n" (reverse (cons "@setfilename " filename))))) "") "\\input texinfo @c -*-texinfo-*-\n@c %**start of header\n" accum)) (else (list* "\n\n" command "@end " (let ((body (append-map (lambda (x) (lp x '())) (reverse (if args (cddr exp) (cdr exp)))))) (if (or (null? body) (eqv? (string-ref (car body) (1- (string-length (car body)))) #\newline)) body (cons "\n" body))) "\n" (serialize-text-args lp formals args) " " command "@" accum)))) (define (table-environ exp lp command type formals args accum) (list* "\n\n" command "@end " (append-map (lambda (x) (lp x '())) (reverse (if args (cddr exp) (cdr exp)))) "\n" (let* ((arg (if args (cadar args) ""))) ;; zero or one args (if (pair? arg) (list (symbol->string (car arg)) "@") arg)) " " command "@" accum)) (define (wrap strings) (fill-string (string-concatenate strings) #:width 72)) (define (paragraph exp lp command type formals args accum) (list* "\n\n" (wrap (reverse (append-map (lambda (x) (lp x '())) (reverse (cdr exp))))) accum)) (define (item exp lp command type formals args accum) (list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) "@item\n" accum)) (define (entry exp lp command type formals args accum) (list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp))) "\n" (append-map (lambda (x) (lp x '())) (reverse (cdar args))) "@item " accum)) (define (fragment exp lp command type formals args accum) (list* "\n@c %end of fragment\n" (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) "\n@c %start of fragment\n\n" accum)) (define serializers `((EMPTY-COMMAND . ,empty-command) (INLINE-TEXT . ,inline-text) (INLINE-ARGS . ,inline-args) (EOL-TEXT . ,eol-text) (EOL-TEXT-ARGS . ,eol-text-args) (INDEX . ,eol-text-args) (EOL-ARGS . ,eol-args) (ENVIRON . ,environ) (TABLE-ENVIRON . ,table-environ) (ENTRY . ,entry) (ITEM . ,item) (PARAGRAPH . ,paragraph) (FRAGMENT . ,fragment) (#f . ,include))) ; support writing include statements (define (serialize exp lp command type formals args accum) ((or (assq-ref serializers type) (error "Unknown command type" exp type)) exp lp command type formals args accum)) (define escaped-chars '(#\} #\{ #\@)) (define (escape str) "Escapes any illegal texinfo characters (currently @{, @}, and @@)." (let loop ((in (string->list str)) (out '())) (if (null? in) (apply string (reverse out)) (if (memq (car in) escaped-chars) (loop (cdr in) (cons* (car in) #\@ out)) (loop (cdr in) (cons (car in) out)))))) (define (stexi->texi tree) "Serialize the stexi @var{tree} into plain texinfo." (string-concatenate-reverse (let lp ((in tree) (out '())) (cond ((or (not in) (null? in)) out) ((string? in) (cons (escape in) out)) ((pair? in) (let ((command-spec (assq (car in) texi-command-specs))) (if (not command-spec) (begin (warn "Unknown stexi command, not rendering" in) out) (serialize in lp (symbol->string (car in)) (cadr command-spec) (filter* symbol? (cddr command-spec)) (cond ((and (pair? (cdr in)) (pair? (cadr in)) (eq? (caadr in) '%)) (cdadr in)) ((not (cadr command-spec)) ;; include (cdr in)) (else #f)) out)))) (else (error "Invalid stexi" in)))))) ;;; arch-tag: d3fa16ea-0bf7-4ec5-ab9f-3f08490f77f5 ����������������������������������������������������������������������������������������������guile-lib-0.2.1/src/container/����������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�013145� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/container/async-queue.scm�������������������������������������������������������0000664�0000764�0000764�00000004174�11212576345�016046� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (container async-queue) -- a thread-safe asynchronous queue ;; Copyright (C) 2007 Andreas Rottmann <a dot rottmann at gmx dot at> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;A asynchronous queue can be used to safely send messages from one ;;thread to another. ;; ;;; Code: (define-module (container async-queue) #:export (make-async-queue async-enqueue! async-dequeue!) #:use-module (ice-9 q) #:use-module (ice-9 threads) #:use-module (oop goops)) (define-class <async-queue> () (queue #:init-form (make-q) #:getter queue) (condv #:init-form (make-condition-variable) #:getter condv) (mutex #:init-form (make-mutex) #:getter mutex) (waiting-threads #:init-value 0 #:accessor waiting-threads)) (define (make-async-queue) "Create a new asynchronous queue." (make <async-queue>)) (define (async-enqueue! q elt) "Enqueue @var{elt} into @var{q}." (with-mutex (mutex q) (enq! (queue q) elt) (if (> (waiting-threads q) 0) (signal-condition-variable (condv q))))) (define (async-dequeue! q) "Dequeue a single element from @var{q}. If the queue is empty, the calling thread is blocked until an element is enqueued by another thread." (with-mutex (mutex q) (cond ((q-empty? (queue q)) (set! (waiting-threads q) (+ (waiting-threads q) 1)) (let loop () (cond ((q-empty? (queue q)) (wait-condition-variable (condv q) (mutex q)) (loop)))) (set! (waiting-threads q) (- (waiting-threads q) 1)))) (deq! (queue q)))) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/container/nodal-tree.scm��������������������������������������������������������0000664�0000764�0000764�00000004160�11137623571�015634� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (container nodal-tree) -- a tree data structure ;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;A nodal tree is a tree composed of nodes, each of which may have ;;children. Nodes are represented as alists. The only alist entry that ;;is specified is @code{children}, which must hold a list of child ;;nodes. Other entries are intentionally left unspecified, so as to ;;allow for extensibility. ;; ;;; Code: (define-module (container nodal-tree) #:export (nodal-tree? make-node node-ref node-set! node-children)) ;; Returns pairs, not lists (define (group-pairs l) (let lp ((in l) (out '())) (cond ((null? in) (reverse! out)) (else (lp (list-cdr-ref in 2) (acons (car in) (cadr in) out)))))) (define (make-node . attributes) (or (even? (length attributes)) (error "invalid node atrributes")) (cons 'nodal-tree (let ((body (group-pairs attributes))) (if (assq 'children body) body (acons 'children '() body))))) (define (node-set! node name val) (set-cdr! node (assq-set! (cdr node) name val))) (define (node-ref node name) (assq-ref (cdr node) name)) (define (node-children node) (or (node-ref node 'children) '())) (define (nodal-tree? x) "Predicate to determine if @var{x} is a nodal tree. Not particularly efficient: intended for debugging purposes." (and (list? x) (eq? (car x) 'nodal-tree) (and-map pair? x) (and-map nodal-tree? (node-children x)))) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/container/delay-tree.scm��������������������������������������������������������0000664�0000764�0000764�00000002731�11137623202�015626� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (container delay-tree) -- a nodal tree with promises ;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;A delay tree is a superset of a nodal tree (see (container ;;nodal-tree)). It extends nodal trees to allow any entry of the node to ;;be a promise created with the @code{delay} operator. ;; ;;; Code: (define-module (container delay-tree) #:use-module (container nodal-tree) #:export (force-ref)) (define (force-ref node field) "Access a field in a node of a delay tree. If the value of the field is a promise, the promise will be forced, and the value will be replaced with the forced value." (let ((val (node-ref node field))) (and val (if (promise? val) (begin (node-set! node field (force val)) (node-ref node field)) val)))) ���������������������������������������guile-lib-0.2.1/src/graph/��������������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�012264� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/graph/topological-sort.scm������������������������������������������������������0000664�0000764�0000764�00000005531�11137606250�016220� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (graph topological-sort) -- topological sorting ;; Written 1995 by Mikael Durfeldt. ;; This file is based on tsort.scm from SLIB, and is in the public domain. ;;; Commentary: ;; The algorithm is inspired by Cormen, Leiserson and Rivest (1990) ;; ``Introduction to Algorithms'', chapter 23. ;;; Code: (define-module (graph topological-sort) #:export (topological-sort topological-sortq topological-sortv) #:use-module (math primes)) (define (topological-sort-helper dag insert lookup) (if (null? dag) '() (let* ((adj-table (make-hash-table (car (primes> (length dag) 1)))) (sorted '())) (letrec ((visit (lambda (u adj-list) ;; Color vertex u (insert adj-table u 'colored) ;; Visit uncolored vertices which u connects to (for-each (lambda (v) (let ((val (lookup adj-table v))) (if (not (eq? val 'colored)) (visit v (or val '()))))) adj-list) ;; Since all vertices downstream u are visited ;; by now, we can safely put u on the output list (set! sorted (cons u sorted))))) ;; Hash adjacency lists (for-each (lambda (def) (insert adj-table (car def) (cdr def))) (cdr dag)) ;; Visit vertices (visit (caar dag) (cdar dag)) (for-each (lambda (def) (let ((val (lookup adj-table (car def)))) (if (not (eq? val 'colored)) (visit (car def) (cdr def))))) (cdr dag))) sorted))) (define (topological-sort dag) "Returns a list of the objects in the directed acyclic graph, @var{dag}, topologically sorted. Objects are compared using @code{equal?}. The graph has the form: @lisp (list (obj1 . (dependents-of-obj1)) (obj2 . (dependents-of-obj2)) ...) @end lisp ...specifying, for example, that @code{obj1} must come before all the objects in @code{(dependents-of-obj1)} in the sort." (topological-sort-helper dag hash-set! hash-ref)) (define (topological-sortq dag) "Returns a list of the objects in the directed acyclic graph, @var{dag}, topologically sorted. Objects are compared using @code{eq?}. The graph has the form: @lisp (list (obj1 . (dependents-of-obj1)) (obj2 . (dependents-of-obj2)) ...) @end lisp ...specifying, for example, that @code{obj1} must come before all the objects in @code{(dependents-of-obj1)} in the sort." (topological-sort-helper dag hashq-set! hashq-ref)) (define (topological-sortv dag) "Returns a list of the objects in the directed acyclic graph, @var{dag}, topologically sorted. Objects are compared using @code{eqv?}. The graph has the form: @lisp (list (obj1 . (dependents-of-obj1)) (obj2 . (dependents-of-obj2)) ...) @end lisp ...specifying, for example, that @code{obj1} must come before all the objects in @code{(dependents-of-obj1)} in the sort." (topological-sort-helper dag hashv-set! hashv-ref)) ;;; arch-tag: 9ef30b53-688a-43fc-b208-df78d5b38c74 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/statprof.scm��������������������������������������������������������������������0000664�0000764�0000764�00000063450�11212576345�013471� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (statprof) -- a statistical profiler for Guile ;; Copyright (C) 2004 Andy Wingo <wingo at pobox dot com> ;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU Lesser General Public License as ;; published by the Free Software Foundation, either version 3 of the ;; License, or (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public ;; License along with this program. If not, see ;; <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;@code{(statprof)} is intended to be a fairly simple ;;statistical profiler for guile. It is in the early stages yet, so ;;consider its output still suspect, and please report any bugs to ;;@email{guile-devel at gnu.org}, or to me directly at @email{rlb at ;;defaultvalue.org}. ;; ;;A simple use of statprof would look like this: ;; ;;@example ;; (statprof-reset 0 50000 #t) ;; (statprof-start) ;; (do-something) ;; (statprof-stop) ;; (statprof-display) ;;@end example ;; ;;This would reset statprof, clearing all accumulated statistics, then ;;start profiling, run some code, stop profiling, and finally display a ;;gprof flat-style table of statistics which will look something like ;;this: ;; ;;@example ;; % cumulative self self total ;; time seconds seconds calls ms/call ms/call name ;; 35.29 0.23 0.23 2002 0.11 0.11 - ;; 23.53 0.15 0.15 2001 0.08 0.08 positive? ;; 23.53 0.15 0.15 2000 0.08 0.08 + ;; 11.76 0.23 0.08 2000 0.04 0.11 do-nothing ;; 5.88 0.64 0.04 2001 0.02 0.32 loop ;; 0.00 0.15 0.00 1 0.00 150.59 do-something ;; ... ;;@end example ;; ;;All of the numerical data with the exception of the calls column is ;;statistically approximate. In the following column descriptions, and ;;in all of statprof, "time" refers to execution time (both user and ;;system), not wall clock time. ;; ;;@table @asis ;;@item % time ;;The percent of the time spent inside the procedure itself ;;(not counting children). ;;@item cumulative seconds ;;The total number of seconds spent in the procedure, including ;;children. ;;@item self seconds ;;The total number of seconds spent in the procedure itself (not counting ;;children). ;;@item calls ;;The total number of times the procedure was called. ;;@item self ms/call ;;The average time taken by the procedure itself on each call, in ms. ;;@item total ms/call ;;The average time taken by each call to the procedure, including time ;;spent in child functions. ;;@item name ;;The name of the procedure. ;;@end table ;; ;;The profiler uses @code{eq?} and the procedure object itself to ;;identify the procedures, so it won't confuse different procedures with ;;the same name. They will show up as two different rows in the output. ;; ;;Right now the profiler is quite simplistic. I cannot provide ;;call-graphs or other higher level information. What you see in the ;;table is pretty much all there is. Patches are welcome :-) ;; ;;@section Implementation notes ;; ;;The profiler works by setting the unix profiling signal ;;@code{ITIMER_PROF} to go off after the interval you define in the call ;;to @code{statprof-reset}. When the signal fires, a sampling routine is ;;run which looks at the current procedure that's executing, and then ;;crawls up the stack, and for each procedure encountered, increments ;;that procedure's sample count. Note that if a procedure is encountered ;;multiple times on a given stack, it is only counted once. After the ;;sampling is complete, the profiler resets profiling timer to fire ;;again after the appropriate interval. ;; ;;Meanwhile, the profiler keeps track, via @code{get-internal-run-time}, ;;how much CPU time (system and user -- which is also what ;;@code{ITIMER_PROF} tracks), has elapsed while code has been executing ;;within a statprof-start/stop block. ;; ;;The profiler also tries to avoid counting or timing its own code as ;;much as possible. ;; ;;; Code: ;; When you add new features, please also add tests to ./tests/ if you ;; have time, and then add the new files to ./run-tests. Also, if ;; anyone's bored, there are a lot of existing API bits that don't ;; have tests yet. ;; TODO ;; ;; Check about profiling C functions -- does profiling primitives work? ;; Also look into stealing code from qprof so we can sample the C stack ;; Call graphs? (define-module (statprof) #:use-module (srfi srfi-1) #:use-module (scheme documentation) #:autoload (ice-9 format) (format) #:export (statprof-active? statprof-start statprof-stop statprof-reset statprof-accumulated-time statprof-sample-count statprof-fold-call-data statprof-proc-call-data statprof-call-data-name statprof-call-data-calls statprof-call-data-cum-samples statprof-call-data-self-samples statprof-call-data->stats statprof-stats-proc-name statprof-stats-%-time-in-proc statprof-stats-cum-secs-in-proc statprof-stats-self-secs-in-proc statprof-stats-calls statprof-stats-self-secs-per-call statprof-stats-cum-secs-per-call statprof-display statprof-display-anomolies statprof-fetch-stacks statprof-fetch-call-tree with-statprof)) ;; This profiler tracks two numbers for every function called while ;; it's active. It tracks the total number of calls, and the number ;; of times the function was active when the sampler fired. ;; ;; Globally the profiler tracks the total time elapsed and the number ;; of times the sampler was fired. ;; ;; Right now, this profiler is not per-thread and is not thread safe. (define accumulated-time #f) ; total so far. (define last-start-time #f) ; start-time when timer is active. (define sample-count #f) ; total count of sampler calls. (define sampling-frequency #f) ; in (seconds . microseconds) (define remaining-prof-time #f) ; time remaining when prof suspended. (define profile-level 0) ; for user start/stop nesting. (define %count-calls? #t) ; whether to catch apply-frame. (define gc-time-taken 0) ; gc time between statprof-start and ; statprof-stop. (define record-full-stacks? #f) ; if #t, stash away the stacks ; for later analysis. (define stacks '()) ;; procedure-data will be a hash where the key is the function object ;; itself and the value is the data. The data will be a vector like ;; this: #(name call-count cum-sample-count self-sample-count) (define procedure-data #f) ;; If you change the call-data data structure, you need to also change ;; sample-uncount-frame. (define (make-call-data name call-count cum-sample-count self-sample-count) (vector (or name (error "internal error (we don't count anonymous procs)")) call-count cum-sample-count self-sample-count)) (define (call-data-name cd) (vector-ref cd 0)) (define (call-data-call-count cd) (vector-ref cd 1)) (define (call-data-cum-sample-count cd) (vector-ref cd 2)) (define (call-data-self-sample-count cd) (vector-ref cd 3)) (define (set-call-data-name! cd name) (vector-set! cd 0 name)) (define (inc-call-data-call-count! cd) (vector-set! cd 1 (1+ (vector-ref cd 1)))) (define (inc-call-data-cum-sample-count! cd) (vector-set! cd 2 (1+ (vector-ref cd 2)))) (define (inc-call-data-self-sample-count! cd) (vector-set! cd 3 (1+ (vector-ref cd 3)))) (define-macro (accumulate-time stop-time) `(set! accumulated-time (+ accumulated-time 0.0 (- ,stop-time last-start-time)))) (define (get-call-data proc) (or (hashq-ref procedure-data proc) (let ((call-data (make-call-data (procedure-name proc) 0 0 0))) (hashq-set! procedure-data proc call-data) call-data))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; SIGPROF handler (define (sample-stack-procs stack) (let ((stacklen (stack-length stack)) (hit-count-call? #f)) (if record-full-stacks? (set! stacks (cons stack stacks))) (set! sample-count (+ sample-count 1)) ;; Now accumulate stats for the whole stack. (let loop ((frame (stack-ref stack 0)) (procs-seen (make-hash-table 13)) (self #f)) (cond ((not frame) (hash-fold (lambda (proc val accum) (inc-call-data-cum-sample-count! (get-call-data proc))) #f procs-seen) (and=> (and=> self get-call-data) inc-call-data-self-sample-count!)) ((frame-procedure frame) => (lambda (proc) (cond ((eq? proc count-call) ;; We're not supposed to be sampling count-call and ;; its sub-functions, so loop again with a clean ;; slate. (set! hit-count-call? #t) (loop (frame-previous frame) (make-hash-table 13) #f)) ((procedure-name proc) (hashq-set! procs-seen proc #t) (loop (frame-previous frame) procs-seen (or self proc))) (else (loop (frame-previous frame) procs-seen self))))) (else (loop (frame-previous frame) procs-seen self)))) hit-count-call?)) (define inside-profiler? #f) (define (profile-signal-handler sig) (set! inside-profiler? #t) ;; FIXME: with-statprof should be able to set an outer frame for the ;; stack cut (if (positive? profile-level) (let* ((stop-time (get-internal-run-time)) ;; cut down to the signal handler, then we rely on ;; knowledge of guile: it dispatches signal handlers ;; through a thunk, so cut one more procedure (stack (make-stack #t profile-signal-handler 0 1)) (inside-apply-trap? (sample-stack-procs stack))) (if (not inside-apply-trap?) (begin ;; disabling here is just a little more efficient, but ;; not necessary given inside-profiler?. We can't just ;; disable unconditionally at the top of this function ;; and eliminate inside-profiler? because it seems to ;; confuse guile wrt re-enabling the trap when ;; count-call finishes. (if %count-calls? (trap-disable 'apply-frame)) (accumulate-time stop-time))) (setitimer ITIMER_PROF 0 0 (car sampling-frequency) (cdr sampling-frequency)) (if (not inside-apply-trap?) (begin (set! last-start-time (get-internal-run-time)) (if %count-calls? (trap-enable 'apply-frame)))))) (set! inside-profiler? #f)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Count total calls. (define (count-call trap-name continuation tail) (if (not inside-profiler?) (begin (accumulate-time (get-internal-run-time)) (and=> (frame-procedure (last-stack-frame continuation)) (lambda (proc) (if (procedure-name proc) (inc-call-data-call-count! (get-call-data proc))))) (set! last-start-time (get-internal-run-time))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (statprof-active?) "Returns @code{#t} if @code{statprof-start} has been called more times than @code{statprof-stop}, @code{#f} otherwise." (positive? profile-level)) ;; Do not call this from statprof internal functions -- user only. (define (statprof-start) "Start the profiler.@code{}" ;; After some head-scratching, I don't *think* I need to mask/unmask ;; signals here, but if I'm wrong, please let me know. (set! profile-level (+ profile-level 1)) (if (= profile-level 1) (let* ((rpt remaining-prof-time) (use-rpt? (and rpt (or (positive? (car rpt)) (positive? (cdr rpt)))))) (set! remaining-prof-time #f) (set! last-start-time (get-internal-run-time)) (set! gc-time-taken (cdr (assq 'gc-time-taken (gc-stats)))) (if use-rpt? (setitimer ITIMER_PROF 0 0 (car rpt) (cdr rpt)) (setitimer ITIMER_PROF 0 0 (car sampling-frequency) (cdr sampling-frequency))) (trap-enable 'apply-frame) #t))) ;; Do not call this from statprof internal functions -- user only. (define (statprof-stop) "Stop the profiler.@code{}" ;; After some head-scratching, I don't *think* I need to mask/unmask ;; signals here, but if I'm wrong, please let me know. (set! profile-level (- profile-level 1)) (if (zero? profile-level) (begin (set! gc-time-taken (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken)) (trap-disable 'apply-frame) ;; I believe that we need to do this before getting the time ;; (unless we want to make things even more complicated). (set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0)) (accumulate-time (get-internal-run-time)) (set! last-start-time #f)))) (define (statprof-reset sample-seconds sample-microseconds count-calls? . full-stacks?) "Reset the statprof sampler interval to @var{sample-seconds} and @var{sample-microseconds}. If @var{count-calls?} is true, arrange to instrument procedure calls as well as collecting statistical profiling data. If @var{full-stacks?} is true, collect all sampled stacks into a list for later analysis. Enables traps and debugging as necessary." (if (positive? profile-level) (error "Can't reset profiler while profiler is running.")) (set! %count-calls? count-calls?) (set! accumulated-time 0) (set! last-start-time #f) (set! sample-count 0) (set! sampling-frequency (cons sample-seconds sample-microseconds)) (set! remaining-prof-time #f) (set! procedure-data (make-hash-table 131)) (if %count-calls? (begin (trap-set! apply-frame-handler count-call) (trap-enable 'traps))) (set! record-full-stacks? (and (pair? full-stacks?) (car full-stacks?))) (set! stacks '()) (debug-enable 'debug) (sigaction SIGPROF profile-signal-handler) #t) (define (statprof-fold-call-data proc init) "Fold @var{proc} over the call-data accumulated by statprof. Cannot be called while statprof is active. @var{proc} should take two arguments, @code{(@var{call-data} @var{prior-result})}. Note that a given proc-name may appear multiple times, but if it does, it represents different functions with the same name." (if (positive? profile-level) (error "Can't call statprof-fold-called while profiler is running.")) (hash-fold (lambda (key value prior-result) (proc value prior-result)) init procedure-data)) (define (statprof-proc-call-data proc) "Returns the call-data associated with @var{proc}, or @code{#f} if none is available." (if (positive? profile-level) (error "Can't call statprof-fold-called while profiler is running.")) (hashq-ref procedure-data proc)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Stats (define (statprof-call-data->stats call-data) "Returns an object of type @code{statprof-stats}." ;; returns (vector proc-name ;; %-time-in-proc ;; cum-seconds-in-proc ;; self-seconds-in-proc ;; num-calls ;; self-secs-per-call ;; total-secs-per-call) (let* ((proc-name (call-data-name call-data)) (self-samples (call-data-self-sample-count call-data)) (cum-samples (call-data-cum-sample-count call-data)) (all-samples (statprof-sample-count)) (secs-per-sample (/ (statprof-accumulated-time) (statprof-sample-count))) (num-calls (and %count-calls? (statprof-call-data-calls call-data)))) (vector proc-name (* (/ self-samples all-samples) 100.0) (* cum-samples secs-per-sample 1.0) (* self-samples secs-per-sample 1.0) num-calls (and num-calls ;; maybe we only sampled in children (if (zero? self-samples) 0.0 (/ (* self-samples secs-per-sample) 1.0 num-calls))) (and num-calls ;; cum-samples must be positive (/ (* cum-samples secs-per-sample) 1.0 num-calls))))) (define (statprof-stats-proc-name stats) (vector-ref stats 0)) (define (statprof-stats-%-time-in-proc stats) (vector-ref stats 1)) (define (statprof-stats-cum-secs-in-proc stats) (vector-ref stats 2)) (define (statprof-stats-self-secs-in-proc stats) (vector-ref stats 3)) (define (statprof-stats-calls stats) (vector-ref stats 4)) (define (statprof-stats-self-secs-per-call stats) (vector-ref stats 5)) (define (statprof-stats-cum-secs-per-call stats) (vector-ref stats 6)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (stats-sorter x y) (let ((diff (- (statprof-stats-self-secs-in-proc x) (statprof-stats-self-secs-in-proc y)))) (positive? (if (= diff 0) (- (statprof-stats-cum-secs-in-proc x) (statprof-stats-cum-secs-in-proc y)) diff)))) (define (statprof-display . port) "Displays a gprof-like summary of the statistics collected. Unless an optional @var{port} argument is passed, uses the current output port." (if (null? port) (set! port (current-output-port))) (cond ((zero? (statprof-sample-count)) (format port "No samples recorded.\n")) (else (let* ((stats-list (statprof-fold-call-data (lambda (data prior-value) (cons (statprof-call-data->stats data) prior-value)) '())) (sorted-stats (sort stats-list stats-sorter))) (define (display-stats-line stats) (if %count-calls? (format port "~6,2f ~9,2f ~9,2f ~8r ~8,2f ~8,2f " (statprof-stats-%-time-in-proc stats) (statprof-stats-cum-secs-in-proc stats) (statprof-stats-self-secs-in-proc stats) (statprof-stats-calls stats) (* 1000 (statprof-stats-self-secs-per-call stats)) (* 1000 (statprof-stats-cum-secs-per-call stats))) (format port "~6,2f ~9,2f ~9,2f " (statprof-stats-%-time-in-proc stats) (statprof-stats-cum-secs-in-proc stats) (statprof-stats-self-secs-in-proc stats))) (display (statprof-stats-proc-name stats) port) (newline port)) (if %count-calls? (begin (format port "~5a ~10a ~7a ~8a ~8a ~8a ~8@a\n" "% " "cumulative" "self" "" "self" "total" "") (format port "~5a ~9a ~8a ~8a ~8a ~8a ~8@a\n" "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "name")) (begin (format port "~5a ~10a ~7a ~8@a\n" "%" "cumulative" "self" "") (format port "~5a ~10a ~7a ~8@a\n" "time" "seconds" "seconds" "name"))) (for-each display-stats-line sorted-stats) (display "---\n" port) (simple-format #t "Sample count: ~A\n" (statprof-sample-count)) (simple-format #t "Total time: ~A seconds (~A seconds in GC)\n" (statprof-accumulated-time) (/ gc-time-taken internal-time-units-per-second)))))) (define (statprof-display-anomolies) "A sanity check that attempts to detect anomolies in statprof's statistics.@code{}" (statprof-fold-call-data (lambda (data prior-value) (if (and %count-calls? (zero? (call-data-call-count data)) (positive? (call-data-sample-count data))) (simple-format #t "==[~A ~A ~A]\n" (call-data-name data) (call-data-call-count data) (call-data-sample-count data)))) #f) (simple-format #t "Total time: ~A\n" (statprof-accumulated-time)) (simple-format #t "Sample count: ~A\n" (statprof-sample-count))) (define (statprof-accumulated-time) "Returns the time accumulated during the last statprof run.@code{}" (if (positive? profile-level) (error "Can't get accumulated time while profiler is running.")) (/ accumulated-time internal-time-units-per-second)) (define (statprof-sample-count) "Returns the number of samples taken during the last statprof run.@code{}" (if (positive? profile-level) (error "Can't get accumulated time while profiler is running.")) sample-count) (define statprof-call-data-name call-data-name) (define statprof-call-data-calls call-data-call-count) (define statprof-call-data-cum-samples call-data-cum-sample-count) (define statprof-call-data-self-samples call-data-self-sample-count) (define (statprof-fetch-stacks) "Returns a list of stacks, as they were captured since the last call to @code{statprof-reset}. Note that stacks are only collected if the @var{full-stacks?} argument to @code{statprof-reset} is true." stacks) (define procedure=? (if (false-if-exception (resolve-interface '(system base compile))) (lambda (a b) (cond ((eq? a b)) ((and ((@ (system vm program) program?) a) ((@ (system vm program) program?) b)) (eq? ((@ (system vm program) program-objcode) a) ((@ (system vm program) program-objcode) b))) ((and (closure? a) (closure? b) (procedure-source a) (procedure-source b)) (and (eq? (procedure-name a) (procedure-name b)) (equal? (procedure-source a) (procedure-source b)))) (else #f))) (lambda (a b) (cond ((eq? a b)) ((and (closure? a) (closure? b) (procedure-source a) (procedure-source b)) (and (eq? (procedure-name a) (procedure-name b)) (equal? (procedure-source a) (procedure-source b)))) (else #f))))) ;; tree ::= (car n . tree*) (define (lists->trees lists equal?) (let lp ((in lists) (n-terminal 0) (tails '())) (cond ((null? in) (let ((trees (map (lambda (tail) (cons (car tail) (lists->trees (cdr tail) equal?))) tails))) (cons (apply + n-terminal (map cadr trees)) (sort trees (lambda (a b) (> (cadr a) (cadr b))))))) ((null? (car in)) (lp (cdr in) (1+ n-terminal) tails)) ((find (lambda (x) (equal? (car x) (caar in))) tails) => (lambda (tail) (lp (cdr in) n-terminal (assq-set! tails (car tail) (cons (cdar in) (cdr tail)))))) (else (lp (cdr in) n-terminal (acons (caar in) (list (cdar in)) tails)))))) (define (stack->procedures stack) (filter identity (unfold-right (lambda (x) (not x)) frame-procedure frame-previous (stack-ref stack 0)))) (define (statprof-fetch-call-tree) "Return a call tree for the previous statprof run. The return value is a list of nodes, each of which is of the type: @code node ::= (@var{proc} @var{count} . @var{nodes}) @end code" (cons #t (lists->trees (map stack->procedures stacks) procedure=?))) (define-macro-with-docs (with-statprof . args) "Profiles the expressions in its body. Keyword arguments: @table @code @item #:loop Execute the body @var{loop} number of times, or @code{#f} for no looping default: @code{#f} @item #:hz Sampling rate default: @code{20} @item #:count-calls? Whether to instrument each function call (expensive) default: @code{#f} @item #:full-stacks? Whether to collect away all sampled stacks into a list default: @code{#f} @end table" (define (kw-arg-ref kw args def) (cond ((null? args) (error "Invalid macro body")) ((keyword? (car args)) (if (eq? (car args) kw) (cadr args) (kw-arg-ref kw (cddr args) def))) ((eq? kw #f def) ;; asking for the body args) (else def))) ;; kw not found (let ((loop (kw-arg-ref #:loop args #f)) (hz (kw-arg-ref #:hz args 20)) (count-calls? (kw-arg-ref #:count-calls? args #f)) (full-stacks? (kw-arg-ref #:full-stacks? args #f)) (body (kw-arg-ref #f args #f))) `(dynamic-wind (lambda () (statprof-reset (inexact->exact (floor (/ 1 ,hz))) (inexact->exact (* 1e6 (- (/ 1 ,hz) (floor (/ 1 ,hz))))) ,count-calls? ,full-stacks?) (statprof-start)) (lambda () ,(if loop (let ((lp (gensym "statprof ")) (x (gensym))) `(let ,lp ((,x ,loop)) (if (not (zero? ,x)) (begin ,@body (,lp (1- ,x)))))) `(begin ,@body))) (lambda () (statprof-stop) (statprof-display) (set! (@@ (statprof) procedure-data) #f))))) ;;; arch-tag: 83969178-b576-4c52-a31c-6a9c2be85d10 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/math/���������������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�012114� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/math/primes.scm�����������������������������������������������������������������0000664�0000764�0000764�00000023067�11436627024�014056� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (math primes) -- factorization, prime test, and generation ;; Copyright (C) 1991, 1992, 1993, 1998, 2010 Aubrey Jaffer ;; Permission to copy this software, to modify it, to redistribute it, ;; to distribute modified versions, and to use it for any purpose is ;; granted, subject to the following restrictions and understandings. ;; ;; 1. Any copy made of this software must include this copyright notice ;; in full. ;; ;; 2. I have made no warranty or representation that the operation of ;; this software will be error-free, and I am under no obligation to ;; provide any services, by way of maintenance, update, or otherwise. ;; ;; 3. In conjunction with products arising from the use of this ;; material, there shall be no use of my name in any advertising, ;; promotional, or sales literature without prior written consent in ;; each case. ;;; Commentary: ;; ;; @cindex prime number ;; @cindex numbers, prime ;; @cindex numbers, prime factors of ;; @cindex prime factors ;; @cindex factors, prime ;; This module defines functions related to prime numbers, and prime factorization. ;; ;;; Code: (define-module (math primes) #:use-module (scheme documentation) #:export (prime:trials prime? prime> primes> prime< primes< factor)) ;;@body ;;@0 is the random-state (@pxref{Random Numbers}) used by these ;;procedures. If you call these procedures from more than one thread ;;(or from interrupt), @code{random} may complain about reentrant ;;calls. (define prime:prngs (seed->random-state "repeatable seed for primes")) ;;@emph{Note:} The prime test and generation procedures implement (or ;;use) the Solovay-Strassen primality test. See ;; ;;@itemize @bullet ;;@item Robert Solovay and Volker Strassen, ;;@cite{A Fast Monte-Carlo Test for Primality}, ;;SIAM Journal on Computing, 1977, pp 84-85. ;;@end itemize ;;; Solovay-Strassen Prime Test ;;; if n is prime, then J(a,n) is congruent mod n to a**((n-1)/2) ;;; (modulo p 16) is because we care only about the low order bits. ;;; The odd? tests are inline of (expt -1 ...) ;;@args p q ;;Returns the value (+1, @minus{}1, or 0) of the Jacobi-Symbol of ;;exact non-negative integer @1 and exact positive odd integer @2. (define (prime:jacobi-symbol p q) (cond ((zero? p) 0) ((= 1 p) 1) ((odd? p) (if (odd? (quotient (* (- (modulo p 16) 1) (- q 1)) 4)) (- (prime:jacobi-symbol (modulo q p) p)) (prime:jacobi-symbol (modulo q p) p))) (else (let ((qq (modulo q 16))) (if (odd? (quotient (- (* qq qq) 1) 8)) (- (prime:jacobi-symbol (quotient p 2) q)) (prime:jacobi-symbol (quotient p 2) q)))))) (define-with-docs prime:trials "This is the maximum number of iterations of Solovay-Strassen that will be done to test a number for primality. The chance of error (a composite being labelled prime) is @code{(expt 2 (- prime:trials))}." 30) ;;; checks if n is prime. Returns #f if not prime. #t if (probably) prime. ;;; probability of a mistake = (expt 2 (- prime:trials)) ;;; choosing prime:trials=30 should be enough (define (Solovay-Strassen-prime? n) (do ((i prime:trials (- i 1)) (a (+ 2 (random (- n 2) prime:prngs)) (+ 2 (random (- n 2) prime:prngs)))) ((not (and (positive? i) (= (gcd a n) 1) (= (modulo (prime:jacobi-symbol a n) n) (modulo-expt a (quotient (- n 1) 2) n)))) (if (positive? i) #f #t)))) ;;; prime:products are products of small primes. ;;; was (comlist:notevery (lambda (prd) (= 1 (gcd n prd))) comps)) (define (primes-gcd? n comps) (not (let mapf ((lst comps)) (or (null? lst) (and (= 1 (gcd n (car lst))) (mapf (cdr lst))))))) (define prime:prime-sqr 121) (define prime:products '(105)) (define prime:sieve #*00110101000) (letrec ((lp (lambda (comp comps primes nexp) (cond ((< comp (quotient most-positive-fixnum nexp)) (let ((ncomp (* nexp comp))) (lp ncomp comps (cons nexp primes) (next-prime nexp (cons ncomp comps))))) ((< (quotient comp nexp) (* nexp nexp)) (set! prime:prime-sqr (* nexp nexp)) (set! prime:sieve (make-bitvector nexp #f)) (for-each (lambda (prime) (bitvector-set! prime:sieve prime #t)) primes) (set! prime:products (reverse (cons comp comps)))) (else (lp nexp (cons comp comps) (cons nexp primes) (next-prime nexp (cons comp comps))))))) (next-prime (lambda (nexp comps) (set! comps (reverse comps)) (do ((nexp (+ 2 nexp) (+ 2 nexp))) ((not (primes-gcd? nexp comps)) nexp))))) (lp 3 '() '(2 3) 5)) (define (prime? n) "Returns @code{#f} if @var{n} is composite, and @code{t} if it is prime. There is a slight chance, @code{(expt 2 (- prime:trials))}, that a composite will return @code{#t}." (set! n (abs n)) (cond ((< n (bitvector-length prime:sieve)) (bitvector-ref prime:sieve n)) ((even? n) #f) ((primes-gcd? n prime:products) #f) ((< n prime:prime-sqr) #t) (else (Solovay-Strassen-prime? n)))) (define (prime< start) "Return the first prime number less than @var{start}. It doesn't matter if @var{start} is prime or composite. If no primes are less than @var{start}, @code{#f} will be returned." (do ((nbr (+ -1 start) (+ -1 nbr))) ((or (negative? nbr) (prime? nbr)) (if (negative? nbr) #f nbr)))) (define (primes< start count) "Returns a list of the first @var{count} prime numbers less than @var{start}. If there are fewer than @var{count} prime numbers less than @var{start}, then the returned list will have fewer than @var{start} elements." (do ((cnt (+ -2 count) (+ -1 cnt)) (lst '() (cons prime lst)) (prime (prime< start) (prime< prime))) ((or (not prime) (negative? cnt)) (if prime (cons prime lst) lst)))) (define (prime> start) "Return the first prime number greater than @var{start}. It doesn't matter if @var{start} is prime or composite." (do ((nbr (+ 1 start) (+ 1 nbr))) ((prime? nbr) nbr))) (define (primes> start count) "Returns a list of the first @var{count} prime numbers greater than @var{start}." (set! start (max 0 start)) (do ((cnt (+ -2 count) (+ -1 cnt)) (lst '() (cons prime lst)) (prime (prime> start) (prime> prime))) ((negative? cnt) (reverse (cons prime lst))))) ;;;;Lankinen's recursive factoring algorithm: ;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler) ; | undefined if n<0, ; | (u,v) if n=0, ;Let f(u,v,b,n) := | [otherwise] ; | f(u+b,v,2b,(n-v)/2) or f(u,v+b,2b,(n-u)/2) if n odd ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m. ;It may be illuminating to consider the relation of the Lankinen function in ;a `computational hierarchy' of other factoring functions.* Assumptions are ;made herein on the basis of conventional digital (binary) computers. Also, ;complexity orders are given for the worst case scenarios (when the number to ;be factored is prime). However, all algorithms would probably perform to ;the same constant multiple of the given orders for complete composite ;factorizations. ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and ; O(n*log2(n)) in space. ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime ; number thm), requiring an array of size proportional to n with log2(n) ; space for each entry. ;Thm: `Odd factors' is O((sqrt(n)/2)*log2(n)) in time and O(log2(n)) in ; space. ;Pf: It tests all odd factors less than the square root of n (about ; sqrt(n)/2), with log2(n) time for each division. It requires only ; log2(n) space for the number and divisors. ;Thm: Lankinen's algorithm is O(sqrt(n)/2) in time and O((sqrt(n)/2)*log2(n)) ; in space. ;Pf: The algorithm is easily modified to seach only for factors p<q for all ; pq=m. Then the recursive call tree forms a geometric progression ; starting at one, and doubling until reaching sqrt(n)/2, or a length of ; log2(sqrt(n)/2). From the formula for a geometric progression, there is ; a total of about 2^log2(sqrt(n)/2) = sqrt(n)/2 calls. Assuming that ; addition, subtraction, comparison, and multiplication/division by two ; occur in constant time, this implies O(sqrt(n)/2) time and a ; O((sqrt(n)/2)*log2(n)) requirement of stack space. (define (prime:f u v b n) (if (<= n 0) (cond ((negative? n) #f) ((= u 1) #f) ((= v 1) #f) ; Do both of these factors need to be factored? (else (append (or (prime:f 1 1 2 (quotient (- u 1) 2)) (list u)) (or (prime:f 1 1 2 (quotient (- v 1) 2)) (list v))))) (if (even? n) (or (prime:f u v (+ b b) (quotient n 2)) (prime:f (+ u b) (+ v b) (+ b b) (quotient (- n (+ u v b)) 2))) (or (prime:f (+ u b) v (+ b b) (quotient (- n v) 2)) (prime:f u (+ v b) (+ b b) (quotient (- n u) 2)))))) (define (prime:fo m) (let* ((s (gcd m (car prime:products))) (r (quotient m s))) (if (= 1 s) (or (prime:f 1 1 2 (quotient (- m 1) 2)) (list m)) (append (if (= 1 r) '() (or (prime:f 1 1 2 (quotient (- r 1) 2)) (list r))) (or (prime:f 1 1 2 (quotient (- s 1) 2)) (list s)))))) (define (prime:fe m) (if (even? m) (cons 2 (prime:fe (quotient m 2))) (if (eqv? 1 m) '() (prime:fo m)))) (define (factor k) "Returns a list of the prime factors of @var{k}. The order of the factors is unspecified. In order to obtain a sorted list do @code{(sort! (factor @var{k}) <)}." (case k ((-1 0 1) (list k)) (else (if (negative? k) (cons -1 (prime:fe (- k))) (prime:fe k))))) ;;; arch-tag: e78db5b0-6694-487e-af31-d9fd33274052 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/math/minima.scm�����������������������������������������������������������������0000664�0000764�0000764�00000011513�11137623114�014014� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (math minima) -- finding minima in mathematical functions ;; Copyright (C) 2003 Richard Todd ;; Based on code placed into the public domain by Lars Arvestad. ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; @cindex golden section ;; @cindex section, golden ;; @cindex minimum, of a mathematical function ;; ;; This module contains functions for computing the minimum values of mathematical ;; expressions on an interval. ;;; Code: (define-module (math minima) #:use-module (scheme documentation) #:export (golden-section-search)) (define-with-docs golden-section-search "The Golden Section Search algorithm finds minima of functions which are expensive to compute or for which derivatives are not available. Although optimum for the general case, convergence is slow, requiring nearly 100 iterations for the example (x^3-2x-5). If the derivative is available, Newton-Raphson is probably a better choice. If the function is inexpensive to compute, consider approximating the derivative. @var{x0} and @var{x1} are real numbers. The (single argument) procedure @var{func} is unimodal over the open interval (@var{x0}, @var{x1}). That is, there is exactly one point in the interval for which the derivative of @var{func} is zero. It returns a pair (@var{x} . @var{func}(@var{x})) where @var{func}(@var{x}) is the minimum. The @var{prec} parameter is the stop criterion. If @var{prec} is a positive number, then the iteration continues until @var{x} is within @var{prec} from the true value. If @var{prec} is a negative integer, then the procedure will iterate @var{-prec} times or until convergence. If @var{prec} is a procedure of seven arguments, @var{x0}, @var{x1}, @var{a}, @var{b}, @var{fa}, @var{fb}, and @var{count}, then the iterations will stop when the procedure returns @code{#t}. Analytically, the minimum of x^3-2x-5 is 0.816497. @example (define func (lambda (x) (+ (* x (+ (* x x) -2)) -5))) (golden-section-search func 0 1 (/ 10000)) ==> (816.4883855245578e-3 . -6.0886621077391165) (golden-section-search func 0 1 -5) ==> (819.6601125010515e-3 . -6.088637561916407) (golden-section-search func 0 1 (lambda (a b c d e f g ) (= g 500))) ==> (816.4965933140557e-3 . -6.088662107903635) @end example" (let ((gss 'golden-section-search:) (r (/ (- (sqrt 5) 1) 2))) ; 1 / golden-section (lambda (f x0 x1 prec) (cond ((not (procedure? f)) (throw 'type-error gss 'procedure? f)) ((not (number? x0)) (throw 'type-error gss 'number? x0)) ((not (number? x1)) (throw 'type-error gss 'number? x1)) ((>= x0 x1) (throw 'type-error gss x0 'not '< x1))) (let ((stop? (cond ((procedure? prec) prec) ((number? prec) (if (>= prec 0) (lambda (x0 x1 a b fa fb count) (<= (abs (- x1 x0)) prec)) (if (integer? prec) (lambda (x0 x1 a b fa fb count) (>= count (- prec))) (throw 'type-error gss 'integer? prec)))) (else (throw 'type-error gss 'procedure? prec)))) (a0 (+ x0 (* (- x1 x0) (- 1 r)))) (b0 (+ x0 (* (- x1 x0) r))) (delta #f) (fmax #f) (fmin #f)) (let loop ((left x0) (right x1) (a a0) (b b0) (fa (f a0)) (fb (f b0)) (count 1)) (define finish (lambda (x fx) (if (> fx fmin) (warn gss fx 'not 'min (list '> fmin))) (if (and (> count 9) (or (eqv? x0 left) (eqv? x1 right))) (warn gss 'min 'not 'found)) (cons x fx))) (case count ((1) (set! fmax (max fa fb)) (set! fmin (min fa fb))) ((2) (set! fmin (min fmin fa fb)) (if (= fmax fa fb) (throw 'misc-error gss 'flat? fmax))) (else (set! fmin (min fmin fa fb)))) (cond ((stop? left right a b fa fb count) (if (< fa fb) (finish a fa) (finish b fb))) ((< fa fb) (let ((a-next (+ left (* (- b left) (- 1 r))))) (cond ((and delta (< delta (- b a))) (finish a fa)) (else (set! delta (- b a)) (loop left b a-next a (f a-next) fa (+ 1 count)))))) (else (let ((b-next (+ a (* (- right a) r)))) (cond ((and delta (< delta (- b a))) (finish b fb)) (else (set! delta (- b a)) (loop a right b b-next fb (f b-next) (+ 1 count)))))))))))) ;;; arch-tag: ceed457c-b54f-48c9-93c6-ed4210f4d82b �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/texinfo.scm���������������������������������������������������������������������0000664�0000764�0000764�00000142303�11137625353�013276� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (texinfo) -- parsing of texinfo into SXML ;; Copyright (C) 2004 Andy Wingo <wingo at pobox dot com> ;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; This file is based on SSAX's SSAX.scm. ;;; Commentary: ;; ;; @subheading Texinfo processing in scheme ;; ;; This module parses texinfo into SXML. TeX will always be the ;; processor of choice for print output, of course. However, although ;; @code{makeinfo} works well for info, its output in other formats is ;; not very customizable, and the program is not extensible as a whole. ;; This module aims to provide an extensible framework for texinfo ;; processing that integrates texinfo into the constellation of SXML ;; processing tools. ;; ;; @subheading Notes on the SXML vocabulary ;; ;; Consider the following texinfo fragment: ;; ;;@example ;; @@deffn Primitive set-car! pair value ;; This function... ;; @@end deffn ;;@end example ;; ;; Logically, the category (Primitive), name (set-car!), and arguments ;; (pair value) are ``attributes'' of the deffn, with the description as ;; the content. However, texinfo allows for @@-commands within the ;; arguments to an environment, like @code{@@deffn}, which means that ;; texinfo ``attributes'' are PCDATA. XML attributes, on the other hand, ;; are CDATA. For this reason, ``attributes'' of texinfo @@-commands are ;; called ``arguments'', and are grouped under the special element, `%'. ;; ;; Because `%' is not a valid NCName, stexinfo is a superset of SXML. In ;; the interests of interoperability, this module provides a conversion ;; function to replace the `%' with `texinfo-arguments'. ;; ;;; Code: ;; Comparison to xml output of texinfo (which is rather undocumented): ;; Doesn't conform to texinfo dtd ;; No DTD at all, in fact :-/ ;; Actually outputs valid xml, after transforming % ;; Slower (although with caching the SXML that problem can go away) ;; Doesn't parse menus (although menus are shite) ;; Args go in a dedicated element, FBOFW ;; Definitions are handled a lot better ;; Does parse comments ;; Outputs only significant line breaks (a biggie!) ;; Nodes are treated as anchors, rather than content organizers (a biggie) ;; (more book-like, less info-like) ;; TODO ;; Integration: help, indexing, plain text (define-module (texinfo) #:use-module (sxml simple) #:use-module (sxml transform) #:use-module (sxml ssax input-parse) #:use-module (scheme documentation) #:use-module (io string) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:export (call-with-file-and-dir texi-command-specs texi-command-depth texi-fragment->stexi texi->stexi stexi->sxml)) ;; Some utilities (define (parser-error port message . rest) (apply error port message rest)) (define (call-with-file-and-dir filename proc) "Call the one-argument procedure @var{proc} with an input port that reads from @var{filename}. During the dynamic extent of @var{proc}'s execution, the current directory will be @code{(dirname @var{filename})}. This is useful for parsing documents that can include files by relative path name." (let ((current-dir (getcwd))) (dynamic-wind (lambda () (chdir (dirname filename))) (lambda () (call-with-input-file (basename filename) proc)) (lambda () (chdir current-dir))))) ;; Define this version here, because (srfi srfi-11)'s definition uses ;; syntax-rules, which is really damn slow (define-macro (let*-values bindings . body) (if (null? bindings) (cons 'begin body) (apply (lambda (vars initializer) (let ((cont (cons 'let*-values (cons (cdr bindings) body)))) (cond ((not (pair? vars)) ; regular let case, a single var `(let ((,vars ,initializer)) ,cont)) ((null? (cdr vars)) ; single var, see the prev case `(let ((,(car vars) ,initializer)) ,cont)) (else ; the most generic case `(call-with-values (lambda () ,initializer) (lambda ,vars ,cont)))))) (car bindings)))) ;;======================================================================== ;; Reflection on the XML vocabulary (define-with-docs texi-command-specs "A list of (@var{name} @var{content-model} . @var{args}) @table @var @item name The name of an @@-command, as a symbol. @item content-model A symbol indicating the syntactic type of the @@-command: @table @code @item EMPTY-COMMAND No content, and no @code{@@end} is coming @item EOL-ARGS Unparsed arguments until end of line @item EOL-TEXT Parsed arguments until end of line @item INLINE-ARGS Unparsed arguments ending with @code{#\\@}} @item INLINE-TEXT Parsed arguments ending with @code{#\\@}} @item ENVIRON The tag is an environment tag, expect @code{@@end foo}. @item TABLE-ENVIRON Like ENVIRON, but with special parsing rules for its arguments. @item FRAGMENT For @code{*fragment*}, the command used for parsing fragments of texinfo documents. @end table @code{INLINE-TEXT} commands will receive their arguments within their bodies, whereas the @code{-ARGS} commands will receive them in their attribute list. @code{EOF-TEXT} receives its arguments in its body. @code{ENVIRON} commands have both: parsed arguments until the end of line, received through their attribute list, and parsed text until the @code{@@end}, received in their bodies. @code{EOF-TEXT-ARGS} receives its arguments in its attribute list, as in @code{ENVIRON}. There are four @@-commands that are treated specially. @code{@@include} is a low-level token that will not be seen by higher-level parsers, so it has no content-model. @code{@@para} is the paragraph command, which is only implicit in the texinfo source. @code{@@item} has special syntax, as noted above, and @code{@@entry} is how this parser treats @code{@@item} commands within @code{@@table}, @code{@@ftable}, and @code{@@vtable}. Also, indexing commands (@code{@@cindex}, etc.) are treated specially. Their arguments are parsed, but they are needed before entering the element so that an anchor can be inserted into the text before the index entry. @item args Named arguments to the command, in the same format as the formals for a lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS}, @code{ENVIRON}, @code{TABLE-ENVIRON} commands. @end table" '(;; Special commands (include #f) ;; this is a low-level token (para PARAGRAPH) (item ITEM) (entry ENTRY . heading) (noindent EMPTY-COMMAND) (*fragment* FRAGMENT) ;; Inline text commands (*braces* INLINE-TEXT) ;; FIXME: make me irrelevant (bold INLINE-TEXT) (sample INLINE-TEXT) (samp INLINE-TEXT) (code INLINE-TEXT) (kbd INLINE-TEXT) (key INLINE-TEXT) (var INLINE-TEXT) (env INLINE-TEXT) (file INLINE-TEXT) (command INLINE-TEXT) (option INLINE-TEXT) (dfn INLINE-TEXT) (cite INLINE-TEXT) (acro INLINE-TEXT) (url INLINE-TEXT) (email INLINE-TEXT) (emph INLINE-TEXT) (strong INLINE-TEXT) (sample INLINE-TEXT) (sc INLINE-TEXT) (titlefont INLINE-TEXT) (asis INLINE-TEXT) (b INLINE-TEXT) (i INLINE-TEXT) (r INLINE-TEXT) (sansserif INLINE-TEXT) (slanted INLINE-TEXT) (t INLINE-TEXT) ;; Inline args commands (value INLINE-ARGS . (key)) (ref INLINE-ARGS . (node #:opt name section info-file manual)) (xref INLINE-ARGS . (node #:opt name section info-file manual)) (pxref INLINE-ARGS . (node #:opt name section info-file manual)) (uref INLINE-ARGS . (url #:opt title replacement)) (anchor INLINE-ARGS . (name)) (dots INLINE-ARGS . ()) (result INLINE-ARGS . ()) (bullet INLINE-ARGS . ()) (copyright INLINE-ARGS . ()) (tie INLINE-ARGS . ()) (image INLINE-ARGS . (file #:opt width height alt-text extension)) ;; EOL args elements (node EOL-ARGS . (name #:opt next previous up)) (c EOL-ARGS . all) (comment EOL-ARGS . all) (setchapternewpage EOL-ARGS . all) (sp EOL-ARGS . all) (page EOL-ARGS . ()) (vskip EOL-ARGS . all) (syncodeindex EOL-ARGS . all) (contents EOL-ARGS . ()) (shortcontents EOL-ARGS . ()) (summarycontents EOL-ARGS . ()) (insertcopying EOL-ARGS . ()) (dircategory EOL-ARGS . (category)) (top EOL-ARGS . (title)) (printindex EOL-ARGS . (type)) ;; EOL text commands (*ENVIRON-ARGS* EOL-TEXT) (itemx EOL-TEXT) (set EOL-TEXT) (center EOL-TEXT) (title EOL-TEXT) (subtitle EOL-TEXT) (author EOL-TEXT) (chapter EOL-TEXT) (section EOL-TEXT) (appendix EOL-TEXT) (appendixsec EOL-TEXT) (unnumbered EOL-TEXT) (unnumberedsec EOL-TEXT) (subsection EOL-TEXT) (subsubsection EOL-TEXT) (appendixsubsec EOL-TEXT) (appendixsubsubsec EOL-TEXT) (unnumberedsubsec EOL-TEXT) (unnumberedsubsubsec EOL-TEXT) (chapheading EOL-TEXT) (majorheading EOL-TEXT) (heading EOL-TEXT) (subheading EOL-TEXT) (subsubheading EOL-TEXT) (deftpx EOL-TEXT-ARGS . (category name . attributes)) (defcvx EOL-TEXT-ARGS . (category class name)) (defivarx EOL-TEXT-ARGS . (class name)) (deftypeivarx EOL-TEXT-ARGS . (class data-type name)) (defopx EOL-TEXT-ARGS . (category class name . arguments)) (deftypeopx EOL-TEXT-ARGS . (category class data-type name . arguments)) (defmethodx EOL-TEXT-ARGS . (class name . arguments)) (deftypemethodx EOL-TEXT-ARGS . (class data-type name . arguments)) (defoptx EOL-TEXT-ARGS . (name)) (defvrx EOL-TEXT-ARGS . (category name)) (defvarx EOL-TEXT-ARGS . (name)) (deftypevrx EOL-TEXT-ARGS . (category data-type name)) (deftypevarx EOL-TEXT-ARGS . (data-type name)) (deffnx EOL-TEXT-ARGS . (category name . arguments)) (deftypefnx EOL-TEXT-ARGS . (category data-type name . arguments)) (defspecx EOL-TEXT-ARGS . (name . arguments)) (defmacx EOL-TEXT-ARGS . (name . arguments)) (defunx EOL-TEXT-ARGS . (name . arguments)) (deftypefunx EOL-TEXT-ARGS . (data-type name . arguments)) ;; Indexing commands (cindex INDEX . entry) (findex INDEX . entry) (vindex INDEX . entry) (kindex INDEX . entry) (pindex INDEX . entry) (tindex INDEX . entry) ;; Environment commands (those that need @end) (texinfo ENVIRON . title) (ignore ENVIRON . ()) (ifinfo ENVIRON . ()) (iftex ENVIRON . ()) (ifhtml ENVIRON . ()) (ifxml ENVIRON . ()) (ifplaintext ENVIRON . ()) (ifnotinfo ENVIRON . ()) (ifnottex ENVIRON . ()) (ifnothtml ENVIRON . ()) (ifnotxml ENVIRON . ()) (ifnotplaintext ENVIRON . ()) (titlepage ENVIRON . ()) (menu ENVIRON . ()) (direntry ENVIRON . ()) (copying ENVIRON . ()) (example ENVIRON . ()) (smallexample ENVIRON . ()) (display ENVIRON . ()) (smalldisplay ENVIRON . ()) (verbatim ENVIRON . ()) (format ENVIRON . ()) (smallformat ENVIRON . ()) (lisp ENVIRON . ()) (smalllisp ENVIRON . ()) (cartouche ENVIRON . ()) (quotation ENVIRON . ()) (deftp ENVIRON . (category name . attributes)) (defcv ENVIRON . (category class name)) (defivar ENVIRON . (class name)) (deftypeivar ENVIRON . (class data-type name)) (defop ENVIRON . (category class name . arguments)) (deftypeop ENVIRON . (category class data-type name . arguments)) (defmethod ENVIRON . (class name . arguments)) (deftypemethod ENVIRON . (class data-type name . arguments)) (defopt ENVIRON . (name)) (defvr ENVIRON . (category name)) (defvar ENVIRON . (name)) (deftypevr ENVIRON . (category data-type name)) (deftypevar ENVIRON . (data-type name)) (deffn ENVIRON . (category name . arguments)) (deftypefn ENVIRON . (category data-type name . arguments)) (defspec ENVIRON . (name . arguments)) (defmac ENVIRON . (name . arguments)) (defun ENVIRON . (name . arguments)) (deftypefun ENVIRON . (data-type name . arguments)) (table TABLE-ENVIRON . (formatter)) (itemize TABLE-ENVIRON . (formatter)) (enumerate TABLE-ENVIRON . (start)) (ftable TABLE-ENVIRON . (formatter)) (vtable TABLE-ENVIRON . (formatter)))) (define command-depths '((chapter . 1) (section . 2) (subsection . 3) (subsubsection . 4) (top . 0) (unnumbered . 1) (unnumberedsec . 2) (unnumberedsubsec . 3) (unnumberedsubsubsec . 4) (appendix . 1) (appendixsec . 2) (appendixsection . 2) (appendixsubsec . 3) (appendixsubsubsec . 4))) (define (texi-command-depth command max-depth) "Given the texinfo command @var{command}, return its nesting level, or @code{#f} if it nests too deep for @var{max-depth}. Examples: @example (texi-command-depth 'chapter 4) @result{} 1 (texi-command-depth 'top 4) @result{} 0 (texi-command-depth 'subsection 4) @result{} 3 (texi-command-depth 'appendixsubsec 4) @result{} 3 (texi-command-depth 'subsection 2) @result{} #f @end example" (let ((depth (and=> (assq command command-depths) cdr))) (and depth (<= depth max-depth) depth))) ;; The % is for arguments (define (space-significant? command) (memq command '(example smallexample verbatim lisp smalllisp menu %))) ;; Like a DTD for texinfo (define (command-spec command) (or (assq command texi-command-specs) (parser-error #f "Unknown command" command))) (define (inline-content? content) (or (eq? content 'INLINE-TEXT) (eq? content 'INLINE-ARGS))) ;;======================================================================== ;; Lower-level parsers and scanners ;; ;; They deal with primitive lexical units (Names, whitespaces, tags) and ;; with pieces of more generic productions. Most of these parsers must ;; be called in appropriate context. For example, complete-start-command ;; must be called only when the @-command start has been detected and ;; its name token has been read. ;; Test if a string is made of only whitespace ;; An empty string is considered made of whitespace as well (define (string-whitespace? str) (or (string-null? str) (string-every char-whitespace? str))) ;; Like read-text-line, but allows EOF. (define read-eof-breaks '(*eof* #\return #\newline)) (define (read-eof-line port) (if (eof-object? (peek-char port)) (peek-char port) (let* ((line (next-token '() read-eof-breaks "reading a line" port)) (c (read-char port))) ; must be either \n or \r or EOF (if (and (eq? c #\return) (eq? (peek-char port) #\newline)) (read-char port)) ; skip \n that follows \r line))) (define ascii->char integer->char) (define (skip-whitespace port) (skip-while '(#\space #\tab #\return #\newline) port)) (define (skip-horizontal-whitespace port) (skip-while '(#\space #\tab) port)) ;; command ::= Letter+ ;; procedure: read-command PORT ;; ;; Read a command starting from the current position in the PORT and ;; return it as a symbol. (define (read-command port) (let ((first-char (peek-char port))) (or (char-alphabetic? first-char) (parser-error port "Nonalphabetic @-command char: '" first-char "'"))) (string->symbol (next-token-of (lambda (c) (cond ((eof-object? c) #f) ((char-alphabetic? c) c) (else #f))) port))) ;; A token is a primitive lexical unit. It is a record with two fields, ;; token-head and token-kind. ;; ;; Token types: ;; END The end of a texinfo command. If the command is ended by }, ;; token-head will be #f. Otherwise if the command is ended by ;; @end COMMAND, token-head will be COMMAND. As a special case, ;; @bye is the end of a special @texinfo command. ;; START The start of a texinfo command. The token-head will be a ;; symbol of the @-command name. ;; INCLUDE An @include directive. The token-head will be empty -- the ;; caller is responsible for reading the include file name. ;; ITEM @item commands have an irregular syntax. They end at the ;; next @item, or at the end of the environment. For that ;; read-command-token treats them specially. (define (make-token kind head) (cons kind head)) (define token? pair?) (define token-kind car) (define token-head cdr) ;; procedure: read-command-token PORT ;; ;; This procedure starts parsing of a command token. The current ;; position in the stream must be #\@. This procedure scans enough of ;; the input stream to figure out what kind of a command token it is ;; seeing. The procedure returns a token structure describing the token. (define (read-command-token port) (assert-curr-char '(#\@) "start of the command" port) (let ((peeked (peek-char port))) (cond ((memq peeked '(#\! #\. #\? #\@ #\\ #\{ #\})) ;; @-commands that escape characters (make-token 'STRING (string (read-char port)))) (else (let ((name (read-command port))) (case name ((end) ;; got an ending tag (let ((command (string-trim-both (read-eof-line port)))) (or (and (not (string-null? command)) (string-every char-alphabetic? command)) (parser-error port "malformed @end" command)) (make-token 'END (string->symbol command)))) ((bye) ;; the end of the top (make-token 'END 'texinfo)) ((item) (make-token 'ITEM 'item)) ((include) (make-token 'INCLUDE #f)) (else (make-token 'START name)))))))) ;; procedure+: read-verbatim-body PORT STR-HANDLER SEED ;; ;; This procedure must be called after we have read a string ;; "@verbatim\n" that begins a verbatim section. The current position ;; must be the first position of the verbatim body. This function reads ;; _lines_ of the verbatim body and passes them to a STR-HANDLER, a ;; character data consumer. ;; ;; The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED. ;; The first STRING1 argument to STR-HANDLER never contains a newline. ;; The second STRING2 argument often will. On the first invocation of the ;; STR-HANDLER, the seed is the one passed to read-verbatim-body ;; as the third argument. The result of this first invocation will be ;; passed as the seed argument to the second invocation of the line ;; consumer, and so on. The result of the last invocation of the ;; STR-HANDLER is returned by the read-verbatim-body. Note a ;; similarity to the fundamental 'fold' iterator. ;; ;; Within a verbatim section all characters are taken at their face ;; value. It ends with "\n@end verbatim(\r)?\n". ;; Must be called right after the newline after @verbatim. (define (read-verbatim-body port str-handler seed) (let loop ((seed seed)) (let ((fragment (next-token '() '(#\newline) "reading verbatim" port))) ;; We're reading the char after the 'fragment', which is ;; #\newline. (read-char port) (if (string=? fragment "@end verbatim") seed (loop (str-handler fragment "\n" seed)))))) ;; procedure+: read-arguments PORT ;; ;; This procedure reads and parses a production ArgumentList. ;; ArgumentList ::= S* Argument (S* , S* Argument)* S* ;; Argument ::= ([^@{},])* ;; ;; Arguments are the things in braces, i.e @ref{my node} has one ;; argument, "my node". Most commands taking braces actually don't have ;; arguments, they process text. For example, in ;; @emph{@strong{emphasized}}, the emph takes text, because the parse ;; continues into the braces. ;; ;; Any whitespace within Argument is replaced with a single space. ;; Whitespace around an Argument is trimmed. ;; ;; The procedure returns a list of arguments. Afterwards the current ;; character will be after the final #\}. (define (read-arguments port stop-char) (define (split str) (read-char port) ;; eat the delimiter (let ((ret (map (lambda (x) (if (string-null? x) #f x)) (map string-trim-both (string-split str #\,))))) (if (and (pair? ret) (eq? (car ret) #f) (null? (cdr ret))) '() ret))) (split (next-token '() (list stop-char) "arguments of @-command" port))) ;; procedure+: complete-start-command COMMAND PORT ;; ;; This procedure is to complete parsing of an @-command. The procedure ;; must be called after the command token has been read. COMMAND is a ;; TAG-NAME. ;; ;; This procedure returns several values: ;; COMMAND: a symbol. ;; ARGUMENTS: command's arguments, as an alist. ;; CONTENT-MODEL: the content model of the command. ;; ;; On exit, the current position in PORT will depend on the CONTENT-MODEL. ;; ;; Content model Port position ;; ============= ============= ;; INLINE-TEXT One character after the #\{. ;; INLINE-ARGS The first character after the #\}. ;; EOL-TEXT The first non-whitespace character after the command. ;; ENVIRON, TABLE-ENVIRON, EOL-ARGS, EOL-TEXT ;; The first character on the next line. ;; PARAGRAPH, ITEM, EMPTY-COMMAND ;; The first character after the command. (define (arguments->attlist port args arg-names) (let loop ((in args) (names arg-names) (opt? #f) (out '())) (cond ((symbol? names) ;; a rest arg (reverse (if (null? in) out (acons names in out)))) ((and (not (null? names)) (eq? (car names) #:opt)) (loop in (cdr names) #t out)) ((null? in) (if (or (null? names) opt?) (reverse out) (parser-error port "@-command expected more arguments:" args arg-names names))) ((null? names) (parser-error port "@-command didn't expect more arguments:" in)) ((not (car in)) (or (and opt? (loop (cdr in) (cdr names) opt? out)) (parser-error "@-command missing required argument" (car names)))) (else (loop (cdr in) (cdr names) opt? (cons (list (car names) (car in)) out)))))) (define (parse-table-args command port) (let* ((line (string-trim-both (read-text-line port))) (length (string-length line))) (define (get-formatter) (or (and (not (zero? length)) (eq? (string-ref line 0) #\@) (let ((f (string->symbol (substring line 1)))) (or (inline-content? (cadr (command-spec f))) (parser-error port "@item formatter must be INLINE" f)) f)) (parser-error "Invalid @item formatter" line))) (case command ((enumerate) (if (zero? length) '() `((start ,(if (or (and (eq? length 1) (char-alphabetic? (string-ref line 0))) (string-every char-numeric? line)) line (parser-error port "Invalid enumerate start" line)))))) ((itemize) `((bullet ,(or (and (eq? length 1) line) (and (string-null? line) '(bullet)) (list (get-formatter)))))) (else ;; tables of various varieties `((formatter (,(get-formatter)))))))) (define (complete-start-command command port) (define (get-arguments type arg-names stop-char) (arguments->attlist port (read-arguments port stop-char) arg-names)) (let* ((spec (command-spec command)) (type (cadr spec)) (arg-names (cddr spec))) (case type ((INLINE-TEXT) (assert-curr-char '(#\{) "Inline element lacks {" port) (values command '() type)) ((INLINE-ARGS) (assert-curr-char '(#\{) "Inline element lacks {" port) (values command (get-arguments type arg-names #\}) type)) ((EOL-ARGS) (values command (get-arguments type arg-names #\newline) type)) ((ENVIRON ENTRY INDEX) (skip-horizontal-whitespace port) (values command (parse-environment-args command port) type)) ((TABLE-ENVIRON) (skip-horizontal-whitespace port) (values command (parse-table-args command port) type)) ((EOL-TEXT) (skip-horizontal-whitespace port) (values command '() type)) ((EOL-TEXT-ARGS) (skip-horizontal-whitespace port) (values command (parse-eol-text-args command port) type)) ((PARAGRAPH EMPTY-COMMAND ITEM FRAGMENT) (values command '() type)) (else ;; INCLUDE shouldn't get here (parser-error port "can't happen"))))) ;;----------------------------------------------------------------------------- ;; Higher-level parsers and scanners ;; ;; They parse productions corresponding entire @-commands. ;; Only reads @settitle, leaves it to the command parser to finish ;; reading the title. (define (take-until-settitle port) (or (find-string-from-port? "\n@settitle " port) (parser-error port "No \\n@settitle found")) (skip-horizontal-whitespace port) (and (eq? (peek-char port) #\newline) (parser-error port "You have a @settitle, but no title"))) ;; procedure+: read-char-data PORT EXPECT-EOF? STR-HANDLER SEED ;; ;; This procedure is to read the CharData of a texinfo document. ;; ;; text ::= (CharData | Command)* ;; ;; The procedure reads CharData and stops at @-commands (or ;; environments). It also stops at an open or close brace. ;; ;; port ;; a PORT to read ;; expect-eof? ;; a boolean indicating if EOF is normal, i.e., the character ;; data may be terminated by the EOF. EOF is normal ;; while processing the main document. ;; preserve-ws? ;; a boolean indicating if we are within a whitespace-preserving ;; environment. If #t, suppress paragraph detection. ;; str-handler ;; a STR-HANDLER, see read-verbatim-body ;; seed ;; an argument passed to the first invocation of STR-HANDLER. ;; ;; The procedure returns two results: SEED and TOKEN. The SEED is the ;; result of the last invocation of STR-HANDLER, or the original seed if ;; STR-HANDLER was never called. ;; ;; TOKEN can be either an eof-object (this can happen only if expect-eof? ;; was #t), or a texinfo token denoting the start or end of a tag. ;; read-char-data port expect-eof? preserve-ws? str-handler seed (define read-char-data (let* ((end-chars-eof '(*eof* #\{ #\} #\@ #\newline))) (define (handle str-handler str1 str2 seed) (if (and (string-null? str1) (string-null? str2)) seed (str-handler str1 str2 seed))) (lambda (port expect-eof? preserve-ws? str-handler seed) (let ((end-chars ((if expect-eof? identity cdr) end-chars-eof))) (let loop ((seed seed)) (let* ((fragment (next-token '() end-chars "reading char data" port)) (term-char (peek-char port))) ; one of end-chars (cond ((eof-object? term-char) ; only if expect-eof? (values (handle str-handler fragment "" seed) term-char)) ((memq term-char '(#\@ #\{ #\})) (values (handle str-handler fragment "" seed) (case term-char ((#\@) (read-command-token port)) ((#\{) (make-token 'START '*braces*)) ((#\}) (read-char port) (make-token 'END #f))))) ((eq? term-char #\newline) ;; Always significant, unless directly before an end token. (let ((c (peek-next-char port))) (cond ((eof-object? c) (or expect-eof? (parser-error port "EOF while reading char data")) (values (handle str-handler fragment "" seed) c)) ((eq? c #\@) (let* ((token (read-command-token port)) (end? (eq? (token-kind token) 'END))) (values (handle str-handler fragment (if end? "" " ") seed) token))) ((and (not preserve-ws?) (eq? c #\newline)) ;; paragraph-separator ::= #\newline #\newline+ (skip-while '(#\newline) port) (skip-horizontal-whitespace port) (values (handle str-handler fragment "" seed) (make-token 'PARA 'para))) (else (loop (handle str-handler fragment (if preserve-ws? "\n" " ") seed))))))))))))) ; procedure+: assert-token TOKEN KIND NAME ; Make sure that TOKEN is of anticipated KIND and has anticipated NAME (define (assert-token token kind name) (or (and (token? token) (eq? kind (token-kind token)) (equal? name (token-head token))) (parser-error #f "Expecting @end for " name ", got " token))) ;;======================================================================== ;; Highest-level parsers: Texinfo to SXML ;; These parsers are a set of syntactic forms to instantiate a SSAX ;; parser. The user tells what to do with the parsed character and ;; element data. These latter handlers determine if the parsing follows a ;; SAX or a DOM model. ;; syntax: make-command-parser fdown fup str-handler ;; Create a parser to parse and process one element, including its ;; character content or children elements. The parser is typically ;; applied to the root element of a document. ;; fdown ;; procedure COMMAND ARGUMENTS EXPECTED-CONTENT SEED ;; ;; This procedure is to generate the seed to be passed to handlers ;; that process the content of the element. This is the function ;; identified as 'fdown' in the denotational semantics of the XML ;; parser given in the title comments to (sxml ssax). ;; ;; fup ;; procedure COMMAND ARGUMENTS PARENT-SEED SEED ;; ;; This procedure is called when parsing of COMMAND is finished. ;; The SEED is the result from the last content parser (or from ;; fdown if the element has the empty content). PARENT-SEED is the ;; same seed as was passed to fdown. The procedure is to generate a ;; seed that will be the result of the element parser. This is the ;; function identified as 'fup' in the denotational semantics of ;; the XML parser given in the title comments to (sxml ssax). ;; ;; str-handler ;; A STR-HANDLER, see read-verbatim-body ;; ;; The generated parser is a ;; procedure COMMAND PORT SEED ;; ;; The procedure must be called *after* the command token has been read. (define (read-include-file-name port) (let ((x (string-trim-both (read-eof-line port)))) (if (string-null? x) (error "no file listed") x))) ;; fixme: should expand @value{} references (define (sxml->node-name sxml) "Turn some sxml string into a valid node name." (let loop ((in (string->list (sxml->string sxml))) (out '())) (if (null? in) (apply string (reverse out)) (if (memq (car in) '(#\{ #\} #\@ #\,)) (loop (cdr in) out) (loop (cdr in) (cons (car in) out)))))) (define (index command arguments fdown fup parent-seed) (case command ((deftp defcv defivar deftypeivar defop deftypeop defmethod deftypemethod defopt defvr defvar deftypevr deftypevar deffn deftypefn defspec defmac defun deftypefun) (let ((args `((name ,(string-append (symbol->string command) "-" (cadr (assq 'name arguments))))))) (fup 'anchor args parent-seed (fdown 'anchor args 'INLINE-ARGS '())))) ((cindex findex vindex kindex pindex tindex) (let ((args `((name ,(string-append (symbol->string command) "-" (sxml->node-name (assq 'entry arguments))))))) (fup 'anchor args parent-seed (fdown 'anchor args 'INLINE-ARGS '())))) (else parent-seed))) (define (make-command-parser fdown fup str-handler) (lambda (command port seed) (let visit ((command command) (port port) (sig-ws? #f) (parent-seed seed)) (let*-values (((command arguments expected-content) (complete-start-command command port))) (let* ((parent-seed (index command arguments fdown fup parent-seed)) (seed (fdown command arguments expected-content parent-seed)) (eof-closes? (or (memq command '(texinfo para *fragment*)) (eq? expected-content 'EOL-TEXT))) (sig-ws? (or sig-ws? (space-significant? command))) (up (lambda (s) (fup command arguments parent-seed s))) (new-para (lambda (s) (fdown 'para '() 'PARAGRAPH s))) (make-end-para (lambda (p) (lambda (s) (fup 'para '() p s))))) (define (port-for-content) (if (eq? expected-content 'EOL-TEXT) (call-with-input-string (read-text-line port) identity) port)) (cond ((memq expected-content '(EMPTY-COMMAND INLINE-ARGS EOL-ARGS INDEX EOL-TEXT-ARGS)) ;; empty or finished by complete-start-command (up seed)) ((eq? command 'verbatim) (up (read-verbatim-body port str-handler seed))) (else (let loop ((port (port-for-content)) (expect-eof? eof-closes?) (end-para identity) (need-break? (and (not sig-ws?) (memq expected-content '(ENVIRON TABLE-ENVIRON ENTRY ITEM FRAGMENT)))) (seed seed)) (cond ((and need-break? (or sig-ws? (skip-whitespace port)) (not (memq (peek-char port) '(#\@ #\}))) (not (eof-object? (peek-char port)))) ;; Even if we have an @, it might be inline -- check ;; that later (let ((seed (end-para seed))) (loop port expect-eof? (make-end-para seed) #f (new-para seed)))) (else (let*-values (((seed token) (read-char-data port expect-eof? sig-ws? str-handler seed))) (cond ((eof-object? token) (case expect-eof? ((include #f) (end-para seed)) (else (up (end-para seed))))) (else (case (token-kind token) ((STRING) ;; this is only @-commands that escape ;; characters: @}, @@, @{ -- new para if need-break (let ((seed ((if need-break? end-para identity) seed))) (loop port expect-eof? (if need-break? (make-end-para seed) end-para) #f (str-handler (token-head token) "" ((if need-break? new-para identity) seed))))) ((END) ;; The end will only have a name if it's for an ;; environment (cond ((memq command '(item entry)) (let ((spec (command-spec (token-head token)))) (or (eq? (cadr spec) 'TABLE-ENVIRON) (parser-error port "@item not ended by @end table/enumerate/itemize" token)))) ((eq? expected-content 'ENVIRON) (assert-token token 'END command))) (up (end-para seed))) ((ITEM) (cond ((memq command '(enumerate itemize)) (up (visit 'item port sig-ws? (end-para seed)))) ((eq? expected-content 'TABLE-ENVIRON) (up (visit 'entry port sig-ws? (end-para seed)))) ((memq command '(item entry)) (visit command port sig-ws? (up (end-para seed)))) (else (parser-error port "@item must be within a table environment" command)))) ((PARA) ;; examine valid paragraphs? (loop port expect-eof? end-para (not sig-ws?) seed)) ((INCLUDE) ;; Recurse for include files (let ((seed (call-with-file-and-dir (read-include-file-name port) (lambda (port) (loop port 'include end-para need-break? seed))))) (loop port expect-eof? end-para need-break? seed))) ((START) ; Start of an @-command (let* ((head (token-head token)) (type (cadr (command-spec head))) (inline? (inline-content? type)) (seed ((if (and inline? (not need-break?)) identity end-para) seed)) (end-para (if inline? (if need-break? (make-end-para seed) end-para) identity)) (new-para (if (and inline? need-break?) new-para identity))) (loop port expect-eof? end-para (not inline?) (visit head port sig-ws? (new-para seed))))) (else (parser-error port "Unknown token type" token)))))))))))))))) ;; procedure: reverse-collect-str-drop-ws fragments ;; ;; Given the list of fragments (some of which are text strings), reverse ;; the list and concatenate adjacent text strings. We also drop ;; "unsignificant" whitespace, that is, whitespace in front, behind and ;; between elements. The whitespace that is included in character data ;; is not affected. (define (reverse-collect-str-drop-ws fragments) (cond ((null? fragments) ; a shortcut '()) ((and (string? (car fragments)) ; another shortcut (null? (cdr fragments)) ; remove single ws-only string (string-whitespace? (car fragments))) '()) (else (let loop ((fragments fragments) (result '()) (strs '()) (all-whitespace? #t)) (cond ((null? fragments) (if all-whitespace? result ; remove leading ws (cons (apply string-append strs) result))) ((string? (car fragments)) (loop (cdr fragments) result (cons (car fragments) strs) (and all-whitespace? (string-whitespace? (car fragments))))) (else (loop (cdr fragments) (cons (car fragments) (cond ((null? strs) result) (all-whitespace? (if (null? result) result ; remove trailing whitespace (cons " " result))); replace interstitial ws with ; one space (else (cons (apply string-append strs) result)))) '() #t))))))) (define (make-dom-parser) (make-command-parser (lambda (command args content seed) ; fdown '()) (lambda (command args parent-seed seed) ; fup (let ((seed (reverse-collect-str-drop-ws seed))) (acons command (if (null? args) seed (acons '% args seed)) parent-seed))) (lambda (string1 string2 seed) ; str-handler (if (string-null? string2) (cons string1 seed) (cons* string2 string1 seed))))) (define parse-environment-args (let ((parser (make-dom-parser))) ;; duplicate arguments->attlist to avoid unnecessary splitting (lambda (command port) (let ((args (cdar (parser '*ENVIRON-ARGS* port '()))) (arg-names (cddr (command-spec command)))) (cond ((not arg-names) (if (null? args) '() (parser-error port "@-command doesn't take args" command))) ((eq? arg-names #t) (list (cons 'arguments args))) (else (let loop ((args args) (arg-names arg-names) (out '())) (cond ((null? arg-names) (if (null? args) (reverse! out) (parser-error port "@-command didn't expect more args" command args))) ((symbol? arg-names) (reverse! (acons arg-names args out))) ((null? args) (parser-error port "@-command expects more args" command arg-names)) ((and (string? (car args)) (string-index (car args) #\space)) => (lambda (i) (let ((rest (substring/shared (car args) (1+ i)))) (if (zero? i) (loop (cons rest (cdr args)) arg-names out) (loop (cons rest (cdr args)) (cdr arg-names) (cons (list (car arg-names) (substring (car args) 0 i)) out)))))) (else (loop (cdr args) (cdr arg-names) (if (and (pair? (car args)) (eq? (caar args) '*braces*)) (acons (car arg-names) (cdar args) out) (cons (list (car arg-names) (car args)) out)))))))))))) (define (parse-eol-text-args command port) ;; perhaps parse-environment-args should be named more ;; generically. (parse-environment-args command port)) ;; procedure: texi-fragment->stexi STRING ;; ;; A DOM parser for a texinfo fragment STRING. ;; ;; The procedure returns an SXML tree headed by the special tag, ;; *fragment*. (define (texi-fragment->stexi string-or-port) "Parse the texinfo commands in @var{string-or-port}, and return the resultant stexi tree. The head of the tree will be the special command, @code{*fragment*}." (define (parse port) (postprocess (car ((make-dom-parser) '*fragment* port '())))) (if (input-port? string-or-port) (parse string-or-port) (call-with-input-string string-or-port parse))) ;; procedure: texi->stexi PORT ;; ;; This is an instance of a SSAX parser above that returns an SXML ;; representation of the texinfo document ready to be read at PORT. ;; ;; The procedure returns an SXML tree. The port points to the ;; first character after the @bye, or to the end of the file. (define (texi->stexi port) "Read a full texinfo document from @var{port} and return the parsed stexi tree. The parsing will start at the @code{@@settitle} and end at @code{@@bye} or EOF." (let ((parser (make-dom-parser))) (take-until-settitle port) (postprocess (car (parser 'texinfo port '()))))) (define (car-eq? x y) (and (pair? x) (eq? (car x) y))) (define (make-contents tree) (define (lp in out depth) (cond ((null? in) (values in (cons 'enumerate (reverse! out)))) ((and (pair? (cdr in)) (texi-command-depth (caadr in) 4)) => (lambda (new-depth) (let ((node-name (and (car-eq? (car in) 'node) (cadr (assq 'name (cdadar in)))))) (cond ((< new-depth depth) (values in (cons 'enumerate (reverse! out)))) ((> new-depth depth) (let ((out-cdr (if (null? out) '() (cdr out))) (out-car (if (null? out) (list 'item) (car out)))) (let*-values (((new-in new-out) (lp in '() (1+ depth)))) (lp new-in (cons (append out-car (list new-out)) out-cdr) depth)))) (else ;; same depth (lp (cddr in) (cons `(item (para ,@(if node-name `((ref (% (node ,node-name)))) (cdadr in)))) out) depth)))))) (else (lp (cdr in) out depth)))) (let*-values (((_ contents) (lp tree '() 1))) `((chapheading "Table of Contents") ,contents))) (define (trim-whitespace str trim-left? trim-right?) (let* ((left-space? (and (not trim-left?) (string-prefix? " " str))) (right-space? (and (not trim-right?) (string-suffix? " " str))) (tail (append! (string-tokenize str) (if right-space? '("") '())))) (string-join (if left-space? (cons "" tail) tail)))) (define (postprocess tree) (define (loop in out state first? sig-ws?) (cond ((null? in) (values (reverse! out) state)) ((string? (car in)) (loop (cdr in) (cons (if sig-ws? (car in) (trim-whitespace (car in) first? (null? (cdr in)))) out) state #f sig-ws?)) ((pair? (car in)) (case (caar in) ((set) (if (null? (cdar in)) (error "@set missing arguments" seed)) (if (string? (cadar in)) (let ((i (string-index (cadar in) #\space))) (if i (loop (cdr in) out (acons (substring (cadar in) 0 i) (cons (substring (cadar in) (1+ i)) (cddar in)) state) #f sig-ws?) (loop (cdr in) out (acons (cadar in) (cddar in) state) #f sig-ws?))) (error "expected a constant to define for @set" in))) ((value) (loop (fold-right cons (cdr in) (or (and=> (assoc (cadr (assq 'key (cdadar in))) state) cdr) (error "unknown value" (cdadar in) state))) out state #f sig-ws?)) ((copying) (loop (cdr in) out (cons (car in) state) #f sig-ws?)) ((insertcopying) (loop (fold-right cons (cdr in) (or (cdr (assoc 'copying state)) (error "copying isn't set yet"))) out state #f sig-ws?)) ((contents) (loop (cdr in) (fold cons out (make-contents tree)) state #f sig-ws?)) (else (let*-values (((kid-out state) (loop (car in) '() state #t (or sig-ws? (space-significant? (caar in)))))) (loop (cdr in) (cons kid-out out) state #f sig-ws?))))) (else ; a symbol (loop (cdr in) (cons (car in) out) state #t sig-ws?)))) (call-with-values (lambda () (loop tree '() '() #t #f)) (lambda (out state) out))) ;; Replace % with texinfo-arguments. (define (stexi->sxml tree) "Transform the stexi tree @var{tree} into sxml. This involves replacing the @code{%} element that keeps the texinfo arguments with an element for each argument. FIXME: right now it just changes % to @code{texinfo-arguments} -- that doesn't hang with the idea of making a dtd at some point" (pre-post-order tree `((% . ,(lambda (x . t) (cons 'texinfo-arguments t))) (*text* . ,(lambda (x t) t)) (*default* . ,(lambda (x . t) (cons x t)))))) ;;; arch-tag: 73890afa-597c-4264-ae70-46fe7756ffb5 ;;; texinfo.scm ends here �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/scheme/�������������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�012427� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/scheme/kwargs.scm���������������������������������������������������������������0000664�0000764�0000764�00000012366�11436604276�014374� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (scheme kwargs) -- an alternate implementation of keyword arguments ;; Copyright (C) 2003,2004,2007 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;; @c ;; Support for defining functions that take python-like keyword ;; arguments. ;; ;; In one of his early talks, Paul Graham wrote about a large system ;; called "Rtml": ;; ;; @quotation ;; ;; Most of the operators in Rtml were designed to take keyword ;; parameters, and what a help that turned out to be. If I wanted to add ;; another dimension to the behavior of one of the operators, I could ;; just add a new keyword parameter, and everyone's existing templates ;; would continue to work. A few of the Rtml operators didn't take ;; keyword parameters, because I didn't think I'd ever need to change ;; them, and almost every one I ended up kicking myself about later. If ;; I could go back and start over from scratch, one of the things I'd ;; change would be that I'd make every Rtml operator take keyword ;; parameters. ;; ;; @end quotation ;; ;; @xref{scheme kwargs lambda/kwargs,,lambda/kwargs}, for documentation ;; and examples. ;; ;; @xref{Optional Arguments,,,guile,Guile Reference Manual}, for more ;; information on Guile's standard support for optional and keyword ;; arguments. ;; ;; Quote taken from ;; @uref{http://lib.store.yahoo.net/lib/paulgraham/bbnexcerpts.txt}. ;; ;;; Code: (define-module (scheme kwargs) :use-module (ice-9 optargs) :use-module (scheme documentation) :export (lambda/kwargs define/kwargs)) (define (until pred? list) "Returns the first elements of @var{list} for which @var{pred?} is false." (if (or (eq? list '()) (pred? (car list))) '() (cons (car list) (until pred? (cdr list))))) (define-macro-with-docs (lambda/kwargs BINDINGS . BODY) "Defines a function that takes keyword arguments. @var{bindings} is a list of bindings, each of which may either be a symbol or a two-element symbol-and-default-value list. Symbols without specified default values will default to @code{#f}. For example: @example (define frobulate (lambda/kwargs (foo (bar 13) (baz 42)) (list foo bar baz))) (frobulate) @result{} (#f 13 42) (frobulate #:baz 3) @result{} (#f 13 3) (frobulate #:foo 3) @result{} (3 13 42) (frobulate 3 4) @result{} (3 4 42) (frobulate 1 2 3) @result{} (1 2 3) (frobulate #:baz 2 #:bar 1) @result{} (#f 1 2) (frobulate 10 20 #:foo 3) @result{} (3 20 42) @end example This function differs from the standard @code{lambda*} provided by Guile in that invoking the function will accept positional arguments. As an example, the @code{lambda/kwargs} behaves more intuitively in the following case: @example ((lambda* (#:optional (bar 42) #:key (baz 73)) (list bar baz)) 1 2) @result{} (1 73) ((lambda/kwargs ((bar 42) (baz 73)) (list bar baz)) 1 2) @result{} (1 2) @end example The fact that @code{lambda*} accepts the extra @samp{2} argument is probably just a bug. In any case, @code{lambda/kwargs} does the right thing. " (or (list? BINDINGS) (error "lambda/kwargs bindings must be a list")) (let ((lambda-gensym (gensym)) (args-gensym (gensym)) (positional (gensym)) (keyword (gensym)) (nbindings (length BINDINGS)) (CANONICAL-BINDINGS (map (lambda (x) (if (list? x) x (list x #f))) BINDINGS)) (VARIABLES (map (lambda (x) (if (list? x) (car x) x)) BINDINGS))) `(let ((,lambda-gensym (lambda ,args-gensym ,@(if (string? (car BODY)) (list (car BODY)) '()) (let* ((,positional ((@@ (scheme kwargs) until) keyword? ,args-gensym)) (,keyword (list-tail ,args-gensym (length ,positional)))) (if (> (length ,positional) ,nbindings) (error "Too many positional arguments.")) ((@ (ice-9 optargs) let-optional) ,positional ,CANONICAL-BINDINGS ;; ,@(map car CANONICAL-BINDINGS) ((@ (ice-9 optargs) let-keywords) ,keyword #f ,(map list VARIABLES VARIABLES) ,@(if (string? (car BODY)) (cdr BODY) BODY))))))) (set-procedure-property! ,lambda-gensym 'arglist '(() () ,CANONICAL-BINDINGS #f #f)) ,lambda-gensym))) (define-macro-with-docs (define/kwargs what . body) "Defines a function that takes kwargs. @xref{scheme kwargs lambda/kwargs}, for more information. " `(define ,(car what) ((@ (scheme kwargs) lambda/kwargs) ,(cdr what) ,@body))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/scheme/documentation.scm��������������������������������������������������������0000664�0000764�0000764�00000003604�11212576345�015737� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (scheme documentation) -- self-documentation helper macros ;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;;@c texinfo commentary ;;Defines some macros to help in documenting macros, variables, generic ;;functions, and classes. ;; ;;; Code: (define-module (scheme documentation) #:export (define-macro-with-docs define-with-docs define-generic-with-docs define-class-with-docs)) (define-macro (define-macro-with-docs name-and-args docs . body) "Define a macro with documentation." `(define-macro ,name-and-args ,docs ,@body)) (define-macro-with-docs (define-with-docs sym docs val) "Define a variable with documentation." `(begin (define ,sym ,val) (set-object-property! ,sym 'documentation ,docs) *unspecified*)) (define-macro-with-docs (define-generic-with-docs name documentation) "Define a generic function with documentation." `(define-with-docs ,name ,documentation (make-generic ',name))) (define-macro-with-docs (define-class-with-docs name supers docs . slots) "Define a class with documentation." `(begin (define-class ,name ,supers ,@slots) (set-object-property! ,name 'documentation ,docs) (if #f #f))) ;;; arch-tag: f5297a2f-bb0a-4d42-8b3b-eb712199d9a0 ����������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/text/���������������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�012147� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/text/parse-lalr.scm�������������������������������������������������������������0000664�0000764�0000764�00000154137�11140027667�014656� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (text parse-lalr) -- yacc's parser generator, in Guile ;; Copyright (C) 1984,1989,1990 Free Software Foundation, Inc. ;; Copyright (C) 1996-2002 Dominique Boucher ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; ---------------------------------------------------------------------- ;; #! ;;; Commentary: This file contains yet another LALR(1) parser generator written in Scheme. In contrast to other such parser generators, this one implements a more efficient algorithm for computing the lookahead sets. The algorithm is the same as used in Bison (GNU yacc) and is described in the following paper: "Efficient Computation of LALR(1) Look-Ahead Set", F. DeRemer and T. Pennello, TOPLAS, vol. 4, no. 4, october 1982. As a consequence, it is not written in a fully functional style. In fact, much of the code is a direct translation from C to Scheme of the Bison sources. @section Defining a parser The module @code{(text parse-lalr)} declares a macro called @code{lalr-parser}: @lisp (lalr-parser tokens rules ...) @end lisp This macro, when given appropriate arguments, generates an LALR(1) syntax analyzer. The macro accepts at least two arguments. The first is a list of symbols which represent the terminal symbols of the grammar. The remaining arguments are the grammar production rules. @section Running the parser The parser generated by the @code{lalr-parser} macro is a function that takes two parameters. The first parameter is a lexical analyzer while the second is an error procedure. The lexical analyzer is zero-argument function (a thunk) invoked each time the parser needs to look-ahead in the token stream. A token is usually a pair whose @code{car} is the symbol corresponding to the token (the same symbol as used in the grammar definition). The @code{cdr} of the pair is the semantic value associated with the token. For example, a string token would have the @code{car} set to @code{'string} while the @code{cdr} is set to the string value @code{"hello"}. Once the end of file is encountered, the lexical analyzer must always return the symbol @code{'*eoi*} each time it is invoked. The error procedure must be a function that accepts at least two parameters. @section The grammar format The grammar is specified by first giving the list of terminals and the list of non-terminal definitions. Each non-terminal definition is a list where the first element is the non-terminal and the other elements are the right-hand sides (lists of grammar symbols). In addition to this, each rhs can be followed by a semantic action. For example, consider the following (yacc) grammar for a very simple expression language: @example e : e '+' t | e '-' t | t ; t : t '*' f : t '/' f | f ; f : ID ; @end example The same grammar, written for the scheme parser generator, would look like this (with semantic actions) @lisp (define expr-parser (lalr-parser ; Terminal symbols (ID + - * /) ; Productions (e (e + t) : (+ $1 $3) (e - t) : (- $1 $3) (t) : $1) (t (t * f) : (* $1 $3) (t / f) : (/ $1 $3) (f) : $1) (f (ID) : $1))) @end lisp In semantic actions, the symbol @code{$n} refers to the synthesized attribute value of the nth symbol in the production. The value associated with the non-terminal on the left is the result of evaluating the semantic action (it defaults to @code{#f}). The above grammar implicitly handles operator precedences. It is also possible to explicitly assign precedences and associativity to terminal symbols and productions a la Yacc. Here is a modified (and augmented) version of the grammar: @lisp (define expr-parser (lalr-parser ; Terminal symbols (ID (left: + -) (left: * /) (nonassoc: uminus)) (e (e + e) : (+ $1 $3) (e - e) : (- $1 $3) (e * e) : (* $1 $3) (e / e) : (/ $1 $3) (- e (prec: uminus)) : (- $2) (ID) : $1))) @end lisp The @code{left:} directive is used to specify a set of left-associative operators of the same precedence level, the @code{right:} directive for right-associative operators, and @code{nonassoc:} for operators that are not associative. Note the use of the (apparently) useless terminal @code{uminus}. It is only defined in order to assign to the penultimate rule a precedence level higher than that of @code{*} and @code{/}. The @code{prec:} directive can only appear as the last element of a rule. Finally, note that precedence levels are incremented from left to right, i.e. the precedence level of @code{+} and @code{-} is less than the precedence level of @code{*} and @code{/} since the formers appear first in the list of terminal symbols (token definitions). @section A final note on conflict resolution Conflicts in the grammar are handled in a conventional way. In the absence of precedence directives, Shift/Reduce conflicts are resolved by shifting, and Reduce/Reduce conflicts are resolved by choosing the rule listed first in the grammar definition. You can print the states of the generated parser by evaluating @code{(print-states)}. The format of the output is similar to the one produced by bison when given the -v command-line option. ;;; Code: !# ;;; ---------- SYSTEM DEPENDENT SECTION ----------------- ;; put in a module by Richard Todd (define-module (text parse-lalr) #:use-module (scheme documentation) #:export (lalr-parser print-states)) ;; this code is by Thien-Thi Nguyen, found in a google search (begin (defmacro def-macro (form . body) `(defmacro ,(car form) ,(cdr form) ,@body)) (def-macro (BITS-PER-WORD) 28) (def-macro (lalr-error msg obj) `(throw 'lalr-error ,msg ,obj)) (def-macro (logical-or x . y) `(logior ,x ,@y))) ;;; ---------- END OF SYSTEM DEPENDENT SECTION ------------ ;; - Macros pour la gestion des vecteurs de bits (def-macro (set-bit v b) `(let ((x (quotient ,b (BITS-PER-WORD))) (y (expt 2 (remainder ,b (BITS-PER-WORD))))) (vector-set! ,v x (logical-or (vector-ref ,v x) y)))) (def-macro (bit-union v1 v2 n) `(do ((i 0 (+ i 1))) ((= i ,n)) (vector-set! ,v1 i (logical-or (vector-ref ,v1 i) (vector-ref ,v2 i))))) ;; - Macro pour les structures de donnees (def-macro (new-core) `(make-vector 4 0)) (def-macro (set-core-number! c n) `(vector-set! ,c 0 ,n)) (def-macro (set-core-acc-sym! c s) `(vector-set! ,c 1 ,s)) (def-macro (set-core-nitems! c n) `(vector-set! ,c 2 ,n)) (def-macro (set-core-items! c i) `(vector-set! ,c 3 ,i)) (def-macro (core-number c) `(vector-ref ,c 0)) (def-macro (core-acc-sym c) `(vector-ref ,c 1)) (def-macro (core-nitems c) `(vector-ref ,c 2)) (def-macro (core-items c) `(vector-ref ,c 3)) (def-macro (new-shift) `(make-vector 3 0)) (def-macro (set-shift-number! c x) `(vector-set! ,c 0 ,x)) (def-macro (set-shift-nshifts! c x) `(vector-set! ,c 1 ,x)) (def-macro (set-shift-shifts! c x) `(vector-set! ,c 2 ,x)) (def-macro (shift-number s) `(vector-ref ,s 0)) (def-macro (shift-nshifts s) `(vector-ref ,s 1)) (def-macro (shift-shifts s) `(vector-ref ,s 2)) (def-macro (new-red) `(make-vector 3 0)) (def-macro (set-red-number! c x) `(vector-set! ,c 0 ,x)) (def-macro (set-red-nreds! c x) `(vector-set! ,c 1 ,x)) (def-macro (set-red-rules! c x) `(vector-set! ,c 2 ,x)) (def-macro (red-number c) `(vector-ref ,c 0)) (def-macro (red-nreds c) `(vector-ref ,c 1)) (def-macro (red-rules c) `(vector-ref ,c 2)) (def-macro (new-set nelem) `(make-vector ,nelem 0)) (def-macro (vector-map f v) `(let ((vm-n (- (vector-length ,v) 1))) (let loop ((vm-low 0) (vm-high vm-n)) (if (= vm-low vm-high) (vector-set! ,v vm-low (,f (vector-ref ,v vm-low) vm-low)) (let ((vm-middle (quotient (+ vm-low vm-high) 2))) (loop vm-low vm-middle) (loop (+ vm-middle 1) vm-high)))))) ;; - Constantes (define STATE-TABLE-SIZE 1009) ;; - Tableaux (define rrhs #f) (define rlhs #f) (define ritem #f) (define nullable #f) (define derives #f) (define fderives #f) (define firsts #f) (define kernel-base #f) (define kernel-end #f) (define shift-symbol #f) (define shift-set #f) (define red-set #f) (define state-table #f) (define acces-symbol #f) (define reduction-table #f) (define shift-table #f) (define consistent #f) (define lookaheads #f) (define LA #f) (define LAruleno #f) (define lookback #f) (define goto-map #f) (define from-state #f) (define to-state #f) (define includes #f) (define F #f) (define action-table #f) ;; - Variables (define nitems #f) (define nrules #f) (define nvars #f) (define nterms #f) (define nsyms #f) (define nstates #f) (define first-state #f) (define last-state #f) (define final-state #f) (define first-shift #f) (define last-shift #f) (define first-reduction #f) (define last-reduction #f) (define nshifts #f) (define maxrhs #f) (define ngotos #f) (define token-set-size #f) (define (gen-tables! tokens gram) (initialize-all) (rewrite-grammar tokens gram (lambda (terms terms/prec vars gram gram/actions) (set! the-terminals/prec (list->vector terms/prec)) (set! the-terminals (list->vector terms)) (set! the-nonterminals (list->vector vars)) (set! nterms (length terms)) (set! nvars (length vars)) (set! nsyms (+ nterms nvars)) (let ((no-of-rules (length gram/actions)) (no-of-items (let loop ((l gram/actions) (count 0)) (if (null? l) count (loop (cdr l) (+ count (length (caar l)))))))) (pack-grammar no-of-rules no-of-items gram) (set-derives) (set-nullable) (generate-states) (lalr) (build-tables) (compact-action-table terms) gram/actions)))) (define (initialize-all) (set! rrhs #f) (set! rlhs #f) (set! ritem #f) (set! nullable #f) (set! derives #f) (set! fderives #f) (set! firsts #f) (set! kernel-base #f) (set! kernel-end #f) (set! shift-symbol #f) (set! shift-set #f) (set! red-set #f) (set! state-table (make-vector STATE-TABLE-SIZE '())) (set! acces-symbol #f) (set! reduction-table #f) (set! shift-table #f) (set! consistent #f) (set! lookaheads #f) (set! LA #f) (set! LAruleno #f) (set! lookback #f) (set! goto-map #f) (set! from-state #f) (set! to-state #f) (set! includes #f) (set! F #f) (set! action-table #f) (set! nstates #f) (set! first-state #f) (set! last-state #f) (set! final-state #f) (set! first-shift #f) (set! last-shift #f) (set! first-reduction #f) (set! last-reduction #f) (set! nshifts #f) (set! maxrhs #f) (set! ngotos #f) (set! token-set-size #f) (set! rule-precedences '())) (define (pack-grammar no-of-rules no-of-items gram) (set! nrules (+ no-of-rules 1)) (set! nitems no-of-items) (set! rlhs (make-vector nrules #f)) (set! rrhs (make-vector nrules #f)) (set! ritem (make-vector (+ 1 nitems) #f)) (let loop ((p gram) (item-no 0) (rule-no 1)) (if (not (null? p)) (let ((nt (caar p))) (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no)) (if (null? prods) (loop (cdr p) it-no2 rl-no2) (begin (vector-set! rlhs rl-no2 nt) (vector-set! rrhs rl-no2 it-no2) (let loop3 ((rhs (car prods)) (it-no3 it-no2)) (if (null? rhs) (begin (vector-set! ritem it-no3 (- rl-no2)) (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1))) (begin (vector-set! ritem it-no3 (car rhs)) (loop3 (cdr rhs) (+ it-no3 1)))))))))))) ;; Fonction set-derives ;; -------------------- (define (set-derives) (define delts (make-vector (+ nrules 1) 0)) (define dset (make-vector nvars -1)) (let loop ((i 1) (j 0)) ; i = 0 (if (< i nrules) (let ((lhs (vector-ref rlhs i))) (if (>= lhs 0) (begin (vector-set! delts j (cons i (vector-ref dset lhs))) (vector-set! dset lhs j) (loop (+ i 1) (+ j 1))) (loop (+ i 1) j))))) (set! derives (make-vector nvars 0)) (let loop ((i 0)) (if (< i nvars) (let ((q (let loop2 ((j (vector-ref dset i)) (s '())) (if (< j 0) s (let ((x (vector-ref delts j))) (loop2 (cdr x) (cons (car x) s))))))) (vector-set! derives i q) (loop (+ i 1)))))) (define (set-nullable) (set! nullable (make-vector nvars #f)) (let ((squeue (make-vector nvars #f)) (rcount (make-vector (+ nrules 1) 0)) (rsets (make-vector nvars #f)) (relts (make-vector (+ nitems nvars 1) #f))) (let loop ((r 0) (s2 0) (p 0)) (let ((*r (vector-ref ritem r))) (if *r (if (< *r 0) (let ((symbol (vector-ref rlhs (- *r)))) (if (and (>= symbol 0) (not (vector-ref nullable symbol))) (begin (vector-set! nullable symbol #t) (vector-set! squeue s2 symbol) (loop (+ r 1) (+ s2 1) p)))) (let loop2 ((r1 r) (any-tokens #f)) (let* ((symbol (vector-ref ritem r1))) (if (> symbol 0) (loop2 (+ r1 1) (or any-tokens (>= symbol nvars))) (if (not any-tokens) (let ((ruleno (- symbol))) (let loop3 ((r2 r) (p2 p)) (let ((symbol (vector-ref ritem r2))) (if (> symbol 0) (begin (vector-set! rcount ruleno (+ (vector-ref rcount ruleno) 1)) (vector-set! relts p2 (cons (vector-ref rsets symbol) ruleno)) (vector-set! rsets symbol p2) (loop3 (+ r2 1) (+ p2 1))) (loop (+ r2 1) s2 p2))))) (loop (+ r1 1) s2 p)))))) (let loop ((s1 0) (s3 s2)) (if (< s1 s3) (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3)) (if p (let* ((x (vector-ref relts p)) (ruleno (cdr x)) (y (- (vector-ref rcount ruleno) 1))) (vector-set! rcount ruleno y) (if (= y 0) (let ((symbol (vector-ref rlhs ruleno))) (if (and (>= symbol 0) (not (vector-ref nullable symbol))) (begin (vector-set! nullable symbol #t) (vector-set! squeue s4 symbol) (loop2 (car x) (+ s4 1))) (loop2 (car x) s4))) (loop2 (car x) s4)))) (loop (+ s1 1) s4))))))))) ; Fonction set-firsts qui calcule un tableau de taille ; nvars et qui donne, pour chaque non-terminal X, une liste des ; non-terminaux pouvant apparaitre au debut d'une derivation a ; partir de X. (define (set-firsts) (set! firsts (make-vector nvars '())) ;; -- initialization (let loop ((i 0)) (if (< i nvars) (let loop2 ((sp (vector-ref derives i))) (if (null? sp) (loop (+ i 1)) (let ((sym (vector-ref ritem (vector-ref rrhs (car sp))))) (if (< -1 sym nvars) (vector-set! firsts i (sinsert sym (vector-ref firsts i)))) (loop2 (cdr sp))))))) ;; -- reflexive and transitive closure (let loop ((continue #t)) (if continue (let loop2 ((i 0) (cont #f)) (if (>= i nvars) (loop cont) (let* ((x (vector-ref firsts i)) (y (let loop3 ((l x) (z x)) (if (null? l) z (loop3 (cdr l) (sunion (vector-ref firsts (car l)) z)))))) (if (equal? x y) (loop2 (+ i 1) cont) (begin (vector-set! firsts i y) (loop2 (+ i 1) #t)))))))) (let loop ((i 0)) (if (< i nvars) (begin (vector-set! firsts i (sinsert i (vector-ref firsts i))) (loop (+ i 1)))))) ; Fonction set-fderives qui calcule un tableau de taille ; nvars et qui donne, pour chaque non-terminal, une liste des regles pouvant ; etre derivees a partir de ce non-terminal. (se sert de firsts) (define (set-fderives) (set! fderives (make-vector nvars #f)) (set-firsts) (let loop ((i 0)) (if (< i nvars) (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '())) (if (null? l) fd (loop2 (cdr l) (sunion (vector-ref derives (car l)) fd)))))) (vector-set! fderives i x) (loop (+ i 1)))))) ; Fonction calculant la fermeture d'un ensemble d'items LR0 ; ou core est une liste d'items (define (closure core) ;; Initialization (define ruleset (make-vector nrules #f)) (let loop ((csp core)) (if (not (null? csp)) (let ((sym (vector-ref ritem (car csp)))) (if (< -1 sym nvars) (let loop2 ((dsp (vector-ref fderives sym))) (if (not (null? dsp)) (begin (vector-set! ruleset (car dsp) #t) (loop2 (cdr dsp)))))) (loop (cdr csp))))) (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0 (if (< ruleno nrules) (if (vector-ref ruleset ruleno) (let ((itemno (vector-ref rrhs ruleno))) (let loop2 ((c csp) (itemsetv2 itemsetv)) (if (and (pair? c) (< (car c) itemno)) (loop2 (cdr c) (cons (car c) itemsetv2)) (loop (+ ruleno 1) c (cons itemno itemsetv2))))) (loop (+ ruleno 1) csp itemsetv)) (let loop2 ((c csp) (itemsetv2 itemsetv)) (if (pair? c) (loop2 (cdr c) (cons (car c) itemsetv2)) (reverse itemsetv2)))))) (define (allocate-item-sets) (set! kernel-base (make-vector nsyms 0)) (set! kernel-end (make-vector nsyms #f))) (define (allocate-storage) (allocate-item-sets) (set! red-set (make-vector (+ nrules 1) 0))) ;; -- (define (initialize-states) (let ((p (new-core))) (set-core-number! p 0) (set-core-acc-sym! p #f) (set-core-nitems! p 1) (set-core-items! p '(0)) (set! first-state (list p)) (set! last-state first-state) (set! nstates 1))) (define (generate-states) (allocate-storage) (set-fderives) (initialize-states) (let loop ((this-state first-state)) (if (pair? this-state) (let* ((x (car this-state)) (is (closure (core-items x)))) (save-reductions x is) (new-itemsets is) (append-states) (if (> nshifts 0) (save-shifts x)) (loop (cdr this-state)))))) ;; Fonction calculant les symboles sur lesquels il faut "shifter" ;; et regroupe les items en fonction de ces symboles (define (new-itemsets itemset) ;; - Initialization (set! shift-symbol '()) (let loop ((i 0)) (if (< i nsyms) (begin (vector-set! kernel-end i '()) (loop (+ i 1))))) (let loop ((isp itemset)) (if (pair? isp) (let* ((i (car isp)) (sym (vector-ref ritem i))) (if (>= sym 0) (begin (set! shift-symbol (sinsert sym shift-symbol)) (let ((x (vector-ref kernel-end sym))) (if (null? x) (begin (vector-set! kernel-base sym (cons (+ i 1) x)) (vector-set! kernel-end sym (vector-ref kernel-base sym))) (begin (set-cdr! x (list (+ i 1))) (vector-set! kernel-end sym (cdr x))))))) (loop (cdr isp))))) (set! nshifts (length shift-symbol))) (define (get-state sym) (let* ((isp (vector-ref kernel-base sym)) (n (length isp)) (key (let loop ((isp1 isp) (k 0)) (if (null? isp1) (modulo k STATE-TABLE-SIZE) (loop (cdr isp1) (+ k (car isp1)))))) (sp (vector-ref state-table key))) (if (null? sp) (let ((x (new-state sym))) (vector-set! state-table key (list x)) (core-number x)) (let loop ((sp1 sp)) (if (and (= n (core-nitems (car sp1))) (let loop2 ((i1 isp) (t (core-items (car sp1)))) (if (and (pair? i1) (= (car i1) (car t))) (loop2 (cdr i1) (cdr t)) (null? i1)))) (core-number (car sp1)) (if (null? (cdr sp1)) (let ((x (new-state sym))) (set-cdr! sp1 (list x)) (core-number x)) (loop (cdr sp1)))))))) (define (new-state sym) (let* ((isp (vector-ref kernel-base sym)) (n (length isp)) (p (new-core))) (set-core-number! p nstates) (set-core-acc-sym! p sym) (if (= sym nvars) (set! final-state nstates)) (set-core-nitems! p n) (set-core-items! p isp) (set-cdr! last-state (list p)) (set! last-state (cdr last-state)) (set! nstates (+ nstates 1)) p)) ;; -- (define (append-states) (set! shift-set (let loop ((l (reverse shift-symbol))) (if (null? l) '() (cons (get-state (car l)) (loop (cdr l))))))) ;; -- (define (save-shifts core) (let ((p (new-shift))) (set-shift-number! p (core-number core)) (set-shift-nshifts! p nshifts) (set-shift-shifts! p shift-set) (if last-shift (begin (set-cdr! last-shift (list p)) (set! last-shift (cdr last-shift))) (begin (set! first-shift (list p)) (set! last-shift first-shift))))) (define (save-reductions core itemset) (let ((rs (let loop ((l itemset)) (if (null? l) '() (let ((item (vector-ref ritem (car l)))) (if (< item 0) (cons (- item) (loop (cdr l))) (loop (cdr l)))))))) (if (pair? rs) (let ((p (new-red))) (set-red-number! p (core-number core)) (set-red-nreds! p (length rs)) (set-red-rules! p rs) (if last-reduction (begin (set-cdr! last-reduction (list p)) (set! last-reduction (cdr last-reduction))) (begin (set! first-reduction (list p)) (set! last-reduction first-reduction))))))) ;; -- (define (lalr) (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD)))) (set-accessing-symbol) (set-shift-table) (set-reduction-table) (set-max-rhs) (initialize-LA) (set-goto-map) (initialize-F) (build-relations) (digraph includes) (compute-lookaheads)) (define (set-accessing-symbol) (set! acces-symbol (make-vector nstates #f)) (let loop ((l first-state)) (if (pair? l) (let ((x (car l))) (vector-set! acces-symbol (core-number x) (core-acc-sym x)) (loop (cdr l)))))) (define (set-shift-table) (set! shift-table (make-vector nstates #f)) (let loop ((l first-shift)) (if (pair? l) (let ((x (car l))) (vector-set! shift-table (shift-number x) x) (loop (cdr l)))))) (define (set-reduction-table) (set! reduction-table (make-vector nstates #f)) (let loop ((l first-reduction)) (if (pair? l) (let ((x (car l))) (vector-set! reduction-table (red-number x) x) (loop (cdr l)))))) (define (set-max-rhs) (let loop ((p 0) (curmax 0) (length 0)) (let ((x (vector-ref ritem p))) (if x (if (>= x 0) (loop (+ p 1) curmax (+ length 1)) (loop (+ p 1) (max curmax length) 0)) (set! maxrhs curmax))))) (define (initialize-LA) (define (last l) (if (null? (cdr l)) (car l) (last (cdr l)))) (set! consistent (make-vector nstates #f)) (set! lookaheads (make-vector (+ nstates 1) #f)) (let loop ((count 0) (i 0)) (if (< i nstates) (begin (vector-set! lookaheads i count) (let ((rp (vector-ref reduction-table i)) (sp (vector-ref shift-table i))) (if (and rp (or (> (red-nreds rp) 1) (and sp (not (< (vector-ref acces-symbol (last (shift-shifts sp))) nvars))))) (loop (+ count (red-nreds rp)) (+ i 1)) (begin (vector-set! consistent i #t) (loop count (+ i 1)))))) (begin (vector-set! lookaheads nstates count) (let ((c (max count 1))) (set! LA (make-vector c #f)) (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size))) (set! LAruleno (make-vector c -1)) (set! lookback (make-vector c #f))) (let loop ((i 0) (np 0)) (if (< i nstates) (if (vector-ref consistent i) (loop (+ i 1) np) (let ((rp (vector-ref reduction-table i))) (if rp (let loop2 ((j (red-rules rp)) (np2 np)) (if (null? j) (loop (+ i 1) np2) (begin (vector-set! LAruleno np2 (car j)) (loop2 (cdr j) (+ np2 1))))) (loop (+ i 1) np)))))))))) (define (set-goto-map) (set! goto-map (make-vector (+ nvars 1) 0)) (let ((temp-map (make-vector (+ nvars 1) 0))) (let loop ((ng 0) (sp first-shift)) (if (pair? sp) (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng)) (if (pair? i) (let ((symbol (vector-ref acces-symbol (car i)))) (if (< symbol nvars) (begin (vector-set! goto-map symbol (+ 1 (vector-ref goto-map symbol))) (loop2 (cdr i) (+ ng2 1))) (loop2 (cdr i) ng2))) (loop ng2 (cdr sp)))) (let loop ((k 0) (i 0)) (if (< i nvars) (begin (vector-set! temp-map i k) (loop (+ k (vector-ref goto-map i)) (+ i 1))) (begin (do ((i 0 (+ i 1))) ((>= i nvars)) (vector-set! goto-map i (vector-ref temp-map i))) (set! ngotos ng) (vector-set! goto-map nvars ngotos) (vector-set! temp-map nvars ngotos) (set! from-state (make-vector ngotos #f)) (set! to-state (make-vector ngotos #f)) (do ((sp first-shift (cdr sp))) ((null? sp)) (let* ((x (car sp)) (state1 (shift-number x))) (do ((i (shift-shifts x) (cdr i))) ((null? i)) (let* ((state2 (car i)) (symbol (vector-ref acces-symbol state2))) (if (< symbol nvars) (let ((k (vector-ref temp-map symbol))) (vector-set! temp-map symbol (+ k 1)) (vector-set! from-state k state1) (vector-set! to-state k state2)))))))))))))) (define (map-goto state symbol) (let loop ((low (vector-ref goto-map symbol)) (high (- (vector-ref goto-map (+ symbol 1)) 1))) (if (> low high) (begin (display (list "Error in map-goto" state symbol) (current-error-port)) (newline (current-error-port)) 0) (let* ((middle (quotient (+ low high) 2)) (s (vector-ref from-state middle))) (cond ((= s state) middle) ((< s state) (loop (+ middle 1) high)) (else (loop low (- middle 1)))))))) (define (initialize-F) (set! F (make-vector ngotos #f)) (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size))) (let ((reads (make-vector ngotos #f))) (let loop ((i 0) (rowp 0)) (if (< i ngotos) (let* ((rowf (vector-ref F rowp)) (stateno (vector-ref to-state i)) (sp (vector-ref shift-table stateno))) (if sp (let loop2 ((j (shift-shifts sp)) (edges '())) (if (pair? j) (let ((symbol (vector-ref acces-symbol (car j)))) (if (< symbol nvars) (if (vector-ref nullable symbol) (loop2 (cdr j) (cons (map-goto stateno symbol) edges)) (loop2 (cdr j) edges)) (begin (set-bit rowf (- symbol nvars)) (loop2 (cdr j) edges)))) (if (pair? edges) (vector-set! reads i (reverse edges)))))) (loop (+ i 1) (+ rowp 1))))) (digraph reads))) (define (add-lookback-edge stateno ruleno gotono) (let ((k (vector-ref lookaheads (+ stateno 1)))) (let loop ((found #f) (i (vector-ref lookaheads stateno))) (if (and (not found) (< i k)) (if (= (vector-ref LAruleno i) ruleno) (loop #t i) (loop found (+ i 1))) (if (not found) (begin (display "Error in add-lookback-edge : " (current-error-port)) (display (list stateno ruleno gotono) (current-error-port)) (newline (current-error-port))) (vector-set! lookback i (cons gotono (vector-ref lookback i)))))))) (define (transpose r-arg n) (let ((new-end (make-vector n #f)) (new-R (make-vector n #f))) (do ((i 0 (+ i 1))) ((= i n)) (let ((x (list 'bidon))) (vector-set! new-R i x) (vector-set! new-end i x))) (do ((i 0 (+ i 1))) ((= i n)) (let ((sp (vector-ref r-arg i))) (if (pair? sp) (let loop ((sp2 sp)) (if (pair? sp2) (let* ((x (car sp2)) (y (vector-ref new-end x))) (set-cdr! y (cons i (cdr y))) (vector-set! new-end x (cdr y)) (loop (cdr sp2)))))))) (do ((i 0 (+ i 1))) ((= i n)) (vector-set! new-R i (cdr (vector-ref new-R i)))) new-R)) (define (build-relations) (define (get-state stateno symbol) (let loop ((j (shift-shifts (vector-ref shift-table stateno))) (stno stateno)) (if (null? j) stno (let ((st2 (car j))) (if (= (vector-ref acces-symbol st2) symbol) st2 (loop (cdr j) st2)))))) (set! includes (make-vector ngotos #f)) (do ((i 0 (+ i 1))) ((= i ngotos)) (let ((state1 (vector-ref from-state i)) (symbol1 (vector-ref acces-symbol (vector-ref to-state i)))) (let loop ((rulep (vector-ref derives symbol1)) (edges '())) (if (pair? rulep) (let ((*rulep (car rulep))) (let loop2 ((rp (vector-ref rrhs *rulep)) (stateno state1) (states (list state1))) (let ((*rp (vector-ref ritem rp))) (if (> *rp 0) (let ((st (get-state stateno *rp))) (loop2 (+ rp 1) st (cons st states))) (begin (if (not (vector-ref consistent stateno)) (add-lookback-edge stateno *rulep i)) (let loop2 ((done #f) (stp (cdr states)) (rp2 (- rp 1)) (edgp edges)) (if (not done) (let ((*rp (vector-ref ritem rp2))) (if (< -1 *rp nvars) (loop2 (not (vector-ref nullable *rp)) (cdr stp) (- rp2 1) (cons (map-goto (car stp) *rp) edgp)) (loop2 #t stp rp2 edgp))) (loop (cdr rulep) edgp)))))))) (vector-set! includes i edges))))) (set! includes (transpose includes ngotos))) (define (compute-lookaheads) (let ((n (vector-ref lookaheads nstates))) (let loop ((i 0)) (if (< i n) (let loop2 ((sp (vector-ref lookback i))) (if (pair? sp) (let ((LA-i (vector-ref LA i)) (F-j (vector-ref F (car sp)))) (bit-union LA-i F-j token-set-size) (loop2 (cdr sp))) (loop (+ i 1)))))))) (define (digraph relation) (define infinity (+ ngotos 2)) (define INDEX (make-vector (+ ngotos 1) 0)) (define VERTICES (make-vector (+ ngotos 1) 0)) (define top 0) (define R relation) (define (traverse i) (set! top (+ 1 top)) (vector-set! VERTICES top i) (let ((height top)) (vector-set! INDEX i height) (let ((rp (vector-ref R i))) (if (pair? rp) (let loop ((rp2 rp)) (if (pair? rp2) (let ((j (car rp2))) (if (= 0 (vector-ref INDEX j)) (traverse j)) (if (> (vector-ref INDEX i) (vector-ref INDEX j)) (vector-set! INDEX i (vector-ref INDEX j))) (let ((F-i (vector-ref F i)) (F-j (vector-ref F j))) (bit-union F-i F-j token-set-size)) (loop (cdr rp2)))))) (if (= (vector-ref INDEX i) height) (let loop () (let ((j (vector-ref VERTICES top))) (set! top (- top 1)) (vector-set! INDEX j infinity) (if (not (= i j)) (begin (bit-union (vector-ref F i) (vector-ref F j) token-set-size) (loop))))))))) (let loop ((i 0)) (if (< i ngotos) (begin (if (and (= 0 (vector-ref INDEX i)) (pair? (vector-ref R i))) (traverse i)) (loop (+ i 1)))))) ;; ---------------------------------------------------------------------- ;; ;; operator precedence management ;; ;; ---------------------------------------------------------------------- ;; ; a vector of precedence descriptors where each element ; is of the form (terminal type precedence) (define the-terminals/prec #f) ; terminal symbols with precedence ; the precedence is an integer >= 0 (define (get-symbol-precedence sym) (caddr (vector-ref the-terminals/prec sym))) ; the operator type is either 'none, 'left, 'right, or 'nonassoc (define (get-symbol-assoc sym) (cadr (vector-ref the-terminals/prec sym))) (define rule-precedences '()) (define (add-rule-precedence! rule sym) (set! rule-precedences (cons (cons rule sym) rule-precedences))) (define (get-rule-precedence ruleno) (cond ((assq ruleno rule-precedences) => (lambda (p) (get-symbol-precedence (cdr p)))) (else ;; process the rule symbols from left to right (let loop ((i (vector-ref rrhs ruleno)) (prec 0)) (let ((item (vector-ref ritem i))) ;; end of rule (if (< item 0) prec (let ((i1 (+ i 1))) (if (>= item nvars) ;; it's a terminal symbol (loop i1 (get-symbol-precedence (- item nvars))) (loop i1 prec))))))))) ;; ---------------------------------------------------------------------- ;; ;; Build the various tables ;; ;; ---------------------------------------------------------------------- ;; (define (build-tables) (define (resolve-conflict sym rule) (let ((sym-prec (get-symbol-precedence sym)) (sym-assoc (get-symbol-assoc sym)) (rule-prec (get-rule-precedence rule))) (cond ((> sym-prec rule-prec) 'shift) ((< sym-prec rule-prec) 'reduce) ((eq? sym-assoc 'left) 'reduce) ((eq? sym-assoc 'right) 'shift) (else 'shift)))) ;; --- Add an action to the action table ------------------------------ ;; (define (add-action St Sym Act) (let* ((x (vector-ref action-table St)) (y (assv Sym x))) (if y (if (not (= Act (cdr y))) ;; -- there is a conflict (begin (if (and (<= (cdr y) 0) (<= Act 0)) ;; --- reduce/reduce conflict ----------------------- ;; (begin (display "%% Reduce/Reduce conflict " (current-error-port)) (display "(reduce " (current-error-port)) (display (- Act) (current-error-port)) (display ", reduce " (current-error-port)) (display (- (cdr y)) (current-error-port)) (display ") on " (current-error-port)) (print-symbol (+ Sym nvars) (current-error-port)) (display " in state " (current-error-port)) (display St (current-error-port)) (newline (current-error-port)) (set-cdr! y (max (cdr y) Act))) ;; --- shift/reduce conflict ------------------------ ;; ;; can we resolve the conflict using precedences? (case (resolve-conflict Sym (- (cdr y))) ;; -- shift ((shift) (set-cdr! y Act)) ;; -- reduce ((reduce) #f) ; well, nothing to do... ;; -- signal a conflict! (else (display "%% Shift/Reduce conflict " (current-error-port)) (display "(shift " (current-error-port)) (display Act (current-error-port)) (display ", reduce " (current-error-port)) (display (- (cdr y)) (current-error-port)) (display ") on " (current-error-port)) (print-symbol (+ Sym nvars) (current-error-port)) (display " in state " (current-error-port)) (display St (current-error-port)) (newline (current-error-port)) (set-cdr! y Act)))))) (vector-set! action-table St (cons (cons Sym Act) x))))) (set! action-table (make-vector nstates '())) (do ((i 0 (+ i 1))) ; i = state ((= i nstates)) (let ((red (vector-ref reduction-table i))) (if (and red (>= (red-nreds red) 1)) (if (and (= (red-nreds red) 1) (vector-ref consistent i)) (add-action i 'default (- (car (red-rules red)))) (let ((k (vector-ref lookaheads (+ i 1)))) (let loop ((j (vector-ref lookaheads i))) (if (< j k) (let ((rule (- (vector-ref LAruleno j))) (lav (vector-ref LA j))) (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0)) (if (< token nterms) (begin (let ((in-la-set? (modulo x 2))) (if (= in-la-set? 1) (add-action i token rule))) (if (= y (BITS-PER-WORD)) (loop2 (+ token 1) (vector-ref lav (+ z 1)) 1 (+ z 1)) (loop2 (+ token 1) (quotient x 2) (+ y 1) z))))) (loop (+ j 1))))))))) (let ((shiftp (vector-ref shift-table i))) (if shiftp (let loop ((k (shift-shifts shiftp))) (if (pair? k) (let* ((state (car k)) (symbol (vector-ref acces-symbol state))) (if (>= symbol nvars) (add-action i (- symbol nvars) state)) (loop (cdr k)))))))) (add-action final-state 0 'accept)) (define (compact-action-table terms) (define (most-common-action acts) (let ((accums '())) (let loop ((l acts)) (if (pair? l) (let* ((x (cdar l)) (y (assv x accums))) (if (and (number? x) (< x 0)) (if y (set-cdr! y (+ 1 (cdr y))) (set! accums (cons `(,x . 1) accums)))) (loop (cdr l))))) (let loop ((l accums) (max 0) (sym #f)) (if (null? l) sym (let ((x (car l))) (if (> (cdr x) max) (loop (cdr l) (cdr x) (car x)) (loop (cdr l) max sym))))))) (define (translate-terms acts) (map (lambda (act) (cons (list-ref terms (car act)) (cdr act))) acts)) (do ((i 0 (+ i 1))) ((= i nstates)) (let ((acts (vector-ref action-table i))) (if (vector? (vector-ref reduction-table i)) (let ((act (most-common-action acts))) (vector-set! action-table i (cons `(*default* . ,(if act act 'error)) (translate-terms (lalr-filter (lambda (x) (not (eq? (cdr x) act))) acts))))) (vector-set! action-table i (cons `(*default* . *error*) (translate-terms acts))))))) ;; -- (define (rewrite-grammar tokens grammar k) (define eoi '*eoi*) (define (check-terminal term terms) (cond ((not (valid-terminal? term)) (lalr-error "invalid terminal: " term)) ((member term terms) (lalr-error "duplicate definition of terminal: " term)))) (define (prec->type prec) (cdr (assq prec '((left: . left) (right: . right) (nonassoc: . nonassoc))))) (cond ;; --- a few error conditions ---------------------------------------- ;; ((not (list? tokens)) (lalr-error "Invalid token list: " tokens)) ((not (pair? grammar)) (lalr-error "Grammar definition must have a non-empty list of productions" '())) (else ;; --- check the terminals ---------------------------------------- ;; (let loop1 ((lst tokens) (rev-terms '()) (rev-terms/prec '()) (prec-level 0)) (if (pair? lst) (let ((term (car lst))) (cond ((pair? term) (if (and (memq (car term) '(left: right: nonassoc:)) (not (null? (cdr term)))) (let ((prec (+ prec-level 1)) (optype (prec->type (car term)))) (let loop-toks ((l (cdr term)) (rev-terms rev-terms) (rev-terms/prec rev-terms/prec)) (if (null? l) (loop1 (cdr lst) rev-terms rev-terms/prec prec) (let ((term (car l))) (check-terminal term rev-terms) (loop-toks (cdr l) (cons term rev-terms) (cons (list term optype prec) rev-terms/prec)))))) (lalr-error "invalid operator precedence specification: " term))) (else (check-terminal term rev-terms) (loop1 (cdr lst) (cons term rev-terms) (cons (list term 'none 0) rev-terms/prec) prec-level)))) ;; --- check the grammar rules ------------------------------ ;; (let loop2 ((lst grammar) (rev-nonterm-defs '())) (if (pair? lst) (let ((def (car lst))) (if (not (pair? def)) (lalr-error "Nonterminal definition must be a non-empty list" '()) (let ((nonterm (car def))) (cond ((not (valid-nonterminal? nonterm)) (lalr-error "Invalid nonterminal:" nonterm)) ((or (member nonterm rev-terms) (assoc nonterm rev-nonterm-defs)) (lalr-error "Nonterminal previously defined:" nonterm)) (else (loop2 (cdr lst) (cons def rev-nonterm-defs))))))) (let* ((terms (cons eoi (reverse rev-terms))) (terms/prec (cons '(eoi none 0) (reverse rev-terms/prec))) (nonterm-defs (reverse rev-nonterm-defs)) (nonterms (cons '*start* (map car nonterm-defs)))) (if (= (length nonterms) 1) (lalr-error "Grammar must contain at least one nonterminal" '()) (let loop-defs ((defs (cons `(*start* (,(cadr nonterms) ,eoi) : $1) nonterm-defs)) (ruleno 0) (comp-defs '())) (if (pair? defs) (let* ((nonterm-def (car defs)) (compiled-def (rewrite-nonterm-def nonterm-def ruleno terms nonterms))) (loop-defs (cdr defs) (+ ruleno (length compiled-def)) (cons compiled-def comp-defs))) (let ((compiled-nonterm-defs (reverse comp-defs))) (k terms terms/prec nonterms (map (lambda (x) (cons (caaar x) (map cdar x))) compiled-nonterm-defs) (apply append compiled-nonterm-defs)))))))))))))) (define (rewrite-nonterm-def nonterm-def ruleno terms nonterms) (define No-NT (length nonterms)) (define (encode x) (let ((PosInNT (pos-in-list x nonterms))) (if PosInNT PosInNT (let ((PosInT (pos-in-list x terms))) (if PosInT (+ No-NT PosInT) (lalr-error "undefined symbol : " x)))))) (define (process-prec-directive rhs ruleno) (let loop ((l rhs)) (if (null? l) '() (let ((first (car l)) (rest (cdr l))) (cond ((or (member first terms) (member first nonterms)) (cons first (loop rest))) ((and (pair? first) (eq? (car first) 'prec:)) (pair? (cdr first)) (if (and (pair? (cdr first)) (member (cadr first) terms)) (if (null? (cddr first)) (begin (add-rule-precedence! ruleno (pos-in-list (cadr first) terms)) (loop rest)) (lalr-error "prec: directive should be at end of rule: " rhs)) (lalr-error "Invalid prec: directive: " first))) (else (lalr-error "Invalid terminal or nonterminal: " first))))))) (if (not (pair? (cdr nonterm-def))) (lalr-error "At least one production needed for nonterminal" (car nonterm-def)) (let ((name (symbol->string (car nonterm-def)))) (let loop1 ((lst (cdr nonterm-def)) (i 1) (rev-productions-and-actions '())) (if (not (pair? lst)) (reverse rev-productions-and-actions) (let* ((rhs (process-prec-directive (car lst) (+ ruleno i -1))) (rest (cdr lst)) (prod (map encode (cons (car nonterm-def) rhs)))) (for-each (lambda (x) (if (not (or (member x terms) (member x nonterms))) (lalr-error "Invalid terminal or nonterminal" x))) rhs) (if (and (pair? rest) (eq? (car rest) ':) (pair? (cdr rest))) (loop1 (cddr rest) (+ i 1) (cons (cons prod (cadr rest)) rev-productions-and-actions)) (let* ((rhs-length (length rhs)) (action (cons 'vector (cons (list 'quote (string->symbol (string-append name "-" (number->string i)))) (let loop-j ((j 1)) (if (> j rhs-length) '() (cons (string->symbol (string-append "$" (number->string j))) (loop-j (+ j 1))))))))) (loop1 rest (+ i 1) (cons (cons prod action) rev-productions-and-actions)))))))))) (define (valid-nonterminal? x) (symbol? x)) (define (valid-terminal? x) (symbol? x)) ; DB ;; ---------------------------------------------------------------------- ;; ;; Miscellaneous ;; ;; ---------------------------------------------------------------------- ;; (define (pos-in-list x lst) (let loop ((lst lst) (i 0)) (cond ((not (pair? lst)) #f) ((equal? (car lst) x) i) (else (loop (cdr lst) (+ i 1)))))) (define (sunion lst1 lst2) ; union of sorted lists (let loop ((L1 lst1) (L2 lst2)) (cond ((null? L1) L2) ((null? L2) L1) (else (let ((x (car L1)) (y (car L2))) (cond ((> x y) (cons y (loop L1 (cdr L2)))) ((< x y) (cons x (loop (cdr L1) L2))) (else (loop (cdr L1) L2)) )))))) (define (sinsert elem lst) (let loop ((l1 lst)) (if (null? l1) (cons elem l1) (let ((x (car l1))) (cond ((< elem x) (cons elem l1)) ((> elem x) (cons x (loop (cdr l1)))) (else l1)))))) (define (lalr-filter p lst) (let loop ((l lst)) (if (null? l) '() (let ((x (car l)) (y (cdr l))) (if (p x) (cons x (loop y)) (loop y)))))) ;; ---------------------------------------------------------------------- ;; ;; Debugging tools ... ;; ;; ---------------------------------------------------------------------- ;; (define the-terminals #f) ; names of terminal symbols (define the-nonterminals #f) ; non-terminals (define (print-item item-no) (let loop ((i item-no)) (let ((v (vector-ref ritem i))) (if (>= v 0) (loop (+ i 1)) (let* ((rlno (- v)) (nt (vector-ref rlhs rlno))) (display (vector-ref the-nonterminals nt)) (display " --> ") (let loop ((i (vector-ref rrhs rlno))) (let ((v (vector-ref ritem i))) (if (= i item-no) (display ". ")) (if (>= v 0) (begin (print-symbol v) (display " ") (loop (+ i 1))) (begin (display " (rule ") (display (- v)) (display ")") (newline)))))))))) (define (print-symbol n . port) (display (if (>= n nvars) (vector-ref the-terminals (- n nvars)) (vector-ref the-nonterminals n)) (if (null? port) (current-output-port) (car port)))) (define (print-states) "Print the states of a generated parser." (define (print-action act) (cond ((eq? act '*error*) (display " : Error")) ((eq? act 'accept) (display " : Accept input")) ((< act 0) (display " : reduce using rule ") (display (- act))) (else (display " : shift and goto state ") (display act))) (newline) #t) (define (print-actions acts) (let loop ((l acts)) (if (null? l) #t (let ((sym (caar l)) (act (cdar l))) (display " ") (cond ((eq? sym 'default) (display "default action")) (else (if (number? sym) (print-symbol (+ sym nvars)) (display sym)))) (print-action act) (loop (cdr l)))))) (if (not action-table) (begin (display "No generated parser available!") (newline) #f) (begin (display "State table") (newline) (display "-----------") (newline) (newline) (let loop ((l first-state)) (if (null? l) #t (let* ((core (car l)) (i (core-number core)) (items (core-items core)) (actions (vector-ref action-table i))) (display "state ") (display i) (newline) (newline) (for-each (lambda (x) (display " ") (print-item x)) items) (newline) (print-actions actions) (newline) (loop (cdr l)))))))) ;; ---------------------------------------------------------------------- ;; (define build-goto-table (lambda () `(vector ,@(map (lambda (shifts) (list 'quote (if shifts (let loop ((l (shift-shifts shifts))) (if (null? l) '() (let* ((state (car l)) (symbol (vector-ref acces-symbol state))) (if (< symbol nvars) (cons `(,symbol . ,state) (loop (cdr l))) (loop (cdr l)))))) '()))) (vector->list shift-table))))) (define build-reduction-table (lambda (gram/actions) `(vector '() ,@(map (lambda (p) (let ((act (cdr p))) `(lambda (___stack ___sp ___goto-table ___k) ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs))) `(let* (,@(if act (let loop ((i 1) (l rhs)) (if (pair? l) (let ((rest (cdr l))) (cons `(,(string->symbol (string-append "$" (number->string (+ (- n i) 1)))) (vector-ref ___stack (- ___sp ,(- (* i 2) 1)))) (loop (+ i 1) rest))) '())) '())) ,(if (= nt 0) '$1 `(___push ___stack (- ___sp ,(* 2 n)) ,nt ___goto-table ,(cdr p) ___k))))))) gram/actions)))) ;; @section (api "API") (define-macro-with-docs (lalr-parser tokens . rules) "The grammar declaration special form. @var{tokens} is the list of token symbols, and @var{rules} are the grammar rules. See the module documentation for more details." (let* ((gram/actions (gen-tables! tokens rules)) (code `(letrec ((___max-stack-size 500) (___atable ',action-table) (___gtable ,(build-goto-table)) (___grow-stack (lambda (stack) ;; make a new stack twice as big as the original (let ((new-stack (make-vector (* 2 (vector-length stack)) #f))) ;; then copy the elements... (let loop ((i (- (vector-length stack) 1))) (if (< i 0) new-stack (begin (vector-set! new-stack i (vector-ref stack i)) (loop (- i 1)))))))) (___push (lambda (stack sp new-cat goto-table lval k) (let* ((state (vector-ref stack sp)) (new-state (cdr (assq new-cat (vector-ref goto-table state)))) (new-sp (+ sp 2)) (stack (if (< new-sp (vector-length stack)) stack (___grow-stack stack)))) (vector-set! stack new-sp new-state) (vector-set! stack (- new-sp 1) lval) (k stack new-sp)))) (___action (lambda (x l) (let ((y (assq x l))) (if y (cdr y) (cdar l))))) (___rtable ,(build-reduction-table gram/actions))) (lambda (lexerp errorp) (let ((stack (make-vector ___max-stack-size 0))) (let loop ((stack stack) (sp 0) (input (lexerp))) (let* ((state (vector-ref stack sp)) (i (if (pair? input) (car input) input)) (attr (if (pair? input) (cdr input) #f)) (act (___action i (vector-ref ___atable state)))) (if (not (symbol? i)) (errorp "PARSE ERROR: invalid token: " input)) (cond ;; Input succesfully parsed ((eq? act 'accept) (vector-ref stack 1)) ;; Syntax error in input ((eq? act '*error*) (if (eq? i '*eoi*) (errorp "PARSE ERROR : unexpected end of input ") (errorp "PARSE ERROR : unexpected token : " input))) ;; Shift current token on top of the stack ((>= act 0) (let ((stack (if (< (+ sp 2) (vector-length stack)) stack (___grow-stack stack)))) (vector-set! stack (+ sp 1) attr) (vector-set! stack (+ sp 2) act) (loop stack (+ sp 2) (lexerp)))) ;; Reduce by rule (- act) (else ((vector-ref ___rtable (- act)) stack sp ___gtable (lambda (stack sp) (loop stack sp input)))))))))))) code)) ;; arch-tag: 4FE771DE-F56D-11D8-8B77-000A95B4C7DC ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/os/�����������������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�011604� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/os/process.scm������������������������������������������������������������������0000664�0000764�0000764�00000060467�11546127450�013732� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (os process): process chains ;; Copyright (C) 1997, 2000, 2001, 2010, 2011 Free Software Foundation, Inc. ;; Written by Gary Houston <ghouston@arglist.com>, originally as "goosh.scm". ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. #! ;;; Commentary: @cindex Goosh module @cindex process, Operating System @cindex process chain @cindex pipeline, process This is a library for execution of other programs from Guile. It also allows communication using pipes (or a pseudo terminal device, but that's not currently implemented). This code originates in the @code{(goosh)} modules, which itself was part of goonix in one of Guile's past lives. The following will hold when starting programs: @enumerate @item If the name of the program does not contain a @code{/} then the directories listed in the current @code{PATH} environment variable are searched to locate the program. @item Unlike for the corresponding primitive exec procedures, e.g., @code{execlp}, the name of the program can not be set independently of the path to execute: the zeroth and first members of the argument vector are combined into one. @end enumerate All symbols exported with the prefix @code{os:process:} are there in support of macros that use them. They should be ignored by users of this module. ;;; Code: !# (define-module (os process) #:use-module (compat guile-2)) (export tail-call-program run run-concurrently run-with-pipe) (export-syntax run-concurrently+ run+ tail-call-pipeline+ tail-call-pipeline) ;; these are exported because they appear in code generated by ;; macros. (export os:process:pipe-make-redir-commands os:process:pipe-make-commands os:process:setup-redirected-port os:process:new-comm-pipes) (export-syntax os:process:pipe-fork-child) ;; setup file descriptors 0, 1, 2 from the current Scheme ports, if ;; possible. if some of these ports can not be used, open new ;; descriptors on /dev/null. (define (stdports->stdio) ;; select the three file descriptors to be used as ;; standard descriptors 0, 1, 2 for the new process. (let* ((ensure-fdes (lambda (port mode) (or (false-if-exception (fileno port)) (open-fdes *null-device* mode)))) (input-fdes (ensure-fdes (current-input-port) O_RDONLY)) (output-fdes (ensure-fdes (current-output-port) O_WRONLY)) (error-fdes (ensure-fdes (current-error-port) O_WRONLY))) ;; copy the three selected descriptors to the standard ;; descriptors 0, 1, 2. note that it's possible that ;; any of output-fdes, input-fdes and error-fdes are equal. (cond ((not (= input-fdes 0)) (if (= output-fdes 0) (set! output-fdes (dup->fdes 0))) (if (= error-fdes 0) (set! error-fdes (dup->fdes 0))) (dup2 input-fdes 0))) (cond ((not (= output-fdes 1)) (if (= error-fdes 1) (set! error-fdes (dup->fdes 1))) (dup2 output-fdes 1))) (dup2 error-fdes 2))) (cond-expand ((not guile-2) (define (ensure-batch-mode!) (set-batch-mode?! #t)) (export ensure-batch-mode!)) (else)) (define (tail-call-program prog . args) "Replace the current process image by executing @var{prog} with the supplied list of arguments, @var{args}. This procedure will reset the signal handlers and attempt to set up file descriptors as follows: @enumerate @item File descriptor 0 is set from (current-input-port). @item File descriptor 1 is set from (current-output-port). @item File descriptor 2 is set from (current-error-port). @end enumerate If a port can not be used (e.g., because it's closed or it's a string port) then the file descriptor is opened on the file specified by @code{*null-device*} instead. Note that this procedure does not close any ports or flush output buffers. Successfully executing @var{prog} will prevent the normal flushing of buffers that occurs when Guile terminates. Doing otherwise would be incorrect after forking a child process, since the buffers would be flushed in both parent and child. Examples: @example (tail-call-program \"cat\" \"/etc/passwd\") @end example @example (with-input-from-file \"/etc/passwd\" (lambda () (tail-call-program \"cat\"))) @end example" (ensure-batch-mode!) (stdports->stdio) (apply execlp (cons prog (cons prog args)))) ;;; create a pipe with the writing end unbuffered. the reading end doesn't ;;; matter, making it unbuffered would just slow things down. (define (unbuffered-pipe) (let ((result (pipe))) (setvbuf (cdr result) _IONBF) result)) ;;; generate the code needed to set up redirections for a child process. (eval-when (eval load compile) (define (os:process:pipe-make-redir-commands connections portvar) (let next-conn ((conns connections) (insert (list)) ;; result (slave #f) (no-auto-close #f)) (cond ((null? conns) (cond (slave (next-conn conns (append insert (list ;; make a new session, drop old ctty. '(setsid) ;; get a new ctty if possible. '(cond ((isatty? (current-input-port)) ;; opening the tty should make ;; it the ctty, now we are the ;; session leader. (let ((name (ttyname (current-input-port))) (mode (port-mode (current-input-port)))) (close-port (current-input-port)) (set-current-input-port (open-file name mode)))) ;; try this too -- required ;; under BSD?. ;(%set-ctty (current-input-port)) ))) #f no-auto-close)) (no-auto-close (append insert (list `(map (lambda (p) (false-if-exception (close-fdes (fileno p)))) ,portvar)))) (else (append insert (list `(let loop ((pts (append (list (current-input-port) (current-output-port) (current-error-port)) ,portvar)) ; keep open. (fds (list))) ; fdes keep open. (if (null? pts) (port-for-each (lambda (p) (let ((f (false-if-exception (fileno p)))) (if (and f (not (memv f fds))) (false-if-exception (close-fdes f)))))) (loop (cdr pts) (let ((fd (false-if-exception (fileno (car pts))))) (if fd (cons fd fds) fds)))))))))) (else (let* ((c (car conns))) (cond ((eq? c #:slave) (next-conn (cdr conns) insert #t no-auto-close)) ((eq? c #:no-auto-close) (next-conn (cdr conns) insert slave #t)) ((eq? c #:foreground) ; would be processed earlier. (next-conn (cdr conns) insert slave no-auto-close)) ((= (length c) 1) (next-conn (cdr conns) (cons `(set! ,portvar (cons ,(car c) ,portvar)) insert) slave no-auto-close)) (else (let* ((reversed (number? (cadr c))) (in (if reversed (cadr c) (car c))) (out (if reversed (car c) (cadr c)))) (next-conn (cdr conns) (append (os:process:pipe-make-commands in out portvar) insert) slave no-auto-close))))))))) ;;; returns the commands for redirecting a single port in the child. (define (os:process:pipe-make-commands fdes port portvar) (if (= fdes 0) `((let ((newport (os:process:setup-redirected-port ,port ,fdes))) (set-current-input-port newport))) (if (= fdes 1) `((let ((newport (os:process:setup-redirected-port ,port ,fdes))) (set-current-output-port newport))) (if (= fdes 2) `((let ((newport (os:process:setup-redirected-port ,port ,fdes))) (set-current-error-port newport))) `((let ((newport (os:process:setup-redirected-port ,port ,fdes))) (set! ,portvar (cons newport ,portvar)))))))) ;;; safely redirect a port to a file descriptor. it must usually be ;;; duplicated, in case it's redirected more than once. (define (os:process:setup-redirected-port port fdes) (if (= (fileno port) fdes) port (let ((newport (duplicate-port port (port-mode port)))) (primitive-move->fdes newport fdes) newport)))) (defmacro-public run-concurrently+ (proc . connections) "Evaluate an expression in a new background process. If no connection terms are specified, then all ports except @code{current-input-port}, @code{current-output-port} and @code{current-error-port} will be closed in the new process. The file descriptors underlying these ports will not be changed. The value returned in the parent is the pid of the new process. When the process terminates its exit status can be collected using the @code{waitpid} procedure. Keywords can be specified before the connection list: @code{#:slave} causes the new process to be put into a new session. If @code{current-input-port} (after redirections) is a tty it will be assigned as the controlling terminal. This option is used when controlling a process via a pty. @code{#:no-auto-close} prevents the usual closing of ports which occurs by default. @code{#:foreground} makes the new process the foreground job of the controlling terminal, if the current process is using job control. (not currently implemented). The default is to place it into the background The optional connection list can take several forms: @code{(port)} usually specifies that a given port not be closed. However if @code{#:no-auto-close} is present it specifies instead a port which should be closed. @code{(port 0)} specifies that a port be moved to a given file descriptor (e.g., 0) in the new process. The order of the two components is not significant, but one must be a number and the other must evaluate to a port. If the file descriptor is one of the standard set @code{(0, 1, 2)} then the corresponding standard port (e.g., @code{current-input-port}) will be set to the specified port. Example: @example (let ((p (open-input-file \"/etc/passwd\"))) (run-concurrently+ (tail-call-program \"cat\") (p 0))) @end example" (let ((pid (gensym)) (ports (gensym))) `(let ((,pid (primitive-fork)) (,ports (list))) (cond ((= ,pid 0) ;; child (ensure-batch-mode!) ,@(os:process:pipe-make-redir-commands connections ports) ,proc (primitive-exit 1)) (else ,pid))))) (defmacro run+ (expr . connections) "Evaluate an expression in a new foreground process and wait for its completion. If no connection terms are specified, then all ports except @code{current-input-port}, @code{current-output-port} and @code{current-error-port} will be closed in the new process. The file descriptors underlying these ports will not be changed. The value returned is the exit status from the new process as returned by the @code{waitpid} procedure. The @var{keywords} and @var{connections} arguments are optional: see @code{run-concurrently+}, which is documented below. The @code{#:foreground} keyword is implied. @example (run+ (begin (write (+ 2 2)) (newline) (quit 0))) @end example @example (run+ (tail-call-program \"cat\" \"/etc/passwd\")) @end example" `(cdr (waitpid (run-concurrently+ ,expr #:foreground ,@connections)))) (define (run prog . args) "Execute @var{prog} in a new foreground process and wait for its completion. The value returned is the exit status of the new process as returned by the @code{waitpid} procedure. Example: @example (run \"cat\" \"/etc/passwd\") @end example" (run+ (apply tail-call-program prog args))) (define (run-concurrently . args) "Start a program running in a new background process. The value returned is the pid of the new process. When the process terminates its exit status can be collected using the @code{waitpid} procedure. Example: @example (run-concurrently \"cat\" \"/etc/passwd\") @end example" (run-concurrently+ (apply tail-call-program args))) (define (run-with-pipe mode prog . args) "Start @var{prog} running in a new background process. The value returned is a pair: the CAR is the pid of the new process and the CDR is either a port or a pair of ports (with the CAR containing the input port and the CDR the output port). The port(s) can be used to read from the standard output of the process and/or write to its standard input, depending on the @var{mode} setting. The value of @var{mode} should be one of \"r\", \"w\" or \"r+\". When the process terminates its exit status can be collected using the @code{waitpid} procedure. Example: @example (use-modules (ice-9 rdelim)) ; needed by read-line (define catport (cdr (run-with-pipe \"r\" \"cat\" \"/etc/passwd\"))) (read-line catport) @end example" (cond ((string=? mode OPEN_READ) (let* ((upipe (unbuffered-pipe)) (pid (run-concurrently+ (apply tail-call-program prog args) (1 (cdr upipe))))) (close-port (cdr upipe)) (cons pid (car upipe)))) ((string=? mode OPEN_WRITE) (let* ((upipe (unbuffered-pipe)) (pid (run-concurrently+ (apply tail-call-program prog args) (0 (car upipe))))) (close-port (car upipe)) (cons pid (cdr upipe)))) ((string=? mode OPEN_BOTH) (let* ((upipe-r (unbuffered-pipe)) (upipe-w (unbuffered-pipe)) (pid (run-concurrently+ (apply tail-call-program prog args) (0 (car upipe-w)) (1 (cdr upipe-r))))) (close-port (car upipe-w)) (close-port (cdr upipe-r)) (cons pid (cons (car upipe-r) (cdr upipe-w))))) (else (error "bad mode string: " mode)))) (defmacro tail-call-pipeline+ args "Replace the current process image with a pipeline of connected processes. Each process is specified by an expression and each pair of processes has a connection list with pairs of file descriptors. E.g., @code{((1 0) (2 0))} specifies that file descriptors 1 and 2 are to be connected to file descriptor 0. This may also be written as @code{((1 2 0))}. The expressions in the pipeline are run in new background processes. The foreground process waits for them all to terminate. The exit status is derived from the status of the process at the tail of the pipeline: its exit status if it terminates normally, otherwise 128 plus the number of the signal that caused it to terminate. The signal handlers will be reset and file descriptors set up as for @code{tail-call-program}. Like @code{tail-call-program} it does not close open ports or flush buffers. Example: @example (tail-call-pipeline+ (tail-call-program \"ls\" \"/etc\") ((1 0)) (tail-call-program \"grep\" \"passwd\")) @end example" (let* ((pipes (gensym)) (split-comps (pipe-split-components args)) (expressions (car split-comps)) (connections (cdr split-comps)) (pids (gensym))) `(let ((,pipes (cons (list) (list))) (,pids (list))) ,@(let loop ((rem-exps expressions) (rem-conns connections) (insert (list))) (cond ((null? rem-exps) insert) (else (loop (cdr rem-exps) (cdr rem-conns) (append insert `(;; update the pipes used by this child. (set! ,pipes (os:process:new-comm-pipes ,pipes ',(cadr rem-conns))) ;; start one child process. (set! ,pids (cons (os:process:pipe-fork-child ,(car rem-exps) ,(car rem-conns) ,(cadr rem-conns) ,pipes) ,pids)) ;; close used pipes in the parent. (map (lambda (pipe-list) (map close-port pipe-list)) (car ,pipes)))))))) ;; wait for all the processes to terminate and quit with the ;; exit status from the one at the tail of the pipe. ;; could save memory by exec'ing a tiny program to do the waiting. (ensure-batch-mode!) (let next-pid ((waiting-for (length ,pids)) (result 0)) (cond ((> waiting-for 0) (let* ((report (waitpid WAIT_ANY)) (pid (car report)) ;; if normal termination return the exit status, ;; otherwise 128 + the signal number. (status (let ((exit-val (status:exit-val (cdr report))) (term-sig (status:term-sig (cdr report)))) (or exit-val (+ term-sig 128))))) (cond ((member pid ,pids) ;; the pid list is reversed. (if (= pid (car ,pids)) (next-pid (- waiting-for 1) status) (next-pid (- waiting-for 1) result))) (else (next-pid waiting-for result))))) (else (primitive-exit result))))))) ;;; create pipes for communication: RHS connection list for a process. ;;; the previous set of pipes gets recycled to the LHS. (define (os:process:new-comm-pipes old-pipes out-conns) (cons (cdr old-pipes) (map (lambda (conn) (let ((rw-pair (unbuffered-pipe))) (let next-dup ((new-pipes (list (cdr rw-pair) (car rw-pair))) (count (- (length conn) 2))) (if (= count 0) (reverse new-pipes) (next-dup (cons (duplicate-port (car new-pipes) "w0") new-pipes) (- count 1)))))) out-conns))) ;;; fork a single child process, given redirections and pipes. (defmacro os:process:pipe-fork-child (expr in-conns out-conns pipes) `(run-concurrently+ ,expr #:no-auto-close ,@(append (let iloop ((count (- (length in-conns) 1)) (redirs (list))) (if (< count 0) redirs (iloop (- count 1) (append (let ((this-conn (list-ref in-conns count))) ;; may be several ports to close (dups). (let next-line ((dcount (- (length this-conn) 2)) (lines (list))) (if (< dcount 0) (append lines ;; redirect (port fdes). `(((car (list-ref (car ,pipes) ,count)) ,(car (reverse this-conn)))) redirs) (next-line (- dcount 1) (cons ;; close the other pipe ends. `((list-ref (list-ref (car ,pipes) ,count) ,(+ dcount 1))) lines))))))))) (let oloop ((count (- (length out-conns) 1)) (redirs (list))) (if (< count 0) redirs (oloop (- count 1) ;; may need several redirections (dups). (let ((this-conn (list-ref out-conns count))) (let next-line ((dcount (- (length this-conn) 2)) (lines (list))) (if (< dcount 0) (append lines ;; close the other pipe ends. `(((car (list-ref (cdr ,pipes) ,count)))) redirs) (next-line (- dcount 1) (cons ;; redirect (port fdes). `((list-ref (list-ref (cdr ,pipes) ,count) ,(+ dcount 1)) ,(list-ref this-conn dcount)) lines))))))))))) ;;; split a pipe into a process list and a connection list. (define (pipe-split-components ppe) (let loop ((remaining ppe) (do-expr? #t) ; track alternating process / connection. (exprs (list)) (connections (list))) (cond ((null? remaining) (cons (reverse exprs) ;; the null lists represent input and output from the pipe ;; ends. (cons (list) (reverse (cons (list) connections))))) (do-expr? (loop (cdr remaining) #f (cons (car remaining) exprs) connections)) (else (loop (cdr remaining) #t exprs (cons (remove-dup-connections! (car remaining)) connections)))))) ;;; convert connection spec like ((1 0)(2 0)) into ((1 2 0)). ;;; returns the mutated connection spec. (define (remove-dup-connections! connections) (let ((r-connections (map reverse connections))) (let next-left ((left r-connections)) (if (or (null? left) (null? (cdr left))) (map reverse r-connections) (let next-right ((right-1 left)) (let ((right (cdr right-1))) (if (null? right) (next-left (cdr left)) (cond ((= (caar left) (caar right)) (set-car! left (append (car left) (cdar right))) (set-cdr! right-1 (cdr right)) (next-right right-1)) (else (next-right (cdr right-1))))))))))) (defmacro tail-call-pipeline args "Replace the current process image with a pipeline of connected processes. The expressions in the pipeline are run in new background processes. The foreground process waits for them all to terminate. The exit status is derived from the status of the process at the tail of the pipeline: its exit status if it terminates normally, otherwise 128 plus the number of the signal that caused it to terminate. The signal handlers will be reset and file descriptors set up as for @code{tail-call-program}. Like @code{tail-call-program} it does not close open ports or flush buffers. Example: @example (tail-call-pipeline (\"ls\" \"/etc\") (\"grep\" \"passwd\")) @end example" `(tail-call-pipeline+ ,@(let next-arg ((rem args) (result (list))) (cond ((null? rem) (reverse result)) (else (next-arg (cdr rem) (let ((temp (cons `(tail-call-program ,@(car rem)) result))) (if (null? (cdr rem)) temp (cons '((1 0)) temp))))))))) ; try debugging a macro through a fork some day... ;(false-if-exception (delete-file "/tmp/goosh-debug")) ;(define-public (debug arg) ; (let ((p (open-file "/tmp/goosh-debug" "a"))) ; (write arg p) ; (newline p) ; (close-port p))) ;;; arch-tag: 74b1df36-abe4-4b5e-b40d-025ec64a9f8a ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/md5.scm�������������������������������������������������������������������������0000664�0000764�0000764�00000036155�11212576345�012316� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (md5) -- md5 hashing in scheme ;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc. ;; Copyright (C) 2004 Moritz Schulte <moritz@gnu.org>. ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU Lesser General Public License as ;; published by the Free Software Foundation, either version 3 of the ;; License, or (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public ;; License along with this program. If not, see ;; <http://www.gnu.org/licenses/>. #! ;;; Commentary: This code is heavily based on the MD5 implementation contained in Libgcrypt. To a certain degree this code is a literal translation from referenced C implementation into Scheme. ;;; Code: !# (define-module (md5) #:use-module (ice-9 rw) #:export (md5)) ;; General helper functions. (define (buffer->hexstring string) (define (buffer->hexstring-do string-rest string-new) (if (string-null? string-rest) string-new (let ((byte (char->integer (string-ref string-rest 0)))) (buffer->hexstring-do (substring string-rest 1) (string-append string-new (number->string (logand (ash byte -4) #xF) 16) (number->string (logand (ash byte -0) #xF) 16)))))) (buffer->hexstring-do string "")) (define (buffer->word buffer) (logior (ash (char->integer (string-ref buffer 0)) 0) (ash (char->integer (string-ref buffer 1)) 8) (ash (char->integer (string-ref buffer 2)) 16) (ash (char->integer (string-ref buffer 3)) 24))) (define (buffer->words buffer n) (define (buffer->words-do buffer i words) (if (= i n) words (buffer->words-do (substring buffer 4) (+ i 1) (append words `(,(buffer->word (substring buffer 0 4))))))) (buffer->words-do buffer 0 `())) (define (word->buffer word) (let ((buffer (make-string 4 #\nul))) (string-set! buffer 0 (integer->char (logand (ash word -0) #xFF))) (string-set! buffer 1 (integer->char (logand (ash word -8) #xFF))) (string-set! buffer 2 (integer->char (logand (ash word -16) #xFF))) (string-set! buffer 3 (integer->char (logand (ash word -24) #xFF))) buffer)) ;; Some math basics. (define f-add +) (define f-ash ash) (define (+ . args) (modulo (apply f-add args) #x100000000)) (define (ash x n) (modulo (f-ash x n) #x100000000)) (define (rol x n) (logior (ash x n) (ash x (- (- 32 n))))) ;; Return a new, initialized MD5 context. (define (md5-init) (let ((buffer-space (make-string 64 #\nul))) ;; Since this is a mutable state, cons it up (list (cons 'values (list (cons 'a #x67452301) (cons 'b #xEFCDAB89) (cons 'c #x98BADCFE) (cons 'd #x10325476))) (cons 'buffer (list (cons 'space buffer-space) (cons 'data-size 0))) (cons 'stats (list (cons 'blocks-processed 0)))))) (define (md5-func-f b c d) (logior (logand b c) (logand (lognot b) d))) (define (md5-func-g b c d) (logior (logand d b) (logand (lognot d) c))) (define (md5-func-h b c d) (logxor b c d)) (define (md5-func-i b c d) (logxor c (logior b (lognot d)))) (define-macro (md5-transform-op-round1 a b c d s T) `(begin (set! ,a (+ ,a (md5-func-f ,b ,c ,d) (list-ref words word-idx) ,T)) (set! word-idx (+ word-idx 1)) (set! ,a (rol ,a ,s)) (set! ,a (+ ,a ,b)))) (define-macro (md5-transform-op-round2/3/4 f a b c d k s T) `(begin (set! ,a (+ ,a (,f ,b ,c ,d) (list-ref words ,k) ,T)) (set! ,a (rol ,a ,s)) (set! ,a (+ ,a ,b)))) (define (md5-transform-block context data) (let ((words (buffer->words data 16)) (word-idx 0) (a (assq-ref (assq-ref context 'values) 'a)) (b (assq-ref (assq-ref context 'values) 'b)) (c (assq-ref (assq-ref context 'values) 'c)) (d (assq-ref (assq-ref context 'values) 'd))) ;; Round 1. (md5-transform-op-round1 a b c d 7 #xD76AA478) (md5-transform-op-round1 d a b c 12 #xE8C7B756) (md5-transform-op-round1 c d a b 17 #x242070DB) (md5-transform-op-round1 b c d a 22 #xC1BDCEEE) (md5-transform-op-round1 a b c d 7 #xF57C0FAF) (md5-transform-op-round1 d a b c 12 #x4787C62A) (md5-transform-op-round1 c d a b 17 #xA8304613) (md5-transform-op-round1 b c d a 22 #xFD469501) (md5-transform-op-round1 a b c d 7 #x698098D8) (md5-transform-op-round1 d a b c 12 #x8B44F7AF) (md5-transform-op-round1 c d a b 17 #xFFFF5BB1) (md5-transform-op-round1 b c d a 22 #x895CD7BE) (md5-transform-op-round1 a b c d 7 #x6B901122) (md5-transform-op-round1 d a b c 12 #xFD987193) (md5-transform-op-round1 c d a b 17 #xA679438E) (md5-transform-op-round1 b c d a 22 #x49B40821) ;; Round 2. (md5-transform-op-round2/3/4 md5-func-g a b c d 1 5 #xF61E2562) (md5-transform-op-round2/3/4 md5-func-g d a b c 6 9 #xC040B340) (md5-transform-op-round2/3/4 md5-func-g c d a b 11 14 #x265E5A51) (md5-transform-op-round2/3/4 md5-func-g b c d a 0 20 #xE9B6C7AA) (md5-transform-op-round2/3/4 md5-func-g a b c d 5 5 #xD62F105D) (md5-transform-op-round2/3/4 md5-func-g d a b c 10 9 #x02441453) (md5-transform-op-round2/3/4 md5-func-g c d a b 15 14 #xD8A1E681) (md5-transform-op-round2/3/4 md5-func-g b c d a 4 20 #xE7D3FBC8) (md5-transform-op-round2/3/4 md5-func-g a b c d 9 5 #x21E1CDE6) (md5-transform-op-round2/3/4 md5-func-g d a b c 14 9 #xC33707D6) (md5-transform-op-round2/3/4 md5-func-g c d a b 3 14 #xF4D50D87) (md5-transform-op-round2/3/4 md5-func-g b c d a 8 20 #x455A14ED) (md5-transform-op-round2/3/4 md5-func-g a b c d 13 5 #xA9E3E905) (md5-transform-op-round2/3/4 md5-func-g d a b c 2 9 #xFCEFA3F8) (md5-transform-op-round2/3/4 md5-func-g c d a b 7 14 #x676F02D9) (md5-transform-op-round2/3/4 md5-func-g b c d a 12 20 #x8D2A4C8A) ;; Round 3. (md5-transform-op-round2/3/4 md5-func-h a b c d 5 4 #xFFFA3942) (md5-transform-op-round2/3/4 md5-func-h d a b c 8 11 #x8771F681) (md5-transform-op-round2/3/4 md5-func-h c d a b 11 16 #x6D9D6122) (md5-transform-op-round2/3/4 md5-func-h b c d a 14 23 #xFDE5380C) (md5-transform-op-round2/3/4 md5-func-h a b c d 1 4 #xA4BEEA44) (md5-transform-op-round2/3/4 md5-func-h d a b c 4 11 #x4BDECFA9) (md5-transform-op-round2/3/4 md5-func-h c d a b 7 16 #xF6BB4B60) (md5-transform-op-round2/3/4 md5-func-h b c d a 10 23 #xBEBFBC70) (md5-transform-op-round2/3/4 md5-func-h a b c d 13 4 #x289B7EC6) (md5-transform-op-round2/3/4 md5-func-h d a b c 0 11 #xEAA127FA) (md5-transform-op-round2/3/4 md5-func-h c d a b 3 16 #xD4EF3085) (md5-transform-op-round2/3/4 md5-func-h b c d a 6 23 #x04881D05) (md5-transform-op-round2/3/4 md5-func-h a b c d 9 4 #xD9D4D039) (md5-transform-op-round2/3/4 md5-func-h d a b c 12 11 #xE6DB99E5) (md5-transform-op-round2/3/4 md5-func-h c d a b 15 16 #x1FA27CF8) (md5-transform-op-round2/3/4 md5-func-h b c d a 2 23 #xC4AC5665) ;; Round 4. (md5-transform-op-round2/3/4 md5-func-i a b c d 0 6 #xF4292244) (md5-transform-op-round2/3/4 md5-func-i d a b c 7 10 #x432AFF97) (md5-transform-op-round2/3/4 md5-func-i c d a b 14 15 #xAB9423A7) (md5-transform-op-round2/3/4 md5-func-i b c d a 5 21 #xFC93A039) (md5-transform-op-round2/3/4 md5-func-i a b c d 12 6 #x655B59C3) (md5-transform-op-round2/3/4 md5-func-i d a b c 3 10 #x8F0CCC92) (md5-transform-op-round2/3/4 md5-func-i c d a b 10 15 #xFFEFF47D) (md5-transform-op-round2/3/4 md5-func-i b c d a 1 21 #x85845DD1) (md5-transform-op-round2/3/4 md5-func-i a b c d 8 6 #x6FA87E4F) (md5-transform-op-round2/3/4 md5-func-i d a b c 15 10 #xFE2CE6E0) (md5-transform-op-round2/3/4 md5-func-i c d a b 6 15 #xA3014314) (md5-transform-op-round2/3/4 md5-func-i b c d a 13 21 #x4E0811A1) (md5-transform-op-round2/3/4 md5-func-i a b c d 4 6 #xF7537E82) (md5-transform-op-round2/3/4 md5-func-i d a b c 11 10 #xBD3AF235) (md5-transform-op-round2/3/4 md5-func-i c d a b 2 15 #x2AD7D2BB) (md5-transform-op-round2/3/4 md5-func-i b c d a 9 21 #xEB86D391) (assq-set! (assq-ref context 'values) 'a (+ (assq-ref (assq-ref context 'values) 'a) a)) (assq-set! (assq-ref context 'values) 'b (+ (assq-ref (assq-ref context 'values) 'b) b)) (assq-set! (assq-ref context 'values) 'c (+ (assq-ref (assq-ref context 'values) 'c) c)) (assq-set! (assq-ref context 'values) 'd (+ (assq-ref (assq-ref context 'values) 'd) d)))) (define (md5-write-do context data data-size) (if (= (assq-ref (assq-ref context 'buffer) 'data-size) 64) ;; Flush the buffer. (begin (md5-transform-block context (assq-ref (assq-ref context 'buffer) 'space)) (assq-set! (assq-ref context 'buffer) 'data-size 0) (assq-set! (assq-ref context 'stats) 'blocks-processed (+ (assq-ref (assq-ref context 'stats) 'blocks-processed) 1)))) (if (> data-size 0) (begin (if (> (assq-ref (assq-ref context 'buffer) 'data-size) 0) ;; Fill buffer. (while (and (> data-size 0) (< (assq-ref (assq-ref context 'buffer) 'data-size) 64)) (begin (string-set! (assq-ref (assq-ref context 'buffer) 'space) (assq-ref (assq-ref context 'buffer) 'data-size) (string-ref data 0)) (assq-set! (assq-ref context 'buffer) 'data-size (+ (assq-ref (assq-ref context 'buffer) 'data-size) 1)) (set! data (substring data 1)) (set! data-size (- data-size 1))))) ;; Transform whole blocks. (while (>= data-size 64) (begin (md5-transform-block context data) (assq-set! (assq-ref context 'stats) 'blocks-processed (+ (assq-ref (assq-ref context 'stats) 'blocks-processed) 1)) (set! data-size (- data-size 64)) (set! data (substring data 64)))) ;; Fill buffer. (while (and (> data-size 0) (< (assq-ref (assq-ref context 'buffer) 'data-size) 64)) (begin (string-set! (assq-ref (assq-ref context 'buffer) 'space) (assq-ref (assq-ref context 'buffer) 'data-size) (string-ref data 0)) (assq-set! (assq-ref context 'buffer) 'data-size (+ (assq-ref (assq-ref context 'buffer) 'data-size) 1)) (set! data-size (- data-size 1)) (set! data (substring data 1))))))) ;; Write data to context. (define (md5-write context data data-size) (md5-write-do context data data-size)) ;; Finalize context, return hash. (define (md5-finalize context) (let ((t 0) (msb 0) (lsb 0)) (md5-write-do context "" 0) (set! t (assq-ref (assq-ref context 'stats) 'blocks-processed)) (set! lsb (ash t 6)) (set! msb (ash t -26)) (set! t lsb) (set! lsb (+ lsb (assq-ref (assq-ref context 'buffer) 'data-size))) (if (< lsb t) (set! msb (+ msb 1))) (set! t lsb) (set! lsb (ash lsb 3)) (set! msb (ash msb 3)) (set! msb (logior msb (ash t -29))) (if (< (assq-ref (assq-ref context 'buffer) 'data-size) 56) (begin (string-set! (assq-ref (assq-ref context 'buffer) 'space) (assq-ref (assq-ref context 'buffer) 'data-size) (integer->char #x80)) (assq-set! (assq-ref context 'buffer) 'data-size (+ (assq-ref (assq-ref context 'buffer) 'data-size) 1)) (while (< (assq-ref (assq-ref context 'buffer) 'data-size) 56) (begin (string-set! (assq-ref (assq-ref context 'buffer) 'space) (assq-ref (assq-ref context 'buffer) 'data-size) #\nul) (assq-set! (assq-ref context 'buffer) 'data-size (+ (assq-ref (assq-ref context 'buffer) 'data-size) 1))))) (begin (string-set! (assq-ref (assq-ref 'context 'buffer) 'space) (assq-ref (assq-ref 'context 'buffer) 'data-size) (integer->char #x80)) (while (< (assq-ref (assq-ref context 'buffer) 'data-size) 64) (begin (string-set! (assq-ref (assq-ref context 'buffer) 'space) (assq-ref (assq-ref context 'buffer) 'data-size) 0) (assq-set! (assq-ref context 'buffer) 'data-size (+ (assq-ref (assq-ref context 'buffer) 'data-size) 1)))) (md5-write-do context "" 0) (substring-fill! (assq-ref (assq-ref context 'buffer) 'space) 0 56 #\nul))) (let ((final-string (map (lambda (x) (integer->char (logand x #xFF))) `(,lsb ,(ash lsb -8) ,(ash lsb -16) ,(ash lsb -24) ,msb ,(ash msb -8) ,(ash msb -16) ,(ash msb -24)))) (buffer (assq-ref (assq-ref context 'buffer) 'space))) (string-set! buffer 56 (list-ref final-string 0)) (string-set! buffer 57 (list-ref final-string 1)) (string-set! buffer 58 (list-ref final-string 2)) (string-set! buffer 59 (list-ref final-string 3)) (string-set! buffer 60 (list-ref final-string 4)) (string-set! buffer 61 (list-ref final-string 5)) (string-set! buffer 62 (list-ref final-string 6)) (string-set! buffer 63 (list-ref final-string 7))) (md5-transform-block context (assq-ref (assq-ref context 'buffer) 'space)) (buffer->hexstring (string-append (word->buffer (assq-ref (assq-ref context 'values) 'a)) (word->buffer (assq-ref (assq-ref context 'values) 'b)) (word->buffer (assq-ref (assq-ref context 'values) 'c)) (word->buffer (assq-ref (assq-ref context 'values) 'd)))))) (define (general-read-string!/partial buffer port) (if (file-port? port) (read-string!/partial buffer port) (let ((max-index (- (string-length buffer) 1))) (let loop ((ch (read-char port)) (read 0)) (if (eof-object? ch) (if (= read 0) #f read) (begin (string-set! buffer read ch) (if (< read max-index) (loop (read-char port) (+ read 1)) (+ read 1)))))))) (define (md5 . port) "Reads data from @var{port}, and returns a string containing the calculated md5 hash of the data. If @var{port} is not given, then the default input port is used." (define (process-data buffer port callback arg) (define (process-data-do) (let ((bytes-read (general-read-string!/partial buffer port))) (if (not bytes-read) #t (begin (callback arg buffer bytes-read) (process-data-do))))) (process-data-do)) (define (process-data-callback arg data data-size) (md5-write arg data data-size)) (if (null? port) (set! port (current-input-port)) (set! port (car port))) (let* ((context (md5-init)) (buffer-size 4096) (buffer (make-string buffer-size #\nul))) (process-data buffer port process-data-callback context) (md5-finalize context))) ;; arch-tag: 03A57FCF-F9E7-11D8-A6BC-000A95CD5044 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/unit-test.scm�������������������������������������������������������������������0000664�0000764�0000764�00000023411�11137621525�013551� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (unit-test) -- a JUnit-like testing framework for Guile ;; Original code by John Maxwell <jmax@toad.net> ;; Copyright (C) 2003 Richard Todd ;; Copyright (C) 2004,2005 Andreas Rottmann ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; This code originally came from ;; http://article.gmane.org/gmane.lisp.guile.user/1728. (define-module (unit-test) #:use-module (oop goops) #:use-module (srfi srfi-1) #:use-module (ice-9 format) #:use-module (ice-9 pretty-print) #:export (assert-equal assert-true assert-numeric-= <test-result> tests-run tests-failed tests-log failure-messages test-started test-failed summary <test-case> name set-up-test tear-down-test run <test-suite> tests add run-all-defined-test-cases exit-with-summary) #:export-syntax (assert-exception)) ;; Utility method for finding an object's method given its name. The ;; equivalent probably already exists somewhere in the MOP, but the doc ;; is a little sketchy. (define-method (lookup-method (object <object>) (name <string>)) (or (any (lambda (method) (let ((gf (method-generic-function method))) (if (string=? name (symbol->string (generic-function-name gf))) gf #f))) (class-direct-methods (class-of object))) (throw 'no-such-method-exception (string-append name ": no such method in class " (symbol->string (class-name (class-of object))))))) ;; Utility method for finding out whether a method is a slot-accessor ;; method for a particular class. (define-method (slot-accessor? (object <object>) (method-name <string>)) (any (lambda (slot) (or (and (slot-definition-getter slot) (string=? method-name (symbol->string (generic-function-name (slot-definition-getter slot))))) (and (slot-definition-setter slot) (string=? method-name (symbol->string (generic-function-name (slot-definition-setter slot))))) (and (slot-definition-accessor slot) (string=? method-name (symbol->string (generic-function-name (slot-definition-accessor slot))))))) (class-slots (class-of object)))) (define (assert-equal expected got) (if (not (equal? expected got)) (throw 'test-failed-exception (with-output-to-string (lambda () (display "assert-equal: expected:\n") (pretty-print expected) (display "\ngot: \n") (pretty-print got)))))) (define (assert-true got) (if (not got) (throw 'test-failed-exception (with-output-to-string (lambda () (display "assert-true: ") (display " got: ") (write got)))))) (define (assert-numeric-= expected got precision) (if (> (abs (- expected got)) precision) (throw 'test-failed-exception (with-output-to-string (lambda () (display "assert-true: ") (display " got: ") (write got)))))) (define-macro (assert-exception expression) `(catch #t (lambda () ,expression (throw 'test-failed-exception (format #f "assert-exception: no exception on ~S" ',expression))) (lambda (key . args) (case key ((test-failed-exception) (apply throw key args)) (else #t))))) ;;;---------------------------------------------------------------- (define-class <test-result> () (tests-run-count #:init-value 0 #:accessor tests-run) (tests-failed-count #:init-value 0 #:accessor tests-failed) (tests-log-messages #:init-value '() #:accessor tests-log) (test-failure-messages #:init-value '() #:accessor failure-messages)) (define-method (test-started (self <test-result>) (description <string>)) (set! (tests-log self) (append (tests-log self) `(,description))) (set! (tests-run self) (+ 1 (tests-run self)))) (define-method (test-failed (self <test-result>) (description <string>)) (set! (failure-messages self) (append (failure-messages self) `(,description))) (set! (tests-failed self) (+ 1 (tests-failed self)))) (define-method (summary (self <test-result>)) (format #f "~S run, ~S failed" (tests-run self) (tests-failed self))) ;;;---------------------------------------------------------------- (define-class <test-case> () (name-value #:init-value "" #:accessor name #:init-keyword #:name)) (define-method (name-if-set (self <test-case>)) (if (string-null? (name self)) (symbol->string (class-name (class-of self))) (name self))) (define-method (set-up-test (self <test-case>))) (define-method (tear-down-test (self <test-case>))) (define-method (run (self <test-case>) (result <test-result>)) (display (string-append "Running test case: " (name-if-set self) "\n") (current-error-port)) (catch #t (lambda () (set-up-test self) (test-started result (name-if-set self)) (catch #t (lambda () (catch 'test-failed-exception (lambda () ((lookup-method self (name-if-set self)) self)) (lambda (exception description) (test-failed result (with-output-to-string (lambda () (display (name-if-set self)) (display " failed: ") (display description))))))) (lambda throw-args (test-failed result (with-output-to-string (lambda () (display (name-if-set self)) (display ": exception in test: ") (write throw-args)))))) (tear-down-test self)) (lambda throw-args (test-failed result (with-output-to-string (lambda () (display (name-if-set self)) (display ": exception in set up: ") (write throw-args))))))) ;;;---------------------------------------------------------------- (define-class <test-suite> () (tests-value #:init-value '() #:accessor tests #:init-keyword #:tests) (suite-name #:init-value "unknown" #:accessor name #:init-keyword #:name)) (define-method (test-case-suite (self <test-case>)) (make <test-suite> #:name (string-append (name-if-set self) "-suite") #:tests (map (lambda (method-name) (make (class-of self) #:name method-name)) (filter (lambda (method-name) (and (>= (string-length method-name) 4) (string=? "test" (substring method-name 0 4)) (not (slot-accessor? self method-name)))) (map (lambda (method) (symbol->string (generic-function-name (method-generic-function method)))) (class-direct-methods (class-of self))))))) (define-method (add (self <test-suite>) (test <test-case>)) (set! (tests self) (cons (test-case-suite test) (tests self)))) (define-method (add (self <test-suite>) (suite <test-suite>)) (set! (tests self) (cons suite (tests self)))) (define-method (run (self <test-suite>) (result <test-result>)) (display (string-append "\nRunning test suite: " (name self) " " (make-string (max (- 50 (string-length (name self))) 0) #\-) "\n") (current-error-port)) (for-each (lambda (test) (run test result)) (reverse! (tests self)))) ;; returns the results of running all the subclasses of <test-case> (define (run-all-defined-test-cases) (let ((my-suite (make <test-suite> #:name "main-suite")) (result (make <test-result>))) ;; add in an instance of each subclass of <test-case> (for-each (lambda (cl) (add my-suite (make cl))) (class-subclasses <test-case>)) (run my-suite result) result)) (define (exit-with-summary result) (for-each (lambda (fm) (display fm (current-error-port))(newline (current-error-port))) (failure-messages result)) (newline (current-error-port)) (display (summary result) (current-error-port))(newline (current-error-port)) (exit (if (> (tests-failed result) 0) 1 0))) ;;; arch-tag: 5411e756-a264-40a1-a7bb-28b55f339029 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/string/�������������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�012471� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/string/soundex.scm��������������������������������������������������������������0000664�0000764�0000764�00000007665�11137623003�014616� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (string soundex) -- the soundex algorithm ;; Based on soundex.scm from SLIB, by jjb@isye.gatech.edu. ;; Copyright (C) 2003 Richard Todd ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. #! ;;; Commentary: Soundex algorithm, taken from Knuth, Vol. 3 ``Sorting and searching'', pp 391--2 ;;; Code: !# (define-module (string soundex) #:export (soundex) #:use-module (scheme documentation) #:use-module (srfi srfi-1)) (define-with-docs soundex "Performs the original soundex algorithm on the input @var{name}. Returns the encoded string. The idea is for similar sounding sames to end up with the same encoding. @lisp (soundex \"Aiza\") => \"A200\" (soundex \"Aisa\") => \"A200\" (soundex \"Aesha\") => \"A200\" @end lisp" (let* ((letters-to-omit (list #\A #\E #\H #\I #\O #\U #\W #\Y)) (codes (list (list #\B #\1) (list #\F #\1) (list #\P #\1) (list #\V #\1) ;; (list #\C #\2) (list #\G #\2) (list #\J #\2) (list #\K #\2) (list #\Q #\2) (list #\S #\2) (list #\X #\2) (list #\Z #\2) ;; (list #\D #\3) (list #\T #\3) ;; (list #\L #\4) ;; (list #\M #\5) (list #\N #\5) ;; (list #\R #\6))) (xform (lambda (c) (let ((code (assv c codes))) (if code (cadr code) c))))) (lambda (name) (let ((char-list (map char-upcase (remove (lambda (c) (not (char-alphabetic? c))) (string->list name))))) (if (null? char-list) name (let* ( ;; Replace letters except first with codes: (n1 (cons (car char-list) (map xform char-list))) ;; If 2 or more letter with same code are adjacent ;; in the original name, omit all but the first: (n2 (let loop ((chars n1)) (cond ((null? (cdr chars)) chars) (else (if (char=? (xform (car chars)) (cadr chars)) (loop (cdr chars)) (cons (car chars) (loop (cdr chars)))))))) ;; Omit vowels and similar letters, except first: (n3 (cons (car char-list) (remove (lambda (c) (memv c letters-to-omit)) (cdr n2))))) ;; ;; pad with 0's or drop rightmost digits until of form "annn": (let loop ((rev-chars (reverse n3))) (let ((len (length rev-chars))) (cond ((= 4 len) (list->string (reverse rev-chars))) ((> 4 len) (loop (cons #\0 rev-chars))) ((< 4 len) (loop (cdr rev-chars)))))))))))) ;;; arch-tag: 978c72d5-40bd-4e76-9af0-a74222a77b65 ���������������������������������������������������������������������������guile-lib-0.2.1/src/string/completion.scm�����������������������������������������������������������0000664�0000764�0000764�00000023101�11137622753�015274� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (string completion) -- a tab completion library ;; Copyright (C) 2003 Richard Todd ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. #! ;;; Commentary: This module provides a facility that can be used to implement features such as TAB-completion in programs. A class @code{<string-completer>} tracks all the potential complete strings. Here is an example usage. @lisp (use-modules (string completion) (oop goops) (srfi srfi-11)) ;; for the (let-values) (define c (make <string-completer>)) (add-strings! c "you your yourself yourselves") (let-values (((completions expansion exact? unique?) (complete c "yours"))) (display completions)(newline) (display expansion) (newline) (display exact?)(newline) (display unique?)(newline)) ==> ("yourself" "yourselves") "yoursel" #f #f @end lisp There are several more options for usage, which are detailed in the class and method documentation. ;;; Code: !# (define-module (string completion) #:export (<string-completer> case-sensitive-completion? add-strings! all-completions complete ) #:use-module (search basic) #:use-module (srfi srfi-13) #:use-module (scheme documentation) #:use-module (oop goops)) (define-generic-with-docs case-sensitive-completion? "@code{case-sensitive-completion? completer}. Returns @code{#t} if the completer is case-sensitive, and @code{#f} otherwise.") (define-class-with-docs <string-completer> () "This is the class that knows what the possible expansions are, and can determine the completions of given partial strings. The following are the recognized keywords on the call to @code{make}: @table @code @item #:strings This gives the completer an initial set of strings. It is optional, and the @code{add-strings!} method can add strings to the completer later, whether these initial strings were given or not. The strings that follow this keyword can take any form that the @code{add-strings!} method can take (see below). @item #:case-sensitive? This is a boolean that directs the completer to do its comparisons in a case sensiteve way or not. The default value is @code{#t}, for case-sensitive behavior. @end table" (strings #:init-value #() #:accessor completer-strings #:init-keyword #:strings) (case-sensitive? #:init-value #t #:getter case-sensitive-completion? #:init-keyword #:case-sensitive?)) (define-method (initialize (sc <string-completer>) initargs) (next-method) (if (not (vector? (completer-strings sc))) (add-strings! sc (completer-strings sc))) sc) (define-generic-with-docs add-strings! "@code{add-strings! completer strings}. Adds the given strings to the set of possible comletions known to @var{completer}. @var{strings} can either be a list of strings, or a single string of words separated by spaces. The order of the words given is not important.") (define-method (add-strings! (sc <string-completer>) strings) (let ((comparison-func (if (case-sensitive-completion? sc) string<? string-ci<?))) (cond ((string? strings) (set! (completer-strings sc) (list->vector (sort (append (vector->list (completer-strings sc)) (string-split strings #\space)) comparison-func)))) ((list? strings) (set! (completer-strings sc) (list->vector (sort (append (vector->list (completer-strings sc)) strings) comparison-func)))) (else (throw 'bad-type "expecting string or list"))) #t)) (define (case-sensitive-partial-compare partial str2) (let ((len1 (string-length partial)) (len2 (string-length str2))) (cond ((= len2 len1) (cond ((string<? partial str2) -1) ((string>? partial str2) 1) (else 0))) ;; If partial is longer, then either it is less than the other string, ;; or we will call it > (even if the length they share is =) ((> len1 len2) (if (string<? partial str2) -1 1)) (else (let ((newstr2 (substring str2 0 len1))) (cond ((string<? partial newstr2) -1) ((string>? partial newstr2) 1) (else 0))))))) (define (case-insensitive-partial-compare partial str2) (let ((len1 (string-length partial)) (len2 (string-length str2))) (cond ((= len2 len1) (cond ((string-ci<? partial str2) -1) ((string-ci>? partial str2) 1) (else 0))) ;; If partial is longer, then either it is less than the other string, ;; or we will call it > (even if the length they share is =) ((> len1 len2) (if (string-ci<? partial str2) -1 1)) (else (let ((newstr2 (substring str2 0 len1))) (cond ((string-ci<? partial newstr2) -1) ((string-ci>? partial newstr2) 1) (else 0))))))) (define (all-completions completer str) "Returns a list of all possible completions for the given string @var{str}. The returned list will be in alphabetical order. Note that users wanting to customize the completion algorithm can subclass @code{<string-completer>} and override this method." (if (string-null? str) (vector->list (completer-strings completer)) (let* ((vec (completer-strings completer)) (compare (if (case-sensitive-completion? completer) case-sensitive-partial-compare case-insensitive-partial-compare)) (found (binary-search-sorted-vector vec str compare))) (if (not found) '() (let loop ((index (- found 1)) (ans (cons (vector-ref vec found) (let innerloop ((index (+ found 1)) (ans '())) (if (= index (vector-length vec)) (reverse! ans) (let ((cur (vector-ref vec index))) (if (= (compare str cur) 0) (innerloop (+ index 1) (cons cur ans)) (reverse! ans)))))))) (if (< index 0) ans (let ((cur (vector-ref vec index))) ;; is this string less than our partial target? (if (= (compare str cur) 0) (loop (- index 1) (cons cur ans)) ans)))))))) (define-generic-with-docs complete "@code{complete completer str}. Accepts a string, @var{str}, and returns four values via a @code{values} call. These are: @table @var @item completions This is the same list that would be returned from a call to @code{all-completions}. @item expansion This is the longest string that would have returned identical results. In other words, this is what most programs replace your string with when you press TAB once. This value will be equal to @var{str} if there were no known completionss. @example (\"wonders\" \"wonderment\" \"wondering\") completed against \"won\" yields an expansion of \"wonder\" @end example @item exact? This will be @code{#t} if the returned @var{expansion} is an exact match of one of the possible completions. @item unique? This will be #t if there is only one possible completion. Note that when @var{unique?} is @code{#t}, then @var{exact?} will also be @code{#t}. @end table") (define-method (complete (sc <string-completer>) str) (let ((longest-substring str) (exact-match? #f) (unique? #f) (completions (all-completions sc str)) (s-p-l (if (case-sensitive-completion? sc) string-prefix-length string-prefix-length-ci)) (s=? (if (case-sensitive-completion? sc) string=? string-ci=?))) (if (not (null? completions)) (begin (set! longest-substring (car completions)) (set! unique? (null? (cdr completions))) (for-each (lambda (s) (set! longest-substring (substring longest-substring 0 (s-p-l longest-substring s)))) completions) (set! exact-match? (s=? (car completions) longest-substring)))) (values completions longest-substring exact-match? unique?))) ;;; arch-tag: cb29925e-b24e-4a69-a1f3-9595db6b7bbf ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/string/transform.scm������������������������������������������������������������0000664�0000764�0000764�00000023067�11137623044�015143� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (string transform) -- some string transformation utilities ;; Copyright (C) 2003 Richard Todd ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. #! ;;; Commentary: Module @samp{(string transform)} provides functions for modifying strings beyond that which is provided in the guile core and @samp{(srfi srfi-13)}. ;;; Code: !# (define-module (string transform) #:export (escape-special-chars transform-string expand-tabs center-string left-justify-string right-justify-string collapse-repeated-chars) #:use-module (ice-9 optargs) #:use-module (srfi srfi-13)) (define* (transform-string str match? replace #:optional (start #f) (end #f)) "Uses @var{match?} against each character in @var{str}, and performs a replacement on each character for which matches are found. @var{match?} may either be a function, a character, a string, or @code{#t}. If @var{match?} is a function, then it takes a single character as input, and should return @samp{#t} for matches. @var{match?} is a character, it is compared to each string character using @code{char=?}. If @var{match?} is a string, then any character in that string will be considered a match. @code{#t} will cause every character to be a match. If @var{replace} is a function, it is called with the matched character as an argument, and the returned value is sent to the output string via @samp{display}. If @var{replace} is anything else, it is sent through the output string via @samp{display}. Note that te replacement for the matched characters does not need to be a single character. That is what differentiates this function from @samp{string-map}, and what makes it useful for applications such as converting @samp{#\\&} to @samp{\"&\"} in web page text. Some other functions in this module are just wrappers around common uses of @samp{transform-string}. Transformations not possible with this function should probably be done with regular expressions. If @var{start} and @var{end} are given, they control which portion of the string undergoes transformation. The entire input string is still output, though. So, if @var{start} is @samp{5}, then the first five characters of @var{str} will still appear in the returned string. @lisp ; these two are equivalent... (transform-string str #\\space #\\-) ; change all spaces to -'s (transform-string str (lambda (c) (char=? #\\space c)) #\\-) @end lisp" ;; I had implemented this with string-fold, but it was ;; slower... (let* ((os (open-output-string)) (matcher (cond ((char? match?) (lambda (c) (char=? match? c))) ((procedure? match?) match?) ((string? match?) (lambda (c) (string-index match? c))) ((boolean? match?) (lambda (c) match?)) (else (throw 'bad-type "expected #t, char, string, or procedure")))) (replacer (if (procedure? replace) (lambda (c) (display (replace c) os)) (lambda (c) (display replace os))))) ;; put the first part in, un-transformed if they asked for it... (if (and start (<= start (string-length str))) (display (substring str 0 start) os)) ;; process the portion they want processed.... (string-for-each (lambda (c) (if (matcher c) ;; we have a match! replace the char as directed... (replacer c) ;; not a match, just insert the character itself... (write-char c os))) str (or start 0) (or end (string-length str))) ;; if there was any at the end, tack it on... (if (and end (< end (string-length str))) (display (substring str end) os)) (get-output-string os))) (define* (expand-tabs str #:optional (tab-size 8)) "Returns a copy of @var{str} with all tabs expanded to spaces. @var{tab-size} defaults to 8. Assuming tab size of 8, this is equivalent to: @lisp (transform-string str #\\tab \" \") @end lisp" (transform-string str #\tab (make-string tab-size #\space))) (define (escape-special-chars str special-chars escape-char) "Returns a copy of @var{str} with all given special characters preceded by the given @var{escape-char}. @var{special-chars} can either be a single character, or a string consisting of all the special characters. @lisp ;; make a string regexp-safe... (escape-special-chars \"***(Example String)***\" \"[]()/*.\" #\\\\) => \"\\\\*\\\\*\\\\*\\\\(Example String\\\\)\\\\*\\\\*\\\\*\" ;; also can escape a singe char... (escape-special-chars \"richardt@@vzavenue.net\" #\\@@ #\\@@) => \"richardt@@@@vzavenue.net\" @end lisp" (transform-string str (if (char? special-chars) ;; if they gave us a char, use char=? (lambda (c) (char=? c special-chars)) ;; if they gave us a string, see if our character is in it (lambda (c) (string-index special-chars c))) ;; replace matches with the character preceded by the escape character (lambda (c) (string escape-char c)))) (define* (center-string str #:optional (width 80) (chr #\space) (rchr #f)) "Returns a copy of @var{str} centered in a field of @var{width} characters. Any needed padding is done by character @var{chr}, which defaults to @samp{#\\space}. If @var{rchr} is provided, then the padding to the right will use it instead. See the examples below. left and @var{rchr} on the right. The default @var{width} is 80. The default @var{lchr} and @var{rchr} is @samp{#\\space}. The string is never truncated. @lisp (center-string \"Richard Todd\" 24) => \" Richard Todd \" (center-string \" Richard Todd \" 24 #\\=) => \"===== Richard Todd =====\" (center-string \" Richard Todd \" 24 #\\< #\\>) => \"<<<<< Richard Todd >>>>>\" @end lisp" (let* ((len (string-length str)) (lpad (make-string (max (quotient (- width len) 2) 0) chr)) ;; right-char == char unless it has been provided by the user (right-chr (or rchr chr)) (rpad (if (char=? right-chr chr) lpad (make-string (max (quotient (- width len) 2) 0) right-chr)))) (if (>= len width) str (string-append lpad str rpad (if (odd? (- width len)) (string right-chr) ""))))) (define* (left-justify-string str #:optional (width 80) (chr #\space)) "@code{left-justify-string str [width chr]}. Returns a copy of @var{str} padded with @var{chr} such that it is left justified in a field of @var{width} characters. The default @var{width} is 80. Unlike @samp{string-pad} from srfi-13, the string is never truncated." (let* ((len (string-length str)) (pad (make-string (max (- width len) 0) chr))) (if (>= len width) str (string-append str pad)))) (define* (right-justify-string str #:optional (width 80) (chr #\space)) "Returns a copy of @var{str} padded with @var{chr} such that it is right justified in a field of @var{width} characters. The default @var{width} is 80. The default @var{chr} is @samp{#\\space}. Unlike @samp{string-pad} from srfi-13, the string is never truncated." (let* ((len (string-length str)) (pad (make-string (max (- width len) 0) chr))) (if (>= len width) str (string-append pad str)))) (define* (collapse-repeated-chars str #:optional (chr #\space) (num 1)) "Returns a copy of @var{str} with all repeated instances of @var{chr} collapsed down to at most @var{num} instances. The default value for @var{chr} is @samp{#\\space}, and the default value for @var{num} is 1. @lisp (collapse-repeated-chars \"H e l l o\") => \"H e l l o\" (collapse-repeated-chars \"H--e--l--l--o\" #\\-) => \"H-e-l-l-o\" (collapse-repeated-chars \"H-e--l---l----o\" #\\- 2) => \"H-e--l--l--o\" @end lisp" ;; define repeat-locator as a stateful match? function which remembers ;; the last character it had seen. (let ((repeat-locator ;; initialize prev-chr to something other than what we're seeking... (let ((prev-chr (if (char=? chr #\space) #\A #\space)) (match-count 0)) (lambda (c) (if (and (char=? c prev-chr) (char=? prev-chr chr)) ;; found enough duplicates if the match-count is high enough (begin (set! match-count (+ 1 match-count)) (>= match-count num)) ;; did not find a duplicate (begin (set! match-count 0) (set! prev-chr c) #f)))))) ;; transform the string with our stateful matcher... ;; deleting matches... (transform-string str repeat-locator ""))) ;;; arch-tag: 71550291-cf61-4ddd-bb50-2386b4d38756 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/string/wrap.scm�����������������������������������������������������������������0000664�0000764�0000764�00000021212�11212456355�014072� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (string wrap) -- text filling and wrapping ;; Copyright (C) 2003 Richard Todd ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. #! ;;; Commentary: Module @samp{(string wrap)} provides functions for formatting text strings such that they fill a given width field. A class, @code{<text-wrapper>}, does the work, but two convenience methods create instances of it for one-shot use, and in the process make for a more ``schemey'' interface. If many strings will be formatted with the same parameters, it might be better performance-wise to create and use a single @code{<text-wrapper>}. ;;; Code: !# (define-module (string wrap) #:export (<text-wrapper> fill-string string->wrapped-lines) #:use-module (srfi srfi-13) #:use-module (srfi srfi-14) #:use-module (string transform) #:use-module (scheme documentation) #:use-module (oop goops)) (define-class-with-docs <text-wrapper> () "This class encapsulates the parameters needing to be fed to the text wrapping algorithm. The following are the recognized keywords on the call to @code{make}: @table @code @item #:line-width This is the target length used when deciding where to wrap lines. Default is 80. @item #:expand-tabs? Boolean describing whether tabs in the input should be expanded. Default is #t. @item #:tab-width If tabs are expanded, this will be the number of spaces to which they expand. Default is 8. @item #:collapse-whitespace? Boolean describing whether the whitespace inside the existing text should be removed or not. Default is #t. If text is already well-formatted, and is just being wrapped to fit in a different width, then setting this to @samp{#f}. This way, many common text conventions (such as two spaces between sentences) can be preserved if in the original text. If the input text spacing cannot be trusted, then leave this setting at the default, and all repeated whitespace will be collapsed down to a single space. @item #:initial-indent Defines a string that will be put in front of the first line of wrapped text. Default is the empty string, ``''. @item #:subsequent-indent Defines a string that will be put in front of all lines of wrapped text, except the first one. Default is the empty string, ``''. @item #:break-long-words? If a single word is too big to fit on a line, this setting tells the wrapper what to do. Defaults to #t, which will break up long words. When set to #f, the line will be allowed, even though it is longer than the defined @code{#:line-width}. @end table Here's an example of creating a @code{<text-wrapper>}: @lisp (make <text-wrapper> #:line-width 48 #:break-long-words? #f) @end lisp" (width #:init-value 80 #:getter line-width #:init-keyword #:line-width) (expand-tabs #:init-value #t #:getter expand-tabs? #:init-keyword #:expand-tabs?) (tab-width #:init-value 8 #:getter tab-width #:init-keyword #:tab-width) (collapse-whitespace #:init-value #t #:getter collapse-whitespace? #:init-keyword #:collapse-whitespace?) (subsequent-indent #:init-value "" #:getter subsequent-indent #:init-keyword #:subsequent-indent) (initial-indent #:init-value "" #:getter initial-indent #:init-keyword #:initial-indent) (break-long-words? #:init-value #t #:getter break-long-words? #:init-keyword #:break-long-words?)) (define-generic-with-docs fill-string "@code{fill-string str keywds ...}. Wraps the text given in string @var{str} according to the parameters provided in @var{keywds}, or the default setting if they are not given. Returns a single string with the wrapped text. Valid keyword arguments are discussed with the @code{<text-wrapper>} class. @code{fill-string tw str}. fills @var{str} using the instance of @code{<text-wrapper>} given as @var{tw}.") (define-method (fill-string str . keywds) (string-join (apply string->wrapped-lines (cons str keywds)) "\n" 'infix)) (define-method (fill-string (tw <text-wrapper>) str) (string-join (string->wrapped-lines tw str) "\n" 'infix)) (define-generic-with-docs string->wrapped-lines "@code{string->wrapped-lines str keywds ...}. Wraps the text given in string @var{str} according to the parameters provided in @var{keywds}, or the default setting if they are not given. Returns a list of strings representing the formatted lines. Valid keyword arguments are discussed with the @code{<text-wrapper>} class. @code{string->wrapped-lines tw str}. Wraps the text given in string @var{str} according to the given @code{<text-wrapper>} @var{tw}. Returns a list of strings representing the formatted lines. Valid keyword arguments are discussed with the @code{<text-wrapper>} class.") (define-method (string->wrapped-lines str . keywds) (string->wrapped-lines (apply make (cons <text-wrapper> keywds)) str)) ;; split a text string into segments that have the form... ;; <ws non-ws> <ws non-ws> etc.. (define (split-by-single-words str) (let ((non-wschars (char-set-complement char-set:whitespace))) (let loop ((ans '()) (index 0)) (let ((next-non-ws (string-index str non-wschars index))) (if next-non-ws ;; found non-ws...look for ws following... (let ((next-ws (string-index str char-set:whitespace next-non-ws))) (if next-ws ;; found the ws following... (loop (cons (substring str index next-ws) ans) next-ws) ;; did not find ws...must be the end... (reverse (cons (substring str index) ans)))) ;; did not find non-ws... only ws at end of the string... (reverse ans)))))) (define-method (string->wrapped-lines (tw <text-wrapper>) str) ;; this is where the real work begins... ;; replace newlines with spaces (set! str (transform-string str (lambda (c) (char=? c #\nl)) #\space)) ;; expand tabs if they wanted us to... (if (expand-tabs? tw) (set! str (expand-tabs str (tab-width tw)))) ;; collapse whitespace if they wanted us to... (if (collapse-whitespace? tw) (set! str (collapse-repeated-chars str))) ;; drop any whitespace from the front... (set! str (string-trim str)) ;; now start breaking the text into lines... (let loop ((ans '()) (words (split-by-single-words str)) (line (initial-indent tw)) (count 0)) (if (null? words) ;; out of words? ...done! (reverse (if (> count 0) (cons line ans) ans)) ;; not out of words...keep going... (let ((length-left (- (line-width tw) (string-length line))) (next-word (if (= count 0) (string-trim (car words)) (car words)))) (cond ;; does the next entry fit? ((<= (string-length next-word) length-left) (loop ans (cdr words) (string-append line next-word) (+ count 1))) ;; ok, it didn't fit...is there already at least one word on the line? ((> count 0) ;; try to use it for the next line, then... (loop (cons line ans) words (subsequent-indent tw) 0)) ;; ok, it didn't fit...and it's the first word. ;; were we told to break up long words? ((break-long-words? tw) ;; break the like at the limit, since the user wants us to... (loop (cons (string-append line (substring next-word 0 length-left)) ans) (cons (substring next-word length-left) (cdr words)) (subsequent-indent tw) 0)) ;; well, then is it the first word and we *shouldn't* break long words, then... (else (loop (cons (string-append line next-word) ans) (cdr words) (subsequent-indent tw) 0))))))) ;;; arch-tag: 61c4a6f9-0c13-4575-95dc-a7e647812216 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/config/�������������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�012430� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/config/load.scm�����������������������������������������������������������������0000664�0000764�0000764�00000007044�11212576345�014010� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (config load) -- loading configuration files ;; Copyright (C) 2003,2004 Andreas Rottmann ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; This module needs to be documented. ;;; Code: (define-module (config load) #:use-module (oop goops) #:use-module (ice-9 safe) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (<configuration> load-config! &config-error config-error-arguments)) (define-class <configuration> ()) (define-condition-type &config-error &error config-error? (key config-error-key) (arguments config-error-arguments)) ;; conditions are not GOOPS objects; but perhaps we should allow this somehow ;; (define-method (write (self &config-error) port) ;; (display "#<" port) ;; (display (class-name (class-of self)) port) ;; (display #\space port) ;; (display (config-error-key self) port) ;; (display #\space port) ;; (display (config-error-arguments self) port) ;; (display ">" port)) (define-method (cfg-include (cfg <configuration>) (file-name <string>) env) (let ((old-dir (getcwd))) (dynamic-wind (lambda () (chdir (dirname file-name))) (lambda () (do-load-config cfg (open-input-file (basename file-name)) env)) (lambda () (chdir old-dir))))) (define (do-load-config cfg port env) ;; Read one expression a time. (let lp ((expr (read port))) ;; End of file? -> Return. (if (eof-object? expr) #t (catch #t (lambda () ;; Evaluate the expression in the safe environment. (eval expr env) ;; ... and read the next expression if no error occured. (lp (read port))) ;; Handle exceptions. This procedure will be called when ;; an error occurs while evaluating the expression. If a ;; condition was signalled, it is re-raised, otherwise a ;; &config-error condition is raised with the original ;; exception key and arguments. ;; (lambda (key . args) (if (and (= (length args) 1) (condition? (car args))) (raise (car args)) (raise (condition (&config-error (key key) (arguments args)))))))))) (define (bind-first proc . bind-args) (lambda args (apply proc (append bind-args args)))) (define (bind-last proc . bind-args) (lambda args (apply proc (append args bind-args)))) (define-method (load-config! (cfg <configuration>) (commands <list>) (file-name <string>)) (let ((config-env (safe-environment 5))) (for-each (lambda (entry) (module-define! config-env (first entry) (bind-first (second entry) cfg))) (cons `(include ,(bind-last cfg-include config-env)) commands)) (cfg-include cfg file-name config-env))) ;;; arch-tag: 09ffbf0f-b7e1-4280-a21f-178226487634 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/Makefile.in���������������������������������������������������������������������0000664�0000764�0000764�00000031621�11546127771�013170� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Makefile.in generated by automake 1.11.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, # 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, # Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : subdir = src DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/m4/guile.m4 \ $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = DIST_SOURCES = am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; am__install_max = 40 am__nobase_strip_setup = \ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` am__nobase_strip = \ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" am__nobase_list = $(am__nobase_strip_setup); \ for p in $$list; do echo "$$p $$p"; done | \ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ if (++n[$$2] == $(am__install_max)) \ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ END { for (dir in files) print dir, files[dir] }' am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' am__installdirs = "$(DESTDIR)$(moddir)" DATA = $(nobase_mod_DATA) DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ ACLOCAL_FLAGS = @ACLOCAL_FLAGS@ AMTAR = @AMTAR@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ GUILE = @GUILE@ GUILE_CFLAGS = @GUILE_CFLAGS@ GUILE_COMPILE = @GUILE_COMPILE@ GUILE_CONFIG = @GUILE_CONFIG@ GUILE_LDFLAGS = @GUILE_LDFLAGS@ GUILE_TOOLS = @GUILE_TOOLS@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LTLIBOBJS = @LTLIBOBJS@ MAKEINFO = @MAKEINFO@ MKDIR_P = @MKDIR_P@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ am__leading_dot = @am__leading_dot@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build_alias = @build_alias@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host_alias = @host_alias@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ moddir = $(prefix)/share/guile/site SXML_FILES = \ sxml/apply-templates.scm \ sxml/fold.scm \ sxml/simple.scm \ sxml/ssax/input-parse.scm \ sxml/ssax.scm \ sxml/transform.scm \ sxml/unicode.scm \ sxml/upstream/SSAX-expanded.scm \ sxml/upstream/SSAX.scm \ sxml/upstream/SXML-tree-trans.scm \ sxml/upstream/SXPath-old.scm \ sxml/upstream/input-parse.scm \ sxml/upstream/assert.scm \ sxml/xpath.scm \ sxml/ssax-simple.scm TEXINFO_FILES = \ texinfo/docbook.scm \ texinfo/html.scm \ texinfo/indexing.scm \ texinfo/nodal-tree.scm \ texinfo/plain-text.scm \ texinfo/reflection.scm \ texinfo/serialize.scm \ texinfo.scm STATPROF_FILES = \ statprof.scm @HAVE_GUILE_COMPILE_FALSE@SXML_SOURCES = $(SXML_FILES) # Here we assume we are using Guile 2.0, and Guile 2.0 already comes # with the `(sxml ...)' and `(texinfo ...)' modules unmodified. @HAVE_GUILE_COMPILE_TRUE@SXML_SOURCES = @HAVE_GUILE_COMPILE_FALSE@TEXINFO_SOURCES = $(TEXINFO_FILES) @HAVE_GUILE_COMPILE_TRUE@TEXINFO_SOURCES = @HAVE_GUILE_COMPILE_FALSE@STATPROF_SOURCES = $(STATPROF_FILES) @HAVE_GUILE_COMPILE_TRUE@STATPROF_SOURCES = @HAVE_GUILE_COMPILE_FALSE@EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) @HAVE_GUILE_COMPILE_TRUE@EXTRA_DIST = $(SXML_FILES) $(TEXINFO_FILES) \ @HAVE_GUILE_COMPILE_TRUE@ $(STATPROF_FILES) $(SOURCES) \ @HAVE_GUILE_COMPILE_TRUE@ $(NOCOMP_SOURCES) SOURCES = \ apicheck.scm \ compat/guile-2.scm \ config/load.scm \ container/delay-tree.scm \ container/nodal-tree.scm \ container/async-queue.scm \ debugging/assert.scm \ debugging/time.scm \ graph/topological-sort.scm \ htmlprag.scm \ io/string.scm \ logging/logger.scm \ logging/port-log.scm \ logging/rotating-log.scm \ math/minima.scm \ math/primes.scm \ match-bind.scm \ md5.scm \ os/process.scm \ scheme/documentation.scm \ scheme/kwargs.scm \ search/basic.scm \ $(STATPROF_SOURCES) \ string/completion.scm \ string/soundex.scm \ string/transform.scm \ string/wrap.scm \ $(SXML_SOURCES) \ term/ansi-color.scm \ $(TEXINFO_SOURCES) \ text/parse-lalr.scm \ unit-test.scm @HAVE_GUILE_COMPILE_FALSE@GOBJECTS = @HAVE_GUILE_COMPILE_TRUE@GOBJECTS = $(SOURCES:%.scm=%.go) nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) $(GOBJECTS) CLEANFILES = $(GOBJECTS) SUFFIXES = .scm .go all: all-am .SUFFIXES: .SUFFIXES: .scm .go $(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): install-nobase_modDATA: $(nobase_mod_DATA) @$(NORMAL_INSTALL) test -z "$(moddir)" || $(MKDIR_P) "$(DESTDIR)$(moddir)" @list='$(nobase_mod_DATA)'; test -n "$(moddir)" || list=; \ $(am__nobase_list) | while read dir files; do \ xfiles=; for file in $$files; do \ if test -f "$$file"; then xfiles="$$xfiles $$file"; \ else xfiles="$$xfiles $(srcdir)/$$file"; fi; done; \ test -z "$$xfiles" || { \ test "x$$dir" = x. || { \ echo "$(MKDIR_P) '$(DESTDIR)$(moddir)/$$dir'"; \ $(MKDIR_P) "$(DESTDIR)$(moddir)/$$dir"; }; \ echo " $(INSTALL_DATA) $$xfiles '$(DESTDIR)$(moddir)/$$dir'"; \ $(INSTALL_DATA) $$xfiles "$(DESTDIR)$(moddir)/$$dir" || exit $$?; }; \ done uninstall-nobase_modDATA: @$(NORMAL_UNINSTALL) @list='$(nobase_mod_DATA)'; test -n "$(moddir)" || list=; \ $(am__nobase_strip_setup); files=`$(am__nobase_strip)`; \ test -n "$$files" || exit 0; \ echo " ( cd '$(DESTDIR)$(moddir)' && rm -f" $$files ")"; \ cd "$(DESTDIR)$(moddir)" && rm -f $$files tags: TAGS TAGS: ctags: CTAGS CTAGS: distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile $(DATA) installdirs: for dir in "$(DESTDIR)$(moddir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ `test -z '$(STRIP)' || \ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install mostlyclean-generic: clean-generic: -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-generic dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-nobase_modDATA install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-generic pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: uninstall-nobase_modDATA .MAKE: install-am install-strip .PHONY: all all-am check check-am clean clean-generic distclean \ distclean-generic distdir dvi dvi-am html html-am info info-am \ install install-am install-data install-data-am install-dvi \ install-dvi-am install-exec install-exec-am install-html \ install-html-am install-info install-info-am install-man \ install-nobase_modDATA install-pdf install-pdf-am install-ps \ install-ps-am install-strip installcheck installcheck-am \ installdirs maintainer-clean maintainer-clean-generic \ mostlyclean mostlyclean-generic pdf pdf-am ps ps-am uninstall \ uninstall-am uninstall-nobase_modDATA .scm.go: $(top_builddir)/dev-environ $(GUILE_COMPILE) -o "$@" "$<" # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: ���������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/Makefile.am���������������������������������������������������������������������0000664�0000764�0000764�00000004240�11546127450�013146� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������moddir=$(prefix)/share/guile/site SXML_FILES = \ sxml/apply-templates.scm \ sxml/fold.scm \ sxml/simple.scm \ sxml/ssax/input-parse.scm \ sxml/ssax.scm \ sxml/transform.scm \ sxml/unicode.scm \ sxml/upstream/SSAX-expanded.scm \ sxml/upstream/SSAX.scm \ sxml/upstream/SXML-tree-trans.scm \ sxml/upstream/SXPath-old.scm \ sxml/upstream/input-parse.scm \ sxml/upstream/assert.scm \ sxml/xpath.scm \ sxml/ssax-simple.scm TEXINFO_FILES = \ texinfo/docbook.scm \ texinfo/html.scm \ texinfo/indexing.scm \ texinfo/nodal-tree.scm \ texinfo/plain-text.scm \ texinfo/reflection.scm \ texinfo/serialize.scm \ texinfo.scm STATPROF_FILES = \ statprof.scm if HAVE_GUILE_COMPILE # Here we assume we are using Guile 2.0, and Guile 2.0 already comes # with the `(sxml ...)' and `(texinfo ...)' modules unmodified. SXML_SOURCES = TEXINFO_SOURCES = STATPROF_SOURCES = EXTRA_DIST = $(SXML_FILES) $(TEXINFO_FILES) $(STATPROF_FILES) else !HAVE_GUILE_COMPILE SXML_SOURCES = $(SXML_FILES) TEXINFO_SOURCES = $(TEXINFO_FILES) STATPROF_SOURCES = $(STATPROF_FILES) EXTRA_DIST = endif !HAVE_GUILE_COMPILE SOURCES = \ apicheck.scm \ compat/guile-2.scm \ config/load.scm \ container/delay-tree.scm \ container/nodal-tree.scm \ container/async-queue.scm \ debugging/assert.scm \ debugging/time.scm \ graph/topological-sort.scm \ htmlprag.scm \ io/string.scm \ logging/logger.scm \ logging/port-log.scm \ logging/rotating-log.scm \ math/minima.scm \ math/primes.scm \ match-bind.scm \ md5.scm \ os/process.scm \ scheme/documentation.scm \ scheme/kwargs.scm \ search/basic.scm \ $(STATPROF_SOURCES) \ string/completion.scm \ string/soundex.scm \ string/transform.scm \ string/wrap.scm \ $(SXML_SOURCES) \ term/ansi-color.scm \ $(TEXINFO_SOURCES) \ text/parse-lalr.scm \ unit-test.scm if HAVE_GUILE_COMPILE GOBJECTS = $(SOURCES:%.scm=%.go) else GOBJECTS = endif nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) $(GOBJECTS) EXTRA_DIST += $(SOURCES) $(NOCOMP_SOURCES) CLEANFILES = $(GOBJECTS) SUFFIXES = .scm .go .scm.go: $(top_builddir)/dev-environ $(GUILE_COMPILE) -o "$@" "$<" ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/io/�����������������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�011572� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/io/string.scm�������������������������������������������������������������������0000664�0000764�0000764�00000007546�11137606000�013534� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (io string) -- input and output with strings ;; Written 1995, 1996 by Oleg Kiselyov (oleg@acm.org) ;; Modified 1996, 1997, 1998, 2001 by A. Jaffer (agj@alum.mit.edu) ;; Modified 2003 by Steve VanDevender (stevev@hexadecimal.uoregon.edu) ;; Modified 2004 Andy Wingo <wingo at pobox dot com> ;; This file is based SLIB's strsrch.scm, and is in the public domain. ;;; Commentary: ;; ;;@c texinfo, really ;; Procedures that do io with strings. ;; ;;; Code: (define-module (io string) #:use-module (scheme documentation) #:export (find-string-from-port?)) (define-with-docs find-string-from-port? "Looks for @var{str} in @var{<input-port>}, optionally within the first @var{max-no-char} characters." (lambda (str <input-port> . max-no-char) (set! max-no-char (if (null? max-no-char) #f (car max-no-char))) (letrec ((no-chars-read 0) (peeked? #f) (my-peek-char ; Return a peeked char or #f (lambda () (and (or (not (number? max-no-char)) (< no-chars-read max-no-char)) (let ((c (peek-char <input-port>))) (cond (peeked? c) ((eof-object? c) #f) ((procedure? max-no-char) (set! peeked? #t) (if (max-no-char c) #f c)) ((eqv? max-no-char c) #f) (else c)))))) (next-char (lambda () (set! peeked? #f) (read-char <input-port>) (set! no-chars-read (+ 1 no-chars-read)))) (match-1st-char ; of the string str (lambda () (let ((c (my-peek-char))) (and c (begin (next-char) (if (char=? c (string-ref str 0)) (match-other-chars 1) (match-1st-char))))))) ;; There has been a partial match, up to the point pos-to-match ;; (for example, str[0] has been found in the stream) ;; Now look to see if str[pos-to-match] for would be found, too (match-other-chars (lambda (pos-to-match) (if (>= pos-to-match (string-length str)) no-chars-read ; the entire string has matched (let ((c (my-peek-char))) (and c (if (not (char=? c (string-ref str pos-to-match))) (backtrack 1 pos-to-match) (begin (next-char) (match-other-chars (+ 1 pos-to-match))))))))) ;; There had been a partial match, but then a wrong char showed up. ;; Before discarding previously read (and matched) characters, we check ;; to see if there was some smaller partial match. Note, characters read ;; so far (which matter) are those of str[0..matched-substr-len - 1] ;; In other words, we will check to see if there is such i>0 that ;; substr(str,0,j) = substr(str,i,matched-substr-len) ;; where j=matched-substr-len - i (backtrack (lambda (i matched-substr-len) (let ((j (- matched-substr-len i))) (if (<= j 0) ;; backed off completely to the begining of str (match-1st-char) (let loop ((k 0)) (if (>= k j) (match-other-chars j) ; there was indeed a shorter match (if (char=? (string-ref str k) (string-ref str (+ i k))) (loop (+ 1 k)) (backtrack (+ 1 i) matched-substr-len)))))))) ) (match-1st-char)))) ;;; arch-tag: 99289f4f-5fdb-4c6e-924a-1c510a61a03e ;;; string.scm ends here ����������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/apicheck.scm��������������������������������������������������������������������0000664�0000764�0000764�00000021446�11546127450�013374� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (apicheck) -- check for API incompatibilities ;; Copyright (C) 2007 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;; @code{(apicheck)} exports two routines. @code{apicheck-generate} ;; produces a description of the Scheme API exported by a set of modules ;; as an S-expression. @code{apicheck-validate} verifies that the API ;; exported by a set of modules is compatible with an API description ;; generated by @code{apicheck-generate}. ;; ;; It would be nice to have Makefile.am fragments here, but for now, see ;; the Guile-Library source distribution for information on how to ;; integrate apicheck with your module's unit test suite. ;; ;;; Code: (define-module (apicheck) #:use-module (unit-test) #:use-module (oop goops) #:use-module (ice-9 pretty-print) #:use-module ((ice-9 common-list) #:select (uniq)) #:use-module ((srfi srfi-1) #:select (append-map lset-difference)) #:export (apicheck-generate apicheck-validate)) (define (interface module) (case (module-kind module) ((interface) module) (else (error "Invalid API: imported module ~a not an interface" module)))) (define (module-all-uses module) (let ((direct (module-uses module))) (map interface (append direct (apply append (map module-all-uses direct)))))) (define (module-exports module) (module-map (lambda (k v) k) module)) (define (symbolcomp pred) (lambda (a b) (pred (symbol->string a) (symbol->string b)))) (define symbol<? (symbolcomp string<?)) (define symbol>? (symbolcomp string>?)) (define (symlist<? a b) (cond ((null? a) (not (null? b))) ((null? b) #f) ((symbol? a) (or (pair? b) (symbol<? a b))) ((symbol? b) #f) ((symbol<? (car a) (car b)) #t) ((symbol>? (car a) (car b)) #f) (else (symlist<? (cdr a) (cdr b))))) (define (module<? a b) (symlist<? (module-name a) (module-name b))) (define (all-public-interfaces module-names) (uniq (sort (append-map (lambda (name) (let ((mod (resolve-interface name))) (cons mod (module-all-uses mod)))) module-names) module<?))) (define (module-exports-sorted mod) (sort (hash-fold (lambda (k v rest) (cons k rest)) '() (module-obarray mod)) symbol<?)) (define (module-map-sorted proc mod) (let ((obarray (module-obarray mod))) (map (lambda (sym) (proc sym (hashq-ref obarray sym))) (module-exports-sorted mod)))) (define (procedure-arity proc) (cond-expand (guile-2 (cons 'arity (procedure-minimum-arity proc))) (else (assq 'arity (procedure-properties proc))))) ;; deals with improper lists (define (map* proc l) (cond ((null? l) '()) ((pair? l) (cons (proc (car l)) (map* proc (cdr l)))) (else (proc l)))) (define (method-specializer-names method) (map* class-name (method-specializers method))) (define (variable-type sym var) (let ((val (catch #t (lambda () (variable-ref var)) (lambda args (error "unbound variable" sym))))) (cond ((is-a? val <class>) (list 'class)) ((is-a? val <generic>) (cons 'generic (sort (map method-specializer-names (generic-function-methods val)) symlist<?))) ((procedure? val) (list 'procedure (procedure-arity val))) ((macro? val) (list 'macro)) ((struct-vtable? val) (list 'struct-vtable)) (else (list (class-name (class-of val))))))) (define (module-api module) `(,(module-name module) (uses-interfaces ,@(map module-name (sort (module-uses module) module<?))) (typed-exports ,@(module-map-sorted (lambda (sym var) (cons sym (variable-type sym var))) module)))) (define *apicheck-major-version* 1) (define *apicheck-minor-version* 0) (define (apicheck-generate module-names) "Generate a description of the API exported by the set of modules @var{module-names}." (cons* 'module-api (list 'version *apicheck-major-version* *apicheck-minor-version*) (map module-api (all-public-interfaces module-names)))) (define (form-match? form template) (define (pred? x) (procedure? x)) (define (var? x) (eq? x '_)) (define (atom? x) (not (pair? x))) (define (pred-match? pred form) (pred form)) (define (var-match? var form) #t) (define (atom-match? atom form) (eq? atom form)) (cond ((null? template) (null? form)) ((pred? template) (pred-match? template form)) ((var? template) (var-match? template form)) ((atom? form) (atom-match? template form)) (else (and (form-match? (car form) (car template)) (form-match? (cdr form) (cdr template)))))) (define (apicheck-form? form) (form-match? form `(module-api (version ,number? ,number?) . _))) (define (apicheck-version-compatible? form) (let ((version-form (cadr form))) (and (= (cadr version-form) *apicheck-major-version*) (<= (caddr version-form) *apicheck-minor-version*)))) (define (assert-sets-compatible! expected actual) (let ((new (lset-difference equal? actual expected))) (if (not (null? new)) (warn "New API, update your API form" new))) (let ((missing (lset-difference equal? expected actual))) (if (not (null? missing)) (error "Public API has been removed" missing)))) (define (arities-compatible? old new) ;; arity := (arity nrequired noptional rest?) (define (required x) (cadr x)) (define (optional x) (caddr x)) (define (rest? x) (cadddr x)) (and (cond ((< (required old) (required new)) #f) ((= (required old) (required new)) #t) (else (or (rest? new) (<= (- (required old) (required new)) (- (optional new) (optional old)))))) (or (<= (required old) (required new)) (rest? new)) (if (rest? old) (rest? new) #t))) (define (method-specializers-compatible? old new) ;; FIXME: define better (assert-sets-compatible! old new)) (define (apicheck-validate-var-type type-form var) (let ((name (car type-form)) (expected-type (cadr type-form)) (expected-args (cddr type-form))) (let ((actual (variable-type name var))) (let ((actual-type (car actual)) (actual-args (cdr actual))) (or (eq? expected-type actual-type) (error "API break: export changed type" name expected-type actual-type)) (or (case expected-type ((generic) (method-specializers-compatible? expected-args actual-args)) ((procedure) (arities-compatible? (car expected-args) (car actual-args))) (else ;; pass #t)) (error "API break: export changed type incompatibly" type-form actual)))))) (define (apicheck-validate-module module-form) (let ((interface (resolve-interface (car module-form))) (uses-interfaces (cdr (assq 'uses-interfaces module-form))) (typed-exports (cdr (assq 'typed-exports module-form)))) (assert-sets-compatible! uses-interfaces (map module-name (module-uses interface))) (assert-sets-compatible! (map car typed-exports) (module-exports-sorted interface)) (for-each (lambda (form) (apicheck-validate-var-type form (module-local-variable interface (car form)))) typed-exports))) (define (apicheck-validate api module-names) "Validate that the API exported by the set of modules @var{module-names} is compatible with the recorded API description @var{api}. Raises an exception if the interface is incompatible." (or (apicheck-form? api) (error "Invalid apicheck form" api)) (or (apicheck-version-compatible? api) (error "Invalid apicheck version" *apicheck-major-version* *apicheck-minor-version* api)) (let ((module-forms (cddr api))) (assert-sets-compatible! (map car module-forms) (map module-name (all-public-interfaces module-names))) (for-each apicheck-validate-module module-forms))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/���������������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�012146� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/ssax-simple.scm������������������������������������������������������������0000664�0000764�0000764�00000007541�11137632350�015051� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (sxml ssax-simple) -- SSAX, without syncase ;; Written 2001,2002,2003,2004 by Oleg Kiselyov <oleg at pobox dot com> as SSAX.sxm. ;; Modified 2004 by Andy Wingo <wingo at pobox dot com>. ;; This file is in the public domain. ;;; Commentary: ;; ;; This module is the same as (sxml ssax), except that it avoids loading ;; R5RS macros due to the slow load-time of (ice-9 syncase). As a result ;; it does not export the @code{ssax:make-parser}, ;; @code{ssax:make-pi-parser}, and @code{ssax:make-elem-parser} macros, ;; which create custom SAX parsers. ;; ;; If you need to make a custom SAX parser, use the (sxml ssax) module ;; instead. ;; ;;; Code: (define-module (sxml ssax-simple) #:use-module (sxml ssax input-parse) #:use-module (sxml unicode) #:use-module (debugging assert) #:use-module (io string) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:export (xml-token? xml-token-kind xml-token-head make-empty-attlist attlist-add attlist-null? attlist-remove-top attlist->alist attlist-fold ssax:uri-string->symbol ssax:skip-internal-dtd ssax:read-pi-body-as-string ssax:reverse-collect-str-drop-ws ssax:reverse-collect-str ssax:read-markup-token ssax:read-cdata-body ssax:predefined-parsed-entities ssax:read-char-ref ssax:read-attributes ssax:complete-start-tag ssax:read-external-id ssax:read-char-data ssax:xml->sxml) ;; We don't want to load up syncase. ;; #:export-syntax (ssax:make-parser ssax:make-pi-parser ssax:make-elem-parser) ) (define (parser-error port message . rest) (apply throw 'parser-error port message rest)) (define ascii->char integer->char) (define char->ascii char->integer) (define (ssax:warn port msg . args) (warn msg port args)) ;; Well, so this isn't correct for other unicode encodings. Something to ;; fix in the future, I guess. (define ucscode->string unichar->utf-8) (define char-newline #\newline) (define char-return #\return) (define char-tab #\tab) (define nl "\n") (define (load-filtered accept-list file) (with-input-from-file (%search-load-path file) (lambda () (let loop ((sexp (read))) (cond ((eof-object? sexp)) ((and (pair? sexp) (memq (car sexp) accept-list)) (eval sexp (current-module)) (loop (read))) (else (loop (read)))))))) ;; if condition is true, execute stmts in turn and return the result of ;; the last statement otherwise, return #f (define-macro (when condition . stmts) `(and ,condition (begin ,@stmts))) ;; Execute a sequence of forms and return the result of the _first_ one. ;; Like PROG1 in Lisp. Typically used to evaluate one or more forms with ;; side effects and return a value that must be computed before some or ;; all of the side effects happen. (define-macro (begin0 form . forms) (let ((var (gensym))) `(let ((,var ,form)) ,@forms ,var))) ; Like let* but allowing for multiple-value bindings (define-macro (let*-values bindings . body) (if (null? bindings) (cons 'begin body) (apply (lambda (vars initializer) (let ((cont (cons 'let*-values (cons (cdr bindings) body)))) (cond ((not (pair? vars)) ; regular let case, a single var `(let ((,vars ,initializer)) ,cont)) ((null? (cdr vars)) ; single var, see the prev case `(let ((,(car vars) ,initializer)) ,cont)) (else ; the most generic case `(call-with-values (lambda () ,initializer) (lambda ,vars ,cont)))))) (car bindings)))) (define ascii->char integer->char) (load-filtered '(define) "sxml/upstream/SSAX-expanded.scm") ;;; arch-tag: 4e4c450f-ea27-4a1c-86b7-df644da40079 ;;; ssax.scm ends here ���������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/ssax.scm�������������������������������������������������������������������0000664�0000764�0000764�00000022202�11436605505�013555� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (sxml ssax) -- the SSAX parser ;; Written 2001,2002,2003,2004 by Oleg Kiselyov <oleg at pobox dot com> as SSAX.scm. ;; Modified 2004 by Andy Wingo <wingo at pobox dot com>. ;; This file is in the public domain. ;;; Commentary: ;; ;@subheading Functional XML parsing framework ;@subsubheading SAX/DOM and SXML parsers with support for XML Namespaces and validation ; ; This is a package of low-to-high level lexing and parsing procedures ; that can be combined to yield a SAX, a DOM, a validating parser, or ; a parser intended for a particular document type. The procedures in ; the package can be used separately to tokenize or parse various ; pieces of XML documents. The package supports XML Namespaces, ; internal and external parsed entities, user-controlled handling of ; whitespace, and validation. This module therefore is intended to be ; a framework, a set of "Lego blocks" you can use to build a parser ; following any discipline and performing validation to any degree. As ; an example of the parser construction, this file includes a ; semi-validating SXML parser. ; The present XML framework has a "sequential" feel of SAX yet a ; "functional style" of DOM. Like a SAX parser, the framework scans the ; document only once and permits incremental processing. An application ; that handles document elements in order can run as efficiently as ; possible. @emph{Unlike} a SAX parser, the framework does not require ; an application register stateful callbacks and surrender control to ; the parser. Rather, it is the application that can drive the framework ; -- calling its functions to get the current lexical or syntax element. ; These functions do not maintain or mutate any state save the input ; port. Therefore, the framework permits parsing of XML in a pure ; functional style, with the input port being a monad (or a linear, ; read-once parameter). ; Besides the @var{port}, there is another monad -- @var{seed}. Most of ; the middle- and high-level parsers are single-threaded through the ; @var{seed}. The functions of this framework do not process or affect ; the @var{seed} in any way: they simply pass it around as an instance ; of an opaque datatype. User functions, on the other hand, can use the ; seed to maintain user's state, to accumulate parsing results, etc. A ; user can freely mix his own functions with those of the framework. On ; the other hand, the user may wish to instantiate a high-level parser: ; @code{SSAX:make-elem-parser} or @code{SSAX:make-parser}. In the latter ; case, the user must provide functions of specific signatures, which ; are called at predictable moments during the parsing: to handle ; character data, element data, or processing instructions (PI). The ; functions are always given the @var{seed}, among other parameters, and ; must return the new @var{seed}. ; From a functional point of view, XML parsing is a combined ; pre-post-order traversal of a "tree" that is the XML document ; itself. This down-and-up traversal tells the user about an element ; when its start tag is encountered. The user is notified about the ; element once more, after all element's children have been ; handled. The process of XML parsing therefore is a fold over the ; raw XML document. Unlike a fold over trees defined in [1], the ; parser is necessarily single-threaded -- obviously as elements ; in a text XML document are laid down sequentially. The parser ; therefore is a tree fold that has been transformed to accept an ; accumulating parameter [1,2]. ; Formally, the denotational semantics of the parser can be expressed ; as ;@smallexample ; parser:: (Start-tag -> Seed -> Seed) -> ; (Start-tag -> Seed -> Seed -> Seed) -> ; (Char-Data -> Seed -> Seed) -> ; XML-text-fragment -> Seed -> Seed ; parser fdown fup fchar "<elem attrs> content </elem>" seed ; = fup "<elem attrs>" seed ; (parser fdown fup fchar "content" (fdown "<elem attrs>" seed)) ; ; parser fdown fup fchar "char-data content" seed ; = parser fdown fup fchar "content" (fchar "char-data" seed) ; ; parser fdown fup fchar "elem-content content" seed ; = parser fdown fup fchar "content" ( ; parser fdown fup fchar "elem-content" seed) ;@end smallexample ; Compare the last two equations with the left fold ;@smallexample ; fold-left kons elem:list seed = fold-left kons list (kons elem seed) ;@end smallexample ; The real parser created by @code{SSAX:make-parser} is slightly more ; complicated, to account for processing instructions, entity ; references, namespaces, processing of document type declaration, etc. ; The XML standard document referred to in this module is ; @uref{http://www.w3.org/TR/1998/REC-xml-19980210.html} ; ; The present file also defines a procedure that parses the text of an ; XML document or of a separate element into SXML, an S-expression-based ; model of an XML Information Set. SXML is also an Abstract Syntax Tree ; of an XML document. SXML is similar but not identical to DOM; SXML is ; particularly suitable for Scheme-based XML/HTML authoring, SXPath ; queries, and tree transformations. See SXML.html for more details. ; SXML is a term implementation of evaluation of the XML document [3]. ; The other implementation is context-passing. ; The present frameworks fully supports the XML Namespaces Recommendation: ; @uref{http://www.w3.org/TR/REC-xml-names/} ; Other links: ;@table @asis ;@item [1] ; Jeremy Gibbons, Geraint Jones, "The Under-appreciated Unfold," ; Proc. ICFP'98, 1998, pp. 273-279. ;@item [2] ; Richard S. Bird, The promotion and accumulation strategies in ; transformational programming, ACM Trans. Progr. Lang. Systems, ; 6(4):487-504, October 1984. ;@item [3] ; Ralf Hinze, "Deriving Backtracking Monad Transformers," ; Functional Pearl. Proc ICFP'00, pp. 186-197. ;@end table ;; ;;; Code: (define-module (sxml ssax) #:use-module (sxml ssax input-parse) #:use-module (sxml unicode) #:use-module (io string) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:export (xml-token? xml-token-kind xml-token-head make-empty-attlist attlist-add attlist-null? attlist-remove-top attlist->alist attlist-fold ssax:uri-string->symbol ssax:skip-internal-dtd ssax:read-pi-body-as-string ssax:reverse-collect-str-drop-ws ssax:read-markup-token ssax:read-cdata-body ssax:read-char-ref ssax:read-attributes ssax:complete-start-tag ssax:read-external-id ssax:read-char-data ssax:xml->sxml) #:export-syntax (ssax:make-parser ssax:make-pi-parser ssax:make-elem-parser)) ;; #:use-syntax doesn't work, see boot-9.scm:1761 (cond-expand (guile-2 (begin)) (else (use-syntax (ice-9 syncase)) ;; hack around lack of hygiene regarding modules in guile 1.8 (let ((mod (current-module))) (set-module-binder! (module-public-interface mod) (lambda (interface sym define?) (let ((var (module-local-variable mod sym))) (if var (module-add! interface sym var)) var)))))) (define (parser-error port message . rest) (apply throw 'parser-error port message rest)) (define ascii->char integer->char) (define char->ascii char->integer) (define (ssax:warn port msg . args) (warn msg port args)) ;; Well, so this isn't correct for other unicode encodings. Something to ;; fix in the future, I guess. (define ucscode->string unichar->utf-8) (define char-newline #\newline) (define char-return #\return) (define char-tab #\tab) (define nl "\n") (define (load-filtered accept-list file) (with-input-from-file (%search-load-path file) (lambda () (let loop ((sexp (read))) (cond ((eof-object? sexp)) ((and (pair? sexp) (memq (car sexp) accept-list)) (primitive-eval sexp) (loop (read))) (else (loop (read)))))))) ;; if condition is true, execute stmts in turn and return the result of ;; the last statement otherwise, return #f (define-syntax when (syntax-rules () ((when condition . stmts) (and condition (begin . stmts))))) ;; Execute a sequence of forms and return the result of the _first_ one. ;; Like PROG1 in Lisp. Typically used to evaluate one or more forms with ;; side effects and return a value that must be computed before some or ;; all of the side effects happen. (define-syntax begin0 (syntax-rules () ((begin0 form form1 ... ) (let ((val form)) form1 ... val)))) ; Like let* but allowing for multiple-value bindings (define-syntax let*-values (syntax-rules () ((let*-values () . bodies) (begin . bodies)) ((let*-values (((var) initializer) . rest) . bodies) (let ((var initializer)) ; a single var optimization (let*-values rest . bodies))) ((let*-values ((vars initializer) . rest) . bodies) (call-with-values (lambda () initializer) ; the most generic case (lambda vars (let*-values rest . bodies)))))) ;; needed for some dumb reason (define inc 1+) (define dec 1-) (load-from-path "sxml/upstream/assert.scm") (load-filtered '(define define-syntax ssax:define-labeled-arg-macro) "sxml/upstream/SSAX.scm") ;;; arch-tag: c30e0855-8f4c-4e8c-ab41-ec24ec391e44 ;;; ssax.scm ends here ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/xpath.scm������������������������������������������������������������������0000664�0000764�0000764�00000045051�11137632567�013740� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (sxml xpath) -- SXPath ;; Written 2001 by Oleg Kiselyov <oleg at pobox dot com> SXPath.scm. ;; Modified 2004 by Andy Wingo <wingo at pobox dot com>. ;; This file is in the public domain. ;;; Commentary: ;; ;;@heading SXPath: SXML Query Language ;; ;; SXPath is a query language for SXML, an instance of XML Information ;; set (Infoset) in the form of s-expressions. See @code{(sxml ssax)} ;; for the definition of SXML and more details. SXPath is also a ;; translation into Scheme of an XML Path Language, ;; @uref{http://www.w3.org/TR/xpath,XPath}. XPath and SXPath describe ;; means of selecting a set of Infoset's items or their properties. ;; ;; To facilitate queries, XPath maps the XML Infoset into an explicit ;; tree, and introduces important notions of a location path and a ;; current, context node. A location path denotes a selection of a set of ;; nodes relative to a context node. Any XPath tree has a distinguished, ;; root node -- which serves as the context node for absolute location ;; paths. Location path is recursively defined as a location step joined ;; with a location path. A location step is a simple query of the ;; database relative to a context node. A step may include expressions ;; that further filter the selected set. Each node in the resulting set ;; is used as a context node for the adjoining location path. The result ;; of the step is a union of the sets returned by the latter location ;; paths. ;; ;; The SXML representation of the XML Infoset (see SSAX.scm) is rather ;; suitable for querying as it is. Bowing to the XPath specification, ;; we will refer to SXML information items as 'Nodes': ;;@example ;; <Node> ::= <Element> | <attributes-coll> | <attrib> ;; | "text string" | <PI> ;;@end example ;; This production can also be described as ;;@example ;; <Node> ::= (name . <Nodeset>) | "text string" ;;@end example ;; An (ordered) set of nodes is just a list of the constituent nodes: ;;@example ;; <Nodeset> ::= (<Node> ...) ;;@end example ;; Nodesets, and Nodes other than text strings are both lists. A ;; <Nodeset> however is either an empty list, or a list whose head is not ;; a symbol. A symbol at the head of a node is either an XML name (in ;; which case it's a tag of an XML element), or an administrative name ;; such as '@@'. This uniform list representation makes processing rather ;; simple and elegant, while avoiding confusion. The multi-branch tree ;; structure formed by the mutually-recursive datatypes <Node> and ;; <Nodeset> lends itself well to processing by functional languages. ;; ;; A location path is in fact a composite query over an XPath tree or ;; its branch. A singe step is a combination of a projection, selection ;; or a transitive closure. Multiple steps are combined via join and ;; union operations. This insight allows us to @emph{elegantly} ;; implement XPath as a sequence of projection and filtering primitives ;; -- converters -- joined by @dfn{combinators}. Each converter takes a ;; node and returns a nodeset which is the result of the corresponding ;; query relative to that node. A converter can also be called on a set ;; of nodes. In that case it returns a union of the corresponding ;; queries over each node in the set. The union is easily implemented as ;; a list append operation as all nodes in a SXML tree are considered ;; distinct, by XPath conventions. We also preserve the order of the ;; members in the union. Query combinators are high-order functions: ;; they take converter(s) (which is a Node|Nodeset -> Nodeset function) ;; and compose or otherwise combine them. We will be concerned with only ;; relative location paths [XPath]: an absolute location path is a ;; relative path applied to the root node. ;; ;; Similarly to XPath, SXPath defines full and abbreviated notations ;; for location paths. In both cases, the abbreviated notation can be ;; mechanically expanded into the full form by simple rewriting ;; rules. In case of SXPath the corresponding rules are given as ;; comments to a sxpath function, below. The regression test suite at ;; the end of this file shows a representative sample of SXPaths in ;; both notations, juxtaposed with the corresponding XPath ;; expressions. Most of the samples are borrowed literally from the ;; XPath specification, while the others are adjusted for our running ;; example, tree1. ;; ;;; Code: (define-module (sxml xpath) #:export (nodeset? node-typeof? node-eq? node-equal? node-pos filter take-until take-after map-union node-reverse node-trace select-kids node-self node-join node-reduce node-or node-closure node-parent sxpath)) ;; Upstream version: ; $Id: SXPath.scm,v 3.5 2001/01/12 23:20:35 oleg Exp oleg $ (define (nodeset? x) (or (and (pair? x) (not (symbol? (car x)))) (null? x))) ;------------------------- ; Basic converters and applicators ; A converter is a function ; type Converter = Node|Nodeset -> Nodeset ; A converter can also play a role of a predicate: in that case, if a ; converter, applied to a node or a nodeset, yields a non-empty ; nodeset, the converter-predicate is deemed satisfied. Throughout ; this file a nil nodeset is equivalent to #f in denoting a failure. ; The following function implements a 'Node test' as defined in ; Sec. 2.3 of XPath document. A node test is one of the components of a ; location step. It is also a converter-predicate in SXPath. ; ; The function node-typeof? takes a type criterion and returns a function, ; which, when applied to a node, will tell if the node satisfies ; the test. ; node-typeof? :: Crit -> Node -> Boolean ; ; The criterion 'crit' is a symbol, one of the following: ; id - tests if the Node has the right name (id) ; @ - tests if the Node is an <attributes-coll> ; * - tests if the Node is an <Element> ; *text* - tests if the Node is a text node ; *PI* - tests if the Node is a PI node ; *any* - #t for any type of Node (define (node-typeof? crit) (lambda (node) (case crit ((*) (and (pair? node) (not (memq (car node) '(@ *PI*))))) ((*any*) #t) ((*text*) (string? node)) (else (and (pair? node) (eq? crit (car node)))) ))) ; Curried equivalence converter-predicates (define (node-eq? other) (lambda (node) (eq? other node))) (define (node-equal? other) (lambda (node) (equal? other node))) ; node-pos:: N -> Nodeset -> Nodeset, or ; node-pos:: N -> Converter ; Select the N'th element of a Nodeset and return as a singular Nodeset; ; Return an empty nodeset if the Nth element does not exist. ; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset, ; if exists; ((node-pos 2) Nodeset) selects the Node after that, if ; exists. ; N can also be a negative number: in that case the node is picked from ; the tail of the list. ; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset; ; ((node-pos -2) Nodeset) selects the last but one node, if exists. (define (node-pos n) (lambda (nodeset) (cond ((not (nodeset? nodeset)) '()) ((null? nodeset) nodeset) ((eqv? n 1) (list (car nodeset))) ((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset)) (else (or (positive? n) (error "yikes!")) ((node-pos (1- n)) (cdr nodeset)))))) ; filter:: Converter -> Converter ; A filter applicator, which introduces a filtering context. The argument ; converter is considered a predicate, with either #f or nil result meaning ; failure. (define (filter pred?) (lambda (lst) ; a nodeset or a node (will be converted to a singleton nset) (let loop ((lst (if (nodeset? lst) lst (list lst))) (res '())) (if (null? lst) (reverse res) (let ((pred-result (pred? (car lst)))) (loop (cdr lst) (if (and pred-result (not (null? pred-result))) (cons (car lst) res) res))))))) ; take-until:: Converter -> Converter, or ; take-until:: Pred -> Node|Nodeset -> Nodeset ; Given a converter-predicate and a nodeset, apply the predicate to ; each element of the nodeset, until the predicate yields anything but #f or ; nil. Return the elements of the input nodeset that have been processed ; till that moment (that is, which fail the predicate). ; take-until is a variation of the filter above: take-until passes ; elements of an ordered input set till (but not including) the first ; element that satisfies the predicate. ; The nodeset returned by ((take-until (not pred)) nset) is a subset -- ; to be more precise, a prefix -- of the nodeset returned by ; ((filter pred) nset) (define (take-until pred?) (lambda (lst) ; a nodeset or a node (will be converted to a singleton nset) (let loop ((lst (if (nodeset? lst) lst (list lst)))) (if (null? lst) lst (let ((pred-result (pred? (car lst)))) (if (and pred-result (not (null? pred-result))) '() (cons (car lst) (loop (cdr lst))))) )))) ; take-after:: Converter -> Converter, or ; take-after:: Pred -> Node|Nodeset -> Nodeset ; Given a converter-predicate and a nodeset, apply the predicate to ; each element of the nodeset, until the predicate yields anything but #f or ; nil. Return the elements of the input nodeset that have not been processed: ; that is, return the elements of the input nodeset that follow the first ; element that satisfied the predicate. ; take-after along with take-until partition an input nodeset into three ; parts: the first element that satisfies a predicate, all preceding ; elements and all following elements. (define (take-after pred?) (lambda (lst) ; a nodeset or a node (will be converted to a singleton nset) (let loop ((lst (if (nodeset? lst) lst (list lst)))) (if (null? lst) lst (let ((pred-result (pred? (car lst)))) (if (and pred-result (not (null? pred-result))) (cdr lst) (loop (cdr lst)))) )))) ; Apply proc to each element of lst and return the list of results. ; if proc returns a nodeset, splice it into the result ; ; From another point of view, map-union is a function Converter->Converter, ; which places an argument-converter in a joining context. (define (map-union proc lst) (if (null? lst) lst (let ((proc-res (proc (car lst)))) ((if (nodeset? proc-res) append cons) proc-res (map-union proc (cdr lst)))))) ; node-reverse :: Converter, or ; node-reverse:: Node|Nodeset -> Nodeset ; Reverses the order of nodes in the nodeset ; This basic converter is needed to implement a reverse document order ; (see the XPath Recommendation). (define node-reverse (lambda (node-or-nodeset) (if (not (nodeset? node-or-nodeset)) (list node-or-nodeset) (reverse node-or-nodeset)))) ; node-trace:: String -> Converter ; (node-trace title) is an identity converter. In addition it prints out ; a node or nodeset it is applied to, prefixed with the 'title'. ; This converter is very useful for debugging. (define (node-trace title) (lambda (node-or-nodeset) (display "\n-->") (display title) (display " :") (pretty-print node-or-nodeset) node-or-nodeset)) ;------------------------- ; Converter combinators ; ; Combinators are higher-order functions that transmogrify a converter ; or glue a sequence of converters into a single, non-trivial ; converter. The goal is to arrive at converters that correspond to ; XPath location paths. ; ; From a different point of view, a combinator is a fixed, named ; _pattern_ of applying converters. Given below is a complete set of ; such patterns that together implement XPath location path ; specification. As it turns out, all these combinators can be built ; from a small number of basic blocks: regular functional composition, ; map-union and filter applicators, and the nodeset union. ; select-kids:: Pred -> Node -> Nodeset ; Given a Node, return an (ordered) subset its children that satisfy ; the Pred (a converter, actually) ; select-kids:: Pred -> Nodeset -> Nodeset ; The same as above, but select among children of all the nodes in ; the Nodeset ; ; More succinctly, the signature of this function is ; select-kids:: Converter -> Converter (define (select-kids test-pred?) (lambda (node) ; node or node-set (cond ((null? node) node) ((not (pair? node)) '()) ; No children ((symbol? (car node)) ((filter test-pred?) (cdr node))) ; it's a single node (else (map-union (select-kids test-pred?) node))))) ; node-self:: Pred -> Node -> Nodeset, or ; node-self:: Converter -> Converter ; Similar to select-kids but apply to the Node itself rather ; than to its children. The resulting Nodeset will contain either one ; component, or will be empty (if the Node failed the Pred). (define node-self filter) ; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or ; node-join:: [Converter] -> Converter ; join the sequence of location steps or paths as described ; in the title comments above. (define (node-join . selectors) (lambda (nodeset) ; Nodeset or node (let loop ((nodeset nodeset) (selectors selectors)) (if (null? selectors) nodeset (loop (if (nodeset? nodeset) (map-union (car selectors) nodeset) ((car selectors) nodeset)) (cdr selectors)))))) ; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or ; node-reduce:: [Converter] -> Converter ; A regular functional composition of converters. ; From a different point of view, ; ((apply node-reduce converters) nodeset) ; is equivalent to ; (foldl apply nodeset converters) ; i.e., folding, or reducing, a list of converters with the nodeset ; as a seed. (define (node-reduce . converters) (lambda (nodeset) ; Nodeset or node (let loop ((nodeset nodeset) (converters converters)) (if (null? converters) nodeset (loop ((car converters) nodeset) (cdr converters)))))) ; node-or:: [Converter] -> Converter ; This combinator applies all converters to a given node and ; produces the union of their results. ; This combinator corresponds to a union, '|' operation for XPath ; location paths. ; (define (node-or . converters) ; (lambda (node-or-nodeset) ; (if (null? converters) node-or-nodeset ; (append ; ((car converters) node-or-nodeset) ; ((apply node-or (cdr converters)) node-or-nodeset))))) ; More optimal implementation follows (define (node-or . converters) (lambda (node-or-nodeset) (let loop ((result '()) (converters converters)) (if (null? converters) result (loop (append result (or ((car converters) node-or-nodeset) '())) (cdr converters)))))) ; node-closure:: Converter -> Converter ; Select all _descendants_ of a node that satisfy a converter-predicate. ; This combinator is similar to select-kids but applies to ; grand... children as well. ; This combinator implements the "descendant::" XPath axis ; Conceptually, this combinator can be expressed as ; (define (node-closure f) ; (node-or ; (select-kids f) ; (node-reduce (select-kids (node-typeof? '*)) (node-closure f)))) ; This definition, as written, looks somewhat like a fixpoint, and it ; will run forever. It is obvious however that sooner or later ; (select-kids (node-typeof? '*)) will return an empty nodeset. At ; this point further iterations will no longer affect the result and ; can be stopped. (define (node-closure test-pred?) (lambda (node) ; Nodeset or node (let loop ((parent node) (result '())) (if (null? parent) result (loop ((select-kids (node-typeof? '*)) parent) (append result ((select-kids test-pred?) parent))) )))) ; node-parent:: RootNode -> Converter ; (node-parent rootnode) yields a converter that returns a parent of a ; node it is applied to. If applied to a nodeset, it returns the list ; of parents of nodes in the nodeset. The rootnode does not have ; to be the root node of the whole SXML tree -- it may be a root node ; of a branch of interest. ; Given the notation of Philip Wadler's paper on semantics of XSLT, ; parent(x) = { y | y=subnode*(root), x=subnode(y) } ; Therefore, node-parent is not the fundamental converter: it can be ; expressed through the existing ones. Yet node-parent is a rather ; convenient converter. It corresponds to a parent:: axis of SXPath. ; Note that the parent:: axis can be used with an attribute node as well! (define (node-parent rootnode) (lambda (node) ; Nodeset or node (if (nodeset? node) (map-union (node-parent rootnode) node) (let ((pred (node-or (node-reduce (node-self (node-typeof? '*)) (select-kids (node-eq? node))) (node-join (select-kids (node-typeof? '@)) (select-kids (node-eq? node)))))) ((node-or (node-self pred) (node-closure pred)) rootnode))))) ;------------------------- ; Evaluate an abbreviated SXPath ; sxpath:: AbbrPath -> Converter, or ; sxpath:: AbbrPath -> Node|Nodeset -> Nodeset ; AbbrPath is a list. It is translated to the full SXPath according ; to the following rewriting rules ; (sxpath '()) -> (node-join) ; (sxpath '(path-component ...)) -> ; (node-join (sxpath1 path-component) (sxpath '(...))) ; (sxpath1 '//) -> (node-or ; (node-self (node-typeof? '*any*)) ; (node-closure (node-typeof? '*any*))) ; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x)) ; (sxpath1 '(eq? x)) -> (select-kids (node-eq? x)) ; (sxpath1 ?symbol) -> (select-kids (node-typeof? ?symbol) ; (sxpath1 procedure) -> procedure ; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...)) ; (sxpath1 '(path reducer ...)) -> ; (node-reduce (sxpath path) (sxpathr reducer) ...) ; (sxpathr number) -> (node-pos number) ; (sxpathr path-filter) -> (filter (sxpath path-filter)) (define (sxpath path) (lambda (nodeset) (let loop ((nodeset nodeset) (path path)) (cond ((null? path) nodeset) ((nodeset? nodeset) (map-union (sxpath path) nodeset)) ((procedure? (car path)) (loop ((car path) nodeset) (cdr path))) ((eq? '// (car path)) (loop ((if (nodeset? nodeset) append cons) nodeset ((node-closure (node-typeof? '*any*)) nodeset)) (cdr path))) ((symbol? (car path)) (loop ((select-kids (node-typeof? (car path))) nodeset) (cdr path))) ((and (pair? (car path)) (eq? 'equal? (caar path))) (loop ((select-kids (apply node-equal? (cdar path))) nodeset) (cdr path))) ((and (pair? (car path)) (eq? 'eq? (caar path))) (loop ((select-kids (apply node-eq? (cdar path))) nodeset) (cdr path))) ((pair? (car path)) (let reducer ((nodeset (if (symbol? (caar path)) ((select-kids (node-typeof? (caar path))) nodeset) (loop nodeset (caar path)))) (reducing-path (cdar path))) (cond ((null? reducing-path) (loop nodeset (cdr path))) ((number? (car reducing-path)) (reducer ((node-pos (car reducing-path)) nodeset) (cdr reducing-path))) (else (reducer ((filter (sxpath (car reducing-path))) nodeset) (cdr reducing-path)))))) (else (error "Invalid path step: " (car path))))))) ;;; arch-tag: c4e57abf-6b61-4612-a6aa-d1536d440774 ;;; xpath.scm ends here ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/unicode.scm����������������������������������������������������������������0000664�0000764�0000764�00000003626�11137623457�014242� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (sxml unicode) -- rendering unicode to byte strings ;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com> ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; ;; Routines for encoding unicode codepoints into byte strings. ;; ;;; Code: (define-module (sxml unicode) #:export (unichar->utf-8)) (define (unichar->utf-8 u) (define (byte header mask shift) (integer->char (logior header (logand mask (ash u shift))))) (cond ((< u #x000000) (error "bad unicode code point" u)) ((< u #x000080) (string (integer->char u))) ((< u #x000800) (string (byte #b11000000 #b11111 -6) (byte #b10000000 #b111111 0))) ((< u #x00d800) (string (byte #b11100000 #b1111 -12) (byte #b10000000 #b111111 -6) (byte #b10000000 #b111111 0))) ((< u #x00e000) (error "bad unicode code point" u)) ((< u #x010000) (string (byte #b11100000 #b1111 -12) (byte #b10000000 #b111111 -6) (byte #b10000000 #b111111 0))) ((< u #x110000) (string (byte #b11110000 #b111 -18) (byte #b10000000 #b111111 -12) (byte #b10000000 #b111111 -6) (byte #b10000000 #b111111 0))) (else (error "bad unicode code point" u)))) ����������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/simple.scm�����������������������������������������������������������������0000664�0000764�0000764�00000013135�11137632313�014070� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; (sxml simple) -- a simple interface to the SSAX parser ;; Originally written by Oleg Kiselyov <oleg at pobox dot com> as SXML-to-HTML.scm. ;; Modified 2004 by Andy Wingo <wingo at pobox dot com>. ;; This file is in the public domain. ;;; Commentary: ;; ;;A simple interface to XML parsing and serialization. ;; ;;; Code: (define-module (sxml simple) #:use-module (sxml ssax-simple) #:use-module (sxml transform) #:use-module (ice-9 optargs) #:use-module (srfi srfi-13) #:use-module (scheme documentation) #:export (xml->sxml sxml->xml sxml->string universal-sxslt-rules)) (define* (xml->sxml #:optional (port (current-input-port))) "Use SSAX to parse an XML document into SXML. Takes one optional argument, @var{port}, which defaults to the current input port." (ssax:xml->sxml port '())) ;; Universal transformation rules. Works for all XML. (define-with-docs universal-sxslt-rules "A set of @code{pre-post-order} rules that transform any SXML tree into a form suitable for XML serialization by @code{(sxml transform)}'s @code{SRV:send-reply}. Used internally by @code{sxml->xml}." `((@ ((*default* . ,(lambda (attr-key . value) ((enattr attr-key) value)))) . ,(lambda (trigger . value) (list '@ value))) (*ENTITY* . ,(lambda (tag name) (list "&" name ";"))) (*PI* . ,(lambda (pi tag str) (list "<?" tag " " str "?>"))) ;; Is this right for entities? I don't have a reference for ;; public-id/system-id at the moment... (*default* . ,(lambda (tag . elems) (apply (entag tag) elems))) (*text* . ,(lambda (trigger str) (if (string? str) (string->escaped-xml str) str))))) (define* (sxml->xml tree #:optional (port (current-output-port))) "Serialize the sxml tree @var{tree} as XML. The output will be written to the current output port, unless the optional argument @var{port} is present." (with-output-to-port port (lambda () (SRV:send-reply (post-order tree universal-sxslt-rules))))) (define (sxml->string sxml) "Detag an sxml tree @var{sxml} into a string. Does not perform any formatting." (string-concatenate-reverse (foldts (lambda (seed tree) ; fdown '()) (lambda (seed kid-seed tree) ; fup (append! kid-seed seed)) (lambda (seed tree) ; fhere (if (string? tree) (cons tree seed) seed)) '() sxml))) ;; The following two functions serialize tags and attributes. They are ;; being used in the node handlers for the post-order function, see ;; above. (define (check-name name) (let* ((str (symbol->string name)) (i (string-index str #\:)) (head (or (and i (substring str 0 i)) str)) (tail (and i (substring str (1+ i))))) (and i (string-index (substring str (1+ i)) #\:) (error "Invalid QName: more than one colon" name)) (for-each (lambda (s) (and s (or (char-alphabetic? (string-ref s 0)) (eq? (string-ref s 0) #\_) (error "Invalid name starting character" s name)) (string-for-each (lambda (c) (or (char-alphabetic? c) (string-index "0123456789.-_" c) (error "Invalid name character" c s name))) s))) (list head tail)))) (define (entag tag) (check-name tag) (lambda elems (if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems))) (list #\< tag (cdar elems) (if (pair? (cdr elems)) (list #\> (cdr elems) "</" tag #\>) " />")) (list #\< tag (if (pair? elems) (list #\> elems "</" tag #\>) " />"))))) (define (enattr attr-key) (check-name attr-key) (let ((attr-str (symbol->string attr-key))) (lambda (value) (list #\space attr-str "=\"" (and (not (null? value)) value) #\")))) (define (make-char-quotator char-encoding) (let ((bad-chars (map car char-encoding))) ;; Check to see if str contains one of the characters in charset, ;; from the position i onward. If so, return that character's index. ;; otherwise, return #f (define (index-cset str i charset) (let loop ((i i)) (and (< i (string-length str)) (if (memv (string-ref str i) charset) i (loop (+ 1 i)))))) ;; The body of the function (lambda (str) (let ((bad-pos (index-cset str 0 bad-chars))) (if (not bad-pos) str ; str had all good chars (string-concatenate-reverse (let loop ((from 0) (to bad-pos) (out '())) (cond ((>= from (string-length str)) out) ((not to) (cons (substring str from (string-length str)) out)) (else (let ((quoted-char (cdr (assv (string-ref str to) char-encoding))) (new-to (index-cset str (+ 1 to) bad-chars))) (loop (1+ to) new-to (if (< from to) (cons* quoted-char (substring str from to) out) (cons quoted-char out))))))))))))) ;; Given a string, check to make sure it does not contain characters ;; such as '<' or '&' that require encoding. Return either the original ;; string, or a list of string fragments with special characters ;; replaced by appropriate character entities. (define string->escaped-xml (make-char-quotator '((#\< . "<") (#\> . ">") (#\& . "&") (#\" . """)))) ;;; arch-tag: 9c853b25-d82f-42ef-a959-ae26fdc7d1ac ;;; simple.scm ends here �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/upstream/������������������������������������������������������������������0000775�0000764�0000764�00000000000�11546130323�014006� 5����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/upstream/input-parse.scm���������������������������������������������������0000664�0000764�0000764�00000032521�11137322547�016713� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;**************************************************************************** ; Simple Parsing of input ; ; The following simple functions surprisingly often suffice to parse ; an input stream. They either skip, or build and return tokens, ; according to inclusion or delimiting semantics. The list of ; characters to expect, include, or to break at may vary from one ; invocation of a function to another. This allows the functions to ; easily parse even context-sensitive languages. ; ; EOF is generally frowned on, and thrown up upon if encountered. ; Exceptions are mentioned specifically. The list of expected characters ; (characters to skip until, or break-characters) may include an EOF ; "character", which is to be coded as symbol *eof* ; ; The input stream to parse is specified as a PORT, which is usually ; the last (and optional) argument. It defaults to the current input ; port if omitted. ; ; IMPORT ; This package relies on a function parser-error, which must be defined ; by a user of the package. The function has the following signature: ; parser-error PORT MESSAGE SPECIALISING-MSG* ; Many procedures of this package call parser-error to report a parsing ; error. The first argument is a port, which typically points to the ; offending character or its neighborhood. Most of the Scheme systems ; let the user query a PORT for the current position. MESSAGE is the ; description of the error. Other arguments supply more details about ; the problem. ; myenv.scm, myenv-bigloo.scm or a similar prelude is assumed. ; From SRFI-13, string-concatenate-reverse ; If a particular implementation lacks SRFI-13 support, please ; include the file srfi-13-local.scm ; ; $Id: input-parse.scm,v 1.7 2004/07/07 16:02:31 sperber Exp $ ;------------------------------------------------------------------------ ; -- procedure+: peek-next-char [PORT] ; advances to the next character in the PORT and peeks at it. ; This function is useful when parsing LR(1)-type languages ; (one-char-read-ahead). ; The optional argument PORT defaults to the current input port. (define-opt (peek-next-char (optional (port (current-input-port)))) (read-char port) (peek-char port)) ;------------------------------------------------------------------------ ; -- procedure+: assert-curr-char CHAR-LIST STRING [PORT] ; Reads a character from the PORT and looks it up ; in the CHAR-LIST of expected characters ; If the read character was found among expected, it is returned ; Otherwise, the procedure writes a nasty message using STRING ; as a comment, and quits. ; The optional argument PORT defaults to the current input port. ; (define-opt (assert-curr-char expected-chars comment (optional (port (current-input-port)))) (let ((c (read-char port))) (if (memv c expected-chars) c (parser-error port "Wrong character " c " (0x" (if (eof-object? c) "*eof*" (number->string (char->integer c) 16)) ") " comment ". " expected-chars " expected")))) ; -- procedure+: skip-until CHAR-LIST [PORT] ; Reads and skips characters from the PORT until one of the break ; characters is encountered. This break character is returned. ; The break characters are specified as the CHAR-LIST. This list ; may include EOF, which is to be coded as a symbol *eof* ; ; -- procedure+: skip-until NUMBER [PORT] ; Skips the specified NUMBER of characters from the PORT and returns #f ; ; The optional argument PORT defaults to the current input port. (define-opt (skip-until arg (optional (port (current-input-port))) ) (cond ((number? arg) ; skip 'arg' characters (do ((i arg (dec i))) ((not (positive? i)) #f) (if (eof-object? (read-char port)) (parser-error port "Unexpected EOF while skipping " arg " characters")))) (else ; skip until break-chars (=arg) (let loop ((c (read-char port))) (cond ((memv c arg) c) ((eof-object? c) (if (memq '*eof* arg) c (parser-error port "Unexpected EOF while skipping until " arg))) (else (loop (read-char port)))))))) ; -- procedure+: skip-while CHAR-LIST [PORT] ; Reads characters from the PORT and disregards them, ; as long as they are mentioned in the CHAR-LIST. ; The first character (which may be EOF) peeked from the stream ; that is NOT a member of the CHAR-LIST is returned. This character ; is left on the stream. ; The optional argument PORT defaults to the current input port. (define-opt (skip-while skip-chars (optional (port (current-input-port))) ) (do ((c (peek-char port) (peek-char port))) ((not (memv c skip-chars)) c) (read-char port))) ; whitespace const ;------------------------------------------------------------------------ ; Stream tokenizers ; -- procedure+: ; next-token PREFIX-CHAR-LIST BREAK-CHAR-LIST [COMMENT-STRING] [PORT] ; skips any number of the prefix characters (members of the ; PREFIX-CHAR-LIST), if any, and reads the sequence of characters ; up to (but not including) a break character, one of the ; BREAK-CHAR-LIST. ; The string of characters thus read is returned. ; The break character is left on the input stream ; The list of break characters may include EOF, which is to be coded as ; a symbol *eof*. Otherwise, EOF is fatal, generating an error message ; including a specified COMMENT-STRING (if any) ; ; The optional argument PORT defaults to the current input port. ; ; Note: since we can't tell offhand how large the token being read is ; going to be, we make a guess, pre-allocate a string, and grow it by ; quanta if necessary. The quantum is always the length of the string ; before it was extended the last time. Thus the algorithm does ; a Fibonacci-type extension, which has been proven optimal. ; Note, explicit port specification in read-char, peek-char helps. ; Procedure: input-parse:init-buffer ; returns an initial buffer for next-token* procedures. ; The input-parse:init-buffer may allocate a new buffer per each invocation: ; (define (input-parse:init-buffer) (make-string 32)) ; Size 32 turns out to be fairly good, on average. ; That policy is good only when a Scheme system is multi-threaded with ; preemptive scheduling, or when a Scheme system supports shared substrings. ; In all the other cases, it's better for input-parse:init-buffer to ; return the same static buffer. next-token* functions return a copy ; (a substring) of accumulated data, so the same buffer can be reused. ; We shouldn't worry about an incoming token being too large: ; next-token will use another chunk automatically. Still, ; the best size for the static buffer is to allow most of the tokens to fit in. ; Using a static buffer _dramatically_ reduces the amount of produced garbage ; (e.g., during XML parsing). (define input-parse:init-buffer (let ((buffer (make-string 512))) (lambda () buffer))) ; See a better version below (define-opt (next-token-old prefix-skipped-chars break-chars (optional (comment "") (port (current-input-port))) ) (let* ((buffer (input-parse:init-buffer)) (curr-buf-len (string-length buffer)) (quantum curr-buf-len)) (let loop ((i 0) (c (skip-while prefix-skipped-chars port))) (cond ((memv c break-chars) (substring buffer 0 i)) ((eof-object? c) (if (memq '*eof* break-chars) (substring buffer 0 i) ; was EOF expected? (parser-error port "EOF while reading a token " comment))) (else (if (>= i curr-buf-len) ; make space for i-th char in buffer (begin ; -> grow the buffer by the quantum (set! buffer (string-append buffer (make-string quantum))) (set! quantum curr-buf-len) (set! curr-buf-len (string-length buffer)))) (string-set! buffer i c) (read-char port) ; move to the next char (loop (inc i) (peek-char port)) ))))) ; A better version of next-token, which accumulates the characters ; in chunks, and later on reverse-concatenates them, using ; SRFI-13 if available. ; The overhead of copying characters is only 100% (or even smaller: bulk ; string copying might be well-optimised), compared to the (hypothetical) ; circumstance if we had known the size of the token beforehand. ; For small tokens, the code performs just as above. For large ; tokens, we expect an improvement. Note, the code also has no ; assignments. ; See next-token-comp.scm (define-opt (next-token prefix-skipped-chars break-chars (optional (comment "") (port (current-input-port))) ) (let outer ((buffer (input-parse:init-buffer)) (filled-buffer-l '()) (c (skip-while prefix-skipped-chars port))) (let ((curr-buf-len (string-length buffer))) (let loop ((i 0) (c c)) (cond ((memv c break-chars) (if (null? filled-buffer-l) (substring buffer 0 i) (string-concatenate-reverse filled-buffer-l buffer i))) ((eof-object? c) (if (memq '*eof* break-chars) ; was EOF expected? (if (null? filled-buffer-l) (substring buffer 0 i) (string-concatenate-reverse filled-buffer-l buffer i)) (parser-error port "EOF while reading a token " comment))) ((>= i curr-buf-len) (outer (make-string curr-buf-len) (cons buffer filled-buffer-l) c)) (else (string-set! buffer i c) (read-char port) ; move to the next char (loop (inc i) (peek-char port)))))))) ; -- procedure+: next-token-of INC-CHARSET [PORT] ; Reads characters from the PORT that belong to the list of characters ; INC-CHARSET. The reading stops at the first character which is not ; a member of the set. This character is left on the stream. ; All the read characters are returned in a string. ; ; -- procedure+: next-token-of PRED [PORT] ; Reads characters from the PORT for which PRED (a procedure of one ; argument) returns non-#f. The reading stops at the first character ; for which PRED returns #f. That character is left on the stream. ; All the results of evaluating of PRED up to #f are returned in a ; string. ; ; PRED is a procedure that takes one argument (a character ; or the EOF object) and returns a character or #f. The returned ; character does not have to be the same as the input argument ; to the PRED. For example, ; (next-token-of (lambda (c) ; (cond ((eof-object? c) #f) ; ((char-alphabetic? c) (char-downcase c)) ; (else #f)))) ; will try to read an alphabetic token from the current ; input port, and return it in lower case. ; ; The optional argument PORT defaults to the current input port. ; ; This procedure is similar to next-token but only it implements ; an inclusion rather than delimiting semantics. (define-opt (next-token-of incl-list/pred (optional (port (current-input-port))) ) (let* ((buffer (input-parse:init-buffer)) (curr-buf-len (string-length buffer))) (if (procedure? incl-list/pred) (let outer ((buffer buffer) (filled-buffer-l '())) (let loop ((i 0)) (if (>= i curr-buf-len) ; make sure we have space (outer (make-string curr-buf-len) (cons buffer filled-buffer-l)) (let ((c (incl-list/pred (peek-char port)))) (if c (begin (string-set! buffer i c) (read-char port) ; move to the next char (loop (inc i))) ; incl-list/pred decided it had had enough (if (null? filled-buffer-l) (substring buffer 0 i) (string-concatenate-reverse filled-buffer-l buffer i))))))) ; incl-list/pred is a list of allowed characters (let outer ((buffer buffer) (filled-buffer-l '())) (let loop ((i 0)) (if (>= i curr-buf-len) ; make sure we have space (outer (make-string curr-buf-len) (cons buffer filled-buffer-l)) (let ((c (peek-char port))) (cond ((not (memv c incl-list/pred)) (if (null? filled-buffer-l) (substring buffer 0 i) (string-concatenate-reverse filled-buffer-l buffer i))) (else (string-set! buffer i c) (read-char port) ; move to the next char (loop (inc i)))))))) ))) ; -- procedure+: read-text-line [PORT] ; Reads one line of text from the PORT, and returns it as a string. ; A line is a (possibly empty) sequence of characters terminated ; by CR, CRLF or LF (or even the end of file). ; The terminating character (or CRLF combination) is removed from ; the input stream. The terminating character(s) is not a part ; of the return string either. ; If EOF is encountered before any character is read, the return ; value is EOF. ; ; The optional argument PORT defaults to the current input port. (define *read-line-breaks* (list char-newline char-return '*eof*)) (define-opt (read-text-line (optional (port (current-input-port))) ) (if (eof-object? (peek-char port)) (peek-char port) (let* ((line (next-token '() *read-line-breaks* "reading a line" port)) (c (read-char port))) ; must be either \n or \r or EOF (and (eqv? c char-return) (eqv? (peek-char port) #\newline) (read-char port)) ; skip \n that follows \r line))) ; -- procedure+: read-string N [PORT] ; Reads N characters from the PORT, and returns them in a string. ; If EOF is encountered before N characters are read, a shorter string ; will be returned. ; If N is not positive, an empty string will be returned. ; The optional argument PORT defaults to the current input port. (define-opt (read-string n (optional (port (current-input-port))) ) (if (not (positive? n)) "" (let ((buffer (make-string n))) (let loop ((i 0) (c (read-char port))) (if (eof-object? c) (substring buffer 0 i) (let ((i1 (inc i))) (string-set! buffer i c) (if (= i1 n) buffer (loop i1 (read-char port))))))))) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/upstream/assert.scm��������������������������������������������������������0000664�0000764�0000764�00000002563�11137322547�015750� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������; ; syntax: assert ?expr ?expr ... [report: ?r-exp ?r-exp ...] ; ; If (and ?expr ?expr ...) evaluates to anything but #f, the result ; is the value of that expression. ; If (and ?expr ?expr ...) evaluates to #f, an error is reported. ; The error message will show the failed expressions, as well ; as the values of selected variables (or expressions, in general). ; The user may explicitly specify the expressions whose ; values are to be printed upon assertion failure -- as ?r-exp that ; follow the identifier 'report:' ; Typically, ?r-exp is either a variable or a string constant. ; If the user specified no ?r-exp, the values of variables that are ; referenced in ?expr will be printed upon the assertion failure. (define-syntax assert (syntax-rules (report:) ((assert "doit" (expr ...) (r-exp ...)) (cond ((and expr ...) => (lambda (x) x)) (else (error "assertion failure: ~a" (list '(and expr ...) r-exp ...))))) ((assert "collect" (expr ...)) (assert "doit" (expr ...) ())) ((assert "collect" (expr ...) report: r-exp ...) (assert "doit" (expr ...) (r-exp ...))) ((assert "collect" (expr ...) expr1 stuff ...) (assert "collect" (expr ... expr1) stuff ...)) ((assert stuff ...) (assert "collect" () stuff ...)))) (define-syntax assure (syntax-rules () ((assure exp error-msg) (assert exp report: error-msg))))���������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/upstream/SXML-tree-trans.scm�����������������������������������������������0000664�0000764�0000764�00000023541�11137322547�017313� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������; XML/HTML processing in Scheme ; SXML expression tree transformers ; ; IMPORT ; A prelude appropriate for your Scheme system ; (myenv-bigloo.scm, myenv-mit.scm, etc.) ; ; EXPORT ; (provide SRV:send-reply ; post-order pre-post-order replace-range) ; ; See vSXML-tree-trans.scm for the validation code, which also ; serves as usage examples. ; ; $Id: SXML-tree-trans.scm,v 1.6 2003/04/25 19:16:15 oleg Exp $ ; Output the 'fragments' ; The fragments are a list of strings, characters, ; numbers, thunks, #f, #t -- and other fragments. ; The function traverses the tree depth-first, writes out ; strings and characters, executes thunks, and ignores ; #f and '(). ; The function returns #t if anything was written at all; ; otherwise the result is #f ; If #t occurs among the fragments, it is not written out ; but causes the result of SRV:send-reply to be #t (define (SRV:send-reply . fragments) (let loop ((fragments fragments) (result #f)) (cond ((null? fragments) result) ((not (car fragments)) (loop (cdr fragments) result)) ((null? (car fragments)) (loop (cdr fragments) result)) ((eq? #t (car fragments)) (loop (cdr fragments) #t)) ((pair? (car fragments)) (loop (cdr fragments) (loop (car fragments) result))) ((procedure? (car fragments)) ((car fragments)) (loop (cdr fragments) #t)) (else (display (car fragments)) (loop (cdr fragments) #t))))) ;------------------------------------------------------------------------ ; Traversal of an SXML tree or a grove: ; a <Node> or a <Nodelist> ; ; A <Node> and a <Nodelist> are mutually-recursive datatypes that ; underlie the SXML tree: ; <Node> ::= (name . <Nodelist>) | "text string" ; An (ordered) set of nodes is just a list of the constituent nodes: ; <Nodelist> ::= (<Node> ...) ; Nodelists, and Nodes other than text strings are both lists. A ; <Nodelist> however is either an empty list, or a list whose head is ; not a symbol (an atom in general). A symbol at the head of a node is ; either an XML name (in which case it's a tag of an XML element), or ; an administrative name such as '@'. ; See SXPath.scm and SSAX.scm for more information on SXML. ; Pre-Post-order traversal of a tree and creation of a new tree: ; pre-post-order:: <tree> x <bindings> -> <new-tree> ; where ; <bindings> ::= (<binding> ...) ; <binding> ::= (<trigger-symbol> *preorder* . <handler>) | ; (<trigger-symbol> *macro* . <handler>) | ; (<trigger-symbol> <new-bindings> . <handler>) | ; (<trigger-symbol> . <handler>) ; <trigger-symbol> ::= XMLname | *text* | *default* ; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree> ; ; The pre-post-order function visits the nodes and nodelists ; pre-post-order (depth-first). For each <Node> of the form (name ; <Node> ...) it looks up an association with the given 'name' among ; its <bindings>. If failed, pre-post-order tries to locate a ; *default* binding. It's an error if the latter attempt fails as ; well. Having found a binding, the pre-post-order function first ; checks to see if the binding is of the form ; (<trigger-symbol> *preorder* . <handler>) ; If it is, the handler is 'applied' to the current node. Otherwise, ; the pre-post-order function first calls itself recursively for each ; child of the current node, with <new-bindings> prepended to the ; <bindings> in effect. The result of these calls is passed to the ; <handler> (along with the head of the current <Node>). To be more ; precise, the handler is _applied_ to the head of the current node ; and its processed children. The result of the handler, which should ; also be a <tree>, replaces the current <Node>. If the current <Node> ; is a text string or other atom, a special binding with a symbol ; *text* is looked up. ; ; A binding can also be of a form ; (<trigger-symbol> *macro* . <handler>) ; This is equivalent to *preorder* described above. However, the result ; is re-processed again, with the current stylesheet. (define (pre-post-order tree bindings) (let* ((default-binding (assq '*default* bindings)) (text-binding (or (assq '*text* bindings) default-binding)) (text-handler ; Cache default and text bindings (and text-binding (if (procedure? (cdr text-binding)) (cdr text-binding) (cddr text-binding))))) (let loop ((tree tree)) (cond ((null? tree) '()) ((not (pair? tree)) (let ((trigger '*text*)) (if text-handler (text-handler trigger tree) (error "Unknown binding for " trigger " and no default")))) ((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist (else ; tree is an SXML node (let* ((trigger (car tree)) (binding (or (assq trigger bindings) default-binding))) (cond ((not binding) (error "Unknown binding for " trigger " and no default")) ((not (pair? (cdr binding))) ; must be a procedure: handler (apply (cdr binding) trigger (map loop (cdr tree)))) ((eq? '*preorder* (cadr binding)) (apply (cddr binding) tree)) ((eq? '*macro* (cadr binding)) (loop (apply (cddr binding) tree))) (else ; (cadr binding) is a local binding (apply (cddr binding) trigger (pre-post-order (cdr tree) (append (cadr binding) bindings))) )))))))) ; post-order is a strict subset of pre-post-order without *preorder* ; (let alone *macro*) traversals. ; Now pre-post-order is actually faster than the old post-order. ; The function post-order is deprecated and is aliased below for ; backward compatibility. (define post-order pre-post-order) ;------------------------------------------------------------------------ ; Extended tree fold ; tree = atom | (node-name tree ...) ; ; foldts fdown fup fhere seed (Leaf str) = fhere seed str ; foldts fdown fup fhere seed (Nd kids) = ; fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids ; procedure fhere: seed -> atom -> seed ; procedure fdown: seed -> node -> seed ; procedure fup: parent-seed -> last-kid-seed -> node -> seed ; foldts returns the final seed (define (foldts fdown fup fhere seed tree) (cond ((null? tree) seed) ((not (pair? tree)) ; An atom (fhere seed tree)) (else (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree))) (if (null? kids) (fup seed kid-seed tree) (loop (foldts fdown fup fhere kid-seed (car kids)) (cdr kids))))))) ;------------------------------------------------------------------------ ; Traverse a forest depth-first and cut/replace ranges of nodes. ; ; The nodes that define a range don't have to have the same immediate ; parent, don't have to be on the same level, and the end node of a ; range doesn't even have to exist. A replace-range procedure removes ; nodes from the beginning node of the range up to (but not including) ; the end node of the range. In addition, the beginning node of the ; range can be replaced by a node or a list of nodes. The range of ; nodes is cut while depth-first traversing the forest. If all ; branches of the node are cut a node is cut as well. The procedure ; can cut several non-overlapping ranges from a forest. ; replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST ; where ; type FOREST = (NODE ...) ; type NODE = Atom | (Name . FOREST) | FOREST ; ; The range of nodes is specified by two predicates, beg-pred and end-pred. ; beg-pred:: NODE -> #f | FOREST ; end-pred:: NODE -> #f | FOREST ; The beg-pred predicate decides on the beginning of the range. The node ; for which the predicate yields non-#f marks the beginning of the range ; The non-#f value of the predicate replaces the node. The value can be a ; list of nodes. The replace-range procedure then traverses the tree and skips ; all the nodes, until the end-pred yields non-#f. The value of the end-pred ; replaces the end-range node. The new end node and its brothers will be ; re-scanned. ; The predicates are evaluated pre-order. We do not descend into a node that ; is marked as the beginning of the range. (define (replace-range beg-pred end-pred forest) ; loop forest keep? new-forest ; forest is the forest to traverse ; new-forest accumulates the nodes we will keep, in the reverse ; order ; If keep? is #t, keep the curr node if atomic. If the node is not atomic, ; traverse its children and keep those that are not in the skip range. ; If keep? is #f, skip the current node if atomic. Otherwise, ; traverse its children. If all children are skipped, skip the node ; as well. (define (loop forest keep? new-forest) (if (null? forest) (values (reverse new-forest) keep?) (let ((node (car forest))) (if keep? (cond ; accumulate mode ((beg-pred node) => ; see if the node starts the skip range (lambda (repl-branches) ; if so, skip/replace the node (loop (cdr forest) #f (append (reverse repl-branches) new-forest)))) ((not (pair? node)) ; it's an atom, keep it (loop (cdr forest) keep? (cons node new-forest))) (else (let*-values (((node?) (symbol? (car node))) ; or is it a nodelist? ((new-kids keep?) ; traverse its children (loop (if node? (cdr node) node) #t '()))) (loop (cdr forest) keep? (cons (if node? (cons (car node) new-kids) new-kids) new-forest))))) ; skip mode (cond ((end-pred node) => ; end the skip range (lambda (repl-branches) ; repl-branches will be re-scanned (loop (append repl-branches (cdr forest)) #t new-forest))) ((not (pair? node)) ; it's an atom, skip it (loop (cdr forest) keep? new-forest)) (else (let*-values (((node?) (symbol? (car node))) ; or is it a nodelist? ((new-kids keep?) ; traverse its children (loop (if node? (cdr node) node) #f '()))) (loop (cdr forest) keep? (if (or keep? (pair? new-kids)) (cons (if node? (cons (car node) new-kids) new-kids) new-forest) new-forest) ; if all kids are skipped )))))))) ; skip the node too (let*-values (((new-forest keep?) (loop forest #t '()))) new-forest)) ���������������������������������������������������������������������������������������������������������������������������������������������������������������guile-lib-0.2.1/src/sxml/upstream/SSAX.scm����������������������������������������������������������0000664�0000764�0000764�00000364541�11137322547�015234� �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������; Functional XML parsing framework: SAX/DOM and SXML parsers ; with support for XML Namespaces and validation ; ; This is a package of low-to-high level lexing and parsing procedures ; that can be combined to yield a SAX, a DOM, a validating parsers, or ; a parser intended for a particular document type. The procedures in ; the package can be used separately to tokenize or parse various ; pieces of XML documents. The package supports XML Namespaces, ; internal and external parsed entities, user-controlled handling of ; whitespace, and validation. This module therefore is intended to be ; a framework, a set of "Lego blocks" you can use to build a parser ; following any discipline and performing validation to any degree. As ; an example of the parser construction, this file includes a ; semi-validating SXML parser. ; The present XML framework has a "sequential" feel of SAX yet a ; "functional style" of DOM. Like a SAX parser, the framework scans ; the document only once and permits incremental processing. An ; application that handles document elements in order can run as ; efficiently as possible. _Unlike_ a SAX parser, the framework does ; not require an application register stateful callbacks and surrender ; control to the parser. Rather, it is the application that can drive ; the framework -- calling its functions to get the current lexical or ; syntax element. These functions do not maintain or mutate any state ; save the input port. Therefore, the framework permits parsing of XML ; in a pure functional style, with the input port being a monad (or a ; linear, read-once parameter). ; Besides the PORT, there is another monad -- SEED. Most of the ; middle- and high-level parsers are single-threaded through the ; seed. The functions of this framework do not process or affect the ; SEED in any way: they simply pass it around as an instance of an ; opaque datatype. User functions, on the other hand, can use the ; seed to maintain user's state, to accumulate parsing results, etc. A ; user can freely mix his own functions with those of the ; framework. On the other hand, the user may wish to instantiate a ; high-level parser: ssax:make-elem-parser or ssax:make-parser. In ; the latter case, the user must provide functions of specific ; signatures, which are called at predictable moments during the ; parsing: to handle character data, element data, or processing ; instructions (PI). The functions are always given the SEED, among ; other parameters, and must return the new SEED. ; From a functional point of view, XML parsing is a combined ; pre-post-order traversal of a "tree" that is the XML document ; itself. This down-and-up traversal tells the user about an element ; when its start tag is encountered. The user is notified about the ; element once more, after all element's children have been ; handled. The process of XML parsing therefore is a fold over the ; raw XML document. Unlike a fold over trees defined in [1], the ; parser is necessarily single-threaded -- obviously as elements ; in a text XML document are laid down sequentially. The parser ; therefore is a tree fold that has been transformed to accept an ; accumulating parameter [1,2]. ; Formally, the denotational semantics of the parser can be expressed ; as ; parser:: (Start-tag -> Seed -> Seed) -> ; (Start-tag -> Seed -> Seed -> Seed) -> ; (Char-Data -> Seed -> Seed) -> ; XML-text-fragment -> Seed -> Seed ; parser fdown fup fchar "<elem attrs> content </elem>" seed ; = fup "<elem attrs>" seed ; (parser fdown fup fchar "content" (fdown "<elem attrs>" seed)) ; ; parser fdown fup fchar "char-data content" seed ; = parser fdown fup fchar "content" (fchar "char-data" seed) ; ; parser fdown fup fchar "elem-content content" seed ; = parser fdown fup fchar "content" ( ; parser fdown fup fchar "elem-content" seed) ; Compare the last two equations with the left fold ; fold-left kons elem:list seed = fold-left kons list (kons elem seed) ; The real parser created my ssax:make-parser is slightly more complicated, ; to account for processing instructions, entity references, namespaces, ; processing of document type declaration, etc. ; The XML standard document referred to in this module is ; http://www.w3.org/TR/1998/REC-xml-19980210.html ; ; The present file also defines a procedure that parses the text of an ; XML document or of a separate element into SXML, an ; S-expression-based model of an XML Information Set. SXML is also an ; Abstract Syntax Tree of an XML document. SXML is similar ; but not identical to DOM; SXML is particularly suitable for ; Scheme-based XML/HTML authoring, SXPath queries, and tree ; transformations. See SXML.html for more details. ; SXML is a term implementation of evaluation of the XML document [3]. ; The other implementation is context-passing. ; The present frameworks fully supports the XML Namespaces Recommendation: ; http://www.w3.org/TR/REC-xml-names/ ; Other links: ; [1] Jeremy Gibbons, Geraint Jones, "The Under-appreciated Unfold," ; Proc. ICFP'98, 1998, pp. 273-279. ; [2] Richard S. Bird, The promotion and accumulation strategies in ; transformational programming, ACM Trans. Progr. Lang. Systems, ; 6(4):487-504, October 1984. ; [3] Ralf Hinze, "Deriving Backtracking Monad Transformers," ; Functional Pearl. Proc ICFP'00, pp. 186-197. ; IMPORT ; parser-error ssax:warn, see Handling of errors, below ; functions declared in files util.scm, input-parse.scm and look-for-str.scm ; char-encoding.scm for various platform-specific character-encoding functions. ; From SRFI-13: string-concatenate/shared and string-concatenate-reverse/shared ; If a particular implementation lacks SRFI-13 support, please ; include the file srfi-13-local.scm ; Handling of errors ; This package relies on a function parser-error, which must be defined ; by a user of the package. The function has the following signature: ; parser-error PORT MESSAGE SPECIALISING-MSG* ; Many procedures of this package call 'parser-error' whenever a ; parsing, well-formedness or validation error is encountered. The ; first argument is a port, which typically points to the offending ; character or its neighborhood. Most of the Scheme systems let the ; user query a PORT for the current position. The MESSAGE argument ; indicates a failed XML production or a failed XML constraint. The ; latter is referred to by its anchor name in the XML Recommendation ; or XML Namespaces Recommendation. The parsing library (e.g., ; next-token, assert-curr-char) invoke 'parser-error' as well, in ; exactly the same way. See input-parse.scm for more details. ; See ; http://pair.com/lisovsky/download/parse-error.scm ; for an excellent example of such a redefined parser-error function. ; ; In addition, the present code invokes a function ssax:warn ; ssax:warn PORT MESSAGE SPECIALISING-MSG* ; to notify the user about warnings that are NOT errors but still ; may alert the user. ; ; Again, parser-error and ssax:warn are supposed to be defined by the ; user. However, if a run-test macro below is set to include ; self-tests, this present code does provide the definitions for these ; functions to allow tests to run. ; Misc notes ; It seems it is highly desirable to separate tests out in a dedicated ; file. ; ; Jim Bender wrote on Mon, 9 Sep 2002 20:03:42 EDT on the SSAX-SXML ; mailing list (message A fine-grained "lego") ; The task was to record precise source location information, as PLT ; does with its current XML parser. That parser records the start and ; end location (filepos, line#, column#) for pi, elements, attributes, ; chuncks of "pcdata". ; As suggested above, though, in some cases I needed to be able force ; open an interface that did not yet exist. For instance, I added an ; "end-char-data-hook", which would be called at the end of char-data ; fragment. This returns a function of type (seed -> seed) which is ; invoked on the current seed only if read-char-data has indeed reached ; the end of a block of char data (after reading a new token. ; But the deepest interface that I needed to expose was that of reading ; attributes. In the official distribution, this is not even a separate ; function. Instead, it is embedded within SSAX:read-attributes. This ; required some small re-structuring as well. ; This definitely will not be to everyone's taste (nor needed by most). ; Certainly, the existing make-parser interface addresses most custom ; needs. And likely 80-90 lines of a "link specification" to create a ; parser from many tiny little lego blocks may please only a few, while ; appalling others. ; The code is available at http://celtic.benderweb.net/ssax-lego.plt or ; http://celtic.benderweb.net/ssax-lego.tar.gz ; In the examples directory, I provide: ; - a unit version of the make-parser interface, ; - a simple SXML parser using that interface, ; - an SXML parser which directly uses the "new lego", ; - a pseudo-SXML parser, which records source location information ; - and lastly a parser which returns the structures used in PLT's xml ; collection, with source location information ; $Id: SSAX.scm,v 5.1 2004/07/07 16:02:30 sperber Exp $ ;^^^^^^^^^ ; See the Makefile in the ../tests directory ; (in particular, the rule vSSAX) for an example of how ; to run this code on various Scheme systems. ; See SSAX examples for many samples of using this code, ; again, on a variety of Scheme systems. ; See http://ssax.sf.net/ ; The following macro runs built-in test cases -- or does not run, ; depending on which of the two cases below you commented out ; Case 1: no tests: ;(define-macro run-test (lambda body '(begin #f))) ;(define-syntax run-test (syntax-rules () ((run-test . args) (begin #f)))) ; Case 2: with tests. ; The following macro could've been defined just as ; (define-macro run-test (lambda body `(begin (display "\n-->Test\n") ,@body))) ; ; Instead, it's more involved, to make up for case-insensitivity of ; symbols on some Scheme systems. In Gambit, symbols are case ; sensitive: (eq? 'A 'a) is #f and (eq? 'Aa (string->symbol "Aa")) is ; #t. On some systems, symbols are case-insensitive and just the ; opposite is true. Therefore, we introduce a notation '"ASymbol" (a ; quoted string) that stands for a case-_sensitive_ ASymbol -- on any ; R5RS Scheme system. This notation is valid only within the body of ; run-test. ; The notation is implemented by scanning the run-test's ; body and replacing every occurrence of (quote "str") with the result ; of (string->symbol "str"). We can do such a replacement at macro-expand ; time (rather than at run time). ; Here's the previous version of run-test, implemented as a low-level ; macro. ; (define-macro run-test ; (lambda body ; (define (re-write body) ; (cond ; ((vector? body) ; (list->vector (re-write (vector->list body)))) ; ((not (pair? body)) body) ; ((and (eq? 'quote (car body)) (pair? (cdr body)) ; (string? (cadr body))) ; (string->symbol (cadr body))) ; (else (cons (re-write (car body)) (re-write (cdr body)))))) ; (cons 'begin (re-write body)))) ; ; For portability, it is re-written as syntax-rules. The syntax-rules ; version is less powerful: for example, it can't handle ; (case x (('"Foo") (do-on-Foo))) whereas the low-level macro ; could correctly place a case-sensitive symbol at the right place. ; We also do not scan vectors (because we don't use them here). ; Twice-deep quasiquotes aren't handled either. ; Still, the syntax-rules version satisfies our immediate needs. ; Incidentally, I originally didn't believe that the macro below ; was at all possible. ; ; The macro is written in a continuation-passing style. A continuation ; typically has the following structure: (k-head ! . args) ; When the continuation is invoked, we expand into ; (k-head <computed-result> . arg). That is, the dedicated symbol ! ; is the placeholder for the result. ; ; It seems that the most modular way to write the run-test macro would ; be the following ; ; (define-syntax run-test ; (syntax-rules () ; ((run-test . ?body) ; (letrec-syntax ; ((scan-exp ; (scan-exp body k) ; (syntax-rules (quote quasiquote !) ; ((scan-exp (quote (hd . tl)) k) ; (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k))) ; ((scan-exp (quote x) (k-head ! . args)) ; (k-head ; (if (string? (quote x)) (string->symbol (quote x)) (quote x)) ; . args)) ; ((scan-exp (hd . tl) k) ; (scan-exp hd (do-tl ! scan-exp tl k))) ; ((scan-exp x (k-head ! . args)) ; (k-head x . args)))) ; (do-tl ; (syntax-rules (!) ; ((do-tl processed-hd fn () (k-head ! . args)) ; (k-head (processed-hd) . args)) ; ((do-tl processed-hd fn old-tl k) ; (fn old-tl (do-cons ! processed-hd k))))) ; ... ; (do-finish ; (syntax-rules () ; ((do-finish (new-body)) new-body) ; ((do-finish new-body) (begin . new-body)))) ; ... ; (scan-exp ?body (do-finish !)) ; )))) ; ; Alas, that doesn't work on all systems. We hit yet another dark ; corner of the R5RS macros. The reason is that run-test is used in ; the code below to introduce definitions. For example: ; (run-test ; (define (ssax:warn port msg . other-msg) ; (apply cerr (cons* nl "Warning: " msg other-msg))) ; ) ; This code expands to ; (begin ; (define (ssax:warn port msg . other-msg) ...)) ; so the definition gets spliced in into the top level. Right? ; Well, On Petite Chez Scheme it is so. However, many other systems ; don't like this approach. The reason is that the invocation of ; (run-test (define (ssax:warn port msg . other-msg) ...)) ; first expands into ; (letrec-syntax (...) ; (scan-exp ((define (ssax:warn port msg . other-msg) ...)) ...)) ; because of the presence of (letrec-syntax ...), the begin form that ; is generated eventually is no longer at the top level! The begin ; form in Scheme is an overloading of two distinct forms: top-level ; begin and the other begin. The forms have different rules: for example, ; (begin (define x 1)) is OK for a top-level begin but not OK for ; the other begin. Some Scheme systems see the that the macro ; (run-test ...) expands into (letrec-syntax ...) and decide right there ; that any further (begin ...) forms are NOT top-level begin forms. ; The only way out is to make sure all our macros are top-level. ; The best approach <sigh> seems to be to make run-test one huge ; top-level macro. (define-syntax run-test (syntax-rules (define) ((run-test "scan-exp" (define vars body)) (define vars (run-test "scan-exp" body))) ((run-test "scan-exp" ?body) (letrec-syntax ((scan-exp ; (scan-exp body k) (syntax-rules (quote quasiquote !) ((scan-exp '() (k-head ! . args)) (k-head '() . args)) ((scan-exp (quote (hd . tl)) k) (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k))) ((scan-exp (quasiquote (hd . tl)) k) (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k))) ((scan-exp (quote x) (k-head ! . args)) (k-head (if (string? (quote x)) (string->symbol (quote x)) (quote x)) . args)) ((scan-exp (hd . tl) k) (scan-exp hd (do-tl ! scan-exp tl k))) ((scan-exp x (k-head ! . args)) (k-head x . args)))) (do-tl (syntax-rules (!) ((do-tl processed-hd fn () (k-head ! . args)) (k-head (processed-hd) . args)) ((do-tl processed-hd fn old-tl k) (fn old-tl (do-cons ! processed-hd k))))) (do-cons (syntax-rules (!) ((do-cons processed-tl processed-hd (k-head ! . args)) (k-head (processed-hd . processed-tl) . args)))) (do-wrap (syntax-rules (!) ((do-wrap val fn (k-head ! . args)) (k-head (fn val) . args)))) (do-finish (syntax-rules () ((do-finish new-body) new-body))) (scan-lit-lst ; scan literal list (syntax-rules (quote unquote unquote-splicing !) ((scan-lit-lst '() (k-head ! . args)) (k-head '() . args)) ((scan-lit-lst (quote (hd . tl)) k) (do-tl quote scan-lit-lst ((hd . tl)) k)) ((scan-lit-lst (unquote x) k) (scan-exp x (do-wrap ! unquote k))) ((scan-lit-lst (unquote-splicing x) k) (scan-exp x (do-wrap ! unquote-splicing k))) ((scan-lit-lst (quote x) (k-head ! . args)) (k-head ,(if (string? (quote x)) (string->symbol (quote x)) (quote x)) . args)) ((scan-lit-lst (hd . tl) k) (scan-lit-lst hd (do-tl ! scan-lit-lst tl k))) ((scan-lit-lst x (k-head ! . args)) (k-head x . args)))) ) (scan-exp ?body (do-finish !)))) ((run-test body ...) (begin (run-test "scan-exp" body) ...)) )) ;======================================================================== ; Data Types ; TAG-KIND ; a symbol 'START, 'END, 'PI, 'DECL, 'COMMENT, 'CDSECT ; or 'ENTITY-REF that identifies a markup token ; UNRES-NAME ; a name (called GI in the XML Recommendation) as given in an xml ; document for a markup token: start-tag, PI target, attribute name. ; If a GI is an NCName, UNRES-NAME is this NCName converted into ; a Scheme symbol. If a GI is a QName, UNRES-NAME is a pair of ; symbols: (PREFIX . LOCALPART) ; RES-NAME ; An expanded name, a resolved version of an UNRES-NAME. ; For an element or an attribute name with a non-empty namespace URI, ; RES-NAME is a pair of symbols, (URI-SYMB . LOCALPART). ; Otherwise, it's a single symbol. ; ELEM-CONTENT-MODEL ; A symbol: ; ANY - anything goes, expect an END tag. ; EMPTY-TAG - no content, and no END-tag is coming ; EMPTY - no content, expect the END-tag as the next token ; PCDATA - expect character data only, and no children elements ; MIXED ; ELEM-CONTENT ; URI-SYMB ; A symbol representing a namespace URI -- or other symbol chosen ; by the user to represent URI. In the former case, ; URI-SYMB is created by %-quoting of bad URI characters and ; converting the resulting string into a symbol. ; NAMESPACES ; A list representing namespaces in effect. An element of the list ; has one of the following forms: ; (PREFIX URI-SYMB . URI-SYMB) or ; (PREFIX USER-PREFIX . URI-SYMB) ; USER-PREFIX is a symbol chosen by the user ; to represent the URI. ; (#f USER-PREFIX . URI-SYMB) ; Specification of the user-chosen prefix and a URI-SYMBOL. ; (*DEFAULT* USER-PREFIX . URI-SYMB) ; Declaration of the default namespace ; (*DEFAULT* #f . #f) ; Un-declaration of the default namespace. This notation ; represents overriding of the previous declaration ; A NAMESPACES list may contain several elements for the same PREFIX. ; The one closest to the beginning of the list takes effect. ; ATTLIST ; An ordered collection of (NAME . VALUE) pairs, where NAME is ; a RES-NAME or an UNRES-NAME. The collection is an ADT ; STR-HANDLER ; A procedure of three arguments: STRING1 STRING2 SEED ; returning a new SEED ; The procedure is supposed to handle a chunk of character data ; STRING1 followed by a chunk of character data STRING2. ; STRING2 is a short string, often "\n" and even "" ; ENTITIES ; An assoc list of pairs: ; (named-entity-name . named-entity-body) ; where named-entity-name is a symbol under which the entity was ; declared, named-entity-body is either a string, or ; (for an external entity) a thunk that will return an ; input port (from which the entity can be read). ; named-entity-body may also be #f. This is an indication that a ; named-entity-name is currently being expanded. A reference to ; this named-entity-name will be an error: violation of the ; WFC nonrecursion. ; XML-TOKEN -- a record ; In Gambit, you can use the following declaration: ; (define-structure xml-token kind head) ; The following declaration is "standard" as it follows SRFI-9: ;;(define-record-type xml-token (make-xml-token kind head) xml-token? ;; (kind xml-token-kind) ;; (head xml-token-head) ) ; No field mutators are declared as SSAX is a pure functional parser ; ; But to make the code more portable, we define xml-token simply as ; a pair. It suffices for us. Furthermore, xml-token-kind and xml-token-head ; can be defined as simple procedures. However, they are declared as ; macros below for efficiency. (define (make-xml-token kind head) (cons kind head)) (define xml-token? pair?) (define-syntax xml-token-kind (syntax-rules () ((xml-token-kind token) (car token)))) (define-syntax xml-token-head (syntax-rules () ((xml-token-head token) (cdr token)))) ; (define-macro xml-token-kind (lambda (token) `(car ,token))) ; (define-macro xml-token-head (lambda (token) `(cdr ,token))) ; This record represents a markup, which is, according to the XML ; Recommendation, "takes the form of start-tags, end-tags, empty-element tags, ; entity references, character references, comments, CDATA section delimiters, ; document type declarations, and processing instructions." ; ; kind -- a TAG-KIND ; head -- an UNRES-NAME. For xml-tokens of kinds 'COMMENT and ; 'CDSECT, the head is #f ; ; For example, ; <P> => kind='START, head='P ; </P> => kind='END, head='P ; <BR/> => kind='EMPTY-EL, head='BR ; <!DOCTYPE OMF ...> => kind='DECL, head='DOCTYPE ; <?xml version="1.0"?> => kind='PI, head='xml ; &my-ent; => kind = 'ENTITY-REF, head='my-ent ; ; Character references are not represented by xml-tokens as these references ; are transparently resolved into the corresponding characters. ; ; XML-DECL -- a record ; The following is Gambit-specific, see below for a portable declaration ;(define-structure xml-decl elems entities notations) ; The record represents a datatype of an XML document: the list of ; declared elements and their attributes, declared notations, list of ; replacement strings or loading procedures for parsed general ; entities, etc. Normally an xml-decl record is created from a DTD or ; an XML Schema, although it can be created and filled in in many other ; ways (e.g., loaded from a file). ; ; elems: an (assoc) list of decl-elem or #f. The latter instructs ; the parser to do no validation of elements and attributes. ; ; decl-elem: declaration of one element: ; (elem-name elem-content decl-attrs) ; elem-name is an UNRES-NAME for the element. ; elem-content is an ELEM-CONTENT-MODEL. ; decl-attrs is an ATTLIST, of (ATTR-NAME . VALUE) associations ; !!!This element can declare a user procedure to handle parsing of an ; element (e.g., to do a custom validation, or to build a hash of ; IDs as they're encountered). ; ; decl-attr: an element of an ATTLIST, declaration of one attribute ; (attr-name content-type use-type default-value) ; attr-name is an UNRES-NAME for the declared attribute ; content-type is a symbol: CDATA, NMTOKEN, NMTOKENS, ... ; or a list of strings for the enumerated type. ; use-type is a symbol: REQUIRED, IMPLIED, FIXED ; default-value is a string for the default value, or #f if not given. ; ; ; see a function make-empty-xml-decl to make a XML declaration entry ; suitable for a non-validating parsing. ;------------------------- ; Utilities ; ssax:warn PORT MESSAGE SPECIALISING-MSG* ; to notify the user about warnings that are NOT errors but still ; may alert the user. ; Result is unspecified. ; We need to define the function to allow the self-tests to run. ; Normally the definition of ssax:warn is to be provided by the user. (run-test (define (ssax:warn port msg . other-msg) (apply cerr (cons* nl "Warning: " msg other-msg))) ) ; parser-error PORT MESSAGE SPECIALISING-MSG* ; to let the user know of a syntax error or a violation of a ; well-formedness or validation constraint. ; Result is unspecified. ; We need to define the function to allow the self-tests to run. ; Normally the definition of parser-error is to be provided by the user. (run-test (define (parser-error port msg . specializing-msgs) (apply error (cons msg specializing-msgs))) ) ; The following is a function that is often used in validation tests, ; to make sure that the computed result matches the expected one. ; This function is a standard equal? predicate with one exception. ; On Scheme systems where (string->symbol "A") and a symbol A ; are the same, equal_? is precisely equal? ; On other Scheme systems, we compare symbols disregarding their case. ; Since this function is used only in tests, we don't have to ; strive to make it efficient. (run-test (define (equal_? e1 e2) (if (eq? 'A (string->symbol "A")) (equal? e1 e2) (cond ((symbol? e1) (and (symbol? e2) (string-ci=? (symbol->string e1) (symbol->string e2)))) ((pair? e1) (and (pair? e2) (equal_? (car e1) (car e2)) (equal_? (cdr e1) (cdr e2)))) ((vector? e1) (and (vector? e2) (equal_? (vector->list e1) (vector->list e2)))) (else (equal? e1 e2))))) ) ; The following function, which is often used in validation tests, ; lets us conveniently enter newline, CR and tab characters in a character ; string. ; unesc-string: ESC-STRING -> STRING ; where ESC-STRING is a character string that may contain ; %n -- for #\newline ; %r -- for #\return ; %t -- for #\tab ; %% -- for #\% ; ; The result of unesc-string is a character string with all %-combinations ; above replaced with their character equivalents (run-test (define (unesc-string str) (call-with-input-string str (lambda (port) (let loop ((frags '())) (let* ((token (next-token '() '(#\% *eof*) "unesc-string" port)) (cterm (read-char port)) (frags (cons token frags))) (if (eof-object? cterm) (string-concatenate-reverse/shared frags) (let ((cchar (read-char port))) ; char after #\% (if (eof-object? cchar) (error "unexpected EOF after reading % in unesc-string:" str) (loop (cons (case cchar ((#\n) (string #\newline)) ((#\r) (string char-return)) ((#\t) (string char-tab)) ((#\%) "%") (else (error "bad %-char in unesc-string:" cchar))) frags)))))))))) ) ; Test if a string is made of only whitespace ; An empty string is considered made of whitespace as well (define (string-whitespace? str) (let ((len (string-length str))) (cond ((zero? len) #t) ((= 1 len) (char-whitespace? (string-ref str 0))) ((= 2 len) (and (char-whitespace? (string-ref str 0)) (char-whitespace? (string-ref str 1)))) (else (let loop ((i 0)) (or (>= i len) (and (char-whitespace? (string-ref str i)) (loop (inc i))))))))) ; Find val in alist ; Return (values found-el remaining-alist) or ; (values #f alist) (define (assq-values val alist) (let loop ((alist alist) (scanned '())) (cond ((null? alist) (values #f scanned)) ((equal? val (caar alist)) (values (car alist) (append scanned (cdr alist)))) (else (loop (cdr alist) (cons (car alist) scanned)))))) ; From SRFI-1 (define (fold-right kons knil lis1) (let recur ((lis lis1)) (if (null? lis) knil (let ((head (car lis))) (kons head (recur (cdr lis))))))) ; Left fold combinator for a single list (define (fold kons knil lis1) (let lp ((lis lis1) (ans knil)) (if (null? lis) ans (lp (cdr lis) (kons (car lis) ans))))) ;======================================================================== ; Lower-level parsers and scanners ; ; They deal with primitive lexical units (Names, whitespaces, tags) ; and with pieces of more generic productions. Most of these parsers ; must be called in appropriate context. For example, ssax:complete-start-tag ; must be called only when the start-tag has been detected and its GI ; has been read. ;------------------------------------------------------------------------ ; Low-level parsing code ; Skip the S (whitespace) production as defined by ; [3] S ::= (#x20 | #x9 | #xD | #xA) ; The procedure returns the first not-whitespace character it ; encounters while scanning the PORT. This character is left ; on the input stream. (define ssax:S-chars (map ascii->char '(32 10 9 13))) (define (ssax:skip-S port) (skip-while ssax:S-chars port)) ; Read a Name lexem and return it as string ; [4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':' ; | CombiningChar | Extender ; [5] Name ::= (Letter | '_' | ':') (NameChar)* ; ; This code supports the XML Namespace Recommendation REC-xml-names, ; which modifies the above productions as follows: ; ; [4] NCNameChar ::= Letter | Digit | '.' | '-' | '_' ; | CombiningChar | Extender ; [5] NCName ::= (Letter | '_') (NCNameChar)* ; As the Rec-xml-names says, ; "An XML document conforms to this specification if all other tokens ; [other than element types and attribute names] in the document which ; are required, for XML conformance, to match the XML production for ; Name, match this specification's production for NCName." ; Element types and attribute names must match the production QName, ; defined below. ; Check to see if a-char may start a NCName (define (ssax:ncname-starting-char? a-char) (and (char? a-char) (or (char-alphabetic? a-char) (char=? #\_ a-char)))) ; Read a NCName starting from the current position in the PORT and ; return it as a symbol. (define (ssax:read-NCName port) (let ((first-char (peek-char port))) (or (ssax:ncname-starting-char? first-char) (parser-error port "XMLNS [4] for '" first-char "'"))) (string->symbol (next-token-of (lambda (c) (cond ((eof-object? c) #f) ((char-alphabetic? c) c) ((string-index "0123456789.-_" c) c) (else #f))) port))) ; Read a (namespace-) Qualified Name, QName, from the current ; position in the PORT. ; From REC-xml-names: ; [6] QName ::= (Prefix ':')? LocalPart ; [7] Prefix ::= NCName ; [8] LocalPart ::= NCName ; Return: an UNRES-NAME (define (ssax:read-QName port) (let ((prefix-or-localpart (ssax:read-NCName port))) (case (peek-char port) ((#\:) ; prefix was given after all (read-char port) ; consume the colon (cons prefix-or-localpart (ssax:read-NCName port))) (else prefix-or-localpart) ; Prefix was omitted ))) ; The prefix of the pre-defined XML namespace (define ssax:Prefix-XML (string->symbol "xml")) (run-test (assert (eq? '_ (call-with-input-string "_" ssax:read-NCName))) (assert (eq? '_ (call-with-input-string "_" ssax:read-QName))) (assert (eq? (string->symbol "_abc_") (call-with-input-string "_abc_;" ssax:read-NCName))) (assert (eq? (string->symbol "_abc_") (call-with-input-string "_abc_;" ssax:read-QName))) (assert (eq? (string->symbol "_a.b") (call-with-input-string "_a.b " ssax:read-QName))) (assert (equal? (cons (string->symbol "_a.b") (string->symbol "d.1-ef-")) (call-with-input-string "_a.b:d.1-ef-;" ssax:read-QName))) (assert (equal? (cons (string->symbol "a") (string->symbol "b")) (call-with-input-string "a:b:c" ssax:read-QName))) (assert (failed? (call-with-input-string ":abc" ssax:read-NCName))) (assert (failed? (call-with-input-string "1:bc" ssax:read-NCName))) ) ; Compare one RES-NAME or an UNRES-NAME with the other. ; Return a symbol '<, '>, or '= depending on the result of ; the comparison. ; Names without PREFIX are always smaller than those with the PREFIX. (define name-compare (letrec ((symbol-compare (lambda (symb1 symb2) (cond ((eq? symb1 symb2) '=) ((string<? (symbol->string symb1) (symbol->string symb2)) '<) (else '>))))) (lambda (name1 name2) (cond ((symbol? name1) (if (symbol? name2) (symbol-compare name1 name2) '<)) ((symbol? name2) '>) ((eq? name2 ssax:largest-unres-name) '<) ((eq? name1 ssax:largest-unres-name) '>) ((eq? (car name1) (car name2)) ; prefixes the same (symbol-compare (cdr name1) (cdr name2))) (else (symbol-compare (car name1) (car name2))))))) ; An UNRES-NAME that is postulated to be larger than anything that can occur in ; a well-formed XML document. ; name-compare enforces this postulate. (define ssax:largest-unres-name (cons (string->symbol "#LARGEST-SYMBOL") (string->symbol "#LARGEST-SYMBOL"))) (run-test (assert (eq? '= (name-compare 'ABC 'ABC))) (assert (eq? '< (name-compare 'ABC 'ABCD))) (assert (eq? '> (name-compare 'XB 'ABCD))) (assert (eq? '> (name-compare '(HTML . PRE) 'PRE))) (assert (eq? '< (name-compare 'HTML '(HTML . PRE)))) (assert (eq? '= (name-compare '(HTML . PRE) '(HTML . PRE)))) (assert (eq? '< (name-compare '(HTML . PRE) '(XML . PRE)))) (assert (eq? '> (name-compare '(HTML . PRE) '(HTML . P)))) (assert (eq? '< (name-compare '(HTML . PRE) ssax:largest-unres-name))) (assert (eq? '< (name-compare '(ZZZZ . ZZZ) ssax:largest-unres-name))) (assert (eq? '> (name-compare ssax:largest-unres-name '(ZZZZ . ZZZ) ))) ) ; procedure: ssax:read-markup-token PORT ; This procedure starts parsing of a markup token. The current position ; in the stream must be #\<. This procedure scans enough of the input stream ; to figure out what kind of a markup token it is seeing. The procedure returns ; an xml-token structure describing the token. Note, generally reading ; of the current markup is not finished! In particular, no attributes of ; the start-tag token are scanned. ; ; Here's a detailed break out of the return values and the position in the PORT ; when that particular value is returned: ; PI-token: only PI-target is read. ; To finish the Processing Instruction and disregard it, ; call ssax:skip-pi. ssax:read-attributes may be useful ; as well (for PIs whose content is attribute-value ; pairs) ; END-token: The end tag is read completely; the current position ; is right after the terminating #\> character. ; COMMENT is read and skipped completely. The current position ; is right after "-->" that terminates the comment. ; CDSECT The current position is right after "<!CDATA[" ; Use ssax:read-cdata-body to read the rest. ; DECL We have read the keyword (the one that follows "<!") ; identifying this declaration markup. The current ; position is after the keyword (usually a ; whitespace character) ; ; START-token We have read the keyword (GI) of this start tag. ; No attributes are scanned yet. We don't know if this ; tag has an empty content either. ; Use ssax:complete-start-tag to finish parsing of ; the token. (define ssax:read-markup-token ; procedure ssax:read-markup-token port (let () ; we have read "<!-". Skip through the rest of the comment ; Return the 'COMMENT token as an indication we saw a comment ; and skipped it. (define (skip-comment port) (assert-curr-char '(#\-) "XML [15], second dash" port) (if (not (find-string-from-port? "-->" port)) (parser-error port "XML [15], no -->")) (make-xml-token 'COMMENT #f)) ; we have read "<![" that must begin a CDATA section (define (read-cdata port) (assert (string=? "CDATA[" (read-string 6 port))) (make-xml-token 'CDSECT #f)) (lambda (port) (assert-curr-char '(#\<) "start of the token" port) (case (peek-char port) ((#\/) (read-char port) (begin0 (make-xml-token 'END (ssax:read-QName port)) (ssax:skip-S port) (assert-curr-char '(#\>) "XML [42]" port))) ((#\?) (read-char port) (make-xml-token 'PI (ssax:read-NCName port))) ((#\!) (case (peek-next-char port) ((#\-) (read-char port) (skip-comment port)) ((#\[) (read-char port) (read-cdata port)) (else (make-xml-token 'DECL (ssax:read-NCName port))))) (else (make-xml-token 'START (ssax:read-QName port))))) )) ; The current position is inside a PI. Skip till the rest of the PI (define (ssax:skip-pi port) (if (not (find-string-from-port? "?>" port)) (parser-error port "Failed to find ?> terminating the PI"))) ; The current position is right after reading the PITarget. We read the ; body of PI and return is as a string. The port will point to the ; character right after '?>' combination that terminates PI. ; [16] PI ::= '<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>' (define (ssax:read-pi-body-as-string port) (ssax:skip-S port) ; skip WS after the PI target name (string-concatenate/shared (let loop () (let ((pi-fragment (next-token '() '(#\?) "reading PI content" port))) (if (eqv? #\> (peek-next-char port)) (begin (read-char port) (cons pi-fragment '())) (cons* pi-fragment "?" (loop))))))) (run-test (assert (equal? "p1 content " (call-with-input-string "<?pi1 p1 content ?>" (lambda (port) (ssax:read-markup-token port) (ssax:read-pi-body-as-string port))))) (assert (equal? "pi2? content? ?" (call-with-input-string "<?pi2 pi2? content? ??>" (lambda (port) (ssax:read-markup-token port) (ssax:read-pi-body-as-string port))))) ) ;(define (ssax:read-pi-body-as-name-values port) ; The current pos in the port is inside an internal DTD subset ; (e.g., after reading #\[ that begins an internal DTD subset) ; Skip until the "]>" combination that terminates this DTD (define (ssax:skip-internal-dtd port) (if (not (find-string-from-port? "]>" port)) (parser-error port "Failed to find ]> terminating the internal DTD subset"))) ; procedure+: ssax:read-cdata-body PORT STR-HANDLER SEED ; ; This procedure must be called after we have read a string "<![CDATA[" ; that begins a CDATA section. The current position must be the first ; position of the CDATA body. This function reads _lines_ of the CDATA ; body and passes them to a STR-HANDLER, a character data consumer. ; ; The str-handler is a STR-HANDLER, a procedure STRING1 STRING2 SEED. ; The first STRING1 argument to STR-HANDLER never contains a newline. ; The second STRING2 argument often will. On the first invocation of ; the STR-HANDLER, the seed is the one passed to ssax:read-cdata-body ; as the third argument. The result of this first invocation will be ; passed as the seed argument to the second invocation of the line ; consumer, and so on. The result of the last invocation of the ; STR-HANDLER is returned by the ssax:read-cdata-body. Note a ; similarity to the fundamental 'fold' iterator. ; ; Within a CDATA section all characters are taken at their face value, ; with only three exceptions: ; CR, LF, and CRLF are treated as line delimiters, and passed ; as a single #\newline to the STR-HANDLER ; "]]>" combination is the end of the CDATA section. ; > is treated as an embedded #\> character ; Note, < and & are not specially recognized (and are not expanded)! (define ssax:read-cdata-body (let ((cdata-delimiters (list char-return #\newline #\] #\&))) (lambda (port str-handler seed) (let loop ((seed seed)) (let ((fragment (next-token '() cdata-delimiters "reading CDATA" port))) ; that is, we're reading the char after the 'fragment' (case (read-char port) ((#\newline) (loop (str-handler fragment nl seed))) ((#\]) (if (not (eqv? (peek-char port) #\])) (loop (str-handler fragment "]" seed)) (let check-after-second-braket ((seed (if (string-null? fragment) seed (str-handler fragment "" seed)))) (case (peek-next-char port) ; after the second bracket ((#\>) (read-char port) seed) ; we have read "]]>" ((#\]) (check-after-second-braket (str-handler "]" "" seed))) (else (loop (str-handler "]]" "" seed))))))) ((#\&) ; Note that #\& within CDATA may stand for itself (let ((ent-ref ; it does not have to start an entity ref (next-token-of (lambda (c) (and (not (eof-object? c)) (char-alphabetic? c) c)) port))) (cond ; ">" is to be replaced with #\> ((and (string=? "gt" ent-ref) (eqv? (peek-char port) #\;)) (read-char port) (loop (str-handler fragment ">" seed))) (else (loop (str-handler ent-ref "" (str-handler fragment "&" seed))))))) (else ; Must be CR: if the next char is #\newline, skip it (if (eqv? (peek-char port) #\newline) (read-char port)) (loop (str-handler fragment nl seed))) )))))) ; a few lines of validation code (run-test (letrec ((consumer (lambda (fragment foll-fragment seed) (cons* (if (equal? foll-fragment (string #\newline)) " NL" foll-fragment) fragment seed))) (test (lambda (str expected-result) (newline) (display "body: ") (write str) (newline) (display "Result: ") (let ((result (reverse (call-with-input-string (unesc-string str) (lambda (port) (ssax:read-cdata-body port consumer '())) )))) (write result) (assert (equal? result expected-result))))) ) (test "]]>" '()) (test "abcd]]>" '("abcd" "")) (test "abcd]]]>" '("abcd" "" "]" "")) (test "abcd]]]]>" '("abcd" "" "]" "" "]" "")) (test "abcd]]]]]>" '("abcd" "" "]" "" "]" "" "]" "")) (test "abcd]]]a]]>" '("abcd" "" "]" "" "]]" "" "a" "")) (test "abc%r%ndef%n]]>" '("abc" " NL" "def" " NL")) (test "%r%n%r%n]]>" '("" " NL" "" " NL")) (test "%r%n%r%na]]>" '("" " NL" "" " NL" "a" "")) (test "%r%r%r%na]]>" '("" " NL" "" " NL" "" " NL" "a" "")) (test "abc&!!!]]>" '("abc" "&" "" "" "!!!" "")) (test "abc]]>>&]]]>and]]>" '("abc" "" "]]" "" "" ">" "" "&" "gt" "" "" "&" "amp" "" ";" "" "]" "" "]]" "" "" ">" "and" "")) )) ; procedure+: ssax:read-char-ref PORT ; ; [66] CharRef ::= '&#' [0-9]+ ';' ; | '&#x' [0-9a-fA-F]+ ';' ; ; This procedure must be called after we we have read "&#" ; that introduces a char reference. ; The procedure reads this reference and returns the corresponding char ; The current position in PORT will be after ";" that terminates ; the char reference ; Faults detected: ; WFC: XML-Spec.html#wf-Legalchar ; ; According to Section "4.1 Character and Entity References" ; of the XML Recommendation: ; "[Definition: A character reference refers to a specific character ; in the ISO/IEC 10646 character set, for example one not directly ; accessible from available input devices.]" ; Therefore, we use a ucscode->string function to convert a character ; code into the character -- *regardless* of the current character ; encoding of the input stream. (define (ssax:read-char-ref port) (let* ((base (cond ((eqv? (peek-char port) #\x) (read-char port) 16) (else 10))) (name (next-token '() '(#\;) "XML [66]" port)) (char-code (string->number name base))) (read-char port) ; read the terminating #\; char (if (integer? char-code) (ucscode->string char-code) (parser-error port "[wf-Legalchar] broken for '" name "'")))) ; procedure+: ssax:handle-parsed-entity PORT NAME ENTITIES ; CONTENT-HANDLER STR-HANDLER SEED ; ; Expand and handle a parsed-entity reference ; port - a PORT ; name - the name of the parsed entity to expand, a symbol ; entities - see ENTITIES ; content-handler -- procedure PORT ENTITIES SEED ; that is supposed to return a SEED ; str-handler - a STR-HANDLER. It is called if the entity in question ; turns out to be a pre-declared entity ; ; The result is the one returned by CONTENT-HANDLER or STR-HANDLER ; Faults detected: ; WFC: XML-Spec.html#wf-entdeclared ; WFC: XML-Spec.html#norecursion (define ssax:predefined-parsed-entities `( (,(string->symbol "amp") . "&") (,(string->symbol "lt") . "<") (,(string->symbol "gt") . ">") (,(string->symbol "apos") . "'") (,(string->symbol "quot") . "\""))) (define (ssax:handle-parsed-entity port name entities content-handler str-handler seed) (cond ; First we check the list of the declared entities ((assq name entities) => (lambda (decl-entity) (let ((ent-body (cdr decl-entity)) ; mark the list to prevent recursion (new-entities (cons (cons name #f) entities))) (cond ((string? ent-body) (call-with-input-string ent-body (lambda (port) (content-handler port new-entities seed)))) ((procedure? ent-body) (let ((port (ent-body))) (begin0 (content-handler port new-entities seed) (close-input-port port)))) (else (parser-error port "[norecursion] broken for " name)))))) ((assq name ssax:predefined-parsed-entities) => (lambda (decl-entity) (str-handler (cdr decl-entity) "" seed))) (else (parser-error port "[wf-entdeclared] broken for " name)))) ; The ATTLIST Abstract Data Type ; Currently is implemented as an assoc list sorted in the ascending ; order of NAMES. (define (make-empty-attlist) '()) ; Add a name-value pair to the existing attlist preserving the order ; Return the new list, in the sorted ascending order. ; Return #f if a pair with the same name already exists in the attlist (define (attlist-add attlist name-value) (if (null? attlist) (cons name-value attlist) (case (name-compare (car name-value) (caar attlist)) ((=) #f) ((<) (cons name-value attlist)) (else (cons (car attlist) (attlist-add (cdr attlist) name-value))) ))) (define attlist-null? null?) ; Given an non-null attlist, return a pair of values: the top and the rest (define (attlist-remove-top attlist) (values (car attlist) (cdr attlist))) (define (attlist->alist attlist) attlist) (define attlist-fold fold) ; procedure+: ssax:read-attributes PORT ENTITIES ; ; This procedure reads and parses a production Attribute* ; [41] Attribute ::= Name Eq AttValue ; [10] AttValue ::= '"' ([^<&"] | Reference)* '"' ; | "'" ([^<&'] | Reference)* "'" ; [25] Eq ::= S? '=' S? ; ; ; The procedure returns an ATTLIST, of Name (as UNRES-NAME), Value (as string) ; pairs. The current character on the PORT is a non-whitespace character ; that is not an ncname-starting character. ; ; Note the following rules to keep in mind when reading an 'AttValue' ; "Before the value of an attribute is passed to the application ; or checked for validity, the XML processor must normalize it as follows: ; - a character reference is processed by appending the referenced ; character to the attribute value ; - an entity reference is processed by recursively processing the ; replacement text of the entity [see ENTITIES] ; [named entities amp lt gt quot apos are assumed pre-declared] ; - a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20 ; to the normalized value, except that only a single #x20 is appended for a ; "#xD#xA" sequence that is part of an external parsed entity or the ; literal entity value of an internal parsed entity ; - other characters are processed by appending them to the normalized value " ; ; ; Faults detected: ; WFC: XML-Spec.html#CleanAttrVals ; WFC: XML-Spec.html#uniqattspec (define ssax:read-attributes ; ssax:read-attributes port entities (let ((value-delimeters (append ssax:S-chars '(#\< #\&)))) ; Read the AttValue from the PORT up to the delimiter ; (which can be a single or double-quote character, ; or even a symbol *eof*) ; 'prev-fragments' is the list of string fragments, accumulated ; so far, in reverse order. ; Return the list of fragments with newly read fragments ; prepended. (define (read-attrib-value delimiter port entities prev-fragments) (let* ((new-fragments (cons (next-token '() (cons delimiter value-delimeters) "XML [10]" port) prev-fragments)) (cterm (read-char port))) (cond ((or (eof-object? cterm) (eqv? cterm delimiter)) new-fragments) ((eqv? cterm char-return) ; treat a CR and CRLF as a LF (if (eqv? (peek-char port) #\newline) (read-char port)) (read-attrib-value delimiter port entities (cons " " new-fragments))) ((memv cterm ssax:S-chars) (read-attrib-value delimiter port entities (cons " " new-fragments))) ((eqv? cterm #\&) (cond ((eqv? (peek-char port) #\#) (read-char port) (read-attrib-value delimiter port entities (cons (ssax:read-char-ref port) new-fragments))) (else (read-attrib-value delimiter port entities (read-named-entity port entities new-fragments))))) (else (parser-error port "[CleanAttrVals] broken"))))) ; we have read "&" that introduces a named entity reference. ; read this reference and return the result of ; normalizing of the corresponding string ; (that is, read-attrib-value is applied to the replacement ; text of the entity) ; The current position will be after ";" that terminates ; the entity reference (define (read-named-entity port entities fragments) (let ((name (ssax:read-NCName port))) (assert-curr-char '(#\;) "XML [68]" port) (ssax:handle-parsed-entity port name entities (lambda (port entities fragments) (read-attrib-value '*eof* port entities fragments)) (lambda (str1 str2 fragments) (if (equal? "" str2) (cons str1 fragments) (cons* str2 str1 fragments))) fragments))) (lambda (port entities) (let loop ((attr-list (make-empty-attlist))) (if (not (ssax:ncname-starting-char? (ssax:skip-S port))) attr-list (let ((name (ssax:read-QName port))) (ssax:skip-S port) (assert-curr-char '(#\=) "XML [25]" port) (ssax:skip-S port) (let ((delimiter (assert-curr-char '(#\' #\" ) "XML [10]" port))) (loop (or (attlist-add attr-list (cons name (string-concatenate-reverse/shared (read-attrib-value delimiter port entities '())))) (parser-error port "[uniqattspec] broken for " name)))))))) )) ; a few lines of validation code (run-test (letrec ((test (lambda (str decl-entities expected-res) (newline) (display "input: ") (write str) (newline) (display "Result: ") (let ((result (call-with-input-string (unesc-string str) (lambda (port) (ssax:read-attributes port decl-entities))))) (write result) (newline) (assert (equal? result expected-res)))))) (test "" '() '()) (test "href='http://a%tb%r%n%r%n%nc'" '() `((,(string->symbol "href") . "http://a b c"))) (test "href='http://a%tb%r%r%n%rc'" '() `((,(string->symbol "href") . "http://a b c"))) (test "_1 ='12&' _2= \"%r%n%t12 3\">" '() `((_1 . "12&") (_2 . ,(unesc-string " 12%n3")))) (test "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<xx>")) `((,(string->symbol "Abc") . ,(unesc-string "<&>%n")) (,(string->symbol "Next") . "12<xx>34"))) (test "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<xx>")) `((,(string->symbol "Abc") . ,(unesc-string "<&>%r")) (,(string->symbol "Next") . "12<xx>34"))) (test "%tAbc='<&> '%nNext='12&en;34' />" `((en . ,(lambda () (open-input-string ""xx'")))) `((,(string->symbol "Abc") . ,(unesc-string "<&>%n")) (,(string->symbol "Next") . "12\"xx'34"))) (test "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<&ent1;T;>") (ent1 . "&")) `((,(string->symbol "Abc") . ,(unesc-string "<&>%n")) (,(string->symbol "Next") . "12<&T;>34"))) (assert (failed? (test "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<&ent1;T;>") (ent1 . "&")) '()))) (assert (failed? (test "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<&ent;T;>") (ent1 . "&")) '()))) (assert (failed? (test "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<&ent1;T;>") (ent1 . "&ent;")) '()))) (test "html:href='http://a%tb%r%n%r%n%nc'" '() `(((,(string->symbol "html") . ,(string->symbol "href")) . "http://a b c"))) (test "html:href='ref1' html:src='ref2'" '() `(((,(string->symbol "html") . ,(string->symbol "href")) . "ref1") ((,(string->symbol "html") . ,(string->symbol "src")) . "ref2"))) (test "html:href='ref1' xml:html='ref2'" '() `(((,(string->symbol "html") . ,(string->symbol "href")) . "ref1") ((,ssax:Prefix-XML . ,(string->symbol "html")) . "ref2"))) (assert (failed? (test "html:href='ref1' html:href='ref2'" '() '()))) (assert (failed? (test "html:href='<' html:href='ref2'" '() '()))) (assert (failed? (test "html:href='ref1' html:href='&ref2;'" '() '()))) )) ; ssax:resolve-name PORT UNRES-NAME NAMESPACES apply-default-ns? ; ; Convert an UNRES-NAME to a RES-NAME given the appropriate NAMESPACES ; declarations. ; the last parameter apply-default-ns? determines if the default ; namespace applies (for instance, it does not for attribute names) ; ; Per REC-xml-names/#nsc-NSDeclared, "xml" prefix is considered pre-declared ; and bound to the namespace name "http://www.w3.org/XML/1998/namespace". ; ; This procedure tests for the namespace constraints: ; http://www.w3.org/TR/REC-xml-names/#nsc-NSDeclared (define (ssax:resolve-name port unres-name namespaces apply-default-ns?) (cond ((pair? unres-name) ; it's a QNAME (cons (cond ((assq (car unres-name) namespaces) => cadr) ((eq? (car unres-name) ssax:Prefix-XML) ssax:Prefix-XML) (else (parser-error port "[nsc-NSDeclared] broken; prefix " (car unres-name)))) (cdr unres-name))) (apply-default-ns? ; Do apply the default namespace, if any (let ((default-ns (assq '*DEFAULT* namespaces))) (if (and default-ns (cadr default-ns)) (cons (cadr default-ns) unres-name) unres-name))) ; no default namespace declared (else unres-name))) ; no prefix, don't apply the default-ns (run-test (let* ((namespaces '((HTML UHTML . URN-HTML) (HTML UHTML-1 . URN-HTML) (A UHTML . URN-HTML))) (namespaces-def (cons '(*DEFAULT* DEF . URN-DEF) namespaces)) (namespaces-undef (cons '(*DEFAULT* #f . #f) namespaces-def)) (port (current-input-port))) (assert (equal? 'ABC (ssax:resolve-name port 'ABC namespaces #t))) (assert (equal? '(DEF . ABC) (ssax:resolve-name port 'ABC namespaces-def #t))) (assert (equal? 'ABC (ssax:resolve-name port 'ABC namespaces-def #f))) (assert (equal? 'ABC (ssax:resolve-name port 'ABC namespaces-undef #t))) (assert (equal? '(UHTML . ABC) (ssax:resolve-name port '(HTML . ABC) namespaces-def #t))) (assert (equal? '(UHTML . ABC) (ssax:resolve-name port '(HTML . ABC) namespaces-def #f))) (assert (equal? `(,ssax:Prefix-XML . space) (ssax:resolve-name port `(,(string->symbol "xml") . space) namespaces-def #f))) (assert (failed? (ssax:resolve-name port '(XXX . ABC) namespaces-def #f))) )) ; procedure+: ssax:uri-string->symbol URI-STR ; Convert a URI-STR to an appropriate symbol (define (ssax:uri-string->symbol uri-str) (string->symbol uri-str)) ; procedure+: ssax:complete-start-tag TAG PORT ELEMS ENTITIES NAMESPACES ; ; This procedure is to complete parsing of a start-tag markup. The ; procedure must be called after the start tag token has been ; read. TAG is an UNRES-NAME. ELEMS is an instance of xml-decl::elems; ; it can be #f to tell the function to do _no_ validation of elements ; and their attributes. ; ; This procedure returns several values: ; ELEM-GI: a RES-NAME. ; ATTRIBUTES: element's attributes, an ATTLIST of (RES-NAME . STRING) ; pairs. The list does NOT include xmlns attributes. ; NAMESPACES: the input list of namespaces amended with namespace ; (re-)declarations contained within the start-tag under parsing ; ELEM-CONTENT-MODEL ; On exit, the current position in PORT will be the first character after ; #\> that terminates the start-tag markup. ; ; Faults detected: ; VC: XML-Spec.html#enum ; VC: XML-Spec.html#RequiredAttr ; VC: XML-Spec.html#FixedAttr ; VC: XML-Spec.html#ValueType ; WFC: XML-Spec.html#uniqattspec (after namespaces prefixes are resolved) ; VC: XML-Spec.html#elementvalid ; WFC: REC-xml-names/#dt-NSName ; Note, although XML Recommendation does not explicitly say it, ; xmlns and xmlns: attributes don't have to be declared (although they ; can be declared, to specify their default value) ; Procedure: ssax:complete-start-tag tag-head port elems entities namespaces (define ssax:complete-start-tag (let ((xmlns (string->symbol "xmlns")) (largest-dummy-decl-attr (list ssax:largest-unres-name #f #f #f))) ; Scan through the attlist and validate it, against decl-attrs ; Return an assoc list with added fixed or implied attrs. ; Note that both attlist and decl-attrs are ATTLISTs, and therefore, ; sorted (define (validate-attrs port attlist decl-attrs) ; Check to see decl-attr is not of use type REQUIRED. Add ; the association with the default value, if any declared (define (add-default-decl decl-attr result) (let*-values (((attr-name content-type use-type default-value) (apply values decl-attr))) (and (eq? use-type 'REQUIRED) (parser-error port "[RequiredAttr] broken for" attr-name)) (if default-value (cons (cons attr-name default-value) result) result))) (let loop ((attlist attlist) (decl-attrs decl-attrs) (result '())) (if (attlist-null? attlist) (attlist-fold add-default-decl result decl-attrs) (let*-values (((attr attr-others) (attlist-remove-top attlist)) ((decl-attr other-decls) (if (attlist-null? decl-attrs) (values largest-dummy-decl-attr decl-attrs) (attlist-remove-top decl-attrs))) ) (case (name-compare (car attr) (car decl-attr)) ((<) (if (or (eq? xmlns (car attr)) (and (pair? (car attr)) (eq? xmlns (caar attr)))) (loop attr-others decl-attrs (cons attr result)) (parser-error port "[ValueType] broken for " attr))) ((>) (loop attlist other-decls (add-default-decl decl-attr result))) (else ; matched occurrence of an attr with its declaration (let*-values (((attr-name content-type use-type default-value) (apply values decl-attr))) ; Run some tests on the content of the attribute (cond ((eq? use-type 'FIXED) (or (equal? (cdr attr) default-value) (parser-error port "[FixedAttr] broken for " attr-name))) ((eq? content-type 'CDATA) #t) ; everything goes ((pair? content-type) (or (member (cdr attr) content-type) (parser-error port "[enum] broken for " attr-name "=" (cdr attr)))) (else (ssax:warn port "declared content type " content-type " not verified yet"))) (loop attr-others other-decls (cons attr result))))) )))) ; Add a new namespace declaration to namespaces. ; First we convert the uri-str to a uri-symbol and search namespaces for ; an association (_ user-prefix . uri-symbol). ; If found, we return the argument namespaces with an association ; (prefix user-prefix . uri-symbol) prepended. ; Otherwise, we prepend (prefix uri-symbol . uri-symbol) (define (add-ns port prefix uri-str namespaces) (and (equal? "" uri-str) (parser-error port "[dt-NSName] broken for " prefix)) (let ((uri-symbol (ssax:uri-string->symbol uri-str))) (let loop ((nss namespaces)) (cond ((null? nss) (cons (cons* prefix uri-symbol uri-symbol) namespaces)) ((eq? uri-symbol (cddar nss)) (cons (cons* prefix (cadar nss) uri-symbol) namespaces)) (else (loop (cdr nss))))))) ; partition attrs into proper attrs and new namespace declarations ; return two values: proper attrs and the updated namespace declarations (define (adjust-namespace-decl port attrs namespaces) (let loop ((attrs attrs) (proper-attrs '()) (namespaces namespaces)) (cond ((null? attrs) (values proper-attrs namespaces)) ((eq? xmlns (caar attrs)) ; re-decl of the default namespace (loop (cdr attrs) proper-attrs (if (equal? "" (cdar attrs)) ; un-decl of the default ns (cons (cons* '*DEFAULT* #f #f) namespaces) (add-ns port '*DEFAULT* (cdar attrs) namespaces)))) ((and (pair? (caar attrs)) (eq? xmlns (caaar attrs))) (loop (cdr attrs) proper-attrs (add-ns port (cdaar attrs) (cdar attrs) namespaces))) (else (loop (cdr attrs) (cons (car attrs) proper-attrs) namespaces))))) ; The body of the function (lambda (tag-head port elems entities namespaces) (let*-values (((attlist) (ssax:read-attributes port entities)) ((empty-el-tag?) (begin (ssax:skip-S port) (and (eqv? #\/ (assert-curr-char '(#\> #\/) "XML [40], XML [44], no '>'" port)) (assert-curr-char '(#\>) "XML [44], no '>'" port)))) ((elem-content decl-attrs) ; see xml-decl for their type (if elems ; elements declared: validate! (cond ((assoc tag-head elems) => (lambda (decl-elem) ; of type xml-decl::decl-elem (values (if empty-el-tag? 'EMPTY-TAG (cadr decl-elem)) (caddr decl-elem)))) (else (parser-error port "[elementvalid] broken, no decl for " tag-head))) (values ; non-validating parsing (if empty-el-tag? 'EMPTY-TAG 'ANY) #f) ; no attributes declared )) ((merged-attrs) (if decl-attrs (validate-attrs port attlist decl-attrs) (attlist->alist attlist))) ((proper-attrs namespaces) (adjust-namespace-decl port merged-attrs namespaces)) ) ;(cerr "proper attrs: " proper-attrs nl) ; build the return value (values (ssax:resolve-name port tag-head namespaces #t) (fold-right (lambda (name-value attlist) (or (attlist-add attlist (cons (ssax:resolve-name port (car name-value) namespaces #f) (cdr name-value))) (parser-error port "[uniqattspec] after NS expansion broken for " name-value))) (make-empty-attlist) proper-attrs) namespaces elem-content))))) (run-test (let* ((urn-a (string->symbol "urn:a")) (urn-b (string->symbol "urn:b")) (urn-html (string->symbol "http://w3c.org/html")) (namespaces `((#f '"UHTML" . ,urn-html) ('"A" '"UA" . ,urn-a))) (test (lambda (tag-head-name elems str) (call-with-input-string str (lambda (port) (call-with-values (lambda () (ssax:complete-start-tag (call-with-input-string tag-head-name (lambda (port) (ssax:read-QName port))) port elems '() namespaces)) list)))))) ; First test with no validation of elements ;(test "TAG1" #f "") (assert (equal? `('"TAG1" () ,namespaces ANY) (test "TAG1" #f ">"))) (assert (equal? `('"TAG1" () ,namespaces EMPTY-TAG) (test "TAG1" #f "/>"))) (assert (equal? `('"TAG1" (('"HREF" . "a")) ,namespaces EMPTY-TAG) (test "TAG1" #f "HREF='a'/>"))) (assert (equal? `(('"UA" . '"TAG1") (('"HREF" . "a")) ,(cons `(*DEFAULT* '"UA" . ,urn-a) namespaces) ANY) (test "TAG1" #f "HREF='a' xmlns='urn:a'>"))) (assert (equal? `('"TAG1" (('"HREF" . "a")) ,(cons '(*DEFAULT* #f . #f) namespaces) ANY) (test "TAG1" #f "HREF='a' xmlns=''>"))) (assert (failed? (test "UA:TAG1" #f "HREF='a' xmlns=''/>"))) (assert (equal? `(('"UA" . '"TAG1") ((('"UA" . '"HREF") . "a")) ,(cons '(*DEFAULT* #f . #f) namespaces) ANY) (test "A:TAG1" #f "A:HREF='a' xmlns=''>"))) (assert (equal? `(('"UA" . '"TAG1") ((('"UA" . '"HREF") . "a")) ,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) ANY) (test "A:TAG1" #f "A:HREF='a' xmlns='urn:b'>"))) (assert (failed? (test "B:TAG1" #f "A:HREF='a' xmlns:b=''/>"))) (assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a")) ,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY) (test "B:TAG1" #f "A:HREF='a' xmlns:B='urn:b'>"))) (assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a") ((,urn-b . '"SRC") . "b")) ,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY) (test "B:TAG1" #f "B:SRC='b' A:HREF='a' xmlns:B='urn:b'>"))) (assert (equal? `((,urn-b . '"TAG1") ((('"UA" . '"HREF") . "a") ((,urn-b . '"HREF") . "b")) ,(cons `('"B" ,urn-b . ,urn-b) namespaces) ANY) (test "B:TAG1" #f "B:HREF=\"b\" A:HREF='a' xmlns:B='urn:b'>"))) ; must be an error! Duplicate attr (assert (failed? (test "B:TAG1" #f "HREF=\"b\" HREF='a' xmlns:B='urn:a'/>"))) ; must be an error! Duplicate attr after ns expansion (assert (failed? (test "B:TAG1" #f "B:HREF=\"b\" A:HREF='a' xmlns:B='urn:a'/>"))) (assert (equal? `(('"UA" . '"TAG1") (('"HREF" . "a") (('"UA" . '"HREF") . "b")) ,(cons `(*DEFAULT* '"UA" . ,urn-a) namespaces) ANY) (test "TAG1" #f "A:HREF=\"b\" HREF='a' xmlns='urn:a'>"))) (assert (equal? `('"TAG1" ((('"UHTML" . '"HREF") . "a") ((,urn-b . '"HREF") . "b")) ,(append `( ('"HTML" '"UHTML" . ,urn-html) ('"B" ,urn-b . ,urn-b)) namespaces) ANY) (test "TAG1" #f "B:HREF=\"b\" xmlns:B='urn:b' xmlns:HTML='http://w3c.org/html' HTML:HREF='a' >"))) ; Now test the validating parsing ; No decl for tag1 (assert (failed? (test "TAG1" '((TAG2 ANY ())) "B:HREF='b' xmlns:B='urn:b'>"))) ; No decl for HREF elem ;; (cond-expand ;; ((not (or scm mit-scheme)) ; Regretfully, SCM treats '() as #f ;; (assert (failed? ;; (test "TAG1" '(('"TAG1" ANY ())) ;; "B:HREF='b' xmlns:B='urn:b'>")))) ;; (else #t)) ; No decl for HREF elem (assert (failed? (test "TAG1" '(('"TAG1" ANY (('"HREF1" CDATA IMPLIED #f)))) "B:HREF='b' xmlns:B='urn:b'>"))) (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces EMPTY-TAG) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)))) "HREF='b'/>"))) (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)))) "HREF='b'>"))) ; Req'd attribute not given error (assert (failed? (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f)))) ">"))) ; Wrong content-type of the attribute (assert (failed? (test "TAG1" '(('"TAG1" PCDATA (('"HREF" ("c") REQUIRED #f)))) "HREF='b'>"))) (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" ("c" "b") IMPLIED #f)))) "HREF='b'>"))) (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED "c")))) "HREF='b'>"))) ; Bad fixed attribute (assert (failed? (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "c")))) "HREF='b'>"))) (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "b")))) "HREF='b'>"))) (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA FIXED "b")))) ">"))) (assert (equal? `('"TAG1" (('"HREF" . "b")) ,namespaces PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED "b")))) ">"))) (assert (equal? `('"TAG1" () ,namespaces PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA IMPLIED #f)))) ">"))) ; Undeclared attr (assert (failed? (test "TAG1" '(('"TAG1" PCDATA ((('"A" . '"HREF") CDATA IMPLIED "c")))) "HREF='b'>"))) (assert (equal? `('"TAG1" (('"HREF" . "b") (('"UA" . '"HREF") . "c")) ,namespaces PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f) (('"A" . '"HREF") CDATA IMPLIED "c")))) "HREF='b'>"))) (assert (equal? `(('"UA" . '"TAG1") (('"HREF" . "b") (('"UA" . '"HREF") . "c")) ,namespaces PCDATA) (test "A:TAG1" '((('"A" . '"TAG1") PCDATA (('"HREF" NMTOKEN REQUIRED #f) (('"A" . '"HREF") CDATA IMPLIED "c")))) "HREF='b'>"))) (assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b")) ,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA) (test "B:TAG1" '((('"B" . '"TAG1") PCDATA (('"HREF" CDATA REQUIRED #f) (('"xmlns" . '"B") CDATA IMPLIED "urn:b")))) "HREF='b'>"))) (assert (equal? `((,urn-b . '"TAG1") (((,urn-b . '"HREF") . "b")) ,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA) (test "B:TAG1" '((('"B" . '"TAG1") PCDATA ((('"B" . '"HREF") CDATA REQUIRED #f) (('"xmlns" . '"B") CDATA IMPLIED "urn:b")))) "B:HREF='b'>"))) (assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b")) ,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f) ('"xmlns" CDATA IMPLIED "urn:b")))) "HREF='b'>"))) ; xmlns not declared (assert (equal? `((,urn-b . '"TAG1") (('"HREF" . "b")) ,(cons `(*DEFAULT* ,urn-b . ,urn-b) namespaces) PCDATA) (test "TAG1" '(('"TAG1" PCDATA (('"HREF" CDATA REQUIRED #f) ))) "HREF='b' xmlns='urn:b'>"))) ; xmlns:B not declared (assert (equal? `((,urn-b . '"TAG1") (((,urn-b . '"HREF") . "b")) ,(cons `('"B" ,urn-b . ,urn-b) namespaces) PCDATA) (test "B:TAG1" '((('"B" . '"TAG1") PCDATA ((('"B" . '"HREF") CDATA REQUIRED #f) ))) "B:HREF='b' xmlns:B='urn:b'>"))) )) ; procedure+: ssax:read-external-id PORT ; ; This procedure parses an ExternalID production: ; [75] ExternalID ::= 'SYSTEM' S SystemLiteral ; | 'PUBLIC' S PubidLiteral S SystemLiteral ; [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") ; [12] PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'" ; [13] PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9] ; | [-'()+,./:=?;!*#@$_%] ; ; This procedure is supposed to be called when an ExternalID is expected; ; that is, the current character must be either #\S or #\P that start ; correspondingly a SYSTEM or PUBLIC token. This procedure returns the ; SystemLiteral as a string. A PubidLiteral is disregarded if present. (define (ssax:read-external-id port) (let ((discriminator (ssax:read-NCName port))) (assert-curr-char ssax:S-chars "space after SYSTEM or PUBLIC" port) (ssax:skip-S port) (let ((delimiter (assert-curr-char '(#\' #\" ) "XML [11], XML [12]" port))) (cond ((eq? discriminator (string->symbol "SYSTEM")) (begin0 (next-token '() (list delimiter) "XML [11]" port) (read-char port) ; reading the closing delim )) ((eq? discriminator (string->symbol "PUBLIC")) (skip-until (list delimiter) port) (assert-curr-char ssax:S-chars "space after PubidLiteral" port) (ssax:skip-S port) (let* ((delimiter (assert-curr-char '(#\' #\" ) "XML [11]" port)) (systemid (next-token '() (list delimiter) "XML [11]" port))) (read-char port) ; reading the closing delim systemid)) (else (parser-error port "XML [75], " discriminator " rather than SYSTEM or PUBLIC")))))) ;----------------------------------------------------------------------------- ; Higher-level parsers and scanners ; ; They parse productions corresponding to the whole (document) entity ; or its higher-level pieces (prolog, root element, etc). ; Scan the Misc production in the context ; [1] document ::= prolog element Misc* ; [22] prolog ::= XMLDecl? Misc* (doctypedec l Misc*)? ; [27] Misc ::= Comment | PI | S ; ; The following function should be called in the prolog or epilog contexts. ; In these contexts, whitespaces are completely ignored. ; The return value from ssax:scan-Misc is either a PI-token, ; a DECL-token, a START token, or EOF. ; Comments are ignored and not reported. (define (ssax:scan-Misc port) (let loop ((c (ssax:skip-S port))) (cond ((eof-object? c) c) ((not (char=? c #\<)) (parser-error port "XML [22], char '" c "' unexpected")) (else (let ((token (ssax:read-markup-token port))) (case (xml-token-kind token) ((COMMENT) (loop (ssax:skip-S port))) ((PI DECL START) token) (else (parser-error port "XML [22], unexpected token of kind " (xml-token-kind token) )))))))) ; procedure+: ssax:read-char-data PORT EXPECT-EOF? STR-HANDLER SEED ; ; This procedure is to read the character content of an XML document ; or an XML element. ; [43] content ::= ; (element | CharData | Reference | CDSect | PI ; | Comment)* ; To be more precise, the procedure reads CharData, expands CDSect ; and character entities, and skips comments. The procedure stops ; at a named reference, EOF, at the beginning of a PI or a start/end tag. ; ; port ; a PORT to read ; expect-eof? ; a boolean indicating if EOF is normal, i.e., the character ; data may be terminated by the EOF. EOF is normal ; while processing a parsed entity. ; str-handler ; a STR-HANDLER ; seed ; an argument passed to the first invocation of STR-HANDLER. ; ; The procedure returns two results: SEED and TOKEN. ; The SEED is the result of the last invocation of STR-HANDLER, or the ; original seed if STR-HANDLER was never called. ; ; TOKEN can be either an eof-object (this can happen only if ; expect-eof? was #t), or: ; - an xml-token describing a START tag or an END-tag; ; For a start token, the caller has to finish reading it. ; - an xml-token describing the beginning of a PI. It's up to an ; application to read or skip through the rest of this PI; ; - an xml-token describing a named entity reference. ; ; CDATA sections and character references are expanded inline and ; never returned. Comments are silently disregarded. ; ; As the XML Recommendation requires, all whitespace in character data ; must be preserved. However, a CR character (#xD) must be disregarded ; if it appears before a LF character (#xA), or replaced by a #xA character ; otherwise. See Secs. 2.10 and 2.11 of the XML Recommendation. See also ; the canonical XML Recommendation. ; ssax:read-char-data port expect-eof? str-handler seed (define ssax:read-char-data (let ((terminators-usual (list #\< #\& char-return)) (terminators-usual-eof (list #\< '*eof* #\& char-return)) (handle-fragment (lambda (fragment str-handler seed) (if (string-null? fragment) seed (str-handler fragment "" seed)))) ) (lambda (port expect-eof? str-handler seed) ; Very often, the first character we encounter is #\< ; Therefore, we handle this case in a special, fast path (if (eqv? #\< (peek-char port)) ; The fast path (let ((token (ssax:read-markup-token port))) (case (xml-token-kind token) ((START END) ; The most common case (values seed token)) ((CDSECT) (let ((seed (ssax:read-cdata-body port str-handler seed))) (ssax:read-char-data port expect-eof? str-handler seed))) ((COMMENT) (ssax:read-char-data port expect-eof? str-handler seed)) (else (values seed token)))) ; The slow path (let ((char-data-terminators (if expect-eof? terminators-usual-eof terminators-usual))) (let loop ((seed seed)) (let* ((fragment (next-token '() char-data-terminators "reading char data" port)) (term-char (peek-char port)) ; one of char-data-terminators ) (if (eof-object? term-char) (values (handle-fragment fragment str-handler seed) term-char) (case term-char ((#\<) (let ((token (ssax:read-markup-token port))) (case (xml-token-kind token) ((CDSECT) (loop (ssax:read-cdata-body port str-handler (handle-fragment fragment str-handler seed)))) ((COMMENT) (loop (handle-fragment fragment str-handler seed))) (else (values (handle-fragment fragment str-handler seed) token))))) ((#\&) (case (peek-next-char port) ((#\#) (read-char port) (loop (str-handler fragment (ssax:read-char-ref port) seed))) (else (let ((name (ssax:read-NCName port))) (assert-curr-char '(#\;) "XML [68]" port) (values (handle-fragment fragment str-handler seed) (make-xml-token 'ENTITY-REF name)))))) (else ; This must be a CR character (if (eqv? (peek-next-char port) #\newline) (read-char port)) (loop (str-handler fragment (string #\newline) seed)))) )))))))) ; a few lines of validation code (run-test (letrec ((a-tag (make-xml-token 'START (string->symbol "BR"))) (a-ref (make-xml-token 'ENTITY-REF (string->symbol "lt"))) (eof-object (lambda () eof-object)) ; a unique value (str-handler (lambda (fragment foll-fragment seed) (if (string-null? foll-fragment) (cons fragment seed) (cons* foll-fragment fragment seed)))) (test (lambda (str expect-eof? expected-data expected-token) (newline) (display "body: ") (write str) (newline) (display "Result: ") (let*-values (((seed token) (call-with-input-string (unesc-string str) (lambda (port) (ssax:read-char-data port expect-eof? str-handler '())))) ((result) (reverse seed))) (write result) (display " ") (display token) (assert (equal? result (map unesc-string expected-data)) (if (eq? expected-token eof-object) (eof-object? token) (equal? token expected-token)))))) ) (test "" #t '() eof-object) (assert (failed? (test "" #f '() eof-object))) (test " " #t '(" ") eof-object) (test "<BR/>" #f '() a-tag) (test " <BR />" #f '(" ") a-tag) (test " <" #f '(" ") a-ref) (test " a<" #f '(" a") a-ref) (test " a <" #f '(" a ") a-ref) (test " <!-- comment--> a a<BR/>" #f '(" " " a a") a-tag) (test " <!-- comment-->%ra a<BR/>" #f '(" " "" "%n" "a a") a-tag) (test " <!-- comment-->%r%na a<BR/>" #f '(" " "" "%n" "a a") a-tag) (test " <!-- comment-->%r%na%t%r%r%na<BR/>" #f '(" " "" "%n" "a%t" "%n" "" "%n" "a") a-tag) (test "a<!-- comment--> a a<BR/>" #f '("a" " a a") a-tag) (test "!<BR/>" #f '("" "!") a-tag) (test "!%n<BR/>" #f '("" "!" "%n") a-tag) (test "%t!%n<BR/>" #f '("%t" "!" "%n") a-tag) (test "%t!%na a<BR/>" #f '("%t" "!" "%na a") a-tag) (test "%t!%ra a<BR/>" #f '("%t" "!" "" "%n" "a a") a-tag) (test "%t!%r%na a<BR/>" #f '("%t" "!" "" "%n" "a a") a-tag) (test " %ta ! b <BR/>" #f '(" %ta " "!" " b ") a-tag) (test " %ta b <BR/>" #f '(" %ta " " " " b ") a-tag) (test "<![CDATA[<]]><BR/>" #f '("<") a-tag) (test "<![CDATA[]]]><BR/>" #f '("]") a-tag) (test "%t<![CDATA[<]]><BR/>" #f '("%t" "<") a-tag) (test "%t<![CDATA[<]]>a b<BR/>" #f '("%t" "<" "a b") a-tag) (test "%t<![CDATA[<]]> a b<BR/>" #f '("%t" "<" " a b") a-tag) (test "%td <![CDATA[ <%r%r%n]]> a b<BR/>" #f '("%td " " <" "%n" "" "%n" " a b") a-tag) )) ; procedure+: ssax:assert-token TOKEN KIND GI ; Make sure that TOKEN is of anticipated KIND and has anticipated GI ; Note GI argument may actually be a pair of two symbols, Namespace ; URI or the prefix, and of the localname. ; If the assertion fails, error-cont is evaluated by passing it ; three arguments: token kind gi. The result of error-cont is returned. (define (ssax:assert-token token kind gi error-cont) (or (and (xml-token? token) (eq? kind (xml-token-kind token)) (equal? gi (xml-token-head token))) (error-cont token kind gi))) ;======================================================================== ; Highest-level parsers: XML to SXML ; These parsers are a set of syntactic forms to instantiate a SSAX parser. ; A user can instantiate the parser to do the full validation, or ; no validation, or any particular validation. The user specifies ; which PI he wants to be notified about. The user tells what to do ; with the parsed character and element data. The latter handlers ; determine if the parsing follows a SAX or a DOM model. ; syntax: ssax:make-pi-parser my-pi-handlers ; Create a parser to parse and process one Processing Element (PI). ; my-pi-handlers ; An assoc list of pairs (PI-TAG . PI-HANDLER) ; where PI-TAG is an NCName symbol, the PI target, and ; PI-HANDLER is a procedure PORT PI-TAG SEED ; where PORT points to the first symbol after the PI target. ; The handler should read the rest of the PI up to and including ; the combination '?>' that terminates the PI. The handler should ; return a new seed. ; One of the PI-TAGs may be the symbol *DEFAULT*. The corresponding ; handler will handle PIs that no other handler will. If the ; *DEFAULT* PI-TAG is not specified, ssax:make-pi-parser will assume ; the default handler that skips the body of the PI ; ; The output of the ssax:make-pi-parser is a procedure ; PORT PI-TAG SEED ; that will parse the current PI according to the user-specified handlers. ; ; The previous version of ssax:make-pi-parser was a low-level macro: ; (define-macro ssax:make-pi-parser ; (lambda (my-pi-handlers) ; `(lambda (port target seed) ; (case target ; ; Generate the body of the case statement ; ,@(let loop ((pi-handlers my-pi-handlers) (default #f)) ; (cond ; ((null? pi-handlers) ; (if default `((else (,default port target seed))) ; '((else ; (ssax:warn port "Skipping PI: " target nl) ; (ssax:skip-pi port) ; seed)))) ; ((eq? '*DEFAULT* (caar pi-handlers)) ; (loop (cdr pi-handlers) (cdar pi-handlers))) ; (else ; (cons ; `((,(caar pi-handlers)) (,(cdar pi-handlers) port target seed)) ; (loop (cdr pi-handlers) default))))))))) (define-syntax ssax:make-pi-parser (syntax-rules () ((ssax:make-pi-parser orig-handlers) (letrec-syntax ; Generate the clauses of the case statement ((loop (syntax-rules (*DEFAULT*) ((loop () #f accum port target seed) ; no default (make-case ((else (ssax:warn port "Skipping PI: " target nl) (ssax:skip-pi port) seed) . accum) () target)) ((loop () default accum port target seed) (make-case ((else (default port target seed)) . accum) () target)) ((loop ((*DEFAULT* . default) . handlers) old-def accum port target seed) (loop handlers default accum port target seed)) ((loop ((tag . handler) . handlers) default accum port target seed) (loop handlers default (((tag) (handler port target seed)) . accum) port target seed)) )) (make-case ; Reverse the clauses, make the 'case' (syntax-rules () ((make-case () clauses target) (case target . clauses)) ((make-case (clause . clauses) accum target) (make-case clauses (clause . accum) target))) )) (lambda (port target seed) (loop orig-handlers #f () port target seed)) )))) (run-test (pp (ssax:make-pi-parser ())) (pp (ssax:make-pi-parser ((xml . (lambda (port target seed) seed))))) (pp (ssax:make-pi-parser ((xml . (lambda (port target seed) seed)) (html . list) (*DEFAULT* . ssax:warn)))) ) ; syntax: ssax:make-elem-parser my-new-level-seed my-finish-element ; my-char-data-handler my-pi-handlers ; Create a parser to parse and process one element, including its ; character content or children elements. The parser is typically ; applied to the root element of a document. ; my-new-level-seed ; procedure ELEM-GI ATTRIBUTES NAMESPACES EXPECTED-CONTENT SEED ; where ELEM-GI is a RES-NAME of the element ; about to be processed. ; This procedure is to generate the seed to be passed ; to handlers that process the content of the element. ; This is the function identified as 'fdown' in the denotational ; semantics of the XML parser given in the title comments to this ; file. ; ; my-finish-element ; procedure ELEM-GI ATTRIBUTES NAMESPACES PARENT-SEED SEED ; This procedure is called when parsing of ELEM-GI is finished. ; The SEED is the result from the last content parser (or ; from my-new-level-seed if the element has the empty content). ; PARENT-SEED is the same seed as was passed to my-new-level-seed. ; The procedure is to generate a seed that will be the result ; of the element parser. ; This is the function identified as 'fup' in the denotational ; semantics of the XML parser given in the title comments to this ; file. ; ; my-char-data-handler ; A STR-HANDLER ; ; my-pi-handlers ; See ssax:make-pi-handler above ; ; The generated parser is a ; procedure START-TAG-HEAD PORT ELEMS ENTITIES ; NAMESPACES PRESERVE-WS? SEED ; The procedure must be called after the start tag token has been ; read. START-TAG-HEAD is an UNRES-NAME from the start-element tag. ; ELEMS is an instance of xml-decl::elems. ; See ssax:complete-start-tag::preserve-ws? ; Faults detected: ; VC: XML-Spec.html#elementvalid ; WFC: XML-Spec.html#GIMatch (define-syntax ssax:make-elem-parser (syntax-rules () ((ssax:make-elem-parser my-new-level-seed my-finish-element my-char-data-handler my-pi-handlers) (lambda (start-tag-head port elems entities namespaces preserve-ws? seed) (define xml-space-gi (cons ssax:Prefix-XML (string->symbol "space"))) (let handle-start-tag ((start-tag-head start-tag-head) (port port) (entities entities) (namespaces namespaces) (preserve-ws? preserve-ws?) (parent-seed seed)) (let*-values (((elem-gi attributes namespaces expected-content) (ssax:complete-start-tag start-tag-head port elems entities namespaces)) ((seed) (my-new-level-seed elem-gi attributes namespaces expected-content parent-seed))) (case expected-content ((EMPTY-TAG) (my-finish-element elem-gi attributes namespaces parent-seed seed)) ((EMPTY) ; The end tag must immediately follow (ssax:assert-token (and (eqv? #\< (ssax:skip-S port)) (ssax:read-markup-token port)) 'END start-tag-head (lambda (token exp-kind exp-head) (parser-error port "[elementvalid] broken for " token " while expecting " exp-kind exp-head))) (my-finish-element elem-gi attributes namespaces parent-seed seed)) (else ; reading the content... (let ((preserve-ws? ; inherit or set the preserve-ws? flag (cond ((assoc xml-space-gi attributes) => (lambda (name-value) (equal? "preserve" (cdr name-value)))) (else preserve-ws?)))) (let loop ((port port) (entities entities) (expect-eof? #f) (seed seed)) (let*-values (((seed term-token) (ssax:read-char-data port expect-eof? my-char-data-handler seed))) (if (eof-object? term-token) seed (case (xml-token-kind term-token) ((END) (ssax:assert-token term-token 'END start-tag-head (lambda (token exp-kind exp-head) (parser-error port "[GIMatch] broken for " term-token " while expecting " exp-kind exp-head))) (my-finish-element elem-gi attributes namespaces parent-seed seed)) ((PI) (let ((seed ((ssax:make-pi-parser my-pi-handlers) port (xml-token-head term-token) seed))) (loop port entities expect-eof? seed))) ((ENTITY-REF) (let ((seed (ssax:handle-parsed-entity port (xml-token-head term-token) entities (lambda (port entities seed) (loop port entities #t seed)) my-char-data-handler seed))) ; keep on reading the content after ent (loop port entities expect-eof? seed))) ((START) ; Start of a child element (if (eq? expected-content 'PCDATA) (parser-error port "[elementvalid] broken for " elem-gi " with char content only; unexpected token " term-token)) ; Do other validation of the element content (let ((seed (handle-start-tag (xml-token-head term-token) port entities namespaces preserve-ws? seed))) (loop port entities expect-eof? seed))) (else (parser-error port "XML [43] broken for " term-token)))))))) ))) )))) ; syntax: ssax:make-parser user-handler-tag user-handler-proc ... ; ; Create an XML parser, an instance of the XML parsing framework. ; This will be a SAX, a DOM, or a specialized parser depending ; on the supplied user-handlers. ; user-handler-tag is a symbol that identifies a procedural expression ; that follows the tag. Given below are tags and signatures of the ; corresponding procedures. Not all tags have to be specified. If some ; are omitted, reasonable defaults will apply. ; ; tag: DOCTYPE ; handler-procedure: PORT DOCNAME SYSTEMID INTERNAL-SUBSET? SEED ; If internal-subset? is #t, the current position in the port ; is right after we have read #\[ that begins the internal DTD subset. ; We must finish reading of this subset before we return ; (or must call skip-internal-subset if we aren't interested in reading it). ; The port at exit must be at the first symbol after the whole ; DOCTYPE declaration. ; The handler-procedure must generate four values: ; ELEMS ENTITIES NAMESPACES SEED ; See xml-decl::elems for ELEMS. It may be #f to switch off the validation. ; NAMESPACES will typically contain USER-PREFIXes for selected URI-SYMBs. ; The default handler-procedure skips the internal subset, ; if any, and returns (values #f '() '() seed) ; tag: UNDECL-ROOT ; handler-procedure: ELEM-GI SEED ; where ELEM-GI is an UNRES-NAME of the root element. This procedure ; is called when an XML document under parsing contains _no_ DOCTYPE ; declaration. ; The handler-procedure, as a DOCTYPE handler procedure above, ; must generate four values: ; ELEMS ENTITIES NAMESPACES SEED ; The default handler-procedure returns (values #f '() '() seed) ; tag: DECL-ROOT ; handler-procedure: ELEM-GI SEED ; where ELEM-GI is an UNRES-NAME of the root element. This procedure ; is called when an XML document under parsing does contains the DOCTYPE ; declaration. ; The handler-procedure must generate a new SEED (and verify ; that the name of the root element matches the doctype, if the handler ; so wishes). ; The default handler-procedure is the identity function. ; tag: NEW-LEVEL-SEED ; handler-procedure: see ssax:make-elem-parser, my-new-level-seed ; tag: FINISH-ELEMENT ; handler-procedure: see ssax:make-elem-parser, my-finish-element ; tag: CHAR-DATA-HANDLER ; handler-procedure: see ssax:make-elem-parser, my-char-data-handler ; tag: PI ; handler-procedure: see ssax:make-pi-parser ; The default value is '() ; The generated parser is a ; procedure PORT SEED ; This procedure parses the document prolog and then exits to ; an element parser (created by ssax:make-elem-parser) to handle ; the rest. ; ; [1] document ::= prolog element Misc* ; [22] prolog ::= XMLDecl? Misc* (doctypedec | Misc*)? ; [27] Misc ::= Comment | PI | S ; ; [28] doctypedecl ::= '<!DOCTYPE' S Name (S ExternalID)? S? ; ('[' (markupdecl | PEReference | S)* ']' S?)? '>' ; [29] markupdecl ::= elementdecl | AttlistDecl ; | EntityDecl ; | NotationDecl | PI ; | Comment ; ; This is ssax:make-parser with all the (specialization) handlers given ; as positional arguments. It is called by ssax:make-parser, see below (define-syntax ssax:make-parser/positional-args (syntax-rules () ((ssax:make-parser/positional-args *handler-DOCTYPE *handler-UNDECL-ROOT *handler-DECL-ROOT *handler-NEW-LEVEL-SEED *handler-FINISH-ELEMENT *handler-CHAR-DATA-HANDLER *handler-PI) (lambda (port seed) ; We must've just scanned the DOCTYPE token ; Handle the doctype declaration and exit to ; scan-for-significant-prolog-token-2, and eventually, to the ; element parser. (define (handle-decl port token-head seed) (or (eq? (string->symbol "DOCTYPE") token-head) (parser-error port "XML [22], expected DOCTYPE declaration, found " token-head)) (assert-curr-char ssax:S-chars "XML [28], space after DOCTYPE" port) (ssax:skip-S port) (let*-values (((docname) (ssax:read-QName port)) ((systemid) (and (ssax:ncname-starting-char? (ssax:skip-S port)) (ssax:read-external-id port))) ((internal-subset?) (begin (ssax:skip-S port) (eqv? #\[ (assert-curr-char '(#\> #\[) "XML [28], end-of-DOCTYPE" port)))) ((elems entities namespaces seed) (*handler-DOCTYPE port docname systemid internal-subset? seed)) ) (scan-for-significant-prolog-token-2 port elems entities namespaces seed))) ; Scan the leading PIs until we encounter either a doctype declaration ; or a start token (of the root element) ; In the latter two cases, we exit to the appropriate continuation (define (scan-for-significant-prolog-token-1 port seed) (let ((token (ssax:scan-Misc port))) (if (eof-object? token) (parser-error port "XML [22], unexpected EOF") (case (xml-token-kind token) ((PI) (let ((seed ((ssax:make-pi-parser *handler-PI) port (xml-token-head token) seed))) (scan-for-significant-prolog-token-1 port seed))) ((DECL) (handle-decl port (xml-token-head token) seed)) ((START) (let*-values (((elems entities namespaces seed) (*handler-UNDECL-ROOT (xml-token-head token) seed))) (element-parser (xml-token-head token) port elems entities namespaces #f seed))) (else (parser-error port "XML [22], unexpected markup " token)))))) ; Scan PIs after the doctype declaration, till we encounter ; the start tag of the root element. After that we exit ; to the element parser (define (scan-for-significant-prolog-token-2 port elems entities namespaces seed) (let ((token (ssax:scan-Misc port))) (if (eof-object? token) (parser-error port "XML [22], unexpected EOF") (case (xml-token-kind token) ((PI) (let ((seed ((ssax:make-pi-parser *handler-PI) port (xml-token-head token) seed))) (scan-for-significant-prolog-token-2 port elems entities namespaces seed))) ((START) (element-parser (xml-token-head token) port elems entities namespaces #f (*handler-DECL-ROOT (xml-token-head token) seed))) (else (parser-error port "XML [22], unexpected markup " token)))))) ; A procedure start-tag-head port elems entities namespaces ; preserve-ws? seed (define element-parser (ssax:make-elem-parser *handler-NEW-LEVEL-SEED *handler-FINISH-ELEMENT *handler-CHAR-DATA-HANDLER *handler-PI)) ; Get the ball rolling ... (scan-for-significant-prolog-token-1 port seed) )))) ; The following meta-macro turns a regular macro (with positional ; arguments) into a form with keyword (labeled) arguments. We later ; use the meta-macro to convert ssax:make-parser/positional-args into ; ssax:make-parser. The latter provides a prettier (with labeled ; arguments and defaults) interface to ; ssax:make-parser/positional-args ; ; ssax:define-labeled-arg-macro LABELED-ARG-MACRO-NAME ; (POS-MACRO-NAME ARG-DESCRIPTOR ...) ; expands into the definition of a macro ; LABELED-ARG-MACRO-NAME KW-NAME KW-VALUE KW-NAME1 KW-VALUE1 ... ; which, in turn, expands into ; POS-MACRO-NAME ARG1 ARG2 ... ; where each ARG1 etc. comes either from KW-VALUE or from ; the deafult part of ARG-DESCRIPTOR. ARG1 corresponds to the first ; ARG-DESCRIPTOR, ARG2 corresponds to the second descriptor, etc. ; Here ARG-DESCRIPTOR describes one argument of the positional macro. ; It has the form ; (ARG-NAME DEFAULT-VALUE) ; or ; (ARG-NAME) ; In the latter form, the default value is not given, so that the invocation of ; LABELED-ARG-MACRO-NAME must mention the corresponding parameter. ; ARG-NAME can be anything: an identifier, a string, or even a number. (define-syntax ssax:define-labeled-arg-macro (syntax-rules () ((ssax:define-labeled-arg-macro labeled-arg-macro-name (positional-macro-name (arg-name . arg-def) ...)) (define-syntax labeled-arg-macro-name (syntax-rules () ((labeled-arg-macro-name . kw-val-pairs) (letrec-syntax ((find (syntax-rules (arg-name ...) ((find k-args (arg-name . default) arg-name val . others) ; found arg-name among kw-val-pairs (next val . k-args)) ... ((find k-args key arg-no-match-name val . others) (find k-args key . others)) ((find k-args (arg-name default)) ; default must be here (next default . k-args)) ... )) (next ; pack the continuation to find (syntax-rules () ((next val vals key . keys) (find ((val . vals) . keys) key . kw-val-pairs)) ((next val vals) ; processed all arg-descriptors (rev-apply (val) vals)))) (rev-apply (syntax-rules () ((rev-apply form (x . xs)) (rev-apply (x . form) xs)) ((rev-apply form ()) form)))) (next positional-macro-name () (arg-name . arg-def) ...)))))))) ; The definition of ssax:make-parser (ssax:define-labeled-arg-macro ssax:make-parser (ssax:make-parser/positional-args (DOCTYPE (lambda (port docname systemid internal-subset? seed) (when internal-subset? (ssax:warn port "Internal DTD subset is not currently handled ") (ssax:skip-internal-dtd port)) (ssax:warn port "DOCTYPE DECL " docname " " systemid " found and skipped") (values #f '() '() seed) )) (UNDECL-ROOT (lambda (elem-gi seed) (values #f '() '() seed))) (DECL-ROOT (lambda (elem-gi seed) seed)) (NEW-LEVEL-SEED) ; required (FINISH-ELEMENT) ; required (CHAR-DATA-HANDLER) ; required (PI ()) )) (run-test (letrec ((simple-parser (lambda (str doctype-fn) (call-with-input-string str (lambda (port) ((ssax:make-parser NEW-LEVEL-SEED (lambda (elem-gi attributes namespaces expected-content seed) '()) FINISH-ELEMENT (lambda (elem-gi attributes namespaces parent-seed seed) (let ((seed (if (null? namespaces) (reverse seed) (cons (list '*NAMESPACES* namespaces) (reverse seed))))) (let ((seed (if (attlist-null? attributes) seed (cons (cons '@ (map (lambda (attr) (list (car attr) (cdr attr))) (attlist->alist attributes))) seed)))) (cons (cons elem-gi seed) parent-seed)))) CHAR-DATA-HANDLER (lambda (string1 string2 seed) (if (string-null? string2) (cons string1 seed) (cons* string2 string1 seed))) DOCTYPE (lambda (port docname systemid internal-subset? seed) (when internal-subset? (ssax:warn port "Internal DTD subset is not currently handled ") (ssax:skip-internal-dtd port)) (ssax:warn port "DOCTYPE DECL " docname " " systemid " found and skipped") (doctype-fn docname seed)) UNDECL-ROOT (lambda (elem-gi seed) (doctype-fn elem-gi seed)) ) port '()))))) (dummy-doctype-fn (lambda (elem-gi seed) (values #f '() '() seed))) (test (lambda (str doctype-fn expected) (cout nl "Parsing: " str nl) (let ((result (simple-parser (unesc-string str) doctype-fn))) (write result) (assert (equal? result expected))))) ) (test "<BR/>" dummy-doctype-fn '(('"BR"))) (assert (failed? (test "<BR>" dummy-doctype-fn '()))) (test "<BR></BR>" dummy-doctype-fn '(('"BR"))) (assert (failed? (test "<BR></BB>" dummy-doctype-fn '()))) (test " <A HREF='URL'> link <I>itlink </I> &amp;</A>" dummy-doctype-fn '(('"A" (@ ('"HREF" "URL")) " link " ('"I" "itlink ") " " "&" "amp;"))) (test " <A HREF='URL' xml:space='preserve'> link <I>itlink </I> &amp;</A>" dummy-doctype-fn '(('"A" (@ ('"HREF" "URL") (('"xml" . '"space") "preserve")) " link " ('"I" "itlink ") " " "&" "amp;"))) (test " <A HREF='URL' xml:space='preserve'> link <I xml:space='default'>itlink </I> &amp;</A>" dummy-doctype-fn '(('"A" (@ ('"HREF" "URL") (('"xml" . '"space") "preserve")) " link " ('"I" (@ (('"xml" . '"space") "default")) "itlink ") " " "&" "amp;"))) (test "<itemize><item>This is item 1 </item>%n<!-- Just:a comment --><item>Item 2</item>%n </itemize>" dummy-doctype-fn `(('"itemize" ('"item" "This is item 1 ") ,(unesc-string "%n") ('"item" "Item 2") ,(unesc-string "%n ")))) (test " <P><![CDATA[<BR>%n<![CDATA[<BR>]]>]]></P>" dummy-doctype-fn `(('"P" "<BR>" ,nl "<![CDATA[<BR>" "]]" "" ">"))) (test " <P><![CDATA[<BR>%r<![CDATA[<BR>]]>]]></P>" dummy-doctype-fn `(('"P" "<BR>" ,nl "<![CDATA[<BR>" "]]" "" ">"))) (test "<?xml version='1.0'?>%n%n<Reports TStamp='1'></Reports>" dummy-doctype-fn '(('"Reports" (@ ('"TStamp" "1"))))) (test "%n<?PI xxx?><!-- Comment %n -%r-->%n<?PI1 zzz?><T/>" dummy-doctype-fn '(('"T"))) (test "<!DOCTYPE T SYSTEM 'system1' ><!-- comment -->%n<T/>" (lambda (elem-gi seed) (assert (equal? elem-gi ''"T")) (values #f '() '() seed)) '(('"T"))) (test "<!DOCTYPE T PUBLIC '//EN/T' \"system1\" [ <!ELEMENT a 'aa'> ]>%n<?pi?><T/>" (lambda (elem-gi seed) (assert (equal? elem-gi ''"T")) (values #f '() '() seed)) '(('"T"))) (test "<BR/>" (lambda (elem-gi seed) (values '(('"BR" EMPTY ())) '() '() seed)) '(('"BR"))) (test "<BR></BR>" (lambda (elem-gi seed) (values '(('"BR" EMPTY ())) '() '() seed)) '(('"BR"))) (assert (failed? (test "<BR>aa</BR>" (lambda (elem-gi seed) (values '(('"BR" EMPTY ())) '() '() seed)) '()))) (test "<BR>aa</BR>" (lambda (elem-gi seed) (values '(('"BR" PCDATA ())) '() '() seed)) '(('"BR" "aa"))) (assert (failed? (test "<BR>a<I>a</I></BR>" (lambda (elem-gi seed) (values '(('"BR" PCDATA ())) '() '() seed)) '()))) (test "<BR>a<I>a</I></BR>" (lambda (elem-gi seed) (values '(('"BR" ANY ()) ('"I" PCDATA ())) '() '() seed)) '(('"BR" "a" ('"I" "a")))) (test "<DIV>Example: \"&example;\"</DIV>" (lambda (elem-gi seed) (values #f '((example . "<P>An ampersand (&) may be escaped numerically (&#38;) or with a general entity (&amp;).</P>")) '() seed)) '(('"DIV" "Example: \"" ('"P" "An ampersand (" "&" ") may be escaped numerically (" "&" "#38;) or with a general entity (" "&" "amp;).") "\""))) (test "<DIV>Example: \"&example;\" <P/></DIV>" (lambda (elem-gi seed) (values #f '(('"quote" . "<I>example:</I> ex") ('"example" . "<Q>"e;!</Q>?")) '() seed)) '(('"DIV" "Example: \"" ('"Q" ('"I" "example:") " ex" "!") "?" "\" " ('"P")))) (assert (failed? (test "<DIV>Example: \"&example;\" <P/></DIV>" (lambda (elem-gi seed) (values #f '(('"quote" . "<I>example:") ('"example" . "<Q>"e;</I>!</Q>?")) '() seed)) '()))) (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" (lambda (elem-gi seed) (values #f '() '() seed)) '((('"URI1" . '"DIV") (@ ('"B" "B") (('"URI1" . '"B") "A")) (*NAMESPACES* (('"A" '"URI1" . '"URI1") (*DEFAULT* '"URI1" . '"URI1"))) (('"URI1" . '"P") (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"URI1" . '"URI1") (*DEFAULT* '"URI1" . '"URI1"))) ('"BR" (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"URI1" . '"URI1") (*DEFAULT* '"URI1" . '"URI1")))))))) (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" (lambda (elem-gi seed) (values #f '() '((#f '"UA" . '"URI1")) seed)) '((('"UA" . '"DIV") (@ ('"B" "B") (('"UA" . '"B") "A")) (*NAMESPACES* (('"A" '"UA" . '"URI1") (*DEFAULT* '"UA" . '"URI1") (#f '"UA" . '"URI1"))) (('"UA" . '"P") (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"UA" . '"URI1") (*DEFAULT* '"UA" . '"URI1") (#f '"UA" . '"URI1"))) ('"BR" (*NAMESPACES* ((*DEFAULT* #f . #f) ('"A" '"UA" . '"URI1") (*DEFAULT* '"UA" . '"URI1") (#f '"UA" . '"URI1")))))))) ; uniqattr should fail (assert (failed? (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" (lambda (elem-gi seed) (values `(('"DIV" ANY (('"B" CDATA IMPLIED #f) (('"A" . '"B") CDATA IMPLIED #f) (('"C" . '"B") CDATA IMPLIED "xx") (('"xmlns" . '"C") CDATA IMPLIED "URI1") )) (('"A" . '"P") ANY ()) ('"BR" '"EMPTY" ())) '() '((#f '"UA" . '"URI1")) seed)) '()))) ; prefix C undeclared (assert (failed? (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" (lambda (elem-gi seed) (values '(('"DIV" ANY (('"B" CDATA IMPLIED #f) ('"xmlns" CDATA IMPLIED "URI1") (('"A" . '"B") CDATA IMPLIED #f) (('"C" . '"B") CDATA IMPLIED "xx") )) (('"A" . '"P") ANY ()) ('"BR" EMPTY ())) '() '((#f '"UA" . '"URI1")) seed)) '()))) ; contradiction to xmlns declaration (assert (failed? (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" (lambda (elem-gi seed) (values '(('"DIV" ANY (('"B" CDATA IMPLIED #f) ('"xmlns" CDATA FIXED "URI2") (('"A" . '"B") CDATA IMPLIED #f) )) (('"A" . '"P") ANY ()) ('"BR" EMPTY ())) '() '((#f '"UA" . '"URI1")) seed)) '()))) (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" (lambda (elem-gi seed) (values '(('"DIV" ANY (('"B" CDATA IMPLIED #f) ('"xmlns" CDATA FIXED "URI1") (('"A" . '"B") CDATA IMPLIED #f) )) (('"A" . '"P") ANY ()) ('"BR" EMPTY ())) '() '((#f '"UA" . '"URI1")) seed)) '((('"UA" . '"DIV") (@ ('"B" "B") (('"UA" . '"B") "A")) (*NAMESPACES* ((*DEFAULT* '"UA" . '"URI1") ('"A" '"UA" . '"URI1") (#f '"UA" . '"URI1"))) (('"UA" . '"P") (*NAMESPACES* ((*DEFAULT* #f . #f) (*DEFAULT* '"UA" . '"URI1") ('"A" '"UA" . '"URI1") (#f '"UA" . '"URI1"))) ('"BR" (*NAMESPACES* ((*DEFAULT* #f . #f) (*DEFAULT* '"UA" . '"URI1") ('"A" '"UA" . '"URI1") (#f '"UA" . '"URI1")))))))) (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" (lambda (elem-gi seed) (values '(('"DIV" ANY (('"B" CDATA IMPLIED #f) (('"A" . '"B") CDATA IMPLIED #f) (('"C" . '"B") CDATA IMPLIED "xx") (('"xmlns" . '"C") CDATA IMPLIED "URI2") )) (('"A" . '"P") ANY ()) ('"BR" EMPTY ())) '() '((#f '"UA" . '"URI1")) seed)) '((('"UA" . '"DIV") (@ ('"B" "B") (('"UA" . '"B") "A") (('"URI2" . '"B") "xx")) (*NAMESPACES* ((*DEFAULT* '"UA" . '"URI1") ('"A" '"UA" . '"URI1") ('"C" '"URI2" . '"URI2") (#f '"UA" . '"URI1"))) (('"UA" . '"P") (*NAMESPACES* ((*DEFAULT* #f . #f) (*DEFAULT* '"UA" . '"URI1") ('"A" '"UA" . '"URI1") ('"C" '"URI2" . '"URI2") (#f '"UA" . '"URI1"))) ('"BR" (*NAMESPACES* ((*DEFAULT* #f . #f) (*DEFAULT* '"UA" . '"URI1") ('"A" '"UA" . '"URI1") ('"C" '"URI2" . '"URI2") (#f '"UA" . '"URI1")))))))) )) ;======================================================================== ; Highest-level parsers: XML to SXML ; ; First, a few utility procedures that turned out useful ; ssax:reverse-collect-str LIST-OF-FRAGS -> LIST-OF-FRAGS ; given the list of fragments (some of which are text strings) ; reverse the list and concatenate adjacent text strings. ; We can prove from the general case below that if LIST-OF-FRAGS ; has zero or one element, the result of the procedure is equal? ; to its argument. This fact justifies the shortcut evaluation below. (define (ssax:reverse-collect-str fragments) (cond ((null? fragments) '()) ; a shortcut ((null? (cdr fragments)) fragments) ; see the comment above (else (let loop ((fragments fragments) (result '()) (strs '())) (cond ((null? fragments) (if (null? strs) result (cons (string-concatenate/shared strs) result))) ((string? (car fragments)) (loop (cdr fragments) result (cons (car fragments) strs))) (else (loop (cdr fragments) (cons (car fragments) (if (null? strs) result (cons (string-concatenate/shared strs) result))) '()))))))) ; ssax:reverse-collect-str-drop-ws LIST-OF-FRAGS -> LIST-OF-FRAGS ; given the list of fragments (some of which are text strings) ; reverse the list and concatenate adjacent text strings. ; We also drop "unsignificant" whitespace, that is, whitespace ; in front, behind and between elements. The whitespace that ; is included in character data is not affected. ; We use this procedure to "intelligently" drop "insignificant" ; whitespace in the parsed SXML. If the strict compliance with ; the XML Recommendation regarding the whitespace is desired, please ; use the ssax:reverse-collect-str procedure instead. (define (ssax:reverse-collect-str-drop-ws fragments) (cond ((null? fragments) '()) ; a shortcut ((null? (cdr fragments)) ; another shortcut (if (and (string? (car fragments)) (string-whitespace? (car fragments))) '() fragments)) ; remove trailing ws (else (let loop ((fragments fragments) (result '()) (strs '()) (all-whitespace? #t)) (cond ((null? fragments) (if all-whitespace? result ; remove leading ws (cons (string-concatenate/shared strs) result))) ((string? (car fragments)) (loop (cdr fragments) result (cons (car fragments) strs) (and all-whitespace? (string-whitespace? (car fragments))))) (else (loop (cdr fragments) (cons (car fragments) (if all-whitespace? result (cons (string-concatenate/shared strs) result))) '() #t))))))) ; procedure: ssax:xml->sxml PORT NAMESPACE-PREFIX-ASSIG ; ; This is an instance of a SSAX parser above that returns an SXML ; representation of the XML document to be read from PORT. ; NAMESPACE-PREFIX-ASSIG is a list of (USER-PREFIX . URI-STRING) ; that assigns USER-PREFIXes to certain namespaces identified by ; particular URI-STRINGs. It may be an empty list. ; The procedure returns an SXML tree. The port points out to the ; first character after the root element. (define (ssax:xml->sxml port namespace-prefix-assig) (letrec ((namespaces (map (lambda (el) (cons* #f (car el) (ssax:uri-string->symbol (cdr el)))) namespace-prefix-assig)) (RES-NAME->SXML (lambda (res-name) (string->symbol (string-append (symbol->string (car res-name)) ":" (symbol->string (cdr res-name)))))) ) (let ((result (reverse ((ssax:make-parser NEW-LEVEL-SEED (lambda (elem-gi attributes namespaces expected-content seed) '()) FINISH-ELEMENT (lambda (elem-gi attributes namespaces parent-seed seed) (let ((seed (ssax:reverse-collect-str seed)) (attrs (attlist-fold (lambda (attr accum) (cons (list (if (symbol? (car attr)) (car attr) (RES-NAME->SXML (car attr))) (cdr attr)) accum)) '() attributes))) (cons (cons (if (symbol? elem-gi) elem-gi (RES-NAME->SXML elem-gi)) (if (null? attrs) seed (cons (cons '@ attrs) seed))) parent-seed))) CHAR-DATA-HANDLER (lambda (string1 string2 seed) (if (string-null? string2) (cons string1 seed) (cons* string2 string1 seed))) DOCTYPE (lambda (port docname systemid internal-subset? seed) (when internal-subset? (ssax:warn port "Internal DTD subset is not currently handled ") (ssax:skip-internal-dtd port)) (ssax:warn port "DOCTYPE DECL " docname " " systemid " found and skipped") (values #f '() namespaces seed)) UNDECL-ROOT (lambda (elem-gi seed) (values #f '() namespaces seed)) PI ((*DEFAULT* . (lambda (port pi-tag seed) (cons (list '*PI* pi-tag (ssax:read-pi-body-as-string port)) seed)))) ) port '())))) (cons '*TOP* (if (null? namespace-prefix-assig) result (cons (list '@ (cons '*NAMESPACES* (map (lambda (ns) (list (car ns) (cdr ns))) namespace-prefix-assig))) result))) ))) ; For backwards compatibility (define SSAX:XML->SXML ssax:xml->sxml) ; a few lines of validation code (run-test (letrec ((test (lambda (str namespace-assig expected-res) (newline) (display "input: ") (write (unesc-string str)) (newline) (display "Result: ") (let ((result (call-with-input-string (unesc-string str) (lambda (port) (ssax:xml->sxml port namespace-assig))))) (pp result) (assert (equal_? result expected-res)))))) (test " <BR/>" '() '(*TOP* (BR))) (test "<BR></BR>" '() '(*TOP* (BR))) (test " <BR CLEAR='ALL'%nCLASS='Class1'/>" '() '(*TOP* (BR (@ (CLEAR "ALL") (CLASS "Class1"))))) (test " <A HREF='URL'> link <I>itlink </I> &amp;</A>" '() '(*TOP* (A (@ (HREF "URL")) " link " (I "itlink ") " &"))) (test " <A HREF='URL' xml:space='preserve'> link <I>itlink </I> &amp;</A>" '() '(*TOP* (A (@ (xml:space "preserve") (HREF "URL")) " link " (I "itlink ") " &"))) (test " <A HREF='URL' xml:space='preserve'> link <I xml:space='default'>itlink </I> &amp;</A>" '() '(*TOP* (A (@ (xml:space "preserve") (HREF "URL")) " link " (I (@ (xml:space "default")) "itlink ") " &"))) (test " <P><?pi1 p1 content ?>?<?pi2 pi2? content? ??></P>" '() '(*TOP* (P (*PI* pi1 "p1 content ") "?" (*PI* pi2 "pi2? content? ?")))) (test " <P>some text <![CDATA[<]]>1%n"<B>strong</B>"%r</P>" '() `(*TOP* (P ,(unesc-string "some text <1%n\"") (B "strong") ,(unesc-string "\"%n")))) (test " <P><![CDATA[<BR>%n<![CDATA[<BR>]]>]]></P>" '() `(*TOP* (P ,(unesc-string "<BR>%n<![CDATA[<BR>]]>")))) ; (test "<T1><T2>it's%r%nand that%n</T2>%r%n%r%n%n</T1>" '() ; '(*TOP* (T1 (T2 "it's%nand that%n") "%n%n%n"))) (test "<T1><T2>it's%r%nand that%n</T2>%r%n%r%n%n</T1>" '() `(*TOP* (T1 (T2 ,(unesc-string "it's%nand that%n")) ,(unesc-string "%n%n%n")))) (test "<T1><T2>it's%rand that%n</T2>%r%n%r%n%n</T1>" '() `(*TOP* (T1 (T2 ,(unesc-string "it's%nand that%n")) ,(unesc-string "%n%n%n")))) (test "<!DOCTYPE T SYSTEM 'system1' ><!-- comment -->%n<T/>" '() '(*TOP* (T))) (test "<?xml version='1.0'?>%n<WEIGHT unit=\"pound\">%n<NET certified='certified'> 67 </NET>%n<GROSS> 95 </GROSS>%n</WEIGHT>" '() `(*TOP* (*PI* xml "version='1.0'") (WEIGHT (@ (unit "pound")) ,nl (NET (@ (certified "certified")) " 67 ") ,nl (GROSS " 95 ") ,nl) )) ; (test "<?xml version='1.0'?>%n<WEIGHT unit=\"pound\">%n<NET certified='certified'> 67 </NET>%n<GROSS> 95 </GROSS>%n</WEIGHT>" '() ; '(*TOP* (*PI* xml "version='1.0'") (WEIGHT (@ (unit "pound")) ; "%n" (NET (@ (certified "certified")) " 67 ") ; "%n" (GROSS " 95 ") "%n") ; )) (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" '() '(*TOP* (URI1:DIV (@ (URI1:B "A") (B "B")) (URI1:P (BR))))) (test "<DIV A:B='A' B='B' xmlns:A='URI1' xmlns='URI1'><A:P xmlns=''><BR/></A:P></DIV>" '((UA . "URI1")) '(*TOP* (@ (*NAMESPACES* (UA "URI1"))) (UA:DIV (@ (UA:B "A") (B "B")) (UA:P (BR))))) ; A few tests from XML Namespaces Recommendation (test (string-append "<x xmlns:edi='http://ecommerce.org/schema'>" "<!-- the 'taxClass' attribute's ns http://ecommerce.org/schema -->" "<lineItem edi:taxClass='exempt'>Baby food</lineItem>" nl "</x>") '() `(*TOP* (x (lineItem (@ (http://ecommerce.org/schema:taxClass "exempt")) "Baby food") ,nl))) (test (string-append "<x xmlns:edi='http://ecommerce.org/schema'>" "<!-- the 'taxClass' attribute's ns http://ecommerce.org/schema -->" "<lineItem edi:taxClass='exempt'>Baby food</lineItem>" "</x>") '((EDI . "http://ecommerce.org/schema")) '(*TOP* (@ (*NAMESPACES* (EDI "http://ecommerce.org/schema"))) (x (lineItem (@ (EDI:taxClass "exempt")) "Baby food")))) (test (string-append "<bk:book xmlns:bk='urn:loc.gov:books' " "xmlns:isbn='urn:ISBN:0-395-36341-6'>" "<bk:title>Cheaper by the Dozen</bk:title>" "<isbn:number>1568491379</isbn:number></bk:book>") '() '(*TOP* (urn:loc.gov:books:book (urn:loc.gov:books:title "Cheaper by the Dozen") (urn:ISBN:0-395-36341-6:number "1568491379")))) (test (string-append "<!-- initially, the default namespace is 'books' -->" "<book xmlns='urn:loc.gov:books' " "xmlns:isbn='urn:ISBN:0-395-36341-6'>" "<title>Cheaper by the Dozen" "1568491379" "" "" "

" "This is a funny book!" "

" "" "") '() '(*TOP* (urn:loc.gov:books:book (urn:loc.gov:books:title "Cheaper by the Dozen") (urn:ISBN:0-395-36341-6:number "1568491379") (urn:loc.gov:books:notes (urn:w3-org-ns:HTML:p "This is a " (urn:w3-org-ns:HTML:i "funny") " book!"))))) (test (string-append "" "" "" "" "" "" "" "" "" "" "
NameOriginDescription
HuntsmanBath, UK" "
BitterFuggles" "Wonderful hop, light alcohol, good summer beer" "Fragile; excessive variance pub to pub" "
" "
" "") '((html . "http://www.w3.org/TR/REC-html40")) '(*TOP* (@ (*NAMESPACES* (html "http://www.w3.org/TR/REC-html40"))) (Beers (html:table (html:th (html:td "Name") (html:td "Origin") (html:td "Description")) (html:tr (html:td (brandName "Huntsman")) (html:td (origin "Bath, UK")) (html:td (details (class "Bitter") (hop "Fuggles") (pro "Wonderful hop, light alcohol, good summer beer") (con "Fragile; excessive variance pub to pub")))))))) (test (string-append "" "Layman, A" "33B" "Check Status" "1997-05-24T07:55:00+1") '((HTML . "http://www.w3.org/TR/REC-html40")) '(*TOP* (@ (*NAMESPACES* (HTML "http://www.w3.org/TR/REC-html40"))) (RESERVATION (NAME (@ (HTML:CLASS "largeSansSerif")) "Layman, A") (SEAT (@ (HTML:CLASS "largeMonotype") (CLASS "Y")) "33B") (HTML:A (@ (HREF "/cgi-bin/ResStatus")) "Check Status") (DEPARTURE "1997-05-24T07:55:00+1")))) ; Part of RDF from the XML Infoset (test (string-concatenate/shared '( "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "")) '((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (RDFS . "http://www.w3.org/2000/01/rdf-schema#") (ISET . "http://www.w3.org/2001/02/infoset#")) '(*TOP* (@ (*NAMESPACES* (RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (RDFS "http://www.w3.org/2000/01/rdf-schema#") (ISET "http://www.w3.org/2001/02/infoset#"))) (*PI* xml "version='1.0' encoding='utf-8' standalone='yes'") (RDF:RDF (RDFS:Class (@ (ID "Boolean"))) (ISET:Boolean (@ (ID "Boolean.true"))) (ISET:Boolean (@ (ID "Boolean.false"))) (RDFS:Class (@ (ID "InfoItem"))) (RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Document"))) (RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Element"))) (RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Attribute"))) (RDFS:Class (@ (RDFS:subClassOf "http://www.w3.org/1999/02/22-rdf-syntax-ns#Bag") (ID "InfoItemSet"))) (RDFS:Class (@ (RDFS:subClassOf "#InfoItemSet") (ID "AttributeSet"))) (RDFS:Property (@ (ID "allDeclarationsProcessed")) (RDFS:domain (@ (resource "#Document"))) (RDFS:range (@ (resource "#Boolean")))) (RDFS:Property (@ (ID "attributes")) (RDFS:domain (@ (resource "#Element"))) (RDFS:range (@ (resource "#AttributeSet"))))))) ; Part of RDF from RSS of the Daemon News Mall (test (string-concatenate/shared (list-intersperse '( "" "" "Daemon News Mall" "http://mall.daemonnews.org/" "Central source for all your BSD needs" "" "" "Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95" "http://mall.daemonnews.org/?page=shop/flypage&product_id=880" "" "" "The Design and Implementation of the 4.4BSD Operating System $54.95" "http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761" "" "") (string #\newline) )) '((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (RSS . "http://my.netscape.com/rdf/simple/0.9/") (ISET . "http://www.w3.org/2001/02/infoset#")) `(*TOP* (@ (*NAMESPACES* (RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (RSS "http://my.netscape.com/rdf/simple/0.9/") (ISET "http://www.w3.org/2001/02/infoset#"))) (*PI* xml "version='1.0'") (RDF:RDF ,nl (RSS:channel ,nl (RSS:title "Daemon News Mall") ,nl (RSS:link "http://mall.daemonnews.org/") ,nl (RSS:description "Central source for all your BSD needs") ,nl) ,nl (RSS:item ,nl (RSS:title "Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95") ,nl (RSS:link "http://mall.daemonnews.org/?page=shop/flypage&product_id=880") ,nl) ,nl (RSS:item ,nl (RSS:title "The Design and Implementation of the 4.4BSD Operating System $54.95") ,nl (RSS:link "http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761") ,nl) ,nl))) (test (string-concatenate/shared '("" "" "111730Z 111818" "" "31010KT P6SM FEW030" "" "" "29016KT P6SM FEW040" "" "" "29010KT P6SM SCT200" "VRB05KT" "" "")) '() '(*TOP* (Forecasts (@ (TStamp "958082142")) (TAF (@ (TStamp "958066200") (SName "KMRY, MONTEREY PENINSULA") (LatLon "36.583, -121.850") (BId "724915")) (VALID (@ (TRange "958068000, 958154400")) "111730Z 111818") (PERIOD (@ (TRange "958068000, 958078800")) (PREVAILING "31010KT P6SM FEW030")) (PERIOD (@ (Title "FM2100") (TRange "958078800, 958104000")) (PREVAILING "29016KT P6SM FEW040")) (PERIOD (@ (Title "FM0400") (TRange "958104000, 958154400")) (PREVAILING "29010KT P6SM SCT200") (VAR (@ (Title "BECMG 0708") (TRange "958114800, 958118400")) "VRB05KT")))))) )) (run-test (newline) (display "All tests passed") (newline) ) guile-lib-0.2.1/src/sxml/upstream/SSAX-expanded.scm0000664000076400007640000102764711137322547017026 00000000000000(define _eqv?_7 eqv?) (define _cons_23 cons) (define _append_24 append) (define _list_25 list) (define _vector_26 vector) (define _list->vector_27 list->vector) (define make-xml-token (lambda (_kind_38 _head_39) (cons _kind_38 _head_39))) (define xml-token? pair?) (define ssax:warn (lambda (_port_38 _msg_39 . _other-msg_40) (apply cerr (cons* nl "Warning: " _msg_39 _other-msg_40)))) (define parser-error (lambda (_port_38 _msg_39 . _specializing-msgs_40) (apply error (cons _msg_39 _specializing-msgs_40)))) (define equal_? (lambda (_e1_38 _e2_39) (if (eq? (if (string? 'A) (string->symbol 'A) 'A) (string->symbol "A")) (equal? _e1_38 _e2_39) (if (symbol? _e1_38) (if (symbol? _e2_39) (string-ci=? (symbol->string _e1_38) (symbol->string _e2_39)) #f) (if (pair? _e1_38) (if (pair? _e2_39) (if (equal_? (car _e1_38) (car _e2_39)) (equal_? (cdr _e1_38) (cdr _e2_39)) #f) #f) (if (vector? _e1_38) (if (vector? _e2_39) (equal_? (vector->list _e1_38) (vector->list _e2_39)) #f) (equal? _e1_38 _e2_39))))))) (define unesc-string (lambda (_str_38) (call-with-input-string _str_38 (lambda (_port_45) ((letrec ((_loop_46 (lambda (_frags_47) ((lambda (_token_48) ((lambda (_cterm_49) ((lambda (_frags_50) (if (eof-object? _cterm_49) (string-concatenate-reverse/shared _frags_50) ((lambda (_cchar_51) (if (eof-object? _cchar_51) (error "unexpected EOF after reading % in unesc-string:" _str_38) (_loop_46 (cons ((lambda (_key_52) (if (if (_eqv?_7 _key_52 '#\n) #t #f) (string #\newline) (if (if (_eqv?_7 _key_52 '#\r) #t #f) (string char-return) (if (if (_eqv?_7 _key_52 '#\t) #t #f) (string char-tab) (if (if (_eqv?_7 _key_52 '#\%) #t #f) "%" (error "bad %-char in unesc-string:" _cchar_51)))))) _cchar_51) _frags_50)))) (read-char _port_45)))) (cons _token_48 _frags_47))) (read-char _port_45))) (next-token '() '(#\% *eof*) "unesc-string" _port_45))))) _loop_46) '()))))) (define string-whitespace? (lambda (_str_38) ((lambda (_len_39) (if (zero? _len_39) #t (if (= 1 _len_39) (char-whitespace? (string-ref _str_38 0)) (if (= 2 _len_39) (if (char-whitespace? (string-ref _str_38 0)) (char-whitespace? (string-ref _str_38 1)) #f) ((letrec ((_loop_40 (lambda (_i_41) ((lambda (_x_42) (if _x_42 _x_42 (if (char-whitespace? (string-ref _str_38 _i_41)) (_loop_40 (+ 1 _i_41)) #f))) (>= _i_41 _len_39))))) _loop_40) 0))))) (string-length _str_38)))) (define assq-values (lambda (_val_38 _alist_39) ((letrec ((_loop_40 (lambda (_alist_41 _scanned_42) (if (null? _alist_41) (values #f _scanned_42) (if (equal? _val_38 (caar _alist_41)) (values (car _alist_41) (append _scanned_42 (cdr _alist_41))) (_loop_40 (cdr _alist_41) (cons (car _alist_41) _scanned_42))))))) _loop_40) _alist_39 '()))) (define fold-right (lambda (_kons_38 _knil_39 _lis1_40) ((letrec ((_recur_41 (lambda (_lis_42) (if (null? _lis_42) _knil_39 ((lambda (_head_43) (_kons_38 _head_43 (_recur_41 (cdr _lis_42)))) (car _lis_42)))))) _recur_41) _lis1_40))) (define fold (lambda (_kons_38 _knil_39 _lis1_40) ((letrec ((_lp_41 (lambda (_lis_42 _ans_43) (if (null? _lis_42) _ans_43 (_lp_41 (cdr _lis_42) (_kons_38 (car _lis_42) _ans_43)))))) _lp_41) _lis1_40 _knil_39))) (define ssax:S-chars (map ascii->char '(32 10 9 13))) (define ssax:skip-S (lambda (_port_38) (skip-while ssax:S-chars _port_38))) (define ssax:ncname-starting-char? (lambda (_a-char_38) (if (char? _a-char_38) ((lambda (_x_39) (if _x_39 _x_39 (char=? #\_ _a-char_38))) (char-alphabetic? _a-char_38)) #f))) (define ssax:read-NCName (lambda (_port_38) (begin ((lambda (_first-char_39) ((lambda (_x_40) (if _x_40 _x_40 (parser-error _port_38 "XMLNS [4] for '" _first-char_39 "'"))) (ssax:ncname-starting-char? _first-char_39))) (peek-char _port_38)) (string->symbol (next-token-of (lambda (_c_39) (if (eof-object? _c_39) #f (if (char-alphabetic? _c_39) _c_39 (if (string-index "0123456789.-_" _c_39) _c_39 #f)))) _port_38))))) (define ssax:read-QName (lambda (_port_38) ((lambda (_prefix-or-localpart_39) ((lambda (_key_40) (if (if (_eqv?_7 _key_40 '#\:) #t #f) (begin (read-char _port_38) (cons _prefix-or-localpart_39 (ssax:read-NCName _port_38))) _prefix-or-localpart_39)) (peek-char _port_38))) (ssax:read-NCName _port_38)))) (define ssax:Prefix-XML (string->symbol "xml")) (assert (eq? (if (string? '_) (string->symbol '_) '_) (call-with-input-string "_" ssax:read-NCName))) (assert (eq? (if (string? '_) (string->symbol '_) '_) (call-with-input-string "_" ssax:read-QName))) (assert (eq? (string->symbol "_abc_") (call-with-input-string "_abc_;" ssax:read-NCName))) (assert (eq? (string->symbol "_abc_") (call-with-input-string "_abc_;" ssax:read-QName))) (assert (eq? (string->symbol "_a.b") (call-with-input-string "_a.b " ssax:read-QName))) (assert (equal? (cons (string->symbol "_a.b") (string->symbol "d.1-ef-")) (call-with-input-string "_a.b:d.1-ef-;" ssax:read-QName))) (assert (equal? (cons (string->symbol "a") (string->symbol "b")) (call-with-input-string "a:b:c" ssax:read-QName))) (assert (failed? (call-with-input-string ":abc" ssax:read-NCName))) (assert (failed? (call-with-input-string "1:bc" ssax:read-NCName))) (define name-compare (letrec ((_symbol-compare_38 (lambda (_symb1_39 _symb2_40) (if (eq? _symb1_39 _symb2_40) '= (if (stringstring _symb1_39) (symbol->string _symb2_40)) '< '>))))) (lambda (_name1_39 _name2_40) (if (symbol? _name1_39) (if (symbol? _name2_40) (_symbol-compare_38 _name1_39 _name2_40) '<) (if (symbol? _name2_40) '> (if (eq? _name2_40 ssax:largest-unres-name) '< (if (eq? _name1_39 ssax:largest-unres-name) '> (if (eq? (car _name1_39) (car _name2_40)) (_symbol-compare_38 (cdr _name1_39) (cdr _name2_40)) (_symbol-compare_38 (car _name1_39) (car _name2_40)))))))))) (define ssax:largest-unres-name (cons (string->symbol "#LARGEST-SYMBOL") (string->symbol "#LARGEST-SYMBOL"))) (assert (eq? (if (string? '=) (string->symbol '=) '=) (name-compare (if (string? 'ABC) (string->symbol 'ABC) 'ABC) (if (string? 'ABC) (string->symbol 'ABC) 'ABC)))) (assert (eq? (if (string? '<) (string->symbol '<) '<) (name-compare (if (string? 'ABC) (string->symbol 'ABC) 'ABC) (if (string? 'ABCD) (string->symbol 'ABCD) 'ABCD)))) (assert (eq? (if (string? '>) (string->symbol '>) '>) (name-compare (if (string? 'XB) (string->symbol 'XB) 'XB) (if (string? 'ABCD) (string->symbol 'ABCD) 'ABCD)))) (assert (eq? (if (string? '>) (string->symbol '>) '>) (name-compare '(HTML . PRE) (if (string? 'PRE) (string->symbol 'PRE) 'PRE)))) (assert (eq? (if (string? '<) (string->symbol '<) '<) (name-compare (if (string? 'HTML) (string->symbol 'HTML) 'HTML) '(HTML . PRE)))) (assert (eq? (if (string? '=) (string->symbol '=) '=) (name-compare '(HTML . PRE) '(HTML . PRE)))) (assert (eq? (if (string? '<) (string->symbol '<) '<) (name-compare '(HTML . PRE) '(XML . PRE)))) (assert (eq? (if (string? '>) (string->symbol '>) '>) (name-compare '(HTML . PRE) '(HTML . P)))) (assert (eq? (if (string? '<) (string->symbol '<) '<) (name-compare '(HTML . PRE) ssax:largest-unres-name))) (assert (eq? (if (string? '<) (string->symbol '<) '<) (name-compare '(ZZZZ . ZZZ) ssax:largest-unres-name))) (assert (eq? (if (string? '>) (string->symbol '>) '>) (name-compare ssax:largest-unres-name '(ZZZZ . ZZZ)))) (define ssax:read-markup-token (letrec ((_read-cdata_38 (lambda (_port_40) (begin (assert (string=? "CDATA[" (read-string 6 _port_40))) (make-xml-token 'CDSECT #f)))) (_skip-comment_39 (lambda (_port_40) (begin (assert-curr-char '(#\-) "XML [15], second dash" _port_40) (if (not (find-string-from-port? "-->" _port_40)) (parser-error _port_40 "XML [15], no -->")) (make-xml-token 'COMMENT #f))))) (lambda (_port_40) (begin (assert-curr-char '(#\<) "start of the token" _port_40) ((lambda (_key_41) (if (if (_eqv?_7 _key_41 '#\/) #t #f) (begin (read-char _port_40) ((lambda (_val_42) (begin (ssax:skip-S _port_40) (assert-curr-char '(#\>) "XML [42]" _port_40) _val_42)) (make-xml-token 'END (ssax:read-QName _port_40)))) (if (if (_eqv?_7 _key_41 '#\?) #t #f) (begin (read-char _port_40) (make-xml-token 'PI (ssax:read-NCName _port_40))) (if (if (_eqv?_7 _key_41 '#\!) #t #f) ((lambda (_key_42) (if (if (_eqv?_7 _key_42 '#\-) #t #f) (begin (read-char _port_40) (_skip-comment_39 _port_40)) (if (if (_eqv?_7 _key_42 '#\[) #t #f) (begin (read-char _port_40) (_read-cdata_38 _port_40)) (make-xml-token 'DECL (ssax:read-NCName _port_40))))) (peek-next-char _port_40)) (make-xml-token 'START (ssax:read-QName _port_40)))))) (peek-char _port_40)))))) (define ssax:skip-pi (lambda (_port_38) (if (not (find-string-from-port? "?>" _port_38)) (parser-error _port_38 "Failed to find ?> terminating the PI")))) (define ssax:read-pi-body-as-string (lambda (_port_38) (begin (ssax:skip-S _port_38) (string-concatenate/shared ((letrec ((_loop_39 (lambda () ((lambda (_pi-fragment_40) (if (eqv? #\> (peek-next-char _port_38)) (begin (read-char _port_38) (cons _pi-fragment_40 '())) (cons* _pi-fragment_40 "?" (_loop_39)))) (next-token '() '(#\?) "reading PI content" _port_38))))) _loop_39)))))) (assert (equal? "p1 content " (call-with-input-string "" (lambda (_port_44) (begin (ssax:read-markup-token _port_44) (ssax:read-pi-body-as-string _port_44)))))) (assert (equal? "pi2? content? ?" (call-with-input-string "" (lambda (_port_44) (begin (ssax:read-markup-token _port_44) (ssax:read-pi-body-as-string _port_44)))))) (define ssax:skip-internal-dtd (lambda (_port_38) (if (not (find-string-from-port? "]>" _port_38)) (parser-error _port_38 "Failed to find ]> terminating the internal DTD subset")))) (define ssax:read-cdata-body ((lambda (_cdata-delimiters_38) (lambda (_port_39 _str-handler_40 _seed_41) ((letrec ((_loop_42 (lambda (_seed_43) ((lambda (_fragment_44) ((lambda (_key_45) (if (if (_eqv?_7 _key_45 '#\newline) #t #f) (_loop_42 (_str-handler_40 _fragment_44 nl _seed_43)) (if (if (_eqv?_7 _key_45 '#\]) #t #f) (if (not (eqv? (peek-char _port_39) #\])) (_loop_42 (_str-handler_40 _fragment_44 "]" _seed_43)) ((letrec ((_check-after-second-braket_46 (lambda (_seed_47) ((lambda (_key_48) (if (if (_eqv?_7 _key_48 '#\>) #t #f) (begin (read-char _port_39) _seed_47) (if (if (_eqv?_7 _key_48 '#\]) #t #f) (_check-after-second-braket_46 (_str-handler_40 "]" "" _seed_47)) (_loop_42 (_str-handler_40 "]]" "" _seed_47))))) (peek-next-char _port_39))))) _check-after-second-braket_46) (if (zero? (string-length _fragment_44)) _seed_43 (_str-handler_40 _fragment_44 "" _seed_43)))) (if (if (_eqv?_7 _key_45 '#\&) #t #f) ((lambda (_ent-ref_46) (if (if (string=? "gt" _ent-ref_46) (eqv? (peek-char _port_39) #\;) #f) (begin (read-char _port_39) (_loop_42 (_str-handler_40 _fragment_44 ">" _seed_43))) (_loop_42 (_str-handler_40 _ent-ref_46 "" (_str-handler_40 _fragment_44 "&" _seed_43))))) (next-token-of (lambda (_c_46) (if (not (eof-object? _c_46)) (if (char-alphabetic? _c_46) _c_46 #f) #f)) _port_39)) (begin (if (eqv? (peek-char _port_39) #\newline) (read-char _port_39)) (_loop_42 (_str-handler_40 _fragment_44 nl _seed_43))))))) (read-char _port_39))) (next-token '() _cdata-delimiters_38 "reading CDATA" _port_39))))) _loop_42) _seed_41))) (list char-return #\newline #\] #\&))) (letrec ((_test_44 (lambda (_str_46 _expected-result_47) (begin (newline) (display "body: ") (write _str_46) (newline) (display "Result: ") ((lambda (_result_48) (begin (write _result_48) (assert (equal? _result_48 _expected-result_47)))) (reverse (call-with-input-string (unesc-string _str_46) (lambda (_port_48) (ssax:read-cdata-body _port_48 _consumer_45 '())))))))) (_consumer_45 (lambda (_fragment_46 _foll-fragment_47 _seed_48) (cons* (if (equal? _foll-fragment_47 (string #\newline)) " NL" _foll-fragment_47) _fragment_46 _seed_48)))) (begin (_test_44 "]]>" '()) (_test_44 "abcd]]>" '("abcd" "")) (_test_44 "abcd]]]>" '("abcd" "" "]" "")) (_test_44 "abcd]]]]>" '("abcd" "" "]" "" "]" "")) (_test_44 "abcd]]]]]>" '("abcd" "" "]" "" "]" "" "]" "")) (_test_44 "abcd]]]a]]>" '("abcd" "" "]" "" "]]" "" "a" "")) (_test_44 "abc%r%ndef%n]]>" '("abc" " NL" "def" " NL")) (_test_44 "%r%n%r%n]]>" '("" " NL" "" " NL")) (_test_44 "%r%n%r%na]]>" '("" " NL" "" " NL" "a" "")) (_test_44 "%r%r%r%na]]>" '("" " NL" "" " NL" "" " NL" "a" "")) (_test_44 "abc&!!!]]>" '("abc" "&" "" "" "!!!" "")) (_test_44 "abc]]>>&]]]>and]]>" '("abc" "" "]]" "" "" ">" "" "&" "gt" "" "" "&" "amp" "" ";" "" "]" "" "]]" "" "" ">" "and" "")))) (define ssax:read-char-ref (lambda (_port_38) ((lambda (_base_39) ((lambda (_name_40) ((lambda (_char-code_41) (begin (read-char _port_38) (if (integer? _char-code_41) (ucscode->string _char-code_41) (parser-error _port_38 "[wf-Legalchar] broken for '" _name_40 "'")))) (string->number _name_40 _base_39))) (next-token '() '(#\;) "XML [66]" _port_38))) (if (eqv? (peek-char _port_38) #\x) (begin (read-char _port_38) 16) 10)))) (define ssax:predefined-parsed-entities (_list_25 (_cons_23 (string->symbol "amp") '"&") (_cons_23 (string->symbol "lt") '"<") (_cons_23 (string->symbol "gt") '">") (_cons_23 (string->symbol "apos") '"'") (_cons_23 (string->symbol "quot") '"\""))) (define ssax:handle-parsed-entity (lambda (_port_38 _name_39 _entities_40 _content-handler_41 _str-handler_42 _seed_43) ((lambda (_tmp_44) (if _tmp_44 ((lambda (_decl-entity_45) ((lambda (_ent-body_46 _new-entities_47) (if (string? _ent-body_46) (call-with-input-string _ent-body_46 (lambda (_port_48) (_content-handler_41 _port_48 _new-entities_47 _seed_43))) (if (procedure? _ent-body_46) ((lambda (_port_48) ((lambda (_val_49) (begin (close-input-port _port_48) _val_49)) (_content-handler_41 _port_48 _new-entities_47 _seed_43))) (_ent-body_46)) (parser-error _port_38 "[norecursion] broken for " _name_39)))) (cdr _decl-entity_45) (cons (cons _name_39 #f) _entities_40))) _tmp_44) ((lambda (_tmp_45) (if _tmp_45 ((lambda (_decl-entity_46) (_str-handler_42 (cdr _decl-entity_46) "" _seed_43)) _tmp_45) (parser-error _port_38 "[wf-entdeclared] broken for " _name_39))) (assq _name_39 ssax:predefined-parsed-entities)))) (assq _name_39 _entities_40)))) (define make-empty-attlist (lambda () '())) (define attlist-add (lambda (_attlist_38 _name-value_39) (if (null? _attlist_38) (cons _name-value_39 _attlist_38) ((lambda (_key_40) (if (if (_eqv?_7 _key_40 '=) #t #f) #f (if (if (_eqv?_7 _key_40 '<) #t #f) (cons _name-value_39 _attlist_38) (cons (car _attlist_38) (attlist-add (cdr _attlist_38) _name-value_39))))) (name-compare (car _name-value_39) (caar _attlist_38)))))) (define attlist-null? null?) (define attlist-remove-top (lambda (_attlist_38) (values (car _attlist_38) (cdr _attlist_38)))) (define attlist->alist (lambda (_attlist_38) _attlist_38)) (define attlist-fold fold) (define ssax:read-attributes ((lambda (_value-delimeters_38) (letrec ((_read-named-entity_39 (lambda (_port_41 _entities_42 _fragments_43) ((lambda (_name_44) (begin (assert-curr-char '(#\;) "XML [68]" _port_41) (ssax:handle-parsed-entity _port_41 _name_44 _entities_42 (lambda (_port_45 _entities_46 _fragments_47) (_read-attrib-value_40 '*eof* _port_45 _entities_46 _fragments_47)) (lambda (_str1_45 _str2_46 _fragments_47) (if (equal? "" _str2_46) (cons _str1_45 _fragments_47) (cons* _str2_46 _str1_45 _fragments_47))) _fragments_43))) (ssax:read-NCName _port_41)))) (_read-attrib-value_40 (lambda (_delimiter_41 _port_42 _entities_43 _prev-fragments_44) ((lambda (_new-fragments_45) ((lambda (_cterm_46) (if ((lambda (_x_47) (if _x_47 _x_47 (eqv? _cterm_46 _delimiter_41))) (eof-object? _cterm_46)) _new-fragments_45 (if (eqv? _cterm_46 char-return) (begin (if (eqv? (peek-char _port_42) #\newline) (read-char _port_42)) (_read-attrib-value_40 _delimiter_41 _port_42 _entities_43 (cons " " _new-fragments_45))) (if (memv _cterm_46 ssax:S-chars) (_read-attrib-value_40 _delimiter_41 _port_42 _entities_43 (cons " " _new-fragments_45)) (if (eqv? _cterm_46 #\&) (if (eqv? (peek-char _port_42) #\#) (begin (read-char _port_42) (_read-attrib-value_40 _delimiter_41 _port_42 _entities_43 (cons (ssax:read-char-ref _port_42) _new-fragments_45))) (_read-attrib-value_40 _delimiter_41 _port_42 _entities_43 (_read-named-entity_39 _port_42 _entities_43 _new-fragments_45))) (parser-error _port_42 "[CleanAttrVals] broken")))))) (read-char _port_42))) (cons (next-token '() (cons _delimiter_41 _value-delimeters_38) "XML [10]" _port_42) _prev-fragments_44))))) (lambda (_port_41 _entities_42) ((letrec ((_loop_43 (lambda (_attr-list_44) (if (not (ssax:ncname-starting-char? (ssax:skip-S _port_41))) _attr-list_44 ((lambda (_name_45) (begin (ssax:skip-S _port_41) (assert-curr-char '(#\=) "XML [25]" _port_41) (ssax:skip-S _port_41) ((lambda (_delimiter_46) (_loop_43 ((lambda (_x_47) (if _x_47 _x_47 (parser-error _port_41 "[uniqattspec] broken for " _name_45))) (attlist-add _attr-list_44 (cons _name_45 (string-concatenate-reverse/shared (_read-attrib-value_40 _delimiter_46 _port_41 _entities_42 '()))))))) (assert-curr-char '(#\' #\") "XML [10]" _port_41)))) (ssax:read-QName _port_41)))))) _loop_43) (make-empty-attlist))))) (append ssax:S-chars '(#\< #\&)))) (letrec ((_test_44 (lambda (_str_45 _decl-entities_46 _expected-res_47) (begin (newline) (display "input: ") (write _str_45) (newline) (display "Result: ") ((lambda (_result_48) (begin (write _result_48) (newline) (assert (equal? _result_48 _expected-res_47)))) (call-with-input-string (unesc-string _str_45) (lambda (_port_48) (ssax:read-attributes _port_48 _decl-entities_46)))))))) (begin (_test_44 "" '() '()) (_test_44 "href='http://a%tb%r%n%r%n%nc'" '() (_list_25 (_cons_23 (string->symbol "href") '"http://a b c"))) (_test_44 "href='http://a%tb%r%r%n%rc'" '() (_list_25 (_cons_23 (string->symbol "href") '"http://a b c"))) (_test_44 "_1 ='12&' _2= \"%r%n%t12 3\">" '() (_list_25 '(_1 . "12&") (_cons_23 '_2 (unesc-string " 12%n3")))) (_test_44 "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<xx>")) (_list_25 (_cons_23 (string->symbol "Abc") (unesc-string "<&>%n")) (_cons_23 (string->symbol "Next") '"1234"))) (_test_44 "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<xx>")) (_list_25 (_cons_23 (string->symbol "Abc") (unesc-string "<&>%r")) (_cons_23 (string->symbol "Next") '"1234"))) (_test_44 "%tAbc='<&> '%nNext='12&en;34' />" (_list_25 (_cons_23 'en (lambda () (open-input-string ""xx'")))) (_list_25 (_cons_23 (string->symbol "Abc") (unesc-string "<&>%n")) (_cons_23 (string->symbol "Next") '"12\"xx'34"))) (_test_44 "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<&ent1;T;>") (ent1 . "&")) (_list_25 (_cons_23 (string->symbol "Abc") (unesc-string "<&>%n")) (_cons_23 (string->symbol "Next") '"12<&T;>34"))) (assert (failed? (_test_44 "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<&ent1;T;>") (ent1 . "&")) '()))) (assert (failed? (_test_44 "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<&ent;T;>") (ent1 . "&")) '()))) (assert (failed? (_test_44 "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<&ent1;T;>") (ent1 . "&ent;")) '()))) (_test_44 "html:href='http://a%tb%r%n%r%n%nc'" '() (_list_25 (_cons_23 (_cons_23 (string->symbol "html") (string->symbol "href")) '"http://a b c"))) (_test_44 "html:href='ref1' html:src='ref2'" '() (_list_25 (_cons_23 (_cons_23 (string->symbol "html") (string->symbol "href")) '"ref1") (_cons_23 (_cons_23 (string->symbol "html") (string->symbol "src")) '"ref2"))) (_test_44 "html:href='ref1' xml:html='ref2'" '() (_list_25 (_cons_23 (_cons_23 (string->symbol "html") (string->symbol "href")) '"ref1") (_cons_23 (_cons_23 ssax:Prefix-XML (string->symbol "html")) '"ref2"))) (assert (failed? (_test_44 "html:href='ref1' html:href='ref2'" '() '()))) (assert (failed? (_test_44 "html:href='<' html:href='ref2'" '() '()))) (assert (failed? (_test_44 "html:href='ref1' html:href='&ref2;'" '() '()))))) (define ssax:resolve-name (lambda (_port_38 _unres-name_39 _namespaces_40 _apply-default-ns?_41) (if (pair? _unres-name_39) (cons ((lambda (_tmp_42) (if _tmp_42 (cadr _tmp_42) (if (eq? (car _unres-name_39) ssax:Prefix-XML) ssax:Prefix-XML (parser-error _port_38 "[nsc-NSDeclared] broken; prefix " (car _unres-name_39))))) (assq (car _unres-name_39) _namespaces_40)) (cdr _unres-name_39)) (if _apply-default-ns?_41 ((lambda (_default-ns_42) (if (if _default-ns_42 (cadr _default-ns_42) #f) (cons (cadr _default-ns_42) _unres-name_39) _unres-name_39)) (assq '*DEFAULT* _namespaces_40)) _unres-name_39)))) ((lambda (_namespaces_44) ((lambda (_namespaces-def_45) ((lambda (_namespaces-undef_46) ((lambda (_port_47) (begin (assert (equal? (if (string? 'ABC) (string->symbol 'ABC) 'ABC) (ssax:resolve-name _port_47 (if (string? 'ABC) (string->symbol 'ABC) 'ABC) _namespaces_44 #t))) (assert (equal? '(DEF . ABC) (ssax:resolve-name _port_47 (if (string? 'ABC) (string->symbol 'ABC) 'ABC) _namespaces-def_45 #t))) (assert (equal? (if (string? 'ABC) (string->symbol 'ABC) 'ABC) (ssax:resolve-name _port_47 (if (string? 'ABC) (string->symbol 'ABC) 'ABC) _namespaces-def_45 #f))) (assert (equal? (if (string? 'ABC) (string->symbol 'ABC) 'ABC) (ssax:resolve-name _port_47 (if (string? 'ABC) (string->symbol 'ABC) 'ABC) _namespaces-undef_46 #t))) (assert (equal? '(UHTML . ABC) (ssax:resolve-name _port_47 '(HTML . ABC) _namespaces-def_45 #t))) (assert (equal? '(UHTML . ABC) (ssax:resolve-name _port_47 '(HTML . ABC) _namespaces-def_45 #f))) (assert (equal? (_cons_23 ssax:Prefix-XML 'space) (ssax:resolve-name _port_47 (_cons_23 (string->symbol "xml") 'space) _namespaces-def_45 #f))) (assert (failed? (ssax:resolve-name _port_47 '(XXX . ABC) _namespaces-def_45 #f))))) (current-input-port))) (cons '(*DEFAULT* #f . #f) _namespaces-def_45))) (cons '(*DEFAULT* DEF . URN-DEF) _namespaces_44))) '((HTML UHTML . URN-HTML) (HTML UHTML-1 . URN-HTML) (A UHTML . URN-HTML))) (define ssax:uri-string->symbol (lambda (_uri-str_38) (string->symbol _uri-str_38))) (define ssax:complete-start-tag ((lambda (_xmlns_38 _largest-dummy-decl-attr_39) (letrec ((_adjust-namespace-decl_40 (lambda (_port_43 _attrs_44 _namespaces_45) ((letrec ((_loop_46 (lambda (_attrs_47 _proper-attrs_48 _namespaces_49) (if (null? _attrs_47) (values _proper-attrs_48 _namespaces_49) (if (eq? _xmlns_38 (caar _attrs_47)) (_loop_46 (cdr _attrs_47) _proper-attrs_48 (if (equal? "" (cdar _attrs_47)) (cons (cons* '*DEFAULT* #f #f) _namespaces_49) (_add-ns_41 _port_43 '*DEFAULT* (cdar _attrs_47) _namespaces_49))) (if (if (pair? (caar _attrs_47)) (eq? _xmlns_38 (caaar _attrs_47)) #f) (_loop_46 (cdr _attrs_47) _proper-attrs_48 (_add-ns_41 _port_43 (cdaar _attrs_47) (cdar _attrs_47) _namespaces_49)) (_loop_46 (cdr _attrs_47) (cons (car _attrs_47) _proper-attrs_48) _namespaces_49))))))) _loop_46) _attrs_44 '() _namespaces_45))) (_add-ns_41 (lambda (_port_43 _prefix_44 _uri-str_45 _namespaces_46) (begin (if (equal? "" _uri-str_45) (parser-error _port_43 "[dt-NSName] broken for " _prefix_44) #f) ((lambda (_uri-symbol_47) ((letrec ((_loop_48 (lambda (_nss_49) (if (null? _nss_49) (cons (cons* _prefix_44 _uri-symbol_47 _uri-symbol_47) _namespaces_46) (if (eq? _uri-symbol_47 (cddar _nss_49)) (cons (cons* _prefix_44 (cadar _nss_49) _uri-symbol_47) _namespaces_46) (_loop_48 (cdr _nss_49))))))) _loop_48) _namespaces_46)) (ssax:uri-string->symbol _uri-str_45))))) (_validate-attrs_42 (lambda (_port_43 _attlist_44 _decl-attrs_45) (letrec ((_add-default-decl_46 (lambda (_decl-attr_47 _result_48) (call-with-values (lambda () (apply values _decl-attr_47)) (lambda (_attr-name_49 _content-type_50 _use-type_51 _default-value_52) (begin (if (eq? _use-type_51 'REQUIRED) (parser-error _port_43 "[RequiredAttr] broken for" _attr-name_49) #f) (if _default-value_52 (cons (cons _attr-name_49 _default-value_52) _result_48) _result_48))))))) ((letrec ((_loop_47 (lambda (_attlist_48 _decl-attrs_49 _result_50) (if (attlist-null? _attlist_48) (attlist-fold _add-default-decl_46 _result_50 _decl-attrs_49) (call-with-values (lambda () (attlist-remove-top _attlist_48)) (lambda (_attr_51 _attr-others_52) (call-with-values (lambda () (if (attlist-null? _decl-attrs_49) (values _largest-dummy-decl-attr_39 _decl-attrs_49) (attlist-remove-top _decl-attrs_49))) (lambda (_decl-attr_53 _other-decls_54) ((lambda (_key_55) (if (if (_eqv?_7 _key_55 '<) #t #f) (if ((lambda (_x_56) (if _x_56 _x_56 (if (pair? (car _attr_51)) (eq? _xmlns_38 (caar _attr_51)) #f))) (eq? _xmlns_38 (car _attr_51))) (_loop_47 _attr-others_52 _decl-attrs_49 (cons _attr_51 _result_50)) (parser-error _port_43 "[ValueType] broken for " _attr_51)) (if (if (_eqv?_7 _key_55 '>) #t #f) (_loop_47 _attlist_48 _other-decls_54 (_add-default-decl_46 _decl-attr_53 _result_50)) (call-with-values (lambda () (apply values _decl-attr_53)) (lambda (_attr-name_56 _content-type_57 _use-type_58 _default-value_59) (begin (if (eq? _use-type_58 'FIXED) ((lambda (_x_60) (if _x_60 _x_60 (parser-error _port_43 "[FixedAttr] broken for " _attr-name_56))) (equal? (cdr _attr_51) _default-value_59)) (if (eq? _content-type_57 'CDATA) #t (if (pair? _content-type_57) ((lambda (_x_60) (if _x_60 _x_60 (parser-error _port_43 "[enum] broken for " _attr-name_56 "=" (cdr _attr_51)))) (member (cdr _attr_51) _content-type_57)) (ssax:warn _port_43 "declared content type " _content-type_57 " not verified yet")))) (_loop_47 _attr-others_52 _other-decls_54 (cons _attr_51 _result_50)))))))) (name-compare (car _attr_51) (car _decl-attr_53))))))))))) _loop_47) _attlist_44 _decl-attrs_45 '()))))) (lambda (_tag-head_43 _port_44 _elems_45 _entities_46 _namespaces_47) ((lambda (_attlist_48) ((lambda (_empty-el-tag?_49) (call-with-values (lambda () (if _elems_45 ((lambda (_tmp_50) (if _tmp_50 ((lambda (_decl-elem_51) (values (if _empty-el-tag?_49 'EMPTY-TAG (cadr _decl-elem_51)) (caddr _decl-elem_51))) _tmp_50) (parser-error _port_44 "[elementvalid] broken, no decl for " _tag-head_43))) (assoc _tag-head_43 _elems_45)) (values (if _empty-el-tag?_49 'EMPTY-TAG 'ANY) #f))) (lambda (_elem-content_50 _decl-attrs_51) ((lambda (_merged-attrs_52) (call-with-values (lambda () (_adjust-namespace-decl_40 _port_44 _merged-attrs_52 _namespaces_47)) (lambda (_proper-attrs_53 _namespaces_54) (values (ssax:resolve-name _port_44 _tag-head_43 _namespaces_54 #t) (fold-right (lambda (_name-value_55 _attlist_56) ((lambda (_x_57) (if _x_57 _x_57 (parser-error _port_44 "[uniqattspec] after NS expansion broken for " _name-value_55))) (attlist-add _attlist_56 (cons (ssax:resolve-name _port_44 (car _name-value_55) _namespaces_54 #f) (cdr _name-value_55))))) (make-empty-attlist) _proper-attrs_53) _namespaces_54 _elem-content_50)))) (if _decl-attrs_51 (_validate-attrs_42 _port_44 _attlist_48 _decl-attrs_51) (attlist->alist _attlist_48)))))) (begin (ssax:skip-S _port_44) (if (eqv? #\/ (assert-curr-char '(#\> #\/) "XML [40], XML [44], no '>'" _port_44)) (assert-curr-char '(#\>) "XML [44], no '>'" _port_44) #f)))) (ssax:read-attributes _port_44 _entities_46))))) (string->symbol "xmlns") (list ssax:largest-unres-name #f #f #f))) ((lambda (_urn-a_44) ((lambda (_urn-b_45) ((lambda (_urn-html_46) ((lambda (_namespaces_47) ((lambda (_test_48) (begin (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 '() (_cons_23 _namespaces_47 '(ANY)))) (_test_48 "TAG1" #f ">"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 '() (_cons_23 _namespaces_47 '(EMPTY-TAG)))) (_test_48 "TAG1" #f "/>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"a")) (_cons_23 _namespaces_47 '(EMPTY-TAG)))) (_test_48 "TAG1" #f "HREF='a'/>"))) (assert (equal? (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"a")) (_cons_23 (cons (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") _urn-a_44)) _namespaces_47) '(ANY)))) (_test_48 "TAG1" #f "HREF='a' xmlns='urn:a'>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"a")) (_cons_23 (cons '(*DEFAULT* #f . #f) _namespaces_47) '(ANY)))) (_test_48 "TAG1" #f "HREF='a' xmlns=''>"))) (assert (failed? (_test_48 "UA:TAG1" #f "HREF='a' xmlns=''/>"))) (assert (equal? (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"a")) (_cons_23 (cons '(*DEFAULT* #f . #f) _namespaces_47) '(ANY)))) (_test_48 "A:TAG1" #f "A:HREF='a' xmlns=''>"))) (assert (equal? (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"a")) (_cons_23 (cons (_cons_23 '*DEFAULT* (_cons_23 _urn-b_45 _urn-b_45)) _namespaces_47) '(ANY)))) (_test_48 "A:TAG1" #f "A:HREF='a' xmlns='urn:b'>"))) (assert (failed? (_test_48 "B:TAG1" #f "A:HREF='a' xmlns:b=''/>"))) (assert (equal? (_cons_23 (_cons_23 _urn-b_45 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"a")) (_cons_23 (cons (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (_cons_23 _urn-b_45 _urn-b_45)) _namespaces_47) '(ANY)))) (_test_48 "B:TAG1" #f "A:HREF='a' xmlns:B='urn:b'>"))) (assert (equal? (_cons_23 (_cons_23 _urn-b_45 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"a") (_cons_23 (_cons_23 _urn-b_45 (if (string? '"SRC") (string->symbol '"SRC") '"SRC")) '"b")) (_cons_23 (cons (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (_cons_23 _urn-b_45 _urn-b_45)) _namespaces_47) '(ANY)))) (_test_48 "B:TAG1" #f "B:SRC='b' A:HREF='a' xmlns:B='urn:b'>"))) (assert (equal? (_cons_23 (_cons_23 _urn-b_45 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"a") (_cons_23 (_cons_23 _urn-b_45 (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"b")) (_cons_23 (cons (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (_cons_23 _urn-b_45 _urn-b_45)) _namespaces_47) '(ANY)))) (_test_48 "B:TAG1" #f "B:HREF=\"b\" A:HREF='a' xmlns:B='urn:b'>"))) (assert (failed? (_test_48 "B:TAG1" #f "HREF=\"b\" HREF='a' xmlns:B='urn:a'/>"))) (assert (failed? (_test_48 "B:TAG1" #f "B:HREF=\"b\" A:HREF='a' xmlns:B='urn:a'/>"))) (assert (equal? (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"a") (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"b")) (_cons_23 (cons (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") _urn-a_44)) _namespaces_47) '(ANY)))) (_test_48 "TAG1" #f "A:HREF=\"b\" HREF='a' xmlns='urn:a'>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (_cons_23 (if (string? '"UHTML") (string->symbol '"UHTML") '"UHTML") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"a") (_cons_23 (_cons_23 _urn-b_45 (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"b")) (_cons_23 (append (_list_25 (_cons_23 (if (string? '"HTML") (string->symbol '"HTML") '"HTML") (_cons_23 (if (string? '"UHTML") (string->symbol '"UHTML") '"UHTML") _urn-html_46)) (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (_cons_23 _urn-b_45 _urn-b_45))) _namespaces_47) '(ANY)))) (_test_48 "TAG1" #f "B:HREF=\"b\" xmlns:B='urn:b' xmlns:HTML='http://w3c.org/html' HTML:HREF='a' >"))) (assert (failed? (_test_48 "TAG1" '((TAG2 ANY ())) "B:HREF='b' xmlns:B='urn:b'>"))) (assert (failed? (_test_48 "TAG1" (_list_25 (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") '(ANY ()))) "B:HREF='b' xmlns:B='urn:b'>"))) (assert (failed? (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'ANY (_list_25 (_cons_23 (if (string? '"HREF1") (string->symbol '"HREF1") '"HREF1") '(CDATA IMPLIED #f))))) "B:HREF='b' xmlns:B='urn:b'>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 _namespaces_47 '(EMPTY-TAG)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA REQUIRED #f))))) "HREF='b'/>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 _namespaces_47 '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA REQUIRED #f))))) "HREF='b'>"))) (assert (failed? (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA REQUIRED #f))))) ">"))) (assert (failed? (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(("c") REQUIRED #f))))) "HREF='b'>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 _namespaces_47 '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(("c" "b") IMPLIED #f))))) "HREF='b'>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 _namespaces_47 '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA IMPLIED "c"))))) "HREF='b'>"))) (assert (failed? (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA FIXED "c"))))) "HREF='b'>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 _namespaces_47 '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA FIXED "b"))))) "HREF='b'>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 _namespaces_47 '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA FIXED "b"))))) ">"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 _namespaces_47 '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA IMPLIED "b"))))) ">"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 '() (_cons_23 _namespaces_47 '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA IMPLIED #f))))) ">"))) (assert (failed? (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '(CDATA IMPLIED "c"))))) "HREF='b'>"))) (assert (equal? (_cons_23 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b") (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"c")) (_cons_23 _namespaces_47 '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA REQUIRED #f)) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '(CDATA IMPLIED "c"))))) "HREF='b'>"))) (assert (equal? (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b") (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"c")) (_cons_23 _namespaces_47 '(PCDATA)))) (_test_48 "A:TAG1" (_list_25 (_list_25 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(NMTOKEN REQUIRED #f)) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '(CDATA IMPLIED "c"))))) "HREF='b'>"))) (assert (equal? (_cons_23 (_cons_23 _urn-b_45 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 (cons (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (_cons_23 _urn-b_45 _urn-b_45)) _namespaces_47) '(PCDATA)))) (_test_48 "B:TAG1" (_list_25 (_list_25 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA REQUIRED #f)) (_cons_23 (_cons_23 (if (string? '"xmlns") (string->symbol '"xmlns") '"xmlns") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED "urn:b"))))) "HREF='b'>"))) (assert (equal? (_cons_23 (_cons_23 _urn-b_45 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (_cons_23 _urn-b_45 (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"b")) (_cons_23 (cons (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (_cons_23 _urn-b_45 _urn-b_45)) _namespaces_47) '(PCDATA)))) (_test_48 "B:TAG1" (_list_25 (_list_25 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) 'PCDATA (_list_25 (_cons_23 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '(CDATA REQUIRED #f)) (_cons_23 (_cons_23 (if (string? '"xmlns") (string->symbol '"xmlns") '"xmlns") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED "urn:b"))))) "B:HREF='b'>"))) (assert (equal? (_cons_23 (_cons_23 _urn-b_45 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 (cons (_cons_23 '*DEFAULT* (_cons_23 _urn-b_45 _urn-b_45)) _namespaces_47) '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA REQUIRED #f)) (_cons_23 (if (string? '"xmlns") (string->symbol '"xmlns") '"xmlns") '(CDATA IMPLIED "urn:b"))))) "HREF='b'>"))) (assert (equal? (_cons_23 (_cons_23 _urn-b_45 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '"b")) (_cons_23 (cons (_cons_23 '*DEFAULT* (_cons_23 _urn-b_45 _urn-b_45)) _namespaces_47) '(PCDATA)))) (_test_48 "TAG1" (_list_25 (_list_25 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1") 'PCDATA (_list_25 (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '(CDATA REQUIRED #f))))) "HREF='b' xmlns='urn:b'>"))) (assert (equal? (_cons_23 (_cons_23 _urn-b_45 (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) (_cons_23 (_list_25 (_cons_23 (_cons_23 _urn-b_45 (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '"b")) (_cons_23 (cons (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (_cons_23 _urn-b_45 _urn-b_45)) _namespaces_47) '(PCDATA)))) (_test_48 "B:TAG1" (_list_25 (_list_25 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (if (string? '"TAG1") (string->symbol '"TAG1") '"TAG1")) 'PCDATA (_list_25 (_cons_23 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") (if (string? '"HREF") (string->symbol '"HREF") '"HREF")) '(CDATA REQUIRED #f))))) "B:HREF='b' xmlns:B='urn:b'>"))))) (lambda (_tag-head-name_48 _elems_49 _str_50) (call-with-input-string _str_50 (lambda (_port_51) (call-with-values (lambda () (ssax:complete-start-tag (call-with-input-string _tag-head-name_48 (lambda (_port_52) (ssax:read-QName _port_52))) _port_51 _elems_49 '() _namespaces_47)) list)))))) (_list_25 (_cons_23 '#f (_cons_23 (if (string? '"UHTML") (string->symbol '"UHTML") '"UHTML") _urn-html_46)) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") _urn-a_44))))) (string->symbol "http://w3c.org/html"))) (string->symbol "urn:b"))) (string->symbol "urn:a")) (define ssax:read-external-id (lambda (_port_38) ((lambda (_discriminator_39) (begin (assert-curr-char ssax:S-chars "space after SYSTEM or PUBLIC" _port_38) (ssax:skip-S _port_38) ((lambda (_delimiter_40) (if (eq? _discriminator_39 (string->symbol "SYSTEM")) ((lambda (_val_41) (begin (read-char _port_38) _val_41)) (next-token '() (list _delimiter_40) "XML [11]" _port_38)) (if (eq? _discriminator_39 (string->symbol "PUBLIC")) (begin (skip-until (list _delimiter_40) _port_38) (assert-curr-char ssax:S-chars "space after PubidLiteral" _port_38) (ssax:skip-S _port_38) ((lambda (_delimiter_41) ((lambda (_systemid_42) (begin (read-char _port_38) _systemid_42)) (next-token '() (list _delimiter_41) "XML [11]" _port_38))) (assert-curr-char '(#\' #\") "XML [11]" _port_38))) (parser-error _port_38 "XML [75], " _discriminator_39 " rather than SYSTEM or PUBLIC")))) (assert-curr-char '(#\' #\") "XML [11], XML [12]" _port_38)))) (ssax:read-NCName _port_38)))) (define ssax:scan-Misc (lambda (_port_38) ((letrec ((_loop_39 (lambda (_c_40) (if (eof-object? _c_40) _c_40 (if (not (char=? _c_40 #\<)) (parser-error _port_38 "XML [22], char '" _c_40 "' unexpected") ((lambda (_token_41) ((lambda (_key_42) (if (if (_eqv?_7 _key_42 'COMMENT) #t #f) (_loop_39 (ssax:skip-S _port_38)) (if (if (_eqv?_7 _key_42 'PI) #t (if (_eqv?_7 _key_42 'DECL) #t (if (_eqv?_7 _key_42 'START) #t #f))) _token_41 (parser-error _port_38 "XML [22], unexpected token of kind " (car _token_41))))) (car _token_41))) (ssax:read-markup-token _port_38))))))) _loop_39) (ssax:skip-S _port_38)))) (define ssax:read-char-data ((lambda (_terminators-usual_38 _terminators-usual-eof_39 _handle-fragment_40) (lambda (_port_41 _expect-eof?_42 _str-handler_43 _seed_44) (if (eqv? #\< (peek-char _port_41)) ((lambda (_token_45) ((lambda (_key_46) (if (if (_eqv?_7 _key_46 'START) #t (if (_eqv?_7 _key_46 'END) #t #f)) (values _seed_44 _token_45) (if (if (_eqv?_7 _key_46 'CDSECT) #t #f) ((lambda (_seed_47) (ssax:read-char-data _port_41 _expect-eof?_42 _str-handler_43 _seed_47)) (ssax:read-cdata-body _port_41 _str-handler_43 _seed_44)) (if (if (_eqv?_7 _key_46 'COMMENT) #t #f) (ssax:read-char-data _port_41 _expect-eof?_42 _str-handler_43 _seed_44) (values _seed_44 _token_45))))) (car _token_45))) (ssax:read-markup-token _port_41)) ((lambda (_char-data-terminators_45) ((letrec ((_loop_46 (lambda (_seed_47) ((lambda (_fragment_48) ((lambda (_term-char_49) (if (eof-object? _term-char_49) (values (_handle-fragment_40 _fragment_48 _str-handler_43 _seed_47) _term-char_49) ((lambda (_key_50) (if (if (_eqv?_7 _key_50 '#\<) #t #f) ((lambda (_token_51) ((lambda (_key_52) (if (if (_eqv?_7 _key_52 'CDSECT) #t #f) (_loop_46 (ssax:read-cdata-body _port_41 _str-handler_43 (_handle-fragment_40 _fragment_48 _str-handler_43 _seed_47))) (if (if (_eqv?_7 _key_52 'COMMENT) #t #f) (_loop_46 (_handle-fragment_40 _fragment_48 _str-handler_43 _seed_47)) (values (_handle-fragment_40 _fragment_48 _str-handler_43 _seed_47) _token_51)))) (car _token_51))) (ssax:read-markup-token _port_41)) (if (if (_eqv?_7 _key_50 '#\&) #t #f) ((lambda (_key_51) (if (if (_eqv?_7 _key_51 '#\#) #t #f) (begin (read-char _port_41) (_loop_46 (_str-handler_43 _fragment_48 (ssax:read-char-ref _port_41) _seed_47))) ((lambda (_name_52) (begin (assert-curr-char '(#\;) "XML [68]" _port_41) (values (_handle-fragment_40 _fragment_48 _str-handler_43 _seed_47) (make-xml-token 'ENTITY-REF _name_52)))) (ssax:read-NCName _port_41)))) (peek-next-char _port_41)) (begin (if (eqv? (peek-next-char _port_41) #\newline) (read-char _port_41)) (_loop_46 (_str-handler_43 _fragment_48 (string #\newline) _seed_47)))))) _term-char_49))) (peek-char _port_41))) (next-token '() _char-data-terminators_45 "reading char data" _port_41))))) _loop_46) _seed_44)) (if _expect-eof?_42 _terminators-usual-eof_39 _terminators-usual_38))))) (list #\< #\& char-return) (list #\< '*eof* #\& char-return) (lambda (_fragment_38 _str-handler_39 _seed_40) (if (zero? (string-length _fragment_38)) _seed_40 (_str-handler_39 _fragment_38 "" _seed_40))))) (letrec ((_test_44 (lambda (_str_49 _expect-eof?_50 _expected-data_51 _expected-token_52) (begin (newline) (display "body: ") (write _str_49) (newline) (display "Result: ") (call-with-values (lambda () (call-with-input-string (unesc-string _str_49) (lambda (_port_53) (ssax:read-char-data _port_53 _expect-eof?_50 _str-handler_45 '())))) (lambda (_seed_53 _token_54) ((lambda (_result_55) (begin (write _result_55) (display " ") (display _token_54) (assert (equal? _result_55 (map unesc-string _expected-data_51)) (if (eq? _expected-token_52 _eof-object_46) (eof-object? _token_54) (equal? _token_54 _expected-token_52))))) (reverse _seed_53))))))) (_str-handler_45 (lambda (_fragment_49 _foll-fragment_50 _seed_51) (if (zero? (string-length _foll-fragment_50)) (cons _fragment_49 _seed_51) (cons* _foll-fragment_50 _fragment_49 _seed_51)))) (_eof-object_46 (lambda () _eof-object_46)) (_a-ref_47 (make-xml-token (if (string? 'ENTITY-REF) (string->symbol 'ENTITY-REF) 'ENTITY-REF) (string->symbol "lt"))) (_a-tag_48 (make-xml-token (if (string? 'START) (string->symbol 'START) 'START) (string->symbol "BR")))) (begin (_test_44 "" #t '() _eof-object_46) (assert (failed? (_test_44 "" #f '() _eof-object_46))) (_test_44 " " #t '(" ") _eof-object_46) (_test_44 "
" #f '() _a-tag_48) (_test_44 "
" #f '(" ") _a-tag_48) (_test_44 " <" #f '(" ") _a-ref_47) (_test_44 " a<" #f '(" a") _a-ref_47) (_test_44 " a <" #f '(" a ") _a-ref_47) (_test_44 " a a
" #f '(" " " a a") _a-tag_48) (_test_44 " %ra a
" #f '(" " "" "%n" "a a") _a-tag_48) (_test_44 " %r%na a
" #f '(" " "" "%n" "a a") _a-tag_48) (_test_44 " %r%na%t%r%r%na
" #f '(" " "" "%n" "a%t" "%n" "" "%n" "a") _a-tag_48) (_test_44 "a a a
" #f '("a" " a a") _a-tag_48) (_test_44 "!
" #f '("" "!") _a-tag_48) (_test_44 "!%n
" #f '("" "!" "%n") _a-tag_48) (_test_44 "%t!%n
" #f '("%t" "!" "%n") _a-tag_48) (_test_44 "%t!%na a
" #f '("%t" "!" "%na a") _a-tag_48) (_test_44 "%t!%ra a
" #f '("%t" "!" "" "%n" "a a") _a-tag_48) (_test_44 "%t!%r%na a
" #f '("%t" "!" "" "%n" "a a") _a-tag_48) (_test_44 " %ta ! b
" #f '(" %ta " "!" " b ") _a-tag_48) (_test_44 " %ta b
" #f '(" %ta " " " " b ") _a-tag_48) (_test_44 "
" #f '("<") _a-tag_48) (_test_44 "
" #f '("]") _a-tag_48) (_test_44 "%t
" #f '("%t" "<") _a-tag_48) (_test_44 "%ta b
" #f '("%t" "<" "a b") _a-tag_48) (_test_44 "%t a b
" #f '("%t" "<" " a b") _a-tag_48) (_test_44 "%td a b
" #f '("%td " " <" "%n" "" "%n" " a b") _a-tag_48))) (define ssax:assert-token (lambda (_token_38 _kind_39 _gi_40 _error-cont_41) ((lambda (_x_42) (if _x_42 _x_42 (_error-cont_41 _token_38 _kind_39 _gi_40))) (if (xml-token? _token_38) (if (eq? _kind_39 (car _token_38)) (equal? _gi_40 (cdr _token_38)) #f) #f)))) (pp (lambda (_port_46 _target_47 _seed_48) ((lambda (_key_49) (begin (ssax:warn _port_46 "Skipping PI: " _target_47 nl) (ssax:skip-pi _port_46) _seed_48)) _target_47))) (pp (lambda (_port_46 _target_47 _seed_48) ((lambda (_key_49) (if (if (_eqv?_7 _key_49 'xml) #t #f) ((lambda (_port_50 _target_51 _seed_52) _seed_52) _port_46 _target_47 _seed_48) (begin (ssax:warn _port_46 "Skipping PI: " _target_47 nl) (ssax:skip-pi _port_46) _seed_48))) _target_47))) (pp (lambda (_port_46 _target_47 _seed_48) ((lambda (_key_49) (if (if (_eqv?_7 _key_49 'xml) #t #f) ((lambda (_port_50 _target_51 _seed_52) _seed_52) _port_46 _target_47 _seed_48) (if (if (_eqv?_7 _key_49 'html) #t #f) (list _port_46 _target_47 _seed_48) (ssax:warn _port_46 _target_47 _seed_48)))) _target_47))) (letrec ((_test_44 (lambda (_str_47 _doctype-fn_48 _expected_49) (begin (cout nl "Parsing: " _str_47 nl) ((lambda (_result_50) (begin (write _result_50) (assert (equal? _result_50 _expected_49)))) (_simple-parser_46 (unesc-string _str_47) _doctype-fn_48))))) (_dummy-doctype-fn_45 (lambda (_elem-gi_47 _seed_48) (values #f '() '() _seed_48))) (_simple-parser_46 (lambda (_str_47 _doctype-fn_48) (call-with-input-string _str_47 (lambda (_port_49) ((lambda (_port_53 _seed_54) (letrec ((_element-parser_55 (lambda (_start-tag-head_59 _port_60 _elems_61 _entities_62 _namespaces_63 _preserve-ws?_64 _seed_65) (letrec ((_xml-space-gi_66 (cons ssax:Prefix-XML (string->symbol "space")))) ((letrec ((_handle-start-tag_67 (lambda (_start-tag-head_68 _port_69 _entities_70 _namespaces_71 _preserve-ws?_72 _parent-seed_73) (call-with-values (lambda () (ssax:complete-start-tag _start-tag-head_68 _port_69 _elems_61 _entities_70 _namespaces_71)) (lambda (_elem-gi_74 _attributes_75 _namespaces_76 _expected-content_77) ((lambda (_seed_78) ((lambda (_key_79) (if (if (_eqv?_7 _key_79 'EMPTY-TAG) #t #f) ((lambda (_elem-gi_80 _attributes_81 _namespaces_82 _parent-seed_83 _seed_84) ((lambda (_seed_85) ((lambda (_seed_86) (cons (cons _elem-gi_80 _seed_86) _parent-seed_83)) (if (attlist-null? _attributes_81) _seed_85 (cons (cons (if (string? '@) (string->symbol '@) '@) (map (lambda (_attr_86) (list (car _attr_86) (cdr _attr_86))) (attlist->alist _attributes_81))) _seed_85)))) (if (null? _namespaces_82) (reverse _seed_84) (cons (list (if (string? '*NAMESPACES*) (string->symbol '*NAMESPACES*) '*NAMESPACES*) _namespaces_82) (reverse _seed_84))))) _elem-gi_74 _attributes_75 _namespaces_76 _parent-seed_73 _seed_78) (if (if (_eqv?_7 _key_79 'EMPTY) #t #f) (begin (ssax:assert-token (if (eqv? #\< (ssax:skip-S _port_69)) (ssax:read-markup-token _port_69) #f) 'END _start-tag-head_68 (lambda (_token_80 _exp-kind_81 _exp-head_82) (parser-error _port_69 "[elementvalid] broken for " _token_80 " while expecting " _exp-kind_81 _exp-head_82))) ((lambda (_elem-gi_80 _attributes_81 _namespaces_82 _parent-seed_83 _seed_84) ((lambda (_seed_85) ((lambda (_seed_86) (cons (cons _elem-gi_80 _seed_86) _parent-seed_83)) (if (attlist-null? _attributes_81) _seed_85 (cons (cons (if (string? '@) (string->symbol '@) '@) (map (lambda (_attr_86) (list (car _attr_86) (cdr _attr_86))) (attlist->alist _attributes_81))) _seed_85)))) (if (null? _namespaces_82) (reverse _seed_84) (cons (list (if (string? '*NAMESPACES*) (string->symbol '*NAMESPACES*) '*NAMESPACES*) _namespaces_82) (reverse _seed_84))))) _elem-gi_74 _attributes_75 _namespaces_76 _parent-seed_73 _seed_78)) ((lambda (_preserve-ws?_80) ((letrec ((_loop_81 (lambda (_port_82 _entities_83 _expect-eof?_84 _seed_85) (call-with-values (lambda () (ssax:read-char-data _port_82 _expect-eof?_84 (lambda (_string1_86 _string2_87 _seed_88) (if (zero? (string-length _string2_87)) (cons _string1_86 _seed_88) (cons* _string2_87 _string1_86 _seed_88))) _seed_85)) (lambda (_seed_86 _term-token_87) (if (eof-object? _term-token_87) _seed_86 ((lambda (_key_88) (if (if (_eqv?_7 _key_88 'END) #t #f) (begin (ssax:assert-token _term-token_87 'END _start-tag-head_68 (lambda (_token_89 _exp-kind_90 _exp-head_91) (parser-error _port_82 "[GIMatch] broken for " _term-token_87 " while expecting " _exp-kind_90 _exp-head_91))) ((lambda (_elem-gi_89 _attributes_90 _namespaces_91 _parent-seed_92 _seed_93) ((lambda (_seed_94) ((lambda (_seed_95) (cons (cons _elem-gi_89 _seed_95) _parent-seed_92)) (if (attlist-null? _attributes_90) _seed_94 (cons (cons (if (string? '@) (string->symbol '@) '@) (map (lambda (_attr_95) (list (car _attr_95) (cdr _attr_95))) (attlist->alist _attributes_90))) _seed_94)))) (if (null? _namespaces_91) (reverse _seed_93) (cons (list (if (string? '*NAMESPACES*) (string->symbol '*NAMESPACES*) '*NAMESPACES*) _namespaces_91) (reverse _seed_93))))) _elem-gi_74 _attributes_75 _namespaces_76 _parent-seed_73 _seed_86)) (if (if (_eqv?_7 _key_88 'PI) #t #f) ((lambda (_seed_89) (_loop_81 _port_82 _entities_83 _expect-eof?_84 _seed_89)) ((lambda (_port_91 _target_92 _seed_93) ((lambda (_key_94) (begin (ssax:warn _port_91 "Skipping PI: " _target_92 nl) (ssax:skip-pi _port_91) _seed_93)) _target_92)) _port_82 (cdr _term-token_87) _seed_86)) (if (if (_eqv?_7 _key_88 'ENTITY-REF) #t #f) ((lambda (_seed_89) (_loop_81 _port_82 _entities_83 _expect-eof?_84 _seed_89)) (ssax:handle-parsed-entity _port_82 (cdr _term-token_87) _entities_83 (lambda (_port_89 _entities_90 _seed_91) (_loop_81 _port_89 _entities_90 #t _seed_91)) (lambda (_string1_89 _string2_90 _seed_91) (if (zero? (string-length _string2_90)) (cons _string1_89 _seed_91) (cons* _string2_90 _string1_89 _seed_91))) _seed_86)) (if (if (_eqv?_7 _key_88 'START) #t #f) (begin (if (eq? _expected-content_77 'PCDATA) (parser-error _port_82 "[elementvalid] broken for " _elem-gi_74 " with char content only; unexpected token " _term-token_87)) ((lambda (_seed_89) (_loop_81 _port_82 _entities_83 _expect-eof?_84 _seed_89)) (_handle-start-tag_67 (cdr _term-token_87) _port_82 _entities_83 _namespaces_76 _preserve-ws?_80 _seed_86))) (parser-error _port_82 "XML [43] broken for " _term-token_87)))))) (car _term-token_87)))))))) _loop_81) _port_69 _entities_70 #f _seed_78)) ((lambda (_tmp_80) (if _tmp_80 ((lambda (_name-value_81) (equal? "preserve" (cdr _name-value_81))) _tmp_80) _preserve-ws?_72)) (assoc _xml-space-gi_66 _attributes_75)))))) _expected-content_77)) ((lambda (_elem-gi_78 _attributes_79 _namespaces_80 _expected-content_81 _seed_82) '()) _elem-gi_74 _attributes_75 _namespaces_76 _expected-content_77 _parent-seed_73))))))) _handle-start-tag_67) _start-tag-head_59 _port_60 _entities_62 _namespaces_63 _preserve-ws?_64 _seed_65)))) (_scan-for-significant-prolog-token-2_56 (lambda (_port_59 _elems_60 _entities_61 _namespaces_62 _seed_63) ((lambda (_token_64) (if (eof-object? _token_64) (parser-error _port_59 "XML [22], unexpected EOF") ((lambda (_key_65) (if (if (_eqv?_7 _key_65 'PI) #t #f) ((lambda (_seed_66) (_scan-for-significant-prolog-token-2_56 _port_59 _elems_60 _entities_61 _namespaces_62 _seed_66)) ((lambda (_port_68 _target_69 _seed_70) ((lambda (_key_71) (begin (ssax:warn _port_68 "Skipping PI: " _target_69 nl) (ssax:skip-pi _port_68) _seed_70)) _target_69)) _port_59 (cdr _token_64) _seed_63)) (if (if (_eqv?_7 _key_65 'START) #t #f) (_element-parser_55 (cdr _token_64) _port_59 _elems_60 _entities_61 _namespaces_62 #f ((lambda (_elem-gi_66 _seed_67) _seed_67) (cdr _token_64) _seed_63)) (parser-error _port_59 "XML [22], unexpected markup " _token_64)))) (car _token_64)))) (ssax:scan-Misc _port_59)))) (_scan-for-significant-prolog-token-1_57 (lambda (_port_59 _seed_60) ((lambda (_token_61) (if (eof-object? _token_61) (parser-error _port_59 "XML [22], unexpected EOF") ((lambda (_key_62) (if (if (_eqv?_7 _key_62 'PI) #t #f) ((lambda (_seed_63) (_scan-for-significant-prolog-token-1_57 _port_59 _seed_63)) ((lambda (_port_65 _target_66 _seed_67) ((lambda (_key_68) (begin (ssax:warn _port_65 "Skipping PI: " _target_66 nl) (ssax:skip-pi _port_65) _seed_67)) _target_66)) _port_59 (cdr _token_61) _seed_60)) (if (if (_eqv?_7 _key_62 'DECL) #t #f) (_handle-decl_58 _port_59 (cdr _token_61) _seed_60) (if (if (_eqv?_7 _key_62 'START) #t #f) (call-with-values (lambda () ((lambda (_elem-gi_63 _seed_64) (_doctype-fn_48 _elem-gi_63 _seed_64)) (cdr _token_61) _seed_60)) (lambda (_elems_63 _entities_64 _namespaces_65 _seed_66) (_element-parser_55 (cdr _token_61) _port_59 _elems_63 _entities_64 _namespaces_65 #f _seed_66))) (parser-error _port_59 "XML [22], unexpected markup " _token_61))))) (car _token_61)))) (ssax:scan-Misc _port_59)))) (_handle-decl_58 (lambda (_port_59 _token-head_60 _seed_61) (begin ((lambda (_x_62) (if _x_62 _x_62 (parser-error _port_59 "XML [22], expected DOCTYPE declaration, found " _token-head_60))) (eq? (string->symbol "DOCTYPE") _token-head_60)) (assert-curr-char ssax:S-chars "XML [28], space after DOCTYPE" _port_59) (ssax:skip-S _port_59) ((lambda (_docname_62) ((lambda (_systemid_63) ((lambda (_internal-subset?_64) (call-with-values (lambda () ((lambda (_port_65 _docname_66 _systemid_67 _internal-subset?_68 _seed_69) (begin (when _internal-subset?_68 (ssax:warn _port_65 "Internal DTD subset is not currently handled ") (ssax:skip-internal-dtd _port_65)) (ssax:warn _port_65 "DOCTYPE DECL " _docname_66 " " _systemid_67 " found and skipped") (_doctype-fn_48 _docname_66 _seed_69))) _port_59 _docname_62 _systemid_63 _internal-subset?_64 _seed_61)) (lambda (_elems_65 _entities_66 _namespaces_67 _seed_68) (_scan-for-significant-prolog-token-2_56 _port_59 _elems_65 _entities_66 _namespaces_67 _seed_68)))) (begin (ssax:skip-S _port_59) (eqv? #\[ (assert-curr-char '(#\> #\[) "XML [28], end-of-DOCTYPE" _port_59))))) (if (ssax:ncname-starting-char? (ssax:skip-S _port_59)) (ssax:read-external-id _port_59) #f))) (ssax:read-QName _port_59)))))) (_scan-for-significant-prolog-token-1_57 _port_53 _seed_54))) _port_49 '())))))) (begin (_test_44 "
" _dummy-doctype-fn_45 (_list_25 (_list_25 (if (string? '"BR") (string->symbol '"BR") '"BR")))) (assert (failed? (_test_44 "
" _dummy-doctype-fn_45 '()))) (_test_44 "

" _dummy-doctype-fn_45 (_list_25 (_list_25 (if (string? '"BR") (string->symbol '"BR") '"BR")))) (assert (failed? (_test_44 "
" _dummy-doctype-fn_45 '()))) (_test_44 " link itlink &amp;" _dummy-doctype-fn_45 (_list_25 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (_list_25 '@ (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '("URL"))) (_cons_23 '" link " (_cons_23 (_cons_23 (if (string? '"I") (string->symbol '"I") '"I") '("itlink ")) '(" " "&" "amp;"))))))) (_test_44 " link itlink &amp;" _dummy-doctype-fn_45 (_list_25 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (_list_25 '@ (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '("URL")) (_cons_23 (_cons_23 (if (string? '"xml") (string->symbol '"xml") '"xml") (if (string? '"space") (string->symbol '"space") '"space")) '("preserve"))) (_cons_23 '" link " (_cons_23 (_cons_23 (if (string? '"I") (string->symbol '"I") '"I") '("itlink ")) '(" " "&" "amp;"))))))) (_test_44 " link itlink &amp;" _dummy-doctype-fn_45 (_list_25 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (_list_25 '@ (_cons_23 (if (string? '"HREF") (string->symbol '"HREF") '"HREF") '("URL")) (_cons_23 (_cons_23 (if (string? '"xml") (string->symbol '"xml") '"xml") (if (string? '"space") (string->symbol '"space") '"space")) '("preserve"))) (_cons_23 '" link " (_cons_23 (_cons_23 (if (string? '"I") (string->symbol '"I") '"I") (_cons_23 (_list_25 '@ (_cons_23 (_cons_23 (if (string? '"xml") (string->symbol '"xml") '"xml") (if (string? '"space") (string->symbol '"space") '"space")) '("default"))) '("itlink "))) '(" " "&" "amp;"))))))) (_test_44 "This is item 1 %nItem 2%n " _dummy-doctype-fn_45 (_list_25 (_list_25 (if (string? '"itemize") (string->symbol '"itemize") '"itemize") (_cons_23 (if (string? '"item") (string->symbol '"item") '"item") '("This is item 1 ")) (unesc-string "%n") (_cons_23 (if (string? '"item") (string->symbol '"item") '"item") '("Item 2")) (unesc-string "%n ")))) (_test_44 "

%n]]>]]>

" _dummy-doctype-fn_45 (_list_25 (_cons_23 (if (string? '"P") (string->symbol '"P") '"P") (_cons_23 '"
" (_cons_23 nl '("" "]]" "" ">")))))) (_test_44 "

%r]]>]]>

" _dummy-doctype-fn_45 (_list_25 (_cons_23 (if (string? '"P") (string->symbol '"P") '"P") (_cons_23 '"
" (_cons_23 nl '("" "]]" "" ">")))))) (_test_44 "%n%n" _dummy-doctype-fn_45 (_list_25 (_list_25 (if (string? '"Reports") (string->symbol '"Reports") '"Reports") (_list_25 '@ (_cons_23 (if (string? '"TStamp") (string->symbol '"TStamp") '"TStamp") '("1")))))) (_test_44 "%n%n" _dummy-doctype-fn_45 (_list_25 (_list_25 (if (string? '"T") (string->symbol '"T") '"T")))) (_test_44 "%n" (lambda (_elem-gi_47 _seed_48) (begin (assert (equal? _elem-gi_47 (if (string? '"T") (string->symbol '"T") '"T"))) (values #f '() '() _seed_48))) (_list_25 (_list_25 (if (string? '"T") (string->symbol '"T") '"T")))) (_test_44 " ]>%n" (lambda (_elem-gi_47 _seed_48) (begin (assert (equal? _elem-gi_47 (if (string? '"T") (string->symbol '"T") '"T"))) (values #f '() '() _seed_48))) (_list_25 (_list_25 (if (string? '"T") (string->symbol '"T") '"T")))) (_test_44 "
" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(EMPTY ()))) '() '() _seed_48)) (_list_25 (_list_25 (if (string? '"BR") (string->symbol '"BR") '"BR")))) (_test_44 "

" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(EMPTY ()))) '() '() _seed_48)) (_list_25 (_list_25 (if (string? '"BR") (string->symbol '"BR") '"BR")))) (assert (failed? (_test_44 "
aa
" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(EMPTY ()))) '() '() _seed_48)) '()))) (_test_44 "
aa
" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(PCDATA ()))) '() '() _seed_48)) (_list_25 (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '("aa")))) (assert (failed? (_test_44 "
aa
" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(PCDATA ()))) '() '() _seed_48)) '()))) (_test_44 "
aa
" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(ANY ())) (_cons_23 (if (string? '"I") (string->symbol '"I") '"I") '(PCDATA ()))) '() '() _seed_48)) (_list_25 (_list_25 (if (string? '"BR") (string->symbol '"BR") '"BR") '"a" (_cons_23 (if (string? '"I") (string->symbol '"I") '"I") '("a"))))) (_test_44 "
Example: \"&example;\"
" (lambda (_elem-gi_47 _seed_48) (values #f '((example . "

An ampersand (&) may be escaped numerically (&#38;) or with a general entity (&amp;).

")) '() _seed_48)) (_list_25 (_cons_23 (if (string? '"DIV") (string->symbol '"DIV") '"DIV") (_cons_23 '"Example: \"" (_cons_23 (_cons_23 (if (string? '"P") (string->symbol '"P") '"P") '("An ampersand (" "&" ") may be escaped numerically (" "&" "#38;) or with a general entity (" "&" "amp;).")) '("\"")))))) (_test_44 "
Example: \"&example;\"

" (lambda (_elem-gi_47 _seed_48) (values #f (_list_25 (_cons_23 (if (string? '"quote") (string->symbol '"quote") '"quote") '"example: ex") (_cons_23 (if (string? '"example") (string->symbol '"example") '"example") '""e;!?")) '() _seed_48)) (_list_25 (_list_25 (if (string? '"DIV") (string->symbol '"DIV") '"DIV") '"Example: \"" (_cons_23 (if (string? '"Q") (string->symbol '"Q") '"Q") (_cons_23 (_cons_23 (if (string? '"I") (string->symbol '"I") '"I") '("example:")) '(" ex" "!"))) '"?" '"\" " (_list_25 (if (string? '"P") (string->symbol '"P") '"P"))))) (assert (failed? (_test_44 "
Example: \"&example;\"

" (lambda (_elem-gi_47 _seed_48) (values #f (_list_25 (_cons_23 (if (string? '"quote") (string->symbol '"quote") '"quote") '"example:") (_cons_23 (if (string? '"example") (string->symbol '"example") '"example") '""e;!?")) '() _seed_48)) '()))) (_test_44 "

" (lambda (_elem-gi_47 _seed_48) (values #f '() '() _seed_48)) (_list_25 (_list_25 (_cons_23 (if (string? '"URI1") (string->symbol '"URI1") '"URI1") (if (string? '"DIV") (string->symbol '"DIV") '"DIV")) (_list_25 '@ (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") '("B")) (_cons_23 (_cons_23 (if (string? '"URI1") (string->symbol '"URI1") '"URI1") (if (string? '"B") (string->symbol '"B") '"B")) '("A"))) (_list_25 '*NAMESPACES* (_list_25 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"URI1") (string->symbol '"URI1") '"URI1") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"URI1") (string->symbol '"URI1") '"URI1") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))))) (_list_25 (_cons_23 (if (string? '"URI1") (string->symbol '"URI1") '"URI1") (if (string? '"P") (string->symbol '"P") '"P")) (_list_25 '*NAMESPACES* (_list_25 '(*DEFAULT* #f . #f) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"URI1") (string->symbol '"URI1") '"URI1") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"URI1") (string->symbol '"URI1") '"URI1") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))))) (_list_25 (if (string? '"BR") (string->symbol '"BR") '"BR") (_list_25 '*NAMESPACES* (_list_25 '(*DEFAULT* #f . #f) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"URI1") (string->symbol '"URI1") '"URI1") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"URI1") (string->symbol '"URI1") '"URI1") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))))))))) (_test_44 "

" (lambda (_elem-gi_47 _seed_48) (values #f '() (_list_25 (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))) _seed_48)) (_list_25 (_list_25 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"DIV") (string->symbol '"DIV") '"DIV")) (_list_25 '@ (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") '("B")) (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"B") (string->symbol '"B") '"B")) '("A"))) (_list_25 '*NAMESPACES* (_list_25 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))))) (_list_25 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"P") (string->symbol '"P") '"P")) (_list_25 '*NAMESPACES* (_list_25 '(*DEFAULT* #f . #f) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))))) (_list_25 (if (string? '"BR") (string->symbol '"BR") '"BR") (_list_25 '*NAMESPACES* (_list_25 '(*DEFAULT* #f . #f) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))))))))) (assert (failed? (_test_44 "

" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_list_25 (if (string? '"DIV") (string->symbol '"DIV") '"DIV") 'ANY (_list_25 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") '(CDATA IMPLIED #f)) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED #f)) (_cons_23 (_cons_23 (if (string? '"C") (string->symbol '"C") '"C") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED "xx")) (_cons_23 (_cons_23 (if (string? '"xmlns") (string->symbol '"xmlns") '"xmlns") (if (string? '"C") (string->symbol '"C") '"C")) '(CDATA IMPLIED "URI1")))) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"P") (string->symbol '"P") '"P")) '(ANY ())) (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") (_cons_23 (if (string? '"EMPTY") (string->symbol '"EMPTY") '"EMPTY") '(())))) '() (_list_25 (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))) _seed_48)) '()))) (assert (failed? (_test_44 "

" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_list_25 (if (string? '"DIV") (string->symbol '"DIV") '"DIV") 'ANY (_list_25 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") '(CDATA IMPLIED #f)) (_cons_23 (if (string? '"xmlns") (string->symbol '"xmlns") '"xmlns") '(CDATA IMPLIED "URI1")) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED #f)) (_cons_23 (_cons_23 (if (string? '"C") (string->symbol '"C") '"C") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED "xx")))) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"P") (string->symbol '"P") '"P")) '(ANY ())) (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(EMPTY ()))) '() (_list_25 (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))) _seed_48)) '()))) (assert (failed? (_test_44 "

" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_list_25 (if (string? '"DIV") (string->symbol '"DIV") '"DIV") 'ANY (_list_25 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") '(CDATA IMPLIED #f)) (_cons_23 (if (string? '"xmlns") (string->symbol '"xmlns") '"xmlns") '(CDATA FIXED "URI2")) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED #f)))) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"P") (string->symbol '"P") '"P")) '(ANY ())) (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(EMPTY ()))) '() (_list_25 (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))) _seed_48)) '()))) (_test_44 "

" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_list_25 (if (string? '"DIV") (string->symbol '"DIV") '"DIV") 'ANY (_list_25 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") '(CDATA IMPLIED #f)) (_cons_23 (if (string? '"xmlns") (string->symbol '"xmlns") '"xmlns") '(CDATA FIXED "URI1")) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED #f)))) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"P") (string->symbol '"P") '"P")) '(ANY ())) (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(EMPTY ()))) '() (_list_25 (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))) _seed_48)) (_list_25 (_list_25 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"DIV") (string->symbol '"DIV") '"DIV")) (_list_25 '@ (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") '("B")) (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"B") (string->symbol '"B") '"B")) '("A"))) (_list_25 '*NAMESPACES* (_list_25 (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))))) (_list_25 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"P") (string->symbol '"P") '"P")) (_list_25 '*NAMESPACES* (_list_25 '(*DEFAULT* #f . #f) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))))) (_list_25 (if (string? '"BR") (string->symbol '"BR") '"BR") (_list_25 '*NAMESPACES* (_list_25 '(*DEFAULT* #f . #f) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))))))))) (_test_44 "

" (lambda (_elem-gi_47 _seed_48) (values (_list_25 (_list_25 (if (string? '"DIV") (string->symbol '"DIV") '"DIV") 'ANY (_list_25 (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") '(CDATA IMPLIED #f)) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED #f)) (_cons_23 (_cons_23 (if (string? '"C") (string->symbol '"C") '"C") (if (string? '"B") (string->symbol '"B") '"B")) '(CDATA IMPLIED "xx")) (_cons_23 (_cons_23 (if (string? '"xmlns") (string->symbol '"xmlns") '"xmlns") (if (string? '"C") (string->symbol '"C") '"C")) '(CDATA IMPLIED "URI2")))) (_cons_23 (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (if (string? '"P") (string->symbol '"P") '"P")) '(ANY ())) (_cons_23 (if (string? '"BR") (string->symbol '"BR") '"BR") '(EMPTY ()))) '() (_list_25 (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))) _seed_48)) (_list_25 (_list_25 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"DIV") (string->symbol '"DIV") '"DIV")) (_list_25 '@ (_cons_23 (if (string? '"B") (string->symbol '"B") '"B") '("B")) (_cons_23 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"B") (string->symbol '"B") '"B")) '("A")) (_cons_23 (_cons_23 (if (string? '"URI2") (string->symbol '"URI2") '"URI2") (if (string? '"B") (string->symbol '"B") '"B")) '("xx"))) (_list_25 '*NAMESPACES* (_list_25 (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 (if (string? '"C") (string->symbol '"C") '"C") (_cons_23 (if (string? '"URI2") (string->symbol '"URI2") '"URI2") (if (string? '"URI2") (string->symbol '"URI2") '"URI2"))) (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))))) (_list_25 (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"P") (string->symbol '"P") '"P")) (_list_25 '*NAMESPACES* (_list_25 '(*DEFAULT* #f . #f) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 (if (string? '"C") (string->symbol '"C") '"C") (_cons_23 (if (string? '"URI2") (string->symbol '"URI2") '"URI2") (if (string? '"URI2") (string->symbol '"URI2") '"URI2"))) (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))))) (_list_25 (if (string? '"BR") (string->symbol '"BR") '"BR") (_list_25 '*NAMESPACES* (_list_25 '(*DEFAULT* #f . #f) (_cons_23 '*DEFAULT* (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 (if (string? '"A") (string->symbol '"A") '"A") (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1"))) (_cons_23 (if (string? '"C") (string->symbol '"C") '"C") (_cons_23 (if (string? '"URI2") (string->symbol '"URI2") '"URI2") (if (string? '"URI2") (string->symbol '"URI2") '"URI2"))) (_cons_23 '#f (_cons_23 (if (string? '"UA") (string->symbol '"UA") '"UA") (if (string? '"URI1") (string->symbol '"URI1") '"URI1")))))))))))) (define ssax:reverse-collect-str (lambda (_fragments_38) (if (null? _fragments_38) '() (if (null? (cdr _fragments_38)) _fragments_38 ((letrec ((_loop_39 (lambda (_fragments_40 _result_41 _strs_42) (if (null? _fragments_40) (if (null? _strs_42) _result_41 (cons (string-concatenate/shared _strs_42) _result_41)) (if (string? (car _fragments_40)) (_loop_39 (cdr _fragments_40) _result_41 (cons (car _fragments_40) _strs_42)) (_loop_39 (cdr _fragments_40) (cons (car _fragments_40) (if (null? _strs_42) _result_41 (cons (string-concatenate/shared _strs_42) _result_41))) '())))))) _loop_39) _fragments_38 '() '()))))) (define ssax:reverse-collect-str-drop-ws (lambda (_fragments_38) (if (null? _fragments_38) '() (if (null? (cdr _fragments_38)) (if (if (string? (car _fragments_38)) (string-whitespace? (car _fragments_38)) #f) '() _fragments_38) ((letrec ((_loop_39 (lambda (_fragments_40 _result_41 _strs_42 _all-whitespace?_43) (if (null? _fragments_40) (if _all-whitespace?_43 _result_41 (cons (string-concatenate/shared _strs_42) _result_41)) (if (string? (car _fragments_40)) (_loop_39 (cdr _fragments_40) _result_41 (cons (car _fragments_40) _strs_42) (if _all-whitespace?_43 (string-whitespace? (car _fragments_40)) #f)) (_loop_39 (cdr _fragments_40) (cons (car _fragments_40) (if _all-whitespace?_43 _result_41 (cons (string-concatenate/shared _strs_42) _result_41))) '() #t)))))) _loop_39) _fragments_38 '() '() #t))))) (define ssax:xml->sxml (lambda (_port_38 _namespace-prefix-assig_39) (letrec ((_RES-NAME->SXML_40 (lambda (_res-name_42) (string->symbol (string-append (symbol->string (car _res-name_42)) ":" (symbol->string (cdr _res-name_42)))))) (_namespaces_41 (map (lambda (_el_42) (cons* #f (car _el_42) (ssax:uri-string->symbol (cdr _el_42)))) _namespace-prefix-assig_39))) ((lambda (_result_42) (cons '*TOP* (if (null? _namespace-prefix-assig_39) _result_42 (cons (list '@ (cons '*NAMESPACES* (map (lambda (_ns_43) (list (car _ns_43) (cdr _ns_43))) _namespace-prefix-assig_39))) _result_42)))) (reverse ((lambda (_port_45 _seed_46) (letrec ((_element-parser_47 (lambda (_start-tag-head_51 _port_52 _elems_53 _entities_54 _namespaces_55 _preserve-ws?_56 _seed_57) (letrec ((_xml-space-gi_58 (cons ssax:Prefix-XML (string->symbol "space")))) ((letrec ((_handle-start-tag_59 (lambda (_start-tag-head_60 _port_61 _entities_62 _namespaces_63 _preserve-ws?_64 _parent-seed_65) (call-with-values (lambda () (ssax:complete-start-tag _start-tag-head_60 _port_61 _elems_53 _entities_62 _namespaces_63)) (lambda (_elem-gi_66 _attributes_67 _namespaces_68 _expected-content_69) ((lambda (_seed_70) ((lambda (_key_71) (if (if (_eqv?_7 _key_71 'EMPTY-TAG) #t #f) ((lambda (_elem-gi_72 _attributes_73 _namespaces_74 _parent-seed_75 _seed_76) ((lambda (_seed_77 _attrs_78) (cons (cons (if (symbol? _elem-gi_72) _elem-gi_72 (_RES-NAME->SXML_40 _elem-gi_72)) (if (null? _attrs_78) _seed_77 (cons (cons '@ _attrs_78) _seed_77))) _parent-seed_75)) (ssax:reverse-collect-str _seed_76) (attlist-fold (lambda (_attr_77 _accum_78) (cons (list (if (symbol? (car _attr_77)) (car _attr_77) (_RES-NAME->SXML_40 (car _attr_77))) (cdr _attr_77)) _accum_78)) '() _attributes_73))) _elem-gi_66 _attributes_67 _namespaces_68 _parent-seed_65 _seed_70) (if (if (_eqv?_7 _key_71 'EMPTY) #t #f) (begin (ssax:assert-token (if (eqv? #\< (ssax:skip-S _port_61)) (ssax:read-markup-token _port_61) #f) 'END _start-tag-head_60 (lambda (_token_72 _exp-kind_73 _exp-head_74) (parser-error _port_61 "[elementvalid] broken for " _token_72 " while expecting " _exp-kind_73 _exp-head_74))) ((lambda (_elem-gi_72 _attributes_73 _namespaces_74 _parent-seed_75 _seed_76) ((lambda (_seed_77 _attrs_78) (cons (cons (if (symbol? _elem-gi_72) _elem-gi_72 (_RES-NAME->SXML_40 _elem-gi_72)) (if (null? _attrs_78) _seed_77 (cons (cons '@ _attrs_78) _seed_77))) _parent-seed_75)) (ssax:reverse-collect-str _seed_76) (attlist-fold (lambda (_attr_77 _accum_78) (cons (list (if (symbol? (car _attr_77)) (car _attr_77) (_RES-NAME->SXML_40 (car _attr_77))) (cdr _attr_77)) _accum_78)) '() _attributes_73))) _elem-gi_66 _attributes_67 _namespaces_68 _parent-seed_65 _seed_70)) ((lambda (_preserve-ws?_72) ((letrec ((_loop_73 (lambda (_port_74 _entities_75 _expect-eof?_76 _seed_77) (call-with-values (lambda () (ssax:read-char-data _port_74 _expect-eof?_76 (lambda (_string1_78 _string2_79 _seed_80) (if (zero? (string-length _string2_79)) (cons _string1_78 _seed_80) (cons* _string2_79 _string1_78 _seed_80))) _seed_77)) (lambda (_seed_78 _term-token_79) (if (eof-object? _term-token_79) _seed_78 ((lambda (_key_80) (if (if (_eqv?_7 _key_80 'END) #t #f) (begin (ssax:assert-token _term-token_79 'END _start-tag-head_60 (lambda (_token_81 _exp-kind_82 _exp-head_83) (parser-error _port_74 "[GIMatch] broken for " _term-token_79 " while expecting " _exp-kind_82 _exp-head_83))) ((lambda (_elem-gi_81 _attributes_82 _namespaces_83 _parent-seed_84 _seed_85) ((lambda (_seed_86 _attrs_87) (cons (cons (if (symbol? _elem-gi_81) _elem-gi_81 (_RES-NAME->SXML_40 _elem-gi_81)) (if (null? _attrs_87) _seed_86 (cons (cons '@ _attrs_87) _seed_86))) _parent-seed_84)) (ssax:reverse-collect-str _seed_85) (attlist-fold (lambda (_attr_86 _accum_87) (cons (list (if (symbol? (car _attr_86)) (car _attr_86) (_RES-NAME->SXML_40 (car _attr_86))) (cdr _attr_86)) _accum_87)) '() _attributes_82))) _elem-gi_66 _attributes_67 _namespaces_68 _parent-seed_65 _seed_78)) (if (if (_eqv?_7 _key_80 'PI) #t #f) ((lambda (_seed_81) (_loop_73 _port_74 _entities_75 _expect-eof?_76 _seed_81)) ((lambda (_port_83 _target_84 _seed_85) ((lambda (_key_86) ((lambda (_port_87 _pi-tag_88 _seed_89) (cons (list '*PI* _pi-tag_88 (ssax:read-pi-body-as-string _port_87)) _seed_89)) _port_83 _target_84 _seed_85)) _target_84)) _port_74 (cdr _term-token_79) _seed_78)) (if (if (_eqv?_7 _key_80 'ENTITY-REF) #t #f) ((lambda (_seed_81) (_loop_73 _port_74 _entities_75 _expect-eof?_76 _seed_81)) (ssax:handle-parsed-entity _port_74 (cdr _term-token_79) _entities_75 (lambda (_port_81 _entities_82 _seed_83) (_loop_73 _port_81 _entities_82 #t _seed_83)) (lambda (_string1_81 _string2_82 _seed_83) (if (zero? (string-length _string2_82)) (cons _string1_81 _seed_83) (cons* _string2_82 _string1_81 _seed_83))) _seed_78)) (if (if (_eqv?_7 _key_80 'START) #t #f) (begin (if (eq? _expected-content_69 'PCDATA) (parser-error _port_74 "[elementvalid] broken for " _elem-gi_66 " with char content only; unexpected token " _term-token_79)) ((lambda (_seed_81) (_loop_73 _port_74 _entities_75 _expect-eof?_76 _seed_81)) (_handle-start-tag_59 (cdr _term-token_79) _port_74 _entities_75 _namespaces_68 _preserve-ws?_72 _seed_78))) (parser-error _port_74 "XML [43] broken for " _term-token_79)))))) (car _term-token_79)))))))) _loop_73) _port_61 _entities_62 #f _seed_70)) ((lambda (_tmp_72) (if _tmp_72 ((lambda (_name-value_73) (equal? "preserve" (cdr _name-value_73))) _tmp_72) _preserve-ws?_64)) (assoc _xml-space-gi_58 _attributes_67)))))) _expected-content_69)) ((lambda (_elem-gi_70 _attributes_71 _namespaces_72 _expected-content_73 _seed_74) '()) _elem-gi_66 _attributes_67 _namespaces_68 _expected-content_69 _parent-seed_65))))))) _handle-start-tag_59) _start-tag-head_51 _port_52 _entities_54 _namespaces_55 _preserve-ws?_56 _seed_57)))) (_scan-for-significant-prolog-token-2_48 (lambda (_port_51 _elems_52 _entities_53 _namespaces_54 _seed_55) ((lambda (_token_56) (if (eof-object? _token_56) (parser-error _port_51 "XML [22], unexpected EOF") ((lambda (_key_57) (if (if (_eqv?_7 _key_57 'PI) #t #f) ((lambda (_seed_58) (_scan-for-significant-prolog-token-2_48 _port_51 _elems_52 _entities_53 _namespaces_54 _seed_58)) ((lambda (_port_60 _target_61 _seed_62) ((lambda (_key_63) ((lambda (_port_64 _pi-tag_65 _seed_66) (cons (list '*PI* _pi-tag_65 (ssax:read-pi-body-as-string _port_64)) _seed_66)) _port_60 _target_61 _seed_62)) _target_61)) _port_51 (cdr _token_56) _seed_55)) (if (if (_eqv?_7 _key_57 'START) #t #f) (_element-parser_47 (cdr _token_56) _port_51 _elems_52 _entities_53 _namespaces_54 #f ((lambda (_elem-gi_58 _seed_59) _seed_59) (cdr _token_56) _seed_55)) (parser-error _port_51 "XML [22], unexpected markup " _token_56)))) (car _token_56)))) (ssax:scan-Misc _port_51)))) (_scan-for-significant-prolog-token-1_49 (lambda (_port_51 _seed_52) ((lambda (_token_53) (if (eof-object? _token_53) (parser-error _port_51 "XML [22], unexpected EOF") ((lambda (_key_54) (if (if (_eqv?_7 _key_54 'PI) #t #f) ((lambda (_seed_55) (_scan-for-significant-prolog-token-1_49 _port_51 _seed_55)) ((lambda (_port_57 _target_58 _seed_59) ((lambda (_key_60) ((lambda (_port_61 _pi-tag_62 _seed_63) (cons (list '*PI* _pi-tag_62 (ssax:read-pi-body-as-string _port_61)) _seed_63)) _port_57 _target_58 _seed_59)) _target_58)) _port_51 (cdr _token_53) _seed_52)) (if (if (_eqv?_7 _key_54 'DECL) #t #f) (_handle-decl_50 _port_51 (cdr _token_53) _seed_52) (if (if (_eqv?_7 _key_54 'START) #t #f) (call-with-values (lambda () ((lambda (_elem-gi_55 _seed_56) (values #f '() _namespaces_41 _seed_56)) (cdr _token_53) _seed_52)) (lambda (_elems_55 _entities_56 _namespaces_57 _seed_58) (_element-parser_47 (cdr _token_53) _port_51 _elems_55 _entities_56 _namespaces_57 #f _seed_58))) (parser-error _port_51 "XML [22], unexpected markup " _token_53))))) (car _token_53)))) (ssax:scan-Misc _port_51)))) (_handle-decl_50 (lambda (_port_51 _token-head_52 _seed_53) (begin ((lambda (_x_54) (if _x_54 _x_54 (parser-error _port_51 "XML [22], expected DOCTYPE declaration, found " _token-head_52))) (eq? (string->symbol "DOCTYPE") _token-head_52)) (assert-curr-char ssax:S-chars "XML [28], space after DOCTYPE" _port_51) (ssax:skip-S _port_51) ((lambda (_docname_54) ((lambda (_systemid_55) ((lambda (_internal-subset?_56) (call-with-values (lambda () ((lambda (_port_57 _docname_58 _systemid_59 _internal-subset?_60 _seed_61) (begin (when _internal-subset?_60 (ssax:warn _port_57 "Internal DTD subset is not currently handled ") (ssax:skip-internal-dtd _port_57)) (ssax:warn _port_57 "DOCTYPE DECL " _docname_58 " " _systemid_59 " found and skipped") (values #f '() _namespaces_41 _seed_61))) _port_51 _docname_54 _systemid_55 _internal-subset?_56 _seed_53)) (lambda (_elems_57 _entities_58 _namespaces_59 _seed_60) (_scan-for-significant-prolog-token-2_48 _port_51 _elems_57 _entities_58 _namespaces_59 _seed_60)))) (begin (ssax:skip-S _port_51) (eqv? #\[ (assert-curr-char '(#\> #\[) "XML [28], end-of-DOCTYPE" _port_51))))) (if (ssax:ncname-starting-char? (ssax:skip-S _port_51)) (ssax:read-external-id _port_51) #f))) (ssax:read-QName _port_51)))))) (_scan-for-significant-prolog-token-1_49 _port_45 _seed_46))) _port_38 '())))))) (define SSAX:XML->SXML ssax:xml->sxml) (letrec ((_test_44 (lambda (_str_45 _namespace-assig_46 _expected-res_47) (begin (newline) (display "input: ") (write (unesc-string _str_45)) (newline) (display "Result: ") ((lambda (_result_48) (begin (pp _result_48) (assert (equal_? _result_48 _expected-res_47)))) (call-with-input-string (unesc-string _str_45) (lambda (_port_48) (ssax:xml->sxml _port_48 _namespace-assig_46)))))))) (begin (_test_44 "
" '() '(*TOP* (BR))) (_test_44 "

" '() '(*TOP* (BR))) (_test_44 "
" '() '(*TOP* (BR (@ (CLEAR "ALL") (CLASS "Class1"))))) (_test_44 " link itlink &amp;" '() '(*TOP* (A (@ (HREF "URL")) " link " (I "itlink ") " &"))) (_test_44 " link itlink &amp;" '() '(*TOP* (A (@ (xml:space "preserve") (HREF "URL")) " link " (I "itlink ") " &"))) (_test_44 " link itlink &amp;" '() '(*TOP* (A (@ (xml:space "preserve") (HREF "URL")) " link " (I (@ (xml:space "default")) "itlink ") " &"))) (_test_44 "

?

" '() '(*TOP* (P (*PI* pi1 "p1 content ") "?" (*PI* pi2 "pi2? content? ?")))) (_test_44 "

some text 1%n"strong"%r

" '() (_list_25 '*TOP* (_list_25 'P (unesc-string "some text <1%n\"") '(B "strong") (unesc-string "\"%n")))) (_test_44 "

%n]]>]]>

" '() (_list_25 '*TOP* (_list_25 'P (unesc-string "
%n]]>")))) (_test_44 "it's%r%nand that%n%r%n%r%n%n" '() (_list_25 '*TOP* (_list_25 'T1 (_list_25 'T2 (unesc-string "it's%nand that%n"))))) (_test_44 "it's%rand that%n%r%n%r%n%n" '() (_list_25 '*TOP* (_list_25 'T1 (_list_25 'T2 (unesc-string "it's%nand that%n"))))) (_test_44 "%n" '() '(*TOP* (T))) (_test_44 "%n%n 67 %n 95 %n" '() '(*TOP* (*PI* xml "version='1.0'") (WEIGHT (@ (unit "pound")) (NET (@ (certified "certified")) " 67 ") (GROSS " 95 ")))) (_test_44 "

" '() '(*TOP* (URI1:DIV (@ (URI1:B "A") (B "B")) (URI1:P (BR))))) (_test_44 "

" '((UA . "URI1")) '(*TOP* (@ (*NAMESPACES* (UA "URI1"))) (UA:DIV (@ (UA:B "A") (B "B")) (UA:P (BR))))) (_test_44 (string-append "" "" "Baby food" nl "") '() '(*TOP* (x (lineItem (@ (http://ecommerce.org/schema:taxClass "exempt")) "Baby food")))) (_test_44 (string-append "" "" "Baby food" "") '((EDI . "http://ecommerce.org/schema")) '(*TOP* (@ (*NAMESPACES* (EDI "http://ecommerce.org/schema"))) (x (lineItem (@ (EDI:taxClass "exempt")) "Baby food")))) (_test_44 (string-append "" "Cheaper by the Dozen" "1568491379") '() '(*TOP* (urn:loc.gov:books:book (urn:loc.gov:books:title "Cheaper by the Dozen") (urn:ISBN:0-395-36341-6:number "1568491379")))) (_test_44 (string-append "" "" "Cheaper by the Dozen" "1568491379" "" "" "

" "This is a funny book!" "

" "" "") '() '(*TOP* (urn:loc.gov:books:book (urn:loc.gov:books:title "Cheaper by the Dozen") (urn:ISBN:0-395-36341-6:number "1568491379") (urn:loc.gov:books:notes (urn:w3-org-ns:HTML:p "This is a " (urn:w3-org-ns:HTML:i "funny") " book!"))))) (_test_44 (string-append "" "" "" "" "" "" "" "" "" "" "
NameOriginDescription
HuntsmanBath, UK" "
BitterFuggles" "Wonderful hop, light alcohol, good summer beer" "Fragile; excessive variance pub to pub" "
" "
" "") '((html . "http://www.w3.org/TR/REC-html40")) '(*TOP* (@ (*NAMESPACES* (html "http://www.w3.org/TR/REC-html40"))) (Beers (html:table (html:th (html:td "Name") (html:td "Origin") (html:td "Description")) (html:tr (html:td (brandName "Huntsman")) (html:td (origin "Bath, UK")) (html:td (details (class "Bitter") (hop "Fuggles") (pro "Wonderful hop, light alcohol, good summer beer") (con "Fragile; excessive variance pub to pub")))))))) (_test_44 (string-append "" "Layman, A" "33B" "Check Status" "1997-05-24T07:55:00+1") '((HTML . "http://www.w3.org/TR/REC-html40")) '(*TOP* (@ (*NAMESPACES* (HTML "http://www.w3.org/TR/REC-html40"))) (RESERVATION (NAME (@ (HTML:CLASS "largeSansSerif")) "Layman, A") (SEAT (@ (HTML:CLASS "largeMonotype") (CLASS "Y")) "33B") (HTML:A (@ (HREF "/cgi-bin/ResStatus")) "Check Status") (DEPARTURE "1997-05-24T07:55:00+1")))) (_test_44 (string-concatenate/shared (list-intersperse '("" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "") (string #\newline))) '((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (RDFS . "http://www.w3.org/2000/01/rdf-schema#") (ISET . "http://www.w3.org/2001/02/infoset#")) '(*TOP* (@ (*NAMESPACES* (RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (RDFS "http://www.w3.org/2000/01/rdf-schema#") (ISET "http://www.w3.org/2001/02/infoset#"))) (*PI* xml "version='1.0' encoding='utf-8' standalone='yes'") (RDF:RDF (RDFS:Class (@ (ID "Boolean"))) (ISET:Boolean (@ (ID "Boolean.true"))) (ISET:Boolean (@ (ID "Boolean.false"))) (RDFS:Class (@ (ID "InfoItem"))) (RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Document"))) (RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Element"))) (RDFS:Class (@ (RDFS:subClassOf "#InfoItem") (ID "Attribute"))) (RDFS:Class (@ (RDFS:subClassOf "http://www.w3.org/1999/02/22-rdf-syntax-ns#Bag") (ID "InfoItemSet"))) (RDFS:Class (@ (RDFS:subClassOf "#InfoItemSet") (ID "AttributeSet"))) (RDFS:Property (@ (ID "allDeclarationsProcessed")) (RDFS:domain (@ (resource "#Document"))) (RDFS:range (@ (resource "#Boolean")))) (RDFS:Property (@ (ID "attributes")) (RDFS:domain (@ (resource "#Element"))) (RDFS:range (@ (resource "#AttributeSet"))))))) (_test_44 (string-concatenate/shared (list-intersperse '("" "" "Daemon News Mall" "http://mall.daemonnews.org/" "Central source for all your BSD needs" "" "" "Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95" "http://mall.daemonnews.org/?page=shop/flypage&product_id=880" "" "" "The Design and Implementation of the 4.4BSD Operating System $54.95" "http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761" "" "") (string #\newline))) '((RDF . "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (RSS . "http://my.netscape.com/rdf/simple/0.9/") (ISET . "http://www.w3.org/2001/02/infoset#")) '(*TOP* (@ (*NAMESPACES* (RDF "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (RSS "http://my.netscape.com/rdf/simple/0.9/") (ISET "http://www.w3.org/2001/02/infoset#"))) (*PI* xml "version='1.0'") (RDF:RDF (RSS:channel (RSS:title "Daemon News Mall") (RSS:link "http://mall.daemonnews.org/") (RSS:description "Central source for all your BSD needs")) (RSS:item (RSS:title "Daemon News Jan/Feb Issue NOW Available! Subscribe $24.95") (RSS:link "http://mall.daemonnews.org/?page=shop/flypage&product_id=880")) (RSS:item (RSS:title "The Design and Implementation of the 4.4BSD Operating System $54.95") (RSS:link "http://mall.daemonnews.org/?page=shop/flypage&product_id=912&category_id=1761"))))) (_test_44 (string-concatenate/shared (list-intersperse '("" "" "111730Z 111818" "" "31010KT P6SM FEW030" "" "" "29016KT P6SM FEW040" "" "" "29010KT P6SM SCT200" "VRB05KT" "" "") (string #\newline))) '() '(*TOP* (Forecasts (@ (TStamp "958082142")) (TAF (@ (TStamp "958066200") (SName "KMRY, MONTEREY PENINSULA") (LatLon "36.583, -121.850") (BId "724915")) (VALID (@ (TRange "958068000, 958154400")) "111730Z 111818") (PERIOD (@ (TRange "958068000, 958078800")) (PREVAILING "31010KT P6SM FEW030")) (PERIOD (@ (Title "FM2100") (TRange "958078800, 958104000")) (PREVAILING "29016KT P6SM FEW040")) (PERIOD (@ (Title "FM0400") (TRange "958104000, 958154400")) (PREVAILING "29010KT P6SM SCT200") (VAR (@ (Title "BECMG 0708") (TRange "958114800, 958118400")) "VRB05KT")))))))) (newline) (display "All tests passed") (newline) guile-lib-0.2.1/src/sxml/upstream/SXPath-old.scm0000664000076400007640000012145011137322547016367 00000000000000; XML processing in Scheme ; SXPath -- SXML Query Language ; ; SXPath is a query language for SXML, an instance of XML Information ; set (Infoset) in the form of s-expressions. See SSAX.scm for the ; definition of SXML and more details. SXPath is also a translation into ; Scheme of an XML Path Language, XPath: ; http://www.w3.org/TR/xpath ; XPath and SXPath describe means of selecting a set of Infoset's items ; or their properties. ; ; To facilitate queries, XPath maps the XML Infoset into an explicit ; tree, and introduces important notions of a location path and a ; current, context node. A location path denotes a selection of a set of ; nodes relative to a context node. Any XPath tree has a distinguished, ; root node -- which serves as the context node for absolute location ; paths. Location path is recursively defined as a location step joined ; with a location path. A location step is a simple query of the ; database relative to a context node. A step may include expressions ; that further filter the selected set. Each node in the resulting set ; is used as a context node for the adjoining location path. The result ; of the step is a union of the sets returned by the latter location ; paths. ; ; The SXML representation of the XML Infoset (see SSAX.scm) is rather ; suitable for querying as it is. Bowing to the XPath specification, ; we will refer to SXML information items as 'Nodes': ; ::= | | ; | "text string" | ; This production can also be described as ; ::= (name . ) | "text string" ; An (ordered) set of nodes is just a list of the constituent nodes: ; ::= ( ...) ; Nodesets, and Nodes other than text strings are both lists. A ; however is either an empty list, or a list whose head is not ; a symbol. A symbol at the head of a node is either an XML name (in ; which case it's a tag of an XML element), or an administrative name ; such as '@'. This uniform list representation makes processing rather ; simple and elegant, while avoiding confusion. The multi-branch tree ; structure formed by the mutually-recursive datatypes and ; lends itself well to processing by functional languages. ; ; A location path is in fact a composite query over an XPath tree or ; its branch. A singe step is a combination of a projection, selection ; or a transitive closure. Multiple steps are combined via join and ; union operations. This insight allows us to _elegantly_ implement ; XPath as a sequence of projection and filtering primitives -- ; converters -- joined by _combinators_. Each converter takes a node ; and returns a nodeset which is the result of the corresponding query ; relative to that node. A converter can also be called on a set of ; nodes. In that case it returns a union of the corresponding queries over ; each node in the set. The union is easily implemented as a list ; append operation as all nodes in a SXML tree are considered ; distinct, by XPath conventions. We also preserve the order of the ; members in the union. Query combinators are high-order functions: ; they take converter(s) (which is a Node|Nodeset -> Nodeset function) ; and compose or otherwise combine them. We will be concerned with ; only relative location paths [XPath]: an absolute location path is a ; relative path applied to the root node. ; ; Similarly to XPath, SXPath defines full and abbreviated notations ; for location paths. In both cases, the abbreviated notation can be ; mechanically expanded into the full form by simple rewriting ; rules. In case of SXPath the corresponding rules are given as ; comments to a sxpath function, below. The regression test suite at ; the end of this file shows a representative sample of SXPaths in ; both notations, juxtaposed with the corresponding XPath ; expressions. Most of the samples are borrowed literally from the ; XPath specification, while the others are adjusted for our running ; example, tree1. ; ; To do: ; Rename filter to node-filter or ns-filter ; Use ;=== for chapters, ;--- for sections, and ;^^^ for end sections ; ; $Id: SXPath-old.scm,v 1.4 2004/07/07 16:02:31 sperber Exp $ ; See http://pobox.com/~oleg/ftp/Scheme/myenv.scm ; See http://pobox.com/~oleg/ftp/Scheme/myenv-scm.scm ; See http://pobox.com/~oleg/ftp/Scheme/myenv-bigloo.scm ;(module SXPath ; (include "myenv-bigloo.scm")) ; For use with Bigloo 2.2b ;(load "myenv-scm.scm") ; For use with SCM v5d2 ;(include "myenv.scm") ; For use with Gambit-C 3.0 (define (nodeset? x) (or (and (pair? x) (not (symbol? (car x)))) (null? x))) ;------------------------- ; Basic converters and applicators ; A converter is a function ; type Converter = Node|Nodeset -> Nodeset ; A converter can also play a role of a predicate: in that case, if a ; converter, applied to a node or a nodeset, yields a non-empty ; nodeset, the converter-predicate is deemed satisfied. Throughout ; this file a nil nodeset is equivalent to #f in denoting a failure. ; The following function implements a 'Node test' as defined in ; Sec. 2.3 of XPath document. A node test is one of the components of a ; location step. It is also a converter-predicate in SXPath. ; ; The function node-typeof? takes a type criterion and returns a function, ; which, when applied to a node, will tell if the node satisfies ; the test. ; node-typeof? :: Crit -> Node -> Boolean ; ; The criterion 'crit' is a symbol, one of the following: ; id - tests if the Node has the right name (id) ; @ - tests if the Node is an ; * - tests if the Node is an ; *text* - tests if the Node is a text node ; *PI* - tests if the Node is a PI node ; *any* - #t for any type of Node (define (node-typeof? crit) (lambda (node) (case crit ((*) (and (pair? node) (not (memq (car node) '(@ *PI*))))) ((*any*) #t) ((*text*) (string? node)) (else (and (pair? node) (eq? crit (car node)))) ))) ; Curried equivalence converter-predicates (define (node-eq? other) (lambda (node) (eq? other node))) (define (node-equal? other) (lambda (node) (equal? other node))) ; node-pos:: N -> Nodeset -> Nodeset, or ; node-pos:: N -> Converter ; Select the N'th element of a Nodeset and return as a singular Nodeset; ; Return an empty nodeset if the Nth element does not exist. ; ((node-pos 1) Nodeset) selects the node at the head of the Nodeset, ; if exists; ((node-pos 2) Nodeset) selects the Node after that, if ; exists. ; N can also be a negative number: in that case the node is picked from ; the tail of the list. ; ((node-pos -1) Nodeset) selects the last node of a non-empty nodeset; ; ((node-pos -2) Nodeset) selects the last but one node, if exists. (define (node-pos n) (lambda (nodeset) (cond ((not (nodeset? nodeset)) '()) ((null? nodeset) nodeset) ((eqv? n 1) (list (car nodeset))) ((negative? n) ((node-pos (+ n 1 (length nodeset))) nodeset)) (else (assert (positive? n)) ((node-pos (dec n)) (cdr nodeset)))))) ; filter:: Converter -> Converter ; A filter applicator, which introduces a filtering context. The argument ; converter is considered a predicate, with either #f or nil result meaning ; failure. (define (filter pred?) (lambda (lst) ; a nodeset or a node (will be converted to a singleton nset) (let loop ((lst (if (nodeset? lst) lst (list lst))) (res '())) (if (null? lst) (reverse res) (let ((pred-result (pred? (car lst)))) (loop (cdr lst) (if (and pred-result (not (null? pred-result))) (cons (car lst) res) res))))))) ; take-until:: Converter -> Converter, or ; take-until:: Pred -> Node|Nodeset -> Nodeset ; Given a converter-predicate and a nodeset, apply the predicate to ; each element of the nodeset, until the predicate yields anything but #f or ; nil. Return the elements of the input nodeset that have been processed ; till that moment (that is, which fail the predicate). ; take-until is a variation of the filter above: take-until passes ; elements of an ordered input set till (but not including) the first ; element that satisfies the predicate. ; The nodeset returned by ((take-until (not pred)) nset) is a subset -- ; to be more precise, a prefix -- of the nodeset returned by ; ((filter pred) nset) (define (take-until pred?) (lambda (lst) ; a nodeset or a node (will be converted to a singleton nset) (let loop ((lst (if (nodeset? lst) lst (list lst)))) (if (null? lst) lst (let ((pred-result (pred? (car lst)))) (if (and pred-result (not (null? pred-result))) '() (cons (car lst) (loop (cdr lst))))) )))) ; take-after:: Converter -> Converter, or ; take-after:: Pred -> Node|Nodeset -> Nodeset ; Given a converter-predicate and a nodeset, apply the predicate to ; each element of the nodeset, until the predicate yields anything but #f or ; nil. Return the elements of the input nodeset that have not been processed: ; that is, return the elements of the input nodeset that follow the first ; element that satisfied the predicate. ; take-after along with take-until partition an input nodeset into three ; parts: the first element that satisfies a predicate, all preceding ; elements and all following elements. (define (take-after pred?) (lambda (lst) ; a nodeset or a node (will be converted to a singleton nset) (let loop ((lst (if (nodeset? lst) lst (list lst)))) (if (null? lst) lst (let ((pred-result (pred? (car lst)))) (if (and pred-result (not (null? pred-result))) (cdr lst) (loop (cdr lst)))) )))) ; Apply proc to each element of lst and return the list of results. ; if proc returns a nodeset, splice it into the result ; ; From another point of view, map-union is a function Converter->Converter, ; which places an argument-converter in a joining context. (define (map-union proc lst) (if (null? lst) lst (let ((proc-res (proc (car lst)))) ((if (nodeset? proc-res) append cons) proc-res (map-union proc (cdr lst)))))) ; node-reverse :: Converter, or ; node-reverse:: Node|Nodeset -> Nodeset ; Reverses the order of nodes in the nodeset ; This basic converter is needed to implement a reverse document order ; (see the XPath Recommendation). (define node-reverse (lambda (node-or-nodeset) (if (not (nodeset? node-or-nodeset)) (list node-or-nodeset) (reverse node-or-nodeset)))) ; node-trace:: String -> Converter ; (node-trace title) is an identity converter. In addition it prints out ; a node or nodeset it is applied to, prefixed with the 'title'. ; This converter is very useful for debugging. (define (node-trace title) (lambda (node-or-nodeset) (cout nl "-->") (display title) (display " :") (pretty-print node-or-nodeset) node-or-nodeset)) ;------------------------- ; Converter combinators ; ; Combinators are higher-order functions that transmogrify a converter ; or glue a sequence of converters into a single, non-trivial ; converter. The goal is to arrive at converters that correspond to ; XPath location paths. ; ; From a different point of view, a combinator is a fixed, named ; _pattern_ of applying converters. Given below is a complete set of ; such patterns that together implement XPath location path ; specification. As it turns out, all these combinators can be built ; from a small number of basic blocks: regular functional composition, ; map-union and filter applicators, and the nodeset union. ; select-kids:: Pred -> Node -> Nodeset ; Given a Node, return an (ordered) subset its children that satisfy ; the Pred (a converter, actually) ; select-kids:: Pred -> Nodeset -> Nodeset ; The same as above, but select among children of all the nodes in ; the Nodeset ; ; More succinctly, the signature of this function is ; select-kids:: Converter -> Converter (define (select-kids test-pred?) (lambda (node) ; node or node-set (cond ((null? node) node) ((not (pair? node)) '()) ; No children ((symbol? (car node)) ((filter test-pred?) (cdr node))) ; it's a single node (else (map-union (select-kids test-pred?) node))))) ; node-self:: Pred -> Node -> Nodeset, or ; node-self:: Converter -> Converter ; Similar to select-kids but apply to the Node itself rather ; than to its children. The resulting Nodeset will contain either one ; component, or will be empty (if the Node failed the Pred). (define node-self filter) ; node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or ; node-join:: [Converter] -> Converter ; join the sequence of location steps or paths as described ; in the title comments above. (define (node-join . selectors) (lambda (nodeset) ; Nodeset or node (let loop ((nodeset nodeset) (selectors selectors)) (if (null? selectors) nodeset (loop (if (nodeset? nodeset) (map-union (car selectors) nodeset) ((car selectors) nodeset)) (cdr selectors)))))) ; node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or ; node-reduce:: [Converter] -> Converter ; A regular functional composition of converters. ; From a different point of view, ; ((apply node-reduce converters) nodeset) ; is equivalent to ; (foldl apply nodeset converters) ; i.e., folding, or reducing, a list of converters with the nodeset ; as a seed. (define (node-reduce . converters) (lambda (nodeset) ; Nodeset or node (let loop ((nodeset nodeset) (converters converters)) (if (null? converters) nodeset (loop ((car converters) nodeset) (cdr converters)))))) ; node-or:: [Converter] -> Converter ; This combinator applies all converters to a given node and ; produces the union of their results. ; This combinator corresponds to a union, '|' operation for XPath ; location paths. ; (define (node-or . converters) ; (lambda (node-or-nodeset) ; (if (null? converters) node-or-nodeset ; (append ; ((car converters) node-or-nodeset) ; ((apply node-or (cdr converters)) node-or-nodeset))))) ; More optimal implementation follows (define (node-or . converters) (lambda (node-or-nodeset) (let loop ((result '()) (converters converters)) (if (null? converters) result (loop (append result (or ((car converters) node-or-nodeset) '())) (cdr converters)))))) ; node-closure:: Converter -> Converter ; Select all _descendants_ of a node that satisfy a converter-predicate. ; This combinator is similar to select-kids but applies to ; grand... children as well. ; This combinator implements the "descendant::" XPath axis ; Conceptually, this combinator can be expressed as ; (define (node-closure f) ; (node-or ; (select-kids f) ; (node-reduce (select-kids (node-typeof? '*)) (node-closure f)))) ; This definition, as written, looks somewhat like a fixpoint, and it ; will run forever. It is obvious however that sooner or later ; (select-kids (node-typeof? '*)) will return an empty nodeset. At ; this point further iterations will no longer affect the result and ; can be stopped. (define (node-closure test-pred?) (lambda (node) ; Nodeset or node (let loop ((parent node) (result '())) (if (null? parent) result (loop ((select-kids (node-typeof? '*)) parent) (append result ((select-kids test-pred?) parent))) )))) ; node-parent:: RootNode -> Converter ; (node-parent rootnode) yields a converter that returns a parent of a ; node it is applied to. If applied to a nodeset, it returns the list ; of parents of nodes in the nodeset. The rootnode does not have ; to be the root node of the whole SXML tree -- it may be a root node ; of a branch of interest. ; Given the notation of Philip Wadler's paper on semantics of XSLT, ; parent(x) = { y | y=subnode*(root), x=subnode(y) } ; Therefore, node-parent is not the fundamental converter: it can be ; expressed through the existing ones. Yet node-parent is a rather ; convenient converter. It corresponds to a parent:: axis of SXPath. ; Note that the parent:: axis can be used with an attribute node as well! (define (node-parent rootnode) (lambda (node) ; Nodeset or node (if (nodeset? node) (map-union (node-parent rootnode) node) (let ((pred (node-or (node-reduce (node-self (node-typeof? '*)) (select-kids (node-eq? node))) (node-join (select-kids (node-typeof? '@)) (select-kids (node-eq? node)))))) ((node-or (node-self pred) (node-closure pred)) rootnode))))) ;------------------------- ; Evaluate an abbreviated SXPath ; sxpath:: AbbrPath -> Converter, or ; sxpath:: AbbrPath -> Node|Nodeset -> Nodeset ; AbbrPath is a list. It is translated to the full SXPath according ; to the following rewriting rules ; (sxpath '()) -> (node-join) ; (sxpath '(path-component ...)) -> ; (node-join (sxpath1 path-component) (sxpath '(...))) ; (sxpath1 '//) -> (node-or ; (node-self (node-typeof? '*any*)) ; (node-closure (node-typeof? '*any*))) ; (sxpath1 '(equal? x)) -> (select-kids (node-equal? x)) ; (sxpath1 '(eq? x)) -> (select-kids (node-eq? x)) ; (sxpath1 ?symbol) -> (select-kids (node-typeof? ?symbol) ; (sxpath1 procedure) -> procedure ; (sxpath1 '(?symbol ...)) -> (sxpath1 '((?symbol) ...)) ; (sxpath1 '(path reducer ...)) -> ; (node-reduce (sxpath path) (sxpathr reducer) ...) ; (sxpathr number) -> (node-pos number) ; (sxpathr path-filter) -> (filter (sxpath path-filter)) (define (sxpath path) (lambda (nodeset) (let loop ((nodeset nodeset) (path path)) (cond ((null? path) nodeset) ((nodeset? nodeset) (map-union (sxpath path) nodeset)) ((procedure? (car path)) (loop ((car path) nodeset) (cdr path))) ((eq? '// (car path)) (loop ((if (nodeset? nodeset) append cons) nodeset ((node-closure (node-typeof? '*any*)) nodeset)) (cdr path))) ((symbol? (car path)) (loop ((select-kids (node-typeof? (car path))) nodeset) (cdr path))) ((and (pair? (car path)) (eq? 'equal? (caar path))) (loop ((select-kids (apply node-equal? (cdar path))) nodeset) (cdr path))) ((and (pair? (car path)) (eq? 'eq? (caar path))) (loop ((select-kids (apply node-eq? (cdar path))) nodeset) (cdr path))) ((pair? (car path)) (let reducer ((nodeset (if (symbol? (caar path)) ((select-kids (node-typeof? (caar path))) nodeset) (loop nodeset (caar path)))) (reducing-path (cdar path))) (cond ((null? reducing-path) (loop nodeset (cdr path))) ((number? (car reducing-path)) (reducer ((node-pos (car reducing-path)) nodeset) (cdr reducing-path))) (else (reducer ((filter (sxpath (car reducing-path))) nodeset) (cdr reducing-path)))))) (else (error "Invalid path step: " (car path))) )))) ;------------------------------------------------------------------------ ; Sample XPath/SXPath expressions: regression test suite for the ; implementation above. ; A running example (define tree1 '(html (head (title "Slides")) (body (p (@ (align "center")) (table (@ (style "font-size: x-large")) (tr (td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ") (td " slides + transition")) (tr (td) (td (@ (align "center")) " = ") (td " data + control")) (tr (td) (td (@ (align "center")) " = ") (td " programs")))) (ul (li (a (@ (href "slides/slide0001.gif")) "Introduction")) (li (a (@ (href "slides/slide0010.gif")) "Summary"))) ))) ; Example from a posting "Re: DrScheme and XML", ; Shriram Krishnamurthi, comp.lang.scheme, Nov. 26. 1999. ; http://www.deja.com/getdoc.xp?AN=553507805 (define tree3 '(poem (@ (title "The Lovesong of J. Alfred Prufrock") (poet "T. S. Eliot")) (stanza (line "Let us go then, you and I,") (line "When the evening is spread out against the sky") (line "Like a patient etherized upon a table:")) (stanza (line "In the room the women come and go") (line "Talking of Michaelangelo.")))) ; Validation Test harness (define-syntax run-test (syntax-rules (define) ((run-test "scan-exp" (define vars body)) (define vars (run-test "scan-exp" body))) ((run-test "scan-exp" ?body) (letrec-syntax ((scan-exp ; (scan-exp body k) (syntax-rules (quote quasiquote !) ((scan-exp '() (k-head ! . args)) (k-head '() . args)) ((scan-exp (quote (hd . tl)) k) (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k))) ((scan-exp (quasiquote (hd . tl)) k) (scan-lit-lst (hd . tl) (do-wrap ! quasiquote k))) ((scan-exp (quote x) (k-head ! . args)) (k-head (if (string? (quote x)) (string->symbol (quote x)) (quote x)) . args)) ((scan-exp (hd . tl) k) (scan-exp hd (do-tl ! scan-exp tl k))) ((scan-exp x (k-head ! . args)) (k-head x . args)))) (do-tl (syntax-rules (!) ((do-tl processed-hd fn () (k-head ! . args)) (k-head (processed-hd) . args)) ((do-tl processed-hd fn old-tl k) (fn old-tl (do-cons ! processed-hd k))))) (do-cons (syntax-rules (!) ((do-cons processed-tl processed-hd (k-head ! . args)) (k-head (processed-hd . processed-tl) . args)))) (do-wrap (syntax-rules (!) ((do-wrap val fn (k-head ! . args)) (k-head (fn val) . args)))) (do-finish (syntax-rules () ((do-finish new-body) new-body))) (scan-lit-lst ; scan literal list (syntax-rules (quote unquote unquote-splicing !) ((scan-lit-lst '() (k-head ! . args)) (k-head '() . args)) ((scan-lit-lst (quote (hd . tl)) k) (do-tl quote scan-lit-lst ((hd . tl)) k)) ((scan-lit-lst (unquote x) k) (scan-exp x (do-wrap ! unquote k))) ((scan-lit-lst (unquote-splicing x) k) (scan-exp x (do-wrap ! unquote-splicing k))) ((scan-lit-lst (quote x) (k-head ! . args)) (k-head ,(if (string? (quote x)) (string->symbol (quote x)) (quote x)) . args)) ((scan-lit-lst (hd . tl) k) (scan-lit-lst hd (do-tl ! scan-lit-lst tl k))) ((scan-lit-lst x (k-head ! . args)) (k-head x . args)))) ) (scan-exp ?body (do-finish !)))) ((run-test body ...) (begin (run-test "scan-exp" body) ...)) )) ; Overwrite the above macro to switch the tests off ; (define-macro (run-test selector node expected-result) #f) ; Location path, full form: child::para ; Location path, abbreviated form: para ; selects the para element children of the context node (let ((tree '(elem (@) (para (@) "para") (br (@)) "cdata" (para (@) "second par")) ) (expected '((para (@) "para") (para (@) "second par"))) ) (run-test (select-kids (node-typeof? 'para)) tree expected) (run-test (sxpath '(para)) tree expected) ) ; Location path, full form: child::* ; Location path, abbreviated form: * ; selects all element children of the context node (let ((tree '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")) ) (expected '((para (@) "para") (br (@)) (para "second par"))) ) (run-test (select-kids (node-typeof? '*)) tree expected) (run-test (sxpath '(*)) tree expected) ) ; Location path, full form: child::text() ; Location path, abbreviated form: text() ; selects all text node children of the context node (let ((tree '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")) ) (expected '("cdata")) ) (run-test (select-kids (node-typeof? '*text*)) tree expected) (run-test (sxpath '(*text*)) tree expected) ) ; Location path, full form: child::node() ; Location path, abbreviated form: node() ; selects all the children of the context node, whatever their node type (let* ((tree '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par")) ) (expected (cdr tree)) ) (run-test (select-kids (node-typeof? '*any*)) tree expected) (run-test (sxpath '(*any*)) tree expected) ) ; Location path, full form: child::*/child::para ; Location path, abbreviated form: */para ; selects all para grandchildren of the context node (let ((tree '(elem (@) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para "third para"))) ) (expected '((para "third para"))) ) (run-test (node-join (select-kids (node-typeof? '*)) (select-kids (node-typeof? 'para))) tree expected) (run-test (sxpath '(* para)) tree expected) ) ; Location path, full form: attribute::name ; Location path, abbreviated form: @name ; selects the 'name' attribute of the context node (let ((tree '(elem (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para (@) "second par") (div (@ (name "aa")) (para (@) "third para"))) ) (expected '((name "elem"))) ) (run-test (node-join (select-kids (node-typeof? '@)) (select-kids (node-typeof? 'name))) tree expected) (run-test (sxpath '(@ name)) tree expected) ) ; Location path, full form: attribute::* ; Location path, abbreviated form: @* ; selects all the attributes of the context node (let ((tree '(elem (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para (@) "third para"))) ) (expected '((name "elem") (id "idz"))) ) (run-test (node-join (select-kids (node-typeof? '@)) (select-kids (node-typeof? '*))) tree expected) (run-test (sxpath '(@ *)) tree expected) ) ; Location path, full form: descendant::para ; Location path, abbreviated form: .//para ; selects the para element descendants of the context node (let ((tree '(elem (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para (@) "third para"))) ) (expected '((para (@) "para") (para "second par") (para (@) "third para"))) ) (run-test (node-closure (node-typeof? 'para)) tree expected) (run-test (sxpath '(// para)) tree expected) ) ; Location path, full form: self::para ; Location path, abbreviated form: _none_ ; selects the context node if it is a para element; otherwise selects nothing (let ((tree '(elem (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para (@) "third para"))) ) ) (run-test (node-self (node-typeof? 'para)) tree '()) (run-test (node-self (node-typeof? 'elem)) tree (list tree)) ) ; Location path, full form: descendant-or-self::node() ; Location path, abbreviated form: // ; selects the context node, all the children (including attribute nodes) ; of the context node, and all the children of all the (element) ; descendants of the context node. ; This is _almost_ a powerset of the context node. (let* ((tree '(para (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para (@) "third para"))) ) (expected (cons tree (append (cdr tree) '((@) "para" (@) "second par" (@ (name "aa")) (para (@) "third para") (@) "third para")))) ) (run-test (node-or (node-self (node-typeof? '*any*)) (node-closure (node-typeof? '*any*))) tree expected) (run-test (sxpath '(//)) tree expected) ) ; Location path, full form: ancestor::div ; Location path, abbreviated form: _none_ ; selects all div ancestors of the context node ; This Location expression is equivalent to the following: ; /descendant-or-self::div[descendant::node() = curr_node] ; This shows that the ancestor:: axis is actually redundant. Still, ; it can be emulated as the following SXPath expression demonstrates. ; The insight behind "ancestor::div" -- selecting all "div" ancestors ; of the current node -- is ; S[ancestor::div] context_node = ; { y | y=subnode*(root), context_node=subnode(subnode*(y)), ; isElement(y), name(y) = "div" } ; We observe that ; { y | y=subnode*(root), pred(y) } ; can be expressed in SXPath as ; ((node-or (node-self pred) (node-closure pred)) root-node) ; The composite predicate 'isElement(y) & name(y) = "div"' corresponds to ; (node-self (node-typeof? 'div)) in SXPath. Finally, filter ; context_node=subnode(subnode*(y)) is tantamount to ; (node-closure (node-eq? context-node)), whereas node-reduce denotes the ; the composition of converters-predicates in the filtering context. (let* ((root '(div (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para (@) "second par") (div (@ (name "aa")) (para (@) "third para")))) (context-node ; /descendant::any()[child::text() == "third para"] (car ((node-closure (select-kids (node-equal? "third para"))) root))) (pred (node-reduce (node-self (node-typeof? 'div)) (node-closure (node-eq? context-node)) )) ) (run-test (node-or (node-self pred) (node-closure pred)) root (cons root '((div (@ (name "aa")) (para (@) "third para"))))) ) ; Location path, full form: child::div/descendant::para ; Location path, abbreviated form: div//para ; selects the para element descendants of the div element ; children of the context node (let ((tree '(elem (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para (@) "third para") (div (para "fourth para")))) ) (expected '((para (@) "third para") (para "fourth para"))) ) (run-test (node-join (select-kids (node-typeof? 'div)) (node-closure (node-typeof? 'para))) tree expected) (run-test (sxpath '(div // para)) tree expected) ) ; Location path, full form: /descendant::olist/child::item ; Location path, abbreviated form: //olist/item ; selects all the item elements that have an olist parent (which is not root) ; and that are in the same document as the context node ; See the following test. ; Location path, full form: /descendant::td/attribute::align ; Location path, abbreviated form: //td/@align ; Selects 'align' attributes of all 'td' elements in tree1 (let ((tree tree1) (expected '((align "right") (align "center") (align "center") (align "center")) )) (run-test (node-join (node-closure (node-typeof? 'td)) (select-kids (node-typeof? '@)) (select-kids (node-typeof? 'align))) tree expected) (run-test (sxpath '(// td @ align)) tree expected) ) ; Location path, full form: /descendant::td[attribute::align] ; Location path, abbreviated form: //td[@align] ; Selects all td elements that have an attribute 'align' in tree1 (let ((tree tree1) (expected '((td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ") (td (@ (align "center")) " = ") (td (@ (align "center")) " = ")) )) (run-test (node-reduce (node-closure (node-typeof? 'td)) (filter (node-join (select-kids (node-typeof? '@)) (select-kids (node-typeof? 'align))))) tree expected) (run-test (sxpath `(// td ,(node-self (sxpath '(@ align))))) tree expected) (run-test (sxpath '(// (td (@ align)))) tree expected) (run-test (sxpath '(// ((td) (@ align)))) tree expected) ; note! (sxpath ...) is a converter. Therefore, it can be used ; as any other converter, for example, in the full-form SXPath. ; Thus we can mix the full and abbreviated form SXPath's freely. (run-test (node-reduce (node-closure (node-typeof? 'td)) (filter (sxpath '(@ align)))) tree expected) ) ; Location path, full form: /descendant::td[attribute::align = "right"] ; Location path, abbreviated form: //td[@align = "right"] ; Selects all td elements that have an attribute align = "right" in tree1 (let ((tree tree1) (expected '((td (@ (align "right")) "Talks ")) )) (run-test (node-reduce (node-closure (node-typeof? 'td)) (filter (node-join (select-kids (node-typeof? '@)) (select-kids (node-equal? '(align "right")))))) tree expected) (run-test (sxpath '(// (td (@ (equal? (align "right")))))) tree expected) ) ; Location path, full form: child::para[position()=1] ; Location path, abbreviated form: para[1] ; selects the first para child of the context node (let ((tree '(elem (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para (@) "third para"))) ) (expected '((para (@) "para")) )) (run-test (node-reduce (select-kids (node-typeof? 'para)) (node-pos 1)) tree expected) (run-test (sxpath '((para 1))) tree expected) ) ; Location path, full form: child::para[position()=last()] ; Location path, abbreviated form: para[last()] ; selects the last para child of the context node (let ((tree '(elem (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para (@) "third para"))) ) (expected '((para "second par")) )) (run-test (node-reduce (select-kids (node-typeof? 'para)) (node-pos -1)) tree expected) (run-test (sxpath '((para -1))) tree expected) ) ; Illustrating the following Note of Sec 2.5 of XPath: ; "NOTE: The location path //para[1] does not mean the same as the ; location path /descendant::para[1]. The latter selects the first ; descendant para element; the former selects all descendant para ; elements that are the first para children of their parents." (let ((tree '(elem (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para (@) "third para"))) ) ) (run-test (node-reduce ; /descendant::para[1] in SXPath (node-closure (node-typeof? 'para)) (node-pos 1)) tree '((para (@) "para"))) (run-test (sxpath '(// (para 1))) tree '((para (@) "para") (para (@) "third para"))) ) ; Location path, full form: parent::node() ; Location path, abbreviated form: .. ; selects the parent of the context node. The context node may be ; an attribute node! ; For the last test: ; Location path, full form: parent::*/attribute::name ; Location path, abbreviated form: ../@name ; Selects the name attribute of the parent of the context node (let* ((tree '(elem (@ (name "elem") (id "idz")) (para (@) "para") (br (@)) "cdata" (para "second par") (div (@ (name "aa")) (para (@) "third para"))) ) (para1 ; the first para node (car ((sxpath '(para)) tree))) (para3 ; the third para node (car ((sxpath '(div para)) tree))) (div ; div node (car ((sxpath '(// div)) tree))) ) (run-test (node-parent tree) para1 (list tree)) (run-test (node-parent tree) para3 (list div)) (run-test ; checking the parent of an attribute node (node-parent tree) ((sxpath '(@ name)) div) (list div)) (run-test (node-join (node-parent tree) (select-kids (node-typeof? '@)) (select-kids (node-typeof? 'name))) para3 '((name "aa"))) (run-test (sxpath `(,(node-parent tree) @ name)) para3 '((name "aa"))) ) ; Location path, full form: following-sibling::chapter[position()=1] ; Location path, abbreviated form: none ; selects the next chapter sibling of the context node ; The path is equivalent to ; let cnode = context-node ; in ; parent::* / child::chapter [take-after node_eq(self::*,cnode)] ; [position()=1] (let* ((tree '(document (preface "preface") (chapter (@ (id "one")) "Chap 1 text") (chapter (@ (id "two")) "Chap 2 text") (chapter (@ (id "three")) "Chap 3 text") (chapter (@ (id "four")) "Chap 4 text") (epilogue "Epilogue text") (appendix (@ (id "A")) "App A text") (References "References")) ) (a-node ; to be used as a context node (car ((sxpath '(// (chapter (@ (equal? (id "two")))))) tree))) (expected '((chapter (@ (id "three")) "Chap 3 text"))) ) (run-test (node-reduce (node-join (node-parent tree) (select-kids (node-typeof? 'chapter))) (take-after (node-eq? a-node)) (node-pos 1) ) a-node expected) ) ; preceding-sibling::chapter[position()=1] ; selects the previous chapter sibling of the context node ; The path is equivalent to ; let cnode = context-node ; in ; parent::* / child::chapter [take-until node_eq(self::*,cnode)] ; [position()=-1] (let* ((tree '(document (preface "preface") (chapter (@ (id "one")) "Chap 1 text") (chapter (@ (id "two")) "Chap 2 text") (chapter (@ (id "three")) "Chap 3 text") (chapter (@ (id "four")) "Chap 4 text") (epilogue "Epilogue text") (appendix (@ (id "A")) "App A text") (References "References")) ) (a-node ; to be used as a context node (car ((sxpath '(// (chapter (@ (equal? (id "three")))))) tree))) (expected '((chapter (@ (id "two")) "Chap 2 text"))) ) (run-test (node-reduce (node-join (node-parent tree) (select-kids (node-typeof? 'chapter))) (take-until (node-eq? a-node)) (node-pos -1) ) a-node expected) ) ; /descendant::figure[position()=42] ; selects the forty-second figure element in the document ; See the next example, which is more general. ; Location path, full form: ; child::table/child::tr[position()=2]/child::td[position()=3] ; Location path, abbreviated form: table/tr[2]/td[3] ; selects the third td of the second tr of the table (let ((tree ((node-closure (node-typeof? 'p)) tree1)) (expected '((td " data + control")) )) (run-test (node-join (select-kids (node-typeof? 'table)) (node-reduce (select-kids (node-typeof? 'tr)) (node-pos 2)) (node-reduce (select-kids (node-typeof? 'td)) (node-pos 3))) tree expected) (run-test (sxpath '(table (tr 2) (td 3))) tree expected) ) ; Location path, full form: ; child::para[attribute::type='warning'][position()=5] ; Location path, abbreviated form: para[@type='warning'][5] ; selects the fifth para child of the context node that has a type ; attribute with value warning (let ((tree '(chapter (para "para1") (para (@ (type "warning")) "para 2") (para (@ (type "warning")) "para 3") (para (@ (type "warning")) "para 4") (para (@ (type "warning")) "para 5") (para (@ (type "warning")) "para 6")) ) (expected '((para (@ (type "warning")) "para 6")) )) (run-test (node-reduce (select-kids (node-typeof? 'para)) (filter (node-join (select-kids (node-typeof? '@)) (select-kids (node-equal? '(type "warning"))))) (node-pos 5)) tree expected) (run-test (sxpath '( (((para (@ (equal? (type "warning"))))) 5 ) )) tree expected) (run-test (sxpath '( (para (@ (equal? (type "warning"))) 5 ) )) tree expected) ) ; Location path, full form: ; child::para[position()=5][attribute::type='warning'] ; Location path, abbreviated form: para[5][@type='warning'] ; selects the fifth para child of the context node if that child has a 'type' ; attribute with value warning (let ((tree '(chapter (para "para1") (para (@ (type "warning")) "para 2") (para (@ (type "warning")) "para 3") (para (@ (type "warning")) "para 4") (para (@ (type "warning")) "para 5") (para (@ (type "warning")) "para 6")) ) (expected '((para (@ (type "warning")) "para 5")) )) (run-test (node-reduce (select-kids (node-typeof? 'para)) (node-pos 5) (filter (node-join (select-kids (node-typeof? '@)) (select-kids (node-equal? '(type "warning")))))) tree expected) (run-test (sxpath '( (( (para 5)) (@ (equal? (type "warning")))))) tree expected) (run-test (sxpath '( (para 5 (@ (equal? (type "warning")))) )) tree expected) ) ; Location path, full form: ; child::*[self::chapter or self::appendix] ; Location path, semi-abbreviated form: *[self::chapter or self::appendix] ; selects the chapter and appendix children of the context node (let ((tree '(document (preface "preface") (chapter (@ (id "one")) "Chap 1 text") (chapter (@ (id "two")) "Chap 2 text") (chapter (@ (id "three")) "Chap 3 text") (epilogue "Epilogue text") (appendix (@ (id "A")) "App A text") (References "References")) ) (expected '((chapter (@ (id "one")) "Chap 1 text") (chapter (@ (id "two")) "Chap 2 text") (chapter (@ (id "three")) "Chap 3 text") (appendix (@ (id "A")) "App A text")) )) (run-test (node-join (select-kids (node-typeof? '*)) (filter (node-or (node-self (node-typeof? 'chapter)) (node-self (node-typeof? 'appendix))))) tree expected) (run-test (sxpath `(* ,(node-or (node-self (node-typeof? 'chapter)) (node-self (node-typeof? 'appendix))))) tree expected) ) ; Location path, full form: child::chapter[child::title='Introduction'] ; Location path, abbreviated form: chapter[title = 'Introduction'] ; selects the chapter children of the context node that have one or more ; title children with string-value equal to Introduction ; See a similar example: //td[@align = "right"] above. ; Location path, full form: child::chapter[child::title] ; Location path, abbreviated form: chapter[title] ; selects the chapter children of the context node that have one or ; more title children ; See a similar example //td[@align] above. (cerr nl "Example with tree3: extracting the first lines of every stanza" nl) (let ((tree tree3) (expected '("Let us go then, you and I," "In the room the women come and go") )) (run-test (node-join (node-closure (node-typeof? 'stanza)) (node-reduce (select-kids (node-typeof? 'line)) (node-pos 1)) (select-kids (node-typeof? '*text*))) tree expected) (run-test (sxpath '(// stanza (line 1) *text*)) tree expected) ) guile-lib-0.2.1/src/sxml/ssax/0000775000076400007640000000000011546130323013124 500000000000000guile-lib-0.2.1/src/sxml/ssax/input-parse.scm0000664000076400007640000000717611137632501016033 00000000000000;; (sxml ssax input-parse) -- a simple lexer ;; Written 2003 by Oleg Kiselyov as input-parse.scm. ;; Modified 2004 by Andy Wingo . ;; This file is in the public domain. ;;; Commentary: ;; ;; A simple lexer. ;; ;; The procedures in this module surprisingly often suffice to parse an ;; input stream. They either skip, or build and return tokens, according ;; to inclusion or delimiting semantics. The list of characters to ;; expect, include, or to break at may vary from one invocation of a ;; function to another. This allows the functions to easily parse even ;; context-sensitive languages. ;; ;; EOF is generally frowned on, and thrown up upon if encountered. ;; Exceptions are mentioned specifically. The list of expected ;; characters (characters to skip until, or break-characters) may ;; include an EOF "character", which is to be coded as the symbol, ;; @code{*eof*}. ;; ;; The input stream to parse is specified as a @dfn{port}, which is ;; usually the last (and optional) argument. It defaults to the current ;; input port if omitted. ;; ;; If the parser encounters an error, it will throw an exception to the ;; key @code{parser-error}. The arguments will be of the form ;; @code{(@var{port} @var{message} @var{specialising-msg}*)}. ;; ;; The first argument is a port, which typically points to the offending ;; character or its neighborhood. You can then use @code{port-column} ;; and @code{port-line} to query the current position. @var{message} is ;; the description of the error. Other arguments supply more details ;; about the problem. ;; ;;; Code: (define-module (sxml ssax input-parse) #:use-module (ice-9 optargs) #:use-module (ice-9 rdelim) #:export (peek-next-char assert-curr-char skip-until skip-while next-token next-token-of read-text-line read-string)) (define ascii->char integer->char) (define char->ascii char->integer) (define char-newline #\newline) (define char-return #\return) (define inc 1+) (define dec 1-) ;; rewrite oleg's define-opt into define* style (define-macro (define-opt bindings body . body-rest) (let* ((rev-bindings (reverse bindings)) (opt-bindings (and (pair? rev-bindings) (pair? (car rev-bindings)) (eq? 'optional (caar rev-bindings)) (cdar rev-bindings)))) (if opt-bindings `(define* ,(append (reverse (cons #:optional (cdr rev-bindings))) opt-bindings) ,body ,@body-rest) `(define* ,bindings ,body ,@body-rest)))) (define (parser-error port message . rest) (apply throw 'parser-error port message rest)) (load-from-path "sxml/upstream/input-parse.scm") ;; This version for guile is quite speedy, due to read-delimited (which ;; is implemented in C). (define-opt (next-token prefix-skipped-chars break-chars (optional (comment "") (port (current-input-port))) ) (let ((delims (list->string (delete '*eof* break-chars)))) (if (eof-object? (if (null? prefix-skipped-chars) (peek-char port) (skip-while prefix-skipped-chars port))) (if (memq '*eof* break-chars) "" (parser-error port "EOF while reading a token " comment)) (let ((token (read-delimited delims port 'peek))) (if (and (eof-object? (peek-char port)) (not (memq '*eof* break-chars))) (parser-error port "EOF while reading a token " comment) token))))) (define-opt (read-text-line (optional (port (current-input-port))) ) (read-line port)) ;;; arch-tag: 73fa0dc1-9f01-45e1-80fa-4d9a7ab83f92 ;;; input-parse.scm ends here guile-lib-0.2.1/src/sxml/apply-templates.scm0000664000076400007640000000610211137632105015713 00000000000000;; (sxml apply-templates) -- xslt-like transformation for sxml ;; Written 2003 by Oleg Kiselyov as apply-templates.scm. ;; Modified 2004 by Andy Wingo . ;; This file is in the public domain. ;;; Commentary: ;; ;; Pre-order traversal of a tree and creation of a new tree: ;; ;;@smallexample ;; apply-templates:: tree x -> ;;@end smallexample ;; where ;;@smallexample ;; ::= (