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

(in-package 'pcl)

(defvar *early-defclass-forms*
  '(

    (defclass t () ())

    (defclass object (t) ())

    (defclass standard-class (object)
	 ((name
	    :initform nil
	    :accessor class-name)
	  (class-precedence-list
	    :initform ()
	    :accessor class-precedence-list
	    :accessor class-class-precedence-list)
	  (local-supers
	    :initform ()
	    :accessor class-local-supers)
	  (local-slots
	    :initform ()
	    :accessor class-local-slots)
	  (direct-subclasses
	    :initform ()
	    :accessor class-direct-subclasses)
	  (direct-methods
	    :initform ()
;	    :accessor class-direct-methods        ;This is defined by hand
	                                          ;during bootstrapping.
	    )
	  (forward-referenced-supers
	    :initform ()
	    :accessor class-forward-referenced-supers)
	  (no-of-instance-slots
	    :initform 0
	    :accessor class-no-of-instance-slots)
	  (instance-slots
	    :initform ())
	  (non-instance-slots
	    :initform ()
	    :accessor class-non-instance-slots)
	  (wrapper
	    :initform nil
	    :accessor class-wrapper)
	  (direct-generic-functions
	    :initform ()
	    :accessor class-direct-generic-functions)
	  (prototype
	    :initform nil)
	  (options
	    :initform ()
	    :accessor class-options)
	  (constructors
	    :initform ()
	    :accessor class-constructors)))

    (defclass standard-slot-description (object)
	 ((name
	    :initform nil
;	    :accessor slotd-name                ;This is defined by hand
						;during bootstrapping.
	    )
	  (keyword
	    :initform nil
	    :accessor slotd-keyword)
	  (initform
	    :initform *slotd-unsupplied*
	    :accessor slotd-initform)
	  (accessors
	    :initform nil
	    :accessor slotd-accessors)
	  (readers
	    :initform nil
	    :accessor slotd-readers)
	  (allocation
	    :initform nil
	    :accessor slotd-allocation)
	  (type
	    :initform nil
	    :accessor slotd-type)))
      

    ))

(defvar *fsc-defclass-forms*
  '((defclass funcallable-standard-class (standard-class)
      ())))

