Finished BAE.
This commit is contained in:
+336
@@ -0,0 +1,336 @@
|
||||
#lang pl 04
|
||||
|
||||
; I added functions.
|
||||
|
||||
#| CFG for the BAE language:
|
||||
<BAE> ::= <number literal>
|
||||
<boolean literal>
|
||||
| { + <BAE> ... }
|
||||
| { * <BAE> ... }
|
||||
| { - <BAE> <BAE> ... }
|
||||
| { / <BAE> <BAE> ... }
|
||||
| { = <BAE> <BAE> }
|
||||
| { < <BAE> <BAE> }
|
||||
| { <= <BAE> <BAE> }
|
||||
| { with { <id> <BAE> } <BAE> }
|
||||
| { if <BAE> <BAE> <BAE> }
|
||||
| { if <BAE> then <BAE> else <BAE> } -- Sugar.
|
||||
| { and <BAE> <BAE> } -- Sugar.
|
||||
| { or <BAE> <BAE> } -- Sugar.
|
||||
| { not <BAE> } -- Sugar.
|
||||
| { lambda <id> <BAE> }
|
||||
| { <BAE> of <BAE> }
|
||||
| <id>
|
||||
|#
|
||||
|
||||
;; BAE abstract syntax trees
|
||||
(define-type BAE
|
||||
[Num Number]
|
||||
[Bool Boolean]
|
||||
[Sum (Listof BAE)]
|
||||
[Mul (Listof BAE)]
|
||||
[Sub BAE (Listof BAE)]
|
||||
[Div BAE (Listof BAE)]
|
||||
[Eq BAE BAE]
|
||||
[Lt BAE BAE]
|
||||
[Lte BAE BAE]
|
||||
[With Symbol BAE BAE]
|
||||
[If BAE BAE BAE]
|
||||
[Lambda Symbol BAE]
|
||||
[Call BAE BAE]
|
||||
[Id Symbol])
|
||||
|
||||
(define-type LambdaContents
|
||||
[Par Symbol]
|
||||
[Body BAE])
|
||||
|
||||
(define-type Primitive = (U Number Boolean (Listof LambdaContents)))
|
||||
|
||||
(define reserved-names (list 'F 'T '+ '* '- '/ '= '< '<= 'with 'if 'then 'else 'lambda 'λ 'of))
|
||||
|
||||
(define pf (Bool #f))
|
||||
(define pt (Bool #t))
|
||||
|
||||
(: parse-sexpr : Sexpr -> BAE)
|
||||
;; parses s-expressions into BAEs
|
||||
(define (parse-sexpr sexpr)
|
||||
;; utility for parsing a list of expressions
|
||||
(: parse-sexprs : (Listof Sexpr) -> (Listof BAE))
|
||||
(define (parse-sexprs sexprs)
|
||||
(map parse-sexpr sexprs))
|
||||
(match sexpr
|
||||
[(number: n) (Num n)]
|
||||
['T (Bool #t)]
|
||||
['F (Bool #f)]
|
||||
[(list '+ args ...) (Sum (parse-sexprs args))]
|
||||
[(list '* args ...) (Mul (parse-sexprs args))]
|
||||
[(list '- fst args ...) (Sub (parse-sexpr fst) (parse-sexprs args))]
|
||||
[(list '/ fst args ...) (Div (parse-sexpr fst) (parse-sexprs args))]
|
||||
[(list '= l r) (Eq (parse-sexpr l) (parse-sexpr r))]
|
||||
[(list '< l r) (Lt (parse-sexpr l) (parse-sexpr r))]
|
||||
[(list '<= l r) (Lte (parse-sexpr l) (parse-sexpr r))]
|
||||
[(cons 'with more)
|
||||
(match sexpr
|
||||
[(list 'with (list (symbol: name) named) body)
|
||||
(With name (parse-sexpr named) (parse-sexpr body))]
|
||||
[else (error 'parse-sexpr "bad `with' syntax in ~s" sexpr)])]
|
||||
[(list 'if p b a) (If (parse-sexpr p) (parse-sexpr b) (parse-sexpr a))]
|
||||
[(list 'if p 'then b 'else a) (If (parse-sexpr p) (parse-sexpr b) (parse-sexpr a))]
|
||||
[(list 'and a b) (If (parse-sexpr a) (If (parse-sexpr b) pt pf) pf)]
|
||||
[(list 'or a b) (If (parse-sexpr a) pt (If (parse-sexpr b) pt pf))]
|
||||
[(list 'not a) (If (parse-sexpr a) pf pt)]
|
||||
[(list 'lambda (symbol: arg) body) (Lambda arg (parse-sexpr body))]
|
||||
[(list f 'of arg) (Call (parse-sexpr f) (parse-sexpr arg))]
|
||||
[(symbol: name) (Id name)]
|
||||
[else (error 'parse-sexpr "bad syntax in ~s" sexpr)]))
|
||||
|
||||
(: parse : String -> BAE)
|
||||
;; parses a string containing an BAE expression to an BAE AST
|
||||
(define (parse str)
|
||||
(parse-sexpr (string->sexpr str)))
|
||||
|
||||
(: subst : BAE Symbol BAE -> BAE)
|
||||
;; substitutes the second argument with the third argument in the
|
||||
;; first argument, as per the rules of substitution; the resulting
|
||||
;; expression contains no free instances of the second argument
|
||||
(define (subst expr from to)
|
||||
;; convenient helper -- no need to specify `from' and `to'
|
||||
(: subst* : BAE -> BAE)
|
||||
(define (subst* x)
|
||||
(subst x from to))
|
||||
;; helper to substitute lists
|
||||
(: substs* : (Listof BAE) -> (Listof BAE))
|
||||
(define (substs* exprs)
|
||||
(map subst* exprs))
|
||||
(cases expr
|
||||
[(Num n) expr]
|
||||
[(Bool p) expr]
|
||||
[(Sum args) (Sum (substs* args))]
|
||||
[(Mul args) (Mul (substs* args))]
|
||||
[(Sub fst args) (Sub (subst* fst) (substs* args))]
|
||||
[(Div fst args) (Div (subst* fst) (substs* args))]
|
||||
[(Eq l r) (Eq (subst* l) (subst* r))]
|
||||
[(Lt l r) (Lt (subst* l) (subst* r))]
|
||||
[(Lte l r) (Lte (subst* l) (subst* r))]
|
||||
[(If p b a) (If (subst* p) (subst* b) (subst* a))]
|
||||
[(With bound-id named-expr bound-body)
|
||||
(With bound-id
|
||||
(subst* named-expr)
|
||||
(if (eq? bound-id from)
|
||||
bound-body
|
||||
(subst* bound-body)))]
|
||||
[(Lambda arg body)
|
||||
(Lambda arg (if (eq? arg from) body (subst* body)))]
|
||||
[(Call f arg) (Call (subst* f) (subst* arg))]
|
||||
[(Id name) (if (eq? name from) to expr)]))
|
||||
|
||||
(: eval-number : BAE -> Number)
|
||||
;; helper for `eval': verifies that the result is a number
|
||||
(define (eval-number expr)
|
||||
(let ([result (eval expr)])
|
||||
(if (number? result)
|
||||
result
|
||||
(error 'eval-number "need a number when evaluating ~s, but got ~s" expr result))))
|
||||
|
||||
(: eval-boolean : BAE -> Boolean)
|
||||
;; helper for `eval': verifies that the result is a boolean
|
||||
(define (eval-boolean expr)
|
||||
(let ([result (eval expr)])
|
||||
(if (boolean? result)
|
||||
result
|
||||
(error 'eval-boolean "need a boolean when evaluating ~s, but got ~s" expr result))))
|
||||
|
||||
; This is pretty cursed, but I couldn't find a better way to have structured data.
|
||||
(: rehydrate : (Listof LambdaContents) -> BAE)
|
||||
; Recreates a lambda from list representation.
|
||||
(define (rehydrate l)
|
||||
(Lambda (cases (first l) [(Par s) s] [_ (error 'rehydrate "what")])
|
||||
(cases (second l) [(Body b) b] [_ (error 'rehydrate "what")])))
|
||||
|
||||
(: value->bae : Primitive -> BAE)
|
||||
;; converts a value to an BAE value (so it can be used with `subst')
|
||||
(define (value->bae val)
|
||||
(cond
|
||||
[(number? val) (Num val)]
|
||||
[(boolean? val) (Bool val)]
|
||||
[(list? val) (rehydrate val)]))
|
||||
|
||||
(: eval-sum : (Listof BAE) -> Number)
|
||||
; Evaluates a Sum expression.
|
||||
(define (eval-sum args)
|
||||
(define l (length args))
|
||||
(cond [(= l 0) 0]
|
||||
[(= l 1) (eval-number (first args))]
|
||||
[else (+ (eval-number (first args)) (eval-sum (rest args)))]))
|
||||
|
||||
(: eval-mul : (Listof BAE) -> Number)
|
||||
; Evaluates a Mul expression.
|
||||
(define (eval-mul args)
|
||||
(define l (length args))
|
||||
(cond [(= l 0) 1]
|
||||
[(= l 1) (eval-number (first args))]
|
||||
[else (* (eval-number (first args)) (eval-mul (rest args)))]))
|
||||
|
||||
(: eval-sub : BAE (Listof BAE) -> Number)
|
||||
; Evaluates a Sub expression.
|
||||
(define (eval-sub fst args)
|
||||
(define l (length args))
|
||||
(cond [(= l 0) (- (eval-number fst))]
|
||||
[else (- (eval-number fst) (eval-sum args))])) ; Huh.
|
||||
|
||||
(: eval-div : BAE (Listof BAE) -> Number)
|
||||
; Evaluates a Div expression.
|
||||
(define (eval-div fst args)
|
||||
(define l (length args))
|
||||
(cond [(= l 0) (/ (eval-number fst))]
|
||||
[else (/ (eval-number fst) (eval-mul args))])) ; Huh.
|
||||
|
||||
(: eval-eq : BAE BAE -> Boolean)
|
||||
; Evaluates an Eq expression.
|
||||
(define (eval-eq a b)
|
||||
(= (eval-number a) (eval-number b)))
|
||||
|
||||
(: eval-lt : BAE BAE -> Boolean)
|
||||
; Evaluates an Lt expression.
|
||||
(define (eval-lt a b)
|
||||
(< (eval-number a) (eval-number b)))
|
||||
|
||||
(: eval-lte : BAE BAE -> Boolean)
|
||||
; Evaluates an Lte expression.
|
||||
(define (eval-lte a b)
|
||||
(<= (eval-number a) (eval-number b)))
|
||||
|
||||
(: eval-if : BAE BAE BAE -> Primitive)
|
||||
; Evaluates an If expression.
|
||||
(define (eval-if pred body alt)
|
||||
(if (eval-boolean pred) (eval body) (eval alt)))
|
||||
|
||||
(: eval-lambda : BAE Symbol BAE -> Primitive )
|
||||
; Evaluates a Lambda expression (in a Call expression).
|
||||
(define (eval-lambda arg par body)
|
||||
(if (member par reserved-names)
|
||||
(error 'eval-lambda "Can't create parameter binding to reserved name '~s'." par)
|
||||
(eval (subst body par (value->bae (eval arg))))))
|
||||
|
||||
(: eval-call : BAE BAE -> Primitive)
|
||||
; Evaluates a Call expression.
|
||||
(define (eval-call f arg)
|
||||
(match f
|
||||
[(list (symbol: par) body) (eval-lambda arg par body)]
|
||||
[_ (cases f
|
||||
[(Lambda par body) (eval-lambda arg par body)]
|
||||
[_ (error 'eval-call "Expected lambda expression to call, instead got: ~s." f)])]))
|
||||
|
||||
(: eval : BAE -> Primitive)
|
||||
;; evaluates BAE expressions by reducing them to numbers
|
||||
(define (eval expr)
|
||||
(cases expr
|
||||
[(Num n) n]
|
||||
[(Bool p) p]
|
||||
[(Sum args) (eval-sum args)]
|
||||
[(Mul args) (eval-mul args)]
|
||||
[(Sub fst args) (eval-sub fst args)]
|
||||
[(Div fst args) (eval-div fst args)]
|
||||
[(Eq l r) (eval-eq l r)]
|
||||
[(Lt l r) (eval-lt l r)]
|
||||
[(Lte l r) (eval-lte l r)]
|
||||
[(If p b a) (eval-if p b a)]
|
||||
[(With bound-id named-expr bound-body)
|
||||
(if (member bound-id reserved-names)
|
||||
(error 'eval "Can't create binding to reserved name '~s'." bound-id)
|
||||
(eval (subst bound-body
|
||||
bound-id
|
||||
;; see the above `value-bae' helper
|
||||
(value->bae (eval named-expr)))))]
|
||||
[(Lambda par body) (list (Par par) (Body body))] ; No lambda primitive, but this branch shouldn't happen anyway. Return dummy value for now.
|
||||
[(Call f arg) (eval-call (value->bae (eval f)) arg)]
|
||||
[(Id name) (error 'eval "free identifier: ~s" name)]))
|
||||
|
||||
(: run : String -> Primitive)
|
||||
;; evaluate an BAE program contained in a string
|
||||
(define (run str)
|
||||
(eval (parse str)))
|
||||
|
||||
; Because we'ren't writing a lazy language, need to use the Z combinator to delay evaluation of f (otherwise it'd never terminate).
|
||||
; Z = λf.(λx.(f λv.((x x) v)))(λx.(f λv.((x x) v)))
|
||||
; factorial = (Y (λself.λn.if (<= n 1) 1 (* n (self (- n 1)))))
|
||||
|
||||
(test (run "
|
||||
{with
|
||||
|
||||
{Z {lambda f {
|
||||
{lambda x {f of {lambda v {{x of x} of v}}}}
|
||||
of
|
||||
{lambda x {f of {lambda v {{x of x} of v}}}}
|
||||
}}}
|
||||
|
||||
{with
|
||||
|
||||
{factorial {Z of
|
||||
{lambda self {lambda n
|
||||
{if {<= n 1} 1 {* n {self of {- n 1}}}}
|
||||
}
|
||||
}}}
|
||||
|
||||
{factorial of 5}
|
||||
|
||||
}}
|
||||
") => 120)
|
||||
|
||||
(test (run "{{lambda f {f of 1}} of {lambda x {+ x 1}}}") => 2)
|
||||
(test (run "{{lambda x {+ x 1}} of 2}") => 3)
|
||||
|
||||
(test (run "{and T T}") => #t)
|
||||
(test (run "{and F aaaaaaaaaa}") => #f)
|
||||
(test (run "{or T aaaaaaaaaa}") => #T)
|
||||
(test (run "{or F T}") => #T)
|
||||
(test (run "{or T T}") => #T)
|
||||
(test (run "{not T}") => #F)
|
||||
(test (run "{not F}") => #T)
|
||||
(test (run "{with {p1 {< 1 2}} {with {p2 {< 3 4}} {and p1 p2}}}") => #T)
|
||||
|
||||
(test (run "{if T 1 2}") => 1)
|
||||
(test (run "{if T then 1 else 2}") => 1)
|
||||
|
||||
(test (run "{with {T 2} {+ T 1}}") =error> "Can't create binding to reserved name 'T'.")
|
||||
(test (run "{with {+ 2} {+ + 1}}") =error> "Can't create binding to reserved name '+'.")
|
||||
|
||||
(test (run "{< 1 2}") => #t)
|
||||
(test (run "{< 2 2}") => #f)
|
||||
(test (run "{< 2 1}") => #f)
|
||||
(test (run "{= 1 2}") => #f)
|
||||
(test (run "{= 2 2}") => #t)
|
||||
(test (run "{<= 1 2}") => #t)
|
||||
(test (run "{<= 2 2}") => #t)
|
||||
(test (run "{<= 2 1}") => #f)
|
||||
|
||||
(test (run "{+}") => 0)
|
||||
(test (run "{+ 12}") => 12)
|
||||
(test (run "{+ 1 2 3}") => 6)
|
||||
|
||||
(test (run "{*}") => 1)
|
||||
(test (run "{* 12}") => 12)
|
||||
(test (run "{* 2 3 5}") => 30)
|
||||
|
||||
(test (run "{-}") =error> "parse-sexpr: bad syntax in (-)")
|
||||
(test (run "{- 1}") => -1)
|
||||
(test (run "{- 3 2 1}") => 0)
|
||||
(test (run "{- 1 2 3}") => -4)
|
||||
|
||||
(test (run "{/}") =error> "parse-sexpr: bad syntax in (/)")
|
||||
(test (run "{/ 2}") => 1/2)
|
||||
(test (run "{/ 3 2 1}") => 3/2)
|
||||
(test (run "{/ 1 2 3}") => 1/6)
|
||||
|
||||
;; tests (for simple expressions)
|
||||
(test (run "5") => 5)
|
||||
(test (run "{+ 5 5}") => 10)
|
||||
(test (run "{with {x {+ 5 5}} {+ x x}}") => 20)
|
||||
(test (run "{with {x 5} {+ x x}}") => 10)
|
||||
(test (run "{with {x {+ 5 5}} {with {y {- x 3}} {+ y y}}}") => 14)
|
||||
(test (run "{with {x 5} {with {y {- x 3}} {+ y y}}}") => 4)
|
||||
(test (run "{with {x 5} {+ x {with {x 3} 10}}}") => 15)
|
||||
(test (run "{with {x 5} {+ x {with {x 3} x}}}") => 8)
|
||||
(test (run "{with {x 5} {+ x {with {y 3} x}}}") => 10)
|
||||
(test (run "{with {x 5} {with {y x} y}}") => 5)
|
||||
(test (run "{with {x 5} {with {x x} x}}") => 5)
|
||||
Reference in New Issue
Block a user