smalltalk-tng
view r6f/vau.rkt @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | 9e5c7b30f3e1 |
| children |
line source
1 #lang racket/base
3 (require rackunit)
5 (struct operative (formals envformal body staticenv) #:transparent)
6 (struct applicative (underlying) #:transparent)
7 (struct primitive (underlying) #:transparent)
9 (define (vau-eval exp env)
10 (let v ((exp exp))
11 (cond
12 ((symbol? exp) (lookup exp env))
13 ((not (pair? exp)) exp)
14 (else (let ((rator (v (car exp))))
15 (cond
16 ((procedure? rator) (apply rator (map v (cdr exp))))
17 ((operative? rator) (vau-eval (operative-body rator)
18 (extend (operative-staticenv rator)
19 (bind! (vau-match (operative-formals rator)
20 (cdr exp))
21 (operative-envformal rator)
22 env))))
23 ((applicative? rator) (v (cons (applicative-underlying rator)
24 (map v (cdr exp)))))
25 ((primitive? rator) (apply (primitive-underlying rator) (cons env (cdr exp))))
26 (else (vau-error 'vau-eval "Not a callable: ~v in exp: ~v" rator exp))))))))
28 (define (vau-error . args)
29 (apply error args))
31 (define (lookup name env)
32 (if (null? env)
33 (vau-error 'vau-eval "Variable not found: ~v" name)
34 (hash-ref (car env) name (lambda () (lookup name (cdr env))))))
36 (define (extend env rib)
37 (cons rib env))
39 (define (bind! rib name value)
40 (if (eq? name '#:ignore)
41 rib
42 (begin (hash-set! rib name value)
43 rib)))
45 (define (empty-env)
46 '())
48 (define (empty-rib)
49 (make-hash))
51 (define (vau-match p v)
52 (let m ((p p)
53 (v v)
54 (rib (empty-rib)))
55 (cond
56 ((pair? p) (if (pair? v)
57 (m (cdr p) (cdr v) (m (car p) (car v) rib))
58 (vau-error 'vau-match "Expected a pair matching ~v; got ~v" p v)))
59 ((symbol? p) (bind! rib p v))
60 ((eq? p '#:ignore) rib)
61 (else (if (eqv? p v)
62 rib
63 (vau-error 'vau-match "Expected a literal eqv? to ~v; got ~v" p v))))))
65 (define (vau-lexer [port (current-input-port)])
66 (let ()
67 (define (eat!) (read-char port))
68 (define (emit val) (eat!) val)
69 (define (emit-number acc)
70 (string->number (list->string (reverse acc))))
71 (define (go state . args)
72 (eat!)
73 (apply state (peek-char port) args))
74 (define (keywordize str)
75 (cond
76 ((string=? str "t") #t)
77 ((string=? str "f") #f)
78 (else (string->keyword str))))
79 (define (start c)
80 (cond
81 ((eof-object? c) (emit c))
82 ((char-whitespace? c) (go start))
83 ((char-numeric? c) (go number (list c)))
84 (else (case c
85 ((#\;) (go line-comment))
86 ((#\-) (go negsign))
87 ((#\") (go string (list)))
88 ((#\#) (go symbol (list) keywordize))
89 ((#\() (emit #\())
90 ((#\)) (emit #\)))
91 (else (go symbol (list c) string->symbol))))))
92 (define (line-comment c)
93 (case c
94 ((#\return #\newline) (go start))
95 (else (go line-comment))))
96 (define (negsign c)
97 (cond
98 ((and (char? c) (char-numeric? c)) (number c (list #\-)))
99 (else (symbol c (list #\-) string->symbol))))
100 (define (number c acc)
101 (cond
102 ((eof-object? c) (emit-number acc))
103 ((char-numeric? c) (go number (cons c acc)))
104 ((eqv? c #\.) (go fraction (cons c acc)))
105 (else (exponent c acc))))
106 (define (fraction c acc)
107 (cond
108 ((eof-object? c) (emit-number acc))
109 ((char-numeric? c) (go fraction (cons c acc)))
110 (else (exponent c acc))))
111 (define (exponent c acc)
112 (case c
113 ((#\e #\E) (go expsign (cons c acc)))
114 (else (emit-number acc))))
115 (define (expsign c acc)
116 (case c
117 ((#\- #\+) (go expdigits (cons c acc)))
118 (else (cond
119 ((eof-object? c) (emit-number acc))
120 ((char-numeric? c) (go expdigits (cons c acc)))
121 (else (vau-error 'vau-lexer
122 "Syntax error: expected at least one digit in exponent"))))))
123 (define (expdigits c acc)
124 (cond
125 ((eof-object? c) (emit-number acc))
126 ((char-numeric? c) (go expdigits (cons c acc)))
127 (else (emit-number acc))))
128 (define (string c acc)
129 (case c
130 ((#\") (emit (list->string (reverse acc))))
131 ((#\\) (go string-escape acc))
132 (else (if (eof-object? c)
133 (vau-error 'vau-lexer "Syntax error: unterminated string")
134 (go string (cons c acc))))))
135 (define (string-escape c acc)
136 (case c
137 ((#\\ #\") (go string (cons c acc)))
138 (else (vau-error 'vau-lexer "Syntax error: bad escape in string: ~v" c))))
139 (define (symbol c acc finalize)
140 (cond
141 ((eof-object? c) (emit (finalize (list->string (reverse acc)))))
142 ((char-alphabetic? c) (go symbol (cons c acc) finalize))
143 ((char-numeric? c) (go symbol (cons c acc) finalize))
144 ((memv c '(#\- #\! #\@ #\$ #\% #\^ #\& #\* #\_ #\= #\+ #\: #\< #\> #\/ #\?))
145 (go symbol (cons c acc) finalize))
146 (else (finalize (list->string (reverse acc))))))
147 (lambda () (start (peek-char port)))))
149 (define (vau-read [port (current-input-port)])
150 (let ((next (vau-lexer port)))
151 (define (read)
152 (read* (next)))
153 (define (read* v)
154 (cond
155 ((eqv? v #\() (read-list '()))
156 ((eqv? v #\)) (vau-error 'vau-read "Syntax error: unexpected close paren"))
157 (else v)))
158 (define (read-list acc)
159 (let ((v (next)))
160 (cond
161 ((eof-object? v) (vau-error 'vau-read "End-of-file in unterminated list"))
162 ((eqv? v #\)) (reverse acc))
163 (else (read-list (cons (read* v) acc))))))
164 (read)))
166 (define (lex-all s)
167 (let ((next (vau-lexer (open-input-string s))))
168 (let loop ()
169 (let ((v (next)))
170 (if (eof-object? v)
171 '()
172 (cons v (loop)))))))
174 (check-equal? (lex-all "abc") '(abc))
175 (check-equal? (lex-all "\"abc\"") '("abc"))
176 (check-equal? (lex-all "\"ab\\\"c\"") '("ab\"c"))
177 (check-equal? (lex-all "abc 123e-2 -2.34e2 12 -12") '(abc 1.23 -234.0 12 -12))
178 (check-equal? (lex-all "(abc()( abc ) abc (#abc) ()abc)")
179 '(#\( abc #\( #\) #\( abc #\) abc #\( #:abc #\) #\( #\) abc #\) ))
181 (check-equal? (vau-read (open-input-string "(abc()( abc ) abc 12e0z (#abc) ()abc)"))
182 '(abc () (abc) abc 12.0 z (#:abc) () abc))
184 ;---------------------------------------------------------------------------
186 (define (alist->rib xs)
187 (let ((rib (empty-rib)))
188 (for-each (lambda (entry)
189 (bind! rib (car entry) (cadr entry)))
190 xs)
191 rib))
193 ;---------------------------------------------------------------------------
195 (define $begin
196 (primitive (lambda (dynenv . exps)
197 (if (null? exps)
198 (void)
199 (let loop ((exps exps))
200 (if (null? (cdr exps))
201 (vau-eval (car exps) dynenv)
202 (begin (vau-eval (car exps) dynenv)
203 (loop (cdr exps)))))))))
205 (define $vau
206 (primitive (lambda (dynenv formals envformal . exps)
207 (let ((body (cond
208 ((null? exps) (void))
209 ((null? (cdr exps)) (car exps))
210 (else (cons $begin exps)))))
211 (operative formals envformal body dynenv)))))
213 (define coreenv
214 (extend (empty-env)
215 (alist->rib
216 `((eval ,vau-eval)
217 (list* ,list*)
218 ($define! ,(primitive (lambda (dynenv name valexp)
219 (let ((value (vau-eval valexp dynenv)))
220 (when (not (symbol? name))
221 (vau-error '$define! "Needs symbol name; got ~v" name))
222 ;; TODO: destructuring-bind definitions
223 (bind! (car dynenv) name value)
224 value))))
225 ($begin ,$begin)
226 ($vau ,$vau)
227 (wrap ,applicative)
228 (unwrap ,applicative-underlying)
229 ;; (unwrap ,(lambda (x)
230 ;; (cond
231 ;; ((applicative? x) (applicative-underlying x))
232 ;; ((procedure? x) (primitive (lambda (dynenv . args)
233 ;; (apply x args)))))))
234 ))))
236 (define $lambda
237 (vau-eval `($define! $lambda
238 ($vau (formals . exps) dynenv
239 (wrap (eval (list* $vau formals #:ignore exps) dynenv))))
240 coreenv))
242 ;---------------------------------------------------------------------------
244 (define baseenv
245 (extend coreenv
246 (alist->rib
247 `(($if ,(primitive (lambda (dynenv test true false)
248 (case (vau-eval test dynenv)
249 ((#t) (vau-eval true dynenv))
250 ((#f) (vau-eval false dynenv))
251 (else (vau-error '$if "Test must evaluate to boolean"))))))
252 ($let ,(primitive (lambda (dynenv bindings . exps)
253 (vau-eval (list* (list* $lambda (map car bindings) exps)
254 (map cadr bindings))
255 dynenv))))
257 ;; (make-environment ,(lambda parents
258 ;; (extend (apply append parents) (empty-rib))))
259 ;; (operative? ,(lambda (x)
260 ;; (or (operative? x)
261 ;; (primitive? x))))
262 ;; (applicative? ,(lambda (x)
263 ;; (or (applicative? x)
264 ;; (procedure? x))))
266 (open-input-file ,open-input-file)
267 (close-input-port ,close-input-port)
268 (eof-object? ,eof-object?)
270 (read ,vau-read)
272 (write ,write)
273 (display ,display)
274 (newline ,newline)
275 (flush-output ,flush-output)
276 (format ,format)
278 (box ,box)
279 (unbox ,unbox)
280 (set-box! ,set-box!)
282 (+ ,+) (- ,-) (* ,*) (/ ,/)
283 (quotient ,quotient) (remainder ,remainder) (modulo ,modulo)
284 (number->string ,number->string) (string->number ,string->number)
286 (cons ,cons)
287 (car ,car)
288 (cdr ,cdr)
289 (pair? ,pair?)
290 (null? ,null?)
292 (symbol? ,symbol?)
294 (eq? ,eq?)
295 (eqv? ,eqv?)
296 (not ,not)
297 (hash->list ,hash->list)
299 ))))
301 (define $load!
302 (vau-eval `($define! $load!
303 ($vau (filename-exp) dynenv
304 ($define! filename (eval filename-exp dynenv))
305 ($define! p (open-input-file filename))
306 ($define! loop
307 ($lambda ()
308 ($let ((exp (read p)))
309 ($if (eof-object? exp)
310 ($begin (close-input-port p)
311 #:ignore)
312 ($begin (eval exp dynenv)
313 (loop))))))
314 (loop)))
315 baseenv))
317 (let () ;; new scope to suppress toplevel expr result printing
318 (vau-eval `($load! "prelude.vau") baseenv)
319 (void))