このファイルのテキスト形式は こっち から ダウンロードしてください。
;; parsexml.scm - 簡単な XML パーザ
; 字句解析ルーチン
; last-char: 文字列 s の最後の文字を返す
(define last-char
(lambda (s) (string-ref s (- (string-length s) 1))))
; begin-tag?: 文字列 s が開始を表すタグならばそれをシンボルにしたものを、
; そうでなければ #f を返す。
(define begin-tag?
(lambda (s)
(and (<= 3 (string-length s)) ; 3文字以上か?
(char=? #\< (string-ref s 0)) ; 最初の文字が "<" か?
(char=? #\> (last-char s)) ; 最後の文字が ">" か?
(not (char=? #\/ (string-ref s 1))) ; 2番目の文字が "/" 以外か?
(string->symbol s)))) ; 文字列 s をシンボルに変換
; end-tag?: 文字列 s が終了を表すタグならばその開始タグをシンボルに
; したものを、そうでなければ #f を返す。
(define end-tag?
(lambda (s)
(and (<= 4 (string-length s)) ; 4文字以上か?
(char=? #\< (string-ref s 0)) ; 最初の文字が "<" か?
(char=? #\> (last-char s)) ; 最後の文字が ">" か?
(char=? #\/ (string-ref s 1)) ; 2番目の文字が "/" か?
; 文字列 s の先頭のスラッシュ (/) を除いたものをシンボルに変換
(string->symbol
(string-append "<" (substring s 2 (- (string-length s) 1)) ">")))))
; get-token1: ポート p からひとつのトークンを読み込み、文字列を返す。
(define get-token1
(lambda (p)
(define loop ; 文字型オブジェクトをリスト s に追加していく。
(lambda (s)
(let* ((c (read-char p))) ; ポートから 1文字を c に読み込む。
(cond ((eof-object? c) ; c は EOF か?
(and (not (null? s)) s)) ; → 抜ける
((char-whitespace? c) ; c は 空白、タブあるいは改行か?
(if (null? s) (loop s) s)) ; → s を返す。
(else ; c は通常の文字か?
(loop (cons c s))))))) ; → 続けて読み込む。
(let* ((chars (loop '())))
(and chars (list->string (reverse chars))))))
; read-all-tokens: ファイル名 filename のファイルから
; すべてのトークンを読み込み、そのリストを返す。
(define get-all-tokens
(lambda (filename)
(define loop ; ポート p から読みこんだトークンを tokens に追加していく。
(lambda (p tokens)
(let* ((t (get-token1 p))) ; #f (EOF) がくるまで続ける。
(if t (loop p (cons t tokens))
tokens))))
; トークン列を逆順にする。
(reverse (loop (open-input-file filename) '()))))
; XML 解析ルーチン
; parse-xml-file: ファイル名 filename の XML テキストを解析し、
; その構造をリストにして返す。
(define parse-xml-file
(lambda (filename)
(define loop
; トークン列 tokens からリストを生成する。tags, trees にはそれぞれ
; 処理中のタグと途中までできたリスト、curtree には処理中のリストが入る。
(lambda (curtree tags trees tokens)
(if (null? tokens) ; トークンがこれで終わりなら終了。
(if (null? trees) ; まだ完了していないリストがあれば、
(car curtree) ; エラー。
(display "unexpected eof\n"))
(let* ((t (car tokens)) ; トークンをひとつ取り出す。
(bt (begin-tag? t))
(et (end-tag? t)))
(cond (bt ; そのトークンが開始タグならば再帰的にリスト作成。
(loop (list bt) (cons bt tags)
(cons curtree trees) (cdr tokens)))
(et ; 終了タグならば curtree の処理は終了する。
(if (and (not (null? tags))
(eq? et (car tags)))
(loop (cons (reverse curtree) (car trees)) (cdr tags)
(cdr trees) (cdr tokens))
; タグが対応していなければエラー。
(display "close tag unmatched\n")))
(else ; そのトークンがタグでないならばリストに追加。
(loop (cons t curtree) tags
trees (cdr tokens))))))))
(loop '() '() '() (get-all-tokens filename))))
; search-xml: parse-xml-file で返されたリストから、述語 pred を
; 満たす部分木をすべてとりだし、リストにして返す。
(define search-xml
(lambda (pred tree)
(define scan-tree ; リスト elements を走査し、見つかったものを found に。
(lambda (found elements)
(cond ((null? elements) found) ; elements が空なら found を返す。
((list? (car elements)) ; さらにリストなら再帰的に検索。
(scan-tree (search-tree found (car elements))
(cdr elements)))
(else ; リストをひとつ進める。
(scan-tree found (cdr elements))))))
(define search-tree ; リスト tree を pred に渡し、判定する。
(lambda (found tree)
(scan-tree (if (pred tree) (cons tree found) found)
(cdr tree))))
; みつかったものを逆順にする。
(reverse (search-tree '() tree))))