smalltalk-tng
view r6f/vau-cps.rkt @ 324:aaedb3bcc2ea
Experiments with x86_64 syscalls from assembler on OS X 10.6.
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sun, 07 Oct 2012 22:29:10 -0400 |
| parents | |
| 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 k)
10 (cond
11 ((symbol? exp) (k (lookup exp env)))
12 ((not (pair? exp)) (k exp))
13 (else (vau-eval (car exp) env (make-combiner (cdr exp) env k)))))
15 (define (make-combiner argtree env k)
16 (lambda (rator)
17 (cond
18 ((procedure? rator)
19 (vau-eval-args argtree '() env (make-primitive-applier rator k)))
20 ((operative? rator)
21 (vau-eval (operative-body rator)
22 (extend (operative-staticenv rator)
23 (bind! (vau-match (operative-formals rator)
24 argtree)
25 (operative-envformal rator)
26 env))
27 k))
28 ((applicative? rator)
29 (vau-eval-args argtree
30 '()
31 env
32 (make-applicative-combiner (applicative-underlying rator) env k)))
33 ((primitive? rator)
34 (apply (primitive-underlying rator) k env argtree))
35 (else (vau-error 'vau-eval "Not a callable: ~v with argtree: ~v" rator argtree)))))
37 (define (make-primitive-applier rator k)
38 (lambda (args)
39 (k (apply rator args))))
41 (define (make-applicative-combiner op env k)
42 (lambda (args)
43 (vau-eval (cons op args) env k)))
45 (define (vau-eval-args args revacc env k)
46 (if (null? args)
47 (k (reverse revacc))
48 (vau-eval (car args) env
49 (make-args-evaler (cdr args) revacc env k))))
51 (define (make-args-evaler remainder revacc env k)
52 (lambda (v)
53 (vau-eval-args remainder (cons v revacc) env k)))
55 (define (vau-error . args)
56 (apply error args))
58 (define (lookup name env)
59 (if (null? env)
60 (vau-error 'vau-eval "Variable not found: ~v" name)
61 (hash-ref (car env) name (lambda () (lookup name (cdr env))))))
63 (define (extend env rib)
64 (cons rib env))
66 (define (bind! rib name value)
67 (if (eq? name '#:ignore)
68 rib
69 (begin (hash-set! rib name value)
70 rib)))
72 (define (empty-env)
73 '())
75 (define (empty-rib)
76 (make-hash))
78 (define (vau-match p v)
79 (let m ((p p)
80 (v v)
81 (rib (empty-rib)))
82 (cond
83 ((pair? p) (if (pair? v)
84 (m (cdr p) (cdr v) (m (car p) (car v) rib))
85 (vau-error 'vau-match "Expected a pair matching ~v; got ~v" p v)))
86 ((symbol? p) (bind! rib p v))
87 ((eq? p '#:ignore) rib)
88 (else (if (eqv? p v)
89 rib
90 (vau-error 'vau-match "Expected a literal eqv? to ~v; got ~v" p v))))))
92 (define (vau-lexer [port (current-input-port)])
93 (let ()
94 (define (eat!) (read-char port))
95 (define (emit val) (eat!) val)
96 (define (emit-number acc)
97 (string->number (list->string (reverse acc))))
98 (define (go state . args)
99 (eat!)
100 (apply state (peek-char port) args))
101 (define (keywordize str)
102 (cond
103 ((string=? str "t") #t)
104 ((string=? str "f") #f)
105 (else (string->keyword str))))
106 (define (start c)
107 (cond
108 ((eof-object? c) (emit c))
109 ((char-whitespace? c) (go start))
110 ((char-numeric? c) (go number (list c)))
111 (else (case c
112 ((#\;) (go line-comment))
113 ((#\-) (go negsign))
114 ((#\") (go string (list)))
115 ((#\#) (go symbol (list) keywordize))
116 ((#\() (emit #\())
117 ((#\)) (emit #\)))
118 (else (go symbol (list c) string->symbol))))))
119 (define (line-comment c)
120 (case c
121 ((#\return #\newline) (go start))
122 (else (go line-comment))))
123 (define (negsign c)
124 (cond
125 ((and (char? c) (char-numeric? c)) (number c (list #\-)))
126 (else (symbol c (list #\-) string->symbol))))
127 (define (number c acc)
128 (cond
129 ((eof-object? c) (emit-number acc))
130 ((char-numeric? c) (go number (cons c acc)))
131 ((eqv? c #\.) (go fraction (cons c acc)))
132 (else (exponent c acc))))
133 (define (fraction c acc)
134 (cond
135 ((eof-object? c) (emit-number acc))
136 ((char-numeric? c) (go fraction (cons c acc)))
137 (else (exponent c acc))))
138 (define (exponent c acc)
139 (case c
140 ((#\e #\E) (go expsign (cons c acc)))
141 (else (emit-number acc))))
142 (define (expsign c acc)
143 (case c
144 ((#\- #\+) (go expdigits (cons c acc)))
145 (else (cond
146 ((eof-object? c) (emit-number acc))
147 ((char-numeric? c) (go expdigits (cons c acc)))
148 (else (vau-error 'vau-lexer
149 "Syntax error: expected at least one digit in exponent"))))))
150 (define (expdigits c acc)
151 (cond
152 ((eof-object? c) (emit-number acc))
153 ((char-numeric? c) (go expdigits (cons c acc)))
154 (else (emit-number acc))))
155 (define (string c acc)
156 (case c
157 ((#\") (emit (list->string (reverse acc))))
158 ((#\\) (go string-escape acc))
159 (else (if (eof-object? c)
160 (vau-error 'vau-lexer "Syntax error: unterminated string")
161 (go string (cons c acc))))))
162 (define (string-escape c acc)
163 (case c
164 ((#\\ #\") (go string (cons c acc)))
165 (else (vau-error 'vau-lexer "Syntax error: bad escape in string: ~v" c))))
166 (define (symbol c acc finalize)
167 (cond
168 ((eof-object? c) (emit (finalize (list->string (reverse acc)))))
169 ((char-alphabetic? c) (go symbol (cons c acc) finalize))
170 ((char-numeric? c) (go symbol (cons c acc) finalize))
171 ((memv c '(#\- #\! #\@ #\$ #\% #\^ #\& #\* #\_ #\= #\+ #\: #\< #\> #\/ #\?))
172 (go symbol (cons c acc) finalize))
173 (else (finalize (list->string (reverse acc))))))
174 (lambda () (start (peek-char port)))))
176 (define (vau-read [port (current-input-port)])
177 (let ((next (vau-lexer port)))
178 (define (read)
179 (read* (next)))
180 (define (read* v)
181 (cond
182 ((eqv? v #\() (read-list '()))
183 ((eqv? v #\)) (vau-error 'vau-read "Syntax error: unexpected close paren"))
184 (else v)))
185 (define (read-list acc)
186 (let ((v (next)))
187 (cond
188 ((eof-object? v) (vau-error 'vau-read "End-of-file in unterminated list"))
189 ((eqv? v #\)) (reverse acc))
190 (else (read-list (cons (read* v) acc))))))
191 (read)))
193 (define (lex-all s)
194 (let ((next (vau-lexer (open-input-string s))))
195 (let loop ()
196 (let ((v (next)))
197 (if (eof-object? v)
198 '()
199 (cons v (loop)))))))
201 (check-equal? (lex-all "abc") '(abc))
202 (check-equal? (lex-all "\"abc\"") '("abc"))
203 (check-equal? (lex-all "\"ab\\\"c\"") '("ab\"c"))
204 (check-equal? (lex-all "abc 123e-2 -2.34e2 12 -12") '(abc 1.23 -234.0 12 -12))
205 (check-equal? (lex-all "(abc()( abc ) abc (#abc) ()abc)")
206 '(#\( abc #\( #\) #\( abc #\) abc #\( #:abc #\) #\( #\) abc #\) ))
208 (check-equal? (vau-read (open-input-string "(abc()( abc ) abc 12e0z (#abc) ()abc)"))
209 '(abc () (abc) abc 12.0 z (#:abc) () abc))
211 ;---------------------------------------------------------------------------
213 (define (alist->rib xs)
214 (let ((rib (empty-rib)))
215 (for-each (lambda (entry)
216 (bind! rib (car entry) (cadr entry)))
217 xs)
218 rib))
220 ;---------------------------------------------------------------------------
222 (define $begin
223 (primitive (lambda (k dynenv . exps)
224 (if (null? exps)
225 (k (void))
226 (let loop ((exps exps))
227 (vau-eval (car exps) dynenv
228 (if (null? (cdr exps))
229 k
230 (lambda (v) (loop (cdr exps))))))))))
232 (define $vau
233 (primitive (lambda (k dynenv formals envformal . exps)
234 (let ((body (cond
235 ((null? exps) (void))
236 ((null? (cdr exps)) (car exps))
237 (else (cons $begin exps)))))
238 (k (operative formals envformal body dynenv))))))
240 (define coreenv
241 (extend (empty-env)
242 (alist->rib
243 `((eval ,(lambda (exp env) (vau-eval exp env values)))
244 (list* ,list*)
245 ($define! ,(primitive (lambda (k dynenv name valexp)
246 (when (not (symbol? name))
247 (vau-error '$define! "Needs symbol name; got ~v" name))
248 (vau-eval valexp dynenv
249 (lambda (value)
250 ;; TODO: destructuring-bind definitions
251 (bind! (car dynenv) name value)
252 (k value))))))
253 ($begin ,$begin)
254 ($vau ,$vau)
255 (wrap ,applicative)
256 (unwrap ,applicative-underlying)
257 ;; (unwrap ,(lambda (x)
258 ;; (cond
259 ;; ((applicative? x) (applicative-underlying x))
260 ;; ((procedure? x) (primitive (lambda (k dynenv . args)
261 ;; (k (apply x args))))))))
262 ))))
264 (define $lambda
265 (vau-eval `($define! $lambda
266 ($vau (formals . exps) dynenv
267 (wrap (eval (list* $vau formals #:ignore exps) dynenv))))
268 coreenv
269 values))
271 ;---------------------------------------------------------------------------
273 (define baseenv
274 (extend coreenv
275 (alist->rib
276 `(($if ,(primitive (lambda (k dynenv test true false)
277 (vau-eval test dynenv
278 (lambda (result)
279 (case result
280 ((#t) (vau-eval true dynenv k))
281 ((#f) (vau-eval false dynenv k))
282 (else (vau-error '$if "Test must evaluate to boolean"))))))))
283 ($let ,(primitive (lambda (k dynenv bindings . exps)
284 (vau-eval (list* (list* $lambda (map car bindings) exps)
285 (map cadr bindings))
286 dynenv
287 k))))
289 ;; (make-environment ,(lambda parents
290 ;; (extend (apply append parents) (empty-rib))))
291 ;; (operative? ,(lambda (x)
292 ;; (or (operative? x)
293 ;; (primitive? x))))
294 ;; (applicative? ,(lambda (x)
295 ;; (or (applicative? x)
296 ;; (procedure? x))))
298 (open-input-file ,open-input-file)
299 (close-input-port ,close-input-port)
300 (eof-object? ,eof-object?)
302 (read ,vau-read)
304 (write ,write)
305 (display ,display)
306 (newline ,newline)
307 (flush-output ,flush-output)
308 (format ,format)
310 (box ,box)
311 (unbox ,unbox)
312 (set-box! ,set-box!)
314 (+ ,+) (- ,-) (* ,*) (/ ,/)
315 (quotient ,quotient) (remainder ,remainder) (modulo ,modulo)
316 (number->string ,number->string) (string->number ,string->number)
318 (cons ,cons)
319 (car ,car)
320 (cdr ,cdr)
321 (pair? ,pair?)
322 (null? ,null?)
324 (symbol? ,symbol?)
326 (eq? ,eq?)
327 (eqv? ,eqv?)
328 (not ,not)
329 (hash->list ,hash->list)
331 ))))
333 (define $load!
334 (vau-eval `($define! $load!
335 ($vau (filename-exp) dynenv
336 ($define! filename (eval filename-exp dynenv))
337 ($define! p (open-input-file filename))
338 ($define! loop
339 ($lambda ()
340 ($let ((exp (read p)))
341 ($if (eof-object? exp)
342 ($begin (close-input-port p)
343 #:ignore)
344 ($begin (eval exp dynenv)
345 (loop))))))
346 (loop)))
347 baseenv
348 values))
350 (let () ;; new scope to suppress toplevel expr result printing
351 (vau-eval `($load! "prelude.vau") baseenv values)
352 (void))