smalltalk-tng

annotate r6f/vau-cps.rkt @ 323:454c18798969

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