~ chicken-core (chicken-5) f5c5364723d70e1724bbfb4ece7312b2a88ef29b

commit f5c5364723d70e1724bbfb4ece7312b2a88ef29b
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Oct 18 04:14:45 2010 -0400
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Oct 18 04:14:45 2010 -0400

    support for blob-literals

diff --git a/c-backend.scm b/c-backend.scm
index f12bc7b6..4f1e5299 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -702,7 +702,7 @@
 	       (gen "C_h_intern(&" to #\, len #\, cstr ");") ) )
 	    ((null? lit) 
 	     (gen #t to "=C_SCHEME_END_OF_LIST;") )
-	    ((and (not (##sys#immediate? lit))
+	    ((and (not (##sys#immediate? lit)) ; nop
 		  (##core#inline "C_lambdainfop" lit)))
 	    ((or (fixnum? lit) (not (##sys#immediate? lit)))
 	     (gen #t to "=C_decode_literal(C_heaptop,")
diff --git a/chicken.h b/chicken.h
index b3260397..bcbeefbd 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1557,6 +1557,7 @@ C_fctexport void C_fcall C_clear_trace_buffer(void) C_regparm;
 C_fctexport C_word C_fetch_trace(C_word start, C_word buffer);
 C_fctexport C_word C_fcall C_string(C_word **ptr, int len, C_char *str) C_regparm;
 C_fctexport C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_static_bytevector(C_word **ptr, int len, C_char *str) C_regparm;
 C_fctexport C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str) C_regparm;
 C_fctexport C_word C_fcall C_bytevector(C_word **ptr, int len, C_char *str) C_regparm;
 C_fctexport C_word C_fcall C_pbytevector(int len, C_char *str) C_regparm;
diff --git a/library.scm b/library.scm
index 7fac6be1..ab03df94 100644
--- a/library.scm
+++ b/library.scm
@@ -2790,6 +2790,30 @@ EOF
 	      (fxior (fxshl (fxand hi #b111111) 10)
 		     (fxand lo #b1111111111)))) )
 
+(define (##sys#read-bytevector-literal port)
+  (define (hex c)
+    (let ((c (char-downcase c)))
+      (cond ((and (char>=? c #\a) (char<=? c #\f))
+	     (fx- (char->integer c) 87)	) ; - #\a + 10
+	    ((and (char>=? c #\0) (char<=? c #\9))
+	     (fx- (char->integer c) 48))
+	    (else (##sys#read-error port "invalid hex-code in blob-literal")))))
+  (let loop ((lst '()) (h #f))
+    (let ((c (##sys#read-char-0 port)))
+      (cond ((eof-object? c)
+	     (##sys#read-error port "unexpected end of blob literal"))
+	    ((char=? #\} c)
+	     (let ((str (##sys#reverse-list->string
+			 (if h
+			     (cons (integer->char h) lst)
+			     lst))))
+	       (##core#inline "C_string_to_bytevector" str)
+	       str))
+	    ((char-whitespace? c) (loop lst h))
+	    (h (loop (cons (integer->char (fxior h (hex c))) lst) #f))
+	    (else (loop lst (fxshl (hex c) 4)))))))
+	      
+
 ;;; Hooks for user-defined read-syntax:
 ;
 ; - Redefine this to handle new read-syntaxes. If 'char' doesn't match
@@ -2799,9 +2823,10 @@ EOF
 (define (##sys#user-read-hook char port)
   (case char
     ;; I put it here, so the SRFI-4 unit can intercept '#f...'
-    [(#\f #\F) (##sys#read-char-0 port) #f ]
-    [(#\t #\T) (##sys#read-char-0 port) #t ]
-    [else (##sys#read-error port "invalid sharp-sign read syntax" char) ] ) )
+    ((#\f #\F) (##sys#read-char-0 port) #f)
+    ((#\t #\T) (##sys#read-char-0 port) #t)
+    ((#\{) (##sys#read-char-0 port) (##sys#read-bytevector-literal port))
+    (else (##sys#read-error port "invalid sharp-sign read syntax" char) ) ) )
 
 
 ;;; Table for specially handled read-syntax:
diff --git a/runtime.c b/runtime.c
index c1ce3692..3ea009ba 100644
--- a/runtime.c
+++ b/runtime.c
@@ -2270,6 +2270,15 @@ C_regparm C_word C_fcall C_bytevector(C_word **ptr, int len, C_char *str)
 }
 
 
+C_regparm C_word C_fcall C_static_bytevector(C_word **ptr, int len, C_char *str)
+{
+  C_word strblock = C_static_string(ptr, len, str);
+
+  ((C_SCHEME_BLOCK *)strblock)->header = C_BYTEVECTOR_TYPE | len;
+  return strblock;
+}
+
+
 C_regparm C_word C_fcall C_pbytevector(int len, C_char *str)
 {
   C_SCHEME_BLOCK *pbv = C_malloc(len + sizeof(C_header));
@@ -8836,6 +8845,12 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
     *str += size;
     break;
     
+  case C_BYTEVECTOR_TYPE:
+    /* ... as are bytevectors (blobs) */
+    val = C_static_bytevector(ptr, size, *str);
+    *str += size;
+    break;
+    
   case C_SYMBOL_TYPE:
     if(dest == NULL) 
       panic(C_text("invalid literal symbol destination"));