Re: edit-definitions-lisp breakage under lispworks

>>>>> Alain Picard writes:

ap> But I'd hold on on patching lispworks.lisp --- I and
ap> a colleague have found a better solution (by reverse engineering
ap> the DSPEC package), so I'll post a better patch soon.  I'm sure
ap> no one minds waiting.  :-)

Okay.

With some digging, and a hint from Dave Fox at Xanalys,
I came up with this, which is a better patch.  It's still by
no means perfect, and I now get regexp overflow errors when
doing next-caller operations, so I think ilisp is buggy.
(i.e. the problem is not in lispworks.lisp anymore).

The key to this patch is to use dspec:*dspec-classes*
and dspec:find-dspec-locations.

Anyway, it improves things somewhat for us lispworks/ilisp users.

Cheers,

This patch is against the following file:

;;; $Id: lispworks.lisp,v 1.6 2002/01/24 19:54:14 anisotropy9 Exp $

which I got on the 5.12.0 branch.

================================================================
19c19
< ;;; $Id: lispworks.lisp,v 1.6 2002/01/24 19:54:14 anisotropy9 Exp $
---
> ;;; $Id: lispworks.lisp,v 1.4 2002/06/06 08:04:04 kooks Exp $
79c79,83
< 	  
---
> 
> 
> 
> ;; LispWorks returns, at least, 3 different forms from hcl:who-calls
> 
83,85c87,91
< 	     (if (atom form)
< 		 form
< 		 (top-level-caller (second form)))))
---
> 	     (cond ((atom form) form)
> 		   ;; For method form
> 		   ((eq (first form) 'method) (second form))
> 		   ;; For subfunction form
> 		   (t (top-level-caller (third form))))))
97,118d102
< (defconstant *source-type-translations*
<   '(
<     ("class"     defclass)
<     ("function"  )
<     ("macro"     )
<     ("structure" defstruct)
<     ("setf"      defsetf)
<     ("type"      deftype)
<     ("variable"  defvar defparameter defconstant)
<     ))
< 
< 
< (defun translate-source-type-to-dspec (symbol type)
<   (let ((entry (find type *source-type-translations*
< 		     :key 'first :test 'equal)))
<     (if entry
< 	(let ((wrappers (rest entry)))
< 	  (if wrappers
< 	      (loop for wrap in wrappers collecting `(,wrap ,symbol))
< 	      `(,symbol)))
< 	(error "unknown source type for ~S requested from ILISP: ~S"
< 	       symbol type))))
119a104,117
> ;; Use dspec:*dspec-classes*
> ;; LispWorks4.2
> (defconstant *ilisp->lispworks-type-mappings*
>   '(("class" SQL:DEF-VIEW-CLASS CL:DEFCLASS)
>     ("macro" CL:DEFMACRO)
>     ("setf"  CL:FUNCTION)))
> 
> (defun ilisp->lispworks-types (type)
>   (if (string-equal type "any")
>       dspec:*dspec-classes*
>       (let ((mapping (assoc type *ilisp->lispworks-type-mappings* :test 'string-equal)))
> 	(if mapping
> 	    (cdr mapping)
> 	    (list (ilisp-find-symbol type "CL"))))))
120a119
> ;; Use dspec:find-name-locations and system:underlying-setf-name
126,147c125,141
<    (let* ((symbol (ilisp-find-symbol symbol package))
< 	  (all (equal type "any"))
< 	  ;; Note:
< 	  ;; 19990806 Marco Antoniotti
< 	  ;;
< 	  ;; (paths (when symbol (compiler::find-source-file symbol)))
< 	  (paths (when symbol (dspec:find-dspec-locations symbol)))
< 	  (dspecs (or all (translate-source-type-to-dspec symbol type)))
< 	  (cands ())
< 	  )
<      (if (and paths (not all))
< 	 (setq cands
< 	       (loop for path in paths
< 		     when (find (car path) dspecs :test 'equal)
< 		     collect path))
<        (setq cands paths))
<      (if cands
< 	 (progn
< 	   (dolist (file (remove-duplicates paths
< 					    :key #'cdr :test #'equal))
< 	     (print (truename (cadr file))))
< 	   t)
---
>    (let ((symbol (ilisp-find-symbol symbol package))
> 	 (processed-pathnames ())
> 	 (types (ilisp->lispworks-types type)))
>      (flet ((process-symbol (symbol)
> 	      (loop for (ignore pathname) in (dspec:find-name-locations types symbol)
> 		    when (and (pathnamep pathname)
> 			      (not (member pathname processed-pathnames :test #'equal)))
> 		    do (print (truename pathname))
> 		    (push pathname processed-pathnames))))
>        (process-symbol symbol)
> 
>        ;; Process setf
>        (when (or (string-equal type "any")
> 		 (string-equal type "setf"))
> 	 (process-symbol (system:underlying-setf-name (list 'setf symbol)))))
>      (if processed-pathnames
> 	 t
================================================================
--
			Alain Picard
			Memetrics

_______________________________________________________________

Sponsored by:
ThinkGeek at http://www.ThinkGeek.com/