Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fixing #; comments as the last element in a list for (scheme read).

Browse source
This commit is contained in:
Alex Shinn 2015-06-13 21:57:31 +09:00
parent a05b94f3c2
commit eab76ce8c1
2 changed files with 147 additions and 136 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

281
lib/srfi/38.scm
View file

@ -259,147 +259,158 @@
(else (else
(slot-set! type res i (car ls)) (slot-set! type res i (car ls))
(lp (cdr ls) (+ i 1))))))) (lp (cdr ls) (+ i 1)))))))
(else (lp (cons (read-one) ls)))))))) (else (lp (cons (read-one in) ls))))))))
(define (read-one) (define (read-hash in)
(skip-whitespace in) (if (eof-object? (peek-char in))
(case (peek-char in) (read-error "read error: incomplete # found at end of input"))
((#\#) (case (char-downcase (peek-char in))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(let* ((str (read-label '()))
(n (string->number str)))
(if (not n) (read-error "read error: invalid reference" str))
(cond
((eqv? #\= (peek-char in))
(read-char in)
(let* ((cell (list #f))
(thunk (lambda () (car cell))))
(set! shared (cons (cons n thunk) shared))
(let ((x (read-one in)))
(set-car! cell x)
x)))
((eqv? #\# (peek-char in))
(read-char in)
(cond
((assv n shared) => cdr)
(else (read-error "read error: unknown reference" n))))
(else
(read-error "read error: expected # after #n"
(read-char in))))))
((#\;)
(read-char in) (read-char in)
(if (eof-object? (peek-char in)) (read-one in) ;; discard
(read-error "read error: incomplete # found at end of input")) (read-one in))
(case (char-downcase (peek-char in)) ((#\|)
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (skip-comment in 0)
(let* ((str (read-label '())) (read-one in))
(n (string->number str))) ((#\!)
(if (not n) (read-error "read error: invalid reference" str))
(cond
((eqv? #\= (peek-char in))
(read-char in)
(let* ((cell (list #f))
(thunk (lambda () (car cell))))
(set! shared (cons (cons n thunk) shared))
(let ((x (read-one)))
(set-car! cell x)
x)))
((eqv? #\# (peek-char in))
(read-char in)
(cond
((assv n shared) => cdr)
(else (read-error "read error: unknown reference" n))))
(else
(read-error "read error: expected # after #n"
(read-char in))))))
((#\;)
(read-char in)
(read-one) ;; discard
(read-one))
((#\|)
(skip-comment in 0)
(read-one))
((#\!)
(read-char in)
(let ((c (peek-char in)))
(cond
((or (char-whitespace? c) (eqv? c #\/))
(skip-line in)
(read-one))
(else
(let ((name (read-name #f in)))
(cond
((string-ci=? name "fold-case")
(set-port-fold-case! in #t))
((string-ci=? name "no-fold-case")
(set-port-fold-case! in #f))
(else ;; assume a #!/bin/bash line
(read-error "unknown #! symbol" name)))
(read-one))))))
((#\() (list->vector (read-one)))
((#\') (read-char in) (list 'syntax (read-one)))
((#\`) (read-char in) (list 'quasisyntax (read-one)))
((#\t) (let ((s (read-name #f in)))
(or (string-ci=? s "t") (string-ci=? s "true")
(read-error "bad # syntax" s))))
((#\f) (let ((s (read-name #f in)))
(if (or (string-ci=? s "f") (string-ci=? s "false"))
#f
(read-error "bad # syntax" s))))
((#\d) (read-char in) (read in))
((#\x) (read-char in) (read-number 16))
((#\o) (read-char in) (read-number 8))
((#\b) (read-char in) (read-number 2))
((#\i) (read-char in) (exact->inexact (read-one)))
((#\e) (string->number (read-name #\# in)))
((#\u #\v)
(if (eqv? #\v (peek-char in))
(read-char in))
(read-char in)
(if (not (eqv? #\8 (peek-char in)))
(read-error "invalid syntax #u" (peek-char in)))
(read-char in)
(let ((ls (read-one)))
(if (not (list? ls))
(read-error "invalid bytevector syntax" ls))
(let* ((len (length ls))
(bv (make-bytevector len)))
(do ((i 0 (+ i 1)) (ls ls (cdr ls)))
((null? ls) bv)
(bytevector-u8-set! bv i (car ls))))))
((#\\)
(read-char in)
(let* ((c1 (read-char in))
(c2 (peek-char in)))
(if (or (eof-object? c2) (memv c2 delimiters))
c1
(read-named-char c1 in))))
(else
(read-error "unknown # syntax: " (peek-char in)))))
((#\()
(read-char in) (read-char in)
(let lp ((res '())) (let ((c (peek-char in)))
(skip-whitespace in) (cond
(let ((c (peek-char in))) ((or (char-whitespace? c) (eqv? c #\/))
(case c (skip-line in)
((#\)) (read-one in))
(read-char in) (else
(reverse res)) (let ((name (read-name #f in)))
((#\.) (cond
(read-char in) ((string-ci=? name "fold-case")
(cond (set-port-fold-case! in #t))
((memv (peek-char in) delimiters) ((string-ci=? name "no-fold-case")
(let ((tail (read-one))) (set-port-fold-case! in #f))
(cond (else ;; assume a #!/bin/bash line
((and (skip-whitespace-and-sexp-comments (read-error "unknown #! symbol" name)))
in (lambda (in) (read-one))) (read-one in))))))
(eqv? #\) (peek-char in))) ((#\() (list->vector (read-one in)))
(read-char in) ((#\') (read-char in) (list 'syntax (read-one in)))
(append (reverse res) tail)) ((#\`) (read-char in) (list 'quasisyntax (read-one in)))
((eof-object? (peek-char in)) ((#\t) (let ((s (read-name #f in)))
(read-incomplete-error "unterminated dotted list")) (or (string-ci=? s "t") (string-ci=? s "true")
(else (read-error "bad # syntax" s))))
(read-error "expected end of list after dot"))))) ((#\f) (let ((s (read-name #f in)))
((char-numeric? (peek-char in)) (if (or (string-ci=? s "f") (string-ci=? s "false"))
(lp (cons (read-float-tail in) res))) #f
(else (read-error "bad # syntax" s))))
(lp (cons (string->symbol (read-name #\. in)) res))))) ((#\d) (read-char in) (read in))
(else ((#\x) (read-char in) (read-number 16))
(if (eof-object? c) ((#\o) (read-char in) (read-number 8))
(read-incomplete-error "unterminated list") ((#\b) (read-char in) (read-number 2))
(lp (cons (read-one) res)))))))) ((#\i) (read-char in) (exact->inexact (read-one in)))
((#\{) ((#\e) (string->number (read-name #\# in)))
((#\u #\v)
(if (eqv? #\v (peek-char in))
(read-char in))
(read-char in) (read-char in)
(read-object)) (if (not (eqv? #\8 (peek-char in)))
((#\') (read-char in) (list 'quote (read-one))) (read-error "invalid syntax #u" (peek-char in)))
((#\`) (read-char in) (list 'quasiquote (read-one)))
((#\,)
(read-char in) (read-char in)
(let ((sym (if (eqv? #\@ (peek-char in)) (let ((ls (read-one in)))
(begin (read-char in) 'unquote-splicing) (if (not (list? ls))
'unquote))) (read-error "invalid bytevector syntax" ls))
(list sym (read-one)))) (let* ((len (length ls))
(bv (make-bytevector len)))
(do ((i 0 (+ i 1)) (ls ls (cdr ls)))
((null? ls) bv)
(bytevector-u8-set! bv i (car ls))))))
((#\\)
(read-char in)
(let* ((c1 (read-char in))
(c2 (peek-char in)))
(if (or (eof-object? c2) (memv c2 delimiters))
c1
(read-named-char c1 in))))
(else (else
(read in)))) (read-error "unknown # syntax: " (peek-char in)))))
(define (read-one in)
(cond
((not (skip-whitespace-and-sexp-comments in read-one))
(read-hash in))
(else
(case (peek-char in)
((#\#)
(read-char in)
(read-hash in))
((#\()
(read-char in)
(let lp ((res '()))
(cond
((not (skip-whitespace-and-sexp-comments in read-one))
(lp (cons (read-hash in) res)))
(else
(let ((c (peek-char in)))
(case c
((#\))
(read-char in)
(reverse res))
((#\.)
(read-char in)
(cond
((memv (peek-char in) delimiters)
(let ((tail (read-one in)))
(cond
((null? res)
(read-error "dot before any elements in list"))
((and (skip-whitespace-and-sexp-comments
in read-one)
(eqv? #\) (peek-char in)))
(read-char in)
(append (reverse res) tail))
((eof-object? (peek-char in))
(read-incomplete-error
"unterminated dotted list"))
(else
(read-error "expected end of list after dot")))))
((char-numeric? (peek-char in))
(lp (cons (read-float-tail in) res)))
(else
(lp (cons (string->symbol (read-name #\. in)) res)))))
(else
(if (eof-object? c)
(read-incomplete-error "unterminated list")
(lp (cons (read-one in) res))))))))))
((#\{)
(read-char in)
(read-object))
((#\') (read-char in) (list 'quote (read-one in)))
((#\`) (read-char in) (list 'quasiquote (read-one in)))
((#\,)
(read-char in)
(let ((sym (if (eqv? #\@ (peek-char in))
(begin (read-char in) 'unquote-splicing)
'unquote)))
(list sym (read-one in))))
(else
(read in))))))
;; body ;; body
(let ((res (read-one))) (let ((res (read-one in)))
(if (pair? shared) (if (pair? shared)
(patch res)) (patch res))
res))))) res)))))

2
tests/r7rs-tests.scm
View file

@ -2040,7 +2040,7 @@
(test '(a . b) (read (open-input-string "(a . b #;c)"))) (test '(a . b) (read (open-input-string "(a . b #;c)")))
(define (test-read-error str) (define (test-read-error str)
(test-assert (test-assert str
(guard (exn (else #t)) (guard (exn (else #t))
(read (open-input-string str)) (read (open-input-string str))
#f))) #f)))