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

Last change on this file since 35094 was 35094, checked in by kon, 8 months ago

still obtuse

File size: 30.9 KB
Line 
1;;;; synch.scm
2;;;; Kon Lovett, Jan '18
3;;;; Kon Lovett, May '17
4;;;; Kon Lovett, Mar '06
5
6;; Issues
7;;
8;; - syntax checking is minimal so expansion errors are cryptic
9
10(module synch
11
12(;export
13  ;;
14  synch
15  synch-with
16  call-synch
17  call-synch-with
18  apply-synch
19  apply-synch-with
20  let-synch-with
21  set!-synch-with
22  synch-lock
23  synch-unlock
24  object-synch-cut-with
25  record-synch
26  record-synch-lock
27  record-synch-unlock
28  ;;
29  %synch
30  %synch-with
31  %call-synch
32  %call-synch-with
33  %apply-synch
34  %apply-synch-with
35  %let-synch-with
36  %set!-synch-with
37  %synch-lock
38  %synch-unlock
39  %object-synch-cut-with
40  %record-synch
41  %record-synch-lock
42  %record-synch-unlock
43  ;;
44  make-synch-with-object
45  synch-with-object?
46  define-constructor-synch
47  define-predicate-synch
48  (define-operation-synch check-synch-with-object)
49  define-operation-%synch
50  ;;
51  ;DEPRECATED
52  call/synch
53  call-with/synch
54  apply/synch
55  apply-with/synch
56  let/synch
57  set!/synch
58  synch/lock
59  synch/unlock
60  object/synch
61  record/synch
62  record-synch/lock
63  record-synch/unlock
64  %call/synch
65  %call-with/synch
66  %apply/synch
67  %apply-with/synch
68  %let/synch
69  %set!/synch
70  %synch/lock
71  %synch/unlock
72  %object/synch
73  %record/synch
74  %record-synch/lock
75  %record-synch/unlock
76  make-object/synch
77  object?/synch
78  define-constructor/synch
79  define-predicate/synch
80  (define-operation/synch check-synch-with-object)
81  define-operation/%synch)
82
83(import
84  scheme
85  (only chicken
86    use
87    declare
88    define-for-syntax optional
89    void unless warning gensym dynamic-wind) )
90(use
91  (only srfi-18
92    thread?
93    make-mutex mutex?
94    mutex-specific mutex-specific-set!
95    mutex-lock! mutex-unlock!
96    mutex-state)
97  (only type-checks define-check+error-type) )
98
99;;;
100
101(define-for-syntax (record-mutex-name nam)
102  (string->symbol (string-append (symbol->string nam) "-" "mutex")) )
103
104;;; Protected
105
106;;
107
108(define-syntax synch
109        (syntax-rules ()
110    ;
111                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
112        (let ((mtx ?mtx))
113        (dynamic-wind
114          (lambda () (mutex-lock! mtx ?lock-arg0 ...))
115          (lambda () ?body ...)
116          (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
117    ;
118                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
119        (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
120    ;
121                ((_ ?mtx ?body ...)
122        (synch (?mtx () ()) ?body ...) ) ) )
123
124;;
125
126(define-syntax synch-with
127  (er-macro-transformer
128    (lambda (frm rnm cmp)
129      ;
130      (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
131      ;
132      (let (
133        (_dynamic-wind (rnm 'dynamic-wind) )
134        (_let (rnm 'let) )
135        (_lambda (rnm 'lambda) )
136        (_mutex-unlock! (rnm 'mutex-unlock!) )
137        (_mutex-specific (rnm 'mutex-specific) )
138        (_mutex-lock! (rnm 'mutex-lock!) )
139        (mtxvar (rnm (gensym)) ) )
140        ;
141        (let (
142          (?mtx (cadr frm) )
143          (?var (caddr frm) )
144          (?body (cdddr frm) ) )
145          ;
146          (call-with-values
147            (lambda ()
148              (if (not (pair? ?mtx))
149                (values ?mtx '() '())
150                (let ((mtx (car ?mtx))
151                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
152                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
153                  (values mtx lock-args unlock-args) ) ) )
154            (lambda (?mtx ?lock-args ?unlock-args)
155              `(,_let ((,mtxvar ,?mtx))
156                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
157                   (,_dynamic-wind
158                     (,_lambda () (,_mutex-lock! ,mtxvar ,@?lock-args))
159                     (,_lambda () ,@?body)
160                     (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) ) )
161
162(define-for-syntax call-synch-transformer
163        (syntax-rules ()
164    ;
165                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
166                  (let ((mtx ?mtx))
167                          (dynamic-wind
168                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
169                                  (lambda () (?proc ?arg0 ...))
170                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
171    ;
172                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
173                  (call-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
174    ;
175                ((_ ?mtx ?proc ?arg0 ...)
176                  (call-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
177
178(define-syntax call-synch call-synch-transformer)
179
180(define-for-syntax call-synch-with-transformer
181        (syntax-rules ()
182    ;
183                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
184                  (let ((mtx ?mtx))
185                          (dynamic-wind
186                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
187                                  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
188                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
189    ;
190                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
191                  (call-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
192    ;
193                ((_ ?mtx ?proc ?arg0 ...)
194                  (call-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )
195
196(define-syntax call-synch-with call-synch-with-transformer)
197
198(define-for-syntax apply-synch-transformer
199        (syntax-rules ()
200          ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
201                  (let ((mtx ?mtx))
202                          (dynamic-wind
203                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
204                                  (lambda () (apply ?proc ?arg0 ...))
205                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
206          ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
207                  (apply-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
208    ;
209                ((_ ?mtx ?proc ?arg0 ...)
210                  (apply-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )
211
212(define-syntax apply-synch apply-synch-transformer)
213
214(define-for-syntax apply-synch-with-transformer
215        (syntax-rules ()
216    ;
217                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
218                  (let ((mtx ?mtx))
219                          (dynamic-wind
220                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
221                                  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
222                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
223    ;
224                ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
225                  (apply-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
226    ;
227                ((_ ?mtx ?proc ?arg0 ...)
228                  (apply-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )
229
230(define-syntax apply-synch-with apply-synch-with-transformer)
231
232(define-for-syntax let-synch-with-transformer
233  (er-macro-transformer
234    (lambda (frm rnm cmp)
235      ;
236      (##sys#check-syntax 'let-synch-with frm '(_ list . _))
237      ;
238      (let ((_synch-with (rnm 'synch-with)))
239        (let* (
240          (?body
241            (cddr frm) )
242          (res
243            (let loop ((bnds (cadr frm)))
244              (if (null? bnds)
245                ?body
246                (let ((?bnd (car bnds)))
247                  (##sys#check-syntax 'let-synch-with ?bnd '(variable . _))
248                  `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
249          ;
250          (car res) ) ) ) ) )
251
252(define-syntax let-synch-with let-synch-with-transformer)
253
254(define-syntax set!-synch-with
255  (er-macro-transformer
256    (lambda (frm rnm cmp)
257      ;
258      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
259      ;
260      (let (
261        (_synch-with (rnm 'synch-with) )
262        (_mutex-specific (rnm 'mutex-specific) )
263        (_mutex-specific-set! (rnm 'mutex-specific-set!) )
264        (_begin (rnm 'begin) ) )
265        ;
266        (let (
267          (?mtx (cadr frm) )
268          (?var (caddr frm) )
269          (?body (cdddr frm) ) )
270          ;
271          `(,_synch-with ,?mtx ,?var
272             (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
273             (,_mutex-specific ,?mtx) ) ) ) ) ) )
274
275;;
276
277(define-for-syntax synch-lock-transformer
278        (syntax-rules ()
279    ;
280                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
281                  (let ((mtx ?mtx) (ok? #f))
282                                (mutex-lock! mtx)
283                                (dynamic-wind
284                                  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
285                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
286                                        (lambda () (unless ok? (mutex-unlock! mtx)))) ) )
287    ;
288                ((_ ?mtx ?body ...)
289                  (synch-lock (?mtx ()) ?body ...) ) ) )
290
291(define-syntax synch-lock synch-lock-transformer)
292
293(define-for-syntax synch-unlock-transformer
294        (syntax-rules ()
295    ;
296                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
297                  (let ((mtx ?mtx))
298                          (dynamic-wind
299                                  (lambda ()
300                                          (unless (thread? (mutex-state mtx))
301                                                  (warning 'synch-unlock "mutex is not locked - locking")
302                                                  (mutex-lock! mtx)))
303                                  (lambda () ?body ...)
304                                  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
305    ;
306                ((_ ?mtx ?body ...)
307                  (synch-unlock (?mtx ()) ?body ...) ) ) )
308
309(define-syntax synch-unlock synch-unlock-transformer)
310
311;;
312
313(define-for-syntax object-synch-cut-with-transformer
314  (er-macro-transformer
315    (lambda (frm rnm cmp)
316      ;
317      (##sys#check-syntax 'object-synch-cut-with frm '(_ _ . _))
318      ;
319      (let (
320        (_synch-with (rnm 'synch-with))
321        (_>< (rnm '><))
322        (var (rnm (gensym)))
323        (mtx (cadr frm)) )
324        ;
325        (let body-loop ((unparsed (cddr frm)) (parsed '()))
326          (if (null? unparsed)
327            ;
328            `(,_synch-with ,mtx ,var ,@(reverse parsed))
329            ;
330            (let (
331              (expr (car unparsed))
332              (next (cdr unparsed)) )
333              ;
334              (let expr-loop ((rest expr) (parsed-expr '()))
335                (cond
336                  ;
337                  ((null? rest)
338                    (body-loop next (cons (reverse parsed-expr) parsed)))
339                  ;
340                  ((pair? rest)
341                    (let (
342                      (arg (car rest))
343                      (next (cdr rest)) )
344                      ;
345                      (if (cmp _>< arg)
346                        (expr-loop next (cons var parsed-expr))
347                        (expr-loop next (cons arg parsed-expr)) ) ))
348                  ;
349                  ((cmp _>< rest)
350                    (body-loop next (cons var parsed)))
351                  ;
352                  (else
353                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )
354
355(define-syntax object-synch-cut-with object-synch-cut-with-transformer)
356
357;;
358
359(define-syntax record-synch
360  (er-macro-transformer
361    (lambda (frm rnm cmp)
362      ;
363      (##sys#check-syntax 'record-synch frm '(_ _ symbol . _))
364      ;
365      (let ((_synch (rnm 'synch)))
366        (let (
367          (?rec (cadr frm) )
368          (?sym (caddr frm) )
369          (?body (cdddr frm) ) )
370          ;
371          `(,_synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
372
373(define-syntax record-synch-lock
374  (er-macro-transformer
375    (lambda (frm rnm cmp)
376      ;
377      (##sys#check-syntax 'record-synch-lock frm '(_ _ symbol . _))
378      ;
379      (let ((_synch-lock (rnm 'synch-lock)))
380        (let (
381          (?rec (cadr frm) )
382          (?sym (caddr frm) )
383          (?body (cdddr frm) ) )
384          ;
385          `(,_synch-lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
386
387(define-syntax record-synch-unlock
388  (er-macro-transformer
389    (lambda (frm rnm cmp)
390      ;
391      (##sys#check-syntax 'record-synch-unlock frm '(_ _ symbol . _))
392      ;
393      (let ((_synch-unlock (rnm 'synch-unlock)))
394        (let (
395          (?rec (cadr frm) )
396          (?sym (caddr frm) )
397          (?body (cdddr frm) ) )
398          ;
399          `(,_synch-unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
400
401;;; Unprotected
402
403(define-syntax %*synch
404        (syntax-rules ()
405    ;
406                ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
407                  (let ((mtx ?mtx))
408        (mutex-lock! mtx ?lock-arg0 ...)
409                                (call-with-values
410                                        (lambda () ?body ...)
411                                        (lambda ret
412                                                (mutex-unlock! mtx ?unlock-arg0 ...)
413                                                (apply values ret))) ) )
414    ;
415                ((_ ?mtx ?body ...)
416                  (%*synch (?mtx () ()) ?body ...) ) ) )
417
418;;
419
420(define-syntax %*synch-with
421  (er-macro-transformer
422    (lambda (frm rnm cmp)
423      (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
424      (let ((_call-with-values (rnm 'call-with-values))
425            (_mutex-specific (rnm 'mutex-specific))
426            (_mutex-lock! (rnm 'mutex-lock!))
427            (_mutex-unlock! (rnm 'mutex-unlock!))
428            (_let (rnm 'let))
429            (_apply (rnm 'apply))
430            (_values (rnm 'values))
431            (_lambda (rnm 'lambda))
432            (_ret (rnm 'ret))
433            (mtxvar (rnm (gensym))))
434        (let ((?mtx (cadr frm))
435              (?var (caddr frm))
436              (?body (cdddr frm)))
437          (call-with-values
438            (lambda ()
439              (if (not (pair? ?mtx))
440                (values ?mtx '() '())
441                (let ((mtx (car ?mtx))
442                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
443                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
444                  (values mtx lock-args unlock-args) ) ) )
445            (lambda (?mtx ?lock-args ?unlock-args)
446              `(,_let ((,mtxvar ,?mtx))
447                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
448                   (,_mutex-lock! ,mtxvar ,@?lock-args)
449                   (,_call-with-values
450                     (,_lambda () ,@?body)
451                     (,_lambda ,_ret
452                       (,_mutex-unlock! ,mtxvar ,@?unlock-args)
453                       (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) ) )
454
455;;
456
457(define-syntax %synch
458        (syntax-rules ()
459                ((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )
460
461;;
462
463(define-syntax %synch-with
464        (syntax-rules ()
465                ((_ ?mtx ?var ?body ...)
466                  (%*synch-with ?mtx ?var ?body ...) ) ) )
467
468(define-for-syntax %call-synch-transformer
469        (syntax-rules ()
470                ((_ ?mtx ?proc ?arg0 ...)
471                  (%*synch ?mtx (?proc ?arg0 ...)) ) ) )
472
473(define-syntax %call-synch %call-synch-transformer)
474
475(define-for-syntax %call-synch-with-transformer
476        (syntax-rules ()
477                ((_ ?mtx ?proc ?arg0 ...)
478                  (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
479
480(define-syntax %call-synch-with %call-synch-with-transformer)
481
482(define-for-syntax %apply-synch-transformer
483        (syntax-rules ()
484                ((_ ?mtx ?proc ?arg0 ...)
485                  (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
486
487(define-syntax %apply-synch %apply-synch-transformer)
488
489(define-for-syntax %apply-synch-with-transformer
490        (syntax-rules ()
491                ((_ ?mtx ?proc ?arg0 ...)
492                  (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
493
494(define-syntax %apply-synch-with %apply-synch-with-transformer)
495
496(define-for-syntax %let-synch-with-transformer
497  (er-macro-transformer
498    (lambda (frm rnm cmp)
499      (##sys#check-syntax '%let-synch-with frm '(_ list . _))
500      (let ((_%synch-with (rnm '%synch-with)))
501        (let ((?body (cddr frm)))
502          (car
503            (let loop ((?bnds (cadr frm)))
504              (if (null? ?bnds)
505                ?body
506                (let ((bnd (car ?bnds)))
507                  (##sys#check-syntax '%let-synch-with bnd '(variable _))
508                  `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) ) ) ) ) ) ) ) )
509
510(define-syntax %let-synch-with %let-synch-with-transformer)
511
512(define-syntax %set!-synch-with
513  (er-macro-transformer
514    (lambda (frm rnm cmp)
515      ;
516      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
517      ;
518      (let (
519        (_%synch-with (rnm '%synch-with) )
520        (_mutex-specific (rnm 'mutex-specific) )
521        (_mutex-specific-set! (rnm 'mutex-specific-set!) )
522        (_let (rnm 'let) )
523        (_begin (rnm 'begin) )
524        (mtxvar (rnm (gensym)) ) )
525        ;
526        (let (
527          (?mtx (cadr frm) )
528          (?var (caddr frm) )
529          (?body (cdddr frm) ) )
530          ;
531          `(,_let ((,mtxvar ,?mtx))
532             (,_%synch-with ,mtxvar ,?var
533               (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
534               (,_mutex-specific ,mtxvar) ) ) ) ) ) ) )
535
536;;
537
538(define-for-syntax %synch-lock-transformer
539        (syntax-rules ()
540    ;
541                ((_ (?mtx (?lock-arg0 ...)) ?body ...)
542                  (let ((mtx ?mtx) (ok? #f))
543                                (mutex-lock! mtx ?lock-arg0 ...)
544                                (call-with-values
545                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
546                                        (lambda ret
547                                                (unless ok? (mutex-unlock! mtx))
548                                                (apply values ret))) ) )
549    ;
550                ((_ ?mtx ?body ...)
551                  (%synch-lock (?mtx ()) ?body ...) ) ) )
552
553(define-syntax %synch-lock %synch-lock-transformer)
554
555(define-for-syntax %synch-unlock-transformer
556        (syntax-rules ()
557    ;
558                ((_ (?mtx (?unlock-arg0 ...)) ?body ...)
559      (let ((mtx ?mtx))
560        (unless (thread? (mutex-state mtx))
561          (warning '%synch-unlock "mutex is not locked - locking")
562          (mutex-lock! mtx))
563        (call-with-values
564          (lambda () ?body ...)
565          (lambda ret
566            (mutex-unlock! mtx ?unlock-arg0 ...)
567            (apply values ret)) ) ) )
568    ;
569                ((_ ?mtx ?body ...)
570      (%synch-unlock (?mtx ()) ?body ...) ) ) )
571
572(define-syntax %synch-unlock %synch-unlock-transformer)
573
574;;
575
576(define-for-syntax %object-synch-cut-with-transformer
577  (er-macro-transformer
578    (lambda (frm rnm cmp)
579      ;
580      (##sys#check-syntax '%object-synch-cut-with frm '(_ _ . _))
581      ;
582      (let (
583        (_%synch-with (rnm '%synch-with))
584        (_>< (rnm '><))
585        (var (rnm (gensym)))
586        (mtx (cadr frm)) )
587        ;
588        (let body-loop ((unparsed (cddr frm)) (parsed '()))
589          (if (null? unparsed)
590            ;
591            `(,_%synch-with ,mtx ,var ,@(reverse parsed))
592            ;
593            (let (
594              (expr (car unparsed))
595              (next (cdr unparsed)) )
596              ;
597              (let expr-loop ((rest expr) (parsed-expr '()))
598                (cond
599                  ;
600                  ((null? rest)
601                    (body-loop next (cons (reverse parsed-expr) parsed)))
602                  ;
603                  ((pair? rest)
604                    (let ((arg (car rest))
605                          (next (cdr rest)))
606                      (if (cmp _>< arg)
607                          (expr-loop next (cons var parsed-expr))
608                          (expr-loop next (cons arg parsed-expr)) ) ))
609                  ;
610                  ((cmp _>< rest)
611                    (body-loop next (cons var parsed)))
612                  ;
613                  (else
614                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )
615
616(define-syntax %object-synch-cut-with %object-synch-cut-with-transformer)
617
618;;
619
620(define-syntax %record-synch
621  (er-macro-transformer
622    (lambda (frm rnm cmp)
623      ;
624      (##sys#check-syntax '%record-synch frm '(_ _ symbol . _))
625      ;
626      (let ((_%synch (rnm '%synch)))
627        (let (
628          (?rec (cadr frm) )
629          (?sym (caddr frm) )
630          (?body (cdddr frm) ) )
631          ;
632          `(,_%synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
633
634(define-syntax %record-synch-lock
635  (er-macro-transformer
636    (lambda (frm rnm cmp)
637      ;
638      (##sys#check-syntax '%record-synch-lock frm '(_ _ symbol . _))
639      ;
640      (let ((_%synch-lock (rnm '%synch-lock)))
641        (let (
642          (?rec (cadr frm) )
643          (?sym (caddr frm) )
644          (?body (cdddr frm) ) )
645          ;
646          `(,_%synch-lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
647
648(define-syntax %record-synch-unlock
649  (er-macro-transformer
650    (lambda (frm rnm cmp)
651      ;
652      (##sys#check-syntax '%record-synch-unlock frm '(_ _ symbol . _))
653      ;
654      (let ((_%synch-unlock (rnm '%synch-unlock)))
655        (let (
656          (?rec (cadr frm) )
657          (?sym (caddr frm) )
658          (?body (cdddr frm) ) )
659          ;
660          `(,_%synch-unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
661
662;;; Synch Object
663
664;;
665
666(define (mutex-with-object? obj)
667        (and
668          (mutex? obj)
669    (not (eq? (void) (mutex-specific obj))) ) )
670
671;;
672
673(define (make-synch-with-object obj #!optional (name '(object-synch-)))
674  (let* (
675    (name (if (pair? name) (gensym (car name)) name) )
676    (mutex (make-mutex name) ) )
677    ;
678    (mutex-specific-set! mutex obj)
679    mutex ) )
680
681(define (synch-with-object? obj #!optional pred)
682  (and
683    (mutex-with-object? obj)
684    (or
685      (not pred)
686      (pred (mutex-specific obj)) ) ) )
687
688(define-check+error-type synch-with-object)
689
690;;
691
692;FIXME this API sucks
693
694(define-for-syntax (synch-wrapper-name sym)
695        (string->symbol (string-append (symbol->string sym) "-" "synch")) )
696
697(define-syntax define-constructor-synch
698  (er-macro-transformer
699    (lambda (frm rnm cmp)
700      ;
701      (##sys#check-syntax 'define-constructor-synch frm '(_ symbol . _))
702      ;
703      (let (
704        (_define (rnm 'define) )
705        (_apply (rnm 'apply) )
706        (_args (rnm (gensym 'args)) )
707        (_make-synch-with-object (rnm 'make-synch-with-object) ) )
708        ;
709        (let* (
710          (prcnam (cadr frm) )
711          (id (if (not (null? (cddr frm))) `('(,(caddr frm))) `('(,prcnam))) )
712          (newnam (synch-wrapper-name prcnam) ) )
713          ;
714          `(,_define (,newnam . ,_args)
715            (,_make-synch-with-object (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
716
717(define-syntax define-predicate-synch
718  (er-macro-transformer
719    (lambda (frm rnm cmp)
720      ;
721      (##sys#check-syntax 'define-predicate-synch frm '(_ symbol))
722      ;
723      (let (
724        (_define (rnm 'define))
725        (_obj (rnm (gensym 'obj)))
726        (_synch-with-object? (rnm 'synch-with-object?)) )
727        ;
728        (let* (
729          (prcnam (cadr frm))
730          (newnam (synch-wrapper-name prcnam)) )
731          ;
732          `(,_define (,newnam ,_obj)
733            (,_synch-with-object? ,_obj ,prcnam)) ) ) ) ) )
734
735;operand must be the 1st argument
736(define-syntax define-operation-synch
737  (er-macro-transformer
738    (lambda (frm rnm cmp)
739      ;
740      (##sys#check-syntax 'define-operation-synch frm '(_ symbol))
741      ;
742      (let ((_define (rnm 'define))
743            (_apply (rnm 'apply))
744            (_let (rnm 'let))
745            (_car (rnm 'car))
746            (_cdr (rnm 'cdr))
747            (_if (rnm 'if))
748            (_pair? (rnm 'pair?))
749            (_synch-with (rnm 'synch-with))
750            (_check-synch-with-object (rnm 'check-synch-with-object))
751            (_mutex-specific (rnm 'mutex-specific))
752            (_mtx+obj (rnm (gensym 'mtx+obj)))
753            (_args (rnm (gensym 'args)))
754            (_obj (rnm (gensym 'obj)))
755            (_mtx (rnm (gensym 'mtx))) )
756        (let* ((prcnam  (cadr frm))
757               (newnam (synch-wrapper-name prcnam)) )
758          `(,_define (,newnam ,_mtx+obj . ,_args)
759             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
760               (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
761               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
762
763;operand must be the 1st argument
764(define-syntax define-operation-%synch
765  (er-macro-transformer
766    (lambda (frm rnm cmp)
767      ;
768      (define (%synch-wrapper-name sym)
769        (string->symbol (string-append (symbol->string sym) "-" "%synch")) )
770      ;
771      (##sys#check-syntax 'define-operation-%synch frm '(_ symbol))
772      (let ((_define (rnm 'define))
773            (_apply (rnm 'apply))
774            (_let (rnm 'let))
775            (_car (rnm 'car))
776            (_cdr (rnm 'cdr))
777            (_if (rnm 'if))
778            (_pair? (rnm 'pair?))
779            (_%synch-with (rnm '%synch-with))
780            (_check-synch-with-object (rnm 'check-synch-with-object))
781            (_mtx+obj (rnm (gensym 'mtx+obj)))
782            (_args (rnm (gensym 'args)))
783            (_obj (rnm (gensym 'obj)))
784            (_mtx (rnm (gensym 'mtx))) )
785        (let* ((prcnam (cadr frm))
786               (newnam (%synch-wrapper-name prcnam)) )
787          `(,_define (,newnam ,_mtx+obj . ,_args)
788             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
789               (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
790                                                         (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
791
792;; ;DEPRECATED
793
794(define-syntax call/synch call-synch-transformer)
795(define-syntax call-with/synch call-synch-with-transformer)
796(define-syntax apply/synch apply-synch-transformer)
797(define-syntax apply-with/synch apply-synch-with-transformer)
798(define-syntax let/synch let-synch-with-transformer)
799
800(define-syntax set!/synch
801  (er-macro-transformer
802    (lambda (frm rnm cmp)
803      (##sys#check-syntax 'set!/synch frm '(_ pair . _))
804      (let ((_synch-with (rnm 'synch-with))
805            (_mutex-specific (rnm 'mutex-specific))
806            (_mutex-specific-set! (rnm 'mutex-specific-set!))
807            (_begin (rnm 'begin)))
808        (let ((?bnd (cadr frm))
809              (?body (cddr frm)))
810          (let ((?var (car ?bnd))
811                (?mtx (cadr ?bnd)))
812            `(,_synch-with ,?mtx ,?var
813               (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
814               (,_mutex-specific ,?mtx) ) ) ) ) ) ) )
815
816(define-syntax synch/lock synch-lock-transformer)
817(define-syntax synch/unlock synch-unlock-transformer)
818(define-syntax object/synch object-synch-cut-with-transformer)
819
820(define-syntax record/synch
821  (er-macro-transformer
822    (lambda (frm rnm cmp)
823      (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
824      (let ((_synch (rnm 'synch)))
825        (let ((?sym (cadr frm))
826              (?rec (caddr frm))
827              (?body (cdddr frm)))
828          `(,_synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
829
830(define-syntax record-synch/lock
831  (er-macro-transformer
832    (lambda (frm rnm cmp)
833      (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
834      (let ((_synch/lock (rnm 'synch/lock)))
835        (let ((?sym (cadr frm))
836              (?rec (caddr frm))
837              (?body (cdddr frm)))
838          `(,_synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
839
840(define-syntax record-synch/unlock
841  (er-macro-transformer
842    (lambda (frm rnm cmp)
843      (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
844      (let ((_synch/unlock (rnm 'synch/unlock)))
845        (let ((?sym (cadr frm))
846              (?rec (caddr frm))
847              (?body (cdddr frm)))
848          `(,_synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
849
850(define-syntax %call/synch %call-synch-transformer)
851(define-syntax %call-with/synch %call-synch-with-transformer)
852(define-syntax %apply/synch %apply-synch-transformer)
853(define-syntax %apply-with/synch %apply-synch-with-transformer)
854(define-syntax %let/synch %let-synch-with-transformer)
855
856(define-syntax %set!/synch
857  (er-macro-transformer
858    (lambda (frm rnm cmp)
859      (##sys#check-syntax '%set!/synch frm '(_ pair . _))
860      (let ((_%synch-with (rnm '%synch-with))
861            (_mutex-specific (rnm 'mutex-specific))
862            (_mutex-specific-set! (rnm 'mutex-specific-set!))
863            (_let (rnm 'let))
864            (_begin (rnm 'begin))
865            (mtxvar (rnm (gensym))))
866        (let ((?bnd (cadr frm))
867              (?body (cddr frm)))
868          (let ((?var (car ?bnd))
869                (?mtx (cadr ?bnd)))
870            `(,_let ((,mtxvar ,?mtx))
871               (,_%synch-with ,mtxvar ,?var
872                 (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
873                 (,_mutex-specific ,mtxvar) ) ) ) ) ) ) ) )
874
875(define-syntax %synch/lock %synch-lock-transformer)
876(define-syntax %synch/unlock %synch-unlock-transformer)
877(define-syntax %object/synch %object-synch-cut-with-transformer)
878
879(define-syntax %record/synch
880  (er-macro-transformer
881    (lambda (frm rnm cmp)
882      (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
883      (let ((_%synch (rnm '%synch)))
884        (let ((?sym (cadr frm))
885              (?rec (caddr frm))
886              (?body (cdddr frm)))
887          `(,_%synch (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
888
889(define-syntax %record-synch/lock
890  (er-macro-transformer
891  (lambda (frm rnm cmp)
892    (##sys#check-syntax '%record-synch/lock frm '(_ symbol _ . _))
893    (let ((_%synch/lock (rnm '%synch/lock)))
894      (let ((?sym (cadr frm))
895            (?rec (caddr frm))
896            (?body (cdddr frm)))
897        `(,_%synch/lock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
898
899(define-syntax %record-synch/unlock
900  (er-macro-transformer
901    (lambda (frm rnm cmp)
902      (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
903      (let ((_%synch/unlock (rnm '%synch/unlock)))
904        (let ((?sym (cadr frm))
905              (?rec (caddr frm))
906              (?body (cdddr frm)))
907          `(,_%synch/unlock (,(record-mutex-name ?sym) ,?rec) ,@?body) ) ) ) ) )
908
909(define make-object/synch make-synch-with-object)
910(define object?/synch synch-with-object?)
911
912;
913
914(define-for-syntax (synch/wrapper-name sym)
915        (string->symbol (string-append (symbol->string sym) "/" "synch")) )
916
917(define-syntax define-constructor/synch
918  (er-macro-transformer
919    (lambda (frm rnm cmp)
920      (##sys#check-syntax 'define-constructor/synch frm '(_ symbol . _))
921      (let ((_define (rnm 'define))
922            (_apply (rnm 'apply))
923            (_args (rnm (gensym 'args)))
924            (_make-object/synch (rnm 'make-object/synch)) )
925        (let* ((prcnam (cadr frm))
926               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
927               (newnam (synch/wrapper-name prcnam)) )
928          `(,_define (,newnam . ,_args)
929             (,_make-object/synch (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )
930
931(define-syntax define-predicate/synch
932  (er-macro-transformer
933    (lambda (frm rnm cmp)
934      (##sys#check-syntax 'define-predicate/synch frm '(_ symbol))
935      (let ((_define (rnm 'define))
936            (_obj (rnm (gensym 'obj)))
937            (_object?/synch (rnm 'object?/synch)) )
938        (let* ((prcnam (cadr frm))
939               (newnam (synch/wrapper-name prcnam)) )
940          `(,_define (,newnam ,_obj) (,_object?/synch ,_obj ,prcnam)) ) ) ) ) )
941
942;operand must be the 1st argument
943(define-syntax define-operation/synch
944  (er-macro-transformer
945    (lambda (frm rnm cmp)
946      (##sys#check-syntax 'define-operation/synch frm '(_ symbol))
947      (let ((_define (rnm 'define))
948            (_apply (rnm 'apply))
949            (_let (rnm 'let))
950            (_car (rnm 'car))
951            (_cdr (rnm 'cdr))
952            (_if (rnm 'if))
953            (_pair? (rnm 'pair?))
954            (_synch-with (rnm 'synch-with))
955            (_check-synch-with-object (rnm 'check-synch-with-object))
956            (_mutex-specific (rnm 'mutex-specific))
957            (_mtx+obj (rnm (gensym 'mtx+obj)))
958            (_args (rnm (gensym 'args)))
959            (_obj (rnm (gensym 'obj)))
960            (_mtx (rnm (gensym 'mtx))) )
961        (let* ((prcnam  (cadr frm))
962               (newnam (synch/wrapper-name prcnam)) )
963          `(,_define (,newnam ,_mtx+obj . ,_args)
964             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
965               (,_check-synch-with-object ',newnam ,_mtx 'object/synch)
966               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )
967
968;operand must be the 1st argument
969(define-syntax define-operation/%synch
970  (er-macro-transformer
971    (lambda (frm rnm cmp)
972      ;
973      (define (%synch/wrapper-name sym)
974        (string->symbol (string-append (symbol->string sym) "/" "%synch")) )
975      ;
976      (##sys#check-syntax 'define-operation/%synch frm '(_ symbol))
977      (let ((_define (rnm 'define))
978            (_apply (rnm 'apply))
979            (_let (rnm 'let))
980            (_car (rnm 'car))
981            (_cdr (rnm 'cdr))
982            (_if (rnm 'if))
983            (_pair? (rnm 'pair?))
984            (_%synch-with (rnm '%synch-with))
985            (_check-synch-with-object (rnm 'check-synch-with-object))
986            (_mtx+obj (rnm (gensym 'mtx+obj)))
987            (_args (rnm (gensym 'args)))
988            (_obj (rnm (gensym 'obj)))
989            (_mtx (rnm (gensym 'mtx))) )
990        (let* ((prcnam (cadr frm))
991               (newnam (%synch/wrapper-name prcnam)) )
992          `(,_define (,newnam ,_mtx+obj . ,_args)
993             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
994               (,_check-synch-with-object ',newnam ,_mtx 'object/synch)
995                                                         (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )
996
997) ;module synch
Note: See TracBrowser for help on using the repository browser.