Changeset 16032 in project


Ignore:
Timestamp:
09/22/09 19:25:51 (10 years ago)
Author:
Kon Lovett
Message:

Use of er-macro-transformer. Hygiene for define-operation variable identifiers.

Location:
release/4/synch
Files:
2 edited

Legend:

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

    r16030 r16032  
    8282
    8383(define-syntax synch-with
    84   (lambda (frm rnm cmp)
    85     (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
    86     (let ((_dynamic-wind (rnm 'dynamic-wind))
    87           (_let (rnm 'let))
    88           (_lambda (rnm 'lambda))
    89           (_mutex-unlock! (rnm 'mutex-unlock!))
    90           (_mutex-specific (rnm 'mutex-specific))
    91           (_mutex-lock! (rnm 'mutex-lock!))
    92           (mtxvar (rnm (gensym))))
    93       (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)) )
    94         (call-with-values
    95           (lambda ()
    96             (if (not (pair? ?mtx)) (values ?mtx '() '())
    97                 (let ((mtx (car ?mtx))
    98                       (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    99                       (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    100                   (values mtx lock-args unlock-args) ) ) )
    101           (lambda (?mtx ?lock-args ?unlock-args)
    102             `(,_let ((,mtxvar ,?mtx))
    103                (,_let ((,?var (,_mutex-specific ,mtxvar)))
    104                  (,_dynamic-wind
    105                    (,_lambda () (,_mutex-lock! ,mtxvar ,@?lock-args))
    106                    (,_lambda () ,@?body)
    107                    (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) )
     84  (er-macro-transformer
     85    (lambda (frm rnm cmp)
     86      (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
     87      (let ((_dynamic-wind (rnm 'dynamic-wind))
     88            (_let (rnm 'let))
     89            (_lambda (rnm 'lambda))
     90            (_mutex-unlock! (rnm 'mutex-unlock!))
     91            (_mutex-specific (rnm 'mutex-specific))
     92            (_mutex-lock! (rnm 'mutex-lock!))
     93            (mtxvar (rnm (gensym))))
     94        (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)) )
     95          (call-with-values
     96            (lambda ()
     97              (if (not (pair? ?mtx)) (values ?mtx '() '())
     98                  (let ((mtx (car ?mtx))
     99                        (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     100                        (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     101                    (values mtx lock-args unlock-args) ) ) )
     102            (lambda (?mtx ?lock-args ?unlock-args)
     103              `(,_let ((,mtxvar ,?mtx))
     104                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
     105                   (,_dynamic-wind
     106                     (,_lambda () (,_mutex-lock! ,mtxvar ,@?lock-args))
     107                     (,_lambda () ,@?body)
     108                     (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) ) )
    108109
    109110(define-syntax call/synch
     
    160161
    161162(define-syntax let/synch
    162   (lambda (frm rnm cmp)
    163     (##sys#check-syntax 'let/synch frm '(_ list . _))
    164     (let ((_synch-with (rnm 'synch-with)))
    165       (let* ((?body (cddr frm))
    166              (res (let loop ((bnds (cadr frm)))
    167                     (if (null? bnds) ?body
    168                         (let ((?bnd (car bnds)))
    169                           (##sys#check-syntax 'let/synch ?bnd '(variable . _))
    170                           `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
    171         (car res) ) ) ) )
     163  (er-macro-transformer
     164    (lambda (frm rnm cmp)
     165      (##sys#check-syntax 'let/synch frm '(_ list . _))
     166      (let ((_synch-with (rnm 'synch-with)))
     167        (let* ((?body (cddr frm))
     168               (res (let loop ((bnds (cadr frm)))
     169                      (if (null? bnds) ?body
     170                          (let ((?bnd (car bnds)))
     171                            (##sys#check-syntax 'let/synch ?bnd '(variable . _))
     172                            `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
     173          (car res) ) ) ) ) )
    172174
    173175(define-syntax set!/synch
    174   (lambda (frm rnm cmp)
    175     (##sys#check-syntax 'set!/synch frm '(_ pair . _))
    176     (let ((_synch-with (rnm 'synch-with))
    177           (_mutex-specific (rnm 'mutex-specific))
    178           (_mutex-specific-set! (rnm 'mutex-specific-set!))
    179           (_begin (rnm 'begin)))
    180       (let ((?bnd (cadr frm)) (?body (cddr frm)))
    181         (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    182           `(,_synch-with ,?mtx ,?var
    183              (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
    184              (,_mutex-specific ,?mtx) ) ) ) ) ) )
     176  (er-macro-transformer
     177    (lambda (frm rnm cmp)
     178      (##sys#check-syntax 'set!/synch frm '(_ pair . _))
     179      (let ((_synch-with (rnm 'synch-with))
     180            (_mutex-specific (rnm 'mutex-specific))
     181            (_mutex-specific-set! (rnm 'mutex-specific-set!))
     182            (_begin (rnm 'begin)))
     183        (let ((?bnd (cadr frm)) (?body (cddr frm)))
     184          (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
     185            `(,_synch-with ,?mtx ,?var
     186               (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
     187               (,_mutex-specific ,?mtx) ) ) ) ) ) ) )
    185188
    186189(define-syntax synch/lock
     
    211214
    212215(define-syntax object/synch
    213   (lambda (frm rnm cmp)
    214     (##sys#check-syntax 'object/synch frm '(_ _ . _))
    215     (let ((_synch-with (rnm 'synch-with))
    216           (_>< (rnm '><))
    217           (var (rnm (gensym)))
    218           (mtx (cadr frm)))
    219       (let body-loop ((unparsed (cddr frm)) (parsed '()))
    220         (if (not (null? unparsed))
    221             (let ((expr (car unparsed))
    222                   (next (cdr unparsed)))
    223               (let expr-loop ((rest expr) (parsedexpr '()))
    224                 (cond ((null? rest)
    225                         (body-loop next (cons (reverse parsedexpr) parsed)))
    226                       ((pair? rest)
    227                         (let ((arg (car rest))
    228                               (next (cdr rest)))
    229                           (if (cmp _>< arg)
    230                               (expr-loop next (cons var parsedexpr))
    231                               (expr-loop next (cons arg parsedexpr)) ) ))
    232                       ((cmp _>< rest)
    233                         (body-loop next (cons var parsed)))
    234                       (else
    235                         (body-loop next (cons rest parsed))) ) ) )
    236             `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
     216  (er-macro-transformer
     217    (lambda (frm rnm cmp)
     218      (##sys#check-syntax 'object/synch frm '(_ _ . _))
     219      (let ((_synch-with (rnm 'synch-with))
     220            (_>< (rnm '><))
     221            (var (rnm (gensym)))
     222            (mtx (cadr frm)))
     223        (let body-loop ((unparsed (cddr frm)) (parsed '()))
     224          (if (not (null? unparsed))
     225              (let ((expr (car unparsed))
     226                    (next (cdr unparsed)))
     227                (let expr-loop ((rest expr) (parsedexpr '()))
     228                  (cond ((null? rest)
     229                          (body-loop next (cons (reverse parsedexpr) parsed)))
     230                        ((pair? rest)
     231                          (let ((arg (car rest))
     232                                (next (cdr rest)))
     233                            (if (cmp _>< arg)
     234                                (expr-loop next (cons var parsedexpr))
     235                                (expr-loop next (cons arg parsedexpr)) ) ))
     236                        ((cmp _>< rest)
     237                          (body-loop next (cons var parsed)))
     238                        (else
     239                          (body-loop next (cons rest parsed))) ) ) )
     240              `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
    237241
    238242(define-syntax record/synch
    239   (lambda (frm rnm cmp)
    240     (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
    241     (let ((_synch (rnm 'synch)))
    242       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    243         `(,_synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     243  (er-macro-transformer
     244    (lambda (frm rnm cmp)
     245      (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
     246      (let ((_synch (rnm 'synch)))
     247        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     248          `(,_synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    244249
    245250(define-syntax record-synch/lock
    246   (lambda (frm rnm cmp)
    247     (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
    248     (let ((_synch/lock (rnm 'synch/lock)))
    249       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    250         `(,_synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     251  (er-macro-transformer
     252    (lambda (frm rnm cmp)
     253      (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
     254      (let ((_synch/lock (rnm 'synch/lock)))
     255        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     256          `(,_synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    251257
    252258(define-syntax record-synch/unlock
    253   (lambda (frm rnm cmp)
    254     (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
    255     (let ((_synch/unlock (rnm 'synch/unlock)))
    256       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    257         `(,_synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     259  (er-macro-transformer
     260    (lambda (frm rnm cmp)
     261      (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
     262      (let ((_synch/unlock (rnm 'synch/unlock)))
     263        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     264          `(,_synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    258265
    259266
     
    274281
    275282(define-syntax %*synch-with
    276   (lambda (frm rnm cmp)
    277     (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
    278     (let ((_call-with-values (rnm 'call-with-values))
    279           (_mutex-specific (rnm 'mutex-specific))
    280           (_mutex-lock! (rnm 'mutex-lock!))
    281           (_mutex-unlock! (rnm 'mutex-unlock!))
    282           (_let (rnm 'let))
    283           (_apply (rnm 'apply))
    284           (_values (rnm 'values))
    285           (_lambda (rnm 'lambda))
    286           (_ret (rnm 'ret))
    287           (mtxvar (rnm (gensym))))
    288       (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)))
    289         (call-with-values
    290           (lambda ()
    291             (if (not (pair? ?mtx)) (values ?mtx '() '())
    292                 (let ((mtx (car ?mtx))
    293                       (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    294                       (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    295                   (values mtx lock-args unlock-args) ) ) )
    296           (lambda (?mtx ?lock-args ?unlock-args)
     283  (er-macro-transformer
     284    (lambda (frm rnm cmp)
     285      (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
     286      (let ((_call-with-values (rnm 'call-with-values))
     287            (_mutex-specific (rnm 'mutex-specific))
     288            (_mutex-lock! (rnm 'mutex-lock!))
     289            (_mutex-unlock! (rnm 'mutex-unlock!))
     290            (_let (rnm 'let))
     291            (_apply (rnm 'apply))
     292            (_values (rnm 'values))
     293            (_lambda (rnm 'lambda))
     294            (_ret (rnm 'ret))
     295            (mtxvar (rnm (gensym))))
     296        (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)))
     297          (call-with-values
     298            (lambda ()
     299              (if (not (pair? ?mtx)) (values ?mtx '() '())
     300                  (let ((mtx (car ?mtx))
     301                        (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     302                        (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     303                    (values mtx lock-args unlock-args) ) ) )
     304            (lambda (?mtx ?lock-args ?unlock-args)
     305              `(,_let ((,mtxvar ,?mtx))
     306                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
     307                   (,_mutex-lock! ,mtxvar ,@?lock-args)
     308                   (,_call-with-values
     309                     (,_lambda () ,@?body)
     310                     (,_lambda ,_ret
     311                       (,_mutex-unlock! ,mtxvar ,@?unlock-args)
     312                       (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) ) )
     313
     314(define-syntax %synch
     315        (syntax-rules ()
     316                ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
     317
     318(define-syntax %synch-with
     319        (syntax-rules ()
     320                ((_ ?mtx ?var ?body ...) (%*synch-with ?mtx ?var ?body ...) ) ) )
     321
     322(define-syntax %call/synch
     323        (syntax-rules ()
     324                ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
     325
     326(define-syntax %call-with/synch
     327        (syntax-rules ()
     328                ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
     329
     330(define-syntax %apply/synch
     331        (syntax-rules ()
     332                ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
     333
     334(define-syntax %apply-with/synch
     335        (syntax-rules ()
     336                ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
     337
     338(define-syntax %let/synch
     339  (er-macro-transformer
     340    (lambda (frm rnm cmp)
     341      (##sys#check-syntax '%let/synch frm '(_ list . _))
     342      (let ((_%synch-with (rnm '%synch-with)))
     343        (let ((?body (cddr frm)))
     344          (car
     345            (let loop ((?bnds (cadr frm)))
     346              (if (not (null? ?bnds))
     347                  (let ((bnd (car ?bnds)))
     348                    (##sys#check-syntax '%let/synch bnd '(variable _))
     349                    `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
     350                  ?body ) ) ) ) ) ) ) )
     351
     352(define-syntax %set!/synch
     353  (er-macro-transformer
     354    (lambda (frm rnm cmp)
     355      (##sys#check-syntax '%set!/synch frm '(_ pair . _))
     356      (let ((_%synch-with (rnm '%synch-with))
     357            (_mutex-specific (rnm 'mutex-specific))
     358            (_mutex-specific-set! (rnm 'mutex-specific-set!))
     359            (_let (rnm 'let))
     360            (_begin (rnm 'begin))
     361            (mtxvar (rnm (gensym))))
     362        (let ((?bnd (cadr frm)) (?body (cddr frm)))
     363          (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    297364            `(,_let ((,mtxvar ,?mtx))
    298                (,_let ((,?var (,_mutex-specific ,mtxvar)))
    299                  (,_mutex-lock! ,mtxvar ,@?lock-args)
    300                  (,_call-with-values
    301                    (,_lambda () ,@?body)
    302                    (,_lambda ,_ret
    303                      (,_mutex-unlock! ,mtxvar ,@?unlock-args)
    304                      (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) )
    305 
    306 (define-syntax %synch
    307         (syntax-rules ()
    308                 ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
    309 
    310 (define-syntax %synch-with
    311         (syntax-rules ()
    312                 ((_ ?mtx ?var ?body ...) (%*synch-with ?mtx ?var ?body ...) ) ) )
    313 
    314 (define-syntax %call/synch
    315         (syntax-rules ()
    316                 ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
    317 
    318 (define-syntax %call-with/synch
    319         (syntax-rules ()
    320                 ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
    321 
    322 (define-syntax %apply/synch
    323         (syntax-rules ()
    324                 ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
    325 
    326 (define-syntax %apply-with/synch
    327         (syntax-rules ()
    328                 ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
    329 
    330 (define-syntax %let/synch
    331   (lambda (frm rnm cmp)
    332     (##sys#check-syntax '%let/synch frm '(_ list . _))
    333     (let ((_%synch-with (rnm '%synch-with)))
    334       (let ((?body (cddr frm)))
    335         (car
    336           (let loop ((?bnds (cadr frm)))
    337             (if (not (null? ?bnds))
    338                 (let ((bnd (car ?bnds)))
    339                   (##sys#check-syntax '%let/synch bnd '(variable _))
    340                   `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
    341                 ?body ) ) ) ) ) ) )
    342 
    343 (define-syntax %set!/synch
    344   (lambda (frm rnm cmp)
    345     (##sys#check-syntax '%set!/synch frm '(_ pair . _))
    346     (let ((_%synch-with (rnm '%synch-with))
    347           (_mutex-specific (rnm 'mutex-specific))
    348           (_mutex-specific-set! (rnm 'mutex-specific-set!))
    349           (_let (rnm 'let))
    350           (_begin (rnm 'begin))
    351           (mtxvar (rnm (gensym))))
    352       (let ((?bnd (cadr frm)) (?body (cddr frm)))
    353         (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    354           `(,_let ((,mtxvar ,?mtx))
    355              (,_%synch-with ,mtxvar ,?var
    356                (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
    357                (,_mutex-specific ,mtxvar) ) ) ) ) ) ) )
     365               (,_%synch-with ,mtxvar ,?var
     366                 (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
     367                 (,_mutex-specific ,mtxvar) ) ) ) ) ) ) ) )
    358368
    359369(define-syntax %synch/lock
     
    386396
    387397(define-syntax %object/synch
    388   (lambda (frm rnm cmp)
    389     (##sys#check-syntax '%object/synch frm '(_ _ . _))
    390     (let ((_%synch-with (rnm '%synch-with))
    391           (_>< (rnm '><))
    392           (var (rnm (gensym)))
    393           (mtx (cadr frm)))
    394       (let body-loop ((unparsed (cddr frm)) (parsed '()))
    395         (if (not (null? unparsed))
    396             (let ((expr (car unparsed))
    397                   (next (cdr unparsed)))
    398               (let expr-loop ((rest expr) (parsedexpr '()))
    399                 (cond ((null? rest)
    400                         (body-loop next (cons (reverse parsedexpr) parsed)))
    401                       ((pair? rest)
    402                         (let ((arg (car rest))
    403                               (next (cdr rest)))
    404                           (if (cmp _>< arg)
    405                               (expr-loop next (cons var parsedexpr))
    406                               (expr-loop next (cons arg parsedexpr)) ) ))
    407                       ((cmp _>< rest)
    408                         (body-loop next (cons var parsed)))
    409                       (else
    410                         (body-loop next (cons rest parsed))) ) ) )
    411             `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
     398  (er-macro-transformer
     399    (lambda (frm rnm cmp)
     400      (##sys#check-syntax '%object/synch frm '(_ _ . _))
     401      (let ((_%synch-with (rnm '%synch-with))
     402            (_>< (rnm '><))
     403            (var (rnm (gensym)))
     404            (mtx (cadr frm)))
     405        (let body-loop ((unparsed (cddr frm)) (parsed '()))
     406          (if (not (null? unparsed))
     407              (let ((expr (car unparsed))
     408                    (next (cdr unparsed)))
     409                (let expr-loop ((rest expr) (parsedexpr '()))
     410                  (cond ((null? rest)
     411                          (body-loop next (cons (reverse parsedexpr) parsed)))
     412                        ((pair? rest)
     413                          (let ((arg (car rest))
     414                                (next (cdr rest)))
     415                            (if (cmp _>< arg)
     416                                (expr-loop next (cons var parsedexpr))
     417                                (expr-loop next (cons arg parsedexpr)) ) ))
     418                        ((cmp _>< rest)
     419                          (body-loop next (cons var parsed)))
     420                        (else
     421                          (body-loop next (cons rest parsed))) ) ) )
     422              `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
    412423
    413424(define-syntax %record/synch
    414   (lambda (frm rnm cmp)
    415     (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
    416     (let ((_%synch (rnm '%synch)))
    417       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    418         `(,_%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) )
     425  (er-macro-transformer
     426    (lambda (frm rnm cmp)
     427      (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
     428      (let ((_%synch (rnm '%synch)))
     429        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     430          `(,_%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) ) )
    419431
    420432(define-syntax %record-synch/lock
     433  (er-macro-transformer
    421434  (lambda (frm rnm cmp)
    422435    (##sys#check-syntax '%record-synch/lock frm '(_ symbol _ . _))
    423436    (let ((_%synch/lock (rnm '%synch/lock)))
    424437      (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    425         `(,_%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     438        `(,_%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    426439
    427440(define-syntax %record-synch/unlock
    428   (lambda (frm rnm cmp)
    429     (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
    430     (let ((_%synch/unlock (rnm '%synch/unlock)))
    431       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    432         `(,_%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     441  (er-macro-transformer
     442    (lambda (frm rnm cmp)
     443      (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
     444      (let ((_%synch/unlock (rnm '%synch/unlock)))
     445        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     446          `(,_%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    433447
    434448
     
    457471
    458472(define-syntax define-constructor/synch
    459   (lambda (frm rnm cmp)
    460     (let ((_define (rnm 'define))
    461           (_apply (rnm 'apply))
    462           (_make-object/synch (rnm 'make-object/synch)) )
    463       (let* ((prcnam (cadr frm))
    464              (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
    465              (newnam (synchsym prcnam)) )
    466         `(,_define (,newnam . args)
    467            (,_make-object/synch (,_apply ,prcnam args) ,@id)) ) ) ) )
     473  (er-macro-transformer
     474    (lambda (frm rnm cmp)
     475      (##sys#check-syntax 'define-constructor/synch frm '(_ symbol . _))
     476      (let ((_define (rnm 'define))
     477            (_apply (rnm 'apply))
     478            (_make-object/synch (rnm 'make-object/synch)) )
     479        (let* ((prcnam (cadr frm))
     480               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
     481               (newnam (synchsym prcnam)) )
     482          `(,_define (,newnam . args)
     483             (,_make-object/synch (,_apply ,prcnam args) ,@id)) ) ) ) ) )
    468484 
    469485;;
    470486
    471487(define-syntax define-predicate/synch
    472   (lambda (frm rnm cmp)
    473     (let ((_define (rnm 'define))
    474           (_object?/synch (rnm 'object?/synch)) )
    475       (let* ((prcnam (cadr frm))
    476              (newnam (synchsym prcnam)) )
    477         `(,_define (,newnam obj) (,_object?/synch obj ,prcnam)) ) ) ) )
    478 
    479 ;;
    480 
    481 ;operant must be the 1st argument
     488  (er-macro-transformer
     489    (lambda (frm rnm cmp)
     490      (##sys#check-syntax 'define-predicate/synch frm '(_ symbol))
     491      (let ((_define (rnm 'define))
     492            (_object?/synch (rnm 'object?/synch)) )
     493        (let* ((prcnam (cadr frm))
     494               (newnam (synchsym prcnam)) )
     495          `(,_define (,newnam obj) (,_object?/synch obj ,prcnam)) ) ) ) ) )
     496
     497;;
     498
     499;operand must be the 1st argument
    482500
    483501(define-syntax define-operation/synch
    484   (lambda (frm rnm cmp)
    485     (let ((_define (rnm 'define))
    486           (_apply (rnm 'apply))
    487           (_let (rnm 'let))
    488           (_car (rnm 'car))
    489           (_cdr (rnm 'cdr))
    490           (_if (rnm 'if))
    491           (_pair? (rnm 'pair?))
    492           (_synch-with (rnm 'synch-with))
    493           (_check-mutex+object (rnm 'check-mutex+object)) )
    494       (let* ((prcnam (cadr frm))
    495              (newnam (synchsym prcnam)) )
    496         `(,_define (,newnam mtx+obj . args)
    497            (,_let ((mtx (,_if (,_pair? mtx+obj) (,_car mtx+obj) mtx+obj)))
    498              (,_check-mutex+object ',newnam mtx 'object/synch)
    499              (,_synch-with mtx+obj obj (,_apply ,prcnam obj args)))) ) ) ) )
    500 
    501 ;;
    502 
    503 ;operant must be the 1st argument
     502  (er-macro-transformer
     503    (lambda (frm rnm cmp)
     504      (##sys#check-syntax 'define-operation/synch frm '(_ symbol))
     505      (let ((_define (rnm 'define))
     506            (_apply (rnm 'apply))
     507            (_let (rnm 'let))
     508            (_car (rnm 'car))
     509            (_cdr (rnm 'cdr))
     510            (_if (rnm 'if))
     511            (_pair? (rnm 'pair?))
     512            (_synch-with (rnm 'synch-with))
     513            (_check-mutex+object (rnm 'check-mutex+object))
     514            (_mtx+obj (rnm 'mtx+obj))
     515            (_args (rnm 'args))
     516            (_mtx (rnm 'mtx)) )
     517        (let* ((prcnam  (cadr frm))
     518               (newnam (synchsym prcnam)) )
     519          `(,_define (,newnam ,_mtx+obj . ,_args)
     520             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     521               (,_check-mutex+object ',newnam ,_mtx 'object/synch)
     522               (,_synch-with ,_mtx+obj obj (,_apply ,prcnam obj ,_args)))) ) ) ) ) )
     523
     524;;
     525
     526;operand must be the 1st argument
    504527
    505528(define-syntax define-operation/%synch
    506   (lambda (frm rnm cmp)
    507     (define (%synchsym sym) (string->symbol (string-append (symbol->string sym) "/%synch")))
    508     (let ((_define (rnm 'define))
    509           (_apply (rnm 'apply))
    510           (_let (rnm 'let))
    511           (_car (rnm 'car))
    512           (_cdr (rnm 'cdr))
    513           (_if (rnm 'if))
    514           (_pair? (rnm 'pair?))
    515           (_%synch-with (rnm '%synch-with))
    516           (_check-mutex+object (rnm 'check-mutex+object)) )
    517       (let* ((prcnam (cadr frm))
    518              (newnam (%synchsym prcnam)) )
    519         `(,_define (,newnam mtx+obj . args)
    520            (,_let ((mtx (,_if (,_pair? mtx+obj) (,_car mtx+obj) mtx+obj)))
    521              (,_%synch-with mtx+obj obj (,_apply ,prcnam obj args)))) ) ) ) )
     529  (er-macro-transformer
     530    (lambda (frm rnm cmp)
     531      (define (%synchsym sym) (string->symbol (string-append (symbol->string sym) "/%synch")))
     532      (##sys#check-syntax 'define-operation/%synch frm '(_ symbol))
     533      (let ((_define (rnm 'define))
     534            (_apply (rnm 'apply))
     535            (_let (rnm 'let))
     536            (_car (rnm 'car))
     537            (_cdr (rnm 'cdr))
     538            (_if (rnm 'if))
     539            (_pair? (rnm 'pair?))
     540            (_%synch-with (rnm '%synch-with))
     541            (_check-mutex+object (rnm 'check-mutex+object))
     542            (_mtx+obj (rnm 'mtx+obj))
     543            (_args (rnm 'args))
     544            (_mtx (rnm 'mtx)) )
     545        (let* ((prcnam (cadr frm))
     546               (newnam (%synchsym prcnam)) )
     547          `(,_define (,newnam ,_mtx+obj . ,_args)
     548             (,_%synch-with ,_mtx+obj obj (,_apply ,prcnam obj ,_args))) ) ) ) ) )
    522549
    523550) ;module synch
  • release/4/synch/trunk/synch.scm

    r16031 r16032  
    8282
    8383(define-syntax synch-with
    84   (lambda (frm rnm cmp)
    85     (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
    86     (let ((_dynamic-wind (rnm 'dynamic-wind))
    87           (_let (rnm 'let))
    88           (_lambda (rnm 'lambda))
    89           (_mutex-unlock! (rnm 'mutex-unlock!))
    90           (_mutex-specific (rnm 'mutex-specific))
    91           (_mutex-lock! (rnm 'mutex-lock!))
    92           (mtxvar (rnm (gensym))))
    93       (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)) )
    94         (call-with-values
    95           (lambda ()
    96             (if (not (pair? ?mtx)) (values ?mtx '() '())
    97                 (let ((mtx (car ?mtx))
    98                       (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    99                       (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    100                   (values mtx lock-args unlock-args) ) ) )
    101           (lambda (?mtx ?lock-args ?unlock-args)
    102             `(,_let ((,mtxvar ,?mtx))
    103                (,_let ((,?var (,_mutex-specific ,mtxvar)))
    104                  (,_dynamic-wind
    105                    (,_lambda () (,_mutex-lock! ,mtxvar ,@?lock-args))
    106                    (,_lambda () ,@?body)
    107                    (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) )
     84  (er-macro-transformer
     85    (lambda (frm rnm cmp)
     86      (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
     87      (let ((_dynamic-wind (rnm 'dynamic-wind))
     88            (_let (rnm 'let))
     89            (_lambda (rnm 'lambda))
     90            (_mutex-unlock! (rnm 'mutex-unlock!))
     91            (_mutex-specific (rnm 'mutex-specific))
     92            (_mutex-lock! (rnm 'mutex-lock!))
     93            (mtxvar (rnm (gensym))))
     94        (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)) )
     95          (call-with-values
     96            (lambda ()
     97              (if (not (pair? ?mtx)) (values ?mtx '() '())
     98                  (let ((mtx (car ?mtx))
     99                        (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     100                        (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     101                    (values mtx lock-args unlock-args) ) ) )
     102            (lambda (?mtx ?lock-args ?unlock-args)
     103              `(,_let ((,mtxvar ,?mtx))
     104                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
     105                   (,_dynamic-wind
     106                     (,_lambda () (,_mutex-lock! ,mtxvar ,@?lock-args))
     107                     (,_lambda () ,@?body)
     108                     (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) ) )
    108109
    109110(define-syntax call/synch
     
    160161
    161162(define-syntax let/synch
    162   (lambda (frm rnm cmp)
    163     (##sys#check-syntax 'let/synch frm '(_ list . _))
    164     (let ((_synch-with (rnm 'synch-with)))
    165       (let* ((?body (cddr frm))
    166              (res (let loop ((bnds (cadr frm)))
    167                     (if (null? bnds) ?body
    168                         (let ((?bnd (car bnds)))
    169                           (##sys#check-syntax 'let/synch ?bnd '(variable . _))
    170                           `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
    171         (car res) ) ) ) )
     163  (er-macro-transformer
     164    (lambda (frm rnm cmp)
     165      (##sys#check-syntax 'let/synch frm '(_ list . _))
     166      (let ((_synch-with (rnm 'synch-with)))
     167        (let* ((?body (cddr frm))
     168               (res (let loop ((bnds (cadr frm)))
     169                      (if (null? bnds) ?body
     170                          (let ((?bnd (car bnds)))
     171                            (##sys#check-syntax 'let/synch ?bnd '(variable . _))
     172                            `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
     173          (car res) ) ) ) ) )
    172174
    173175(define-syntax set!/synch
    174   (lambda (frm rnm cmp)
    175     (##sys#check-syntax 'set!/synch frm '(_ pair . _))
    176     (let ((_synch-with (rnm 'synch-with))
    177           (_mutex-specific (rnm 'mutex-specific))
    178           (_mutex-specific-set! (rnm 'mutex-specific-set!))
    179           (_begin (rnm 'begin)))
    180       (let ((?bnd (cadr frm)) (?body (cddr frm)))
    181         (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    182           `(,_synch-with ,?mtx ,?var
    183              (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
    184              (,_mutex-specific ,?mtx) ) ) ) ) ) )
     176  (er-macro-transformer
     177    (lambda (frm rnm cmp)
     178      (##sys#check-syntax 'set!/synch frm '(_ pair . _))
     179      (let ((_synch-with (rnm 'synch-with))
     180            (_mutex-specific (rnm 'mutex-specific))
     181            (_mutex-specific-set! (rnm 'mutex-specific-set!))
     182            (_begin (rnm 'begin)))
     183        (let ((?bnd (cadr frm)) (?body (cddr frm)))
     184          (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
     185            `(,_synch-with ,?mtx ,?var
     186               (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
     187               (,_mutex-specific ,?mtx) ) ) ) ) ) ) )
    185188
    186189(define-syntax synch/lock
     
    211214
    212215(define-syntax object/synch
    213   (lambda (frm rnm cmp)
    214     (##sys#check-syntax 'object/synch frm '(_ _ . _))
    215     (let ((_synch-with (rnm 'synch-with))
    216           (_>< (rnm '><))
    217           (var (rnm (gensym)))
    218           (mtx (cadr frm)))
    219       (let body-loop ((unparsed (cddr frm)) (parsed '()))
    220         (if (not (null? unparsed))
    221             (let ((expr (car unparsed))
    222                   (next (cdr unparsed)))
    223               (let expr-loop ((rest expr) (parsedexpr '()))
    224                 (cond ((null? rest)
    225                         (body-loop next (cons (reverse parsedexpr) parsed)))
    226                       ((pair? rest)
    227                         (let ((arg (car rest))
    228                               (next (cdr rest)))
    229                           (if (cmp _>< arg)
    230                               (expr-loop next (cons var parsedexpr))
    231                               (expr-loop next (cons arg parsedexpr)) ) ))
    232                       ((cmp _>< rest)
    233                         (body-loop next (cons var parsed)))
    234                       (else
    235                         (body-loop next (cons rest parsed))) ) ) )
    236             `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
     216  (er-macro-transformer
     217    (lambda (frm rnm cmp)
     218      (##sys#check-syntax 'object/synch frm '(_ _ . _))
     219      (let ((_synch-with (rnm 'synch-with))
     220            (_>< (rnm '><))
     221            (var (rnm (gensym)))
     222            (mtx (cadr frm)))
     223        (let body-loop ((unparsed (cddr frm)) (parsed '()))
     224          (if (not (null? unparsed))
     225              (let ((expr (car unparsed))
     226                    (next (cdr unparsed)))
     227                (let expr-loop ((rest expr) (parsedexpr '()))
     228                  (cond ((null? rest)
     229                          (body-loop next (cons (reverse parsedexpr) parsed)))
     230                        ((pair? rest)
     231                          (let ((arg (car rest))
     232                                (next (cdr rest)))
     233                            (if (cmp _>< arg)
     234                                (expr-loop next (cons var parsedexpr))
     235                                (expr-loop next (cons arg parsedexpr)) ) ))
     236                        ((cmp _>< rest)
     237                          (body-loop next (cons var parsed)))
     238                        (else
     239                          (body-loop next (cons rest parsed))) ) ) )
     240              `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
    237241
    238242(define-syntax record/synch
    239   (lambda (frm rnm cmp)
    240     (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
    241     (let ((_synch (rnm 'synch)))
    242       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    243         `(,_synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     243  (er-macro-transformer
     244    (lambda (frm rnm cmp)
     245      (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
     246      (let ((_synch (rnm 'synch)))
     247        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     248          `(,_synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    244249
    245250(define-syntax record-synch/lock
    246   (lambda (frm rnm cmp)
    247     (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
    248     (let ((_synch/lock (rnm 'synch/lock)))
    249       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    250         `(,_synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     251  (er-macro-transformer
     252    (lambda (frm rnm cmp)
     253      (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
     254      (let ((_synch/lock (rnm 'synch/lock)))
     255        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     256          `(,_synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    251257
    252258(define-syntax record-synch/unlock
    253   (lambda (frm rnm cmp)
    254     (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
    255     (let ((_synch/unlock (rnm 'synch/unlock)))
    256       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    257         `(,_synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     259  (er-macro-transformer
     260    (lambda (frm rnm cmp)
     261      (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
     262      (let ((_synch/unlock (rnm 'synch/unlock)))
     263        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     264          `(,_synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    258265
    259266
     
    274281
    275282(define-syntax %*synch-with
    276   (lambda (frm rnm cmp)
    277     (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
    278     (let ((_call-with-values (rnm 'call-with-values))
    279           (_mutex-specific (rnm 'mutex-specific))
    280           (_mutex-lock! (rnm 'mutex-lock!))
    281           (_mutex-unlock! (rnm 'mutex-unlock!))
    282           (_let (rnm 'let))
    283           (_apply (rnm 'apply))
    284           (_values (rnm 'values))
    285           (_lambda (rnm 'lambda))
    286           (_ret (rnm 'ret))
    287           (mtxvar (rnm (gensym))))
    288       (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)))
    289         (call-with-values
    290           (lambda ()
    291             (if (not (pair? ?mtx)) (values ?mtx '() '())
    292                 (let ((mtx (car ?mtx))
    293                       (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
    294                       (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
    295                   (values mtx lock-args unlock-args) ) ) )
    296           (lambda (?mtx ?lock-args ?unlock-args)
     283  (er-macro-transformer
     284    (lambda (frm rnm cmp)
     285      (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
     286      (let ((_call-with-values (rnm 'call-with-values))
     287            (_mutex-specific (rnm 'mutex-specific))
     288            (_mutex-lock! (rnm 'mutex-lock!))
     289            (_mutex-unlock! (rnm 'mutex-unlock!))
     290            (_let (rnm 'let))
     291            (_apply (rnm 'apply))
     292            (_values (rnm 'values))
     293            (_lambda (rnm 'lambda))
     294            (_ret (rnm 'ret))
     295            (mtxvar (rnm (gensym))))
     296        (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)))
     297          (call-with-values
     298            (lambda ()
     299              (if (not (pair? ?mtx)) (values ?mtx '() '())
     300                  (let ((mtx (car ?mtx))
     301                        (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
     302                        (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
     303                    (values mtx lock-args unlock-args) ) ) )
     304            (lambda (?mtx ?lock-args ?unlock-args)
     305              `(,_let ((,mtxvar ,?mtx))
     306                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
     307                   (,_mutex-lock! ,mtxvar ,@?lock-args)
     308                   (,_call-with-values
     309                     (,_lambda () ,@?body)
     310                     (,_lambda ,_ret
     311                       (,_mutex-unlock! ,mtxvar ,@?unlock-args)
     312                       (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) ) )
     313
     314(define-syntax %synch
     315        (syntax-rules ()
     316                ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
     317
     318(define-syntax %synch-with
     319        (syntax-rules ()
     320                ((_ ?mtx ?var ?body ...) (%*synch-with ?mtx ?var ?body ...) ) ) )
     321
     322(define-syntax %call/synch
     323        (syntax-rules ()
     324                ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
     325
     326(define-syntax %call-with/synch
     327        (syntax-rules ()
     328                ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
     329
     330(define-syntax %apply/synch
     331        (syntax-rules ()
     332                ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
     333
     334(define-syntax %apply-with/synch
     335        (syntax-rules ()
     336                ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
     337
     338(define-syntax %let/synch
     339  (er-macro-transformer
     340    (lambda (frm rnm cmp)
     341      (##sys#check-syntax '%let/synch frm '(_ list . _))
     342      (let ((_%synch-with (rnm '%synch-with)))
     343        (let ((?body (cddr frm)))
     344          (car
     345            (let loop ((?bnds (cadr frm)))
     346              (if (not (null? ?bnds))
     347                  (let ((bnd (car ?bnds)))
     348                    (##sys#check-syntax '%let/synch bnd '(variable _))
     349                    `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
     350                  ?body ) ) ) ) ) ) ) )
     351
     352(define-syntax %set!/synch
     353  (er-macro-transformer
     354    (lambda (frm rnm cmp)
     355      (##sys#check-syntax '%set!/synch frm '(_ pair . _))
     356      (let ((_%synch-with (rnm '%synch-with))
     357            (_mutex-specific (rnm 'mutex-specific))
     358            (_mutex-specific-set! (rnm 'mutex-specific-set!))
     359            (_let (rnm 'let))
     360            (_begin (rnm 'begin))
     361            (mtxvar (rnm (gensym))))
     362        (let ((?bnd (cadr frm)) (?body (cddr frm)))
     363          (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    297364            `(,_let ((,mtxvar ,?mtx))
    298                (,_let ((,?var (,_mutex-specific ,mtxvar)))
    299                  (,_mutex-lock! ,mtxvar ,@?lock-args)
    300                  (,_call-with-values
    301                    (,_lambda () ,@?body)
    302                    (,_lambda ,_ret
    303                      (,_mutex-unlock! ,mtxvar ,@?unlock-args)
    304                      (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) )
    305 
    306 (define-syntax %synch
    307         (syntax-rules ()
    308                 ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
    309 
    310 (define-syntax %synch-with
    311         (syntax-rules ()
    312                 ((_ ?mtx ?var ?body ...) (%*synch-with ?mtx ?var ?body ...) ) ) )
    313 
    314 (define-syntax %call/synch
    315         (syntax-rules ()
    316                 ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
    317 
    318 (define-syntax %call-with/synch
    319         (syntax-rules ()
    320                 ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
    321 
    322 (define-syntax %apply/synch
    323         (syntax-rules ()
    324                 ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
    325 
    326 (define-syntax %apply-with/synch
    327         (syntax-rules ()
    328                 ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
    329 
    330 (define-syntax %let/synch
    331   (lambda (frm rnm cmp)
    332     (##sys#check-syntax '%let/synch frm '(_ list . _))
    333     (let ((_%synch-with (rnm '%synch-with)))
    334       (let ((?body (cddr frm)))
    335         (car
    336           (let loop ((?bnds (cadr frm)))
    337             (if (not (null? ?bnds))
    338                 (let ((bnd (car ?bnds)))
    339                   (##sys#check-syntax '%let/synch bnd '(variable _))
    340                   `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
    341                 ?body ) ) ) ) ) ) )
    342 
    343 (define-syntax %set!/synch
    344   (lambda (frm rnm cmp)
    345     (##sys#check-syntax '%set!/synch frm '(_ pair . _))
    346     (let ((_%synch-with (rnm '%synch-with))
    347           (_mutex-specific (rnm 'mutex-specific))
    348           (_mutex-specific-set! (rnm 'mutex-specific-set!))
    349           (_let (rnm 'let))
    350           (_begin (rnm 'begin))
    351           (mtxvar (rnm (gensym))))
    352       (let ((?bnd (cadr frm)) (?body (cddr frm)))
    353         (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
    354           `(,_let ((,mtxvar ,?mtx))
    355              (,_%synch-with ,mtxvar ,?var
    356                (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
    357                (,_mutex-specific ,mtxvar) ) ) ) ) ) ) )
     365               (,_%synch-with ,mtxvar ,?var
     366                 (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
     367                 (,_mutex-specific ,mtxvar) ) ) ) ) ) ) ) )
    358368
    359369(define-syntax %synch/lock
     
    386396
    387397(define-syntax %object/synch
    388   (lambda (frm rnm cmp)
    389     (##sys#check-syntax '%object/synch frm '(_ _ . _))
    390     (let ((_%synch-with (rnm '%synch-with))
    391           (_>< (rnm '><))
    392           (var (rnm (gensym)))
    393           (mtx (cadr frm)))
    394       (let body-loop ((unparsed (cddr frm)) (parsed '()))
    395         (if (not (null? unparsed))
    396             (let ((expr (car unparsed))
    397                   (next (cdr unparsed)))
    398               (let expr-loop ((rest expr) (parsedexpr '()))
    399                 (cond ((null? rest)
    400                         (body-loop next (cons (reverse parsedexpr) parsed)))
    401                       ((pair? rest)
    402                         (let ((arg (car rest))
    403                               (next (cdr rest)))
    404                           (if (cmp _>< arg)
    405                               (expr-loop next (cons var parsedexpr))
    406                               (expr-loop next (cons arg parsedexpr)) ) ))
    407                       ((cmp _>< rest)
    408                         (body-loop next (cons var parsed)))
    409                       (else
    410                         (body-loop next (cons rest parsed))) ) ) )
    411             `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
     398  (er-macro-transformer
     399    (lambda (frm rnm cmp)
     400      (##sys#check-syntax '%object/synch frm '(_ _ . _))
     401      (let ((_%synch-with (rnm '%synch-with))
     402            (_>< (rnm '><))
     403            (var (rnm (gensym)))
     404            (mtx (cadr frm)))
     405        (let body-loop ((unparsed (cddr frm)) (parsed '()))
     406          (if (not (null? unparsed))
     407              (let ((expr (car unparsed))
     408                    (next (cdr unparsed)))
     409                (let expr-loop ((rest expr) (parsedexpr '()))
     410                  (cond ((null? rest)
     411                          (body-loop next (cons (reverse parsedexpr) parsed)))
     412                        ((pair? rest)
     413                          (let ((arg (car rest))
     414                                (next (cdr rest)))
     415                            (if (cmp _>< arg)
     416                                (expr-loop next (cons var parsedexpr))
     417                                (expr-loop next (cons arg parsedexpr)) ) ))
     418                        ((cmp _>< rest)
     419                          (body-loop next (cons var parsed)))
     420                        (else
     421                          (body-loop next (cons rest parsed))) ) ) )
     422              `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
    412423
    413424(define-syntax %record/synch
    414   (lambda (frm rnm cmp)
    415     (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
    416     (let ((_%synch (rnm '%synch)))
    417       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    418         `(,_%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) )
     425  (er-macro-transformer
     426    (lambda (frm rnm cmp)
     427      (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
     428      (let ((_%synch (rnm '%synch)))
     429        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     430          `(,_%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) ) )
    419431
    420432(define-syntax %record-synch/lock
     433  (er-macro-transformer
    421434  (lambda (frm rnm cmp)
    422435    (##sys#check-syntax '%record-synch/lock frm '(_ symbol _ . _))
    423436    (let ((_%synch/lock (rnm '%synch/lock)))
    424437      (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    425         `(,_%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     438        `(,_%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    426439
    427440(define-syntax %record-synch/unlock
    428   (lambda (frm rnm cmp)
    429     (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
    430     (let ((_%synch/unlock (rnm '%synch/unlock)))
    431       (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
    432         `(,_%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
     441  (er-macro-transformer
     442    (lambda (frm rnm cmp)
     443      (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
     444      (let ((_%synch/unlock (rnm '%synch/unlock)))
     445        (let ((?sym (cadr frm)) (?rec (caddr frm)) (?body (cdddr frm)))
     446          `(,_%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
    433447
    434448
     
    457471
    458472(define-syntax define-constructor/synch
    459   (lambda (frm rnm cmp)
    460     (let ((_define (rnm 'define))
    461           (_apply (rnm 'apply))
    462           (_make-object/synch (rnm 'make-object/synch)) )
    463       (let* ((prcnam (cadr frm))
    464              (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
    465              (newnam (synchsym prcnam)) )
    466         `(,_define (,newnam . args)
    467            (,_make-object/synch (,_apply ,prcnam args) ,@id)) ) ) ) )
     473  (er-macro-transformer
     474    (lambda (frm rnm cmp)
     475      (##sys#check-syntax 'define-constructor/synch frm '(_ symbol . _))
     476      (let ((_define (rnm 'define))
     477            (_apply (rnm 'apply))
     478            (_make-object/synch (rnm 'make-object/synch)) )
     479        (let* ((prcnam (cadr frm))
     480               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
     481               (newnam (synchsym prcnam)) )
     482          `(,_define (,newnam . args)
     483             (,_make-object/synch (,_apply ,prcnam args) ,@id)) ) ) ) ) )
    468484 
    469485;;
    470486
    471487(define-syntax define-predicate/synch
    472   (lambda (frm rnm cmp)
    473     (let ((_define (rnm 'define))
    474           (_object?/synch (rnm 'object?/synch)) )
    475       (let* ((prcnam (cadr frm))
    476              (newnam (synchsym prcnam)) )
    477         `(,_define (,newnam obj) (,_object?/synch obj ,prcnam)) ) ) ) )
    478 
    479 ;;
    480 
    481 ;operant must be the 1st argument
     488  (er-macro-transformer
     489    (lambda (frm rnm cmp)
     490      (##sys#check-syntax 'define-predicate/synch frm '(_ symbol))
     491      (let ((_define (rnm 'define))
     492            (_object?/synch (rnm 'object?/synch)) )
     493        (let* ((prcnam (cadr frm))
     494               (newnam (synchsym prcnam)) )
     495          `(,_define (,newnam obj) (,_object?/synch obj ,prcnam)) ) ) ) ) )
     496
     497;;
     498
     499;operand must be the 1st argument
    482500
    483501(define-syntax define-operation/synch
    484   (lambda (frm rnm cmp)
    485     (let ((_define (rnm 'define))
    486           (_apply (rnm 'apply))
    487           (_let (rnm 'let))
    488           (_car (rnm 'car))
    489           (_cdr (rnm 'cdr))
    490           (_if (rnm 'if))
    491           (_pair? (rnm 'pair?))
    492           (_synch-with (rnm 'synch-with))
    493           (_check-mutex+object (rnm 'check-mutex+object)) )
    494       (let* ((prcnam (cadr frm))
    495              (newnam (synchsym prcnam)) )
    496         `(,_define (,newnam mtx+obj . args)
    497            (,_let ((mtx (,_if (,_pair? mtx+obj) (,_car mtx+obj) mtx+obj)))
    498              (,_check-mutex+object ',newnam mtx 'object/synch)
    499              (,_synch-with mtx+obj obj (,_apply ,prcnam obj args)))) ) ) ) )
    500 
    501 ;;
    502 
    503 ;operant must be the 1st argument
     502  (er-macro-transformer
     503    (lambda (frm rnm cmp)
     504      (##sys#check-syntax 'define-operation/synch frm '(_ symbol))
     505      (let ((_define (rnm 'define))
     506            (_apply (rnm 'apply))
     507            (_let (rnm 'let))
     508            (_car (rnm 'car))
     509            (_cdr (rnm 'cdr))
     510            (_if (rnm 'if))
     511            (_pair? (rnm 'pair?))
     512            (_synch-with (rnm 'synch-with))
     513            (_check-mutex+object (rnm 'check-mutex+object))
     514            (_mtx+obj (rnm 'mtx+obj))
     515            (_args (rnm 'args))
     516            (_mtx (rnm 'mtx)) )
     517        (let* ((prcnam  (cadr frm))
     518               (newnam (synchsym prcnam)) )
     519          `(,_define (,newnam ,_mtx+obj . ,_args)
     520             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
     521               (,_check-mutex+object ',newnam ,_mtx 'object/synch)
     522               (,_synch-with ,_mtx+obj obj (,_apply ,prcnam obj ,_args)))) ) ) ) ) )
     523
     524;;
     525
     526;operand must be the 1st argument
    504527
    505528(define-syntax define-operation/%synch
    506   (lambda (frm rnm cmp)
    507     (define (%synchsym sym) (string->symbol (string-append (symbol->string sym) "/%synch")))
    508     (let ((_define (rnm 'define))
    509           (_apply (rnm 'apply))
    510           (_let (rnm 'let))
    511           (_car (rnm 'car))
    512           (_cdr (rnm 'cdr))
    513           (_if (rnm 'if))
    514           (_pair? (rnm 'pair?))
    515           (_%synch-with (rnm '%synch-with))
    516           (_check-mutex+object (rnm 'check-mutex+object)) )
    517       (let* ((prcnam (cadr frm))
    518              (newnam (%synchsym prcnam)) )
    519         `(,_define (,newnam mtx+obj . args)
    520            (,_let ((mtx (,_if (,_pair? mtx+obj) (,_car mtx+obj) mtx+obj)))
    521              (,_%synch-with mtx+obj obj (,_apply ,prcnam obj args)))) ) ) ) )
     529  (er-macro-transformer
     530    (lambda (frm rnm cmp)
     531      (define (%synchsym sym) (string->symbol (string-append (symbol->string sym) "/%synch")))
     532      (##sys#check-syntax 'define-operation/%synch frm '(_ symbol))
     533      (let ((_define (rnm 'define))
     534            (_apply (rnm 'apply))
     535            (_let (rnm 'let))
     536            (_car (rnm 'car))
     537            (_cdr (rnm 'cdr))
     538            (_if (rnm 'if))
     539            (_pair? (rnm 'pair?))
     540            (_%synch-with (rnm '%synch-with))
     541            (_check-mutex+object (rnm 'check-mutex+object))
     542            (_mtx+obj (rnm 'mtx+obj))
     543            (_args (rnm 'args))
     544            (_mtx (rnm 'mtx)) )
     545        (let* ((prcnam (cadr frm))
     546               (newnam (%synchsym prcnam)) )
     547          `(,_define (,newnam ,_mtx+obj . ,_args)
     548             (,_%synch-with ,_mtx+obj obj (,_apply ,prcnam obj ,_args))) ) ) ) ) )
    522549
    523550) ;module synch
Note: See TracChangeset for help on using the changeset viewer.