;;; obj.scm version 4.0 5/18/2000
;;; -- implementation of the object-oriented syntax
;; By Matt Wright, based on a handout from MIT
;; Revised for STk by Brian Gaeke - removed scm and procedure->macro

;; ASK: send a message to an object

; The dot in the first line of the definition of ASK, below, makes it
; take a variable number of arguments.  The first argument is associated
; with the formal parameter OBJECT; the second with MESSAGE; any extra
; actual arguments are put in a list, and that list is associated with
; the formal parameter ARGS.  (If there are only two actual args, then
; ARGS will be the empty list.)

; APPLY takes two arguments, a procedure and a list, and applies the
; procedure to the things in the list, which are used as actual
; argument values.

(load "tables.scm")

(define *traced-method-table* (make-table))
(define *err-port* (current-error-port))

(define (show-args formals actuals)
    )

(define (indent) "")

(define (ask object message . args)
  (let ((method (object message)))
    (if (method? method)
        (let ((trace-info (lookup *traced-method-table* method)))
             (if trace-info
                 (begin (format *err-port* "~A -> ~A method ~A with "
                                (indent)
                                (car trace-info) (cadr trace-info))
                        (show-args (cddr trace-info) args)
                 ))
             (let ((result (apply method args)))
                  (if trace-info
                      (begin (format *err-port*
                                     "~A <- ~A method ~A returns ~S\n"
                                     (indent)
                                     (car trace-info) (cadr trace-info)
                                     (result)))))
        )
	(error "Instance of class " (cadr method)
               " does not respond to message: " message))))

