;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation.  All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;; 
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;; 
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; This file contains the higher level support for funcallable instances.
;;; 

(in-package 'pcl)

(eval-when (compile load eval)
  (mapcar #'eval *fsc-defclass-forms*))

;;; By macroleting the definitions of:
;;;   IWMC-CLASS-CLASS-WRAPPER
;;;   IWMC-CLASS-STATIC-SLOTS
;;;   IWMC-CLASS-DYNAMIC-SLOTS
;;;   slot-value-using-class--class-internal   ;These are kind of a
;;;   put-slot-using-class--class-internal   ;hack, solidfy this.
;;;
;;; we can use all the existing code for metaclass class.
;;; 
(defmacro with-funcallable-standard-class-as-class ((instance checkp)
						    &body body)
  (once-only (instance)
    `(let ((.class. (funcallable-instance-p ,instance)))
       ,(and checkp
	     `(or .class.
		  (error "~S is not an instance with meta-class ~
                          funcallable-standard-class." ,instance)))
       (macrolet ((iwmc-class-class-wrapper (instance)
		    `(funcallable-instance-wrapper ,instance))
		  (iwmc-class-static-slots (instance)
		    `(funcallable-instance-static-slots ,instance))
		  (iwmc-class-dynamic-slots (instance)
		    `(funcallable-instance-dynamic-slots ,instance))
		  (slot-value-using-class--class-internal
		    (class object slot-name
			   dont-call-slot-missing-p default)
		    `(with-slot-internal--class (,class ,object
						 ,slot-name nil)
		       (:instance (index)
			(get-static-slot--class ,object index))
		       (:dynamic (loc newp) (if (eq newp t)
						(setf (car loc) ,default)
						(car loc)))
		       (:class (slotd) (slotd-initform slotd))
		       (nil () (unless ,dont-call-slot-missing-p
				 (slot-missing ,object ,slot-name)))
		       ))
		  (put-slot-using-class--class-internal
		    (class object slot-name new-value
			   dont-call-slot-missing-p)
		    `(with-slot-internal--class (,class ,object
						 ,slot-name
						 ,dont-call-slot-missing-p)
		       (:instance (index)
			(setf (get-static-slot--class ,object
						      index)
			      ,new-value))
		       (:dynamic (loc) (setf (car loc) ,new-value))
		       (:class (slotd) (setf (slotd-initform slotd)
					     ,new-value))
		       (nil () (unless ,dont-call-slot-missing-p
				 (slot-missing ,object ,slot-name))))))
	 ,@body))))

  ;;   
;;;;;; 
  ;;   


(defmacro slot-value--funcallable-standard-class (class fsc-instance slot-name dont-call-slot-missing-p default)
  (once-only (fsc-instance slot-name)
    `(with-funcallable-standard-class-as-class (,fsc-instance t)
       (slot-value-using-class--class ,class
				    ,fsc-instance
				    ,slot-name
				    ,dont-call-slot-missing-p
				    ,default))))

(defmacro put-slot--funcallable-standard-class (class
						fsc-instance
						slot-name
						new-value
						dont-call-slot-missing-p)
  (once-only (fsc-instance slot-name)
    `(with-funcallable-standard-class-as-class (,fsc-instance t)
       ;; Cheat a little bit here, its worth it.
       ,(if (constantp slot-name)
	    (if (eq (eval slot-name) 'function)
		`(progn
		   (set-funcallable-instance-function ,fsc-instance
						      ,new-value)
		   (put-slot-using-class--class ,class
						,fsc-instance
						,slot-name
						,new-value
						,dont-call-slot-missing-p))
		`(put-slot-using-class--class ,class
					      ,fsc-instance
					      ,slot-name
					      ,new-value
					      ,dont-call-slot-missing-p))
	    `(if (eq ,slot-name 'function)
		 (progn (set-funcallable-instance-function ,fsc-instance
							   ,new-value)
			(put-slot-using-class--class ,class
						     ,fsc-instance
						     ,slot-name
						     ,new-value
						     ,dont-call-slot-missing-p))
		 (put-slot-using-class--class ,class
					      ,fsc-instance
					      ,slot-name
					      ,new-value
					      ,dont-call-slot-missing-p))))))

(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class)
						(class class))
  (declare (ignore fsc))
  (null (class-instance-slots class)))


(defmethod slot-value-using-class ((class funcallable-standard-class)
				 instance
				 slot-name
				 &optional dont-call-slot-missing-p
					   default)
  (slot-value--funcallable-standard-class
    class instance slot-name dont-call-slot-missing-p default))

(defmethod put-slot-using-class ((class funcallable-standard-class)
				 instance
				 slot-name
				 new-value
				 &optional dont-call-slot-missing-p)
  (put-slot--funcallable-standard-class
    class instance slot-name new-value dont-call-slot-missing-p))

(defmethod allocate-instance ((class funcallable-standard-class))
  (let ((class-wrapper (class-wrapper class)))
    (if class-wrapper				;Are there any instances?
        ;; If there are instances, the class is OK, just go ahead and
        ;; make the instance.
	(allocate-funcallable-instance class-wrapper
				   (class-no-of-instance-slots class))
        ;; Do first allocate-instance-time error-checking, build the class
        ;; wrapper and call ourselves again to really build the instance.
        (progn
          ;; no first time error checking yet.
          (setf (class-wrapper class) (make-class-wrapper class))
          (allocate-instance class)))))



(defmethod make-reader-method-function ((class funcallable-standard-class)
					slotd)
  (declare (ignore class))
  (funcall (get-templated-function-constructor 'get-function--fsc-class)
	   (slotd-name slotd)))

(defmethod make-writer-method-function ((class funcallable-standard-class)
					slotd)
  (declare (ignore class))
  (funcall (get-templated-function-constructor 'set-function--fsc-class)
	   (slotd-name slotd)))

(define-function-template get-function--fsc-class () '(slot-name)
  `(function
     (lambda (instance--fsc-class)
       (slot-value--funcallable-standard-class (class-of instance--fsc-class)
					     instance--fsc-class
					     slot-name
					     nil
					     nil))))

(define-function-template set-function--fsc-class () '(slot-name)
  `(function
     (lambda (instance--fsc-class new-value)
       (put-slot--funcallable-standard-class (class-of instance--fsc-class)
					     instance--fsc-class
					     slot-name
					     new-value
					     nil))))


(eval-when (load)
  (pre-make-templated-function-constructor get-function--fsc-class)
  (pre-make-templated-function-constructor set-function--fsc-class))


(defmethod make-type-predicate ((class funcallable-standard-class))
  (funcall (get-templated-function-constructor 'type-predicate--fsc-class)
	   class))

(define-function-template type-predicate--fsc-class () '(class)
  '(function (lambda (x)
	       (and (funcallable-instance-p x)
		    (memq class
			  (class-precedence-list
			    (funcallable-instance-class x)))))))

(eval-when (load)
  (pre-make-templated-function-constructor type-predicate--fsc-class))

(defmethod all-slots-using-class ((class funcallable-standard-class) object)
  (append (iterate ((slotd in (class-instance-slots class)))
            (collect (slotd-name slotd))
            (collect (slot-value object (slotd-name slotd))))
          (funcallable-instance-dynamic-slots object)))