Changeset 13667 in project


Ignore:
Timestamp:
03/10/09 13:13:32 (11 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/4/err5rs-arithmetic/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/err5rs-arithmetic/trunk/chicken-primitive-object-inlines.scm

    r13619 r13667  
    88
    99;; 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 
     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
     37;;; Unsafe Type Predicates
    4238
    4339;; Immediate
     
    4541(define-inline (%immediate? x) (##core#inline "C_immp" x))
    4642
    47 
    4843;; Fixnum
    4944
    5045(define-inline (%fixnum-type? x) (##core#inline "C_fixnump" x))
    5146
    52 (define-inline (%fixnum? x) (and (%immediate? x) (%fixnum-type? x)))
    53 
    54 
    5547;; Character
    5648
    5749(define-inline (%char-type? x) (##core#inline "C_charp" x))
    5850
    59 (define-inline (%char? x) (and (%immediate? x) (%char-type? x)))
    60 
    61 
    6251;; Boolean
    6352
    6453(define-inline (%boolean-type? x) (##core#inline "C_booleanp" x))
    6554
    66 (define-inline (%boolean? x) (and (%immediate? x) (%boolean-type? x)))
    67 
    68 (define-inline (%true-value? x) (and (%boolean? x) (##core#inline "C_and" x #t)))
    69 
    70 (define-inline (%false-value? x) (not (%true-value? x)))
    71 
    72 
    7355;; EOF
    7456
    7557(define-inline (%eof-object-type? x) (##core#inline "C_eofp" x))
    7658
    77 (define-inline (%eof-object? x) (and (%immediate? x) (%eof-object-type? x)))
    78 
    79 
    8059;; Null (the end-of-list value)
    8160
    8261(define-inline (%eol-object-type? x) (##core#inline "C_i_nullp" x))
    8362
    84 (define-inline (%eol-object? x) (and (%immediate? x) (%eol-object-type? x)))
    85 
    86 
    8763;; Undefined (void)
    8864
    8965(define-inline (%undefined-type? x) (##core#inline "C_undefinedp" x))
    9066
    91 (define-inline (%undefined-value? x) (and (%immediate? x) (%undefined-type? x)))
    92 
    93 (define-inline (%undefined-value) (##core#undefined))
    94 
    95 
    9667;; Unbound (the unbound value, not 'is a symbol unbound')
    9768
    9869(define-inline (%unbound-type? x) (##core#inline "C_unboundvaluep" x))
    9970
    100 (define-inline (%unbound-value? x) (and (%immediate? x) (%unbound-type? x)))
    101 
    102 
    10371;; Block (anything not immediate)
    10472
    10573(define-inline (%block? x) (##core#inline "C_blockp" x))
    10674
    107 
    10875;; Special
    10976
    11077(define-inline (%special? x) (##core#inline "C_specialp" x))
    11178
     79;; Byteblock
     80
     81(define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))
     82
     83;; Bytevector
     84
     85(define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))
     86
     87;; String
     88
     89(define-inline (%string-type? x) (##core#inline "C_stringp" x))
     90
     91;; Flonum
     92
     93(define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
     94
     95;; Lambda-info
     96
     97(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
    11298
    11399;; Wordblock (special block)
     
    115101(define-inline (%wordblock? x) (and (%block? x) (%special? x)))
    116102
    117 
    118 ;; Byteblock
    119 
    120 (define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))
    121 
    122 (define-inline (%byteblock? x) (and (%block? x) (%byteblock-type? x)))
    123 
    124 
    125103;; Vector
    126104
    127105(define-inline (%vector-type? x) (##core#inline "C_vectorp" x))
    128106
    129 (define-inline (%vector? x) (and (%block? x) (%vector-type? x)))
    130 
    131 
    132 ;; Bytevector (isa vector so be careful; refers to how allocated, not what stored)
    133 
    134 (define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))
    135 
    136 (define-inline (%bytevector? x) (and (%block? x) (%bytevector-type? x)))
    137 
    138 
    139107;; Pair
    140108
    141109(define-inline (%pair-type? x) (##core#inline "C_pairp" x))
    142 
    143 (define-inline (%pair? x) (and (%block? x) (%pair-type? x)))
    144 
    145110
    146111;; Bucket
     
    149114; "seen" by Scheme code.
    150115
    151 
    152116;; Structure
    153117
    154118(define-inline (%structure-type? x) (##core#inline "C_structurep" x))
    155119
     120;; Symbol
     121
     122(define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
     123
     124;; Closure
     125
     126(define-inline (%closure-type? x) (##core#inline "C_closurep" x))
     127
     128;; Port
     129
     130(define-inline (%port-type? x) (##core#inline "C_portp" x))
     131
     132;; Any-pointer
     133
     134(define-inline (%any-pointer-type? x) (##core#inline "C_anypointerp" x))
     135
     136;; Simple-pointer
     137
     138(define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
     139
     140;; Tagged-Pointer
     141
     142(define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
     143
     144;; Swig-Pointer
     145
     146(define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
     147
     148;; Locative
     149
     150(define-inline (%locative-type? x) (##core#inline "C_locativep" x))
     151
     152
     153;;; Safe Type Predicates
     154
     155;; Immediate
     156
     157(define-inline (%immediate? x) (##core#inline "C_immp" x))
     158
     159;; Fixnum
     160
     161(define-inline (%fixnum? x) (and (%immediate? x) (%fixnum-type? x)))
     162
     163;; Character
     164
     165(define-inline (%char? x) (and (%immediate? x) (%char-type? x)))
     166
     167;; Boolean
     168
     169(define-inline (%boolean? x) (and (%immediate? x) (%boolean-type? x)))
     170
     171(define-inline (%true-value? x) (and (%boolean? x) (##core#inline "C_and" x #t)))
     172(define-inline (%false-value? x) (not (%true-value? x)))
     173
     174;; EOF
     175
     176(define-inline (%eof-object? x) (and (%immediate? x) (%eof-object-type? x)))
     177
     178;; Null (the end-of-list value)
     179
     180(define-inline (%eol-object? x) (and (%immediate? x) (%eol-object-type? x)))
     181
     182;; Undefined (void)
     183
     184(define-inline (%undefined-value? x) (and (%immediate? x) (%undefined-type? x)))
     185
     186(define-inline (%undefined-value) (##core#undefined))
     187
     188;; Unbound (the unbound value, not 'is a symbol unbound')
     189
     190(define-inline (%unbound-value? x) (and (%immediate? x) (%unbound-type? x)))
     191
     192;; Block (anything not immediate)
     193
     194(define-inline (%block? x) (##core#inline "C_blockp" x))
     195
     196;; Special
     197
     198(define-inline (%special? x) (##core#inline "C_specialp" x))
     199
     200;; Byteblock
     201
     202(define-inline (%byteblock? x) (and (%block? x) (%byteblock-type? x)))
     203
     204;; Bytevector
     205
     206(define-inline (%bytevector? x) (and (%block? x) (%bytevector-type? x)))
     207
     208;; String
     209
     210(define-inline (%string? x) (and (%block? x) (%string-type? x)))
     211
     212;; Flonum
     213
     214(define-inline (%flonum? x) (and (%block? x) (%flonum-type? x)))
     215
     216;; Lambda-info
     217
     218(define-inline (%lambda-info? x) (and (%block? x) (%lambda-info-type? x)))
     219
     220;; Wordblock (special block)
     221
     222(define-inline (%wordblock? x) (and (%block? x) (%special? x)))
     223
     224;; Vector
     225
     226(define-inline (%vector? x) (and (%block? x) (%vector-type? x)))
     227
     228;; Pair
     229
     230(define-inline (%pair? x) (and (%block? x) (%pair-type? x)))
     231
     232;; Bucket
     233
     234; A bucket is used by the runtime for the symbol-table. The bucket type is not
     235; "seen" by Scheme code.
     236
     237;; Structure
     238
    156239(define-inline (%structure? x) (and (%block? x) (%structure-type? x)))
    157240
    158 
    159241;; Symbol
    160242
    161 (define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
    162 
    163243(define-inline (%symbol? x) (and (%block? x) (%symbol-type? x)))
    164244
    165 
    166 ;; String
    167 
    168 (define-inline (%string-type? x) (##core#inline "C_stringp" x))
    169 
    170 (define-inline (%string? x) (and (%block? x) (%string-type? x)))
    171 
    172 
    173 ;; Flonum
    174 
    175 (define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
    176 
    177 (define-inline (%flonum? x) (and (%block? x) (%flonum-type? x)))
    178 
    179 
    180 ;; Lambda-info
    181 
    182 (define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
    183 
    184 (define-inline (%lambda-info? x) (and (%block? x) (%lambda-info-type? x)))
    185 
    186 
    187245;; Closure
    188246
    189 (define-inline (%closure-type? x) (##core#inline "C_closurep" x))
    190 
    191247(define-inline (%closure? x) (and (%block? x) (%closure-type? x)))
    192248
    193 
    194249;; Port
    195250
    196 (define-inline (%port-type? x) (##core#inline "C_portp" x))
    197 
    198251(define-inline (%port? x) (and (%block? x) (%port-type? x)))
    199252
     253;; Any-pointer
     254
     255(define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))
    200256
    201257;; Simple-pointer
    202258
    203 (define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
    204 
    205259(define-inline (%simple-pointer? x) (and (%block? x) (%simple-pointer-type? x)))
    206260
    207 
    208261;; Tagged-Pointer
    209262
    210 (define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
    211 
    212263(define-inline (%tagged-pointer? x) (and (%block? x) (%tagged-pointer-type? x)))
    213264
    214 
    215265;; Swig-Pointer
    216266
    217 (define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
    218 
    219267(define-inline (%swig-pointer? x) (and (%block? x) (%swig-pointer-type? x)))
    220268
    221 
    222 ;; Any-pointer
    223 
    224 (define-inline (%any-pointer-type? x) (##core#inline "C_anypointerp" x))
    225 
    226 (define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))
    227 
    228 
    229269;; Locative
    230270
    231 (define-inline (%locative-type? x) (##core#inline "C_locativep" x))
    232 
    233271(define-inline (%locative? x) (and (%block? x) (%locative-type? x)))
    234272
    235 
    236273;; Forwarded (block object moved to new address, forwarding pointer)
    237274
     
    239276
    240277
    241 
    242 ;;; Values
    243 
    244 
    245278;;; Operations
     279
     280;Safe
    246281
    247282(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
     
    251286(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
    252287
    253 
    254288;; Fixnum
    255289
    256 (define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
    257 (define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
    258 (define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
     290;Safe
     291
     292(define-inline (%fxrandom x) (##core#inline "C_random_fixnum" x))
     293
     294;Unsafe
     295
    259296(define-inline (%fx= x y) (%eq? x y))
    260297(define-inline (%fx> x y) (##core#inline "C_fixnum_greaterp" x y))
     
    262299(define-inline (%fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
    263300(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
     301
     302(define-inline (%fxclosed-right? l x h) (and (%< l obj) (%fx<= obj h)))
     303(define-inline (%fxclosed? l x h) (and (%<= l obj) (%fx<= obj h)))
     304(define-inline (%fxclosed-left? l x h) (and (%<= l obj) (%fx< obj h)))
     305
     306(define-inline (%fxzero? fx) (%fx= 0 fx))
     307(define-inline (%fxpositive? fx) (%fx< 0 fx))
     308(define-inline (%fxnegative? fx) (%fx< fx 0))
     309(define-inline (%fxcardinal? fx) (%fx<= 0 fx))
     310(define-inline (%fxodd? fx) (%fx= 1 (%fxand fx 1)))
     311(define-inline (%fxeven? fx) (%fx= 0 (%fxand fx 1)))
     312
    264313(define-inline (%fxmin x y) (##core#inline "C_i_fixnum_min" x y))
    265314(define-inline (%fxmax x y) (##core#inline "C_i_fixnum_max" x y))
     315
     316(define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
     317(define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
     318(define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
     319(define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
     320(define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))
     321
     322(define-inline (%fxadd1 fx) (##core#inline "C_fixnum_increase" fx))
     323(define-inline (%fxsub1 fx) (##core#inline "C_fixnum_decrease" fx))
     324
     325(define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
     326(define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
     327
    266328(define-inline (%fxneg x) (##core#inline "C_fixnum_negate" x))
     329(define-inline (%fxabs fx) (if (%fxnegative? fx) (%fxneg fx) fx))
     330
    267331(define-inline (%fxand x y) (##core#inline "C_fixnum_and" x y))
    268332(define-inline (%fxior x y) (##core#inline "C_fixnum_or" x y))
    269333(define-inline (%fxxor x y) (##core#inline "C_fixnum_xor" x y))
    270334(define-inline (%fxnot x) (##core#inline "C_fixnum_not" x))
    271 (define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
    272 (define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
    273 
    274 ; These are very unsafe, no check for division-by-zero
    275 (define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
    276 (define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))
    277 
    278 
    279 ;;; Block
    280 
     335
     336;; Block
     337
     338;Safe
     339
     340(define-inline (%block-address b) (##core#inline_allocate ("C_block_address" 4) b))
    281341
    282342;; Size of object in units of sub-object.
    283343
    284 ; byteblock is # of bytes, otherwise # of words.
     344; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
    285345;
    286 (define-inline (%block-size x) (##core#inline "C_block_size" x))
    287 
    288 
    289 ;; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
    290 ;
    291 ; Creates & returns a string when 'byteblock?', otherwise a vector.
    292 ;
    293 ; Size is # of bytes when 'byteblock?', otherwise # of words.
    294 ; Fill is a character when 'byteblock?', otherwise any.
    295 ;
    296 (define-inline (%block-allocate n bb f a) ((##core#primitive "C_allocate_vector") n bb f a))
    297 
    298 (define-inline (%block-address x) (##core#inline_allocate ("C_block_address" 4) x))
    299 
    300 
    301 ;; Byte access
     346; byteblock? #t - size is # of bytes, fill is-a character  -> "string"
     347; byteblock? #f - size is # of words, fill is-a any        -> "vector"
     348
     349(define-inline (%block-allocate n bb? f a?) ((##core#primitive "C_allocate_vector") n bb? f a?))
     350
     351;Unsafe
     352
     353; Byteblock -> # of bytes
     354; Wordblock -> # of words.
     355
     356(define-inline (%block-size b) (##core#inline "C_block_size" b))
     357
     358;;
     359
     360;; Byteblock
     361
     362;Safe
    302363
    303364(define-inline (%make-byteblock n f a?) (%block-allocate n #t f a?))
    304365
    305 (define-inline (%byteblock-ref x i) (##core#inline "C_subbyte" x i))
    306 (define-inline (%byteblock-set! x i n) (##core#inline "C_setsubbyte" x i n))
    307 
    308 
    309 ;; Word access
    310 
    311 (define-inline (%make-wordblock n f a?) (%block-allocate n #f f a?))
    312 
    313 (define-inline (%wordblock-ref x i) (##core#inline "C_slot" x i))
    314 
    315 (define-inline (%wordblock-set! x i y) (##core#inline "C_i_setslot" x i y))
    316 (define-inline (%wordblock-set!/immediate x i y) (##core#inline "C_i_set_i_slot" x i y))
    317 
    318 (define-inline (%wordblock-set!/maybe-immediate x i y)
    319   (if (%immediate? y)
    320       (%wordblock-set!/immediate x i y)
    321       (%wordblock-set! x i y) ) )
    322 
    323 
    324 ;;;
    325 
     366;Unsafe
     367
     368(define-inline (%byteblock-length bb) (%block-size bb))
     369
     370(define-inline (%byteblock-ref bb i) (##core#inline "C_subbyte" bb i))
     371
     372(define-inline (%byteblock-set! bb i v) (##core#inline "C_setsubbyte" bb i v))
    326373
    327374;; Generic-byteblock
    328375
    329 ; generic-byteblock isa string, flonum, or lambda-info
    330 
     376;Safe
     377
     378; generic-byteblock isa bytevector, string, flonum, or lambda-info
     379(define-inline (%generic-byteblock? x)
     380  (or (bytevector? x) (string? x) (flonum? x) (lambda-info? x)))
     381
     382;; Bytevector (byteblock)
     383
     384;Safe
     385
     386(define-inline (%make-bytevector sz)
     387  (let ((bv (%make-byteblock sz #f #t)))
     388    (##core#inline "C_string_to_bytevector" bv)
     389    bv ) )
     390
     391(define-inline (%string->bytevector s)
     392  (let* ((n (%byteblock-length s) #;(%string-length s))
     393               (bv (%make-bytevector sz)) )
     394    (##core#inline "C_copy_memory" bv s n)
     395    bv ) )
     396
     397;Unsafe
     398
     399(define-inline (%bytevector-length bv) (%byteblock-length bv))
     400
     401(define-inline (%bytevector=? bv1 bv2)
     402  (let ((n (%bytevector-length bv1)))
     403    (and (%fx= n (%bytevector-length bv2))
     404         (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) )
     405
     406(define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
     407
     408(define-inline (%bytevector-set! bv i x) (%byteblock-set! bv i x))
     409
     410;; Blob (isa bytevector w/o accessors)
     411
     412(define-inline (%make-blob sz) (%make-bytevector sz))
     413
     414(define-inline (%string->blob s) (%string->bytevector s))
     415
     416(define-inline (%blob? x) (%bytevector? x))
     417
     418(define-inline (%blob-size b) (%bytevector-length b))
     419
     420(define-inline (%blob=? b1 b2) (%bytevector=? b1 b2))
    331421
    332422;; String (byteblock)
    333423
     424;Safe
     425
    334426(define-inline (%make-string size fill) (%make-byteblock size fill #f))
    335427
     428;Unsafe
     429
     430(define-inline (%bytevector->string bv)
     431  (let* ((n (%bytevector-length bv))
     432               (s (%make-string n #\space)) )
     433    (##core#inline "C_copy_memory" s bv n)
     434    s ) )
     435
     436(define-inline (%blob->string bv) (%bytevector->string bv))
     437
     438(define-inline (%lambda-info->string li)
     439  (let* ((sz (%byteblock-length li) #;(%lambda-info-length li))
     440         (s (%make-string sz #\space)) )
     441    (##core#inline "C_copy_memory" s li sz)
     442    s ) )
     443
     444(define-inline (%string-length s) (%byteblock-length s))
     445
    336446(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
    337447
    338448(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
    339449
    340 (define-inline (%string-length s) (%block-size s))
    341 
    342 ;%bytevector->string - see Bytevector
    343 
    344 
    345450;; Flonum (byteblock)
    346451
     452;Unsafe
     453
    347454(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
     455
     456(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
     457(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
     458(define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y))
     459(define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y))
     460(define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y))
     461
     462(define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y))
     463(define-inline (%fpmin x y) (##core#inline "C_i_flonum_min" x y))
    348464
    349465(define-inline (%finite? x) (##core#inline "C_i_finitep" x))
     
    356472(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
    357473
    358 (define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
    359 (define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y))
    360 (define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
    361 (define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y))
    362 (define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y))
    363 
    364 (define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y))
    365 (define-inline (%fpmax x y) (##core#inline "C_i_flonum_min" x y))
    366 
     474(define-inline (%fpnegate x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y))
     475
     476(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
     477(define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x))
     478(define-inline (%fpround x) ((##core#primitive "C_flonum_round") x))
     479(define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x))
     480
     481;Safe
     482
     483(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
     484
     485; Actually 'number' operations
    367486(define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
    368487(define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
     
    377496(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
    378497
    379 (define-inline (%fpnegate x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y))
    380 
    381 (define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
    382 (define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x))
    383 (define-inline (%fpround x) ((##core#primitive "C_flonum_round") x))
    384 (define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x))
    385 
    386 
    387498;; Lambda-info (byteblock)
    388499
    389 
    390 ;; Generic-vector
     500;Unsafe
     501
     502(define-inline (%string->lambda-info s)
     503  (let* ((n (%string-length s))
     504               (li (%make-string sz)) )
     505    (##core#inline "C_copy_memory" li s n)
     506    (##core#inline "C_string_to_lambdainfo" li)
     507    li ) )
     508
     509(define-inline (%lambda-info-length li) (%byteblock-length s))
     510
     511;; Wordblock
     512
     513;Safe
     514
     515(define-inline (%make-wordblock n f a?) (%block-allocate n #f f a?))
     516
     517;Unsafe
     518
     519(define-inline (%wordblock-length wb) (%block-size wb))
     520
     521(define-inline (%wordblock-ref wb i) (##core#inline "C_slot" wb i))
     522
     523(define-inline (%wordblock-set!/mutate wb i v) (##core#inline "C_i_setslot" wb i v))
     524(define-inline (%wordblock-set!/immediate wb i v) (##core#inline "C_i_set_i_slot" wb i v))
     525(define-inline (%wordblock-set! wb i v)
     526  (if (%immediate? v) (%wordblock-set!/immediate wb i v)
     527      (%wordblock-set!/mutate wb i v) ) )
     528
     529;; Generic-vector (wordblock)
    391530
    392531; generic-vector isa vector, pair, structure, symbol, or keyword
    393 (define-inline (%generic-vector? x)
    394   (and (%block? x)
    395        (not (or (%special? x) (%byteblock? x)))) )
    396 
     532(define-inline (%generic-vector? x) (and (%block? x) (not (or (%special? x) (%byteblock? x)))))
    397533
    398534;; Vector (wordblock)
    399535
     536;Safe
     537
    400538(define-inline (%make-vector size fill) (%make-wordblock size fill #f))
    401539
     540;Unsafe
     541
     542(define-inline (%vector-length v) (%wordblock-length v))
     543
    402544(define-inline (%vector-ref v i) (%wordblock-ref v i))
    403545
     546(define-inline (%vector-set!/mutate v i x) (%wordblock-set!/mutate v i x))
     547(define-inline (%vector-set!/immediate v i x) (%wordblock-set!/immediate v i x))
    404548(define-inline (%vector-set! v i x) (%wordblock-set! v i x))
    405 (define-inline (%vector-set!/immediate v i x) (%wordblock-set!/immediate v i x))
    406 (define-inline (%vector-set!/maybe-immediate v i x) (%wordblock-set!/maybe-immediate v i x))
    407 
    408 (define-inline (%vector-length v) (%block-size v))
    409 
    410 
    411 ;; Bytevector (wordblock, but byte referenced)
    412 
    413 (define-inline (%make-bytevector sz)
    414   (let ([bv (%make-string sz #f #t)])
    415     (##core#inline "C_string_to_bytevector" bv)
    416     bv ) )
    417 
    418 (define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
    419 
    420 (define-inline (%bytevector-set! bv i x) (%byteblock-set! bv i x))
    421 
    422 (define-inline (%bytevector-length bv) (%block-size bv))
    423 
    424 (define-inline (%bytevector=? v1 v2)
    425   (let ([ln (%bytevector-length v1)])
    426     (and (%eq? n %bytevector-length v2))
    427          (%fx=? 0 (##core#inline "C_string_compare" v1 v2 n)) ) )
    428 
    429 (define-inline (%string->bytevector s)
    430   (let* ([n (%string-length s)]
    431                [bv (%make-bytevector sz)] )
    432     (##core#inline "C_copy_memory" bv s n)
    433     bv ) )
    434 
    435 (define-inline (%bytevector->string bv)
    436   (let* ([n (%bytevector-length bv)]
    437                [s (%make-string n #\space)] )
    438     (##core#inline "C_copy_memory" s bv n)
    439     s ) )
    440 
    441 
    442 ;; Blob (isa bytevector w/o accessors)
    443 
    444 (define-inline (%make-blob sz) (%make-bytevector sz))
    445 
    446 (define-inline (%blob? x) (%bytevector? x))
    447 
    448 (define-inline (%blob-size b) (%bytevector-length b))
    449 
    450 (define-inline (%blob=? b1 b2) (%bytevector=? b1 b2))
    451 
    452 (define-inline (%string->blob s) (%string->bytevector s))
    453 
    454 (define-inline (%blob->string bv) (%bytevector->string bv))
    455 
    456549
    457550;; Pair (wordblock)
    458551
     552;Safe
     553
    459554(define-inline (%null? x) (%eol-object? x))
    460555
     
    465560(define-inline (%length ls) (##core#inline "C_i_length" ls))
    466561
     562;Unsafe
     563
    467564(define-inline (%car pr) (%wordblock-ref pr 0))
     565
     566(define-inline (%set-car!/mutate pr x) (%wordblock-set!/mutate pr 0 x))
     567(define-inline (%set-car!/immediate pr x) (%wordblock-set!/immediate pr 0 x))
     568(define-inline (%set-car! pr x) (%wordblock-set! pr 0 x))
     569
    468570(define-inline (%cdr pr) (%wordblock-ref pr 1))
     571
     572(define-inline (%set-cdr!/mutate pr x) (%wordblock-set!/mutate pr 1 x))
     573(define-inline (%set-cdr!/immediate pr x) (%wordblock-set!/immediate pr 1 x))
     574(define-inline (%set-cdr! pr x) (%wordblock-set! pr 1 x))
    469575
    470576(define-inline (%caar pr) (%car (%car pr)))
     
    482588(define-inline (%cdddr pr) (%cdr (%cddr pr)))
    483589
    484 (define-inline (%set-car! pr x) (%wordblock-set! pr 0 x))
    485 (define-inline (%set-cdr! pr x) (%wordblock-set! pr 1 x))
    486 (define-inline (%set-car!/immediate pr x) (%wordblock-set!/immediate pr 0 x))
    487 (define-inline (%set-cdr!/immediate pr x) (%wordblock-set!/immediate pr 1 x))
    488 (define-inline (%set-car!/maybe-immediate pr x) (%wordblock-set!/maybe-immediate pr 0 x))
    489 (define-inline (%set-cdr!/maybe-immediate pr x) (%wordblock-set!/maybe-immediate pr 1 x))
    490 
    491 ;; These are safe
     590;Safe
    492591
    493592(define-inline (%memq x ls) (##core#inline "C_i_memq" x ls))
     
    499598(define-inline (%assoc x ls) (##core#inline "C_i_assoc" x ls))
    500599
     600;Unsafe
     601
    501602(define-inline (%list-ref ls0 i0)
    502603  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    503   (let loop ([ls ls0] [i i0])
    504     (cond [(%null? ls)  '() ]
    505                 [(%fx= 0 i)   (%car ls) ]
    506                 [else         (loop (%cdr ls) (%fx- i 1)) ] ) ) )
     604  (let loop ((ls ls0) (i i0))
     605    (cond ((%null? ls)  '() )
     606                ((%fx= 0 i)   (%car ls) )
     607                (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    507608
    508609(define-inline (%list-pair-ref ls0 i0)
    509610  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    510   (let loop ([ls ls0] [i i0])
    511     (cond [(%null? ls)  '() ]
    512                 [(%fx= 0 i)   ls ]
    513                 [else         (loop (%cdr ls) (%fx- i 1)) ] ) ) )
     611  (let loop ((ls ls0) (i i0))
     612    (cond ((%null? ls)  '() )
     613                ((%fx= 0 i)   ls )
     614                (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    514615
    515616(define-inline (%last-pair ls0)
    516   ;(assert (and (proper-list? ls0) (not (null? ls0))))
    517   (do ([ls ls0 (%cdr ls)])
    518       [(%null? (%cdr ls)) ls]) )
     617  ;(assert (and (proper-list? ls0) (pair? ls0)))
     618  (do ((ls ls0 (%cdr ls)))
     619      ((%null? (%cdr ls)) ls)) )
    519620
    520621(define-inline (%list-copy ls0)
    521622  ;(assert (proper-list? ls0))
    522   (let loop ([ls ls0])
     623  (let copy-rest ((ls ls0))
    523624    (if (%null? ls) '()
    524         (%cons (%car ls) (loop (%cdr ls))) ) ) )
     625        (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
    525626
    526627(define-inline (%append! . lss)
    527   ;(assert (and (proper-list? lss) (for-each (lambda (x) (proper-list? x)) lss)))
    528   (let ([lss (let position-at-first-pair ([lss lss])
    529                (cond [(%null? lss)        '() ]
    530                      [(%null? (%car lss))  (position-at-first-pair (%cdr lss)) ]
    531                      [else                 lss ] ) ) ] )
     628  ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
     629  (let ((lss (let position-at-first-pair ((lss lss))
     630               (cond ((%null? lss)        '() )
     631                     ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
     632                     (else                 lss ) ) ) ) )
    532633    (if (%null? lss) '()
    533         (let ([ls0 (%car lss)])
    534           ;(assert (not (null? ls0)))
    535           (let append!-rest ([lss (%cdr lss)] [pls ls0])
     634        (let ((ls0 (%car lss)))
     635          ;(assert (pair? ls0))
     636          (let append!-rest ((lss (%cdr lss)) (pls ls0))
    536637            (if (%null? lss) ls0
    537                 (let ([ls (%car lss)])
    538                   (cond [(%null? ls)
    539                          (append!-rest (%cdr lss) pls) ]
    540                         [else
    541                          (%set-cdr! (%last-pair pls) ls)
    542                          (append!-rest (%cdr lss) ls) ] ) ) ) ) ) ) ) )
     638                (let ((ls (%car lss)))
     639                  (cond ((%null? ls)
     640                         (append!-rest (%cdr lss) pls) )
     641                        (else
     642                         (%set-cdr!/mutate (%last-pair pls) ls)
     643                         (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
    543644
    544645(define-inline (%delq! x ls0)
    545646  ;(assert (proper-list? ls0))
    546   (let find-elm ([ls ls0] [ppr #f])
    547     (cond [(%null? ls)
    548            ls0 ]
    549                 [(%eq? x (%car ls))
    550                  (cond [ppr
    551                         (%set-cdr!/maybe-immediate ppr (%cdr ls))
    552                         ls0 ]
    553                        [else
    554                         (%cdr ls) ] ) ]
    555                 [else
    556                  (find-elm (%cdr ls) ls) ] ) ) )
     647  (let find-elm ((ls ls0) (ppr #f))
     648    (cond ((%null? ls)
     649           ls0 )
     650                ((%eq? x (%car ls))
     651                 (cond (ppr
     652                        (%set-cdr! ppr (%cdr ls))
     653                        ls0 )
     654                       (else
     655                        (%cdr ls) ) ) )
     656                (else
     657                 (find-elm (%cdr ls) ls) ) ) ) )
    557658
    558659(define-inline (%list-fold-1 func init ls0)
    559660  ;(assert (and (proper-list? ls0) (procedure? func)))
    560   (let loop ([ls ls0] [acc init])
     661  (let loop ((ls ls0) (acc init))
    561662    (if (%null? ls) acc
    562663        (loop (%cdr ls) (func (%car ls) acc)) ) ) )
     
    564665(define-inline (%list-map-1 func ls0)
    565666  ;(assert (and (proper-list? ls0) (procedure? func)))
    566   (let loop ([ls ls0])
     667  (let loop ((ls ls0))
    567668    (if (%null? ls) '()
    568669        (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
     
    570671(define-inline (%list-for-each-1 proc ls0)
    571672  ;(assert (and (proper-list? ls0) (procedure? proc)))
    572   (let loop ([ls ls0])
     673  (let loop ((ls ls0))
    573674    (unless (%null? ls)
    574675      (proc (%car ls))
    575676      (loop (%cdr ls)) ) ) )
    576677
    577 
    578678;; Structure (wordblock)
    579679
     
    582682(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
    583683
     684(define-inline (%structure-length r) (%wordblock-length r))
     685
     686(define-inline (%structure-tag r) (%wordblock-ref r 0))
     687
    584688(define-inline (%structure-ref r i) (%wordblock-ref r i))
    585689
     690(define-inline (%structure-set!/mutate r i x) (%wordblock-set!/mutate r i x))
     691(define-inline (%structure-set!/immediate r i x) (%wordblock-set!/immediate r i x))
    586692(define-inline (%structure-set! r i x) (%wordblock-set! r i x))
    587 (define-inline (%structure-set!/immediate r i x) (%wordblock-set!/immediate r i x))
    588 (define-inline (%structure-set!/maybe-immediate r i x) (%wordblock-set!/maybe-immediate r i x))
    589 
    590 (define-inline (%structure-length r) (%block-size r))
    591 
    592 (define-inline (%structure-tag r) (%wordblock-ref r 0))
    593 
    594693
    595694;; Port (wordblock)
     
    597696; Port layout:
    598697;
    599 ; 0       FP (special - C FILE *)
     698; 0       FP (special - FILE *)
    600699; 1       input/output (bool)
    601700; 2       class (vector, see Port-class)
     
    609708; 10-15  reserved, port class specific
    610709
    611 ; port is 16 slots + a block-header word
    612 ;
    613 ;(define-inline (%make-port n) (##core#inline_allocate ("C_a_i_port" 17)))
    614 
    615710(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    616711(define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
     
    626721(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
    627722(define-inline (%port-input-mode-set! port f) (%wordblock-set!/immediate port 1 f))
    628 (define-inline (%port-class port v) (%wordblock-set! port 2 v))
    629 (define-inline (%port-name-set! port s) (%wordblock-set! port 3 s))
     723(define-inline (%port-class-set! port v) (%wordblock-set!/mutate port 2 v))
     724(define-inline (%port-name-set! port s) (%wordblock-set!/mutate port 3 s))
    630725(define-inline (%port-row-set! port n) (%wordblock-set!/immediate port 4 n))
    631726(define-inline (%port-column-set! port n) (%wordblock-set!/immediate port 5 n))
    632727(define-inline (%port-eof-set! port f) (%wordblock-set!/immediate port 6 f))
    633 (define-inline (%port-type-set! port s) (%wordblock-set! port 7 s))
     728(define-inline (%port-type-set! port s) (%wordblock-set!/mutate port 7 s))
    634729(define-inline (%port-closed-set! port f) (%wordblock-set!/immediate port 8 f))
    635 (define-inline (%port-data-set! port port) (%wordblock-set! port 9 x))
     730(define-inline (%port-data-set! port port) (%wordblock-set!/mutate port 9 x))
     731
     732(define-inline (%make-port i/o class name type)
     733  ; port is 16 slots + a block-header word
     734  (let ((port (##core#inline_allocate ("C_a_i_port" 17))))
     735    (%port-input-mode-set! port i/o)
     736    (%port-class-set! port class)
     737    (%port-name-set! port name)
     738    (%port-row-set! port 1)
     739    (%port-column-set! port 0)
     740    (%port-type-set! port type)
     741    port ) )
    636742
    637743; Port-class layout
     
    647753; 8       (read-line PORT LIMIT) -> STRING | EOF
    648754
     755(define-inline (%make-port-class rc pc wc ws cl fl cr rs rl)
     756  (let ((class (%make-vector 9 #f)))
     757    (%vector-set! class 0 rc)
     758    (%vector-set! class 1 pc)
     759    (%vector-set! class 2 wc)
     760    (%vector-set! class 3 ws)
     761    (%vector-set! class 4 cl)
     762    (%vector-set! class 5 fl)
     763    (%vector-set! class 6 cr)
     764    (%vector-set! class 7 rs)
     765    (%vector-set! class 8 rl)
     766    class ) )
     767
     768(define-inline (%port-class-read-char-ref c) (%vector-ref c 0))
     769(define-inline (%port-class-peek-char-ref c) (%vector-ref c 1))
     770(define-inline (%port-class-write-char-ref c) (%vector-ref c 2))
     771(define-inline (%port-class-write-string-ref c) (%vector-ref c 3))
     772(define-inline (%port-class-close-ref c) (%vector-ref c 4))
     773(define-inline (%port-class-flush-output-ref c) (%vector-ref c 5))
     774(define-inline (%port-class-char-ready-ref c) (%vector-ref c 6))
     775(define-inline (%port-class-read-string-ref c) (%vector-ref c 7))
     776(define-inline (%port-class-read-line-ref c) (%vector-ref c 8))
     777
     778(define-inline (%port-class-read-char c p) ((%port-class-read-char-ref c) p) )
     779(define-inline (%port-class-peek-char c p) ((%port-class-peek-char-ref c) p))
     780(define-inline (%port-class-write-char c p c) ((%port-class-write-char-ref c) p c))
     781(define-inline (%port-class-write-string c p s) ((%port-class-write-string-ref c) p s))
     782(define-inline (%port-class-close c p) ((%port-class-close-ref c) p))
     783(define-inline (%port-class-flush-output c p) ((%port-class-flush-output-ref c) p))
     784(define-inline (%port-class-char-ready? c p) ((%port-class-char-ready-ref c) p))
     785(define-inline (%port-class-read-string! c p n d s) ((%port-class-read-string-ref c) p n d s))
     786(define-inline (%port-class-read-line c p l) ((%port-class-read-line-ref c) p l))
     787
     788(define-inline (%port-read-char p) ((%port-class-read-char-ref (%port-class p)) p) )
     789(define-inline (%port-peek-char p) ((%port-class-peek-char-ref (%port-class p)) p))
     790(define-inline (%port-write-char p c) ((%port-class-write-char-ref (%port-class p)) p c))
     791(define-inline (%port-write-string p s) ((%port-class-write-string-ref (%port-class p)) p s))
     792(define-inline (%port-close p) ((%port-class-close-ref (%port-class p)) p))
     793(define-inline (%port-flush-output p) ((%port-class-flush-output-ref (%port-class p)) p))
     794(define-inline (%port-char-ready? p) ((%port-class-char-ready-ref (%port-class p)) p))
     795(define-inline (%port-read-string! p n d s) ((%port-class-read-string-ref (%port-class p)) p n d s))
     796(define-inline (%port-read-line p l) ((%port-class-read-line-ref (%port-class p)) p l))
    649797
    650798;; Closure (wordblock)
    651799
    652 (define-inline (%closure-size c) (%block-size? c))
     800;Unsafe
     801
     802(define-inline (%make-closure! n)
     803  (let ((v (%make-vector n)))
     804    (##core#inline "C_vector_to_closure" v)
     805    v ) )
    653806
    654807(define-inline (%vector->closure! v a)
     
    656809  (##core#inline "C_update_pointer" a v) )
    657810
     811(define-inline (%closure-length c) (%wordblock-length? c))
     812
     813(define-inline (%closure-ref c i) (%wordblock-ref c i))
     814
     815(define-inline (%closure-set! c i v) (%wordblock-set! c i v))
     816
     817(define-inline (%closure-copy tc fc l)
     818  (do ((i 1 (%fxadd1 i)))
     819      ((%fx>= i l))
     820    (%closure-set! tc i (%closure-ref fc i)) ) )
     821
     822(define-inline (%closure-decoration c t)
     823  (let find-decor ((i (%fxsub1 (%closure-length c))))
     824    (and (%fxpositive? i)
     825         (let ((x (%closure-ref c i)))
     826           (if (t x) x
     827               (find-decor (%fxsub1 i)) ) ) ) ) )
     828
     829(define-inline (%closure-decorate! c t d)
     830  (let ((l (%closure-length c)))
     831    (let find-decor ((i (%fxsub l)))
     832      (cond ((%fxzero? i)
     833             (let ((nc (%make-closure (%fxadd1 l))))
     834               (%closure-copy nc c l)
     835               (##core#inline "C_copy_pointer" c nc)
     836               (d nc i) ) )
     837            (else
     838             (let ((x (%closure-ref c i)))
     839               (if (t x) (d c i)
     840                   (find-decor (%fxsub i)) ) ) ) ) ) ) )
     841
     842(define-inline (%closure-lambda-info c)
     843  (%closure-decoration c (lambda (x) (%lambda-info? x))) )
    658844
    659845;; Symbol (wordblock)
     
    671857(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))
    672858
    673 
    674859;; Keyword (wordblock)
    675860
    676 (define-inline (%keyword? x)
    677   (and (%symbol? x)
    678        (%eq? 0 (%byteblock-ref (%symbol-string x) 0)) ) )
    679 
     861(define-inline (%keyword? x) (and (%symbol? x) (%fx= 0 (%byteblock-ref (%symbol-string x) 0))))
     862
     863;; Pointer (wordblock)
     864
     865; simple-pointer, tagged-pointer, swig-pointer, locative
     866(define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
     867
     868; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
     869(define-inline (%pointer-like? x) (%wordblock? x))
     870
     871; These operate on pointer-like objects
     872
     873(define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
     874
     875(define-inline (%pointer-ref ptr) (%wordblock-ref ptr 0))
     876(define-inline (%pointer-set! ptr y) (%wordblock-set!/mutate ptr 0 y))
     877
     878(define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
     879
     880(define-inline (%pointer->address ptr)
     881  ; Pack pointer address value into Chicken words; '4' is platform dependent!
     882  (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref x)) )
     883
     884;; Simple-pointer (wordblock)
     885
     886(define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))
     887
     888(define-inline (%make-pointer-null)
     889  (let ((ptr (%make-simple-pointer)))
     890    (##core#inline "C_update_pointer" 0 ptr)
     891    ptr ) )
     892
     893(define-inline (%address->pointer a)
     894  (let ((ptr (%make-simple-pointer)))
     895    (##core#inline "C_update_pointer" a ptr)
     896    ptr ) )
     897
     898(define-inline (%make-block-pointer b)
     899  (let ((ptr (%make-simple-pointer)))
     900    (##core#inline "C_pointer_to_block" ptr b)
     901    ptr ) )
     902
     903;; Tagged-pointer (wordblock)
     904
     905(define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))
     906
     907;; Swig-pointer (wordblock)
    680908
    681909;; Locative (wordblock)
     
    701929; 3     Object or #f, if weak (C_word)
    702930
    703 ;%locative-address - see Pointer
     931(define-inline (%locative-address lv) (%pointer->address lv))
     932
    704933(define-inline (%locative-offset lv) (%wordblock-ref lv 1))
    705934(define-inline (%locative-type lv) (%wordblock-ref lv 2))
     
    707936(define-inline (%locative-object lv) (%wordblock-ref lv 3))
    708937
    709 
    710 ;; Pointer (wordblock)
    711 
    712 ; simple-pointer, tagged-pointer, swig-pointer, locative
    713 (define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
    714 
    715 ; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
    716 (define-inline (%pointer-like? x) (%wordblock? x))
    717 
    718 ; These operate on pointer-like objects
    719 
    720 (define-inline (%pointer-ref ptr) (%wordblock-ref ptr 0))
    721 (define-inline (%pointer-set! ptr y) (%wordblock-set! ptr 0 y))
    722 
    723 (define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
    724 
    725 (define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
    726 
    727 (define-inline (%pointer->address ptr)
    728   ; Pack pointer address value into Chicken words; '4' is platform dependent!
    729   (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref x)) )
    730 
    731 (define-inline (%locative-address lv) (%pointer->address lv))
    732 
    733 
    734 ;; Simple-pointer (wordblock)
    735 
    736 (define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))
    737 
    738 (define-inline (%make-pointer-null)
    739   (let ([ptr (%make-simple-pointer)])
    740     (##core#inline "C_update_pointer" 0 ptr)
    741     ptr ) )
    742 
    743 (define-inline (%address->pointer a)
    744   (let ([ptr (%make-simple-pointer)])
    745     (##core#inline "C_update_pointer" a ptr)
    746     ptr ) )
    747 
    748 (define-inline (%make-pointer-block b)
    749   (let ([ptr (%make-simple-pointer)])
    750     (##core#inline "C_pointer_to_block" ptr b)
    751     ptr ) )
    752 
    753 
    754 ;; Tagged-pointer (wordblock)
    755 
    756 (define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))
    757 
    758 
    759 ;; Swig-pointer (wordblock)
    760 
    761 
    762 ;;; Values
    763 
    764 
    765 ;;; Numbers
    766 
    767 (define-inline (%number? x) (or (%fixnum? x) (%flonum? x) ) )
     938;; Numbers
     939
     940;Safe
     941
     942(define-inline (%number? x) (or (%fixnum? x) (%flonum? x)))
    768943(define-inline (%integer? x) (##core#inline "C_i_integerp" x))
    769 (define-inline (%negative? x) (##core#inline "C_i_negativep" x))
     944
     945(define-inline (%= x y) ((##core#primitive "C_i_eqvp") x y))
     946(define-inline (%< x y) ((##core#primitive "C_i_lessp") x y))
     947(define-inline (%<= x y) ((##core#primitive "C_i_less_or_equalp") x y))
     948(define-inline (%> x y) ((##core#primitive "C_i_greaterp") x y))
     949(define-inline (%>= x y) ((##core#primitive "C_i_greater_or_equalp") x y))
     950
    770951(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
    771 
    772 (define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
     952(define-inline (%positive? n) (##core#inline "C_i_positivep" n))
     953(define-inline (%negative? n) (##core#inline "C_i_negativep" n))
     954(define-inline (%cardinal? n) (and (%integer? x) (%<= 0 n)))
     955(define-inline (%odd? n) (##core#inline "C_i_oddp" n))
     956(define-inline (%even? n) (##core#inline "C_i_evenp" n))
    773957
    774958(define-inline (%- x y) ((##core#primitive "C_minus") x y))
     
    777961(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
    778962
    779 (define-inline (%= x y) ((##core#primitive "C_i_eqvp") x y))
    780 
    781 (define-inline (%< x y) ((##core#primitive "C_i_lessp") x y))
    782 (define-inline (%<= x y) ((##core#primitive "C_i_less_or_equalp") x y))
    783 (define-inline (%> x y) ((##core#primitive "C_i_greaterp") x y))
    784 (define-inline (%>= x y) ((##core#primitive "C_i_greater_or_equalp") x y))
     963(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
     964(define-inline (%remainder x y) (let ((quo (%quotient x y))) (%- x (%* quo y))))
    785965
    786966(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
    787 
    788 (define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
     967(define-inline (%abs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
     968(define-inline (%acos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
     969(define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
     970(define-inline (%atan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
     971(define-inline (%atan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
     972(define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
     973(define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
     974(define-inline (%log x) (##core#inline_allocate ("C_a_i_log" 4) x))
     975(define-inline (%sin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
     976(define-inline (%sqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
     977(define-inline (%tan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
    789978
    790979(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
     980(define-inline (%bitwise-xor x y) (##core#inline_allocate ("C_a_i_bitwise_xor" 4) x y))
    791981(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
    792982(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
    793983
    794 
    795 ;;; Operations
    796 
    797 
    798 ;; Random
    799 
    800 (define-inline (%random-fixnum x) (##core#inline "C_random_fixnum" x))
    801 
     984(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
     985
     986(define-inline (%bit-set? n i) (##core#inline "C_i_bit_setp" n i))
     987
     988(define-inline (%randomize n) (##core#inline "C_randomize" n))
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13651 r13667  
    3030(define-inline (%check-flonum loc obj) (##sys#check-inexact obj loc))
    3131
    32 (define-inline (%check-cardinal loc obj)
    33   (unless (%cardinal obj)
     32(define-inline (%check-not-negative loc obj)
     33  (unless (%<= 0 obj)
    3434    (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal number" obj) ) )
    3535
     
    8181(define-inline (%fpdiv0-and-mod0 fpn fpd)
    8282  (let-values (((quo rem) (%fpdiv-and-mod  fpn fpd)))
    83     (cond ((%fp>=? fpd 0.0)
     83    (cond ((%fp<=? 0.0 fpd)
    8484           (if (%fp<? rem (%fp/ fpd 2.0))
    85                (if (%fp>=? rem (%fp/ fpd -2.0)) (values quo rem)
     85               (if (%fp<=? (%fp/ fpd -2.0) rem) (values quo rem)
    8686                   (values (%fp- quo 1.0) (%fp+ rem fpd)) )
    8787               (values (%fp+ quo 1.0) (%fp- rem fpd)) ) )
    8888          ((%fp<? rem (%fp/ fpd -2.0))
    89            (if (%fp>=? rem (%fp/ fpd 2.0)) (values quo rem)
     89           (if (%fp<=? (%fp/ fpd 2.0) rem) (values quo rem)
    9090               (values (%fp+ quo 1.0) (%fp- rem fpd)) ) )
    9191          (else
     
    9494(define-inline (%fpdiv0 fpn fpd)
    9595  (let-values (((quo rem) (%fpdiv-and-mod  fpn fpd)))
    96     (cond ((%fp>=? fpd 0.0)
     96    (cond ((%fp<=? 0.0 fpd)
    9797           (if (%fp<? rem (%fp/ fpd 2.0))
    98                (if (%fp>=? rem (%fp/ fpd -2.0)) quo
     98               (if (%fp<=? (%fp/ fpd -2.0) rem) quo
    9999                   (%fp- quo 1.0) )
    100100               (%fp+ quo 1.0) ) )
    101101          ((%fp<? rem (%fp/ fpd -2.0))
    102            (if (%fp>=? rem (%fp/ fpd 2.0)) quo
     102           (if (%fp<=? (%fp/ fpd 2.0) rem) quo
    103103               (%fp+ quo 1.0) ) )
    104104          (else
     
    107107(define-inline (%fpmod0 fpn fpd)
    108108  (let ((rem (%fpmod fpn fpd)))
    109     (cond ((%fp>=? fpd 0.0)
     109    (cond ((%fp<=? 0.0 fpd)
    110110           (if (%fp<? rem (%fp/ fpd 2.0))
    111                (if (%fp>=? rem (%fp/ fpd -2.0)) rem
     111               (if (%fp<=? (%fp/ fpd -2.0) rem) rem
    112112                   (%fp+ rem fpd) )
    113113               (%fp- rem fpd) ) )
    114114          ((%fp<? rem (%fp/ fpd -2.0))
    115            (if (%fp>=? rem (%fp/ fpd 2.0)) rem
     115           (if (%fp<=? (%fp/ fpd 2.0) rem) rem
    116116               (%fp- rem fpd) ))
    117117          (else
     
    340340  (if (not base) (%fplog fl)
    341341      (begin
    342         (%check-cardinal 'fllog base)
     342        (%check-not-negative 'fllog base)
    343343        ((log/base base) fl) ) ) )
    344344
     
    377377  (%check-flonum 'flexpt fl)
    378378  (%check-flonum 'flexpt exp)
    379   (if (= 2.0 fl) (ldexp 1.0 exp)
     379  (if (%fp= 2.0 fl) (ldexp 1.0 exp)
    380380      (%expt fl exp) ) )
    381381
Note: See TracChangeset for help on using the changeset viewer.