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

65
lib/srfi/38.scm
View file

@ -259,12 +259,8 @@
(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)
(case (peek-char in)
((#\#)
(read-char in)
(if (eof-object? (peek-char in)) (if (eof-object? (peek-char in))
(read-error "read error: incomplete # found at end of input")) (read-error "read error: incomplete # found at end of input"))
(case (char-downcase (peek-char in)) (case (char-downcase (peek-char in))
@ -278,7 +274,7 @@
(let* ((cell (list #f)) (let* ((cell (list #f))
(thunk (lambda () (car cell)))) (thunk (lambda () (car cell))))
(set! shared (cons (cons n thunk) shared)) (set! shared (cons (cons n thunk) shared))
(let ((x (read-one))) (let ((x (read-one in)))
(set-car! cell x) (set-car! cell x)
x))) x)))
((eqv? #\# (peek-char in)) ((eqv? #\# (peek-char in))
@ -291,18 +287,18 @@
(read-char in)))))) (read-char in))))))
((#\;) ((#\;)
(read-char in) (read-char in)
(read-one) ;; discard (read-one in) ;; discard
(read-one)) (read-one in))
((#\|) ((#\|)
(skip-comment in 0) (skip-comment in 0)
(read-one)) (read-one in))
((#\!) ((#\!)
(read-char in) (read-char in)
(let ((c (peek-char in))) (let ((c (peek-char in)))
(cond (cond
((or (char-whitespace? c) (eqv? c #\/)) ((or (char-whitespace? c) (eqv? c #\/))
(skip-line in) (skip-line in)
(read-one)) (read-one in))
(else (else
(let ((name (read-name #f in))) (let ((name (read-name #f in)))
(cond (cond
@ -312,10 +308,10 @@
(set-port-fold-case! in #f)) (set-port-fold-case! in #f))
(else ;; assume a #!/bin/bash line (else ;; assume a #!/bin/bash line
(read-error "unknown #! symbol" name))) (read-error "unknown #! symbol" name)))
(read-one)))))) (read-one in))))))
((#\() (list->vector (read-one))) ((#\() (list->vector (read-one in)))
((#\') (read-char in) (list 'syntax (read-one))) ((#\') (read-char in) (list 'syntax (read-one in)))
((#\`) (read-char in) (list 'quasisyntax (read-one))) ((#\`) (read-char in) (list 'quasisyntax (read-one in)))
((#\t) (let ((s (read-name #f in))) ((#\t) (let ((s (read-name #f in)))
(or (string-ci=? s "t") (string-ci=? s "true") (or (string-ci=? s "t") (string-ci=? s "true")
(read-error "bad # syntax" s)))) (read-error "bad # syntax" s))))
@ -327,7 +323,7 @@
((#\x) (read-char in) (read-number 16)) ((#\x) (read-char in) (read-number 16))
((#\o) (read-char in) (read-number 8)) ((#\o) (read-char in) (read-number 8))
((#\b) (read-char in) (read-number 2)) ((#\b) (read-char in) (read-number 2))
((#\i) (read-char in) (exact->inexact (read-one))) ((#\i) (read-char in) (exact->inexact (read-one in)))
((#\e) (string->number (read-name #\# in))) ((#\e) (string->number (read-name #\# in)))
((#\u #\v) ((#\u #\v)
(if (eqv? #\v (peek-char in)) (if (eqv? #\v (peek-char in))
@ -336,7 +332,7 @@
(if (not (eqv? #\8 (peek-char in))) (if (not (eqv? #\8 (peek-char in)))
(read-error "invalid syntax #u" (peek-char in))) (read-error "invalid syntax #u" (peek-char in)))
(read-char in) (read-char in)
(let ((ls (read-one))) (let ((ls (read-one in)))
(if (not (list? ls)) (if (not (list? ls))
(read-error "invalid bytevector syntax" ls)) (read-error "invalid bytevector syntax" ls))
(let* ((len (length ls)) (let* ((len (length ls))
@ -353,10 +349,22 @@
(read-named-char c1 in)))) (read-named-char c1 in))))
(else (else
(read-error "unknown # syntax: " (peek-char 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) (read-char in)
(let lp ((res '())) (let lp ((res '()))
(skip-whitespace in) (cond
((not (skip-whitespace-and-sexp-comments in read-one))
(lp (cons (read-hash in) res)))
(else
(let ((c (peek-char in))) (let ((c (peek-char in)))
(case c (case c
((#\)) ((#\))
@ -366,15 +374,18 @@
(read-char in) (read-char in)
(cond (cond
((memv (peek-char in) delimiters) ((memv (peek-char in) delimiters)
(let ((tail (read-one))) (let ((tail (read-one in)))
(cond (cond
((null? res)
(read-error "dot before any elements in list"))
((and (skip-whitespace-and-sexp-comments ((and (skip-whitespace-and-sexp-comments
in (lambda (in) (read-one))) in read-one)
(eqv? #\) (peek-char in))) (eqv? #\) (peek-char in)))
(read-char in) (read-char in)
(append (reverse res) tail)) (append (reverse res) tail))
((eof-object? (peek-char in)) ((eof-object? (peek-char in))
(read-incomplete-error "unterminated dotted list")) (read-incomplete-error
"unterminated dotted list"))
(else (else
(read-error "expected end of list after dot"))))) (read-error "expected end of list after dot")))))
((char-numeric? (peek-char in)) ((char-numeric? (peek-char in))
@ -384,22 +395,22 @@
(else (else
(if (eof-object? c) (if (eof-object? c)
(read-incomplete-error "unterminated list") (read-incomplete-error "unterminated list")
(lp (cons (read-one) res)))))))) (lp (cons (read-one in) res))))))))))
((#\{) ((#\{)
(read-char in) (read-char in)
(read-object)) (read-object))
((#\') (read-char in) (list 'quote (read-one))) ((#\') (read-char in) (list 'quote (read-one in)))
((#\`) (read-char in) (list 'quasiquote (read-one))) ((#\`) (read-char in) (list 'quasiquote (read-one in)))
((#\,) ((#\,)
(read-char in) (read-char in)
(let ((sym (if (eqv? #\@ (peek-char in)) (let ((sym (if (eqv? #\@ (peek-char in))
(begin (read-char in) 'unquote-splicing) (begin (read-char in) 'unquote-splicing)
'unquote))) 'unquote)))
(list sym (read-one)))) (list sym (read-one in))))
(else (else
(read in)))) (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)))