~ chicken-core (chicken-5) 14c084b3887da034d2bf296323d4b6d2b838e51f
commit 14c084b3887da034d2bf296323d4b6d2b838e51f
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sun May 26 14:24:06 2013 +0200
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Sun May 26 15:25:57 2013 +0200
Make vectors, srfi-4 vectors self-evaluating, for R7RS compat. Blobs are made self-evaluating as well, for consistency reasons.
This also adds a convenience predicate number-vector? which checks
whether an object is of any of the SRFI-4 homogeneous number vector
types.
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/NEWS b/NEWS
index be9d0987..07a8a5ad 100644
--- a/NEWS
+++ b/NEWS
@@ -20,6 +20,8 @@
- Syntax
- Added the aliases "&optional" and "&rest" as alternatives to "#!optional"
and "#!rest" in type-declarations (suggested by Joerg Wittenberger).
+ - Vectors, SRFI-4 number vectors and blobs are now self-evaluating for
+ R7RS compatibility. Being literal constants, they are implicitly quoted.
- Compiler
- the "inline" declaration does not force inlining anymore as recursive
diff --git a/eval.scm b/eval.scm
index 62227cd0..caf069d3 100644
--- a/eval.scm
+++ b/eval.scm
@@ -295,10 +295,13 @@
(if x
(lambda v #t)
(lambda v #f) ) ]
- [(or (char? x)
+ ((or (char? x)
(eof-object? x)
- (string? x) )
- (lambda v x) ]
+ (string? x)
+ (blob? x)
+ (vector? x)
+ (##sys#srfi-4-vector? x))
+ (lambda v x) )
[(not (pair? x))
(##sys#syntax-error/context "illegal non-atomic object" x)]
[(symbol? (##sys#slot x 0))
diff --git a/library.scm b/library.scm
index 6c4e8a9b..9bea2b45 100644
--- a/library.scm
+++ b/library.scm
@@ -4225,6 +4225,10 @@ EOF
(define (##sys#permanent? x) (##core#inline "C_permanentp" x))
(define (##sys#block-address x) (##core#inline_allocate ("C_block_address" 4) x))
(define (##sys#locative? x) (##core#inline "C_locativep" x))
+(define (##sys#srfi-4-vector? x)
+ (and (##sys#generic-structure? x)
+ (memq (##sys#slot x 0)
+ '(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector))))
(define (##sys#null-pointer)
(let ([ptr (##sys#make-pointer)])
diff --git a/manual/Unit srfi-4 b/manual/Unit srfi-4
index 5b80983f..f2bc17aa 100644
--- a/manual/Unit srfi-4
+++ b/manual/Unit srfi-4
@@ -163,7 +163,7 @@ This external representation is also available in program source code. For examp
(set! x '#u8(1 2 3))
-will set {{x}} to the object {{#u8(1 2 3)}}. Literal homogeneous vectors must be quoted just like heterogeneous vectors must be. Homogeneous vectors can appear in quasiquotations but must not contain {{unquote}} or {{unquote-splicing}} forms. ''I.e.'',
+will set {{x}} to the object {{#u8(1 2 3)}}. Since CHICKEN 4.9.0, literal homogeneous vectors do not have to be quoted. Homogeneous vectors can appear in quasiquotations but must not contain {{unquote}} or {{unquote-splicing}} forms. ''I.e.'',
`(,x #u8(1 2)) ; legal
`#u8(1 ,x 2) ; illegal
@@ -181,6 +181,11 @@ will set {{x}} to the object {{#u8(1 2 3)}}. Literal homogeneous vectors must be
Return {{#t}} if {{obj}} is an object of the specified type or {{#f}} if not.
+<procedure>(number-vector? OBJ)</procedure>
+
+Return {{#t}} if {{obj}} is a number vector, {{#f}} if not. A "number vector" is any of the homogeneous number vector types defined by SRFI-4, ie it's one of {{u8vector}}, {{s8vector}}, {{u16vector}}, {{s16vector}}, {{u32vector}}, {{s32vector}}, {{f32vector}} or {{f64vector}}).
+
+
=== Constructors
<procedure>(make-u8vector N [U8VALUE NONGC FINALIZE])</procedure><br>
diff --git a/srfi-4.import.scm b/srfi-4.import.scm
index 52011fbc..234c6fe9 100644
--- a/srfi-4.import.scm
+++ b/srfi-4.import.scm
@@ -141,4 +141,5 @@
u8vector-ref
u8vector-set!
u8vector?
- write-u8vector))
+ write-u8vector
+ number-vector?))
diff --git a/srfi-4.scm b/srfi-4.scm
index 991e9f5c..690e2484 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -275,9 +275,7 @@ EOF
(set! release-number-vector
(lambda (v)
- (if (and (##sys#generic-structure? v)
- (memq (##sys#slot v 0)
- '(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)) )
+ (if (number-vector? v)
(ext-free v)
(##sys#error 'release-number-vector "bad argument type - not a number vector" v)) ) )
@@ -493,6 +491,8 @@ EOF
(define (f32vector? x) (##sys#structure? x 'f32vector))
(define (f64vector? x) (##sys#structure? x 'f64vector))
+;; Catch-all predicate
+(define number-vector? ##sys#srfi-4-vector?)
;;; Accessing the packed bytevector:
diff --git a/support.scm b/support.scm
index 8842198c..23494faf 100644
--- a/support.scm
+++ b/support.scm
@@ -253,6 +253,9 @@
(string? x)
(boolean? x)
(eof-object? x)
+ (blob? x)
+ (vector? x)
+ (##sys#srfi-4-vector? x)
(and (pair? x) (eq? 'quote (car x))) ) )
(define (collapsable-literal? x)
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 2d88321b..12d96b51 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -327,6 +327,12 @@
(assert (equal? '#${abc} '#${ab0c}))
(assert (equal? '#${a b c} '#${0a0b0c}))
+;; self-evaluating
+(assert (equal? '#${a} #${a}))
+(assert (equal? '#${abcd} #${abcd}))
+(assert (equal? '#${abc} #${abc}))
+
+
;; #808: blobs and strings with embedded nul bytes should not be compared
;; with ASCIIZ string comparison functions
(assert (equal? '#${a b 0 c} '#${a b 0 c}))
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index dce6bb29..ca6ff807 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -46,4 +46,15 @@
(test 1 force (make-promise (lambda _ 1)))
(test 1 force (make-promise (make-promise 1)))
+
+
+(SECTION 6 8)
+
+;; Symbols are implicitly quoted inside self-evaluating vectors.
+;; This is not as clear from draft 9 as it could be.
+(test '#(0 (2 2 2 2) "Anna") #(0 (2 2 2 2) "Anna"))
+(test #t vector? '#(0 (a b) c))
+(test #t vector? #(0 (a b) c))
+(test '#(0 (a b) c d #(1 2 (e) f) g) #(0 (a b) c d #(1 2 (e) f) g))
+
(report-errs)
diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm
index 435f879f..4e87a759 100644
--- a/tests/srfi-4-tests.scm
+++ b/tests/srfi-4-tests.scm
@@ -14,6 +14,8 @@
`(let ((x (,(conc "vector") 100 101)))
(print x)
(assert (= 100 (,(conc "vector-ref") x 0)))
+ (assert (,(conc "vector?") x))
+ (assert (number-vector? x))
(,(conc "vector-set!") x 1 99)
(assert (= 99 (,(conc "vector-ref") x 1)))
(assert (= 2 (,(conc "vector-length") x)))
@@ -30,3 +32,13 @@
(test1 s32)
(test1 f32)
(test1 f64)
+
+;; Test implicit quoting/self evaluation
+(assert (equal? #u8(1 2 3) '#u8(1 2 3)))
+(assert (equal? #s8(-1 2 3) '#s8(-1 2 3)))
+(assert (equal? #u16(1 2 3) '#u16(1 2 3)))
+(assert (equal? #s16(-1 2 3) '#s16(-1 2 3)))
+(assert (equal? #u32(1 2 3) '#u32(1 2 3)))
+(assert (equal? #s32(-1 2 3) '#s32(-1 2 3)))
+(assert (equal? #f32(1 2 3) '#f32(1 2 3)))
+(assert (equal? #f64(-1 2 3) '#f64(-1 2 3)))
diff --git a/types.db b/types.db
index 01d84e21..5510a367 100644
--- a/types.db
+++ b/types.db
@@ -2507,6 +2507,9 @@
(write-u8vector (#(procedure #:enforce) write-u8vector ((struct u8vector) #!optional output-port fixnum fixnum) undefined))
+(number-vector? (#(procedure #:pure #:predicate (or (struct u8vector) (struct u16vector) (struct s8vector) (struct s16vector) (struct u32vector) (struct s32vector) (struct f32vector) (struct f64vector))) number-vector? (*) boolean))
+(##sys#srfi-4-vector? (#(procedure #:pure #:predicate (or (struct u8vector) (struct u16vector) (struct s8vector) (struct s16vector) (struct u32vector) (struct s32vector) (struct f32vector) (struct f64vector))) ##sys#srfi-4-vector? (*) boolean))
+
;; srfi-69
Trap