Done with compilation.
This commit is contained in:
+54
-42
@@ -30,11 +30,11 @@ POSTT :== PUWAE
|
||||
[Sub PUWAE PUWAE]
|
||||
[Mul PUWAE PUWAE]
|
||||
[Div PUWAE PUWAE]
|
||||
; [Post (Listof POSTT)]
|
||||
[Post (Listof POSTT)]
|
||||
[With Symbol PUWAE PUWAE])
|
||||
|
||||
(define-type POSTT = (U '+ '- '* '/ PUWAE))
|
||||
|
||||
|
||||
(: parse : (String -> PUWAE))
|
||||
;; parse the string into our language
|
||||
(define (parse str)
|
||||
@@ -50,49 +50,27 @@ POSTT :== PUWAE
|
||||
[(list '- l r) (Sub (sexpr->puwae l) (sexpr->puwae r))]
|
||||
[(list '* l r) (Mul (sexpr->puwae l) (sexpr->puwae r))]
|
||||
[(list '/ l r) (Div (sexpr->puwae l) (sexpr->puwae r))]
|
||||
[(list 'post posts ...) (parsepost posts '())]
|
||||
[(list 'post posts ...) (Post (sexpr-list->postts posts))]
|
||||
[(list 'with (list (symbol: id) val) bound-body)
|
||||
(With id (sexpr->puwae val) (sexpr->puwae bound-body))]
|
||||
[_ (error 'sexpr->puwae "malformed expression in ~s" sexpr)]))
|
||||
|
||||
(: parsepost : (Sexpr (Listof PUWAE) -> PUWAE))
|
||||
; Parse a post expression into a PUWAE.
|
||||
(define (parsepost sexpr glob)
|
||||
(: sexpr->postt : (Sexpr -> POSTT))
|
||||
;; Turn a post into POSTT.
|
||||
(define (sexpr->postt sexpr)
|
||||
(match sexpr
|
||||
['() (if (= 1 (length glob)) (first glob) (error 'parsepost "finished with messy glob: ~s" glob))] ; There shouldn't be anything else left in the stack.
|
||||
[(cons '+ rest) (parsepost rest (parsepost-sum glob))]
|
||||
[(cons '- rest) (parsepost rest (parsepost-sub glob))]
|
||||
[(cons '* rest) (parsepost rest (parsepost-mul glob))]
|
||||
[(cons '/ rest) (parsepost rest (parsepost-div glob))]
|
||||
[(cons (symbol: id) rest) (parsepost rest (cons (Id id) glob))] ; Capture non-post symbols (variables).
|
||||
[(cons exp rest) (parsepost rest (cons (sexpr->puwae exp) glob))])) ; Assume anything else must be a PUWAE.
|
||||
['+ '+]
|
||||
['- '-]
|
||||
['* '*]
|
||||
['/ '/]
|
||||
[_ (sexpr->puwae sexpr)]))
|
||||
|
||||
(: glob-swap : Symbol (Listof PUWAE) (PUWAE PUWAE -> PUWAE) -> (Listof PUWAE))
|
||||
; Validates the glob length before swapping with result of globberator.
|
||||
(define (glob-swap operation glob globberator)
|
||||
(if (>= (length glob) 2)
|
||||
(cons (globberator (second glob) (first glob)) (rest (rest glob))) ; Replace the two arguments, while preserving whatever else was on the stack.
|
||||
(error 'glob-swap "too few arguments globbed for ~s: ~s" operation glob)))
|
||||
|
||||
(: parsepost-sum : ((Listof PUWAE) -> (Listof PUWAE)))
|
||||
; Parse a post sum.
|
||||
(define (parsepost-sum glob)
|
||||
(glob-swap 'sum glob Sum))
|
||||
|
||||
(: parsepost-mul : ((Listof PUWAE) -> (Listof PUWAE)))
|
||||
; Parse a post product.
|
||||
(define (parsepost-mul glob)
|
||||
(glob-swap 'mul glob Mul))
|
||||
|
||||
(: parsepost-sub : ((Listof PUWAE) -> (Listof PUWAE)))
|
||||
; Parse a post subtration.
|
||||
(define (parsepost-sub glob)
|
||||
(glob-swap 'sub glob Sub))
|
||||
|
||||
(: parsepost-div : ((Listof PUWAE) -> (Listof PUWAE)))
|
||||
; Parse a post quotient.
|
||||
(define (parsepost-div glob)
|
||||
(glob-swap 'div glob Div))
|
||||
(: sexpr-list->postts : ((Listof Sexpr) -> (Listof POSTT)))
|
||||
(define (sexpr-list->postts sexprs)
|
||||
(match sexprs
|
||||
['() '()]
|
||||
[(cons token rest)
|
||||
(cons (sexpr->postt token) (sexpr-list->postts rest))]))
|
||||
|
||||
(: eval : (PUWAE -> Number))
|
||||
;; evaluate to a final number
|
||||
@@ -104,8 +82,32 @@ POSTT :== PUWAE
|
||||
[(Sub l r) (- (eval l) (eval r))]
|
||||
[(Mul l r) (* (eval l) (eval r))]
|
||||
[(Div l r) (/ (eval l) (eval r))]
|
||||
[(Post postts) (eval-post postts '())]
|
||||
[(With id pre-val bound-body) (eval (subst id (Num (eval pre-val)) bound-body))]))
|
||||
|
||||
(: post-stack-apply : (Symbol (Number Number -> Number) (Listof Number) -> (Listof Number)))
|
||||
(define (post-stack-apply operator operation stack)
|
||||
(if (>= (length stack) 2)
|
||||
(cons (operation (second stack) (first stack)) (rest (rest stack)))
|
||||
(error 'eval-post "Too few arguments for ~s: ~s" operator stack)))
|
||||
|
||||
(: eval-post : ((Listof POSTT) (Listof Number) -> Number))
|
||||
(define (eval-post postts stack)
|
||||
(match postts
|
||||
['()
|
||||
(if (= 1 (length stack))
|
||||
(first stack)
|
||||
(error 'eval-post "Finished with messy stack: ~s" stack))]
|
||||
[(cons token rest)
|
||||
(if (symbol? token)
|
||||
(match token
|
||||
['+ (eval-post rest (post-stack-apply '+ + stack))]
|
||||
['- (eval-post rest (post-stack-apply '- - stack))]
|
||||
['* (eval-post rest (post-stack-apply '* * stack))]
|
||||
['/ (eval-post rest (post-stack-apply '/ / stack))]
|
||||
[_ (error 'eval-post "Bad post operator ~s" token)])
|
||||
(eval-post rest (cons (eval token) stack)))]))
|
||||
|
||||
(: subst : (Symbol PUWAE PUWAE -> PUWAE))
|
||||
;; subst all instances of id with val in body
|
||||
(define (subst id val body)
|
||||
@@ -116,6 +118,7 @@ POSTT :== PUWAE
|
||||
[(Sub l r) (Sub (subst id val l) (subst id val r))]
|
||||
[(Mul l r) (Mul (subst id val l) (subst id val r))]
|
||||
[(Div l r) (Div (subst id val l) (subst id val r))]
|
||||
[(Post postts) (Post (subst-postts id val postts))]
|
||||
[(With other-id pre-val bound-body)
|
||||
(With other-id
|
||||
(subst id val pre-val)
|
||||
@@ -123,6 +126,15 @@ POSTT :== PUWAE
|
||||
bound-body
|
||||
(subst id val bound-body)))]))
|
||||
|
||||
(: subst-postts : (Symbol PUWAE (Listof POSTT) -> (Listof POSTT)))
|
||||
(define (subst-postts id val postts)
|
||||
(match postts
|
||||
['() '()]
|
||||
[(cons token rest)
|
||||
(if (symbol? token)
|
||||
(cons token (subst-postts id val rest))
|
||||
(cons (subst id val token) (subst-postts id val rest)))]))
|
||||
|
||||
(: run : String -> Number)
|
||||
;; run the program
|
||||
(define (run str)
|
||||
@@ -139,9 +151,9 @@ POSTT :== PUWAE
|
||||
(test (run "{with {x {post 1 3 +}} {post 5 6 + x *}}") => 44)
|
||||
(test (run "{post 1 3 + 5 6 + *}") => 44) ; Not 48 :P (5 + 6 ≠ 12).
|
||||
|
||||
(test (run "{post 3 +}") =error> "glob-swap: too few arguments globbed for sum: ((Num 3))")
|
||||
(test (run "{post 3 3 3 +}") =error> "parsepost: finished with messy glob: ((Sum (Num 3) (Num 3)) (Num 3))")
|
||||
(test (run "{post 1 2 + 2}") =error> "parsepost: finished with messy glob: ((Num 2) (Sum (Num 1) (Num 2)))")
|
||||
(test (run "{post 3 +}") =error> "eval-post: Too few arguments for +: (3)")
|
||||
(test (run "{post 3 3 3 +}") =error> "eval-post: Finished with messy stack: (6 3)")
|
||||
(test (run "{post 1 2 + 2}") =error> "eval-post: Finished with messy stack: (2 3)")
|
||||
|
||||
(test (run "4") => 4)
|
||||
(test (run "{+ 4 {* 2 3}}") => 10)
|
||||
|
||||
+249
-110
@@ -1,6 +1,5 @@
|
||||
;;; ---<<<TOY>>>----------------------------------------------------
|
||||
#lang pl
|
||||
|
||||
;;; ----------------------------------------------------------------
|
||||
;;; Syntax
|
||||
|
||||
@@ -10,6 +9,7 @@
|
||||
| { bind {{ <id> <TOY> } ... } <TOY> ... }
|
||||
| { bindrec {{ <id> <TOY> } ... } <TOY> ... }
|
||||
| { fun { <id> ... } <TOY> ... }
|
||||
| { rfun { <id> ... } <TOY> ... }
|
||||
| { <TOY> <TOY> ... }
|
||||
| { if <TOY> <TOY> <TOY> }
|
||||
| { set! <id> <TOY> }
|
||||
@@ -17,17 +17,18 @@
|
||||
|
||||
;; A matching abstract syntax tree datatype:
|
||||
(define-type TOY
|
||||
[Num Number]
|
||||
[Id Symbol]
|
||||
[Bind (Listof Symbol) (Listof TOY) (Listof TOY)]
|
||||
[Bindrec (Listof Symbol) (Listof TOY) (Listof TOY)]
|
||||
[Fun (Listof Symbol) (Listof TOY)]
|
||||
[Call TOY (Listof TOY)]
|
||||
[If TOY TOY TOY]
|
||||
[Set Symbol TOY])
|
||||
[Num Number]
|
||||
[Id Symbol]
|
||||
[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]
|
||||
[Set Symbol TOY])
|
||||
|
||||
; Things you can't name things.
|
||||
(define BAD_WORDS (list 'bind 'fun 'if 'set! '+ '- '* '/ '= '< '> 'true 'false 'void))
|
||||
(define BAD_WORDS (list 'bind 'bindrec 'fun 'rfun 'if 'set! '+ '- '* '/ '= '< '> 'true 'false 'void))
|
||||
|
||||
(: unique-list? : (Listof Any) -> Boolean)
|
||||
;; Tests whether a list is unique, guards Bind and Fun values.
|
||||
@@ -36,39 +37,56 @@
|
||||
(and (not (member (first xs) (rest xs)))
|
||||
(unique-list? (rest xs)))))
|
||||
|
||||
(: no-bad-words? : (Listof Symbol) -> Boolean)
|
||||
;; Tests whether a list avoids all bad words.
|
||||
(define (no-bad-words? names)
|
||||
(or (null? names)
|
||||
(and (not (member (first names) BAD_WORDS))
|
||||
(no-bad-words? (rest names)))))
|
||||
|
||||
(: parse-sexpr : Sexpr -> TOY)
|
||||
;; parses s-expressions into TOYs
|
||||
(define (parse-sexpr sexpr)
|
||||
(match sexpr
|
||||
; Primitives.
|
||||
[(number: n) (Num n)]
|
||||
[(number: n) (Num n)]
|
||||
[(symbol: name) (Id name)]
|
||||
|
||||
; Bindrec.
|
||||
[(cons (and binder (or 'bind 'bindrec)) more) ; `binder` bound to 'bind or 'bindrec.
|
||||
[(cons (and binder (or 'bind 'bindrec)) _) ; `binder` bound to 'bind or 'bindrec.
|
||||
; `_` feels cooler than `more`.
|
||||
(match sexpr
|
||||
[(list b (list (list (symbol: names) (sexpr: nameds)) ...) body ...)
|
||||
(if (not (null? body))
|
||||
(if (unique-list? names)
|
||||
((if (symbol=? b 'bind) Bind Bindrec)
|
||||
names
|
||||
(map parse-sexpr nameds)
|
||||
(last (map parse-sexpr body)))
|
||||
(error 'parse-sexpr "duplicate `~s' names: ~s" binder names))
|
||||
(error 'parse-sexpr "bind expression missing body: ~s" sexpr))]
|
||||
(if (unique-list? names)
|
||||
(if (no-bad-words? names)
|
||||
((if (symbol=? b 'bind) Bind Bindrec)
|
||||
names
|
||||
(map parse-sexpr nameds)
|
||||
(map parse-sexpr body))
|
||||
(error 'parse-sexpr "bad word found in `~s' : ~s" binder names))
|
||||
(error 'parse-sexpr "duplicate `~s' names: ~s" binder names))
|
||||
(error 'parse-sexpr "bind expression missing body: ~s" sexpr))]
|
||||
[else (error 'parse-sexpr "bad `~s' syntax in ~s" binder sexpr)])]
|
||||
|
||||
; Function definition.
|
||||
[(cons 'fun more)
|
||||
;
|
||||
;
|
||||
;
|
||||
; RFun definition.
|
||||
[(cons (and funer (or 'fun 'rfun)) _)
|
||||
(match sexpr
|
||||
[(list 'fun (list (symbol: names) ...) body)
|
||||
(if (unique-list? names)
|
||||
(Fun names (parse-sexpr body))
|
||||
(error 'parse-sexpr "duplicate `fun' names: ~s" names))]
|
||||
[else (error 'parse-sexpr "bad `fun' syntax in ~s" sexpr)])]
|
||||
|
||||
[(list f (list (symbol: parameters) ...) body ...)
|
||||
(if (not (null? body))
|
||||
(if (unique-list? parameters)
|
||||
(if (no-bad-words? parameters)
|
||||
((if (symbol=? f 'fun) Fun Rfun) parameters (map parse-sexpr body))
|
||||
(error 'parse-sexpr "bad words found in function parameter names in ~s" sexpr))
|
||||
(error 'parse-sexpr "bad parameters defined for function in ~s" sexpr))
|
||||
(error 'parse-sexpr "disemobodied function in ~s" sexpr))]
|
||||
[else (error 'parse-sexpr "bad function syntax in ~s" sexpr)])]
|
||||
|
||||
; Conditional.
|
||||
[(cons 'if more)
|
||||
[(cons 'if _)
|
||||
(match sexpr
|
||||
[(list 'if cond then else)
|
||||
(If (parse-sexpr cond)
|
||||
@@ -77,7 +95,7 @@
|
||||
[else (error 'parse-sexpr "bad `if' syntax in ~s" sexpr)])]
|
||||
|
||||
; Set!.
|
||||
[(cons 'set! more)
|
||||
[(cons 'set! _)
|
||||
(match sexpr
|
||||
[(list 'set! (symbol: thing) as)
|
||||
(Set thing (parse-sexpr as))])]
|
||||
@@ -95,21 +113,19 @@
|
||||
(define (parse str)
|
||||
(parse-sexpr (string->sexpr str)))
|
||||
|
||||
;;; ----------------------------------------------------------------
|
||||
;;; Values and environments
|
||||
|
||||
(define-type ENV
|
||||
[EmptyEnv]
|
||||
[FrameEnv FRAME 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 VAL
|
||||
[RktV Any]
|
||||
[FunV (Listof Symbol) TOY ENV]
|
||||
[PrimV ((Listof VAL) -> VAL)]
|
||||
[VoidV])
|
||||
[RktV Any]
|
||||
; Parameters, compiled body, whether it's an Rfun, environment.
|
||||
[FunV (Listof Symbol) (ENV -> VAL) Boolean ENV]
|
||||
[PrimV ((Listof VAL) -> VAL)]
|
||||
[VoidV])
|
||||
|
||||
(: extend : (Listof Symbol) (Listof VAL) ENV -> ENV)
|
||||
(define (extend names vals env)
|
||||
@@ -125,35 +141,33 @@
|
||||
env)
|
||||
(error 'extend "arity mismatch for names: ~s" names)))
|
||||
|
||||
(: extend-rec : (Listof Symbol) (Listof TOY) ENV -> ENV)
|
||||
(define (extend-rec names vals env)
|
||||
(define newenv (extend names (map (lambda (_) (VoidV)) vals) env))
|
||||
(for-each (lambda ([name : Symbol] [val : TOY])
|
||||
(set-box! (lookup name newenv) (eval val newenv)))
|
||||
names vals)
|
||||
(: extend-rec : (Listof Symbol) (Listof (ENV -> VAL)) ENV -> ENV)
|
||||
(define (extend-rec names compiled-vals env)
|
||||
(define newenv (extend names (map (lambda (_) (VoidV)) compiled-vals) env))
|
||||
(for-each (lambda ([name : Symbol] [compiled-val : (ENV -> VAL)])
|
||||
(set-box! (lookup name newenv) (compiled-val newenv)))
|
||||
names compiled-vals)
|
||||
newenv)
|
||||
|
||||
|
||||
|
||||
(: lookup : Symbol ENV -> (Boxof VAL))
|
||||
;; lookup a symbol in an environment, frame by frame,
|
||||
;; return its value or throw an error if it isn't bound
|
||||
(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)))]))
|
||||
[(EmptyEnv) (error 'lookup "no binding for ~s" name)]
|
||||
[(FrameEnv frame rest)
|
||||
(let ([cell (assq name frame)])
|
||||
(if cell
|
||||
(second cell)
|
||||
(lookup name rest)))]))
|
||||
|
||||
(: 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))
|
||||
;; converts a racket function to a primitive evaluator function
|
||||
@@ -164,7 +178,7 @@
|
||||
(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)))))))
|
||||
(RktV (list-func (map unwrap-rktv args)))))))
|
||||
|
||||
;; The global environment has a few primitives:
|
||||
(: global-environment : ENV)
|
||||
@@ -177,59 +191,177 @@
|
||||
(list '> (racket-func->prim-val >))
|
||||
(list '= (racket-func->prim-val =))
|
||||
;; values
|
||||
(list 'true (box (RktV #t)))
|
||||
(list 'true (box (RktV #t)))
|
||||
(list 'false (box (RktV #f)))
|
||||
(list 'void (box (VoidV))))
|
||||
(EmptyEnv)))
|
||||
|
||||
;;; ----------------------------------------------------------------
|
||||
;;; Evaluation
|
||||
(: compiler-enabled? : (Boxof Boolean))
|
||||
(define compiler-enabled? (box #f))
|
||||
|
||||
(: eval : TOY ENV -> VAL)
|
||||
;; evaluates TOY expressions
|
||||
(define (eval expr env)
|
||||
;; convenient helper
|
||||
(: eval* : TOY -> VAL)
|
||||
(define (eval* expr) (eval expr env))
|
||||
(: ensure-compiler-enabled! : Symbol -> Void)
|
||||
(define (ensure-compiler-enabled! who)
|
||||
(if (unbox compiler-enabled?)
|
||||
(void)
|
||||
(error who "compiler is not enabled")))
|
||||
|
||||
(: run-compiled-body : (Listof (ENV -> VAL)) ENV -> VAL)
|
||||
; Compile a body of expressions.
|
||||
(define (run-compiled-body compiled env)
|
||||
(if (null? compiled)
|
||||
(error 'compile "empty body")
|
||||
(if (null? (rest compiled))
|
||||
((first compiled) env)
|
||||
(let ([_ ((first compiled) env)]) ; We've side effects in this language.
|
||||
(run-compiled-body (rest compiled) env)))))
|
||||
|
||||
(: compile-body : (Listof TOY) -> (ENV -> VAL))
|
||||
;; Compile a sequence of body expressions into runtime sequencing code.
|
||||
(define (compile-body body)
|
||||
(ensure-compiler-enabled! 'compile-body)
|
||||
(define compiled-body (map compile body))
|
||||
(lambda ([env : ENV])
|
||||
(run-compiled-body compiled-body env)))
|
||||
|
||||
; Convenient helper for running compiled code.
|
||||
(: caller : ENV -> (ENV -> VAL) -> VAL)
|
||||
(define (caller env)
|
||||
(lambda ([compiled : (ENV -> VAL)]) (compiled env)))
|
||||
|
||||
(: compile : TOY -> (ENV -> VAL))
|
||||
;; compileuates TOY expressions.
|
||||
(define (compile expr)
|
||||
(ensure-compiler-enabled! 'compile)
|
||||
(cases expr
|
||||
[(Num n) (RktV n)]
|
||||
[(Id name) (unbox (lookup name env))]
|
||||
[(Bind names exprs bound-body)
|
||||
(eval bound-body (extend names (map eval* exprs) env))]
|
||||
[(Bindrec names exprs bound-body)
|
||||
(eval bound-body (extend-rec names exprs env))]
|
||||
[(Fun names bound-body)
|
||||
(FunV names bound-body env)]
|
||||
[(Call fun-expr arg-exprs)
|
||||
(let ([fval (eval* fun-expr)]
|
||||
[arg-vals (map eval* arg-exprs)])
|
||||
(cases fval
|
||||
[(PrimV proc) (proc arg-vals)]
|
||||
[(FunV names body fun-env)
|
||||
(eval body (extend names arg-vals fun-env))]
|
||||
[else (error 'eval "function call with a non-function: ~s"
|
||||
fval)]))]
|
||||
[(If cond-expr then-expr else-expr)
|
||||
(eval* (if (cases (eval* cond-expr)
|
||||
[(RktV v) v] ; Racket value => use as boolean
|
||||
[else #t]) ; other values are always true
|
||||
then-expr
|
||||
else-expr))]
|
||||
[(Set thing as)
|
||||
(set-box! (lookup thing env) (eval* as)) ; We are not a lazy language.
|
||||
(VoidV)]))
|
||||
[(Num n) (λ ([_ : ENV]) (RktV n))]
|
||||
[(Id name) (λ ([env : ENV]) (unbox (lookup name env)))]
|
||||
[(Bind names exprs body)
|
||||
(define compiled-exprs (map compile exprs))
|
||||
(define compiled-body (compile-body body))
|
||||
(λ ([env : ENV])
|
||||
(compiled-body
|
||||
(extend names
|
||||
(map (caller env) compiled-exprs)
|
||||
env)))]
|
||||
[(Bindrec names exprs body)
|
||||
(define compiled-exprs (map compile exprs))
|
||||
(define compiled-body (compile-body body))
|
||||
(λ ([env : ENV])
|
||||
(compiled-body (extend-rec names compiled-exprs env)))]
|
||||
[(Fun names body)
|
||||
(define compiled-body (compile-body body))
|
||||
(λ ([env : ENV]) (FunV names compiled-body #f env))]
|
||||
[(Rfun names body)
|
||||
(define compiled-body (compile-body body))
|
||||
(λ ([env : ENV]) (FunV names compiled-body #t env))]
|
||||
[(Call fun-expr arg-exprs)
|
||||
(define compiled-fun (compile fun-expr))
|
||||
(define compiled-args (map compile arg-exprs))
|
||||
(define compiled-get-boxes (compile-get-boxes arg-exprs))
|
||||
(λ ([env : ENV])
|
||||
(let ([fval (compiled-fun env)]
|
||||
[arg-vals-thunk
|
||||
(lambda ()
|
||||
(map (caller env) compiled-args))]) ; THunk.
|
||||
(cases fval
|
||||
[(PrimV proc) (proc (arg-vals-thunk))]
|
||||
[(FunV names body ref? fun-env)
|
||||
(if ref?
|
||||
(compile-rfun names compiled-get-boxes body env fun-env)
|
||||
(body (extend names (arg-vals-thunk) fun-env)))]
|
||||
[else (error 'compile "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))
|
||||
(λ ([env : ENV])
|
||||
(if (cases (compiled-cond env)
|
||||
[(RktV v) v] ; Racket value => use as boolean
|
||||
[else #t]) ; other values are always true
|
||||
(compiled-then env)
|
||||
(compiled-else env)))]
|
||||
[(Set thing as)
|
||||
(define compiled-as (compile as))
|
||||
(λ ([env : ENV])
|
||||
(set-box! (lookup thing env) (compiled-as env))
|
||||
(VoidV))]))
|
||||
|
||||
(: compile-rfun : (Listof Symbol) (ENV -> (Listof (Boxof VAL))) (ENV -> VAL) ENV ENV -> VAL)
|
||||
; Compile an RFun.
|
||||
(define (compile-rfun params get-boxes body callerenv calleeenv)
|
||||
(body (raw-extend params (get-boxes callerenv) calleeenv)))
|
||||
|
||||
(: compile-get-boxes : (Listof TOY) -> (ENV -> (Listof (Boxof VAL))))
|
||||
; Utility for applying rfun.
|
||||
(define (compile-get-boxes exprs)
|
||||
(ensure-compiler-enabled! 'compile-get-boxes)
|
||||
(: compile-getter : TOY -> (ENV -> (Boxof VAL)))
|
||||
(define (compile-getter expr)
|
||||
(cases expr
|
||||
[(Id name) (lambda ([env : ENV]) (lookup name env))]
|
||||
[else
|
||||
(lambda ([_ : ENV]) (error 'compile-get-boxes "non-identifier"))]))
|
||||
(let ([getters (map compile-getter exprs)])
|
||||
(lambda ([env : ENV])
|
||||
(map (lambda ([getter : (ENV -> (Boxof VAL))])
|
||||
(getter env))
|
||||
getters))))
|
||||
|
||||
(: run : String -> Any)
|
||||
;; evaluate a TOY program contained in a string
|
||||
(define (run str)
|
||||
(let ([result (eval (parse str) global-environment)])
|
||||
(define parsed (parse str))
|
||||
(set-box! compiler-enabled? #t)
|
||||
(define compiled (compile parsed))
|
||||
(set-box! compiler-enabled? #f)
|
||||
(let ([result (compiled global-environment)])
|
||||
(cases result
|
||||
[(RktV v) v]
|
||||
[else (error 'run "evaluation returned a bad value: ~s"
|
||||
result)])))
|
||||
[(RktV v) v]
|
||||
[else (error 'run "evaluation returned a bad value: ~s"
|
||||
result)])))
|
||||
|
||||
;;; ----------------------------------------------------------------
|
||||
;;; Tests
|
||||
(test (run "{{rfun {x} x} {/ 4 0}}") =error> "non-identifier")
|
||||
(test (run "{5 {/ 6 0}}") =error> "non-function")
|
||||
(test (run "
|
||||
{bind
|
||||
{
|
||||
{swap!
|
||||
{rfun {x y}
|
||||
{bind {{tmp x}}
|
||||
{set! x y}
|
||||
{set! y tmp}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
{a 1}
|
||||
|
||||
{b 2}
|
||||
}
|
||||
|
||||
{swap! a b}
|
||||
|
||||
{+ a {* 10 b}}
|
||||
}") => 12)
|
||||
|
||||
(test (run "{bind {{make-counter
|
||||
{fun {}
|
||||
{bind {{c 0}}
|
||||
{fun {}
|
||||
{set! c {+ 1 c}}
|
||||
c}}}}}
|
||||
{bind {{c1 {make-counter}}
|
||||
{c2 {make-counter}}}
|
||||
{* {c1} {c1} {c2} {c1}}}}")
|
||||
|
||||
=> 6)
|
||||
(test (run "{bindrec {{foo {fun {}
|
||||
|
||||
{set! foo {fun {} 2}}
|
||||
1}}}
|
||||
{+ {foo} {* 10 {foo}}}}")
|
||||
=> 21)
|
||||
|
||||
(test (run "{bindrec {{fact {fun {n}
|
||||
{if {= 0 n}
|
||||
@@ -237,7 +369,7 @@
|
||||
{* n {fact {- n 1}}}}}}}
|
||||
|
||||
{fact 5}}")
|
||||
=> 120)
|
||||
=> 120)
|
||||
|
||||
(test (run "
|
||||
{bind {{x 10}}
|
||||
@@ -273,18 +405,25 @@
|
||||
=> 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 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 "{bind x 5 x}") =error> "bad `bind' syntax")
|
||||
(test (run "{fun x x}") =error> "parse-sexpr: bad function syntax in (fun x x)")
|
||||
(test (run "{if x}") =error> "bad `if' syntax")
|
||||
(test (run "{}") =error> "bad syntax")
|
||||
(test (run "{bind {{x 5} {x 5}} x}") =error> "parse-sexpr: duplicate `bind' names: (x x)")
|
||||
(test (run "{fun {x x} x}") =error> "parse-sexpr: bad parameters defined for function in (fun (x x) x)")
|
||||
(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")
|
||||
|
||||
(test (compile (Num 1)) =error> "compiler is not enabled")
|
||||
(test (compile-body (list (Num 1))) =error> "compiler is not enabled")
|
||||
(test (compile-get-boxes (list (Id 'x))) =error> "compiler is not enabled")
|
||||
|
||||
(test (run "{bind {{if 5}} if}") =error> "parse-sexpr: bad word found in `bind' : (if)")
|
||||
(test (run "{fun {if} if}") =error> "parse-sexpr: bad words found in function parameter names in (fun (if) if)")
|
||||
|
||||
Reference in New Issue
Block a user