Changeset 13664 in project


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

Save.

Location:
release/4/mailbox/trunk
Files:
3 edited

Legend:

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

    r13617 r13664  
    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
    246279
     280;Safe
     281
    247282(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
    248283
    249284(define-inline (%peek-signed-integer b i) ((##core#primitive "C_peek_signed_integer") b i))
    250 
    251285(define-inline (%peek-unsigned-integer b i) ((##core#primitive "C_peek_unsigned_integer") b i))
    252 
    253286(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
    254287
    255 
    256288;; Fixnum
    257289
    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))
     290;Safe
     291
     292(define-inline (%fxrandom x) (##core#inline "C_random_fixnum" x))
     293
     294;Unsafe
     295
    261296(define-inline (%fx= x y) (%eq? x y))
    262297(define-inline (%fx> x y) (##core#inline "C_fixnum_greaterp" x y))
     
    264299(define-inline (%fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
    265300(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
    266313(define-inline (%fxmin x y) (##core#inline "C_i_fixnum_min" x y))
    267314(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
    268328(define-inline (%fxneg x) (##core#inline "C_fixnum_negate" x))
     329(define-inline (%fxabs fx) (if (%fxnegative? fx) (%fxneg fx) fx))
     330
    269331(define-inline (%fxand x y) (##core#inline "C_fixnum_and" x y))
    270332(define-inline (%fxior x y) (##core#inline "C_fixnum_or" x y))
    271333(define-inline (%fxxor x y) (##core#inline "C_fixnum_xor" x y))
    272334(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 
     335
     336;; Block
     337
     338;Safe
     339
     340(define-inline (%block-address b) (##core#inline_allocate ("C_block_address" 4) b))
    283341
    284342;; Size of object in units of sub-object.
    285343
    286 ; byteblock is # of bytes, otherwise # of words.
     344; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
    287345;
    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
     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
    304363
    305364(define-inline (%make-byteblock n f a?) (%block-allocate n #t f a?))
    306365
    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 
     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))
    328373
    329374;; Generic-byteblock
    330375
    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)
     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
    375385
    376386(define-inline (%make-bytevector sz)
    377   (let ([bv (%make-string sz #f #t)])
     387  (let ((bv (%make-byteblock sz #f #t)))
    378388    (##core#inline "C_string_to_bytevector" bv)
    379389    bv ) )
    380390
    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 
    392391(define-inline (%string->bytevector s)
    393   (let* ([n (%string-length s)]
    394                [bv (%make-bytevector sz)] )
     392  (let* ((n (%byteblock-length s) #;(%string-length s))
     393               (bv (%make-bytevector sz)) )
    395394    (##core#inline "C_copy_memory" bv s n)
    396395    bv ) )
    397396
     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))
     421
     422;; String (byteblock)
     423
     424;Safe
     425
     426(define-inline (%make-string size fill) (%make-byteblock size fill #f))
     427
     428;Unsafe
     429
    398430(define-inline (%bytevector->string bv)
    399   (let* ([n (%bytevector-length bv)]
    400                [s (%make-string n #\space)] )
     431  (let* ((n (%bytevector-length bv))
     432               (s (%make-string n #\space)) )
    401433    (##core#inline "C_copy_memory" s bv n)
    402434    s ) )
    403435
    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 
    417436(define-inline (%blob->string bv) (%bytevector->string bv))
    418437
     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
     446(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
     447
     448(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
     449
     450;; Flonum (byteblock)
     451
     452;Unsafe
     453
     454(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))
     464
     465(define-inline (%finite? x) (##core#inline "C_i_finitep" x))
     466
     467(define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
     468(define-inline (%fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
     469(define-inline (%fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
     470(define-inline (%fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
     471
     472(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
     473
     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
     486(define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
     487(define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
     488(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
     489(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
     490(define-inline (%fpatan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
     491(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
     492(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
     493(define-inline (%fplog x) (##core#inline_allocate ("C_a_i_log" 4) x))
     494(define-inline (%fpsin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
     495(define-inline (%fpsqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
     496(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
     497
     498;; Lambda-info (byteblock)
     499
     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)
     530
     531; generic-vector isa vector, pair, structure, symbol, or keyword
     532(define-inline (%generic-vector? x) (and (%block? x) (not (or (%special? x) (%byteblock? x)))))
     533
     534;; Vector (wordblock)
     535
     536;Safe
     537
     538(define-inline (%make-vector size fill) (%make-wordblock size fill #f))
     539
     540;Unsafe
     541
     542(define-inline (%vector-length v) (%wordblock-length v))
     543
     544(define-inline (%vector-ref v i) (%wordblock-ref v i))
     545
     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))
     548(define-inline (%vector-set! v i x) (%wordblock-set! v i x))
    419549
    420550;; Pair (wordblock)
    421551
     552;Safe
     553
    422554(define-inline (%null? x) (%eol-object? x))
    423555
     
    428560(define-inline (%length ls) (##core#inline "C_i_length" ls))
    429561
     562;Unsafe
     563
    430564(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
    431570(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))
    432575
    433576(define-inline (%caar pr) (%car (%car pr)))
     
    445588(define-inline (%cdddr pr) (%cdr (%cddr pr)))
    446589
    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
     590;Safe
    455591
    456592(define-inline (%memq x ls) (##core#inline "C_i_memq" x ls))
     
    462598(define-inline (%assoc x ls) (##core#inline "C_i_assoc" x ls))
    463599
     600;Unsafe
     601
    464602(define-inline (%list-ref ls0 i0)
    465603  ;(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)) ] ) ) )
     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)) ) ) ) )
    470608
    471609(define-inline (%list-pair-ref ls0 i0)
    472610  ;(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)) ] ) ) )
     611  (let loop ((ls ls0) (i i0))
     612    (cond ((%null? ls)  '() )
     613                ((%fx= 0 i)   ls )
     614                (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    477615
    478616(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]) )
     617  ;(assert (and (proper-list? ls0) (pair? ls0)))
     618  (do ((ls ls0 (%cdr ls)))
     619      ((%null? (%cdr ls)) ls)) )
    482620
    483621(define-inline (%list-copy ls0)
    484622  ;(assert (proper-list? ls0))
    485   (let loop ([ls ls0])
     623  (let copy-rest ((ls ls0))
    486624    (if (%null? ls) '()
    487         (%cons (%car ls) (loop (%cdr ls))) ) ) )
     625        (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
    488626
    489627(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 ] ) ) ] )
     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 ) ) ) ) )
    495633    (if (%null? lss) '()
    496         (let ([ls0 (%car lss)])
    497           ;(assert (not (null? ls0)))
    498           (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))
    499637            (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) ] ) ) ) ) ) ) ) )
     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) ) ) ) ) ) ) ) ) )
    506644
    507645(define-inline (%delq! x ls0)
    508646  ;(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) ] ) ) )
     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) ) ) ) )
    520658
    521659(define-inline (%list-fold-1 func init ls0)
    522660  ;(assert (and (proper-list? ls0) (procedure? func)))
    523   (let loop ([ls ls0] [acc init])
     661  (let loop ((ls ls0) (acc init))
    524662    (if (%null? ls) acc
    525663        (loop (%cdr ls) (func (%car ls) acc)) ) ) )
     
    527665(define-inline (%list-map-1 func ls0)
    528666  ;(assert (and (proper-list? ls0) (procedure? func)))
    529   (let loop ([ls ls0])
     667  (let loop ((ls ls0))
    530668    (if (%null? ls) '()
    531669        (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
     
    533671(define-inline (%list-for-each-1 proc ls0)
    534672  ;(assert (and (proper-list? ls0) (procedure? proc)))
    535   (let loop ([ls ls0])
     673  (let loop ((ls ls0))
    536674    (unless (%null? ls)
    537675      (proc (%car ls))
    538676      (loop (%cdr ls)) ) ) )
    539677
    540 
    541678;; Structure (wordblock)
    542679
     
    545682(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
    546683
     684(define-inline (%structure-length r) (%wordblock-length r))
     685
     686(define-inline (%structure-tag r) (%wordblock-ref r 0))
     687
    547688(define-inline (%structure-ref r i) (%wordblock-ref r i))
    548689
     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))
    549692(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 
    557693
    558694;; Port (wordblock)
     
    560696; Port layout:
    561697;
    562 ; 0       FP (special - C FILE *)
     698; 0       FP (special - FILE *)
    563699; 1       input/output (bool)
    564700; 2       class (vector, see Port-class)
     
    572708; 10-15  reserved, port class specific
    573709
    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 
    578710(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    579711(define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
     
    589721(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
    590722(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))
     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))
    593725(define-inline (%port-row-set! port n) (%wordblock-set!/immediate port 4 n))
    594726(define-inline (%port-column-set! port n) (%wordblock-set!/immediate port 5 n))
    595727(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))
     728(define-inline (%port-type-set! port s) (%wordblock-set!/mutate port 7 s))
    597729(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))
     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 ) )
    599742
    600743; Port-class layout
     
    610753; 8       (read-line PORT LIMIT) -> STRING | EOF
    611754
     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))
    612797
    613798;; Closure (wordblock)
    614799
    615 (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 ) )
    616806
    617807(define-inline (%vector->closure! v a)
     
    619809  (##core#inline "C_update_pointer" a v) )
    620810
     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))) )
    621844
    622845;; Symbol (wordblock)
     
    634857(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))
    635858
    636 
    637859;; Keyword (wordblock)
    638860
    639 (define-inline (%keyword? x)
    640   (and (%symbol? x)
    641        (%eq? 0 (%byteblock-ref (%symbol-string x) 0)) ) )
    642 
     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)
    643908
    644909;; Locative (wordblock)
     
    664929; 3     Object or #f, if weak (C_word)
    665930
    666 ;%locative-address - see Pointer
     931(define-inline (%locative-address lv) (%pointer->address lv))
     932
    667933(define-inline (%locative-offset lv) (%wordblock-ref lv 1))
    668934(define-inline (%locative-type lv) (%wordblock-ref lv 2))
     
    670936(define-inline (%locative-object lv) (%wordblock-ref lv 3))
    671937
    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))
     938;; Numbers
     939
     940;Safe
     941
     942(define-inline (%number? x) (or (%fixnum? x) (%flonum? x)))
     943(define-inline (%integer? x) (##core#inline "C_i_integerp" 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
     951(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
     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))
     957
     958(define-inline (%- x y) ((##core#primitive "C_minus") x y))
     959(define-inline (%* x y) ((##core#primitive "C_times") x y))
     960(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
     961(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
     962
     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))))
     965
     966(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
     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))
     978
     979(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))
     981(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
     982(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
     983
     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/mailbox/trunk/chicken-thread-object-inlines.scm

    r13617 r13664  
    3838
    3939(define-inline (%mutex-thread-set! mx th)
    40   (%structure-set! mx 2 th) )
     40  (%structure-set!/mutate mx 2 th) )
    4141
    4242(define-inline (%mutex-thread-clear! mx)
     
    4747
    4848(define-inline (%mutex-waiters-set! mx wt)
    49   (%structure-set! mx 3 wt) )
     49  (%structure-set!/mutate mx 3 wt) )
    5050
    5151(define-inline (%mutex-waiters-empty? mx)
     
    8383
    8484(define-inline (%mutex-specific-set! mx x)
    85   (%structure-set! mx 6 x) )
     85  (%structure-set!/mutate mx 6 x) )
    8686
    8787
     
    118118
    119119(define-inline (%thread-thunk-set! th tk)
    120   (%structure-set! th 1 tk) )
     120  (%structure-set!/mutate th 1 tk) )
    121121
    122122(define-inline (%thread-results th)
     
    124124
    125125(define-inline (%thread-results-set! th rs)
    126   (%structure-set! th 2 rs) )
     126  (%structure-set!/mutate th 2 rs) )
    127127
    128128(define-inline (%thread-state th)
     
    130130
    131131(define-inline (%thread-state-set! th st)
    132   (%structure-set! th 3 st) )
     132  (%structure-set!/mutate th 3 st) )
    133133
    134134(define-inline (%thread-block-timeout th)
     
    145145
    146146(define-inline (%thread-state-buffer-set! th v)
    147   (%structure-set! th 5 v) )
     147  (%structure-set!/mutate th 5 v) )
    148148
    149149(define-inline (%thread-name th)
     
    154154
    155155(define-inline (%thread-reason-set! th cd)
    156   (%structure-set! th 7 cd) )
     156  (%structure-set!/mutate th 7 cd) )
    157157
    158158(define-inline (%thread-mutexes th)
     
    160160
    161161(define-inline (%thread-mutexes-set! th wt)
    162   (%structure-set! th 8 wx) )
     162  (%structure-set!/mutate th 8 wx) )
    163163
    164164(define-inline (%thread-mutexes-empty? th)
     
    184184
    185185(define-inline (%thread-specific-set! th x)
    186   (%structure-set! th 10 x) )
     186  (%structure-set!/mutate th 10 x) )
    187187
    188188(define-inline (%thread-block-object th)
     
    190190
    191191(define-inline (%thread-block-object-set! th x)
    192   (%structure-set! th 11 x) )
     192  (%structure-set!/mutate th 11 x) )
    193193
    194194(define-inline (%thread-block-object-clear! th)
     
    199199
    200200(define-inline (%thread-recipients-set! th x)
    201   (%structure-set! th 12 x) )
     201  (%structure-set!/mutate th 12 x) )
    202202
    203203(define-inline (%thread-recipients-empty? th)
     
    271271
    272272(define-inline (%condition-variable-waiters-set! cv x)
    273   (%structure-set! cv 2 x) )
     273  (%structure-set!/mutate cv 2 x) )
    274274
    275275(define-inline (%condition-variable-waiters-empty? cv)
     
    295295
    296296(define-inline (%condition-variable-specific-set! cv x)
    297   (%structure-set! cv 3 x) )
     297  (%structure-set!/mutate cv 3 x) )
  • release/4/mailbox/trunk/mailbox.scm

    r13650 r13664  
    4444  (%structure-ref q 1) )
    4545
    46 (define-inline (%queue-first-pair-set! q v)
    47   (%structure-set! q 1 v) )
    48 
    4946(define-inline (%queue-last-pair q)
    5047  (%structure-ref q 2) )
    5148
    52 (define-inline (%queue-last-pair-set! q v)
    53   (%structure-set! q 2 v) )
     49(define-inline (%queue-valid? obj)
     50  (and #;(%queue? obj) (%fx= 3 (%structure-length obj))
     51       (%list? (%queue-first-pair q))
     52       (%list? (%queue-last-pair q)) ) )
    5453
    5554(define-inline (%queue-empty? q)
     
    5857(define-inline (%queue-count q)
    5958  (%length (%queue-first-pair q)) )
     59
     60(define-inline (%queue-first-pair-set! q v)
     61  (%structure-set!/mutate  q 1 v) )
     62
     63(define-inline (%queue-last-pair-set! q v)
     64  (%structure-set!/mutate q 2 v) )
    6065
    6166;; Queue Operations
     
    6772  (let ((new-pair (%cons datum '())))
    6873    (if (%null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
    69         (%set-cdr! (%queue-last-pair q) new-pair) )
     74        (%set-cdr!/mutate (%queue-last-pair q) new-pair) )
    7075    (%queue-last-pair-set! q new-pair) ) )
    7176
     
    97102          ; At the head of the list, or in the body?
    98103          (if (%null? prev-pair) (%queue-first-pair-set! q next-pair)
    99               (%set-cdr! prev-pair next-pair) )
     104              (%set-cdr!/mutate prev-pair next-pair) )
    100105          ; When the cut pair is the last item update the last pair ref.
    101106          (when (%eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) )
     
    120125  (%structure-ref mb 2) )
    121126
     127(define-inline (%mailbox-queue-first-pair mb)
     128  (%queue-first-pair (%mailbox-queue mb)) )
     129
     130(define-inline (%mailbox-queue-last-pair mb)
     131  (%queue-last-pair (%mailbox-queue mb)) )
     132
    122133(define-inline (%mailbox-queue-empty? mb)
    123134  (%queue-empty? (%mailbox-queue mb)) )
     
    138149  (%queue-push-back-list! (%mailbox-queue mb) ls) )
    139150
    140 (define-inline (%mailbox-queue-first-pair mb)
    141   (%queue-first-pair (%mailbox-queue mb)) )
    142 
    143 (define-inline (%mailbox-queue-last-pair mb)
    144   (%queue-last-pair (%mailbox-queue mb)) )
    145 
    146151;; Waiting threads
    147152
     
    149154  (%structure-ref mb 3) )
    150155
    151 (define-inline (%mailbox-waiters-set! mb v)
    152   (%structure-set! mb 3 v) )
    153 
    154156(define-inline (%mailbox-waiters-empty? mb)
    155157  (%null? (%mailbox-waiters mb)) )
     
    157159(define-inline (%mailbox-waiters-count mb)
    158160  (%length (%mailbox-waiters mb)) )
     161
     162(define-inline (%mailbox-waiters-set! mb v)
     163  (%structure-set!/mutate  mb 3 v) )
    159164
    160165(define-inline (%mailbox-waiters-add! mb th)
     
    169174    (%car ts) ) )
    170175
     176;;
     177
     178(define-inline (%mailbox-valid? obj)
     179  (and #;(%mailbox? obj) (%fx= 4 (%structure-length obj))
     180       (%queue-valid? (%mailbox-queue mb))
     181       (%list (%mailbox-waiters mb)) ) )
     182
    171183
    172184;;; Mailbox Cursor Support
     
    181193  (%structure-ref mbc 1) )
    182194
    183 (define-inline (%mailbox-cursor-next-pair-set! mbc v)
    184   (%structure-set! mbc 1 v) )
    185 
    186 (define-inline (%mailbox-cursor-next-pair-empty! mbc)
    187   (%structure-set!/immediate mbc 1 '()) )
    188 
    189195(define-inline (%mailbox-cursor-prev-pair mbc)
    190196  (%structure-ref mbc 2) )
    191197
    192 (define-inline (%mailbox-cursor-prev-pair-set! mbc v)
    193   (%structure-set! mbc 2 v) )
    194 
    195 (define-inline (%mailbox-cursor-prev-pair-clear! mbc)
    196   (%structure-set!/immediate mbc 2 #f) )
     198(define-inline (%mailbox-cursor-mailbox mbc)
     199  (%structure-ref mbc 3) )
     200
     201(define-inline (%mailbox-cursor-valid? obj)
     202  (and #;(%mailbox-cursor? obj) (%fx= 4 (%structure-length obj))
     203       (%mailbox-valid? (%mailbox-cursor-mailbox mbc))
     204       (%list? (%mailbox-cursor-next-pair mbc))
     205       (let ((pp (%mailbox-cursor-prev-pair mbc)))
     206         (or (not pp) (%list? pp) ) ) ) )
    197207
    198208(define-inline (%mailbox-cursor-winding? mbc)
     
    200210       #t) )
    201211
    202 (define-inline (%mailbox-cursor-mailbox mbc)
    203   (%structure-ref mbc 3) )
    204 
    205 (define-inline (%mailbox-cursor-rewind mbc)
     212(define-inline (%mailbox-cursor-next-pair-set! mbc v)
     213  (%structure-set!/mutate  mbc 1 v) )
     214
     215(define-inline (%mailbox-cursor-next-pair-empty! mbc)
     216  (%structure-set!/immediate mbc 1 '()) )
     217
     218(define-inline (%mailbox-cursor-prev-pair-set! mbc v)
     219  (%structure-set!/mutate  mbc 2 v) )
     220
     221(define-inline (%mailbox-cursor-prev-pair-clear! mbc)
     222  (%structure-set!/immediate mbc 2 #f) )
     223
     224(define-inline (%mailbox-cursor-rewind! mbc)
    206225  (%mailbox-cursor-next-pair-empty! mbc)
    207226  (%mailbox-cursor-prev-pair-clear! mbc) )
     
    218237  (%structure-instance? obj 'time) )
    219238
     239(define-inline (%time-valid? obj)
     240  (and #;(%time? obj) (%fx= 4 (%structure-length obj))
     241       (%fixnum? (%structure-ref obj 1))
     242       (%number? (%structure-ref obj 2))
     243       (%fixnum? (%structure-ref obj 3)) ) )
     244
    220245(define-inline (%timeout? obj)
    221246  (or (%time? obj) (%number? obj)) )
     
    231256;;; Argument Checking
    232257
     258(define-inline (%error-type-mailbox loc obj)
     259  (##sys#signal-hook #:type-error loc "bad argument type - not a mailbox" obj) )
     260
     261(define-inline (%error-type-mailbox-cursor loc obj)
     262  (##sys#signal-hook #:type-error loc "bad argument type - not a mailbox-cursor" obj) )
     263
     264(define-inline (%error-type-timeout loc obj)
     265  (##sys#signal-hook #:type-error loc "bad argument type - not a timeout object" obj) )
     266
     267(define-inline (%error-corrupted-mailbox loc obj)
     268  (##sys#signal-hook #:type-error loc "mailbox corrupted" obj) )
     269
     270(define-inline (%error-corrupted-mailbox-cursor loc obj)
     271  (##sys#signal-hook #:type-error loc "mailbox-cursor corrupted" obj) )
     272
     273(define-inline (%error-corrupted-time loc obj)
     274  (##sys#signal-hook #:type-error loc "time corrupted" obj) )
     275
    233276(define-inline (%check-mailbox loc obj)
    234   (##sys#check-structure obj 'mailbox loc) )
     277  (unless (%mailbox? obj)
     278    (%error-type-mailbox loc obj) )
     279  (unless (%mailbox-valid? obj)
     280    (%error-corrupted-mailbox loc obj) ) )
    235281
    236282(define-inline (%check-mailbox-cursor loc obj)
    237   (##sys#check-structure obj 'mailbox-cursor loc) )
     283  (unless (%mailbox-cursor? obj)
     284    (%error-type-mailbox-cursor loc obj) )
     285  (unless (%mailbox-cursor-valid? obj)
     286    (%error-corrupted-mailbox loc obj) ) )
    238287
    239288(define-inline (%check-timeout loc obj)
    240289  (unless (%timeout? obj)
    241     (##sys#signal-hook #:type-error loc "bad argument type - invalid timeout object" obj) ) )
     290    (%error-type-timeout loc obj) )
     291  (unless (and (%time? obj) (%time-valid? obj))
     292    (%error-corrupted-time loc obj) ) )
    242293
    243294(define-inline (%check-symbol loc obj)
     
    464515(define (mailbox-cursor-rewind mbc)
    465516  (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)
    466   (%mailbox-cursor-rewind mbc) )
     517  (%mailbox-cursor-rewind! mbc) )
    467518
    468519(define (mailbox-cursor-next mbc #!optional to-tim (to-def (%undefined-value)))
     
    499550  (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc)
    500551  (%mailbox-cursor-extract! mbc)
    501   (%mailbox-cursor-rewind mbc) )
     552  (%mailbox-cursor-rewind! mbc) )
    502553
    503554;;; Read/Print Syntax
Note: See TracChangeset for help on using the changeset viewer.