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

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

Rmvd dup. Added opers.

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