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

Last change on this file since 34225 was 34225, checked in by Kon Lovett, 3 years ago

re-flow

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