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

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

Fix for core prim calls.

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