;;; -*- Mode:Common-Lisp; Package:Doc; Base:10; Fonts:(CPTFONT HL12 HL12BI CPTFONTB) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1987-1989 Texas Instruments Incorporated. All rights reserved.


Ï1;;;Ï*	Ï2Cross-reference and documentation utility.

Ï1;Version:
;  7/22/87 DNG - Original.
;  7/31/87 DNG - Fix Ï*Ï*document-flavorÏ1 for methods whose definition is a symbol.
;  8/24/87 DNG - Modify Ï*document-functionÏ1 to avoid error trap in Ï*arglistÏ1 on undefined symbol.
;  8/26/87 DNG - Update Ï*document-files-internalÏ1 to read the file when the 
;Ï*		Ï1needed information is not on the generic pathname plist.
;  9/10/87 DNG - Fix Ï*document Ï1so that references to a symbol as a constant are 
;Ï*		Ï1not limited to the symbol's own package.  Also don't ask to scan the keyword package.
;  9/11/87 DNG - Update Ï*document-variableÏ1 to not use octal for variable values 
;Ï*		Ï1less than 8 and to fix alias detection.
;  9/15/87 DNG - Enhanced Ï*document-flavorÏ1 to show the dependent and depended on flavors.
;  9/21/87 DNG - Enhanced Ï*document-flavorÏ1 to show the instance variables and required flavors.
;  10/6/87 DNG - Fix Ï*DOCUMENT-FILES-INTERNALÏ1 to not be fooled by a 
;Ï*		:DEFINITIONSÏ1 property that only lists functions that have been patched.
; 10/16/87 DNG - Cleaned up Ï*build-xref-table-from-systemÏ1 .
; 11/11/87 DNG - Use Ï*:no-reload-system-declarationÏ1 option in Ï*make-systemÏ1 calls.
;Ï*		Ï1Identify as a "macro" a symbol whose function definition is a symbol whose 
;Ï*		Ï1definition is a macro.  Avoid trapping when definition cell holds Ï*nil.
Ï1; 12/02/87 DNG - New function Ï*map-definitions-in-fileÏ1 separated out of Ï*document-files-internalÏ1 .
;  1/29/88 DNG - Fix Ï*map-definitions-in-fileÏ1 to look for Ï*global:defconstÏ1 instead of Ï*doc:defconstÏ1.
;  2/08/88 DNG - Fix Ï*document-files-internalÏ1 to not scan files more than once.
;  2/24/88 DNG - Update Ï*doc:system-filesÏ1 to use new function Ï*sys:system-filesÏ1 .
;  3/04/88 DNG - Moved the old version of Ï*system-filesÏ1 to a separate file.Ï*
;Ï1 5/24/88 CLM  - Fixed Ï*MAP-DEFINITIONS-IN-FILE Ï1to pass correct argument to FIND-PACKAGE.Ï*
;Ï1                     Trouble occurred when package was a list (spr 8146).Ï*
;Ï1 7/11/88 CLM - 1) Fixed DOCUMENT-FUNCTION to prevent going into the debugger when the functionÏ*
;Ï1                     is undefined.  Don't call SI:DWIMIFY-PACKAGE, instead use the guts to either get the Ï*
;Ï1                     function or print a msg if undefined.  2) Bound COMPILER:WARN-ON-ERRORS to T inÏ*
;Ï1                     DOCUMENT-SYSTEM.  Since this is the default value, this binding is overkill, but if the Ï*
;Ï1                     user should happen to reset the variable to NIL, he could wind up in the debugger.  We Ï*
;Ï1                     want to prevent this if at all possible.  3)  Bound COMPILER:WARN-ON-ERRORS to TÏ*
;Ï1                     in DOCUMENT and DOCUMENT-FILE for reasons cited above.Ï*  (spr 8277)
Ï1;  8/04/88 DNG - Fix Ï*DOCUMENTÏ1 to invoke Ï*DOCUMENT-FUNCTIONÏ1 for sub-primitives.
;  8/12/88 DNG - Fix Ï*build-xref-table-from-systemÏ1 to use Ï*sys:system-filesÏ1 
;Ï*		Ï1instead of Ï*make-systemÏ1. [SPR 7936]
;Ï*	Ï1-- The following changes are for release 6.  --
; 12/23/88 DNG - Update Ï*FUNCTION-SPEC-LESSPÏ1 for CLOS.  Update 
;;Ï*		document-instance-variableÏ1 to show references to its name.  Update 
;;Ï*		document-functionÏ1 to recognize CLOS generic functions.  Added new function Ï*document-classÏ1 .
;;  1/09/89 DNG - More features for Ï*document-classÏ1 .Ï2  Ï*Added no-query option to Ï*document.
Ï1;;  1/13/89 DNG - More updates to Ï*document-classÏ1 and to Ï*document-function Ï1for generic functions.
;;  1/16/89 DNG - New function Ï*document-slotÏ1 .
;;  1/20/89 DNG - Add support for mousable items when writing to Zmacs type-out window.
;;  1/25/89 DNG - Update Ï*document-function Ï1to recognize structure accessors, constructors, and predicates.
;;  1/27/89 DNG - Have Ï*document Ï1bind Ï**line-length* Ï1to the width of the window.
;;  1/31/89 DNG - Update Ï*documentÏ1 to find Ï*setf Ï1and Ï*locfÏ1 functions on symbol plist.
;;  2/03/89 DNG - Fix Ï*non-trivial-function-pÏ1 to return true for functions 
;;Ï*		Ï1which are very short but call another function, and to return Ï*nilÏ1 for 
;;Ï*		ticlos::dispatch-errorÏ1 and Ï*si::xr-bq-appendÏ1 .
;;  2/18/89 DNG - Fix Ï*document-flavorÏ1 to not error on sorting method named by a symbol.
;;  2/22/89 DNG - Update Ï*document Ï1and Ï*document-keywordÏ1 to show flavors which define a method for the keyword.
;;  2/27/89 DNG - Update Ï*document-functionÏ1 to recognize Ï*defstruct Ï1copier and alterant functions.
;;  3/06/89 DNG - Fix Ï*document-flavorÏ1 to show Ï*:INCLUDED-FLAVORSÏ1 as well as component flavors.
;;Ï*		Ï1Update Ï*map-definitions-in-fileÏ1 to recognize Ï*defgenericÏ1, Ï*defclassÏ1, and Ï*add-methodÏ1. 
;;  3/08/89 DNG - Update Ï*document-functionÏ1 to enable mousing on the method specializers of generic functions.
;;  4/13/89 DNG - Updated Ï*document-functionÏ1 to show optimizers. 
;;  4/20/89 DNG - Updated Ï*document-functionÏ1 to show "superseded by".
;;  5/06/89 DNG - Improve handling of hybrid classes.Ï*

