;;; -*- Mode: Lisp; Package: User -*-
;;;  (c) copyright 2002 by John Wiseman (jjwiseman@yahoo.com)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(export 'ccl::stream-finish-output :ccl)

(defpackage :clim-mop
  #-openmcl-partial-mop
  (:use :common-lisp)
  #+openmcl-partial-mop
  (:use :openmcl-mop)
  #+openmcl-partial-mop
  (:import-from :ccl #:class-name #:eql-specializer)
  #-openmcl-partial-mop
  (:import-from :ccl #:class-prototype #:class-precedence-list
		#:class-direct-superclasses #:generic-function-methods
		#:method-specializers #:compute-applicable-methods
		#:funcallable-standard-class #:slot-definition-name)
  #-openmcl-partial-mop
  (:export #:validate-superclass #:class-finalized-p
	   #:finalize-inheritance ccl::class-prototype
	   ccl::class-precedence-list ccl::class-direct-superclasses
	   ccl::generic-function-methods ccl::method-specializers
	   ccl::compute-applicable-methods
	   ccl::funcallable-standard-class
	   #:slot-definition-name
	   #:eql-specializer
	   #:eql-specializer-object
	   #:intern-eql-specializer
	   ccl::ensure-class
	   #:compute-applicable-methods-using-classes
	   #:extract-specializer-names #:extract-lambda-list
	   #:class-slots))

#+openmcl-partial-mop
(eval-when (:compile-toplevel :load-toplevel :execute)
  (loop for sym being the symbols of :clim-mop
	do (export sym :clim-mop)))

#-openmcl-partial-mop
(in-package :clim-mop)

#-openmcl-partial-mop
(progn
  (defmethod validate-superclass (a b)
	T)

  (defmethod class-finalized-p (c)
	T)

  (defmethod finalize-inheritance (c)
	(values))

  ;; MCL's eql-specializer-objects are just lists whose car is eql.

  (defun eql-specializer-p (spec)
	(and (consp spec) (eq (car spec) 'eql)))

  (deftype eql-specializer () '(satisfies eql-specializer-p))

  (defun eql-specializer-object (spec)
	(cadr spec))

;;; Pretty bogus, but should suit our purposes, whatever they are.

  (defparameter *eql-specializer-hash* (make-hash-table))

  (defun intern-eql-specializer (object)
	(let ((eql-object (gethash object *eql-specializer-hash* nil)))
	  (unless eql-object
		(setq eql-object (cons 'eql object))
		(setf (gethash object *eql-specializer-hash*) eql-object))
	  eql-object))

  (defun ensure-class (name &rest all-keys &key name metaclass direct-superclasses
							&allow-other-keys)
	(let ((metaclass-options (copy-list all-keys)))
	  (remf metaclass-options :name)
	  (remf metaclass-options :metaclass)
	  (remf metaclass-options :direct-superclasses)
	  (ccl::%defclass name direct-superclasses '() '() nil '()
					  metaclass :metaclass-opts metaclass-options)))

  (defun extract-specializer-names (lambda-list)
	(loop for var in lambda-list
		  until (member var lambda-list-keywords :test #'eq)
		  collect (if (consp var)
					  (cadr var)
					t)))

  (defun extract-lambda-list (lambda-list)
	(loop for tail on lambda-list
		  for (var) = tail
		  until (member var lambda-list-keywords :test #'eq)
		  collect (if (consp var)
					  (car var)
					var)
		  into required
		  finally (return (nconc required tail))))

  (defmethod class-slots ((class standard-class))
	(append (ccl::class-instance-slots class) (ccl::class-class-slots class)))
  )										; #-openmcl-partial-mop

(defpackage :clim-lisp-patch
  (:use)
  (:export #:defclass))

(defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table))
 
(defun clim-lisp-patch::compile-time-clos-class-p (name)
  (gethash name clim-lisp-patch::*compile-time-clos-names* nil))

(defmacro clim-lisp-patch:defclass (name &rest args)
  `(progn
     (eval-when (:compile-toplevel)
       (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t))
     (eval-when (:compile-toplevel :load-toplevel :execute)
       (cl:defclass ,name ,@args))))

	 
  
#-openmcl-partial-mop
(in-package :ccl)
#-openmcl-partial-mop
(let ((*warn-if-redefine-kernel* NIL))
(defun %defclass (class-name superclasses instance-slotds class-slotds doc
		  default-initargs metaclass
		  &key primary-p metaclass-opts)
	  (if (null superclasses)
		  (setq superclasses (list 'standard-object))
		(setq superclasses (copy-list superclasses)))
	  (if (null metaclass)
		  (setq metaclass *standard-class-class*))
	  (if (symbolp metaclass) (setq metaclass (find-class metaclass)))
	  (unless (subclassp metaclass *std-class-class*)
		(error "~s is not a subclass of ~s" metaclass *std-class-class*))
	  (let* ((old-class (find-class class-name nil))
			 (class (or old-class
						(let* ((c (if (or (eq metaclass *standard-class-class*)
										  (eq metaclass *funcallable-standard-class-class*))
									  (%cons-standard-class class-name (%class-own-wrapper metaclass))
									(apply #'make-instance metaclass :name class-name metaclass-opts))))
						  (setf (%class-ctype c) (make-class-ctype c))
						  c))))
		(when (eq class *standard-object-class*)
		  (error "Cannot redefine ~S" class))
		(unless (eq (class-of class) metaclass)
		  (cerror (format nil "(~s '~s '~s)" 'change-class class metaclass)
				  "~s is not an instance of ~s" class metaclass)
		  (change-class class metaclass)) ; (s)he asked for it.
		(setf (find-class class-name) class)
		(labels ((obsolete (class)
						   (dolist (sub (%class-subclasses class)) (obsolete sub))
										;Need to save old class info in wrapper for obsolete instance access...
						   (setf (%class-cpl class) nil)
						   (make-instances-obsolete class)))
		  (without-interrupts
		   (obsolete class)
		   (dolist (sup (%class-local-supers class))
			 (if (typep sup 'class)	; might be a symbol from earlier forward ref
				 (setf (%class-subclasses sup) (nremove class (%class-subclasses sup)))))
		   (setf (%class-local-supers class) superclasses)
		   (setf (%class-local-instance-slotds class) instance-slotds)
		   (setf (%old-class-local-shared-slotds class)
				 (%class-local-shared-slotds class))
		   (setf (%class-local-shared-slotds class) class-slotds)
		   (setf (%class-local-default-initargs class) default-initargs)))
		(setf (%class-primary-p class) primary-p)
		(when doc (setf (documentation class 'type) doc))
		(record-source-file class-name 'class)
		(initialize-class class t)
		class)))

;;; Fake compute-applicable-methods-using-classes, for the Show
;;; Applicable Methods command in the listener.

#+openmcl-partial-mop
(in-package :ccl)
#+openmcl-partial-mop
(progn
  (defgeneric compute-applicable-methods-using-classes (gf args))
  (defmethod compute-applicable-methods-using-classes
      ((gf standard-generic-function) args)
    (let* ((methods (%gf-methods gf))
	   (args-length (length args))
	   (bits (inner-lfun-bits gf))
	   arg-count res)
      (when methods
	(setq arg-count (length (%method-specializers (car methods))))
	(unless (<= arg-count args-length)
	  (error "Too few args to ~s" gf))
	(unless (or (logbitp $lfbits-rest-bit bits)
		    (logbitp $lfbits-restv-bit bits)
		    (logbitp $lfbits-keys-bit bits)
		    (<= args-length 
			(+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
	  (error "Too many args to ~s" gf))
	(let ((cpls (make-list arg-count)))
	  (declare (dynamic-extent cpls))
	  (do* ((args-tail args (cdr args-tail))
		(cpls-tail cpls (cdr cpls-tail)))
	       ((null cpls-tail))
	    (setf (car cpls-tail)
		  (%class-precedence-list (car args-tail))))
	  (dolist (m methods)
	    (when (find-if #'(lambda (spec)
			       (typep spec 'eql-specializer))
			   (%method-specializers m))
	      (return-from compute-applicable-methods-using-classes
		(values nil nil)))
	    (if (%method-applicable-p m args cpls)
		(push m res)))
	  (values (sort-methods res cpls (%gf-precedence-list gf)) t))))))
