CS217 Day 25 Wednesday, May 24, 2000, 2000

A Simple Typed OOL

• New features
  • Fields and methods are specified with their types
  • Concept of abstract class and methods

    A method is abstract if it is declared abstract and has no body.

    A class is abstract if it declared abstract or one of its abstract methods has not been defined.

  • Concept of casting, and an instance-of test
  • Concept of subtype polymorphism
  • void type, as type of a set.

• Grammar for the complete language

  (define the-grammar
    '((program ((arbno class-decl) expression) a-program)
  
      (expression (number) lit-exp)
      (expression ("true") true-exp)	
      (expression ("false") false-exp)	
      (expression (identifier) var-exp)   
      (expression
        (primitive "(" (separated-list expression ",") ")")
        primapp-exp)
      (expression
        ("if" expression "then" expression "else" expression)
        if-exp)
  
      (expression
        ("let" (arbno identifier "=" expression) "in" expression)
        let-exp)
  
      (expression				
        ("proc" "(" (separated-list type-exp identifier ",") ")" expression)
        proc-exp)
      (expression
        ("(" expression (arbno expression) ")")
        app-exp)
  
      (expression
        ("letrec"
          (arbno type-exp identifier
            "(" (separated-list type-exp identifier ",") ")" 
            "=" expression)
          "in" expression)
        letrec-exp)
  
      (expression ("set" identifier "=" expression) varassign-exp)
      (expression
        ("begin" expression (arbno ";" expression) "end")
        begin-exp)
  
      (expression
        ("list" "(" expression (arbno "," expression) ")")
        list-exp)
      (expression
        ("cons" "(" expression "," expression ")")
        cons-exp)
      (expression
        ("car" "(" expression ")" )
        car-exp)
      (expression
        ("cdr" "(" expression ")" )
        cdr-exp)
      (expression 
        ("nil" "[" type-exp "]")
        nil-exp)
      (expression
        ("null?" "(" expression ")" )
        null?-exp)
  
      (primitive ("+")     add-prim)
      (primitive ("-")     subtract-prim)
      (primitive ("*")     mult-prim)
      (primitive ("add1")  incr-prim)
      (primitive ("sub1")  decr-prim)
      (primitive ("zero?") zero-test-prim)
  
      (class-decl
        (abstraction-specifier		; new for ch8
          ;; do we really need/want abstract classes?
         "class" identifier
         "extends" identifier
           
           (arbno "field" type-exp identifier)
           (arbno method-decl)
           )
        a-class-decl)
  
      (abstraction-specifier		; new for ch 8
        ()
        concrete-specifier)
  
      (abstraction-specifier
        ("abstract")
        abstract-specifier)
  
      (field-decl                         
        ("field" type-exp identifier)
        a-field-decl)
  
      (method-decl			
        ("method"
          type-exp	
  	identifier 
          "("  (separated-list type-exp identifier ",") ")" ; method ids
           expression  )
        a-method-decl)
  
      (method-decl			; ch 8
        ("abstractmethod" type-exp identifier 
          "("  (separated-list type-exp identifier ",") ")" ; method ids
          )                               ; no body
        abstract-method-decl)
  
      (expression 
        ("new" identifier "(" (separated-list expression ",") ")")
        new-object-exp)
      (expression
        ("send" expression identifier
          "("  (separated-list expression ",") ")")
        method-app-exp)
      (expression
        ("super" identifier
          "("  (separated-list expression ",") ")")
        super-call-exp)
  
      ;; these do not appear in ordinary programs
      (expression
        ("apply-method-indexed" expression number
  	  "("  (separated-list expression ",") ")")
        apply-method-indexed-exp)
  
      (expression
        ("lexvar" number number)
        lexvar-exp)
  
      (expression
       ("cast" expression identifier)
       cast-exp)
  
      (expression
        ("instanceof" expression identifier)
        instanceof-exp)
  
      (type-exp ("int") int-type-exp)             ; 6-1
      (type-exp ("bool") bool-type-exp)           ; 6-1
      (type-exp ("void") void-type-exp)	; oo-5
      (type-exp (identifier) class-type-exp) ; oo-5
      (type-exp                               ; 6-1
        ("(" (separated-list type-exp "*") "->" type-exp ")")
        proc-type-exp)
      (type-exp
        ("list" type-exp)
        list-type-exp)
  
      ))
  

