;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
;;;. Copyright (c) 1991 by Venue


(in-package "CLOS")

(eval-when (compile load eval)
       (defvar *defclass-times* '(load eval compile))	;Probably have to change this
						;if you use defconstructor.
(defvar *defmethod-times*  '(load eval compile))
(defvar *defgeneric-times* '(load eval compile))
)


;;; Convert a function name to its standard setf function name.  We have to do this hack because not
;;; all Common Lisps have yet converted to having setf function specs. In a port that does have setf
;;; function specs you can use those just by making the obvious simple changes to these functions. 
;;; The rest of CLOS believes that there are function names like (SETF <foo>), this is the only place
;;; that knows about this hack. 


(eval-when (compile load eval)
       (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
(defun get-setf-function-name (name)
  (or (gethash name *setf-function-names*)
      (setf (gethash name *setf-function-names*)
	    (intern (format nil
			    "SETF ~A ~A"
			    (package-name (symbol-package name))
			    (symbol-name name))
		    *the-clos-package*))))

;;;
;;; Call this to define a setf macro for a function with the same behavior as
;;; specified by the SETF function cleanup proposal.  Specifically, this will
;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
;;;
;;; do-standard-defsetf                  A macro interface for use at top level
;;;                                      in files.  Unfortunately, users may
;;;                                      have to use this for a while.
;;;                                      
;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
;;; 
;;; do-standard-defsetf-1                A functional interface called by the
;;;                                      above, defmethod and defgeneric.
;;;                                      Since this is all a crock anyways,
;;;                                      users are free to call this as well.
;;;
(defmacro do-standard-defsetf (&rest function-names)
  `(eval-when (compile load eval)
     (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))

(defun do-standard-defsetfs-for-defclass (accessors)
  (dolist (name accessors) (do-standard-defsetf-1 name)))

(defun do-standard-defsetf-1 (function-name)
  (unless (setfboundp function-name)
    (let* ((setf-function-name (get-setf-function-name function-name)))
    
  (flet ((setf-expander (body env)
	       (declare (ignore env))
	       (let ((temps
		       (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
			       (cdr body)))
		     (forms (cdr body))
		     (vars (list (gensym))))
		 (values temps
			 forms
			 vars
			 `(,setf-function-name ,@vars ,@temps)
			 `(,function-name ,@temps)))))
	(let ((setf-method-expander (intern (concatenate 'string
						         (symbol-name function-name)
						         "-setf-expander")
				     (symbol-package function-name))))
	  (setf (get function-name :setf-method-expander) setf-method-expander
		(symbol-function setf-method-expander) #'setf-expander)))

     )))
(defun setfboundp (symbol)
(or (get symbol :setf-inverse)
	       (get symbol 'il:setf-inverse)
	       (get symbol 'il:setfn)
	       (get symbol :shared-setf-inverse)
	       (get symbol :setf-method-expander)
	       (get symbol 'il:setf-method-expander)))
)

                                                             ; eval-when



;;; CLOS, like user code, must endure the fact that we don't have a properly working setf.  Many
;;; things work because they get mentioned by a defclass or defmethod before they are used, but
;;; others have to be done by hand. 


(do-standard-defsetf 
	class-wrapper                           ; ***
     generic-function-name 
	method-function-plist 
	method-function-get 
	gdefinition 
     slot-value-using-class)

(defsetf slot-value set-slot-value)


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


;;; If symbol names a function which is traced or advised, return the unadvised, traced etc.
;;; definition.  This lets me get at the generic function object even when it is traced. 


(defun unencapsulated-fdefinition (symbol)
       (il:virginfn symbol))


;;; If symbol names a function which is traced or advised, redefine the `real' definition without
;;; affecting the advise. 


(defun fdefine-carefully (symbol new-definition)
       (let ((advisedp (member symbol il:advisedfns :test #'eq))
             (brokenp (member symbol il:brokenfns :test #'eq)))
            
            ;; In XeroxLisp (late of envos) tracing is implemented as a special case of "breaking". 
            ;; Advising, however, is treated specially. 
            (xcl:unadvise-function symbol :no-error t)
            (xcl:unbreak-function symbol :no-error t)
            (setf (symbol-function symbol)
                  new-definition)
            (when brokenp (xcl:rebreak-function symbol))
            (when advisedp (xcl:readvise-function symbol)))
       new-definition)

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

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

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

(defun SETF\ CLOS\ GDEFINITION (new-value spec)
       (parse-gspec spec (name (fdefine-carefully name new-value))
              (name (fdefine-carefully (get-setf-function-name name)
                           new-value))))


;;; These functions are a pale imitiation of their namesake.  They accept class objects or types
;;; where they should. 


(defun *typep (object type)
       (if (classp type)
           (let ((class (class-of object)))
                (if class
                    (memq type (class-precedence-list class))
                    nil))
           (let ((class (find-class type nil)))
                (if class
                    (*typep object class)
                    (typep object type)))))

(defun *subtypep (type1 type2)
       (let ((c1 (if (classp type1)
                     type1
                     (find-class type1 nil)))
             (c2 (if (classp type2)
                     type2
                     (find-class type2 nil))))
            (if (and c1 c2)
                (memq c2 (class-precedence-list c1))
                (if (or c1 c2)
                    nil
                                                             ; This isn't quite right, but...
                    (subtypep type1 type2)))))

(defun do-satisfies-deftype (name predicate)
       (let* ((specifier `(satisfies ,predicate))
              (expand-fn #'(lambda (&rest ignore)
                                  (declare (ignore ignore))
                                  specifier)))
             
             ;; Specific ports can insert their own way of doing this.  Many ports may find the
             ;; expand-fn defined above useful. 
             (or 
                 ;; This is the default for ports for which we don't know any better.  Note that for
                 ;; most ports, providing this definition should just speed up class definition.  It
                 ;; shouldn't have an effect on performance of most user code. 
                 (eval `(deftype ,name nil '(satisfies ,predicate))))))

(defun make-type-predicate-name (name)
       (intern (format nil "TYPE-PREDICATE ~A ~A" (package-name (symbol-package name))
                      (symbol-name name))
              *the-clos-package*))

(proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* 
                  *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* 
                  *the-class-null* *the-class-list* *the-class-integer* *the-class-float* 
                  *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* 
                  *the-class-array* *the-class-standard-object* *the-class-class* *the-class-method*
                  *the-class-generic-function* *the-class-standard-class* *the-class-standard-method*
                  *the-class-standard-generic-function* 
                  *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots*))

(proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* 
                  *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* 
                  *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* 
                  *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* 
                  *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* 
                  *the-wrapper-of-bit-vector* *the-wrapper-of-array*))

(defvar *built-in-class-symbols* nil)

(defvar *built-in-wrapper-symbols* nil)

(defun get-built-in-class-symbol (class-name)
       (or (cadr (assq class-name *built-in-class-symbols*))
           (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name))
                                *the-clos-package*)))
                (push (list class-name symbol)
                      *built-in-class-symbols*)
                symbol)))

(defun get-built-in-wrapper-symbol (class-name)
       (or (cadr (assq class-name *built-in-wrapper-symbols*))
           (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name))
                                *the-clos-package*)))
                (push (list class-name symbol)
                      *built-in-wrapper-symbols*)
                symbol)))

(pushnew 'class *variable-declarations*)

(pushnew 'variable-rebinding *variable-declarations*)

(defun variable-class (var env)
       (caddr (variable-declaration 'class var env)))

(defvar *boot-state* nil)
                                                             ; NIL EARLY BRAID COMPLETE 


(eval-when (load eval)
       (when (eq *boot-state* 'complete)
             (error "Trying to load (or compile) CLOS in an environment in which it~%~
            has already been loaded.  This doesn't work, you will have to~%~
            get a fresh lisp (reboot) and then load CLOS."))
       (when *boot-state* (cerror "Try loading (or compiling) CLOS anyways." "Trying to load (or compile) CLOS in an environment in which it~%~
             has already been partially loaded.  This may not work, you may~%~
             need to get a fresh lisp (reboot) and then load CLOS.")))


;;; This is used by combined methods to communicate the next methods to the methods they call.  This
;;; variable is captured by a lexical variable of the methods to give it the proper lexical scope. 


(defvar *next-methods* nil)

(defvar *not-an-eql-specializer* '(not-an-eql-specializer))

(defvar *umi-gfs*)

(defvar *umi-complete-classes*)

(defvar *umi-reorder*)

(defvar *invalidate-discriminating-function-force-p* nil)

(defvar *invalid-dfuns-on-stack* nil)

(defvar *standard-method-combination*)

(defvar *slotd-unsupplied* (list '*slotd-unsupplied*))

                                                             ; ***


(defmacro define-gf-predicate (predicate &rest classes)
       `(progn (defmethod ,predicate ((x t))
                      nil)
               ,@(mapcar #'(lambda (c)
                                  `(defmethod ,predicate ((x ,c))
                                          t))
                        classes)))

(defmacro plist-value (object name)
       `(with-slots (plist)
               ,object
               (getf plist ,name)))

(defsetf plist-value (object name)
       (new-value)
       (once-only (new-value)
              `(with-slots (plist)
                      ,object
                      (if ,new-value
                          (setf (getf plist ,name)
                                ,new-value)
                          (progn (remf plist ,name)
                                 nil)))))

(defvar *built-in-classes* 

       ;; name       supers     subs                     cdr of cpl 
       '((number (t) (complex float rational)
                (t))
         (complex (number)
                nil
                (number t))
         (float (number)
                nil
                (number t))
         (rational (number)
                (integer ratio)
                (number t))
         (integer (rational)
                nil
                (rational number t))
         (ratio (rational)
                nil
                (rational number t))
         (sequence (t)
                (list vector)
                (t))
         (list (sequence)
               (cons null)
               (sequence t))
         (cons (list)
               nil
               (list sequence t))
         (array (t)
                (vector)
                (t))
         (vector (array sequence)
                (string bit-vector)
                (array sequence t))
         (string (vector)
                nil
                (vector array sequence t))
         (bit-vector (vector)
                nil
                (vector array sequence t))
         (character (t)
                nil
                (t))
         (symbol (t)
                (null)
                (t))
         (null (symbol)
               nil
               (symbol list sequence t))))


;;; The classes that define the kernel of the metabraid. 


(defclass t nil nil (:metaclass built-in-class))

(defclass standard-object (t)
       nil)

(defclass metaobject (standard-object)
       nil)

(defclass specializer (metaobject)
       nil)

(defclass definition-source-mixin (standard-object)
       ((source :initform (load-truename)
               :reader definition-source :initarg :definition-source)))

(defclass plist-mixin (standard-object)
       ((plist :initform nil)))

(defclass documentation-mixin (plist-mixin)
       nil)

(defclass dependent-update-mixin (plist-mixin)
       nil)


;;; The class CLASS is a specified basic class.  It is the common superclass of any kind of class. 
;;; That is any class that can be a metaclass must have the class CLASS in its class precedence
;;; list. 


(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer)
       ((name :initform nil :initarg :name :accessor class-name)
        (direct-superclasses :initform nil :reader class-direct-superclasses)
        (direct-subclasses :initform nil :reader class-direct-subclasses)
        (direct-methods :initform (cons nil nil))))


;;; The class CLOS-CLASS is an implementation-specific common superclass of all specified subclasses
;;; of the class CLASS. 


(defclass clos-class (class)
       ((class-precedence-list :initform nil)
        (wrapper :initform nil)))


;;; The class STD-CLASS is an implementation-specific common superclass of the classes
;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. 


(defclass std-class (clos-class)
       ((direct-slots :initform nil :accessor class-direct-slots)
        (slots :initform nil :accessor class-slots)
        (no-of-instance-slots                                ; *** MOVE TO WRAPPER ***
               :initform 0 :accessor class-no-of-instance-slots)
        (prototype :initform nil)))

(defclass standard-class (std-class)
       nil)

(defclass funcallable-standard-class (std-class)
       nil)

(defclass forward-referenced-class (clos-class)
       nil)

(defclass built-in-class (clos-class)
       nil)


;;; Slot definitions. Note that throughout CLOS, "SLOT-DEFINITION" is abbreviated as "SLOTD". 


(defclass slot-definition (metaobject)
       nil)

(defclass direct-slot-definition (slot-definition)
       nil)

(defclass effective-slot-definition (slot-definition)
       nil)
;
(defclass standard-slot-definition (slot-definition)
       ((name :initform nil :accessor slotd-name)
        (initform :initform *slotd-unsupplied* :accessor slotd-initform)
        (initfunction :initform *slotd-unsupplied* :accessor slotd-initfunction)
        (readers :initform nil :accessor slotd-readers)
        (writers :initform nil :accessor slotd-writers)
        (initargs :initform nil :accessor slotd-initargs)
        (allocation :initform nil :accessor slotd-allocation)
        (type :initform nil :accessor slotd-type)
        (documentation :initform "" :initarg :documentation)
        (class :initform nil :accessor slotd-class)
        (instance-index :initform nil :accessor slotd-instance-index)))

(defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition)
       nil)

                                                             ; Adding slots here may involve extra
                                                             ; work to the code in braid.lisp 


(defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition)
       nil)

                                                             ; Adding slots here may involve extra
                                                             ; work to the code in braid.lisp 


(defclass eql-specializer (specializer)
       ((object :initarg :object :reader eql-specializer-object)))


;;; 


(defmacro dolist-carefully ((var list improper-list-handler)
                            &body body)
       `(let ((,var nil)
              (.dolist-carefully. ,list))
             (loop (when (null .dolist-carefully.)
                         (return nil))
                   (if (consp .dolist-carefully.)
                       (progn (setq ,var (pop .dolist-carefully.))
                              ,@body)
                       (,improper-list-handler)))))

(defun legal-std-documentation-p (x)
       (if (or (null x)
               (stringp x))
           t
           "a string or NULL"))

(defun legal-std-lambda-list-p (x)
       (declare (ignore x))
       t)

(defun legal-std-method-function-p (x)
       (if (functionp x)
           t
           "a function"))

(defun legal-std-qualifiers-p (x)
       (flet ((improper-list nil (return-from legal-std-qualifiers-p "Is not a proper list.")))
             (dolist-carefully (q x improper-list)
                    (let ((ok (legal-std-qualifier-p q)))
                         (unless (eq ok t)
                             (return-from legal-std-qualifiers-p (format nil "Contains ~S which ~A" q
                                                                        ok)))))
             t))

(defun legal-std-qualifier-p (x)
       (if (and x (atom x))
           t
           "is not a non-null atom"))

(defun legal-std-slot-name-p (x)
       (cond ((not (symbolp x))
              "is not a symbol and so cannot be bound")
             ((keywordp x)
              "is a keyword and so cannot be bound")
             ((memq x '(t nil))
              "cannot be bound")
             (t t)))

(defun legal-std-specializers-p (x)
       (flet ((improper-list nil (return-from legal-std-specializers-p "Is not a proper list.")))
             (dolist-carefully (s x improper-list)
                    (let ((ok (legal-std-specializer-p s)))
                         (unless (eq ok t)
                             (return-from legal-std-specializers-p (format nil "Contains ~S which ~A"
                                                                          s ok)))))
             t))

(defun legal-std-specializer-p (x)
       (if (or (classp x)
               (eql-specializer-p x))
           t
           "is neither a class object nor an eql specializer"))