;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 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 PARC
;;;   3333 Coyote Hill Rd.
;;;   Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;

(in-package :pcl)

(defmacro slot-symbol (slot-name type)
  `(if (symbolp ,slot-name)
       (or (get ,slot-name ',(ecase type
			       (reader 'reader-symbol)
			       (writer 'writer-symbol)
			       (boundp 'boundp-symbol)))
	   (intern (format nil "~A ~A slot ~a" 
			   (if (symbol-package ,slot-name)
			       (package-name (symbol-package ,slot-name))
			     "UNINTERNED")
			   (symbol-name ,slot-name)
			   ,(symbol-name type))
	           *slot-accessor-name-package*))
       (progn 
	 (error "non-symbol and non-interned symbol slot name accessors~
                 are not yet implemented")
	 ;;(make-symbol (format nil "~a ~a" ,slot-name ,type))
	 )))

(defun slot-reader-symbol (slot-name)
  (slot-symbol slot-name reader))

(defun slot-writer-symbol (slot-name)
  (slot-symbol slot-name writer))

(defun slot-boundp-symbol (slot-name)
  (slot-symbol slot-name boundp))

(defmacro asv-funcall (sym slot-name type &rest args)
  (declare (ignore type))
  `(if (#-akcl fboundp #+akcl %fboundp ',sym)
       (,sym ,@args)
       (no-slot ',sym ',slot-name)))

(defun no-slot (sym slot-name)
  (error "No class has a slot named ~S (~s has no function binding)."
	 slot-name sym))

(defmacro accessor-slot-value (object slot-name)
  (unless (constantp slot-name)
    (error "~s requires its slot-name argument to be a constant" 
	   'accessor-slot-value))
  (let* ((slot-name (eval slot-name))
	 (sym (slot-reader-symbol slot-name)))
    `(asv-funcall ,sym ,slot-name reader ,object)))

(defmacro accessor-set-slot-value (object slot-name new-value &environment env)
  (unless (constantp slot-name)
    (error "~s requires its slot-name argument to be a constant" 
	   'accessor-set-slot-value))
  (setq object (macroexpand object env))
  (setq slot-name (macroexpand slot-name env))
  (let* ((slot-name (eval slot-name))
	 (bindings (unless (or (constantp new-value) (atom new-value))
		     (let ((object-var (gensym)))
		       (prog1 `((,object-var ,object))
			 (setq object object-var)))))
	 (sym (slot-writer-symbol slot-name))
	 (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
    (if bindings
	`(let ,bindings ,form)
	form)))

(defconstant *optimize-slot-boundp* nil)

(defmacro accessor-slot-boundp (object slot-name)
  (unless (constantp slot-name)
    (error "~s requires its slot-name argument to be a constant" 
	   'accessor-slot-boundp))
  (let* ((slot-name (eval slot-name))
	 (sym (slot-boundp-symbol slot-name)))
    (if (not *optimize-slot-boundp*)
	`(slot-boundp-normal ,object ',slot-name)
	`(asv-funcall ,sym ,slot-name boundp ,object))))


(defun structure-slot-boundp (object)
  (declare (ignore object))
  t)

(defun make-structure-slot-boundp-function (slotd)
  (let* ((reader (slot-definition-internal-reader-function slotd))
	 (fun #'(lambda (object)
		  (not (eq (funcall reader object) *slot-unbound*)))))
    (declare (type function reader))
    #+(and kcl turbo-closure) (si:turbo-closure fun)
    fun))		    

(defun get-optimized-std-accessor-method-function (class slotd name)
  (if (structure-class-p class)
      (ecase name
	(reader (slot-definition-internal-reader-function slotd))
	(writer (slot-definition-internal-writer-function slotd))
	(boundp (make-structure-slot-boundp-function slotd)))
      (let* ((fsc-p (cond ((standard-class-p class) nil)
			  ((funcallable-standard-class-p class) t)
			  (t (error "~S is not a standard-class" class))))
	     (slot-name (slot-definition-name slotd))
	     (index (slot-definition-location slotd))
	     (function (ecase name
			 (reader #'make-optimized-std-reader-method-function)
			 (writer #'make-optimized-std-writer-method-function)
			 (boundp #'make-optimized-std-boundp-method-function)))
	     (value (funcall function fsc-p slot-name index)))
	(declare (type function function))
	(values value index))))

(defun make-optimized-std-reader-method-function (fsc-p slot-name index)
  (declare #.*optimize-speed*)
  (set-function-name
   (etypecase index
     (fixnum (if fsc-p
		 #'(lambda (instance)
		     (let ((value (%instance-ref (fsc-instance-slots instance) index)))
		       (if (eq value *slot-unbound*)
			   (slot-unbound (class-of instance) instance slot-name)
			   value)))
		 #'(lambda (instance)
		     (let ((value (%instance-ref (std-instance-slots instance) index)))
		       (if (eq value *slot-unbound*)
			   (slot-unbound (class-of instance) instance slot-name)
			   value)))))
     (cons   #'(lambda (instance)
		 (let ((value (cdr index)))
		   (if (eq value *slot-unbound*)
		       (slot-unbound (class-of instance) instance slot-name)
		       value)))))
   `(reader ,slot-name)))

(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
  (declare #.*optimize-speed*)
  (set-function-name
   (etypecase index
     (fixnum (if fsc-p
		 #'(lambda (nv instance)
		     (setf (%instance-ref (fsc-instance-slots instance) index) nv))
		 #'(lambda (nv instance)
		     (setf (%instance-ref (std-instance-slots instance) index) nv))))
     (cons   #'(lambda (nv instance)
		 (declare (ignore instance))
		 (setf (cdr index) nv))))
   `(writer ,slot-name)))

(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
  (declare #.*optimize-speed*)
  (set-function-name
   (etypecase index
     (fixnum (if fsc-p
		 #'(lambda (instance)
		     (not (eq *slot-unbound*
			      (%instance-ref (fsc-instance-slots instance) index))))
		 #'(lambda (instance)
		     (not (eq *slot-unbound* 
			      (%instance-ref (std-instance-slots instance) index))))))
     (cons   #'(lambda (instance)
		 (declare (ignore instance))
		 (not (eq *slot-unbound* (cdr index))))))
   `(boundp ,slot-name)))

