Changeset 13698 in project


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

New prims.

Location:
release/4/mailbox
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/mailbox/tags/2.0.0/chicken-primitive-object-inlines.scm

    r13617 r13698  
    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 
    42 
    43 ;; Immediate
    44 
    45 (define-inline (%immediate? x) (##core#inline "C_immp" x))
    46 
     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
    4738
    4839;; Fixnum
     
    5041(define-inline (%fixnum-type? x) (##core#inline "C_fixnump" x))
    5142
    52 (define-inline (%fixnum? x) (and (%immediate? x) (%fixnum-type? x)))
    53 
    54 
    5543;; Character
    5644
    5745(define-inline (%char-type? x) (##core#inline "C_charp" x))
    5846
    59 (define-inline (%char? x) (and (%immediate? x) (%char-type? x)))
    60 
    61 
    6247;; Boolean
    6348
    6449(define-inline (%boolean-type? x) (##core#inline "C_booleanp" x))
    6550
    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 
    7351;; EOF
    7452
    7553(define-inline (%eof-object-type? x) (##core#inline "C_eofp" x))
    7654
    77 (define-inline (%eof-object? x) (and (%immediate? x) (%eof-object-type? x)))
    78 
    79 
    8055;; Null (the end-of-list value)
    8156
    8257(define-inline (%eol-object-type? x) (##core#inline "C_i_nullp" x))
    8358
    84 (define-inline (%eol-object? x) (and (%immediate? x) (%eol-object-type? x)))
    85 
    86 
    8759;; Undefined (void)
    8860
    8961(define-inline (%undefined-type? x) (##core#inline "C_undefinedp" x))
    9062
    91 (define-inline (%undefined-value? x) (and (%immediate? x) (%undefined-type? x)))
    92 
    93 (define-inline (%undefined-value) (##core#undefined))
    94 
    95 
    9663;; Unbound (the unbound value, not 'is a symbol unbound')
    9764
    9865(define-inline (%unbound-type? x) (##core#inline "C_unboundvaluep" x))
    9966
    100 (define-inline (%unbound-value? x) (and (%immediate? x) (%unbound-type? x)))
    101 
    102 
    103 ;; Block (anything not immediate)
    104 
    105 (define-inline (%block? x) (##core#inline "C_blockp" x))
    106 
    107 
    108 ;; Special
    109 
    110 (define-inline (%special? x) (##core#inline "C_specialp" x))
    111 
    112 
    113 ;; Wordblock (special block)
    114 
    115 (define-inline (%wordblock? x) (and (%block? x) (%special? x)))
    116 
    117 
    11867;; Byteblock
    11968
    12069(define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))
    12170
    122 (define-inline (%byteblock? x) (and (%block? x) (%byteblock-type? x)))
    123 
     71;; Bytevector
     72
     73(define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))
     74
     75;; String
     76
     77(define-inline (%string-type? x) (##core#inline "C_stringp" x))
     78
     79;; Flonum
     80
     81(define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
     82
     83;; Lambda-info
     84
     85(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
    12486
    12587;; Vector
     
    12789(define-inline (%vector-type? x) (##core#inline "C_vectorp" x))
    12890
    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 
    13991;; Pair
    14092
    14193(define-inline (%pair-type? x) (##core#inline "C_pairp" x))
    142 
    143 (define-inline (%pair? x) (and (%block? x) (%pair-type? x)))
    144 
    14594
    14695;; Bucket
     
    14998; "seen" by Scheme code.
    15099
    151 
    152100;; Structure
    153101
    154102(define-inline (%structure-type? x) (##core#inline "C_structurep" x))
    155103
     104;; Symbol
     105
     106(define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
     107
     108;; Closure
     109
     110(define-inline (%closure-type? x) (##core#inline "C_closurep" x))
     111
     112;; Port
     113
     114(define-inline (%port-type? x) (##core#inline "C_portp" x))
     115
     116;; Any-pointer
     117
     118(define-inline (%any-pointer-type? x) (##core#inline "C_anypointerp" x))
     119
     120;; Simple-pointer
     121
     122(define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
     123
     124;; Tagged-Pointer
     125
     126(define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
     127
     128;; Swig-Pointer
     129
     130(define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
     131
     132;; Locative
     133
     134(define-inline (%locative-type? x) (##core#inline "C_locativep" x))
     135
     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
    156223(define-inline (%structure? x) (and (%block? x) (%structure-type? x)))
    157224
    158 
    159225;; Symbol
    160226
    161 (define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
    162 
    163227(define-inline (%symbol? x) (and (%block? x) (%symbol-type? x)))
    164228
    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 
    187229;; Closure
    188230
    189 (define-inline (%closure-type? x) (##core#inline "C_closurep" x))
    190 
    191231(define-inline (%closure? x) (and (%block? x) (%closure-type? x)))
    192232
    193 
    194233;; Port
    195234
    196 (define-inline (%port-type? x) (##core#inline "C_portp" x))
    197 
    198235(define-inline (%port? x) (and (%block? x) (%port-type? x)))
    199236
     237;; Any-pointer
     238
     239(define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))
    200240
    201241;; Simple-pointer
    202242
    203 (define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
    204 
    205243(define-inline (%simple-pointer? x) (and (%block? x) (%simple-pointer-type? x)))
    206244
    207 
    208245;; Tagged-Pointer
    209246
    210 (define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
    211 
    212247(define-inline (%tagged-pointer? x) (and (%block? x) (%tagged-pointer-type? x)))
    213248
    214 
    215249;; Swig-Pointer
    216250
    217 (define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
    218 
    219251(define-inline (%swig-pointer? x) (and (%block? x) (%swig-pointer-type? x)))
    220252
    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 
    229253;; Locative
    230254
    231 (define-inline (%locative-type? x) (##core#inline "C_locativep" x))
    232 
    233255(define-inline (%locative? x) (and (%block? x) (%locative-type? x)))
    234256
    235 
    236257;; Forwarded (block object moved to new address, forwarding pointer)
    237258
     
    239260
    240261
    241 
    242 ;;; Values
    243 
    244 
    245262;;; Operations
    246263
     264;Safe
     265
    247266(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
    248267
    249268(define-inline (%peek-signed-integer b i) ((##core#primitive "C_peek_signed_integer") b i))
    250 
    251269(define-inline (%peek-unsigned-integer b i) ((##core#primitive "C_peek_unsigned_integer") b i))
    252 
    253270(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
    254271
    255 
    256272;; Fixnum
    257273
    258 (define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
    259 (define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
    260 (define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
     274;Safe
     275
     276(define-inline (%fxrandom x) (##core#inline "C_random_fixnum" x))
     277
     278;Unsafe
     279
    261280(define-inline (%fx= x y) (%eq? x y))
    262281(define-inline (%fx> x y) (##core#inline "C_fixnum_greaterp" x y))
     
    264283(define-inline (%fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
    265284(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
     285
     286(define-inline (%fxclosed-right? l x h) (and (%< l obj) (%fx<= obj h)))
     287(define-inline (%fxclosed? l x h) (and (%<= l obj) (%fx<= obj h)))
     288(define-inline (%fxclosed-left? l x h) (and (%<= l obj) (%fx< obj h)))
     289
     290(define-inline (%fxzero? fx) (%fx= 0 fx))
     291(define-inline (%fxpositive? fx) (%fx< 0 fx))
     292(define-inline (%fxnegative? fx) (%fx< fx 0))
     293(define-inline (%fxcardinal? fx) (%fx<= 0 fx))
     294(define-inline (%fxodd? fx) (%fx= 1 (%fxand fx 1)))
     295(define-inline (%fxeven? fx) (%fx= 0 (%fxand fx 1)))
     296
    266297(define-inline (%fxmin x y) (##core#inline "C_i_fixnum_min" x y))
    267298(define-inline (%fxmax x y) (##core#inline "C_i_fixnum_max" x y))
     299
     300(define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
     301(define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
     302(define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
     303(define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
     304(define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))
     305
     306(define-inline (%fxadd1 fx) (##core#inline "C_fixnum_increase" fx))
     307(define-inline (%fxsub1 fx) (##core#inline "C_fixnum_decrease" fx))
     308
     309(define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
     310(define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
     311
    268312(define-inline (%fxneg x) (##core#inline "C_fixnum_negate" x))
     313(define-inline (%fxabs fx) (if (%fxnegative? fx) (%fxneg fx) fx))
     314
    269315(define-inline (%fxand x y) (##core#inline "C_fixnum_and" x y))
    270316(define-inline (%fxior x y) (##core#inline "C_fixnum_or" x y))
    271317(define-inline (%fxxor x y) (##core#inline "C_fixnum_xor" x y))
    272318(define-inline (%fxnot x) (##core#inline "C_fixnum_not" x))
    273 (define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
    274 (define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
    275 
    276 ; These are very unsafe, no check for division-by-zero
    277 (define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
    278 (define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))
    279 
    280 
    281 ;;; Block
    282 
     319
     320;; Block
     321
     322;Safe
     323
     324(define-inline (%block-address b) (##core#inline_allocate ("C_block_address" 4) b))
    283325
    284326;; Size of object in units of sub-object.
    285327
    286 ; byteblock is # of bytes, otherwise # of words.
     328; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
    287329;
    288 (define-inline (%block-size x) (##core#inline "C_block_size" x))
    289 
    290 
    291 ;; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
    292 ;
    293 ; Creates & returns a string when 'byteblock?', otherwise a vector.
    294 ;
    295 ; Size is # of bytes when 'byteblock?', otherwise # of words.
    296 ; Fill is a character when 'byteblock?', otherwise any.
    297 ;
    298 (define-inline (%block-allocate n bb f a) ((##core#primitive "C_allocate_vector") n bb f a))
    299 
    300 (define-inline (%block-address x) (##core#inline_allocate ("C_block_address" 4) x))
    301 
    302 
    303 ;; Byte access
     330; byteblock? #t - size is # of bytes, fill is-a character  -> "string"
     331; byteblock? #f - size is # of words, fill is-a any        -> "vector"
     332
     333(define-inline (%block-allocate n bb? f a?) ((##core#primitive "C_allocate_vector") n bb? f a?))
     334
     335;Unsafe
     336
     337; Byteblock -> # of bytes
     338; Wordblock -> # of words.
     339
     340(define-inline (%block-size b) (##core#inline "C_block_size" b))
     341
     342;;
     343
     344;; Byteblock
     345
     346;Safe
    304347
    305348(define-inline (%make-byteblock n f a?) (%block-allocate n #t f a?))
    306349
    307 (define-inline (%byteblock-ref x i) (##core#inline "C_subbyte" x i))
    308 (define-inline (%byteblock-set! x i n) (##core#inline "C_setsubbyte" x i n))
    309 
    310 
    311 ;; Word access
    312 
    313 (define-inline (%make-wordblock n f a?) (%block-allocate n #f f a?))
    314 
    315 (define-inline (%wordblock-ref x i) (##core#inline "C_slot" x i))
    316 
    317 (define-inline (%wordblock-set! x i y) (##core#inline "C_i_setslot" x i y))
    318 (define-inline (%wordblock-set!/immediate x i y) (##core#inline "C_i_set_i_slot" x i y))
    319 
    320 (define-inline (%wordblock-set!/maybe-immediate x i y)
    321   (if (%immediate? y)
    322       (%wordblock-set!/immediate x i y)
    323       (%wordblock-set! x i y) ) )
    324 
    325 
    326 ;;;
    327 
     350;Unsafe
     351
     352(define-inline (%byteblock-length bb) (%block-size bb))
     353
     354(define-inline (%byteblock-ref bb i) (##core#inline "C_subbyte" bb i))
     355
     356(define-inline (%byteblock-set! bb i v) (##core#inline "C_setsubbyte" bb i v))
    328357
    329358;; Generic-byteblock
    330359
    331 ; generic-byteblock isa string, flonum, or lambda-info
    332 
    333 
    334 ;; String (byteblock)
    335 
    336 (define-inline (%make-string size fill) (%make-byteblock size fill #f))
    337 
    338 (define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
    339 
    340 (define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
    341 
    342 (define-inline (%string-length s) (%block-size s))
    343 
    344 ;%bytevector->string - see Bytevector
    345 
    346 
    347 ;; Flonum (byteblock)
    348 
    349 
    350 ;; Lambda-info (byteblock)
    351 
    352 
    353 ;; Generic-vector
    354 
    355 ; generic-vector isa vector, pair, structure, symbol, or keyword
    356 (define-inline (%generic-vector? x)
    357   (and (%block? x)
    358        (not (or (%special? x) (%byteblock? x)))) )
    359 
    360 
    361 ;; Vector (wordblock)
    362 
    363 (define-inline (%make-vector size fill) (%make-wordblock size fill #f))
    364 
    365 (define-inline (%vector-ref v i) (%wordblock-ref v i))
    366 
    367 (define-inline (%vector-set! v i x) (%wordblock-set! v i x))
    368 (define-inline (%vector-set!/immediate v i x) (%wordblock-set!/immediate v i x))
    369 (define-inline (%vector-set!/maybe-immediate v i x) (%wordblock-set!/maybe-immediate v i x))
    370 
    371 (define-inline (%vector-length v) (%block-size v))
    372 
    373 
    374 ;; Bytevector (wordblock, but byte referenced)
     360;Safe
     361
     362; generic-byteblock isa bytevector, string, flonum, or lambda-info
     363(define-inline (%generic-byteblock? x)
     364  (or (bytevector? x) (string? x) (flonum? x) (lambda-info? x)) )
     365
     366;; Bytevector (byteblock)
     367
     368;Safe
    375369
    376370(define-inline (%make-bytevector sz)
    377   (let ([bv (%make-string sz #f #t)])
     371  (let ((bv (%make-byteblock sz #f #t)))
    378372    (##core#inline "C_string_to_bytevector" bv)
    379373    bv ) )
    380374
    381 (define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
    382 
    383 (define-inline (%bytevector-set! bv i x) (%byteblock-set! bv i x))
    384 
    385 (define-inline (%bytevector-length bv) (%block-size bv))
    386 
    387 (define-inline (%bytevector=? v1 v2)
    388   (let ([ln (%bytevector-length v1)])
    389     (and (%eq? n %bytevector-length v2))
    390          (%fx=? 0 (##core#inline "C_string_compare" v1 v2 n)) ) )
    391 
    392375(define-inline (%string->bytevector s)
    393   (let* ([n (%string-length s)]
    394                [bv (%make-bytevector sz)] )
     376  (let* ((n (%byteblock-length s) #;(%string-length s))
     377               (bv (%make-bytevector sz)) )
    395378    (##core#inline "C_copy_memory" bv s n)
    396379    bv ) )
    397380
     381;Unsafe
     382
     383(define-inline (%bytevector-length bv) (%byteblock-length bv))
     384
     385(define-inline (%bytevector=? bv1 bv2)
     386  (let ((n (%bytevector-length bv1)))
     387    (and (%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
    398414(define-inline (%bytevector->string bv)
    399   (let* ([n (%bytevector-length bv)]
    400                [s (%make-string n #\space)] )
     415  (let* ((n (%bytevector-length bv))
     416               (s (%make-string n #\space)) )
    401417    (##core#inline "C_copy_memory" s bv n)
    402418    s ) )
    403419
    404 
    405 ;; Blob (isa bytevector w/o accessors)
    406 
    407 (define-inline (%make-blob sz) (%make-bytevector sz))
    408 
    409 (define-inline (%blob? x) (%bytevector? x))
    410 
    411 (define-inline (%blob-size b) (%bytevector-length b))
    412 
    413 (define-inline (%blob=? b1 b2) (%bytevector=? b1 b2))
    414 
    415 (define-inline (%string->blob s) (%string->bytevector s))
    416 
    417420(define-inline (%blob->string bv) (%bytevector->string bv))
    418421
     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-length s) (%byteblock-length s))
     429
     430(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
     431
     432(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
     433
     434;; Flonum (byteblock)
     435
     436;Unsafe
     437
     438(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
     439
     440(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
     441(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
     442(define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y))
     443(define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y))
     444(define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y))
     445
     446(define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y))
     447(define-inline (%fpmin x y) (##core#inline "C_i_flonum_min" x y))
     448
     449(define-inline (%finite? x) (##core#inline "C_i_finitep" x))
     450
     451(define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
     452(define-inline (%fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
     453(define-inline (%fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
     454(define-inline (%fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
     455
     456(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
     457
     458(define-inline (%fpnegate x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y))
     459
     460(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
     461(define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x))
     462(define-inline (%fpround x) ((##core#primitive "C_flonum_round") x))
     463(define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x))
     464
     465;Safe
     466
     467(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
     468
     469; Actually 'number' operations
     470(define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
     471(define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
     472(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
     473(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
     474(define-inline (%fpatan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
     475(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
     476(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
     477(define-inline (%fplog x) (##core#inline_allocate ("C_a_i_log" 4) x))
     478(define-inline (%fpsin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
     479(define-inline (%fpsqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
     480(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
     481
     482;; Lambda-info (byteblock)
     483
     484;Unsafe
     485
     486(define-inline (%string->lambda-info s)
     487  (let* ((n (%string-length s))
     488               (li (%make-string sz)) )
     489    (##core#inline "C_copy_memory" li s n)
     490    (##core#inline "C_string_to_lambdainfo" li)
     491    li ) )
     492
     493(define-inline (%lambda-info-length li) (%byteblock-length s))
     494
     495;; Wordblock
     496
     497;Safe
     498
     499(define-inline (%make-wordblock n f a?) (%block-allocate n #f f a?))
     500
     501;Unsafe
     502
     503(define-inline (%wordblock-length wb) (%block-size wb))
     504
     505(define-inline (%wordblock-ref wb i) (##core#inline "C_slot" wb i))
     506
     507(define-inline (%wordblock-set!/mutate wb i v) (##core#inline "C_i_setslot" wb i v))
     508(define-inline (%wordblock-set!/immediate wb i v) (##core#inline "C_i_set_i_slot" wb i v))
     509(define-inline (%wordblock-set! wb i v)
     510  (if (%immediate? v) (%wordblock-set!/immediate wb i v)
     511      (%wordblock-set!/mutate wb i v) ) )
     512
     513;; Generic-vector (wordblock)
     514
     515; generic-vector isa vector, pair, structure, symbol, or keyword
     516(define-inline (%generic-vector? x) (and (%block? x) (not (or (%special? x) (%byteblock? x)))))
     517
     518;; Vector (wordblock)
     519
     520;Safe
     521
     522(define-inline (%make-vector size fill) (%make-wordblock size fill #f))
     523
     524;Unsafe
     525
     526(define-inline (%vector-length v) (%wordblock-length v))
     527
     528(define-inline (%vector-ref v i) (%wordblock-ref v i))
     529
     530(define-inline (%vector-set!/mutate v i x) (%wordblock-set!/mutate v i x))
     531(define-inline (%vector-set!/immediate v i x) (%wordblock-set!/immediate v i x))
     532(define-inline (%vector-set! v i x) (%wordblock-set! v i x))
    419533
    420534;; Pair (wordblock)
    421535
     536;Safe
     537
    422538(define-inline (%null? x) (%eol-object? x))
    423539
     
    428544(define-inline (%length ls) (##core#inline "C_i_length" ls))
    429545
     546;Unsafe
     547
    430548(define-inline (%car pr) (%wordblock-ref pr 0))
     549
     550(define-inline (%set-car!/mutate pr x) (%wordblock-set!/mutate pr 0 x))
     551(define-inline (%set-car!/immediate pr x) (%wordblock-set!/immediate pr 0 x))
     552(define-inline (%set-car! pr x) (%wordblock-set! pr 0 x))
     553
    431554(define-inline (%cdr pr) (%wordblock-ref pr 1))
     555
     556(define-inline (%set-cdr!/mutate pr x) (%wordblock-set!/mutate pr 1 x))
     557(define-inline (%set-cdr!/immediate pr x) (%wordblock-set!/immediate pr 1 x))
     558(define-inline (%set-cdr! pr x) (%wordblock-set! pr 1 x))
    432559
    433560(define-inline (%caar pr) (%car (%car pr)))
     
    445572(define-inline (%cdddr pr) (%cdr (%cddr pr)))
    446573
    447 (define-inline (%set-car! pr x) (%wordblock-set! pr 0 x))
    448 (define-inline (%set-cdr! pr x) (%wordblock-set! pr 1 x))
    449 (define-inline (%set-car!/immediate pr x) (%wordblock-set!/immediate pr 0 x))
    450 (define-inline (%set-cdr!/immediate pr x) (%wordblock-set!/immediate pr 1 x))
    451 (define-inline (%set-car!/maybe-immediate pr x) (%wordblock-set!/maybe-immediate pr 0 x))
    452 (define-inline (%set-cdr!/maybe-immediate pr x) (%wordblock-set!/maybe-immediate pr 1 x))
    453 
    454 ;; These are safe
     574;Safe
    455575
    456576(define-inline (%memq x ls) (##core#inline "C_i_memq" x ls))
     
    462582(define-inline (%assoc x ls) (##core#inline "C_i_assoc" x ls))
    463583
     584;Unsafe
     585
    464586(define-inline (%list-ref ls0 i0)
    465587  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    466   (let loop ([ls ls0] [i i0])
    467     (cond [(%null? ls)  '() ]
    468                 [(%fx= 0 i)   (%car ls) ]
    469                 [else         (loop (%cdr ls) (%fx- i 1)) ] ) ) )
     588  (let loop ((ls ls0) (i i0))
     589    (cond ((%null? ls)  '() )
     590                ((%fx= 0 i)   (%car ls) )
     591                (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    470592
    471593(define-inline (%list-pair-ref ls0 i0)
    472594  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    473   (let loop ([ls ls0] [i i0])
    474     (cond [(%null? ls)  '() ]
    475                 [(%fx= 0 i)   ls ]
    476                 [else         (loop (%cdr ls) (%fx- i 1)) ] ) ) )
     595  (let loop ((ls ls0) (i i0))
     596    (cond ((%null? ls)  '() )
     597                ((%fx= 0 i)   ls )
     598                (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    477599
    478600(define-inline (%last-pair ls0)
    479   ;(assert (and (proper-list? ls0) (not (null? ls0))))
    480   (do ([ls ls0 (%cdr ls)])
    481       [(%null? (%cdr ls)) ls]) )
     601  ;(assert (and (proper-list? ls0) (pair? ls0)))
     602  (do ((ls ls0 (%cdr ls)))
     603      ((%null? (%cdr ls)) ls)) )
    482604
    483605(define-inline (%list-copy ls0)
    484606  ;(assert (proper-list? ls0))
    485   (let loop ([ls ls0])
     607  (let copy-rest ((ls ls0))
    486608    (if (%null? ls) '()
    487         (%cons (%car ls) (loop (%cdr ls))) ) ) )
     609        (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
    488610
    489611(define-inline (%append! . lss)
    490   ;(assert (and (proper-list? lss) (for-each (lambda (x) (proper-list? x)) lss)))
    491   (let ([lss (let position-at-first-pair ([lss lss])
    492                (cond [(%null? lss)        '() ]
    493                      [(%null? (%car lss))  (position-at-first-pair (%cdr lss)) ]
    494                      [else                 lss ] ) ) ] )
     612  ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
     613  (let ((lss (let position-at-first-pair ((lss lss))
     614               (cond ((%null? lss)        '() )
     615                     ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
     616                     (else                 lss ) ) ) ) )
    495617    (if (%null? lss) '()
    496         (let ([ls0 (%car lss)])
    497           ;(assert (not (null? ls0)))
    498           (let append!-rest ([lss (%cdr lss)] [pls ls0])
     618        (let ((ls0 (%car lss)))
     619          ;(assert (pair? ls0))
     620          (let append!-rest ((lss (%cdr lss)) (pls ls0))
    499621            (if (%null? lss) ls0
    500                 (let ([ls (%car lss)])
    501                   (cond [(%null? ls)
    502                          (append!-rest (%cdr lss) pls) ]
    503                         [else
    504                          (%set-cdr! (%last-pair pls) ls)
    505                          (append!-rest (%cdr lss) ls) ] ) ) ) ) ) ) ) )
     622                (let ((ls (%car lss)))
     623                  (cond ((%null? ls)
     624                         (append!-rest (%cdr lss) pls) )
     625                        (else
     626                         (%set-cdr!/mutate (%last-pair pls) ls)
     627                         (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
    506628
    507629(define-inline (%delq! x ls0)
    508630  ;(assert (proper-list? ls0))
    509   (let find-elm ([ls ls0] [ppr #f])
    510     (cond [(%null? ls)
    511            ls0 ]
    512                 [(%eq? x (%car ls))
    513                  (cond [ppr
    514                         (%set-cdr!/maybe-immediate ppr (%cdr ls))
    515                         ls0 ]
    516                        [else
    517                         (%cdr ls) ] ) ]
    518                 [else
    519                  (find-elm (%cdr ls) ls) ] ) ) )
     631  (let find-elm ((ls ls0) (ppr #f))
     632    (cond ((%null? ls)
     633           ls0 )
     634                ((%eq? x (%car ls))
     635                 (cond (ppr
     636                        (%set-cdr! ppr (%cdr ls))
     637                        ls0 )
     638                       (else
     639                        (%cdr ls) ) ) )
     640                (else
     641                 (find-elm (%cdr ls) ls) ) ) ) )
    520642
    521643(define-inline (%list-fold-1 func init ls0)
    522644  ;(assert (and (proper-list? ls0) (procedure? func)))
    523   (let loop ([ls ls0] [acc init])
     645  (let loop ((ls ls0) (acc init))
    524646    (if (%null? ls) acc
    525647        (loop (%cdr ls) (func (%car ls) acc)) ) ) )
     
    527649(define-inline (%list-map-1 func ls0)
    528650  ;(assert (and (proper-list? ls0) (procedure? func)))
    529   (let loop ([ls ls0])
     651  (let loop ((ls ls0))
    530652    (if (%null? ls) '()
    531653        (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
     
    533655(define-inline (%list-for-each-1 proc ls0)
    534656  ;(assert (and (proper-list? ls0) (procedure? proc)))
    535   (let loop ([ls ls0])
     657  (let loop ((ls ls0))
    536658    (unless (%null? ls)
    537659      (proc (%car ls))
    538660      (loop (%cdr ls)) ) ) )
    539661
    540 
    541662;; Structure (wordblock)
    542663
     
    545666(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
    546667
     668(define-inline (%structure-length r) (%wordblock-length r))
     669
     670(define-inline (%structure-tag r) (%wordblock-ref r 0))
     671
    547672(define-inline (%structure-ref r i) (%wordblock-ref r i))
    548673
     674(define-inline (%structure-set!/mutate r i x) (%wordblock-set!/mutate r i x))
     675(define-inline (%structure-set!/immediate r i x) (%wordblock-set!/immediate r i x))
    549676(define-inline (%structure-set! r i x) (%wordblock-set! r i x))
    550 (define-inline (%structure-set!/immediate r i x) (%wordblock-set!/immediate r i x))
    551 (define-inline (%structure-set!/maybe-immediate r i x) (%wordblock-set!/maybe-immediate r i x))
    552 
    553 (define-inline (%structure-length r) (%block-size r))
    554 
    555 (define-inline (%structure-tag r) (%wordblock-ref r 0))
    556 
    557677
    558678;; Port (wordblock)
     
    560680; Port layout:
    561681;
    562 ; 0       FP (special - C FILE *)
     682; 0       FP (special - FILE *)
    563683; 1       input/output (bool)
    564684; 2       class (vector, see Port-class)
     
    572692; 10-15  reserved, port class specific
    573693
    574 ; port is 16 slots + a block-header word
    575 ;
    576 ;(define-inline (%make-port n) (##core#inline_allocate ("C_a_i_port" 17)))
    577 
    578694(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    579695(define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
     
    589705(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
    590706(define-inline (%port-input-mode-set! port f) (%wordblock-set!/immediate port 1 f))
    591 (define-inline (%port-class port v) (%wordblock-set! port 2 v))
    592 (define-inline (%port-name-set! port s) (%wordblock-set! port 3 s))
     707(define-inline (%port-class-set! port v) (%wordblock-set!/mutate port 2 v))
     708(define-inline (%port-name-set! port s) (%wordblock-set!/mutate port 3 s))
    593709(define-inline (%port-row-set! port n) (%wordblock-set!/immediate port 4 n))
    594710(define-inline (%port-column-set! port n) (%wordblock-set!/immediate port 5 n))
    595711(define-inline (%port-eof-set! port f) (%wordblock-set!/immediate port 6 f))
    596 (define-inline (%port-type-set! port s) (%wordblock-set! port 7 s))
     712(define-inline (%port-type-set! port s) (%wordblock-set!/mutate port 7 s))
    597713(define-inline (%port-closed-set! port f) (%wordblock-set!/immediate port 8 f))
    598 (define-inline (%port-data-set! port port) (%wordblock-set! port 9 x))
     714(define-inline (%port-data-set! port port) (%wordblock-set!/mutate port 9 x))
     715
     716(define-inline (%make-port i/o class name type)
     717  ; port is 16 slots + a block-header word
     718  (let ((port (##core#inline_allocate ("C_a_i_port" 17))))
     719    (%port-input-mode-set! port i/o)
     720    (%port-class-set! port class)
     721    (%port-name-set! port name)
     722    (%port-row-set! port 1)
     723    (%port-column-set! port 0)
     724    (%port-type-set! port type)
     725    port ) )
    599726
    600727; Port-class layout
     
    610737; 8       (read-line PORT LIMIT) -> STRING | EOF
    611738
     739(define-inline (%make-port-class rc pc wc ws cl fl cr rs rl)
     740  (let ((class (%make-vector 9 #f)))
     741    (%vector-set! class 0 rc)
     742    (%vector-set! class 1 pc)
     743    (%vector-set! class 2 wc)
     744    (%vector-set! class 3 ws)
     745    (%vector-set! class 4 cl)
     746    (%vector-set! class 5 fl)
     747    (%vector-set! class 6 cr)
     748    (%vector-set! class 7 rs)
     749    (%vector-set! class 8 rl)
     750    class ) )
     751
     752(define-inline (%port-class-read-char-ref c) (%vector-ref c 0))
     753(define-inline (%port-class-peek-char-ref c) (%vector-ref c 1))
     754(define-inline (%port-class-write-char-ref c) (%vector-ref c 2))
     755(define-inline (%port-class-write-string-ref c) (%vector-ref c 3))
     756(define-inline (%port-class-close-ref c) (%vector-ref c 4))
     757(define-inline (%port-class-flush-output-ref c) (%vector-ref c 5))
     758(define-inline (%port-class-char-ready-ref c) (%vector-ref c 6))
     759(define-inline (%port-class-read-string-ref c) (%vector-ref c 7))
     760(define-inline (%port-class-read-line-ref c) (%vector-ref c 8))
     761
     762(define-inline (%port-class-read-char c p) ((%port-class-read-char-ref c) p) )
     763(define-inline (%port-class-peek-char c p) ((%port-class-peek-char-ref c) p))
     764(define-inline (%port-class-write-char c p c) ((%port-class-write-char-ref c) p c))
     765(define-inline (%port-class-write-string c p s) ((%port-class-write-string-ref c) p s))
     766(define-inline (%port-class-close c p) ((%port-class-close-ref c) p))
     767(define-inline (%port-class-flush-output c p) ((%port-class-flush-output-ref c) p))
     768(define-inline (%port-class-char-ready? c p) ((%port-class-char-ready-ref c) p))
     769(define-inline (%port-class-read-string! c p n d s) ((%port-class-read-string-ref c) p n d s))
     770(define-inline (%port-class-read-line c p l) ((%port-class-read-line-ref c) p l))
     771
     772(define-inline (%port-read-char p) ((%port-class-read-char-ref (%port-class p)) p) )
     773(define-inline (%port-peek-char p) ((%port-class-peek-char-ref (%port-class p)) p))
     774(define-inline (%port-write-char p c) ((%port-class-write-char-ref (%port-class p)) p c))
     775(define-inline (%port-write-string p s) ((%port-class-write-string-ref (%port-class p)) p s))
     776(define-inline (%port-close p) ((%port-class-close-ref (%port-class p)) p))
     777(define-inline (%port-flush-output p) ((%port-class-flush-output-ref (%port-class p)) p))
     778(define-inline (%port-char-ready? p) ((%port-class-char-ready-ref (%port-class p)) p))
     779(define-inline (%port-read-string! p n d s) ((%port-class-read-string-ref (%port-class p)) p n d s))
     780(define-inline (%port-read-line p l) ((%port-class-read-line-ref (%port-class p)) p l))
    612781
    613782;; Closure (wordblock)
    614783
    615 (define-inline (%closure-size c) (%block-size? c))
     784;Unsafe
     785
     786(define-inline (%make-closure! n)
     787  (let ((v (%make-vector n)))
     788    (##core#inline "C_vector_to_closure" v)
     789    v ) )
    616790
    617791(define-inline (%vector->closure! v a)
     
    619793  (##core#inline "C_update_pointer" a v) )
    620794
     795(define-inline (%closure-length c) (%wordblock-length? c))
     796
     797(define-inline (%closure-ref c i) (%wordblock-ref c i))
     798
     799(define-inline (%closure-set! c i v) (%wordblock-set! c i v))
     800
     801(define-inline (%closure-copy tc fc l)
     802  (do ((i 1 (%fxadd1 i)))
     803      ((%fx>= i l))
     804    (%closure-set! tc i (%closure-ref fc i)) ) )
     805
     806(define-inline (%closure-decoration c t)
     807  (let find-decor ((i (%fxsub1 (%closure-length c))))
     808    (and (%fxpositive? i)
     809         (let ((x (%closure-ref c i)))
     810           (if (t x) x
     811               (find-decor (%fxsub1 i)) ) ) ) ) )
     812
     813(define-inline (%closure-decorate! c t d)
     814  (let ((l (%closure-length c)))
     815    (let find-decor ((i (%fxsub l)))
     816      (cond ((%fxzero? i)
     817             (let ((nc (%make-closure (%fxadd1 l))))
     818               (%closure-copy nc c l)
     819               (##core#inline "C_copy_pointer" c nc)
     820               (d nc i) ) )
     821            (else
     822             (let ((x (%closure-ref c i)))
     823               (if (t x) (d c i)
     824                   (find-decor (%fxsub i)) ) ) ) ) ) ) )
     825
     826(define-inline (%closure-lambda-info c)
     827  (%closure-decoration c (lambda (x) (%lambda-info? x))) )
    621828
    622829;; Symbol (wordblock)
     
    634841(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))
    635842
    636 
    637843;; Keyword (wordblock)
    638844
    639 (define-inline (%keyword? x)
    640   (and (%symbol? x)
    641        (%eq? 0 (%byteblock-ref (%symbol-string x) 0)) ) )
    642 
     845(define-inline (%keyword? x) (and (%symbol? x) (%fx= 0 (%byteblock-ref (%symbol-string x) 0))))
     846
     847;; Pointer (wordblock)
     848
     849; simple-pointer, tagged-pointer, swig-pointer, locative
     850(define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
     851
     852; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
     853(define-inline (%pointer-like? x) (%wordblock? x))
     854
     855; These operate on pointer-like objects
     856
     857(define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
     858
     859(define-inline (%pointer-ref ptr) (%wordblock-ref ptr 0))
     860(define-inline (%pointer-set! ptr y) (%wordblock-set!/mutate ptr 0 y))
     861
     862(define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
     863
     864(define-inline (%pointer->address ptr)
     865  ; Pack pointer address value into Chicken words; '4' is platform dependent!
     866  (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref x)) )
     867
     868;; Simple-pointer (wordblock)
     869
     870(define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))
     871
     872(define-inline (%make-pointer-null)
     873  (let ((ptr (%make-simple-pointer)))
     874    (##core#inline "C_update_pointer" 0 ptr)
     875    ptr ) )
     876
     877(define-inline (%address->pointer a)
     878  (let ((ptr (%make-simple-pointer)))
     879    (##core#inline "C_update_pointer" a ptr)
     880    ptr ) )
     881
     882(define-inline (%make-block-pointer b)
     883  (let ((ptr (%make-simple-pointer)))
     884    (##core#inline "C_pointer_to_block" ptr b)
     885    ptr ) )
     886
     887;; Tagged-pointer (wordblock)
     888
     889(define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))
     890
     891;; Swig-pointer (wordblock)
    643892
    644893;; Locative (wordblock)
     
    664913; 3     Object or #f, if weak (C_word)
    665914
    666 ;%locative-address - see Pointer
     915(define-inline (%locative-address lv) (%pointer->address lv))
     916
    667917(define-inline (%locative-offset lv) (%wordblock-ref lv 1))
    668918(define-inline (%locative-type lv) (%wordblock-ref lv 2))
     
    670920(define-inline (%locative-object lv) (%wordblock-ref lv 3))
    671921
    672 
    673 ;; Pointer (wordblock)
    674 
    675 ; simple-pointer, tagged-pointer, swig-pointer, locative
    676 (define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
    677 
    678 ; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
    679 (define-inline (%pointer-like? x) (%wordblock? x))
    680 
    681 ; These operate on pointer-like objects
    682 
    683 (define-inline (%pointer-ref ptr) (%wordblock-ref ptr 0))
    684 (define-inline (%pointer-set! ptr y) (%wordblock-set! ptr 0 y))
    685 
    686 (define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
    687 
    688 (define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
    689 
    690 (define-inline (%pointer->address ptr)
    691   ; Pack pointer address value into Chicken words; '4' is platform dependent!
    692   (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref x)) )
    693 
    694 (define-inline (%locative-address lv) (%pointer->address lv))
    695 
    696 
    697 ;; Simple-pointer (wordblock)
    698 
    699 (define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))
    700 
    701 (define-inline (%make-pointer-null)
    702   (let ([ptr (%make-simple-pointer)])
    703     (##core#inline "C_update_pointer" 0 ptr)
    704     ptr ) )
    705 
    706 (define-inline (%address->pointer a)
    707   (let ([ptr (%make-simple-pointer)])
    708     (##core#inline "C_update_pointer" a ptr)
    709     ptr ) )
    710 
    711 (define-inline (%make-pointer-block b)
    712   (let ([ptr (%make-simple-pointer)])
    713     (##core#inline "C_pointer_to_block" ptr b)
    714     ptr ) )
    715 
    716 
    717 ;; Tagged-pointer (wordblock)
    718 
    719 (define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))
    720 
    721 
    722 ;; Swig-pointer (wordblock)
    723 
    724 
    725 
    726 ;;; Values
    727 
    728 
    729 
    730 ;;; Numbers
    731 
    732 (define-inline (%number? x) (or (%fixnum? x) (%flonum? x) ) )
    733 
    734 
    735 ;;; Operations
    736 
    737 
    738 ;; Random
    739 
    740 (define-inline (%random-fixnum x) (##core#inline "C_random_fixnum" x))
     922;; Numbers
     923
     924;Safe
     925
     926(define-inline (%number? x) (or (%fixnum? x) (%flonum? x)))
     927(define-inline (%integer? x) (##core#inline "C_i_integerp" x))
     928
     929(define-inline (%= x y) ((##core#primitive "C_i_eqvp") x y))
     930(define-inline (%< x y) ((##core#primitive "C_i_lessp") x y))
     931(define-inline (%<= x y) ((##core#primitive "C_i_less_or_equalp") x y))
     932(define-inline (%> x y) ((##core#primitive "C_i_greaterp") x y))
     933(define-inline (%>= x y) ((##core#primitive "C_i_greater_or_equalp") x y))
     934
     935(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
     936(define-inline (%positive? n) (##core#inline "C_i_positivep" n))
     937(define-inline (%negative? n) (##core#inline "C_i_negativep" n))
     938(define-inline (%cardinal? n) (and (%integer? x) (%<= 0 n)))
     939(define-inline (%odd? n) (##core#inline "C_i_oddp" n))
     940(define-inline (%even? n) (##core#inline "C_i_evenp" n))
     941
     942(define-inline (%- x y) ((##core#primitive "C_minus") x y))
     943(define-inline (%* x y) ((##core#primitive "C_times") x y))
     944(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
     945(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
     946
     947(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
     948(define-inline (%remainder x y) (let ((quo (%quotient x y))) (%- x (%* quo y))))
     949
     950(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
     951(define-inline (%abs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
     952(define-inline (%acos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
     953(define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
     954(define-inline (%atan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
     955(define-inline (%atan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
     956(define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
     957(define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
     958(define-inline (%log x) (##core#inline_allocate ("C_a_i_log" 4) x))
     959(define-inline (%sin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
     960(define-inline (%sqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
     961(define-inline (%tan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
     962
     963(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
     964(define-inline (%bitwise-xor x y) (##core#inline_allocate ("C_a_i_bitwise_xor" 4) x y))
     965(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
     966(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
     967
     968(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
     969
     970(define-inline (%bit-set? n i) (##core#inline "C_i_bit_setp" n i))
     971
     972(define-inline (%randomize n) (##core#inline "C_randomize" n))
  • release/4/mailbox/trunk/chicken-primitive-object-inlines.scm

    r13664 r13698  
    3737;;; Unsafe Type Predicates
    3838
    39 ;; Immediate
    40 
    41 (define-inline (%immediate? x) (##core#inline "C_immp" x))
    42 
    4339;; Fixnum
    4440
     
    6965(define-inline (%unbound-type? x) (##core#inline "C_unboundvaluep" x))
    7066
    71 ;; Block (anything not immediate)
    72 
    73 (define-inline (%block? x) (##core#inline "C_blockp" x))
    74 
    75 ;; Special
    76 
    77 (define-inline (%special? x) (##core#inline "C_specialp" x))
    78 
    7967;; Byteblock
    8068
     
    9684
    9785(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
    98 
    99 ;; Wordblock (special block)
    100 
    101 (define-inline (%wordblock? x) (and (%block? x) (%special? x)))
    10286
    10387;; Vector
     
    378362; generic-byteblock isa bytevector, string, flonum, or lambda-info
    379363(define-inline (%generic-byteblock? x)
    380   (or (bytevector? x) (string? x) (flonum? x) (lambda-info? x)))
     364  (or (bytevector? x) (string? x) (flonum? x) (lambda-info? x)) )
    381365
    382366;; Bytevector (byteblock)
     
    402386  (let ((n (%bytevector-length bv1)))
    403387    (and (%fx= n (%bytevector-length bv2))
    404          (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) )
     388         (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
    405389
    406390(define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
Note: See TracChangeset for help on using the changeset viewer.