-
Notifications
You must be signed in to change notification settings - Fork 1
/
init.rkt
363 lines (335 loc) · 20 KB
/
init.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
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
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
#lang racket
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initial environments, etc.
(require "env.rkt"
"data.rkt"
"parse.rkt"
"mutrec.rkt")
(provide initial-env meets-arity?
init-envs!)
;; This file exports:
;; initial-env - initial R4RS environment
;; meets-arity? - for testing arity match
(define initial-info
; name type optional-attribute(s)
; where optional-attribute(s) are any of:
; (S tag con-index) is a selector
; (P tag ...) is a predicate
; (C tag) is a constructor
; (M tag con-index val-index) is a mutator
; (X) applications with constant args may be simplified
; (A) allocates
; (R) uses global state
; (W) modifies global state, diverges, or raises an error
; when applied type correct
'(; booleans
(not (_ -> (+ true false)) (X))
; equivalence predicates
(eqv? (_ _ -> (+ true false)) (R) (X))
(eq? (_ _ -> (+ true false)) (R) (X))
(equal? (_ _ -> (+ true false)) (W))
; pairs and lists
(cons (_ _ -> cons) (C cons) (A))
(car (cons -> _) (S cons 0) (R))
(cdr (cons -> _) (S cons 1) (R))
(set-car! (cons _ -> void) (M cons 0 1) (W))
(set-cdr! (cons _ -> void) (M cons 1 1) (W))
; symbols
(symbol->string (sym -> str) (X))
(string->symbol (str -> sym) (X))
; numbers
(complex? (_ -> (+ true false)) (X))
(real? (_ -> (+ true false)) (X))
(rational? (_ -> (+ true false)) (X))
(integer? (_ -> (+ true false)) (X))
(exact? (num -> (+ true false)) (X))
(inexact? (num -> (+ true false)) (X))
(= (num num (&list num) -> (+ true false)) (X))
(< (num num (&list num) -> (+ true false)) (X))
(> (num num (&list num) -> (+ true false)) (X))
(<= (num num (&list num) -> (+ true false)) (X))
(>= (num num (&list num) -> (+ true false)) (X))
(zero? (num -> (+ true false)) (X))
(positive? (num -> (+ true false)) (X))
(negative? (num -> (+ true false)) (X))
(odd? (num -> (+ true false)) (X))
(even? (num -> (+ true false)) (X))
(max (num (&list num) -> num) (X))
(min (num (&list num) -> num) (X))
(+ ((&list num) -> num) (X))
(* ((&list num) -> num) (X))
(- (num (&list num) -> num) (X))
(/ (num (&list num) -> num) (W))
(abs (num -> num) (X))
(quotient (num num -> num) (W))
(remainder (num num -> num) (W))
(modulo (num num -> num) (W))
(gcd ((&list num) -> num) (X))
(lcm ((&list num) -> num) (X))
(numerator (num -> num) (X))
(denominator (num -> num) (X))
(floor (num -> num) (X))
(ceiling (num -> num) (X))
(truncate (num -> num) (X))
(round (num -> num) (X))
(rationalize (num num -> num) (X))
(exp (num -> num) (X))
(log (num -> num) (W))
(sin (num -> num) (X))
(cos (num -> num) (X))
(tan (num -> num) (X))
(asin (num -> num) (X))
(acos (num -> num) (X))
(atan (num (&optional num) -> num) (X))
(sqrt (num -> num) (X))
(expt (num num -> num) (X))
(make-rectangular (num num -> num) (X))
(make-polar (num num -> num) (X))
(real-part (num -> num) (X))
(imag-part (num -> num) (X))
(magnitude (num -> num) (X))
(angle (num -> num) (X))
(exact->inexact (num -> num) (X))
(inexact->exact (num -> num) (X))
(number->string (num (&optional num) -> str) (X))
(string->number (str (&optional num) -> num) (X))
; characters
(char=? (char char -> (+ true false)) (X))
(char<? (char char -> (+ true false)) (X))
(char>? (char char -> (+ true false)) (X))
(char<=? (char char -> (+ true false)) (X))
(char>=? (char char -> (+ true false)) (X))
(char-ci=? (char char -> (+ true false)) (X))
(char-ci<? (char char -> (+ true false)) (X))
(char-ci>? (char char -> (+ true false)) (X))
(char-ci<=? (char char -> (+ true false)) (X))
(char-ci>=? (char char -> (+ true false)) (X))
(char-alphabetic? (char -> (+ true false)) (X))
(char-numeric? (char -> (+ true false)) (X))
(char-whitespace? (char -> (+ true false)) (X))
(char-upper-case? (char -> (+ true false)) (X))
(char-lower-case? (char -> (+ true false)) (X))
(char->integer (char -> num) (X))
(integer->char (num -> char) (W))
(char-upcase (char -> char) (X))
(char-downcase (char -> char) (X))
; strings
(make-string (num (&optional char) -> str) (A))
(string ((&list char) -> str) (A))
(string-length (str -> num) (X) (R))
(string-ref (str num -> char) (R))
(string-set! (str num char -> void) (W))
(string=? (str str -> (+ true false)) (X))
(string<? (str str -> (+ true false)) (X))
(string>? (str str -> (+ true false)) (X))
(string<=? (str str -> (+ true false)) (X))
(string>=? (str str -> (+ true false)) (X))
(string-ci=? (str str -> (+ true false)) (X))
(string-ci<? (str str -> (+ true false)) (X))
(string-ci>? (str str -> (+ true false)) (X))
(string-ci<=? (str str -> (+ true false)) (X))
(string-ci>=? (str str -> (+ true false)) (X))
(substring (str num num -> str) (W))
(string-append ((&list str) -> str) (R))
(string-copy (str -> str) (R))
(string-fill! (str char -> void) (W))
; vectors
(make-vector (num (&optional _) -> vec) (C vec) (A))
(vector ((&list _) -> vec) (C vec) (A))
(vector-length ((+ vec0 vec) -> num) (X) (R))
(vector-ref ((+ vec0 vec) num -> _) (S vec 0) (R))
(vector-set! ((+ vec0 vec) num _ -> void) (M vec 0 2) (W))
(vector-fill! ((+ vec0 vec) _ -> void) (M vec 0 1) (W))
; input and output
(input-port? (_ -> (+ true false)) (P (iport)))
(output-port? (_ -> (+ true false)) (P (oport)))
(current-input-port (-> iport) (R))
(current-output-port (-> oport) (R))
(open-input-file (str -> iport) (R))
(open-output-file (str -> oport) (R))
(close-input-port (iport -> void) (W))
(close-output-port (oport -> void) (W))
(read ((&optional iport) -> (+)) (W)) ; handled specially in flow.scm
(read-char ((&optional iport) -> (+ char eof)) (W))
(peek-char ((&optional iport) -> (+ char eof)) (R))
(char-ready? ((&optional iport) -> (+ true false)) (R))
(write (_ (&optional oport) -> void) (W))
(display (_ (&optional oport) -> void) (W))
(newline ((&optional oport) -> void) (W))
(write-char (char (&optional oport) -> void) (W))
; system interface
(load (str -> void) (W))
(transcript-on (str -> void) (W))
(transcript-off (-> void) (W))
; non R4RS extensions
; misc
(symbol-append ((&list _) -> sym) (X))
(box (_ -> box) (C box) (A))
(unbox (box -> _) (S box 0) (R))
(set-box! (box _ -> void) (M box 0 1) (W))
(void (-> void) (X))
(raise ((&list _) -> (+)) (W))
; Chez extensions
(error ((&list _) -> (+)) (W))
(reset (-> (+)) (W))
(gensym (-> sym) (W))
(pretty-print (_ (&optional oport) -> void) (W))
(printf (str (&list _) -> void) (W))
(format (str (&list _) -> void) (W))
(cpu-time (-> num) (W))
(real-time (-> num) (W))
(collect ((&optional num) -> void) (W))
(flush-output ((&optional oport) -> void) (W))
(compile-file (str str -> void) (W))
(print-length ((&optional (+ num false)) -> (+ num false)) (W))
(pretty-maximum-lines ((&optional (+ num false)) -> (+ num false)) (W))
(print-level ((&optional (+ num false)) -> (+ num false)) (W))
(gensym-prefix ((&optional str) -> str) (W))
(gensym-count ((&optional num) -> num) (W))
(fl+ ((&list num) -> num) (W))
(fl* ((&list num) -> num) (W))
(fl- (num (&list num) -> num) (W))
(fl/ (num (&list num) -> num) (W))
(fx+ ((&list num) -> num) (W))
(fx* ((&list num) -> num) (W))
(fx- (num (&list num) -> num) (W))
(fx/ (num (&list num) -> num) (W))
(fx= (num num (&list num) -> (+ true false)) (W))
(fx< (num num (&list num) -> (+ true false)) (W))
(fx> (num num (&list num) -> (+ true false)) (W))
(fx<= (num num (&list num) -> (+ true false)) (W))
(fx>= (num num (&list num) -> (+ true false)) (W))
(fxlogand ((&list num) -> num) (W))
(fxlogor ((&list num) -> num) (W))
(fxlognot (num -> num) (W))
(delete-file (str -> void) (W))
(file-exists? (str -> (+ true false)) (R))
(current-directory ((&optional str) -> void) (W))
(eval (_ -> (+)) (W)) ; handled specially in flow.scm
(get (_ -> (+)) (W)) ; handled specially in flow.scm
(expand-once (_ -> (+)) (W)) ; handled specially in flow.scm
(optimize-level ((&optional num) -> (+ void num)) (W))
; for match
(match:error (_ (&list _) -> (+)) (W))
; predicates
(number? (_ -> (+ true false)) (X) (P (num)))
(null? (_ -> (+ true false)) (X) (P (nil)))
(char? (_ -> (+ true false)) (X) (P (char)))
(symbol? (_ -> (+ true false)) (X) (P (sym)))
(string? (_ -> (+ true false)) (X) (P (str)))
(vector? (_ -> (+ true false)) (X) (P (vec)))
(box? (_ -> (+ true false)) (X) (P (box)))
(pair? (_ -> (+ true false)) (X) (P (cons)))
(procedure? (_ -> (+ true false)) (X) (P (closure cont)))
(eof-object? (_ -> (+ true false)) (X) (P (eof)))
(input-port? (_ -> (+ true false)) (X) (P (iport)))
(output-port? (_ -> (+ true false)) (X) (P (oport)))
(boolean? (_ -> (+ true false)) (X))
(list? (_ -> (+ true false)) (X))
))
(define special-info
'((qcons (_ _ -> cons) (C cons) (A))
(qbox (_ -> box) (C box) (A))
(qvector ((&list _) -> vec) (C vec) (A))
(qlist ((&list _) -> (+)) (A))
(qmerge-list ((&list _) -> (+)) (A))
; handles
(make-handle (_ -> handle) (R))
(handle-ref (handle _ -> _) (S handle 0) (R))
(handle-set! (handle _ -> void) (M handle 0 1) (W))
(make-closure (_ (&list _) -> (+)) (A))
(closure-ref (_ _ -> (+)) (R))
(closure-set! (_ _ _ -> void) (W))
(closure? (_ -> (+ true false)) )
(internal-apply (_ (&list _) -> (+)) (W))
))
(define init-prim
(lambda (make-print-name)
(lambda (l env)
(match l
[(list-rest name type attr)
(let ([find-attr (lambda (x)
(let ((r (assq x attr)))
(and r (cdr r))))])
(extend-env env name
(let ([n (make-Name (make-print-name name) '())])
(set-Name-binder! n
(let-values ([(arity args result) (parse-type type)])
(Primitive
(cond
((find-attr 'C)
=> (lambda (x) (Constructor (car x))))
((find-attr 'P)
=> (lambda (x) (Predicate (car x))))
((find-attr 'S)
=> (lambda (x) (Selector (car x) (cadr x))))
((find-attr 'M)
=> (lambda (x) (Mutator (car x) (cadr x) (caddr x))))
(else (Simple)))
arity
args
result
(if (find-attr 'X) #t #f)
(cond [(find-attr 'W) 'W]
[(find-attr 'R) 'R]
[(find-attr 'A) 'A]
[else #f]))))
n)))]))))
;; Parse a type description into
;; arity description, which is one of:
;; positive integer N - fixed arity
;; (N N+1) for N positive - N args plus 1 optional
;; negative N - -N or more
;; argument constructor list list
;; result constructor list
(define parse-type
(letrec ([parse-union
(match-lambda
['_ '_]
[(? symbol? s) (list s)]
[(cons '+ results) results])])
(lambda (t)
(let loop ([t t] [arity 0] [args '()] [opt #f] [var #f])
(match (car t)
['->
(let ([arity-list (cond (opt (list arity (+ 1 arity)))
(var (list (- (- arity) 1)))
(else (list arity)))]
(result (parse-union (cadr t))))
(values arity-list (reverse args) result))]
[`(&list ,a)
(loop (cdr t) arity (cons (parse-union a) args) opt #t)]
[`(&optional ,a)
(loop (cdr t) arity (cons (parse-union a) args) #t var)]
[a
(loop (cdr t) (+ 1 arity) (cons (parse-union a) args) opt var)])))))
(define meets-arity?
(lambda (arity-spec nargs)
(ormap
(lambda (n)
(or (= n nargs)
(and (negative? n) (<= (- (- n) 1) nargs))))
arity-spec)))
(set-applies-to?!
(lambda (arity-spec type-spec arg-types)
(and (meets-arity? arity-spec (length arg-types))
(let loop ([provided arg-types] [required type-spec])
(or (null? provided)
(and (andmap
(lambda (t)
(or (eq? '_ (car required)) (memq t (car required))))
(car provided))
(loop (cdr provided)
(if (null? (cdr required))
required
(cdr required)))))))))
(define initial-env #f)
(define (init-envs!)
(set! initial-env
(foldr (init-prim (lambda (x) x))
basic-env
initial-info))
(set-special-env!
(foldr (init-prim (lambda (x) x))
quote-env
special-info)))