Changeset 13666 in project


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

Save.

Location:
release/4/synch
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/synch/tags/2.0.0/synch.scm

    r13498 r13666  
    88  (fixnum)
    99  (local)
    10   (no-procedure-checks)
    11   (no-bound-checks) )
     10  (no-procedure-checks) )
    1211
    1312;;;
     
    7978
    8079(define (make-object/synch obj #!optional (name '(synchobj)))
    81   (let ([mutex (make-mutex (if (pair? name) (gensym (car name)) name))])
     80  (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
    8281    (mutex-specific-set! mutex obj)
    8382    mutex ) )
    8483
    8584(define object?/synch
    86   (let ([tpred (constantly #t)])
     85  (let ((tpred (constantly #t)))
    8786    (lambda (obj #!optional (pred tpred))
    8887      (and (mutex? obj)
    89            (let ([ms (mutex-specific obj)])
     88           (let ((ms (mutex-specific obj)))
    9089             (and (not (eq? (void) ms))
    9190                  (pred ms)) ) ) ) ) )
     
    9594(define-syntax synch
    9695        (syntax-rules ()
    97                 [(_ ?mtx ?body ...)
    98         (let ([mtx ?mtx])
     96                ((_ ?mtx ?body ...)
     97        (let ((mtx ?mtx))
    9998        (dynamic-wind
    10099          (lambda () (mutex-lock! mtx))
    101100          (lambda () ?body ...)
    102           (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     101          (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    103102
    104103(define-syntax synch-with
    105104  (lambda (form r c)
    106105    (##sys#check-syntax 'synch-with form '(_ _ variable . #(_ 0)))
    107     (let ([$dynamic-wind (r 'dynamic-wind)]
    108           [$let (r 'let)]
    109           [$lambda (r 'lambda)]
    110           [$mutex-unlock! (r 'mutex-unlock!)]
    111           [$mutex-specific (r 'mutex-specific)]
    112           [$mutex-lock! (r 'mutex-lock!)]
    113           [mtxvar (r (gensym))])
    114       (let ([?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)])
    115                     `(,$let ([,mtxvar ,?mtx])
    116            (,$let ([,?var (,$mutex-specific ,mtxvar)])
     106    (let (($dynamic-wind (r 'dynamic-wind))
     107          ($let (r 'let))
     108          ($lambda (r 'lambda))
     109          ($mutex-unlock! (r 'mutex-unlock!))
     110          ($mutex-specific (r 'mutex-specific))
     111          ($mutex-lock! (r 'mutex-lock!))
     112          (mtxvar (r (gensym))))
     113      (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
     114                    `(,$let ((,mtxvar ,?mtx))
     115           (,$let ((,?var (,$mutex-specific ,mtxvar)))
    117116             (,$dynamic-wind
    118117               (,$lambda () (,$mutex-lock! ,mtxvar))
     
    122121(define-syntax call/synch
    123122        (syntax-rules ()
    124                 [(_ ?mtx ?proc ?arg0 ...)
    125                   (let ([mtx ?mtx])
     123                ((_ ?mtx ?proc ?arg0 ...)
     124                  (let ((mtx ?mtx))
    126125                          (dynamic-wind
    127126                                  (lambda () (mutex-lock! mtx))
    128127                                  (lambda () (?proc ?arg0 ...))
    129                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     128                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    130129
    131130(define-syntax call-with/synch
    132131        (syntax-rules ()
    133                 [(_ ?mtx ?proc ?arg0 ...)
    134                   (let ([mtx ?mtx])
     132                ((_ ?mtx ?proc ?arg0 ...)
     133                  (let ((mtx ?mtx))
    135134                          (dynamic-wind
    136135                                  (lambda () (mutex-lock! mtx))
    137136                                  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
    138                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     137                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    139138
    140139(define-syntax apply/synch
    141140        (syntax-rules ()
    142                 [(_ ?mtx ?proc ?arg0 ...)
    143                   (let ([mtx ?mtx])
     141                ((_ ?mtx ?proc ?arg0 ...)
     142                  (let ((mtx ?mtx))
    144143                          (dynamic-wind
    145144                                  (lambda () (mutex-lock! mtx))
    146145                                  (lambda () (apply ?proc ?arg0 ...))
    147                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     146                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    148147
    149148(define-syntax apply-with/synch
    150149        (syntax-rules ()
    151                 [(_ ?mtx ?proc ?arg0 ...)
    152                   (let ([mtx ?mtx])
     150                ((_ ?mtx ?proc ?arg0 ...)
     151                  (let ((mtx ?mtx))
    153152                          (dynamic-wind
    154153                                  (lambda () (mutex-lock! mtx))
    155154                                  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
    156                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     155                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    157156
    158157(define-syntax let/synch
    159158  (lambda (form r c)
    160159    (##sys#check-syntax 'let/synch form '(_ list . _))
    161     (let ([$synch-with (r 'synch-with)])
    162       (let ([?body (cddr form)])
     160    (let (($synch-with (r 'synch-with)))
     161      (let ((?body (cddr form)))
    163162        (car
    164           (let loop ([?bnds (cadr form)])
     163          (let loop ((?bnds (cadr form)))
    165164            (if (not (null? ?bnds))
    166                 (let ([bnd (car ?bnds)])
     165                (let ((bnd (car ?bnds)))
    167166                  (##sys#check-syntax 'let/synch bnd '(variable _))
    168167                  `((,$synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
     
    172171  (lambda (form r c)
    173172    (##sys#check-syntax 'set!/synch form '(_ pair . _))
    174     (let ([$synch-with (r 'synch-with)]
    175           [$mutex-specific (r 'mutex-specific)]
    176           [$mutex-specific-set! (r 'mutex-specific-set!)]
    177           [$begin (r 'begin)])
    178       (let ([?bnd (cadr form)] [?body (cddr form)])
    179         (let ([?var (car ?bnd)] [?mtx (cadr ?bnd)])
     173    (let (($synch-with (r 'synch-with))
     174          ($mutex-specific (r 'mutex-specific))
     175          ($mutex-specific-set! (r 'mutex-specific-set!))
     176          ($begin (r 'begin)))
     177      (let ((?bnd (cadr form)) (?body (cddr form)))
     178        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    180179          `(,$synch-with ,?mtx ,?var
    181180             (,$mutex-specific-set! ,?mtx (,$begin ,@?body))
     
    186185  (lambda (form r c)
    187186    (##sys#check-syntax 'synch/lock form '(_ _ . _))
    188     (let ([$dynamic-wind (r 'dynamic-wind)]
    189           [$unless (r 'unless)]
    190           [$begin (r 'begin)]
    191           [$let (r 'let)]
    192           [$set! (r 'set!)]
    193           [$lambda (r 'lambda)]
    194           [$mutex-unlock! (r 'mutex-unlock!)]
    195           [$mutex-specific (r 'mutex-specific)]
    196           [$mutex-lock! (r 'mutex-lock!)]
    197           [mtxvar (r (gensym))]
    198           [okvar (r (gensym))]
    199           [resvar (r (gensym))])
    200       (let ([?mtx (cadr form)] [?body (cddr form)])
    201         `(,$let ([,mtxvar ,?mtx] [,okvar #f])
     187    (let (($dynamic-wind (r 'dynamic-wind))
     188          ($unless (r 'unless))
     189          ($begin (r 'begin))
     190          ($let (r 'let))
     191          ($set! (r 'set!))
     192          ($lambda (r 'lambda))
     193          ($mutex-unlock! (r 'mutex-unlock!))
     194          ($mutex-specific (r 'mutex-specific))
     195          ($mutex-lock! (r 'mutex-lock!))
     196          (mtxvar (r (gensym)))
     197          (okvar (r (gensym)))
     198          (resvar (r (gensym))))
     199      (let ((?mtx (cadr form)) (?body (cddr form)))
     200        `(,$let ((,mtxvar ,?mtx) (,okvar #f))
    202201           (,$dynamic-wind
    203202             (,$lambda () (,$mutex-lock! ,mtxvar))
    204              (,$lambda () (,$let ([,resvar (,$begin ,@?body)]) (,$set! ,okvar #t) ,resvar))
     203             (,$lambda () (,$let ((,resvar (,$begin ,@?body))) (,$set! ,okvar #t) ,resvar))
    205204             (,$lambda () (,$unless ,okvar (,$mutex-unlock! ,mtxvar))) ) ) ) ) ) )
    206205
    207206(define-syntax synch/lock
    208207        (syntax-rules ()
    209                 [(_ ?mtx ?body ...)
    210                   (let ([mtx ?mtx] [ok? #f])
     208                ((_ ?mtx ?body ...)
     209                  (let ((mtx ?mtx) (ok? #f))
    211210                                (mutex-lock! mtx)
    212211                                (dynamic-wind
    213212                                  (lambda () (mutex-lock! mtx))
    214                                         (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res))
    215                                         (lambda () (unless ok? (mutex-unlock! mtx)))) ) ] ) )
     213                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
     214                                        (lambda () (unless ok? (mutex-unlock! mtx)))) ) ) ) )
    216215
    217216(define-syntax synch/unlock
    218217        (syntax-rules ()
    219                 [(_ ?mtx ?body ...)
    220                   (let ([mtx ?mtx])
     218                ((_ ?mtx ?body ...)
     219                  (let ((mtx ?mtx))
    221220                          (dynamic-wind
    222221                                  (lambda ()
     
    225224                                                  (mutex-lock! mtx)))
    226225                                  (lambda () ?body ...)
    227                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     226                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    228227
    229228(define-syntax object/synch
    230229  (lambda (form r c)
    231230    (##sys#check-syntax 'object/synch form '(_ _ . _))
    232     (let ([$synch-with (r 'synch-with)]
    233           [$>< (r '><)]
    234           [var (r (gensym))]
    235           [mtx (cadr form)])
    236       (let body-loop ([unparsed (cddr form)] [parsed '()])
     231    (let (($synch-with (r 'synch-with))
     232          ($>< (r '><))
     233          (var (r (gensym)))
     234          (mtx (cadr form)))
     235      (let body-loop ((unparsed (cddr form)) (parsed '()))
    237236        (if (not (null? unparsed))
    238             (let ([expr (car unparsed)]
    239                   [next (cdr unparsed)])
    240               (let expr-loop ([rest expr] [parsedexpr '()])
    241                 (cond [(null? rest)
    242                         (body-loop next (cons (reverse parsedexpr) parsed))]
    243                       [(pair? rest)
    244                         (let ([arg (car rest)]
    245                               [next (cdr rest)])
     237            (let ((expr (car unparsed))
     238                  (next (cdr unparsed)))
     239              (let expr-loop ((rest expr) (parsedexpr '()))
     240                (cond ((null? rest)
     241                        (body-loop next (cons (reverse parsedexpr) parsed)))
     242                      ((pair? rest)
     243                        (let ((arg (car rest))
     244                              (next (cdr rest)))
    246245                          (if (c $>< arg)
    247246                              (expr-loop next (cons var parsedexpr))
    248                               (expr-loop next (cons arg parsedexpr)) ) )]
    249                       [(c $>< rest)
    250                         (body-loop next (cons var parsed))]
    251                       [else
    252                         (body-loop next (cons rest parsed))] ) ) )
     247                              (expr-loop next (cons arg parsedexpr)) ) ))
     248                      ((c $>< rest)
     249                        (body-loop next (cons var parsed)))
     250                      (else
     251                        (body-loop next (cons rest parsed))) ) ) )
    253252            `(,$synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
    254253
     
    256255  (lambda (form r c)
    257256    (##sys#check-syntax 'record/synch form '(_ symbol _ . _))
    258     (let ([$synch (r 'synch)])
    259       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     257    (let (($synch (r 'synch)))
     258      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    260259        `(,$synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    261260
     
    263262  (lambda (form r c)
    264263    (##sys#check-syntax 'record-synch/lock form '(_ symbol _ . _))
    265     (let ([$synch/lock (r 'synch/lock)])
    266       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     264    (let (($synch/lock (r 'synch/lock)))
     265      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    267266        `(,$synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    268267
     
    270269  (lambda (form r c)
    271270    (##sys#check-syntax 'record-synch/unlock form '(_ symbol _ . _))
    272     (let ([$synch/unlock (r 'synch/unlock)])
    273       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     271    (let (($synch/unlock (r 'synch/unlock)))
     272      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    274273        `(,$synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    275274
     
    278277(define-syntax %synch-mutex*
    279278        (syntax-rules ()
    280                 [(_ ?mtx ?body ...)
    281                   (let ([mtx ?mtx])
     279                ((_ ?mtx ?body ...)
     280                  (let ((mtx ?mtx))
    282281        (mutex-lock! mtx)
    283282                                (call-with-values
     
    285284                                        (lambda ret
    286285                                                (mutex-unlock! mtx)
    287                                                 (apply values ret))) ) ] ) )
     286                                                (apply values ret))) ) ) ) )
    288287
    289288(define-syntax %synch-mutex-with*
    290289  (lambda (form r c)
    291290    (##sys#check-syntax '%synch-mutex-with* form '(_ _ variable . _))
    292     (let ([$call-with-values (r 'call-with-values)]
    293           [$mutex-specific (r 'mutex-specific)]
    294           [$mutex-lock! (r 'mutex-lock!)]
    295           [$mutex-unlock! (r 'mutex-unlock!)]
    296           [$let (r 'let)]
    297           [$apply (r 'apply)]
    298           [$values (r 'values)]
    299           [$lambda (r 'lambda)]
    300           [$ret (r 'ret)]
    301           [mtxvar (r (gensym))])
    302       (let ([?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)])
    303         `(,$let ([,mtxvar ,?mtx])
    304            (,$let ([,?var (,$mutex-specific ,mtxvar)])
     291    (let (($call-with-values (r 'call-with-values))
     292          ($mutex-specific (r 'mutex-specific))
     293          ($mutex-lock! (r 'mutex-lock!))
     294          ($mutex-unlock! (r 'mutex-unlock!))
     295          ($let (r 'let))
     296          ($apply (r 'apply))
     297          ($values (r 'values))
     298          ($lambda (r 'lambda))
     299          ($ret (r 'ret))
     300          (mtxvar (r (gensym))))
     301      (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
     302        `(,$let ((,mtxvar ,?mtx))
     303           (,$let ((,?var (,$mutex-specific ,mtxvar)))
    305304             (,$mutex-lock! ,mtxvar)
    306305             (,$call-with-values
     
    312311(define-syntax %synch
    313312        (syntax-rules ()
    314                 [(_ ?mtx ?body ...) (%synch-mutex* ?mtx ?body ...) ] ) )
     313                ((_ ?mtx ?body ...) (%synch-mutex* ?mtx ?body ...) ) ) )
    315314
    316315(define-syntax %synch-with
    317316        (syntax-rules ()
    318                 [(_ ?mtx ?var ?body ...) (%synch-mutex-with* ?mtx ?var ?body ...) ] ) )
     317                ((_ ?mtx ?var ?body ...) (%synch-mutex-with* ?mtx ?var ?body ...) ) ) )
    319318
    320319(define-syntax %call/synch
    321320        (syntax-rules ()
    322                 [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (?proc ?arg0 ...)) ] ) )
     321                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (?proc ?arg0 ...)) ) ) )
    323322
    324323(define-syntax %call-with/synch
    325324        (syntax-rules ()
    326                 [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (?proc var ?arg0 ...)) ] ) )
     325                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (?proc var ?arg0 ...)) ) ) )
    327326
    328327(define-syntax %apply/synch
    329328        (syntax-rules ()
    330                 [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (apply ?proc ?arg0 ...)) ] ) )
     329                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (apply ?proc ?arg0 ...)) ) ) )
    331330
    332331(define-syntax %apply-with/synch
    333332        (syntax-rules ()
    334                 [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (apply ?proc var ?arg0 ...)) ] ) )
     333                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
    335334
    336335(define-syntax %let/synch
    337336  (lambda (form r c)
    338337    (##sys#check-syntax '%let/synch form '(_ list . _))
    339     (let ([$%synch-with (r '%synch-with)])
    340       (let ([?body (cddr form)])
     338    (let (($%synch-with (r '%synch-with)))
     339      (let ((?body (cddr form)))
    341340        (car
    342           (let loop ([?bnds (cadr form)])
     341          (let loop ((?bnds (cadr form)))
    343342            (if (not (null? ?bnds))
    344                 (let ([bnd (car ?bnds)])
     343                (let ((bnd (car ?bnds)))
    345344                  (##sys#check-syntax '%let/synch bnd '(variable _))
    346345                  `((,$%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
     
    350349  (lambda (form r c)
    351350    (##sys#check-syntax '%set!/synch form '(_ pair . _))
    352     (let ([$%synch-with (r '%synch-with)]
    353           [$mutex-specific (r 'mutex-specific)]
    354           [$mutex-specific-set! (r 'mutex-specific-set!)]
    355           [$let (r 'let)]
    356           [$begin (r 'begin)]
    357           [mtxvar (r (gensym))])
    358       (let ([?bnd (cadr form)] [?body (cddr form)])
    359         (let ([?var (car ?bnd)] [?mtx (cadr ?bnd)])
    360           `(,$let ([,mtxvar ,?mtx])
     351    (let (($%synch-with (r '%synch-with))
     352          ($mutex-specific (r 'mutex-specific))
     353          ($mutex-specific-set! (r 'mutex-specific-set!))
     354          ($let (r 'let))
     355          ($begin (r 'begin))
     356          (mtxvar (r (gensym))))
     357      (let ((?bnd (cadr form)) (?body (cddr form)))
     358        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
     359          `(,$let ((,mtxvar ,?mtx))
    361360             (,$%synch-with ,mtxvar ,?var
    362361               (,$mutex-specific-set! ,mtxvar (,$begin ,@?body))
     
    365364(define-syntax %synch/lock
    366365        (syntax-rules ()
    367                 [(_ ?mtx ?body ...)
    368                   (let ([mtx ?mtx] [ok? #f])
     366                ((_ ?mtx ?body ...)
     367                  (let ((mtx ?mtx) (ok? #f))
    369368                                (mutex-lock! mtx)
    370369                                (call-with-values
    371                                         (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res))
     370                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
    372371                                        (lambda ret
    373372                                                (unless ok? (mutex-unlock! mtx))
    374                                                 (apply values ret))) ) ] ) )
     373                                                (apply values ret))) ) ) ) )
    375374
    376375(define-syntax %synch/unlock
    377376        (syntax-rules ()
    378                 [(_ ?mtx ?body ...)
    379       (let ([mtx ?mtx])
     377                ((_ ?mtx ?body ...)
     378      (let ((mtx ?mtx))
    380379        (unless (thread? (mutex-state mtx))
    381380          (warning '%synch/unlock "mutex is not locked - locking")
     
    385384          (lambda ret
    386385            (mutex-unlock! mtx)
    387             (apply values ret)) ) ) ] ) )
     386            (apply values ret)) ) ) ) ) )
    388387
    389388(define-syntax %object/synch
    390389  (lambda (form r c)
    391390    (##sys#check-syntax '%object/synch form '(_ _ . _))
    392     (let ([$%synch-with (r '%synch-with)]
    393           [$>< (r '><)]
    394           [var (r (gensym))]
    395           [mtx (cadr form)])
    396       (let body-loop ([unparsed (cddr form)] [parsed '()])
     391    (let (($%synch-with (r '%synch-with))
     392          ($>< (r '><))
     393          (var (r (gensym)))
     394          (mtx (cadr form)))
     395      (let body-loop ((unparsed (cddr form)) (parsed '()))
    397396        (if (not (null? unparsed))
    398             (let ([expr (car unparsed)]
    399                   [next (cdr unparsed)])
    400               (let expr-loop ([rest expr] [parsedexpr '()])
    401                 (cond [(null? rest)
    402                         (body-loop next (cons (reverse parsedexpr) parsed))]
    403                       [(pair? rest)
    404                         (let ([arg (car rest)]
    405                               [next (cdr rest)])
     397            (let ((expr (car unparsed))
     398                  (next (cdr unparsed)))
     399              (let expr-loop ((rest expr) (parsedexpr '()))
     400                (cond ((null? rest)
     401                        (body-loop next (cons (reverse parsedexpr) parsed)))
     402                      ((pair? rest)
     403                        (let ((arg (car rest))
     404                              (next (cdr rest)))
    406405                          (if (c $>< arg)
    407406                              (expr-loop next (cons var parsedexpr))
    408                               (expr-loop next (cons arg parsedexpr)) ) )]
    409                       [(c $>< rest)
    410                         (body-loop next (cons var parsed))]
    411                       [else
    412                         (body-loop next (cons rest parsed))] ) ) )
     407                              (expr-loop next (cons arg parsedexpr)) ) ))
     408                      ((c $>< rest)
     409                        (body-loop next (cons var parsed)))
     410                      (else
     411                        (body-loop next (cons rest parsed))) ) ) )
    413412            `(,$%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
    414413
     
    416415  (lambda (form r c)
    417416    (##sys#check-syntax '%record/synch form '(_ symbol _ . _))
    418     (let ([$%synch (r '%synch)])
    419       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     417    (let (($%synch (r '%synch)))
     418      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    420419        `(,$%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) )
    421420
     
    423422  (lambda (form r c)
    424423    (##sys#check-syntax '%record-synch/lock form '(_ symbol _ . _))
    425     (let ([$%synch/lock (r '%synch/lock)])
    426       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     424    (let (($%synch/lock (r '%synch/lock)))
     425      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    427426        `(,$%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    428427
     
    430429  (lambda (form r c)
    431430    (##sys#check-syntax '%record-synch/unlock form '(_ symbol _ . _))
    432     (let ([$%synch/unlock (r '%synch/unlock)])
    433       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     431    (let (($%synch/unlock (r '%synch/unlock)))
     432      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    434433        `(,$%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    435434
  • release/4/synch/trunk/synch.scm

    r13498 r13666  
    88  (fixnum)
    99  (local)
    10   (no-procedure-checks)
    11   (no-bound-checks) )
     10  (no-procedure-checks) )
    1211
    1312;;;
     
    7978
    8079(define (make-object/synch obj #!optional (name '(synchobj)))
    81   (let ([mutex (make-mutex (if (pair? name) (gensym (car name)) name))])
     80  (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
    8281    (mutex-specific-set! mutex obj)
    8382    mutex ) )
    8483
    8584(define object?/synch
    86   (let ([tpred (constantly #t)])
     85  (let ((tpred (constantly #t)))
    8786    (lambda (obj #!optional (pred tpred))
    8887      (and (mutex? obj)
    89            (let ([ms (mutex-specific obj)])
     88           (let ((ms (mutex-specific obj)))
    9089             (and (not (eq? (void) ms))
    9190                  (pred ms)) ) ) ) ) )
     
    9594(define-syntax synch
    9695        (syntax-rules ()
    97                 [(_ ?mtx ?body ...)
    98         (let ([mtx ?mtx])
     96                ((_ ?mtx ?body ...)
     97        (let ((mtx ?mtx))
    9998        (dynamic-wind
    10099          (lambda () (mutex-lock! mtx))
    101100          (lambda () ?body ...)
    102           (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     101          (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    103102
    104103(define-syntax synch-with
    105104  (lambda (form r c)
    106105    (##sys#check-syntax 'synch-with form '(_ _ variable . #(_ 0)))
    107     (let ([$dynamic-wind (r 'dynamic-wind)]
    108           [$let (r 'let)]
    109           [$lambda (r 'lambda)]
    110           [$mutex-unlock! (r 'mutex-unlock!)]
    111           [$mutex-specific (r 'mutex-specific)]
    112           [$mutex-lock! (r 'mutex-lock!)]
    113           [mtxvar (r (gensym))])
    114       (let ([?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)])
    115                     `(,$let ([,mtxvar ,?mtx])
    116            (,$let ([,?var (,$mutex-specific ,mtxvar)])
     106    (let (($dynamic-wind (r 'dynamic-wind))
     107          ($let (r 'let))
     108          ($lambda (r 'lambda))
     109          ($mutex-unlock! (r 'mutex-unlock!))
     110          ($mutex-specific (r 'mutex-specific))
     111          ($mutex-lock! (r 'mutex-lock!))
     112          (mtxvar (r (gensym))))
     113      (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
     114                    `(,$let ((,mtxvar ,?mtx))
     115           (,$let ((,?var (,$mutex-specific ,mtxvar)))
    117116             (,$dynamic-wind
    118117               (,$lambda () (,$mutex-lock! ,mtxvar))
     
    122121(define-syntax call/synch
    123122        (syntax-rules ()
    124                 [(_ ?mtx ?proc ?arg0 ...)
    125                   (let ([mtx ?mtx])
     123                ((_ ?mtx ?proc ?arg0 ...)
     124                  (let ((mtx ?mtx))
    126125                          (dynamic-wind
    127126                                  (lambda () (mutex-lock! mtx))
    128127                                  (lambda () (?proc ?arg0 ...))
    129                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     128                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    130129
    131130(define-syntax call-with/synch
    132131        (syntax-rules ()
    133                 [(_ ?mtx ?proc ?arg0 ...)
    134                   (let ([mtx ?mtx])
     132                ((_ ?mtx ?proc ?arg0 ...)
     133                  (let ((mtx ?mtx))
    135134                          (dynamic-wind
    136135                                  (lambda () (mutex-lock! mtx))
    137136                                  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
    138                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     137                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    139138
    140139(define-syntax apply/synch
    141140        (syntax-rules ()
    142                 [(_ ?mtx ?proc ?arg0 ...)
    143                   (let ([mtx ?mtx])
     141                ((_ ?mtx ?proc ?arg0 ...)
     142                  (let ((mtx ?mtx))
    144143                          (dynamic-wind
    145144                                  (lambda () (mutex-lock! mtx))
    146145                                  (lambda () (apply ?proc ?arg0 ...))
    147                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     146                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    148147
    149148(define-syntax apply-with/synch
    150149        (syntax-rules ()
    151                 [(_ ?mtx ?proc ?arg0 ...)
    152                   (let ([mtx ?mtx])
     150                ((_ ?mtx ?proc ?arg0 ...)
     151                  (let ((mtx ?mtx))
    153152                          (dynamic-wind
    154153                                  (lambda () (mutex-lock! mtx))
    155154                                  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
    156                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     155                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    157156
    158157(define-syntax let/synch
    159158  (lambda (form r c)
    160159    (##sys#check-syntax 'let/synch form '(_ list . _))
    161     (let ([$synch-with (r 'synch-with)])
    162       (let ([?body (cddr form)])
     160    (let (($synch-with (r 'synch-with)))
     161      (let ((?body (cddr form)))
    163162        (car
    164           (let loop ([?bnds (cadr form)])
     163          (let loop ((?bnds (cadr form)))
    165164            (if (not (null? ?bnds))
    166                 (let ([bnd (car ?bnds)])
     165                (let ((bnd (car ?bnds)))
    167166                  (##sys#check-syntax 'let/synch bnd '(variable _))
    168167                  `((,$synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
     
    172171  (lambda (form r c)
    173172    (##sys#check-syntax 'set!/synch form '(_ pair . _))
    174     (let ([$synch-with (r 'synch-with)]
    175           [$mutex-specific (r 'mutex-specific)]
    176           [$mutex-specific-set! (r 'mutex-specific-set!)]
    177           [$begin (r 'begin)])
    178       (let ([?bnd (cadr form)] [?body (cddr form)])
    179         (let ([?var (car ?bnd)] [?mtx (cadr ?bnd)])
     173    (let (($synch-with (r 'synch-with))
     174          ($mutex-specific (r 'mutex-specific))
     175          ($mutex-specific-set! (r 'mutex-specific-set!))
     176          ($begin (r 'begin)))
     177      (let ((?bnd (cadr form)) (?body (cddr form)))
     178        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    180179          `(,$synch-with ,?mtx ,?var
    181180             (,$mutex-specific-set! ,?mtx (,$begin ,@?body))
     
    186185  (lambda (form r c)
    187186    (##sys#check-syntax 'synch/lock form '(_ _ . _))
    188     (let ([$dynamic-wind (r 'dynamic-wind)]
    189           [$unless (r 'unless)]
    190           [$begin (r 'begin)]
    191           [$let (r 'let)]
    192           [$set! (r 'set!)]
    193           [$lambda (r 'lambda)]
    194           [$mutex-unlock! (r 'mutex-unlock!)]
    195           [$mutex-specific (r 'mutex-specific)]
    196           [$mutex-lock! (r 'mutex-lock!)]
    197           [mtxvar (r (gensym))]
    198           [okvar (r (gensym))]
    199           [resvar (r (gensym))])
    200       (let ([?mtx (cadr form)] [?body (cddr form)])
    201         `(,$let ([,mtxvar ,?mtx] [,okvar #f])
     187    (let (($dynamic-wind (r 'dynamic-wind))
     188          ($unless (r 'unless))
     189          ($begin (r 'begin))
     190          ($let (r 'let))
     191          ($set! (r 'set!))
     192          ($lambda (r 'lambda))
     193          ($mutex-unlock! (r 'mutex-unlock!))
     194          ($mutex-specific (r 'mutex-specific))
     195          ($mutex-lock! (r 'mutex-lock!))
     196          (mtxvar (r (gensym)))
     197          (okvar (r (gensym)))
     198          (resvar (r (gensym))))
     199      (let ((?mtx (cadr form)) (?body (cddr form)))
     200        `(,$let ((,mtxvar ,?mtx) (,okvar #f))
    202201           (,$dynamic-wind
    203202             (,$lambda () (,$mutex-lock! ,mtxvar))
    204              (,$lambda () (,$let ([,resvar (,$begin ,@?body)]) (,$set! ,okvar #t) ,resvar))
     203             (,$lambda () (,$let ((,resvar (,$begin ,@?body))) (,$set! ,okvar #t) ,resvar))
    205204             (,$lambda () (,$unless ,okvar (,$mutex-unlock! ,mtxvar))) ) ) ) ) ) )
    206205
    207206(define-syntax synch/lock
    208207        (syntax-rules ()
    209                 [(_ ?mtx ?body ...)
    210                   (let ([mtx ?mtx] [ok? #f])
     208                ((_ ?mtx ?body ...)
     209                  (let ((mtx ?mtx) (ok? #f))
    211210                                (mutex-lock! mtx)
    212211                                (dynamic-wind
    213212                                  (lambda () (mutex-lock! mtx))
    214                                         (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res))
    215                                         (lambda () (unless ok? (mutex-unlock! mtx)))) ) ] ) )
     213                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
     214                                        (lambda () (unless ok? (mutex-unlock! mtx)))) ) ) ) )
    216215
    217216(define-syntax synch/unlock
    218217        (syntax-rules ()
    219                 [(_ ?mtx ?body ...)
    220                   (let ([mtx ?mtx])
     218                ((_ ?mtx ?body ...)
     219                  (let ((mtx ?mtx))
    221220                          (dynamic-wind
    222221                                  (lambda ()
     
    225224                                                  (mutex-lock! mtx)))
    226225                                  (lambda () ?body ...)
    227                                   (lambda () (mutex-unlock! mtx)) ) ) ] ) )
     226                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
    228227
    229228(define-syntax object/synch
    230229  (lambda (form r c)
    231230    (##sys#check-syntax 'object/synch form '(_ _ . _))
    232     (let ([$synch-with (r 'synch-with)]
    233           [$>< (r '><)]
    234           [var (r (gensym))]
    235           [mtx (cadr form)])
    236       (let body-loop ([unparsed (cddr form)] [parsed '()])
     231    (let (($synch-with (r 'synch-with))
     232          ($>< (r '><))
     233          (var (r (gensym)))
     234          (mtx (cadr form)))
     235      (let body-loop ((unparsed (cddr form)) (parsed '()))
    237236        (if (not (null? unparsed))
    238             (let ([expr (car unparsed)]
    239                   [next (cdr unparsed)])
    240               (let expr-loop ([rest expr] [parsedexpr '()])
    241                 (cond [(null? rest)
    242                         (body-loop next (cons (reverse parsedexpr) parsed))]
    243                       [(pair? rest)
    244                         (let ([arg (car rest)]
    245                               [next (cdr rest)])
     237            (let ((expr (car unparsed))
     238                  (next (cdr unparsed)))
     239              (let expr-loop ((rest expr) (parsedexpr '()))
     240                (cond ((null? rest)
     241                        (body-loop next (cons (reverse parsedexpr) parsed)))
     242                      ((pair? rest)
     243                        (let ((arg (car rest))
     244                              (next (cdr rest)))
    246245                          (if (c $>< arg)
    247246                              (expr-loop next (cons var parsedexpr))
    248                               (expr-loop next (cons arg parsedexpr)) ) )]
    249                       [(c $>< rest)
    250                         (body-loop next (cons var parsed))]
    251                       [else
    252                         (body-loop next (cons rest parsed))] ) ) )
     247                              (expr-loop next (cons arg parsedexpr)) ) ))
     248                      ((c $>< rest)
     249                        (body-loop next (cons var parsed)))
     250                      (else
     251                        (body-loop next (cons rest parsed))) ) ) )
    253252            `(,$synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
    254253
     
    256255  (lambda (form r c)
    257256    (##sys#check-syntax 'record/synch form '(_ symbol _ . _))
    258     (let ([$synch (r 'synch)])
    259       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     257    (let (($synch (r 'synch)))
     258      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    260259        `(,$synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    261260
     
    263262  (lambda (form r c)
    264263    (##sys#check-syntax 'record-synch/lock form '(_ symbol _ . _))
    265     (let ([$synch/lock (r 'synch/lock)])
    266       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     264    (let (($synch/lock (r 'synch/lock)))
     265      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    267266        `(,$synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    268267
     
    270269  (lambda (form r c)
    271270    (##sys#check-syntax 'record-synch/unlock form '(_ symbol _ . _))
    272     (let ([$synch/unlock (r 'synch/unlock)])
    273       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     271    (let (($synch/unlock (r 'synch/unlock)))
     272      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    274273        `(,$synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    275274
     
    278277(define-syntax %synch-mutex*
    279278        (syntax-rules ()
    280                 [(_ ?mtx ?body ...)
    281                   (let ([mtx ?mtx])
     279                ((_ ?mtx ?body ...)
     280                  (let ((mtx ?mtx))
    282281        (mutex-lock! mtx)
    283282                                (call-with-values
     
    285284                                        (lambda ret
    286285                                                (mutex-unlock! mtx)
    287                                                 (apply values ret))) ) ] ) )
     286                                                (apply values ret))) ) ) ) )
    288287
    289288(define-syntax %synch-mutex-with*
    290289  (lambda (form r c)
    291290    (##sys#check-syntax '%synch-mutex-with* form '(_ _ variable . _))
    292     (let ([$call-with-values (r 'call-with-values)]
    293           [$mutex-specific (r 'mutex-specific)]
    294           [$mutex-lock! (r 'mutex-lock!)]
    295           [$mutex-unlock! (r 'mutex-unlock!)]
    296           [$let (r 'let)]
    297           [$apply (r 'apply)]
    298           [$values (r 'values)]
    299           [$lambda (r 'lambda)]
    300           [$ret (r 'ret)]
    301           [mtxvar (r (gensym))])
    302       (let ([?mtx (cadr form)] [?var (caddr form)] [?body (cdddr form)])
    303         `(,$let ([,mtxvar ,?mtx])
    304            (,$let ([,?var (,$mutex-specific ,mtxvar)])
     291    (let (($call-with-values (r 'call-with-values))
     292          ($mutex-specific (r 'mutex-specific))
     293          ($mutex-lock! (r 'mutex-lock!))
     294          ($mutex-unlock! (r 'mutex-unlock!))
     295          ($let (r 'let))
     296          ($apply (r 'apply))
     297          ($values (r 'values))
     298          ($lambda (r 'lambda))
     299          ($ret (r 'ret))
     300          (mtxvar (r (gensym))))
     301      (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
     302        `(,$let ((,mtxvar ,?mtx))
     303           (,$let ((,?var (,$mutex-specific ,mtxvar)))
    305304             (,$mutex-lock! ,mtxvar)
    306305             (,$call-with-values
     
    312311(define-syntax %synch
    313312        (syntax-rules ()
    314                 [(_ ?mtx ?body ...) (%synch-mutex* ?mtx ?body ...) ] ) )
     313                ((_ ?mtx ?body ...) (%synch-mutex* ?mtx ?body ...) ) ) )
    315314
    316315(define-syntax %synch-with
    317316        (syntax-rules ()
    318                 [(_ ?mtx ?var ?body ...) (%synch-mutex-with* ?mtx ?var ?body ...) ] ) )
     317                ((_ ?mtx ?var ?body ...) (%synch-mutex-with* ?mtx ?var ?body ...) ) ) )
    319318
    320319(define-syntax %call/synch
    321320        (syntax-rules ()
    322                 [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (?proc ?arg0 ...)) ] ) )
     321                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (?proc ?arg0 ...)) ) ) )
    323322
    324323(define-syntax %call-with/synch
    325324        (syntax-rules ()
    326                 [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (?proc var ?arg0 ...)) ] ) )
     325                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (?proc var ?arg0 ...)) ) ) )
    327326
    328327(define-syntax %apply/synch
    329328        (syntax-rules ()
    330                 [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (apply ?proc ?arg0 ...)) ] ) )
     329                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (apply ?proc ?arg0 ...)) ) ) )
    331330
    332331(define-syntax %apply-with/synch
    333332        (syntax-rules ()
    334                 [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (apply ?proc var ?arg0 ...)) ] ) )
     333                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
    335334
    336335(define-syntax %let/synch
    337336  (lambda (form r c)
    338337    (##sys#check-syntax '%let/synch form '(_ list . _))
    339     (let ([$%synch-with (r '%synch-with)])
    340       (let ([?body (cddr form)])
     338    (let (($%synch-with (r '%synch-with)))
     339      (let ((?body (cddr form)))
    341340        (car
    342           (let loop ([?bnds (cadr form)])
     341          (let loop ((?bnds (cadr form)))
    343342            (if (not (null? ?bnds))
    344                 (let ([bnd (car ?bnds)])
     343                (let ((bnd (car ?bnds)))
    345344                  (##sys#check-syntax '%let/synch bnd '(variable _))
    346345                  `((,$%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
     
    350349  (lambda (form r c)
    351350    (##sys#check-syntax '%set!/synch form '(_ pair . _))
    352     (let ([$%synch-with (r '%synch-with)]
    353           [$mutex-specific (r 'mutex-specific)]
    354           [$mutex-specific-set! (r 'mutex-specific-set!)]
    355           [$let (r 'let)]
    356           [$begin (r 'begin)]
    357           [mtxvar (r (gensym))])
    358       (let ([?bnd (cadr form)] [?body (cddr form)])
    359         (let ([?var (car ?bnd)] [?mtx (cadr ?bnd)])
    360           `(,$let ([,mtxvar ,?mtx])
     351    (let (($%synch-with (r '%synch-with))
     352          ($mutex-specific (r 'mutex-specific))
     353          ($mutex-specific-set! (r 'mutex-specific-set!))
     354          ($let (r 'let))
     355          ($begin (r 'begin))
     356          (mtxvar (r (gensym))))
     357      (let ((?bnd (cadr form)) (?body (cddr form)))
     358        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
     359          `(,$let ((,mtxvar ,?mtx))
    361360             (,$%synch-with ,mtxvar ,?var
    362361               (,$mutex-specific-set! ,mtxvar (,$begin ,@?body))
     
    365364(define-syntax %synch/lock
    366365        (syntax-rules ()
    367                 [(_ ?mtx ?body ...)
    368                   (let ([mtx ?mtx] [ok? #f])
     366                ((_ ?mtx ?body ...)
     367                  (let ((mtx ?mtx) (ok? #f))
    369368                                (mutex-lock! mtx)
    370369                                (call-with-values
    371                                         (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res))
     370                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
    372371                                        (lambda ret
    373372                                                (unless ok? (mutex-unlock! mtx))
    374                                                 (apply values ret))) ) ] ) )
     373                                                (apply values ret))) ) ) ) )
    375374
    376375(define-syntax %synch/unlock
    377376        (syntax-rules ()
    378                 [(_ ?mtx ?body ...)
    379       (let ([mtx ?mtx])
     377                ((_ ?mtx ?body ...)
     378      (let ((mtx ?mtx))
    380379        (unless (thread? (mutex-state mtx))
    381380          (warning '%synch/unlock "mutex is not locked - locking")
     
    385384          (lambda ret
    386385            (mutex-unlock! mtx)
    387             (apply values ret)) ) ) ] ) )
     386            (apply values ret)) ) ) ) ) )
    388387
    389388(define-syntax %object/synch
    390389  (lambda (form r c)
    391390    (##sys#check-syntax '%object/synch form '(_ _ . _))
    392     (let ([$%synch-with (r '%synch-with)]
    393           [$>< (r '><)]
    394           [var (r (gensym))]
    395           [mtx (cadr form)])
    396       (let body-loop ([unparsed (cddr form)] [parsed '()])
     391    (let (($%synch-with (r '%synch-with))
     392          ($>< (r '><))
     393          (var (r (gensym)))
     394          (mtx (cadr form)))
     395      (let body-loop ((unparsed (cddr form)) (parsed '()))
    397396        (if (not (null? unparsed))
    398             (let ([expr (car unparsed)]
    399                   [next (cdr unparsed)])
    400               (let expr-loop ([rest expr] [parsedexpr '()])
    401                 (cond [(null? rest)
    402                         (body-loop next (cons (reverse parsedexpr) parsed))]
    403                       [(pair? rest)
    404                         (let ([arg (car rest)]
    405                               [next (cdr rest)])
     397            (let ((expr (car unparsed))
     398                  (next (cdr unparsed)))
     399              (let expr-loop ((rest expr) (parsedexpr '()))
     400                (cond ((null? rest)
     401                        (body-loop next (cons (reverse parsedexpr) parsed)))
     402                      ((pair? rest)
     403                        (let ((arg (car rest))
     404                              (next (cdr rest)))
    406405                          (if (c $>< arg)
    407406                              (expr-loop next (cons var parsedexpr))
    408                               (expr-loop next (cons arg parsedexpr)) ) )]
    409                       [(c $>< rest)
    410                         (body-loop next (cons var parsed))]
    411                       [else
    412                         (body-loop next (cons rest parsed))] ) ) )
     407                              (expr-loop next (cons arg parsedexpr)) ) ))
     408                      ((c $>< rest)
     409                        (body-loop next (cons var parsed)))
     410                      (else
     411                        (body-loop next (cons rest parsed))) ) ) )
    413412            `(,$%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
    414413
     
    416415  (lambda (form r c)
    417416    (##sys#check-syntax '%record/synch form '(_ symbol _ . _))
    418     (let ([$%synch (r '%synch)])
    419       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     417    (let (($%synch (r '%synch)))
     418      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    420419        `(,$%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) )
    421420
     
    423422  (lambda (form r c)
    424423    (##sys#check-syntax '%record-synch/lock form '(_ symbol _ . _))
    425     (let ([$%synch/lock (r '%synch/lock)])
    426       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     424    (let (($%synch/lock (r '%synch/lock)))
     425      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    427426        `(,$%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    428427
     
    430429  (lambda (form r c)
    431430    (##sys#check-syntax '%record-synch/unlock form '(_ symbol _ . _))
    432     (let ([$%synch/unlock (r '%synch/unlock)])
    433       (let ([?sym (cadr form)] [?rec (caddr form)] [?body (cdddr form)])
     431    (let (($%synch/unlock (r '%synch/unlock)))
     432      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
    434433        `(,$%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
    435434
Note: See TracChangeset for help on using the changeset viewer.