Alan Watson <[EMAIL PROTECTED]> writes:
> William D Clinger wrote:
>> It sounds as though the R6RS has created a need for some
>> kind of tool and/or language that would allow us to read
>> R5RS data reliably and then to write that data reliably
>> as R6RS-readable data.
>
> Such a tool would be trivial to write in R5RS Scheme. It would still be
> worth having, though.
It certainly would be trivial to write in R6RS Scheme. I was able to
hack the R5RS reader and writer that come with Scheme 48 to run in
Ikarus in about 20 minutes. The result is attached. The following R6RS
top-level program then can perform a trivial conversion:
(import (rnrs base)
(rnrs programs)
(prefix (de deinprogramm r5rs-write) r5rs:)
(prefix (de deinprogramm r5rs-read) r5rs:)
(rnrs io simple))
(r5rs:write
(call-with-input-file (cadr (command-line))
(lambda (port)
(r5rs:read port))))
(newline)
It's only a proof-of-concept, with no claims as to its correctness,
completeness, usefulness, or R6RS compliance. To be sure, there's a few
shortcomings, notably the reliance on R6RS's `string->number' in the
reader, which doesn't support '#' anymore, but I'm sure the interested
reader can easily fix that problem. (As well as fixing the 80,000+
other failing test cases a decent test suite can probably be made to
find.)
--
Cheers =8-} Mike
Friede, Völkerverständigung und überhaupt blabla
; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
; A little Scheme reader.
(library (de deinprogramm r5rs-read)
(export read)
(import (rnrs base)
(rnrs unicode)
(rnrs control)
(rnrs mutable-strings)
(rnrs exceptions)
(rnrs conditions)
(rnrs lists)
(except (rnrs io simple) read))
(define preferred-case char-downcase)
(define (read . port-option)
(let ((port (input-port-option port-option)))
(let loop ()
(let ((form (sub-read port)))
(cond ((not (reader-token? form))
form)
((eq? form close-paren)
;; Too many right parens.
(display "discarding extraneous right parenthesis")
(newline)
(loop))
(else
(reading-error port (cdr form))))))))
(define (sub-read-carefully port)
(let ((form (sub-read port)))
(cond ((eof-object? form)
(reading-error port "unexpected end of file"))
((reader-token? form) (reading-error port (cdr form)))
(else form))))
(define reader-token-marker (list 'reader-token))
(define (make-reader-token message) (cons reader-token-marker message))
(define (reader-token? form)
(and (pair? form) (eq? (car form) reader-token-marker)))
(define close-paren (make-reader-token "unexpected right parenthesis"))
(define dot (make-reader-token "unexpected \" . \""))
; Main dispatch
(define ascii-whitespaces '(32 10 9 12 13)) ;space linefeed tab page return
(define ascii-limit 128)
(define (sub-read port)
(let ((c (read-char port)))
(if (eof-object? c)
c
((vector-ref read-dispatch-vector (char->integer c))
c port))))
(define read-dispatch-vector
(make-vector ascii-limit
(lambda (c port)
(reading-error port "illegal character read" c))))
(define read-terminating?-vector
(make-vector ascii-limit #t))
(define (set-standard-syntax! char terminating? reader)
(vector-set! read-dispatch-vector (char->integer char) reader)
(vector-set! read-terminating?-vector (char->integer char) terminating?))
; Usual read macros
(define (set-standard-read-macro! c terminating? proc)
(set-standard-syntax! c terminating? proc))
(define (sub-read-list c port)
(let ((form (sub-read port)))
(if (eq? form dot)
(reading-error port
"missing car -- ( immediately followed by .")
(let recur ((form form))
(cond ((eof-object? form)
(reading-error port
"end of file inside list -- unbalanced
parentheses"))
((eq? form close-paren) '())
((eq? form dot)
(let* ((last-form (sub-read-carefully port))
(another-form (sub-read port)))
(if (eq? another-form close-paren)
last-form
(reading-error port
"randomness after form after dot"
another-form))))
(else
(cons form (recur (sub-read port)))))))))
(define (gobble-line port)
(let loop ()
(let ((c (read-char port)))
(cond ((eof-object? c) c)
((char=? c #\newline) #f)
(else (loop))))))
(define *sharp-macros* '())
(define (define-sharp-macro c proc)
(set! *sharp-macros* (cons (cons c proc) *sharp-macros*)))
(define (proper-list? x)
(cond ((null? x) #t)
((pair? x) (proper-list? (cdr x)))
(else #f)))
; Tokens
(define (sub-read-token c port)
(let loop ((l (list (preferred-case c))) (n 1))
(let ((c (peek-char port)))
(cond ((or (eof-object? c)
(vector-ref read-terminating?-vector (char->integer c)))
(reverse-list->string l n))
(else
(read-char port)
(loop (cons (preferred-case c) l)
(+ n 1)))))))
(define (parse-token string port)
(if (let ((c (string-ref string 0)))
(or (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.)))
(cond ((string->number (downcase string)))
((member string strange-symbol-names)
(string->symbol string))
((string=? string ".")
dot)
(else
(reading-error port "unsupported number syntax" string)))
(string->symbol string)))
(define strange-symbol-names
'("+" "-" "..."))
; Reader errors
(define (reverse-list->string l n)
(list->string (reverse l)))
;; should be replaced by `string-downcase'
(define (downcase s)
(do ((d (make-string (string-length s)))
(i 0 (+ 1 i)))
((= i (string-length s))
d)
(string-set! d (char-downcase (string-ref s i)))))
(define (reading-error port message . irritants)
(raise
(condition
(make-who-condition 'reading-error)
(make-lexical-violation)
(make-irritants-condition (cons port irritants)))))
(define (input-port-option args)
(if (null? args)
(current-input-port)
(car args)))
(let ((sub-read-whitespace
(lambda (c port)
c ;ignored
(sub-read port))))
(for-each (lambda (c)
(vector-set! read-dispatch-vector c sub-read-whitespace))
ascii-whitespaces))
(let ((sub-read-constituent
(lambda (c port)
(parse-token (sub-read-token c port) port))))
(for-each (lambda (c)
(set-standard-syntax! c #f sub-read-constituent))
(string->list
(string-append "!$%&*+-./0123456789:<=>[EMAIL PROTECTED]"
"NOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))))
(set-standard-read-macro! #\( #t sub-read-list)
(set-standard-read-macro! #\) #t
(lambda (c port)
c port
close-paren))
(set-standard-read-macro! #\' #t
(lambda (c port)
c
(list 'quote (sub-read-carefully port))))
(set-standard-read-macro! #\` #t
(lambda (c port)
c
(list 'quasiquote (sub-read-carefully port))))
(set-standard-read-macro! #\, #t
(lambda (c port)
c
(let* ((next (peek-char port))
;; DO NOT beta-reduce!
(keyword (cond ((eof-object? next)
(reading-error port "end
of file after ,"))
((char=? next #\@)
(read-char port)
'unquote-splicing)
(else 'unquote))))
(list keyword
(sub-read-carefully port)))))
(set-standard-read-macro! #\" #t
(lambda (c port)
c ;ignored
(let loop ((l '()) (i 0))
(let ((c (read-char port)))
(cond ((eof-object? c)
(reading-error port "end of file
within a string"))
((char=? c #\\)
(let ((c (read-char port)))
(cond ((eof-object? c)
(reading-error port "end of
file within a string"))
((or (char=? c #\\) (char=? c
#\"))
(loop (cons c l) (+ i 1)))
(else
(reading-error port
"invalid
escaped character in string"
c)))))
((char=? c #\")
(reverse-list->string l i))
(else
(loop (cons c l) (+ i 1))))))))
(set-standard-read-macro! #\; #t
(lambda (c port)
c ;ignored
(gobble-line port)
(sub-read port)))
(set-standard-read-macro! #\# #f
(lambda (c port)
c ;ignored
(let* ((c (peek-char port))
(c (if (eof-object? c)
(reading-error port "end of file
after #")
(char-downcase c)))
(probe (assq c *sharp-macros*)))
(if probe
((cdr probe) c port)
(reading-error port "unknown # syntax"
c)))))
(define-sharp-macro #\f
(lambda (c port) (read-char port) #f))
(define-sharp-macro #\t
(lambda (c port) (read-char port) #t))
(define-sharp-macro #\\
(lambda (c port)
(read-char port)
(let ((c (peek-char port)))
(cond ((eof-object? c)
(reading-error port "end of file after #\\"))
((char-alphabetic? c)
(let ((name (sub-read-carefully port)))
(cond ((= (string-length (symbol->string name)) 1)
c)
((assq name '((space #\space)
(newline #\newline)))
=> cadr)
(else
(reading-error port "unknown #\\ name" name)))))
(else
(read-char port)
c)))))
(define-sharp-macro #\(
(lambda (c port)
(read-char port)
(let ((elts (sub-read-list c port)))
(if (proper-list? elts)
(list->vector elts)
(reading-error port "dot in #(...)")))))
(let ((number-sharp-macro
(lambda (c port)
(let ((string (sub-read-token #\# port)))
(or (string->number string)
(reading-error port "unsupported number syntax" string))))))
(for-each (lambda (c)
(define-sharp-macro c number-sharp-macro))
'(#\b #\o #\d #\x #\i #\e)))
)
; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
(library (de deinprogramm r5rs-write)
(export write display)
(import (rnrs base)
(rnrs unicode)
(rnrs control)
(except (rnrs io simple) display write))
(define (write obj . port-option)
(let ((port (output-port-option port-option)))
(let recur ((obj obj))
(recurring-write obj port recur))))
(define (recurring-write obj port recur)
(cond ((null? obj) (write-string "()" port))
((pair? obj) (write-list obj port recur))
((eq? obj #t) (write-boolean 't port))
((eq? obj #f) (write-boolean 'f port))
((symbol? obj) (write-string (symbol->string obj) port))
((number? obj) (write-number obj port))
((string? obj) (write-string-literal obj port))
((char? obj) (write-char-literal obj port))
(else (write-other obj port recur))))
(define (write-boolean mumble port)
(write-char #\# port)
(write mumble port))
(define (write-number n port)
(write-string (number->string n 10) port))
(define (write-char-literal obj port)
(let ((probe (character-name obj)))
(write-string "#\\" port)
(if probe
(write probe port)
(write-char obj port))))
(define (character-name char)
(cond ((char=? char #\space) 'space)
((char=? char #\newline) 'newline)
(else #f)))
(define (write-string-literal obj port)
(write-char #\" port)
(let ((len (string-length obj)))
(do ((i 0 (+ i 1)))
((= i len) (write-char #\" port))
(let ((c (string-ref obj i)))
(if (or (char=? c #\\) (char=? c #\"))
(write-char #\\ port))
(write-char c port)))))
(define (write-list obj port recur)
(cond ((quotation? obj)
(write-char #\' port)
(recur (cadr obj)))
(else
(write-char #\( port)
(recur (car obj))
(let loop ((l (cdr obj))
(n 1))
(cond ((not (pair? l))
(cond ((not (null? l))
(write-string " . " port)
(recur l))))
(else
(write-char #\space port)
(recur (car l))
(loop (cdr l) (+ n 1)))))
(write-char #\) port))))
(define (quotation? obj)
(and (pair? obj)
(eq? (car obj) 'quote)
(pair? (cdr obj))
(null? (cddr obj))))
(define (write-vector obj port recur)
(write-string "#(" port)
(let ((z (vector-length obj)))
(cond ((> z 0)
(recur (vector-ref obj 0))
(let loop ((i 1))
(cond ((>= i z))
(else
(write-char #\space port)
(recur (vector-ref obj i))
(loop (+ i 1))))))))
(write-char #\) port))
; The vector case goes last just so that this version of WRITE can be
; used in Scheme implementations in which records, ports, or
; procedures are represented as vectors. (Scheme 48 doesn't have this
; property.)
(define (write-other obj port recur)
(cond ((eof-object? obj) (write-string "#{End-of-file}" port))
((vector? obj) (write-vector obj port recur))
((procedure? obj) (write-string "#{Procedure}" port))
((eq? obj (if #f #f)) (write-string "#{Unspecified}" port))
(else
(write-string "#{Random object}" port))))
; Display the symbol WHO-CARES as Who-cares.
(define (display-type-name name port)
(if (symbol? name)
(let* ((s (symbol->string name))
(len (string-length s)))
(if (and (> len 0)
(char-alphabetic? (string-ref s 0)))
(begin (write-char (char-upcase (string-ref s 0)) port)
(do ((i 1 (+ i 1)))
((>= i len))
(write-char (char-downcase (string-ref s i)) port)))
(display name port)))
(display name port)))
(define (write-string s port)
(do ((i 0 (+ i 1)))
((= i (string-length s)))
(write-char (string-ref s i) port)))
; DISPLAY
(define (display obj . port-option)
(let ((port (output-port-option port-option)))
(let recur ((obj obj))
(cond ((string? obj) (write-string obj port))
((char? obj) (write-char obj port))
(else
(recurring-write obj port recur))))))
(define (output-port-option args)
(if (null? args)
(current-output-port)
(car args)))
)
_______________________________________________
r6rs-discuss mailing list
[email protected]
http://lists.r6rs.org/cgi-bin/mailman/listinfo/r6rs-discuss
