Changeset 13178 in project


Ignore:
Timestamp:
02/04/09 01:48:45 (11 years ago)
Author:
Kon Lovett
Message:

defaults.make : chking of svnrev sep from svnrev fil as a target
lolevel.scm : comment fix
runtime.c : use of C defines for platform info, reflow of some comments/code due to > 100 chars long, cl -> closure (like other procs), use of macros rather than open-coded block access, added return value testing for FreeLibrary? & shl_unlaod.
library.scm : refactored make-property-condition & condition-property-accessor so ##sy# routine available, make ##sys# routines for breakpoint condition, placed 'continuation, etc, on breakpoint condition & not exn.
chicken.h : use of C defines for platform info, added comments, C_CHAR_SHIFT.
posixunix.scm, posixwin.scm : added use of Unit ports
scheduler.scm : use of library breakpoint condition routines, placed 'continuation, etc, on breakpoint condition & not exn
srfi-18.scm : renamed some -inlines (match chicken-thread-object-inlines)

Location:
chicken/branches/chicken-3
Files:
11 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/chicken-3/chicken-primitive-object-inlines.scm

    r13147 r13178  
    1 ;;;; chicken-primitive-inlines.scm
    2 ;;;; Kon Lovett, Oct '07
    3 
    4 ;;;; Provides inlines & macros for primitive procedures
    5 ;;;; MUST be included
    6 
    7 
    8 ;;; Type Predicates (these are not fool-proof)
     1;;;; chicken-primitive-object-nlines.scm
     2;;;; Kon Lovett, Jan '09
     3;;;; (Was chicken-sys-macros.scm)
     4
     5; Usage
     6;
     7; (include "chicken-primitive-object-inlines")
     8
     9;; Notes
     10;
     11; Provides inlines & 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
    939
    1040;; Argument is a 'C_word'
    1141
     42
    1243;; Immediate
    1344
    1445(define-inline (%immediate? ?x) (##core#inline "C_immp" x))
    1546
     47
    1648;; Fixnum
    1749
    1850(define-inline (%fixnum? x) (##core#inline "C_fixnump" x))
    1951
     52
    2053;; Character
    2154
    2255(define-inline (%char? x) (##core#inline "C_charp" x))
    2356
     57
    2458;; Boolean
    2559
    2660(define-inline (%boolean? x) (##core#inline "C_booleanp" x))
    2761
    28 ;; True
    29 
    30 ;(define-inline (%true? x) (##core#inline "" x))
    31 
    32 ;; False
    33 
    34 ;(define-inline (%false? x) (##core#inline "" x))
    3562
    3663;; EOF
     
    3865(define-inline (%eof-object? x) (##core#inline "C_eofp" x))
    3966
     67
    4068;; Null (the end-of-list value)
    4169
    4270(define-inline (%null? x) (##core#inline "C_i_nullp" x))
    4371
     72
    4473;; Undefined (void)
    4574
    4675(define-inline (%undefined? x) (##core#inline "C_undefinedp" x))
    4776
    48 ;; Unbound (the unbound value, not is a symbol unbound)
     77
     78;; Unbound (the unbound value, not 'is a symbol unbound')
    4979
    5080(define-inline (%unbound? x) (##core#inline "C_unboundvaluep" x))
    5181
     82
    5283;; Block (anything not immediate)
    5384
    5485(define-inline (%block? x) (##core#inline "C_blockp" x))
    5586
    56 ;; Forwarded (block object moved to new address, forwarding pointer)
    57 
    58 (define-inline (%forwarded? x) (##core#inline "C_forwardedp" x))
    59 
    60 ;; Special
    61 
    62 (define-inline (%special? x) (##core#inline "C_specialp" x))
    63 
    64 ;; Byteblock
    65 
    66 (define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))
    67 
    68 ;; String
    69 
    70 (define-inline (%string-type? x) (##core#inline "C_stringp" x))
    71 
    72 ;; Flonum
    73 
    74 (define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
    75 
    76 ;; Lambda-info
    77 
    78 (define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
    7987
    8088;; Vector
     
    8290(define-inline (%vector-type? x) (##core#inline "C_vectorp" x))
    8391
    84 ;; Bytevector
     92
     93;; Bytevector (isa vector so be careful; refers to how allocated, not what stored)
    8594
    8695(define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))
    8796
     97
    8898;; Pair
    8999
    90100(define-inline (%pair-type? x) (##core#inline "C_pairp" x))
     101
    91102
    92103;; Bucket
     
    95106; "seen" by Scheme code.
    96107
     108
    97109;; Structure
    98110
    99111(define-inline (%structure-type? x) (##core#inline "C_structurep" x))
    100112
     113
     114;; Symbol
     115
     116(define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
     117
     118
     119;; Byteblock
     120
     121(define-inline (%byteblock? x) (##core#inline "C_byteblockp" x))
     122
     123
     124;; String
     125
     126(define-inline (%string-type? x) (##core#inline "C_stringp" x))
     127
     128
     129;; Flonum
     130
     131(define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
     132
     133
     134;; Lambda-info
     135
     136(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
     137
     138
     139;; Special
     140
     141(define-inline (%special? x) (##core#inline "C_specialp" x))
     142
     143
    101144;; Closure
    102145
    103146(define-inline (%closure-type? x) (##core#inline "C_closurep" x))
    104147
     148
    105149;; Port
    106150
    107151(define-inline (%port-type? x) (##core#inline "C_portp" x))
    108152
    109 ;; Symbol
    110 
    111 (define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
    112153
    113154;; Simple-pointer
     
    115156(define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
    116157
     158
    117159;; Tagged-Pointer
    118160
    119161(define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
    120162
     163
    121164;; Swig-Pointer
    122165
    123166(define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
    124167
     168
     169;; Any-pointer
     170
     171(define-inline (%any-pointer-type? x) (##core#inline "C_anypointerp" x))
     172
     173
    125174;; Locative
    126175
     
    128177
    129178
     179;; Forwarded (block object moved to new address, forwarding pointer)
     180
     181(define-inline (%forwarded? x) (##core#inline "C_forwardedp" x))
     182
     183
     184
    130185;;; Values
    131186
    132187
    133 ;;; Primitive Operations
     188
     189;;; Operations
    134190
    135191(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
    136192
    137 (define-inline %become (##core#primitive "C_become"))
    138 
    139 
    140 ;;; Complex Types
     193; (%peek-signed-integer BLOCK INDEX)
     194;
     195(define-inline %peek-signed-integer (##core#primitive "C_peek_signed_integer"))
     196
     197; (%peek-unsigned-integer BLOCK INDEX)
     198;
     199(define-inline %peek-unsigned-integer (##core#primitive "C_peek_unsigned_integer"))
     200
     201(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
     202
     203
     204;; Fixnum
     205
     206(define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
     207(define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
     208(define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
     209(define-inline (%fx= x y) (%eq? x y))
     210(define-inline (%fx> x y) (##core#inline "C_fixnum_greaterp" x y))
     211(define-inline (%fx< x y) (##core#inline "C_fixnum_lessp" x y))
     212(define-inline (%fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
     213(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
     214(define-inline (%fxmin x y) (##core#inline "C_i_fixnum_min" x y))
     215(define-inline (%fxmax x y) (##core#inline "C_i_fixnum_max" x y))
     216(define-inline (%fxneg x) (##core#inline "C_fixnum_negate" x))
     217(define-inline (%fxand x y) (##core#inline "C_fixnum_and" x y))
     218(define-inline (%fxior x y) (##core#inline "C_fixnum_or" x y))
     219(define-inline (%fxxor x y) (##core#inline "C_fixnum_xor" x y))
     220(define-inline (%fxnot x) (##core#inline "C_fixnum_not" x))
     221(define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
     222(define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
     223
     224; These are very unsafe, no check for division-by-zero
     225(define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
     226(define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))
     227
     228
     229;;; Block
     230
    141231
    142232;; Size of object in units of sub-object.
    143 ;; Byteblock is # of bytes, other are # of words.
    144 
    145 (define-inline (%size x) (##core#inline "C_block_size" x))
    146 
    147 ;; Generic-bytevector
    148 
    149 (define-inline (%byte-ref x i) (##core#inline "C_subbyte" x i))
    150 (define-inline (%byte-set! x i n) (##core#inline "C_setsubbyte" x i n))
     233
     234; byteblock is # of bytes, otherwise # of words.
     235;
     236(define-inline (%block-size x) (##core#inline "C_block_size" x))
     237
     238
     239;; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
     240;
     241; Creates & returns a string when 'byteblock?', otherwise a vector.
     242;
     243; Size is # of bytes when 'byteblock?', otherwise # of words.
     244; Fill is a character when 'byteblock?', otherwise any.
     245;
     246(define-inline %block-allocate (##core#primitive "C_allocate_vector"))
     247
     248(define-inline (%block-address x) (##core#inline_allocate ("C_block_address" 4) x))
     249
     250
     251;; Byte access
     252
     253(define-inline (%make-block-byte n f a?) (%block-allocate n #t f a?))
     254
     255(define-inline (%block-byte-ref x i) (##core#inline "C_subbyte" x i))
     256(define-inline (%block-byte-set! x i n) (##core#inline "C_setsubbyte" x i n))
     257
     258
     259;; Word access
     260
     261(define-inline (%make-block-word n f a?) (%block-allocate n #f f a?))
     262
     263(define-inline (%block-word-ref x i) (##core#inline "C_slot" x i))
     264
     265(define-inline (%block-word-set! x i y) (##core#inline "C_i_setslot" x i y))
     266(define-inline (%block-word-set!/immediate x i y) (##core#inline "C_i_set_i_slot" x i y))
     267
     268
     269
     270;;;
     271
     272
     273;; Generic-byteblock
     274
     275; generic-byteblock isa string, flonum, or lambda-info
     276;
     277(define-inline (%generic-byteblock? x) (and (%block? x) (%byteblock? x)))
     278
     279
     280;; String (byteblock)
     281
     282(define-inline (%make-string size fill) (%make-block-byte size fill #f))
     283
     284(define-inline (%string? x) (and (%block? x) (%string-type? x)))
     285
     286(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
     287
     288(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
     289
     290(define-inline (%string-length s) (%block-size s))
     291
     292;%bytevector->string - see Bytevector
     293
     294
     295;; Flonum (byteblock)
     296
     297(define-inline (%flonum? x) (and (%block? x) (%flonum-type? x)))
     298
     299
     300;; Lambda-info (byteblock)
     301
     302(define-inline (%lambda-info? x) (and (%block? x) (%lambda-info-type? x)))
     303
    151304
    152305;; Generic-vector
    153306
     307; generic-vector isa vector, pair, structure, symbol, or keyword
     308;
    154309(define-inline (%generic-vector? x)
    155310  (and (%block? x)
    156        (not (or (%special? x)
    157                       (%byteblock? x)))) )
    158 
    159 (define-inline (%slot-ref x i) (##core#inline "C_slot" x i))
    160 
    161 (define-inline (%slot-set! x i y) (##core#inline "C_i_setslot" x i y))
    162 (define-inline (%slot-set-immediate! x i y) (##core#inline "C_i_set_i_slot" x i y))
    163 
    164 (define-inline (%block-address x) (##core#inline_allocate ("C_block_address" 4) x))
    165 
    166 (define-inline %allocate-vector (##core#primitive "C_allocate_vector"))
    167 
    168 ;; String (byteblock)
    169 
    170 (define-inline (%string? x)
    171   (and (%block? x) (%string-type? x)) )
    172 
    173 (define-inline (%make-string size fill) (%allocate-vector size #t fill #f))
    174 
    175 (define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
    176 
    177 (define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
    178 
    179 (define-inline (%string-length s) (%size s))
    180 
    181 ;; Flonum (byteblock)
    182 
    183 (define-inline (%flonum? x)
    184   (and (%block? x) (%flonum-type? x)) )
    185 
    186 (define-inline (%flonum-magnitude f) (##core#inline "C_flonum_magnitude" x))
    187 
    188 ;; Lambda-info (byteblock)
    189 
    190 (define-inline (%lambda-info? x)
    191   (and (%block? x) (%lambda-info-type? x)) )
     311       (not (or (%special? x) (%byteblock? x)))) )
     312
    192313
    193314;; Vector (wordblock)
    194315
    195 (define-inline (%vector? x)
    196   (and (%block? x) (%vector-type? x)) )
    197 
    198 (define-inline (%make-vector size fill) (%allocate-vector size #f fill #f))
    199 
    200 (define-inline (%vector-ref v i) (%slot-ref v i))
    201 
    202 (define-inline (%vector-set-slot! v i x) (%slot-set! v i x))
    203 (define-inline (%vector-set-immediate! v i x) (%slot-set-immediate! v i x))
    204 
    205 (define-inline (%vector-set! v i x)
    206   (if (%immediate? x)
    207       (%vector-set-immediate! v i x)
    208       (%vector-set-slot! v i x) ) )
    209 
    210 (define-inline (%vector-length v) (%size v))
    211 
    212 ;; Bytevector (wordblock)
    213 
    214 (define-inline (%bytevector? x)
    215   (and (%block? x) (%bytevector-type? x)) )
    216 
    217 (define-inline (%bytevector-ref v i) (%byte-ref v i))
    218 
    219 (define-inline (%bytevector-set! v i x) (%byte-set! v i x))
    220 
    221 (define-inline (%bytevector-length v) (%size v))
    222 
    223 (define-inline (%string->bytevector s) (##core#inline "C_string_to_pbytevector" s))
     316(define-inline (%make-vector size fill) (%make-word-block size fill #f))
     317
     318(define-inline (%vector? x) (and (%block? x) (%vector-type? x)))
     319
     320(define-inline (%vector-ref v i) (%block-word-ref v i))
     321
     322(define-inline (%vector-set! v i x) (%block-word-set! v i x))
     323(define-inline (%vector-set!/immediate v i x) (%block-word-set!/immediate v i x))
     324
     325(define-inline (%vector-length v) (%block-size v))
     326
     327
     328;; Bytevector (wordblock, but byte referenced)
     329
     330(define-inline (%make-bytevector sz)
     331  (let ([bv (%make-string sz #f #t)])
     332    (##core#inline "C_string_to_bytevector" bv)
     333    bv ) )
     334
     335(define-inline (%bytevector? x) (and (%block? x) (%bytevector-type? x)))
     336
     337(define-inline (%bytevector-ref bv i) (%block-byte-ref bv i))
     338
     339(define-inline (%bytevector-set! bv i x) (%block-byte-set! bv i x))
     340
     341(define-inline (%bytevector-length bv) (%block-size bv))
    224342
    225343(define-inline (%bytevector=? v1 v2)
    226344  (let ([ln (%bytevector-length v1)])
    227345    (and (%eq? n %bytevector-length v2))
    228          (%eq? 0 (##core#inline "C_string_compare" v1 v2 n)) ) )
     346         (fx=? 0 (##core#inline "C_string_compare" v1 v2 n)) ) )
     347
     348(define-inline (%string->bytevector s)
     349  (let* ([n (%string-length s)]
     350               [bv (%make-bytevector sz)] )
     351    (##core#inline "C_copy_memory" bv s n)
     352    bv ) )
     353
     354(define-inline (%bytevector->string bv)
     355  (let* ([n (%bytevector-length bv)]
     356               [s (%make-string n #\space)] )
     357    (##core#inline "C_copy_memory" s bv n)
     358    s ) )
     359
     360
     361;; Blob (isa bytevector w/o accessors)
     362
     363(define-inline (%make-blob sz) (%make-bytevector sz))
    229364
    230365(define-inline (%blob? x) (%bytevector? x))
    231366
    232 (define-inline (%blob-size? x) (%size? x))
     367(define-inline (%blob-size b) (%bytevector-length b))
     368
     369(define-inline (%blob=? b1 b2) (%bytevector=? b1 b2))
     370
     371(define-inline (%string->blob s) (%string->bytevector s))
     372
     373(define-inline (%blob->string bv) (%bytevector->string bv))
     374
    233375
    234376;; Pair (wordblock)
    235377
    236 (define-inline (%pair? x)
    237   (and (%block? x) (%pair-type? x)) )
    238 
    239 (define-inline (%list? x)
    240   (or (%null? x)
    241       (%pair? x)) )
     378(define-inline (%pair? x) (and (%block? x) (%pair-type? x)))
     379
     380(define-inline (%list? x) (or (%null? x) (%pair? x)))
    242381
    243382(define-inline (%cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y) )
    244383
    245 (define-inline (%length x y) (##core#inline "C_i_length" lst))
    246 
    247 (define-inline (%car p) (%slot-ref p 0))
    248 (define-inline (%cdr p) (%slot-ref p 1))
     384(define-inline (%length l) (##core#inline "C_i_length" l))
     385
     386(define-inline (%car p) (%block-word-ref p 0))
     387(define-inline (%cdr p) (%block-word-ref p 1))
    249388
    250389(define-inline (%caar p) (%car (%car p)))
     
    262401(define-inline (%cdddr p) (%cdr (%cddr p)))
    263402
    264 (define-inline (%set-car-slot! p x) (%slot-set! p 0 x))
    265 (define-inline (%set-cdr-slot! p x) (%slot-set! p 1 x))
    266 (define-inline (%set-car-immediate! p x) (%slot-set-immediate! p 0 x))
    267 (define-inline (%set-cdr-immediate! p x) (%slot-set-immediate! p 1 x))
    268 
    269 (define-inline (%set-car! p x)
    270   (if (%immediate? x)
    271       (%set-car-immediate! p x)
    272       (%set-car-slot! p x) ) )
    273 
    274 (define-inline (%set-cdr! p x)
    275   (if (%immediate? x)
    276       (%set-cdr-immediate! p x)
    277       (%set-cdr-slot! p x) ) )
    278 
     403(define-inline (%set-car! p x) (%block-word-set! p 0 x))
     404(define-inline (%set-cdr! p x) (%block-word-set! p 1 x))
     405(define-inline (%set-car/immediate! p x) (%block-word-set!/immediate p 0 x))
     406(define-inline (%set-cdr/immediate! p x) (%block-word-set!/immediate p 1 x))
     407
     408;; l0 must be a proper-list
     409
     410(define-inline (%list-ref l0 i0)
     411  (let loop ([l l0] [i i0])
     412    (cond [(null? l)
     413           '() ]
     414                [(%fx= 0 i)
     415                 (%car l) ]
     416                [else
     417                 (loop (%cdr l) (%fx- i 1)) ] ) ) )
     418
     419; l0 cannot be null
    279420(define-inline (%last-pair l0)
    280421  (do ([l l0 (%cdr l)])
    281422      [(%null? (%cdr l)) l]) )
    282423
     424(define-inline (%delq! x l0)
     425  (let loop ([l l0] [pp #f])
     426    (cond [(null? l)
     427           l0 ]
     428                [(%eq? x (%car l))
     429                 (cond [pp
     430                        (%set-cdr! pp (%cdr l))
     431                        l0 ]
     432                       [else
     433                        (%cdr l) ] ) ]
     434                [else
     435                 (loop (%cdr l) l) ] ) ) )
     436
     437;; These are safe
     438
    283439(define-inline (%memq x l) (##core#inline "C_i_memq" x l))
    284440(define-inline (%memv x l) (##core#inline "C_i_memv" x l))
    285441(define-inline (%member x l) (##core#inline "C_i_member" x l))
     442
    286443(define-inline (%assq x l) (##core#inline "C_i_assq" x l))
    287444(define-inline (%assv x l) (##core#inline "C_i_assv" x l))
    288445(define-inline (%assoc x l) (##core#inline "C_i_assoc" x l))
    289446
     447
    290448;; Structure (wordblock)
    291449
    292 (define-inline (%generic-structure? x)
    293   (and (%block? x) (%structure-type? x)) )
     450;; (%make-structure tag fill)
     451;;
     452
     453; (%make-structure TAG [SLOT ...])
     454(define-inline %make-structure (##core#primitive "C_make_structure"))
     455
     456(define-inline (%generic-structure? x) (and (%block? x) (%structure-type? x)))
    294457
    295458(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
     
    300463      (syntax-rules ()
    301464        [(_ ?x)     (%generic-structure? ?x)]
    302         [(_ ?x ?t)  (%structure-instance? ?x ,?t)] ) ) ]
     465        [(_ ?x ?t)  (%structure-instance? ?x ?t)] ) ) ]
    303466  [else
    304467    (define-macro (%structure? ?x . ?t)
    305       (if (%null? ?t) `(%generic-structure? ,?x) `(%structure-type? ,?x ,(car ?t))) ) ] )
    306 
    307 (define-inline %make-structure (##core#primitive "C_make_structure"))
    308 
    309 (define-inline (%vector->structure! vec) (##core#inline "C_vector_to_structure" vec))
    310 
    311 (define-inline (%structure-ref r i) (%slot-ref r i))
    312 
    313 (define-inline (%structure-slot-set! r i x) (%slot-set! r i x))
    314 (define-inline (%structure-immediate-set! r i x) (%slot-set-immediate! r i x))
    315 
    316 (define-inline (%structure-length r) (%size r))
    317 
    318 (define-inline (%structure-tag r) (%slot-ref r 0))
     468      (if (%null? ?t)
     469          `(%generic-structure? ,?x)
     470          `(%structure-instance? ,?x ,(car ?t)) ) ) ] )
     471
     472(define-inline (%structure-ref r i) (%block-word-ref r i))
     473
     474(define-inline (%structure-set! r i x) (%block-word-set! r i x))
     475(define-inline (%structure-set!/immediate r i x) (%block-word-set!/immediate r i x))
     476
     477(define-inline (%structure-length r) (%block-size r))
     478
     479(define-inline (%structure-tag r) (%block-word-ref r 0))
     480
     481
     482;; Special-block (wordblock)
     483
     484(define-inline (%special-block? x) (and (%block? x) (%special? x)))
     485
    319486
    320487;; Port (wordblock)
     
    322489; Port layout:
    323490;
    324 ; 0:  FP (special)
    325 ; 1:  input/output (bool)
    326 ; 2:  class (vector of procedures)
    327 ; 3:  name (string)
    328 ; 4:  row (fixnum)
    329 ; 5:  col (fixnum)
    330 ; 6:  EOF (bool)
    331 ; 7:  type ('stream | 'custom | 'string | 'socket)
    332 ; 8:  closed (bool)
    333 ; 9:  data
    334 ; 10-15: reserved, port class specific
    335 
    336 (define-inline (%port? x)
    337   (and (%block? x) (%port-type? x)) )
    338 
    339 (define-inline (%port-mode p) (%slot-ref? x 1))
    340 
    341 (define-inline (%input-port? x)
    342   (and (%port? x)
    343        (%port-mode x)) )
    344 
    345 (define-inline (%output-port? x)
    346   (and (%port? x)
    347        (not (%port-mode x))) )
     491; 0       FP (special - C FILE *)
     492; 1       input/output (bool)
     493; 2       class (vector, see Port-class)
     494; 3       name (string)
     495; 4       row (fixnum)
     496; 5       col (fixnum)
     497; 6       EOF (bool)
     498; 7       type (symbol)
     499; 8       closed (bool)
     500; 9       data
     501; 10-15  reserved, port class specific
     502
     503; port is 16 slots + a block-header word
     504;
     505;(define-inline (%make-port n) (##core#inline_allocate ("C_a_i_port" 17)))
     506
     507(define-inline (%port? x) (and (%block? x) (%port-type? x)))
     508
     509(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
     510(define-inline (%port-input-mode? port) (%block-word-ref? port 1))
     511(define-inline (%port-class port) (%block-word-ref? port 2))
     512(define-inline (%port-name port) (%block-word-ref? port 3))
     513(define-inline (%port-row port) (%block-word-ref? port 4))
     514(define-inline (%port-column port) (%block-word-ref? port 5))
     515(define-inline (%port-eof? port) (%block-word-ref? port 6))
     516(define-inline (%port-type port) (%block-word-ref? port 7))
     517(define-inline (%port-closed? port) (%block-word-ref? port 8))
     518(define-inline (%port-data port) (%block-word-ref? port 9))
     519
     520(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
     521(define-inline (%port-input-mode-set! port f) (%block-word-set!/immediate port 1 f))
     522(define-inline (%port-class port v) (%block-word-set! port 2 v))
     523(define-inline (%port-name-set! port s) (%block-word-set! port 3 s))
     524(define-inline (%port-row-set! port n) (%block-word-set!/immediate port 4 n))
     525(define-inline (%port-column-set! port n) (%block-word-set!/immediate port 5 n))
     526(define-inline (%port-eof-set! port f) (%block-word-set!/immediate port 6 f))
     527(define-inline (%port-type-set! port s) (%block-word-set! port 7 s))
     528(define-inline (%port-closed-set! port f) (%block-word-set!/immediate port 8 f))
     529(define-inline (%port-data-set! port port) (%block-word-set! port 9 x))
     530
     531; Port-class layout     
     532;
     533; 0       (read-char PORT) -> CHAR | EOF
     534; 1       (peek-char PORT) -> CHAR | EOF
     535; 2       (write-char PORT CHAR)
     536; 3       (write-string PORT STRING)
     537; 4       (close PORT)
     538; 5       (flush-output PORT)
     539; 6       (char-ready? PORT) -> BOOL
     540; 7       (read-string! PORT COUNT STRING START) -> COUNT'
     541; 8       (read-line PORT LIMIT) -> STRING | EOF
     542
    348543
    349544;; Closure (wordblock)
    350545
    351 (define-inline (%closure? x)
    352   (and (%block? x) (%closure-type? x)) )
    353 
    354 (define-inline (%procedure x) (%closure? x))
    355 
    356 (define-inline (%closure-size x) (%size? x))
     546(define-inline (%closure? x) (and (%block? x) (%closure-type? x)))
     547
     548(define-inline (%closure-size c) (%block-size? c))
    357549
    358550(define-inline (%vector->closure! v a)
     
    360552  (##core#inline "C_update_pointer" a v) )
    361553
     554
    362555;; Symbol (wordblock)
    363556
    364 (define-inline (%symbol? x)
    365   (and (%block? x) (%symbol-type? x)) )
    366 
    367 (define-inline %intern-symbol (##core#primitive "C_string_to_symbol"))
    368 (define-inline (%interned-symbol? x) (##core#inline "C_lookup_symbol" x))
    369 
    370 (define-inline (%string->symbol s) (%intern-symbol s)
     557(define-inline (%symbol? x) (and (%block? x) (%symbol-type? x)))
     558
     559(define-inline (%symbol-binding s) (%block-word-ref s 0))
     560(define-inline (%symbol-string s) (%block-word-ref s 1))
     561(define-inline (%symbol-bucket s) (%block-word-ref s 2))
     562
     563(define-inline %string->symbol-interned (##core#primitive "C_string_to_symbol"))
     564
     565;(define-inline (%symbol-intern! s) (%string->symbol (%symbol-string s)))
     566
     567(define-inline (%symbol-interned? x) (##core#inline "C_lookup_symbol" x))
     568
     569(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))
     570
    371571
    372572;; Keyword (wordblock)
     
    374574(define-inline (%keyword? x)
    375575  (and (%symbol? x)
    376        (%eq? 0 (%byte-ref (%slot-ref x) 0)) ) )
     576       (%eq? 0 (%block-byte-ref (%symbol-string x) 0)) ) )
     577
    377578
    378579;; Locative (wordblock)
    379580
    380 (define-inline (%locative? x)
    381   (and (%block? x) (%locative-type? x)) )
    382 
    383 ;; Generic-pointer
    384 
    385 (define-inline (%generic-pointer? x)
    386   (or (%pointer? x)
    387       (%locative? x) ) )
    388 
    389 ; generic-pointer, port, closure
    390 (define-inline (%special-block? x)
    391   (and (%block? x) (%special? x)) )
    392 
    393 (define-inline (%pointer? x)
    394   (and (%block? x) (##core#inline "C_anypointerp" x)) )
    395 
     581(define-inline (%make-locative typ obj idx weak?)
     582  (##core#inline_allocate ("C_a_i_make_locative" 5) typ obj idx weak?))
     583
     584(define-inline (%locative? x) (and (%block? x) (%locative-type? x)))
     585
     586; Locative layout:
     587;
     588; 0     Object-address + byte-offset (address)
     589; 1     Byte-offset (fixnum)
     590; 2     Type (fixnum)
     591;         0     vector or pair          (C_SLOT_LOCATIVE)
     592;         1     string                  (C_CHAR_LOCATIVE)
     593;         2     u8vector                (C_U8_LOCATIVE)
     594;         3     s8vector or bytevector  (C_U8_LOCATIVE)
     595;         4     u16vector                           (C_U16_LOCATIVE)
     596;         5     s16vector                           (C_S16_LOCATIVE)
     597;         6     u32vector                           (C_U32_LOCATIVE)
     598;         7     s32vector                           (C_S32_LOCATIVE)
     599;         8     f32vector                           (C_F32_LOCATIVE)
     600;         9     f64vector                           (C_F64_LOCATIVE)
     601; 3     Object or #f, if weak (C_word)
     602
     603;%locative-address - see Pointer
     604(define-inline (%locative-offset lv) (%block-word-ref lv 1))
     605(define-inline (%locative-type lv) (%block-word-ref lv 2))
     606(define-inline (%locative-weak? lv) (not (%block-word-ref lv 3)))
     607(define-inline (%locative-object lv) (%block-word-ref lv 3))
     608
     609
     610;; Pointer (wordblock)
     611
     612(define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))
     613
     614; simple-pointer, tagged-pointer, swig-pointer, locative
     615(define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
     616
     617; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
    396618(define-inline (%pointer-like? x) (%special-block? x))
    397619
    398 (define-inline (%generic-pointer-ref x) (%slot-ref x 0))
    399 (define-inline (%generic-pointer-set! x y) (%slot-set! x 0 y))
     620; These operate on pointer-like objects
     621
     622(define-inline (%pointer-ref ptr) (%block-word-ref ptr 0))
     623(define-inline (%pointer-set! ptr y) (%block-word-set! ptr 0 y))
     624
     625(define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
     626
     627(define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
    400628
    401629(define-inline (%pointer->address ptr)
    402630  ; Pack pointer address value into Chicken words; '4' is platform dependent!
    403   (##core#inline_allocate ("C_a_unsigned_int_to_num" 4) (%generic-pointer-ref x)) )
    404 
    405 (define-inline (%null-pointer? p)
    406   (%eq? 0 (%pointer->address ptr)) )
    407   (and (%block? x) (%swig-pointer-type? x)) )
    408 
    409 ;; Simple-ointer (wordblock)
    410 
    411 (define-inline (%simple-pointer? x)
    412   (and (%block? x) (%simple-pointer-type? x)) )
     631  (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref x)) )
     632
     633(define-inline (%locative-address lv) (%pointer->address lv))
     634
     635
     636;; Simple-pointer (wordblock)
    413637
    414638(define-inline %make-simple-pointer (##core#primitive "C_make_pointer"))
    415639
    416 (define-inline (%address->pointer addr)
    417   (let ([ptr (%make-simple-pointer)])
    418     (##core#inline "C_update_pointer" addr ptr)
    419     ptr ) )
    420 
    421 (define-inline (%block-pointer x)
    422   (let ([ptr (%make-simple-pointer)])
    423     (##core#inline "C_pointer_to_block" ptr x)
    424     ptr ) )
    425 
    426 (define-inline (%null-pointer)
     640(define-inline (%simple-pointer? x) (and (%block? x) (%simple-pointer-type? x)))
     641
     642(define-inline (%make-pointer-null)
    427643  (let ([ptr (%make-simple-pointer)])
    428644    (##core#inline "C_update_pointer" 0 ptr)
    429645    ptr ) )
    430646
     647(define-inline (%address->pointer a)
     648  (let ([ptr (%make-simple-pointer)])
     649    (##core#inline "C_update_pointer" a ptr)
     650    ptr ) )
     651
     652(define-inline (%make-pointer-block b)
     653  (let ([ptr (%make-simple-pointer)])
     654    (##core#inline "C_pointer_to_block" ptr b)
     655    ptr ) )
     656
     657
    431658;; Tagged-pointer (wordblock)
    432659
    433 (define-inline (%tagged-pointer? x)
    434   (and (%block? x) (%tagged-pointer-type? x)) )
    435 
    436660(define-inline %make-tagged-pointer (##core#primitive "C_make_tagged_pointer"))
    437661
     662(define-inline (%tagged-pointer? x) (and (%block? x) (%tagged-pointer-type? x)))
     663
     664
    438665;; Swig-pointer (wordblock)
    439666
    440 (define-inline (%swig-pointer? x)
    441   (and (%block? x) (%swig-pointer-type? x)) )
     667(define-inline (%swig-pointer? x) (and (%block? x) (%swig-pointer-type? x)))
     668
    442669
    443670
     
    445672
    446673
     674
    447675;;; Operations
    448676
     677
    449678;; Random
    450679
  • chicken/branches/chicken-3/chicken-thread-object-inlines.scm

    r13143 r13178  
    22;;;; Kon Lovett, Jan '09
    33
    4 ;;;; Provides inlines & macros for thread objects
    5 ;;;; MUST be included
    6 ;;;; NEEDS "chicken-primitive-inlines" included
     4; Usage
     5;
     6; (include "chicken-primitive-object-inlines")
     7; (include "chicken-thread-object-inlines")
     8
     9;; Notes
     10;
     11; Provides inlines & macros for thread objects. 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
    717
    818;;; Mutex object helpers:
     
    1929
    2030(define-inline (%mutex? x)
    21   (%structure-instance? x 'mutex) )
     31  (%structure? x 'mutex) )
    2232
    2333(define-inline (%mutex-name mx)
     
    2838
    2939(define-inline (%mutex-thread-set! mx th)
    30   (%structure-slot-set! mx 2 th) )
     40  (%structure-set! mx 2 th) )
    3141
    3242(define-inline (%mutex-thread-clear! mx)
    33   (%structure-immediate-set! mx 2 #f) )
     43  (%structure-set!/immediate mx 2 #f) )
    3444
    3545(define-inline (%mutex-waiters mx)
     
    3747
    3848(define-inline (%mutex-waiters-set! mx wt)
    39   (%structure-slot-set! mx 3 wt) )
     49  (%structure-set! mx 3 wt) )
     50
     51(define-inline (%mutex-waiters-empty? mx)
     52  (%null? (%mutex-waiters mx)) )
     53
     54(define-inline (%mutex-waiters-empty! mx)
     55  (%structure-set!/immediate mx 3 '()) )
    4056
    4157(define-inline (%mutex-waiters-add! mx th)
     
    4359
    4460(define-inline (%mutex-waiters-delete! mx th)
    45   (%mutex-waiters-set! mx (##sys#delq th (%mutex-waiters mx))) )
    46 
    47 (define-inline (%mutex-waiters-empty? mx)
    48   (%null? (%mutex-waiters mx)) )
    49 
    50 (define-inline (%mutex-waiters-forget! mx)
    51   (%structure-immediate-set! mx 3 '()) )
     61  (%mutex-waiters-set! mx (%delq! th (%mutex-waiters mx))) )
    5262
    5363(define-inline (%mutex-waiters-pop! mx)
     
    6171
    6272(define-inline (%mutex-abandoned-set! mx f)
    63   (%structure-immediate-set! mx 4 f) )
     73  (%structure-set!/immediate mx 4 f) )
    6474
    6575(define-inline (%mutex-locked? mx)
     
    6777
    6878(define-inline (%mutex-locked-set! mx f)
    69   (%structure-immediate-set! mx 5 f) )
     79  (%structure-set!/immediate mx 5 f) )
    7080
    7181(define-inline (%mutex-specific mx)
     
    7383
    7484(define-inline (%mutex-specific-set! mx x)
    75   (%structure-slot-set! mx 6 x) )
     85  (%structure-set! mx 6 x) )
    7686
    7787
     
    102112
    103113(define-inline (%thread? x)
    104   (%structure-instance? x 'thread) )
     114  (%structure? x 'thread) )
    105115
    106116(define-inline (%thread-thunk th)
     
    108118
    109119(define-inline (%thread-thunk-set! th tk)
    110   (%structure-slot-set! th 1 tk) )
     120  (%structure-set! th 1 tk) )
    111121
    112122(define-inline (%thread-results th)
     
    114124
    115125(define-inline (%thread-results-set! th rs)
    116   (%structure-slot-set! th 2 rs) )
     126  (%structure-set! th 2 rs) )
    117127
    118128(define-inline (%thread-state th)
     
    120130
    121131(define-inline (%thread-state-set! th st)
    122   (%structure-slot-set! th 3 st) )
     132  (%structure-set! th 3 st) )
    123133
    124134(define-inline (%thread-block-timeout th)
     
    126136
    127137(define-inline (%thread-block-timeout-set! th to)
    128   (%structure-immediate-set! th 4 to) )
     138  (%structure-set!/immediate th 4 to) )
    129139
    130140(define-inline (%thread-block-timeout-clear! th)
     
    135145
    136146(define-inline (%thread-state-buffer-set! th v)
    137   (%structure-slot-set! th 5 v) )
     147  (%structure-set! th 5 v) )
    138148
    139149(define-inline (%thread-name th)
     
    144154
    145155(define-inline (%thread-reason-set! th cd)
    146   (%structure-slot-set! th 7 cd) )
     156  (%structure-set! th 7 cd) )
    147157
    148158(define-inline (%thread-mutexes th)
     
    150160
    151161(define-inline (%thread-mutexes-set! th wt)
    152   (%structure-slot-set! th 8 wx) )
     162  (%structure-set! th 8 wx) )
    153163
    154164(define-inline (%thread-mutexes-empty? th)
    155165  (%null? (%thread-mutexes th)) )
    156166
    157 (define-inline (%thread-mutexes-forget! th)
    158   (%structure-immediate-set! th 8 '()) )
     167(define-inline (%thread-mutexes-empty! th)
     168  (%structure-set!/immediate th 8 '()) )
    159169
    160170(define-inline (%thread-mutexes-add! th mx)
     
    162172
    163173(define-inline (%thread-mutexes-delete! th mx)
    164   (%thread-mutexes-set! th (##sys#delq mx (%thread-mutexes th))) )
     174  (%thread-mutexes-set! th (%delq! mx (%thread-mutexes th))) )
    165175
    166176(define-inline (%thread-quantum th)
     
    168178
    169179(define-inline (%thread-quantum-set! th qt)
    170   (%structure-immediate-set! th 9 qt) )
     180  (%structure-set!/immediate th 9 qt) )
    171181
    172182(define-inline (%thread-specific th)
     
    174184
    175185(define-inline (%thread-specific-set! th x)
    176   (%structure-slot-set! th 10 x) )
     186  (%structure-set! th 10 x) )
    177187
    178188(define-inline (%thread-block-object th)
     
    180190
    181191(define-inline (%thread-block-object-set! th x)
    182   (%structure-slot-set! th 11 x) )
     192  (%structure-set! th 11 x) )
    183193
    184194(define-inline (%thread-block-object-clear! th)
    185   (%structure-immediate-set! th 11 #f) )
     195  (%structure-set!/immediate th 11 #f) )
    186196
    187197(define-inline (%thread-recipients th)
     
    189199
    190200(define-inline (%thread-recipients-set! th x)
    191   (%structure-slot-set! th 12 x) )
     201  (%structure-set! th 12 x) )
     202
     203(define-inline (%thread-recipients-empty? th)
     204  (%null? (%condition-variable-waiters th)) )
     205
     206(define-inline (%thread-recipients-empty! th)
     207  (%structure-set!/immediate th 12 '()) )
    192208
    193209(define-inline (%thread-recipients-add! th rth)
    194210  (%thread-recipients-set! t (%cons rth (%thread-recipients t))) )
    195 
    196 (define-inline (%thread-recipients-forget! th)
    197   (%structure-immediate-set! th 12 '()) )
    198211
    199212(define-inline (%thread-recipients-process! th tk)
    200213  (let ([rs (%thread-recipients t)])
    201214    (unless (%null? rs) (for-each tk rs) ) )
    202   (thread-recipients-forget! t) )
     215  (thread-recipients-empty! t) )
    203216
    204217(define-inline (%thread-unblocked-by-timeout? th)
     
    206219
    207220(define-inline (%thread-unblocked-by-timeout-set! th f)
    208   (%structure-immediate-set! th 13 f) )
     221  (%structure-set!/immediate th 13 f) )
    209222
    210223
     
    219232
    220233(define-inline (%condition-variable? x)
    221   (%structure-instance? x 'condition-variable) )
     234  (%structure? x 'condition-variable) )
    222235
    223236(define-inline (%condition-variable-name cv)
     
    228241
    229242(define-inline (%condition-variable-waiters-set! cv x)
    230   (%structure-slot-set! cv 2 x) )
     243  (%structure-set! cv 2 x) )
     244
     245(define-inline (%condition-variable-waiters-empty? cv)
     246  (%null? (%condition-variable-waiters cv)) )
     247
     248(define-inline (%condition-variable-waiters-empty! cv)
     249  (%structure-set!/immediate cv 2 '()) )
    231250
    232251(define-inline (%condition-variable-waiters-add! cv th)
     
    234253
    235254(define-inline (%condition-variable-waiters-delete! cv th)
    236   (%condition-variable-waiters-set! cv (##sys#delq th (%condition-variable-waiters cv))) )
    237 
    238 (define-inline (%condition-variable-waiters-empty? mx)
    239   (%null? (%condition-variable-waiters mx)) )
     255  (%condition-variable-waiters-set! cv (%delq! th (%condition-variable-waiters cv))) )
    240256
    241257(define-inline (%condition-variable-waiters-pop! mx)
     
    245261    top ) )
    246262
    247 (define-inline (%condition-variable-waiters-clear! cv)
    248   (%structure-immediate-set! cv 2 '()) )
    249 
    250263(define-inline (%condition-variable-specific cv)
    251264  (%structure-ref cv 3) )
    252265
    253266(define-inline (%condition-variable-specific-set! cv x)
    254   (%structure-slot-set! cv 3 x) )
     267  (%structure-set! cv 3 x) )
  • chicken/branches/chicken-3/chicken.h

    r13147 r13178  
    377377#define C_FIXNUM_SHIFT            1
    378378
     379/* Character range is that of a UTF-8 codepoint, not representable range */
    379380#define C_CHAR_BIT_MASK           0x1fffff
     381#define C_CHAR_SHIFT              8
    380382
    381383#ifdef C_SIXTY_FOUR
     
    446448# define C_BUCKET_TYPE            (0x0f000000)
    447449#endif
    448 
     450#define C_VECTOR_TYPE             0x00000000
     451#define C_BYTEVECTOR_TYPE         (C_VECTOR_TYPE | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
     452
     453#define C_SIZEOF_LIST(n)          ((n) * 3 + 1)
     454#define C_SIZEOF_PAIR             3
     455#define C_SIZEOF_STRING(n)        (C_bytestowords(n) + 2)
     456#define C_SIZEOF_SYMBOL           4
     457#define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_BUCKET + C_SIZEOF_STRING(n))
     458#ifdef C_DOUBLE_IS_32_BITS
     459# define C_SIZEOF_FLONUM          2
     460#else
     461# define C_SIZEOF_FLONUM          4
     462#endif
     463#define C_SIZEOF_POINTER          2
     464#define C_SIZEOF_TAGGED_POINTER   3
     465#define C_SIZEOF_SWIG_POINTER     3
     466#define C_SIZEOF_VECTOR(n)        ((n) + 1)
     467#define C_SIZEOF_BUCKET           3
     468#define C_SIZEOF_LOCATIVE         5
     469#define C_SIZEOF_PORT             16
     470
     471/* Fixed size types have pre-computed header tags */
     472#define C_PAIR_TAG                (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
     473#define C_POINTER_TAG             (C_POINTER_TYPE | (C_SIZEOF_POINTER - 1))
     474#define C_LOCATIVE_TAG            (C_LOCATIVE_TYPE | (C_SIZEOF_LOCATIVE - 1))
     475#define C_TAGGED_POINTER_TAG      (C_TAGGED_POINTER_TYPE | (C_SIZEOF_TAGGED_POINTER - 1))
     476#define C_SWIG_POINTER_TAG        (C_SWIG_POINTER_TYPE | (C_wordstobytes(C_SIZEOF_SWIG_POINTER - 1)))
     477#define C_SYMBOL_TAG              (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1))
     478#define C_FLONUM_TAG              (C_FLONUM_TYPE | sizeof(double))
     479
     480/* Locative subtypes */
    449481#define C_SLOT_LOCATIVE           0
    450482#define C_CHAR_LOCATIVE           1
     
    457489#define C_F32_LOCATIVE            8
    458490#define C_F64_LOCATIVE            9
    459 
    460 #define C_VECTOR_TYPE             0x00000000
    461 #define C_BYTEVECTOR_TYPE         (C_VECTOR_TYPE | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
    462 
    463 #define C_SIZEOF_LIST(n)          ((n) * 3 + 1)
    464 #define C_SIZEOF_PAIR             3
    465 #define C_SIZEOF_STRING(n)        (C_bytestowords(n) + 2)
    466 #define C_SIZEOF_SYMBOL          4
    467 #define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_BUCKET + C_SIZEOF_STRING(n))
    468 #ifdef C_DOUBLE_IS_32_BITS
    469 # define C_SIZEOF_FLONUM           2
    470 #else
    471 # define C_SIZEOF_FLONUM           4
    472 #endif
    473 #define C_SIZEOF_POINTER          2
    474 #define C_SIZEOF_TAGGED_POINTER   3
    475 #define C_SIZEOF_SWIG_POINTER     3
    476 #define C_SIZEOF_VECTOR(n)        ((n) + 1)
    477 #define C_SIZEOF_BUCKET           3
    478 #define C_SIZEOF_LOCATIVE         5
    479 #define C_SIZEOF_PORT             16
    480 
    481 #define C_PAIR_TAG                (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
    482 #define C_POINTER_TAG             (C_POINTER_TYPE | (C_SIZEOF_POINTER - 1))
    483 #define C_LOCATIVE_TAG            (C_LOCATIVE_TYPE | (C_SIZEOF_LOCATIVE - 1))
    484 #define C_TAGGED_POINTER_TAG      (C_TAGGED_POINTER_TYPE | (C_SIZEOF_TAGGED_POINTER - 1))
    485 #define C_SWIG_POINTER_TAG        (C_SWIG_POINTER_TYPE | (C_wordstobytes(C_SIZEOF_SWIG_POINTER - 1)))
    486 #define C_SYMBOL_TAG              (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1))
    487 #define C_FLONUM_TAG             (C_FLONUM_TYPE | sizeof(double))
    488491
    489492#ifdef C_SIXTY_FOUR
     
    549552
    550553
    551 #define CHICKEN_gc_root_ref(root)      (((C_GC_ROOT *)(root))->value)
    552 #define CHICKEN_gc_root_set(root, x)   C_mutate(&((C_GC_ROOT *)(root))->value, (x))
    553 
    554 #define CHICKEN_global_ref(root)       C_u_i_car(((C_GC_ROOT *)(root))->value)
    555 #define CHICKEN_global_set(root, x)    C_mutate(&C_u_i_car(((C_GC_ROOT *)(root))->value), (x))
    556 
    557 #define CHICKEN_default_toplevel       ((void *)C_default_stub_toplevel)
     554/* Platform information */
     555#if defined(C_BIG_ENDIAN)
     556# define C_MACHINE_BYTE_ORDER "big-endian"
     557#elif defined(C_LITTLE_ENDIAN)
     558# define C_MACHINE_BYTE_ORDER "little-endian"
     559#endif
     560
     561#if defined(__alpha__)
     562# define C_MACHINE_TYPE "alpha"
     563#elif defined(__mips__)
     564# define C_MACHINE_TYPE "mips"
     565#elif defined(__hppa__)
     566# define C_MACHINE_TYPE "hppa"
     567#elif defined(__sparc_v9__) || defined(__sparcv9)
     568# define C_MACHINE_TYPE "ultrasparc"
     569#elif defined(__sparc__)
     570# define C_MACHINE_TYPE "sparc"
     571#elif defined(__powerpc64__)
     572# define C_MACHINE_TYPE "ppc64"
     573#elif defined(__ppc__) || defined(__powerpc__)
     574# define C_MACHINE_TYPE "ppc"
     575#elif defined(_M_IX86) || defined(__i386__)
     576# define C_MACHINE_TYPE "x86"
     577#elif defined(__ia64__)
     578# define C_MACHINE_TYPE "ia64"
     579#elif defined(__x86_64__)
     580# define C_MACHINE_TYPE "x86-64"
     581#elif defined(__arm__)
     582# define C_MACHINE_TYPE "arm"
     583#else
     584# define C_MACHINE_TYPE "unknown"
     585#endif
     586
     587#if defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)
     588# define C_SOFTWARE_TYPE "windows"
     589#elif defined(__unix__) || defined(C_XXXBSD)
     590# define C_SOFTWARE_TYPE "unix"
     591#elif defined(ECOS)
     592# define C_SOFTWARE_TYPE "ecos"
     593#else
     594# define C_SOFTWARE_TYPE "unknown"
     595#endif
     596
     597#if defined(__CYGWIN__)
     598# define C_BUILD_PLATFORM "cygwin"
     599#elif defined(_MSC_VER)
     600# define C_BUILD_PLATFORM "msvc"
     601#elif defined(__SUNPRO_C)
     602# define C_BUILD_PLATFORM "sun"
     603#elif defined(__MINGW32__)
     604# define C_BUILD_PLATFORM "mingw32"
     605#elif defined(__GNUC__)
     606# define C_BUILD_PLATFORM "gnu"
     607#elif defined(__MWERKS__)
     608# define C_BUILD_PLATFORM "metrowerks"
     609#elif defined(__INTEL_COMPILER)
     610# define C_BUILD_PLATFORM "intel"
     611#elif defined(__WATCOMC__)
     612# define C_BUILD_PLATFORM "watcom"
     613#else
     614# define C_BUILD_PLATFORM "unknown"
     615#endif
     616
     617#if defined(_MSC_VER)
     618# if defined(_DLL)
     619#   define C_RUNTIME_VERSION "dynamic"
     620# else
     621#   define C_RUNTIME_VERSION "static"
     622# endif
     623#else
     624# define C_RUNTIME_VERSION "unknown"
     625#endif
     626
     627#if defined(__linux__)
     628# define C_SOFTWARE_VERSION "linux"
     629#elif defined(__FreeBSD__)
     630# define C_SOFTWARE_VERSION "freebsd"
     631#elif defined(__NetBSD__)
     632# define C_SOFTWARE_VERSION "netbsd"
     633#elif defined(__OpenBSD__)
     634# define C_SOFTWARE_VERSION "openbsd"
     635#elif defined(C_MACOSX)
     636# define C_SOFTWARE_VERSION "macosx"
     637#elif defined(__hpux__)
     638# define C_SOFTWARE_VERSION "hpux"
     639#elif defined(__DragonFly__)
     640# define C_SOFTWARE_VERSION "dragonfly"
     641#elif defined(__sun__)
     642# if defined(__svr4__)
     643#   define C_SOFTWARE_VERSION "solaris"
     644# else
     645#   define C_SOFTWARE_VERSION "sunos"
     646# endif
     647#else
     648# define C_SOFTWARE_VERSION "unknown"
     649#endif
    558650
    559651
     
    657749
    658750/* Macros: */
     751
     752#define CHICKEN_gc_root_ref(root)      (((C_GC_ROOT *)(root))->value)
     753#define CHICKEN_gc_root_set(root, x)   C_mutate(&((C_GC_ROOT *)(root))->value, (x))
     754
     755#define CHICKEN_global_ref(root)       C_u_i_car(((C_GC_ROOT *)(root))->value)
     756#define CHICKEN_global_set(root, x)    C_mutate(&C_u_i_car(((C_GC_ROOT *)(root))->value), (x))
     757
     758#define CHICKEN_default_toplevel       ((void *)C_default_stub_toplevel)
    659759
    660760#define C_align4(n)                (((n) + 3) & ~3)
     
    785885#define C_fix(n)                   (((C_word)(n) << C_FIXNUM_SHIFT) | C_FIXNUM_BIT)
    786886#define C_unfix(x)                 ((x) >> C_FIXNUM_SHIFT)
    787 #define C_make_character(c)        ((((c) & C_CHAR_BIT_MASK) << 8) | C_CHARACTER_BITS)
    788 #define C_character_code(x)        (((x) >> 8) & C_CHAR_BIT_MASK)
     887#define C_make_character(c)        ((((c) & C_CHAR_BIT_MASK) << C_CHAR_SHIFT) | C_CHARACTER_BITS)
     888#define C_character_code(x)        (((x) >> C_CHAR_SHIFT) & C_CHAR_BIT_MASK)
    789889#define C_flonum_magnitude(x)      (*((double *)(((C_SCHEME_BLOCK *)(x))->data)))
    790890#define C_c_string(x)              ((C_char *)(((C_SCHEME_BLOCK *)(x))->data))
  • chicken/branches/chicken-3/defaults.make

    r13010 r13178  
    307307.PHONY: all
    308308
    309 ifdef NO_UNIX_SHELL
    310 all: $(TARGETS)
    311 else
    312 all: buildsvnrevision $(TARGETS)
    313 endif
    314 
    315 buildsvnrevision:
    316         sh $(SRCDIR)/svnrevision.sh
     309all: checksvnrevision $(TARGETS)
     310
     311checksvnrevision:
     312ifdef WINDOWS_SHELL
     313else
     314        sh $(SRCDIR)svnrevision.sh
     315endif
    317316
    318317
  • chicken/branches/chicken-3/library.scm

    r13149 r13178  
    136136     ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-port* ##sys#check-string ##sys#substring ##sys#check-port-mode
    137137     ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair
    138      ##sys#not-a-proper-list-error ##sys#error ##sys#warn ##sys#signal-hook
     138     ##sys#error-not-a-proper-list ##sys#error ##sys#warn ##sys#signal-hook
    139139     ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round
    140140     ##sys#check-number ##sys#cons-flonum ##sys#check-integer ##sys#check-special
     
    171171     ##sys#append ##sys#list ##sys#cons ##sys#list->vector ##sys#list ##sys#apply ##sys#make-vector
    172172     ##sys#write-char ##sys#force-finalizers ##sys#cleanup-before-exit ##sys#write-char-0
    173      ##sys#default-read-info-hook ##sys#read-error) ) ] )
     173     ##sys#default-read-info-hook ##sys#read-error ##sys#make-exn-condition ##sys#condition-property) ) ] )
    174174
    175175
     
    474474          (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
    475475
    476 (define (##sys#not-a-proper-list-error arg . loc)
    477   (##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int)
    478                     (and (pair? loc) (car loc)) arg) )
     476(define (##sys#error-not-a-proper-list arg . loc)
     477  (##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int) (and (pair? loc) (car loc)) arg) )
     478
     479(define ##sys#not-a-proper-list-error ##sys#error-not-a-proper-list) ;DEPRECATED
    479480
    480481(define (append . lsts)
     
    494495                      ((pair? node)
    495496                       (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
    496                       (else (##sys#not-a-proper-list-error (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) )
     497                      (else (##sys#error-not-a-proper-list (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) )
    497498
    498499(define (reverse lst0)
     
    507508              ((pair? lst)
    508509               (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )
    509               (else (##sys#not-a-proper-list-error lst0 'reverse)) ) ] ) ) )
     510              (else (##sys#error-not-a-proper-list lst0 'reverse)) ) ] ) ) )
    510511
    511512(define (memq x lst) (##core#inline "C_i_memq" x lst))
     
    567568    [else
    568569    (if (not (list? lst0))
    569       (##sys#not-a-proper-list-error lst0 'list->string)
     570      (##sys#error-not-a-proper-list lst0 'list->string)
    570571      (let* ([len (length lst0)]
    571572             [s (##sys#make-string len)] )
     
    603604                 (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
    604605        s )
    605       (##sys#not-a-proper-list-error l 'reverse-list->string) ) ]
     606      (##sys#error-not-a-proper-list l 'reverse-list->string) ) ]
    606607    ) )
    607608
     
    13241325    [else
    13251326    (if (not (list? lst0))
    1326       (##sys#not-a-proper-list-error lst0 'list->vector)
     1327      (##sys#error-not-a-proper-list lst0 'list->vector)
    13271328      (let* ([len (length lst0)]
    13281329             [v (##sys#make-vector len)] )
     
    15431544             (p (##sys#slot lst 0))
    15441545             (loop (##sys#slot lst 1)) )
    1545             (else (##sys#not-a-proper-list-error lst0 'for-each)) ) ] ) ) )
     1546            (else (##sys#error-not-a-proper-list lst0 'for-each)) ) ] ) ) )
    15461547
    15471548(define (##sys#map p lst0)
     
    15561557            ((pair? lst)
    15571558             (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) )
    1558             (else (##sys#not-a-proper-list-error lst0 'map)) ) ] ) ) )
     1559            (else (##sys#error-not-a-proper-list lst0 'map)) ) ] ) ) )
    15591560
    15601561(define for-each)
     
    15731574                          ((pair? item)
    15741575                           (cons (p item) (mapsafe p (##sys#slot lsts 1) #f loc)) )
    1575                           (else (##sys#not-a-proper-list-error item loc)) ) ) ) ) )
     1576                          (else (##sys#error-not-a-proper-list item loc)) ) ) ) ) )
    15761577           (check
    15771578            (lambda (lsts start loc)
     
    34243425(define ##sys#break-in-thread #f)
    34253426
     3427; Returns a new exn-breakpoint condition
     3428;
     3429; bkptprops is p-list of propkey value or '()
     3430; The bkptprops are extra condition-properties for the 'breakpoint condition
     3431;
     3432(define (##sys#make-breakpoint-condition loc k bkptprops . args)
     3433  (make-composite-condition
     3434   (apply ##sys#make-exn-condition loc "*** breakpoint ***" args)
     3435   (apply make-property-condition 'breakpoint 'continuation k bkptprops)) )
     3436
     3437(define (##sys#error-condition-without-continuation cnd)
     3438  (##sys#signal-hook #:type-error "condition has no continuation" cnd) )
     3439
    34263440(define (##sys#break-entry name args)
    34273441  ;; Does _not_ unwind!
    34283442  (##sys#call-with-current-continuation
    3429    (lambda (c)
    3430      (let ((exn (##sys#make-structure
    3431                  'condition
    3432                  '(exn breakpoint)
    3433                  (list '(exn . message) "*** breakpoint ***"
    3434                        '(exn . arguments) (list (cons name args))
    3435                        '(exn . location) name
    3436                        '(exn . continuation) c) ) ) )
    3437        (set! ##sys#last-breakpoint exn)
    3438        (##sys#signal exn) ) ) ) )
    3439 
    3440 (define (##sys#break-resume exn)
    3441   (let ((a (member '(exn . continuation) (##sys#slot exn 2))))
    3442     (if a
    3443         ((cadr a) (##core#undefined))
    3444         (##sys#signal-hook #:type-error "condition has no continuation" exn) ) ) )
     3443   (lambda (k)
     3444     (let ([cnd (##sys#make-breakpoint-condition name k '() (cons name args))])
     3445       (set! ##sys#last-breakpoint cnd)
     3446       (##sys#signal cnd) ) ) ) )
     3447
     3448(define (##sys#break-resume cnd)
     3449  (let ((k (##sys#condition-property cnd '(breakpoint . continuation))))
     3450    (if k
     3451        (k (void))
     3452        (##sys#error-condition-without-continuation cnd) ) ) )
    34453453
    34463454(define (breakpoint #!optional name)
     
    37213729(define (current-exception-handler) ##sys#current-exception-handler)
    37223730
     3731;; Condition layout:
     3732;
     3733; kindkey, propkey (atom)
     3734; SRFI-12 states eqv? as the predicate but symbols usually a keys.
     3735;
     3736; 0     Tag - 'condition
     3737; 1     Kinds (list-of kindkey)
     3738; 2     Properties (plist-of (pair-of kindkey propkey) object ...)
     3739
     3740(define-inline (%make-condition kinds props)
     3741  (##sys#make-structure 'condition kinds props) )
     3742
     3743(define-inline (%condition-kinds c)
     3744  (##sys#slot c 1) )
     3745
     3746(define-inline (%condition-props c)
     3747  (##sys#slot c 2) )
     3748
     3749(define-inline (%check-condition x loc)
     3750  (##sys#check-structure x 'condition loc) )
     3751
     3752(define (##sys#condition-kind? cnd kind)
     3753  (and (memv kind (%condition-kinds cnd))
     3754       #t ) )
     3755
     3756; Returns the property value for the kind & property keys, otherwise 'def'
     3757; 'kind+prop' is a pair, (kind . prop)
     3758;
     3759(define (##sys#condition-property cnd kind+prop #!optional def)
     3760  (and (memv (car kind+prop) (%condition-kinds cnd))
     3761       (let ([a (member kind+prop (%condition-props cnd))])
     3762         (if a (cadr a) def) ) ) )
     3763
    37233764(define (make-property-condition kind . props)
    3724   (##sys#make-structure
    3725    'condition (list kind)
    3726    (let loop ((props props))
     3765  (%make-condition
     3766   (list kind)
     3767   (let loop ([props props])
    37273768     (if (null? props)
    37283769         '()
    37293770         (cons (cons kind (car props)) (cons (cadr props) (loop (cddr props)))) ) ) ) )
    37303771
    3731 (define (make-composite-condition c1 . conds)
    3732   (let ([conds (cons c1 conds)])
    3733     (for-each (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition)) conds)
    3734     (##sys#make-structure
    3735      'condition
    3736      (apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))
    3737      (apply ##sys#append (map (lambda (c) (##sys#slot c 2)) conds)) ) ) )
     3772(define (make-composite-condition c1 . cnds)
     3773  (let ([cnds (cons c1 cnds)])
     3774    (for-each (lambda (c) (%check-condition c 'make-composite-condition)) cnds)
     3775    (%make-condition
     3776     (apply ##sys#append (map (lambda (c) (%condition-kinds c)) cnds))
     3777     (apply ##sys#append (map (lambda (c) (%condition-props c)) cnds)) ) ) )
    37383778
    37393779(define (condition? x) (##sys#structure? x 'condition))
    37403780
    37413781(define (condition-predicate kind)
    3742   (lambda (c)
    3743     (##sys#check-structure c 'condition)
    3744     (if (memv kind (##sys#slot c 1)) #t #f) ) )
     3782  (lambda (cnd)
     3783    (%check-condition cnd 'condition-predicate)
     3784    (##sys#condition-kind? cnd kind) ) )
    37453785
    37463786(define (condition-property-accessor kind prop . err-def)
    3747   (let ((err? (null? err-def))
    3748         (k+p (cons kind prop)) )
    3749     (lambda (c)
    3750       (##sys#check-structure c 'condition)
    3751       (and (memv kind (##sys#slot c 1))
    3752            (let ([a (member k+p (##sys#slot c 2))])
    3753              (cond [a (cadr a)]
    3754                    [err? (##sys#signal-hook
    3755                           #:type-error 'condition-property-accessor
    3756                           "condition has no such property" prop) ]
    3757                    [else (car err-def)] ) ) ) ) ) )
     3787  (let ([err? (null? err-def)]
     3788        [k+p (cons kind prop)] )
     3789    (lambda (cnd)
     3790      (%check-condition cnd 'condition-property-accessor)
     3791      (let ([val (##sys#condition-property cnd k+p (void))])
     3792        (cond [(not (eq? (void) val))
     3793               val ]
     3794              [err?
     3795               (##sys#signal-hook
     3796                #:type-error 'condition-property-accessor
     3797                "condition has no such property" prop) ]
     3798              [else
     3799               (car err-def) ] ) ) ) ) )
     3800
     3801(define (##sys#make-exn-condition loc msg . args)
     3802  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
    37583803
    37593804
  • chicken/branches/chicken-3/lolevel.scm

    r13147 r13178  
    303303              "bad argument type - not a pointer or integer" x)] ) ) ) )
    304304
     305
     306;;; Tagged-pointers:
     307
     308(define (tag-pointer ptr tag)
     309  (let ([tp (##sys#make-tagged-pointer tag)])
     310    (if (%special-block? ptr)
     311        (##core#inline "C_copy_pointer" ptr tp)
     312        (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
     313    tp) )
     314
     315(define (tagged-pointer? x #!optional tag)
     316  (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
     317       (or (not tag)
     318           (equal? tag (##sys#slot x 1)) ) ) )
     319
     320(define (pointer-tag x)
     321  (if (%special-block? x)
     322      (and (##core#inline "C_taggedpointerp" x)
     323           (##sys#slot x 1) )
     324      (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
     325
     326
     327;;; locatives:
     328
     329;; Locative layout:
     330;
     331; 0     Object-address + Byte-offset (address)
     332; 1     Byte-offset (fixnum)
     333; 2     Type (fixnum)
     334;       0       vector or pair          (C_SLOT_LOCATIVE)
     335;       1       string                  (C_CHAR_LOCATIVE)
     336;       2       u8vector or blob        (C_U8_LOCATIVE)
     337;       3       s8vector                (C_S8_LOCATIVE)
     338;       4       u16vector               (C_U16_LOCATIVE)
     339;       5       s16vector               (C_S16_LOCATIVE)
     340;       6       u32vector               (C_U32_LOCATIVE)
     341;       7       s32vector               (C_S32_LOCATIVE)
     342;       8       f32vector               (C_F32_LOCATIVE)
     343;       9       f64vector               (C_F64_LOCATIVE)
     344; 3     Object or #f, if weak (C_word)
     345
     346(define (make-locative obj . index)
     347  (##sys#make-locative obj (optional index 0) #f 'make-locative) )
     348
     349(define (make-weak-locative obj . index)
     350  (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
     351
     352(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
     353(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
     354(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
     355(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
     356
     357
     358;;; SRFI-4 number-vector:
     359
    305360(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
    306361(define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;"))
     
    351406   (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));")
    352407   pointer-f64-set!) )
    353 
    354 
    355 ;;; Tagged-pointers:
    356 
    357 (define (tag-pointer ptr tag)
    358   (let ([tp (##sys#make-tagged-pointer tag)])
    359     (if (%special-block? ptr)
    360         (##core#inline "C_copy_pointer" ptr tp)
    361         (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
    362     tp) )
    363 
    364 (define (tagged-pointer? x #!optional tag)
    365   (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
    366        (or (not tag)
    367            (equal? tag (##sys#slot x 1)) ) ) )
    368 
    369 (define (pointer-tag x)
    370   (if (%special-block? x)
    371       (and (##core#inline "C_taggedpointerp" x)
    372            (##sys#slot x 1) )
    373       (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
    374 
    375 
    376 ;;; locatives:
    377 
    378 ;; Locative layout:
    379 ;
    380 ; 0     Object-address + Byte-offset (address)
    381 ; 1     Byte-offset (fixnum)
    382 ; 2     Type (fixnum)
    383 ;       0       vector or pair          (C_SLOT_LOCATIVE)
    384 ;       1       string                  (C_CHAR_LOCATIVE)
    385 ;       2       u8vector                (C_U8_LOCATIVE)
    386 ;       3       s8vector or blob        (C_U8_LOCATIVE)
    387 ;       4       u16vector               (C_U16_LOCATIVE)
    388 ;       5       s16vector               (C_S16_LOCATIVE)
    389 ;       6       u32vector               (C_U32_LOCATIVE)
    390 ;       7       s32vector               (C_S32_LOCATIVE)
    391 ;       8       f32vector               (C_F32_LOCATIVE)
    392 ;       9       f64vector               (C_F64_LOCATIVE)
    393 ; 3     Object or #f, if weak (C_word)
    394 
    395 (define (make-locative obj . index)
    396   (##sys#make-locative obj (optional index 0) #f 'make-locative) )
    397 
    398 (define (make-weak-locative obj . index)
    399   (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
    400 
    401 (define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
    402 (define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
    403 (define (locative->object x) (##core#inline "C_i_locative_to_object" x))
    404 (define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
    405408
    406409
  • chicken/branches/chicken-3/posixunix.scm

    r13135 r13178  
    2828(declare
    2929  (unit posix)
    30   (uses scheduler regex extras utils files)
     30  (uses scheduler regex extras utils files ports)
    3131  (disable-interrupts)
    3232  (usual-integrations)
  • chicken/branches/chicken-3/posixwin.scm

    r13134 r13178  
    6666(declare
    6767  (unit posix)
    68   (uses scheduler regex extras utils files)
     68  (uses scheduler regex extras utils files ports)
    6969  (disable-interrupts)
    7070  (usual-integrations)
  • chicken/branches/chicken-3/runtime.c

    r13143 r13178  
    549549static C_PTABLE_ENTRY *create_initial_ptable();
    550550
    551 #if !defined(NO_DLOAD2) &&(defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))
     551#if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))
    552552static void dload_2(void *dummy) C_noret;
    553553#endif
     
    693693  finalizer_list = NULL;
    694694  finalizer_free_list = NULL;
    695   pending_finalizer_indices = (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *));
     695  pending_finalizer_indices =
     696      (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *));
    696697
    697698  if(pending_finalizer_indices == NULL) return 0;
    698699
    699700  /* Initialize forwarding table: */
    700   forwarding_table = (C_word *)C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) * 2 * sizeof(C_word));
     701  forwarding_table =
     702      (C_word *)C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) * 2 * sizeof(C_word));
    701703
    702704  if(forwarding_table == NULL) return 0;
     
    17361738
    17371739    if(C_getrusage(RUSAGE_SELF, &ru) == -1) return 0;
    1738     else return (ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 1000 + (ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000;
     1740    else return (ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 1000
     1741                 + (ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000;
    17391742#endif
    17401743}
     
    18881891void C_zap_strings(C_word str)
    18891892{
    1890   C_word bucket, sym;
    18911893  int i;
    18921894 
    1893   for(i = 0; i < symbol_table->size; ++i)
    1894     for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket)) {
     1895  for(i = 0; i < symbol_table->size; ++i) {
     1896    C_word bucket, sym;
     1897
     1898    for(bucket = symbol_table->table[ i ];
     1899        bucket != C_SCHEME_END_OF_LIST;
     1900        bucket = C_u_i_cdr(bucket)) {
    18951901      sym = C_u_i_car(bucket);
    18961902      C_set_block_item(sym, 1, str);
    1897     } 
     1903    }
     1904  }
    18981905}
    18991906
     
    20912098    s = C_u_i_cdr(sym);
    20922099
    2093     if(C_header_size(s) == (C_word)len && !C_memcmp(str, (C_char *)((C_SCHEME_BLOCK *)s)->data, len))
     2100    if(C_header_size(s) == (C_word)len
     2101       && !C_memcmp(str, (C_char *)((C_SCHEME_BLOCK *)s)->data, len))
    20942102      return sym;
    20952103  }
     
    24822490  double m;
    24832491
    2484   if(n <= (double)C_MOST_POSITIVE_FIXNUM && n >= (double)C_MOST_NEGATIVE_FIXNUM && modf(n, &m) == 0.0)
     2492  if(n <= (double)C_MOST_POSITIVE_FIXNUM
     2493     && n >= (double)C_MOST_NEGATIVE_FIXNUM && modf(n, &m) == 0.0)
    24852494    return C_fix(n);
    24862495
     
    26692678      assert(mutation_stack_top == mutation_stack_limit);
    26702679      mssize = mutation_stack_top - mutation_stack_bottom;
    2671       mutation_stack_bottom = (C_word **)realloc(mutation_stack_bottom, (mssize + MUTATION_STACK_GROWTH) * sizeof(C_word *));
     2680      mutation_stack_bottom =
     2681          (C_word **)realloc(mutation_stack_bottom,
     2682                             (mssize + MUTATION_STACK_GROWTH) * sizeof(C_word *));
    26722683     
    26732684      if(mutation_stack_bottom == NULL)
     
    29312942
    29322943    if(C_enable_gcweak) {
    2933       /* Check entries in weak item table and recover items ref'd only once and which are unbound symbols: */
     2944      /* Check entries in weak item table and recover items ref'd only
     2945      * once and which are unbound symbols: */
    29342946      weakn = 0;
    29352947      wep = weak_item_table;
     
    33913403    }
    33923404
    3393     /* Link points into nursery, fromspace or the old tospace: fetch new pointer + header and copy... */
     3405    /* Link points into nursery, fromspace or the old tospace:
     3406    * fetch new pointer + header and copy... */
    33943407    p = (C_SCHEME_BLOCK *)val;
    33953408    h = p->header;
     
    33973410
    33983411    while(is_fptr(h)) {
    3399       /* Link points into fromspace or old tospace and into a link which points into tospace or new-tospace: */
     3412      /* Link points into fromspace or old tospace and into a link which
     3413       * points into tospace or new-tospace: */
    34003414      val = fptr_to_ptr(h);
    34013415       
     
    34453459  C_uword ptr2;
    34463460
    3447   /*  C_printf("major: %d, %d locs in %d\n", major, locative_table_count, locative_table_size); */
     3461  /*C_printf("major: %d, %d locs in %d\n", major, locative_table_count, locative_table_size); */
    34483462
    34493463  for(i = 0; i < locative_table_count; ++i) {
     
    34583472        if(is_fptr(h))          /* forwarded? update l-table entry */
    34593473          loc = locative_table[ i ] = fptr_to_ptr(h);
    3460         else if(C_in_stackp(loc)) { /* otherwise it must have been GC'd (since this is a minor one) */
     3474        /* otherwise it must have been GC'd (since this is a minor one) */
     3475        else if(C_in_stackp(loc)) {
    34613476          locative_table[ i ] = C_SCHEME_UNDEFINED;
    34623477          C_set_block_item(loc, 0, 0);
     
    34643479        }
    34653480
    3466         ptr = C_block_item(loc, 0); /* forwarded. fix up ptr and check pointed-at object for being forwarded... */
     3481        /* forwarded. fix up ptr and check pointed-at object for being forwarded... */
     3482        ptr = C_block_item(loc, 0);
    34673483        offset = C_unfix(C_block_item(loc, 1));
    34683484        obj = ptr - offset;
     
    35713587  /* Build vector with context information: */
    35723588  n = C_temporary_stack_bottom - C_temporary_stack;
    3573   p = C_alloc(19 + n); /* 19 <=> 2 headers + trampoline + proc + 1 extra slot + 9 for interning + 5 for string */
     3589  /* 19 <=> 2 headers + trampoline + proc + 1 extra slot + 9 for interning + 5 for string */
     3590  p = C_alloc(19 + n);
    35743591  x = (C_word)p;
    35753592  *(p++) = C_VECTOR_TYPE | C_BYTEBLOCK_BIT | (2 * sizeof(C_word));
     
    35993616  last_interrupt_latency = c;
    36003617  C_timer_interrupt_counter = C_initial_timer_interrupt_period; /* just in case */
    3601   C_do_apply(2, x, C_SCHEME_UNDEFINED);  /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */
     3618  /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */
     3619  C_do_apply(2, x, C_SCHEME_UNDEFINED);
    36023620}
    36033621
     
    36333651  if(val == C_SCHEME_UNBOUND) {
    36343652    len = C_strlen(name);
    3635     p = C_alloc(C_SIZEOF_STRING(len));  /* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */
     3653    /* this is ok: we won't return from `C_retrieve2'
     3654     * (or the value isn't needed). */
     3655    p = C_alloc(C_SIZEOF_STRING(len));
    36363656    return get_unbound_variable_value(C_string2(&p, name));
    36373657  }
     
    38123832      if(ptr >= trace_buffer_limit) ptr = trace_buffer;
    38133833
    3814       C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw); /* outside-pointer, will be ignored by GC */
     3834      /* outside-pointer, will be ignored by GC */
     3835      C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw);
    38153836      C_mutate(&C_block_item(buffer, p++), ptr->cooked1);
    38163837      C_mutate(&C_block_item(buffer, p++), ptr->cooked2);
     
    43784399  double m, f = C_flonum_magnitude(n);
    43794400
    4380   if(f <= (double)C_MOST_POSITIVE_FIXNUM && f >= (double)C_MOST_NEGATIVE_FIXNUM && modf(f, &m) == 0.0)
     4401  if(f <= (double)C_MOST_POSITIVE_FIXNUM
     4402     && f >= (double)C_MOST_NEGATIVE_FIXNUM && modf(f, &m) == 0.0)
    43814403    return C_fix(f);
    43824404  else return n;
     
    45954617  n = C_header_size(x);
    45964618
    4597   return C_mk_bool(n == C_header_size(y) && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
     4619  return C_mk_bool(n == C_header_size(y)
     4620                   && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
    45984621}
    45994622
     
    46044627
    46054628  n = C_header_size(x);
    4606   return C_mk_bool(n == C_header_size(y) && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
     4629  return C_mk_bool(n == C_header_size(y)
     4630         && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
    46074631}
    46084632
     
    46874711C_regparm C_word C_fcall C_i_numberp(C_word x)
    46884712{
    4689   return C_mk_bool((x & C_FIXNUM_BIT) || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG));
     4713  return C_mk_bool((x & C_FIXNUM_BIT)
     4714         || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG));
    46904715}
    46914716
     
    59826007C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)
    59836008{
    5984   if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0 || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))
     6009  if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0
     6010     || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))
    59856011    barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);
    59866012
     
    62266252
    62276253
    6228 void C_ccall C_call_cc(C_word c, C_word cl, C_word k, C_word cont)
     6254void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont)
    62296255{
    62306256  C_word *a = C_alloc(3),
     
    63476373
    63486374
    6349 void C_ccall C_call_with_values(C_word c, C_word cl, C_word k, C_word thunk, C_word kont)
     6375void C_ccall C_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont)
    63506376{
    63516377  C_word *a = C_alloc(4),
     
    63676393
    63686394
    6369 void C_ccall C_u_call_with_values(C_word c, C_word cl, C_word k, C_word thunk, C_word kont)
     6395void C_ccall C_u_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont)
    63706396{
    63716397  C_word *a = C_alloc(4),
     
    63796405void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...)
    63806406{
    6381   C_word kont = ((C_SCHEME_BLOCK *)closure)->data[ 1 ],
    6382          k = ((C_SCHEME_BLOCK *)closure)->data[ 2 ],
     6407  C_word kont = C_u_i_cdr(closure),
     6408         k = C_block_item(closure, 2),
    63836409         n = c,
    63846410         *ptr;
     
    81008126  int n = 0, total;
    81018127  C_SYMBOL_TABLE *stp;
    8102   C_word x, y, ab[ WORDS_PER_FLONUM * 2 + 5 ], *a = ab; /* 2 flonums + 1 vector of 4 elements */
     8128  C_word x, y,
     8129         ab[ WORDS_PER_FLONUM * 2 + 5 ], /* 2 flonums + 1 vector of 4 elements */
     8130         *a = ab;
    81038131
    81048132  for(stp = symbol_table_list; stp != NULL; stp = stp->next)
     
    81958223void C_ccall C_machine_byte_order(C_word c, C_word closure, C_word k)
    81968224{
     8225  char *str;
    81978226  C_word *a, s;
    81988227
    81998228  if(c != 2) C_bad_argc(c, 2);
    82008229
    8201 #if defined(C_BIG_ENDIAN)
    8202   a = C_alloc(2 + C_bytestowords(10));
    8203   s = C_string2(&a, "big-endian");
    8204 #elif defined(C_LITTLE_ENDIAN)
    8205   a = C_alloc(2 + C_bytestowords(13));
    8206   s = C_string2(&a, "little-endian");
     8230#if defined(C_MACHINE_BYTE_ORDER)
     8231  str = C_MACHINE_BYTE_ORDER;
    82078232#else
    82088233  C_cblock
    82098234    static C_word one_two_three = 123;
    8210     if(*((C_char *)&one_two_three) != 123) {
    8211       a = C_alloc(2 + C_bytestowords(10));
    8212       s = C_string2(&a, "big-endian");
    8213     } else {
    8214       a = C_alloc(2 + C_bytestowords(13));
    8215       s = C_string2(&a, "little-endian");
    8216     }
     8235    str = (*((C_char *)&one_two_three) != 123) ? "big-endian" : "little-endian";
    82178236  C_cblockend
    82188237#endif
    82198238
     8239  a = C_alloc(2 + C_bytestowords(strlen(str)));
     8240  s = C_string2(&a, str);
     8241
    82208242  C_kontinue(k, s);
    82218243}
     
    82288250  if(c != 2) C_bad_argc(c, 2);
    82298251
    8230 #if defined(__alpha__)
    8231   a = C_alloc(2 + C_bytestowords(5));
    8232   s = C_string2(&a, "alpha");
    8233 #elif defined(__mips__)
    8234   a = C_alloc(2 + C_bytestowords(4));
    8235   s = C_string2(&a, "mips");
    8236 #elif defined(__hppa__)
    8237   a = C_alloc(2 + C_bytestowords(4));
    8238   s = C_string2(&a, "hppa");
    8239 #elif defined(__sparc_v9__) || defined(__sparcv9)
    8240   a = C_alloc(2 + C_bytestowords(10));
    8241   s = C_string2(&a, "ultrasparc");
    8242 #elif defined(__sparc__)
    8243   a = C_alloc(2 + C_bytestowords(5));
    8244   s = C_string2(&a, "sparc");
    8245 #elif defined(__powerpc64__)
    8246   a = C_alloc(2 + C_bytestowords(5));
    8247   s = C_string2(&a, "ppc64");
    8248 #elif defined(__ppc__) || defined(__powerpc__)
    8249   a = C_alloc(2 + C_bytestowords(3));
    8250   s = C_string2(&a, "ppc");
    8251 #elif defined(_M_IX86) || defined(__i386__)
    8252   a = C_alloc(2 + C_bytestowords(3));
    8253   s = C_string2(&a, "x86");
    8254 #elif defined(__ia64__)
    8255   a = C_alloc(2 + C_bytestowords(4));
    8256   s = C_string2(&a, "ia64");
    8257 #elif defined(__x86_64__)
    8258   a = C_alloc(2 + C_bytestowords(6));
    8259   s = C_string2(&a, "x86-64");
    8260 #elif defined(__arm__)
    8261   a = C_alloc(2 + C_bytestowords(3));
    8262   s = C_string2(&a, "arm");
    8263 #else
    8264   a = C_alloc(2 + C_bytestowords(7));
    8265   s = C_string2(&a, "unknown");
    8266 #endif
     8252  a = C_alloc(2 + C_bytestowords(strlen(C_MACHINE_TYPE)));
     8253  s = C_string2(&a, C_MACHINE_TYPE);
    82678254 
    82688255  C_kontinue(k, s);
     
    82768263  if(c != 2) C_bad_argc(c, 2);
    82778264
    8278 #if defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)
    8279   a = C_alloc(2 + C_bytestowords(7));
    8280   s = C_string2(&a, "windows");
    8281 #elif defined(__unix__) || defined(C_XXXBSD)
    8282   a = C_alloc(2 + C_bytestowords(4));
    8283   s = C_string2(&a, "unix");
    8284 #elif defined(ECOS)
    8285   a = C_alloc(2 + C_bytestowords(4));
    8286   s = C_string2(&a, "ecos");
    8287 #else
    8288   a = C_alloc(2 + C_bytestowords(7));
    8289   s = C_string2(&a, "unknown");
    8290 #endif
     8265  a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_TYPE)));
     8266  s = C_string2(&a, C_SOFTWARE_TYPE);
    82918267
    82928268 C_kontinue(k, s);
     
    83008276  if(c != 2) C_bad_argc(c, 2);
    83018277
    8302 #if defined(__CYGWIN__)
    8303   a = C_alloc(2 + C_bytestowords(6));
    8304   s = C_string2(&a, "cygwin");
    8305 #elif defined(_MSC_VER)
    8306   a = C_alloc(2 + C_bytestowords(4));
    8307   s = C_string2(&a, "msvc");
    8308 #elif defined(__SUNPRO_C)
    8309   a = C_alloc(2 + C_bytestowords(3));
    8310   s = C_string2(&a, "sun");
    8311 #elif defined(__MINGW32__)
    8312   a = C_alloc(2 + C_bytestowords(7));
    8313   s = C_string2(&a, "mingw32");
    8314 #elif defined(__GNUC__)
    8315   a = C_alloc(2 + C_bytestowords(3));
    8316   s = C_string2(&a, "gnu");
    8317 #elif defined(__MWERKS__)
    8318   a = C_alloc(2 + C_bytestowords(10));
    8319   s = C_string2(&a, "metrowerks");
    8320 #elif defined(__INTEL_COMPILER)
    8321   a = C_alloc(2 + C_bytestowords(5));
    8322   s = C_string2(&a, "intel");
    8323 #elif defined(__WATCOMC__)
    8324   a = C_alloc(2 + C_bytestowords(7));
    8325   s = C_string2(&a, "watcom");
    8326 #else
    8327   a = C_alloc(2 + C_bytestowords(7));
    8328   s = C_string2(&a, "unknown");
    8329 #endif
     8278  a = C_alloc(2 + C_bytestowords(strlen(C_BUILD_PLATFORM)));
     8279  s = C_string2(&a, C_BUILD_PLATFORM);
    83308280
    83318281 C_kontinue(k, s);
     
    83408290  if(c != 2) C_bad_argc(c, 2);
    83418291
    8342 #if defined(_MSC_VER)
    8343 # if defined(_DLL)
    8344   a = C_alloc(2 + C_bytestowords(7));
    8345   s = C_string2(&a, "dynamic");
    8346 # else
    8347   a = C_alloc(2 + C_bytestowords(6));
    8348   s = C_string2(&a, "static");
    8349 # endif
    8350 #else
    8351   a = C_alloc(2 + C_bytestowords(7));
    8352   s = C_string2(&a, "unknown");
    8353 #endif
     8292  a = C_alloc(2 + C_bytestowords(strlen(C_RUNTIME_VERSION)));
     8293  s = C_string2(&a, C_RUNTIME_VERSION);
    83548294
    83558295 C_kontinue(k, s);
     
    83638303  if(c != 2) C_bad_argc(c, 2);
    83648304
    8365 #if defined(__linux__)
    8366   a = C_alloc(2 + C_bytestowords(5));
    8367   s = C_string2(&a, "linux");
    8368 #elif defined(__FreeBSD__)
    8369   a = C_alloc(2 + C_bytestowords(7));
    8370   s = C_string2(&a, "freebsd");
    8371 #elif defined(__NetBSD__)
    8372   a = C_alloc(2 + C_bytestowords(6));
    8373   s = C_string2(&a, "netbsd");
    8374 #elif defined(__OpenBSD__)
    8375   a = C_alloc(2 + C_bytestowords(7));
    8376   s = C_string2(&a, "openbsd");
    8377 #elif defined(C_MACOSX)
    8378   a = C_alloc(2 + C_bytestowords(6));
    8379   s = C_string2(&a, "macosx");
    8380 #elif defined(__hpux__)
    8381   a = C_alloc(2 + C_bytestowords(4));
    8382   s = C_string2(&a, "hpux");
    8383 #elif defined(__DragonFly__)
    8384   a = C_alloc(2 + C_bytestowords(9));
    8385   s = C_string2(&a, "dragonfly");
    8386 #elif defined(__sun__)
    8387  #if defined(__svr4__)
    8388   a = C_alloc(2 + C_bytestowords(7));
    8389   s = C_string2(&a, "solaris");
    8390  #else
    8391   a = C_alloc(2 + C_bytestowords(5));
    8392   s = C_string2(&a, "sunos");
    8393  #endif
    8394 #else
    8395   a = C_alloc(2 + C_bytestowords(7));
    8396   s = C_string2(&a, "unknown");
    8397 #endif
     8305  a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_VERSION)));
     8306  s = C_string2(&a, C_SOFTWARE_VERSION);
    83988307
    83998308 C_kontinue(k, s);
     
    85108419
    85118420  if(C_truep(reloadable) && (reload_lf = find_module_handle(mname)) != NULL) {
    8512     shl_unload((shl_t)reload_lf->module_handle); /*** failure currently not handled - what does shl_unload() return ? */
     8421    if(shl_unload((shl_t)reload_lf->module_handle) != 0)
     8422      panic(C_text("Unable to unload previously loaded compiled code"));
    85138423  }
    85148424  else reload_lf = NULL;
     
    85858495
    85868496    if(p != NULL) {
    8587       /* check whether dloaded code is not a library unit and matches current safety setting: */
     8497      /* check whether dloaded code is not a library unit
     8498       * and matches current safety setting: */
    85888499      if((p2 = C_dlsym(handle, C_text("C_dynamic_and_unsafe"))) == NULL)
    85898500        p2 = C_dlsym(handle, C_text("_C_dynamic_and_unsafe"));
     
    85958506#endif
    85968507     
    8597       if(!ok && !C_strcmp(topname, "C_toplevel")) /* unsafe marker not found and this is not a library unit? */
     8508      /* unsafe marker not found and this is not a library unit? */
     8509      if(!ok && !C_strcmp(topname, "C_toplevel"))
    85988510#ifdef C_UNSAFE_RUNTIME
    85998511        barf(C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR, NULL);
     
    86538565
    86548566  if(C_truep(reloadable) && (reload_lf = find_module_handle((char *)C_data_pointer(name))) != NULL) {
    8655     FreeLibrary((HINSTANCE)reload_lf->module_handle); /*** failure currently not handled - what does FreeLibrary() return ? */
     8567    if(FreeLibrary((HINSTANCE)reload_lf->module_handle) == 0)
     8568      panic(C_text("Unable to unload previously loaded compiled code"));
    86568569  }
    86578570  else reload_lf = NULL;
     
    86598572  if((handle = LoadLibrary(mname)) != NULL) {
    86608573    if ((p = GetProcAddress(handle, topname)) != NULL) {
    8661       /* check whether dloaded code is not a library unit and matches current safety setting: */
     8574      /* check whether dloaded code is not a library unit
     8575       * and matches current safety setting: */
    86628576      p2 = GetProcAddress(handle, C_text("C_dynamic_and_unsafe"));
    86638577
     
    86688582#endif
    86698583     
    8670       if(!ok && !C_strcmp(topname, "C_toplevel")) /* unsafe marker not found and this is not a library unit? */
     8584      /* unsafe marker not found and this is not a library unit? */
     8585      if(!ok && !C_strcmp(topname, "C_toplevel"))
    86718586#ifdef C_UNSAFE_RUNTIME
    86728587        barf(C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR, NULL);
     
    87078622#ifndef NO_DLOAD2
    87088623# if defined(__hpux__) && defined(HAVE_DL_H)
    8709   shl_unload((shl_t)m->module_handle);
     8624  if(shl_unload((shl_t)m->module_handle) != 0) return C_SCHEME_FALSE;
    87108625# elif defined(HAVE_DLFCN_H)
    87118626  if(dlclose(m->module_handle) != 0) return C_SCHEME_FALSE;
    87128627# elif defined(HAVE_LOADLIBRARY)
    8713   FreeLibrary(m->module_handle);
     8628  if(FreeLibrary(m->module_handle) == 0) return C_SCHEME_FALSE;
    87148629# else
    87158630  return C_SCHEME_FALSE;
  • chicken/branches/chicken-3/scheduler.scm

    r13135 r13178  
    500500    (##sys#call-with-current-continuation
    501501     (lambda (k)
    502        (let* ((pk (if (eq? ##sys#current-thread ##sys#primordial-thread)
    503                       '()
    504                       (list '(exn . thread) ##sys#current-thread
    505                             '(exn . primordial-continuation)
    506                             (lambda _ ((##sys#slot ##sys#primordial-thread 1))))))
    507               (exn (##sys#make-structure
    508                     'condition
    509                     '(exn breakpoint)
    510                     (append
    511                      (list '(exn . message) "*** breakpoint ***"
    512                            '(exn . arguments) (cons name args)
    513                            '(exn . location) name
    514                            '(exn . continuation) k)
    515                      pk) ) ) )
     502       (let* ([exn
     503              (##sys#make-breakpoint-condition
     504               name
     505               k
     506               (if (eq? ##sys#current-thread ##sys#primordial-thread)
     507                   '()
     508                    `(thread                  ,##sys#current-thread
     509                      primordial-continuation ,(lambda _ ((%thread-thunk ##sys#primordial-thread)))))
     510               (%cons name args))] )
    516511         (set! ##sys#last-breakpoint exn)
    517512         (cond ((eq? ##sys#current-thread ##sys#primordial-thread)
     
    531526(define (##sys#break-resume exn)
    532527  ;; assumes current-thread is primordial
    533   (let* ((props (##sys#slot exn 2))
    534          (a (member '(exn . continuation) props))
    535          (t (member '(exn . thread) props))
    536          (pk (or (member '(exn . primordial-continuation) props) a)))
     528  (let* ([k (##sys#condition-property cnd '(breakpoint . continuation))]
     529         [t (##sys#condition-property cnd '(breakpoint . thread))]
     530         [pk (or (##sys#condition-property cnd '(breakpoint . primordial-continuation))
     531                 k)] )
    537532    (when t
    538       (let ((t (cadr t)))
    539         (if a
    540             (##sys#setslot t 1 (lambda () ((cadr a) (void))))
    541             (##sys#signal-hook #:type-error "condition has no continuation" exn) )
    542         (##sys#add-to-ready-queue t) ) )
     533      (if k
     534          (%thread-thunk-set! t (lambda () (k (void))))
     535          (##sys#error-condition-without-continuation cnd) )
     536      (##sys#add-to-ready-queue t) )
    543537    (if pk
    544         ((cadr pk) (void))
    545         (##sys#signal-hook #:type-error "condition has no continuation" exn) ) ) )
     538        (pk (void))
     539        (##sys#error-condition-without-continuation cnd) ) ) )
  • chicken/branches/chicken-3/srfi-18.scm

    r13135 r13178  
    121121; 0     Tag - 'thread
    122122; 1     Thunk (procedure)
    123 ; 2     Results (list)
     123; 2     Results (list-of object)
    124124; 3     State (symbol)
    125 ; 4     Block-timeout
     125; 4     Block-timeout (fixnum or #f)
    126126; 5     State buffer (vector)
    127127;       0       Dynamic winds (list)
     
    132132;       5       Parameters (vector)
    133133; 6     Name (object)
    134 ; 7     Reason (condition)
    135 ; 8     Mutexes (set as list)
     134; 7     Reason (condition of #f)
     135; 8     Mutexes (list-of mutex)
    136136; 9     Quantum (fixnum)
    137137; 10    Specific (object)
    138 ; 11    Block object (type depends on blocking type)
    139 ; 12    Recipients (currently unused)
     138; 11    Block object (thread or (pair-of fd io-mode))
     139; 12    Recipients (list-of thread)
    140140; 13    Unblocked by timeout? (boolean)
    141141
    142 #; ;UNUSED
    143142(define-inline (%thread? x)
    144143  (##sys#structure? x 'thread) )
     
    165164  (##sys#slot th 4) )
    166165
    167 #; ;UNUSED
     166(define-inline (%thread-block-timeout-set! th to)
     167  (##sys#setislot th 4 to) )
     168
     169(define-inline (%thread-block-timeout-clear! th)
     170  (%thread-block-timeout-set! th #f) )
     171
    168172(define-inline (%thread-state-buffer th)
    169173  (##sys#slot th 5) )
    170174
     175(define-inline (%thread-state-buffer-set! th v)
     176  (##sys#setslot th 5 v) )
     177
    171178(define-inline (%thread-name th)
    172179  (##sys#slot th 6) )
     
    184191  (##sys#setslot th 8 wx) )
    185192
     193(define-inline (%thread-mutexes-empty? th)
     194  (null? (%thread-mutexes th)) )
     195
     196(define-inline (%thread-mutexes-empty! th)
     197  (##sys#setislot th 8 '()) )
     198
    186199(define-inline (%thread-mutexes-add! th mx)
    187200  (%thread-mutexes-set! th (cons mx (%thread-mutexes th))) )
     
    202215  (##sys#setslot th 10 x) )
    203216
    204 #; ;UNUSED
    205217(define-inline (%thread-block-object th)
    206218  (##sys#slot th 11) )
    207219
    208 #; ;UNUSED
     220(define-inline (%thread-block-object-set! th x)
     221  (##sys#setslot th 11 x) )
     222
     223(define-inline (%thread-block-object-clear! th)
     224  (##sys#setislot th 11 #f) )
     225
    209226(define-inline (%thread-recipients th)
    210227  (##sys#slot th 12) )
    211228
    212 #; ;UNUSED
     229(define-inline (%thread-recipients-set! th x)
     230  (##sys#setslot th 12 x) )
     231
     232(define-inline (%thread-recipients-empty! th)
     233  (##sys#setislot th 12 '()) )
     234
     235(define-inline (%thread-recipients-add! th rth)
     236  (%thread-recipients-set! t (cons rth (%thread-recipients t))) )
     237
     238(define-inline (%thread-recipients-process! th tk)
     239  (let ([rs (%thread-recipients t)])
     240    (unless (null? rs) (for-each tk rs) ) )
     241  (thread-recipients-empty! t) )
     242
    213243(define-inline (%thread-unblocked-by-timeout? th)
    214244  (##sys#slot th 13) )
     245
     246(define-inline (%thread-unblocked-by-timeout-set! th f)
     247  (##sys#setislot th 13 f) )
    215248
    216249(define-inline (%make-thread nm tk #!optional (qt (%thread-quantum ##sys#current-thread)))
     
    263296  (null? (%mutex-waiters mx)) )
    264297
     298(define-inline (%mutex-waiters-empty! mx)
     299  (##sys#setislot mx 3 '()) )
     300
    265301(define-inline (%mutex-waiters-pop! mx)
    266302  (let* ([wt (%mutex-waiters mx)]
     
    275311  (##sys#setislot mx 4 f) )
    276312
    277 (define-inline (%mutex-not-abandoned! mx)
    278   (%mutex-abandoned-set! mx #f) )
    279 
    280 (define-inline (%mutex-abandoned! mx)
    281   (%mutex-abandoned-set! mx #t) )
    282 
    283313(define-inline (%mutex-locked? mx)
    284314  (##sys#slot mx 5) )
     
    286316(define-inline (%mutex-locked-set! mx f)
    287317  (##sys#setislot mx 5 f) )
    288 
    289 (define-inline (%mutex-not-locked! mx)
    290   (%mutex-locked-set! mx #f) )
    291 
    292 (define-inline (%mutex-locked! mx)
    293   (%mutex-locked-set! mx #t) )
    294318
    295319(define-inline (%mutex-specific mx)
     
    505529(define (thread-join! thread #!optional timeout timeout-val)
    506530  (%check-thread thread 'thread-join!)
    507   (let* ([limit (and timeout (##sys#timeout->limit timeout 'thread-join!))])
     531  (let ([limit (and timeout (##sys#timeout->limit timeout 'thread-join!))])
    508532    (##sys#call-with-current-continuation
    509533     (lambda (return)
     
    629653                    (begin
    630654                      (%mutex-thread-clear! mutex)
    631                       (%mutex-locked! mutex) )
     655                      (%mutex-locked-set! mutex #t) )
    632656                    (let* ([th (or thread ct)]
    633657                           [ts (%thread-state th)] )
    634658                      (if (or (eq?'terminated ts) (eq? 'dead ts))
    635                           (%mutex-abandoned! mutex)
     659                          (%mutex-abandoned-set! mutex #t)
    636660                          (begin
    637                             (%mutex-locked! mutex)
     661                            (%mutex-locked-set! mutex #t)
    638662                            (%thread-mutexes-add! th mutex)
    639663                            (%mutex-thread-set! mutex th) ) ) ) )
     
    663687       (let ([limit (and timeout (##sys#timeout->limit timeout 'mutex-unlock!))]
    664688             [result #t] )
    665          (%mutex-not-abandoned! mutex)
    666          (%mutex-not-locked! mutex)
     689         (%mutex-abandoned-set! mutex #f)
     690         (%mutex-locked-set! mutex #f)
    667691         (%thread-mutexes-delete! ct mutex)
    668692         (%thread-thunk-set! ct (lambda () (return result)))
     
    681705           (let* ([wt (%mutex-waiters-pop! mutex)]
    682706                  [wts (%thread-state wt)] )
    683              (%mutex-locked! mutex)
     707             (%mutex-locked-set! mutex #t)
    684708             (when (or (eq? 'blocked wts) (eq? 'sleeping wts))
    685709               (%mutex-thread-set! mutex wt)
Note: See TracChangeset for help on using the changeset viewer.