source: project/chicken/branches/chicken-3/chicken-primitive-object-inlines.scm @ 13147

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

lolevel.scm : check-pointer not in library.scm yet
chicken.h : grouped like, note that swig pointer is now special
chicken-primitive-object-inlines.scm : wrong unbound value C predicate name
Unit lolevel : rmvd empty line

File size: 11.2 KB
Line 
1;;;; chicken-primitive-inlines.scm
2;;;; Kon Lovett, Oct '07
3
4;;;; Provides inlines & macros for primitive procedures
5;;;; MUST be included
6
7
8;;; Type Predicates (these are not fool-proof)
9
10;; Argument is a 'C_word'
11
12;; Immediate
13
14(define-inline (%immediate? ?x) (##core#inline "C_immp" x))
15
16;; Fixnum
17
18(define-inline (%fixnum? x) (##core#inline "C_fixnump" x))
19
20;; Character
21
22(define-inline (%char? x) (##core#inline "C_charp" x))
23
24;; Boolean
25
26(define-inline (%boolean? x) (##core#inline "C_booleanp" x))
27
28;; True
29
30;(define-inline (%true? x) (##core#inline "" x))
31
32;; False
33
34;(define-inline (%false? x) (##core#inline "" x))
35
36;; EOF
37
38(define-inline (%eof-object? x) (##core#inline "C_eofp" x))
39
40;; Null (the end-of-list value)
41
42(define-inline (%null? x) (##core#inline "C_i_nullp" x))
43
44;; Undefined (void)
45
46(define-inline (%undefined? x) (##core#inline "C_undefinedp" x))
47
48;; Unbound (the unbound value, not is a symbol unbound)
49
50(define-inline (%unbound? x) (##core#inline "C_unboundvaluep" x))
51
52;; Block (anything not immediate)
53
54(define-inline (%block? x) (##core#inline "C_blockp" x))
55
56;; Forwarded (block object moved to new address, forwarding pointer)
57
58(define-inline (%forwarded? x) (##core#inline "C_forwardedp" x))
59
60;; Special
61
62(define-inline (%special? x) (##core#inline "C_specialp" x))
63
64;; Byteblock
65
66(define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))
67
68;; String
69
70(define-inline (%string-type? x) (##core#inline "C_stringp" x))
71
72;; Flonum
73
74(define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
75
76;; Lambda-info
77
78(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
79
80;; Vector
81
82(define-inline (%vector-type? x) (##core#inline "C_vectorp" x))
83
84;; Bytevector
85
86(define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))
87
88;; Pair
89
90(define-inline (%pair-type? x) (##core#inline "C_pairp" x))
91
92;; Bucket
93
94; A bucket is used by the runtime for the symbol-table. The bucket type is not
95; "seen" by Scheme code.
96
97;; Structure
98
99(define-inline (%structure-type? x) (##core#inline "C_structurep" x))
100
101;; Closure
102
103(define-inline (%closure-type? x) (##core#inline "C_closurep" x))
104
105;; Port
106
107(define-inline (%port-type? x) (##core#inline "C_portp" x))
108
109;; Symbol
110
111(define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
112
113;; Simple-pointer
114
115(define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
116
117;; Tagged-Pointer
118
119(define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
120
121;; Swig-Pointer
122
123(define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
124
125;; Locative
126
127(define-inline (%locative-type? x) (##core#inline "C_locativep" x))
128
129
130;;; Values
131
132
133;;; Primitive Operations
134
135(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
136
137(define-inline %become (##core#primitive "C_become"))
138
139
140;;; Complex Types
141
142;; Size of object in units of sub-object.
143;; Byteblock is # of bytes, other are # of words.
144
145(define-inline (%size x) (##core#inline "C_block_size" x))
146
147;; Generic-bytevector
148
149(define-inline (%byte-ref x i) (##core#inline "C_subbyte" x i))
150(define-inline (%byte-set! x i n) (##core#inline "C_setsubbyte" x i n))
151
152;; Generic-vector
153
154(define-inline (%generic-vector? x)
155  (and (%block? x)
156       (not (or (%special? x)
157                      (%byteblock? x)))) )
158
159(define-inline (%slot-ref x i) (##core#inline "C_slot" x i))
160
161(define-inline (%slot-set! x i y) (##core#inline "C_i_setslot" x i y))
162(define-inline (%slot-set-immediate! x i y) (##core#inline "C_i_set_i_slot" x i y))
163
164(define-inline (%block-address x) (##core#inline_allocate ("C_block_address" 4) x))
165
166(define-inline %allocate-vector (##core#primitive "C_allocate_vector"))
167
168;; String (byteblock)
169
170(define-inline (%string? x)
171  (and (%block? x) (%string-type? x)) )
172
173(define-inline (%make-string size fill) (%allocate-vector size #t fill #f))
174
175(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
176
177(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
178
179(define-inline (%string-length s) (%size s))
180
181;; Flonum (byteblock)
182
183(define-inline (%flonum? x)
184  (and (%block? x) (%flonum-type? x)) )
185
186(define-inline (%flonum-magnitude f) (##core#inline "C_flonum_magnitude" x))
187
188;; Lambda-info (byteblock)
189
190(define-inline (%lambda-info? x)
191  (and (%block? x) (%lambda-info-type? x)) )
192
193;; Vector (wordblock)
194
195(define-inline (%vector? x)
196  (and (%block? x) (%vector-type? x)) )
197
198(define-inline (%make-vector size fill) (%allocate-vector size #f fill #f))
199
200(define-inline (%vector-ref v i) (%slot-ref v i))
201
202(define-inline (%vector-set-slot! v i x) (%slot-set! v i x))
203(define-inline (%vector-set-immediate! v i x) (%slot-set-immediate! v i x))
204
205(define-inline (%vector-set! v i x)
206  (if (%immediate? x)
207      (%vector-set-immediate! v i x)
208      (%vector-set-slot! v i x) ) )
209
210(define-inline (%vector-length v) (%size v))
211
212;; Bytevector (wordblock)
213
214(define-inline (%bytevector? x)
215  (and (%block? x) (%bytevector-type? x)) )
216
217(define-inline (%bytevector-ref v i) (%byte-ref v i))
218
219(define-inline (%bytevector-set! v i x) (%byte-set! v i x))
220
221(define-inline (%bytevector-length v) (%size v))
222
223(define-inline (%string->bytevector s) (##core#inline "C_string_to_pbytevector" s))
224
225(define-inline (%bytevector=? v1 v2)
226  (let ([ln (%bytevector-length v1)])
227    (and (%eq? n %bytevector-length v2))
228         (%eq? 0 (##core#inline "C_string_compare" v1 v2 n)) ) )
229
230(define-inline (%blob? x) (%bytevector? x))
231
232(define-inline (%blob-size? x) (%size? x))
233
234;; Pair (wordblock)
235
236(define-inline (%pair? x)
237  (and (%block? x) (%pair-type? x)) )
238
239(define-inline (%list? x)
240  (or (%null? x)
241      (%pair? x)) )
242
243(define-inline (%cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y) )
244
245(define-inline (%length x y) (##core#inline "C_i_length" lst))
246
247(define-inline (%car p) (%slot-ref p 0))
248(define-inline (%cdr p) (%slot-ref p 1))
249
250(define-inline (%caar p) (%car (%car p)))
251(define-inline (%cadr p) (%car (%cdr p)))
252(define-inline (%cdar p) (%cdr (%car p)))
253(define-inline (%cddr p) (%cdr (%cdr p)))
254
255(define-inline (%caaar p) (%car (%caar p)))
256(define-inline (%caadr p) (%car (%cadr p)))
257(define-inline (%cadar p) (%car (%cdar p)))
258(define-inline (%caddr p) (%car (%cddr p)))
259(define-inline (%cdaar p) (%cdr (%caar p)))
260(define-inline (%cdadr p) (%cdr (%cadr p)))
261(define-inline (%cddar p) (%cdr (%cdar p)))
262(define-inline (%cdddr p) (%cdr (%cddr p)))
263
264(define-inline (%set-car-slot! p x) (%slot-set! p 0 x))
265(define-inline (%set-cdr-slot! p x) (%slot-set! p 1 x))
266(define-inline (%set-car-immediate! p x) (%slot-set-immediate! p 0 x))
267(define-inline (%set-cdr-immediate! p x) (%slot-set-immediate! p 1 x))
268
269(define-inline (%set-car! p x)
270  (if (%immediate? x)
271      (%set-car-immediate! p x)
272      (%set-car-slot! p x) ) )
273
274(define-inline (%set-cdr! p x)
275  (if (%immediate? x)
276      (%set-cdr-immediate! p x)
277      (%set-cdr-slot! p x) ) )
278
279(define-inline (%last-pair l0)
280  (do ([l l0 (%cdr l)])
281      [(%null? (%cdr l)) l]) )
282
283(define-inline (%memq x l) (##core#inline "C_i_memq" x l))
284(define-inline (%memv x l) (##core#inline "C_i_memv" x l))
285(define-inline (%member x l) (##core#inline "C_i_member" x l))
286(define-inline (%assq x l) (##core#inline "C_i_assq" x l))
287(define-inline (%assv x l) (##core#inline "C_i_assv" x l))
288(define-inline (%assoc x l) (##core#inline "C_i_assoc" x l))
289
290;; Structure (wordblock)
291
292(define-inline (%generic-structure? x)
293  (and (%block? x) (%structure-type? x)) )
294
295(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
296
297(cond-expand
298  [hygienic-macros
299    (define-syntax %structure?
300      (syntax-rules ()
301        [(_ ?x)     (%generic-structure? ?x)]
302        [(_ ?x ?t)  (%structure-instance? ?x ,?t)] ) ) ]
303  [else
304    (define-macro (%structure? ?x . ?t)
305      (if (%null? ?t) `(%generic-structure? ,?x) `(%structure-type? ,?x ,(car ?t))) ) ] )
306
307(define-inline %make-structure (##core#primitive "C_make_structure"))
308
309(define-inline (%vector->structure! vec) (##core#inline "C_vector_to_structure" vec))
310
311(define-inline (%structure-ref r i) (%slot-ref r i))
312
313(define-inline (%structure-slot-set! r i x) (%slot-set! r i x))
314(define-inline (%structure-immediate-set! r i x) (%slot-set-immediate! r i x))
315
316(define-inline (%structure-length r) (%size r))
317
318(define-inline (%structure-tag r) (%slot-ref r 0))
319
320;; Port (wordblock)
321
322; Port layout:
323;
324; 0:  FP (special)
325; 1:  input/output (bool)
326; 2:  class (vector of procedures)
327; 3:  name (string)
328; 4:  row (fixnum)
329; 5:  col (fixnum)
330; 6:  EOF (bool)
331; 7:  type ('stream | 'custom | 'string | 'socket)
332; 8:  closed (bool)
333; 9:  data
334; 10-15: reserved, port class specific
335
336(define-inline (%port? x)
337  (and (%block? x) (%port-type? x)) )
338
339(define-inline (%port-mode p) (%slot-ref? x 1))
340
341(define-inline (%input-port? x)
342  (and (%port? x)
343       (%port-mode x)) )
344
345(define-inline (%output-port? x)
346  (and (%port? x)
347       (not (%port-mode x))) )
348
349;; Closure (wordblock)
350
351(define-inline (%closure? x)
352  (and (%block? x) (%closure-type? x)) )
353
354(define-inline (%procedure x) (%closure? x))
355
356(define-inline (%closure-size x) (%size? x))
357
358(define-inline (%vector->closure! v a)
359  (##core#inline "C_vector_to_closure" v)
360  (##core#inline "C_update_pointer" a v) )
361
362;; Symbol (wordblock)
363
364(define-inline (%symbol? x)
365  (and (%block? x) (%symbol-type? x)) )
366
367(define-inline %intern-symbol (##core#primitive "C_string_to_symbol"))
368(define-inline (%interned-symbol? x) (##core#inline "C_lookup_symbol" x))
369
370(define-inline (%string->symbol s) (%intern-symbol s)
371
372;; Keyword (wordblock)
373
374(define-inline (%keyword? x)
375  (and (%symbol? x)
376       (%eq? 0 (%byte-ref (%slot-ref x) 0)) ) )
377
378;; Locative (wordblock)
379
380(define-inline (%locative? x)
381  (and (%block? x) (%locative-type? x)) )
382
383;; Generic-pointer
384
385(define-inline (%generic-pointer? x)
386  (or (%pointer? x)
387      (%locative? x) ) )
388
389; generic-pointer, port, closure
390(define-inline (%special-block? x)
391  (and (%block? x) (%special? x)) )
392
393(define-inline (%pointer? x)
394  (and (%block? x) (##core#inline "C_anypointerp" x)) )
395
396(define-inline (%pointer-like? x) (%special-block? x))
397
398(define-inline (%generic-pointer-ref x) (%slot-ref x 0))
399(define-inline (%generic-pointer-set! x y) (%slot-set! x 0 y))
400
401(define-inline (%pointer->address ptr)
402  ; Pack pointer address value into Chicken words; '4' is platform dependent!
403  (##core#inline_allocate ("C_a_unsigned_int_to_num" 4) (%generic-pointer-ref x)) )
404
405(define-inline (%null-pointer? p)
406  (%eq? 0 (%pointer->address ptr)) )
407  (and (%block? x) (%swig-pointer-type? x)) )
408
409;; Simple-ointer (wordblock)
410
411(define-inline (%simple-pointer? x)
412  (and (%block? x) (%simple-pointer-type? x)) )
413
414(define-inline %make-simple-pointer (##core#primitive "C_make_pointer"))
415
416(define-inline (%address->pointer addr)
417  (let ([ptr (%make-simple-pointer)])
418    (##core#inline "C_update_pointer" addr ptr)
419    ptr ) )
420
421(define-inline (%block-pointer x)
422  (let ([ptr (%make-simple-pointer)])
423    (##core#inline "C_pointer_to_block" ptr x)
424    ptr ) )
425
426(define-inline (%null-pointer)
427  (let ([ptr (%make-simple-pointer)])
428    (##core#inline "C_update_pointer" 0 ptr)
429    ptr ) )
430
431;; Tagged-pointer (wordblock)
432
433(define-inline (%tagged-pointer? x)
434  (and (%block? x) (%tagged-pointer-type? x)) )
435
436(define-inline %make-tagged-pointer (##core#primitive "C_make_tagged_pointer"))
437
438;; Swig-pointer (wordblock)
439
440(define-inline (%swig-pointer? x)
441  (and (%block? x) (%swig-pointer-type? x)) )
442
443
444;;; Values
445
446
447;;; Operations
448
449;; Random
450
451(define-inline (%random-fixnum x) (##core#inline "C_random_fixnum" x))
Note: See TracBrowser for help on using the repository browser.