~ chicken-core (chicken-5) 6f4a50ce66f8a721a6343ccd75d35426e738755b
commit 6f4a50ce66f8a721a6343ccd75d35426e738755b
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sat Jun 4 00:03:23 2016 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Thu Jun 16 13:21:23 2016 +0200
Move memory-related procedures to new chicken.memory module
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/README b/README
index e997947d..2a92808d 100644
--- a/README
+++ b/README
@@ -296,12 +296,13 @@
| | |-- chicken.foreign.import.so
| | |-- chicken.format.import.so
| | |-- chicken.gc.import.so
- | | |-- chicken.keyword.import.so
- | | |-- chicken.locative.import.so
- | | |-- chicken.lolevel.import.so
| | |-- chicken.internal.import.so
| | |-- chicken.io.import.so
| | |-- chicken.irregex.import.so
+ | | |-- chicken.keyword.import.so
+ | | |-- chicken.locative.import.so
+ | | |-- chicken.lolevel.import.so
+ | | |-- chicken.memory.import.so
| | |-- chicken.pathname.import.so
| | |-- chicken.ports.import.so
| | |-- chicken.posix.import.so
diff --git a/c-platform.scm b/c-platform.scm
index f95a2380..acd0b533 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -181,31 +181,31 @@
srfi-4#blob->u32vector/shared srfi-4#blob->s32vector/shared
srfi-4#blob->u64vector/shared srfi-4#blob->s64vector/shared
srfi-4#blob->f32vector/shared srfi-4#blob->f64vector/shared
- chicken.lolevel#make-record-instance
+ chicken.lolevel#number-of-slots chicken.lolevel#make-record-instance
chicken.lolevel#block-ref chicken.lolevel#block-set!
- chicken.lolevel#u8vector-ref chicken.lolevel#s8vector-ref
- chicken.lolevel#u16vector-ref chicken.lolevel#s16vector-ref
- chicken.lolevel#u32vector-ref chicken.lolevel#s32vector-ref
- chicken.lolevel#u64vector-ref chicken.lolevel#s64vector-ref
- chicken.lolevel#f32vector-ref chicken.lolevel#f64vector-ref
- chicken.lolevel#f32vector-set! chicken.lolevel#f64vector-set!
- chicken.lolevel#u8vector-set! chicken.lolevel#s8vector-set!
- chicken.lolevel#u16vector-set! chicken.lolevel#s16vector-set!
- chicken.lolevel#u32vector-set! chicken.lolevel#s32vector-set!
- chicken.lolevel#u64vector-set! chicken.lolevel#s64vector-set!
+ chicken.memory#u8vector-ref chicken.memory#s8vector-ref
+ chicken.memory#u16vector-ref chicken.memory#s16vector-ref
+ chicken.memory#u32vector-ref chicken.memory#s32vector-ref
+ chicken.memory#u64vector-ref chicken.memory#s64vector-ref
+ chicken.memory#f32vector-ref chicken.memory#f64vector-ref
+ chicken.memory#f32vector-set! chicken.memory#f64vector-set!
+ chicken.memory#u8vector-set! chicken.memory#s8vector-set!
+ chicken.memory#u16vector-set! chicken.memory#s16vector-set!
+ chicken.memory#u32vector-set! chicken.memory#s32vector-set!
+ chicken.memory#u64vector-set! chicken.memory#s64vector-set!
chicken.locative#locative-ref chicken.locative#locative-set!
chicken.locative#locative->object chicken.locative#locative?
- chicken.lolevel#pointer->object chicken.lolevel#pointer+
- chicken.lolevel#address->pointer chicken.lolevel#pointer->address
- chicken.lolevel#pointer=? chicken.lolevel#number-of-slots
- chicken.lolevel#pointer-u8-ref chicken.lolevel#pointer-s8-ref
- chicken.lolevel#pointer-u16-ref chicken.lolevel#pointer-s16-ref
- chicken.lolevel#pointer-u32-ref chicken.lolevel#pointer-s32-ref
- chicken.lolevel#pointer-f32-ref chicken.lolevel#pointer-f64-ref
- chicken.lolevel#pointer-u8-set! chicken.lolevel#pointer-s8-set!
- chicken.lolevel#pointer-u16-set! chicken.lolevel#pointer-s16-set!
- chicken.lolevel#pointer-u32-set! chicken.lolevel#pointer-s32-set!
- chicken.lolevel#pointer-f32-set! chicken.lolevel#pointer-f64-set!
+ chicken.memory#pointer+ chicken.memory#pointer=?
+ chicken.memory#address->pointer chicken.memory#pointer->address
+ chicken.memory#pointer->object chicken.memory#object->pointer
+ chicken.memory#pointer-u8-ref chicken.memory#pointer-s8-ref
+ chicken.memory#pointer-u16-ref chicken.memory#pointer-s16-ref
+ chicken.memory#pointer-u32-ref chicken.memory#pointer-s32-ref
+ chicken.memory#pointer-f32-ref chicken.memory#pointer-f64-ref
+ chicken.memory#pointer-u8-set! chicken.memory#pointer-s8-set!
+ chicken.memory#pointer-u16-set! chicken.memory#pointer-s16-set!
+ chicken.memory#pointer-u32-set! chicken.memory#pointer-s32-set!
+ chicken.memory#pointer-f32-set! chicken.memory#pointer-f64-set!
chicken.data-structures#o
chicken.data-structures#substring-index
chicken.data-structures#substring-index-ci
@@ -745,28 +745,28 @@
(rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t)
(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t #t)
(rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care
-(rewrite 'chicken.lolevel#address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)
-(rewrite 'chicken.lolevel#pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)
-(rewrite 'chicken.lolevel#pointer+ 16 2 "C_a_u_i_pointer_inc" #f 2)
+(rewrite 'chicken.memory#address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)
+(rewrite 'chicken.memory#pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)
+(rewrite 'chicken.memory#pointer+ 16 2 "C_a_u_i_pointer_inc" #f 2)
(rewrite 'chicken.locative#locative-ref 16 1 "C_a_i_locative_ref" #t 6)
-(rewrite 'chicken.lolevel#pointer-u8-ref 2 1 "C_u_i_pointer_u8_ref" #f)
-(rewrite 'chicken.lolevel#pointer-s8-ref 2 1 "C_u_i_pointer_s8_ref" #f)
-(rewrite 'chicken.lolevel#pointer-u16-ref 2 1 "C_u_i_pointer_u16_ref" #f)
-(rewrite 'chicken.lolevel#pointer-s16-ref 2 1 "C_u_i_pointer_s16_ref" #f)
-(rewrite 'chicken.lolevel#pointer-u8-set! 2 2 "C_u_i_pointer_u8_set" #f)
-(rewrite 'chicken.lolevel#pointer-s8-set! 2 2 "C_u_i_pointer_s8_set" #f)
-(rewrite 'chicken.lolevel#pointer-u16-set! 2 2 "C_u_i_pointer_u16_set" #f)
-(rewrite 'chicken.lolevel#pointer-s16-set! 2 2 "C_u_i_pointer_s16_set" #f)
-(rewrite 'chicken.lolevel#pointer-u32-set! 2 2 "C_u_i_pointer_u32_set" #f)
-(rewrite 'chicken.lolevel#pointer-s32-set! 2 2 "C_u_i_pointer_s32_set" #f)
-(rewrite 'chicken.lolevel#pointer-f32-set! 2 2 "C_u_i_pointer_f32_set" #f)
-(rewrite 'chicken.lolevel#pointer-f64-set! 2 2 "C_u_i_pointer_f64_set" #f)
-
-(rewrite 'chicken.lolevel#pointer-u32-ref 16 1 "C_a_u_i_pointer_u32_ref" #f words-per-flonum)
-(rewrite 'chicken.lolevel#pointer-s32-ref 16 1 "C_a_u_i_pointer_s32_ref" #f words-per-flonum)
-(rewrite 'chicken.lolevel#pointer-f32-ref 16 1 "C_a_u_i_pointer_f32_ref" #f words-per-flonum)
-(rewrite 'chicken.lolevel#pointer-f64-ref 16 1 "C_a_u_i_pointer_f64_ref" #f words-per-flonum)
+(rewrite 'chicken.memory#pointer-u8-ref 2 1 "C_u_i_pointer_u8_ref" #f)
+(rewrite 'chicken.memory#pointer-s8-ref 2 1 "C_u_i_pointer_s8_ref" #f)
+(rewrite 'chicken.memory#pointer-u16-ref 2 1 "C_u_i_pointer_u16_ref" #f)
+(rewrite 'chicken.memory#pointer-s16-ref 2 1 "C_u_i_pointer_s16_ref" #f)
+(rewrite 'chicken.memory#pointer-u8-set! 2 2 "C_u_i_pointer_u8_set" #f)
+(rewrite 'chicken.memory#pointer-s8-set! 2 2 "C_u_i_pointer_s8_set" #f)
+(rewrite 'chicken.memory#pointer-u16-set! 2 2 "C_u_i_pointer_u16_set" #f)
+(rewrite 'chicken.memory#pointer-s16-set! 2 2 "C_u_i_pointer_s16_set" #f)
+(rewrite 'chicken.memory#pointer-u32-set! 2 2 "C_u_i_pointer_u32_set" #f)
+(rewrite 'chicken.memory#pointer-s32-set! 2 2 "C_u_i_pointer_s32_set" #f)
+(rewrite 'chicken.memory#pointer-f32-set! 2 2 "C_u_i_pointer_f32_set" #f)
+(rewrite 'chicken.memory#pointer-f64-set! 2 2 "C_u_i_pointer_f64_set" #f)
+
+(rewrite 'chicken.memory#pointer-u32-ref 16 1 "C_a_u_i_pointer_u32_ref" #f words-per-flonum)
+(rewrite 'chicken.memory#pointer-s32-ref 16 1 "C_a_u_i_pointer_s32_ref" #f words-per-flonum)
+(rewrite 'chicken.memory#pointer-f32-ref 16 1 "C_a_u_i_pointer_f32_ref" #f words-per-flonum)
+(rewrite 'chicken.memory#pointer-f64-ref 16 1 "C_a_u_i_pointer_f64_ref" #f words-per-flonum)
(rewrite
'##sys#setslot 8
@@ -836,7 +836,7 @@
(rewrite '##sys#setbyte 17 3 "C_setbyte")
(rewrite '##sys#peek-fixnum 17 2 "C_peek_fixnum")
(rewrite '##sys#peek-byte 17 2 "C_peek_byte")
-(rewrite 'chicken.lolevel#pointer->object 17 2 "C_pointer_to_object")
+(rewrite 'chicken.memory#pointer->object 17 2 "C_pointer_to_object")
(rewrite '##sys#setislot 17 3 "C_i_set_i_slot")
(rewrite '##sys#poke-integer 17 3 "C_poke_integer")
(rewrite '##sys#poke-double 17 3 "C_poke_double")
@@ -973,14 +973,14 @@
(srfi-4#f64vector-ref . srfi-4#f64vector-set!)
(chicken.locative#locative-ref . chicken.locative#locative-set!)
(chicken.lolevel#block-ref . chicken.lolevel#block-set!)
- (chicken.lolevel#pointer-u8-ref . chicken.lolevel#pointer-u8-set!)
- (chicken.lolevel#pointer-s8-ref . chicken.lolevel#pointer-s8-set!)
- (chicken.lolevel#pointer-u16-ref . chicken.lolevel#pointer-u16-set!)
- (chicken.lolevel#pointer-s16-ref . chicken.lolevel#pointer-s16-set!)
- (chicken.lolevel#pointer-u32-ref . chicken.lolevel#pointer-u32-set!)
- (chicken.lolevel#pointer-s32-ref . chicken.lolevel#pointer-s32-set!)
- (chicken.lolevel#pointer-f32-ref . chicken.lolevel#pointer-f32-set!)
- (chicken.lolevel#pointer-f64-ref . chicken.lolevel#pointer-f64-set!)))
+ (chicken.memory#pointer-u8-ref . chicken.memory#pointer-u8-set!)
+ (chicken.memory#pointer-s8-ref . chicken.memory#pointer-s8-set!)
+ (chicken.memory#pointer-u16-ref . chicken.memory#pointer-u16-set!)
+ (chicken.memory#pointer-s16-ref . chicken.memory#pointer-s16-set!)
+ (chicken.memory#pointer-u32-ref . chicken.memory#pointer-u32-set!)
+ (chicken.memory#pointer-s32-ref . chicken.memory#pointer-s32-set!)
+ (chicken.memory#pointer-f32-ref . chicken.memory#pointer-f32-set!)
+ (chicken.memory#pointer-f64-ref . chicken.memory#pointer-f64-set!)))
(rewrite
'##sys#setter 8
diff --git a/chicken-install.scm b/chicken-install.scm
index a4b87caf..68d08c6c 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -63,6 +63,7 @@
"chicken.keyword.import.so"
"chicken.locative.import.so"
"chicken.lolevel.import.so"
+ "chicken.memory.import.so"
"chicken.pathname.import.so"
"chicken.ports.import.so"
"chicken.posix.import.so"
diff --git a/defaults.make b/defaults.make
index 404fa11c..c9cf4587 100644
--- a/defaults.make
+++ b/defaults.make
@@ -265,7 +265,7 @@ CHICKEN_PROGRAM_OPTIONS += $(if $(PROFILE_OBJECTS),-profile)
PRIMITIVE_IMPORT_LIBRARIES = chicken chicken.csi chicken.foreign
DYNAMIC_IMPORT_LIBRARIES = setup-api setup-download srfi-4
DYNAMIC_CHICKEN_IMPORT_LIBRARIES = bitwise fixnum flonum format gc io \
- keyword locative posix pretty-print random time
+ keyword locative memory posix pretty-print random time
DYNAMIC_CHICKEN_COMPILER_IMPORT_LIBRARIES = user-pass
DYNAMIC_CHICKEN_UNIT_IMPORT_LIBRARIES = continuation data-structures \
eval expand files internal irregex lolevel pathname ports \
diff --git a/distribution/manifest b/distribution/manifest
index e9106cbd..15dad8bd 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -291,6 +291,8 @@ chicken.locative.import.scm
chicken.locative.import.c
chicken.lolevel.import.scm
chicken.lolevel.import.c
+chicken.memory.import.scm
+chicken.memory.import.c
chicken.pathname.import.scm
chicken.pathname.import.c
chicken.ports.import.scm
diff --git a/lolevel.scm b/lolevel.scm
index d226166b..e53d5264 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -36,30 +36,24 @@
EOF
) )
-(module chicken.lolevel
- (address->pointer align-to-word allocate block-ref block-set!
- extend-procedure extended-procedure? free
- make-pointer-vector make-record-instance
- move-memory! mutate-procedure! number-of-bytes number-of-slots
- object->pointer object-become! object-copy pointer+ pointer->address
+(include "common-declarations.scm")
+
+(module chicken.memory
+ (address->pointer align-to-word allocate free make-pointer-vector
+ move-memory! object->pointer pointer+ pointer->address
pointer->object pointer-f32-ref pointer-f32-set! pointer-f64-ref
pointer-f64-set! pointer-like? pointer-s16-ref pointer-s16-set!
pointer-s32-ref pointer-s32-set! pointer-s64-ref pointer-s64-set!
pointer-s8-ref pointer-s8-set! pointer-tag pointer-u16-ref
- pointer-u16-set! pointer-u32-ref pointer-u32-set!
- pointer-u64-ref pointer-u64-set! pointer-u8-ref pointer-u8-set!
- pointer-vector pointer-vector-fill! pointer-vector-length
- pointer-vector-ref pointer-vector-set! pointer-vector?
- pointer=? pointer? procedure-data
- record->vector record-instance-length record-instance-slot
- record-instance-slot-set! record-instance-type record-instance?
- set-procedure-data! tag-pointer tagged-pointer? vector-like?)
+ pointer-u16-set! pointer-u32-ref pointer-u32-set! pointer-u64-ref
+ pointer-u64-set! pointer-u8-ref pointer-u8-set! pointer-vector
+ pointer-vector-fill! pointer-vector-length pointer-vector-ref
+ pointer-vector-set! pointer-vector? pointer=? pointer? tag-pointer
+ tagged-pointer?)
(import scheme chicken)
(import chicken.foreign)
-(include "common-declarations.scm")
-
;;; Helpers:
@@ -197,23 +191,6 @@ EOF
(typerr from)] ) ) ) ) )
-;;; Copy arbitrary object:
-
-(define (object-copy x)
- (let copy ([x x])
- (cond [(not (##core#inline "C_blockp" x)) x]
- [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
- [else
- (let* ([n (##sys#size x)]
- [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
- [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
- (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
- (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
- [(fx>= i n)]
- (##sys#setslot y i (copy (##sys#slot y i))) ) )
- y) ] ) ) )
-
-
;;; Pointer operations:
(define allocate (foreign-lambda c-pointer "C_malloc" int))
@@ -358,6 +335,107 @@ EOF
"(pointer-f64-ref p)"))
+;;; pointer vectors
+
+(define make-pointer-vector
+ (let ((unset (list 'unset)))
+ (lambda (n #!optional (init unset))
+ (##sys#check-exact n 'make-pointer-vector)
+ (let* ((mul (##sys#fudge 7)) ; wordsize
+ (size (fx* n mul))
+ (buf (##sys#make-blob size)))
+ (unless (eq? init unset)
+ (when init
+ (##sys#check-pointer init 'make-pointer-vector))
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i n))
+ (pv-buf-set! buf i init)))
+ (##sys#make-structure 'pointer-vector n buf)))))
+
+(define (pointer-vector? x)
+ (##sys#structure? x 'pointer-vector))
+
+(define (pointer-vector . ptrs)
+ (let* ((n (length ptrs))
+ (pv (make-pointer-vector n))
+ (buf (##sys#slot pv 2))) ; buf
+ (do ((ptrs ptrs (cdr ptrs))
+ (i 0 (fx+ i 1)))
+ ((null? ptrs) pv)
+ (let ((ptr (car ptrs)))
+ (##sys#check-pointer ptr 'pointer-vector)
+ (pv-buf-set! buf i ptr)))))
+
+(define (pointer-vector-fill! pv ptr)
+ (##sys#check-structure pv 'pointer-vector 'pointer-vector-fill!)
+ (when ptr (##sys#check-pointer ptr 'pointer-vector-fill!))
+ (let ((buf (##sys#slot pv 2)) ; buf
+ (n (##sys#slot pv 1))) ; n
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i n))
+ (pv-buf-set! buf i ptr))))
+
+(define pv-buf-ref
+ (foreign-lambda* c-pointer ((scheme-object buf) (unsigned-int i))
+ "C_return(*((void **)C_data_pointer(buf) + i));"))
+
+(define pv-buf-set!
+ (foreign-lambda* void ((scheme-object buf) (unsigned-int i) (c-pointer ptr))
+ "*((void **)C_data_pointer(buf) + i) = ptr;"))
+
+(define (pointer-vector-set! pv i ptr)
+ (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
+ (##sys#check-exact i 'pointer-vector-ref)
+ (##sys#check-range i 0 (##sys#slot pv 1)) ; len
+ (when ptr (##sys#check-pointer ptr 'pointer-vector-set!))
+ (pv-buf-set! (##sys#slot pv 2) i ptr))
+
+(define pointer-vector-ref
+ (getter-with-setter
+ (lambda (pv i)
+ (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
+ (##sys#check-exact i 'pointer-vector-ref)
+ (##sys#check-range i 0 (##sys#slot pv 1)) ; len
+ (pv-buf-ref (##sys#slot pv 2) i)) ; buf
+ pointer-vector-set!
+ "(pointer-vector-ref pv i)"))
+
+(define (pointer-vector-length pv)
+ (##sys#check-structure pv 'pointer-vector 'pointer-vector-length)
+ (##sys#slot pv 1))
+
+) ; chicken.memory
+
+
+(module chicken.lolevel
+ (block-ref block-set! extend-procedure extended-procedure?
+ make-record-instance mutate-procedure! number-of-bytes
+ number-of-slots object-become! object-copy procedure-data
+ record->vector record-instance-length record-instance-slot
+ record-instance-slot-set! record-instance-type record-instance?
+ set-procedure-data! vector-like?)
+
+(import scheme chicken)
+(import chicken.foreign)
+
+
+;;; Copy arbitrary object:
+
+(define (object-copy x)
+ (let copy ((x x))
+ (cond ((not (##core#inline "C_blockp" x)) x)
+ ((symbol? x) (##sys#intern-symbol (##sys#slot x 1)))
+ (else
+ (let* ((n (##sys#size x))
+ (words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n))
+ (y (##core#inline "C_copy_block" x (##sys#make-vector words))))
+ (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
+ (do ((i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)))
+ ((fx>= i n))
+ (##sys#setslot y i (copy (##sys#slot y i)))))
+ y)))))
+
+
;;; Procedures extended with data:
; Unique id for extended-procedures
@@ -480,78 +558,9 @@ EOF
(##sys#become! (list (cons old (proc new))))
new ) )
-
-;;; pointer vectors
-
-(define make-pointer-vector
- (let ((unset (list 'unset)))
- (lambda (n #!optional (init unset))
- (##sys#check-exact n 'make-pointer-vector)
- (let* ((mul (##sys#fudge 7)) ; wordsize
- (size (fx* n mul))
- (buf (##sys#make-blob size)))
- (unless (eq? init unset)
- (when init
- (##sys#check-pointer init 'make-pointer-vector))
- (do ((i 0 (fx+ i 1)))
- ((fx>= i n))
- (pv-buf-set! buf i init)))
- (##sys#make-structure 'pointer-vector n buf)))))
-
-(define (pointer-vector? x)
- (##sys#structure? x 'pointer-vector))
-
-(define (pointer-vector . ptrs)
- (let* ((n (length ptrs))
- (pv (make-pointer-vector n))
- (buf (##sys#slot pv 2))) ; buf
- (do ((ptrs ptrs (cdr ptrs))
- (i 0 (fx+ i 1)))
- ((null? ptrs) pv)
- (let ((ptr (car ptrs)))
- (##sys#check-pointer ptr 'pointer-vector)
- (pv-buf-set! buf i ptr)))))
-
-(define (pointer-vector-fill! pv ptr)
- (##sys#check-structure pv 'pointer-vector 'pointer-vector-fill!)
- (when ptr (##sys#check-pointer ptr 'pointer-vector-fill!))
- (let ((buf (##sys#slot pv 2)) ; buf
- (n (##sys#slot pv 1))) ; n
- (do ((i 0 (fx+ i 1)))
- ((fx>= i n))
- (pv-buf-set! buf i ptr))))
-
-(define pv-buf-ref
- (foreign-lambda* c-pointer ((scheme-object buf) (unsigned-int i))
- "C_return(*((void **)C_data_pointer(buf) + i));"))
-
-(define pv-buf-set!
- (foreign-lambda* void ((scheme-object buf) (unsigned-int i) (c-pointer ptr))
- "*((void **)C_data_pointer(buf) + i) = ptr;"))
-
-(define (pointer-vector-set! pv i ptr)
- (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
- (##sys#check-exact i 'pointer-vector-ref)
- (##sys#check-range i 0 (##sys#slot pv 1)) ; len
- (when ptr (##sys#check-pointer ptr 'pointer-vector-set!))
- (pv-buf-set! (##sys#slot pv 2) i ptr))
-
-(define pointer-vector-ref
- (getter-with-setter
- (lambda (pv i)
- (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
- (##sys#check-exact i 'pointer-vector-ref)
- (##sys#check-range i 0 (##sys#slot pv 1)) ; len
- (pv-buf-ref (##sys#slot pv 2) i)) ; buf
- pointer-vector-set!
- "(pointer-vector-ref pv i)"))
-
-(define (pointer-vector-length pv)
- (##sys#check-structure pv 'pointer-vector 'pointer-vector-length)
- (##sys#slot pv 1))
-
) ; chicken.lolevel
+
(module chicken.locative
(locative? make-locative make-weak-locative
locative-ref locative-set! locative->object)
diff --git a/manual/Unit lolevel b/manual/Unit lolevel
index 33ba4994..38f708f2 100644
--- a/manual/Unit lolevel
+++ b/manual/Unit lolevel
@@ -7,9 +7,6 @@
This unit provides a number of handy low-level operations. '''Use
at your own risk.'''
-This unit uses the {{srfi-4}} and {{extras}} units.
-
-
=== Foreign pointers
@@ -22,6 +19,8 @@ The abstract class of ''pointer'' is divided into 2 categories:
Note that Locatives, while technically pointers, are not considered a ''pointer
object'', but a ''pointer-like object''. The distinction is artificial.
+Pointer operations are provided by the {{(chicken memory)}} module.
+
==== address->pointer
@@ -128,12 +127,14 @@ Use of anything other than an integer or pointer object as an argument is
questionable.
-
=== SRFI-4 Foreign pointers
These procedures actually accept a pointer-like object as the {{POINTER}} argument.
However, as usual, use of anything other than a pointer object is questionable.
+SRFI-4 pointer operations are provided by the {{(chicken memory)}} module.
+
+
==== pointer-u8-ref
<procedure>(pointer-u8-ref POINTER)</procedure>
@@ -288,6 +289,8 @@ Stores the 64-bit floating-point number {{N}} at the address designated by {{POI
''Tagged'' pointers are foreign pointer objects with an extra tag object.
+Tagged pointer operations are provided by the {{(chicken memory)}} module.
+
==== tag-pointer
@@ -324,6 +327,9 @@ foreign pointer objects. All procedures defined below that accept
a pointer object allow {{#f}} as an alternative representation of
the {{NULL}}-pointer.
+Pointer vectors are provided by the {{(chicken memory)}} module.
+
+
==== make-pointer-vector
<procedure>(make-pointer-vector LENGTH [INIT])</procedure>
@@ -555,6 +561,8 @@ for the source and destination arguments.
Signals an error if any of the above constraints is violated.
+This procedure is provided by the {{(chicken memory)}} module.
+
=== Record instance
diff --git a/rules.make b/rules.make
index a32d5c6c..a4a32936 100644
--- a/rules.make
+++ b/rules.make
@@ -530,6 +530,7 @@ $(eval $(call declare-emitted-import-lib-dependency,chicken.io,extras))
$(eval $(call declare-emitted-import-lib-dependency,chicken.pretty-print,extras))
$(eval $(call declare-emitted-import-lib-dependency,chicken.random,extras))
$(eval $(call declare-emitted-import-lib-dependency,chicken.locative,lolevel))
+$(eval $(call declare-emitted-import-lib-dependency,chicken.memory,lolevel))
chicken.c: chicken.scm mini-srfi-1.scm \
chicken.compiler.batch-driver.import.scm \
@@ -820,7 +821,8 @@ files.c: $(SRCDIR)files.scm $(SRCDIR)common-declarations.scm
lolevel.c: $(SRCDIR)lolevel.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) \
-emit-import-library chicken.locative \
- -emit-import-library chicken.lolevel
+ -emit-import-library chicken.lolevel \
+ -emit-import-library chicken.memory
tcp.c: $(SRCDIR)tcp.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) -emit-import-library chicken.tcp
srfi-4.c: $(SRCDIR)srfi-4.scm $(SRCDIR)common-declarations.scm
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index 9082bf95..243d2d74 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -1,6 +1,6 @@
;;;; Unit lolevel testing
-(require-extension format locative lolevel srfi-4)
+(use chicken.memory format locative lolevel srfi-4)
(define-syntax assert-error
(syntax-rules ()
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 785691b6..83db2d0a 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -1,7 +1,7 @@
;;;; typematch-tests.scm
-(use locative lolevel data-structures)
+(use chicken.memory data-structures locative)
(define (make-list n x)
diff --git a/types.db b/types.db
index 61b4f058..3c0ee1e2 100644
--- a/types.db
+++ b/types.db
@@ -1715,27 +1715,78 @@
(chicken.irregex#string->sre (#(procedure #:clean #:enforce) chicken.irregex#string->sre (string #!rest) *))
-;; lolevel
+;; memory
+
+(chicken.memory#allocate (#(procedure #:clean #:enforce) chicken.memory#allocate (fixnum) (or false pointer)))
+(chicken.memory#free (#(procedure #:clean #:enforce) chicken.memory#free (pointer) undefined))
+
+(chicken.memory#address->pointer (#(procedure #:clean #:enforce) chicken.memory#address->pointer (fixnum) pointer)
+ ((fixnum) (##sys#address->pointer #(1))))
+
+(chicken.memory#pointer->address (#(procedure #:clean #:enforce) chicken.memory#pointer->address ((or pointer procedure port locative)) integer)
+ ((pointer) (##sys#pointer->address #(1))))
+
+(chicken.memory#align-to-word (#(procedure #:clean) chicken.memory#align-to-word ((or number pointer locative procedure port)) (or pointer number)))
+
+(chicken.memory#move-memory! (#(procedure #:enforce) chicken.memory#move-memory! (* * #!optional fixnum fixnum fixnum) *))
+
+(chicken.memory#object->pointer (#(procedure #:clean) chicken.memory#object->pointer (*) *))
+(chicken.memory#pointer->object (#(procedure #:clean #:enforce) chicken.memory#pointer->object (pointer) *)
+ ((pointer) (##core#inline "C_pointer_to_object" #(1))))
+
+(chicken.memory#pointer+ (#(procedure #:clean #:enforce) chicken.memory#pointer+ ((or pointer procedure port locative) fixnum) pointer))
+(chicken.memory#pointer? (#(procedure #:clean #:predicate pointer) chicken.memory#pointer? (*) boolean))
+(chicken.memory#pointer=? (#(procedure #:clean #:enforce) chicken.memory#pointer=? ((or pointer locative procedure port)
+ (or pointer locative procedure port)) boolean)
+ ((pointer pointer) (##core#inline "C_pointer_eqp" #(1) #(2))))
+(chicken.memory#pointer-like? (#(procedure #:pure #:predicate (or pointer locative procedure port)) chicken.memory#pointer-like? (*) boolean)
+ (((or pointer locative procedure port)) (let ((#(tmp) #(1))) '#t)))
+
+(chicken.memory#make-pointer-vector (#(procedure #:clean #:enforce) chicken.memory#make-pointer-vector (fixnum #!optional (or pointer false)) pointer-vector))
+(chicken.memory#make-record-instance (#(procedure #:clean) chicken.memory#make-record-instance (symbol #!rest) *))
+(chicken.memory#pointer-vector (#(procedure #:clean #:enforce) chicken.memory#pointer-vector (#!rest pointer-vector) boolean))
+(chicken.memory#pointer-vector? (#(procedure #:pure #:predicate pointer-vector) chicken.memory#pointer-vector? (*) boolean))
+(chicken.memory#pointer-vector-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-vector-ref (pointer-vector fixnum) (or pointer false)))
+(chicken.memory#pointer-vector-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-vector-set! (pointer-vector fixnum (or pointer false)) undefined))
+(chicken.memory#pointer-vector-fill! (#(procedure #:clean #:enforce) chicken.memory#pointer-vector-fill! (pointer-vector (or pointer false)) undefined))
+(chicken.memory#pointer-vector-length (#(procedure #:clean #:enforce) chicken.memory#pointer-vector-length (pointer-vector) fixnum)
+ ((pointer-vector) (##sys#slot #(1) '1)))
+
+(chicken.memory#pointer-f32-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-f32-ref (pointer) number))
+(chicken.memory#pointer-f32-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-f32-set! (pointer number) undefined))
+(chicken.memory#pointer-f64-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-f64-ref (pointer) number))
+(chicken.memory#pointer-f64-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-f64-set! (pointer number) undefined))
+
+(chicken.memory#pointer-s16-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-s16-ref (pointer) fixnum))
+(chicken.memory#pointer-s16-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-s16-set! (pointer fixnum) undefined))
+(chicken.memory#pointer-s32-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-s32-ref (pointer) integer))
+(chicken.memory#pointer-s32-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-s32-set! (pointer integer) undefined))
+(chicken.memory#pointer-s64-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-s64-ref (pointer) integer))
+(chicken.memory#pointer-s64-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-s64-set! (pointer integer) undefined))
+(chicken.memory#pointer-s8-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-s8-ref (pointer) fixnum))
+(chicken.memory#pointer-s8-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-s8-set! (pointer fixnum) undefined))
+
+(chicken.memory#pointer-u16-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-u16-ref (pointer) fixnum))
+(chicken.memory#pointer-u16-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-u16-set! (pointer fixnum) undefined))
+(chicken.memory#pointer-u32-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-u32-ref (pointer) integer))
+(chicken.memory#pointer-u32-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-u32-set! (pointer integer) undefined))
+(chicken.memory#pointer-u64-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-u64-ref (pointer) integer))
+(chicken.memory#pointer-u64-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-u64-set! (pointer integer) undefined))
+(chicken.memory#pointer-u8-ref (#(procedure #:clean #:enforce) chicken.memory#pointer-u8-ref (pointer) fixnum))
+(chicken.memory#pointer-u8-set! (#(procedure #:clean #:enforce) chicken.memory#pointer-u8-set! (pointer fixnum) undefined))
+
+(chicken.memory#tag-pointer (#(procedure #:clean #:enforce) chicken.memory#tag-pointer (pointer *) pointer))
+(chicken.memory#tagged-pointer? (#(procedure #:clean #:enforce) chicken.memory#tagged-pointer? (* #!optional *) boolean))
+(chicken.memory#pointer-tag (#(procedure #:clean #:enforce) chicken.memory#pointer-tag ((or pointer locative procedure port)) *)
+ (((or locative procedure port)) (let ((#(tmp) #(1))) '#f)))
-(chicken.lolevel#address->pointer (#(procedure #:clean #:enforce) chicken.lolevel#address->pointer (fixnum) pointer)
- ((fixnum) (##sys#address->pointer #(1))))
-(chicken.lolevel#align-to-word
- (#(procedure #:clean)
- chicken.lolevel#align-to-word
- ((or number pointer locative procedure port))
- (or pointer number)))
+;; lolevel
-(chicken.lolevel#allocate (#(procedure #:clean #:enforce) chicken.lolevel#allocate (fixnum) (or false pointer)))
(chicken.lolevel#block-ref (#(procedure #:clean #:enforce) chicken.lolevel#block-ref (* fixnum) *))
(chicken.lolevel#block-set! (#(procedure #:enforce) chicken.lolevel#block-set! (* fixnum *) *))
(chicken.lolevel#extend-procedure (#(procedure #:clean #:enforce) chicken.lolevel#extend-procedure (procedure *) procedure))
(chicken.lolevel#extended-procedure? (#(procedure #:clean) chicken.lolevel#extended-procedure (*) boolean))
-(chicken.lolevel#free (#(procedure #:clean #:enforce) chicken.lolevel#free (pointer) undefined))
-(chicken.lolevel#make-pointer-vector (#(procedure #:clean #:enforce) chicken.lolevel#make-pointer-vector (fixnum #!optional (or pointer false)) pointer-vector))
-(chicken.lolevel#make-record-instance (#(procedure #:clean) chicken.lolevel#make-record-instance (symbol #!rest) *))
-
-(chicken.lolevel#move-memory! (#(procedure #:enforce) chicken.lolevel#move-memory! (* * #!optional fixnum fixnum fixnum) *))
(chicken.lolevel#mutate-procedure!
(#(procedure #:enforce) chicken.lolevel#mutate-procedure! (procedure (procedure (procedure) . *)) procedure))
@@ -1750,62 +1801,8 @@
(chicken.lolevel#number-of-slots (#(procedure #:clean #:foldable) chicken.lolevel#number-of-slots (*) fixnum)
(((or vector symbol pair)) (##sys#size #(1))))
-(chicken.lolevel#object->pointer (#(procedure #:clean) chicken.lolevel#object->pointer (*) *))
(chicken.lolevel#object-become! (procedure chicken.lolevel#object-become! (list) *))
(chicken.lolevel#object-copy (#(procedure #:clean) chicken.lolevel#object-copy (*) *))
-(chicken.lolevel#pointer+ (#(procedure #:clean #:enforce) chicken.lolevel#pointer+ ((or pointer procedure port locative) fixnum) pointer))
-
-(chicken.lolevel#pointer->address (#(procedure #:clean #:enforce) chicken.lolevel#pointer->address ((or pointer procedure port locative)) integer)
- ((pointer) (##sys#pointer->address #(1))))
-
-(chicken.lolevel#pointer->object (#(procedure #:clean #:enforce) chicken.lolevel#pointer->object (pointer) *)
- ((pointer) (##core#inline "C_pointer_to_object" #(1))))
-
-(chicken.lolevel#pointer-like? (#(procedure #:pure #:predicate (or pointer locative procedure port)) chicken.lolevel#pointer-like? (*) boolean)
- (((or pointer locative procedure port)) (let ((#(tmp) #(1))) '#t)))
-
-(chicken.lolevel#pointer-f32-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-f32-ref (pointer) number))
-(chicken.lolevel#pointer-f32-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-f32-set! (pointer number) undefined))
-(chicken.lolevel#pointer-f64-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-f64-ref (pointer) number))
-(chicken.lolevel#pointer-f64-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-f64-set! (pointer number) undefined))
-(chicken.lolevel#pointer-vector (#(procedure #:clean #:enforce) chicken.lolevel#pointer-vector (#!rest pointer-vector) boolean))
-
-(chicken.lolevel#pointer-vector? (#(procedure #:pure #:predicate pointer-vector) chicken.lolevel#pointer-vector? (*) boolean))
-
-(chicken.lolevel#pointer-vector-fill! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-vector-fill! (pointer-vector (or pointer false)) undefined))
-
-(chicken.lolevel#pointer-vector-length (#(procedure #:clean #:enforce) chicken.lolevel#pointer-vector-length (pointer-vector) fixnum)
- ((pointer-vector) (##sys#slot #(1) '1)))
-
-(chicken.lolevel#pointer-vector-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-vector-ref (pointer-vector fixnum) (or pointer false)))
-(chicken.lolevel#pointer-vector-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-vector-set! (pointer-vector fixnum (or pointer false)) undefined))
-(chicken.lolevel#pointer-s16-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-s16-ref (pointer) fixnum))
-(chicken.lolevel#pointer-s16-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-s16-set! (pointer fixnum) undefined))
-(chicken.lolevel#pointer-s32-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-s32-ref (pointer) integer))
-(chicken.lolevel#pointer-s32-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-s32-set! (pointer integer) undefined))
-(chicken.lolevel#pointer-s64-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-s64-ref (pointer) integer))
-(chicken.lolevel#pointer-s64-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-s64-set! (pointer integer) undefined))
-(chicken.lolevel#pointer-s8-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-s8-ref (pointer) fixnum))
-(chicken.lolevel#pointer-s8-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-s8-set! (pointer fixnum) undefined))
-
-(chicken.lolevel#pointer-tag (#(procedure #:clean #:enforce) chicken.lolevel#pointer-tag ((or pointer locative procedure port)) *)
- (((or locative procedure port)) (let ((#(tmp) #(1))) '#f)))
-
-(chicken.lolevel#pointer-u16-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-u16-ref (pointer) fixnum))
-(chicken.lolevel#pointer-u16-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-u16-set! (pointer fixnum) undefined))
-(chicken.lolevel#pointer-u32-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-u32-ref (pointer) integer))
-(chicken.lolevel#pointer-u32-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-u32-set! (pointer integer) undefined))
-(chicken.lolevel#pointer-u64-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-u64-ref (pointer) integer))
-(chicken.lolevel#pointer-u64-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-u64-set! (pointer integer) undefined))
-(chicken.lolevel#pointer-u8-ref (#(procedure #:clean #:enforce) chicken.lolevel#pointer-u8-ref (pointer) fixnum))
-(chicken.lolevel#pointer-u8-set! (#(procedure #:clean #:enforce) chicken.lolevel#pointer-u8-set! (pointer fixnum) undefined))
-
-(chicken.lolevel#pointer=? (#(procedure #:clean #:enforce) chicken.lolevel#pointer=? ((or pointer locative procedure port)
- (or pointer locative procedure port)) boolean)
- ((pointer pointer) (##core#inline "C_pointer_eqp" #(1) #(2))))
-
-(chicken.lolevel#pointer? (#(procedure #:clean #:predicate pointer) chicken.lolevel#pointer? (*) boolean))
-
(chicken.lolevel#procedure-data (#(procedure #:clean #:enforce) chicken.lolevel#procedure-data (procedure) *))
(chicken.lolevel#record->vector (#(procedure #:clean) chicken.lolevel#record->vector (*) vector))
@@ -1821,8 +1818,6 @@
(chicken.lolevel#record-instance-slot-set! (#(procedure #:clean #:enforce) chicken.lolevel#record-instance-slot-set! (* fixnum *) undefined))
(chicken.lolevel#record-instance-type (#(procedure #:clean) chicken.lolevel#record-instance-type (*) *))
(chicken.lolevel#set-procedure-data! (#(procedure #:clean #:enforce) chicken.lolevel#set-procedure-data! (procedure *) undefined))
-(chicken.lolevel#tag-pointer (#(procedure #:clean #:enforce) chicken.lolevel#tag-pointer (pointer *) pointer))
-(chicken.lolevel#tagged-pointer? (#(procedure #:clean #:enforce) chicken.lolevel#tagged-pointer? (* #!optional *) boolean))
;; locative
Trap