pcl-env.lisp

[msch@ztivax.siemens.com (Matthias Schneider-Hufschmidt)]

This message is for LYRIC-PCL-users, who use pcl-env.lisp
on no-cute-name-pcl.

I keep having problems with the structure-editor when trying to
edit eql-specified methods. The reason for this seems to be that
the source code cannot be found by the editor.

Example:
(setf a (make-instance 'c2))

(defmethod foo ((par1 c1)(par2 (eql a)))
   <some_code>)

(ed 'foo) will not find the definition of this method since
in the methodobject the specializer-list is (c1 (eql #<c2_whatever>))
and the source code editor looks for a definition for
(foo (c1 (eql #<c2_whatever>))) via il:{get|has}def, while
the definiton of the method is stored under
(foo (c1 (eql a)))

Since I don't know about the internals of the editor I have made an
attempt to patch this behaviour in pcl-env.lisp. See below.
The idea is that whenever possible I store the definition under
(foo (c1 (eql #<c2_whatever>))) in the first place.

If anyone has a better solution I'd be glad to hear about it.

Here is my solution. I only inserted the two mapcars.

Matthias

;;; in File pcl-env.lisp

(defun full-method-name (method)
  "Return the full name of the method"
; this mapcar inserted
  (let ((specializers (mapcar #'(lambda (x) 
                                  (cond ((eq x 't) 't)
                                        ((and (listp x)(eq (car x) 'eql)) x)
                                        (T (class-name x))))
		       (method-type-specifiers method))))
    ;; Now go through some hair to make sure that specializer is
    ;; really right.  Once PCL returns the right value for
    ;; specializers this can be taken out.
    (let* ((arglist (method-arglist method))
	   (number-required (or (position-if
				  #'(lambda (x) (member x lambda-list-keywords))
				  arglist)
				(length arglist)))
	   (diff (- number-required (length specializers))))
      (when (> diff 0)
	(setq specializers (nconc (copy-list specializers)
				  (make-list diff :initial-element 't)))))
    (make-full-method-name (generic-function-name
			       (method-generic-function method))
			   (method-qualifiers method)
			   specializers)))

(defun make-full-method-name (generic-function-name qualifiers arg-types)
  "Return the full name of a method, given the generic-function name, the method
qualifiers, and the arg-types"
  ;; The name of the method is:
  ;;      (<generic-function-name> <qualifier-1> .. 
  ;; <arg-specializer-1>..)
  (labels ((remove-trailing-ts (l)
	     (if (null l)
		 nil
		 (let ((tail (remove-trailing-ts (cdr l))))
		   (if (null tail)
		       (if (eq (car l) 't)
			   nil
			   (list (car l)))
		       (if (eq l tail)
			   l
			   (cons (car l) tail)))))))
    `(,generic-function-name ,@qualifiers
; this mapcar inserted
      ,(remove-trailing-ts (mapcar #'(lambda (elem)
                                       (cond ((and (listp elem)
						   (eq (car elem) 'eql)
                                                   (boundp (cadr elem)))
                                              `(eql ,(eval (cadr elem))))
                                             (T elem)))
                                   arg-types)))))