diff options
Diffstat (limited to 'legacy/stklos/reader.stk')
| -rw-r--r-- | legacy/stklos/reader.stk | 136 |
1 files changed, 136 insertions, 0 deletions
diff --git a/legacy/stklos/reader.stk b/legacy/stklos/reader.stk new file mode 100644 index 0000000..bd38562 --- /dev/null +++ b/legacy/stklos/reader.stk @@ -0,0 +1,136 @@ +;;;; +;;;; reader.stk -- Reader hook for the open bracket +;;;; +;;;; Copyright (C) 2001-2003 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; 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 2 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, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@unice.fr] +;;;; Creation date: 6-Dec-2001 22:59 (eg) +;;;; Last file update: 28-Feb-2004 10:22 (eg) +;;;; + +;; Examples of ISO-2022-JP (here for cut'n paste tests, since my japanese +;; is *very* limited ;-). +;; +;; "Japan" 日本 +;; "China and Chinese music" 中国と中国の音楽 + + +;; +;; This function is a hook for the standard reader. After defining, +;; %read-bracket, the reader calls it when it encounters an open +;; bracket + + +(define (%read-bracket in) + + (define (read-japanese in) + ;; This function reads an ISO-2022-JP sequence. Susch s sequence is coded + ;; as "^[$B......^[(B" . When entering in this function the current + ;; character is 'B' (the opening sequence one). Function reads until the + ;; end of the sequence and return it as a string + (read-char in) ;; to skip the starting #\B + (let ((res (open-output-string))) + (let Loop ((c (peek-char in))) + (cond + ((eof-object? c) ;; EOF + (error '%read-bracket "EOF encountered")) + ((char=? c #\escape) + (read-char in) + (let ((next1 (peek-char in))) + (if (char=? next1 #\() + (begin + (read-char in) + (let ((next2 (peek-char in))) + (if (char=? next2 #\B) + (begin + (read-char in) + (format "\033$B~A\033(B" (get-output-string res))) + (begin + (format res "\033~A" next1) + (Loop next2))))) + (begin + (display #\escape res) + (Loop next1))))) + (else (display (read-char in) res) + (Loop (peek-char in))))))) + ;; + ;; Body of %read-bracket starts here + ;; + (let ((out (open-output-string)) + (res '()) + (in-string? #f)) + + (read-char in) ; skip open bracket + + (let Loop ((c (peek-char in))) + (cond + ((eof-object? c) ;; EOF + (error '%read-bracket "EOF encountered")) + + ((char=? c #\escape) ;; ISO-2022-JP string? + (read-char in) + (let ((next1 (peek-char in))) + (if (char=? next1 #\$) + (begin + (read-char in) + (let ((next2 (peek-char in))) + (if (char=? next2 #\B) + (begin + (set! res + (append! res + (list (get-output-string out) + (list 'unquote + (list 'jp + (read-japanese in)))))) + (set! out (open-output-string))) + (format out "\033~A" next1)))) + (display #\escape out))) + (Loop (peek-char in))) + + ((char=? c #\\) ;; Quote char + (read-char in) + (display (read-char in) out) + (Loop (peek-char in))) + + ((and (not in-string?) (char=? c #\,)) ;; Comma + (read-char in) + (let ((next (peek-char in))) + (if (char=? next #\() + (begin + (set! res (append! res (list (get-output-string out) + (list 'unquote + (read in))))) + (set! out (open-output-string))) + (display #\, out)) + (Loop (peek-char in)))) + + ((and (not in-string?) (char=? c #\[)) ;; Open bracket + (display (%read-bracket in) out) + (Loop (peek-char in))) + + ((and (not in-string?) (char=? c #\])) ;; Close bracket + (read-char in) + (let ((str (get-output-string out))) + (list 'quasiquote + (append! res (if (string=? str "") '() (list str)))))) + + (else (when (char=? c #\") (set! in-string? (not in-string?))) + (display (read-char in) out) + (Loop (peek-char in))))))) + |