(defun make-optimized-structure-slot-value-using-class-method-function (function)
  #+cmu (declare (type function function))
  #'(lambda (class object slotd)
      (let ((value (funcall function object)))
	(if (eq value *slot-unbound*)
	    (slot-unbound class object (slot-definition-name slotd))
	    value))))	    

(defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
  #+cmu (declare (type function function))
  #'(lambda (nv class object slotd)
      (declare (ignore class slotd))
      (funcall function nv object)))

(defun make-optimized-structure-slot-boundp-using-class-method-function (function)
  #+cmu (declare (type function function))
  #'(lambda (class object slotd)
      (declare (ignore class slotd))
      (not (eq (funcall function object) *slot-unbound*))))

(defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
  (if (structure-class-p class)
      (ecase name
	(reader (make-optimized-structure-slot-value-using-class-method-function
		 (slot-definition-internal-reader-function slotd)))
	(writer (make-optimized-structure-setf-slot-value-using-class-method-function
		 (slot-definition-internal-writer-function slotd)))
	(boundp (make-optimized-structure-slot-boundp-using-class-method-function
		 (slot-definition-internal-writer-function slotd))))
      (let* ((fsc-p (cond ((standard-class-p class) nil)
			  ((funcallable-standard-class-p class) t)
			  (t (error "~S is not a standard-class" class))))
	     (slot-name (slot-definition-name slotd))
	     (index (slot-definition-location slotd))
	     (function 
	      (ecase name
		(reader 
		 #'make-optimized-std-slot-value-using-class-method-function)
		(writer 
		 #'make-optimized-std-setf-slot-value-using-class-method-function)
		(boundp 
		 #'make-optimized-std-slot-boundp-using-class-method-function))))
	#+cmu (declare (type function function))
	(values (funcall function fsc-p slot-name index) index))))

(defun make-optimized-std-slot-value-using-class-method-function
    (fsc-p slot-name index)
  (declare #.*optimize-speed*)
  (etypecase index
    (fixnum (if fsc-p
		#'(lambda (class instance slotd)
		    (declare (ignore slotd))
		    (unless (fsc-instance-p instance) (error "not fsc"))
		    (let ((value (%instance-ref (fsc-instance-slots instance) index)))
		      (if (eq value *slot-unbound*)
			  (slot-unbound class instance slot-name)
			  value)))
		#'(lambda (class instance slotd)
		    (declare (ignore slotd))
		    (unless (std-instance-p instance) (error "not std"))
		    (let ((value (%instance-ref (std-instance-slots instance) index)))
		      (if (eq value *slot-unbound*)
			  (slot-unbound class instance slot-name)
			  value)))))
    (cons   #'(lambda (class instance slotd)
		(declare (ignore slotd))
		(let ((value (cdr index)))
		  (if (eq value *slot-unbound*)
		      (slot-unbound class instance slot-name)
		      value))))))

(defun make-optimized-std-setf-slot-value-using-class-method-function
    (fsc-p slot-name index)
  (declare #.*optimize-speed*)
  (declare (ignore slot-name))
  (etypecase index
    (fixnum (if fsc-p
		#'(lambda (nv class instance slotd)
		    (declare (ignore class slotd))
		    (setf (%instance-ref (fsc-instance-slots instance) index) nv))
		#'(lambda (nv class instance slotd)
		    (declare (ignore class slotd))
		    (setf (%instance-ref (std-instance-slots instance) index) nv))))
    (cons   #'(lambda (nv class instance slotd)
		(declare (ignore class instance slotd))
		(setf (cdr index) nv)))))

(defun make-optimized-std-slot-boundp-using-class-method-function
    (fsc-p slot-name index)
  (declare #.*optimize-speed*)
  (declare (ignore slot-name))
  (etypecase index
    (fixnum (if fsc-p
		#'(lambda (class instance slotd)
		    (declare (ignore class slotd))
		    (not (eq *slot-unbound* 
			     (%instance-ref (fsc-instance-slots instance) index))))
		#'(lambda (class instance slotd)
		    (declare (ignore class slotd))
		    (not (eq *slot-unbound* 
			     (%instance-ref (std-instance-slots instance) index))))))
    (cons   #'(lambda (class instance slotd)
		(declare (ignore class instance slotd))
		(not (eq *slot-unbound* (cdr index)))))))

