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

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

Added '%append!' & thread state test procs.

File size: 18.6 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;; These are safe
405
406(define-inline (%memq x l) (##core#inline "C_i_memq" x l))
407(define-inline (%memv x l) (##core#inline "C_i_memv" x l))
408(define-inline (%member x l) (##core#inline "C_i_member" x l))
409
410(define-inline (%assq x l) (##core#inline "C_i_assq" x l))
411(define-inline (%assv x l) (##core#inline "C_i_assv" x l))
412(define-inline (%assoc x l) (##core#inline "C_i_assoc" x l))
413
414; l0 must be a proper-list
415(define-inline (%list-ref l0 i0)
416  (let loop ([l l0] [i i0])
417    (cond [(null? l)  '() ]
418                [(%fx= 0 i) (%car l) ]
419                [else       (loop (%cdr l) (%fx- i 1)) ] ) ) )
420
421; l0 cannot be null
422(define-inline (%last-pair l0)
423  (do ([l l0 (%cdr l)])
424      [(%null? (%cdr l)) l]) )
425
426; each elm of ls must be a proper-list
427(define-inline (%append! . ls)
428  (let ([ls (let loop ([ls ls])
429              (cond [(%null? ls)        '() ]
430                    [(%null? (%car ls)) (loop (%cdr ls)) ]
431                    [else               ls ] ) ) ] )
432    (if (%null? ls)
433        '()
434        (let ([l0 (%car ls)])
435          ;(assert (not (null? l0)))
436          (let loop ([ls (%cdr ls)] [pl l0])
437            (if (%null? ls)
438                l0
439                (let ([l1 (%car ls)])
440                  (if (%null? l1)
441                      (loop (%cdr ls) pl)
442                      (begin
443                        (%set-cdr! (%last-pair pl) l1)
444                        (loop (%cdr ls) l1) ) ) ) ) ) ) ) ) )
445   
446; l0 must be a proper-list
447(define-inline (%delq! x l0)
448  (let loop ([l l0] [pp #f])
449    (cond [(null? l)
450           l0 ]
451                [(%eq? x (%car l))
452                 (cond [pp
453                        (%set-cdr! pp (%cdr l))
454                        l0 ]
455                       [else
456                        (%cdr l) ] ) ]
457                [else
458                 (loop (%cdr l) l) ] ) ) )
459
460
461;; Structure (wordblock)
462
463(define-inline (%make-structure t . s) (apply (##core#primitive "C_make_structure") t s))
464
465(define-inline (%generic-structure? x) (and (%block? x) (%structure-type? x)))
466
467(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
468
469(define-inline (%structure-ref r i) (%block-word-ref r i))
470
471(define-inline (%structure-set! r i x) (%block-word-set! r i x))
472(define-inline (%structure-set!/immediate r i x) (%block-word-set!/immediate r i x))
473
474(define-inline (%structure-length r) (%block-size r))
475
476(define-inline (%structure-tag r) (%block-word-ref r 0))
477
478
479;; Special-block (wordblock)
480
481(define-inline (%special-block? x) (and (%block? x) (%special? x)))
482
483
484;; Port (wordblock)
485
486; Port layout:
487;
488; 0       FP (special - C FILE *)
489; 1       input/output (bool)
490; 2       class (vector, see Port-class)
491; 3       name (string)
492; 4       row (fixnum)
493; 5       col (fixnum)
494; 6       EOF (bool)
495; 7       type (symbol)
496; 8       closed (bool)
497; 9       data
498; 10-15  reserved, port class specific
499
500; port is 16 slots + a block-header word
501;
502;(define-inline (%make-port n) (##core#inline_allocate ("C_a_i_port" 17)))
503
504(define-inline (%port? x) (and (%block? x) (%port-type? x)))
505
506(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
507(define-inline (%port-input-mode? port) (%block-word-ref? port 1))
508(define-inline (%port-class port) (%block-word-ref? port 2))
509(define-inline (%port-name port) (%block-word-ref? port 3))
510(define-inline (%port-row port) (%block-word-ref? port 4))
511(define-inline (%port-column port) (%block-word-ref? port 5))
512(define-inline (%port-eof? port) (%block-word-ref? port 6))
513(define-inline (%port-type port) (%block-word-ref? port 7))
514(define-inline (%port-closed? port) (%block-word-ref? port 8))
515(define-inline (%port-data port) (%block-word-ref? port 9))
516
517(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
518(define-inline (%port-input-mode-set! port f) (%block-word-set!/immediate port 1 f))
519(define-inline (%port-class port v) (%block-word-set! port 2 v))
520(define-inline (%port-name-set! port s) (%block-word-set! port 3 s))
521(define-inline (%port-row-set! port n) (%block-word-set!/immediate port 4 n))
522(define-inline (%port-column-set! port n) (%block-word-set!/immediate port 5 n))
523(define-inline (%port-eof-set! port f) (%block-word-set!/immediate port 6 f))
524(define-inline (%port-type-set! port s) (%block-word-set! port 7 s))
525(define-inline (%port-closed-set! port f) (%block-word-set!/immediate port 8 f))
526(define-inline (%port-data-set! port port) (%block-word-set! port 9 x))
527
528; Port-class layout     
529;
530; 0       (read-char PORT) -> CHAR | EOF
531; 1       (peek-char PORT) -> CHAR | EOF
532; 2       (write-char PORT CHAR)
533; 3       (write-string PORT STRING)
534; 4       (close PORT)
535; 5       (flush-output PORT)
536; 6       (char-ready? PORT) -> BOOL
537; 7       (read-string! PORT COUNT STRING START) -> COUNT'
538; 8       (read-line PORT LIMIT) -> STRING | EOF
539
540
541;; Closure (wordblock)
542
543(define-inline (%closure? x) (and (%block? x) (%closure-type? x)))
544
545(define-inline (%closure-size c) (%block-size? c))
546
547(define-inline (%vector->closure! v a)
548  (##core#inline "C_vector_to_closure" v)
549  (##core#inline "C_update_pointer" a v) )
550
551
552;; Symbol (wordblock)
553
554(define-inline (%symbol? x) (and (%block? x) (%symbol-type? x)))
555
556(define-inline (%symbol-binding s) (%block-word-ref s 0))
557(define-inline (%symbol-string s) (%block-word-ref s 1))
558(define-inline (%symbol-bucket s) (%block-word-ref s 2))
559
560(define-inline (%string->symbol-interned s) ((##core#primitive "C_string_to_symbol") s))
561
562;(define-inline (%symbol-intern! s) (%string->symbol (%symbol-string s)))
563
564(define-inline (%symbol-interned? x) (##core#inline "C_lookup_symbol" x))
565
566(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))
567
568
569;; Keyword (wordblock)
570
571(define-inline (%keyword? x)
572  (and (%symbol? x)
573       (%eq? 0 (%block-byte-ref (%symbol-string x) 0)) ) )
574
575
576;; Locative (wordblock)
577
578(define-inline (%make-locative typ obj idx weak?)
579  (##core#inline_allocate ("C_a_i_make_locative" 5) typ obj idx weak?))
580
581(define-inline (%locative? x) (and (%block? x) (%locative-type? x)))
582
583; Locative layout:
584;
585; 0     Object-address + byte-offset (address)
586; 1     Byte-offset (fixnum)
587; 2     Type (fixnum)
588;         0     vector or pair          (C_SLOT_LOCATIVE)
589;         1     string                  (C_CHAR_LOCATIVE)
590;         2     u8vector                (C_U8_LOCATIVE)
591;         3     s8vector or bytevector  (C_U8_LOCATIVE)
592;         4     u16vector                           (C_U16_LOCATIVE)
593;         5     s16vector                           (C_S16_LOCATIVE)
594;         6     u32vector                           (C_U32_LOCATIVE)
595;         7     s32vector                           (C_S32_LOCATIVE)
596;         8     f32vector                           (C_F32_LOCATIVE)
597;         9     f64vector                           (C_F64_LOCATIVE)
598; 3     Object or #f, if weak (C_word)
599
600;%locative-address - see Pointer
601(define-inline (%locative-offset lv) (%block-word-ref lv 1))
602(define-inline (%locative-type lv) (%block-word-ref lv 2))
603(define-inline (%locative-weak? lv) (not (%block-word-ref lv 3)))
604(define-inline (%locative-object lv) (%block-word-ref lv 3))
605
606
607;; Pointer (wordblock)
608
609(define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))
610
611; simple-pointer, tagged-pointer, swig-pointer, locative
612(define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
613
614; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
615(define-inline (%pointer-like? x) (%special-block? x))
616
617; These operate on pointer-like objects
618
619(define-inline (%pointer-ref ptr) (%block-word-ref ptr 0))
620(define-inline (%pointer-set! ptr y) (%block-word-set! ptr 0 y))
621
622(define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
623
624(define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
625
626(define-inline (%pointer->address ptr)
627  ; Pack pointer address value into Chicken words; '4' is platform dependent!
628  (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref x)) )
629
630(define-inline (%locative-address lv) (%pointer->address lv))
631
632
633;; Simple-pointer (wordblock)
634
635(define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))
636
637(define-inline (%simple-pointer? x) (and (%block? x) (%simple-pointer-type? x)))
638
639(define-inline (%make-pointer-null)
640  (let ([ptr (%make-simple-pointer)])
641    (##core#inline "C_update_pointer" 0 ptr)
642    ptr ) )
643
644(define-inline (%address->pointer a)
645  (let ([ptr (%make-simple-pointer)])
646    (##core#inline "C_update_pointer" a ptr)
647    ptr ) )
648
649(define-inline (%make-pointer-block b)
650  (let ([ptr (%make-simple-pointer)])
651    (##core#inline "C_pointer_to_block" ptr b)
652    ptr ) )
653
654
655;; Tagged-pointer (wordblock)
656
657(define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))
658
659(define-inline (%tagged-pointer? x) (and (%block? x) (%tagged-pointer-type? x)))
660
661
662;; Swig-pointer (wordblock)
663
664(define-inline (%swig-pointer? x) (and (%block? x) (%swig-pointer-type? x)))
665
666
667
668;;; Values
669
670
671
672;;; Operations
673
674
675;; Random
676
677(define-inline (%random-fixnum x) (##core#inline "C_random_fixnum" x))
Note: See TracBrowser for help on using the repository browser.