internal (read) in n.{sf,c} is now R7RS-compatible

This commit is contained in:
ESL 2023-03-26 16:29:57 -04:00
parent 8dc87ec18f
commit 72c49980a8
4 changed files with 3644 additions and 2406 deletions

37
k.c
View file

@ -422,6 +422,7 @@ extern void oportputshared(obj x, obj p, int disp);
#include "i.h"
/* cx globals */
extern obj cx__25read; /* %read */
extern obj cx__25residual_2Dcadr; /* %residual-cadr */
extern obj cx__25residual_2Dcdr; /* %residual-cdr */
extern obj cx__25residual_2Dcons; /* %residual-cons */
@ -438,7 +439,6 @@ extern obj cx_error; /* error */
extern obj cx_file_2Derror; /* file-error */
extern obj cx_fixnum_2D_3Estring; /* fixnum->string */
extern obj cx_flonum_2D_3Estring; /* flonum->string */
extern obj cx_read_2Ddatum; /* read-datum */
extern obj cx_write_2Dserialized_2Dsexp; /* write-serialized-sexp */
obj cx__25residual_2Dbinding_2Dset_2Dval_21; /* %residual-binding-set-val! */
obj cx__25residual_2Dbinding_2Dspecial_3F; /* %residual-binding-special? */
@ -21403,13 +21403,14 @@ s_l_v10593: /* ek r k */
*--hp = r[1];
*--hp = obj_from_case(463);
r[3] = (hendblk(2+1));
r[4+0] = (cx_read_2Ddatum);
r[4+0] = (cx__25read);
pc = objptr_from_obj(r[4+0])[0];
r[4+1] = r[3];
r[4+2] = r[1];
r[4+3] = obj_from_bool(0);
r += 4; /* shift reg wnd */
rreserve(MAX_HOSTREGS);
rc = 3;
rc = 4;
goto jump;
case 463: /* clo ek r */
@ -21473,12 +21474,13 @@ case 465: /* clo ek . */
*--hp = r[3];
*--hp = obj_from_case(466);
r[5] = (hendblk(2+1));
r[0] = (cx_read_2Ddatum);
r[0] = (cx__25read);
pc = objptr_from_obj(r[0])[0];
r[1] = r[5];
/* r[2] */
r[3] = obj_from_bool(0);
rreserve(MAX_HOSTREGS);
rc = 3;
rc = 4;
goto jump;
case 466: /* clo ek r */
@ -21748,13 +21750,14 @@ s_l_v10515: /* ek r k */
*--hp = r[1];
*--hp = obj_from_case(476);
r[3] = (hendblk(2+1));
r[4+0] = (cx_read_2Ddatum);
r[4+0] = (cx__25read);
pc = objptr_from_obj(r[4+0])[0];
r[4+1] = r[3];
r[4+2] = r[1];
r[4+3] = obj_from_bool(0);
r += 4; /* shift reg wnd */
rreserve(MAX_HOSTREGS);
rc = 3;
rc = 4;
goto jump;
case 476: /* clo ek r */
@ -21818,12 +21821,13 @@ case 478: /* clo ek . */
*--hp = r[3];
*--hp = obj_from_case(479);
r[5] = (hendblk(2+1));
r[0] = (cx_read_2Ddatum);
r[0] = (cx__25read);
pc = objptr_from_obj(r[0])[0];
r[1] = r[5];
/* r[2] */
r[3] = obj_from_bool(0);
rreserve(MAX_HOSTREGS);
rc = 3;
rc = 4;
goto jump;
case 479: /* clo ek r */
@ -22649,12 +22653,13 @@ case 505: /* clo ek r */
*--hp = r[2];
*--hp = obj_from_case(506);
r[6] = (hendblk(3+1));
r[0] = (cx_read_2Ddatum);
r[0] = (cx__25read);
pc = objptr_from_obj(r[0])[0];
r[1] = r[6];
r[2] = (objptr_from_obj(r[2])[0]);
r[3] = obj_from_bool(0);
rreserve(MAX_HOSTREGS);
rc = 3;
rc = 4;
goto jump;
case 506: /* clo ek r */
@ -22726,12 +22731,13 @@ case 508: /* clo ek . */
*--hp = r[3];
*--hp = obj_from_case(509);
r[5] = (hendblk(2+1));
r[0] = (cx_read_2Ddatum);
r[0] = (cx__25read);
pc = objptr_from_obj(r[0])[0];
r[1] = r[5];
r[2] = (objptr_from_obj(r[2])[0]);
r[3] = obj_from_bool(0);
rreserve(MAX_HOSTREGS);
rc = 3;
rc = 4;
goto jump;
case 509: /* clo ek r */
@ -23534,13 +23540,14 @@ case 540: /* repl-read k iport */
r += 1; /* shift reg. wnd */
gs_repl_2Dread: /* k iport */
(void)(((r[1]) == (cx__2Acurrent_2Dinput_2Dport_2A)) ? (void)(oportputcircular((cx__234830), (cx__2Acurrent_2Doutput_2Dport_2A), 1)) : (void)(0));
r[2+0] = (cx_read_2Ddatum);
r[2+0] = (cx__25read);
pc = objptr_from_obj(r[2+0])[0];
r[2+1] = r[0];
r[2+2] = r[1];
r[2+3] = obj_from_bool(0);
r += 2; /* shift reg wnd */
rreserve(MAX_HOSTREGS);
rc = 3;
rc = 4;
goto jump;
case 541: /* repl-from-port k iport */

