source: project/release/5/synch/tags/3.3.0/synch-dynexn.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: 4.1 KB
Line 
1;;;; synch-dynexn.scm
2;;;; Kon Lovett, Dec '18
3
4;; Issues
5;;
6;; - syntax checking is minimal so expansion errors are cryptic
7;;
8;; - dynamic-wind, ...
9
10(module synch-dynexn
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
45(import scheme)
46(import (chicken base))
47(import (chicken syntax))
48(import (chicken condition))
49(import (only (srfi 18)
50  thread?
51  make-mutex mutex?
52  mutex-specific mutex-specific-set!
53  mutex-lock! mutex-unlock!
54  mutex-state))
55(import synch-object)
56(import synch-params)
57
58;;; Protected
59
60;;
61
62(define-syntax synch
63  (syntax-rules ()
64    ;
65    ((synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...) ?abandon?) ?body ...)
66      ;eval args ahead of time
67      (let (
68        (mtx ?mtx)
69        (lock-args (list ?lock-arg0 ...))
70        (unlock-args (list ?unlock-arg0 ...))
71        (abandon? ?abandon?) )
72        ;do not continue when cannot get a lock
73        (when (apply mutex-lock! ?mtx lock-args)
74          (let (
75            (ok? (not abandon?))
76            (exception? #f) )
77            (let (
78              (result
79                (dynamic-wind
80                  void
81                  (lambda ()
82                    ;(wraps bodies & exits exn handler non-locally)
83                    (handle-exceptions exn
84                      (begin
85                        (set! exception? #t)
86                        exn )
87                      (let (
88                        (result (begin ?body ...)) )
89                        (set! ok? #t)
90                        result ) ) )
91                  (lambda ()
92                    (when ok?
93                      (apply mutex-unlock! ?mtx unlock-args))))) )
94              (cond
95                (exception?
96                  ((current-synch-raise) result) )
97                ((not ok?)
98                  ((current-synch-raise) (current-synch-exit-condition)) )
99                (else
100                  result ) ) ) ) ) ) )
101    ;
102    ((synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
103      (let ((mtx ?mtx))
104        (synch (mtx (?lock-arg0 ...) (?unlock-arg0 ...) #f) ?body ...) ) )
105    ;
106    ((synch (?mtx (?lock-arg0 ...)) ?body ...)
107      (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
108    ;
109    ((synch (?mtx) ?body ...)
110      (synch (?mtx () () (current-synch-abandon?)) ?body ...) )
111    ;
112    ((synch ?mtx ?body ...)
113      (synch (?mtx) ?body ...) ) ) )
114;;
115
116(define-syntax synch-lock
117  (syntax-rules ()
118    ;
119    ((synch-lock (?mtx (?lock-arg0 ...)) ?body ...)
120      ;eval args ahead of time
121      (let (
122        (lock-args (list ?lock-arg0 ...))
123        (mtx ?mtx)
124        (ok? #f) )
125        ;do not continue when cannot get a lock
126        (when (apply mutex-lock! mtx lock-args)
127          (dynamic-wind
128            void
129            (lambda ()
130              (let (
131                (res (begin ?body ...)) )
132                (set! ok? #t)
133                res))
134            (lambda ()
135              (unless ok?
136                (mutex-unlock! mtx)))) ) ) )
137    ;
138    ((synch-lock ?mtx ?body ...)
139      (synch-lock (?mtx ()) ?body ...) ) ) )
140
141(define-syntax synch-unlock
142  (syntax-rules ()
143    ;
144    ((synch-unlock (?mtx (?unlock-arg0 ...)) ?body ...)
145      (let (
146        (unlock-args (list ?unlock-arg0 ...))
147        (mtx ?mtx) )
148        ;race-condition
149        (let ((st (mutex-state mtx)))
150          (if (or (eq 'abandoned st) (eq 'not-abandoned st))
151            (error 'synch-unlock "mutex unlocked" mtx)
152            (dynamic-wind
153              void
154              (lambda () ?body ...)
155              (lambda () (apply mutex-unlock! mtx unlock-args)) ) ) ) ) )
156    ;
157    ((synch-unlock ?mtx ?body ...)
158      (synch-unlock (?mtx ()) ?body ...) ) ) )
159
160;;
161
162(include "synch-incl")
163
164) ;module synch-dynexn
Note: See TracBrowser for help on using the repository browser.