Source

cs173-scratch / Conditional-pt.rkt

Full commit
#lang plai-typed

;; Core Language

(define-type ArithC
  [numC (n : number)]
  [plusC (l : ArithC) (r : ArithC)]
  [multC (l : ArithC) (r : ArithC)]
  [ifC (predicate : ArithC) (true : ArithC) (false : ArithC)])

(define (interp [a : ArithC]) : number
  (type-case ArithC a
    [numC (n) n]
    [plusC (l r) (+ (interp l) (interp r))]
    [multC (l r) (* (interp l) (interp r))]
    [ifC (p t f) (if (zero? (interp p))
                     (interp t)
                     (interp f))]))

;; Surface Language

(define-type ArithS
  [numS (n : number)]
  [plusS (l : ArithS) (r : ArithS)]
  [bminusS (l : ArithS) (r : ArithS)]
  [multS (l : ArithS) (r : ArithS)]
  [ifS (predicate : ArithS) (true : ArithS) (false : ArithS)])

(define (parse s) : ArithS
  (cond 
    [(s-exp-number? s) (numS (s-exp->number s))]
    [(s-exp-list? s)
     (let ([sl (s-exp->list s)])
       (case (s-exp->symbol (first sl))
         [(+) (plusS (parse (second sl)) (parse (third sl)))]
         [(*) (multS (parse (second sl)) (parse (third sl)))]
         [(-) (bminusS (parse (second sl)) (parse (third sl)))]
         [(if0) (ifS (parse (second sl))
                     (parse (third sl)) 
                     (parse (fourth sl)))]
         [else (error 'parse "invalid input")]))]
    [else (error 'parse "invalid input")]))

(define (desugar [as : ArithS]) : ArithC
  (type-case ArithS as
    [numS (n) (numC n)]
    [plusS (l r) (plusC (desugar l) (desugar r))]
    [bminusS (l r) (plusC (desugar l) 
                          (multC (numC -1) 
                                 (desugar r)))]
    [multS (l r) (multC (desugar l) (desugar r))]
    [ifS (p t f) (ifC (desugar p)
                      (desugar t)
                      (desugar f))]))