Changeset 13488 in project for chicken


Ignore:
Timestamp:
03/04/09 06:09:45 (11 years ago)
Author:
Kon Lovett
Message:

Added '%append!' & thread state test procs.

Location:
chicken/trunk
Files:
2 edited

Legend:

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

    r13466 r13488  
    402402(define-inline (%set-cdr/immediate! p x) (%block-word-set!/immediate p 1 x))
    403403
    404 ;; l0 must be a proper-list
    405 
     404;; These are safe
     405
     406(define-inline (%memq x l) (##core#inline "C_i_memq" x l))
     407(define-inline (%memv x l) (##core#inline "C_i_memv" x l))
     408(define-inline (%member x l) (##core#inline "C_i_member" x l))
     409
     410(define-inline (%assq x l) (##core#inline "C_i_assq" x l))
     411(define-inline (%assv x l) (##core#inline "C_i_assv" x l))
     412(define-inline (%assoc x l) (##core#inline "C_i_assoc" x l))
     413
     414; l0 must be a proper-list
    406415(define-inline (%list-ref l0 i0)
    407416  (let loop ([l l0] [i i0])
    408     (cond [(null? l)
    409            '() ]
    410                 [(%fx= 0 i)
    411                  (%car l) ]
    412                 [else
    413                  (loop (%cdr l) (%fx- i 1)) ] ) ) )
     417    (cond [(null? l)  '() ]
     418                [(%fx= 0 i) (%car l) ]
     419                [else       (loop (%cdr l) (%fx- i 1)) ] ) ) )
    414420
    415421; l0 cannot be null
     
    418424      [(%null? (%cdr l)) l]) )
    419425
     426; each elm of ls must be a proper-list
     427(define-inline (%append! . ls)
     428  (let ([ls (let loop ([ls ls])
     429              (cond [(%null? ls)        '() ]
     430                    [(%null? (%car ls)) (loop (%cdr ls)) ]
     431                    [else               ls ] ) ) ] )
     432    (if (%null? ls)
     433        '()
     434        (let ([l0 (%car ls)])
     435          ;(assert (not (null? l0)))
     436          (let loop ([ls (%cdr ls)] [pl l0])
     437            (if (%null? ls)
     438                l0
     439                (let ([l1 (%car ls)])
     440                  (if (%null? l1)
     441                      (loop (%cdr ls) pl)
     442                      (begin
     443                        (%set-cdr! (%last-pair pl) l1)
     444                        (loop (%cdr ls) l1) ) ) ) ) ) ) ) ) )
     445   
     446; l0 must be a proper-list
    420447(define-inline (%delq! x l0)
    421448  (let loop ([l l0] [pp #f])
     
    430457                [else
    431458                 (loop (%cdr l) l) ] ) ) )
    432 
    433 ;; These are safe
    434 
    435 (define-inline (%memq x l) (##core#inline "C_i_memq" x l))
    436 (define-inline (%memv x l) (##core#inline "C_i_memv" x l))
    437 (define-inline (%member x l) (##core#inline "C_i_member" x l))
    438 
    439 (define-inline (%assq x l) (##core#inline "C_i_assq" x l))
    440 (define-inline (%assv x l) (##core#inline "C_i_assv" x l))
    441 (define-inline (%assoc x l) (##core#inline "C_i_assoc" x l))
    442459
    443460
  • chicken/trunk/chicken-thread-object-inlines.scm

    r13167 r13488  
    2929
    3030(define-inline (%mutex? x)
    31   (%structure? x 'mutex) )
     31  (%structure-instance? x 'mutex) )
    3232
    3333(define-inline (%mutex-name mx)
     
    5656
    5757(define-inline (%mutex-waiters-add! mx th)
    58   (%mutex-waiters-set! mx (%append-item (%mutex-waiters mx) th)) )
     58  (%mutex-waiters-set! mx (%append! (%mutex-waiters mx) (%cons th '()))) )
    5959
    6060(define-inline (%mutex-waiters-delete! mx th)
     
    112112
    113113(define-inline (%thread? x)
    114   (%structure? x 'thread) )
     114  (%structure-instance? x 'thread) )
    115115
    116116(define-inline (%thread-thunk th)
     
    213213  (let ([rs (%thread-recipients t)])
    214214    (unless (%null? rs) (for-each tk rs) ) )
    215   (thread-recipients-empty! t) )
     215  (%thread-recipients-empty! t) )
    216216
    217217(define-inline (%thread-unblocked-by-timeout? th)
     
    220220(define-inline (%thread-unblocked-by-timeout-set! th f)
    221221  (%structure-set!/immediate th 13 f) )
     222
     223(define-inline (%thread-blocked-for-timeout? th)
     224  (and (%thread-block-timeout th)
     225       (not (%thread-block-object th))) )
     226
     227(define-inline (%thread-blocked? th)
     228  (%eq? 'blocked (%thread-state th)) )
     229
     230(define-inline (%thread-created? th)
     231  (%eq? 'created (%thread-state th)) )
     232
     233(define-inline (%thread-ready? th)
     234  (%eq? 'ready (%thread-state th)) )
     235
     236(define-inline (%thread-sleeping? th)
     237  (%eq? 'sleeping (%thread-state th)) )
     238
     239(define-inline (%thread-suspended? th)
     240  (%eq? 'suspended (%thread-state th)) )
     241
     242(define-inline (%thread-terminated? th)
     243  (%eq? 'terminated (%thread-state th)) )
     244
     245(define-inline (%thread-dead? th)
     246  (%eq? 'dead (%thread-state th)) )
    222247
    223248
     
    232257
    233258(define-inline (%condition-variable? x)
    234   (%structure? x 'condition-variable) )
     259  (%structure-instance? x 'condition-variable) )
    235260
    236261(define-inline (%condition-variable-name cv)
     
    250275
    251276(define-inline (%condition-variable-waiters-add! cv th)
    252   (%condition-variable-waiters-set! cv (%append-item (%condition-variable-waiters cv) th)) )
     277  (%condition-variable-waiters-set! cv (%append! (%condition-variable-waiters cv) (%cons th '()))) )
    253278
    254279(define-inline (%condition-variable-waiters-delete! cv th)
Note: See TracChangeset for help on using the changeset viewer.