(defvar *methods-defclass-forms*
  '(
    
      
    (defclass standard-method ()
	 ((function
	    :initform nil)
	  (generic-function
	    :initform nil)
	  (type-specifiers
	    :initform ())
	  (arglist
	    :initform ())
	  (options
	    :initform ())
	  (documentation
	    :initform nil))
       (:accessor-prefix method-))

    (defclass standard-reader/writer-method (standard-method)
	 ((slot-name nil))
      ;; There is a hand coded reader method for this which appears
      ;; in the beginning of methods.  See the comment there.
      ;(:reader-prefix reader/writer-method)
      )

    (defclass standard-reader-method (standard-reader/writer-method) ())
    (defclass standard-writer-method (standard-reader/writer-method) ())
    
    (defclass standard-generic-function ()
        ((name
	   :initform nil)
	 (methods
	   :initform ())
	 (discriminating-function
	   :initform ())
	 (classical-method-table
	   :initform nil)
	 (cache
	   :initform ())
	 (pretty-arglist
	   :initform ())
	 (method-class
	   :initform (class-named 'standard-method))
	 (dispatch-order
	   :initform :default))
      (:metaclass funcallable-standard-class)
      (:accessor-prefix generic-function-))

;    (defclass standard-generic-function (generic-function)
;      (
;       (method-combination-type
;	 :initform :daemon
;	 :accessor method-combination-type)
;       (method-combination-parameters
;	 :initform ()
;	 :accessor method-combination-parameters)
;       (methods-combine-p
;	 :initform ()
;	 :accessor methods-combine-p))
;      (:metaclass funcallable-standard-class))

    ))

;;;
;;; make-setf-method-lambda-list is used by any part of PCL that has to
;;; construct the lambda-list of a setf-method from an access lambda list
;;; and a new value lambda list.  This function is not (yet) a documented
;;; part of CLOS, but it is a documented part of PCL.
;;; 
(defun make-setf-method-lambda-list (access-lambda-list new-value-lambda-list)
  (when (or (cdr new-value-lambda-list)
	    (memq (car new-value-lambda-list) lambda-list-keywords))
    (error "The new-value lambda-list is only allowed to contain one~%~
            argument, and it must be a required argument.~%~
            The new-value lambda-list ~S is illegal."
	   new-value-lambda-list))
  (let* ((setf-ll (list nil))
	 (setf-tail setf-ll)
	 (access-tail access-lambda-list))
    (loop
      (cond ((null access-tail)
	     (setf (cdr setf-tail) (list (car new-value-lambda-list)))
	     (return (cdr setf-ll)))
	    ((memq (car access-tail) lambda-list-keywords)
	     (setf (cdr setf-tail) (cons (car new-value-lambda-list)
					 (copy-list access-tail)))
	     (return (cdr setf-ll)))
	    (t
	     (setf (cdr setf-tail) (list (pop access-tail))
		   setf-tail (cdr setf-tail)))))))





;;;
;;; This is like fdefinition on the Lispm.  If Common Lisp had something like
;;; function specs I wouldn't need this.  On the other hand, I don't like the
;;; way this really works so maybe function specs aren't really right either?
;;; 
;;; I also don't understand the real implications of a Lisp-1 on this sort of
;;; thing.  Certainly some of the lossage in all of this is because these
;;; SPECs name global definitions.
;;;
;;; Note that this implementation is set up so that an implementation which
;;; has a 'real' function spec mechanism can use that instead and in that way
;;; get rid of setf generic function names.
;;;
(defmacro parse-gspec (spec
		       (non-setf-var . non-setf-case)
		       (setf-var . setf-case))
  (declare (indentation 1 1))
  (once-only (spec)
    `(cond ((symbolp ,spec)
	    (let ((,non-setf-var ,spec)) ,@non-setf-case))
	   ((and (listp ,spec)
		 (eq (car ,spec) 'setf)
		 (symbolp (cadr ,spec)))
	    (let ((,setf-var (cadr ,spec))) ,@setf-case))
	   (t
	    (error "Can't understand ~S as a generic function specifier.~%~
                    It must be either a symbol which can name a function or~%~
                    a like ~S, where the car is the symbol ~S and the cadr~%~
                    is a symbol which can name a generic function."
		   ,spec '(setf <foo>) 'setf)))))

;;;
;;; Note that this is just one possible implementation of these functions.  In
;;; particular, an implementation that has some 'real' function spec mechanism
;;; is free to redefine these functions not to use these crufty setf generic
;;; function names.
;;;
(defvar *setf-generic-function-names* (make-hash-table :size 100))

(defun get-setf-generic-function-name (name)
  (or (gethash name *setf-generic-function-names*)
      (setf (gethash name *setf-generic-function-names*)
	    (intern (string-append "setf  " name)
		    (symbol-package name)))))

(defun gboundp (spec)
  (parse-gspec spec
    (name (fboundp name))
    (name (fboundp (get-setf-generic-function-name name)))))

(defun gmakunbound (spec)
  (parse-gspec spec
    (name (fmakunbound name))
    (name (fmakunbound (get-setf-generic-function-name name)))))

(defun gdefinition (spec)
  (parse-gspec spec
    (name (or (macro-function name)		;??
	      (symbol-function name)))
    (name (symbol-function (get-setf-generic-function-name name)))))

(defun set-gdefinition (spec new-value)
  (parse-gspec spec
    (name (setf (symbol-function name)
		new-value))
    (name (setf (symbol-function (get-setf-generic-function-name name))
		new-value))))

(defsetf gdefinition set-gdefinition)


;;;
;;; This is the documented function (in the CLOS spec) for getting at the setf
;;; generic function for a symbol.  Of course propagating all these different
;;; namespaces this way is folly, but since we are on a (losing) roll...
;;; 
(defun GET-SETF-GENERIC-FUNCTION (name)
  (gdefinition `(setf ,name)))

(defsetf get-setf-generic-function (name) (new-value)
  `(setf (gdefinition ,name) ,new-value))


;;;
;;; do-defmethod-setf-defsetf is called whenever any part of PCL (typically
;;; load-defmethod-setf) wants to do a 'defsetf' to establish the setf
;;; generic function for a symbol.
;;; 
(defun do-defmethod-setf-defsetf (generic-function-name
				  arglist
				  &optional (new-value-arglist '(new-value)))
  (when (member '&aux arglist)
    (setq arglist (reverse arglist))
    (loop (when (eq (pop arglist) '&aux)
	    (return (setq arglist (nreverse arglist))))))
  (let* ((setf-name (get-setf-generic-function-name generic-function-name))
	 (setf-ll (make-setf-method-lambda-list arglist new-value-arglist)))
    (do-defsetf generic-function-name
		arglist		
		new-value-arglist
		``(,',setf-name
		   ,,@(remove-if #'(lambda (x)
				     (member x lambda-list-keywords))
				 setf-ll)))))

(defun do-defsetf (access store-or-args &optional store-vars &rest body)
  (let #+Symbolics ((si:inhibit-fdefine-warnings t))
       #-Symbolics ()
    #+Lispm (setq body (copy-list body))
    (if body
	(eval `(defsetf ,access ,store-or-args ,store-vars ,@body))
	(eval `(defsetf ,access ,store-or-args)))))



(defun do-deftype (name lambda-list &rest body)
  (let #+Symbolics ((si:inhibit-fdefine-warnings t))
       #-Symbolics ()
    #+Lispm (setq body (copy-list body))
    (eval `(deftype ,name ,lambda-list ,@body))))


