Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 05:27:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fixing SRFI 38 reading trailing #; comment after dotted tail.

Browse source
This commit is contained in:
Alex Shinn 2014-04-08 08:08:31 +09:00
parent 7685d1f097
commit 1d9ef7c3a0
2 changed files with 42 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
lib/srfi/38.scm
View file

@ -144,6 +144,20 @@
(error "unterminated #| comment") (error "unterminated #| comment")
(skip-comment in depth))))) (skip-comment in depth)))))
;; returns #f if a trailing # was consumed
(define (skip-whitespace-and-sexp-comments in read)
(skip-whitespace in)
(cond
((eqv? #\# (peek-char in))
(read-char in)
(cond ((eqv? #\; (peek-char in))
(read-char in)
(read in)
(skip-whitespace-and-sexp-comments in read))
(else #f)))
(else
#t)))
(define delimiters (define delimiters
'(#\; #\" #\| #\( #\) #\{ #\} #\space #\tab #\newline #\return)) '(#\; #\" #\| #\( #\) #\{ #\} #\space #\tab #\newline #\return))
@ -338,10 +352,16 @@
(cond (cond
((memv (peek-char in) delimiters) ((memv (peek-char in) delimiters)
(let ((tail (read-one))) (let ((tail (read-one)))
(skip-whitespace in) (cond
(if (eqv? #\) (peek-char in)) ((and (skip-whitespace-and-sexp-comments
(begin (read-char in) (append (reverse res) tail)) in (lambda (in) (read-one)))
(error "expected end of list after dot")))) (eqv? #\) (peek-char in)))
(read-char in)
(append (reverse res) tail))
((eof-object? (peek-char in))
(error "unterminated dotted list"))
(else
(error "expected end of list after dot")))))
((char-numeric? (peek-char in)) ((char-numeric? (peek-char in))
(lp (cons (read-float-tail in) res))) (lp (cons (read-float-tail in) res)))
(else (lp (cons (string->symbol (read-name #\. in)) res))))) (else (lp (cons (string->symbol (read-name #\. in)) res)))))

18
tests/r7rs-tests.scm
View file

@ -1940,6 +1940,24 @@
(test 'def (read (open-input-string "#| abc |# def"))) (test 'def (read (open-input-string "#| abc |# def")))
(test 'ghi (read (open-input-string "#| abc #| def |# |# ghi"))) (test 'ghi (read (open-input-string "#| abc #| def |# |# ghi")))
(test 'ghi (read (open-input-string "#; ; abc\n def ghi"))) (test 'ghi (read (open-input-string "#; ; abc\n def ghi")))
(test '(abs -16) (read (open-input-string "(#;sqrt abs -16)")))
(test '(a d) (read (open-input-string "(a #; #;b c d)")))
(test '(a e) (read (open-input-string "(a #;(b #;c d) e)")))
(test '(a . c) (read (open-input-string "(a . #;b c)")))
(test '(a . b) (read (open-input-string "(a . b #;c)")))
(define (test-read-error str)
(test-assert
(guard (exn (else #t))
(read (open-input-string str))
#f)))
(test-read-error "(#;a . b)")
(test-read-error "(a . #;b)")
(test-read-error "(a #;. b)")
(test-read-error "(#;x #;y . z)")
(test-read-error "(#; #;x #;y . z)")
(test-read-error "(#; #;x . z)")
(test #\a (read (open-input-string "#\\a"))) (test #\a (read (open-input-string "#\\a")))
(test #\space (read (open-input-string "#\\space"))) (test #\space (read (open-input-string "#\\space")))