Eopl3: chapter 9.4 solution to exercise 9.13

Adding final methods (which cannot be overridden).
--------------------------------------------
> lang.scm_____________________________________________________________

        (method-decl
            ("final" "method" identifier
                  "("  (separated-list identifier ",") ")" ; method formals
              expression)
        a-method-decl-final)

;; So we created a new type of method-decl, called a-method-decl-final

> classes.scm___________________________________________________________

;; First we add a new field for the a-method data structure

  (define-datatype method method?
    (a-method
      (vars (list-of symbol?))
      (body expression?)
      (super-name symbol?)
      (field-names (list-of symbol?))
      (isFinal boolean?)
    ))

;; We check for method-decl in 2 cases (regular one + the one added above).
;; In the first case, in case the super-class is not object, we check if the method already existed
;; If yes, we check its status: final or not. If final, don't override, else override;
;; when we override, we set the final field to #f
;; In the 2nd case, same steps basically, but when we override, we set the final field to #t (final)

  (define method-decls->method-env
    (lambda (m-decls super-name field-names)
      (map
        (lambda (m-decl)
          (cases method-decl m-decl
            (a-method-decl (method-name vars body)        ;; create a non-final method
                (if (eq? super-name 'object) (list method-name (a-method vars body super-name field-names #f))
                ;; else check if it didnt exist before in the super class, as a final
                (let ((possibleMethod (find-method super-name method-name)))
                    (if (eq? possibleMethod #f)
                        (list method-name (a-method vars body super-name field-names #f))    ;;  not found before, create the method
                        ;; found before so check if it's final
                        (cases method possibleMethod (a-method (vars body super fnames isFinal)   
                            (if (eq? isFinal #t)
                                (list 'xxx (a-method vars body super-name field-names #f))    ;; make a dummy, don't overwrite
                                (list method-name (a-method vars body super-name field-names #f))    ;; else overwrite
                            )))
                ))))
            (a-method-decl-final (method-name vars body)                ;; final method
                (if (eq? super-name 'object) (list method-name (a-method vars body super-name field-names #t))
                ;; else check if it didnt exist before in the super class, as a final
                (let ((possibleMethod (find-method super-name method-name)))
                    (if (eq? possibleMethod #f)
                        (list method-name (a-method vars body super-name field-names #t))    ;;  not found before, create the method
                        ;; found before so check if it's final
                        (cases method possibleMethod (a-method (vars body super fnames isFinal)   
                            (if (eq? isFinal #t)
                                (list 'xxx (a-method vars body super-name field-names #t))    ;; make a dummy, don't overwrite
                                (list method-name (a-method vars body super-name field-names #t))    ;; else overwrite
                            )))
                )))
        )))
        m-decls)))

;; a small change in find-method

  (define find-method
    (lambda (c-name name)
      (let ((m-env (class->method-env (lookup-class c-name))))
        (let ((maybe-pair (assq name m-env)))
          (if (pair? maybe-pair) (cadr maybe-pair)
            (begin
                (report-method-not-found name) #f)    ;; ex. 9.13
    )))))


> interp.scm____________________________________________________________

;; a small change to accommodate the new field isFinal

  (define apply-method                   
    (lambda (m self args)
      (cases method m
        (a-method (vars body super-name field-names isFinal) ;; ex 9.13
          (value-of body
            (extend-env vars (map newref args)
              (extend-env-with-self-and-super
                self super-name
                (extend-env field-names (object->fields self)
                  (empty-env)))))))))


__________           _     Test... exemplu_____                ________________

class c1 extends object
    field x
    field y
    method initialize ()
        begin
         set x = 11;
         set y = 12
        end
    final method m1 (a)
        -(x,a)

class c2 extends c1
    method initialize ()
        begin
         super initialize()
        end
    method m1 (a)
        -(a,1)

let o2 = new c2() in send o2 m1(55)        % m1 cannot be overwritten, should write -44