-
Notifications
You must be signed in to change notification settings - Fork 1
/
main.rkt
136 lines (104 loc) · 3.08 KB
/
main.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
#lang racket/base
;; Bindings to express & solve semaphore problems
;; TODO
;; - express constraints, random testing
(provide
(all-from-out racket/base racket/class)
(for-syntax (all-from-out racket/base syntax/parse racket/syntax))
;; Essentials
define-event define-event*
;; (define-event X)
;; Declares a callable event X. For use in later threads
define-thread
;; (define-thread ID EXPR* ...)
;; Declares, but does not run, a thread named ID that should execute
;; each EXPR* in sequence when run.
lock<%>
;; Interface for locks:
;; Methods:
;; - wait
;; aka lock
;; - signal
;; aka unlock
(struct-out abstract-lock)
;; Struct "interface" for locks
;; Fields are 'wait' and 'signal'
repeat forever
;; Syntax for making loops.
;; `repeat n e* ...` does `e* ...` exactly `n` times.
;; `forever e* ...` loops indefinitely
run
;; (run)
;; Runs all threads scheduled with `define-thread`
wait signal
;; Semaphore operations, optionally take a natural number
with
;; (with S e* ...)
;; Shorthand for acquiring & releasing a semaphore `S`
incr decr
;; Syntax for boxes
)
(provide
;; --- Don't use these values!
;; They are used internally by macros here
thread* random-sleep
)
;; -----------------------------------------------------------------------------
(require
racket/class
(for-syntax racket/base syntax/parse racket/syntax))
;; =============================================================================
(define thread* (box '()))
(define (random-sleep)
(sleep 0.1))
(define-syntax define-event
(syntax-parser
[(_ s:id)
#`(define s (lambda () (displayln #,(symbol->string (syntax-e #'s)))))]
[stx
(raise-user-error 'define-event (format "Expected a fresh identifier, got '~a'" (syntax->datum #'stx)))]))
(define-syntax-rule (define-event* s* ...)
(begin (define-event s*) ...))
(define-syntax define-thread
(syntax-parser
[(_ name:id e*:expr ...)
#'(begin
(define name (lambda () (begin (begin e* (random-sleep)) ...)))
(set-box! thread* (cons name (unbox thread*))))]
[stx
(raise-user-error 'define-thread (format "Expected (define-thread id expr* ...), got '~a'" #'stx))]))
(define-syntax-rule (repeat n e* ...)
(for ([__i (in-range n)])
(begin e* ...)))
(define-syntax-rule (forever e* ...)
(let loop ()
(begin e* ... (loop))))
(define-syntax run
(syntax-parser
[(_)
#'(for-each thread-wait (map thread (unbox thread*)))]))
(define-syntax-rule (with s e* ...)
(begin (wait s) (let ([r (begin e* ...)]) (signal s) r)))
(define lock<%>
(interface ()
signal
;; Unlock
wait
;; Lock
))
(struct abstract-lock (
signal ;; (-> Void)
wait ;; (-> Void)
))
;; -----------------------------------------------------------------------------
;; -- Non-critical syntax
(define (wait S [N 1])
(for ([_i (in-range N)])
(semaphore-wait S)))
(define (signal S [N 1])
(for ([_i (in-range N)])
(semaphore-post S)))
(define-syntax-rule (incr b)
(set-box! b (add1 (unbox b))))
(define-syntax-rule (decr b)
(set-box! b (sub1 (unbox b))))