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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
|
#lang racket
;; ZADANIE 1
;; =========
;; W tym zadaniu rozważamy język WHILE (w formie z grubsza
;; odpowiadającej tej z wykładu), z blokami deklarującymi zmienne o
;; lokalnym zakresie.
;; Zadanie polega na dodaniu do języka procedur definiowanych na
;; zewnątrz głównego polecenia programu (podobnie jak w C, gdzie
;; główne polecenie odpowiadałoby procedurze main, czy Pascalu) — o
;; dowolnym wybranym przez siebie modelu działania. W tym celu należy:
;; · rozszerzyć składnię abstrakcyjną o składnię procedur i rozbudować odpowiednio składnię programów
;; · rozszerzyć procedurę parsowania
;; · rozszerzyć ewaluator
;; · *opisać* wybrany model działania procedur, w tym jego potencjalne zalety lub ograniczenia
;; Należy rozszerzyć poniższy szablon, a część słowną zadania umieścić
;; w komentarzu, podobnie jak niniejsze polecenie.
;; Uwaga! Zadanie jest *bardzo* szeroko sformułowane, jest wiele
;; sensownych rozwiązań które stosowały liczne języki imperatywne w
;; historii — nie jest treścią zadania znalezienie *najlepszego*,
;; tylko swojego, które *rozumiecie*. Wybrany model działania procedur
;; *może* być relatywnie ubogi, jednak jeśli tak się zrobi, warto
;; pokazać że ma się tego świadomość w słownym opisie jego działania.
(struct const (val) #:transparent)
(struct binop (op l r) #:transparent)
(struct var-expr (name) #:transparent)
(struct call-expr (name args) #:transparent)
(struct return-expr (val) #:transparent)
(define (operator? x)
(member x '(+ * - / > < = >= <=)))
(define (keyword? x)
(member x '(skip while if := func call return)))
(define (expr? e)
(match e
[(const v)
(integer? v)]
[(var-expr x)
(and (symbol? x)
(not (keyword? x)))]
[(binop op l r)
(and (operator? op)
(expr? l)
(expr? r))]
[_ false]))
(struct skip () #:transparent)
(struct assign (id exp) #:transparent)
(struct if-cmd (exp ct cf) #:transparent)
(struct while (exp cmd) #:transparent)
(struct comp (left right) #:transparent)
(struct var-in (name expr cmd) #:transparent)
(struct function (name args cmd) #:transparent)
(define (cmd? c)
(match c
[(skip) true]
[(assign x e) (and (symbol? x) (expr? e))]
[(if-cmd e ct cf) (and (expr? e) (cmd? ct) (cmd? cf))]
[(while e c) (and (expr? e) (cmd? c))]
[(comp c1 c2) (and (cmd? c1) (cmd? c2))]
[(var-in x e c) (and (symbol? x) (expr? e) (cmd? c))]
[(function f a c) (and (symbol? f) (list? a) (andmap symbol? a) (cmd? c))]))
(define (prog? p)
(cmd? p))
(define (parse-expr p)
(cond
[(number? p) (const p)]
[(and (symbol? p)
(not (keyword? p)))
(var-expr p)]
[(and (list? p)
(= 3 (length p))
(operator? (car p)))
(binop (first p)
(parse-expr (second p))
(parse-expr (third p)))]
[(and (list? p) ; <------ wywołanie funkcji
(= (length p) 3)
(eq? (first p) 'call)
(symbol? (second p))
(list? (third p)))
(call-expr (second p) (map parse-expr (third p)))]
[else false]))
(define (parse-cmd q)
(cond
[(eq? q 'skip) (skip)]
[(and (list? q)
(= (length q) 3)
(eq? (second q) ':=))
(assign (first q) (parse-expr (third q)))]
[(and (list? q)
(= (length q) 4)
(eq? (first q) 'if))
(if-cmd (parse-expr (second q)) (parse-cmd (third q)) (parse-cmd (fourth q)))]
[(and (list? q)
(= (length q) 3)
(eq? (first q) 'while))
(while (parse-expr (second q)) (parse-cmd (third q)))]
[(and (list? q)
(= (length q) 3)
(eq? (first q) 'var)
(list? (second q))
(= (length (second q)) 2))
(var-in (first (second q))
(parse-expr (second (second q)))
(parse-cmd (third q)))]
[(and (list? q) ; <------ funkcje
(= (length q) 4)
(eq? (first q) 'func)
(symbol? (second q))
(list? (third q))
(andmap symbol? (third q)))
(function (second q) (third q) (parse-cmd (fourth q)))]
[(and (list? q)
(= (length q) 2)
(eq? (first q) 'return))
(return-expr (parse-expr (second q)))]
[(and (list? q)
(>= (length q) 2))
(desugar-comp (map parse-cmd q))]
[else false]))
(define (desugar-comp cs)
(if (null? (cdr cs))
(car cs)
(comp (car cs)
(desugar-comp (cdr cs)))))
(define (value? v)
(number? v))
(struct mem (xs) #:transparent)
(define (mem-lookup x m)
(define (assoc-lookup xs)
(cond
[(null? xs) (error "Undefined variable" x)]
[(eq? x (caar xs)) (cdar xs)]
[else (assoc-lookup (cdr xs))]))
(assoc-lookup (mem-xs m)))
(define (mem-defined? x m) ; <----------- !!! Sprawdz, czy x jest w ogole zdefiniowane
(define (assoc-lookup xs)
(cond
[(null? xs) #f]
[(eq? x (caar xs) #t)]
[else (assoc-lookup (cdr xs))]))
(assoc-lookup (mem-xs m)))
(define (mem-update x v m)
(define (assoc-update xs)
(cond
[(null? xs) (error "Undefined variable" x)]
[(eq? x (caar xs)) (cons (cons x v) (cdr xs))]
[else (cons (car xs) (assoc-update (cdr xs)))]))
(mem (assoc-update (mem-xs m))))
(define (mem-alloc x v m)
(mem (cons (cons x v) (mem-xs m))))
(define (mem-drop-last m)
(cond
[(null? (mem-xs m))
(error "Deallocating from empty memory")]
[else
(mem (cdr (mem-xs m)))]))
(define empty-mem
(mem null))
(define (op->proc op)
(match op
['+ +]
['- -]
['* *]
['/ /]
['< (lambda (x y) (if (< x y) 1 0))]
['> (lambda (x y) (if (> x y) 1 0))]
['= (lambda (x y) (if (= x y) 1 0))]
['<= (lambda (x y) (if (<= x y) 1 0))]
['>= (lambda (x y) (if (>= x y) 1 0))]
))
;; zał: (expr? e) i (mem? m) jest prawdą
;; (value? (eval e m)) jest prawdą
(define (eval e m)
(match e
[(const v) v]
[(var-expr x) (mem-lookup x m)]
[(binop op l r)
(let ((vl (eval l m))
(vr (eval r m))
(p (op->proc op)))
(p vl vr))]
[(call-expr name args)
(match (mem-lookup name m)
[(clo func-args cmd)
(if (= (length args) (length func-args))
(let* ([func-mem (assign-values args func-args m)]
[final-mem (eval-cmd cmd func-mem)]
[ret (mem-lookup 'RETURN final-mem)])
(if ret
ret
(error "No return statement in function" name)))
(error "Arity mismatch, function" name "takes" (length func-args) ", got" (length args)))]
[else (error "Undefined function" name)])]))
(define (assign-values args func-args mem)
(if (null? args)
mem
(assign-values (cdr args) (cdr func-args) (mem-alloc (car func-args) (eval (car args) mem) mem))))
(struct clo (args cmd))
;; zał: (cmd? c) (mem? m)
;; (mem? (eval-cmd c m))
(define (eval-cmd c m)
(if (mem-lookup 'RETURN m)
m
(match c
[(skip) m]
[(assign x e) (mem-update x (eval e m) m)]
[(if-cmd e ct cf) (if (= (eval e m) 0)
(eval-cmd cf m)
(eval-cmd ct m))]
[(while e cw) (if (= (eval e m) 0)
m
(let* ((m1 (eval-cmd cw m))
(m2 (eval-cmd c m1)))
m2))]
[(comp c1 c2) (let* ((m1 (eval-cmd c1 m))
(m2 (eval-cmd c2 m1)))
m2)]
[(var-in x e c) (let* ((v (eval e m))
(m1 (mem-alloc x v m))
(m2 (eval-cmd c m1)))
(mem-drop-last m2))]
[(function name args cmd)
(mem-alloc name (clo args cmd) m)]
[(return-expr val)
(mem-update 'RETURN (eval val m) m)]
[_ (error "Unknown command" c "— likely a syntax error")])))
(define (eval-prog p m)
(let ((final-mem (eval-cmd p (mem-alloc 'RETURN #f m))))
(with-handlers ([exn:fail? (lambda (v) (error "Undefined reference to main"))])
(match (mem-lookup 'main final-mem)
[(clo args cmd) (mem-lookup 'RETURN (eval-cmd cmd final-mem))]))))
(define WHILE_FACT
'({func decr (x)
{(x := (- x 1))
(return x)}}
{func main ()
{(i := 1)
(while (> t 0)
{(i := (* i t))
(t := (call decr (t)))})
(return i)}}
))
(define TEST
'({func decr (x) (return (- x 1))}
{func main ()
(var (x 1)
{(x := (+ x 1))
(return (call decr (x)))})}))
(define TEST2
'({func decr (x) (return (- x 1))}
{func main () (return (call decr (3)))}))
(define TEST3
'({func sth (x)
{(i := -1)
(return x)}}
{func main ()
{(i := 2)
(return (call sth (i)))}}))
(define TEST4
'(func f ()
{return 1}))
(define (fact n)
(let* ([init-env (mem-alloc 'i 1 (mem-alloc 't n empty-mem))])
(eval-prog (parse-cmd WHILE_FACT) init-env)))
|
