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