From f1634b0bf40708941c7f03b681cc71b12cfc0254 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Thu, 18 Feb 2016 21:48:49 +0100 Subject: [PATCH] Fix references into u32 and s32 locatives. Thanks to Joerg Wittenberger for pointing out that this was broken. --- NEWS | 2 ++ runtime.c | 47 +++++++++++-------------------------- tests/lolevel-tests.scm | 62 ++++++++++++++++++++++++++++++++++++++++++------- 3 files changed, 70 insertions(+), 41 deletions(-) diff --git a/NEWS b/NEWS index a51db30..b088d39 100644 --- a/NEWS +++ b/NEWS @@ -77,6 +77,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 024af68..650769a 100644 --- a/runtime.c +++ b/runtime.c @@ -12369,16 +12369,20 @@ 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, +#ifdef C_SIXTY_FOUR + ab[nmax(C_SIZEOF_BIGNUM(2), WORDS_PER_FLONUM)], +#else + ab[nmax(C_SIZEOF_BIGNUM(1), WORDS_PER_FLONUM)], +#endif + *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); @@ -12392,35 +12396,12 @@ void C_ccall C_locative_ref(C_word c, C_word *av) 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_U64_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_uint64(3, av); - case C_S64_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_int64(3, av); - case C_F32_LOCATIVE: C_kontinue_flonum(k, *((float *)ptr)); - case C_F64_LOCATIVE: C_kontinue_flonum(k, *((double *)ptr)); + 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_U64_LOCATIVE: C_kontinue(k, C_uint64_to_num(&a, *((C_u64 *)ptr))); + case C_S64_LOCATIVE: C_kontinue(k, C_int64_to_num(&a, *((C_s64 *)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 e925104..f84cedd 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 () @@ -142,18 +142,64 @@ (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) +(check-type-locative u64vector + 0 1 2 #xfffffffffffffffe #xffffffffffffffff) +(check-type-locative s64vector + #x-8000000000000000 #x-7fffffffffffffff -2 -1 + 0 1 2 #x7ffffffffffffffe #x7fffffffffffffff) +;; 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)) -- 2.1.4