~ chicken-core (chicken-5) 5f17e3fcac425156b26648b7f5ffed5aef0aa458
commit 5f17e3fcac425156b26648b7f5ffed5aef0aa458
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Nov 8 05:30:21 2010 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Nov 8 05:30:21 2010 -0500
show escaped special characters in readable symbol (reported by Alaric)
diff --git a/c-backend.scm b/c-backend.scm
index 4f1e5299..85e38498 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1088,8 +1088,10 @@
[(char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int32
byte unsigned-byte)
ns]
- [(float double c-pointer unsigned-integer unsigned-integer32 long integer integer32 unsigned-long
- nonnull-c-pointer number unsigned-integer64 integer64 c-string-list c-string-list*)
+ [(float double c-pointer unsigned-integer unsigned-integer32 long integer integer32
+ unsigned-long size_t
+ nonnull-c-pointer number unsigned-integer64 integer64 c-string-list
+ c-string-list*)
(string-append ns "+3") ]
[(c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)
(string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") ]
@@ -1156,6 +1158,7 @@
[(unsigned-int unsigned-integer) (str "unsigned int")]
[(unsigned-int32 unsigned-integer32) (str "C_u32")]
[(int integer bool) (str "int")]
+ [(size_t) (str "size_t")]
[(int32 integer32) (str "C_s32")]
[(integer64) (str "C_s64")]
[(unsigned-integer64) (str "C_u64")]
@@ -1256,6 +1259,7 @@
((double number float) "C_c_double(")
((integer integer32) "C_num_to_int(")
((integer64) "C_num_to_int64(")
+ ((size_t) "(size_t)C_num_to_int(")
((unsigned-integer64) "C_num_to_uint64(")
((long) "C_num_to_long(")
((unsigned-integer unsigned-integer32) "C_num_to_unsigned_int(")
@@ -1339,6 +1343,7 @@
((c-pointer) (sprintf "C_mpointer_or_false(&~a,(void*)" dest))
((integer integer32) (sprintf "C_int_to_num(&~a," dest))
((integer64) (sprintf "C_a_double_to_num(&~a," dest))
+ ((size_t) (sprintf "C_int_to_num(%~a,(int)" dest))
((unsigned-integer unsigned-integer32) (sprintf "C_unsigned_int_to_num(&~a," dest))
((long) (sprintf "C_long_to_num(&~a," dest))
((unsigned-long) (sprintf "C_unsigned_long_to_num(&~a," dest))
diff --git a/library.scm b/library.scm
index c6fc5ef6..8b3fe0e8 100644
--- a/library.scm
+++ b/library.scm
@@ -2315,52 +2315,50 @@ EOF
(lp (fx+ i 1) (cons (##core#inline "C_subchar" s i) lst))))))
(define (r-string term)
- (if (eq? (##sys#read-char-0 port) term)
- (let loop ((c (##sys#read-char-0 port)) (lst '()))
- (cond ((##core#inline "C_eofp" c)
- (##sys#read-error port "unterminated string") )
- ((eq? #\\ c)
- (set! c (##sys#read-char-0 port))
- (case c
- ((#\t) (loop (##sys#read-char-0 port) (cons #\tab lst)))
- ((#\r) (loop (##sys#read-char-0 port) (cons #\return lst)))
- ((#\b) (loop (##sys#read-char-0 port) (cons #\backspace lst)))
- ((#\n) (loop (##sys#read-char-0 port) (cons #\newline lst)))
- ((#\a) (loop (##sys#read-char-0 port) (cons (integer->char 7) lst)))
- ((#\v) (loop (##sys#read-char-0 port) (cons (integer->char 11) lst)))
- ((#\f) (loop (##sys#read-char-0 port) (cons (integer->char 12) lst)))
- ((#\x)
- (let ([ch (integer->char (r-usequence "x" 2))])
- (loop (##sys#read-char-0 port) (cons ch lst)) ) )
- ((#\u)
- (let ([n (r-usequence "u" 4)])
- (if (##sys#unicode-surrogate? n)
- (if (and (eqv? #\\ (##sys#read-char-0 port))
- (eqv? #\u (##sys#read-char-0 port)))
- (let* ((m (r-usequence "u" 4))
- (cp (##sys#surrogates->codepoint n m)))
- (if cp
- (loop (##sys#read-char-0 port)
- (r-cons-codepoint cp lst))
- (##sys#read-error port "bad surrogate pair" n m)))
- (##sys#read-error port "unpaired escaped surrogate" n))
- (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) ) ))
- ((#\U)
- (let ([n (r-usequence "U" 8)])
- (if (##sys#unicode-surrogate? n)
- (##sys#read-error port (string-append "invalid escape (surrogate)" n))
- (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))
- ((#\\ #\' #\")
- (loop (##sys#read-char-0 port) (cons c lst)))
- (else
- (##sys#read-warning
- port
- "undefined escape sequence in string - probably forgot backslash"
- c)
- (loop (##sys#read-char-0 port) (cons c lst))) ) )
- ((eq? term c) (##sys#reverse-list->string lst))
- (else (loop (##sys#read-char-0 port) (cons c lst))) ) )
- (##sys#read-error port (string-append "missing `" (string term) "'")) ) )
+ (let loop ((c (##sys#read-char-0 port)) (lst '()))
+ (cond ((##core#inline "C_eofp" c)
+ (##sys#read-error port "unterminated string") )
+ ((eq? #\\ c)
+ (set! c (##sys#read-char-0 port))
+ (case c
+ ((#\t) (loop (##sys#read-char-0 port) (cons #\tab lst)))
+ ((#\r) (loop (##sys#read-char-0 port) (cons #\return lst)))
+ ((#\b) (loop (##sys#read-char-0 port) (cons #\backspace lst)))
+ ((#\n) (loop (##sys#read-char-0 port) (cons #\newline lst)))
+ ((#\a) (loop (##sys#read-char-0 port) (cons (integer->char 7) lst)))
+ ((#\v) (loop (##sys#read-char-0 port) (cons (integer->char 11) lst)))
+ ((#\f) (loop (##sys#read-char-0 port) (cons (integer->char 12) lst)))
+ ((#\x)
+ (let ([ch (integer->char (r-usequence "x" 2))])
+ (loop (##sys#read-char-0 port) (cons ch lst)) ) )
+ ((#\u)
+ (let ([n (r-usequence "u" 4)])
+ (if (##sys#unicode-surrogate? n)
+ (if (and (eqv? #\\ (##sys#read-char-0 port))
+ (eqv? #\u (##sys#read-char-0 port)))
+ (let* ((m (r-usequence "u" 4))
+ (cp (##sys#surrogates->codepoint n m)))
+ (if cp
+ (loop (##sys#read-char-0 port)
+ (r-cons-codepoint cp lst))
+ (##sys#read-error port "bad surrogate pair" n m)))
+ (##sys#read-error port "unpaired escaped surrogate" n))
+ (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) ) ))
+ ((#\U)
+ (let ([n (r-usequence "U" 8)])
+ (if (##sys#unicode-surrogate? n)
+ (##sys#read-error port (string-append "invalid escape (surrogate)" n))
+ (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))
+ ((#\\ #\' #\" #\|)
+ (loop (##sys#read-char-0 port) (cons c lst)))
+ (else
+ (##sys#read-warning
+ port
+ "undefined escape sequence in string - probably forgot backslash"
+ c)
+ (loop (##sys#read-char-0 port) (cons c lst))) ) )
+ ((eq? term c) (##sys#reverse-list->string lst))
+ (else (loop (##sys#read-char-0 port) (cons c lst))) ) ))
(define (r-list start end)
(if (eq? (##sys#read-char-0 port) start)
@@ -2511,38 +2509,36 @@ EOF
(info 'symbol-info s (##sys#port-line port)) ) )
(define (r-xtoken)
- (let loop ((esc #f) (lst '()))
+ (let loop ((lst '()))
(let ((c (##sys#peek-char-0 port)))
- (cond ((eof-object? c)
- (if esc
- (##sys#read-error
- port
- "unexpected end of file while reading token delimited by `| ... |'")
- (##sys#reverse-list->string lst)))
- ((and (not esc)
- (or (char-whitespace? c)
- (memq c terminating-characters)))
+ (cond ((or (eof-object? c)
+ (char-whitespace? c)
+ (memq c terminating-characters))
(##sys#reverse-list->string lst))
(else
- (let ((c ((if esc read-unreserved-char-0 ##sys#read-char-0) port)))
- (case (and sep c) ; is sep is false, esc will be as well
- ((#\|) (loop (not esc) lst))
+ (let ((c (##sys#read-char-0 port)))
+ (case (and sep c)
+ ((#\|)
+ (let ((part (r-string #\|)))
+ (string-append
+ (##sys#reverse-list->string lst)
+ part
+ (loop '()))))
((#\newline)
(##sys#read-warning
port "escaped symbol syntax spans multiple lines"
(##sys#reverse-list->string lst))
- (loop esc (cons #\newline lst)))
+ (loop (cons #\newline lst)))
((#\\)
(let ((c (##sys#read-char-0 port)))
(if (eof-object? c)
(##sys#read-error
port
"unexpected end of file while reading escaped character")
- (loop esc (cons c lst)))))
+ (loop (cons c lst)))))
(else
(loop
- esc
- (cons (if (or esc csp) c (char-downcase c)) lst))))))))))
+ (cons (if csp c (char-downcase c)) lst))))))))))
(define (r-char)
;; Code contributed by Alex Shinn
@@ -2750,7 +2746,7 @@ EOF
(else (##sys#user-read-hook dchar port)) ) ) ) ) ) )
((#\() (r-list #\( #\)))
((#\)) (##sys#read-char-0 port) (container c))
- ((#\") (r-string #\"))
+ ((#\") (##sys#read-char-0 port) (r-string #\"))
((#\.) (r-number #f))
((#\- #\+) (r-number #f))
(else
@@ -2997,15 +2993,22 @@ EOF
(memq chr special-characters) ) ) )
(define (outreadablesym port str)
- (let ([len (##sys#size str)])
+ (let ((len (##sys#size str)))
(outchr port #\|)
- (let loop ([i 0])
+ (let loop ((i 0))
(if (fx>= i len)
(outchr port #\|)
- (let ([c (##core#inline "C_subchar" str i)])
- (when (or (eq? c #\|) (eq? c #\\)) (outchr port #\\))
- (outchr port c)
- (loop (fx+ i 1)) ) ) ) ) )
+ (let ((c (##core#inline "C_subchar" str i)))
+ (cond ((or (char<? c #\space) (char>? c #\~))
+ (outstr port "\\x")
+ (let ((n (char->integer c)))
+ (when (fx< n 16) (outchr port #\0))
+ (outstr port (##sys#number->string n 16))
+ (loop (fx+ i 1))))
+ (else
+ (when (or (eq? c #\|) (eq? c #\\)) (outchr port #\\))
+ (outchr port c)
+ (loop (fx+ i 1)) ) ) ) ) )))
(define (sym-is-readable? str)
(let ((len (##sys#size str)))
diff --git a/support.scm b/support.scm
index d73dba09..661392dc 100644
--- a/support.scm
+++ b/support.scm
@@ -959,7 +959,7 @@
`(##sys#foreign-struct-wrapper-argument
',(##sys#slot (assq t tmap) 1)
,param) ) ]
- [(integer long integer32 integer64)
+ [(integer long size_t integer32 integer64)
(if unsafe param `(##sys#foreign-integer-argument ,param))]
[(unsigned-integer unsigned-integer32 unsigned-long unsigned-integer64)
(if unsafe
@@ -1060,7 +1060,7 @@
unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
c-string-list c-string-list*)
(words->bytes 3) )
- ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
+ ((unsigned-integer long integer size_t unsigned-long integer32 unsigned-integer32)
(words->bytes 4) )
((float double number integer64 unsigned-integer64)
(words->bytes 4) ) ; possibly 8-byte aligned 64-bit double
@@ -1086,7 +1086,7 @@
((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte unsigned-byte
c-pointer pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
- unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
+ unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string* size_t
nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*) ; pointer and nonnull-pointer are DEPRECATED
(words->bytes 1) )
((double number integer64 unsigned-integer64)
Trap