(defun get-accessor-from-svuc-method-function (class slotd sdfun name)
  (macrolet ((emf-funcall (emf &rest args)
	       `(invoke-effective-method-function ,emf nil ,@args)))
    (set-function-name
     (case name
       (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
       (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
       (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
     `(,name ,(class-name class) ,(slot-definition-name slotd)))))

(defun make-internal-reader-method-function (class-name slot-name)
  (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
	 (make-method-function
	  (lambda (instance)
	    (let ((wrapper (get-instance-wrapper-or-nil instance)))
	      (if wrapper
		  (let* ((class (wrapper-class* wrapper))
			 (index (or (instance-slot-index wrapper slot-name)
				    (assq slot-name (wrapper-class-slots wrapper)))))
		    (typecase index
		      (fixnum 	
		       (let ((value (%instance-ref (get-slots instance) index)))
			 (if (eq value *slot-unbound*)
			     (slot-unbound (class-of instance) instance slot-name)
			     value)))
		      (cons
		       (let ((value (cdr index)))
			 (if (eq value *slot-unbound*)
			     (slot-unbound (class-of instance) instance slot-name)
			     value)))
		      (t
		       (error "The wrapper for class ~S does not have the slot ~S"
			      class slot-name))))
		  (slot-value instance slot-name)))))))


(defun make-std-reader-method-function (class-name slot-name)
  (let* ((pv-table-symbol (gensym))
	 (initargs (copy-tree
		    (make-method-function
		     (lambda (instance)
		       (pv-binding1 (.pv. .calls.
					  (symbol-value pv-table-symbol)
					  (instance) (instance-slots))
			 (instance-read-internal 
			  .pv. instance-slots 1
			  (slot-value instance slot-name))))))))
    (setf (getf (getf initargs ':plist) ':slot-name-lists)
	  (list (list nil slot-name)))
    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
    (list* ':method-spec `(reader-method ,class-name ,slot-name)
	   initargs)))

(defun make-std-writer-method-function (class-name slot-name)
  (let* ((pv-table-symbol (gensym))
	 (initargs (copy-tree
		    (make-method-function
		     (lambda (nv instance)
		       (pv-binding1 (.pv. .calls.
					  (symbol-value pv-table-symbol)
					  (instance) (instance-slots))
			 (instance-write-internal 
			  .pv. instance-slots 1 nv
			  (setf (slot-value instance slot-name) nv))))))))
    (setf (getf (getf initargs ':plist) ':slot-name-lists)
	  (list nil (list nil slot-name)))
    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
    (list* ':method-spec `(writer-method ,class-name ,slot-name)
	   initargs)))

(defun make-std-boundp-method-function (class-name slot-name)
  (let* ((pv-table-symbol (gensym))
	 (initargs (copy-tree
		    (make-method-function
		     (lambda (instance)
		       (pv-binding1 (.pv. .calls.
					  (symbol-value pv-table-symbol)
					  (instance) (instance-slots))
			  (instance-boundp-internal 
			   .pv. instance-slots 1
			   (slot-boundp instance slot-name))))))))
    (setf (getf (getf initargs ':plist) ':slot-name-lists)
	  (list (list nil slot-name)))
    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
    (list* ':method-spec `(boundp-method ,class-name ,slot-name)
	   initargs)))

(defun initialize-internal-slot-gfs (slot-name &optional type)
  (when (or (null type) (eq type 'reader))
    (let* ((name (slot-reader-symbol slot-name))
	   (gf (ensure-generic-function name)))
      (unless (generic-function-methods gf)
	(add-reader-method *the-class-slot-object* gf slot-name))))
  (when (or (null type) (eq type 'writer))
    (let* ((name (slot-writer-symbol slot-name))
	   (gf (ensure-generic-function name)))
      (unless (generic-function-methods gf)
	(add-writer-method *the-class-slot-object* gf slot-name))))
  (when (and *optimize-slot-boundp*
	     (or (null type) (eq type 'boundp)))
    (let* ((name (slot-boundp-symbol slot-name))
	   (gf (ensure-generic-function name)))
      (unless (generic-function-methods gf)
	(add-boundp-method *the-class-slot-object* gf slot-name))))
  nil)

(defun initialize-internal-slot-gfs* (readers writers boundps)
  (dolist (reader readers)
    (initialize-internal-slot-gfs reader 'reader))
  (dolist (writer writers)
    (initialize-internal-slot-gfs writer 'writer))
  (dolist (boundp boundps)
    (initialize-internal-slot-gfs boundp 'boundp)))
