#lang plai-typed (define-type ExprC [numC (n : number)] [plusC (lhs : ExprC) (rhs : ExprC)] [multC (lhs : ExprC) (rhs : ExprC)] [argC] [thisC] [objectC (field-names : (listof symbol)) (field-exprs : (listof ExprC)) (methods : (listof Method))] [getC (obj-expr : ExprC) (field-name : symbol)] [sendC (obj-expr : ExprC) (method-name : symbol) (arg-expr : ExprC)]) (define-type Method [method (name : symbol) (body-expr : ExprC)]) (define-type Value [numV (n : number)] [objV (field-names : (listof symbol)) (field-values : (listof Value)) (methods : (listof Method))]) (module+ test (print-only-errors true)) ;; ---------------------------------------- (define (make-find [name-of : ('a -> symbol)]) (lambda ([name : symbol] [vals : (listof 'a)]) : (optionof 'a) (cond [(empty? vals) (none)] [else (if (equal? name (name-of (first vals))) (some (first vals)) ((make-find name-of) name (rest vals)))]))) (define find-method : (symbol (listof Method) -> Method) (local [(define find (make-find method-name))] (lambda (sym methods) (type-case (optionof Method) (find sym methods) [none () (error 'find-method "Method not found")] [some (s) s])))) ;; A non-list pair: (define-type (Pair 'a 'b) [kons (first : 'a) (rest : 'b)]) (define (get-field [name : symbol] [field-names : (listof symbol)] [vals : (listof Value)]) ;; Pair fields and values, find by field name, ;; then extract value from pair (type-case (optionof 'a) ((make-find kons-first) name (map2 kons field-names vals)) [none () (none)] [some (s) (some (kons-rest s))])) (module+ test (test/exn (find-method 'a empty) "not found") (test (find-method 'a (list (method 'a (numC 0)))) (method 'a (numC 0))) (test (find-method 'b (list (method 'a (numC 0)) (method 'b (numC 1)))) (method 'b (numC 1))) ;(test (get-field 'a ; (list 'a 'b) ; (list (numV 0) (numV 1))) ; (numV 0)) ) ;; ---------------------------------------- (define interp : (ExprC Value Value -> Value) (lambda (a this-val arg-val) (type-case ExprC a [numC (n) (numV n)] [plusC (l r) (num+ (interp l this-val arg-val) (interp r this-val arg-val))] [multC (l r) (num* (interp l this-val arg-val) (interp r this-val arg-val))] [thisC () this-val] [argC () arg-val] [objectC (field-names field-exprs methods) (objV field-names (map (lambda (a) (interp a this-val arg-val)) field-exprs) methods)] [getC (obj-expr field-name) (local [(define obj (interp obj-expr this-val arg-val))] (type-case Value obj [objV (field-names field-vals methods) (type-case (optionof 'a) (get-field field-name field-names field-vals) [none () (call-method field-name methods obj (numV 0))] [some (s) s])] [else (error 'interp "not an object")]))] [sendC (obj-expr method-name arg-expr) (local [(define obj (interp obj-expr this-val arg-val)) (define next-arg-val (interp arg-expr this-val arg-val))] (type-case Value obj [objV (field-names field-vals methods) (call-method method-name methods obj next-arg-val)] [else (error 'interp "not an object")]))]))) (define (call-method (method-name : symbol) (methods : (listof Method)) (obj : Value) (next-arg-val : Value)) : Value (type-case Method (find-method method-name methods) [method (name body-expr) (interp body-expr obj next-arg-val)])) (define (num-op [op : (number number -> number)] [op-name : symbol] [x : Value] [y : Value]) : Value (cond [(and (numV? x) (numV? y)) (numV (op (numV-n x) (numV-n y)))] [else (error 'interp "not a number")])) (define (num+ x y) (num-op + '+ x y)) (define (num* x y) (num-op * '* x y)) ;; ---------------------------------------- ;; Examples (module+ test (define posn27 (objectC (list 'x 'y) (list (numC 2) (numC 7)) (list (method 'mdist (plusC (getC (thisC) 'x) (getC (thisC) 'y))) (method 'addX (plusC (getC (thisC) 'x) (argC))) (method 'multY (multC (argC) (getC (thisC) 'y)))))) (define posn531 (objectC (list 'x 'y 'z) (list (numC 5) (numC 3) (numC 1)) (list (method 'mdist (plusC (getC (thisC) 'z) (plusC (getC (thisC) 'x) (getC (thisC) 'y)))))))) ;; ---------------------------------------- (module+ test (test (interp (numC 10) (numV -1) (numV -1)) (numV 10)) (test (interp (plusC (numC 10) (numC 17)) (numV -1) (numV -1)) (numV 27)) (test (interp (multC (numC 10) (numC 7)) (numV -1) (numV -1)) (numV 70)) (test (interp (objectC (list 'a 'b) (list (numC 1) (numC 2)) (list (method 'm (numC 0)))) (numV -1) (numV -1)) (objV (list 'a 'b) (list (numV 1) (numV 2)) (list (method 'm (numC 0))))) (test (interp (sendC posn27 'mdist (numC 0)) (numV -1) (numV -1)) (numV 9)) (test (interp (sendC posn27 'addX (numC 10)) (numV -1) (numV -1)) (numV 12)) (test/exn (interp (plusC (numC 1) (objectC empty empty empty)) (numV -1) (numV -1)) "not a number") (test/exn (interp (getC (numC 1) 'x) (numV -1) (numV -1)) "not an object") (test/exn (interp (sendC (numC 1) 'mdist (numC 0)) (numV -1) (numV -1)) "not an object")) (test (interp (getC (objectC empty empty (list (method 'x (numC 0)))) 'x ) (numV -1) (numV -1)) (numV 0))