• Type Checker for STDOOL

  No program that passes type checker will try to

  • send a message to an object for which there is no corresponding method,
  • send a message with wrong number of types of args,
  • create an instance of an abstract class,
  • create an instance of a concrete class with an unimplemented abstract method.

• Example programs in the new language.
  • sum-leaves -- What is the type error?

    class tree extends object 
      method int initialize() 1
      
    class interior_node extends tree 
      field node left
      field node right
      method void initialize(node l, node r)
       begin
        set left = l; set right = r
       end
      method int sum () +(send left sum(), send right sum())
      
    class leaf_node extends tree 
      field int value
      method void initialize(int v) set value = v
      method int sum() value
      
    let o1 = new interior_node (
              new interior_node (
                new leaf_node(3),
                new leaf_node(4)),
              new leaf_node(5))
    in send o1 sum()
    

  • sum-leaves-2 -- with abstract class tree. Type error?

    abstract class tree extends object 
      method int initialize() 1
      
    class interior_node extends tree 
      field tree left
      field tree right
      method void initialize(tree l, tree r)
       begin
        set left = l; set right = r
       end
      method int sum() +(send left sum(), send right sum())
      
    class leaf_node extends tree 
      field int value
      method void initialize(int v)set value = v
      method int sum() value
      
    let o1 = new interior_node (
              new interior_node (
                new leaf_node(3),
                new leaf_node(4)),
              new leaf_node(5))
    in send o1 sum()
    

  • sum-leaves-with-abstract-method

    abstract class tree extends object 
      method int  initialize()1
      abstractmethod int sum()
      
    class interior_node extends tree 
      field tree left
      field tree right
      method void initialize(tree l, tree r)
       begin
        set left = l; set right = r
       end
      method int sum() +(send left sum(), send right sum())
      
    class leaf_node extends tree 
      field int value
      method void initialize(int v)set value = v
      method int sum() value
      
    let o1 = new interior_node (
              new interior_node (
                new leaf_node(3),   %% need subtyping to make this ok.
                new leaf_node(4)),
              new leaf_node(5))
    in send o1 sum()
    

  • equal-trees-1

    abstract class tree extends object 
      method int  initialize() 1
      abstractmethod int sum()
      abstractmethod bool equal(tree t)
      
    class interior_node extends tree 
      field tree left
      field tree right
      method void initialize(tree l, tree r)
       begin
        set left = l; set right = r
       end
      method tree getleft() left
      method tree getright() right
      method int sum() +(send left sum(), send right sum())
      method bool equal(tree t) 
        if instanceof t interior_node
         then if send left equal(send cast t interior_node getleft())
              then send right equal(send cast t interior_node getright())
              else false
         else false 
         
      
    class leaf_node extends tree 
      field int value
      method void initialize(int v)set value = v
      method int sum() value
      method int getvalue() value
      method bool equal(tree t) 
       if instanceof t leaf_node
        then zero?(-(value, send cast t leaf_node getvalue()))
        else false
        
      
    let o1 = new interior_node (
              new interior_node (
                new leaf_node(3),   
                new leaf_node(4)),
              new leaf_node(5))
    in send o1 equal(o1)
    

  • equal-trees-by-double-dispatch

    abstract class tree extends object 
      method int  initialize() 1
      abstractmethod int sum()
      abstractmethod bool equal(tree t)
      abstractmethod bool equal_int(tree l, tree r)
      abstractmethod bool equal_leaf(int val)
      
    class interior_node extends tree 
      field tree left
      field tree right
      method void initialize(tree l, tree r)
       begin
        set left = l; set right = r
       end
      method int sum() +(send left sum(), send right sum())
      method bool equal(tree t) send t equal_int(left, right)
      method bool equal_int(tree l, tree r) 
         if send left equal(l)
         then send right equal(r)
         else false
         
      method bool equal_leaf(int v) false
      
    class leaf_node extends tree 
      field int value
      method void initialize(int v)set value = v
      method int sum() value
      method bool equal(tree t) send t equal_leaf(value)
      method bool equal_int(tree l, tree r) false
      method bool equal_leaf(int otherval) zero?(-(value, otherval))
      
    let o1 = new interior_node (
              new interior_node (
                new leaf_node(3),   
                new leaf_node(4)),
              new leaf_node(5))
    in send o1 equal(o1)
    

  • goldberg-80

    class c1 extends object 
      method int initialize () 1
      method int test () 1
      method int result1 () send self test ()
      
    class c2 extends c1 
      method int test () 2
      
    class c3 extends c2 
      method int result2 () send self result1 ()
      method int result3 () super test ()
      
    class c4 extends c3 
      method int test () 4
      
    let o3 = new c3 ()
        o4 = new c4 ()
    in list(send o3 test(),
            send o4 result1 (),
            send o3 result2 (),   
            send o4 result2 (),
            send o3 result3 (),
            send o4 result3 ())
    

