~ chicken-core (chicken-5) ef2d98332b4d453288dc98298c394d8af645c863
commit ef2d98332b4d453288dc98298c394d8af645c863
Author: John Croisant <john@croisant.net>
AuthorDate: Fri Jan 7 15:26:30 2022 -0600
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jan 9 13:39:24 2022 +0100
Add `locative-index` procedure in (chicken locative).
Signed-off-by: felix <felix@call-with-current-continuation.org>
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 6a8df909..31b8d0c2 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
+
+<procedure>(locative-index LOC)</procedure>
+
+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 981996f4..32748661 100644
--- a/runtime.c
+++ b/runtime.c
@@ -12150,6 +12150,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))))
Trap