(define (no-method name)
  (list 'no-method name))

(define (no-method? x)
  (if (pair? x)
      (eq? (car x) 'no-method)
      #f))

(define (method? x)
  (not (no-method? x)))


;; INSTANTIATE and INSTANTIATE-PARENT:  Create an instance of a class

; The difference is that only INSTANTIATE initializes the new object

(define (instantiate class . arguments)
  (let ((new-instance (apply (class 'instantiate) arguments)))
    (ask new-instance 'initialize new-instance)
    new-instance))

(define (instantiate-parent class . arguments)
  (apply (class 'instantiate) arguments))

;; GET-METHOD: Send a message to several objects and return the first
;; method found (for multiple inheritance)

(define (get-method give-up-name message . objects)
  (if (null? objects)
      (no-method give-up-name)
      (let ((method ((car objects) message)))
	(if (method? method)
	    method
	    (apply get-method (cons give-up-name
				    (cons message (cdr objects)) ))))))



;; USUAL: Invoke a parent's method
;; Note: The 'send-usual-to-parent method is put in automatically by
;; define-class.

(define-macro (usual . args)
	     `(ask dispatch 'send-usual-to-parent . ,args))


;; DEFINE-CLASS:  Create a new class.

; DEFINE-CLASS is a special form.  When you type (define-class body...)
; it's as if you typed (make-definitions (quote body...)).  In other
; words, the argument to DEFINE-CLASS isn't evaluated.  This makes sense
; because the argument isn't Scheme syntax, but rather is the special
; object-oriented programming language we're defining.
; Make-definitions transforms the OOP notation into a standard Scheme
; expression, then uses EVAL to evaluate the result.  (You'll see EVAL
; again in chapter 4 with the metacircular evaluator.)

; When you define a class named THING, for example, two global Scheme
; variables are created.  The variable THING has as its value the
; procedure that represents the class.  This procedure is invoked by
; INSTANTIATE to create instances of the class.  A second variable,
; THING-DEFINITION, has as its value the text of the Scheme expression
; that defines THING.  This text is used only by SHOW-CLASS, the
; procedure that lets you examine the result of the OOP-to-Scheme
; translation process.

(define-macro (define-class . body) (make-definitions body))

(define (make-definitions form)
  (let ((definition (translate form)))
    (eval `(define ,(word (class-name form) '-definition) ',definition))
    (eval definition)
    (list 'quote (class-name form))))

(define (show-class name)
  (eval (word name '-definition)) )

; TRANSLATE does all the work of DEFINE-CLASS.
; The backquote operator (`) works just like regular quote (') except
; that expressions proceeded by a comma are evaluated.  Also, expressions
; proceeded by ",@" evaluate to lists; the lists are inserted into the
; text without the outermost level of parentheses.

(define (translate form)
  (cond ((null? form) (error "Define-class: empty body"))
	((not (null? (obj-filter form (lambda (x) (not (pair? x))))))
	 (error "Each argument to define-class must be a list"))
	((not (null? (extra-clauses form)))
	 (error "Unrecognized clause in define-class:" (extra-clauses form)))
	(else 
	 `(define ,(class-name form)
	    (let ,(class-var-bindings form)
	      (lambda (class-message)
		(cond
		 ,@(class-variable-methods form)
		 ((eq? class-message 'instantiate)
		  (lambda ,(instantiation-vars form)
		    (let ((self '())
			  ,@(parent-let-list form)
			  ,@(instance-vars-let-list form))
		      (define (dispatch message)
			(cond
			 ,(init-clause form)
			 ,(usual-clause form)
			 ,@(method-clauses form)
			 ,@(local-variable-methods form)
			 ,(else-clause form) ))
		      dispatch )))
		 (else (error "Class " ',(class-name form)
                              " does not respond to message: " class-message))
                              )))))))

(define *legal-clauses*
  '(instance-vars class-vars method default-method parent initialize))

(define (extra-clauses form)
  (obj-filter (cdr form)
	      (lambda (x) (not (member? (car x) *legal-clauses*)))))

(define class-name caar)

(define (class-var-bindings form)
  (let ((classvar-clause (find-a-clause 'class-vars form)))
    (if (null? classvar-clause)
	'()
	(cdr classvar-clause) )))

(define instantiation-vars cdar)

(define (parent-let-list form)
  (let ((parent-clause (find-a-clause 'parent form)))
    (if (null? parent-clause)
	'()
	(map (lambda (parent-and-args)
	       (list (word 'my- (car parent-and-args))
		     (cons 'instantiate-parent parent-and-args)))
	     (cdr parent-clause)))))

(define (instance-vars-let-list form)
  (let ((instance-vars-clause (find-a-clause 'instance-vars form)))
    (if (null? instance-vars-clause)
	'()
	(cdr instance-vars-clause))))

(define (init-clause form)
  (define (parent-initialization form)
    (let ((parent-clause (find-a-clause 'parent form)))
      (if (null? parent-clause)
	  '()
	  (map
	   (lambda (parent-and-args)
	     `(ask ,(word 'my- (car parent-and-args)) 'initialize self) )
	   (cdr parent-clause) ))))
  (define (my-initialization form)
    (let ((init-clause (find-a-clause 'initialize form)))
      (if (null? init-clause) '()
	  (cdr init-clause))))
  (define (init-body form)
    (append (parent-initialization form)
	    (my-initialization form) ))

  `((eq? message 'initialize)
    (lambda (value-for-self)
      (set! self value-for-self)
      ,@(init-body form) )))

(define (variable-list var-type form)
  (let ((clause (find-a-clause var-type form)))
    (if (null? clause)
	'()
	(map car (cdr clause)) )))

(define (class-variable-methods form)
  (cons `((eq? class-message 'class-name) (lambda () ',(class-name form)))
	(map (lambda (variable)
	       `((eq? class-message ',variable) (lambda () ,variable)))
	     (variable-list 'class-vars form))))

(define (local-variable-methods form)
  (cons `((eq? message 'class-name) (lambda () ',(class-name form)))
	(map (lambda (variable)
	       `((eq? message ',variable) (lambda () ,variable)))
	     (append (cdr (car form))
		     (variable-list 'instance-vars form)
		     (variable-list 'class-vars form)))))

(define (method-clauses form)
  (map
   (lambda (method-defn)
     (let ((this-message (car (cadr method-defn)))
	   (args (cdr (cadr method-defn)))
	   (body (cddr method-defn)))
       `((eq? message ',this-message)
	 (lambda ,args ,@body))))
   (obj-filter (cdr form) (lambda (x) (eq? (car x) 'method))) ))

(define (parent-list form)
  (let ((parent-clause (find-a-clause 'parent form)))
    (if (null? parent-clause)
	'()
	(map (lambda (class) (word 'my- class))
	     (map car (cdr parent-clause))))))

(define (usual-clause form)
  (let ((parent-clause (find-a-clause 'parent form)))
    (if (null? parent-clause)
	`((eq? message 'send-usual-to-parent)
	  (error "Can't use USUAL in class " ',(class-name form)
                 " since it has no parent."))
	`((eq? message 'send-usual-to-parent)
	  (lambda (message . args)
	    (let ((method (get-method ',(class-name form)
				      message
				      ,@(parent-list form))))
	      (if (method? method)
		  (apply method args)
		  (error "Class " ',(class-name form)
                         "has no USUAL method for '" message)
                         )))))))

(define (else-clause form)
  (let ((parent-clause (find-a-clause 'parent form))
	(default-method (find-a-clause 'default-method form)))
    (cond
     ((and (null? parent-clause) (null? default-method))
      `(else (no-method ',(class-name form))))
     ((null? parent-clause)
      `(else (lambda args ,@(cdr default-method))))
     ((null? default-method)
      `(else (get-method ',(class-name form) message ,@(parent-list form))) )
     (else
      `(else (let ((method (get-method ',(class-name form)
				       message
				       ,@(parent-list form))))
	       (if (method? method)
		   method
		   (lambda args ,@(cdr default-method)) )))))))

(define (find-a-clause clause-name form)
  (let ((clauses (obj-filter (cdr form)
			     (lambda (x) (eq? (car x) clause-name)))))
    (cond ((null? clauses) '())
	  ((null? (cdr clauses)) (car clauses))
	  (else (error "Error in define-class: too many "
		       clause-name " clauses.")) )))

(define (obj-filter l pred)
  (cond ((null? l) '())
	((pred (car l))
	 (cons (car l) (obj-filter (cdr l) pred)))
	(else (obj-filter (cdr l) pred))))