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

ah

Browse Source
This commit is contained in:
jacob
2026-05-30 09:12:17 -04:00
parent c3a09556b3
commit 18e5275a76
1 changed files with 19 additions and 13 deletions
Download Patch File Download Diff File Expand all files Collapse all files
15-compilation-part-2/main.rkt
+19 -13
View File
@@ -72,7 +72,7 @@
(match sexpr (match sexpr
[(list 'set! (symbol: name) new) (Set name (parse-sexpr new))] [(list 'set! (symbol: name) new) (Set name (parse-sexpr new))]
[else (error 'parse-sexpr "bad `set!' syntax in ~s" sexpr)])] [else (error 'parse-sexpr "bad `set!' syntax in ~s" sexpr)])]
[(cons (and binder (or 'bind 'bindrec)) more) [(cons (and binder (or 'bind 'bindrec)) _)
(match sexpr (match sexpr
[(list _ (list (list (symbol: names) (sexpr: nameds)) ...) [(list _ (list (list (symbol: names) (sexpr: nameds)) ...)
body0 body ...) body0 body ...)
@@ -84,7 +84,7 @@
(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)) _)
(match sexpr (match sexpr
[(list _ (list (symbol: names) ...) [(list _ (list (symbol: names) ...)
body0 body ...) body0 body ...)
@@ -95,7 +95,7 @@
(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 _)
(match sexpr (match sexpr
[(list 'if cond then else) [(list 'if cond then else)
(If (parse-sexpr cond) (parse-sexpr then) (parse-sexpr else))] (If (parse-sexpr cond) (parse-sexpr then) (parse-sexpr else))]
@@ -118,7 +118,7 @@
(define-type VAL (define-type VAL
[BogusV] [BogusV]
[RktV Any] [RktV Any]
[FunV (Listof Symbol) (ENV -> VAL) ENV Boolean] ; `byref?' flag [FunV Natural (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
@@ -126,7 +126,7 @@
(: extend : (Listof VAL) ENV -> ENV) (: extend : (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 values env)
(cons (map (inst box VAL) values) env)) (cons (map (inst box VAL) values) env))
(: extend-rec : (Listof (ENV -> VAL)) ENV -> ENV) (: extend-rec : (Listof (ENV -> VAL)) ENV -> ENV)
@@ -221,8 +221,8 @@
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)) (let [(_ (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
@@ -292,12 +292,17 @@
(compiled-body (extend-rec compiled-exprs env)))] (compiled-body (extend-rec compiled-exprs env)))]
[(Fun names bound-body) [(Fun names bound-body)
(define compiled-body (compile-body bound-body (cons names bin))) (define compiled-body (compile-body bound-body (cons names bin)))
(lambda ([env : ENV]) (FunV names compiled-body env #f))] (: arity : Natural)
(define arity (length names))
(lambda ([env : ENV]) (FunV arity compiled-body env #f))]
[(RFun names bound-body) [(RFun names bound-body)
(define compiled-body (compile-body bound-body (cons names bin))) (define compiled-body (compile-body bound-body (cons names bin)))
(lambda ([env : ENV]) (FunV names compiled-body env #t))] (define arity (length names))
(lambda ([env : ENV]) (FunV arity compiled-body env #t))]
[(Call fun-expr arg-exprs) [(Call fun-expr arg-exprs)
(define compiled-fun (compile fun-expr bin)) (define compiled-fun (compile fun-expr bin))
(: nargs : Natural)
(define nargs (length arg-exprs))
(define compiled-args (map compile* arg-exprs)) (define compiled-args (map compile* arg-exprs))
(define compiled-boxes-getter (compile-get-boxes arg-exprs bin)) (define compiled-boxes-getter (compile-get-boxes arg-exprs bin))
(lambda ([env : ENV]) (lambda ([env : ENV])
@@ -306,10 +311,11 @@
(define arg-vals (lambda () (map (caller env) compiled-args))) (define arg-vals (lambda () (map (caller env) compiled-args)))
(cases fval (cases fval
[(PrimV proc) (proc (arg-vals))] [(PrimV proc) (proc (arg-vals))]
[(FunV names compiled-body fun-env byref?) [(FunV arity compiled-body fun-env byref?) (if (= arity nargs)
(compiled-body (if byref? (compiled-body (if byref?
(cons (compiled-boxes-getter env) fun-env) (cons (compiled-boxes-getter env) fun-env)
(extend (arg-vals) fun-env)))] (extend (arg-vals) fun-env)))
(error 'compile "arity mismatch"))]
[else (error 'call "function call with a non-function: ~s" [else (error 'call "function call with a non-function: ~s"
fval)]))] fval)]))]
[(If cond-expr then-expr else-expr) [(If cond-expr then-expr else-expr)