433 lines
15 KiB
Racket
433 lines
15 KiB
Racket
#lang pl
|
|
|
|
#|
|
|
|
|
CFG for the BARF language:
|
|
|
|
<PROG> ::= { prog <FUN> ... }
|
|
<FUN> ::= { fun <id> { <id> } <BARF> }
|
|
<BARF> ::= <number literal>
|
|
|<boolean literal>
|
|
| { + <BARF> ... }
|
|
| { * <BARF> ... }
|
|
| { - <BARF> <BARF> ... }
|
|
| { / <BARF> <BARF> ... }
|
|
| { = <BARF> <BARF> }
|
|
| { <BARF> is <BARF> } -- Sugar.
|
|
| { < <BARF> <BARF> }
|
|
| { <BARF> is less than <BARF> } -- Sugar.
|
|
| { <= <BARF> <BARF> }
|
|
| { <BARF> is less than or equal to <BARF> } -- Sugar.
|
|
| { with { <id> <BARF> } <BARF> }
|
|
| { with <id> as <BARF> <BARF> } -- Sugar.
|
|
| { if <BARF> <BARF> <BARF> }
|
|
| { if <BARF> then <BARF> else <BARF> } -- Sugar.
|
|
| { and <BARF> <BARF> } -- Sugar.
|
|
| { or <BARF> <BARF> } -- Sugar.
|
|
| { not <BARF> } -- Sugar.
|
|
| { lambda <id> <BARF> }
|
|
| { <BARF> of <BARF> }
|
|
| <id>
|
|
| { call <id> <BARF> }
|
|
|#
|
|
|
|
(define-type PROG [Prog (Listof FUN)])
|
|
(define-type FUN [Fun Symbol Symbol BARF])
|
|
(define-type BARF
|
|
[Num Number]
|
|
[Bool Boolean]
|
|
[Sum (Listof BARF)]
|
|
[Mul (Listof BARF)]
|
|
[Sub BARF (Listof BARF)]
|
|
[Div BARF (Listof BARF)]
|
|
[Eq BARF BARF]
|
|
[Lt BARF BARF]
|
|
[Lte BARF BARF]
|
|
[With Symbol BARF BARF]
|
|
[If BARF BARF BARF]
|
|
[Lambda Symbol BARF]
|
|
[Call BARF BARF]
|
|
[Id Symbol]
|
|
[Call2 Symbol BARF])
|
|
|
|
; This is a little strange.
|
|
(define-type LambdaContents
|
|
[Par Symbol]
|
|
[Body BARF])
|
|
|
|
(define-type Primitive = (U Number Boolean (Listof LambdaContents)))
|
|
|
|
(define reserved-names (list 'F 'T '+ '* '- '/ '= 'is '< 'less 'than '<= 'or 'equal 'to 'with 'if 'then 'else 'lambda 'of 'and 'not 'as 'call 'prog 'fun))
|
|
|
|
(define pf (Bool #f))
|
|
(define pt (Bool #t))
|
|
|
|
(: parse : Sexpr -> PROG)
|
|
(define (parse sexpr) (parse-prog sexpr))
|
|
|
|
(: parse-prog : Sexpr -> PROG)
|
|
;; Parses Sexprs into PROGs.
|
|
(define (parse-prog sexpr)
|
|
(match sexpr
|
|
[(list 'prog functions ...) (Prog (map parse-fun functions))]
|
|
[else (error 'parse-prog "Bag prog syntax in ~s." sexpr)]))
|
|
|
|
(: parse-fun : Sexpr -> FUN)
|
|
;; Parses Sexprs into FUNs.
|
|
(define (parse-fun sexpr)
|
|
(match sexpr
|
|
[(list 'fun more ...)
|
|
(match sexpr
|
|
[(list 'fun (symbol: fname) (list (symbol: param)) barf)
|
|
(Fun fname param (parse-barf barf))])]))
|
|
|
|
(: parse-barf : Sexpr -> BARF)
|
|
;; parses s-expressions into BARFs
|
|
(define (parse-barf sexpr)
|
|
;; utility for parsing a list of barf expressions
|
|
(: parse-barfs : (Listof Sexpr) -> (Listof BARF))
|
|
(define (parse-barfs sexprs)
|
|
(map parse-barf sexprs))
|
|
(match sexpr
|
|
[(number: n) (Num n)]
|
|
['T (Bool #t)]
|
|
['F (Bool #f)]
|
|
[(list '+ args ...) (Sum (parse-barfs args))]
|
|
[(list '* args ...) (Mul (parse-barfs args))]
|
|
[(list '- fst args ...) (Sub (parse-barf fst) (parse-barfs args))]
|
|
[(list '/ fst args ...) (Div (parse-barf fst) (parse-barfs args))]
|
|
[(list '= l r) (Eq (parse-barf l) (parse-barf r))]
|
|
[(list l 'is r) (Eq (parse-barf l) (parse-barf r))]
|
|
[(list '< l r) (Lt (parse-barf l) (parse-barf r))]
|
|
[(list l 'is 'less 'than r) (Lt (parse-barf l) (parse-barf r))]
|
|
[(list '<= l r) (Lte (parse-barf l) (parse-barf r))]
|
|
[(list l 'is 'less 'than 'or 'equal 'to r) (Lte (parse-barf l) (parse-barf r))]
|
|
[(list 'with (symbol: name) 'as val body) (With name (parse-barf val) (parse-barf body))]
|
|
[(cons 'with more)
|
|
(match sexpr
|
|
[(list 'with (list (symbol: name) named) body)
|
|
(With name (parse-barf named) (parse-barf body))]
|
|
[else (error 'parse-barf "bad `with' syntax in ~s" sexpr)])]
|
|
[(list 'if p b a) (If (parse-barf p) (parse-barf b) (parse-barf a))]
|
|
[(list 'if p 'then b 'else a) (If (parse-barf p) (parse-barf b) (parse-barf a))]
|
|
[(list 'and a b) (andhelper a b)]
|
|
[(list a 'and b) (andhelper a b)]
|
|
[(list 'or a b) (orhelper a b)]
|
|
[(list a 'or b) (orhelper a b)]
|
|
[(list 'not a) (nothelper a)]
|
|
[(list 'lambda (symbol: arg) body) (Lambda arg (parse-barf body))]
|
|
[(list f 'of arg) (Call (parse-barf f) (parse-barf arg))]
|
|
[(symbol: name) (Id name)]
|
|
[(list 'call (symbol: f) b) (Call2 f (parse-barf b))]
|
|
[else (error 'parse-barf "Bad barf syntax in ~s." sexpr)]))
|
|
|
|
(: andhelper : Sexpr Sexpr -> BARF)
|
|
(define (andhelper a b)
|
|
(If (parse-barf a) (If (parse-barf b) pt pf) pf))
|
|
|
|
(: orhelper : Sexpr Sexpr -> BARF)
|
|
(define (orhelper a b)
|
|
(If (parse-barf a) pt (If (parse-barf b) pt pf)))
|
|
|
|
(: nothelper : Sexpr -> BARF)
|
|
(define (nothelper a )
|
|
(If (parse-barf a) pf pt))
|
|
|
|
#|
|
|
(: parse : String -> BARF)
|
|
;; parses a string containing an BARF expression to an BARF AST
|
|
(define (parse str)
|
|
(parse-barf (string->sexpr str)))|#
|
|
|
|
(: subst : BARF Symbol BARF -> BARF)
|
|
;; 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* : BARF -> BARF)
|
|
(define (subst* x)
|
|
(subst x from to))
|
|
;; helper to substitute lists
|
|
(: substs* : (Listof BARF) -> (Listof BARF))
|
|
(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)]
|
|
[(Call2 fname arg) (Call2 fname (subst* arg))]))
|
|
|
|
(: eval-number : PROG BARF -> Number)
|
|
;; helper for `eval': verifies that the result is a number
|
|
(define (eval-number prog expr)
|
|
(let ([result (eval prog expr)])
|
|
(if (number? result)
|
|
result
|
|
(error 'eval-number "need a number when evaluating ~s, but got ~s" expr result))))
|
|
|
|
(: eval-boolean : PROG BARF -> Boolean)
|
|
;; helper for `eval': verifies that the result is a boolean
|
|
(define (eval-boolean prog expr)
|
|
(let ([result (eval prog 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) -> BARF)
|
|
; 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->barf : Primitive -> BARF)
|
|
;; converts a value to an BARF value (so it can be used with `subst')
|
|
(define (value->barf val)
|
|
(cond
|
|
[(number? val) (Num val)]
|
|
[(boolean? val) (Bool val)]
|
|
[(list? val) (rehydrate val)]))
|
|
|
|
(: eval-sum : PROG (Listof BARF) -> Number)
|
|
; Evaluates a Sum expression.
|
|
(define (eval-sum prog args)
|
|
(foldr + 0 (map (lambda ([arg : BARF]) (eval-number prog arg)) args)))
|
|
|
|
(: eval-mul : PROG (Listof BARF) -> Number)
|
|
; Evaluates a Mul expression.
|
|
(define (eval-mul prog args)
|
|
(foldr * 1 (map (lambda ([arg : BARF]) (eval-number prog arg)) args)))
|
|
|
|
(: eval-sub : PROG BARF (Listof BARF) -> Number)
|
|
; Evaluates a Sub expression.
|
|
(define (eval-sub prog fst args)
|
|
(define l (length args))
|
|
(cond [(= l 0) (- (eval-number prog fst))]
|
|
[else (- (eval-number prog fst) (eval-sum prog args))]))
|
|
|
|
(: eval-div : PROG BARF (Listof BARF) -> Number)
|
|
; Evaluates a Div expression.
|
|
(define (eval-div prog fst args)
|
|
(define l (length args))
|
|
(cond [(= l 0) (/ (eval-number prog fst))]
|
|
[else (/ (eval-number prog fst) (eval-mul prog args))]))
|
|
|
|
(: eval-eq : PROG BARF BARF -> Boolean)
|
|
; Evaluates an Eq expression.
|
|
(define (eval-eq prog a b)
|
|
(= (eval-number prog a) (eval-number prog b)))
|
|
|
|
(: eval-lt : PROG BARF BARF -> Boolean)
|
|
; Evaluates an Lt expression.
|
|
(define (eval-lt prog a b)
|
|
(< (eval-number prog a) (eval-number prog b)))
|
|
|
|
(: eval-lte : PROG BARF BARF -> Boolean)
|
|
; Evaluates an Lte expression.
|
|
(define (eval-lte prog a b)
|
|
(<= (eval-number prog a) (eval-number prog b)))
|
|
|
|
(: eval-if : PROG BARF BARF BARF -> Primitive)
|
|
; Evaluates an If expression.
|
|
(define (eval-if prog pred body alt)
|
|
(if (eval-boolean prog pred) (eval prog body) (eval prog alt)))
|
|
|
|
(: eval-lambda : PROG BARF Symbol BARF -> Primitive )
|
|
; Evaluates a Lambda expression (in a Call expression).
|
|
(define (eval-lambda prog arg par body)
|
|
(if (member par reserved-names)
|
|
(error 'eval-lambda "Can't create parameter binding to reserved name '~s'." par)
|
|
(eval prog (subst body par (value->barf (eval prog arg))))))
|
|
|
|
(: eval-call : PROG BARF BARF -> Primitive)
|
|
; Evaluates a Call expression.
|
|
(define (eval-call prog f arg)
|
|
(match f
|
|
[(list (symbol: par) body) (eval-lambda prog arg par body)]
|
|
[_ (cases f
|
|
[(Lambda par body) (eval-lambda prog arg par body)]
|
|
[_ (error 'eval-call "Expected lambda expression to call, instead got: ~s." f)])]))
|
|
|
|
(: findfun : Symbol PROG -> FUN)
|
|
; Finds the Fun.
|
|
(define (findfun fname prog)
|
|
(define foundfun (cases prog [(Prog functions) (ormap (lambda ([f : FUN]) (cases f [(Fun name par body) (if (symbol=? name fname) f #f)])) functions)]))
|
|
(if (not foundfun) (error 'findfun "Function not found.") foundfun))
|
|
|
|
(: eval-call2 : PROG Symbol BARF -> Primitive)
|
|
; Evaluates a call (new version).
|
|
(define (eval-call2 prog fname arg)
|
|
(: fdef : FUN)
|
|
(define fdef (findfun fname prog)) ; Definition of the function.
|
|
(cases fdef [(Fun name par body)
|
|
(: substbody : BARF)
|
|
(define substbody (subst body par arg))
|
|
(eval prog substbody)]))
|
|
|
|
(: eval : PROG BARF -> Primitive)
|
|
; Evaluates a BARF in the context of a PROG.
|
|
(define (eval prog expr)
|
|
(cases expr
|
|
[(Num n) n]
|
|
[(Bool p) p]
|
|
[(Sum args) (eval-sum prog args)]
|
|
[(Mul args) (eval-mul prog args)]
|
|
[(Sub fst args) (eval-sub prog fst args)]
|
|
[(Div fst args) (eval-div prog fst args)]
|
|
[(Eq l r) (eval-eq prog l r)]
|
|
[(Lt l r) (eval-lt prog l r)]
|
|
[(Lte l r) (eval-lte prog l r)]
|
|
[(If p b a) (eval-if prog 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 prog (subst bound-body
|
|
bound-id
|
|
;; see the above `value-barf' helper
|
|
(value->barf (eval prog named-expr)))))]
|
|
[(Lambda par body)
|
|
(if (member par reserved-names)
|
|
(error 'eval "Can't create parameter binding to reserved name '~s'." par)
|
|
(list (Par par) (Body body)))]
|
|
[(Call f arg) (eval-call prog (value->barf (eval prog f)) arg)]
|
|
[(Id name) (error 'eval "free identifier: ~s" name)]
|
|
[(Call2 fname arg) (eval-call2 prog fname arg)]))
|
|
|
|
(: run : String -> Primitive)
|
|
;; evaluate an BARF program contained in a string
|
|
(define (run str)
|
|
(eval (parse (string->sexpr str)) (Call2 'main (Num 4))))
|
|
|
|
(: run* : String -> Primitive)
|
|
(define (run* str)
|
|
(eval (Prog (list (Fun 'main 'n (parse-barf (string->sexpr str))))) (Call2 'main (Num 4))))
|
|
|
|
(test (run "{prog {fun main {n} n}}") => 4)
|
|
|
|
(test (run "
|
|
{prog
|
|
{fun even? {n}
|
|
{if {= 0 n} T {call odd? {- n 1}}}}
|
|
|
|
{fun odd? {n}
|
|
{if {= 0 n} F {call even? {- n 1}}}}
|
|
|
|
{fun 3np1 {n}
|
|
{if {= n 1}
|
|
1
|
|
{+ 1 {call 3np1
|
|
{if {call even? n}
|
|
{/ n 2}
|
|
{+ 1 {* n 3}}}}}}}
|
|
|
|
{fun main {n}
|
|
{and {= {call 3np1 5} 6}
|
|
{= {call 3np1 4} 3}}}}"
|
|
) => #T)
|
|
|
|
; As we'ren't writing a lazy language, we need to use the Z combinator to delay evaluation of f (otherwise it'd never terminate). This factorial function also isn't tail recursive cause it's hard enough for me to understand already ;-;.
|
|
; 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 as {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 as {Z of
|
|
{lambda self {lambda n
|
|
{if {n is less than or equal to 1} then 1 else {* n {self of {- n 1}}}}
|
|
}
|
|
}}
|
|
|
|
{{{factorial of 4} is 24} and
|
|
{{factorial of 5} is 120}}}}") => #t)
|
|
|
|
|
|
(test (run* "{{lambda f {f of 1}} of {lambda x {+ x 1}}}") => 2)
|
|
(test (run* "{{lambda x {+ x 1}} of 2}") => 3)
|
|
(test (run* "{{lambda + {+ + +}} of 2}") =error> "Can't create parameter binding to reserved name '+'.")
|
|
(test (run* "{1 of 1}") =error> "eval-call: Expected lambda expression to call, instead got: (Num 1).")
|
|
(test (run* "{with {x 2} {x of 1}}") =error> "eval-call: Expected lambda expression to call, instead got: (Num 2).")
|
|
|
|
|
|
(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 is 2}") => #f)
|
|
(test (run* "{= 1 2}") => #f)
|
|
(test (run* "{= 2 2}") => #t)
|
|
(test (run* "{2 is 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-barf: Bad barf syntax in (-).")
|
|
(test (run* "{- 1}") => -1)
|
|
(test (run* "{- 3 2 1}") => 0)
|
|
(test (run* "{- 1 2 3}") => -4)
|
|
|
|
(test (run* "{/}") =error> "parse-barf: Bad barf syntax in (/).")
|
|
(test (run* "{/ 2}") => 1/2)
|
|
(test (run* "{/ 3 2 1}") => 3/2)
|
|
(test (run* "{/ 1 2 3}") => 1/6)
|
|
|
|
(test (run* "{+ x 1}") =error> "eval: free identifier: x")
|
|
|
|
|
|
|
|
(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)
|