>From ce64dfb98afe1af21cb6aea084187714816e09f1 Mon Sep 17 00:00:00 2001 From: John Croisant Date: Fri, 7 Jan 2022 15:26:30 -0600 Subject: [PATCH 1/1] Add `locative-index` procedure in (chicken locative). --- c-platform.scm | 1 + chicken.h | 1 + lolevel.scm | 5 ++++- manual/Module (chicken locative) | 9 +++++++++ runtime.c | 32 ++++++++++++++++++++++++++++++ tests/lolevel-tests.scm | 34 ++++++++++++++++++++++++++++++++ types.db | 1 + 7 files changed, 82 insertions(+), 1 deletion(-) diff --git a/c-platform.scm b/c-platform.scm index 00960c82..5035d311 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -238,6 +238,7 @@ chicken.locative#locative-ref chicken.locative#locative-set! chicken.locative#locative->object chicken.locative#locative? + chicken.locative#locative-index chicken.memory#pointer+ chicken.memory#pointer=? chicken.memory#address->pointer chicken.memory#pointer->address diff --git a/chicken.h b/chicken.h index 02fea9be..3358a057 100644 --- a/chicken.h +++ b/chicken.h @@ -2059,6 +2059,7 @@ C_fctexport C_word C_fcall C_i_char_less_or_equal_p(C_word x, C_word y) C_regpar C_fctexport C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc) C_regparm; C_fctexport C_word C_fcall C_i_locative_set(C_word loc, C_word x) C_regparm; C_fctexport C_word C_fcall C_i_locative_to_object(C_word loc) C_regparm; +C_fctexport C_word C_fcall C_i_locative_index(C_word loc) C_regparm; C_fctexport C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak) C_regparm; C_fctexport C_word C_fcall C_i_bit_to_bool(C_word n, C_word i) C_regparm; /* DEPRECATED */ C_fctexport C_word C_fcall C_i_integer_length(C_word x) C_regparm; diff --git a/lolevel.scm b/lolevel.scm index ef339b7d..fb90bc5c 100644 --- a/lolevel.scm +++ b/lolevel.scm @@ -554,7 +554,7 @@ EOF (module chicken.locative (locative? make-locative make-weak-locative - locative-ref locative-set! locative->object) + locative-ref locative-set! locative->object locative-index) (import scheme chicken.base) @@ -597,5 +597,8 @@ EOF (define (locative->object x) (##core#inline "C_i_locative_to_object" x)) +(define (locative-index x) + (##core#inline "C_i_locative_index" x)) + (define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))) diff --git a/manual/Module (chicken locative) b/manual/Module (chicken locative) index 9c26a2a3..807673c7 100644 --- a/manual/Module (chicken locative) +++ b/manual/Module (chicken locative) @@ -68,6 +68,15 @@ Returns the object that contains the element referred to by {{LOC}} or (locative->object (make-locative "abc" 1)) ==> "abc" + +=== locative-index + +(locative-index LOC) + +Returns the index (position) of the element that {{LOC}} refers to. + + (locative-index (make-locative "abcde" 3)) ==> 3 + --- Previous: [[Module (chicken load)]] diff --git a/runtime.c b/runtime.c index c46cde6f..bbeeffb0 100644 --- a/runtime.c +++ b/runtime.c @@ -12164,6 +12164,38 @@ C_regparm C_word C_fcall C_i_locative_to_object(C_word loc) } +C_regparm C_word C_fcall C_i_locative_index(C_word loc) +{ + int bytes; + + if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG) + barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-index", loc); + + bytes = C_unfix(C_block_item(loc, 1)) - sizeof(C_header); + + switch(C_unfix(C_block_item(loc, 2))) { + case C_SLOT_LOCATIVE: return C_fix(bytes/sizeof(C_word)); break; + + case C_CHAR_LOCATIVE: + case C_U8_LOCATIVE: + case C_S8_LOCATIVE: return C_fix(bytes); break; + + case C_U16_LOCATIVE: + case C_S16_LOCATIVE: return C_fix(bytes/2); break; + + case C_U32_LOCATIVE: + case C_S32_LOCATIVE: + case C_F32_LOCATIVE: return C_fix(bytes/4); break; + + case C_U64_LOCATIVE: + case C_S64_LOCATIVE: + case C_F64_LOCATIVE: return C_fix(bytes/8); break; + + default: panic(C_text("bad locative type")); + } +} + + /* GC protection of user-variables: */ C_regparm void C_fcall C_gc_protect(C_word **addr, int n) diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm index 332102a2..88e3a626 100644 --- a/tests/lolevel-tests.scm +++ b/tests/lolevel-tests.scm @@ -201,6 +201,40 @@ ; locative->object +; locative-index + +;; Default index (0) +(assert (= 0 (locative-index (make-locative '(0 . 1))))) +(assert (= 0 (locative-index (make-locative #(a b c d e))))) +(assert (= 0 (locative-index (make-locative "abcde")))) +(assert (= 0 (locative-index (make-locative #${012345})))) +(assert (= 0 (locative-index (make-locative #u8(0 1 2 3 4))))) +(assert (= 0 (locative-index (make-locative #s8(0 1 2 3 4))))) +(assert (= 0 (locative-index (make-locative #u16(0 1 2 3 4))))) +(assert (= 0 (locative-index (make-locative #s16(0 1 2 3 4))))) +(assert (= 0 (locative-index (make-locative #u32(0 1 2 3 4))))) +(assert (= 0 (locative-index (make-locative #s32(0 1 2 3 4))))) +(assert (= 0 (locative-index (make-locative #u64(0 1 2 3 4))))) +(assert (= 0 (locative-index (make-locative #s64(0 1 2 3 4))))) +(assert (= 0 (locative-index (make-locative #f32(0 1 2 3 4))))) +(assert (= 0 (locative-index (make-locative #f64(0 1 2 3 4))))) + +;; Given index argument +(assert (= 1 (locative-index (make-locative '(0 . 1) 1)))) +(assert (= 2 (locative-index (make-locative #(a b c d e) 2)))) +(assert (= 3 (locative-index (make-locative "abcde" 3)))) +(assert (= 2 (locative-index (make-locative #${01234} 2)))) +(assert (= 1 (locative-index (make-locative #u8(0 1 2 3 4) 1)))) +(assert (= 2 (locative-index (make-locative #s8(0 1 2 3 4) 2)))) +(assert (= 3 (locative-index (make-locative #u16(0 1 2 3 4) 3)))) +(assert (= 2 (locative-index (make-locative #s16(0 1 2 3 4) 2)))) +(assert (= 1 (locative-index (make-locative #u32(0 1 2 3 4) 1)))) +(assert (= 2 (locative-index (make-locative #s32(0 1 2 3 4) 2)))) +(assert (= 3 (locative-index (make-locative #u64(0 1 2 3 4) 3)))) +(assert (= 2 (locative-index (make-locative #s64(0 1 2 3 4) 2)))) +(assert (= 1 (locative-index (make-locative #f32(0 1 2 3 4) 1)))) +(assert (= 2 (locative-index (make-locative #f64(0 1 2 3 4) 2)))) + ; extend-procedure (define (foo a b) (list a b)) diff --git a/types.db b/types.db index 922c07af..39938c47 100644 --- a/types.db +++ b/types.db @@ -1814,6 +1814,7 @@ ;; locative +(chicken.locative#locative-index (#(procedure #:clean #:enforce) chicken.locative#locative-index (locative) fixnum)) (chicken.locative#locative->object (#(procedure #:clean #:enforce) chicken.locative#locative->object (locative) *)) (chicken.locative#locative-ref (#(procedure #:clean #:enforce) chicken.locative#locative-ref (locative) *) ((locative) (##core#inline_allocate ("C_a_i_locative_ref" 6) #(1)))) -- 2.25.1