source: project/release/5/synch/tags/3.3.0/synch-dyn.scm @ 38609

Last change on this file since 38609 was 38609, checked in by Kon Lovett, 3 months ago

rel 3.3.0

File size: 3.6 KB
Line 
1;;;; synch-dyn.scm
2;;;; Kon Lovett, Dec '18
3
4;; Issues
5;;
6;; - syntax checking is minimal so expansion errors are cryptic
7;;
8;; - dynamic-wind exit is invoked by thread scheduler
9
10(module synch-dyn
11
12(;export
13  ;;
14  current-synch-exit-condition
15  current-synch-raise synch-raise-warning
16  current-synch-abandon?
17  ;;
18  synch
19  synch-lock
20  synch-unlock
21  ;;
22  synch-with
23  call-synch
24  call-synch-with
25  apply-synch
26  apply-synch-with
27  let-synch-with
28  set!-synch-with
29  ;;
30  object-synch-cut-with
31  record-synch
32  record-synch-lock
33  record-synch-unlock
34  ;;
35  make-synch-with-object
36  synch-with-object? check-synch-with-object error-synch-with-object
37  ;
38  define-constructor-synch
39  define-predicate-synch
40  define-operation-synch
41  ;
42  synchronized-procedure)
43
44(import scheme)
45(import (chicken base))
46(import (chicken syntax))
47(import (only (srfi 18)
48  thread?
49  make-mutex mutex?
50  mutex-specific mutex-specific-set!
51  mutex-lock! mutex-unlock!
52  mutex-state))
53(import synch-object)
54(import synch-params)
55
56;;; Protected
57
58;;
59
60(define-syntax synch
61  (syntax-rules ()
62    ;
63    ((synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...) ?abandon?) ?body ...)
64      ;eval args ahead of time
65      (let (
66        (mtx ?mtx)
67        (lock-args (list ?lock-arg0 ...))
68        (unlock-args (list ?unlock-arg0 ...))
69        (abandon? ?abandon?) )
70        ;do not continue when cannot get a lock
71        (when (apply mutex-lock! ?mtx lock-args)
72          (let (
73            (ok? (not abandon?)) )
74            (let (
75              (result
76                (dynamic-wind
77                  void
78                  (lambda ()
79                    (let (
80                      (result (begin ?body ...)) )
81                      (set! ok? #t)
82                      result ) )
83                  (lambda ()
84                    (when ok?
85                      (apply mutex-unlock! ?mtx unlock-args))))) )
86              (cond
87                ((not ok?)
88                  ((current-synch-raise) (current-synch-exit-condition)) )
89                (else
90                  result ) ) ) ) ) ) )
91    ;
92    ((synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
93      (let ((mtx ?mtx))
94        (synch (mtx (?lock-arg0 ...) (?unlock-arg0 ...) #f) ?body ...) ) )
95    ;
96    ((synch (?mtx (?lock-arg0 ...)) ?body ...)
97      (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
98    ;
99    ((synch (?mtx) ?body ...)
100      (synch (?mtx () () (current-synch-abandon?)) ?body ...) )
101    ;
102    ((synch ?mtx ?body ...)
103      (synch (?mtx) ?body ...) ) ) )
104;;
105
106(define-syntax synch-lock
107  (syntax-rules ()
108    ;
109    ((synch-lock (?mtx (?lock-arg0 ...)) ?body ...)
110      (let ((mtx ?mtx))
111        (let ((ok? #f))
112          (when (mutex-lock! mtx ?lock-arg0 ...)
113            (dynamic-wind
114              void
115              (lambda ()
116                (let ((res (begin ?body ...)))
117                  (set! ok? #t)
118                  res))
119              (lambda ()
120                (unless ok?
121                  (mutex-unlock! mtx)))) ) ) ) )
122    ;
123    ((synch-lock ?mtx ?body ...)
124      (synch-lock (?mtx ()) ?body ...) ) ) )
125
126(define-syntax synch-unlock
127  (syntax-rules ()
128    ;
129    ((synch-unlock (?mtx (?unlock-arg0 ...)) ?body ...)
130      (let ((mtx ?mtx))
131        (let ((st (mutex-state mtx)))
132          (if (or (eq 'abandoned st) (eq 'not-abandoned st))
133            (error 'synch-unlock "mutex unlocked" mtx)
134            (dynamic-wind
135              void
136              (lambda () ?body ...)
137              (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) ) ) )
138    ;
139    ((synch-unlock ?mtx ?body ...)
140      (synch-unlock (?mtx ()) ?body ...) ) ) )
141
142;;
143
144(include "synch-incl")
145
146) ;module synch-dyn
Note: See TracBrowser for help on using the repository browser.