Changeset 13135 in project for chicken


Ignore:
Timestamp:
01/30/09 13:21:18 (11 years ago)
Author:
Kon Lovett
Message:

trunk/posixwin.scm : unimplimented is syntax
trunk/runtime.c : nl btwn computation & return is distracting
lolevel.scm : added type check helpers
library.scm : moved '##sys#abandon-mutexes' to schedular
posixunix.scm : rmvd some unused decls
schedular.scm : added '##sys#abandon-mutexes' since only used here
tests/runtests.sh : added no init
runtime.c : added "true unix" fudge, rmvd host PCRE fudge
srfi-18 : added OO-procedures - the algorithms read much easier now

Location:
chicken
Files:
12 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/chicken-3/chicken.h

    r13134 r13135  
    343343# define C_LOCATIVE_TYPE          (0x0a00000000000000L | C_SPECIALBLOCK_BIT)
    344344# define C_TAGGED_POINTER_TYPE    (0x0b00000000000000L | C_SPECIALBLOCK_BIT)
    345 # define C_SWIG_POINTER_TYPE      (0x0c00000000000000L | C_BYTEBLOCK_BIT)
     345# define C_SWIG_POINTER_TYPE      (0x0c00000000000000L | C_SPECIALBLOCK_BIT)
    346346# define C_LAMBDA_INFO_TYPE       (0x0d00000000000000L | C_BYTEBLOCK_BIT)
    347347#else
     
    372372# define C_LOCATIVE_TYPE          (0x0a000000 | C_SPECIALBLOCK_BIT)
    373373# define C_TAGGED_POINTER_TYPE    (0x0b000000 | C_SPECIALBLOCK_BIT)
    374 # define C_SWIG_POINTER_TYPE      (0x0c000000 | C_BYTEBLOCK_BIT)
     374# define C_SWIG_POINTER_TYPE      (0x0c000000 | C_SPECIALBLOCK_BIT)
    375375# define C_LAMBDA_INFO_TYPE       (0x0d000000 | C_BYTEBLOCK_BIT)
    376376#endif
  • chicken/branches/chicken-3/library.scm

    r13127 r13135  
    152152     ##sys#schedule ##sys#make-thread ##sys#print-to-string ##sys#scan-buffer-line
    153153     ##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer ##sys#user-print-hook
    154      ##sys#current-exception-handler ##sys#default-exception-handler ##sys#abandon-mutexes ##sys#make-mutex
     154     ##sys#current-exception-handler ##sys#default-exception-handler ##sys#make-mutex
    155155     ##sys#port-has-file-pointer? ##sys#infix-list-hook char-name ##sys#open-file-port make-parameter
    156156     ##sys#intern-symbol ##sys#make-string ##sys#number? software-type build-platform
     
    40084008   (##core#undefined) ) )               ; #6 specific
    40094009
    4010 (define (##sys#abandon-mutexes thread)
    4011   (let ([ms (##sys#slot thread 8)])
    4012     (unless (null? ms)
    4013       (##sys#for-each
    4014        (lambda (m)
    4015          (##sys#setislot m 2 #f)
    4016          (##sys#setislot m 4 #t)
    4017          (##sys#setislot m 5 #f)
    4018          (##sys#setislot m 3 '()) )
    4019        ms) ) ) )
    4020 
    40214010(define (##sys#schedule) ((##sys#slot ##sys#current-thread 1)))
    40224011
  • chicken/branches/chicken-3/lolevel.scm

    r13134 r13135  
    3434   ##sys#check-become-alist
    3535   ##sys#check-generic-structure
    36    ##sys#check-generic-vector
    37    ##sys#tagged-pointer? )
     36   ##sys#check-generic-vector )
    3837  (foreign-declare #<<EOF
    3938#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
     
    7069     extend-procedure ) ) ] )
    7170
     71;;; Helpers:
     72
     73(define-inline (%pointer? x)
     74  (and (##core#inline "C_blockp" x) (##core#inline "C_anypointerp" x)
     75       #; ;C_anypointerp covers it
     76       (or (##core#inline "C_pointerp" x)
     77           (##core#inline "C_taggedpointerp" x)
     78           (##core#inline "C_swigpointerp" x))) )
     79
     80(define-inline (%generic-vector? x)
     81  (and (##core#inline "C_blockp" x)
     82       (not (or (##core#inline "C_specialp" x)
     83                (##core#inline "C_byteblockp" x)))) )
     84
     85(define-inline (%special-block? x)
     86  (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x)) )
     87
     88(define-inline (%record-structure? x)
     89  (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x)) )
     90
     91(define-inline (%generic-pointer? x)
     92  (or (##core#inline "C_anypointerp" x)
     93      (##sys#locative? x) ) )
     94
     95;;; Argument checking:
     96
    7297(define (##sys#check-block x . loc)
    7398  (unless (##core#inline "C_blockp" x)
     
    92117
    93118(define (##sys#check-generic-structure x . loc)
    94   (unless (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x) )
     119  (unless (%record-structure? x)
    95120    (##sys#signal-hook
    96121     #:type-error (and (pair? loc) (car loc))
     
    100125
    101126(define (##sys#check-generic-vector x . loc)
    102   (when (or (not (##core#inline "C_blockp" x))
    103             (##core#inline "C_specialp" x)
    104             (##core#inline "C_byteblockp" x) )
     127  (unless (%generic-vector? x)
    105128    (##sys#signal-hook
    106129     #:type-error (and (pair? loc) (car loc))
     
    143166
    144167;;; Move arbitrary blocks of memory around:
    145 
    146 (define (##sys#tagged-pointer? x) (##core#inline "C_taggedpointerp" x))
    147 
    148 (define-inline (%allocated-object-pointer? x)
    149   (or (##sys#pointer? x)
    150       (##sys#tagged-pointer? x)
    151       (##sys#locative? x) ) )
    152168
    153169(define move-memory!
     
    192208                   (move from (##sys#slot to 1))
    193209                   (typerr to) ) ]
    194               [(%allocated-object-pointer? from)
    195                (cond [(%allocated-object-pointer? to)
     210              [(%generic-pointer? from)
     211               (cond [(%generic-pointer? to)
    196212                      (memmove1 to from (or n (nosizerr)) toffset foffset)]
    197213                     [(or (##sys#bytevector? to) (string? to))
     
    201217              [(or (##sys#bytevector? from) (string? from))
    202218               (let ([nfrom (##sys#size from)])
    203                  (cond [(%allocated-object-pointer? to)
     219                 (cond [(%generic-pointer? to)
    204220                        (memmove2 to from (checkn1 (or n nfrom) nfrom foffset) toffset foffset)]
    205221                       [(or (##sys#bytevector? to) (string? to))
     
    234250(define free (foreign-lambda void "C_free" c-pointer))
    235251
    236 (define (pointer? x)
    237   (and (##core#inline "C_blockp" x)
    238        (or (##core#inline "C_taggedpointerp" x)
    239            (##core#inline "C_pointerp" x) ) ) )
    240 
    241 (define (pointer-like? x)
    242   (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x) ) )
     252(define (pointer? x) (%pointer? x))
     253
     254(define (pointer-like? x) (%special-block? x))
    243255
    244256(define (address->pointer addr)
     
    278290      (cond [(integer? x)
    279291             (align x)]
    280             [(and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x))
     292            [(%special-block? x)
    281293             (##sys#address->pointer (align (##sys#pointer->address x))) ]
    282294            [else
     
    338350(define (tag-pointer ptr tag)
    339351  (let ([tp (##sys#make-tagged-pointer tag)])
    340     (if (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
     352    (if (%special-block? ptr)
    341353        (##core#inline "C_copy_pointer" ptr tp)
    342354        (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
     
    349361
    350362(define (pointer-tag x)
    351   (if (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x))
     363  (if (%special-block? x)
    352364      (and (##core#inline "C_taggedpointerp" x)
    353365           (##sys#slot x 1) )
     
    551563(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
    552564
     565(define (vector-like? x)
     566  (%generic-vector? x) )
     567
    553568(define (number-of-slots x)
    554569  (##sys#check-generic-vector x 'number-of-slots)
     
    578593
    579594(define (record-instance? x #!optional type)
    580   (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x)
     595  (and (%record-structure? x)
    581596       (or (not type)
    582            (eq? type (##sys#slot x 0)) ) ) )
     597           (eq? type (##sys#slot x 0)))) )
    583598
    584599(define (record-instance-type x)
  • chicken/branches/chicken-3/manual/Unit lolevel

    r13134 r13135  
    1616=== Foreign pointers
    1717
    18 The abstract class of pointers is divided into 2 major categories: {{pointer
    19 objects}} and {{pointer-like objects}}.
    20 
    21 A {{pointer object}} is a foreign pointer object or a tagged foreign pointer
    22 object (see {{Tagged pointers}}).
    23 
    24 A {{pointer-like object}} may be a closure, port, locative (see {{Locatives}},
    25 or a {{pointer object}}.
    26 
    27 SWIG pointers are currently second class citizens due to "bitrot" in the SWIG
    28 Chicken translator. While they qualify as a {{c-pointer}} for foreign lambda
    29 argument conversion they are not supported by the foreign pointer operations.
     18The abstract class of ''pointer'' is divided into 2 categories:
     19
     20; ''pointer object'' : is a foreign pointer object, a tagged foreign pointer object (see {{Tagged pointers}}), or a SWIG-pointer.
     21
     22; ''pointer-like object'' " is a closure, port, locative (see {{Locatives}}, or a pointer object.
     23
     24SWIG-pointers are currently an issue due to "bitrot" in the SWIG Chicken
     25translator. While they are considered a pointer object unexpected results are
     26possible.
     27
     28Note that Locatives, while technically pointers, are not considered a ''pointer
     29object'', but a ''pointer-like object''. The distinction is artificial.
    3030
    3131
     
    7474==== null-pointer?
    7575
    76  [procedure] (null-pointer? PTR*)
    77 
    78 Returns {{#t}} if the pointer-like object {{PTR*}} contains a {{NULL}} pointer,
     76 [procedure] (null-pointer? POINTER*)
     77
     78Returns {{#t}} if the pointer-like object {{POINTER*}} contains a {{NULL}} pointer,
    7979or {{#f}} otherwise.
    8080
     
    9292==== pointer->object
    9393
    94  [procedure] (pointer->object PTR)
    95 
    96 Returns the Scheme object pointed to by the pointer object {{PTR}}.
    97 
    98 Whether the {{PTR}} actually points to a Scheme object is not guaranteed. Use
     94 [procedure] (pointer->object POINTER)
     95
     96Returns the Scheme object pointed to by the pointer object {{POINTER}}.
     97
     98Whether the {{POINTER}} actually points to a Scheme object is not guaranteed. Use
    9999at your own risk.
    100100
     
    115115==== pointer=?
    116116
    117  [procedure] (pointer=? PTR*1 PTR*2)
    118 
    119 Returns {{#t}} if the pointer-like objects {{PTR*1}} and {{PTR*2}} point
     117 [procedure] (pointer=? POINTER*1 POINTER*2)
     118
     119Returns {{#t}} if the pointer-like objects {{POINTER*1}} and {{POINTER*2}} point
    120120to the same address, or {{#f}} otherwise.
    121121
     
    123123==== pointer->address
    124124
    125  [procedure] (pointer->address PTR*)
    126 
    127 Returns the address, to which the pointer-like object {{PTR*}} points.
     125 [procedure] (pointer->address POINTER*)
     126
     127Returns the address, to which the pointer-like object {{POINTER*}} points.
    128128
    129129
    130130==== pointer-offset
    131131
    132  [procedure] (pointer-offset PTR* N)
     132 [procedure] (pointer-offset POINTER* N)
    133133
    134134Returns a new foreign pointer object representing the pointer-like object
    135 {{PTR*}} address value increased by the byte-offset {{N}}.
     135{{POINTER*}} address value increased by the byte-offset {{N}}.
    136136
    137137Use of anything other than a pointer object as an argument is questionable.
     
    140140==== align-to-word
    141141
    142  [procedure] (align-to-word PTR*-OR-INT)
     142 [procedure] (align-to-word POINTER*-OR-INT)
    143143
    144144Accepts either a pointer-like object or an integer as the argument and returns
     
    153153=== SRFI-4 Foreign pointers
    154154
    155 These procedures actually accept a pointer-like object as the {{PTR}} argument.
    156 However, as usual, use of anything other than a pointer object is questionable. 
     155These procedures actually accept a pointer-like object as the {{POINTER}} argument.
     156However, as usual, use of anything other than a pointer object is questionable.
    157157
    158158==== pointer-u8-ref
    159159
    160  [procedure] (pointer-u8-ref PTR)
    161 
    162 Returns the unsigned byte at the address designated by {{PTR}}.
     160 [procedure] (pointer-u8-ref POINTER)
     161
     162Returns the unsigned byte at the address designated by {{POINTER}}.
    163163
    164164
    165165==== pointer-s8-ref
    166166
    167  [procedure] (pointer-s8-ref PTR)
    168 
    169 Returns the signed byte at the address designated by {{PTR}}.
     167 [procedure] (pointer-s8-ref POINTER)
     168
     169Returns the signed byte at the address designated by {{POINTER}}.
    170170
    171171
    172172==== pointer-u16-ref
    173173
    174  [procedure] (pointer-u16-ref PTR)
    175 
    176 Returns the unsigned 16-bit integer at the address designated by {{PTR}}.
     174 [procedure] (pointer-u16-ref POINTER)
     175
     176Returns the unsigned 16-bit integer at the address designated by {{POINTER}}.
    177177
    178178
    179179==== pointer-s16-ref
    180180
    181  [procedure] (pointer-s16-ref PTR)
    182 
    183 Returns the signed 16-bit integer at the address designated by {{PTR}}.
     181 [procedure] (pointer-s16-ref POINTER)
     182
     183Returns the signed 16-bit integer at the address designated by {{POINTER}}.
    184184
    185185
    186186==== pointer-u32-ref
    187187
    188  [procedure] (pointer-u32-ref PTR)
    189 
    190 Returns the unsigned 32-bit integer at the address designated by {{PTR}}.
     188 [procedure] (pointer-u32-ref POINTER)
     189
     190Returns the unsigned 32-bit integer at the address designated by {{POINTER}}.
    191191
    192192
    193193==== pointer-s32-ref
    194194
    195  [procedure] (pointer-s32-ref PTR)
    196 
    197 Returns the signed 32-bit integer at the address designated by {{PTR}}.
     195 [procedure] (pointer-s32-ref POINTER)
     196
     197Returns the signed 32-bit integer at the address designated by {{POINTER}}.
    198198
    199199
    200200==== pointer-f32-ref
    201201
    202  [procedure] (pointer-f32-ref PTR)
    203 
    204 Returns the 32-bit float at the address designated by {{PTR}}.
     202 [procedure] (pointer-f32-ref POINTER)
     203
     204Returns the 32-bit float at the address designated by {{POINTER}}.
    205205
    206206
    207207==== pointer-f64-ref
    208208
    209  [procedure] (pointer-f64-ref PTR)
    210 
    211 Returns the 64-bit double at the address designated by {{PTR}}.
     209 [procedure] (pointer-f64-ref POINTER)
     210
     211Returns the 64-bit double at the address designated by {{POINTER}}.
    212212
    213213
    214214==== pointer-u8-set!
    215215
    216  [procedure] (pointer-u8-set! PTR N)
    217  [procedure] (set! (pointer-u8-ref PTR) N)
    218 
    219 Stores the unsigned byte {{N}} at the address designated by {{PTR}}.
     216 [procedure] (pointer-u8-set! POINTER N)
     217 [procedure] (set! (pointer-u8-ref POINTER) N)
     218
     219Stores the unsigned byte {{N}} at the address designated by {{POINTER}}.
    220220
    221221
    222222==== pointer-s8-set!
    223223
    224  [procedure] (pointer-s8-set! PTR N)
    225  [procedure] (set! (pointer-s8-ref PTR) N)
    226 
    227 Stores the signed byte {{N}} at the address designated by {{PTR}}.
     224 [procedure] (pointer-s8-set! POINTER N)
     225 [procedure] (set! (pointer-s8-ref POINTER) N)
     226
     227Stores the signed byte {{N}} at the address designated by {{POINTER}}.
    228228
    229229
    230230==== pointer-u16-set!
    231231
    232  [procedure] (pointer-u16-set! PTR N)
    233  [procedure] (set! (pointer-u16-ref PTR) N)
    234 
    235 Stores the unsigned 16-bit integer {{N}} at the address designated by {{PTR}}.
     232 [procedure] (pointer-u16-set! POINTER N)
     233 [procedure] (set! (pointer-u16-ref POINTER) N)
     234
     235Stores the unsigned 16-bit integer {{N}} at the address designated by {{POINTER}}.
    236236
    237237
    238238==== pointer-s16-set!
    239239
    240  [procedure] (pointer-s16-set! PTR N)
    241  [procedure] (set! (pointer-s16-ref PTR) N)
    242 
    243 Stores the signed 16-bit integer {{N}} at the address designated by {{PTR}}.
     240 [procedure] (pointer-s16-set! POINTER N)
     241 [procedure] (set! (pointer-s16-ref POINTER) N)
     242
     243Stores the signed 16-bit integer {{N}} at the address designated by {{POINTER}}.
    244244
    245245
    246246==== pointer-u32-set!
    247247
    248  [procedure] (pointer-u32-set! PTR N)
    249  [procedure] (set! (pointer-u32-ref PTR) N)
    250 
    251 Stores the unsigned 32-bit integer {{N}} at the address designated by {{PTR}}.
     248 [procedure] (pointer-u32-set! POINTER N)
     249 [procedure] (set! (pointer-u32-ref POINTER) N)
     250
     251Stores the unsigned 32-bit integer {{N}} at the address designated by {{POINTER}}.
    252252
    253253
    254254==== pointer-s32-set!
    255255
    256  [procedure] (pointer-s32-set! PTR N)
    257  [procedure] (set! (pointer-s32-ref PTR) N)
    258 
    259 Stores the 32-bit integer {{N}} at the address designated by {{PTR}}.
     256 [procedure] (pointer-s32-set! POINTER N)
     257 [procedure] (set! (pointer-s32-ref POINTER) N)
     258
     259Stores the 32-bit integer {{N}} at the address designated by {{POINTER}}.
    260260
    261261
    262262==== pointer-f32-set!
    263263
    264  [procedure] (pointer-f32-set! PTR N)
    265  [procedure] (set! (pointer-f32-ref PTR) N)
    266 
    267 Stores the 32-bit floating-point number {{N}} at the address designated by {{PTR}}.
     264 [procedure] (pointer-f32-set! POINTER N)
     265 [procedure] (set! (pointer-f32-ref POINTER) N)
     266
     267Stores the 32-bit floating-point number {{N}} at the address designated by {{POINTER}}.
    268268
    269269
    270270==== pointer-f64-set!
    271271
    272  [procedure] (pointer-f64-set! PTR N)
    273  [procedure] (set! (pointer-f64-ref PTR) N)
    274 
    275 Stores the 64-bit floating-point number {{N}} at the address designated by {{PTR}}.
     272 [procedure] (pointer-f64-set! POINTER N)
     273 [procedure] (set! (pointer-f64-ref POINTER) N)
     274
     275Stores the 64-bit floating-point number {{N}} at the address designated by {{POINTER}}.
    276276
    277277
     
    284284==== tag-pointer
    285285
    286  [procedure] (tag-pointer PTR* TAG)
     286 [procedure] (tag-pointer POINTER* TAG)
    287287
    288288Creates a new tagged foreign pointer object from the pointer-like object
    289 {{PTR*}} with the tag {{TAG}}, which may an arbitrary Scheme object.
     289{{POINTER*}} with the tag {{TAG}}, which may an arbitrary Scheme object.
    290290
    291291Use of anything other than a pointer object is questionable.
     
    303303==== pointer-tag
    304304
    305  [procedure] (pointer-tag PTR*)
    306 
    307 If {{PTR}} is a tagged foreign pointer object, its tag is returned. If {{PTR*}}
     305 [procedure] (pointer-tag POINTER*)
     306
     307If {{POINTER}} is a tagged foreign pointer object, its tag is returned. If {{POINTER*}}
    308308is any other kind of pointer-like object {{#f}} is returned. Otherwise an
    309309error is signalled.
     
    429429
    430430
     431=== Low-level data access
     432
     433These procedures operate with what are known as {{vector-like objects}}. A
     434{{vector-like object}} is a vector, record structure, pair, symbol or keyword.
     435
     436Note that strings and blobs are not considered vector-like.
     437
     438
     439==== vector-like?
     440
     441 [procedure] (vector-like? X)
     442
     443Returns {{#t}} when {{X}} is a vector-like object, returns {{#f}}
     444otherwise.
     445
     446
     447==== block-ref
     448
     449 [procedure] (block-ref VECTOR* INDEX)
     450
     451Returns the contents of the {{INDEX}}th slot of the vector-like object
     452{{VECTOR*}}.
     453
     454
     455==== block-set!
     456
     457 [procedure] (block-set! VECTOR* INDEX X)
     458 [procedure] (set! (block-ref VECTOR* INDEX) X)
     459
     460Sets the contents of the {{INDEX}}th slot of the vector-like object {{VECTOR*}}
     461to the value of {{X}}.
     462
     463==== number-of-slots
     464
     465 [procedure] (number-of-slots VECTOR*)
     466
     467Returns the number of slots that the vector-like object {{VECTOR*}} contains.
     468
     469
     470==== number-of-bytes
     471
     472 [procedure] (number-of-bytes BLOCK)
     473
     474Returns the number of bytes that the object {{BLOCK}} contains. {{BLOCK}} may
     475be any non-immediate value.
     476
     477
     478==== object-copy
     479
     480 [procedure] (object-copy X)
     481
     482Copies {{X}} recursively and returns the fresh copy. Objects allocated in
     483static memory are copied back into garbage collected storage.
     484
     485
     486==== move-memory!
     487
     488 [procedure] (move-memory! FROM TO [BYTES [FROM-OFFSET [TO-OFFSET]])
     489
     490Copies {{BYTES}} bytes of memory from {{FROM}} to {{TO}}. {{FROM}} and {{TO}}
     491may be strings, blobs, SRFI-4 number-vectors (see: @ref{Unit srfi-4}), memory
     492mapped files, foreign pointers (as obtained from a call to {{foreign-lambda}},
     493for example), tagged-pointers or locatives. if {{BYTES}} is not given and the
     494size of the source or destination operand is known then the maximal number of
     495bytes will be copied. Moving memory to the storage returned by locatives will
     496cause havoc, if the locative refers to containers of non-immediate data, like
     497vectors or pairs.
     498
     499The additional fourth and fifth argument specify starting offsets (in bytes)
     500for the source and destination arguments.
     501
     502Signals an error if any of the above constraints is violated.
     503
     504
     505
    431506=== Data in unmanaged memory
    432507
     
    464539==== object-evict-to-location
    465540
    466  [procedure] (object-evict-to-location X PTR* [LIMIT])
     541 [procedure] (object-evict-to-location X POINTER* [LIMIT])
    467542
    468543As {{object-evict}} but moves the object at the address pointed to by
    469 the pointer-like object {{PTR*}}. If the number of copied bytes exceeds
     544the pointer-like object {{POINTER*}}. If the number of copied bytes exceeds
    470545the optional {{LIMIT}} then an error is signalled (specifically a composite
    471546condition of types {{exn}} and {{evict}}. The latter provides
     
    474549free address after the evicted object.
    475550
    476 Use of anything other than a pointer object as the {{PTR*}} argument is
     551Use of anything other than a pointer object as the {{POINTER*}} argument is
    477552questionable.
    478553
     
    499574 [procedure] (object-unevict X [FULL])
    500575
    501 Copies the object {{X}} and nested objects back into the normal Scheme heap. 
     576Copies the object {{X}} and nested objects back into the normal Scheme heap.
    502577Symbols are re-interned into the symbol table. Strings and byte-vectors are
    503578'''not''' copied, unless {{FULL}} is given and not {{#f}}.
     
    542617
    543618Sets the global variable named {{SYMBOL}} to the value {{X}}.
    544 
    545 
    546 
    547 === Low-level data access
    548 
    549 
    550 ==== block-ref
    551 
    552  [procedure] (block-ref BLOCK INDEX)
    553 
    554 Returns the contents of the {{INDEX}}th slot of the object {{BLOCK}}. {{BLOCK}}
    555 may be a vector, record structure, pair or symbol.
    556 
    557 
    558 ==== block-set!
    559 
    560  [procedure] (block-set! BLOCK INDEX X)
    561  [procedure] (set! (block-ref BLOCK INDEX) X)
    562 
    563 Sets the contents of the {{INDEX}}th slot of the object {{BLOCK}} to the value
    564 of {{X}}.  {{BLOCK}} may be a vector, record structure, pair or symbol.
    565 
    566 
    567 ==== number-of-bytes
    568 
    569  [procedure] (number-of-bytes BLOCK)
    570 
    571 Returns the number of bytes that the object {{BLOCK}} contains. {{BLOCK}} may
    572 be any non-immediate value.
    573 
    574 
    575 ==== number-of-slots
    576 
    577  [procedure] (number-of-slots BLOCK)
    578 
    579 Returns the number of slots that the object {{BLOCK}} contains.
    580 {{BLOCK}} may be a vector, record structure, pair or symbol.
    581 
    582 
    583 ==== object-copy
    584 
    585  [procedure] (object-copy X)
    586 
    587 Copies {{X}} recursively and returns the fresh copy. Objects allocated in
    588 static memory are copied back into garbage collected storage.
    589 
    590 
    591 ==== move-memory!
    592 
    593  [procedure] (move-memory! FROM TO [BYTES [FROM-OFFSET [TO-OFFSET]])
    594 
    595 Copies {{BYTES}} bytes of memory from {{FROM}} to {{TO}}. {{FROM}} and {{TO}}
    596 may be strings, blobs, SRFI-4 number-vectors (see: @ref{Unit srfi-4}), memory
    597 mapped files, foreign pointers (as obtained from a call to {{foreign-lambda}},
    598 for example), tagged-pointers or locatives. if {{BYTES}} is not given and the
    599 size of the source or destination operand is known then the maximal number of
    600 bytes will be copied. Moving memory to the storage returned by locatives will
    601 cause havoc, if the locative refers to containers of non-immediate data, like
    602 vectors or pairs.
    603 
    604 The additional fourth and fifth argument specify starting offsets (in bytes)
    605 for the source and destination arguments.
    606 
    607 Signals an error if any of the above constraints is violated.
    608619
    609620
     
    773784;;; Replace arbitrary procedure with tracing one:
    774785
    775 (mutate-procedure my-proc 
    776   (lambda (new) 
     786(mutate-procedure my-proc
     787  (lambda (new)
    777788    (lambda args
    778789      (printf "~s called with arguments: ~s~%" new args)
  • chicken/branches/chicken-3/posixunix.scm

    r13134 r13135  
    484484     decompose-pathname ##sys#cons-flonum ##sys#decode-seconds ##sys#null-pointer ##sys#pointer->address
    485485     ##sys#substring ##sys#context-switch close-input-pipe close-output-pipe change-directory
    486      current-directory ##sys#make-pointer port? ##sys#schedule ##sys#process
     486     current-directory ##sys#make-pointer port? ##sys#process
    487487     ##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts
    488488     make-nonblocking-input-port make-nonblocking-output-port
  • chicken/branches/chicken-3/regex.scm

    r13090 r13135  
    3333  (usual-integrations)
    3434  (disable-interrupts)
    35   (generic) ; PCRE options use lotsa bits
     35  (generic)
    3636  (disable-warning var)
    3737  (bound-to-procedure
    38     ;; Imports
    39     get-output-string open-output-string
    40     string->list list->string string-length string-ref substring make-string string-append
    41     reverse list-ref
    42     char=? char-alphabetic? char-numeric? char->integer
    43     set-finalizer!
    44     ##sys#pointer?
    45     ##sys#slot ##sys#setslot ##sys#size
    46     ##sys#make-structure ##sys#structure?
    47     ##sys#error ##sys#signal-hook
    48     ##sys#substring ##sys#fragments->string ##sys#make-c-string ##sys#string-append
    49     ##sys#write-char-0 )
     38   get-output-string open-output-string
     39   string->list list->string string-length string-ref substring make-string string-append
     40   reverse list-ref
     41   char=? char-alphabetic? char-numeric? char->integer
     42   ##sys#size ##sys#error ##sys#fragments->string ##sys#write-char-0 )
    5043  (export
    5144   regexp? regexp
    52     string-match string-match-positions string-search string-search-positions
    53     string-split-fields string-substitute string-substitute*
    54     glob? glob->regexp
    55     grep regexp-escape
    56 
    57     irregex string->irregex sre->irregex irregex? irregex-match-data?
    58     irregex-new-matches irregex-reset-matches!
    59     irregex-match-start irregex-match-end irregex-match-substring
    60     irregex-match-num-submatches
    61     irregex-search irregex-search/matches irregex-match irregex-match-string
    62     irregex-replace irregex-replace/all
    63     irregex-dfa irregex-dfa/search irregex-dfa/extract
    64     irregex-nfa irregex-flags irregex-submatches irregex-lengths irregex-names
    65 
    66     ) )
     45   string-match string-match-positions string-search string-search-positions
     46   string-split-fields string-substitute string-substitute*
     47   glob? glob->regexp
     48   grep regexp-escape
     49   irregex string->irregex sre->irregex irregex? irregex-match-data?
     50   irregex-new-matches irregex-reset-matches!
     51   irregex-match-start irregex-match-end irregex-match-substring
     52   irregex-match-num-submatches
     53   irregex-search irregex-search/matches irregex-match irregex-match-string
     54   irregex-replace irregex-replace/all
     55   irregex-dfa irregex-dfa/search irregex-dfa/extract
     56   irregex-nfa irregex-flags irregex-submatches irregex-lengths irregex-names ) )
    6757
    6858(cond-expand
     
    7666 [unsafe
    7767  (eval-when (compile)
    78     (define-macro (##sys#check-chardef-table . _) '(##core#undefined))
    7968    (define-macro (##sys#check-integer . _) '(##core#undefined))
    8069    (define-macro (##sys#check-blob . _) '(##core#undefined))
     
    8978    (define-macro (##sys#check-exact . _) '(##core#undefined))
    9079    (define-macro (##sys#check-port . _) '(##core#undefined))
    91     (define-macro (##sys#check-number . _) '(##core#undefined))
    92     (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
     80    (define-macro (##sys#check-number . _) '(##core#undefined)) ) ]
    9381 [else
    9482  (declare
  • chicken/branches/chicken-3/runtime.c

    r13127 r13135  
    41474147
    41484148  case C_fix(11):
    4149 #ifdef MACINTOSH_GUI
     4149#if defined(C_NONUNIX) || defined(__CYGWIN__)
     4150    return C_SCHEME_FALSE;
     4151#else
    41504152    return C_SCHEME_TRUE;
    4151 #else
    4152     return C_SCHEME_FALSE;
    41534153#endif
    41544154
     
    42664266    return C_mk_bool(debug_mode);
    42674267
    4268   case C_fix(37):
    4269 #ifdef C_USE_HOST_PCRE
    4270     return C_SCHEME_TRUE;
    4271 #else
     4268  case C_fix(37): /* No PCRE */
    42724269    return C_SCHEME_FALSE;
    4273 #endif
    42744270
    42754271  case C_fix(38):
  • chicken/branches/chicken-3/scheduler.scm

    r13134 r13135  
    3838        ##sys#fdset-input-set ##sys#fdset-output-set ##sys#fdset-clear
    3939        ##sys#fdset-select-timeout ##sys#fdset-restore ##sys#remove-from-timeout-list
    40         ##sys#clear-i/o-state-for-thread!)
     40        ##sys#clear-i/o-state-for-thread!
     41        ##sys#abandon-mutexes )
    4142  (foreign-declare #<<EOF
    4243#ifdef HAVE_ERRNO_H
     
    247248      (##sys#setslot t 11 t2) ) ) )
    248249
     250(define (##sys#abandon-mutexes thread)
     251  (let ([ms (##sys#slot thread 8)])
     252    (unless (null? ms)
     253      (##sys#for-each
     254       (lambda (m)
     255         (##sys#setislot m 2 #f)
     256         (##sys#setislot m 4 #t)
     257         (##sys#setislot m 5 #f)
     258         (##sys#setislot m 3 '()) )
     259       ms) ) ) )
     260
    249261(define (##sys#thread-kill! t s)
    250262  (dbg "killing: " t " -> " s ", recipients: " (##sys#slot t 12))
  • chicken/branches/chicken-3/srfi-18.scm

    r13134 r13135  
    99;
    1010;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
    11 ;     disclaimer. 
     11;     disclaimer.
    1212;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
    13 ;     disclaimer in the documentation and/or other materials provided with the distribution. 
     13;     disclaimer in the documentation and/or other materials provided with the distribution.
    1414;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
    15 ;     products derived from this software without specific prior written permission. 
     15;     products derived from this software without specific prior written permission.
    1616;
    1717; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
     
    3232 (disable-interrupts)
    3333 (usual-integrations)
    34  (hide ##sys#compute-time-limit) )
     34 (hide ##sys#timeout->limit ##sys#sleep-current-thread) )
    3535
    3636(cond-expand
     
    4141    (no-procedure-checks-for-usual-bindings)
    4242    (bound-to-procedure
     43     condition? condition-predicate signal
    4344     ##sys#thread-yield!
    4445     condition-property-accessor ##sys#tty-port? ##sys#thread-block-for-i/o thread-yield! ##sys#thread-unblock!
     
    4849     ##sys#schedule ##sys#make-thread
    4950     ##sys#check-number ##sys#error ##sys#signal-hook ##sys#signal
    50      ##sys#current-exception-handler ##sys#abandon-mutexes ##sys#check-structure ##sys#structure? ##sys#make-mutex
    51      ##sys#delq ##sys#compute-time-limit ##sys#fudge) ) ] )
     51     ##sys#current-exception-handler ##sys#check-structure ##sys#structure? ##sys#make-mutex
     52     ##sys#delq ##sys#timeout->limit ##sys#fudge) ) ] )
    5253
    5354(cond-expand
     
    6364    (define-macro (##sys#check-exact . _) '(##core#undefined))
    6465    (define-macro (##sys#check-port . _) '(##core#undefined))
    65     (define-macro (##sys#check-number . _) '(##core#undefined))
    66     (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
     66    (define-macro (##sys#check-number . _) '(##core#undefined)) ) ]
    6767 [else
    6868  (declare (emit-exports "srfi-18.exports"))] )
     
    7575
    7676
    77 ;;; Helper routines:
    78 
    79 (define ##sys#compute-time-limit
    80   (let ([truncate truncate])
    81     (lambda (tm)
    82       (and tm
    83            (cond [(##sys#structure? tm 'time) (##sys#slot tm 1)]
    84                  [(number? tm) (fx+ (##sys#fudge 16) (inexact->exact (truncate (* tm 1000))))]
    85                  [else (##sys#signal-hook #:type-error "invalid timeout argument" tm)] ) ) ) ) )
     77;;; Helpers
     78
     79(define-inline (%append-item ls x)
     80  (##sys#append ls (list x)) )
     81
     82
     83;;; Time object helpers:
     84
     85;; Time layout:
     86;
     87; Clock time is since Unix-epoch (Jan 1, 1970 00:00 am) since C Library routines are used.
     88;
     89; 0     Tag - 'time (symbol)
     90; 1     Milliseconds since startup (fixnum)
     91; 2     Seconds (integer)
     92; 3     Milliseconds (fixnum)
     93
     94(define-inline (%time? x)
     95  (##sys#structure? x 'time) )
     96
     97(define-inline (%time-timeout tm)
     98  (##sys#slot tm 1) )
     99
     100(define-inline (%time-seconds tm)
     101  (##sys#slot tm 2) )
     102
     103(define-inline (%time-milliseconds tm)
     104  (##sys#slot tm 3) )
     105
     106(define-inline (%check-time x loc)
     107  (##sys#check-structure x 'time loc) )
     108
     109; Enforces the representation constraints
     110(define-inline (%make-time nms s ms)
     111  (##sys#make-structure 'time
     112   (inexact->exact (truncate nms))
     113   (truncate s)
     114   (inexact->exact (truncate ms))) )
     115
     116
     117;;; Thread object helpers:
     118
     119;; Thread layout:
     120;
     121; 0     Tag - 'thread
     122; 1     Thunk (procedure)
     123; 2     Results (list)
     124; 3     State (symbol)
     125; 4     Block-timeout
     126; 5     State buffer (vector)
     127;       0       Dynamic winds (list)
     128;       1       Standard input (port)
     129;       2       Standard output (port)
     130;       3       Standard error (port)
     131;       4       Exception handler (procedure)
     132;       5       Parameters (vector)
     133; 6     Name (object)
     134; 7     Reason (condition)
     135; 8     Mutexes (set as list)
     136; 9     Quantum (fixnum)
     137; 10    Specific (object)
     138; 11    Block object (type depends on blocking type)
     139; 12    Recipients (currently unused)
     140; 13    Unblocked by timeout? (boolean)
     141
     142#; ;UNUSED
     143(define-inline (%thread? x)
     144  (##sys#structure? x 'thread) )
     145
     146(define-inline (%thread-thunk th)
     147  (##sys#slot th 1) )
     148
     149(define-inline (%thread-thunk-set! th tk)
     150  (##sys#setslot th 1 tk) )
     151
     152(define-inline (%thread-results th)
     153  (##sys#slot th 2) )
     154
     155(define-inline (%thread-results-set! th rs)
     156  (##sys#setslot th 2 rs) )
     157
     158(define-inline (%thread-state th)
     159  (##sys#slot th 3) )
     160
     161(define-inline (%thread-state-set! th st)
     162  (##sys#setslot th 3 st) )
     163
     164(define-inline (%thread-block-timeout th)
     165  (##sys#slot th 4) )
     166
     167#; ;UNUSED
     168(define-inline (%thread-state-buffer th)
     169  (##sys#slot th 5) )
     170
     171(define-inline (%thread-name th)
     172  (##sys#slot th 6) )
     173
     174(define-inline (%thread-reason th)
     175  (##sys#slot th 7) )
     176
     177(define-inline (%thread-reason-set! th cd)
     178  (##sys#setslot th 7 cd) )
     179
     180(define-inline (%thread-mutexes th)
     181  (##sys#slot th 8) )
     182
     183(define-inline (%thread-mutexes-set! th wt)
     184  (##sys#setslot th 8 wx) )
     185
     186(define-inline (%thread-mutexes-add! th mx)
     187  (%thread-mutexes-set! th (cons mx (%thread-mutexes th))) )
     188
     189(define-inline (%thread-mutexes-delete! th mx)
     190  (%thread-mutexes-set! th (##sys#delq mx (%thread-mutexes th))) )
     191
     192(define-inline (%thread-quantum th)
     193  (##sys#slot th 9) )
     194
     195(define-inline (%thread-quantum-set! th qt)
     196  (##sys#setislot th 9 qt) )
     197
     198(define-inline (%thread-specific th)
     199  (##sys#slot th 10) )
     200
     201(define-inline (%thread-specific-set! th x)
     202  (##sys#setslot th 10 x) )
     203
     204#; ;UNUSED
     205(define-inline (%thread-block-object th)
     206  (##sys#slot th 11) )
     207
     208#; ;UNUSED
     209(define-inline (%thread-recipients th)
     210  (##sys#slot th 12) )
     211
     212#; ;UNUSED
     213(define-inline (%thread-unblocked-by-timeout? th)
     214  (##sys#slot th 13) )
     215
     216(define-inline (%make-thread nm tk #!optional (qt (%thread-quantum ##sys#current-thread)))
     217  (##sys#make-thread tk 'created nm qt) )
     218
     219(define-inline (%check-thread x loc)
     220  (##sys#check-structure x 'thread loc) )
     221
     222
     223;;; Mutex object helpers:
     224
     225;; Mutex layout:
     226;
     227; 0     Tag - 'mutex
     228; 1     Name (object)
     229; 2     Thread (thread or #f)
     230; 3     Waiting threads (FIFO list)
     231; 4     Abandoned? (boolean)
     232; 5     Locked? (boolean)
     233; 6     Specific (object)
     234
     235(define-inline (%mutex? x)
     236  (##sys#structure? x 'mutex) )
     237
     238(define-inline (%mutex-name mx)
     239  (##sys#slot mx 1) )
     240
     241(define-inline (%mutex-thread mx)
     242  (##sys#slot mx 2) )
     243
     244(define-inline (%mutex-thread-set! mx th)
     245  (##sys#setslot mx 2 th) )
     246
     247(define-inline (%mutex-thread-clear! mx)
     248  (##sys#setislot mx 2 #f) )
     249
     250(define-inline (%mutex-waiters mx)
     251  (##sys#slot mx 3) )
     252
     253(define-inline (%mutex-waiters-set! mx wt)
     254  (##sys#setslot mx 3 wt) )
     255
     256(define-inline (%mutex-waiters-add! mx th)
     257  (%mutex-waiters-set! mx (%append-item (%mutex-waiters mx) th)) )
     258
     259(define-inline (%mutex-waiters-delete! mx th)
     260  (%mutex-waiters-set! mx (##sys#delq th (%mutex-waiters mx))) )
     261
     262(define-inline (%mutex-waiters-empty? mx)
     263  (null? (%mutex-waiters mx)) )
     264
     265(define-inline (%mutex-waiters-pop! mx)
     266  (let* ([wt (%mutex-waiters mx)]
     267         [top (car wt)])
     268    (%mutex-waiters-set! mx (cdr wt))
     269    top ) )
     270
     271(define-inline (%mutex-abandoned? mx)
     272  (##sys#slot mx 4) )
     273
     274(define-inline (%mutex-abandoned-set! mx f)
     275  (##sys#setislot mx 4 f) )
     276
     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
     283(define-inline (%mutex-locked? mx)
     284  (##sys#slot mx 5) )
     285
     286(define-inline (%mutex-locked-set! mx f)
     287  (##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) )
     294
     295(define-inline (%mutex-specific mx)
     296  (##sys#slot mx 6) )
     297
     298(define-inline (%mutex-specific-set! mx x)
     299  (##sys#setslot mx 6 x) )
     300
     301(define-inline (%make-mutex id)
     302  (##sys#make-mutex id ##sys#current-thread) )
     303
     304(define-inline (%check-mutex x loc)
     305  (##sys#check-structure x 'mutex loc) )
     306
     307
     308;;; Condition-variable object:
     309
     310;; Condition-variable layout:
     311;
     312; 0     Tag - 'condition-variable
     313; 1     Name (object)
     314; 2     Waiting threads (FIFO list)
     315; 3     Specific (object)
     316
     317(define-inline (%condition-variable? x)
     318  (##sys#structure? x 'condition-variable) )
     319
     320(define-inline (%condition-variable-name cv)
     321  (##sys#slot cv 1) )
     322
     323(define-inline (%condition-variable-waiters cv)
     324  (##sys#slot cv 2) )
     325
     326(define-inline (%condition-variable-waiters-set! cv x)
     327  (##sys#setslot cv 2 x) )
     328
     329(define-inline (%condition-variable-waiters-add! cv th)
     330  (%condition-variable-waiters-set! cv (%append-item (%condition-variable-waiters cv) th)) )
     331
     332(define-inline (%condition-variable-waiters-delete! cv th)
     333  (%condition-variable-waiters-set! cv (##sys#delq th (%condition-variable-waiters cv))) )
     334
     335(define-inline (%condition-variable-waiters-empty? mx)
     336  (null? (%condition-variable-waiters mx)) )
     337
     338(define-inline (%condition-variable-waiters-pop! mx)
     339  (let* ([wt (%condition-variable-waiters mx)]
     340         [top (car wt)])
     341    (%condition-variable-waiters-set! mx (cdr wt))
     342    top ) )
     343
     344(define-inline (%condition-variable-waiters-clear! cv)
     345  (##sys#setislot cv 2 '()) )
     346
     347(define-inline (%condition-variable-specific cv)
     348  (##sys#slot cv 3) )
     349
     350(define-inline (%condition-variable-specific-set! cv x)
     351  (##sys#setslot cv 3 x) )
     352
     353(define-inline (%make-condition-variable nm #!optional (wt '()) (sp (void)))
     354  (##sys#make-structure 'condition-variable nm wt sp) )
     355
     356(define-inline (%check-condition-variable x loc)
     357    (##sys#check-structure x 'condition-variable loc) )
    86358
    87359
    88360;;; Time objects:
    89361
    90 (declare
    91   (foreign-declare #<<EOF
     362#>
    92363static C_TLS long C_ms;
    93364#define C_get_seconds   C_seconds(&C_ms)
    94 EOF
    95 ) )
    96 
     365<#
     366
     367(define-foreign-variable C_startup_time_seconds double)
    97368(define-foreign-variable C_get_seconds double)
    98 (define-foreign-variable C_startup_time_seconds double)
    99369(define-foreign-variable C_ms long)
     370
     371(define-inline (%seconds-since-startup s)
     372  (max 0 (- s C_startup_time_seconds)) )
     373
     374(define-inline (%seconds-after-startup s)
     375  (max 0 (+ s C_startup_time_seconds)) )
     376
     377(define-inline (%seconds->milliseconds s)
     378  (* (##sys#flonum-fraction (##sys#exact->inexact s)) 1000) )
     379
     380(define-inline (%milliseconds->seconds ms)
     381  (/ ms 1000) )
     382
     383(define-inline (%milliseconds-since-startup s)
     384  (%seconds->milliseconds (%seconds-since-startup s)) )
     385
     386(define ##sys#timeout->limit
     387  (let ([truncate truncate])
     388    (lambda (tm loc)
     389      (and tm
     390           (cond [(%time? tm)
     391                  (%time-timeout tm) ]
     392                 [(number? tm)
     393                  (fx+ (##sys#fudge 16)
     394                       (inexact->exact (truncate (%seconds->milliseconds tm)))) ]
     395                 [else
     396                  (##sys#signal-hook
     397                   #:type-error loc "bad argument type - invalid timeout object" tm) ] ) ) ) ) )
    100398
    101399(define (current-time)
    102400  (let* ([s C_get_seconds]
    103          [ss C_startup_time_seconds]
    104          [ms C_ms] )
    105     (##sys#make-structure
    106      'time
    107      (inexact->exact (truncate (+ (* (- s ss) 1000) C_ms)))
    108      s
    109      C_ms) ) )
     401         [ms C_ms])
     402    (%make-time (+ (%milliseconds-since-startup s) ms) s ms) ) )
     403
     404(define (time->seconds tm)
     405  (%check-time tm 'time->seconds)
     406  (+ (%time-seconds tm) (%milliseconds->seconds (%time-milliseconds tm))) )
     407
     408(define (seconds->time s)
     409  (##sys#check-number s 'seconds->time)
     410  (let ([ms (%seconds->milliseconds s)]) ; milliseconds since startup
     411    (%make-time (+ (%milliseconds-since-startup s) ms) s ms) ) )
     412
     413(define (time->milliseconds tm)
     414  (%check-time tm 'time->milliseconds)
     415  (+ (%milliseconds-since-startup (%time-seconds tm)) (%time-milliseconds tm)) )
     416
     417(define (milliseconds->time nms)
     418  (##sys#check-integer nms 'milliseconds->time)
     419  (let ([s (%milliseconds->seconds nms)])
     420    (%make-time nms (%seconds-after-startup s) (%seconds->milliseconds s)) ) )
     421
     422(define (time? x) (%time? x))
     423
     424;; For SRFI-19 identifier conflict
    110425
    111426(define srfi-18:current-time current-time)
    112 
    113 (define (time->seconds tm)
    114   (##sys#check-structure tm 'time 'time->seconds)
    115   (+ (##sys#slot tm 2) (/ (##sys#slot tm 3) 1000)) )
    116 
    117 (define (time->milliseconds tm)
    118   (##sys#check-structure tm 'time 'time->milliseconds)
    119   (+ (inexact->exact (* (- (##sys#slot tm 2) C_startup_time_seconds) 1000))
    120      (##sys#slot tm 3) ) )
    121 
    122 (define (seconds->time n)
    123   (##sys#check-number n 'seconds->time)
    124   (let* ([n2 (max 0 (- n C_startup_time_seconds))] ; seconds since startup
    125          [ms (truncate (* 1000 (##sys#flonum-fraction (##sys#exact->inexact n))))] ; milliseconds
    126          [n3 (inexact->exact (truncate (+ (* n2 1000) ms)))] ) ; milliseconds since startup
    127     (##sys#make-structure 'time n3 (truncate n) (inexact->exact ms)) ) )
    128 
    129 (define (milliseconds->time nms)
    130   (##sys#check-exact nms 'milliseconds->time)
    131   (let ((s (+ C_startup_time_seconds (/ nms 1000))))
    132     (##sys#make-structure 'time nms s 0) ) )
    133 
    134 (define (time? x) (##sys#structure? x 'time))
    135 
    136427(define srfi-18:time? time?)
    137428
     
    139430;;; Exception handling:
    140431
    141 (define raise ##sys#signal)
    142 
    143 (define (join-timeout-exception? x)
    144   (and (##sys#structure? x 'condition)
    145        (memq 'join-timeout-exception (##sys#slot x 1)) ) )
    146 
    147 (define (abandoned-mutex-exception? x)
    148   (and (##sys#structure? x 'condition)
    149        (memq 'abandoned-mutex-exception (##sys#slot x 1)) ) )
    150 
    151 (define (terminated-thread-exception? x)
    152   (and (##sys#structure? x 'condition)
    153        (memq 'terminated-thread-exception (##sys#slot x 1)) ) )
    154 
    155 (define (uncaught-exception? x)
    156   (and (##sys#structure? x 'condition)
    157        (memq 'uncaught-exception (##sys#slot x 1)) ) )
    158 
    159 (define uncaught-exception-reason
    160   (condition-property-accessor 'uncaught-exception 'reason) )
     432(define raise signal)
     433
     434(define join-timeout-exception? (condition-predicate 'join-timeout-exception))
     435
     436(define abandoned-mutex-exception? (condition-predicate 'join-timeout-exception))
     437
     438(define terminated-thread-exception? (condition-predicate 'terminated-thread-exception))
     439
     440(define uncaught-exception? (condition-predicate 'uncaught-exception))
     441
     442(define uncaught-exception-reason (condition-property-accessor 'uncaught-exception 'reason))
    161443
    162444
    163445;;; Threads:
    164446
    165 (define make-thread
    166   (let ((gensym gensym))
    167     (lambda (thunk . name)
    168       (let ((thread
    169              (##sys#make-thread
    170               #f
    171               'created
    172               (if (pair? name) (##sys#slot name 0) (gensym 'thread))
    173               (##sys#slot ##sys#current-thread 9) ) ) )
    174         (##sys#setslot
    175          thread 1
    176          (lambda ()
    177            (##sys#call-with-values
    178             thunk
    179             (lambda results
    180               (##sys#setslot thread 2 results)
    181               (##sys#thread-kill! thread 'dead)
    182               (##sys#schedule) ) ) ) )
    183         thread) ) ) )
    184 
    185 (define (thread? x) (##sys#structure? x 'thread))
     447(define make-thread)
     448(let ([gensym gensym])
     449  (set! make-thread
     450    (lambda (thunk #!optional (name (gensym 'thread)))
     451      (##sys#check-closure thunk 'make-thread)
     452      (%make-thread
     453       name
     454       (lambda ()
     455         (##sys#call-with-values
     456          thunk
     457          (lambda results
     458            (%thread-results-set! thread results)
     459            (##sys#thread-kill! thread 'dead)
     460            (##sys#schedule))))))) )
     461
     462(define (thread? x) (%thread x))
     463
    186464(define (current-thread) ##sys#current-thread)
    187465
    188466(define (thread-state thread)
    189   (##sys#check-structure thread 'thread 'thread-state)
    190   (##sys#slot thread 3) )
     467  (%check-thread thread 'thread-state)
     468  (%thread-state thread) )
    191469
    192470(define (thread-specific thread)
    193   (##sys#check-structure thread 'thread 'thread-specific)
    194   (##sys#slot thread 10) )
     471  (%check-thread thread 'thread-specific)
     472  (%thread-specific thread) )
    195473
    196474(define (thread-specific-set! thread x)
    197   (##sys#check-structure thread 'thread 'thread-specific-set!)
    198   (##sys#setslot thread 10 x) )
     475  (%check-thread thread 'thread-specific-set!)
     476  (%thread-specific-set! thread x) )
    199477
    200478(define (thread-quantum thread)
    201   (##sys#check-structure thread 'thread 'thread-quantum)
    202   (##sys#slot thread 9) )
     479  (%check-thread thread 'thread-quantum)
     480  (%thread-quantum thread) )
    203481
    204482(define (thread-quantum-set! thread q)
    205   (##sys#check-structure thread 'thread 'thread-quantum-set!)
     483  (%check-thread thread 'thread-quantum-set!)
    206484  (##sys#check-exact q 'thread-quantum-set!)
    207   (##sys#setislot thread 9 (fxmax q 10)) )
     485  (%thread-quantum-set! thread (fxmax q 10)) )
    208486
    209487(define (thread-name x)
    210   (##sys#check-structure x 'thread 'thread-name)
    211   (##sys#slot x 6) )
     488  (%check-thread x 'thread-name)
     489  (%thread-name x) )
    212490
    213491(define thread-start!
     
    216494      (if (procedure? thread)
    217495          (set! thread (make-thread thread))
    218           (##sys#check-structure thread 'thread 'thread-start!) )
    219       (unless (eq? 'created (##sys#slot thread 3))
    220         (##sys#error 'thread-start! "thread can not be started a second time" thread) )
    221       (##sys#setslot thread 3 'ready)
    222       (##sys#add-to-ready-queue thread) 
    223       thread) ) )
     496          (%check-thread thread 'thread-start!) )
     497      (unless (eq? 'created (%thread-state thread))
     498        (##sys#error 'thread-start! "thread already started" thread) )
     499      (%thread-state-set! thread 'ready)
     500      (##sys#add-to-ready-queue thread)
     501      thread ) ) )
    224502
    225503(define thread-yield! ##sys#thread-yield!) ;In library.scm
    226504
    227 (define thread-join!
    228   (lambda (thread . timeout)
    229     (##sys#check-structure thread 'thread 'thread-join!)
    230     (let* ((limit (and (pair? timeout) (##sys#compute-time-limit (##sys#slot timeout 0))))
    231            (rest (and (pair? timeout) (##sys#slot timeout 1)))
    232            (tosupplied (and rest (pair? rest)))
    233            (toval (and tosupplied (##sys#slot rest 0))) )
    234       (##sys#call-with-current-continuation
    235        (lambda (return)
    236          (let ([ct ##sys#current-thread])
    237            (when limit (##sys#thread-block-for-timeout! ct limit))
    238            (##sys#setslot
    239             ct 1
    240             (lambda ()
    241               (case (##sys#slot thread 3)
    242                 [(dead) (apply return (##sys#slot thread 2))]
    243                 [(terminated)
    244                  (return
    245                   (##sys#signal
    246                    (##sys#make-structure
    247                     'condition '(uncaught-exception)
    248                     (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) ]
    249                 [else
    250                  (return
    251                   (if tosupplied
    252                       toval
    253                       (##sys#signal
    254                        (##sys#make-structure 'condition '(join-timeout-exception) '())) ) ) ] ) ) )
    255            (##sys#thread-block-for-termination! ct thread)
    256            (##sys#schedule) ) ) ) ) ) )
    257            
    258 (define (thread-terminate! thread)
    259   (##sys#check-structure thread 'thread 'thread-terminate!)
    260   (when (eq? thread ##sys#primordial-thread)
    261     ((##sys#exit-handler)) )
    262   (##sys#setslot thread 2 (list (void)))
    263   (##sys#setslot thread 7 (##sys#make-structure 'condition '(terminated-thread-exception) '()))
    264   (##sys#thread-kill! thread 'terminated)
    265   (when (eq? thread ##sys#current-thread) (##sys#schedule)) )
    266 
    267 (define (thread-suspend! thread)
    268   (##sys#check-structure thread 'thread 'thread-suspend!)
    269   (##sys#setslot thread 3 'suspended)
    270   (when (eq? thread ##sys#current-thread)
     505(define (thread-join! thread #!optional timeout timeout-val)
     506  (%check-thread thread 'thread-join!)
     507  (let* ([limit (and timeout (##sys#timeout->limit timeout 'thread-join!))])
    271508    (##sys#call-with-current-continuation
    272509     (lambda (return)
    273        (##sys#setslot thread 1 (lambda () (return (void))))
    274        (##sys#schedule) ) ) ) )
    275 
    276 (define (thread-resume! thread)
    277   (##sys#check-structure thread 'thread 'thread-resume!)
    278   (when (eq? (##sys#slot thread 3) 'suspended)
    279     (##sys#setslot thread 3 'ready)
    280     (##sys#add-to-ready-queue thread) ) )
    281 
    282 (define (thread-sleep! tm)
    283   (define (sleep limit loc)
     510       (let ([ct ##sys#current-thread])
     511         (when limit (##sys#thread-block-for-timeout! ct limit))
     512         (%thread-thunk-set! ct
     513          (lambda ()
     514            (case (%thread-state thread)
     515              [(dead)
     516               (apply return (%thread-results thread))]
     517              [(terminated)
     518               (return
     519                (signal
     520                 (make-property-condition 'uncaught-exception 'reason (%thread-reason thread)))) ]
     521              [else
     522               (return
     523                (or timeout-val
     524                    (signal (make-property-condition 'join-timeout-exception)))) ] ) ) )
     525         (##sys#thread-block-for-termination! ct thread)
     526         (##sys#schedule) ) ) ) ) )
     527
     528(define (thread-terminate! thread)
     529  (%check-thread thread 'thread-terminate!)
     530  (when (eq? ##sys#primordial-thread thread) ((##sys#exit-handler)) )
     531  (%thread-results-set! thread (list (void)))
     532  (%thread-reason-set! thread (make-property-condition 'terminated-thread-exception))
     533  (##sys#thread-kill! thread 'terminated)
     534  (when (eq? ##sys#current-thread thread) (##sys#schedule)) )
     535
     536(define (thread-suspend! thread)
     537  (%check-thread thread 'thread-suspend!)
     538  (%thread-state-set! thread 'suspended)
     539  (when (eq? ##sys#current-thread thread)
    284540    (##sys#call-with-current-continuation
    285541     (lambda (return)
    286        (let ((ct ##sys#current-thread))
    287          (##sys#setslot ct 1 (lambda () (return (void))))
    288          (##sys#thread-block-for-timeout! ct limit)
    289          (##sys#schedule) ) ) ) )
    290   (unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout argument" tm))
    291   (sleep (##sys#compute-time-limit tm) 'thread-sleep!) )
     542       (%thread-thunk-set! thread (lambda () (return (void))))
     543       (##sys#schedule) ) ) ) )
     544
     545(define (thread-resume! thread)
     546  (%check-thread thread 'thread-resume!)
     547  (when (eq? 'suspended (%thread-state thread))
     548    (%thread-state-set! thread 'ready)
     549    (##sys#add-to-ready-queue thread) ) )
     550
     551(define (##sys#sleep-current-thread limit)
     552  (##sys#call-with-current-continuation
     553   (lambda (return)
     554     (let ([ct ##sys#current-thread])
     555       (%thread-thunk-set! ct (lambda () (return (void))))
     556       (##sys#thread-block-for-timeout! ct limit)
     557       (##sys#schedule) ) ) ) )
     558
     559(define (thread-sleep! timeout)
     560  (##sys#sleep-current-thread (##sys#timeout->limit timeout 'thread-sleep!)) )
     561
     562
     563;;; Change continuation of thread to signal an exception:
     564
     565(define (thread-signal! thread exn)
     566  (%check-thread thread 'thread-signal!)
     567  (if (eq? ##sys#current-thread thread)
     568      (signal exn)
     569      (let ([old (%thread-thunk thread)])
     570        (%thread-thunk-set! thread (lambda () (signal exn) (old)))
     571        (##sys#thread-unblock! thread) ) ) )
     572
     573
     574;;; Waiting for I/O on file-descriptor
     575
     576(define (thread-wait-for-i/o! fd #!optional (mode #:all))
     577  (##sys#check-exact fd 'thread-wait-for-i/o!)
     578  (##sys#thread-block-for-i/o! ##sys#current-thread fd mode)
     579  (thread-yield!) )
    292580
    293581
    294582;;; Mutexes:
    295583
    296 (define (mutex? x) (##sys#structure? x 'mutex))
    297 
    298 (define make-mutex
    299   (let ((gensym gensym))
    300     (lambda id
    301       (let* ((id (if (pair? id) (car id) (gensym 'mutex)))
    302              (m (##sys#make-mutex id ##sys#current-thread)) )
    303         m) ) ) )
    304 
    305 (define (mutex-name x)
    306   (##sys#check-structure x 'mutex 'mutex-name)
    307   (##sys#slot x 1) )
     584(define make-mutex)
     585(let ([gensym gensym])
     586  (set! make-mutex
     587    (lambda (#!optional (id (gensym 'mutex)))
     588      (%make-mutex id) ) ) )
     589
     590(define (mutex? x) (%mutex x))
     591
     592(define (mutex-name mutex)
     593  (%check-mutex mutex 'mutex-specific)
     594  (%mutex-name mutex) )
    308595
    309596(define (mutex-specific mutex)
    310   (##sys#check-structure mutex 'mutex 'mutex-specific)
    311   (##sys#slot mutex 6) )
     597  (%check-mutex mutex 'mutex-specific)
     598  (%mutex-specific mutex) )
    312599
    313600(define (mutex-specific-set! mutex x)
    314   (##sys#check-structure mutex 'mutex 'mutex-specific-set!)
    315   (##sys#setslot mutex 6 x) )
     601  (%check-mutex mutex 'mutex-specific-set!)
     602  (%mutex-specific-set! mutex x) )
    316603
    317604(define (mutex-state mutex)
    318   (##sys#check-structure mutex 'mutex 'mutex-state)
    319   (cond [(##sys#slot mutex 5) (or (##sys#slot mutex 2) 'not-owned)]
    320         [(##sys#slot mutex 4) 'abandoned]
    321         [else 'not-abandoned] ) )
    322 
    323 (define mutex-lock!
    324   (lambda (mutex . ms-and-t)
    325     (##sys#check-structure mutex 'mutex 'mutex-lock!)
    326     (let* ([limitsup (pair? ms-and-t)]
    327            [limit (and limitsup (##sys#compute-time-limit (car ms-and-t)))]
    328            [threadsup (fx> (length ms-and-t) 1)]
    329            [thread (and threadsup (cadr ms-and-t))]
    330            [abd (##sys#slot mutex 4)] )
    331       (when thread (##sys#check-structure thread 'thread 'mutex-lock!))
    332       (##sys#call-with-current-continuation
    333        (lambda (return)
    334          (let ([ct ##sys#current-thread])
    335            (define (switch)
    336              (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
    337              (##sys#schedule) )
    338            (define (check)
    339              (when abd
    340                (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
    341            (dbg ct ": locking " mutex)
    342            (cond [(not (##sys#slot mutex 5))
    343                   (if (and threadsup (not thread))
    344                       (begin
    345                         (##sys#setislot mutex 2 #f)
    346                         (##sys#setislot mutex 5 #t) )
    347                       (let* ([t (or thread ct)]
    348                              [ts (##sys#slot t 3)] )
    349                         (if (or (eq? 'terminated ts) (eq? 'dead ts))
    350                             (##sys#setislot mutex 4 #t)
    351                             (begin
    352                               (##sys#setislot mutex 5 #t)
    353                               (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))
    354                               (##sys#setslot mutex 2 t) ) ) ) )
    355                   (check)
    356                   (return #t) ]
    357                  [limit
    358                   (check)
    359                   (##sys#setslot
    360                    ct 1
    361                    (lambda ()
    362                      (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
    363                      (##sys#setslot ##sys#current-thread 8 (cons mutex (##sys#slot ##sys#current-thread 8)))
    364                      (##sys#setslot mutex 2 thread)
    365                      #f) )
    366                   (##sys#thread-block-for-timeout! ct limit)
    367                   (switch) ]
    368                  [else
    369                   (##sys#setslot ct 3 'sleeping)
    370                   (##sys#setslot ct 1 (lambda () (return #t)))
    371                   (switch) ] ) ) ) ) ) ) )
    372 
    373 (define mutex-unlock!
    374   (lambda (mutex . cvar-and-to)
    375     (##sys#check-structure mutex 'mutex 'mutex-unlock!)
    376     (let ([ct ##sys#current-thread]
    377           [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
    378           [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
    379       (dbg ct ": unlocking " mutex)
    380       (when cvar (##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
    381       (##sys#call-with-current-continuation
    382        (lambda (return)
    383          (let ([waiting (##sys#slot mutex 3)]
    384                [limit (and timeout (##sys#compute-time-limit timeout))]
    385                [result #t] )
    386            (##sys#setislot mutex 4 #f)
    387            (##sys#setislot mutex 5 #f)
    388            (##sys#setslot ct 8 (##sys#delq mutex (##sys#slot ct 8)))
    389            (##sys#setslot ct 1 (lambda () (return result)))
    390            (when cvar
    391              (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
    392              (cond [limit
    393                     (##sys#setslot
    394                      ct 1
    395                      (lambda ()
    396                        (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))
    397                        (return #f) ) )
    398                     (##sys#thread-block-for-timeout! ct limit) ]
    399                    [else
    400                     (##sys#setslot ct 3 'sleeping)] ) )
    401            (unless (null? waiting)
    402              (let* ([wt (##sys#slot waiting 0)]
    403                     [wts (##sys#slot wt 3)] )
    404                (##sys#setslot mutex 3 (##sys#slot waiting 1))
    405                (##sys#setislot mutex 5 #t)
    406                (when (or (eq? wts 'blocked) (eq? wts 'sleeping))
    407                  (##sys#setslot mutex 2 wt)
    408                  (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))
    409                  (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) )
    410            (##sys#schedule) ) ) ) ) ) )
     605  (%check-mutex mutex 'mutex-state)
     606  (cond [(%mutex-locked? mutex)    (or (%mutex-thread mutex) 'not-owned)]
     607        [(%mutex-abandoned? mutex) 'abandoned]
     608        [else                      'not-abandoned] ) )
     609
     610(define (mutex-lock! mutex #!optional timeout (thread (void)))
     611  (%check-mutex mutex 'mutex-lock!)
     612  (let* ([limit (and timeout (##sys#timeout->limit timeout 'mutex-lock!))]
     613         [threadsup (not (eq? (void) thread))]
     614         [thread (and threadsup thread)]
     615         [abd (%mutex-abandoned? mutex)] )
     616    (when thread (%check-thread thread 'mutex-lock!))
     617    (##sys#call-with-current-continuation
     618     (lambda (return)
     619       (let ([ct ##sys#current-thread])
     620         (define (switch)
     621           (%mutex-waiters-add! mutex ct)
     622           (##sys#schedule) )
     623         (define (check)
     624           (when abd
     625             (return (signal (make-property-condition 'abandoned-mutex-exception))) ) )
     626         (dbg ct ": locking " mutex)
     627         (cond [(not (%mutex-locked? mutex))
     628                (if (and threadsup (not thread))
     629                    (begin
     630                      (%mutex-thread-clear! mutex)
     631                      (%mutex-locked! mutex) )
     632                    (let* ([th (or thread ct)]
     633                           [ts (%thread-state th)] )
     634                      (if (or (eq?'terminated ts) (eq? 'dead ts))
     635                          (%mutex-abandoned! mutex)
     636                          (begin
     637                            (%mutex-locked! mutex)
     638                            (%thread-mutexes-add! th mutex)
     639                            (%mutex-thread-set! mutex th) ) ) ) )
     640                (check)
     641                (return #t) ]
     642               [limit
     643                (check)
     644                (%thread-thunk-set! ct
     645                 (lambda ()
     646                   (%mutex-waiters-delete! mutex ct)
     647                   (%thread-mutexes-add! ##sys#current-thread mutex)
     648                   (%mutex-thread-set! mutex thread)
     649                   #f))
     650                (##sys#thread-block-for-timeout! ct limit)
     651                (switch) ]
     652               [else
     653                (%thread-state-set! ct 'sleeping)
     654                (%thread-thunk-set! ct (lambda () (return #t)))
     655                (switch) ] ) ) ) ) ) )
     656
     657(define (mutex-unlock! mutex #!optional cv timeout)
     658  (%check-mutex mutex 'mutex-unlock!)
     659  (let ([ct ##sys#current-thread])
     660    (dbg ct ": unlocking " mutex)
     661    (##sys#call-with-current-continuation
     662     (lambda (return)
     663       (let ([limit (and timeout (##sys#timeout->limit timeout 'mutex-unlock!))]
     664             [result #t] )
     665         (%mutex-not-abandoned! mutex)
     666         (%mutex-not-locked! mutex)
     667         (%thread-mutexes-delete! ct mutex)
     668         (%thread-thunk-set! ct (lambda () (return result)))
     669         (when cv
     670           (%check-condition-variable cv 'mutex-unlock!)
     671           (%condition-variable-waiters-add! cv ct)
     672           (cond [limit
     673                  (%thread-thunk-set! ct
     674                   (lambda ()
     675                     (%condition-variable-waiters-delete! cv ct)
     676                     (return #f)))
     677                  (##sys#thread-block-for-timeout! ct limit) ]
     678                 [else
     679                  (%thread-state-set! ct 'sleeping) ] ) )
     680         (unless (%mutex-waiters-empty? mutex)
     681           (let* ([wt (%mutex-waiters-pop! mutex)]
     682                  [wts (%thread-state wt)] )
     683             (%mutex-locked! mutex)
     684             (when (or (eq? 'blocked wts) (eq? 'sleeping wts))
     685               (%mutex-thread-set! mutex wt)
     686               (%thread-mutexes-add! wt mutex)
     687               (when (eq? 'sleeping wts) (##sys#add-to-ready-queue wt) ) ) ) )
     688         (##sys#schedule) ) ) ) ) )
    411689
    412690
    413691;;; Condition variables:
    414692
    415 (define make-condition-variable
    416   (let ([gensym gensym])
    417     (lambda name
    418       (##sys#make-structure
    419        'condition-variable
    420        (if (pair? name)                 ; #1 name
    421            (car name)
    422            (gensym 'condition-variable) )
    423        '()                              ; #2 list of waiting threads
    424        (void) ) ) ) )                   ; #3 specific
    425 
    426 (define (condition-variable? x)
    427   (##sys#structure? x 'condition-variable) )
     693(define make-condition-variable)
     694(let ([gensym gensym])
     695  (set! make-condition-variable
     696    (lambda (#!optional (name (gensym 'condition-variable)))
     697      (%make-condition-variable name))) )
     698
     699(define (condition-variable? x) (%condition-variable? x) )
     700
     701(define (condition-variable-name cv)
     702  (%check-condition-variable cv 'condition-variable-name)
     703  (%condition-variable-name cv) )
    428704
    429705(define (condition-variable-specific cv)
    430   (##sys#check-structure cv 'condition-variable 'condition-variable-specific)
    431   (##sys#slot cv 3) )
     706  (%check-condition-variable cv 'condition-variable-specific)
     707  (%condition-variable-specific cv) )
    432708
    433709(define (condition-variable-specific-set! cv x)
    434   (##sys#check-structure cv 'condition-variable 'condition-variable-specific-set!)
    435   (##sys#setslot cv 3 x) )
    436 
    437 (define (condition-variable-signal! cvar)
    438   (##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
    439   (dbg "signalling " cvar)
    440   (let ([ts (##sys#slot cvar 2)])
    441     (unless (null? ts)
    442       (let* ([t0 (##sys#slot ts 0)]
    443              [t0s (##sys#slot t0 3)] )
    444         (##sys#setslot cvar 2 (##sys#slot ts 1))
    445         (when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
    446           (##sys#thread-basic-unblock! t0) ) ) ) ) )
    447 
    448 (define (condition-variable-broadcast! cvar)
    449   (##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!)
    450   (dbg "broadcasting " cvar)
     710  (%check-condition-variable cv 'condition-variable-specific-set!)
     711  (%condition-variable-specific-set! cv x) )
     712
     713(define (condition-variable-signal! cv)
     714  (%check-condition-variable cv 'condition-variable-signal!)
     715  (dbg "signalling " cv)
     716  (unless (%condition-variable-waiters-empty? cv)
     717    (let* ([t0 (%condition-variable-waiters-pop! cv)]
     718           [t0s (%thread-state t0)] )
     719      (when (or (eq? 'blocked t0s) (eq? 'sleeping t0s))
     720        (##sys#thread-basic-unblock! t0) ) ) ) )
     721
     722(define (condition-variable-broadcast! cv)
     723  (%check-condition-variable cv 'condition-variable-broadcast!)
     724  (dbg "broadcasting " cv)
    451725  (##sys#for-each
    452726   (lambda (ti)
    453      (let ([tis (##sys#slot ti 3)])
    454        (when (or (eq? tis 'blocked) (eq? tis 'sleeping))
     727     (let ([tis (%thread-state ti)])
     728       (when (or (eq? 'blocked tis) (eq? 'sleeping tis))
    455729         (##sys#thread-basic-unblock! ti) ) ) )
    456    (##sys#slot cvar 2) )
    457   (##sys#setislot cvar 2 '()) )
    458 
    459 
    460 ;;; Change continuation of thread to signal an exception:
    461 
    462 (define (thread-signal! thread exn)
    463   (##sys#check-structure thread 'thread 'thread-signal!)
    464   (if (eq? thread ##sys#current-thread)
    465       (##sys#signal exn)
    466       (let ([old (##sys#slot thread 1)])
    467         (##sys#setslot
    468          thread 1
    469          (lambda ()
    470            (##sys#signal exn)
    471            (old) ) )
    472         (##sys#thread-unblock! thread) ) ) )
     730   (%condition-variable-waiters cv) )
     731  (%condition-variable-waiters-clear! cv) )
    473732
    474733
    475734;;; Don't block in the repl: (by Chris Double)
    476735
    477 (unless (eq? (build-platform) 'msvc)
     736(unless (eq? 'msvc (build-platform))
    478737  (set! ##sys#read-prompt-hook
    479738    (let ([old ##sys#read-prompt-hook]
     
    484743          (##sys#thread-block-for-i/o! ##sys#current-thread 0 #t)
    485744          (thread-yield!)))) ) )
    486 
    487 
    488 ;;; Waiting for I/O on file-descriptor
    489 
    490 (define (thread-wait-for-i/o! fd #!optional (mode #:all))
    491   (##sys#check-exact fd 'thread-wait-for-i/o!)
    492   (##sys#thread-block-for-i/o! ##sys#current-thread fd mode)
    493   (thread-yield!) )
  • chicken/branches/chicken-3/tests/runtests.sh

    r13134 r13135  
    99
    1010echo "======================================== runtime tests ..."
    11 ../csi -s apply-test.scm
     11../csi -n -s apply-test.scm
    1212$compile test-gc-hooks.scm && ./a.out
    1313
    1414echo "======================================== library tests ..."
    15 ../csi -w -s library-tests.scm
     15../csi -n -w -s library-tests.scm
    1616
    1717echo "======================================== lolevel tests ..."
    18 ../csi -w -s lolevel-tests.scm
     18../csi -n -w -s lolevel-tests.scm
    1919
    2020echo "======================================== hash-table tests ..."
    21 ../csi -w -s hash-table-tests.scm
     21../csi -n -w -s hash-table-tests.scm
    2222
    2323echo "======================================== port tests ..."
    24 ../csi -w -s port-tests.scm
     24../csi -n -w -s port-tests.scm
    2525
    2626echo "======================================== fixnum tests ..."
     
    2828
    2929echo "======================================== srfi-18 tests ..."
    30 ../csi -w -s srfi-18-tests.scm
     30../csi -n -w -s srfi-18-tests.scm
    3131
    3232echo "======================================== path tests ..."
     
    3434
    3535echo "======================================== r4rstest ..."
    36 ../csi -e '(set! ##sys#procedure->string (constantly "#<procedure>"))' \
     36../csi -n -e '(set! ##sys#procedure->string (constantly "#<procedure>"))' \
    3737  -i -s r4rstest.scm >r4rstest.log
    3838diff -u r4rstest.out r4rstest.log
  • chicken/trunk/posixwin.scm

    r12937 r13135  
    20662066;;; unimplemented stuff:
    20672067
    2068 (define-inline (define-unimplemented name)
    2069   (define (,name . _)
    2070     (error 'name (##core#immutable '"this function is not available on this platform")) ) )
     2068(define-syntax define-unimplemented
     2069  (syntax-rules ()
     2070    [(_ ?name)
     2071     (define (?name . _)
     2072       (error '?name (##core#immutable '"this function is not available on this platform")) ) ] ) )
    20712073
    20722074(define-unimplemented change-file-owner)
  • chicken/trunk/runtime.c

    r13127 r13135  
    41694169    for(i = j = 0; i < locative_table_count; ++i)
    41704170      if(locative_table[ i ] != C_SCHEME_UNDEFINED) ++j;
    4171  
    41724171    return C_fix(j);
    41734172
Note: See TracChangeset for help on using the changeset viewer.