(defun make-type-predicate-name (class-name)
  (intern (string-append class-name " predicate")
	  (symbol-package class-name)))


;;;
;;; Do the defsetfs for accessors defined by defclass's in the bootstrap.
;;; These have to be here because we want to be able to compile setfs of
;;; calls to those accessors before we have actually been able to evaluate
;;; those defclass forms.
;;;
(defun define-early-setfs-and-type-predicates ()
  (dolist (forms-var '(*early-defclass-forms*
		       *fsc-defclass-forms*
		       *methods-defclass-forms*))
    (dolist (defclass (eval forms-var))
      (destructuring-bind (ignore name supers slots . options)
			  defclass      
	(unless (eq name 't)
	  (do-deftype name
		      ()
		      `'(satisfies ,(make-type-predicate-name name))))
	
	(dolist (slot slots)
	  (let ((slot-options (cdr slot)))
	    (loop (when (null slot-options) (return t))
		  (when (eq (car slot-options) ':accessor)
		    (do-defmethod-setf-defsetf (cadr slot-options)
					       (list name)))
		  (setq slot-options (cddr slot-options)))))

	(dolist (option options)
	  (when (and (listp option)
		     (eq (car option) :accessor-prefix))
	    (setq option (cadr option))
	    (dolist (slot slots)
	      (if (null option)
		  (do-defmethod-setf-defsetf (car slot) (list name))
		  (do-defmethod-setf-defsetf
		    (intern (string-append (symbol-name option)
					   (symbol-name (car slot))))
		    (list name))))))))))


(eval-when (load eval)
  (define-early-setfs-and-type-predicates))

;;;
;;; Extra little defsetfs which we need now.
;;; 
(defsetf class-instance-slots set-class-instance-slots)
(defsetf slotd-name set-slotd-name)
(do-defmethod-setf-defsetf 'class-options '(standard-class))

(defsetf slot-value set-slot-value)

(defsetf slot-value-always (object slot-name &optional default) (new-value)
  `(put-slot-always ,object ,slot-name ,new-value))