source: project/release/4/synch/trunk/synch.scm @ 26458

Last change on this file since 26458 was 26458, checked in by Kon Lovett, 8 years ago

Ensure all local vars in operation macros hygenic.

File size: 20.0 KB
Line 
1;;;; synch.scm
2;;;; Kon Lovett, Mar '06
3
4;; Issues
5;;
6;; - syntax checking is minimal so expansion errors are cryptic
7
8(module synch
9
10  (;export
11    ;;
12    synch
13    synch-with
14    call/synch
15    call-with/synch
16    apply/synch
17    apply-with/synch
18    let/synch
19    set!/synch
20    synch/lock
21    synch/unlock
22    object/synch
23    record/synch
24    record-synch/lock
25    record-synch/unlock
26    ;;
27    %synch
28    %synch-with
29    %call/synch
30    %call-with/synch
31    %apply/synch
32    %apply-with/synch
33    %let/synch
34    %set!/synch
35    %synch/lock
36    %synch/unlock
37    %object/synch
38    %record/synch
39    %record-synch/lock
40    %record-synch/unlock
41    ;;
42    make-object/synch
43    object?/synch
44    ;;
45    define-constructor/synch
46    define-predicate/synch
47    (define-operation/synch check-mutex+object)
48    define-operation/%synch)
49
50  (import
51    scheme
52    (only chicken
53      define-for-syntax optional
54      void unless warning gensym dynamic-wind)
55    (only data-structures any?)
56    (only srfi-18
57      thread?
58      make-mutex mutex?
59      mutex-specific mutex-specific-set!
60      mutex-lock! mutex-unlock!
61      mutex-state)
62    (only type-checks define-check+error-type) )
63
64  (import-for-syntax (only data-structures conc))
65
66  (require-library data-structures srfi-18 type-checks)
67
68;;;
69
70(define-for-syntax (recmuxnam nam) (string->symbol (conc nam #\- 'mutex)))
71
72;;; Protected
73
74(define-syntax synch
75        (syntax-rules ()
76                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
77        (let ((mtx ?mtx))
78        (dynamic-wind
79          (lambda () (mutex-lock! mtx ?lock-arg0 ...))
80          (lambda () ?body ...)
81          (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
82                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
83        (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
84                ((_ ?mtx ?body ...)
85        (synch (?mtx () ()) ?body ...) ) ) )
86
87(define-syntax synch-with
88  (er-macro-transformer
89    (lambda (frm rnm cmp)
90      (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
91      (let ((_dynamic-wind (rnm 'dynamic-wind))
92            (_let (rnm 'let))
93            (_lambda (rnm 'lambda))
94            (_mutex-unlock! (rnm 'mutex-unlock!))
95            (_mutex-specific (rnm 'mutex-specific))
96            (_mutex-lock! (rnm 'mutex-lock!))
97            (mtxvar (rnm (gensym))))
98        (let ((?mtx (cadr frm)) (?var (caddr frm)) (?body (cdddr frm)) )
99          (call-with-values
100            (lambda ()
101              (if (not (pair? ?mtx)) (values ?mtx '() '())
102                  (let ((mtx (car ?mtx))
103                        (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
104                        (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
105                    (values mtx lock-args unlock-args) ) ) )
106            (lambda (?mtx ?lock-args ?unlock-args)
107              `(,_let ((,mtxvar ,?mtx))
108                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
109                   (,_dynamic-wind
110                     (,_lambda () (,_mutex-lock! ,mtxvar ,@?lock-args))
111                     (,_lambda () ,@?body)
112                     (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) ) )
113
114(define-syntax call/synch
115        (syntax-rules ()
116                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
117                  (let ((mtx ?mtx))
118                          (dynamic-wind
119                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
120                                  (lambda () (?proc ?arg0 ...))
121                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
122                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
123                  (call/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
124                ((_ ?mtx ?proc ?arg0 ...)
125                  (call/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
126
127(define-syntax call-with/synch
128        (syntax-rules ()
129                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
130                  (let ((mtx ?mtx))
131                          (dynamic-wind
132                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
133                                  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
134                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
135                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
136                  (call-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
137                ((_ ?mtx ?proc ?arg0 ...)
138                  (call-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
139
140(define-syntax apply/synch
141        (syntax-rules ()
142          ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
143                  (let ((mtx ?mtx))
144                          (dynamic-wind
145                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
146                                  (lambda () (apply ?proc ?arg0 ...))
147                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
148          ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
149                  (apply/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
150                ((_ ?mtx ?proc ?arg0 ...)
151                  (apply/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
152
153(define-syntax apply-with/synch
154        (syntax-rules ()
155                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
156                  (let ((mtx ?mtx))
157                          (dynamic-wind
158                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
159                                  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
160                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
161                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
162                  (apply-with/synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
163                ((_ ?mtx ?proc ?arg0 ...)
164                  (apply-with/synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
165
166(define-syntax let/synch
167  (er-macro-transformer
168    (lambda (frm rnm cmp)
169      (##sys#check-syntax 'let/synch frm '(_ list . _))
170      (let ((_synch-with (rnm 'synch-with)))
171        (let* ((?body (cddr frm))
172               (res
173                (let loop ((bnds (cadr frm)))
174                  (if (null? bnds) ?body
175                      (let ((?bnd (car bnds)))
176                        (##sys#check-syntax 'let/synch ?bnd '(variable . _))
177                        `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
178          (car res) ) ) ) ) )
179
180(define-syntax set!/synch
181  (er-macro-transformer
182    (lambda (frm rnm cmp)
183      (##sys#check-syntax 'set!/synch frm '(_ pair . _))
184      (let ((_synch-with (rnm 'synch-with))
185            (_mutex-specific (rnm 'mutex-specific))
186            (_mutex-specific-set! (rnm 'mutex-specific-set!))
187            (_begin (rnm 'begin)))
188        (let ((?bnd (cadr frm))
189              (?body (cddr frm)))
190          (let ((?var (car ?bnd))
191                (?mtx (cadr ?bnd)))
192            `(,_synch-with ,?mtx ,?var
193               (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
194               (,_mutex-specific ,?mtx) ) ) ) ) ) ) )
195
196(define-syntax synch/lock
197        (syntax-rules ()
198                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
199                  (let ((mtx ?mtx) (ok? #f))
200                                (mutex-lock! mtx)
201                                (dynamic-wind
202                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
203                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
204                                        (lambda () (unless ok? (mutex-unlock! mtx)))) ) )
205                ((_ ?mtx ?body ...)
206                  (synch/lock (?mtx ()) ?body ...) ) ) )
207
208(define-syntax synch/unlock
209        (syntax-rules ()
210                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
211                  (let ((mtx ?mtx))
212                          (dynamic-wind
213                                  (lambda ()
214                                          (unless (thread? (mutex-state mtx))
215                                                  (warning 'synch/unlock "mutex is not locked - locking")
216                                                  (mutex-lock! mtx)))
217                                  (lambda () ?body ...)
218                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
219                ((_ ?mtx ?body ...)
220                  (synch/unlock (?mtx ()) ?body ...) ) ) )
221
222(define-syntax object/synch
223  (er-macro-transformer
224    (lambda (frm rnm cmp)
225      (##sys#check-syntax 'object/synch frm '(_ _ . _))
226      (let ((_synch-with (rnm 'synch-with))
227            (_>< (rnm '><))
228            (var (rnm (gensym)))
229            (mtx (cadr frm)))
230        (let body-loop ((unparsed (cddr frm)) (parsed '()))
231          (if (not (null? unparsed))
232              (let ((expr (car unparsed))
233                    (next (cdr unparsed)))
234                (let expr-loop ((rest expr) (parsedexpr '()))
235                  (cond ((null? rest)
236                          (body-loop next (cons (reverse parsedexpr) parsed)))
237                        ((pair? rest)
238                          (let ((arg (car rest))
239                                (next (cdr rest)))
240                            (if (cmp _>< arg)
241                                (expr-loop next (cons var parsedexpr))
242                                (expr-loop next (cons arg parsedexpr)) ) ))
243                        ((cmp _>< rest)
244                          (body-loop next (cons var parsed)))
245                        (else
246                          (body-loop next (cons rest parsed))) ) ) )
247              `(,_synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
248
249(define-syntax record/synch
250  (er-macro-transformer
251    (lambda (frm rnm cmp)
252      (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
253      (let ((_synch (rnm 'synch)))
254        (let ((?sym (cadr frm))
255              (?rec (caddr frm))
256              (?body (cdddr frm)))
257          `(,_synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
258
259(define-syntax record-synch/lock
260  (er-macro-transformer
261    (lambda (frm rnm cmp)
262      (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
263      (let ((_synch/lock (rnm 'synch/lock)))
264        (let ((?sym (cadr frm))
265              (?rec (caddr frm))
266              (?body (cdddr frm)))
267          `(,_synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
268
269(define-syntax record-synch/unlock
270  (er-macro-transformer
271    (lambda (frm rnm cmp)
272      (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
273      (let ((_synch/unlock (rnm 'synch/unlock)))
274        (let ((?sym (cadr frm))
275              (?rec (caddr frm))
276              (?body (cdddr frm)))
277          `(,_synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
278
279
280;;; Unprotected
281
282(define-syntax %*synch
283        (syntax-rules ()
284                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
285                  (let ((mtx ?mtx))
286        (mutex-lock! mtx ?lock-arg0 ...)
287                                (call-with-values
288                                        (lambda () ?body ...)
289                                        (lambda ret
290                                                (mutex-unlock! mtx ?unlock-arg0 ...)
291                                                (apply values ret))) ) )
292                ((_ ?mtx ?body ...)
293                  (%*synch (?mtx () ()) ?body ...) ) ) )
294
295(define-syntax %*synch-with
296  (er-macro-transformer
297    (lambda (frm rnm cmp)
298      (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
299      (let ((_call-with-values (rnm 'call-with-values))
300            (_mutex-specific (rnm 'mutex-specific))
301            (_mutex-lock! (rnm 'mutex-lock!))
302            (_mutex-unlock! (rnm 'mutex-unlock!))
303            (_let (rnm 'let))
304            (_apply (rnm 'apply))
305            (_values (rnm 'values))
306            (_lambda (rnm 'lambda))
307            (_ret (rnm 'ret))
308            (mtxvar (rnm (gensym))))
309        (let ((?mtx (cadr frm))
310              (?var (caddr frm))
311              (?body (cdddr frm)))
312          (call-with-values
313            (lambda ()
314              (if (not (pair? ?mtx)) (values ?mtx '() '())
315                (let ((mtx (car ?mtx))
316                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
317                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
318                  (values mtx lock-args unlock-args) ) ) )
319            (lambda (?mtx ?lock-args ?unlock-args)
320              `(,_let ((,mtxvar ,?mtx))
321                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
322                   (,_mutex-lock! ,mtxvar ,@?lock-args)
323                   (,_call-with-values
324                     (,_lambda () ,@?body)
325                     (,_lambda ,_ret
326                       (,_mutex-unlock! ,mtxvar ,@?unlock-args)
327                       (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) ) )
328
329(define-syntax %synch
330        (syntax-rules ()
331                ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
332
333(define-syntax %synch-with
334        (syntax-rules ()
335                ((_ ?mtx ?var ?body ...) (%*synch-with ?mtx ?var ?body ...) ) ) )
336
337(define-syntax %call/synch
338        (syntax-rules ()
339                ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
340
341(define-syntax %call-with/synch
342        (syntax-rules ()
343                ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
344
345(define-syntax %apply/synch
346        (syntax-rules ()
347                ((_ ?mtx ?proc ?arg0 ...) (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
348
349(define-syntax %apply-with/synch
350        (syntax-rules ()
351                ((_ ?mtx ?proc ?arg0 ...) (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
352
353(define-syntax %let/synch
354  (er-macro-transformer
355    (lambda (frm rnm cmp)
356      (##sys#check-syntax '%let/synch frm '(_ list . _))
357      (let ((_%synch-with (rnm '%synch-with)))
358        (let ((?body (cddr frm)))
359          (car
360            (let loop ((?bnds (cadr frm)))
361              (if (null? ?bnds) ?body
362                (let ((bnd (car ?bnds)))
363                  (##sys#check-syntax '%let/synch bnd '(variable _))
364                  `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) ) ) ) ) ) ) ) )
365
366(define-syntax %set!/synch
367  (er-macro-transformer
368    (lambda (frm rnm cmp)
369      (##sys#check-syntax '%set!/synch frm '(_ pair . _))
370      (let ((_%synch-with (rnm '%synch-with))
371            (_mutex-specific (rnm 'mutex-specific))
372            (_mutex-specific-set! (rnm 'mutex-specific-set!))
373            (_let (rnm 'let))
374            (_begin (rnm 'begin))
375            (mtxvar (rnm (gensym))))
376        (let ((?bnd (cadr frm))
377              (?body (cddr frm)))
378          (let ((?var (car ?bnd))
379                (?mtx (cadr ?bnd)))
380            `(,_let ((,mtxvar ,?mtx))
381               (,_%synch-with ,mtxvar ,?var
382                 (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
383                 (,_mutex-specific ,mtxvar) ) ) ) ) ) ) ) )
384
385(define-syntax %synch/lock
386        (syntax-rules ()
387                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
388                  (let ((mtx ?mtx) (ok? #f))
389                                (mutex-lock! mtx ?lock-arg0 ...)
390                                (call-with-values
391                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
392                                        (lambda ret
393                                                (unless ok? (mutex-unlock! mtx))
394                                                (apply values ret))) ) )
395                ((_ ?mtx ?body ...)
396                  (%synch/lock (?mtx ()) ?body ...) ) ) )
397
398(define-syntax %synch/unlock
399        (syntax-rules ()
400                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
401      (let ((mtx ?mtx))
402        (unless (thread? (mutex-state mtx))
403          (warning '%synch/unlock "mutex is not locked - locking")
404          (mutex-lock! mtx))
405        (call-with-values
406          (lambda () ?body ...)
407          (lambda ret
408            (mutex-unlock! mtx ?unlock-arg0 ...)
409            (apply values ret)) ) ) )
410                ((_ ?mtx ?body ...)
411      (%synch/unlock (?mtx ()) ?body ...) ) ) )
412
413(define-syntax %object/synch
414  (er-macro-transformer
415    (lambda (frm rnm cmp)
416      (##sys#check-syntax '%object/synch frm '(_ _ . _))
417      (let ((_%synch-with (rnm '%synch-with))
418            (_>< (rnm '><))
419            (var (rnm (gensym)))
420            (mtx (cadr frm)))
421        (let body-loop ((unparsed (cddr frm)) (parsed '()))
422          (if (not (null? unparsed))
423              (let ((expr (car unparsed))
424                    (next (cdr unparsed)))
425                (let expr-loop ((rest expr) (parsedexpr '()))
426                  (cond ((null? rest)
427                          (body-loop next (cons (reverse parsedexpr) parsed)))
428                        ((pair? rest)
429                          (let ((arg (car rest))
430                                (next (cdr rest)))
431                            (if (cmp _>< arg)
432                                (expr-loop next (cons var parsedexpr))
433                                (expr-loop next (cons arg parsedexpr)) ) ))
434                        ((cmp _>< rest)
435                          (body-loop next (cons var parsed)))
436                        (else
437                          (body-loop next (cons rest parsed))) ) ) )
438              `(,_%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) ) )
439
440(define-syntax %record/synch
441  (er-macro-transformer
442    (lambda (frm rnm cmp)
443      (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
444      (let ((_%synch (rnm '%synch)))
445        (let ((?sym (cadr frm))
446              (?rec (caddr frm))
447              (?body (cdddr frm)))
448          `(,_%synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
449
450(define-syntax %record-synch/lock
451  (er-macro-transformer
452  (lambda (frm rnm cmp)
453    (##sys#check-syntax '%record-synch/lock frm '(_ symbol _ . _))
454    (let ((_%synch/lock (rnm '%synch/lock)))
455      (let ((?sym (cadr frm))
456            (?rec (caddr frm))
457            (?body (cdddr frm)))
458        `(,_%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
459
460(define-syntax %record-synch/unlock
461  (er-macro-transformer
462    (lambda (frm rnm cmp)
463      (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
464      (let ((_%synch/unlock (rnm '%synch/unlock)))
465        (let ((?sym (cadr frm))
466              (?rec (caddr frm))
467              (?body (cdddr frm)))
468          `(,_%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) ) )
469
470
471;;; Synch Object
472
473(define (mutex+object? obj)
474        (and (mutex? obj)
475                   (not (eq? (void) (mutex-specific obj)))) )
476
477(define-check+error-type mutex+object)
478
479;;
480
481(define (make-object/synch obj #!optional (name '(object/synch-)))
482  (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
483    (mutex-specific-set! mutex obj)
484    mutex) )
485
486(define (object?/synch obj #!optional (pred any?))
487  (and (mutex+object? obj)
488       (pred (mutex-specific obj))) )
489
490;;
491
492(define-for-syntax (synchsym sym)
493        (string->symbol (string-append (symbol->string sym) "/synch")) )
494
495;;
496
497(define-syntax define-constructor/synch
498  (er-macro-transformer
499    (lambda (frm rnm cmp)
500      (##sys#check-syntax 'define-constructor/synch frm '(_ symbol . _))
501      (let ((_define (rnm 'define))
502            (_apply (rnm 'apply))
503            (_args (rnm (gensym 'args)))
504            (_make-object/synch (rnm 'make-object/synch)) )
505        (let* ((prcnam (cadr frm))
506               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
507               (newnam (synchsym prcnam)) )
508          `(,_define (,newnam . ,_args)
509             (,_make-object/synch (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
510
511;;
512
513(define-syntax define-predicate/synch
514  (er-macro-transformer
515    (lambda (frm rnm cmp)
516      (##sys#check-syntax 'define-predicate/synch frm '(_ symbol))
517      (let ((_define (rnm 'define))
518            (_obj (rnm (gensym 'obj)))
519            (_object?/synch (rnm 'object?/synch)) )
520        (let* ((prcnam (cadr frm))
521               (newnam (synchsym prcnam)) )
522          `(,_define (,newnam ,_obj) (,_object?/synch ,_obj ,prcnam)) ) ) ) ) )
523
524;;
525
526;operand must be the 1st argument
527
528(define-syntax define-operation/synch
529  (er-macro-transformer
530    (lambda (frm rnm cmp)
531      (##sys#check-syntax 'define-operation/synch frm '(_ symbol))
532      (let ((_define (rnm 'define))
533            (_apply (rnm 'apply))
534            (_let (rnm 'let))
535            (_car (rnm 'car))
536            (_cdr (rnm 'cdr))
537            (_if (rnm 'if))
538            (_pair? (rnm 'pair?))
539            (_synch-with (rnm 'synch-with))
540            (_check-mutex+object (rnm 'check-mutex+object))
541            (_mutex-specific (rnm 'mutex-specific))
542            (_mtx+obj (rnm (gensym 'mtx+obj)))
543            (_args (rnm (gensym 'args)))
544            (_obj (rnm (gensym 'obj)))
545            (_mtx (rnm (gensym 'mtx))) )
546        (let* ((prcnam  (cadr frm))
547               (newnam (synchsym prcnam)) )
548          `(,_define (,newnam ,_mtx+obj . ,_args)
549             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
550               (,_check-mutex+object ',newnam ,_mtx 'object/synch)
551               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
552
553;;
554
555;operand must be the 1st argument
556
557(define-syntax define-operation/%synch
558  (er-macro-transformer
559    (lambda (frm rnm cmp)
560      (define (%synchsym sym) (string->symbol (string-append (symbol->string sym) "/%synch")))
561      (##sys#check-syntax 'define-operation/%synch frm '(_ symbol))
562      (let ((_define (rnm 'define))
563            (_apply (rnm 'apply))
564            (_let (rnm 'let))
565            (_car (rnm 'car))
566            (_cdr (rnm 'cdr))
567            (_if (rnm 'if))
568            (_pair? (rnm 'pair?))
569            (_%synch-with (rnm '%synch-with))
570            (_check-mutex+object (rnm 'check-mutex+object))
571            (_mtx+obj (rnm (gensym 'mtx+obj)))
572            (_args (rnm (gensym 'args)))
573            (_obj (rnm (gensym 'obj)))
574            (_mtx (rnm (gensym 'mtx))) )
575        (let* ((prcnam (cadr frm))
576               (newnam (%synchsym prcnam)) )
577          `(,_define (,newnam ,_mtx+obj . ,_args)
578             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
579               (,_check-mutex+object ',newnam ,_mtx 'object/synch)
580                                                         (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
581
582) ;module synch
Note: See TracBrowser for help on using the repository browser.