Changeset 13167 in project


Ignore:
Timestamp:
02/03/09 05:28:28 (11 years ago)
Author:
Kon Lovett
Message:

posixunix.scm, osixwin.scm : added Unit ports use
lolevel.scm : comment fix
runtime.c : cl -> closure (like other procs), use of macros rather than open-coded block access
chicken-thread-object-inlines.scm : minor fix

Location:
chicken/trunk
Files:
7 edited

Legend:

Unmodified
Added
Removed

  • chicken/trunk/chicken-thread-object-inlines.scm

    r13146 r13167  
    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/trunk/chicken.h

    r13148 r13167  
    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
    … …  
    464466#define C_SIZEOF_PAIR             3
    465467#define C_SIZEOF_STRING(n)        (C_bytestowords(n) + 2)
    466 #define C_SIZEOF_SYMBOL          4
     468#define C_SIZEOF_SYMBOL           4
    467469#define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_BUCKET + C_SIZEOF_STRING(n))
    468470#ifdef C_DOUBLE_IS_32_BITS
    469 # define C_SIZEOF_FLONUM           2
    470 #else
    471 # define C_SIZEOF_FLONUM           4
     471# define C_SIZEOF_FLONUM          2
     472#else
     473# define C_SIZEOF_FLONUM          4
    472474#endif
    473475#define C_SIZEOF_POINTER          2
    … …  
    485487#define C_SWIG_POINTER_TAG        (C_SWIG_POINTER_TYPE | (C_wordstobytes(C_SIZEOF_SWIG_POINTER - 1)))
    486488#define C_SYMBOL_TAG              (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1))
    487 #define C_FLONUM_TAG             (C_FLONUM_TYPE | sizeof(double))
     489#define C_FLONUM_TAG              (C_FLONUM_TYPE | sizeof(double))
    488490
    489491#ifdef C_SIXTY_FOUR
    … …  
    787789#define C_fix(n)                   (((C_word)(n) << C_FIXNUM_SHIFT) | C_FIXNUM_BIT)
    788790#define C_unfix(x)                 ((x) >> C_FIXNUM_SHIFT)
    789 #define C_make_character(c)        ((((c) & C_CHAR_BIT_MASK) << 8) | C_CHARACTER_BITS)
    790 #define C_character_code(x)        (((x) >> 8) & C_CHAR_BIT_MASK)
     791#define C_make_character(c)        ((((c) & C_CHAR_BIT_MASK) << C_CHAR_SHIFT) | C_CHARACTER_BITS)
     792#define C_character_code(x)        (((x) >> C_CHAR_SHIFT) & C_CHAR_BIT_MASK)
    791793#define C_flonum_magnitude(x)      (*((double *)(((C_SCHEME_BLOCK *)(x))->data)))
    792794#define C_c_string(x)              ((C_char *)(((C_SCHEME_BLOCK *)(x))->data))

  • chicken/trunk/library.scm

    r13150 r13167  
    25792579
    25802580(define (##sys#char->utf8-string c)
    2581   (let ((i (char->integer c)))
    2582     (cond
    2583       ((fx<= i #x7F) (string c))
    2584       ((fx<= i #x7FF)
    2585        (string (integer->char (fxior #b11000000 (fxshr i 6)))
    2586                (integer->char (fxior #b10000000 (fxand i #b111111)))))
    2587       ((fx<= i #xFFFF)
    2588        (string (integer->char (fxior #b11100000 (fxshr i 12)))
    2589                (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
    2590                (integer->char (fxior #b10000000 (fxand i #b111111)))))
    2591       ((fx<= i #x1FFFFF)
    2592        (string (integer->char (fxior #b11110000 (fxshr i 18)))
    2593                (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))
    2594                (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
    2595                (integer->char (fxior #b10000000 (fxand i #b111111)))))
    2596       (else (error "unicode codepoint out of range:" i)))))
     2581  (let ([i (char->integer c)])
     2582    (cond [(fx<= i #x7F)
     2583           (string c) ]
     2584          [(fx<= i #x7FF)
     2585           (string (integer->char (fxior #b11000000 (fxshr i 6)))
     2586                   (integer->char (fxior #b10000000 (fxand i #b111111)))) ]
     2587          [(fx<= i #xFFFF)
     2588           (string (integer->char (fxior #b11100000 (fxshr i 12)))
     2589                   (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
     2590                   (integer->char (fxior #b10000000 (fxand i #b111111)))) ]
     2591          [(fx<= i #x1FFFFF)
     2592           (string (integer->char (fxior #b11110000 (fxshr i 18)))
     2593                   (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))
     2594                   (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
     2595                   (integer->char (fxior #b10000000 (fxand i #b111111)))) ]
     2596          [else
     2597           (error "UTF-8 codepoint out of range:" i) ] ) ) )
    25972598
    25982599(define (##sys#unicode-surrogate? n)
    2599   (and (fx<= #xD800 n) (fx<= n #xDFFF)))
     2600  (and (fx<= #xD800 n) (fx<= n #xDFFF)) )
    26002601
    26012602;; returns #f if the inputs are not a valid surrogate pair (hi followed by lo)
    … …  
    26052606       (fxior (fxshl (fx+ 1 (fxand (fxshr hi 6) #b11111)) 16)
    26062607              (fxior (fxshl (fxand hi #b111111) 10)
    2607                      (fxand lo #b1111111111)))))
     2608                     (fxand lo #b1111111111)))) )
    26082609
    26092610;;; Hooks for user-defined read-syntax:
    … …  
    26162617  (case char
    26172618    ;; I put it here, so the SRFI-4 unit can intercept '#f...'
    2618     ((#\f #\F) (##sys#read-char-0 port) #f)
    2619     ((#\t #\T) (##sys#read-char-0 port) #t)
    2620     (else (##sys#read-error port "invalid sharp-sign read syntax" char) ) ) )
     2619    [(#\f #\F) (##sys#read-char-0 port) #f ]
     2620    [(#\t #\T) (##sys#read-char-0 port) #t ]
     2621    [else (##sys#read-error port "invalid sharp-sign read syntax" char) ] ) )
    26212622
    26222623

  • chicken/trunk/lolevel.scm

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

  • chicken/trunk/posixunix.scm

    r13093 r13167  
    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/trunk/posixwin.scm

    r13135 r13167  
    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/trunk/runtime.c

    r13148 r13167  
    62396239
    62406240
    6241 void C_ccall C_call_cc(C_word c, C_word cl, C_word k, C_word cont)
     6241void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont)
    62426242{
    62436243  C_word *a = C_alloc(3),
    … …  
    63606360
    63616361
    6362 void C_ccall C_call_with_values(C_word c, C_word cl, C_word k, C_word thunk, C_word kont)
     6362void C_ccall C_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont)
    63636363{
    63646364  C_word *a = C_alloc(4),
    … …  
    63806380
    63816381
    6382 void C_ccall C_u_call_with_values(C_word c, C_word cl, C_word k, C_word thunk, C_word kont)
     6382void C_ccall C_u_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont)
    63836383{
    63846384  C_word *a = C_alloc(4),
    … …  
    63926392void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...)
    63936393{
    6394   C_word kont = ((C_SCHEME_BLOCK *)closure)->data[ 1 ],
    6395          k = ((C_SCHEME_BLOCK *)closure)->data[ 2 ],
     6394  C_word kont = C_u_i_cdr(closure),
     6395         k = C_block_item(closure, 2),
    63966396         n = c,
    63976397         *ptr;
    … …  
    84128412void C_ccall C_register_finalizer(C_word c, C_word closure, C_word k, C_word x, C_word proc)
    84138413{
    8414   if(C_immediatep(x)) C_kontinue(k, x );
     8414  if(C_immediatep(x)) C_kontinue(k, x);
    84158415
    84168416  C_do_register_finalizer(x, proc);
Note: See TracChangeset for help on using the changeset viewer.