;;; -*- 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-p (sym)
  (and (fboundp sym)
       (typep (symbol-function sym) 'microcode-function)))

(defvar *microcode-references*)
(defvar *microcode-file-references*)

(defun microcode-references ()
  (setq *microcode-references* nil)
  (setq *microcode-file-references* nil)
  (dolist (file *system-files*)
    (let ((printed nil)
	  (refs (remove-if #'(lambda(ref) (member ref *microcode-references*))
			   (or (get file :interesting-references)
			       (interesting-references file)))))
      (when refs
	(format t "~&*** ~A: ~~{~S ~S ~S ~S~&~}" file refs)
	(setq *microcode-references* (append refs *microcode-references*))
	(push (cons file refs) *microcode-file-references*)))))