>From a6773f5f7aa61d96ded8c1a496f41eaa6739161b Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 28 Sep 2013 22:14:16 +0200 Subject: [PATCH 3/4] =?UTF-8?q?Fix=20several=20subtle=20problems=20in=20th?= =?UTF-8?q?e=20reader=20caused=20by=20calling=20char=3D=3F=20on=20EOF?= --- eval.scm | 4 +- library.scm | 230 +++++++++++++++++++++++++++++++++--------------------------- 2 files changed, 127 insertions(+), 107 deletions(-) diff --git a/eval.scm b/eval.scm index b6d72fd..bf447d8 100644 --- a/eval.scm +++ b/eval.scm @@ -1011,7 +1011,7 @@ (lambda () #f) (lambda () (let ((c1 (peek-char in))) - (when (char=? c1 (integer->char 127)) + (when (eq? c1 (integer->char 127)) (##sys#error 'load (##sys#string-append @@ -1623,7 +1623,7 @@ (##sys#read-prompt-hook) (let ([exp ((or ##sys#repl-read-hook read))]) (unless (eof-object? exp) - (when (char=? #\newline (##sys#peek-char-0 ##sys#standard-input)) + (when (eq? #\newline (##sys#peek-char-0 ##sys#standard-input)) (##sys#read-char-0 ##sys#standard-input) ) (##sys#clear-trace-buffer) (set! ##sys#unbound-in-eval '()) diff --git a/library.scm b/library.scm index 2d56328..c2bae34 100644 --- a/library.scm +++ b/library.scm @@ -1473,10 +1473,18 @@ EOF (let ((char-downcase char-downcase)) (set! char-ci=? (lambda (x y) (eq? (char-downcase x) (char-downcase y)))) - (set! char-ci>? (lambda (x y) (fx> (char-downcase x) (char-downcase y)))) - (set! char-ci=? (lambda (x y) (fx>= (char-downcase x) (char-downcase y)))) - (set! char-ci<=? (lambda (x y) (fx<= (char-downcase x) (char-downcase y)))) ) + (set! char-ci>? (lambda (x y) + (##core#inline "C_i_char_greaterp" + (char-downcase x) (char-downcase y)))) + (set! char-ci=? (lambda (x y) + (##core#inline "C_i_char_greater_or_equal_p" + (char-downcase x) (char-downcase y)))) + (set! char-ci<=? (lambda (x y) + (##core#inline "C_i_char_less_or_equal_p" + (char-downcase x) (char-downcase y)))) ) (define (char-upper-case? c) (##sys#check-char c 'char-upper-case?) @@ -2680,7 +2688,7 @@ EOF (else (build-symbol tok)) ) ) ) ) ) )) (define (r-number-with-exactness radix) - (cond [(char=? #\# (##sys#peek-char-0 port)) + (cond [(eq? #\# (##sys#peek-char-0 port)) (##sys#read-char-0 port) (let ([c2 (##sys#read-char-0 port)]) (cond [(eof-object? c2) @@ -2694,7 +2702,7 @@ EOF [else (r-number radix #f)] ) ) (define (r-number-with-radix exactness) - (cond [(char=? #\# (##sys#peek-char-0 port)) + (cond [(eq? #\# (##sys#peek-char-0 port)) (##sys#read-char-0 port) (let ([c2 (##sys#read-char-0 port)]) (cond [(eof-object? c2) (##sys#read-error port "unexpected end of numeric literal")] @@ -2858,7 +2866,7 @@ EOF ":" (##sys#string-append kwprefix tok)) )) - ; now have the state to make a decision. + ;; now have the state to make a decision. (set! reserved-characters (append (if (not psp) '(#\[ #\] #\{ #\}) '()) (if (not sep) '(#\|) '()))) @@ -2866,13 +2874,14 @@ EOF (r-spaces) (let* ((c (##sys#peek-char-0 port)) (srst (##sys#slot crt 1)) - (h (and srst (##sys#slot srst (char->integer c)) ) ) ) + (h (and (not (eof-object? c)) srst + (##sys#slot srst (char->integer c)) ) ) ) (if h - ;then handled by read-table entry + ;; then handled by read-table entry (##sys#call-with-values (lambda () (h c port)) (lambda xs (if (null? xs) (readrec) (car xs)))) - ;otherwise chicken extended r5rs syntax + ;; otherwise chicken extended r5rs syntax (case c ((#\') (##sys#read-char-0 port) @@ -2889,101 +2898,112 @@ EOF ((#\#) (##sys#read-char-0 port) (let ((dchar (##sys#peek-char-0 port))) - (if (char-numeric? dchar) - (let* ((n (string->number (r-digits))) - (dchar (##sys#peek-char-0 port)) - (spdrst (##sys#slot crt 3)) - (h (and spdrst (##sys#slot spdrst (char->integer dchar)) ) ) ) - ;# handled by parameterized # read-table entry? - (cond (h (##sys#call-with-values - (lambda () (h dchar port n)) - (lambda xs (if (null? xs) (readrec) (car xs))))) - ;#? - ((or (eq? dchar #\)) (char-whitespace? dchar)) - (##sys#sharp-number-hook port n)) - (else (##sys#read-error - port - "invalid parameterized read syntax" - dchar n) ) ) ) - (let* ((sdrst (##sys#slot crt 2)) - (h (and sdrst (##sys#slot sdrst (char->integer dchar)) ) ) ) - (if h - ;then handled by # read-table entry - (##sys#call-with-values - (lambda () (h dchar port)) - (lambda xs (if (null? xs) (readrec) (car xs)))) - ;otherwise chicken extended r5rs syntax - (case (char-downcase dchar) - ((#\x) (##sys#read-char-0 port) (r-number-with-exactness 16)) - ((#\d) (##sys#read-char-0 port) (r-number-with-exactness 10)) - ((#\o) (##sys#read-char-0 port) (r-number-with-exactness 8)) - ((#\b) (##sys#read-char-0 port) (r-number-with-exactness 2)) - ((#\i) (##sys#read-char-0 port) (r-number-with-radix 'i)) - ((#\e) (##sys#read-char-0 port) (r-number-with-radix 'e)) - ((#\c) - (##sys#read-char-0 port) - (let ([c (##sys#read-char-0 port)]) - (fluid-let ([csp - (cond [(eof-object? c) - (##sys#read-error port "unexpected end of input while reading `#c...' sequence")] - [(eq? c #\i) #f] - [(eq? c #\s) #t] - [else (##sys#read-error port "invalid case specifier in `#c...' sequence" c)] ) ] ) - (readrec) ) ) ) - ((#\() (r-vector)) - ((#\\) (##sys#read-char-0 port) (r-char)) - ((#\|) - (##sys#read-char-0 port) - (r-comment) (readrec) ) - ((#\#) - (##sys#read-char-0 port) - (r-ext-symbol) ) - ((#\;) - (##sys#read-char-0 port) - (readrec) (readrec) ) - ((#\`) - (##sys#read-char-0 port) - (list 'quasisyntax (readrec)) ) - ((#\$) - (##sys#read-char-0 port) - (let ((c (##sys#peek-char-0 port))) - (cond ((char=? c #\{) - (##sys#read-char-0 port) - (##sys#read-bytevector-literal port)) - (else (list 'location (readrec)) )))) - ((#\:) - (##sys#read-char-0 port) - (let ((tok (r-token))) - (if (eq? 0 (##sys#size tok)) - (##sys#read-error port "empty keyword") - (build-keyword tok)))) - ((#\%) - (build-symbol (##sys#string-append "#" (r-token))) ) - ((#\+) - (##sys#read-char-0 port) - (let ((tst (readrec))) - (list 'cond-expand (list tst (readrec)) '(else)) ) ) - ((#\!) - (##sys#read-char-0 port) - (let ((c (##sys#peek-char-0 port))) - (cond ((or (char-whitespace? c) (char=? #\/ c)) - (skip-to-eol) - (readrec) ) - (else - (let ([tok (r-token)]) - (cond [(string=? "eof" tok) #!eof] - [(member tok '("optional" "rest" "key")) - (build-symbol (##sys#string-append "#!" tok)) ] - [else - (let ((a (assq (string->symbol tok) read-marks))) - (if a - ((##sys#slot a 1) port) - (##sys#read-error - port - "invalid `#!' token" tok) ) ) ] ) ) ) ) ) ) - (else - (##sys#call-with-values (lambda () (##sys#user-read-hook dchar port)) - (lambda xs (if (null? xs) (readrec) (car xs)))) ) ) ) ) ) ) ) + (cond + ((eof-object? dchar) + (##sys#read-error + port "unexpected end of input after reading #-sign")) + ((char-numeric? dchar) + (let* ((n (string->number (r-digits))) + (dchar2 (##sys#peek-char-0 port)) + (spdrst (##sys#slot crt 3)) + (h (and (char? dchar2) spdrst + (##sys#slot spdrst (char->integer dchar2)) ) ) ) + ;; # handled by parameterized # read-table entry? + (cond ((eof-object? dchar2) + (##sys#read-error + port "unexpected end of input after reading" + c n)) + (h (##sys#call-with-values + (lambda () (h dchar2 port n)) + (lambda xs (if (null? xs) (readrec) (car xs))))) + ;; #? + ((or (eq? dchar2 #\)) (char-whitespace? dchar2)) + (##sys#sharp-number-hook port n)) + (else (##sys#read-char-0 port) ; Consume it first + (##sys#read-error + port + "invalid parameterized read syntax" + c n dchar2) ) ) )) + (else (let* ((sdrst (##sys#slot crt 2)) + (h (and sdrst (##sys#slot sdrst (char->integer dchar)) ) ) ) + (if h + ;; then handled by # read-table entry + (##sys#call-with-values + (lambda () (h dchar port)) + (lambda xs (if (null? xs) (readrec) (car xs)))) + ;; otherwise chicken extended r5rs syntax + (case (char-downcase dchar) + ((#\x) (##sys#read-char-0 port) (r-number-with-exactness 16)) + ((#\d) (##sys#read-char-0 port) (r-number-with-exactness 10)) + ((#\o) (##sys#read-char-0 port) (r-number-with-exactness 8)) + ((#\b) (##sys#read-char-0 port) (r-number-with-exactness 2)) + ((#\i) (##sys#read-char-0 port) (r-number-with-radix 'i)) + ((#\e) (##sys#read-char-0 port) (r-number-with-radix 'e)) + ((#\c) + (##sys#read-char-0 port) + (let ([c (##sys#read-char-0 port)]) + (fluid-let ([csp + (cond [(eof-object? c) + (##sys#read-error port "unexpected end of input while reading `#c...' sequence")] + [(eq? c #\i) #f] + [(eq? c #\s) #t] + [else (##sys#read-error port "invalid case specifier in `#c...' sequence" c)] ) ] ) + (readrec) ) ) ) + ((#\() (r-vector)) + ((#\\) (##sys#read-char-0 port) (r-char)) + ((#\|) + (##sys#read-char-0 port) + (r-comment) (readrec) ) + ((#\#) + (##sys#read-char-0 port) + (r-ext-symbol) ) + ((#\;) + (##sys#read-char-0 port) + (readrec) (readrec) ) + ((#\`) + (##sys#read-char-0 port) + (list 'quasisyntax (readrec)) ) + ((#\$) + (##sys#read-char-0 port) + (let ((c (##sys#peek-char-0 port))) + (cond ((char=? c #\{) + (##sys#read-char-0 port) + (##sys#read-bytevector-literal port)) + (else (list 'location (readrec)) )))) + ((#\:) + (##sys#read-char-0 port) + (let ((tok (r-token))) + (if (eq? 0 (##sys#size tok)) + (##sys#read-error port "empty keyword") + (build-keyword tok)))) + ((#\%) + (build-symbol (##sys#string-append "#" (r-token))) ) + ((#\+) + (##sys#read-char-0 port) + (let ((tst (readrec))) + (list 'cond-expand (list tst (readrec)) '(else)) ) ) + ((#\!) + (##sys#read-char-0 port) + (let ((c (##sys#peek-char-0 port))) + (cond ((and (char? c) + (or (char-whitespace? c) (char=? #\/ c))) + (skip-to-eol) + (readrec) ) + (else + (let ([tok (r-token)]) + (cond [(string=? "eof" tok) #!eof] + [(member tok '("optional" "rest" "key")) + (build-symbol (##sys#string-append "#!" tok)) ] + [else + (let ((a (assq (string->symbol tok) read-marks))) + (if a + ((##sys#slot a 1) port) + (##sys#read-error + port + "invalid `#!' token" tok) ) ) ] ) ) ) ) ) ) + (else + (##sys#call-with-values (lambda () (##sys#user-read-hook dchar port)) + (lambda xs (if (null? xs) (readrec) (car xs)))) ) ) ) )) ) ) ) ((#\() (r-list #\( #\))) ((#\)) (##sys#read-char-0 port) (container c)) ((#\") (##sys#read-char-0 port) (r-string #\")) -- 1.8.3.4