[Openmcl-devel] persistence of xref info in fasl files.

Alan Ruttenberg alanralanr at comcast.net
Sat Jan 3 20:29:53 UTC 2004

Here's an implementation. Gary, I don't really know which what the best 
place to put the hooks, so I've used advise where it seemed 
appropriate. Please feel free to fix or tell me how to.

I came across one issue when doing this.  If you have (defun foo () 
(flet ((bar ())) *baz*))
then you get a recorded xref from bar to *baz*. I think this should be 
foo to *baz* since bar isn't global. If you disagree with that policy 
the code needs to be reworked a bit.

The bit about (add-pre-xref-xrefs) is for bootstrapping.

BTW, what does "indirect calls" mean?


(in-package :ccl)

(defvar *compiling-xrefs*)
(defvar *clear-fasl-xrefs* nil)

(defun maybe-load-fasl-xrefs (function)
   (when (and (fboundp '%add-xref-entry)
	     (getf (%lfun-info function) :xrefs))
       (add-fasl-xrefs (getf (%lfun-info function) :xrefs)))
   (when (and *clear-fasl-xrefs* function (getf (%lfun-info function) 
     (clear-fasl-xref-info function)))

(defun %add-xref-entry (relation name1 name2)
   (when (and *record-xref-info* relation name1 name2)
     (if (boundp '*compiling-xrefs*)
       (push (list relation name1 name2) *compiling-xrefs*))
     (pushnew (make-xref-entry name2 relation)
	     (gethash name1 (%xref-table relation nil))
	     :test #'xref-entry-equal)
     (pushnew (make-xref-entry name1 relation)
	     (gethash name2 (%xref-table relation t))
	     :test #'xref-entry-equal)

(defun xrefs-for-fasl (name xrefs)
   (let ((table nil))
     (loop for (relation name1 name2) in xrefs
	  when (symbolp name2) ;; should track down why this isn't always 
true. But it isn't.
	  (pushnew name2 (getf table relation))
	  (identity name1)
	  '(if (null name) (setq name name1) (assert (eq name name1)))
     (loop for spot on table
	  when (listp (car spot))
	  do (setf (car spot) (coerce (cons name (car spot)) 'vector)))
     (if table (coerce table 'vector))))

(defun add-fasl-xrefs (xrefs)
   (loop for (relation refs) on (coerce xrefs 'list) by #'cddr
	for (name1 . name2s) = (coerce refs 'list)
	do (dolist (name2 name2s) (%add-xref-entry relation name1 name2))))

(defun clear-fasl-xref-info (function)
   (let ((found (member :xrefs (%lfun-info function))))
     (when found
       (setf (second found) nil))))

(defun add-pre-xref-xrefs ()
      (when (and (plistp (%lfun-info f)) (getf (%lfun-info f) :xrefs))
        (add-fasl-xrefs (getf (%lfun-info f) :xrefs))
        (when *clear-fasl-xrefs* (clear-fasl-xref-info f))))))

(defun clear-all-fasl-xref-info ()
      (when (and (plistp (%lfun-info f)) (getf (%lfun-info f) :xrefs))
        (clear-fasl-xref-info f)))))

(advise compile-named-function
	  (if *compile-file-pathname*
	    (let ((*compiling-xrefs* nil))
	      (multiple-value-bind (lfun warnings) (:do-it)
		(when (and lfun *compiling-xrefs*)
		  (nconc (%lfun-info lfun) (list :xrefs (xrefs-for-fasl (second 
arglist) *compiling-xrefs*))))
		(values lfun warnings)
	:when :around
	:name :xref)

(advise %defun
	(maybe-load-fasl-xrefs (car arglist))
	:when :after
	:name :xref)

(advise %macro
	(maybe-load-fasl-xrefs (car arglist))
	:when :after
	:name :xref)

-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: text/enriched
Size: 3350 bytes
Desc: not available
URL: <http://lists.clozure.com/pipermail/openmcl-devel/attachments/20040103/f99eedd9/attachment.bin>

More information about the Openmcl-devel mailing list