Interpretador Rudimentar

scheme-study1.ss

;More information about what this program do at 
;http://www.cs.brown.edu/courses/cs173/2008/Assignments/01-rinterp.html

#lang plai

; Binding type definition
(define-type Binding
  [binding (name symbol?) (named-expr WAE?)])


;; WAE type definition
(define-type WAE
  [num (n number?)]
  [binop (operation symbol?) (lhs WAE?) (rhs WAE?)]
  [with (lob (listof Binding?)) (body WAE?)]
  [id (name symbol?)])

(define operation-list (list (list '+ +)
                             (list '- -)
                             (list '* *)
                             (list '/ /)
                             ;add new binary operations here!
                             ))

; binop-lookup: symbol -> procedure
(define (binop-lookup op)
  (define (binop-lookup-local op l)
    (if (empty? l)
        false
        (if (symbol=? op (first (first l)))
            (second (first l))
            (binop-lookup-local op (rest l)))))
  (binop-lookup-local op operation-list))

;test binop-lookup
(test (binop-lookup '+) +)
(test (binop-lookup '-) -)
(test (binop-lookup '*) *)
(test (binop-lookup '/) /)

;; parse : s-exp -> WAE
;; Consumes an s-expression and generates the corresponding WAE
(define (parse sexp)
  (define (build-bindings list)
    (if (empty? list)
        '()
        (if (and (list? (first list))
                 (= 2 (length (first list)))
                 (symbol? (first (first list))))
            (cons (binding (first (first list)) (parse (second (first list))))
                  (build-bindings (rest list)))
            (error 'parse "invalid 'with' expression"))))
  (cond
    [(symbol? sexp) (id sexp)]
    [(number? sexp) (num sexp)]
    [(list? sexp)
     (if (= (length sexp) 3)
         (if (binop-lookup (first sexp))
             (binop (first sexp)
                    (parse (second sexp))
                    (parse (third sexp)))
             (case (first sexp)
               [(with) 
                (if (list? (second sexp))
                    (with (build-bindings (second sexp)) (parse (third sexp)))
                    (error 'parse "invalid 'with' expression"))]
               [else (error 'parse "invalid operator: expected + or - or with")]
               ))
         (error 'parse "this operation must have 2 arguments"))]
    [else (error 'parse "invalid expression")]))

;; parse functionality tests
(test (parse '3) (num 3))
(test (parse '{+ 4 5}) (binop '+ (num 4) (num 5)))
(test (parse '{- 4 5}) (binop '- (num 4) (num 5)))
(test (parse '{with {{x 5}} x}) (with (list (binding 'x (num 5))) (id 'x) )) 
(test (parse '{with {{x 5}} {+ x 10}}) (with (list (binding 'x (num 5))) (binop '+ (id 'x) (num 10)))) 
(test (parse '{with {{x {- 10 8}}} {+ x 5}})
      (with (list (binding 'x (binop '- (num 10) (num 8)))) (binop '+ (id 'x) (num 5))))
(test (parse '{with {{x 7}} {with {{y x}} y}}) 
      (with (list (binding 'x (num 7))) (with (list (binding 'y (id 'x))) (id 'y))))

(test (parse '{with {{x 7} {y 5}} {* x y}})
      (with (list (binding 'x (num 7)) (binding 'y (num 5))) (binop '* (id 'x) (id 'y))))
(test (parse '{with {{x {with {{y 5}} y}}} x})
      (with (list (binding 'x (with (list (binding 'y (num 5))) (id 'y)))) (id 'x)))

;; parse error messages test
(test/exn (parse '{g 1 2}) "invalid operator: expected + or - or with")
(test/exn (parse '{+ 1 2 3}) "this operation must have 2 arguments")
(test/exn (parse (id 'x)) "invalid expression")
(test/exn (parse '{with 1 2}) "invalid 'with' expression") 
(test/exn (parse '{with {x 2 4} 4}) "invalid 'with' expression") 
(test/exn (parse '{with {{4 2}} 4}) "invalid 'with' expression")

;; subst : WAE symbol WAE -> WAE
(define (subst expr sub-id val)
  (define (have-binding id binding-list)
    (if (empty? binding-list)
        false
        (or (symbol=? (binding-name (first binding-list)) sub-id)
            (have-binding id (rest binding-list)))))
  (define (subst-binding b sub-id val)
    (binding (binding-name b) (subst (binding-named-expr b) sub-id val)))
  (define (subst-bindings binding-list sub-id val)
    (if (empty? binding-list)
        '()
        (cons (subst-binding (first binding-list) sub-id val) (subst-bindings (rest binding-list) sub-id val))))
  (type-case WAE expr
    [num (n) expr]
    [binop (op l r) (binop op (subst l sub-id val)
                           (subst r sub-id val))]
    [with (binding-list bound-body)
          (if (have-binding sub-id binding-list)
              (with (subst-bindings binding-list sub-id val)
                    bound-body)    
              (with (subst-bindings binding-list sub-id val)
                    (subst bound-body sub-id val)))]
    [id (v) (if (symbol=? v sub-id) val expr)])) 


;; subst tests
(test (subst (num 9) 'x (num 7)) (num 9))
(test (subst (id 'x) 'x (num 9)) (num 9)) 
(test (subst (binop '+ (id 'x) (id 'y)) 'y (num 7)) (binop '+ (id 'x) (num 7)))       
(test (subst (with (list (binding 'x (num 7))) (binop '+ (id 'y) (id 'x))) 'y (num 5))
      (with (list (binding 'x (num 7))) (binop '+ (num 5) (id 'x))))
(test (subst (with (list (binding 'x (num 7))) (binop '+ (id 'y) (id 'x))) 'x (num 5))
      (with (list (binding 'x (num 7))) (binop '+ (id 'y) (id 'x))))
(test (subst (with (list (binding 'x (id 'y))) (binop '+ (id 'x) (num 5))) 'y (num 7))
      (with (list (binding 'x (num 7))) (binop '+ (id 'x) (num 5))))
(test (subst (with (list (binding 'x (num 7)) (binding 'y (num 9))) (binop '+ (id 'x) (id 'z))) 'z (num 4))
      (with (list (binding 'x (num 7)) (binding 'y (num 9))) (binop '+ (id 'x) (num 4))))
(test (subst (with (list (binding 'x (num 7)) (binding 'y (num 9))) (binop '+ (id 'x) (id 'y))) 'y (num 4))
      (with (list (binding 'x (num 7)) (binding 'y (num 9))) (binop '+ (id 'x) (id 'y))))
(test (subst (with (list (binding 'x (num 7)) (binding 'y (num 9))) (binop '+ (id 'x) (id 'z))) 'y (num 4))
      (with (list (binding 'x (num 7)) (binding 'y (num 9))) (binop '+ (id 'x) (id 'z))))



;; interp : WAE -> number
;; Consumes a WAE representation of an expression and computes
;;   the corresponding numerical result
(define (interp expr)
  (define (subst-bindings binding-list bound-body binded)
    (if (empty? binding-list)
        bound-body
        (if (memq (binding-name (first binding-list))  binded) ;usei a funcao memq, pois é trivial achar um elemento numa lista
            (error "duplicated binding")
            (subst-bindings (rest binding-list) 
                            (subst bound-body (binding-name (first binding-list)) 
                                   (binding-named-expr (first binding-list)))
                            (cons (binding-name (first binding-list)) binded))))) 
  
  (type-case WAE expr
    [num (n) n]
    [binop (op l r)
           (let [(right (interp r))]
           (if (and (symbol=? op '/) (= right 0))
               (error "division by zero")
               ((binop-lookup op) (interp l) right)))]
    [with (binding-list bound-body)
          (interp (subst-bindings binding-list bound-body '()))]
    [id (v) (error 'interp "free identifier")]
    ))


(test (interp (parse '3)) 3) 
(test (interp (parse '{+ 3 4})) 7) 
(test (interp (parse '{+ {- 3 4} 7} )) 6) 
(test (interp (parse '{/ {* 6 2} 3} )) 4) 
(test (interp (parse '{with {{x 7}} {+ x 7}})) 14)
(test (interp (parse '{with {{x {with {{y 5}} {* 2 y}}}} {+ x 1}})) 11)
(test (interp (parse '{with {{x 5}} {with {{y {+ x 2}}} {* 2 y}}})) 14)
(test (interp (parse '{with {{x 8} {y 9}} {+ x y}})) 17)
(test (interp (parse '{with {{x 8} {y 9}} {+ x y}})) 17)
(test (interp (parse '{with {{x {+ 5 5}}} {with {{y {- x 3}}} {+ y y}}})) 14)
(test (interp (parse '{with {{x 4} {y 2}} {with {{z {/ x y}}} {+ x z}}})) 6)

;interpreter exceptions
(test/exn (interp (parse '{with {{x 2}} y})) "free identifier")
(test/exn (interp (parse '{with {{x {+ 2 x}}} {+ x 7}})) "free identifier")
(test/exn (interp (parse '{with {{x {+ 2 x}}} {+ x 7}})) "free identifier")
(test/exn (interp (parse '{with {{x {+ 2 x}}} {+ x 7}})) "free identifier")
(test/exn (interp (parse '{/ 2 {- 1 1}})) "division by zero")
(test/exn (interp (parse '{with {{x 2} {x 3}}{+ x 2}})) "duplicated binding")
(test/exn (interp (parse '{with {{x 2} {y 3} {z 6} {x 7}} {+ x 2}})) "duplicated binding")