jacob/cs5
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Wow

Browse Source
This commit is contained in:
jacob
2026-05-26 10:04:15 -04:00
parent df4462b436
commit c3a09556b3
1 changed files with 215 additions and 167 deletions
Download Patch File Download Diff File Expand all files Collapse all files
15-compilation-part-2/main.rkt
+215 -167
View File
@@ -15,19 +15,19 @@
| { <TOY> <TOY> ... } | { <TOY> <TOY> ... }
|# |#
(define-type BINDINGS (Listof (Listof Symbol))) (define-type BINDINGS = (Listof (Listof Symbol)))
;; A matching abstract syntax tree datatype: ;; A matching abstract syntax tree datatype:
(define-type TOY (define-type TOY
[Num Number] [Num Number]
[Id Symbol] [Id Symbol]
[Set Symbol TOY] [Set Symbol TOY]
[Bind (Listof Symbol) (Listof TOY) (Listof TOY)] [Bind (Listof Symbol) (Listof TOY) (Listof TOY)]
[BindRec (Listof Symbol) (Listof TOY) (Listof TOY)] [BindRec (Listof Symbol) (Listof TOY) (Listof TOY)]
[Fun (Listof Symbol) (Listof TOY)] [Fun (Listof Symbol) (Listof TOY)]
[RFun (Listof Symbol) (Listof TOY)] [RFun (Listof Symbol) (Listof TOY)]
[Call TOY (Listof TOY)] [Call TOY (Listof TOY)]
[If TOY TOY TOY]) [If TOY TOY TOY])
(: unique-list? : (Listof Any) -> Boolean) (: unique-list? : (Listof Any) -> Boolean)
;; Tests whether a list is unique, guards Bind and Fun values. ;; Tests whether a list is unique, guards Bind and Fun values.
@@ -36,11 +36,37 @@
(and (not (member (first xs) (rest xs))) (and (not (member (first xs) (rest xs)))
(unique-list? (rest xs))))) (unique-list? (rest xs)))))
; Parametric types having to end in '-of' is dumb.
(define-type (Perhapsof A)
[Some A]
[None])
(: index-of : Symbol (Listof Symbol) -> (Perhapsof Natural))
(define (index-of name names)
(: loop : (Listof Symbol) Natural -> (Perhapsof Natural))
(define (loop remaining idx)
(cond [(null? remaining) (None)]
[(symbol=? name (first remaining)) (Some idx)]
[else (loop (rest remaining) (add1 idx))]))
(loop names 0))
(: find-index : Symbol BINDINGS -> (Perhapsof (List Natural Natural)))
(define (find-index name bindings)
(: loop : BINDINGS Natural -> (Perhapsof (List Natural Natural)))
(define (loop rest-bindings binding-idx)
(cond [(null? rest-bindings) (None)]
[else
(let ([name-idx (index-of name (first rest-bindings))])
(cases name-idx
[(Some idx-in-scope) (Some (list binding-idx idx-in-scope))]
[(None) (loop (rest rest-bindings) (add1 binding-idx))]))]))
(loop bindings 0))
(: parse-sexpr : Sexpr -> TOY) (: parse-sexpr : Sexpr -> TOY)
;; parses s-expressions into TOYs ;; parses s-expressions into TOYs
(define (parse-sexpr sexpr) (define (parse-sexpr sexpr)
(match sexpr (match sexpr
[(number: n) (Num n)] [(number: n) (Num n)]
[(symbol: name) (Id name)] [(symbol: name) (Id name)]
[(cons 'set! more) [(cons 'set! more)
(match sexpr (match sexpr
@@ -49,24 +75,24 @@
[(cons (and binder (or 'bind 'bindrec)) more) [(cons (and binder (or 'bind 'bindrec)) more)
(match sexpr (match sexpr
[(list _ (list (list (symbol: names) (sexpr: nameds)) ...) [(list _ (list (list (symbol: names) (sexpr: nameds)) ...)
body0 body ...) body0 body ...)
(if (unique-list? names) (if (unique-list? names)
((if (eq? 'bind binder) Bind BindRec) ((if (eq? 'bind binder) Bind BindRec)
names names
(map parse-sexpr nameds) (map parse-sexpr nameds)
(map parse-sexpr (cons body0 body))) (map parse-sexpr (cons body0 body)))
(error 'parse-sexpr "duplicate `~s' names: ~s" binder names))] (error 'parse-sexpr "duplicate `~s' names: ~s" binder names))]
[else (error 'parse-sexpr "bad `~s' syntax in ~s" [else (error 'parse-sexpr "bad `~s' syntax in ~s"
binder sexpr)])] binder sexpr)])]
[(cons (and funner (or 'fun 'rfun)) more) [(cons (and funner (or 'fun 'rfun)) more)
(match sexpr (match sexpr
[(list _ (list (symbol: names) ...) [(list _ (list (symbol: names) ...)
body0 body ...) body0 body ...)
(if (unique-list? names) (if (unique-list? names)
((if (eq? 'fun funner) Fun RFun) ((if (eq? 'fun funner) Fun RFun)
names names
(map parse-sexpr (cons body0 body))) (map parse-sexpr (cons body0 body)))
(error 'parse-sexpr "duplicate `~s' names: ~s" funner names))] (error 'parse-sexpr "duplicate `~s' names: ~s" funner names))]
[else (error 'parse-sexpr "bad `~s' syntax in ~s" [else (error 'parse-sexpr "bad `~s' syntax in ~s"
funner sexpr)])] funner sexpr)])]
[(cons 'if more) [(cons 'if more)
@@ -87,74 +113,65 @@
;;; ================================================================== ;;; ==================================================================
;;; Values and environments ;;; Values and environments
(define-type ENV (define-type ENV = (Listof (Listof (Boxof VAL))))
[EmptyEnv]
[FrameEnv FRAME ENV])
;; a frame is an association list of names and values.
(define-type FRAME = (Listof (List Symbol (Boxof VAL))))
(define-type VAL (define-type VAL
[BogusV] [BogusV]
[RktV Any] [RktV Any]
[FunV (Listof Symbol) (ENV -> VAL) ENV Boolean] ; `byref?' flag [FunV (Listof Symbol) (ENV -> VAL) ENV Boolean] ; `byref?' flag
[PrimV ((Listof VAL) -> VAL)]) [PrimV ((Listof VAL) -> VAL)])
;; a single bogus value to use wherever needed ;; a single bogus value to use wherever needed
(define the-bogus-value (BogusV)) (define the-bogus-value (BogusV))
(: raw-extend : (Listof Symbol) (Listof (Boxof VAL)) ENV -> ENV) (: extend : (Listof VAL) ENV -> ENV)
;; extends an environment with a new frame, given names and value
;; boxes
(define (raw-extend names boxed-values env)
(if (= (length names) (length boxed-values))
(FrameEnv (map (lambda ([name : Symbol] [boxed-val : (Boxof VAL)])
(list name boxed-val))
names boxed-values)
env)
(error 'raw-extend "arity mismatch for names: ~s" names)))
(: extend : (Listof Symbol) (Listof VAL) ENV -> ENV)
;; extends an environment with a new frame (given plain values). ;; extends an environment with a new frame (given plain values).
(define (extend names values env) (define (extend names values env)
(raw-extend names (map (inst box VAL) values) env)) (cons (map (inst box VAL) values) env))
(: extend-rec : (Listof Symbol) (Listof (ENV -> VAL)) ENV -> ENV) (: extend-rec : (Listof (ENV -> VAL)) ENV -> ENV)
;; extends an environment with a new recursive frame (given compiled ;; extends an environment with a new recursive frame (given compiled
;; expressions). ;; expressions).
(define (extend-rec names compiled-exprs env) (define (extend-rec compiled-exprs env)
(define new-env (define new-boxes
(extend names (map (λ (_) (box the-bogus-value)) compiled-exprs))
(map (lambda (_) the-bogus-value) compiled-exprs) (define new-frame new-boxes)
env)) (define new-env (cons new-frame env))
;; note: no need to check the lengths here, since this is only ;; note: no need to check the lengths here, since this is only
;; called for `bindrec', and the syntax make it impossible to have ;; called for `bindrec', and the syntax make it impossible to have
;; different lengths ;; different lengths
(for-each (lambda ([name : Symbol] [compiled : (ENV -> VAL)]) (for-each (lambda ([boxed-val : (Boxof VAL)] [compiled : (ENV -> VAL)])
(set-box! (lookup name new-env) (compiled new-env))) (set-box! boxed-val (compiled new-env)))
names compiled-exprs) new-boxes compiled-exprs)
new-env) new-env)
(: lookup : Symbol ENV -> (Boxof VAL)) (: framerefbox : (Listof (Boxof VAL)) Natural -> (Boxof VAL))
;; looks for a name in an environment, searching through each frame. ;; Gets you the box at idx in the frame.
(define (lookup name env) (define (framerefbox frame idx)
(cases env (if (null? frame)
[(EmptyEnv) (error 'lookup "no binding for ~s" name)] (error 'framerefbox "no binding found for index ~s" idx)
[(FrameEnv frame rest) (if (zero? idx)
(let ([cell (assq name frame)]) (first frame)
(if cell (framerefbox (rest frame) (sub1 idx)))))
(second cell)
(lookup name rest)))])) (: envrefbox : ENV Natural Natural -> (Boxof VAL))
;; Gets you the box at (frameidx, keyidx) in an environment.
(define (envrefbox env frameidx keyidx)
(if (null? env)
(error 'envrefbox "no binding found for frame index ~s" frameidx)
(if (zero? frameidx)
(framerefbox (first env) keyidx)
(envrefbox (rest env) (sub1 frameidx) keyidx))))
(: unwrap-rktv : VAL -> Any) (: unwrap-rktv : VAL -> Any)
;; helper for `racket-func->prim-val': unwrap a RktV wrapper in ;; helper for `racket-func->prim-val': unwrap a RktV wrapper in
;; preparation to be sent to the primitive function ;; preparation to be sent to the primitive function
(define (unwrap-rktv x) (define (unwrap-rktv x)
(cases x (cases x
[(RktV v) v] [(RktV v) v]
[else (error 'racket-func "bad input: ~s" x)])) [else (error 'racket-func "bad input: ~s" x)]))
(: racket-func->prim-val : Function -> (Boxof VAL)) (: racket-func->prim-val : Function -> VAL)
;; converts a racket function to a primitive evaluator function which ;; converts a racket function to a primitive evaluator function which
;; is a PrimV holding a ((Listof VAL) -> VAL) function. (the ;; is a PrimV holding a ((Listof VAL) -> VAL) function. (the
;; resulting function will use the list function as is, and it is the ;; resulting function will use the list function as is, and it is the
@@ -162,23 +179,29 @@
;; bad number of arguments or bad input types.) ;; bad number of arguments or bad input types.)
(define (racket-func->prim-val racket-func) (define (racket-func->prim-val racket-func)
(define list-func (make-untyped-list-function racket-func)) (define list-func (make-untyped-list-function racket-func))
(box (PrimV (lambda (args) (PrimV (lambda (args)
(RktV (list-func (map unwrap-rktv args))))))) (RktV (list-func (map unwrap-rktv args))))))
;; The global environment has a few primitives: ;; The global environment has a few primitives:
(: global-environment : ENV) (: global-environment : (Listof (List Symbol VAL)))
(define global-environment (define global-environment
(FrameEnv (list (list '+ (racket-func->prim-val +)) (list (list '+ (racket-func->prim-val +))
(list '- (racket-func->prim-val -)) (list '- (racket-func->prim-val -))
(list '* (racket-func->prim-val *)) (list '* (racket-func->prim-val *))
(list '/ (racket-func->prim-val /)) (list '/ (racket-func->prim-val /))
(list '< (racket-func->prim-val <)) (list '< (racket-func->prim-val <))
(list '> (racket-func->prim-val >)) (list '> (racket-func->prim-val >))
(list '= (racket-func->prim-val =)) (list '= (racket-func->prim-val =))
;; values ;; values
(list 'true (box (RktV #t))) (list 'true (RktV #t))
(list 'false (box (RktV #f)))) (list 'false (RktV #f))))
(EmptyEnv)))
(: global-lookup : Symbol -> VAL)
(define (global-lookup name)
(let ([cell (assq name global-environment)])
(if cell
(second cell)
(error 'global-lookup "no binding for ~s" name))))
;;; ================================================================== ;;; ==================================================================
;;; Compilation ;;; Compilation
@@ -193,13 +216,13 @@
(unless (unbox compiler-enabled?) (unless (unbox compiler-enabled?)
(error 'compile-body "compiler disabled")) (error 'compile-body "compiler disabled"))
(let ([compiled-1st (compile (first exprs) bin)] (let ([compiled-1st (compile (first exprs) bin)]
[rest (rest exprs)]) [rest (rest exprs)])
(if (null? rest) (if (null? rest)
compiled-1st compiled-1st
(let ([compiled-rest (compile-body rest bin)]) (let ([compiled-rest (compile-body rest bin)])
(lambda (env) (lambda (env)
(define ignored (compiled-1st env)) (define ignored (compiled-1st env))
(compiled-rest env)))))) (compiled-rest env))))))
(: compile-get-boxes : (Listof TOY) BINDINGS -> (ENV -> (Listof (Boxof VAL)))) (: compile-get-boxes : (Listof TOY) BINDINGS -> (ENV -> (Listof (Boxof VAL))))
;; utility for applying rfun ;; utility for applying rfun
@@ -207,12 +230,17 @@
(: compile-getter : TOY -> (ENV -> (Boxof VAL))) (: compile-getter : TOY -> (ENV -> (Boxof VAL)))
(define (compile-getter expr) (define (compile-getter expr)
(cases expr (cases expr
[(Id name) [(Id name)
(lambda ([env : ENV]) (lookup name env))] (cases (find-index name bin)
[else [(Some location) (λ ([env : ENV])
(lambda ([env : ENV]) (envrefbox env (first location) (second location)))]
(error 'call "rfun application with a non-identifier ~s" [(None) (if (assq name global-environment)
expr))])) (λ ([_ : ENV]) (error 'call "rfun can't use global ~s" name))
(error 'compile-get-boxes "no binding for ~s" name))])]
[else
(lambda ([_ : ENV])
(error 'call "rfun application with a non-identifier ~s"
expr))]))
(unless (unbox compiler-enabled?) (unless (unbox compiler-enabled?)
(error 'compile-get-boxes "compiler disabled")) (error 'compile-get-boxes "compiler disabled"))
(let ([getters (map compile-getter exprs)]) (let ([getters (map compile-getter exprs)])
@@ -229,72 +257,84 @@
(lambda (compiled) (compiled env))) (lambda (compiled) (compiled env)))
(unless (unbox compiler-enabled?) (unless (unbox compiler-enabled?)
(error 'compile "compiler disabled")) (error 'compile "compiler disabled"))
(: compile* : TOY -> (ENV -> VAL))
(define (compile* expr*) (compile expr* bin))
(cases expr (cases expr
[(Num n) (lambda ([env : ENV]) (RktV n))] [(Num n) (lambda ([env : ENV]) (RktV n))]
[(Id name) (lambda ([env : ENV]) (unbox (lookup name env)))] [(Id name)
[(Set name new) (cases (find-index name bin)
(define compiled-new (compile new)) [(Some location) (λ ([env : ENV]) (unbox (envrefbox env (first location) (second location))))]
(lambda ([env : ENV]) [(None) (let ([global-val (global-lookup name)])
(set-box! (lookup name env) (compiled-new env)) (λ ([_ : ENV]) global-val))])]
the-bogus-value)] [(Set name new)
[(Bind names exprs bound-body) (define compiled-new (compile new bin))
(define compiled-exprs (map compile exprs)) (cases (find-index name bin)
(define compiled-body (compile-body bound-body)) [(Some location)
(lambda ([env : ENV]) (λ ([env : ENV])
(compiled-body (set-box! (envrefbox env (first location) (second location))
(extend names (map (caller env) compiled-exprs) env)))] (compiled-new env))
[(BindRec names exprs bound-body) the-bogus-value)]
(define compiled-exprs (map compile exprs)) [(None)
(define compiled-body (compile-body bound-body)) (let ([_ (global-lookup name)])
(lambda ([env : ENV]) (λ ([_ : ENV]) (error 'compile "can't set flobal binding for ~s" name)))])]
(compiled-body (extend-rec names compiled-exprs env)))] [(Bind names exprs bound-body)
[(Fun names bound-body) (define compiled-exprs (map compile* exprs))
(define compiled-body (compile-body bound-body)) (define compiled-body (compile-body bound-body (cons names bin)))
(lambda ([env : ENV]) (FunV names compiled-body env #f))] (lambda ([env : ENV])
[(RFun names bound-body) (compiled-body
(define compiled-body (compile-body bound-body)) (extend (map (caller env) compiled-exprs) env)))]
(lambda ([env : ENV]) (FunV names compiled-body env #t))] [(BindRec names exprs bound-body)
[(Call fun-expr arg-exprs) (: ah : (Listof (Listof Symbol)))
(define compiled-fun (compile fun-expr)) (define ah (cons names bin))
(define compiled-args (map compile arg-exprs)) (define compiled-exprs (map (λ ([x : TOY]) (compile x ah)) exprs))
(define compiled-boxes-getter (compile-get-boxes arg-exprs)) (define compiled-body (compile-body bound-body ah))
(lambda ([env : ENV]) (lambda ([env : ENV])
(define fval (compiled-fun env)) (compiled-body (extend-rec compiled-exprs env)))]
;; delay evaluating the arguments [(Fun names bound-body)
(define arg-vals (lambda () (map (caller env) compiled-args))) (define compiled-body (compile-body bound-body (cons names bin)))
(cases fval (lambda ([env : ENV]) (FunV names compiled-body env #f))]
[(PrimV proc) (proc (arg-vals))] [(RFun names bound-body)
[(FunV names compiled-body fun-env byref?) (define compiled-body (compile-body bound-body (cons names bin)))
(compiled-body (if byref? (lambda ([env : ENV]) (FunV names compiled-body env #t))]
(raw-extend names [(Call fun-expr arg-exprs)
(compiled-boxes-getter env) (define compiled-fun (compile fun-expr bin))
fun-env) (define compiled-args (map compile* arg-exprs))
(extend names (arg-vals) fun-env)))] (define compiled-boxes-getter (compile-get-boxes arg-exprs bin))
[else (error 'call "function call with a non-function: ~s" (lambda ([env : ENV])
fval)]))] (define fval (compiled-fun env))
[(If cond-expr then-expr else-expr) ;; delay evaluating the arguments
(define compiled-cond (compile cond-expr)) (define arg-vals (lambda () (map (caller env) compiled-args)))
(define compiled-then (compile then-expr)) (cases fval
(define compiled-else (compile else-expr)) [(PrimV proc) (proc (arg-vals))]
(lambda ([env : ENV]) [(FunV names compiled-body fun-env byref?)
((if (cases (compiled-cond env) (compiled-body (if byref?
[(RktV v) v] ; Racket value => use as boolean (cons (compiled-boxes-getter env) fun-env)
[else #t]) ; other values are always true (extend (arg-vals) fun-env)))]
compiled-then [else (error 'call "function call with a non-function: ~s"
compiled-else) fval)]))]
env))])) [(If cond-expr then-expr else-expr)
(define compiled-cond (compile cond-expr bin))
(define compiled-then (compile then-expr bin))
(define compiled-else (compile else-expr bin))
(lambda ([env : ENV])
((if (cases (compiled-cond env)
[(RktV v) v] ; Racket value => use as boolean
[else #t]) ; other values are always true
compiled-then
compiled-else)
env))]))
(: run : String -> Any) (: run : String -> Any)
;; compiles and runs a TOY program contained in a string ;; compiles and runs a TOY program contained in a string
(define (run str) (define (run str)
(set-box! compiler-enabled? #t) (set-box! compiler-enabled? #t)
(let ([compiled (compile (parse str))]) (let ([compiled (compile (parse str) '(()))])
(set-box! compiler-enabled? #f) (set-box! compiler-enabled? #f)
(let ([result (compiled global-environment)]) (let ([result (compiled '())])
(cases result (cases result
[(RktV v) v] [(RktV v) v]
[else (error 'run "the program returned a bad value: ~s" [else (error 'run "the program returned a bad value: ~s"
result)])))) result)]))))
;;; ================================================================== ;;; ==================================================================
;;; Tests ;;; Tests
@@ -322,25 +362,27 @@
=> 124) => 124)
;; More tests for complete coverage ;; More tests for complete coverage
(test (run "{bind x 5 x}") =error> "bad `bind' syntax") (test (run "{bind x 5 x}") =error> "bad `bind' syntax")
(test (run "{fun x x}") =error> "bad `fun' syntax") (test (run "{fun x x}") =error> "bad `fun' syntax")
(test (run "{if x}") =error> "bad `if' syntax") (test (run "{if x}") =error> "bad `if' syntax")
(test (run "{}") =error> "bad syntax") (test (run "{}") =error> "bad syntax")
(test (run "{bind {{x 5} {x 5}} x}") =error> "duplicate*bind*names") (test (run "{bind {{x 5} {x 5}} x}") =error> "duplicate*bind*names")
(test (run "{fun {x x} x}") =error> "duplicate*fun*names") (test (run "{fun {x x} x}") =error> "duplicate*fun*names")
(test (run "{+ x 1}") =error> "no binding for") (test (run "{+ x 1}") =error> "no binding for")
(test (run "{+ 1 {fun {x} x}}") =error> "bad input") (test (run "{+ 1 {fun {x} x}}") =error> "bad input")
(test (run "{+ 1 {fun {x} x}}") =error> "bad input") (test (run "{+ 1 {fun {x} x}}") =error> "bad input")
(test (run "{1 2}") =error> "with a non-function") (test (run "{1 2}") =error> "with a non-function")
(test (run "{{fun {x} x}}") =error> "arity mismatch") (test (run "{{fun {x} x}}") =error> "arity mismatch")
(test (run "{if {< 4 5} 6 7}") => 6) (test (run "{if {< 4 5} 6 7}") => 6)
(test (run "{if {< 5 4} 6 7}") => 7) (test (run "{if {< 5 4} 6 7}") => 7)
(test (run "{if + 6 7}") => 6) (test (run "{if + 6 7}") => 6)
(test (run "{fun {x} x}") =error> "returned a bad value") (test (run "{fun {x} x}") =error> "returned a bad value")
;; assignment tests ;; assignment tests
(test (run "{set! {+ x 1} x}") =error> "bad `set!' syntax") (test (run "{set! {+ x 1} x}") =error> "bad `set!' syntax")
(test (run "{bind {{x 1}} {set! x {+ x 1}} x}") => 2) (test (run "{bind {{x 1}} {set! x {+ x 1}} x}") => 2)
(test (run "{set! + 1}") =error> "set")
(test (run "{set! nope 1}") =error> "no binding")
;; `bindrec' tests ;; `bindrec' tests
(test (run "{bindrec {x 6} x}") =error> "bad `bindrec' syntax") (test (run "{bindrec {x 6} x}") =error> "bad `bindrec' syntax")
@@ -384,13 +426,19 @@
(test (run "{{rfun {x} x} {/ 4 0}}") =error> "non-identifier") (test (run "{{rfun {x} x} {/ 4 0}}") =error> "non-identifier")
(test (run "{5 {/ 6 0}}") =error> "non-function") (test (run "{5 {/ 6 0}}") =error> "non-function")
(test (index-of 'k '(a b k c)) => (Some 2))
(test (index-of 'k '(a b c)) => (None))
(test (find-index 'k '((a b) (k y) (k z))) => (Some '(1 0)))
(test (find-index 'a '((a b) (k y))) => (Some '(0 0)))
(test (find-index 'q '((a b) (k y))) => (None))
;; test compiler-disabled flag, for complete coverage ;; test compiler-disabled flag, for complete coverage
;; (these tests must use the functions instead of the toplevel `run', ;; (these tests must use the functions instead of the toplevel `run',
;; since there is no way to get this error otherwise, this indicates ;; since there is no way to get this error otherwise, this indicates
;; that this error should not occur outside of our code -- it is an ;; that this error should not occur outside of our code -- it is an
;; internal error check) ;; internal error check)
(test (compile (Num 1)) =error> "compiler disabled") (test (compile (Num 1) '(())) =error> "compiler disabled")
(test (compile-body (list (Num 1))) =error> "compiler disabled") (test (compile-body (list (Num 1)) '(())) =error> "compiler disabled")
(test (compile-get-boxes (list (Num 1))) =error> "compiler disabled") (test (compile-get-boxes (list (Num 1)) '(())) =error> "compiler disabled")
;;; ================================================================== ;;; ==================================================================