• The Interpreter (Complete code is in 8-interp.scm.)

  ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
  
  (define eval-program 
    (lambda (pgm)
      (cases program pgm
        (a-program (class-decls body)
          (elaborate-class-decls! class-decls) ; new for ch6
          (eval-expression body (init-env))))))
  
  (define eval-expression
    (lambda (exp env)
      (cases expression exp
        (lit-exp (datum) datum)
        (var-exp (id) (apply-env env id))
        (lexvar-exp (depth pos) (apply-env-lexvar env depth pos))
        (true-exp () 1)
        (false-exp () 0)
        (primapp-exp (prim rands)
          (let ((args (eval-rands rands env)))
            (apply-primitive prim args)))
        (if-exp (test-exp true-exp false-exp)
          (if (true-value? (eval-expression test-exp env))
            (eval-expression true-exp env)
            (eval-expression false-exp env)))
        (let-exp (ids rands body)
  	(let ((args (eval-rands rands env)))
            (eval-expression body (extend-env ids args env))))
        (proc-exp (type-exps ids body)
          (closure ids body env))
        (app-exp (rator rands)
          (let ((proc (eval-expression rator env))
                (args (eval-rands      rands env)))
            (if (procval? proc)
              (apply-procval proc args)
              (eopl:error 'eval-expression 
                "attempt to apply non-procedure ~s"
                proc))))
        (letrec-exp (result-texps proc-names type-expss idss bodies
                      letrec-body)
          (eval-expression letrec-body
            (extend-env-recursively proc-names idss bodies env)))
        (varassign-exp (id rhs-exp)
          (begin
            (setref! 
              (apply-env-ref env id)
              (eval-expression rhs-exp env))
            1))
  
        (begin-exp (exp1 exps)
          (let loop ((acc (eval-expression exp1 env))
                     (exps exps))
            (if (null? exps) acc
              (loop (eval-expression (car exps) env) (cdr exps)))))
  
  
        ;; lists 
        (list-exp (exp exps) 
  	(let ((the-car (eval-expression exp env))
  	      (the-cdr (eval-expressions exps env)))
  	  (cons the-car the-cdr)))
        (cons-exp (car-exp cdr-exp) 
  	(cons
  	  (eval-expression car-exp env)
  	  (eval-expression cdr-exp env)))
        (car-exp (exp) 
  	(car (eval-expression exp env)))
        (cdr-exp (exp) 
  	(cdr (eval-expression exp env)))
        (nil-exp (type-exp) '())
        (null?-exp (exp)
  	(if (null? (eval-expression exp env))
            1 0))
  
  ;;;;;;;;;;;;;;;; new cases for chap 6 ;;;;;;;;;;;;;;;;
  
        (new-object-exp (class-name rands)
          (let ((args (eval-rands rands env))
                (obj (new-object class-name)))
            (find-method-and-apply 'initialize class-name obj args)
            obj))
  
        (method-app-exp (obj-exp method-name rands)
          (let ((args (eval-rands rands env))
                (obj (eval-expression obj-exp env)))
            (find-method-and-apply
              method-name (object->class-name obj) obj args)))
  
        (super-call-exp (method-name rands)
          (let ((args (eval-rands rands env))
                (obj (apply-env env 'self)))
            (find-method-and-apply method-name
  	    (apply-env env '%super) obj args)))
  
  ;;;;;;;;;;;;;;;; new cases for chapter 8 ;;;;;;;;;;;;;;;;
  
        ;; oo-6: get method at position pos. pos is a number, not an
        ;; expression. 
        (apply-method-indexed-exp (obj-exp pos rands)
  	(let ((obj (eval-expression obj-exp env))
                (args (eval-expressions rands env)))
            (let ((class-name (object->class-name obj)))
              (apply-method
                (list-ref
                  (class->methods (lookup-class class-name))
                  pos)
                class-name
                obj
                (eval-expressions rands env)))))
  
        (cast-exp (exp name)
          (let ((obj (eval-expression exp env)))
            (if (is-subclass? (object->class-name obj) name)
              obj
              (eopl:error 'eval-expression
                "can't cast object to type ~s:~%~s"))))
  
        (instanceof-exp (exp name)
          (let ((obj (eval-expression exp env)))
            (if (is-subclass? (object->class-name obj) name)
              the-true-value
              the-false-value)))
  
        (else
          (eopl:error 'eval-expression
            "~%Illegal expression~%~s"
            exp))
  
        )))
  
  (define eval-rands
    (lambda (exps env)
      (map
        (lambda (exp) (eval-expression exp env))
        exps)))
  
  (define eval-expressions
    (lambda (exps env)
      (map
        (lambda (exp) (eval-expression exp env))
        exps)))
  
  (define apply-primitive
    (lambda (prim args)
      (cases primitive prim
        (add-prim  () (+ (car args) (cadr args)))
        (subtract-prim () (- (car args) (cadr args)))
        (mult-prim  () (* (car args) (cadr args)))
        (incr-prim  () (+ (car args) 1))
        (decr-prim  () (- (car args) 1))
        (zero-test-prim () (if (zero? (car args)) 1 0))
        )))
  
  (define init-env 
    (lambda ()
      (extend-env
        '(i v x)
        '(1 5 10)
        (empty-env))))
  

• The class datatype and *class-env* for goldberg-80

  Class datatype:

  (define-datatype class class?
    (a-class
      (class-name symbol?)  
      (super-name symbol?) 
      (field-length integer?)  
      (field-ids (list-of symbol?))
      (methods method-environment?)))
  

  *class-env* for goldberg-80 -- a list of the class-decls:

  ((a-class
     c4
     c3
     0
     ()
     ((a-method
        (a-method-decl (int-type-exp) initialize () () (lit-exp 1))
        object
        ())
      (a-method
        (a-method-decl (int-type-exp) test () () (lit-exp 4))
        c3
        ())
      (a-method
        (a-method-decl
          (int-type-exp)
          result1
          ()
          ()
          (method-app-exp (var-exp self) test ()))
        object
        ())
      (a-method
        (a-method-decl
          (int-type-exp)
          result2
          ()
          ()
          (method-app-exp (var-exp self) result1 ()))
        c2
        ())
      (a-method
        (a-method-decl
          (int-type-exp)
          result3
          ()
          ()
          (super-call-exp test ()))
        c2
        ())))
   (a-class
     c3
     c2
     0
     ()
     ((a-method
        (a-method-decl (int-type-exp) initialize () () (lit-exp 1))
        object
        ())
      (a-method
        (a-method-decl (int-type-exp) test () () (lit-exp 2))
        c1
        ())
      (a-method
        (a-method-decl
          (int-type-exp)
          result1
          ()
          ()
          (method-app-exp (var-exp self) test ()))
        object
        ())
      (a-method
        (a-method-decl
          (int-type-exp)
          result2
          ()
          ()
          (method-app-exp (var-exp self) result1 ()))
        c2
        ())
      (a-method
        (a-method-decl
          (int-type-exp)
          result3
          ()
          ()
          (super-call-exp test ()))
        c2
        ())))
   (a-class
     c2
     c1
     0
     ()
     ((a-method
        (a-method-decl (int-type-exp) initialize () () (lit-exp 1))
        object
        ())
      (a-method
        (a-method-decl (int-type-exp) test () () (lit-exp 2))
        c1
        ())
      (a-method
        (a-method-decl
          (int-type-exp)
          result1
          ()
          ()
          (method-app-exp (var-exp self) test ()))
        object
        ())))
   (a-class
     c1
     object
     0
     ()
     ((a-method
        (a-method-decl (int-type-exp) initialize () () (lit-exp 1))
        object
        ())
      (a-method
        (a-method-decl (int-type-exp) test () () (lit-exp 1))
        object
        ())
      (a-method
        (a-method-decl
          (int-type-exp)
          result1
          ()
          ()
          (method-app-exp (var-exp self) test ()))
        object
        ()))))
  

• Chapter 8 files from Mitch Wand

  First load dj.scm, sllgen.scm, and r5rs.scm.
  Loading 8-top.scm loads the other files.

  • 8-top.scm
  • 8-grammar.scm
  • 8-interp.scm
  • 8-checker.scm
  • 8-compiler.scm
  • 8-tests.scm

  (check-all) -- runs type-check on all tests.
  (interpret-all) -- runs run on all tests that have correct answers.
  

• Individual tests can be run/checked using find.scm