mirror of
https://github.com/false-schemers/skint.git
synced 2025-01-21 19:27:27 +01:00
internal (read) in n.{sf,c} is now R7RS-compatible
This commit is contained in:
ESL
parent
8dc87ec18f
commit
72c49980a8
4 changed files with 3644 additions and 2406 deletions
37
k.c
37
k.c
|
|
@ -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 */
|
||||
|
|
|
|||
555
src/n.sf
555
src/n.sf
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Reference in a new issue