;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-

;;; Reason: Fix MAP-DEFINITIONS-IN-FILE to pass correct argument to FIND-PACKAGE.
;;; Trouble occurred when package was a list (spr 8146).
;;;			      RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(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) 1988 Texas Instruments Incorporated. All rights reserved.

;;; Written 06/01/88 09:31:31 by MCCREARY,
;;; while running on Jules-Verne from band LODA
;;; With SYSTEM 4.61, VIRTUAL-MEMORY 4.4, EH 4.5, MAKE-SYSTEM 4.5, MICRONET 4.5, LOCAL-FILE 4.1,
;;;  BASIC-PATHNAME 4.12, NETWORK-SUPPORT-COLD 4.1, NAMESPACE 4.22, NETWORK-NAMESPACE 4.2,
;;;  DISK-IO 4.14, DISK-LABEL 4.0, BASIC-FILE 4.7, MAC-PATHNAME 4.5, NETWORK-PATHNAME 4.1,
;;;  COMPILER 4.11, TV 4.85, DATALINK 4.14, CHAOSNET 4.18, GC 4.3, MEMORY-AUX 4.0,
;;;  NVRAM 4.6, SYSLOG 4.0, STREAMER-TAPE 4.4, UCL 4.1, INPUT-EDITOR 4.0, METER 4.3,
;;;  ZWEI 4.18, DEBUG-TOOLS 4.2, NETWORK-SUPPORT 4.5, NETWORK-SERVICE 4.0, DATALINK-DISPLAYS 4.0,
;;;  FONT-EDITOR 4.0, SERIAL 4.0, PRINTER 4.8, PRINTER-TYPES 4.2, IMAGEN 4.0, SUGGESTIONS 4.0,
;;;  MAIL-DAEMON 4.7, MAIL-READER 4.6, TELNET 4.1, VT100 4.5, NAMESPACE-EDITOR 4.5,
;;;  PROFILE 4.4, VISIDOC 4.4, IP 3.19, Experimental BUG 10.1, DOCUMENTER 4.0,  microcode 567,
;;;  Band Name: Rel 4.1 + IP 5/9

#!C
; From file DOCUMENT.LISP#> DOCUMENTER; MR-X:
#10R DOC#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "DOC"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: DOCUMENTER; DOCUMENT.#"


(defun map-definitions-in-file (file handler)
  "For each thing defined in FILE, call HANDLER, which should be a function 
accepting two arguments:  the name and the kind of definition, which will be 
one of:  DEFUN, DEFVAR, DEFFLAVOR, DEFTYPE, DEFSTRUCT, or DEFSYSTEM."
  (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))
	  ;; Note: can't test the :definitions property because it could be set 
	  ;; for any functions that are patched, but not be recorded for the rest of the file.
	  (progn ; 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))) )
	;; else will have to read the file
	(compiler:with-compile-driver-bindings 
	  (let ((compiler:functions-referenced nil) ; 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)	; called after macro expansion
			    (declare (ignore type))
			    (when (consp form)
			      (case (car form)
				(( fdefine fset
				  ;; the next two are for Scheme
				   si:define-internal si:define-integrable-1)
				 (when (compiler:quotep (second form))
				   (funcall handler (second (second form)) 'defun)))
				)))
			#'(lambda (form)	; 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)
				   (funcall handler (if (atom name) name (car name)) (first form))
				   nil)		; go ahead and macroexpand so we can see the accessors
				  )))) )) ))
	    (readfile (send pathname :new-pathname :type :lisp) nil t))
	  (let ((tpkg (send pathname :get :package)))
	    ;;find-package cannot handle packages specified by a list 5/24/88 clm
	    (setq pkg (find-package (if (consp tpkg) (car tpkg) tpkg))))
	)))
    pkg))
))