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

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

rm dup #\space

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