1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/r6f/vau-cps.rkt	Tue Feb 07 11:34:20 2012 -0500
     1.3 @@ -0,0 +1,352 @@
     1.4 +#lang racket/base
     1.5 +
     1.6 +(require rackunit)
     1.7 +
     1.8 +(struct operative (formals envformal body staticenv) #:transparent)
     1.9 +(struct applicative (underlying) #:transparent)
    1.10 +(struct primitive (underlying) #:transparent)
    1.11 +
    1.12 +(define (vau-eval exp env k)
    1.13 +  (cond
    1.14 +   ((symbol? exp) (k (lookup exp env)))
    1.15 +   ((not (pair? exp)) (k exp))
    1.16 +   (else (vau-eval (car exp) env (make-combiner (cdr exp) env k)))))
    1.17 +
    1.18 +(define (make-combiner argtree env k)
    1.19 +  (lambda (rator)
    1.20 +    (cond
    1.21 +     ((procedure? rator)
    1.22 +      (vau-eval-args argtree '() env (make-primitive-applier rator k)))
    1.23 +     ((operative? rator)
    1.24 +      (vau-eval (operative-body rator)
    1.25 +		(extend (operative-staticenv rator)
    1.26 +			(bind! (vau-match (operative-formals rator)
    1.27 +					  argtree)
    1.28 +			       (operative-envformal rator)
    1.29 +			       env))
    1.30 +		k))
    1.31 +     ((applicative? rator)
    1.32 +      (vau-eval-args argtree
    1.33 +		     '()
    1.34 +		     env
    1.35 +		     (make-applicative-combiner (applicative-underlying rator) env k)))
    1.36 +     ((primitive? rator)
    1.37 +      (apply (primitive-underlying rator) k env argtree))
    1.38 +     (else (vau-error 'vau-eval "Not a callable: ~v with argtree: ~v" rator argtree)))))
    1.39 +
    1.40 +(define (make-primitive-applier rator k)
    1.41 +  (lambda (args)
    1.42 +    (k (apply rator args))))
    1.43 +
    1.44 +(define (make-applicative-combiner op env k)
    1.45 +  (lambda (args)
    1.46 +    (vau-eval (cons op args) env k)))
    1.47 +
    1.48 +(define (vau-eval-args args revacc env k)
    1.49 +  (if (null? args)
    1.50 +      (k (reverse revacc))
    1.51 +      (vau-eval (car args) env
    1.52 +		(make-args-evaler (cdr args) revacc env k))))
    1.53 +
    1.54 +(define (make-args-evaler remainder revacc env k)
    1.55 +  (lambda (v)
    1.56 +    (vau-eval-args remainder (cons v revacc) env k)))
    1.57 +
    1.58 +(define (vau-error . args)
    1.59 +  (apply error args))
    1.60 +
    1.61 +(define (lookup name env)
    1.62 +  (if (null? env)
    1.63 +      (vau-error 'vau-eval "Variable not found: ~v" name)
    1.64 +      (hash-ref (car env) name (lambda () (lookup name (cdr env))))))
    1.65 +
    1.66 +(define (extend env rib)
    1.67 +  (cons rib env))
    1.68 +
    1.69 +(define (bind! rib name value)
    1.70 +  (if (eq? name '#:ignore)
    1.71 +      rib
    1.72 +      (begin (hash-set! rib name value)
    1.73 +	     rib)))
    1.74 +
    1.75 +(define (empty-env)
    1.76 +  '())
    1.77 +
    1.78 +(define (empty-rib)
    1.79 +  (make-hash))
    1.80 +
    1.81 +(define (vau-match p v)
    1.82 +  (let m ((p p)
    1.83 +	  (v v)
    1.84 +	  (rib (empty-rib)))
    1.85 +    (cond
    1.86 +     ((pair? p) (if (pair? v)
    1.87 +		    (m (cdr p) (cdr v) (m (car p) (car v) rib))
    1.88 +		    (vau-error 'vau-match "Expected a pair matching ~v; got ~v" p v)))
    1.89 +     ((symbol? p) (bind! rib p v))
    1.90 +     ((eq? p '#:ignore) rib)
    1.91 +     (else (if (eqv? p v)
    1.92 +	       rib
    1.93 +	       (vau-error 'vau-match "Expected a literal eqv? to ~v; got ~v" p v))))))
    1.94 +
    1.95 +(define (vau-lexer [port (current-input-port)])
    1.96 +  (let ()
    1.97 +    (define (eat!) (read-char port))
    1.98 +    (define (emit val) (eat!) val)
    1.99 +    (define (emit-number acc)
   1.100 +      (string->number (list->string (reverse acc))))
   1.101 +    (define (go state . args)
   1.102 +      (eat!)
   1.103 +      (apply state (peek-char port) args))
   1.104 +    (define (keywordize str)
   1.105 +      (cond
   1.106 +       ((string=? str "t") #t)
   1.107 +       ((string=? str "f") #f)
   1.108 +       (else (string->keyword str))))
   1.109 +    (define (start c)
   1.110 +      (cond
   1.111 +       ((eof-object? c) (emit c))
   1.112 +       ((char-whitespace? c) (go start))
   1.113 +       ((char-numeric? c) (go number (list c)))
   1.114 +       (else (case c
   1.115 +	       ((#\;) (go line-comment))
   1.116 +	       ((#\-) (go negsign))
   1.117 +	       ((#\") (go string (list)))
   1.118 +	       ((#\#) (go symbol (list) keywordize))
   1.119 +	       ((#\() (emit #\())
   1.120 +	       ((#\)) (emit #\)))
   1.121 +	       (else (go symbol (list c) string->symbol))))))
   1.122 +    (define (line-comment c)
   1.123 +      (case c
   1.124 +	((#\return #\newline) (go start))
   1.125 +	(else (go line-comment))))
   1.126 +    (define (negsign c)
   1.127 +      (cond
   1.128 +       ((and (char? c) (char-numeric? c)) (number c (list #\-)))
   1.129 +       (else (symbol c (list #\-) string->symbol))))
   1.130 +    (define (number c acc)
   1.131 +      (cond
   1.132 +       ((eof-object? c) (emit-number acc))
   1.133 +       ((char-numeric? c) (go number (cons c acc)))
   1.134 +       ((eqv? c #\.) (go fraction (cons c acc)))
   1.135 +       (else (exponent c acc))))
   1.136 +    (define (fraction c acc)
   1.137 +      (cond
   1.138 +       ((eof-object? c) (emit-number acc))
   1.139 +       ((char-numeric? c) (go fraction (cons c acc)))
   1.140 +       (else (exponent c acc))))
   1.141 +    (define (exponent c acc)
   1.142 +      (case c
   1.143 +	((#\e #\E) (go expsign (cons c acc)))
   1.144 +	(else (emit-number acc))))
   1.145 +    (define (expsign c acc)
   1.146 +      (case c
   1.147 +	((#\- #\+) (go expdigits (cons c acc)))
   1.148 +	(else (cond
   1.149 +	       ((eof-object? c) (emit-number acc))
   1.150 +	       ((char-numeric? c) (go expdigits (cons c acc)))
   1.151 +	       (else (vau-error 'vau-lexer
   1.152 +				"Syntax error: expected at least one digit in exponent"))))))
   1.153 +    (define (expdigits c acc)
   1.154 +      (cond
   1.155 +       ((eof-object? c) (emit-number acc))
   1.156 +       ((char-numeric? c) (go expdigits (cons c acc)))
   1.157 +       (else (emit-number acc))))
   1.158 +    (define (string c acc)
   1.159 +      (case c
   1.160 +	((#\") (emit (list->string (reverse acc))))
   1.161 +	((#\\) (go string-escape acc))
   1.162 +	(else (if (eof-object? c)
   1.163 +		  (vau-error 'vau-lexer "Syntax error: unterminated string")
   1.164 +		  (go string (cons c acc))))))
   1.165 +    (define (string-escape c acc)
   1.166 +      (case c
   1.167 +	((#\\ #\") (go string (cons c acc)))
   1.168 +	(else (vau-error 'vau-lexer "Syntax error: bad escape in string: ~v" c))))
   1.169 +    (define (symbol c acc finalize)
   1.170 +      (cond
   1.171 +       ((eof-object? c) (emit (finalize (list->string (reverse acc)))))
   1.172 +       ((char-alphabetic? c) (go symbol (cons c acc) finalize))
   1.173 +       ((char-numeric? c) (go symbol (cons c acc) finalize))
   1.174 +       ((memv c '(#\- #\! #\@ #\$ #\% #\^ #\& #\* #\_ #\= #\+ #\: #\< #\> #\/ #\?))
   1.175 +	(go symbol (cons c acc) finalize))
   1.176 +       (else (finalize (list->string (reverse acc))))))
   1.177 +    (lambda () (start (peek-char port)))))
   1.178 +
   1.179 +(define (vau-read [port (current-input-port)])
   1.180 +  (let ((next (vau-lexer port)))
   1.181 +    (define (read)
   1.182 +      (read* (next)))
   1.183 +    (define (read* v)
   1.184 +      (cond
   1.185 +       ((eqv? v #\() (read-list '()))
   1.186 +       ((eqv? v #\)) (vau-error 'vau-read "Syntax error: unexpected close paren"))
   1.187 +       (else v)))
   1.188 +    (define (read-list acc)
   1.189 +      (let ((v (next)))
   1.190 +	(cond
   1.191 +	 ((eof-object? v) (vau-error 'vau-read "End-of-file in unterminated list"))
   1.192 +	 ((eqv? v #\)) (reverse acc))
   1.193 +	 (else (read-list (cons (read* v) acc))))))
   1.194 +    (read)))
   1.195 +
   1.196 +(define (lex-all s)
   1.197 +  (let ((next (vau-lexer (open-input-string s))))
   1.198 +    (let loop ()
   1.199 +      (let ((v (next)))
   1.200 +	(if (eof-object? v)
   1.201 +	    '()
   1.202 +	    (cons v (loop)))))))
   1.203 +
   1.204 +(check-equal? (lex-all "abc") '(abc))
   1.205 +(check-equal? (lex-all "\"abc\"") '("abc"))
   1.206 +(check-equal? (lex-all "\"ab\\\"c\"") '("ab\"c"))
   1.207 +(check-equal? (lex-all "abc 123e-2 -2.34e2 12 -12") '(abc 1.23 -234.0 12 -12))
   1.208 +(check-equal? (lex-all "(abc()( abc ) abc (#abc) ()abc)")
   1.209 +	      '(#\( abc #\( #\) #\( abc #\) abc #\( #:abc #\) #\( #\) abc #\) ))
   1.210 +
   1.211 +(check-equal? (vau-read (open-input-string "(abc()( abc ) abc 12e0z (#abc) ()abc)"))
   1.212 +	      '(abc () (abc) abc 12.0 z (#:abc) () abc))
   1.213 +
   1.214 +;---------------------------------------------------------------------------
   1.215 +
   1.216 +(define (alist->rib xs)
   1.217 +  (let ((rib (empty-rib)))
   1.218 +    (for-each (lambda (entry)
   1.219 +		(bind! rib (car entry) (cadr entry)))
   1.220 +	      xs)
   1.221 +    rib))
   1.222 +
   1.223 +;---------------------------------------------------------------------------
   1.224 +
   1.225 +(define $begin
   1.226 +  (primitive (lambda (k dynenv . exps)
   1.227 +	       (if (null? exps)
   1.228 +		   (k (void))
   1.229 +		   (let loop ((exps exps))
   1.230 +		     (vau-eval (car exps) dynenv
   1.231 +			       (if (null? (cdr exps))
   1.232 +				   k
   1.233 +				   (lambda (v) (loop (cdr exps))))))))))
   1.234 +
   1.235 +(define $vau
   1.236 +  (primitive (lambda (k dynenv formals envformal . exps)
   1.237 +	       (let ((body (cond
   1.238 +			    ((null? exps) (void))
   1.239 +			    ((null? (cdr exps)) (car exps))
   1.240 +			    (else (cons $begin exps)))))
   1.241 +		 (k (operative formals envformal body dynenv))))))
   1.242 +
   1.243 +(define coreenv
   1.244 +  (extend (empty-env)
   1.245 +	  (alist->rib
   1.246 +	   `((eval ,(lambda (exp env) (vau-eval exp env values)))
   1.247 +	     (list* ,list*)
   1.248 +	     ($define! ,(primitive (lambda (k dynenv name valexp)
   1.249 +				     (when (not (symbol? name))
   1.250 +				       (vau-error '$define! "Needs symbol name; got ~v" name))
   1.251 +				     (vau-eval valexp dynenv
   1.252 +				       (lambda (value)
   1.253 +					 ;; TODO: destructuring-bind definitions
   1.254 +					 (bind! (car dynenv) name value)
   1.255 +					 (k value))))))
   1.256 +	     ($begin ,$begin)
   1.257 +	     ($vau ,$vau)
   1.258 +	     (wrap ,applicative)
   1.259 +	     (unwrap ,applicative-underlying)
   1.260 +	     ;; (unwrap ,(lambda (x)
   1.261 +	     ;; 		(cond
   1.262 +	     ;; 		 ((applicative? x) (applicative-underlying x))
   1.263 +	     ;; 		 ((procedure? x) (primitive (lambda (k dynenv . args)
   1.264 +	     ;; 					      (k (apply x args))))))))
   1.265 +	     ))))
   1.266 +
   1.267 +(define $lambda
   1.268 +  (vau-eval `($define! $lambda
   1.269 +		       ($vau (formals . exps) dynenv
   1.270 +			     (wrap (eval (list* $vau formals #:ignore exps) dynenv))))
   1.271 +	    coreenv
   1.272 +	    values))
   1.273 +
   1.274 +;---------------------------------------------------------------------------
   1.275 +
   1.276 +(define baseenv
   1.277 +  (extend coreenv
   1.278 +	  (alist->rib
   1.279 +	   `(($if ,(primitive (lambda (k dynenv test true false)
   1.280 +				(vau-eval test dynenv
   1.281 +				  (lambda (result)
   1.282 +				    (case result
   1.283 +				      ((#t) (vau-eval true dynenv k))
   1.284 +				      ((#f) (vau-eval false dynenv k))
   1.285 +				      (else (vau-error '$if "Test must evaluate to boolean"))))))))
   1.286 +	     ($let ,(primitive (lambda (k dynenv bindings . exps)
   1.287 +				 (vau-eval (list* (list* $lambda (map car bindings) exps)
   1.288 +						  (map cadr bindings))
   1.289 +					   dynenv
   1.290 +					   k))))
   1.291 +
   1.292 +	     ;; (make-environment ,(lambda parents
   1.293 +	     ;; 			  (extend (apply append parents) (empty-rib))))
   1.294 +	     ;; (operative? ,(lambda (x)
   1.295 +	     ;; 		    (or (operative? x)
   1.296 +	     ;; 			(primitive? x))))
   1.297 +	     ;; (applicative? ,(lambda (x)
   1.298 +	     ;; 		      (or (applicative? x)
   1.299 +	     ;; 			  (procedure? x))))
   1.300 +
   1.301 +	     (open-input-file ,open-input-file)
   1.302 +	     (close-input-port ,close-input-port)
   1.303 +	     (eof-object? ,eof-object?)
   1.304 +
   1.305 +	     (read ,vau-read)
   1.306 +
   1.307 +	     (write ,write)
   1.308 +	     (display ,display)
   1.309 +	     (newline ,newline)
   1.310 +	     (flush-output ,flush-output)
   1.311 +	     (format ,format)
   1.312 +
   1.313 +	     (box ,box)
   1.314 +	     (unbox ,unbox)
   1.315 +	     (set-box! ,set-box!)
   1.316 +
   1.317 +	     (+ ,+) (- ,-) (* ,*) (/ ,/)
   1.318 +	     (quotient ,quotient) (remainder ,remainder) (modulo ,modulo)
   1.319 +	     (number->string ,number->string) (string->number ,string->number)
   1.320 +
   1.321 +	     (cons ,cons)
   1.322 +	     (car ,car)
   1.323 +	     (cdr ,cdr)
   1.324 +	     (pair? ,pair?)
   1.325 +	     (null? ,null?)
   1.326 +
   1.327 +	     (symbol? ,symbol?)
   1.328 +
   1.329 +	     (eq? ,eq?)
   1.330 +	     (eqv? ,eqv?)
   1.331 +	     (not ,not)
   1.332 +	     (hash->list ,hash->list)
   1.333 +
   1.334 +	     ))))
   1.335 +
   1.336 +(define $load!
   1.337 +  (vau-eval `($define! $load!
   1.338 +		       ($vau (filename-exp) dynenv
   1.339 +			     ($define! filename (eval filename-exp dynenv))
   1.340 +			     ($define! p (open-input-file filename))
   1.341 +			     ($define! loop
   1.342 +				       ($lambda ()
   1.343 +						($let ((exp (read p)))
   1.344 +						      ($if (eof-object? exp)
   1.345 +							   ($begin (close-input-port p)
   1.346 +								   #:ignore)
   1.347 +							   ($begin (eval exp dynenv)
   1.348 +								   (loop))))))
   1.349 +			     (loop)))
   1.350 +	    baseenv
   1.351 +	    values))
   1.352 +
   1.353 +(let () ;; new scope to suppress toplevel expr result printing
   1.354 +  (vau-eval `($load! "prelude.vau") baseenv values)
   1.355 +  (void))