~ chicken-core (chicken-5) /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])
165	(cond [(##sys#generic-structure? from)
166	       (if (memq (##sys#slot from 0) slot1structs)
167		   (move (##sys#slot from 1) to)
168		   (typerr from) ) ]
169	      [(##sys#generic-structure? to)
170	       (if (memq (##sys#slot to 0) slot1structs)
171		   (move from (##sys#slot to 1))
172		   (typerr to) ) ]
173	      [(%generic-pointer? from)
174	       (cond [(%generic-pointer? to)
175		      (memmove1 to from (or n (nosizerr)) toffset foffset)]
176		     [(or (##sys#bytevector? to) (string? to))
177		      (memmove3 to from (checkn1 (or n (nosizerr)) (##sys#size to) toffset) toffset foffset) ]
178		     [else
179		      (typerr to)] ) ]
180	      [(or (##sys#bytevector? from) (string? from))
181	       (let ([nfrom (##sys#size from)])
182		 (cond [(%generic-pointer? to)
183			(memmove2 to from (checkn1 (or n nfrom) nfrom foffset) toffset foffset)]
184		       [(or (##sys#bytevector? to) (string? to))
185			(memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
186				  toffset foffset) ]
187		       [else
188			(typerr to)] ) ) ]
189	      [else
190	       (typerr from)] ) ) ) ) )
191
192
193;;; Pointer operations:
194
195(define allocate (foreign-lambda c-pointer "C_malloc" int))
196(define free (foreign-lambda void "C_free" c-pointer))
197
198(define (pointer? x) (%pointer? x))
199
200(define (pointer-like? x) (%special-block? x))
201
202(define (address->pointer addr)
203  (##sys#check-integer addr 'address->pointer)
204  (##sys#address->pointer addr) )
205
206(define (pointer->address ptr)
207  (##sys#check-special ptr 'pointer->address)
208  (##sys#pointer->address ptr) )
209
210(define (object->pointer x)
211  (and (##core#inline "C_blockp" x)
212       ((foreign-lambda* nonnull-c-pointer ((scheme-object x)) "C_return((void *)x);") x) ) )
213
214(define (pointer->object ptr)
215  (##sys#check-pointer ptr 'pointer->object)
216  (##core#inline "C_pointer_to_object" ptr) )
217
218(define (pointer=? p1 p2)
219  (##sys#check-special p1 'pointer=?)
220  (##sys#check-special p2 'pointer=?)
221  (##core#inline "C_pointer_eqp" p1 p2) )
222
223(define pointer+
224  (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
225    "C_return((unsigned char *)ptr + off);") )
226
227(define align-to-word
228  (let ([align (foreign-lambda integer "C_align" integer)])
229    (lambda (x)
230      (cond [(integer? x)
231	     (align x)]
232	    [(%special-block? x)
233	     (##sys#address->pointer (align (##sys#pointer->address x))) ]
234	    [else
235	     (##sys#signal-hook
236	      #:type-error 'align-to-word
237	      "bad argument type - not a pointer or integer" x)] ) ) ) )
238
239
240;;; Tagged-pointers:
241
242(define (tag-pointer ptr tag)
243  (let ([tp (##sys#make-tagged-pointer tag)])
244    (if (%special-block? ptr)
245	(##core#inline "C_copy_pointer" ptr tp)
246	(##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
247    tp) )
248
249(define (tagged-pointer? x #!optional tag)
250  (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
251       (or (not tag)
252	   (equal? tag (##sys#slot x 1)) ) ) )
253
254(define (pointer-tag x)
255  (if (%special-block? x)
256      (and (##core#inline "C_taggedpointerp" x)
257	   (##sys#slot x 1) )
258      (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
259
260
261
262
263;;; SRFI-4 number-vector:
264
265(define (pointer-u8-set! p n) (##core#inline "C_u_i_pointer_u8_set" p n))
266(define (pointer-s8-set! p n) (##core#inline "C_u_i_pointer_s8_set" p n))
267(define (pointer-u16-set! p n) (##core#inline "C_u_i_pointer_u16_set" p n))
268(define (pointer-s16-set! p n) (##core#inline "C_u_i_pointer_s16_set" p n))
269(define (pointer-u32-set! p n) (##core#inline "C_u_i_pointer_u32_set" p n))
270(define (pointer-s32-set! p n) (##core#inline "C_u_i_pointer_s32_set" p n))
271(define (pointer-u64-set! p n) (##core#inline "C_u_i_pointer_u64_set" p n))
272(define (pointer-s64-set! p n) (##core#inline "C_u_i_pointer_s64_set" p n))
273(define (pointer-f32-set! p n) (##core#inline "C_u_i_pointer_f32_set" p n))
274(define (pointer-f64-set! p n) (##core#inline "C_u_i_pointer_f64_set" p n))
275
276(define pointer-u8-ref
277  (getter-with-setter
278   (lambda (p) (##core#inline "C_u_i_pointer_u8_ref" p))
279   pointer-u8-set!
280   "(chicken.memory#pointer-u8-ref p)"))
281
282(define pointer-s8-ref
283  (getter-with-setter
284   (lambda (p) (##core#inline "C_u_i_pointer_s8_ref" p))
285   pointer-s8-set!
286   "(chicken.memory#pointer-s8-ref p)"))
287
288(define pointer-u16-ref
289  (getter-with-setter
290   (lambda (p) (##core#inline "C_u_i_pointer_u16_ref" p))
291   pointer-u16-set!
292   "(chicken.memory#pointer-u16-ref p)"))
293
294(define pointer-s16-ref
295  (getter-with-setter
296   (lambda (p) (##core#inline "C_u_i_pointer_s16_ref" p))
297   pointer-s16-set!
298   "(chicken.memory#pointer-s16-ref p)"))
299
300(define pointer-u32-ref
301  (getter-with-setter
302   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_u32_ref" 6) p)) ;XXX hardcoded size
303   pointer-u32-set!
304   "(chicken.memory#pointer-u32-ref p)"))
305
306(define pointer-s32-ref
307  (getter-with-setter
308   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_s32_ref" 6) p)) ;XXX hardcoded size
309   pointer-s32-set!
310   "(chicken.memory#pointer-s32-ref p)"))
311
312(define pointer-u64-ref
313  (getter-with-setter
314   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_u64_ref" 7) p)) ;XXX hardcoded size
315   pointer-u64-set!
316   "(chicken.memory#pointer-u64-ref p)"))
317
318(define pointer-s64-ref
319  (getter-with-setter
320   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_s64_ref" 7) p)) ;XXX hardcoded size
321   pointer-s64-set!
322   "(chicken.memory#pointer-s64-ref p)"))
323
324(define pointer-f32-ref
325  (getter-with-setter
326   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_f32_ref" 4) p)) ;XXX hardcoded size
327   pointer-f32-set!
328   "(chicken.memory#pointer-f32-ref p)"))
329
330(define pointer-f64-ref
331  (getter-with-setter
332   (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_f64_ref" 4) p)) ;XXX hardcoded size
333   pointer-f64-set!
334   "(chicken.memory#pointer-f64-ref p)"))
335
336
337;;; pointer vectors
338
339(define make-pointer-vector
340  (let ((unset (list 'unset)))
341    (lambda (n #!optional (init unset))
342      (##sys#check-fixnum n 'make-pointer-vector)
343      (let* ((words->bytes (foreign-lambda int "C_wordstobytes" int))
344	     (size (words->bytes n))
345	     (buf (##sys#make-blob size)))
346	(unless (eq? init unset)
347	  (when init
348	    (##sys#check-pointer init 'make-pointer-vector))
349	  (do ((i 0 (fx+ i 1)))
350	      ((fx>= i n))
351	    (pv-buf-set! buf i init)))
352	(##sys#make-structure 'pointer-vector n buf)))))
353
354(define (pointer-vector? x)
355  (##sys#structure? x 'pointer-vector))
356
357(define (pointer-vector . ptrs)
358  (let* ((n (length ptrs))
359	 (pv (make-pointer-vector n))
360	 (buf (##sys#slot pv 2)))	; buf
361    (do ((ptrs ptrs (cdr ptrs))
362	 (i 0 (fx+ i 1)))
363	((null? ptrs) pv)
364      (let ((ptr (car ptrs)))
365	(##sys#check-pointer ptr 'pointer-vector)
366	(pv-buf-set! buf i ptr)))))
367
368(define (pointer-vector-fill! pv ptr)
369  (##sys#check-structure pv 'pointer-vector 'pointer-vector-fill!)
370  (when ptr (##sys#check-pointer ptr 'pointer-vector-fill!))
371  (let ((buf (##sys#slot pv 2))		; buf
372	(n (##sys#slot pv 1)))		; n
373    (do ((i 0 (fx+ i 1)))
374	((fx>= i n))
375      (pv-buf-set! buf i ptr))))
376
377(define pv-buf-ref
378  (foreign-lambda* c-pointer ((scheme-object buf) (unsigned-int i))
379    "C_return(*((void **)C_data_pointer(buf) + i));"))
380
381(define pv-buf-set!
382  (foreign-lambda* void ((scheme-object buf) (unsigned-int i) (c-pointer ptr))
383    "*((void **)C_data_pointer(buf) + i) = ptr;"))
384
385(define (pointer-vector-set! pv i ptr)
386  (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
387  (##sys#check-range i 0 (##sys#slot pv 1)) ; len
388  (when ptr (##sys#check-pointer ptr 'pointer-vector-set!))
389  (pv-buf-set! (##sys#slot pv 2) i ptr))
390
391(define pointer-vector-ref
392  (getter-with-setter
393   (lambda (pv i)
394     (##sys#check-structure pv 'pointer-vector 'pointer-vector-ref)
395     (##sys#check-range i 0 (##sys#slot pv 1)) ; len
396     (pv-buf-ref (##sys#slot pv 2) i))	; buf
397   pointer-vector-set!
398   "(chicken.memory#pointer-vector-ref pv i)"))
399
400(define (pointer-vector-length pv)
401  (##sys#check-structure pv 'pointer-vector 'pointer-vector-length)
402  (##sys#slot pv 1))
403
404) ; chicken.memory
405
406
407(module chicken.memory.representation
408  (block-ref block-set! extend-procedure extended-procedure?
409   make-record-instance mutate-procedure! number-of-bytes
410   number-of-slots object-become! object-copy procedure-data
411   record->vector record-instance-length record-instance-slot
412   record-instance-slot-set! record-instance-type record-instance?
413   set-procedure-data! vector-like?)
414
415(import scheme chicken.base chicken.fixnum chicken.foreign)
416
417
418;;; Copy arbitrary object:
419
420(define (object-copy x)
421  (let copy ((x x))
422    (cond ((not (##core#inline "C_blockp" x)) x)
423	  ((symbol? x) (##sys#intern-symbol (##sys#slot x 1)))
424	  (else
425	   (let* ((n (##sys#size x))
426		  (words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n))
427		  (y (##core#inline "C_copy_block" x (##sys#make-vector words))))
428	     (unless (##core#inline "C_byteblockp" x)
429	       (do ((i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)))
430		   ((fx>= i n))
431		 (##sys#setslot y i (copy (##sys#slot y i)))))
432	     y)))))
433
434
435;;; Procedures extended with data:
436
437; Unique id for extended-procedures
438(define xproc-tag (vector 'extended))
439
440(define (extend-procedure proc data)
441  (##sys#check-closure proc 'extend-procedure)
442  (##sys#decorate-lambda
443   proc
444   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))) 
445   (lambda (x i) (##sys#setslot x i (cons xproc-tag data)) x) ) )
446
447(define-inline (%procedure-data proc)
448  (##sys#lambda-decoration proc (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))) )
449
450(define (extended-procedure? x)
451  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
452       (%procedure-data x)
453       #t) )
454
455(define (procedure-data x)
456  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
457       (and-let* ([d (%procedure-data x)])
458	 (##sys#slot d 1) ) ) )
459
460(define (set-procedure-data! proc x)
461  (unless (eq? proc (extend-procedure proc x))
462    (##sys#signal-hook #:type-error 'set-procedure-data!
463     "bad argument type - not an extended procedure" proc)))
464
465;;; Accessors for arbitrary vector-like block objects:
466
467(define (vector-like? x) (%generic-vector? x))
468
469(define block-set! ##sys#block-set!)
470
471(define block-ref 
472  (getter-with-setter
473   ##sys#block-ref ##sys#block-set! "(chicken.memory.representation#block-ref x i)"))
474
475(define (number-of-slots x)
476  (##sys#check-generic-vector x 'number-of-slots)
477  (##sys#size x) )
478
479(define (number-of-bytes x)
480  (cond [(not (##core#inline "C_blockp" x))
481	 (##sys#signal-hook
482	  #:type-error 'number-of-bytes
483	  "cannot compute number of bytes of immediate object" x) ]
484	[(##core#inline "C_byteblockp" x)
485	 (##sys#size x)]
486	[else
487	 (##core#inline "C_bytes" (##sys#size x))] ) )
488
489
490;;; Record objects:
491
492;; Record layout:
493;
494; 0	Tag (symbol)
495; 1..N	Slot (object)
496
497(define (make-record-instance type . args)
498  (##sys#check-symbol type 'make-record-instance)
499  (apply ##sys#make-structure type args) )
500
501(define (record-instance? x #!optional type)
502  (and (%record-structure? x)
503       (or (not type)
504	   (eq? type (##sys#slot x 0)))) )
505
506(define (record-instance-type x)
507  (##sys#check-generic-structure x 'record-instance-type)
508  (##sys#slot x 0) )
509
510(define (record-instance-length x)
511  (##sys#check-generic-structure x 'record-instance-length)
512  (fx- (##sys#size x) 1) )
513
514(define (record-instance-slot-set! x i y)
515  (##sys#check-generic-structure x 'record-instance-slot-set!)
516  (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot-set!)
517  (##sys#setslot x (fx+ i 1) y) )
518
519(define record-instance-slot
520  (getter-with-setter
521   (lambda (x i)
522     (##sys#check-generic-structure x 'record-instance-slot)
523     (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot)
524     (##sys#slot x (fx+ i 1)) )
525   record-instance-slot-set!
526   "(chicken.memory.representation#record-instance-slot x i)"))
527
528(define (record->vector x)
529  (##sys#check-generic-structure x 'record->vector)
530  (let* ([n (##sys#size x)]
531	 [v (##sys#make-vector n)] )
532    (do ([i 0 (fx+ i 1)])
533	 [(fx>= i n) v]
534      (##sys#setslot v i (##sys#slot x i)) ) ) )
535
536
537;;; `become':
538
539(define (object-become! alst)
540  (##sys#check-become-alist alst 'object-become!)
541  (##sys#become! alst) )
542
543(define (mutate-procedure! old proc)
544  (##sys#check-closure old 'mutate-procedure!)
545  (##sys#check-closure proc 'mutate-procedure!)
546  (let* ([n (##sys#size old)]
547	 [words (##core#inline "C_words" n)]
548	 [new (##core#inline "C_copy_block" old (##sys#make-vector words))] )
549    (##sys#become! (list (cons old (proc new))))
550    new ) )
551
552) ; chicken.memory.representation
553
554
555(module chicken.locative
556  (locative? make-locative make-weak-locative
557   locative-ref locative-set! locative->object locative-index)
558
559(import scheme chicken.base)
560
561;;; locatives:
562
563;; Locative layout:
564;
565; 0	Object-address + Byte-offset (address)
566; 1	Byte-offset (fixnum)
567; 2	Type (fixnum)
568;	0	vector or pair		(C_SLOT_LOCATIVE)
569;	1	string			(C_CHAR_LOCATIVE)
570;	2	u8vector or blob        (C_U8_LOCATIVE)
571;	3	s8vector	        (C_S8_LOCATIVE)
572;	4	u16vector		(C_U16_LOCATIVE)
573;	5	s16vector		(C_S16_LOCATIVE)
574;	6	u32vector		(C_U32_LOCATIVE)
575;	7	s32vector		(C_S32_LOCATIVE)
576;	8	u64vector		(C_U32_LOCATIVE)
577;	9	s64vector		(C_S32_LOCATIVE)
578;	10	f32vector		(C_F32_LOCATIVE)
579;	11	f64vector		(C_F64_LOCATIVE)
580; 3	Object or #f, if weak (C_word)
581
582(define (make-locative obj . index)
583  (##sys#make-locative obj (optional index 0) #f 'make-locative))
584
585(define (make-weak-locative obj . index)
586  (##sys#make-locative obj (optional index 0) #t 'make-weak-locative))
587
588(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
589
590(define locative-ref
591  (getter-with-setter
592   (lambda (loc)
593     (##core#inline_allocate ("C_a_i_locative_ref" 6) loc))
594   locative-set!
595   "(chicken.locative#locative-ref loc)"))
596
597(define (locative->object x)
598  (##core#inline "C_i_locative_to_object" x))
599
600(define (locative-index x)
601  (##core#inline "C_i_locative_index" x))
602
603(define (locative? x)
604  (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x))))