~ chicken-core (master) /lolevel.scm

  1;;;; lolevel.scm - Low-level routines for CHICKEN
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  8; conditions are met:
  9;
 10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 11;     disclaimer. 
 12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 13;     disclaimer in the documentation and/or other materials provided with the distribution. 
 14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 15;     products derived from this software without specific prior written permission. 
 16;
 17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 25; POSSIBILITY OF SUCH DAMAGE.
 26
 27
 28(declare
 29  (unit lolevel)
 30  (foreign-declare #<<EOF
 31#ifndef C_NONUNIX
 32# include <sys/mman.h>
 33#endif
 34
 35#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
 36EOF
 37) )
 38
 39(include "common-declarations.scm")
 40
 41(module chicken.memory
 42  (address->pointer align-to-word allocate free make-pointer-vector
 43   move-memory! object->pointer pointer+ pointer->address
 44   pointer->object pointer-f32-ref pointer-f32-set! pointer-f64-ref
 45   pointer-f64-set! pointer-like? pointer-s16-ref pointer-s16-set!
 46   pointer-s32-ref pointer-s32-set! pointer-s64-ref pointer-s64-set!
 47   pointer-s8-ref pointer-s8-set! pointer-tag pointer-u16-ref
 48   pointer-u16-set! pointer-u32-ref pointer-u32-set! pointer-u64-ref
 49   pointer-u64-set! pointer-u8-ref pointer-u8-set! pointer-vector
 50   pointer-vector-fill! pointer-vector-length pointer-vector-ref
 51   pointer-vector-set! pointer-vector? pointer=? pointer? tag-pointer
 52   tagged-pointer?)
 53
 54(import scheme chicken.base chicken.fixnum chicken.foreign)
 55
 56
 57;;; Helpers:
 58
 59(define-inline (%pointer? x)
 60  (##core#inline "C_i_safe_pointerp" x))
 61
 62(define-inline (%generic-pointer? x)
 63  (or (%pointer? x)
 64      (##core#inline "C_locativep" x) ) )
 65
 66(define-inline (%special-block? x)
 67  ; generic-pointer, port, closure
 68  (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x)) )
 69
 70(define-inline (%generic-vector? x)
 71  (and (##core#inline "C_blockp" x)
 72       (not (or (##core#inline "C_specialp" x)
 73	        (##core#inline "C_byteblockp" x)))) )
 74
 75(define-inline (%record-structure? x)
 76  (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x)) )
 77
 78
 79
 80;;; Argument checking:
 81
 82(define (##sys#check-block x . loc)
 83  (unless (##core#inline "C_blockp" x)
 84    (##sys#error-hook
 85     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR" int) (and (pair? loc) (car loc))
 86     x) ) )
 87
 88(define (##sys#check-become-alist x loc)
 89  (##sys#check-list x loc)
 90  (let loop ([lst x])
 91    (cond [(null? lst) ]
 92	  [(pair? lst)
 93	   (let ([a (car lst)])
 94	     (##sys#check-pair a loc)
 95	     (##sys#check-block (car a) loc)
 96	     (##sys#check-block (cdr a) loc)
 97	     (loop (cdr lst)) ) ]
 98	  [else
 99	   (##sys#signal-hook
100	    #:type-error loc
101	    "bad argument type - not an a-list of block objects" x) ] ) ) )
102
103(define (##sys#check-generic-structure x . loc)
104  (unless (%record-structure? x)
105    (##sys#signal-hook
106     #:type-error (and (pair? loc) (car loc))
107     "bad argument type - not a structure" x) ) )
108
109;; Vector, Structure, Pair, and Symbol
110
111(define (##sys#check-generic-vector x . loc)
112  (unless (%generic-vector? x)
113    (##sys#signal-hook
114     #:type-error (and (pair? loc) (car loc))
115     "bad argument type - not a vector-like object" x) ) )
116
117(define (##sys#check-pointer x . loc)
118  (unless (%pointer? x)
119    (##sys#error-hook
120     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int)
121     (and (pair? loc) (car loc))
122     "bad argument type - not a pointer" x) ) )
123
124
125;;; Move arbitrary blocks of memory around:
126
127(define move-memory!
128  (let ((memmove1 (foreign-lambda void "C_memmove_o" c-pointer c-pointer int int int))
129	(memmove2 (foreign-lambda void "C_memmove_o" c-pointer scheme-pointer int int int))
130	(memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int))
131	(memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int))
132	(typerr (lambda (x)
133		  (##sys#error-hook
134		   (foreign-value "C_BAD_ARGUMENT_TYPE_ERROR" int)
135		   'move-memory! x)))
136	(slot1structs '(mmap
137			u8vector u16vector u32vector u64vector
138			s8vector s16vector s32vector s64vector
139			f32vector f64vector)) )
140    (lambda (from to #!optional n (foffset 0) (toffset 0))
141      ;
142      (define (nosizerr)
143	(##sys#error 'move-memory! "need number of bytes to move" from to))
144      ;
145      (define (sizerr . args)
146	(apply ##sys#error 'move-memory! "number of bytes to move too large" from to args))
147      ;
148      (define (checkn1 n nmax off)
149	(if (fx<= n (fx- nmax off))
150	    n
151	    (sizerr n nmax) ) )
152      ;
153      (define (checkn2 n nmax nmax2 off1 off2)
154	(if (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))
155	    n
156	    (sizerr n nmax nmax2) ) )
157      ;
158      (##sys#check-block from 'move-memory!)
159      (##sys#check-block to 'move-memory!)
160      (when (fx< foffset 0)
161	(##sys#error 'move-memory! "negative source offset" foffset))
162      (when (fx< toffset 0)
163	(##sys#error 'move-memory! "negative destination offset" toffset))
164      (let move ([from from] [to to] (n n))
165	(cond [(##sys#generic-structure? from)
166	       (if (memq (##sys#slot from 0) slot1structs)
167		   (move (##sys#slot from 1) to n)
168		   (typerr from) ) ]
169	      [(##sys#generic-structure? to)
170	       (if (memq (##sys#slot to 0) slot1structs)
171		   (move from (##sys#slot to 1) n)
172		   (typerr to) ) ]
173              ((string? from)
174               (let ((buf (##sys#slot from 0)))
175                 (move buf to (or n (fx- (##sys#size buf) 1)))))
176              ((string? to)
177               (let ((buf (##sys#slot to 0)))
178                 (move from buf (or n (fx- (##sys#size buf) 1)))))
179	      [(%generic-pointer? from)
180	       (cond [(%generic-pointer? to)
181		      (memmove1 to from (or n (nosizerr)) toffset foffset)]
182		     ((##sys#bytevector? to)
183		      (memmove3 to from (checkn1 (or n (nosizerr)) (##sys#size to) toffset) toffset foffset) )
184		     [else
185		      (typerr to)] ) ]
186	      [(##sys#bytevector? from)
187	       (let ([nfrom (##sys#size from)])
188		 (cond [(%generic-pointer? to)
189			(memmove2 to from (checkn1 (or n nfrom) nfrom foffset) toffset foffset)]
190		       ((##sys#bytevector? to)
191			(memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
192				  toffset foffset) )
193		       [else
194			(typerr to)] ) ) ]
195	      [else
196	       (typerr from)] ) ) ) ) )
197
198
199;;; Pointer operations:
200
201(define allocate (foreign-lambda c-pointer "C_malloc" int))
202(define free (foreign-lambda void "C_free" c-pointer))
203
204(define (pointer? x) (%pointer? x))
205
206(define (pointer-like? x) (%special-block? x))
207
208(define (address->pointer addr)
209  (##sys#check-integer addr 'address->pointer)
210  (##sys#address->pointer addr) )
211
212(define (pointer->address ptr)
213  (##sys#check-special ptr 'pointer->address)
214  (##sys#pointer->address ptr) )
215
216(define (object->pointer x)
217  (and (##core#inline "C_blockp" x)
218       ((foreign-lambda* nonnull-c-pointer ((scheme-object x)) "C_return((void *)x);") x) ) )
219
220(define (pointer->object ptr)
221  (##sys#check-pointer ptr 'pointer->object)
222  (##core#inline "C_pointer_to_object" ptr) )
223
224(define (pointer=? p1 p2)
225  (##sys#check-special p1 'pointer=?)
226  (##sys#check-special p2 'pointer=?)
227  (##core#inline "C_pointer_eqp" p1 p2) )
228
229(define pointer+
230  (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
231    "C_return((unsigned char *)ptr + off);") )
232
233(define align-to-word
234  (let ([align (foreign-lambda integer "C_align" integer)])
235    (lambda (x)
236      (cond [(integer? x)
237	     (align x)]
238	    [(%special-block? x)
239	     (##sys#address->pointer (align (##sys#pointer->address x))) ]
240	    [else
241	     (##sys#signal-hook
242	      #:type-error 'align-to-word
243	      "bad argument type - not a pointer or integer" x)] ) ) ) )
244
245
246;;; Tagged-pointers:
247
248(define (tag-pointer ptr tag)
249  (let ([tp (##sys#make-tagged-pointer tag)])
250    (if (%special-block? ptr)
251	(##core#inline "C_copy_pointer" ptr tp)
252	(##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
253    tp) )
254
255(define (tagged-pointer? x #!optional tag)
256  (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
257       (or (not tag)
258	   (equal? tag (##sys#slot x 1)) ) ) )
259
260(define (pointer-tag x)
261  (if (%special-block? x)
262      (and (##core#inline "C_taggedpointerp" x)
263	   (##sys#slot x 1) )
264      (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
265
266
267
268
269;;; SRFI-4 number-vector:
270
271(define (pointer-u8-set! p n) (##core#inline "C_u_i_pointer_u8_set" p n))
272(define (pointer-s8-set! p n) (##core#inline "C_u_i_pointer_s8_set" p n))
273(define (pointer-u16-set! p n) (##core#inline "C_u_i_pointer_u16_set" p n))
274(define (pointer-s16-set! p n) (##core#inline "C_u_i_pointer_s16_set" p n))
275(define (pointer-u32-set! p n) (##core#inline "C_u_i_pointer_u32_set" p n))
276(define (pointer-s32-set! p n) (##core#inline "C_u_i_pointer_s32_set" p n))
277(define (pointer-u64-set! p n) (##core#inline "C_u_i_pointer_u64_set" p n))
278(define (pointer-s64-set! p n) (##core#inline "C_u_i_pointer_s64_set" p n))
279(define (pointer-f32-set! p n) (##core#inline "C_u_i_pointer_f32_set" p n))
280(define (pointer-f64-set! p n) (##core#inline "C_u_i_pointer_f64_set" p n))
281
282(define pointer-u8-ref
283  (getter-with-setter
284   (lambda (p) (##core#inline "C_u_i_pointer_u8_ref" p))
285   pointer-u8-set!
286   "(chicken.memory#pointer-u8-ref p)"))
287
288(define pointer-s8-ref
289  (getter-with-setter
290   (lambda (p) (##core#inline "C_u_i_pointer_s8_ref" p))
291   pointer-s8-set!
292   "(chicken.memory#pointer-s8-ref p)"))
293
294(define pointer-u16-ref
295  (getter-with-setter
296   (lambda (p) (##core#inline "C_u_i_pointer_u16_ref" p))
297   pointer-u16-set!
298   "(chicken.memory#pointer-u16-ref p)"))
299
300(define pointer-s16-ref
301  (getter-with-setter
302   (lambda (p) (##core#inline "C_u_i_pointer_s16_ref" p))
303   pointer-s16-set!
304   "(chicken.memory#pointer-s16-ref p)"))
305
306(define pointer-u32-ref
307  (getter-with-setter
308   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_u32_ref" 6) p)) ;XXX hardcoded size
309   pointer-u32-set!
310   "(chicken.memory#pointer-u32-ref p)"))
311
312(define pointer-s32-ref
313  (getter-with-setter
314   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_s32_ref" 6) p)) ;XXX hardcoded size
315   pointer-s32-set!
316   "(chicken.memory#pointer-s32-ref p)"))
317
318(define pointer-u64-ref
319  (getter-with-setter
320   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_u64_ref" 7) p)) ;XXX hardcoded size
321   pointer-u64-set!
322   "(chicken.memory#pointer-u64-ref p)"))
323
324(define pointer-s64-ref
325  (getter-with-setter
326   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_s64_ref" 7) p)) ;XXX hardcoded size
327   pointer-s64-set!
328   "(chicken.memory#pointer-s64-ref p)"))
329
330(define pointer-f32-ref
331  (getter-with-setter
332   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_f32_ref" 4) p)) ;XXX hardcoded size
333   pointer-f32-set!
334   "(chicken.memory#pointer-f32-ref p)"))
335
336(define pointer-f64-ref
337  (getter-with-setter
338   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_f64_ref" 4) p)) ;XXX hardcoded size
339   pointer-f64-set!
340   "(chicken.memory#pointer-f64-ref p)"))
341
342
343;;; pointer vectors
344
345(define make-pointer-vector
346  (let ((unset (list 'unset)))
347    (lambda (n #!optional (init unset))
348      (##sys#check-fixnum n 'make-pointer-vector)
349      (let* ((words->bytes (foreign-lambda int "C_wordstobytes" int))
350	     (size (words->bytes n))
351	     (buf (##sys#make-bytevector size)))
352	(unless (eq? init unset)
353	  (when init
354	    (##sys#check-pointer init 'make-pointer-vector))
355	  (do ((i 0 (fx+ i 1)))
356	      ((fx>= i n))
357	    (pv-buf-set! buf i init)))
358	(##sys#make-structure 'pointer-vector n buf)))))
359
360(define (pointer-vector? x)
361  (##sys#structure? x 'pointer-vector))
362
363(define (pointer-vector . ptrs)
364  (let* ((n (length ptrs))
365	 (pv (make-pointer-vector n))
366	 (buf (##sys#slot pv 2)))	; buf
367    (do ((ptrs ptrs (cdr ptrs))
368	 (i 0 (fx+ i 1)))
369	((null? ptrs) pv)
370      (let ((ptr (car ptrs)))
371	(##sys#check-pointer ptr 'pointer-vector)
372	(pv-buf-set! buf i ptr)))))
373
374(define (pointer-vector-fill! pv ptr)
375  (##sys#check-structure pv 'pointer-vector 'pointer-vector-fill!)
376  (when ptr (##sys#check-pointer ptr 'pointer-vector-fill!))
377  (let ((buf (##sys#slot pv 2))		; buf
378	(n (##sys#slot pv 1)))		; n
379    (do ((i 0 (fx+ i 1)))
380	((fx>= i n))
381      (pv-buf-set! buf i ptr))))
382
383(define pv-buf-ref
384  (foreign-lambda* c-pointer ((scheme-object buf) (unsigned-int i))
385    "C_return(*((void **)C_data_pointer(buf) + i));"))
386
387(define pv-buf-set!
388  (foreign-lambda* void ((scheme-object buf) (unsigned-int i) (c-pointer ptr))
389    "*((void **)C_data_pointer(buf) + i) = ptr;"))
390
391(define (pointer-vector-set! pv i ptr)
392  (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
393  (##sys#check-range i 0 (##sys#slot pv 1)) ; len
394  (when ptr (##sys#check-pointer ptr 'pointer-vector-set!))
395  (pv-buf-set! (##sys#slot pv 2) i ptr))
396
397(define pointer-vector-ref
398  (getter-with-setter
399   (lambda (pv i)
400     (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
401     (##sys#check-range i 0 (##sys#slot pv 1)) ; len
402     (pv-buf-ref (##sys#slot pv 2) i))	; buf
403   pointer-vector-set!
404   "(chicken.memory#pointer-vector-ref pv i)"))
405
406(define (pointer-vector-length pv)
407  (##sys#check-structure pv 'pointer-vector 'pointer-vector-length)
408  (##sys#slot pv 1))
409
410) ; chicken.memory
411
412
413(module chicken.memory.representation
414  (block-ref block-set! extend-procedure extended-procedure?
415   make-record-instance mutate-procedure! number-of-bytes
416   number-of-slots object-become! object-copy procedure-data
417   record->vector record-instance-length record-instance-slot
418   record-instance-slot-set! record-instance-type record-instance?
419   set-procedure-data! vector-like? number-vector-data)
420
421(import scheme chicken.base chicken.fixnum chicken.foreign)
422
423
424;;; Copy arbitrary object:
425
426(define (object-copy x)
427  (let copy ((x x))
428    (cond ((not (##core#inline "C_blockp" x)) x)
429	  ((symbol? x) (##sys#string->symbol (##sys#slot x 1)))
430	  (else
431	   (let* ((n (##sys#size x))
432		  (words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n))
433		  (y (##core#inline "C_copy_block" x (##sys#make-vector words))))
434	     (unless (##core#inline "C_byteblockp" x)
435	       (do ((i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)))
436		   ((fx>= i n))
437		 (##sys#setslot y i (copy (##sys#slot y i)))))
438	     y)))))
439
440
441;;; Procedures extended with data:
442
443; Unique id for extended-procedures
444(define xproc-tag (vector 'extended))
445
446(define (extend-procedure proc data)
447  (##sys#check-closure proc 'extend-procedure)
448  (##sys#decorate-lambda
449   proc
450   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))) 
451   (lambda (x i) (##sys#setslot x i (cons xproc-tag data)) x) ) )
452
453(define-inline (%procedure-data proc)
454  (##sys#lambda-decoration proc (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))) )
455
456(define (extended-procedure? x)
457  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
458       (%procedure-data x)
459       #t) )
460
461(define (procedure-data x)
462  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
463       (and-let* ([d (%procedure-data x)])
464	 (##sys#slot d 1) ) ) )
465
466(define (set-procedure-data! proc x)
467  (unless (eq? proc (extend-procedure proc x))
468    (##sys#signal-hook #:type-error 'set-procedure-data!
469     "bad argument type - not an extended procedure" proc)))
470
471;;; Accessors for arbitrary vector-like block objects:
472
473(define (vector-like? x) (%generic-vector? x))
474
475(define block-set! ##sys#block-set!)
476
477(define block-ref 
478  (getter-with-setter
479   ##sys#block-ref ##sys#block-set! "(chicken.memory.representation#block-ref x i)"))
480
481(define (number-of-slots x)
482  (##sys#check-generic-vector x 'number-of-slots)
483  (##sys#size x) )
484
485(define (number-of-bytes x)
486  (cond ((not (##core#inline "C_blockp" x))
487	 (##sys#signal-hook
488	  #:type-error 'number-of-bytes
489	  "cannot compute number of bytes of immediate object" x) )
490        ((##core#inline "C_stringp" x)
491         (fx- (##sys#size (##sys#slot x 0)) 1))
492        ((##core#inline "C_symbolp" x)
493         (fx- (##sys#size (##sys#slot x 1)) 1))
494	((##core#inline "C_byteblockp" x)
495	 (##sys#size x))
496	(else
497	 (##core#inline "C_bytes" (##sys#size x))) ) )
498
499
500;;; Record objects:
501
502;; Record layout:
503;
504; 0	Tag (symbol)
505; 1..N	Slot (object)
506
507(define (make-record-instance type . args)
508  (##sys#check-symbol type 'make-record-instance)
509  (apply ##sys#make-structure type args) )
510
511(define (record-instance? x #!optional type)
512  (and (%record-structure? x)
513       (or (not type)
514	   (eq? type (##sys#slot x 0)))) )
515
516(define (record-instance-type x)
517  (##sys#check-generic-structure x 'record-instance-type)
518  (##sys#slot x 0) )
519
520(define (record-instance-length x)
521  (##sys#check-generic-structure x 'record-instance-length)
522  (fx- (##sys#size x) 1) )
523
524(define (record-instance-slot-set! x i y)
525  (##sys#check-generic-structure x 'record-instance-slot-set!)
526  (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot-set!)
527  (##sys#setslot x (fx+ i 1) y) )
528
529(define record-instance-slot
530  (getter-with-setter
531   (lambda (x i)
532     (##sys#check-generic-structure x 'record-instance-slot)
533     (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot)
534     (##sys#slot x (fx+ i 1)) )
535   record-instance-slot-set!
536   "(chicken.memory.representation#record-instance-slot x i)"))
537
538(define (record->vector x)
539  (##sys#check-generic-structure x 'record->vector)
540  (let* ([n (##sys#size x)]
541	 [v (##sys#make-vector n)] )
542    (do ([i 0 (fx+ i 1)])
543	 [(fx>= i n) v]
544      (##sys#setslot v i (##sys#slot x i)) ) ) )
545
546
547;;; `become':
548
549(define (object-become! alst)
550  (##sys#check-become-alist alst 'object-become!)
551  (##sys#become! alst) )
552
553(define (mutate-procedure! old proc)
554  (##sys#check-closure old 'mutate-procedure!)
555  (##sys#check-closure proc 'mutate-procedure!)
556  (let* ([n (##sys#size old)]
557         [words (##core#inline "C_words" n)]
558         [new (##core#inline "C_copy_block" old (##sys#make-vector words))] )
559    (##sys#become! (list (cons old (proc new))))
560    new ) )
561
562
563;;; access backing store of numeric vector
564
565(define (number-vector-data v)
566  (cond ((and (##core#inline "C_blockp" v)
567              (##core#inline "C_bytevectorp" v))
568          v)
569        ((##sys#srfi-4-vector? v) (##sys#slot v 1))
570          (else (##sys#signal-hook #:type-error 'number-vector-data
571                  "bad argument type - not a numeric vector" v))))
572
573
574) ; chicken.memory.representation
575
576
577(module chicken.locative
578  (locative? make-locative make-weak-locative
579   locative-ref locative-set! locative->object locative-index)
580
581(import scheme chicken.base)
582
583;;; locatives:
584
585;; Locative layout:
586;
587; 0	Object-address + Byte-offset (address)
588; 1	Byte-offset (fixnum)
589; 2	Type (fixnum)
590;	0	vector or pair		(C_SLOT_LOCATIVE)
591;	1	string			(C_CHAR_LOCATIVE)
592;	2	u8vector or bytevector        (C_U8_LOCATIVE)
593;	3	s8vector	        (C_S8_LOCATIVE)
594;	4	u16vector		(C_U16_LOCATIVE)
595;	5	s16vector		(C_S16_LOCATIVE)
596;	6	u32vector		(C_U32_LOCATIVE)
597;	7	s32vector		(C_S32_LOCATIVE)
598;	8	u64vector		(C_U32_LOCATIVE)
599;	9	s64vector		(C_S32_LOCATIVE)
600;	10	f32vector		(C_F32_LOCATIVE)
601;	11	f64vector		(C_F64_LOCATIVE)
602; 3	Object or #f, if weak (C_word)
603
604(define (make-locative obj . index)
605  (##sys#make-locative obj (optional index 0) #f 'make-locative))
606
607(define (make-weak-locative obj . index)
608  (##sys#make-locative obj (optional index 0) #t 'make-weak-locative))
609
610(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
611
612(define locative-ref
613  (getter-with-setter
614   (lambda (loc)
615     (##core#inline_allocate ("C_a_i_locative_ref" 6) loc))
616   locative-set!
617   "(chicken.locative#locative-ref loc)"))
618
619(define (locative->object x)
620  (##core#inline "C_i_locative_to_object" x))
621
622(define (locative-index x)
623  (##core#inline "C_i_locative_index" x))
624
625(define (locative? x)
626  (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x))))