source: project/release/5/stack/trunk/chicken-primitive-object-inlines.scm @ 35980

Last change on this file since 35980 was 35980, checked in by Kon Lovett, 3 years ago

C5 initial

File size: 35.6 KB
Line 
1;;;; chicken-primitive-object-nlines.scm
2;;;; Kon Lovett, Jan '09
3;;;; (Was chicken-sys-macros.scm)
4
5; ***** SHOULD RENAME SAFE ROUTINES AS '*foo', KEEPING '%foo' FOR UNSAFE *****
6
7; Usage
8;
9; (include "chicken-primitive-object-inlines")
10
11;; Notes
12;;
13;; Provides inlines for primitive procedures. Use of these procedures
14;; by non-core is highly suspect. Many of these routines are unsafe.
15;;
16;; In fact, any use is suspect ;-)
17;;
18;; A ##core#Inline is just what it says - literal inclusion in the compiled C
19;; code of the C macro/function and the arguments taken literally, i.e. as the
20;; C_word value.
21;;
22;; These are much faster than a lambda, but very dangerous since the arguments and
23;; the return value are not converted. The C code must perform any such conversions.
24;;
25;; ##core#inline cannot be used with a runtime C function which is coded in the
26;; CPS style.
27;;
28;; A ##core#primitive creates a lambda for a C function which is coded in the
29;; CPS style.
30;;
31;; These have a stereotypical argument list which begins the 3 arguments C_word
32;; c, C_word closure, and C_word k. Any actual arguments follow.
33;;
34;; c       - number of arguments, not including 'c', but including 'closure' & 'k'
35;; closure - caller
36;; k       - continuation
37
38;;; Unsafe Type Predicates
39
40;; Fixnum
41
42(define-inline (%fixnum-type? x) (##core#inline "C_fixnump" x))
43
44;; Character
45
46(define-inline (%char-type? x) (##core#inline "C_charp" x))
47
48;; Boolean
49
50(define-inline (%boolean-type? x) (##core#inline "C_booleanp" x))
51
52;; EOF
53
54(define-inline (%eof-object-type? x) (##core#inline "C_eofp" x))
55
56;; Null (the end-of-list value)
57
58(define-inline (%eol-object-type? x) (##core#inline "C_i_nullp" x))
59
60;; Undefined (void)
61
62(define-inline (%undefined-type? x) (##core#inline "C_undefinedp" x))
63
64;; Unbound (the unbound value, not 'is a symbol unbound')
65
66(define-inline (%unbound-type? x) (##core#inline "C_unboundvaluep" x))
67
68;; Byteblock
69
70(define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))
71
72;; Bytevector
73
74(define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))
75
76;; String
77
78(define-inline (%string-type? x) (##core#inline "C_stringp" x))
79
80;; Flonum
81
82(define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
83
84;; Lambda-info
85
86(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
87
88;; Vector
89
90(define-inline (%vector-type? x) (##core#inline "C_vectorp" x))
91
92;; Pair
93
94(define-inline (%pair-type? x) (##core#inline "C_pairp" x))
95
96;; Bucket
97
98; A bucket is used by the runtime for the symbol-table. The bucket type is not
99; "seen" by Scheme code.
100
101;; Structure
102
103(define-inline (%structure-type? x) (##core#inline "C_structurep" x))
104
105;; Symbol
106
107(define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
108
109;; Closure
110
111(define-inline (%closure-type? x) (##core#inline "C_closurep" x))
112
113;; Port
114
115(define-inline (%port-type? x) (##core#inline "C_portp" x))
116
117;; Any-pointer
118
119(define-inline (%any-pointer-type? x) (##core#inline "C_anypointerp" x))
120
121;; Simple-pointer
122
123(define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
124
125;; Tagged-Pointer
126
127(define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
128
129;; Swig-Pointer
130
131(define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
132
133;; Locative
134
135(define-inline (%locative-type? x) (##core#inline "C_locativep" x))
136
137;;; Safe Type Predicates
138
139;; Immediate
140
141(define-inline (%immediate? x) (##core#inline "C_immp" x))
142
143;; Fixnum
144
145(define-inline (%fixnum? x) (and (%immediate? x) (%fixnum-type? x)))
146
147;; Character
148
149(define-inline (%char? x) (and (%immediate? x) (%char-type? x)))
150
151;; Boolean
152
153(define-inline (%boolean? x) (and (%immediate? x) (%boolean-type? x)))
154
155(define-inline (%true-value? x) (and (%boolean? x) (##core#inline "C_and" x #t)))
156(define-inline (%false-value? x) (not (%true-value? x)))
157
158;; EOF
159
160(define-inline (%eof-object? x) (and (%immediate? x) (%eof-object-type? x)))
161
162;; Null (the end-of-list value)
163
164(define-inline (%eol-object? x) (and (%immediate? x) (%eol-object-type? x)))
165
166;; Undefined (void)
167
168(define-inline (%undefined-value? x) (and (%immediate? x) (%undefined-type? x)))
169
170(define-inline (%undefined-value) (##core#undefined))
171
172;; Unbound (the unbound value, not 'is a symbol unbound')
173
174(define-inline (%unbound-value? x) (and (%immediate? x) (%unbound-type? x)))
175
176;; Block (anything not immediate)
177
178(define-inline (%block? x) (##core#inline "C_blockp" x))
179
180;; Special
181
182(define-inline (%special? x) (##core#inline "C_specialp" x))
183
184;; Byteblock
185
186(define-inline (%byteblock? x) (and (%block? x) (%byteblock-type? x)))
187
188;; Bytevector
189
190(define-inline (%bytevector? x) (and (%block? x) (%bytevector-type? x)))
191
192;; String
193
194(define-inline (%string? x) (and (%block? x) (%string-type? x)))
195
196;; Flonum
197
198(define-inline (%flonum? x) (and (%block? x) (%flonum-type? x)))
199
200;; Lambda-info
201
202(define-inline (%lambda-info? x) (and (%block? x) (%lambda-info-type? x)))
203
204;; Wordblock (special block)
205
206(define-inline (%wordblock? x) (and (%block? x) (%special? x)))
207
208;; Vector
209
210(define-inline (%vector? x) (and (%block? x) (%vector-type? x)))
211
212;; Pair
213
214(define-inline (%pair? x) (and (%block? x) (%pair-type? x)))
215
216;; Bucket
217
218; A bucket is used by the runtime for the symbol-table. The bucket type is not
219; "seen" by Scheme code.
220
221;; Structure
222
223(define-inline (%structure? x) (and (%block? x) (%structure-type? x)))
224
225;; Symbol
226
227(define-inline (%symbol? x) (and (%block? x) (%symbol-type? x)))
228
229;; Closure
230
231(define-inline (%closure? x) (and (%block? x) (%closure-type? x)))
232
233;; Port
234
235(define-inline (%port? x) (and (%block? x) (%port-type? x)))
236
237;; Any-pointer
238
239(define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))
240
241;; Simple-pointer
242
243(define-inline (%simple-pointer? x) (and (%block? x) (%simple-pointer-type? x)))
244
245;; Tagged-Pointer
246
247(define-inline (%tagged-pointer? x) (and (%block? x) (%tagged-pointer-type? x)))
248
249;; Swig-Pointer
250
251(define-inline (%swig-pointer? x) (and (%block? x) (%swig-pointer-type? x)))
252
253;; Locative
254
255(define-inline (%locative? x) (and (%block? x) (%locative-type? x)))
256
257;; Forwarded (block object moved to new address, forwarding pointer)
258
259(define-inline (%forwarded? x) (##core#inline "C_forwardedp" x))
260
261;;; Operations
262
263;Safe
264
265(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
266
267;; Fixnum
268
269;Safe
270
271(define-inline (%fxrandom x) (##core#inline "C_random_fixnum" x))
272
273;Unsafe
274
275(define-inline (%fx= x y) (%eq? x y))
276(define-inline (%fx> x y) (##core#inline "C_fixnum_greaterp" x y))
277(define-inline (%fx< x y) (##core#inline "C_fixnum_lessp" x y))
278(define-inline (%fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
279(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
280
281(define-inline (%fxclosed-right? l x h) (and (fx%< l x) (%fx<= x h)))
282(define-inline (%fxclosed? l x h) (and (%fx<= l x) (%fx<= x h)))
283(define-inline (%fxclosed-left? l x h) (and (%fx<= l x) (%fx< x h)))
284
285(define-inline (%fxzero? fx) (%fx= 0 fx))
286(define-inline (%fxpositive? fx) (%fx< 0 fx))
287(define-inline (%fxnegative? fx) (%fx< fx 0))
288(define-inline (%fxcardinal? fx) (%fx<= 0 fx))
289(define-inline (%fxodd? fx) (%fx= 1 (%fxand fx 1)))
290(define-inline (%fxeven? fx) (%fx= 0 (%fxand fx 1)))
291
292(define-inline (%fxmin x y) (if (%fx< x y) x y))
293(define-inline (%fxmax x y) (if (%fx< x y) y x))
294
295(define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
296(define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
297(define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
298(define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
299(define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))
300
301(define-inline (%fxadd1 fx) (##core#inline "C_fixnum_increase" fx))
302(define-inline (%fxsub1 fx) (##core#inline "C_fixnum_decrease" fx))
303
304(define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
305(define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
306
307(define-inline (%fxneg x) (##core#inline "C_fixnum_negate" x))
308(define-inline (%fxabs fx) (if (%fxnegative? fx) (%fxneg fx) fx))
309
310(define-inline (%fxand x y) (##core#inline "C_fixnum_and" x y))
311(define-inline (%fxior x y) (##core#inline "C_fixnum_or" x y))
312(define-inline (%fxxor x y) (##core#inline "C_fixnum_xor" x y))
313(define-inline (%fxnot x) (##core#inline "C_fixnum_not" x))
314
315;; Block
316
317(define-inline (%peek-signed-integer b i) ((##core#primitive "C_peek_signed_integer") b i))
318(define-inline (%peek-unsigned-integer b i) ((##core#primitive "C_peek_unsigned_integer") b i))
319(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
320
321;Safe
322
323(define-inline (%block-address b) (##core#inline_allocate ("C_block_address" 4) b))
324
325;; Size of object in units of sub-object.
326
327; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
328;
329; byteblock? #t - size is # of bytes, fill is-a character  -> "string"
330; byteblock? #f - size is # of words, fill is-a any        -> "vector"
331
332(define-inline (%block-allocate n bb? f a?) ((##core#primitive "C_allocate_vector") n bb? f a?))
333
334;Unsafe
335
336; Byteblock -> # of bytes
337; Wordblock -> # of words.
338
339(define-inline (%block-size b) (##core#inline "C_block_size" b))
340
341;;
342
343;; Byteblock
344
345;Safe
346
347(define-inline (%make-byteblock n f a?) (%block-allocate n #t f a?))
348
349;Unsafe
350
351(define-inline (%byteblock-length bb) (%block-size bb))
352
353(define-inline (%byteblock-ref bb i) (##core#inline "C_subbyte" bb i))
354
355(define-inline (%byteblock-set! bb i v) (##core#inline "C_setsubbyte" bb i v))
356
357;; Generic-byteblock
358
359;Safe
360
361; generic-byteblock isa bytevector, string, flonum, or lambda-info
362(define-inline (%generic-byteblock? x)
363  (or (%bytevector? x) (%string? x) (%flonum? x) (%lambda-info? x)) )
364
365;; Bytevector (byteblock)
366
367;Safe
368
369(define-inline (%make-bytevector sz)
370  (let ((bv (%make-byteblock sz #f #t)))
371    (##core#inline "C_string_to_bytevector" bv)
372    bv ) )
373
374(define-inline (%string->bytevector s)
375  (let* ((n (%byteblock-length s) #;(%string-size s))
376               (bv (%make-bytevector sz)) )
377    (##core#inline "C_copy_memory" bv s n)
378    bv ) )
379
380;Unsafe
381
382(define-inline (%bytevector-length bv) (%byteblock-length bv))
383
384(define-inline (%bytevector=? bv1 bv2)
385  (let ((n (%bytevector-length bv1)))
386    (and
387      (%fx= n (%bytevector-length bv2))
388      (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
389
390(define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
391
392(define-inline (%bytevector-set! bv i x) (%byteblock-set! bv i x))
393
394;; Blob (isa bytevector w/o accessors)
395
396(define-inline (%make-blob sz) (%make-bytevector sz))
397
398(define-inline (%string->blob s) (%string->bytevector s))
399
400(define-inline (%blob? x) (%bytevector? x))
401
402(define-inline (%blob-size b) (%bytevector-length b))
403
404(define-inline (%blob=? b1 b2) (%bytevector=? b1 b2))
405
406;; String (byteblock)
407
408;Safe
409
410(define-inline (%make-string size fill) (%make-byteblock size fill #f))
411
412;Unsafe
413
414(define-inline (%bytevector->string bv)
415  (let* ((n (%bytevector-length bv))
416               (s (%make-string n #\space)) )
417    (##core#inline "C_copy_memory" s bv n)
418    s ) )
419
420(define-inline (%blob->string bv) (%bytevector->string bv))
421
422(define-inline (%lambda-info->string li)
423  (let* ((sz (%byteblock-length li) #;(%lambda-info-length li))
424         (s (%make-string sz #\space)) )
425    (##core#inline "C_copy_memory" s li sz)
426    s ) )
427
428(define-inline (%string-size s) (%byteblock-length s))
429(define-inline (%string-length s) (%byteblock-length s))
430
431(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
432
433(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
434
435(define-inline (%string-compare/length s1 s2 l) (##core#inline "C_string_compare" s1 s2 l))
436
437(define-inline (%string-compare s1 s2)
438  (let* ((l1 (%string-length s1))
439         (l2 (%string-length s2))
440         (d (%fx- l1 l2))
441         (r (%string-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
442    (if (%fxzero? r)
443      d
444      r ) ) )
445
446(define-inline (%string=? s1 s2) (%fxzero? (%string-compare s1 s2)))
447(define-inline (%string<? s1 s2) (%fxnegative? (%string-compare s1 s2)))
448(define-inline (%string>? s1 s2) (%fxpositive? (%string-compare s1 s2)))
449(define-inline (%string<=? s1 s2) (%fx<= 0 (%string-compare s1 s2)))
450(define-inline (%string>=? s1 s2) (%fx>= 0 (%string-compare s1 s2)))
451
452(define-inline (%string-ci-compare/length s1 s2 l) (##core#inline "C_string_compare_case_insensitive" s1 s2 l))
453
454(define-inline (%string-ci-compare s1 s2)
455  (let* ((l1 (%string-length s1))
456         (l2 (%string-length s2))
457         (d (%fx- l1 l2))
458         (r (%string-ci-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
459    (if (%fxzero? r)
460      d
461      r ) ) )
462
463(define-inline (%string-ci=? s1 s2) (%fxzero? (%string-ci-compare s1 s2)))
464(define-inline (%string-ci<? s1 s2) (%fxnegative? (%string-ci-compare s1 s2)))
465(define-inline (%string-ci>? s1 s2) (%fxpositive? (%string-ci-compare s1 s2)))
466(define-inline (%string-ci<=? s1 s2) (%fx<= 0 (%string-ci-compare s1 s2)))
467(define-inline (%string-ci>=? s1 s2) (%fx>= 0 (%string-ci-compare s1 s2)))
468
469;; Flonum (byteblock)
470
471;Unsafe
472
473(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
474(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
475(define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y))
476(define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y))
477(define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y))
478
479(define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y))
480(define-inline (%fpmin x y) (##core#inline "C_i_flonum_min" x y))
481
482(define-inline (%finite? x) (##core#inline "C_i_finitep" x))
483
484(define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
485(define-inline (%fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
486(define-inline (%fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
487(define-inline (%fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
488
489(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
490
491(define-inline (%fpnegate x) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x))
492
493(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
494(define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x))
495(define-inline (%fpround x) ((##core#primitive "C_flonum_round") x))
496(define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x))
497
498;Safe
499
500(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
501
502; Actually 'number' operations
503(define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
504(define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
505(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
506(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
507(define-inline (%fpatan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
508(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
509(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
510(define-inline (%fplog x) (##core#inline_allocate ("C_a_i_log" 4) x))
511(define-inline (%fpsin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
512(define-inline (%fpsqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
513(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
514
515;; Lambda-info (byteblock)
516
517;Unsafe
518
519(define-inline (%string->lambda-info s)
520  (let* ((n (%string-size s))
521               (li (%make-string n)) )
522    (##core#inline "C_copy_memory" li s n)
523    (##core#inline "C_string_to_lambdainfo" li)
524    li ) )
525
526(define-inline (%lambda-info-length li) (%byteblock-length s))
527
528;; Wordblock
529
530;Safe
531
532(define-inline (%make-wordblock n f a?) (%block-allocate n #f f a?))
533
534;Unsafe
535
536(define-inline (%wordblock-length wb) (%block-size wb))
537
538(define-inline (%wordblock-ref wb i) (##core#inline "C_slot" wb i))
539
540(define-inline (%wordblock-set!/mutate wb i v) (##core#inline "C_i_setslot" wb i v))
541(define-inline (%wordblock-set!/immediate wb i v) (##core#inline "C_i_set_i_slot" wb i v))
542(define-inline (%wordblock-set! wb i v)
543  (if (%immediate? v)
544    (%wordblock-set!/immediate wb i v)
545    (%wordblock-set!/mutate wb i v) ) )
546
547;; Generic-vector (wordblock)
548
549; generic-vector isa vector, pair, structure, symbol, or keyword
550(define-inline (%generic-vector? x) (and (%block? x) (not (or (%special? x) (%byteblock? x)))))
551
552;; Vector (wordblock)
553
554;Safe
555
556(define-inline (%make-vector size fill) (%make-wordblock size fill #f))
557
558;Unsafe
559
560(define-inline (%vector-length v) (%wordblock-length v))
561
562(define-inline (%vector-ref v i) (%wordblock-ref v i))
563
564(define-inline (%vector-set!/mutate v i x) (%wordblock-set!/mutate v i x))
565(define-inline (%vector-set!/immediate v i x) (%wordblock-set!/immediate v i x))
566(define-inline (%vector-set! v i x) (%wordblock-set! v i x))
567
568;; Pair (wordblock)
569
570;Safe
571
572(define-inline (%null? x) (%eol-object? x))
573
574(define-inline (%list? x) (or (%null? x) (%pair? x)))
575
576(define-inline (%cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y) )
577
578(define-inline (%length ls) (##core#inline "C_i_length" ls))
579
580;Unsafe
581
582(define-inline (%car pr) (%wordblock-ref pr 0))
583
584(define-inline (%set-car!/mutate pr x) (%wordblock-set!/mutate pr 0 x))
585(define-inline (%set-car!/immediate pr x) (%wordblock-set!/immediate pr 0 x))
586(define-inline (%set-car! pr x) (%wordblock-set! pr 0 x))
587
588(define-inline (%cdr pr) (%wordblock-ref pr 1))
589
590(define-inline (%set-cdr!/mutate pr x) (%wordblock-set!/mutate pr 1 x))
591(define-inline (%set-cdr!/immediate pr x) (%wordblock-set!/immediate pr 1 x))
592(define-inline (%set-cdr! pr x) (%wordblock-set! pr 1 x))
593
594(define-inline (%caar pr) (%car (%car pr)))
595(define-inline (%cadr pr) (%car (%cdr pr)))
596(define-inline (%cdar pr) (%cdr (%car pr)))
597(define-inline (%cddr pr) (%cdr (%cdr pr)))
598
599(define-inline (%caaar pr) (%car (%caar pr)))
600(define-inline (%caadr pr) (%car (%cadr pr)))
601(define-inline (%cadar pr) (%car (%cdar pr)))
602(define-inline (%caddr pr) (%car (%cddr pr)))
603(define-inline (%cdaar pr) (%cdr (%caar pr)))
604(define-inline (%cdadr pr) (%cdr (%cadr pr)))
605(define-inline (%cddar pr) (%cdr (%cdar pr)))
606(define-inline (%cdddr pr) (%cdr (%cddr pr)))
607
608;Safe
609
610(define-inline (%memq x ls) (##core#inline "C_i_memq" x ls))
611(define-inline (%memv x ls) (##core#inline "C_i_memv" x ls))
612(define-inline (%member x ls) (##core#inline "C_i_member" x ls))
613
614(define-inline (%assq x ls) (##core#inline "C_i_assq" x ls))
615(define-inline (%assv x ls) (##core#inline "C_i_assv" x ls))
616(define-inline (%assoc x ls) (##core#inline "C_i_assoc" x ls))
617
618;Unsafe
619
620(define-inline (%list-ref ls0 i0)
621  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
622  (let loop ((ls ls0) (i i0))
623    (cond
624      ((%null? ls)  '() )
625      ((%fx= 0 i)   (%car ls) )
626      (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
627
628(define-inline (%list-pair-ref ls0 i0)
629  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
630  (let loop ((ls ls0) (i i0))
631    (cond
632      ((%null? ls)  '() )
633      ((%fx= 0 i)   ls )
634      (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
635
636(define-inline (%last-pair ls0)
637  ;(assert (and (proper-list? ls0) (pair? ls0)))
638  (do ((ls ls0 (%cdr ls)))
639      ((%null? (%cdr ls)) ls)) )
640
641(define-inline (%list-copy ls0)
642  ;(assert (proper-list? ls0))
643  (let copy-rest ((ls ls0))
644    (if (%null? ls)
645      '()
646      (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
647
648(define-inline (%append! . lss)
649  ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
650  (let ((lss
651          (let position-at-first-pair ((lss lss))
652            (cond
653              ((%null? lss)        '() )
654              ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
655              (else                 lss ) ) ) ) )
656    (if (%null? lss)
657      '()
658      (let ((ls0 (%car lss)))
659        ;(assert (pair? ls0))
660        (let append!-rest ((lss (%cdr lss)) (pls ls0))
661          (if (%null? lss)
662            ls0
663            (let ((ls (%car lss)))
664              (cond
665                ((%null? ls)
666                  (append!-rest (%cdr lss) pls) )
667                (else
668                  (%set-cdr!/mutate (%last-pair pls) ls)
669                  (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
670
671(define-inline (%delq! x ls0)
672  ;(assert (proper-list? ls0))
673  (let find-elm ((ls ls0) (ppr #f))
674    (cond
675      ((%null? ls)
676       ls0 )
677      ((%eq? x (%car ls))
678        (cond
679          (ppr
680            (%set-cdr! ppr (%cdr ls))
681            ls0 )
682          (else
683            (%cdr ls) ) ) )
684      (else
685        (find-elm (%cdr ls) ls) ) ) ) )
686
687(define-inline (%list-fold/1 func init ls0)
688  ;(assert (and (proper-list? ls0) (procedure? func)))
689  (let loop ((ls ls0) (acc init))
690    (if (%null? ls)
691      acc
692      (loop (%cdr ls) (func (%car ls) acc)) ) ) )
693
694(define-inline (%list-map/1 func ls0)
695  ;(assert (and (proper-list? ls0) (procedure? func)))
696  (let loop ((ls ls0))
697    (if (%null? ls)
698      '()
699      (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
700
701(define-inline (%list-for-each/1 proc ls0)
702  ;(assert (and (proper-list? ls0) (procedure? proc)))
703  (let loop ((ls ls0))
704    (unless (%null? ls)
705      (proc (%car ls))
706      (loop (%cdr ls)) ) ) )
707
708(define-inline (%list/1 obj) (%cons obj '()))
709
710(define-inline (%list . objs)
711  (let loop ((objs objs))
712    (if (%null? objs)
713      '()
714      (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
715
716(define-inline (%make-list n e)
717  (let loop ((n n) (ls '()))
718    (if (%fxzero? n)
719      ls
720      (loop (%fxsub1 n) (%cons e ls)) ) ) )
721
722(define-inline (%list-take ls0 n)
723  (let loop ((ls ls0) (n n))
724    (if (%fxzero? n)
725      '()
726      (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
727
728(define-inline (%list-drop ls0 n)
729  (let loop ((ls ls0) (n n))
730    (if (%fxzero? n)
731      ls
732      (loop (%cdr ls) (%fxsub1 n)) ) ) )
733
734(define-inline (%list-any/1 pred? ls)
735  (let loop ((ls ls))
736    (and
737      (not (%null? ls))
738      (or
739        (pred? (%car ls))
740        (loop (%cdr ls)) ) ) ) )
741
742(define-inline (%list-every/1 pred? ls)
743  (let loop ((ls ls) (last #t))
744    (if (%null? ls)
745      last
746      (let ((this (pred? (%car ls))))
747        (and
748          this
749          (loop (%cdr ls) this)) ) ) ) )
750
751(define-inline (%list-length ls0)
752  (let loop ((ls ls0) (n 0))
753    (if (%null? ls)
754      n
755      (loop (%cdr ls) (%fxadd1 n)) ) ) )
756
757(define-inline (%list-find pred? ls)
758  (let loop ((ls ls))
759    (and
760      (not (%null? ls))
761      (or
762        (let ((elm (%car ls))) (and (pred? elm) elm))
763        (loop (%cdr ls)) ) ) ) )
764
765(define-inline (%alist-ref key al #!optional (test eqv?) def)
766  (let loop ((al al))
767    (cond
768      ((%null? al) def )
769      ((test key (%caar al)) (%cdar al) )
770      (else (loop (%cdr al)) ) ) ) )
771
772(define-inline (%alist-update! key val al0 #!optional (test eqv?))
773  (let loop ((al al0))
774    (cond
775      ((%null? al) (%cons (%cons key val) al0) )
776      ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
777      (else (loop (%cdr al)) ) ) ) )
778
779(define-inline (%alist-delete! key al0 #!optional (test equal?))
780  (let loop ((al al0) (prv #f))
781    (cond
782      ((%null? al) al0)
783      ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
784      (else (loop (%cdr al) al) ) ) ) )
785
786;; Structure (wordblock)
787
788(define-inline (%make-structure t . s) (apply (##core#primitive "C_make_structure") t s))
789
790(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
791
792(define-inline (%structure-length r) (%wordblock-length r))
793
794(define-inline (%structure-tag r) (%wordblock-ref r 0))
795
796(define-inline (%structure-ref r i) (%wordblock-ref r i))
797
798(define-inline (%structure-set!/mutate r i x) (%wordblock-set!/mutate r i x))
799(define-inline (%structure-set!/immediate r i x) (%wordblock-set!/immediate r i x))
800(define-inline (%structure-set! r i x) (%wordblock-set! r i x))
801
802;; Port (wordblock)
803
804; Port layout:
805;
806; 0       FP (special - FILE *)
807; 1       input/output (bool)
808; 2       class (vector, see Port-class)
809; 3       name (string)
810; 4       row (fixnum)
811; 5       col (fixnum)
812; 6       EOF (bool)
813; 7       type (symbol)
814; 8       closed (bool)
815; 9       data
816; 10-15  reserved, port class specific
817
818(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
819(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
820(define-inline (%port-class port) (%wordblock-ref port 2))
821(define-inline (%port-name port) (%wordblock-ref port 3))
822(define-inline (%port-row port) (%wordblock-ref port 4))
823(define-inline (%port-column port) (%wordblock-ref port 5))
824(define-inline (%port-eof? port) (%wordblock-ref port 6))
825(define-inline (%port-type port) (%wordblock-ref port 7))
826(define-inline (%port-closed? port) (%wordblock-ref port 8))
827(define-inline (%port-data port) (%wordblock-ref port 9))
828
829(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
830(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
831
832(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
833(define-inline (%port-input-mode-set! port f) (%wordblock-set!/immediate port 1 f))
834(define-inline (%port-class-set! port v) (%wordblock-set!/mutate port 2 v))
835(define-inline (%port-name-set! port s) (%wordblock-set!/mutate port 3 s))
836(define-inline (%port-row-set! port n) (%wordblock-set!/immediate port 4 n))
837(define-inline (%port-column-set! port n) (%wordblock-set!/immediate port 5 n))
838(define-inline (%port-eof-set! port f) (%wordblock-set!/immediate port 6 f))
839(define-inline (%port-type-set! port s) (%wordblock-set!/mutate port 7 s))
840(define-inline (%port-closed-set! port f) (%wordblock-set!/immediate port 8 f))
841(define-inline (%port-data-set! port x) (%wordblock-set!/mutate port 9 x))
842
843(define-inline (%make-port i/o class name type)
844  ; port is 16 slots + a block-header word
845  (let ((port (##core#inline_allocate ("C_a_i_port" 17))))
846    (%port-input-mode-set! port i/o)
847    (%port-class-set! port class)
848    (%port-name-set! port name)
849    (%port-row-set! port 1)
850    (%port-column-set! port 0)
851    (%port-type-set! port type)
852    port ) )
853
854; Port-class layout
855;
856; 0       (read-char PORT) -> CHAR | EOF
857; 1       (peek-char PORT) -> CHAR | EOF
858; 2       (write-char PORT CHAR)
859; 3       (write-string PORT STRING)
860; 4       (close PORT)
861; 5       (flush-output PORT)
862; 6       (char-ready? PORT) -> BOOL
863; 7       (read-string! PORT COUNT STRING START) -> COUNT'
864; 8       (read-line PORT LIMIT) -> STRING | EOF
865
866(define-inline (%make-port-class rc pc wc ws cl fl cr rs rl)
867  (let ((class (%make-vector 9 #f)))
868    (%vector-set! class 0 rc)
869    (%vector-set! class 1 pc)
870    (%vector-set! class 2 wc)
871    (%vector-set! class 3 ws)
872    (%vector-set! class 4 cl)
873    (%vector-set! class 5 fl)
874    (%vector-set! class 6 cr)
875    (%vector-set! class 7 rs)
876    (%vector-set! class 8 rl)
877    class ) )
878
879(define-inline (%port-class-read-char-ref c) (%vector-ref c 0))
880(define-inline (%port-class-peek-char-ref c) (%vector-ref c 1))
881(define-inline (%port-class-write-char-ref c) (%vector-ref c 2))
882(define-inline (%port-class-write-string-ref c) (%vector-ref c 3))
883(define-inline (%port-class-close-ref c) (%vector-ref c 4))
884(define-inline (%port-class-flush-output-ref c) (%vector-ref c 5))
885(define-inline (%port-class-char-ready-ref c) (%vector-ref c 6))
886(define-inline (%port-class-read-string-ref c) (%vector-ref c 7))
887(define-inline (%port-class-read-line-ref c) (%vector-ref c 8))
888
889(define-inline (%port-class-read-char c p) ((%port-class-read-char-ref c) p) )
890(define-inline (%port-class-peek-char c p) ((%port-class-peek-char-ref c) p))
891(define-inline (%port-class-write-char c p c) ((%port-class-write-char-ref c) p c))
892(define-inline (%port-class-write-string c p s) ((%port-class-write-string-ref c) p s))
893(define-inline (%port-class-close c p) ((%port-class-close-ref c) p))
894(define-inline (%port-class-flush-output c p) ((%port-class-flush-output-ref c) p))
895(define-inline (%port-class-char-ready? c p) ((%port-class-char-ready-ref c) p))
896(define-inline (%port-class-read-string! c p n d s) ((%port-class-read-string-ref c) p n d s))
897(define-inline (%port-class-read-line c p l) ((%port-class-read-line-ref c) p l))
898
899(define-inline (%port-read-char p) ((%port-class-read-char-ref (%port-class p)) p) )
900(define-inline (%port-peek-char p) ((%port-class-peek-char-ref (%port-class p)) p))
901(define-inline (%port-write-char p c) ((%port-class-write-char-ref (%port-class p)) p c))
902(define-inline (%port-write-string p s) ((%port-class-write-string-ref (%port-class p)) p s))
903(define-inline (%port-close p) ((%port-class-close-ref (%port-class p)) p))
904(define-inline (%port-flush-output p) ((%port-class-flush-output-ref (%port-class p)) p))
905(define-inline (%port-char-ready? p) ((%port-class-char-ready-ref (%port-class p)) p))
906(define-inline (%port-read-string! p n d s) ((%port-class-read-string-ref (%port-class p)) p n d s))
907(define-inline (%port-read-line p l) ((%port-class-read-line-ref (%port-class p)) p l))
908
909;; Closure (wordblock)
910
911;Unsafe
912
913(define-inline (%make-closure! n)
914  (let ((v (%make-vector n)))
915    (##core#inline "C_vector_to_closure" v)
916    v ) )
917
918(define-inline (%procedure? x) (%closure? x))
919
920(define-inline (%vector->closure! v a)
921  (##core#inline "C_vector_to_closure" v)
922  (##core#inline "C_update_pointer" a v) )
923
924(define-inline (%closure-length c) (%wordblock-length? c))
925
926(define-inline (%closure-ref c i) (%wordblock-ref c i))
927
928(define-inline (%closure-set! c i v) (%wordblock-set! c i v))
929
930(define-inline (%closure-copy tc fc l)
931  (do ((i 1 (%fxadd1 i)))
932      ((%fx>= i l))
933    (%closure-set! tc i (%closure-ref fc i)) ) )
934
935(define-inline (%closure-decoration c test)
936  (let find-decor ((i (%fxsub1 (%closure-length c))))
937    (and
938      (%fxpositive? i)
939      (let ((x (%closure-ref c i)))
940        (if (test x)
941          x
942          (find-decor (%fxsub1 i)) ) ) ) ) )
943
944(define-inline (%closure-decorate! c test dcor)
945  (let ((l (%closure-length c)))
946    (let find-decor ((i (%fxsub l)))
947      (cond
948        ((%fxzero? i)
949          (let ((nc (%make-closure (%fxadd1 l))))
950            (%closure-copy nc c l)
951            (##core#inline "C_copy_pointer" c nc)
952            (dcor nc i) ) )
953        (else
954          (let ((x (%closure-ref c i)))
955            (if (test x)
956              (dcor c i)
957              (find-decor (%fxsub i)) ) ) ) ) ) ) )
958
959(define-inline (%closure-lambda-info c)
960  (%closure-decoration c (lambda (x) (%lambda-info? x))) )
961
962;; Symbol (wordblock)
963
964;Unsafe
965
966(define-inline (%symbol-binding s) (%wordblock-ref s 0))
967(define-inline (%symbol-string s) (%wordblock-ref s 1))
968(define-inline (%symbol-bucket s) (%wordblock-ref s 2))
969
970(define-constant NAMESPACE-MAX-ID-LEN 31)
971
972(define-inline (%qualified-symbol? s)
973  (let ((str (%symbol-string s)))
974    (and
975      (%fxpositive? (%string-size str))
976      (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
977
978;Safe
979
980(define-inline (%string->symbol-interned s) ((##core#primitive "C_string_to_symbol") s))
981
982(define-inline (%symbol-interned? x) (##core#inline "C_lookup_symbol" x))
983
984(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))
985
986;; Keyword (wordblock)
987
988(define-inline (%keyword? x) (and (%symbol? x) (%fxzero? (%byteblock-ref (%symbol-string x) 0))))
989
990;; Pointer (wordblock)
991
992; simple-pointer, tagged-pointer, swig-pointer, locative
993(define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
994
995; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
996(define-inline (%pointer-like? x) (%wordblock? x))
997
998; These operate on pointer-like objects
999
1000(define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
1001
1002(define-inline (%pointer-ref ptr) (%wordblock-ref ptr 0))
1003(define-inline (%pointer-set! ptr y) (%wordblock-set!/mutate ptr 0 y))
1004
1005(define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
1006
1007(define-inline (%pointer->address ptr)
1008  ; Pack pointer address value into Chicken words; '4' is platform dependent!
1009  (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref ptr)) )
1010
1011;; Simple-pointer (wordblock)
1012
1013(define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))
1014
1015(define-inline (%make-pointer-null)
1016  (let ((ptr (%make-simple-pointer)))
1017    (##core#inline "C_update_pointer" 0 ptr)
1018    ptr ) )
1019
1020(define-inline (%address->pointer a)
1021  (let ((ptr (%make-simple-pointer)))
1022    (##core#inline "C_update_pointer" a ptr)
1023    ptr ) )
1024
1025(define-inline (%make-block-pointer b)
1026  (let ((ptr (%make-simple-pointer)))
1027    (##core#inline "C_pointer_to_block" ptr b)
1028    ptr ) )
1029
1030;; Tagged-pointer (wordblock)
1031
1032(define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))
1033
1034;; Swig-pointer (wordblock)
1035
1036;; Locative (wordblock)
1037
1038(define-inline (%make-locative typ obj idx weak?)
1039  (##core#inline_allocate ("C_a_i_make_locative" 5) typ obj idx weak?))
1040
1041; Locative layout:
1042;
1043; 0     Object-address + byte-offset (address)
1044; 1     Byte-offset (fixnum)
1045; 2     Type (fixnum)
1046;         0     vector or pair          (C_SLOT_LOCATIVE)
1047;         1     string                  (C_CHAR_LOCATIVE)
1048;         2     u8vector                (C_U8_LOCATIVE)
1049;         3     s8vector or bytevector  (C_U8_LOCATIVE)
1050;         4     u16vector                           (C_U16_LOCATIVE)
1051;         5     s16vector                           (C_S16_LOCATIVE)
1052;         6     u32vector                           (C_U32_LOCATIVE)
1053;         7     s32vector                           (C_S32_LOCATIVE)
1054;         8     f32vector                           (C_F32_LOCATIVE)
1055;         9     f64vector                           (C_F64_LOCATIVE)
1056; 3     Object or #f, if weak (C_word)
1057
1058(define-inline (%locative-address lv) (%pointer->address lv))
1059
1060(define-inline (%locative-offset lv) (%wordblock-ref lv 1))
1061(define-inline (%locative-type lv) (%wordblock-ref lv 2))
1062(define-inline (%locative-weak? lv) (not (%wordblock-ref lv 3)))
1063(define-inline (%locative-object lv) (%wordblock-ref lv 3))
1064
1065;; Numbers
1066
1067;Safe
1068
1069(define-inline (%number? x) (or (%fixnum? x) (%flonum? x)))
1070(define-inline (%integer? x) (##core#inline "C_i_integerp" x))
1071(define-inline (%exact? x) (##core#inline "C_i_exactp" x))
1072(define-inline (%inexact? x) (##core#inline "C_i_inexactp" x))
1073
1074(define-inline (%= x y) (##core#inline "C_i_eqvp" x y))
1075(define-inline (%< x y) (##core#inline "C_i_lessp" x y))
1076(define-inline (%<= x y) (##core#inline "C_i_less_or_equalp" x y))
1077(define-inline (%> x y) (##core#inline "C_i_greaterp" x y))
1078(define-inline (%>= x y) (##core#inline "C_i_greater_or_equalp" x y))
1079
1080(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
1081(define-inline (%positive? n) (##core#inline "C_i_positivep" n))
1082(define-inline (%negative? n) (##core#inline "C_i_negativep" n))
1083(define-inline (%cardinal? fx) (%<= 0 fx))
1084
1085(define-inline (%odd? n) (##core#inline "C_i_oddp" n))
1086(define-inline (%even? n) (##core#inline "C_i_evenp" n))
1087
1088(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
1089(define-inline (%- x y) ((##core#primitive "C_minus") x y))
1090(define-inline (%* x y) ((##core#primitive "C_times") x y))
1091(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
1092
1093(define-inline (%add1 x) (%+ x 1))
1094(define-inline (%sub1 x) (%- x 1))
1095
1096(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
1097(define-inline (%remainder x y) (let ((quo (%quotient x y))) (%- x (%* quo y))))
1098
1099(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
1100(define-inline (%abs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
1101(define-inline (%acos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
1102(define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
1103(define-inline (%atan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
1104(define-inline (%atan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
1105(define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
1106(define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
1107(define-inline (%log x) (##core#inline_allocate ("C_a_i_log" 4) x))
1108(define-inline (%sin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
1109(define-inline (%sqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
1110(define-inline (%tan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
1111
1112(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
1113(define-inline (%bitwise-xor x y) (##core#inline_allocate ("C_a_i_bitwise_xor" 4) x y))
1114(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
1115(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
1116
1117(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
1118
1119(define-inline (%bit-set? n i) (##core#inline "C_i_bit_setp" n i))
1120
1121(define-inline (%randomize n) (##core#inline "C_randomize" n))
1122
1123;;; Operations
1124
1125;Safe
1126
1127(define-inline (%->boolean obj) (and obj #t))
1128
1129(define-inline (%make-unique-object #!optional id) (if id (%make-vector 1 id) '#()))
Note: See TracBrowser for help on using the repository browser.