;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10 -*-

(defvar *system-files*)

(defun system-files (&optional (system :system))
  (setq *system-files*
	(mapcar #'(lambda (file) (send file :generic-pathname))
		(si:system-source-files system si:*source-file-types*))))

(defun interesting-function-p (sym)
  (and sym (symbolp sym) (not (keywordp sym))
       (functionp sym)
       (fboundp sym)))

(defun definition-list (defs)
  (remove-if-not 'symbolp
		 (remove-if-not 'consp (mapcan 'identity defs))
		 :key 'car))

(defun interesting-definitions (file &optional
				(interesting-p 'interesting-function-p)
				(deftypes '(defun)))
  (let ((defs (definition-list (get file :definitions))))
    (setf (get file :interesting-definitions)
	  (mapcar 'car
		  (remove-if-not interesting-p
				 (remove-if-not #'(lambda (def)
						    (member (cdr def) deftypes))
						defs)
				 :key 'car)))))

(defun interesting-references (file &optional
			       (interesting-p 'interesting-function-p))
  (setf (get file :interesting-references)
	(coerce (remove-if-not interesting-p
			       (get file :foreign-objects-referenced))
		'list)))

(defun microcode-references ()
  (let (mic-refs)
    (dolist (file *system-files*)
      (let ((printed nil)
	    (refs (or (get file :interesting-references)
		      (interesting-references file))))
	(dolist (ref refs)
	  (when (and (typep (symbol-function ref) 'microcode-function)
	    (or printed
		(format t "~&*** ~A:" file)
		(setq printed t))
	    (format t " ~A," ref))))))