~ chicken-core (chicken-5) ee4518f762ca49e4480190795caeb90066a084e3
commit ee4518f762ca49e4480190795caeb90066a084e3
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Thu Feb 18 21:33:44 2016 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Thu Feb 18 21:33:44 2016 +0100
Fix references into u32 and s32 locatives
Thanks to Joerg Wittenberger for pointing out that this was broken.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 141ed231..390155ff 100644
--- a/NEWS
+++ b/NEWS
@@ -45,6 +45,8 @@
fifo? and socket?.
- Unit "data-structures": alist-{update[!],ref} were made consistent
with srfi-1 in the argument order of comparison procedures.
+ - Unit "lolevel": locative-ref has been fixed for locatives of u32
+ and s32vectors (thanks to Joerg Wittenberger for pointing this out).
- Tools
- A debugger is now available, known as "feathers", which allows
diff --git a/runtime.c b/runtime.c
index 9ca83ce8..b1e99e21 100644
--- a/runtime.c
+++ b/runtime.c
@@ -8789,16 +8789,15 @@ void C_ccall C_locative_ref(C_word c, C_word *av)
/* closure = av[ 0 ] */
k = av[ 1 ],
loc,
- *av2,
- *ptr, val;
- C_alloc_flonum;
+ *ptr, val,
+ ab[WORDS_PER_FLONUM], *a = ab;
if(c != 3) C_bad_argc(c, 3);
loc = av[ 2 ];
if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", loc);
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-ref", loc);
ptr = (C_word *)C_block_item(loc, 0);
@@ -8811,22 +8810,10 @@ void C_ccall C_locative_ref(C_word c, C_word *av)
case C_S8_LOCATIVE: C_kontinue(k, C_fix(*((char *)ptr)));
case C_U16_LOCATIVE: C_kontinue(k, C_fix(*((unsigned short *)ptr)));
case C_S16_LOCATIVE: C_kontinue(k, C_fix(*((short *)ptr)));
- case C_U32_LOCATIVE:
- av2 = C_alloc(4);
- av2[ 0 ] = C_SCHEME_UNDEFINED;
- av2[ 1 ] = k;
- av2[ 2 ] = (C_word)(ptr - 1);
- av2[ 3 ] = C_fix(0);
- C_peek_unsigned_integer(3, av);
- case C_S32_LOCATIVE:
- av2 = C_alloc(4);
- av2[ 0 ] = C_SCHEME_UNDEFINED;
- av2[ 1 ] = k;
- av2[ 2 ] = (C_word)(ptr - 1);
- av2[ 3 ] = C_fix(0);
- C_peek_signed_integer(3, av);
- case C_F32_LOCATIVE: C_kontinue_flonum(k, *((float *)ptr));
- case C_F64_LOCATIVE: C_kontinue_flonum(k, *((double *)ptr));
+ case C_U32_LOCATIVE: C_kontinue(k, C_unsigned_int_to_num(&a, *((C_u32 *)ptr)));
+ case C_S32_LOCATIVE: C_kontinue(k, C_int_to_num(&a, *((C_s32 *)ptr)));
+ case C_F32_LOCATIVE: C_kontinue(k, C_flonum(&a, *((float *)ptr)));
+ case C_F64_LOCATIVE: C_kontinue(k, C_flonum(&a, *((double *)ptr)));
default: panic(C_text("bad locative type"));
}
}
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index d0398fac..9b14a751 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -1,6 +1,6 @@
;;;; Unit lolevel testing
-(require-extension lolevel)
+(require-extension lolevel srfi-4 extras)
(define-syntax assert-error
(syntax-rules ()
@@ -134,18 +134,59 @@
(assert (eq? some-unique-tag (pointer-tag some-tagged-pointer)))
-; make-locative
+; make-locative, locative-ref, locative-set!, locative?
+
+;; Reverse an object vector of the given type by going through
+;; locatives.
+(define-syntax check-type-locative
+ (ir-macro-transformer
+ (lambda (e i c)
+ (let* ((type (strip-syntax (cadr e)))
+ (inits (cddr e))
+ (size (length inits))
+ (construct type)
+ (make (i (symbol-append 'make- type)))
+ (ref (i (symbol-append type '-ref))))
+ `(let* ((old (,construct ,@inits))
+ (new (,make ,size)))
+ ;; Copy first
+ (do ((i 0 (add1 i)))
+ ((= i ,size))
+ (let ((loc-src (make-locative old i))
+ (loc-dst (make-locative new (- ,size i 1))))
+ (assert (locative? loc-src))
+ (assert (locative? loc-dst))
+ (locative-set! loc-dst (locative-ref loc-src))))
+ (printf "\nold: ~S\nnew: ~S\n" old new)
+ ;; Now compare (unroll loop for better error reporting)
+ ,@(let lp ((i 0) (res '()))
+ (if (= i size)
+ res
+ (lp (add1 i)
+ ;; Note: we must use eqv? because extraction
+ ;; may cause fresh object allocation.
+ (cons `(assert (eqv? (,ref old ,i)
+ (,ref new ,(- size i 1))))
+ res)))))))))
+
+(check-type-locative string #\nul #\y #\o #\xff)
+(check-type-locative vector 'yo 1 2 #f #t '(1 2 3) #(1 2 3))
+(check-type-locative u8vector 0 1 2 #xfe #xff)
+(check-type-locative s8vector #x-80 #x-7f -2 -1 0 1 2 #x7e #x7f)
+(check-type-locative u16vector 0 1 2 #xfffe #xffff)
+(check-type-locative s16vector #x-8000 #x-7fff -2 -1 0 1 2 #x7ffe #x7fff)
+(check-type-locative u32vector 0 1 2 #xfffffffe #xffffffff)
+(check-type-locative s32vector
+ #x-80000000 #x-7fffffff -2 -1
+ 0 1 2 #x7ffffffe #x7fffffff)
+;; TODO: better/more extreme values?
+(check-type-locative f32vector -1e100 -2.0 -1.0 0.0 1.0 2.0 1e100)
+(check-type-locative f64vector -1e200 -2.0 -1.0 0.0 1.0 2.0 1e200)
; make-weak-locative
-; locative-set!
-
-; locative-ref
-
; locative->object
-; locative?
-
; extend-procedure
(define (foo a b) (list a b))
Trap