source: project/chicken/trunk/chicken-primitive-object-inlines.scm @ 13525

Last change on this file since 13525 was 13525, checked in by Kon Lovett, 11 years ago

Addded maybe-immediate set! routines. Added better assert comments.

File size: 21.3 KB
Line 
1;;;; chicken-primitive-object-nlines.scm
2;;;; Kon Lovett, Jan '09
3;;;; (Was chicken-sys-macros.scm)
4
5; Usage
6;
7; (include "chicken-primitive-object-inlines")
8
9;; Notes
10;
11; Provides inlines & macros for primitive procedures. Use of these procedures
12; by non-core & non-core-extensions is highly suspect. Many of these routines
13; are unsafe.
14;
15; In fact, any use is suspect ;-)
16;
17; A ##core#Inline is just what it says - literal inclusion in the compiled C
18; code of the C macro/function and the arguments taken literally, i.e. as the
19; C_word value.
20;
21; These are much faster than a lambda, but very dangerous since the arguments and
22; the return value are not converted. The C code must perform any such conversions.
23;
24; ##core#inline cannot be used with a runtime C function which is coded in the
25;CPS style.
26;
27; A ##core#primitive creates a lambda for a C function which is coded in the
28; CPS style.
29;
30; These have a stereotypical argument list which begins the 3 arguments C_word
31; c, C_word closure, and C_word k. Any actual arguments follow.
32;
33; c - number of arguments, not including 'c', but including 'closure' & 'k'
34; closure - caller
35; k - continuation
36
37
38;;; Type Predicates
39
40;; Argument is a 'C_word'
41
42
43;; Immediate
44
45(define-inline (%immediate? x) (##core#inline "C_immp" x))
46
47
48;; Fixnum
49
50(define-inline (%fixnum-type? x) (##core#inline "C_fixnump" x))
51
52(define-inline (%fixnum? x) (and (%immediate? x) (%fixnum-type? x)))
53
54
55;; Character
56
57(define-inline (%char-type? x) (##core#inline "C_charp" x))
58
59(define-inline (%char? x) (and (%immediate? x) (%char-type? x)))
60
61
62;; Boolean
63
64(define-inline (%boolean-type? x) (##core#inline "C_booleanp" x))
65
66(define-inline (%boolean? x) (and (%immediate? x) (%boolean-type? x)))
67
68(define-inline (%true-value? x) (and (%boolean? x) (##core#inline "C_and" x #t)))
69
70(define-inline (%false-value? x) (not (%true-value? x)))
71
72
73;; EOF
74
75(define-inline (%eof-object-type? x) (##core#inline "C_eofp" x))
76
77(define-inline (%eof-object? x) (and (%immediate? x) (%eof-object-type? x)))
78
79
80;; Null (the end-of-list value)
81
82(define-inline (%eol-object-type? x) (##core#inline "C_i_nullp" x))
83
84(define-inline (%eol-object? x) (and (%immediate? x) (%eol-object-type? x)))
85
86
87;; Undefined (void)
88
89(define-inline (%undefined-type? x) (##core#inline "C_undefinedp" x))
90
91(define-inline (%undefined-value? x) (and (%immediate? x) (%undefined-type? x)))
92
93(define-inline (%undefined-value) (##core#undefined))
94
95
96;; Unbound (the unbound value, not 'is a symbol unbound')
97
98(define-inline (%unbound-type? x) (##core#inline "C_unboundvaluep" x))
99
100(define-inline (%unbound-value? x) (and (%immediate? x) (%unbound-type? x)))
101
102
103;; Block (anything not immediate)
104
105(define-inline (%block? x) (##core#inline "C_blockp" x))
106
107
108;; Special
109
110(define-inline (%special? x) (##core#inline "C_specialp" x))
111
112
113;; Wordblock (special block)
114
115(define-inline (%wordblock? x) (and (%block? x) (%special? x)))
116
117
118;; Byteblock
119
120(define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))
121
122(define-inline (%byteblock? x) (and (%block? x) (%byteblock-type? x)))
123
124
125;; Vector
126
127(define-inline (%vector-type? x) (##core#inline "C_vectorp" x))
128
129(define-inline (%vector? x) (and (%block? x) (%vector-type? x)))
130
131
132;; Bytevector (isa vector so be careful; refers to how allocated, not what stored)
133
134(define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))
135
136(define-inline (%bytevector? x) (and (%block? x) (%bytevector-type? x)))
137
138
139;; Pair
140
141(define-inline (%pair-type? x) (##core#inline "C_pairp" x))
142
143(define-inline (%pair? x) (and (%block? x) (%pair-type? x)))
144
145
146;; Bucket
147
148; A bucket is used by the runtime for the symbol-table. The bucket type is not
149; "seen" by Scheme code.
150
151
152;; Structure
153
154(define-inline (%structure-type? x) (##core#inline "C_structurep" x))
155
156(define-inline (%structure? x) (and (%block? x) (%structure-type? x)))
157
158
159;; Symbol
160
161(define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
162
163(define-inline (%symbol? x) (and (%block? x) (%symbol-type? x)))
164
165
166;; String
167
168(define-inline (%string-type? x) (##core#inline "C_stringp" x))
169
170(define-inline (%string? x) (and (%block? x) (%string-type? x)))
171
172
173;; Flonum
174
175(define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
176
177(define-inline (%flonum? x) (and (%block? x) (%flonum-type? x)))
178
179
180;; Lambda-info
181
182(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
183
184(define-inline (%lambda-info? x) (and (%block? x) (%lambda-info-type? x)))
185
186
187;; Closure
188
189(define-inline (%closure-type? x) (##core#inline "C_closurep" x))
190
191(define-inline (%closure? x) (and (%block? x) (%closure-type? x)))
192
193
194;; Port
195
196(define-inline (%port-type? x) (##core#inline "C_portp" x))
197
198(define-inline (%port? x) (and (%block? x) (%port-type? x)))
199
200
201;; Simple-pointer
202
203(define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
204
205(define-inline (%simple-pointer? x) (and (%block? x) (%simple-pointer-type? x)))
206
207
208;; Tagged-Pointer
209
210(define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
211
212(define-inline (%tagged-pointer? x) (and (%block? x) (%tagged-pointer-type? x)))
213
214
215;; Swig-Pointer
216
217(define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
218
219(define-inline (%swig-pointer? x) (and (%block? x) (%swig-pointer-type? x)))
220
221
222;; Any-pointer
223
224(define-inline (%any-pointer-type? x) (##core#inline "C_anypointerp" x))
225
226(define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))
227
228
229;; Locative
230
231(define-inline (%locative-type? x) (##core#inline "C_locativep" x))
232
233(define-inline (%locative? x) (and (%block? x) (%locative-type? x)))
234
235
236;; Forwarded (block object moved to new address, forwarding pointer)
237
238(define-inline (%forwarded? x) (##core#inline "C_forwardedp" x))
239
240
241
242;;; Values
243
244
245;;; Operations
246
247(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
248
249(define-inline (%peek-signed-integer b i) ((##core#primitive "C_peek_signed_integer") b i))
250
251(define-inline (%peek-unsigned-integer b i) ((##core#primitive "C_peek_unsigned_integer") b i))
252
253(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
254
255
256;; Fixnum
257
258(define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
259(define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
260(define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
261(define-inline (%fx= x y) (%eq? x y))
262(define-inline (%fx> x y) (##core#inline "C_fixnum_greaterp" x y))
263(define-inline (%fx< x y) (##core#inline "C_fixnum_lessp" x y))
264(define-inline (%fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
265(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
266(define-inline (%fxmin x y) (##core#inline "C_i_fixnum_min" x y))
267(define-inline (%fxmax x y) (##core#inline "C_i_fixnum_max" x y))
268(define-inline (%fxneg x) (##core#inline "C_fixnum_negate" x))
269(define-inline (%fxand x y) (##core#inline "C_fixnum_and" x y))
270(define-inline (%fxior x y) (##core#inline "C_fixnum_or" x y))
271(define-inline (%fxxor x y) (##core#inline "C_fixnum_xor" x y))
272(define-inline (%fxnot x) (##core#inline "C_fixnum_not" x))
273(define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
274(define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
275
276; These are very unsafe, no check for division-by-zero
277(define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
278(define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))
279
280
281;;; Block
282
283
284;; Size of object in units of sub-object.
285
286; byteblock is # of bytes, otherwise # of words.
287;
288(define-inline (%block-size x) (##core#inline "C_block_size" x))
289
290
291;; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
292;
293; Creates & returns a string when 'byteblock?', otherwise a vector.
294;
295; Size is # of bytes when 'byteblock?', otherwise # of words.
296; Fill is a character when 'byteblock?', otherwise any.
297;
298(define-inline (%block-allocate n bb f a) ((##core#primitive "C_allocate_vector") n bb f a))
299
300(define-inline (%block-address x) (##core#inline_allocate ("C_block_address" 4) x))
301
302
303;; Byte access
304
305(define-inline (%make-block-byte n f a?) (%block-allocate n #t f a?))
306
307(define-inline (%block-byte-ref x i) (##core#inline "C_subbyte" x i))
308(define-inline (%block-byte-set! x i n) (##core#inline "C_setsubbyte" x i n))
309
310
311;; Word access
312
313(define-inline (%make-block-word n f a?) (%block-allocate n #f f a?))
314
315(define-inline (%block-word-ref x i) (##core#inline "C_slot" x i))
316
317(define-inline (%block-word-set! x i y) (##core#inline "C_i_setslot" x i y))
318(define-inline (%block-word-set!/immediate x i y) (##core#inline "C_i_set_i_slot" x i y))
319
320(define-inline (%block-word-set!/maybe-immediate x i y)
321  (if (%immediate? y)
322      (%block-word-set!/immediate x i y)
323      (%block-word-set! x i y) ) )
324
325
326;;;
327
328
329;; Generic-byteblock
330
331; generic-byteblock isa string, flonum, or lambda-info
332
333
334;; String (byteblock)
335
336(define-inline (%make-string size fill) (%make-block-byte size fill #f))
337
338(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
339
340(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
341
342(define-inline (%string-length s) (%block-size s))
343
344;%bytevector->string - see Bytevector
345
346
347;; Flonum (byteblock)
348
349
350;; Lambda-info (byteblock)
351
352
353;; Generic-vector
354
355; generic-vector isa vector, pair, structure, symbol, or keyword
356(define-inline (%generic-vector? x)
357  (and (%block? x)
358       (not (or (%special? x) (%byteblock? x)))) )
359
360
361;; Vector (wordblock)
362
363(define-inline (%make-vector size fill) (%make-word-block size fill #f))
364
365(define-inline (%vector-ref v i) (%block-word-ref v i))
366
367(define-inline (%vector-set! v i x) (%block-word-set! v i x))
368(define-inline (%vector-set!/immediate v i x) (%block-word-set!/immediate v i x))
369(define-inline (%vector-set!/maybe-immediate v i x) (%block-word-set!/maybe-immediate v i x))
370
371(define-inline (%vector-length v) (%block-size v))
372
373
374;; Bytevector (wordblock, but byte referenced)
375
376(define-inline (%make-bytevector sz)
377  (let ([bv (%make-string sz #f #t)])
378    (##core#inline "C_string_to_bytevector" bv)
379    bv ) )
380
381(define-inline (%bytevector-ref bv i) (%block-byte-ref bv i))
382
383(define-inline (%bytevector-set! bv i x) (%block-byte-set! bv i x))
384
385(define-inline (%bytevector-length bv) (%block-size bv))
386
387(define-inline (%bytevector=? v1 v2)
388  (let ([ln (%bytevector-length v1)])
389    (and (%eq? n %bytevector-length v2))
390         (%fx=? 0 (##core#inline "C_string_compare" v1 v2 n)) ) )
391
392(define-inline (%string->bytevector s)
393  (let* ([n (%string-length s)]
394               [bv (%make-bytevector sz)] )
395    (##core#inline "C_copy_memory" bv s n)
396    bv ) )
397
398(define-inline (%bytevector->string bv)
399  (let* ([n (%bytevector-length bv)]
400               [s (%make-string n #\space)] )
401    (##core#inline "C_copy_memory" s bv n)
402    s ) )
403
404
405;; Blob (isa bytevector w/o accessors)
406
407(define-inline (%make-blob sz) (%make-bytevector sz))
408
409(define-inline (%blob? x) (%bytevector? x))
410
411(define-inline (%blob-size b) (%bytevector-length b))
412
413(define-inline (%blob=? b1 b2) (%bytevector=? b1 b2))
414
415(define-inline (%string->blob s) (%string->bytevector s))
416
417(define-inline (%blob->string bv) (%bytevector->string bv))
418
419
420;; Pair (wordblock)
421
422(define-inline (%null? x) (%eol-object? x))
423
424(define-inline (%list? x) (or (%null? x) (%pair? x)))
425
426(define-inline (%cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y) )
427
428(define-inline (%length ls) (##core#inline "C_i_length" ls))
429
430(define-inline (%car pr) (%block-word-ref pr 0))
431(define-inline (%cdr pr) (%block-word-ref pr 1))
432
433(define-inline (%caar pr) (%car (%car pr)))
434(define-inline (%cadr pr) (%car (%cdr pr)))
435(define-inline (%cdar pr) (%cdr (%car pr)))
436(define-inline (%cddr pr) (%cdr (%cdr pr)))
437
438(define-inline (%caaar pr) (%car (%caar pr)))
439(define-inline (%caadr pr) (%car (%cadr pr)))
440(define-inline (%cadar pr) (%car (%cdar pr)))
441(define-inline (%caddr pr) (%car (%cddr pr)))
442(define-inline (%cdaar pr) (%cdr (%caar pr)))
443(define-inline (%cdadr pr) (%cdr (%cadr pr)))
444(define-inline (%cddar pr) (%cdr (%cdar pr)))
445(define-inline (%cdddr pr) (%cdr (%cddr pr)))
446
447(define-inline (%set-car! pr x) (%block-word-set! pr 0 x))
448(define-inline (%set-cdr! pr x) (%block-word-set! pr 1 x))
449(define-inline (%set-car/immediate! pr x) (%block-word-set!/immediate pr 0 x))
450(define-inline (%set-cdr/immediate! pr x) (%block-word-set!/immediate pr 1 x))
451(define-inline (%set-car!/maybe-immediate pr x) (%block-word-set!/maybe-immediate pr 0 x))
452(define-inline (%set-cdr!/maybe-immediate pr x) (%block-word-set!/maybe-immediate pr 1 x))
453
454;; These are safe
455
456(define-inline (%memq x ls) (##core#inline "C_i_memq" x ls))
457(define-inline (%memv x ls) (##core#inline "C_i_memv" x ls))
458(define-inline (%member x ls) (##core#inline "C_i_member" x ls))
459
460(define-inline (%assq x ls) (##core#inline "C_i_assq" x ls))
461(define-inline (%assv x ls) (##core#inline "C_i_assv" x ls))
462(define-inline (%assoc x ls) (##core#inline "C_i_assoc" x ls))
463
464(define-inline (%list-ref ls0 i0)
465  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
466  (let loop ([ls ls0] [i i0])
467    (cond [(%null? ls)  '() ]
468                [(%fx= 0 i)   (%car ls) ]
469                [else         (loop (%cdr ls) (%fx- i 1)) ] ) ) )
470
471(define-inline (%list-pair-ref ls0 i0)
472  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
473  (let loop ([ls ls0] [i i0])
474    (cond [(%null? ls)  '() ]
475                [(%fx= 0 i)   ls ]
476                [else         (loop (%cdr ls) (%fx- i 1)) ] ) ) )
477
478(define-inline (%last-pair ls0)
479  ;(assert (and (proper-list? ls0) (not (null? ls0))))
480  (do ([ls ls0 (%cdr ls)])
481      [(%null? (%cdr ls)) ls]) )
482
483(define-inline (%list-copy ls0)
484  ;(assert (proper-list? ls0))
485  (let loop ([ls ls0])
486    (if (%null? ls) '()
487        (%cons (%car ls) (loop (%cdr ls))) ) ) )
488
489(define-inline (%append! . lss)
490  ;(assert (and (proper-list? lss) (for-each (lambda (x) (proper-list? x)) lss)))
491  (let ([lss (let position-at-first-pair ([lss lss])
492               (cond [(%null? lss)        '() ]
493                     [(%null? (%car lss))  (position-at-first-pair (%cdr lss)) ]
494                     [else                 lss ] ) ) ] )
495    (if (%null? lss) '()
496        (let ([ls0 (%car lss)])
497          ;(assert (not (null? ls0)))
498          (let append!-rest ([lss (%cdr lss)] [pls ls0])
499            (if (%null? lss) ls0
500                (let ([ls (%car lss)])
501                  (cond [(%null? ls)
502                         (append!-rest (%cdr lss) pls) ]
503                        [else
504                         (%set-cdr! (%last-pair pls) ls)
505                         (append!-rest (%cdr lss) ls) ] ) ) ) ) ) ) ) )
506
507(define-inline (%delq! x ls0)
508  ;(assert (proper-list? ls0))
509  (let find-elm ([ls ls0] [ppr #f])
510    (cond [(%null? ls)
511           ls0 ]
512                [(%eq? x (%car ls))
513                 (cond [ppr
514                        (%set-cdr!/maybe-immediate ppr (%cdr ls))
515                        ls0 ]
516                       [else
517                        (%cdr ls) ] ) ]
518                [else
519                 (find-elm (%cdr ls) ls) ] ) ) )
520
521(define-inline (%list-fold-1 ls0 func init)
522  ;(assert (and (proper-list? ls0) (procedure? func)))
523  (let loop ([ls ls0] [acc init])
524    (if (%null? ls) acc
525        (loop (%cdr ls) (func (%car ls) acc)) ) ) )
526
527(define-inline (%list-map-1 ls0 func)
528  ;(assert (and (proper-list? ls0) (procedure? func)))
529  (let loop ([ls ls0])
530    (if (%null? ls) '()
531        (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
532
533(define-inline (%list-for-each-1 ls0 proc)
534  ;(assert (and (proper-list? ls0) (procedure? proc)))
535  (let loop ([ls ls0])
536    (unless (%null? ls)
537      (proc (%car ls))
538      (loop (%cdr ls)) ) ) )
539
540
541;; Structure (wordblock)
542
543(define-inline (%make-structure t . s) (apply (##core#primitive "C_make_structure") t s))
544
545(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
546
547(define-inline (%structure-ref r i) (%block-word-ref r i))
548
549(define-inline (%structure-set! r i x) (%block-word-set! r i x))
550(define-inline (%structure-set!/immediate r i x) (%block-word-set!/immediate r i x))
551(define-inline (%structure-set!/maybe-immediate r i x) (%block-word-set!/maybe-immediate r i x))
552
553(define-inline (%structure-length r) (%block-size r))
554
555(define-inline (%structure-tag r) (%block-word-ref r 0))
556
557
558;; Port (wordblock)
559
560; Port layout:
561;
562; 0       FP (special - C FILE *)
563; 1       input/output (bool)
564; 2       class (vector, see Port-class)
565; 3       name (string)
566; 4       row (fixnum)
567; 5       col (fixnum)
568; 6       EOF (bool)
569; 7       type (symbol)
570; 8       closed (bool)
571; 9       data
572; 10-15  reserved, port class specific
573
574; port is 16 slots + a block-header word
575;
576;(define-inline (%make-port n) (##core#inline_allocate ("C_a_i_port" 17)))
577
578(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
579(define-inline (%port-input-mode? port) (%block-word-ref? port 1))
580(define-inline (%port-class port) (%block-word-ref? port 2))
581(define-inline (%port-name port) (%block-word-ref? port 3))
582(define-inline (%port-row port) (%block-word-ref? port 4))
583(define-inline (%port-column port) (%block-word-ref? port 5))
584(define-inline (%port-eof? port) (%block-word-ref? port 6))
585(define-inline (%port-type port) (%block-word-ref? port 7))
586(define-inline (%port-closed? port) (%block-word-ref? port 8))
587(define-inline (%port-data port) (%block-word-ref? port 9))
588
589(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
590(define-inline (%port-input-mode-set! port f) (%block-word-set!/immediate port 1 f))
591(define-inline (%port-class port v) (%block-word-set! port 2 v))
592(define-inline (%port-name-set! port s) (%block-word-set! port 3 s))
593(define-inline (%port-row-set! port n) (%block-word-set!/immediate port 4 n))
594(define-inline (%port-column-set! port n) (%block-word-set!/immediate port 5 n))
595(define-inline (%port-eof-set! port f) (%block-word-set!/immediate port 6 f))
596(define-inline (%port-type-set! port s) (%block-word-set! port 7 s))
597(define-inline (%port-closed-set! port f) (%block-word-set!/immediate port 8 f))
598(define-inline (%port-data-set! port port) (%block-word-set! port 9 x))
599
600; Port-class layout
601;
602; 0       (read-char PORT) -> CHAR | EOF
603; 1       (peek-char PORT) -> CHAR | EOF
604; 2       (write-char PORT CHAR)
605; 3       (write-string PORT STRING)
606; 4       (close PORT)
607; 5       (flush-output PORT)
608; 6       (char-ready? PORT) -> BOOL
609; 7       (read-string! PORT COUNT STRING START) -> COUNT'
610; 8       (read-line PORT LIMIT) -> STRING | EOF
611
612
613;; Closure (wordblock)
614
615(define-inline (%closure-size c) (%block-size? c))
616
617(define-inline (%vector->closure! v a)
618  (##core#inline "C_vector_to_closure" v)
619  (##core#inline "C_update_pointer" a v) )
620
621
622;; Symbol (wordblock)
623
624(define-inline (%symbol-binding s) (%block-word-ref s 0))
625(define-inline (%symbol-string s) (%block-word-ref s 1))
626(define-inline (%symbol-bucket s) (%block-word-ref s 2))
627
628(define-inline (%string->symbol-interned s) ((##core#primitive "C_string_to_symbol") s))
629
630;(define-inline (%symbol-intern! s) (%string->symbol (%symbol-string s)))
631
632(define-inline (%symbol-interned? x) (##core#inline "C_lookup_symbol" x))
633
634(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))
635
636
637;; Keyword (wordblock)
638
639(define-inline (%keyword? x)
640  (and (%symbol? x)
641       (%eq? 0 (%block-byte-ref (%symbol-string x) 0)) ) )
642
643
644;; Locative (wordblock)
645
646(define-inline (%make-locative typ obj idx weak?)
647  (##core#inline_allocate ("C_a_i_make_locative" 5) typ obj idx weak?))
648
649; Locative layout:
650;
651; 0     Object-address + byte-offset (address)
652; 1     Byte-offset (fixnum)
653; 2     Type (fixnum)
654;         0     vector or pair          (C_SLOT_LOCATIVE)
655;         1     string                  (C_CHAR_LOCATIVE)
656;         2     u8vector                (C_U8_LOCATIVE)
657;         3     s8vector or bytevector  (C_U8_LOCATIVE)
658;         4     u16vector                           (C_U16_LOCATIVE)
659;         5     s16vector                           (C_S16_LOCATIVE)
660;         6     u32vector                           (C_U32_LOCATIVE)
661;         7     s32vector                           (C_S32_LOCATIVE)
662;         8     f32vector                           (C_F32_LOCATIVE)
663;         9     f64vector                           (C_F64_LOCATIVE)
664; 3     Object or #f, if weak (C_word)
665
666;%locative-address - see Pointer
667(define-inline (%locative-offset lv) (%block-word-ref lv 1))
668(define-inline (%locative-type lv) (%block-word-ref lv 2))
669(define-inline (%locative-weak? lv) (not (%block-word-ref lv 3)))
670(define-inline (%locative-object lv) (%block-word-ref lv 3))
671
672
673;; Pointer (wordblock)
674
675; simple-pointer, tagged-pointer, swig-pointer, locative
676(define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
677
678; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
679(define-inline (%pointer-like? x) (%wordblock? x))
680
681; These operate on pointer-like objects
682
683(define-inline (%pointer-ref ptr) (%block-word-ref ptr 0))
684(define-inline (%pointer-set! ptr y) (%block-word-set! ptr 0 y))
685
686(define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
687
688(define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
689
690(define-inline (%pointer->address ptr)
691  ; Pack pointer address value into Chicken words; '4' is platform dependent!
692  (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref x)) )
693
694(define-inline (%locative-address lv) (%pointer->address lv))
695
696
697;; Simple-pointer (wordblock)
698
699(define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))
700
701(define-inline (%make-pointer-null)
702  (let ([ptr (%make-simple-pointer)])
703    (##core#inline "C_update_pointer" 0 ptr)
704    ptr ) )
705
706(define-inline (%address->pointer a)
707  (let ([ptr (%make-simple-pointer)])
708    (##core#inline "C_update_pointer" a ptr)
709    ptr ) )
710
711(define-inline (%make-pointer-block b)
712  (let ([ptr (%make-simple-pointer)])
713    (##core#inline "C_pointer_to_block" ptr b)
714    ptr ) )
715
716
717;; Tagged-pointer (wordblock)
718
719(define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))
720
721
722;; Swig-pointer (wordblock)
723
724
725
726;;; Values
727
728
729
730;;; Numbers
731
732(define-inline (%number? x) (or (%fixnum? x) (%flonum? x) ) )
733
734
735;;; Operations
736
737
738;; Random
739
740(define-inline (%random-fixnum x) (##core#inline "C_random_fixnum" x))
Note: See TracBrowser for help on using the repository browser.