451 lines
18 KiB
Racket
451 lines
18 KiB
Racket
#lang pl
|
|
|
|
;;; ==================================================================
|
|
;;; Syntax
|
|
|
|
#| The BNF:
|
|
<TOY> ::= <num>
|
|
| <id>
|
|
| { set! <id> <TOY> }
|
|
| { bind {{ <id> <TOY> } ... } <TOY> <TOY> ... }
|
|
| { bindrec {{ <id> <TOY> } ... } <TOY> <TOY> ... }
|
|
| { fun { <id> ... } <TOY> <TOY> ... }
|
|
| { rfun { <id> ... } <TOY> <TOY> ... }
|
|
| { if <TOY> <TOY> <TOY> }
|
|
| { <TOY> <TOY> ... }
|
|
|#
|
|
|
|
(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])
|
|
|
|
(: unique-list? : (Listof Any) -> Boolean)
|
|
;; Tests whether a list is unique, guards Bind and Fun values.
|
|
(define (unique-list? xs)
|
|
(or (null? xs)
|
|
(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)]
|
|
[(symbol: name) (Id name)]
|
|
[(cons 'set! more)
|
|
(match sexpr
|
|
[(list 'set! (symbol: name) new) (Set name (parse-sexpr new))]
|
|
[else (error 'parse-sexpr "bad `set!' syntax in ~s" sexpr)])]
|
|
[(cons (and binder (or 'bind 'bindrec)) _)
|
|
(match sexpr
|
|
[(list _ (list (list (symbol: names) (sexpr: nameds)) ...)
|
|
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))]
|
|
[else (error 'parse-sexpr "bad `~s' syntax in ~s"
|
|
binder sexpr)])]
|
|
[(cons (and funner (or 'fun 'rfun)) _)
|
|
(match sexpr
|
|
[(list _ (list (symbol: names) ...)
|
|
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))]
|
|
[else (error 'parse-sexpr "bad `~s' syntax in ~s"
|
|
funner sexpr)])]
|
|
[(cons 'if _)
|
|
(match sexpr
|
|
[(list 'if cond then else)
|
|
(If (parse-sexpr cond) (parse-sexpr then) (parse-sexpr else))]
|
|
[else (error 'parse-sexpr "bad `if' syntax in ~s" sexpr)])]
|
|
[(list fun args ...) ; other lists are applications
|
|
(Call (parse-sexpr fun)
|
|
(map parse-sexpr args))]
|
|
[else (error 'parse-sexpr "bad syntax in ~s" sexpr)]))
|
|
|
|
(: parse : String -> TOY)
|
|
;; Parses a string containing an TOY expression to a TOY AST.
|
|
(define (parse str)
|
|
(parse-sexpr (string->sexpr str)))
|
|
|
|
;;; ==================================================================
|
|
;;; Values and environments
|
|
|
|
(define-type ENV = (Listof (Listof (Boxof VAL))))
|
|
|
|
(define-type VAL
|
|
[BogusV]
|
|
[RktV Any]
|
|
[FunV Natural (ENV -> VAL) ENV Boolean] ; `byref?' flag
|
|
[PrimV ((Listof VAL) -> VAL)])
|
|
|
|
;; a single bogus value to use wherever needed
|
|
(define the-bogus-value (BogusV))
|
|
|
|
(: extend : (Listof VAL) ENV -> ENV)
|
|
;; extends an environment with a new frame (given plain values).
|
|
(define (extend values env)
|
|
(cons (map (inst box VAL) values) env))
|
|
|
|
(: extend-rec : (Listof (ENV -> VAL)) ENV -> ENV)
|
|
;; extends an environment with a new recursive frame (given compiled
|
|
;; expressions).
|
|
(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 ([boxed-val : (Boxof VAL)] [compiled : (ENV -> VAL)])
|
|
(set-box! boxed-val (compiled new-env)))
|
|
new-boxes compiled-exprs)
|
|
new-env)
|
|
|
|
(: 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)]))
|
|
|
|
(: 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
|
|
;; list function's responsibility to throw an error if it's given a
|
|
;; bad number of arguments or bad input types.)
|
|
(define (racket-func->prim-val racket-func)
|
|
(define list-func (make-untyped-list-function racket-func))
|
|
(PrimV (lambda (args)
|
|
(RktV (list-func (map unwrap-rktv args))))))
|
|
|
|
;; The global environment has a few primitives:
|
|
(: global-environment : (Listof (List Symbol VAL)))
|
|
(define global-environment
|
|
(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
|
|
|
|
(: compiler-enabled? : (Boxof Boolean))
|
|
;; a global flag that can disable the compiler
|
|
(define compiler-enabled? (box #f))
|
|
|
|
(: compile-body : (Listof TOY) BINDINGS -> (ENV -> VAL))
|
|
;; compiles a list of expressions to a single Racket function.
|
|
(define (compile-body exprs bin)
|
|
(unless (unbox compiler-enabled?)
|
|
(error 'compile-body "compiler disabled"))
|
|
(let ([compiled-1st (compile (first exprs) bin)]
|
|
[rest (rest exprs)])
|
|
(if (null? rest)
|
|
compiled-1st
|
|
(let ([compiled-rest (compile-body rest bin)])
|
|
(lambda (env)
|
|
(let [(_ (compiled-1st env))]
|
|
(compiled-rest env)))))))
|
|
|
|
(: compile-get-boxes : (Listof TOY) BINDINGS -> (ENV -> (Listof (Boxof VAL))))
|
|
;; utility for applying rfun
|
|
(define (compile-get-boxes exprs bin)
|
|
(: compile-getter : TOY -> (ENV -> (Boxof VAL)))
|
|
(define (compile-getter expr)
|
|
(cases 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)])
|
|
(lambda (env)
|
|
(map (lambda ([get-box : (ENV -> (Boxof VAL))]) (get-box env))
|
|
getters))))
|
|
|
|
(: compile : TOY BINDINGS -> (ENV -> VAL))
|
|
;; compiles TOY expressions to Racket functions.
|
|
(define (compile expr bin)
|
|
;; convenient helper for running compiled code
|
|
(: caller : ENV -> ((ENV -> VAL) -> VAL))
|
|
(define (caller env)
|
|
(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)
|
|
(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)))
|
|
(: arity : Natural)
|
|
(define arity (length names))
|
|
(lambda ([env : ENV]) (FunV arity compiled-body env #f))]
|
|
[(RFun names bound-body)
|
|
(define compiled-body (compile-body bound-body (cons names bin)))
|
|
(define arity (length names))
|
|
(lambda ([env : ENV]) (FunV arity compiled-body env #t))]
|
|
[(Call fun-expr arg-exprs)
|
|
(define compiled-fun (compile fun-expr bin))
|
|
(: nargs : Natural)
|
|
(define nargs (length arg-exprs))
|
|
(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 arity compiled-body fun-env byref?) (if (= arity nargs)
|
|
(compiled-body (if byref?
|
|
(cons (compiled-boxes-getter env) fun-env)
|
|
(extend (arg-vals) fun-env)))
|
|
(error 'compile "arity mismatch"))]
|
|
[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) '(()))])
|
|
(set-box! compiler-enabled? #f)
|
|
(let ([result (compiled '())])
|
|
(cases result
|
|
[(RktV v) v]
|
|
[else (error 'run "the program returned a bad value: ~s"
|
|
result)]))))
|
|
|
|
;;; ==================================================================
|
|
;;; Tests
|
|
|
|
(test (run "{{fun {x} {+ x 1}} 4}")
|
|
=> 5)
|
|
(test (run "{bind {{add3 {fun {x} {+ x 3}}}} {add3 1}}")
|
|
=> 4)
|
|
(test (run "{bind {{add3 {fun {x} {+ x 3}}}
|
|
{add1 {fun {x} {+ x 1}}}}
|
|
{bind {{x 3}} {add1 {add3 x}}}}")
|
|
=> 7)
|
|
(test (run "{bind {{identity {fun {x} x}}
|
|
{foo {fun {x} {+ x 1}}}}
|
|
{{identity foo} 123}}")
|
|
=> 124)
|
|
(test (run "{bind {{x 3}}
|
|
{bind {{f {fun {y} {+ x y}}}}
|
|
{bind {{x 5}}
|
|
{f 4}}}}")
|
|
=> 7)
|
|
(test (run "{{{fun {x} {x 1}}
|
|
{fun {x} {fun {y} {+ x y}}}}
|
|
123}")
|
|
=> 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 "{+ 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")
|
|
|
|
;; assignment tests
|
|
(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")
|
|
(test (run "{bindrec {{fact {fun {n}
|
|
{if {= 0 n}
|
|
1
|
|
{* n {fact {- n 1}}}}}}}
|
|
{fact 5}}")
|
|
=> 120)
|
|
|
|
;; tests for multiple expressions and assignment
|
|
(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)
|
|
|
|
;; `rfun' tests
|
|
(test (run "{{rfun {x} x} 4}") =error> "non-identifier")
|
|
(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 that argument are not evaluated redundantly
|
|
(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")
|
|
|
|
;;; ==================================================================
|