EQL specializers under Genera

[Richard Lamson <rsl@max-fleischer.ila-sf.dialnet.symbolics.com>]

The current PCL implementation for Genera doesn't handle EQL specializers
correctly.  The value of the constant against which to compare the
argument is never evaluated.  At first I tried fixing this by patching the
specializer parser to evaluate the object, but I realized that this has
problems getting the environment in which to call EVAL.  I adopted a mixed
strategy in which the special rewrite of methods continues (it still
expands to 

   (DEFUN (PCL:METHOD ,GF-NAME ,@QUALIFIERS ,SPECIALIZERS) ...)

but now it also has a call to LOAD-DEFMETHOD at load time; this call was
essentially cribbed from the portable copy of EXPAND-DEFMETHOD.

Here are the changes:

In BOOT.LISP:

1.  Make the Genera version of EXPAND-DEFMETHOD expand into DEFUN and a
    call to LOAD-DEFMETHOD.

2.  Remove the special declarations inserted into the method body in the
    Genera case; these were only needed because LOAD-DEFMETHOD was being
    called with a couple of arguments derived from these declarations (in
    EXPAND-DEFMETHOD-INTERNAL).

=================================================================
#+Genera
(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
  (when (listp name) (do-standard-defsetf-1 (cadr name)))
  (multiple-value-bind (fn-form specializers doc plist)
      (expand-defmethod-internal name qualifiers lambda-list body env)
    (let ((fn-args (cadadr fn-form))
	  (fn-body (cddadr fn-form))
	  (method-name `(method ,name ,@qualifiers ,specializers)))
      `(progn
	 (defun ,method-name ,fn-args
	   ,@fn-body)
	 (load-defmethod
	   ',(if proto-method
		 (class-name (class-of proto-method))
		 'standard-method)
	   ',name
	   ',qualifiers
	   (list ,@(mapcar #'(lambda (specializer)
			       (if (and (consp specializer)
					(eq (car specializer) 'eql))
				   ``(eql ,,(cadr specializer))
				   `',specializer))
			   specializers))
	   ',(specialized-lambda-list-lambda-list lambda-list)
	   ',doc
	   ',(getf plist :isl-cache-symbol)	;Paper over a bug in KCL by
						;passing the cache-symbol
						;here in addition to in the
						;plist.
	   ',plist
	   #',method-name)))))

(defun expand-defmethod-internal
       (generic-function-name qualifiers specialized-lambda-list body env)
  (declare (values fn-form specializers doc)
	   (ignore qualifiers))
  (when (listp generic-function-name)
    (do-standard-defsetf-1 (cadr generic-function-name)))
  (multiple-value-bind (documentation declarations real-body)
      (extract-declarations body)
    (multiple-value-bind (parameters lambda-list specializers)
	(parse-specialized-lambda-list specialized-lambda-list)

      
      (let* ((required-parameters
	       (mapcar #'(lambda (r s) (declare (ignore s)) r)
		       parameters
		       specializers))
	     (parameters-to-reference
	       (make-parameter-references specialized-lambda-list
					  required-parameters
					  declarations
					  generic-function-name
					  specializers))
	     (class-declarations 
	       `(declare
		  ,@(remove nil
			    (mapcar #'(lambda (a s) (and (symbolp s)
							 (neq s 't)
							 `(class ,a ,s)))
				    parameters
				    specializers))))
	     (method-lambda 
	       ;; Remove the documentation string and insert the
	       ;; appropriate class declarations.  The documentation
	       ;; string is removed to make it easy for us to insert
	       ;; new declarations later, they will just go after the
	       ;; cadr of the method lambda.  The class declarations
	       ;; are inserted to communicate the class of the method's
	       ;; arguments to the code walk.
	       (let ()
		 `(lambda ,lambda-list
		    ,class-declarations
		    ,@declarations
		    (progn ,@parameters-to-reference)
		    (block ,(if (listp generic-function-name)
				(cadr generic-function-name)
				generic-function-name)
		      ,@real-body))))

	     (call-next-method-p nil)   ;flag indicating that call-next-method
	                                ;should be in the method definition
	     (next-method-p-p nil)      ;flag indicating that next-method-p
                                        ;should be in the method definition
	     (save-original-args nil)   ;flag indicating whether or not the
				        ;original arguments to the method
					;must be preserved.  This happens
					;for two reasons:
	                                ; - the method takes &mumble args,
					;   so one of the lexical functions
					;   might be used in a default value
	                                ;   form
					; - call-next-method is used without
					;   arguments at least once in the
					;   body of the method
	     (original-args ())
	     (applyp nil)		;flag indicating whether or not the
					;method takes &mumble arguments. If
					;it does, it means call-next-method
					;without arguments must be APPLY'd
					;to original-args.  If this gets set
					;true, save-original-args is set so
					;as well
	     (aux-bindings ())		;Suffice to say that &aux is one of
					;damndest things to have put in a
					;language.
	     (slots (mapcar #'list required-parameters))
	     (plist ())
	     (walked-lambda nil))
	(flet ((walk-function (form context env)
		 (cond ((not (eq context ':eval)) form)
		       ((not (listp form)) form)
		       ((eq (car form) 'call-next-method)
			(setq call-next-method-p 't)
			(setq save-original-args (not (cdr form)))
			form)
		       ((eq (car form) 'next-method-p)
			(setq next-method-p-p 't)
			form)
		       ((and (eq (car form) 'function)
			     (cond ((eq (cadr form) 'call-next-method)
				    (setq call-next-method-p 't)
				    (setq save-original-args 't)
				    form)
				   ((eq (cadr form) 'next-method-p)
				    (setq next-method-p-p 't)
				    form)
				   (t nil))))
		       ((and (or (eq (car form) 'slot-value)
				 (eq (car form) 'set-slot-value))
			     (symbolp (cadr form))
			     (constantp (caddr form)))
			(let ((parameter
				(can-optimize-access (cadr form) required-parameters env)))
			  (if (null parameter)
			      form
			      (ecase (car form)
				(slot-value
				  (optimize-slot-value     slots parameter form))
				(set-slot-value
				  (optimize-set-slot-value slots parameter form))))))
		       (t form))))
	  
	  (setq walked-lambda (walk-form method-lambda env #'walk-function))

	  ;;
	  ;; Add &allow-other-keys to the lambda list as an interim
	  ;; way of implementing lambda list congruence rules.
	  ;;
	  (when (and (memq '&key lambda-list)
		     (not (memq '&allow-other-keys lambda-list)))
	    (let* ((rll (reverse lambda-list))
		   (aux (memq '&aux rll)))
	      (setq lambda-list
		    (if aux
			(progn (setf (cdr aux)
				     (cons '&allow-other-keys (cdr aux)))
			       (nreverse rll))
		        (nconc (nreverse rll) (list '&allow-other-keys))))))
	  ;; Scan the lambda list to determine whether this method
	  ;; takes &mumble arguments.  If it does, we set applyp and
	  ;; save-original-args true.
	  ;; 
	  ;; This is also the place where we construct the original
	  ;; arguments lambda list if there has to be one.
	  (dolist (p lambda-list)
	    (if (memq p lambda-list-keywords)
		(if (eq p '&aux)
		    (progn
		      (setq aux-bindings (cdr (memq '&aux lambda-list)))
		      (return nil))
		    (progn
		      (setq applyp t
			    save-original-args t)
		      (push '&rest original-args)
		      (push (make-symbol "AMPERSAND-ARGS") original-args)
		      (return nil)))
		(push (make-symbol (symbol-name p)) original-args)))
	  (setq original-args (if save-original-args
				  (nreverse original-args)
				  ()))
	  
	  (multiple-value-bind (ignore walked-declarations walked-lambda-body)
	      (extract-declarations (cddr walked-lambda))
	    (declare (ignore ignore))

	    
	    (when (some #'cdr slots)
	      (setq slots (slot-name-lists-from-slots slots))
	      (setq plist (list* :isl slots plist))
	      (setq walked-lambda-body (add-pv-binding walked-lambda-body
						       plist
						       required-parameters))
	      (dolist (dcl-stm walked-declarations)
		(dolist (dcl (cdr dcl-stm))
		  (when (eql (car dcl) 'ignore)
		    (setf (cdr dcl) (set-difference (cdr dcl) required-parameters))))))
	    (when (or next-method-p-p call-next-method-p)
	      (setq plist (list* :needs-next-methods-p 't plist)))

	    ;;; changes are here... (mt)
	    (let ((fn-body (if (or call-next-method-p next-method-p-p)
			      (add-lexical-functions-to-method-lambda
				walked-declarations
				walked-lambda-body
				`(lambda ,lambda-list
				   ,@walked-declarations
				   ,.walked-lambda-body)
				original-args
				lambda-list
				save-original-args
				applyp
				aux-bindings
				call-next-method-p
				next-method-p-p)
			      `(lambda ,lambda-list
				 ,@walked-declarations
				 ,.walked-lambda-body))))
;	      #+Genera
;	      (setq fn-body `(lambda ,(cadr fn-body)
;			       (declare (pcl-documentation ,documentation)
;					(pcl-plist ,plist))
;			       ,@(cddr fn-body)))
;
	      (values
		`(function ,fn-body)
		specializers
		documentation
		plist))))))))

=================================================================

In GENERA-LOW.LISP:

Remove the call to PCL-FDEFINE-HELPER and the one lexical variable bound
only for the call to it; this function is no longer in use and can be
removed.  You still need the function-spec handler and the hash table
because LOAD-DEFMETHOD is still called with #'(PCL:METHOD ...) at load
time.

=================================================================
(si:define-function-spec-handler method (op spec &optional arg1 arg2)
  (if (eq op 'sys:validate-function-spec)
      (and (let ((gspec (cadr spec)))
	     (or (symbolp gspec)
		 (and (listp gspec)
		      (eq (car gspec) 'setf)
		      (symbolp (cadr gspec))
		      (null (cddr gspec)))))
	   (let ((tail (cddr spec)))
	     (loop (cond ((null tail) (return nil))
			 ((listp (car tail)) (return t))
			 ((atom (pop tail)))			 
			 (t (return nil))))))
      (let ((table *method-htable*)
	    (key spec))
	(case op
	  ((si:fdefinedp si:fdefinition)
	   (car (gethash key table nil)))
	  (si:fundefine
	    (remhash key table))
	  (si:fdefine
	    (let ((old (gethash key table nil))
;		  (gspec (cadr spec))
		  (quals nil)
		  (specs nil)
		  (ptr (cddr spec)))
	      (setq specs
		    (loop (cond ((null ptr) (return nil))
				((listp (car ptr)) (return (car ptr)))
				(t (push (pop ptr) quals)))))
;	      (pcl-fdefine-helper gspec (nreverse quals) specs arg1)
	      (setf (gethash key table) (cons arg1 (cdr old)))))
	  (si:get
	    (let ((old (gethash key table nil)))
	      (getf (cdr old) arg1)))
	  (si:plist
	    (let ((old (gethash key table nil)))
	      (cdr old)))
	  (si:putprop
	    (let ((old (gethash key table nil)))
	      (unless old
		(setf old (cons nil nil))
		(setf (gethash key table) old))
	      (setf (getf (cdr old) arg2) arg1)))
	  (si:remprop
	    (let ((old (gethash key table nil)))
	      (when old
		(remf (cdr old) arg1))))
	  (otherwise
	    (si:function-spec-default-handler op spec arg1 arg2))))))
=================================================================