5456
n.c

File diff suppressed because it is too large Load diff

555
src/n.sf
View file

@ -3586,261 +3586,347 @@ void oportputshared(obj x, obj p, int disp) {
; S-expression reader
(define read-datum
(let* ([reader-token-marker (list 'reader-token)]
[close-paren (cons reader-token-marker "right parenthesis")]
[close-bracket (cons reader-token-marker "right bracket")]
[dot (cons reader-token-marker "\" . \"")])
(define (%read port simple?)
(define-syntax r-error
(syntax-rules () [(_ p msg a ...) (read-error msg a ... 'port: p)]))
(define-syntax r-error
(syntax-rules () [(_ p msg a ...) (read-error msg a ... 'port: p)])) ; see read-error below
(define shared '())
(define (make-shared-ref loc) (lambda () (unbox loc)))
(define (shared-ref? form) (procedure? form))
(define (patch-ref! form) (if (procedure? form) (patch-ref! (form)) form))
(define (patch-shared! form)
(cond [(pair? form)
(if (procedure? (car form))
(set-car! form (patch-ref! (car form)))
(patch-shared! (car form)))
(if (procedure? (cdr form))
(set-cdr! form (patch-ref! (cdr form)))
(patch-shared! (cdr form)))]
[(vector? form)
(let loop ([i 0])
(when (fx<? i (vector-length form))
(let ([fi (vector-ref form i)])
(if (procedure? fi)
(vector-set! form i (patch-ref! fi))
(patch-shared! fi)))
(loop (fx+ i 1))))]
[(box? form)
(if (procedure? (unbox form))
(set-box! form (patch-shared! (unbox form)))
(patch-shared! (unbox form)))]))
(define (patch-shared form) (patch-shared! form) form)
(define (reader-token? form)
(and (pair? form) (eq? (car form) reader-token-marker)))
(define reader-token-marker #f)
(define close-paren #f)
(define close-bracket #f)
(define dot #f)
(define ; idless
(let ([rtm (list 'reader-token)])
(set! reader-token-marker rtm)
(set! close-paren (cons rtm "right parenthesis"))
(set! close-bracket (cons rtm "right bracket"))
(set! dot (cons rtm "\" . \""))))
(define (char-symbolic? c)
(string-position c
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!$%&*/:<=>?^_~0123456789+-.@"))
(define (reader-token? form)
(and (pair? form) (eq? (car form) reader-token-marker)))
(define (char-hex-digit? c)
(let ([scalar-value (char->integer c)])
(or (and (>= scalar-value 48) (<= scalar-value 57))
(and (>= scalar-value 65) (<= scalar-value 70))
(and (>= scalar-value 97) (<= scalar-value 102)))))
(define (char-symbolic? c)
(string-position c
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!$%&*/:<=>?^_~0123456789+-.@"))
(define (char-delimiter? c)
(or (char-whitespace? c)
(char=? c #\)) (char=? c #\()
(char=? c #\]) (char=? c #\[)
(char=? c #\") (char=? c #\;)))
(define (char-hex-digit? c)
(let ([scalar-value (char->integer c)])
(or (and (>= scalar-value 48) (<= scalar-value 57))
(and (>= scalar-value 65) (<= scalar-value 70))
(and (>= scalar-value 97) (<= scalar-value 102)))))
(define (sub-read-carefully p)
(let ([form (sub-read p)])
(cond [(eof-object? form)
(r-error p "unexpected end of file")]
[(reader-token? form)
(r-error p "unexpected token:" (cdr form))]
[else form])))
(define (char-delimiter? c)
(or (char-whitespace? c)
(char=? c #\)) (char=? c #\()
(char=? c #\]) (char=? c #\[)
(char=? c #\") (char=? c #\;)))
(define (sub-read p)
(let ([c (read-char p)])
(cond [(eof-object? c) c]
[(char-whitespace? c) (sub-read p)]
[(char=? c #\() (sub-read-list c p close-paren #t)]
[(char=? c #\)) close-paren]
[(char=? c #\[) (sub-read-list c p close-bracket #t)]
[(char=? c #\]) close-bracket]
[(char=? c #\') (list 'quote (sub-read-carefully p))]
[(char=? c #\`) (list 'quasiquote (sub-read-carefully p))]
[(char-symbolic? c) (sub-read-number-or-symbol c p)]
[(char=? c #\;)
(let loop ([c (read-char p)])
(or (eof-object? c) (char=? c #\newline)
(loop (read-char p))))
(sub-read p)]
[(char=? c #\,)
(let ([next (peek-char p)])
(cond [(eof-object? next)
(r-error p "end of file after ,")]
[(char=? next #\@)
(read-char p)
(list 'unquote-splicing (sub-read-carefully p))]
[else (list 'unquote (sub-read-carefully p))]))]
[(char=? c #\")
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a string")]
[(char=? c #\\)
(loop (cons (sub-read-string-char-escape p) l))]
[(char=? c #\") (list->string (reverse! l))]
[else (loop (cons c l))])))]
[(char=? c #\#)
(let ([c (peek-char p)])
(cond [(eof-object? c) (r-error p "end of file after #")]
[(char-ci=? c #\t) (read-char p) #t]
[(char-ci=? c #\f) (read-char p) #f]
[(or (char-ci=? c #\b) (char-ci=? c #\o)
(char-ci=? c #\d) (char-ci=? c #\x)
(char-ci=? c #\i) (char-ci=? c #\e))
(sub-read-number-or-symbol #\# p)]
[(char=? c #\&)
(read-char p)
(box (sub-read-carefully p))]
[(char=? c #\;)
(read-char p)
(sub-read-carefully p)
(sub-read p)]
[(char=? c #\|)
(read-char p)
(let recur () ;starts right after opening #|
(let ([next (read-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\|)
(let ([next (peek-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\#) (read-char p)]
[else (recur)]))]
[(char=? next #\#)
(let ([next (peek-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\|) (read-char p) (recur) (recur)]
[else (recur)]))]
[else (recur)])))
(sub-read p)]
[(char=? c #\() ;)
(read-char p)
(list->vector (sub-read-list c p close-paren #f))]
[(char=? c #\u)
(read-char p)
(if (and (eq? (read-char p) #\8) (eq? (read-char p) #\())
(list->bytevector (sub-read-byte-list p))
(r-error p "invalid bytevector syntax"))]
(define (sub-read-carefully p)
(let ([form (sub-read p)])
(cond [(eof-object? form)
(r-error p "unexpected end of file")]
[(reader-token? form)
(r-error p "unexpected token:" (cdr form))]
[else form])))
(define (sub-read p)
(let ([c (read-char p)])
(cond [(eof-object? c) c]
[(char-whitespace? c) (sub-read p)]
[(char=? c #\() (sub-read-list c p close-paren #t)]
[(char=? c #\)) close-paren]
[(char=? c #\[) (sub-read-list c p close-bracket #t)]
[(char=? c #\]) close-bracket]
[(char=? c #\') (list 'quote (sub-read-carefully p))]
[(char=? c #\`) (list 'quasiquote (sub-read-carefully p))]
[(char-symbolic? c) (sub-read-number-or-symbol c p)]
[(char=? c #\;)
(let loop ([c (read-char p)])
(or (eof-object? c) (char=? c #\newline)
(loop (read-char p))))
(sub-read p)]
[(char=? c #\,)
(let ([next (peek-char p)])
(cond [(eof-object? next)
(r-error p "end of file after ,")]
[(char=? next #\@)
(read-char p)
(list 'unquote-splicing (sub-read-carefully p))]
[else (list 'unquote (sub-read-carefully p))]))]
[(char=? c #\")
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a string")]
[(char=? c #\\)
(read-char p)
(let ([c (peek-char p)])
(let ([e (sub-read-strsym-char-escape p 'string)])
(loop (if e (cons e l) l)))]
[(char=? c #\") (list->string (reverse! l))]
[else (loop (cons c l))])))]
[(char=? c #\|)
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a |symbol|")]
[(char=? c #\\)
(let ([e (sub-read-strsym-char-escape p 'symbol)])
(loop (if e (cons e l) l)))]
[(char=? c #\|) (string->symbol (list->string (reverse! l)))]
[else (loop (cons c l))])))]
[(char=? c #\#)
(let ([c (peek-char p)])
(cond [(eof-object? c) (r-error p "end of file after #")]
[(or (char-ci=? c #\t) (char-ci=? c #\f))
(let ([name (sub-read-carefully p)])
(case name [(t true) #t] [(f false) #f]
[else (r-error p "unexpected name after #" name)]))]
[(or (char-ci=? c #\b) (char-ci=? c #\o)
(char-ci=? c #\d) (char-ci=? c #\x)
(char-ci=? c #\i) (char-ci=? c #\e))
(sub-read-number-or-symbol #\# p)]
[(char=? c #\&)
(read-char p)
(box (sub-read-carefully p))]
[(char=? c #\;)
(read-char p)
(sub-read-carefully p)
(sub-read p)]
[(char=? c #\|)
(read-char p)
(let recur () ;starts right after opening #|
(let ([next (read-char p)])
(cond
[(eof-object? c)
(r-error p "end of file after #\\")]
[(char=? #\x c)
(read-char p)
(if (char-delimiter? (peek-char p))
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\|)
(let ([next (peek-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\#) (read-char p)]
[else (recur)]))]
[(char=? next #\#)
(let ([next (peek-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\|) (read-char p) (recur) (recur)]
[else (recur)]))]
[else (recur)])))
(sub-read p)]
[(char=? c #\() ;)
(read-char p)
(list->vector (sub-read-list c p close-paren #f))]
[(char=? c #\u)
(read-char p)
(if (and (eq? (read-char p) #\8) (eq? (read-char p) #\())
(list->bytevector (sub-read-byte-list p))
(r-error p "invalid bytevector syntax"))]
[(char=? c #\\)
(read-char p)
(let ([c (peek-char p)])
(cond
[(eof-object? c)
(r-error p "end of file after #\\")]
[(char=? #\x c)
(read-char p)
(if (char-delimiter? (peek-char p))
c
(sub-read-x-char-escape p #f))]
[(char-alphabetic? c)
(let ([name (sub-read-carefully p)])
(if (= (string-length (symbol->string name)) 1)
c
(sub-read-x-char-escape p #f))]
[(char-alphabetic? c)
(let ([name (sub-read-carefully p)])
(if (= (string-length (symbol->string name)) 1)
c
(case name
[(space) #\space]
[(alarm) #\alarm]
[(backspace) #\backspace]
[(tab) #\tab]
[(newline linefeed) #\newline]
[(vtab) #\vtab]
[(page) #\page]
[(return) #\return]
[else (r-error p "unknown #\\ name" name)])))]
[else (read-char p) c]))]
[else (r-error p "unknown # syntax" c)]))]
[else (r-error p "illegal character read" c)])))
(case name
[(null) (integer->char #x00)]
[(space) #\space]
[(alarm) #\alarm]
[(backspace) #\backspace]
[(delete) (integer->char #x7F)] ; todo: support by SFC
[(escape) (integer->char #x1B)]
[(tab) #\tab]
[(newline linefeed) #\newline]
[(vtab) #\vtab]
[(page) #\page]
[(return) #\return]
[else (r-error p "unknown #\\ name" name)])))]
[else (read-char p) c]))]
[(char-numeric? c)
(when simple? (r-error p "#N=/#N# notation is not allowed in this mode"))
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a #N notation")]
[(char-numeric? c)
(loop (cons c l))]
[(char=? c #\#)
(let* ([s (list->string (reverse! l))] [n (string->number s)])
(cond [(and (fixnum? n) (assq n shared)) => cdr]
[else (r-error "unknown #n# reference:" s)]))]
[(char=? c #\=)
(let* ([s (list->string (reverse! l))] [n (string->number s)])
(cond [(not (fixnum? n)) (r-error "invalid #n= reference:" s)]
[(assq n shared) (r-error "duplicate #n= tag:" n)])
(let ([loc (box #f)])
(set! shared (cons (cons n (make-shared-ref loc)) shared))
(let ([form (sub-read-carefully p)])
(cond [(shared-ref? form) (r-error "#n= has another label as target" s)]
[else (set-box! loc form) form]))))]
[else (r-error p "invalid terminator for #N notation")])))]
[else (r-error p "unknown # syntax" c)]))]
[else (r-error p "illegal character read" c)])))
(define (sub-read-list c p close-token dot?)
(let ([form (sub-read p)])
(if (eq? form dot)
(r-error p "missing car -- ( immediately followed by .") ;)
(let recur ([form form])
(cond [(eof-object? form)
(r-error p "eof inside list -- unbalanced parentheses")]
[(eq? form close-token) '()]
[(eq? form dot)
(if dot?
(let* ([last-form (sub-read-carefully p)]
[another-form (sub-read p)])
(if (eq? another-form close-token)
last-form
(r-error p "randomness after form after dot" another-form)))
(r-error p "dot in #(...)"))]
[(reader-token? form)
(r-error p "error inside list --" (cdr form))]
[else (cons form (recur (sub-read p)))])))))
(define (sub-read-list c p close-token dot?)
(let ([form (sub-read p)])
(if (eq? form dot)
(r-error p "missing car -- ( immediately followed by .") ;)
(let recur ([form form])
(cond [(eof-object? form)
(r-error p "eof inside list -- unbalanced parentheses")]
[(eq? form close-token) '()]
[(eq? form dot)
(if dot?
(let* ([last-form (sub-read-carefully p)]
[another-form (sub-read p)])
(if (eq? another-form close-token)
last-form
(r-error p "randomness after form after dot" another-form)))
(r-error p "dot in #(...)"))]
[(reader-token? form)
(r-error p "error inside list --" (cdr form))]
[else (cons form (recur (sub-read p)))])))))
(define (sub-read-byte-list p)
(let recur ([form (sub-read p)])
(cond [(eof-object? form)
(r-error p "eof inside bytevector")]
[(eq? form close-paren) '()]
[(reader-token? form)
(r-error p "error inside bytevector --" (cdr form))]
[(or (not (fixnum? form)) (fx<? form 0) (fx>? form 255))
(r-error p "invalid byte inside bytevector --" form)]
[else (cons form (recur (sub-read p)))])))
(define (sub-read-byte-list p)
(let recur ([form (sub-read p)])
(cond [(eof-object? form)
(r-error p "eof inside bytevector")]
[(eq? form close-paren) '()]
[(reader-token? form)
(r-error p "error inside bytevector --" (cdr form))]
[(or (not (fixnum? form)) (fx<? form 0) (fx>? form 255))
(r-error p "invalid byte inside bytevector --" form)]
[else (cons form (recur (sub-read p)))])))
(define (sub-read-string-char-escape p)
(let ([c (read-char p)])
(if (eof-object? c)
(r-error p "end of file within a string"))
(cond [(or (char=? c #\\) (char=? c #\")) c]
[(char=? c #\a) #\alarm]
[(char=? c #\b) #\backspace]
[(char=? c #\t) #\tab]
[(char=? c #\n) #\newline]
[(char=? c #\v) #\vtab]
[(char=? c #\f) #\page]
[(char=? c #\r) #\return]
[(char=? c #\x) (sub-read-x-char-escape p #t)]
[else (r-error p "invalid char escape in string" c)])))
(define (sub-read-strsym-char-escape p what)
(let ([c (read-char p)])
(if (eof-object? c)
(r-error p "end of file within a" what))
(cond [(or (char=? c #\\) (char=? c #\") (char=? c #\|)) c]
[(char=? c #\a) #\alarm]
[(char=? c #\b) #\backspace]
[(char=? c #\t) #\tab]
[(char=? c #\n) #\newline]
[(char=? c #\v) #\vtab]
[(char=? c #\f) #\page]
[(char=? c #\r) #\return]
[(char=? c #\x) (sub-read-x-char-escape p #t)]
[(and (eq? what 'string) (char-whitespace? c))
(let loop ([gotnl (char=? c #\newline)] [nc (peek-char p)])
(cond [(or (eof-object? nc) (not (char-whitespace? nc)))
(if gotnl #f (r-error p "no newline in line ending escape"))]
[(and gotnl (char=? nc #\newline)) #f]
[else (read-char p) (loop (or gotnl (char=? nc #\newline)) (peek-char p))]))]
[else (r-error p "invalid char escape in" what ': c)])))
(define (sub-read-x-char-escape p in-string?)
(define (rev-digits->char l)
(if (null? l)
(r-error p "\\x escape sequence is too short")
(integer->char (string->fixnum (list->string (reverse! l)) 16))))
(let loop ([c (peek-char p)] [l '()] [cc 0])
(cond [(eof-object? c)
(if in-string?
(r-error p "end of file within a string")
(rev-digits->char l))]
[(and in-string? (char=? c #\;))
(read-char p)
(rev-digits->char l)]
[(and (not in-string?) (char-delimiter? c))
(rev-digits->char l)]
[(not (char-hex-digit? c))
(r-error p "unexpected char in \\x escape sequence" c)]
[(> cc 2)
(r-error p "\\x escape sequence is too long")]
[else
(read-char p)
(loop (peek-char p) (cons c l) (+ cc 1))])))
(define (sub-read-x-char-escape p in-string?)
(define (rev-digits->char l)
(if (null? l)
(r-error p "\\x escape sequence is too short")
(integer->char (string->fixnum (list->string (reverse! l)) 16))))
(let loop ([c (peek-char p)] [l '()] [cc 0])
(cond [(eof-object? c)
(if in-string?
(r-error p "end of file within a string")
(rev-digits->char l))]
[(and in-string? (char=? c #\;))
(read-char p)
(rev-digits->char l)]
[(and (not in-string?) (char-delimiter? c))
(rev-digits->char l)]
[(not (char-hex-digit? c))
(r-error p "unexpected char in \\x escape sequence" c)]
[(> cc 2)
(r-error p "\\x escape sequence is too long")]
[else
(read-char p)
(loop (peek-char p) (cons c l) (+ cc 1))])))
(define (sub-read-number-or-symbol c p)
(let loop ([c (peek-char p)] [l (list c)] [hash? (char=? c #\#)])
(cond [(or (eof-object? c) (char-delimiter? c))
(let* ([l (reverse! l)] [c (car l)] [s (list->string l)])
(if (or hash? (char-numeric? c)
(char=? c #\+) (char=? c #\-) (char=? c #\.))
(cond [(string=? s ".") dot]
[(or (string=? s "+") (string=? s "-") (string=? s "..."))
(string->symbol s)]
[(and (not hash?)
(>= (string-length s) 2)
(char=? (string-ref s 0) #\-)
(char=? (string-ref s 1) #\>))
(string->symbol s)]
[(string->number s)]
[else (r-error p "unsupported number syntax (implementation restriction)" s)])
(string->symbol s)))]
[(char=? c #\#)
(read-char p)
(loop (peek-char p) (cons c l) #t)]
[(char-symbolic? c)
(read-char p)
(loop (peek-char p) (cons c l) hash?)]
[else (r-error p "unexpected number/symbol char" c)])))
(lambda (p) ; body of read-datum
(let ([form (sub-read p)])
(if (not (reader-token? form))
form
(r-error p "unexpected token:" (cdr form)))))))
(define (suspect-number-or-symbol-peculiar? hash? c l s)
(cond [(or hash? (char-numeric? c)) #f]
[(or (string-ci=? s "+i") (string-ci=? s "-i")) #f]
[(or (string-ci=? s "+nan.0") (string-ci=? s "-nan.0")) #f]
[(or (string-ci=? s "+inf.0") (string-ci=? s "-inf.0")) #f]
[(or (char=? c #\+) (char=? c #\-))
(cond [(null? (cdr l)) #t]
[(char=? (cadr l) #\.) (and (pair? (cddr l)) (not (char-numeric? (caddr l))))]
[else (not (char-numeric? (cadr l)))])]
[else (and (char=? c #\.) (pair? (cdr l)) (not (char-numeric? (cadr l))))]))
(define-inline (get-datum p)
(read-datum p))
(define (sub-read-number-or-symbol c p)
(let loop ([c (peek-char p)] [l (list c)] [hash? (char=? c #\#)])
(cond [(or (eof-object? c) (char-delimiter? c))
(let* ([l (reverse! l)] [c (car l)] [s (list->string l)])
(if (or hash? (char-numeric? c)
(char=? c #\+) (char=? c #\-) (char=? c #\.))
(cond [(string=? s ".") dot]
[(suspect-number-or-symbol-peculiar? hash? c l s) (string->symbol s)]
[(string->number s)]
[else (r-error p "unsupported number syntax (implementation restriction)" s)])
(string->symbol s)))]
[(char=? c #\#)
(read-char p)
(loop (peek-char p) (cons c l) #t)]
[(char-symbolic? c)
(read-char p)
(loop (peek-char p) (cons c l) hash?)]
[else (r-error p "unexpected number/symbol char" c)])))
; body of %read
(let ([form (sub-read port)])
(if (not (reader-token? form))
(if (null? shared) form (patch-shared form))
(r-error port "unexpected token:" (cdr form)))))
(define-syntax read
(syntax-rules ()
[(_) (read-datum (current-input-port))]
[(_ p) (read-datum p)]
[(_) (%read (current-input-port) #f)]
[(_ p) (%read p #f)]
[_ %residual-read]))
(define-syntax read-simple
(syntax-rules ()
[(_) (%read (current-input-port) #t)]
[(_ p) (%read p #t)]
[_ %residual-read-simple]))
(define-inline (get-datum p)
(%read p #f))
; file system
@ -4341,5 +4427,6 @@ void oportputshared(obj x, obj p, int disp) {
(define %residual-display (unary-binary-adaptor display))
(define %residual-read (nullary-unary-adaptor read))
(define %residual-read-simple (nullary-unary-adaptor read-simple))
(define %residual-exit (nullary-unary-adaptor exit))

View file

@ -1155,7 +1155,7 @@
(define (%read port simple?)
(define-syntax r-error
(syntax-rules () [(_ p msg a ...) (read-error msg a ... 'port: p)])) ; see read-error below
(syntax-rules () [(_ p msg a ...) (read-error msg a ... 'port: p)]))
(define shared '())
(define (make-shared-ref loc) (lambda () (unbox loc)))