;;; obj.scm -- implementation of the object-oriented syntax

;; 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.

(define (ask object message . args)
  (let ((method (object message)))
    (if (method? method)
	(apply method (cons object args))
	(error "No method" message (cadr method)))))

(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 arguments)))
    (ask new-instance 'initialize)
    new-instance))

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


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

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


;; 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.

(extend-syntax (define-class)
   [(define-class . body)
    (make-definitions (quote body)) ])

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

(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 ,(instance-vars form)
	       (let ,(append (parent-let-list form)
			     (locals-let-list form))
		 (define (self message)
		   (cond
		    ,(init-clause form)
		    ,@(method-clauses form)
		    ,(else-clause form) ))
		 self )))) )))


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

(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 instance-vars cdar)

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

(define (locals-let-list form)
  (let ((locals-clause (find-a-clause 'locals form)))
    (if (null? locals-clause) '()
	(cdr locals-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)
	     `((,(word 'my- (car parent-and-args)) 'initialize)
	       receiver))
	   (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)
    (let ((body (append (parent-initialization form)
			(my-initialization form) )))
      (if (null? body) (list #f) body)))

  `((eq? message 'initialize)
    (lambda (receiver)
      ,@(init-body form) )))

(define (method-clauses form)
  (map
   (lambda (method-defn)
     `((eq? message ',(caadr method-defn))
       (lambda (receiver ,@(cdadr method-defn))
	 ,@(cddr method-defn) )) )
   (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 (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 (receiver . args) ,@(cdr default-method))))
     ((null? default-method)
      `(else (get-method message ,@(parent-list form))) )
     (else (error "Classes cannot have both default methods and parents.")))))

(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))))