;;*****************************************************************
;;  Solutin for hw 7. Inheritance
;;
;;  Suggested by Jayu Wu.
;;

;;; ****************************************************************
;;; Imperative language with classes
;;; In this program, the original interpreter is modified, the 
;;; language with inheritance is implementted by using the following
;;; syntax:
;;;
;;;<class-decl> ::= derive class<identifier> from <identifier> <method-decl>*
;;;
;;; Terminology; when writing derive class B from A ..., then A is said
;;; to be the superclass of B, and B is said to be a subclass of A. In
;;; C++ terminalogy, A is the base class, and B is the derived class.
;;; The derive class is like its base class, except that the methods declared 
;;; in the derived class may override those declared in the base class. 
;;; The added features will be indicated by "MODIFIED".
;;; added functions and routines are also highlighted in between the two
;;; horizontal lines.
;;; ****************************************************************

;;; ****************************************************************
;;; ****************************************************************

;;; Lexical and syntactic specification

(define lexical-specification
  '((class method init var proc if while then else new print read perform
          returning derive from)   ;;; MODIFIED, two more key worlds 
    (start-state		   ;;; MODIFIED, derive, from are added
      (whitespace #f)
      (#\+ plus-sym)
      (#\- minus-sym)
      (#\/ div-sym)
      (#\* mult-sym)
      (#\< lt-state)
      (#\> gt-state)
      (#\= equal-sym)
      (#\! #\= unequal-sym)
      ((alphabetic)
        (arbno (alphabetic #\_ numeric))
        identifier)
      (numeric (arbno numeric) number)
      (#\%  comment-state)
      (#\,  comma)
      (#\;  semicolon)
      (#\(  lparen)
      (#\)  rparen)
      (#\{  lbrace)
      (#\}  rbrace)
      (#\^  end-marker))
    (lt-state
      (#\- message-send-sym)            ; this is a <- .
      (#\= le-sym)
      (else lt-sym))                    ; emit the < and reprocess
                                        ; next char.
    (gt-state
      (#\= ge-sym)
      (else gt-sym))
    (comment-state 
      (#\newline #f)
      (any comment-state))))

(define syntactic-specification
  '((pgm 
      ((arbno class-decl optional-semicolon)

       ;;;MODIFIED, added derived class decalation
       (arbno der-class-decl optional-semicolon) block)
      pgm)                              ; only one production for most
                                        ; of these guys -- all the
                                        ; choices are in the ARBNO's.
    (class-decl
      (class identifier lparen identifier-list rparen
        var-decl
        (arbno method-decl optional-semicolon) 
        init                            ; a keyword before the initialization
        block)
      class-decl)
    (der-class-decl			;;; MODIFIED, added der-class-decl
      (derive class identifier from identifier
        (arbno method-decl)) 
    der-class-decl)
    (method-decl
      (method identifier lparen identifier-list rparen expression)
       method-decl)
    (block
      (var-decl
       (arbno proc-decl)
       compound-statement)
      block)
    (var-decl
      (var identifier-list)
      non-empty-var-decl)
    (var-decl
      ()
      empty-var-decl)
    (proc-decl
      (proc identifier lparen identifier-list rparen block)
      proc-decl)
    (compound-statement
      (lbrace (arbno statement optional-semicolon) rbrace)
      compound-statement)
    (statement
      (if expression compound-statement if-tail)
      if-statement)
    (statement
      (while expression compound-statement)
      while-statement)
    (statement
      (print expression)
      print-statement)
    (statement
      (read identifier)
      read-statement)
    (statement
      (identifier primitive-tail)
      primitive-statement)
    (if-tail
      ()
      empty-if-tail)
    (if-tail
      (compound-statement)
      non-empty-if-tail)
    (primitive-tail
      (equal-sym expression)
      assignment-statement)
    (primitive-tail
      (new identifier operand-list)
      new-statement)
    (primitive-tail
      (operand-list)
      proc-call-statement)
    (expression
      (perform block returning expression)
      perform-expression)
    (expression
      (if expression then expression else expression)
      if-expression)
    (expression
      (sum (arbno relational-op sum))
      expression)
    (sum
      (term (arbno additive-op term))
      sum)
    (term 
      (factor (arbno mult-op factor))
      product)
    (factor
      (number)
      const-factor)
    (factor
      (lparen expression rparen)
      paren-exp)
    (factor
      (identifier identifier-tail)
      identifier-exp)
    (identifier-tail
      ()
      empty-identifier-tail)
    (identifier-tail
      (message-send-sym identifier operand-list)
      method-call)
    (additive-op (plus-sym) plus-op)
    (additive-op (minus-sym) minus-op)
    (mult-op (mult-sym) times-op)
    (mult-op (div-sym) div-op)
    (relational-op (equal-sym) equal-op)
    (relational-op (unequal-sym) unequal-op)
    (relational-op (lt-sym) lt-op)
    (relational-op (gt-sym) gt-op)
    (relational-op (le-sym) le-op)
    (relational-op (ge-sym) ge-op)
    (identifier-list
      ((arbno identifier optional-comma))
      identifier-list)
    (operand-list
      (lparen (arbno expression optional-comma) rparen)
      operand-list)
    (optional-comma
      (comma)
      comma)
    (optional-comma
      ()
      no-comma)
    (optional-semicolon
      (semicolon)
      semicolon)
    (optional-semicolon
      ()
      no-semicolon)
    ))

(define scan&parse 
  (sllgen:string->tree lexical-specification
    syntactic-specification))


(define gen-parse
  (lambda ()
    (set! scan&parse
      (sllgen:string->tree lexical-specification
        syntactic-specification))))

(define run
  (lambda (string)
    (eval-pgm (scan&parse string))))

;;; ****************************************************************
;;; ****************************************************************

;;; The interpreter -- follow the grammar!!

;;; ****************************************************************

;   (pgm 
;       ((arbno class-decl optional-semicolon)
;        (arbno der-class-decl optional-semicolon) block)
;       pgm)                              

(define eval-pgm
  (lambda (pgm)                         ; no initial environment
    (record-case pgm
      (pgm (class-decl* der-class-decl* block)
           (let ((env (empty-env))
                 (class-env (eval-class-decl* class-decl*)))

 	;;;MODIFIED, added eval-der-class-decl* der-class-decl* routine
        ;;;MODIFIED, and the class environment is extented by the derived
        ;;;MODIFIED, classes
                 (let ((new-env (eval-der-class-decl* der-class-decl*	
       				class-env)))
			(let ((class-env (append new-env class-env)))
                    (eval-block block env class-env)))))
      (else (error 'eval-pgm "unknown pgm ~s" pgm)))))

;;; ****************************************************************

;     (class-decl
;       (class identifier lparen identifier-list rparen
;         var-decl
;         (arbno method-decl optional-semicolon) 
;         init                            ; a keyword before the initialization
;         block)
;       class-decl)

;;; record for putting in class-env:
(define-record class-decl
  (name init-formals instance-var-decl methods initializer))

;;; ---------------------------------------------------------------------------
;;; MODIFIED, added der-class-decl record for putting in class-env
(define-record der-class-decl 
    (der-name parentname methods))
;;; ---------------------------------------------------------------------------

; the record produced by sllgen and the record used by the evaluator
; will differ only in whether methods is a list of method-decl's or an
; alternating list.  All we do now is stip out the optional semicolons.
; this is what's produced by sllgen.  We'll want to use the
; extractors, so we throw in a define-record:

(define-record method-decl (name formals body)) 

(define strip-optionals
  (lambda (alt-list)
    (if (null? alt-list) '()
      (cons (car alt-list)
            (strip-optionals (cddr alt-list))))))

(define eval-class-decl*
  (lambda (class-decl*)
    ;; class-decl* is an alternating list
    (map eval-class-decl (strip-optionals class-decl*))))

;; just return the class declaration-- don't need to do much with
;; it now.  Just strip out the optional semicolons in the method decls.

;;; ---------------------------------------------------------------------------
;;; MODIFIED, added define eval-der-class-decl*

(define eval-der-class-decl*
  (lambda (der-class-decl* class-env)
    (eval-der-class-decl (strip-optionals der-class-decl*) class-env)))
;;; ---------------------------------------------------------------------------

;;; ---------------------------------------------------------------------------
;;; MODIFIED, added routine eval-der-class-decl* for extending derived class 
;;; environment 

(define eval-der-class-decl
  (lambda (der-class-decl* class-env)
    (if (null? der-class-decl*)
        '()
         (let ((new-class-env (eval-derive-class-decl (car der-class-decl*)
					class-env)))
              (let ((new-env (cons new-class-env class-env)))
                (if (null? (cdr der-class-decl*))
		   new-env
                   (eval-der-class-decl (cdr der-class-decl*) new-env)))))))
;;; ---------------------------------------------------------------------------


(define eval-class-decl
  (lambda (class-decl)
    (record-case class-decl
      (class-decl (name init-formals instance-var-decl methods initializer)
        (make-class-decl 
          name 
          (eval-identifier-list init-formals)
          instance-var-decl
          (map eval-method-decl (strip-optionals methods))
          initializer))
      (else (raise-error 'eval-class-decl class-decl)))))


;;; ---------------------------------------------------------------------------
;;; MODIFIED, added routine eval-derive-class-decl for appending parent methods
;;; on to the derived class  

(define eval-derive-class-decl
  (lambda (class-decl class-env)
    (record-case class-decl
      (der-class-decl (der-name parentname methods)
        (let ((parentclass (apply-class-env class-env  parentname)))
          (let ((new-inst-v (class-decl->instance-var-decl parentclass))
                (new-init-formals (class-decl->init-formals parentclass))
                (new-methods (append (map eval-method-decl 
		         methods) (class-decl->methods parentclass)))
                (new-init (class-decl->initializer parentclass)))
                  (make-class-decl 
                    der-name 
                    new-init-formals 
                    new-inst-v
                    new-methods
                    new-init))))
      (else (raise-error 'eval-class-decl class-decl)))))
;;; ---------------------------------------------------------------------------


;;; ---------------------------------------------------------------------------
;;; NON-MODIFIED, from here on no modification is made 
;;; ---------------------------------------------------------------------------
;;; ****************************************************************

;     (method-decl
;       (method identifier lparen identifier-list rparen expression)
;       method-decl)

(define eval-method-decl
  (lambda (method-decl)
    (record-case method-decl
      (method-decl (name formals body)
        (make-method-decl
          name
          (eval-identifier-list formals)
          body))
      (else (raise-error 'eval-method-decl method-decl)))))

;;; added copy method-decl

;;; ****************************************************************

;     (block
;       (var-decl (arbno proc-decl) compound-statement)
;       block)

(define eval-block
  (lambda (block env class-env)
    (record-case block
      (block (var-decl proc-decl* compound-statement)
             (let* ((new-vars (eval-var-decl var-decl))
                    (new-env  (extend-env new-vars env))
                    (new-procs (eval-proc-decl* proc-decl*))
                    (new-env-2 (extend-env new-procs new-env)))
               (eval-compound-statement compound-statement
                 new-env-2 class-env)))
      (else (error 'eval-block "~s" block)))))

;;; ****************************************************************

;     (var-decl
;       ()
;       empty-var-decl)
;     (var-decl
;       (var identifier-list)
;       non-empty-var-decl)

(define-record var-rib (names cells))

;;; returns rib for use by extend-env

(define eval-var-decl
  (lambda (var-decl)
    (record-case var-decl
      (empty-var-decl () (make-var-rib '() '()))
      (non-empty-var-decl (identifier-list)
        (let ((names (eval-identifier-list identifier-list)))
          (make-var-rib names (map make-cell names))))
      (else (raise-error 'eval-var-decl var-decl)))))


;;; ****************************************************************

;     (identifier-list
;       ((arbno identifier optional-comma))
;       identifier-list)

(define eval-identifier-list
  (lambda (identifier-list)
    (record-case identifier-list
      (identifier-list (identifier-and-optional-comma-list)
        (strip-optionals identifier-and-optional-comma-list))
      (else (raise-error 'eval-identifier-list identifier-list)))))


;;; ****************************************************************

;     (proc-decl
;       (proc identifier lparen identifier-list rparen block)
;       proc-decl)

(define-record proc-rib (procdefs))
(define-record procdef (name formals body))

(define eval-proc-decl*
  (lambda (proc-decl*)
    (make-proc-rib (map eval-proc-decl proc-decl*))))

(define eval-proc-decl
  (lambda (proc-decl)
    (record-case proc-decl
      (proc-decl (name identifier-list body)
        (make-procdef name (eval-identifier-list identifier-list) body)))))


;;; ****************************************************************

;     (compound-statement
;       (lbrace (arbno statement optional-semicolon) rbrace)
;       compound-statement)

(define eval-compound-statement
  (lambda (compound env class-env)
    (record-case compound
      (compound-statement (statement-and-semicolon-list)
        (letrec
          ((loop (lambda (statement-and-semicolon-list)
                   (if (null? statement-and-semicolon-list)
                     #t                 ; statements work by side-effect
                     (begin
                       (eval-statement
                         (car statement-and-semicolon-list) env class-env)
                       (loop (cddr statement-and-semicolon-list)))))))
          (loop statement-and-semicolon-list)))
      (else (raise-error 'eval-compound-statement compound)))))


;;; ****************************************************************

;     (statement
;       (if expression compound-statement if-tail)
;       if-statement)
;     (statement
;       (while expression compound-statement)
;       while-statement)
;     (statement
;       (print expression)
;       print-statement)
;      (statement
;        (read identifier)
;        read-statement)
;     (statement
;       (identifier primitive-tail)
;       primitive-statement)

(define eval-statement
  (lambda (statement env class-env)
    (record-case statement
      (if-statement
        (expression compound-statement if-tail)
        (if (true-value? (eval-expression expression env class-env))
          (eval-compound-statement compound-statement env class-env)
          (eval-if-tail if-tail env class-env)))
      (while-statement
        (expression compound-statement)
        (letrec
          ((loop (lambda ()
                   (if
                     (true-value? (eval-expression expression env class-env))
                     (begin
                       (eval-compound-statement compound-statement env
                         class-env) 
                       (loop))
                     #t))))
          (loop)))
      (print-statement
        (expression)
        (display (eval-expression expression env class-env))
        (display  " "))
      (read-statement
        (identifier)
        (let ((cell (apply-env env identifier))
              (value (prompt-read "input>")))
          (set-cell! cell value)))
      (primitive-statement
        (identifier primitive-tail)
        (eval-primitive-tail identifier primitive-tail env class-env))
      (else (raise-error 'eval-statement statement)))))

;;; ****************************************************************

;     (if-tail
;       ()
;       empty-if-tail)
;     (if-tail
;       (compound-statement)
;       non-empty-if-tail)

(define eval-if-tail
  (lambda (if-tail env class-env)
    (record-case if-tail
      (empty-if-tail () #t)             ; do nothing
      (non-empty-if-tail (compound-statement)
        (eval-compound-statement compound-statement env class-env))
      (else (raise-error 'eval-if-tail if-tail)))))


;;; ****************************************************************

;     (primitive-tail
;       (= expression)
;       assignment-statement)
;     (primitive-tail
;       (<- identifier operand-list)
;       message-send-statement)
;     (primitive-tail
;       (new identifier operand-list)
;       new-statement)
;     (primitive-tail
;       (operand-list)
;       proc-call-statement)

(define eval-primitive-tail
  (lambda (identifier primitive-tail env class-env)
    (record-case primitive-tail
      (assignment-statement (expression)
        (set-cell! 
          (apply-env env identifier)
          (eval-expression expression env class-env)))
;       (message-send-statement
;         (message operand-list)
;         (let ((object (deref (apply-env env identifier)))
;               (args (eval-operand-list operand-list env class-env)))
;           (send-message object message args class-env)))
      (new-statement
        (class-identifier operand-list)
        (let ((cell (apply-env env identifier))
              (args (eval-operand-list operand-list env class-env)))
          (set-cell!
            cell
            (make-new-object class-identifier args class-env))))
      (proc-call-statement
        (operand-list)
        (apply-proc
          (apply-env env identifier)
          (eval-operand-list operand-list env class-env)
          class-env))
      (else (raise-error 'eval-primitive-tail primitive-tail)))))


;;; ****************************************************************

;     (operand-list
;       (lparen (arbno expression optional-comma) rparen)
;       operand-list)

(define eval-operand-list
  (lambda (operand-list env class-env)
    (record-case operand-list
      (operand-list (list)
        (map (lambda (expression)
               (eval-expression expression env class-env))
             (strip-optionals list)))
      (else (raise-error 'eval-operand-list operand-list)))))


;;; ****************************************************************

;     (expression
;       (sum (arbno relational-op sum))
;       expression)

(define eval-expression
  (lambda (expression env class-env)
    (record-case expression
      (perform-expression (compound-statement expression)
        (begin
          (eval-block compound-statement env class-env)
          (eval-expression expression env class-env)))
      (if-expression (test-exp then-exp else-exp)
        (if (true-value? (eval-expression test-exp env class-env))
          (eval-expression then-exp env class-env)
          (eval-expression else-exp env class-env)))
      (expression (seed rest)
        (letrec
          ((loop (lambda (acc rest)
                   (if (null? rest) acc
                     (loop (apply-relational-op (car rest)
                            acc
                            (eval-sum (cadr rest) env class-env))
                           (cddr rest))))))
          (loop (eval-sum seed env class-env) rest)))
      (else (raise-error 'eval-expression expression)))))

;;; ****************************************************************

;     (sum
;       (term (arbno additive-op term))
;       sum)

(define eval-sum
  (lambda (sum env class-env)
    (record-case sum
      (sum (seed rest)
        (letrec
          ((loop (lambda (acc rest)
                   (if (null? rest) acc
                     (loop (apply-additive-op (car rest)
                            acc
                            (eval-term (cadr rest) env class-env))
                           (cddr rest))))))
          (loop (eval-term seed env class-env) rest)))
      (else (raise-error 'eval-sum sum)))))

;;; ****************************************************************

;     (term 
;       (factor (arbno mult-op factor))
;       product)

(define eval-term
  (lambda (term env class-env)
    (record-case term
      (product (seed rest)
        (letrec
          ((loop (lambda (acc rest)
                   (if (null? rest) acc
                     (loop (apply-mult-op (car rest)
                            acc
                            (eval-factor (cadr rest) env class-env))
                           (cddr rest))))))
          (loop (eval-factor seed env class-env) rest)))
      (else (raise-error 'eval-term term)))))

;;; ****************************************************************

;     (factor
;       (number)
;       const-factor)
;     (factor
;       (lparen expression rparen)
;       paren-exp)
;     (factor
;       (identifier identifier-tail)
;       identifier-exp)


(define eval-factor
  (lambda (factor env class-env)
    (record-case factor
      (const-factor (num) num)
      (paren-exp (expression) (eval-expression expression env class-env))
      (identifier-exp (ident ident-tail) 
        (eval-ident-tail
          (deref (apply-env env ident)) ident-tail env class-env))
      (else (raise-error 'eval-factor factor)))))

;;; ****************************************************************

;     (identifier-tail
;       ()
;       empty-identifier-tail)
;     (identifier-tail
;       (message-send-sym identifier operand-list)
;       method-call)

(define eval-ident-tail
  (lambda (val-of-ident ident-tail env class-env)
    (record-case ident-tail
      (empty-identifier-tail () val-of-ident)
      (method-call (message operand-list)
        (let ((args (eval-operand-list operand-list env class-env))
              (object val-of-ident))
          (send-message object message args class-env)))
      (else (raise-error 'eval-ident-tail ident-tail)))))
        

;;; ****************************************************************

;     (additive-op (+) plus-op)
;     (additive-op (-) minus-op)


(define apply-additive-op
  (lambda (additive-op x y)
    (record-case additive-op
      (plus-op () (+ x y))
      (minus-op ()(- x y))
      (else (raise-error 'apply-additive-op additive-op)))))


;;; ****************************************************************

;     (mult-op (*) times-op)
;     (mult-op (/) div-op)

(define apply-mult-op
  (lambda (mult-op x y)
    (record-case mult-op
      (times-op () (* x y))
      (div-op () (/ x y))
      (else (raise-error 'apply-mult-op mult-op)))))


;;; ****************************************************************

;     (relational-op (equal-sym) equal-op)
;     (relational-op (unequal-sym) unequal-op)
;     (relational-op (lt-sym) lt-op)
;     (relational-op (gt-sym) gt-op)
;     (relational-op (le-sym) le-op)
;     (relational-op (ge-sym) ge-op)


(define apply-relational-op 
  (lambda (relational-op x y)
    (record-case relational-op
      (equal-op () (if (= x y) true-value false-value))
      (unequal-op () (if (= x y) false-value true-value))
      (gt-op () (if (> x y) true-value false-value))
      (lt-op () (if (< x y) true-value false-value))
      (ge-op () (if (>= x y) true-value false-value))
      (le-op () (if (<= x y) true-value false-value))
      (else (raise-error 'eval-relational-op relational-op)))))


;;; ****************************************************************
;;; ****************************************************************

;;; procedures

(define-record closure (formals body env))

(define apply-proc
  (lambda (proc args class-env)
    (record-case proc
      (closure (formals body env)
        (eval-block body 
          (extend-env
            (make-var-rib formals (map make-cell args))
            env)
          class-env))
      (else (raise-error 'apply-proc proc)))))


;;; ****************************************************************
;;; ****************************************************************
            
;;; environments

;;; an environment is a list of ribs.  Each rib is either a var-rib or
;;; a proc-rib.  vars are in cells, procs are not.  This means you
;;; can't pass a procedure.  [Is this a bug or a feature?] 

(define empty-env
  (lambda () '()))

(define extend-env
  (lambda (rib old-env)
    (cons rib old-env)))

(define apply-env
  (lambda (ribs var)
    (if (null? ribs)
      (error 'apply-env "unbound variable ~s" var)
      (record-case (car ribs)
        (var-rib (names cells)
          (lookup-in-var-rib var names cells (cdr ribs)))
        (proc-rib (procs)
          (lookup-in-proc-rib procs var ribs))
        (else (raise-error 'apply-env ribs))))))

(define lookup-in-var-rib
  (lambda (var names cells old-ribs)
    (cond
      ((null? names) (apply-env old-ribs var))
      ((null? cells) (error 'lookup-in-var-rib
                       "not enough cells in rib: names = ~s cells = ~s"
                       names cells))
      ((eq? var (car names)) (car cells))
      (else (lookup-in-var-rib var (cdr names) (cdr cells) old-ribs)))))
                       
    

(define lookup-in-proc-rib
  (lambda (procdefs var ribs)
    (cond
      ((null? procdefs) (apply-env (cdr ribs) var))
      ((eq? var (procdef->name (car procdefs)))
       (make-closure 
         (procdef->formals (car procdefs))
         (procdef->body    (car procdefs))
         ribs                           ; the recursive environment
         ))
      (else
        (lookup-in-proc-rib (cdr procdefs) var ribs)))))

;;; ****************************************************************
;;; ****************************************************************

;;; Cells

(define make-cell
  (lambda (value)
    (cons '*cell value)))

(define deref   
  (lambda (cell) 
    (cdr cell)))

(define set-cell!
  (lambda (cell value)
    (set-cdr! cell value)))

;;; ****************************************************************
;;; ****************************************************************

;;; booleans

(define true-value 1)
(define false-value 0)

(define true-value?
  (lambda (val) (not (zero? val))))

;;; ****************************************************************
;;; ****************************************************************

;;; objects

(define-record object (class-name instance-var-rib))

(define make-new-object
  (lambda (class-name args class-env)
    ;; first retrieve the class-decl from the class-env and pull out
    ;; the pieces.
    (let ((class-decl (apply-class-env class-env class-name)))
      (record-case class-decl
        (class-decl (name init-formals instance-var-decl methods initializer)
          ;; next make a rib for the instance variables
          (let ((instance-rib (eval-var-decl instance-var-decl))
                (init-rib
                  (make-var-rib
                    init-formals (map make-cell args))))
            ;; now run the initializer on this rib.  It should
            ;; initialize the variables, etc.  
            ;; Is there some reason this is a compound statement and not
            ;; a block?
            (eval-block 
              initializer
              (extend-env instance-rib (extend-env init-rib (empty-env)))
              class-env)
            ;; now return the object:
            (make-object class-name instance-rib)))
        (else (raise-error 'make-new-object class-decl))))))

(define send-message
  (lambda (object message args class-env)
    (let ((class-name (object->class-name object)))
      (let ((method-decl (lookup-method class-name message
                           class-env)))
        (record-case method-decl
          (method-decl (name formals body)
            ;; methods are NOT recursive.  They have to use self.
            ;; Also, methods are not scoped.  They run with a 2-rib
            ;; environment, always:
            (let ((ans (eval-expression body
                         (extend-env 
                           (make-var-rib
                             (cons 'self formals)
                             (map make-cell
                                  (cons object args)))
                           (extend-env
                             (object->instance-var-rib object)
                             (empty-env)))
                         class-env)))
              ans))
          (else (raise-error 'send-message method-decl)))))))

(define apply-class-env
  (lambda (class-env class-name)
    (cond
      ((null? class-env)
       (error 'apply-class-env "undefined class ~s" class-name))
      ((eq? class-name (class-decl->name (car class-env)))
       (car class-env))
      (else (apply-class-env (cdr class-env) class-name)))))

(define lookup-method
  (lambda (class-name method-name class-env)
    (letrec
      ((loop (lambda (method-decls)
               (cond
                 ((null? method-decls)
                  (error 'lookup-method
                    "unknown message ~s for class ~s"
                    method-name class-name))
                 ((eq? method-name
                       (method-decl->name (car method-decls)))
                  (car method-decls))
                 (else (loop (cdr method-decls)))))))
      (loop (class-decl->methods (apply-class-env class-env class-name))))))
                  
(define empty-class-env
  (lambda () '()))

;; extend-class-env is CONS, hidden in the MAP in eval-class-decl*.
;; This is probably not the best coding.

;;; ****************************************************************
;;; ****************************************************************

;;; miscellany

(define raise-error
  (lambda (name value)
    (error name "unknown structure ~s" value)))

(define prompt-read
  (lambda (msg)
    (printf "  " msg)
    (read)))