>From 58fd0e7ea48282c06515ffcf1743d95a42a22227 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 26 May 2013 14:24:06 +0200 Subject: [PATCH] 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. --- NEWS | 2 ++ eval.scm | 9 ++++++--- library.scm | 4 ++++ manual/Unit srfi-4 | 7 ++++++- srfi-4.import.scm | 3 ++- srfi-4.scm | 6 +++--- support.scm | 3 +++ tests/library-tests.scm | 8 ++++++++ tests/r7rs-tests.scm | 11 +++++++++++ tests/srfi-4-tests.scm | 12 ++++++++++++ types.db | 3 +++ 11 files changed, 60 insertions(+), 8 deletions(-) diff --git a/NEWS b/NEWS index be9d098..07a8a5a 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 62227cd..caf069d 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 6c4e8a9..9bea2b4 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 5b80983..f2bc17a 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. +(number-vector? OBJ) + +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 (make-u8vector N [U8VALUE NONGC FINALIZE])
diff --git a/srfi-4.import.scm b/srfi-4.import.scm index 52011fb..234c6fe 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 991e9f5..690e248 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 8842198..23494fa 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 2d88321..20594b7 100644 --- a/tests/library-tests.scm +++ b/tests/library-tests.scm @@ -327,6 +327,14 @@ (assert (equal? '#${abc} '#${ab0c})) (assert (equal? '#${a b c} '#${0a0b0c})) +;; self-evaluating +(assert (equal? '#${a} #${a})) +(assert (equal? '#${abcd} #${abcd})) +(assert (equal? '#${abc} #${abc})) +(assert (equal? '#${abc} #${abc})) +(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 dce6bb2..ca6ff80 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 435f879..4e87a75 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 01d84e2..5510a36 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 -- 1.8.2.3