conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

some asserion violations in the reader are converted to &lexicals so 

that the repl displays them properly.  E.g., 
(read (open-string-input-port "#!r6rs |foo|")) shows an &assertion,
but typing #!r6rs |foo| at the repl causes the repl to reset without
a message.
This commit is contained in:
Abdulaziz Ghuloum 2009-07-30 21:46:11 +03:00
parent af233a2ac2
commit b586d2e21a
2 changed files with 12 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
scheme/ikarus.reader.ss
View File

@ -774,7 +774,7 @@
(tokenize-dot p)] (tokenize-dot p)]
[($char= #\| c) [($char= #\| c)
(when (eq? (port-mode p) 'r6rs-mode) (when (eq? (port-mode p) 'r6rs-mode)
(die 'tokenize "|symbol| syntax is invalid in #!r6rs mode")) (die/p p 'tokenize "|symbol| syntax is invalid in #!r6rs mode"))
(let ([ls (reverse (tokenize-bar p '()))]) (let ([ls (reverse (tokenize-bar p '()))])
(cons 'datum (string->symbol (list->string ls))))] (cons 'datum (string->symbol (list->string ls))))]
[($char= #\\ c) [($char= #\\ c)
@ -785,7 +785,7 @@
;[($char= #\{ c) 'lbrace] ;[($char= #\{ c) 'lbrace]
[($char= #\@ c) [($char= #\@ c)
(when (eq? (port-mode p) 'r6rs-mode) (when (eq? (port-mode p) 'r6rs-mode)
(die 'tokenize "@-expr syntax is invalid in #!r6rs mode")) (die/p p 'tokenize "@-expr syntax is invalid in #!r6rs mode"))
'at-expr] 'at-expr]
[else [else
(die/p-1 p 'tokenize "invalid syntax" c)]))) (die/p-1 p 'tokenize "invalid syntax" c)])))
@ -1441,7 +1441,7 @@
(lambda (x) (lambda (x)
(let ([loc (cdr x)]) (let ([loc (cdr x)])
(when (loc-set? loc) ;;; FIXME: pos (when (loc-set? loc) ;;; FIXME: pos
(die 'read "duplicate mark" n)) (die/p p 'read "duplicate mark" n))
(set-loc-value! loc expr) (set-loc-value! loc expr)
(set-loc-value^! loc expr^) (set-loc-value^! loc expr^)
(set-loc-set?! loc #t) (set-loc-set?! loc #t)
@ -1460,7 +1460,7 @@
(let ([loc (make-loc #f 'unused #f)]) (let ([loc (make-loc #f 'unused #f)])
(let ([locs (cons (cons n loc) locs)]) (let ([locs (cons (cons n loc) locs)])
(values loc 'unused locs k)))]))] (values loc 'unused locs k)))]))]
[else (die 'read "invalid token" t)])] [else (die/p p 'read "invalid token" t)])]
[else [else
(die/p-1 p 'read (die/p-1 p 'read
(format "unexpected ~s found" t))]))) (format "unexpected ~s found" t))])))
@ -1474,11 +1474,11 @@
(parse-token p locs k t pos))))) (parse-token p locs k t pos)))))
(define reduce-loc! (define (reduce-loc! p)
(lambda (x) (lambda (x)
(let ([loc (cdr x)]) (let ([loc (cdr x)])
(unless (loc-set? loc) (unless (loc-set? loc)
(die 'read "referenced mark is not set" (car x))) (die/p p 'read "referenced mark is not set" (car x)))
(when (loc? (loc-value loc)) (when (loc? (loc-value loc))
(let f ([h loc] [t loc]) (let f ([h loc] [t loc])
(if (loc? h) (if (loc? h)
@ -1486,7 +1486,7 @@
(if (loc? h1) (if (loc? h1)
(begin (begin
(when (eq? h1 t) (when (eq? h1 t)
(die 'read "circular marks")) (die/p p 'read "circular marks"))
(let ([v (f (loc-value h1) (loc-value t))]) (let ([v (f (loc-value h1) (loc-value t))])
(set-loc-value! h1 v) (set-loc-value! h1 v)
(set-loc-value! h v) (set-loc-value! h v)
@ -1511,7 +1511,7 @@
(cond (cond
[(null? locs) expr] [(null? locs) expr]
[else [else
(for-each reduce-loc! locs) (for-each (reduce-loc! p) locs)
(k) (k)
(if (loc? expr) (if (loc? expr)
(loc-value expr) (loc-value expr)
@ -1523,7 +1523,7 @@
(cond (cond
[(null? locs) expr] [(null? locs) expr]
[else [else
(for-each reduce-loc! locs) (for-each (reduce-loc! p) locs)
(k) (k)
(if (loc? expr) (if (loc? expr)
(loc-value expr) (loc-value expr)
@ -1538,7 +1538,7 @@
(cond (cond
[(null? locs) (return-annotated expr^)] [(null? locs) (return-annotated expr^)]
[else [else
(for-each reduce-loc! locs) (for-each (reduce-loc! p) locs)
(k) (k)
(if (loc? expr) (if (loc? expr)
(loc-value^ expr) (loc-value^ expr)
@ -1551,7 +1551,7 @@
(cond (cond
[(null? locs) (return-annotated expr^)] [(null? locs) (return-annotated expr^)]
[else [else
(for-each reduce-loc! locs) (for-each (reduce-loc! p) locs)
(k) (k)
(if (loc? expr) (if (loc? expr)
(loc-value^ expr) (loc-value^ expr)

2
scheme/last-revision
View File

@ -1 +1 @@
1832 1833