From c3a09556b33939891300c3ddbc18d9f798526698 Mon Sep 17 00:00:00 2001 From: Jacob Signorovitch Date: Tue, 26 May 2026 10:04:15 -0400 Subject: [PATCH] Wow --- 15-compilation-part-2/main.rkt | 382 +++++++++++++++++++-------------- 1 file changed, 215 insertions(+), 167 deletions(-) diff --git a/15-compilation-part-2/main.rkt b/15-compilation-part-2/main.rkt index 552d360..e5c183d 100644 --- a/15-compilation-part-2/main.rkt +++ b/15-compilation-part-2/main.rkt @@ -15,19 +15,19 @@ | { ... } |# -(define-type BINDINGS (Listof (Listof Symbol))) +(define-type BINDINGS = (Listof (Listof Symbol))) ;; A matching abstract syntax tree datatype: (define-type TOY - [Num Number] - [Id Symbol] - [Set Symbol TOY] - [Bind (Listof Symbol) (Listof TOY) (Listof TOY)] - [BindRec (Listof Symbol) (Listof TOY) (Listof TOY)] - [Fun (Listof Symbol) (Listof TOY)] - [RFun (Listof Symbol) (Listof TOY)] - [Call TOY (Listof TOY)] - [If TOY TOY TOY]) + [Num Number] + [Id Symbol] + [Set Symbol TOY] + [Bind (Listof Symbol) (Listof TOY) (Listof TOY)] + [BindRec (Listof Symbol) (Listof TOY) (Listof TOY)] + [Fun (Listof Symbol) (Listof TOY)] + [RFun (Listof Symbol) (Listof TOY)] + [Call TOY (Listof TOY)] + [If TOY TOY TOY]) (: unique-list? : (Listof Any) -> Boolean) ;; Tests whether a list is unique, guards Bind and Fun values. @@ -36,11 +36,37 @@ (and (not (member (first xs) (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) ;; parses s-expressions into TOYs (define (parse-sexpr sexpr) (match sexpr - [(number: n) (Num n)] + [(number: n) (Num n)] [(symbol: name) (Id name)] [(cons 'set! more) (match sexpr @@ -49,24 +75,24 @@ [(cons (and binder (or 'bind 'bindrec)) more) (match sexpr [(list _ (list (list (symbol: names) (sexpr: nameds)) ...) - body0 body ...) + body0 body ...) (if (unique-list? names) - ((if (eq? 'bind binder) Bind BindRec) - names - (map parse-sexpr nameds) - (map parse-sexpr (cons body0 body))) - (error 'parse-sexpr "duplicate `~s' names: ~s" binder names))] + ((if (eq? 'bind binder) Bind BindRec) + names + (map parse-sexpr nameds) + (map parse-sexpr (cons body0 body))) + (error 'parse-sexpr "duplicate `~s' names: ~s" binder names))] [else (error 'parse-sexpr "bad `~s' syntax in ~s" binder sexpr)])] [(cons (and funner (or 'fun 'rfun)) more) (match sexpr [(list _ (list (symbol: names) ...) - body0 body ...) + body0 body ...) (if (unique-list? names) - ((if (eq? 'fun funner) Fun RFun) - names - (map parse-sexpr (cons body0 body))) - (error 'parse-sexpr "duplicate `~s' names: ~s" funner names))] + ((if (eq? 'fun funner) Fun RFun) + names + (map parse-sexpr (cons body0 body))) + (error 'parse-sexpr "duplicate `~s' names: ~s" funner names))] [else (error 'parse-sexpr "bad `~s' syntax in ~s" funner sexpr)])] [(cons 'if more) @@ -87,74 +113,65 @@ ;;; ================================================================== ;;; Values and environments -(define-type ENV - [EmptyEnv] - [FrameEnv FRAME ENV]) - -;; a frame is an association list of names and values. -(define-type FRAME = (Listof (List Symbol (Boxof VAL)))) +(define-type ENV = (Listof (Listof (Boxof VAL)))) (define-type VAL - [BogusV] - [RktV Any] - [FunV (Listof Symbol) (ENV -> VAL) ENV Boolean] ; `byref?' flag - [PrimV ((Listof VAL) -> VAL)]) + [BogusV] + [RktV Any] + [FunV (Listof Symbol) (ENV -> VAL) ENV Boolean] ; `byref?' flag + [PrimV ((Listof VAL) -> VAL)]) ;; a single bogus value to use wherever needed (define the-bogus-value (BogusV)) -(: raw-extend : (Listof Symbol) (Listof (Boxof 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) +(: extend : (Listof VAL) ENV -> ENV) ;; extends an environment with a new frame (given plain values). (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 ;; expressions). -(define (extend-rec names compiled-exprs env) - (define new-env - (extend names - (map (lambda (_) the-bogus-value) compiled-exprs) - env)) +(define (extend-rec compiled-exprs env) + (define new-boxes + (map (λ (_) (box the-bogus-value)) compiled-exprs)) + (define new-frame new-boxes) + (define new-env (cons new-frame env)) ;; note: no need to check the lengths here, since this is only ;; called for `bindrec', and the syntax make it impossible to have ;; different lengths - (for-each (lambda ([name : Symbol] [compiled : (ENV -> VAL)]) - (set-box! (lookup name new-env) (compiled new-env))) - names compiled-exprs) + (for-each (lambda ([boxed-val : (Boxof VAL)] [compiled : (ENV -> VAL)]) + (set-box! boxed-val (compiled new-env))) + new-boxes compiled-exprs) new-env) -(: lookup : Symbol ENV -> (Boxof VAL)) -;; looks for a name in an environment, searching through each frame. -(define (lookup name env) - (cases env - [(EmptyEnv) (error 'lookup "no binding for ~s" name)] - [(FrameEnv frame rest) - (let ([cell (assq name frame)]) - (if cell - (second cell) - (lookup name rest)))])) +(: framerefbox : (Listof (Boxof VAL)) Natural -> (Boxof VAL)) +;; Gets you the box at idx in the frame. +(define (framerefbox frame idx) + (if (null? frame) + (error 'framerefbox "no binding found for index ~s" idx) + (if (zero? idx) + (first frame) + (framerefbox (rest frame) (sub1 idx))))) + +(: 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) ;; helper for `racket-func->prim-val': unwrap a RktV wrapper in ;; preparation to be sent to the primitive function (define (unwrap-rktv x) (cases x - [(RktV v) v] - [else (error 'racket-func "bad input: ~s" x)])) + [(RktV v) v] + [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 ;; is a PrimV holding a ((Listof VAL) -> VAL) function. (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.) (define (racket-func->prim-val racket-func) (define list-func (make-untyped-list-function racket-func)) - (box (PrimV (lambda (args) - (RktV (list-func (map unwrap-rktv args))))))) + (PrimV (lambda (args) + (RktV (list-func (map unwrap-rktv args)))))) ;; The global environment has a few primitives: -(: global-environment : ENV) +(: global-environment : (Listof (List Symbol VAL))) (define global-environment - (FrameEnv (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 =)) - ;; values - (list 'true (box (RktV #t))) - (list 'false (box (RktV #f)))) - (EmptyEnv))) + (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 =)) + ;; values + (list 'true (RktV #t)) + (list 'false (RktV #f)))) + +(: 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 @@ -193,13 +216,13 @@ (unless (unbox compiler-enabled?) (error 'compile-body "compiler disabled")) (let ([compiled-1st (compile (first exprs) bin)] - [rest (rest exprs)]) + [rest (rest exprs)]) (if (null? rest) - compiled-1st - (let ([compiled-rest (compile-body rest bin)]) - (lambda (env) - (define ignored (compiled-1st env)) - (compiled-rest env)))))) + compiled-1st + (let ([compiled-rest (compile-body rest bin)]) + (lambda (env) + (define ignored (compiled-1st env)) + (compiled-rest env)))))) (: compile-get-boxes : (Listof TOY) BINDINGS -> (ENV -> (Listof (Boxof VAL)))) ;; utility for applying rfun @@ -207,12 +230,17 @@ (: compile-getter : TOY -> (ENV -> (Boxof VAL))) (define (compile-getter expr) (cases expr - [(Id name) - (lambda ([env : ENV]) (lookup name env))] - [else - (lambda ([env : ENV]) - (error 'call "rfun application with a non-identifier ~s" - expr))])) + [(Id name) + (cases (find-index name bin) + [(Some location) (λ ([env : ENV]) + (envrefbox env (first location) (second location)))] + [(None) (if (assq name global-environment) + (λ ([_ : 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?) (error 'compile-get-boxes "compiler disabled")) (let ([getters (map compile-getter exprs)]) @@ -229,72 +257,84 @@ (lambda (compiled) (compiled env))) (unless (unbox compiler-enabled?) (error 'compile "compiler disabled")) + (: compile* : TOY -> (ENV -> VAL)) + (define (compile* expr*) (compile expr* bin)) (cases expr - [(Num n) (lambda ([env : ENV]) (RktV n))] - [(Id name) (lambda ([env : ENV]) (unbox (lookup name env)))] - [(Set name new) - (define compiled-new (compile new)) - (lambda ([env : ENV]) - (set-box! (lookup name env) (compiled-new env)) - the-bogus-value)] - [(Bind names exprs bound-body) - (define compiled-exprs (map compile exprs)) - (define compiled-body (compile-body bound-body)) - (lambda ([env : ENV]) - (compiled-body - (extend names (map (caller env) compiled-exprs) env)))] - [(BindRec names exprs bound-body) - (define compiled-exprs (map compile exprs)) - (define compiled-body (compile-body bound-body)) - (lambda ([env : ENV]) - (compiled-body (extend-rec names compiled-exprs env)))] - [(Fun names bound-body) - (define compiled-body (compile-body bound-body)) - (lambda ([env : ENV]) (FunV names compiled-body env #f))] - [(RFun names bound-body) - (define compiled-body (compile-body bound-body)) - (lambda ([env : ENV]) (FunV names compiled-body env #t))] - [(Call fun-expr arg-exprs) - (define compiled-fun (compile fun-expr)) - (define compiled-args (map compile arg-exprs)) - (define compiled-boxes-getter (compile-get-boxes arg-exprs)) - (lambda ([env : ENV]) - (define fval (compiled-fun env)) - ;; delay evaluating the arguments - (define arg-vals (lambda () (map (caller env) compiled-args))) - (cases fval - [(PrimV proc) (proc (arg-vals))] - [(FunV names compiled-body fun-env byref?) - (compiled-body (if byref? - (raw-extend names - (compiled-boxes-getter env) - fun-env) - (extend names (arg-vals) fun-env)))] - [else (error 'call "function call with a non-function: ~s" - fval)]))] - [(If cond-expr then-expr else-expr) - (define compiled-cond (compile cond-expr)) - (define compiled-then (compile then-expr)) - (define compiled-else (compile else-expr)) - (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))])) + [(Num n) (lambda ([env : ENV]) (RktV n))] + [(Id name) + (cases (find-index name bin) + [(Some location) (λ ([env : ENV]) (unbox (envrefbox env (first location) (second location))))] + [(None) (let ([global-val (global-lookup name)]) + (λ ([_ : ENV]) global-val))])] + [(Set name new) + (define compiled-new (compile new bin)) + (cases (find-index name bin) + [(Some location) + (λ ([env : ENV]) + (set-box! (envrefbox env (first location) (second location)) + (compiled-new env)) + the-bogus-value)] + [(None) + (let ([_ (global-lookup name)]) + (λ ([_ : ENV]) (error 'compile "can't set flobal binding for ~s" name)))])] + [(Bind names exprs bound-body) + (define compiled-exprs (map compile* exprs)) + (define compiled-body (compile-body bound-body (cons names bin))) + (lambda ([env : ENV]) + (compiled-body + (extend (map (caller env) compiled-exprs) env)))] + [(BindRec names exprs bound-body) + (: ah : (Listof (Listof Symbol))) + (define ah (cons names bin)) + (define compiled-exprs (map (λ ([x : TOY]) (compile x ah)) exprs)) + (define compiled-body (compile-body bound-body ah)) + (lambda ([env : ENV]) + (compiled-body (extend-rec compiled-exprs env)))] + [(Fun names bound-body) + (define compiled-body (compile-body bound-body (cons names bin))) + (lambda ([env : ENV]) (FunV names compiled-body env #f))] + [(RFun names bound-body) + (define compiled-body (compile-body bound-body (cons names bin))) + (lambda ([env : ENV]) (FunV names compiled-body env #t))] + [(Call fun-expr arg-exprs) + (define compiled-fun (compile fun-expr bin)) + (define compiled-args (map compile* arg-exprs)) + (define compiled-boxes-getter (compile-get-boxes arg-exprs bin)) + (lambda ([env : ENV]) + (define fval (compiled-fun env)) + ;; delay evaluating the arguments + (define arg-vals (lambda () (map (caller env) compiled-args))) + (cases fval + [(PrimV proc) (proc (arg-vals))] + [(FunV names compiled-body fun-env byref?) + (compiled-body (if byref? + (cons (compiled-boxes-getter env) fun-env) + (extend (arg-vals) fun-env)))] + [else (error 'call "function call with a non-function: ~s" + fval)]))] + [(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) ;; compiles and runs a TOY program contained in a string (define (run str) (set-box! compiler-enabled? #t) - (let ([compiled (compile (parse str))]) + (let ([compiled (compile (parse str) '(()))]) (set-box! compiler-enabled? #f) - (let ([result (compiled global-environment)]) + (let ([result (compiled '())]) (cases result - [(RktV v) v] - [else (error 'run "the program returned a bad value: ~s" - result)])))) + [(RktV v) v] + [else (error 'run "the program returned a bad value: ~s" + result)])))) ;;; ================================================================== ;;; Tests @@ -322,25 +362,27 @@ => 124) ;; More tests for complete coverage -(test (run "{bind x 5 x}") =error> "bad `bind' syntax") -(test (run "{fun x x}") =error> "bad `fun' syntax") -(test (run "{if x}") =error> "bad `if' syntax") -(test (run "{}") =error> "bad syntax") +(test (run "{bind x 5 x}") =error> "bad `bind' syntax") +(test (run "{fun x x}") =error> "bad `fun' syntax") +(test (run "{if x}") =error> "bad `if' syntax") +(test (run "{}") =error> "bad syntax") (test (run "{bind {{x 5} {x 5}} x}") =error> "duplicate*bind*names") -(test (run "{fun {x x} x}") =error> "duplicate*fun*names") -(test (run "{+ x 1}") =error> "no binding for") +(test (run "{fun {x x} x}") =error> "duplicate*fun*names") +(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 2}") =error> "with a non-function") -(test (run "{{fun {x} x}}") =error> "arity mismatch") -(test (run "{if {< 4 5} 6 7}") => 6) -(test (run "{if {< 5 4} 6 7}") => 7) -(test (run "{if + 6 7}") => 6) -(test (run "{fun {x} x}") =error> "returned a bad value") +(test (run "{1 2}") =error> "with a non-function") +(test (run "{{fun {x} x}}") =error> "arity mismatch") +(test (run "{if {< 4 5} 6 7}") => 6) +(test (run "{if {< 5 4} 6 7}") => 7) +(test (run "{if + 6 7}") => 6) +(test (run "{fun {x} x}") =error> "returned a bad value") ;; 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 "{set! + 1}") =error> "set") +(test (run "{set! nope 1}") =error> "no binding") ;; `bindrec' tests (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 "{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 ;; (these tests must use the functions instead of the toplevel `run', ;; 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 ;; internal error check) -(test (compile (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 (Num 1) '(())) =error> "compiler disabled") +(test (compile-body (list (Num 1)) '(())) =error> "compiler disabled") +(test (compile-get-boxes (list (Num 1)) '(())) =error> "compiler disabled") ;;; ==================================================================