(proclaim '(special *line-length*))

(defun Ï3documentÏ* (object &optional output-file (format :text) no-query)
  Ï2"Write documentation for an object.
The Ï3OBJECTÏ* may be a symbol, function, function spec, pathname, package, class,
or a string which names a system, package, or file.
Writes to Ï3OUTPUT-FILEÏ* if specified, else Ï3*STANDARD-OUTPUT*.
FORMATÏ* should be one of Ï3:TEXT, :PDWSÏ*, Ï3:SCRIBEÏ*, or Ï3:LATEXÏ*."Ï*
    (when output-file
      (return-from document
	(with-open-file (*standard-output* (text-pathname output-file) :direction :output)
	  (document object nil format no-query)
	  (truename *standard-output*))))
  (let ((compiler:warn-on-errors t)  ;Ï1;clm 7/11/88Ï*
	(*line-length* (if (closurep *standard-output*) Ï1; dribble fileÏ*
			   *line-length*
			 (- (line-length *standard-output* (+ *line-length* 3)) 3))))
    (cond ((symbolp object)
	   (let ((symbol object)
		 (functions nil) (variables nil) (flavors nil)
		 (types nil) (constants nil))
	     (when (or (and (boundp symbol) (not (keywordp symbol)))
		       (get symbol 'special)
		       (get-item symbol :variable nil)
		       (get-item symbol :instance-variable nil)
		       (get-item symbol :slot nil))
	       (push symbol variables))
	     (if (get symbol 'si:flavor)
		 (progn (push symbol flavors)
			(when (and (fboundp 'ticlos:find-class)
				   (typep (ticlos:find-class symbol nil)
					  'ticlos:hybrid-class))
			  (push symbol types)))
	       (when (si:type-specifier-p symbol)
		 (push symbol types)))
	     (loop for (prop value) on (symbol-plist symbol) by #'cddr
		   do (cond ((and (not (symbolp value))
				  (functionp value t))
			     (push `(:property ,symbol ,prop) functions))
			    ((and (consp value)
				  (consp (car value))
				  (consp (cdr (car value)))
				  (eq symbol (second (car value)))
				  (si:validate-function-spec (car value)))
			     (let ((defn (si:fdefinition-safe (car value) nil)))
			       (when (and defn (member defn (cdr value) :test #'eq))
				 Ï1;; here for Ï*setfÏ1 and Ï*locfÏ1 functionsÏ*
				 (push (car value) functions))))
			    ))
	     (when (or (fboundp symbol)
		       (get-item symbol :function nil)
		       (getl symbol '(compiler:p1 compiler:p2 compiler:opcode)) Ï1; DNG 8/4/88Ï*
		       (listp (get symbol 'arglist :default))Ï1 ; DNG 4/24/89Ï*
		       )
	       (push symbol functions))
	     (unless (or variables (member symbol functions :test #'eq))
	       (when (or (get-item symbol :constant nil)
			 (and (keywordp symbol) (get-item symbol :method nil)))
		 (push symbol constants)))
	     (if (or functions variables types flavors constants)
		 (let ((pkg (symbol-package symbol))
		       (*formatter* (format-function format)))
		   (when (and pkg
			      (not (member pkg *packages-processed* :test #'eq))
			      (not (eq pkg *keyword-package*))
			      (not no-query)
			      (yes-or-no-p "Build cross-reference table for package ~A?"
					   (package-name pkg)))
		     (build-xref-table-from-package pkg))
		   (write-attributes)
		   (send *formatter* :begin-document "symbol" (symbol-name symbol) symbol)
		   (document-stuff nil functions variables types flavors t constants)
		   (send *formatter* :end-document) )
		 (describe symbol))
	     (values)))				; end symbol
	  ((or (functionp object t)
	       (si:validate-function-spec object))
	   (let ((*formatter* (format-function format)))
	     (document-function object :no-query no-query)))
	  ((and (stringp object)
		(si:get-system-version object))
	   (document-system object nil format))
	  ((or (packagep object)
	       (and (stringp object) (find-package object)))
	   (document-package object nil format))
	  ((or (pathnamep object)
	       (and (stringp object) (ignore-errors (pathname object))))
	   ;;(calls-who object)
	   (document-file object nil format))
	  ((locally (declare (notinline sys:classp))
		    (and (fboundp 'sys:classp)
			 (sys:classp object)))
	   (document-class object t))
	  (t (let ((*print-length* 20) (*print-level* 4))
	       (describe object))))))

(unless (fboundp 'ticlos:generic-function-p)
  (setf (symbol-function 'ticlos:generic-function-p) #'ignore))

(defun Ï3document-functionÏ* (function &key package no-query (filter #'non-trivial-function-p))
  "Print information about a function.
Tells where it is defined, who calls it, what it calls, what special variables
it uses, and shows the documentation string.
  :PACKAGE tells where to look for references, defaults to the function name's package.
  :FILTER is a predicate which decides whether a function or macro reference should be mentioned."
  (declare (unspecial package))
  (let ((functions nil)
	(variables nil)
	(ivars nil)
	(slots nil)
	(keywords nil)
	(macros nil)
	(name (if (symbolp function) function (function-name function)))
	(generic nil)
	defn defn2)
    (setq defn (if (si:validate-function-spec function)
		   (if (and (symbolp function)
			    (not (fboundp function))
			    (getl function '(compiler:p1 compiler:p2 compiler:opcode arglist)))
		       nil ; sub-primitive understood by compiler only
		     (if (and (not (fdefinedp function))
			      (get-item name :function nil)) Ï1; undefined but referencedÏ*
			 nil
		       ;;7/11/88 clm - handle undefined functions
		       (let (x tem
			     (def-decoder (GET 'fdefinedp 'si:dwimify)) )
			 (setq x 
			       (COND ((AND (FUNCALL (FIRST def-decoder) function)    ;; SHOULD BE FDEFINITION-SAFE
					   (FUNCALL (SECOND def-decoder) function))
				      function)
				     ((setq tem (si:dwimify-package-0 function 'fdefinedp))
				      tem)) )
			 (when (null x)
			   (format *error-output* "~&~S is not the name of a function." function)
			   (return-from document-function (values)))
			 (unless (eq x function)
			   (setq name x function x))
			 (si:fdefinition-safe x t))))
		   function))
    (when (eq (car-safe name) ':handler)
      (setq name (function-name defn)))
    (unless (null defn)
     (setq defn2 (if (and (symbolp defn) (fboundp defn))
		     (symbol-function defn)
		   defn))
     (flet ((collector (caller callee how)
		(declare (ignore caller))
		(case how
		  (:function (when (funcall filter callee)
			       (pushnew callee functions :test #'equal)))
		  (:macro    (when (funcall filter callee)
			       (pushnew callee macros :test #'equal)))
		  (:variable (unless (constantp callee)
			       (pushnew callee variables :test #'equal)))
		  (:constant (when (keywordp callee)
			       (pushnew callee keywords :test #'eq)))
		  (:instance-variable (pushnew callee ivars :test #'eq))
		  (:slot (pushnew callee slots :test #'eq))
		  )
		(values))
	     )
       (FIND-THINGS-USED-BY-FUNCTION name defn #'collector)))
    (multiple-value-bind (args values)
	(if (and defn ; sub-primitives won't have a definition
		 (not (and (symbolp defn) (not (fboundp defn))))) ; avoid error trap in ARGLIST
	    (arglist function)
	  (get name 'arglist t))
      (let ((pkg (or (and package (pkg-find-package package))
		     (function-spec-package name))))
	(when (and pkg
		   (symbolp name) ; wouldn't help otherwise
		   (not (member pkg *packages-processed* :test #'eq))
		   defn
		   (not no-query)
		   (yes-or-no-p "Build cross-reference table for package ~A?" (package-name pkg)))
	  (build-xref-table-from-package pkg)))
      (print-header-line name
			 (cond ((eq (car-safe defn2) 'macro) "macro")
			       ((and (symbolp name)
				     (functionp defn2 t) ; to avoid error in special-form-p [SPR 6922]
				     (special-form-p name)) "special form")
			       ((or (si:compiled-subst? defn2)
				    (and (consp defn2)
					 (member (car defn2)
						 '(subst named-subst global:subst global:named-subst)
						 :test #'eq)))
				    "defsubst")
			       ((closurep defn) "closure")
			       ((typep defn 'microcode-function) "microcoded function")
			       ((and (null defn)
				     (symbolp name))
				(cond ((getl name '(compiler:p1 compiler:p2 compiler:opcode))
				       "sub-primitive")
				      ((and (neq (get name 'arglist 't) 't)
					    (documentation name 'function))
				       "local function")
				      ((get-item name :function nil) "undefined function")
				      (t nil)))
			       ((ticlos:generic-function-p defn)
				(setq generic t)
				"generic function")
			       (t nil))
			 (and (si:validate-function-spec name)
			      (si:get-source-file-name name 'defun)))
      (send *formatter* :insert
	    #'(lambda (&aux (print-function (item-printer #'print-mousable-caller)))
		(when (listp args)
		  (print-labeled-list "parameters"
				      (if (and (eq (car-safe name) ':method)
					       (eq (first args) 'si:.operation.))
					  (rest args)
					args)
				      #'princ-quote " " "(" ")" )
		  (when (and (not (eq (car-safe name) ':method))
			     (si:fef-flavor-name defn))
		    (print-labeled-value "SELF flavor" (si:fef-flavor-name defn))))
		(when values
		  (print-labeled-list "values" values #'princ " " "(" ")" ))
		(let ((f-item (get-item name :function nil))
		      (m-item (get-item name :macro nil)))
		  (unless (or (null f-item)
			      (and (null (xref-item-callers f-item))
				   (or m-item (eq (car-safe defn) 'macro) (null defn))))
		    (print-labeled-list-else "called by"
					     (sortf (xref-item-callers f-item) #'function-spec-lessp)
					     "[none]" print-function))
		  (if (or (null m-item)
			  (and (null (xref-item-callers m-item))
			       (not (eq (car-safe defn) 'macro))))
		      (when (uninteresting-macro-p name)
			(print-labeled-list-else "expanded in" nil "[users too numerous to list]"))
		    (print-labeled-list-else "expanded in"
					     (sortf (xref-item-callers m-item) #'function-spec-lessp)
					     (if (uninteresting-macro-p name)
						 "[users too numerous to list]"
					       "[none]")
					     print-function)) )
		(let ((c-item (get-item name :constant nil)))
		  (when (and c-item (xref-item-callers c-item))
		    (print-labeled-list-else "used as a constant by"
					     (sortf (xref-item-callers c-item) #'function-spec-lessp)
					     "()" print-function)))
		(when (and (null functions) (symbolp defn) defn) ; undefined symbol function
		  (setq functions (list defn)))
		(when functions
		  (print-labeled-list "calls" (sort functions #'function-spec-lessp) print-function))
		(when macros
		  (print-labeled-list "macros expanded" (sort macros #'function-spec-lessp) print-function))
		(when ivars
		  (print-labeled-list "instance variables" (sort ivars #'string<)))
		(when slots
		  (print-labeled-list "slots referenced" (sort slots #'string<)))
		(when variables
		  (print-labeled-list "special variables" (sort variables #'string<)
				      (item-printer #'print-mousable-symbol)))
		(when keywords
		  (print-labeled-list "uses keywords" (sort keywords #'string<)))
		(when generic
		  (let ((temp (clos:generic-function-argument-precedence-order defn)))
		    (when (mismatch (the list temp)
				    (the list (clos:generic-function-lambda-list defn))
				    :end2 (length temp))
		      (print-labeled-list "argument precedence order" temp #'princ-quote)))
		  (let ((temp (clos:generic-function-method-combination defn)))
		    (unless (or (atom temp)
				(string= (car temp) "STANDARD"))
		      (print-labeled-list "method combination" temp)))
		  (print-labeled-list-else "method specializers"
					   (sort (delete-duplicates
						   (mapcar #'(lambda (method)
							       (mapcar #'name-of-class
								       (clos:method-specializers method)))
							   (clos:generic-function-methods defn))
						   :test #'equal)
						 #'object-lessp)
					   "[none]"
					   (let ((temp (if (equal (si:fdefinition-safe name t) defn)
							   name defn)))
					     #'(lambda (list)
						 (if (send *standard-output* :operation-handled-p :item)
						     (send *standard-output* :item 'zwei:function-name
							   (list 'ticlos:method temp list) "~s" list)
						   (prin1 list)))))
		  ) ; end generic
		(when (symbolp name)
		  (let ((opts (get name 'compiler:optimizers)))
		    (if (listp opts) (setq opts (copy-list opts)) (setq opts (list opts)))
		    (let ((temp (get name 'compiler:post-optimizers)))
		      (if (listp temp)
			  (dolist (x temp)
			    (pushnew (if (consp x) (car x) x) opts :test #'eq))
			(push temp opts)))
		    (unless (null opts)
		      (print-labeled-list "optimized by"
					  (sort opts #'function-spec-lessp) print-function)
		      (let ((temp (get name 'compiler:optimized-into)))
			(unless (null temp)
			  (print-labeled-list "optimized into"
					      (if (listp temp) (sort temp #'function-spec-lessp) temp)
					      print-function)))))
		  (let ((temp (get name 'compiler::superseded-by 0)))
		    (when (symbolp temp)
		      (print-labeled-value "superseded by" temp print-function)))
		  )))
      (print-doc-string
	(ignore-errors 
	  (or (documentation function 'function)
	      (let ((parent (sys:function-parent name)) temp)
		(cond ((null parent) nil)
		      ((not (symbolp parent)) nil)
		      ((setq temp (get parent 'si::defstruct-description))
		       (and (setq temp (cond ((and defn (equal (arglist defn) (list parent)))
					      "Accessor")
					     ((member name (si::defstruct-description-constructors temp)
						      :test #'eq)
					      "Constructor")
					     ((eq name (si::defstruct-description-predicate temp))
					      "Predicate")
					     ((eq name (si::defstruct-description-copier temp))
					      "Copier")
					     ((eq name (si::defstruct-description-alterant temp))
					      "Alterant")
					     ))
			    (format nil "~A for structure ~S" temp parent)))
		      ((setq temp (get parent 'si::flavor))
		       (and (setq temp (cond ((and defn (equal (arglist defn) (list parent)))
					      "Accessor")
					     ))
			    (format nil "~A for flavor ~S" temp parent)))
		      ))
	      (and (eq (car-safe name) 'ticlos:method)
		   defn
		   (= (length name) 3)
		   (let* ((method (ticlos:find-method (fdefinition (second name))
						      nil (mapcar #'ticlos:find-class (third name)) nil)))
		     (typecase method
		       ( ticlos:standard-reader-method "A reader method defined by DEFCLASS.")
		       ( ticlos:standard-writer-method "A writer method defined by DEFCLASS.")
		       ( t nil))))
	      )))
      (print-trailer)
      ))
  (values))

(defun call-if-defined (package-name symbol-name &rest args)
  (let ((pkg (find-package package-name)))
    (unless (null pkg)
      (let ((symbol (find-symbol symbol-name pkg)))
	(unless (or (null symbol)
		    (not (fboundp symbol)))
	  (apply symbol args))))))

(defunÏ3 document-variableÏ* (symbol &key package no-query)
  Ï2"Print information about a special variable.
Tells where it is defined, who uses it, and shows the documentation string.
  :PACKAGE tells where to look for references, defaults to the symbol's package."Ï*
  (declare (unspecial package))
  (check-type symbol symbol)
  (let ((pkg (or (and package (pkg-find-package package))
		 (function-spec-package symbol))))
    (when (and pkg
	       (not (member pkg *packages-processed* :test #'eq))
	       (not no-query)
	       (yes-or-no-p "Build cross-reference table for package ~A?" (package-name pkg)))
      (build-xref-table-from-package pkg)))
  (let ((xitem (get-item symbol :variable nil))
	(file (si:get-source-file-name symbol 'defvar))
	(alias nil))
    (unless (or xitem file
		(boundp symbol)
		(get symbol 'special))
      (if (get-item symbol :instance-variable nil)
	  (document-instance-variable symbol)
	(if (get-item symbol :slot nil)
	    (document-slot symbol)
	  (format *error-output* "~&~S does not name a special variable." symbol)))
      (return-from document-variable (values)))
    (print-header-line symbol (if (constantp symbol) "constant" "variable") file)
    (send *formatter* :insert
	  #'(lambda (symbol alias xitem)
	      (let (value)
		(if (and (boundp symbol)
			 (or (not (member (setq value (symbol-value symbol))
					  '(nil t 0)))
			     (constantp symbol)))
		    (cond ((and (fixnump value) (< 0 value #o10000)
				(string= (symbol-name symbol) "%%" :end1 2))
			   Ï1;; looks like a byte specifierÏ*
			   (print-labeled-value "value" `(byte ,(byte-size value) ,(byte-position value))))
			  ((and (fixnump value)
				(> value 7)
				(eql (char (symbol-name symbol) 0) #\%))
			   Ï1;; looks like a bit maskÏ*
			   (let ((*print-base* 8) (*print-radix* t))
			     (print-labeled-value "value" value)))
			  (t (let ((*print-length* 20) (*print-level* 4)
				   (*print-array* t) (*print-structure* t)
				   (*print-pretty* (and (consp value)
							(or (consp (car value))
							    (> (length value) 4)))))
			       (print-labeled-value "value" value) )))
		  (when (fboundp 'compiler:type-of-expression)
		    (let ((type (compiler:type-of-expression symbol)))
		      (unless (eq type t)
			(print-labeled-value "type" type #'print-mousable-symbol))))))
	      (when (and (= (sys:%p-data-type-offset symbol 1) sys:dtp-one-q-forward)
			 (setq alias (si:%FIND-STRUCTURE-HEADER (si:%P-CONTENTS-AS-LOCATIVE-OFFSET symbol 1))))
		(print-labeled-value "alias of" alias #'print-mousable-symbol))
	      (let ((printer (item-printer #'print-mousable-caller)))
		(unless (or (null xitem)
			    (and (null (xref-item-callers xitem)) alias))
		  (print-labeled-list-else "used by"
					   (sortf (xref-item-callers xitem) #'function-spec-lessp)
					   "[none]" printer))
		(let ((c-item (get-item symbol :constant nil)))
		  (when (and c-item (xref-item-callers c-item))
		    (print-labeled-list-else "used as a quoted symbol in"
					     (sortf (xref-item-callers c-item) #'function-spec-lessp)
					     "()" printer)))))
	  symbol alias xitem))
  (print-doc-string (documentation symbol 'variable))
  (print-trailer)
  (when (and (not no-query) (get-item symbol :instance-variable nil))
    (document-instance-variable symbol))
  (when (and (not no-query) (get-item symbol :slot nil))
    (document-slot symbol))
  (values))

(defunÏ3 document-instance-variableÏ* (symbol &optional flavor-name)
  Ï2"Print information about an instance variable."Ï*
  Ï1;; 11/08/88 DNG - Fix to show references to the variable's name.Ï*
  Ï1;;  5/6/89 DNG - Don't say used by none if the package hasn't been scanned.Ï*
  (let* ((xitem (get-item symbol :instance-variable nil))
	 (users (and xitem
		     (if (null flavor-name)
			 (sortf (xref-item-callers xitem) #'function-spec-lessp)
		       (sort (let ((list nil))
			       (dolist (fspec (xref-item-callers xitem) list)
				 (let ((method-flavor (function-flavor fspec)))
				   (when (or (flavor-match-p method-flavor flavor-name)
					     (flavor-match-p flavor-name method-flavor))
				     (push fspec list)))))
			     #'function-spec-lessp)))))
    (unless (or users flavor-name)
      (format *error-output* "~&No information available for instance variable ~S." symbol)
      (return-from document-instance-variable (values)))
    (print-header-line symbol (if flavor-name (format nil "instance variable of ~S" flavor-name)
				"instance variable") nil)
    (let ((print-function (item-printer #'print-mousable-caller)))
      (send *formatter* :insert
	    #'(lambda (users)
		(when (or (not (null users))
			  (member (symbol-package symbol) *packages-processed* :test #'eq)
			  (and flavor-name
			       (member (symbol-package flavor-name) *packages-processed* :test #'eq)))
		  (print-labeled-list-else "used by" users "[none]" print-function)))
	    users)
      (let ((c-item (get-item symbol :constant nil)))
	(when (and c-item (xref-item-callers c-item))
	  (print-labeled-list-else "used as a quoted symbol in"
				   (sortf (xref-item-callers c-item) #'function-spec-lessp)
				   "()" print-function))))
    (print-trailer))
  (values))

(defun function-flavor (fspec)
  (cond ((and (consp fspec) (eq (car fspec) ':method))
	 (second fspec))
	(t (si:fef-flavor-name (si:fdefinition-safe fspec t)))))

(defun flavor-match-p (flavor-name-1 flavor-name-2)
  Ï1"Does flavor 1 include or require flavor 2?"Ï*
  (or (eq flavor-name-1 flavor-name-2)
      (subtypep flavor-name-1 flavor-name-2)
      (let ((fl (get flavor-name-1 'si:flavor)))
	(and fl
	     (or (dolist (x (si:flavor-depends-on fl) nil)
		   (when (flavor-match-p x flavor-name-2)
		     (return t)))
		 (dolist (x (getf (si:flavor-plist fl) :required-flavors) nil)
		   (when (flavor-match-p x flavor-name-2)
		     (return t))))))))

(defunÏ3 document-slotÏ* (symbol &optional class-name)
  Ï2"Print information about an instance slot."Ï*
  Ï1;;  1/16/89 DNG - Original.Ï*
  (let* ((xitem (get-item symbol :slot nil))
	 (users (and xitem
		     (if (null class-name)
			 (sortf (xref-item-callers xitem) #'function-spec-lessp)
		       (sort (let ((list nil))
			       (dolist (fspec (xref-item-callers xitem) list)
				 (dolist (method-class (car-safe (last fspec)))
				   (when (or (subtypep method-class class-name)
					     (subtypep class-name method-class))
				     (push fspec list)
				     (return)))))
			     #'function-spec-lessp)))))
    (unless (or users class-name)
      (format *error-output* "~&No information available for slot ~S." symbol)
      (return-from document-slot (values)))
    (print-header-line symbol (if class-name (format nil "slot in class ~S" class-name)
				"slot")
		       (slot-source-file symbol (xref-item-callers xitem)))
    (let ((print-function (item-printer #'print-mousable-caller)))
      (send *formatter* :insert
	    #'(lambda (users)
		(print-labeled-list-else "used by" users "[none]" print-function))
	    users)
      (let ((c-item (get-item symbol :constant nil)))
	(when (and c-item (xref-item-callers c-item))
	  (print-labeled-list-else "name used in"
				   (sortf (xref-item-callers c-item) #'function-spec-lessp)
				   "()" print-function))))
    (print-trailer))
  (values))

(defunÏ3 document-typeÏ* (symbol)
  Ï2"Print information about a data type.
Tells where it is defined, and shows the documentation string."Ï*
  (check-type symbol symbol)
    (let ((doc-string (or (documentation symbol 'type)
			  (documentation symbol 'structure))))
      (let ((file (or (si:get-source-file-name symbol 'defstruct)
		      (si:get-source-file-name symbol 'deftype)
		      (si:get-source-file-name `(:property ,symbol si::type-expander))
		      (si:get-source-file-name `(:property ,symbol si::type-optimizer))
		      (si:get-source-file-name `(:property ,symbol si::type-predicate)))))
	(when (call-if-defined "CLOS" "FIND-CLASS" symbol nil)
	  (document-class symbol)
	  (unless file (return-from document-type)))
	(when (not (or doc-string file
		       (getl symbol '(si::type-expander si::type-optimizer
							si::type-predicate si::defstruct-description))))
	  (if (get symbol 'si:flavor)
	      (return-from document-type (document-flavor symbol))
	    (progn (format *error-output* "~&~S is not the name of a type." symbol)
		   (return-from document-type (values)))))
	(print-header-line symbol (if (get symbol 'si::defstruct-description) "structure" "type") file)
	)
      Ï2;;Ï*
      Ï2;;   --  more stuff to be added here  --Ï*
      Ï2;;Ï*
      (print-doc-string doc-string))
    (print-trailer)
  (values))

(defunÏ3 document-flavorÏ* (symbol &optional document-methods-p)
  Ï2"Print information about a flavor.
Tells where it is defined, and shows the documentation string."Ï*
  (check-type symbol symbol)
  (let ((fl (get symbol 'si:flavor)))
    (unless fl
      (format *error-output* "~&~S is not the name of a flavor." symbol)
      (return-from document-flavor (values)))
    (print-header-line symbol "flavor" (si:get-source-file-name symbol 'defflavor))
    (let ((xitem (get-item symbol :constant nil)))
      (send *formatter* :insert
	    #'(lambda (xitem fl &aux (printer (item-printer #'print-mousable-flavor)))
		(when (and (not (eq symbol (sys:flavor-name fl)))
			   (eq (get (sys:flavor-name fl) 'si:flavor) fl))
		  (print-labeled-value "alias of flavor" (sys:flavor-name fl) printer)
		  (setq document-methods-p nil))
		(let ((list (si:flavor-depended-on-by fl)))
		  (unless (null list)
		    (print-labeled-list "included in flavors"
					(sort (copy-list list) #'string<)
					printer)))
		(when (and xitem (xref-item-callers xitem))
		  (print-labeled-list-else "name used in"
					   (sortf (xref-item-callers xitem) #'function-spec-lessp)
					   "()" (item-printer #'print-mousable-caller)))
		(let ((list (union (si:flavor-depends-on fl) (si:flavor-includes fl))))
		  (unless (null list)
		    (print-labeled-list "includes flavors"
					(sort (copy-list list) #'string<) printer)))
		(let ((list (getf (si:flavor-plist fl) :required-flavors)))
		  (unless (null list)
		    (print-labeled-list "requires flavors"
					(sort (copy-list list) #'string<) printer))))
	    xitem fl))
    (print-doc-string (documentation symbol 'defflavor))
    (print-trailer)
    (when document-methods-p
      (let ((ivars nil))
	(dolist (x (si:flavor-local-instance-variables fl))
	  (push (if (atom x) x (car x)) ivars))
	(sortf ivars #'string<)
	(dolist (x ivars)
	  (document-instance-variable x symbol)))
      (let ((methods nil))
	(dolist (mte (sys:flavor-method-table fl))
	  (dolist (meth (cdddr mte))
	    (when (sys:meth-definedp meth)
	      (let ((def (sys:meth-definition meth)))
		(push (if (or (symbolp def)
			      (atom (function-name def)))
			  (sys:meth-function-spec meth)
			def)
		      methods)))))
	(sortf methods #'(lambda (m1 m2)
			   (string< (car (last (function-name m1)))
				    (car (last (function-name m2))))))
	(dolist (defn methods)
	  (document-function defn :no-query t) )))
    )
  (values))

(defunÏ3 document-classÏ* (symbol &optional document-methods-p)
  Ï2"Print information about a class.
Tells where it is defined, and shows the documentation string."Ï*
  (let ((class (call-if-defined "TICLOS" "CLASS-NAMED" symbol t))
	class-name (alias nil))
    (unless class
      (let ((find (find-symbol "FIND-CLASS" "CLOS")))
	(when (and find (symbolp symbol))
	  (when (setq class-name (ignore-errors (sys:dwimify-package symbol find)))
	    (setq symbol class-name)
	    (setq class (funcall find symbol)))))
      (unless class
	(format *error-output* "~&~S is not the name of a class." symbol)
	(return-from document-class (values))))
    (setq class-name (if (symbolp symbol) symbol (ticlos:class-name class)))
    (print-header-line class-name "class" (si:get-source-file-name class-name (find-symbol "DEFCLASS" "CLOS")))
    (let ((xitem (get-item class-name :constant nil)))
      (send *formatter* :insert
	    #'(lambda (xitem class)
		(let ((print-function (item-printer #'print-mousable-caller))
		      (print-symbol (item-printer #'print-mousable-symbol))
		      (proper-name (ticlos:class-proper-name class)))
		  (if (and proper-name (symbolp proper-name) (symbolp symbol)
			   (not (eq symbol proper-name)))
		      (progn (setq alias proper-name)
			     (print-labeled-value "alias of class" proper-name print-symbol))
		    (let ((list (clos:class-direct-subclasses class)))
		      (unless (null list)
			(print-labeled-list "included in classes"
					    (sort (mapcar #'name-of-class list)
						  #'object-lessp)
					    print-symbol))) )
		  (when (and xitem (xref-item-callers xitem))
		    (print-labeled-list-else "name used in"
					     (sortf (xref-item-callers xitem) #'function-spec-lessp)
					     "()" print-function))
		  (unless alias
		    (let ((list (mapcar #'name-of-class
					(clos:class-direct-superclasses class))))
		      (unless (or (null list)
				  (and (null (cdr list))
				       (or (eq (car list) 't)
					   (string= (car list) "STANDARD-OBJECT"))))
			(print-labeled-list "includes classes"
					    (sort (mapcar #'name-of-class list)
						  #'object-lessp)
					    print-symbol)))
		    (let ((metaclass (type-of class)))
		      (unless (string= metaclass "STANDARD-CLASS")
			(print-labeled-value "metaclass"
					     (name-of-class (clos:class-of class))
					     print-symbol)))
		    (let ((list (if (ticlos:class-composed-p class)
				    (clos:class-slots class)
				  (clos:class-direct-slots class))))
		      (unless (null list)
			(print-labeled-list "slots"
					    (sort (mapcar (find-symbol "SLOT-DESCRIPTION-NAME" "CLOS") list)
						  #'string<)
					    print-symbol)))
		    (let ((list (clos:specializer-direct-generic-functions class)))
		      (unless (null list)
			(print-labeled-list "direct generic functions"
					    (sort (delete-duplicates (mapcar (find-symbol "GENERIC-FUNCTION-NAME" "CLOS")
									     list)
								     :test #'equal)
						  #'function-spec-lessp)
					    print-function)))))
		
		Ï2;;   --  more to be added  --Ï*
		
		)
	    xitem class))
    (print-doc-string (if alias (documentation symbol 'type)
			(or (documentation class)
			    (documentation class-name 'type))))
    (print-trailer)
    (when document-methods-p

Ï2       ;;;  -- Ï* Ï2more to be added  --
       
       Ï*))
  (values))

(defun name-of-class (class)
  (if (sys:classp class)
      (ticlos:class-proper-name class)
    class))

(defun object-lessp (a b) ; is A less than B?
  Ï1;; The arguments can be anything except complex numbers.Ï*
  Ï1;; Adapted from Ï*sys:general-sort-predicateÏ1 in "Almost Scheme", with added handling for Ï*DTP-INSTANCEÏ1.Ï*
  (declare (optimize speed (safety 0)))
  (cond ((eql a b) nil)
	((numberp a) (or (not (numberp b)) (< a b)))
	((and (consp a) (consp b)) ; treat DTP-LIST and DTP-STACK-LIST the same.
	 (or (object-lessp (car a) (car b))
	     (and (equal (car a) (car b))
		  (object-lessp (cdr a) (cdr b)))))
	(t (let ((da (sys:%data-type a))
		 (db (sys:%data-type b)))
	     (declare (fixnum da db))
	     (if (eql da db)
		 (cond ((eql da sys:dtp-character) (char< a b))
		       ((eql da sys:dtp-array)
			(if (stringp a)
			    (or (not (stringp b)) (string< a b))
			  (< (length a) (length b))))
		       ((eql da sys:dtp-symbol) (string< a b))
		       ((member da '(#.sys:dtp-function #.sys:dtp-closure #.sys:dtp-lexical-closure))
			(object-lessp (function-name a) (function-name b)))
		       ((eql da sys:dtp-instance)
			(cond ((sys:classp a)
			       (or (not (sys:classp b))
				   (object-lessp (clos:class-name a)
						 (clos:class-name b))))
			      ((and (typep a 'pathname) (typep b 'pathname))
			       (string< (send a :name) (send b :name)))
			      (t (object-lessp (clos:class-of a) (clos:class-of b)))))
		       (t (< (sys:%pointer a) (sys:%pointer b))))
	       (and (not (numberp b))
		    (let ((dtp-sort-order
			    '#.(let ((array (make-array 32 :initial-element 31 :element-type '(integer 0 63))))
				 (dotimes (i (length array))
				   (setf (aref array i) (+ 32 i)))
				 (do ((tail 'sys:( DTP-Fix DTP-Single-Float DTP-Short-Float DTP-Extended-Number 
						  DTP-Character DTP-Symbol DTP-List Dtp-Stack-List DTP-Array DTP-Instance 
						  DTP-Function DTP-Closure DTP-Lexical-Closure DTP-U-Entry DTP-Locative)
					    (cdr tail))
				      (i 0 (1+ i)))
				     ((null tail))
				   (setf (aref array (symbol-value (car tail))) i))
				 array)))
		      (< (aref dtp-sort-order da) (aref dtp-sort-order db)))))))))

(defunÏ3 document-keywordÏ* (symbol &key package)
  Ï2"Tell who uses a symbol as a constant.
With a Ï3:PACKAGEÏ* argument, only mention references in that package."Ï*
  (declare (unspecial package))
  (let ((xitem (get-item symbol :constant nil))
	(fitem (get-item symbol :method nil)))
    (unless (or xitem fitem)
      (format *error-output* "~&No references recorded for ~S." symbol)
      (return-from document-keyword (values)))
    (print-header-line symbol
		       (typecase symbol (keyword "keyword") (symbol "symbol") (t "constant"))
		       nil)
    (let ((refs nil)
	  (pkg (and package (pkg-find-package package))))
      (dolist (ref (xref-item-callers xitem))
	(when (or (null pkg)
		  (eq (function-spec-package ref) pkg)
		  (and (consp ref)
		       (eq (first ref) ':property)
		       (symbolp (third ref))
		       (eq (symbol-package (third ref)) pkg)))
	  (push ref refs)))
      (sortf refs #'function-spec-lessp)
      (send *formatter* :insert
	    #'(lambda (list flavors)
		(unless (and (null list) (not (null flavors)))
		  (print-labeled-list-else "used by" list "[none]" (item-printer #'print-mousable-caller)))
		(when flavors
		  (print-labeled-list "message defined for flavors"
				      flavors (item-printer #'print-mousable-flavor)))
		)
	    refs (and fitem (sortf (xref-item-callers fitem) #'string<)))))
  (print-trailer)
  (values))

(defun Ï3document-packageÏ* (package &optional output-file format)
Ï2  "Write documentation for each function and variable in a package."Ï*
  (declare (unspecial package))
  (let ((pkg (pkg-find-package package))
	(functions nil)
	(variables nil)
	(flavors nil)
	(types nil)
	(keywords nil)
	(constants nil))
    (when output-file
      (return-from document-package
	(with-open-file (*standard-output* (text-pathname output-file) :direction :output)
	  (document-package pkg nil format)
	  (truename *standard-output*))))
    (assure-xref-table-from-package pkg)
    (format *terminal-io* "~&Collecting symbols from package ~A." (package-name pkg))
    (do-local-symbols (symbol pkg)
      (when (or (boundp symbol)
		(get symbol 'special))
	(push symbol variables))
      (if (get symbol 'si:flavor)
	  (push symbol flavors)
	(when (si:type-specifier-p symbol)
	  (push symbol types)))
      (loop for (prop value) on (symbol-plist symbol) by #'cddr
	    when (and (not (symbolp value))
		      (functionp value t)
		      (not (eq prop ':PREVIOUS-DEFINITION)))
	    do (push `(:property ,symbol ,prop) functions))
      (when (fboundp symbol)
        (push symbol functions))
      )
    (format *terminal-io* "~&Collecting keywords.")
    (map-items #'(lambda (name xitem)
		   (when (and (eq (xref-item-type xitem) :constant)
			      (not (and (symbolp name) (null (symbol-package name))))
			      (or (keywordp name)
				  (and (not (member name functions :test #'eq))
				       (not (member name variables :test #'eq))))
			      (or (eq (function-spec-package name) pkg)
				  (some #'(lambda (s) (eq (function-spec-package s) pkg))
					(xref-item-callers xitem))))
		     (if (keywordp name)
			 (push name keywords)
		       (push name constants)))))
    (format *terminal-io* "~&Sorting the symbols.")
    (sortf functions #'function-spec-lessp)
    (sortf variables #'string<)
    (sortf flavors #'string<)
    (sortf types #'string<)
    (setf constants (nconc (sort keywords #'string<)
			   (sort constants #'string<)))
    (format *terminal-io* "~&Writing the report.")
    (let ((*package* pkg)
	  (*formatter* (format-function format)))
      (write-attributes)
      (send *formatter* :begin-document "package" (package-name pkg))
      (document-stuff pkg functions variables types flavors t constants)
      (send *formatter* :end-document)
      )
    (values)))

(defun text-pathname (namestring) Ï1; parse a pathname, defaulting type to Ï*text.
  (fs:merge-pathname-defaults namestring *DEFAULT-PATHNAME-DEFAULTS* :text))

(defun document-stuff (pkg functions &optional variables types flavors methods-p constants)
  (flet ((line ()
	    (send *formatter* :separator-line)
	    (send *formatter* :need-lines 8) ))
    (when types
      (send *formatter* :new-section "Types")
      (dolist (symbol types)
	(catch-error-restart ((error break) "Give up documenting type ~S" symbol)
	  (document-type symbol))
	(line)))
    (when variables
      (send *formatter* :new-section "Variables")
      (dolist (symbol variables)
	(document-variable symbol :package pkg :no-query t)
	(line)))
    (when functions
      (send *formatter* :new-section "Functions")
      (dolist (fspec functions)
	(unless (and methods-p
		     (consp fspec)
		     (eq (first fspec) ':method)
		     (member (second fspec) flavors :test #'eq))
	  ;; unless it will be done by document-flavor
	  (catch-error-restart ((error break) "Give up documenting function ~S" fspec)
	    (document-function fspec :package pkg :no-query t))
	  (line))))
    (when flavors
      (send *formatter* :new-section "Flavors")
      (dolist (symbol flavors)
	(catch-error-restart ((error break) "Give up documenting flavor ~S" symbol)
	  (document-flavor symbol methods-p))
	(line)))
    (when constants
      (send *formatter* :new-section "Constants")
      (dolist (symbol constants)
	(document-keyword symbol :package pkg)
	(line)))))

(defun Ï3document-fileÏ* (file &optional output-file format)
Ï2  "Write documentation for each thing defined in a file or list of files.
A single wild-carded pathname is also permitted.  The files need to be loaded."Ï*
  (let ((*formatter* (format-function format))
	(compiler:warn-on-errors t)   ;Ï1;clm 7/11/88Ï*
	path)
    (document-files-internal (if (and (atom file)
				      (send (setq path (merge-pathnames file ".LISP" :newest))
					    :wild-p))
				 (directory path)
			       file)
			     output-file
			     "file" (and (atom file) file))))

(defun document-files-internal (file &optional output-file header-kind header-arg)
  (let (the-pathname
	(functions nil)
	(variables nil)
	(flavors nil)
	(types nil)
	(keywords nil)
	(constants nil)
	(pkg nil)
	(pathnames nil))
    (when output-file
      (return-from document-files-internal
	(with-open-file (*standard-output* (text-pathname output-file) :direction :output)
	  (document-files-internal file nil header-kind header-arg)
	  (truename *standard-output*))))
    (dolist (file (if (listp file) file (list file)))
      (block this-file
	(let ((pathname (send (merge-pathnames file) :generic-pathname)))
	  (when (member pathname pathnames :test #'eq)
	    (return-from this-file))
	  (setq the-pathname pathname)
	  (setq pathname (assure-xref-table-from-file pathname))
	  (when (null pathname) (return-from this-file))
	  (push pathname pathnames)
	  (let ((file-pkg (map-definitions-in-file
			    pathname
			    #'(lambda (name kind)
				(case kind
				  ( defun (pushnew name functions :test #'equal) )
				  ( defvar (pushnew name variables :test #'eq) )
				  ( defflavor (pushnew name flavors :test #'eq) )
				  ((deftype defstructÏ1 Ï*ticlos:defclass)
				   (pushnew name types :test #'eq))
				  ((defsystem))
				  ( t ; (cerror "Continue." "Unrecognized definition type ~S" kind)
				   nil))
				(values)))))
	    (cond ((null pkg) (setq pkg file-pkg))
		  ((eq pkg file-pkg))
		  (t (setq pkg t)))
	    ))))
    (format *terminal-io* "~&Sorting the definitions.")
    (sortf functions #'function-spec-lessp)
    (sortf variables #'string<)
    (sortf flavors #'string<)
    (sortf types #'string<)
    (format *terminal-io* "~&Collecting keywords.")
    (map-items #'(lambda (name xitem)
		   (when (and (eq (xref-item-type xitem) :constant)
			      (symbolp name)
			      (not (and (symbolp name) (null (symbol-package name))))
			      (or (keywordp name)
				  (and (> (length (xref-item-callers xitem)) 1)
				       (not (member name functions :test #'eq))
				       (not (member name variables :test #'eq))))
			      (some #'(lambda (s) (member s functions :test #'eq))
				    (xref-item-callers xitem)))
		     (if (keywordp name)
			 (push name keywords)
		       (push name constants)))))
    (setf constants (nconc (sort keywords #'string<)
			   (sort constants #'string<)))
    (format *terminal-io* "~&Writing the report.")
    (write-attributes)
    (send *formatter* :begin-document header-kind header-arg)
    (document-stuff (and (packagep pkg) pkg)
		    functions variables types flavors
		    (string-equal header-kind "system") constants)
    (send *formatter* :end-document)
    (values)))

(defun map-definitions-in-file (file handler)
  Ï1"For each thing defined in Ï*FILE,Ï1 call Ï*HANDLER,Ï1 which should be a function 
accepting two arguments:  the name and the kind of definition, which will be 
one of:  Ï*DEFUN,Ï1 Ï*DEFVAR,Ï1 Ï*DEFFLAVOR,Ï1 Ï*DEFTYPEÏ1, Ï*DEFSTRUCTÏ1, Ï*DEFCLASSÏ1, or Ï*DEFSYSTEMÏ1."Ï*
  (declare (values package))
  (let ((pkg nil)
	(pathname (send (merge-pathnames file) :generic-pathname)))
    (format *terminal-io* "~&Collecting definitions from file ~A." pathname)
    (let ((definitions (send pathname :get :definitions)))
      (if (or (send pathname :get :random-forms)  (send pathname :get :macros-expanded))
	  Ï1;; Note: can't test the Ï*:definitionsÏ1 property because it could be set Ï*
	  Ï1;; for any functions that are patched, but not be recorded for the rest of the file.Ï*
	  (progn Ï1; can use the information recorded on the generic pathname plistÏ*
	    (setq pkg (caar definitions))
	    (dolist (def (cdr (car definitions)))
	      (let ((name (car def))
		    (kind (cdr def)))
		(funcall handler name kind))) )
	;Ï1; else will have to read the fileÏ*
	(compiler:with-compile-driver-bindings 
	  (let ((compiler:functions-referenced nil)Ï1 ; needed by Ï*(:PROPERTY DEFF-MACRO COMPILER:STYLE-CHECKER)
		(compiler:INHIBIT-STYLE-WARNINGS-SWITCH t)
		(si:*loader-eval*
		  #'(lambda (exp)
		      (compiler:compile-driver
			exp
			#'(lambda (form type)	Ï1; called after macro expansionÏ*
			    (declare (ignore type))
			    (when (consp form)
			      (case (car form)
				(( fdefine fset
				  Ï1;; the next two are for SchemeÏ*
				   si:define-internal si:define-integrable-1)
				 (when (compiler:quotep (second form))
				   (funcall handler (second (second form)) 'defun)))
				( ticlos:add-method Ï1; handle accessor methods generated by Ï*defclass
				   (let ((arg2 (third form)))
				     (when (and (member (car-safe arg2) '(ticlos:make-reader ticlos:make-writer))
						(every #'compiler:quotep (cdr arg2)))
				       (let ((fn (second (second arg2)))
					     (class (second (fourth arg2))))
					 (funcall handler
						  (list 'ticlos:method fn
							(if (eq (car-safe fn) 'setf)
							    (list t class)
							  (list class)))
						  'defun)))))
				)))
			#'(lambda (form)	Ï1; called before macro expansionÏ*
			    (when (and (consp form)
				       (> (length form) 2))
			      (let ((name (second form)))
				(case (first form)
				  ((defun defflavor)
				   (funcall handler name (first form)) t)
				  ((defvar global:defconst defconstant defparameter)
				   (funcall handler name 'defvar) t )
				  ((deftype defstruct ticlos:defclass)
				   (funcall handler (if (atom name) name (car name)) (first form))
				   nil) Ï1; go ahead and macroexpand so we can see the accessorsÏ*
				  (ticlos:defgeneric
				   (funcall handler name 'defun)
				   nil)Ï1 ; expand so we can see the initial methodsÏ*
				  )))) )) ))
	    (readfile (source-pathname pathname) nil t))
	  (let ((tpkg (send pathname :get :package)))
	    ;;find-package cannot handle packages specified by a listÏ1 5/24/88 clmÏ*
	    (setq pkg (find-package (if (consp tpkg) (car tpkg) tpkg))))
	)))
    pkg))

(defun document-system (system &optional output-file format)
  "Write documentation for everything defined in a system."
  (let ((*formatter* (format-function format))
	(compiler:warn-on-errors t))   ;Ï1;clm 7/11/88Ï*
    (document-files-internal (system-files system) output-file "system" system) 
    ))

(defunÏ3 Ï*system-files (system)
  Ï1"Return the list of files that make up a system."Ï*
  (unless (if (fboundp 'si:system-made-p)Ï1 ; new in release 4Ï*
	      (si:system-made-p system)
	    (si:get-system-version system))
    (make-system system)) Ï1; make sure it is loadedÏ*
  (sys:system-files system '(:recompile :no-reload-system-declaration)
		    '(:fasload :readfile :compile)))

(unless (fboundp 'sys:system-files)
Ï1  ;; This function new in System patch 4.25 2/24/88
  ;; Needs to be in a separate file because it has to be compiled on release 3 
  ;; in order to work on release 3.Ï*
  (load "SYS:BAND-TOOLS;SYSTEM-FILES"))

(defun build-xref-table-from-system (system)
  (unless (si:find-system-named system t t)
    (make-system system)) Ï1; make sure it is loadedÏ*
  (let ((files (sys:system-files system '(:recompile :no-load-patches :no-increment-patch
					  :no-reload-system-declaration))))
    (dolist (file files)
      (build-xref-table-from-file file nil t nil t)))
  (values))

Ï1;;;Ï*	Ï1Utility functions used by the various Ï*document-Ï1... functionsÏ*

(defun non-trivial-function-p (fspec)
  Ï1"Function not too small or too common to be of interest?"Ï*
  (and (neq fspec 'si:macro-report-args-error)
       (let ((defn (si:fdefinition-safe fspec t)))
	 (typecase defn
	   (null t)
	   (symbol (non-trivial-function-p defn))
	   (compiled-function (and (or (> (si:fef-length defn) 5)
				       (catch 'check
					 (find-things-used-by-fef fspec defn
								  #'(lambda (&rest ignore)
								      (throw 'check t)))
					 nil))
				   ;; DISPATCH-ERROR is not interesting since it is only 
				   ;; called in cases that shouldn't happen.
				   (not (eq fspec 'ticlos::dispatch-error))
				   ))
	   (microcode-function nil)
	   (cons (not (and (eq (car defn) 'macro)
			   (member fspec '(setf when unless prog prog* dolist
					   locally si:displaced
					   SI::XR-BQ-CONS SI::XR-BQ-LIST SI::XR-BQ-LIST* SI::XR-BQ-APPEND)
				   :test #'eq) )))
	   (t t)))))

(defun FUNCTION-SPEC-LESSP (fs1 fs2)
  "Compare two function specs, approximately alphabetically."
  ;; Adapted from SYS:FUNCTION-SPEC-LESSP, fixing for :INTERNAL function specs. [SPR 5932]
  Ï1;;  8/15/88 DNG - Update to not error on CLOS method names.Ï*
  Ï1;;  1/13/89 DNG - Fix to not error on qualified methods.Ï*
  Ï1;;  1/16/89 DNG - Fix to not error on method spec containing generic function object.Ï*
  Ï1;;  1/27/89 DNG - Use Ï*object-lesspÏ1 to compare specializer lists and unexpected cases.Ï*
  (declare (optimize (safety 0) (speed 3)))
  (cond ((and (symbolp fs1) (symbolp fs2))	; most common case
	 (string< fs1 fs2))
	((and (consp fs1) (consp fs2)
	      (eq (first fs1) (first fs2)) (eq (second fs1) (second fs2)))
	 (let ((n1 (third fs1))
	       (n2 (third fs2)))
	   (cond ((numberp n1)
		  (if (numberp n2) (< n1 n2) nil))
		 ((numberp n2) t)
		 ((consp n1)
		  (if (consp n2)Ï1 Ï*; here for CLOS method specializers
		      (object-lessp n1 n2)
		    Ï1;; here if Ï*fs1Ï1 is an unqualified method and Ï*fs2Ï1 is a qualified method.Ï*
		    t))
		 ((consp n2)Ï1 ; here if Ï*fs1Ï1 is a qualified method and Ï*fs2Ï1 is an unqualified method.Ï*
		  nil)
		 (t (object-lessp (cddr fs1) (cddr fs2))))))
	((consp fs1)
	 (function-spec-lessp (if (locativep (second fs1)) (first fs1) (second fs1))
			      fs2))
	((consp fs2)
	 (or (eq fs1 (second fs2))
	     (function-spec-lessp fs1 (if (locativep (second fs2)) (first fs2) (second fs2)))))
	((symbolp fs1) t)
	((symbolp fs2) nil)
	(t (object-lessp fs1 fs2))))

(defun function-spec-package  (fspec)
  (typecase fspec
    (symbol (symbol-package fspec))
    (cons (function-spec-package (second fspec)))
    (t nil)))
