#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)]) : 'a (cond [(empty? vals) (error 'find "not found")] [else (if (equal? name (name-of (first vals))) (first vals) ((make-find name-of) name (rest vals)))]))) (define find-method : (symbol (listof Method) -> Method) (make-find method-name)) ;; 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 (kons-rest ((make-find kons-first) name (map2 kons field-names vals)))) (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) (type-case Value (interp obj-expr this-val arg-val) [objV (field-names field-vals methods) (get-field field-name field-names field-vals)] [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) (type-case Method (find-method method-name methods) [method (name body-expr) (interp body-expr obj next-arg-val)])] [else (error 'interp "not an object")]))]))) (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"))