Re: 8/2/88 PCL and Allegro 3.0

[Gregor.pa@Xerox.COM]

    Date: Thu, 04 Aug 88 14:33:18 PDT
    From: franz!frisky!jkf@ucbarpa.Berkeley.EDU (John Foderaro)

    The problem with 8/2/88 pcl is that 

       (make-specializable 'describe)

    is being eval'ed twice: once when compiling high.cl and once when
    loading high.cl

Yes, this is true.  Its kind of unfortunate that this doesn't work in
ExCL since having a generic function as the method function of a method
is perfectly legal in CLOS.  When we get a chance, we should fix this.

But, it doesn't make sense for make-specializable to make the same thing
specializable twice.  I have modified make-specializable to not touch
the function if it is already generic.

I changed the version that is already on arisia, and have included a
patch in this message.  Anyone running 8/2/88 should make this change.

;from methods.lisp
(defun make-specializable (function-name &key (arglist nil arglistp))
  (cond ((not (null arglistp)))
	((not (fboundp function-name)))
	((fboundp 'function-arglist)
	 ;; function-arglist exists, get the arglist from it.
	 (setq arglist (function-arglist function-name)))
	(t
	 (error
	   "The :arglist argument to make-specializable was not supplied~%~
            and there is no version of FUNCTION-ARGLIST defined for this~%~
            port of Portable CommonLoops.~%~
            You must either define a version of FUNCTION-ARGLIST (which~%~
            should be easy), and send it off to the Portable CommonLoops~%~
            people or you should call make-specializable again with the~%~
            :arglist keyword to specify the arglist.")))
  (let ((original (and (fboundp function-name)
		       (symbol-function function-name)))
	(generic-function (make-instance 'standard-generic-function
					 :name function-name))
	(nrequireds 0))
    (if (generic-function-p original)
	original
	(progn
	  (dolist (arg arglist)
	    (if (memq arg lambda-list-keywords)
		(return)
		(incf nrequireds)))
	  (setf (symbol-function function-name) generic-function)
	  (when arglistp
	    (setf (generic-function-pretty-arglist generic-function) arglist))
	  (when original
	    (add-named-method function-name
			      ()
			      (make-list nrequireds :initial-element 't)
			      arglist
			      original))
	  generic-function))))
-------