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)) |
---|