LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031338. :SYSTEM-TYPE :LOGICAL :VERSION 9. :TYPE "LISP" :NAME "NEW-QRAND-SOURCEFILE" :DIRECTORY ("REL3-SOURCE" "IO") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758637523. :AUTHOR "REL3" :LENGTH-IN-BYTES 10255. :LENGTH-IN-BLOCKS 11. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     ;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Cold-load: T -*-;;;                           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) 1985,1987 Texas Instruments Incorporated. All rights reserved.;** (c) Copyright 1980 Massachusetts Institute of Technology **(DEFPROP DEFUN "Function" DEFINITION-TYPE-NAME)(DEFPROP DEFVAR "Variable" DEFINITION-TYPE-NAME)(DEFVAR NON-PATHNAME-REDEFINED-FILES NIL  "Files whose functions it is ok to redefine from the keyboard.")(DEFPARAMETER QUERY-ABOUT-REDEFINITION-CHOICES   (APPEND '(((T "Yes.") #\Y #\T #\space #\uparrow) ((NIL "No.") #\N #\rubout #\down-arrow))   '(((PROCEED "Proceed.") #\P)     ((GLOBAL:ERROR "Error.") #\E)))   "Choices-list for fquery within query-about-redefinition.")(SETQ FS:THIS-IS-A-PATCH-FILE NIL);For the cold load(DEFVAR FDEFINE-FILE-PATHNAME NIL  "Generic pathname of source file being loaded or evaluated, or NIL.")(DEFVAR PATCH-SOURCE-FILE-NAMESTRING NIL  "While loading a patch, holds namestring of generic pathname of the source of the patch.");If the above is not NIL, this variable accumulates a list of all function specs defined.(DEFVAR FDEFINE-FILE-DEFINITIONS NIL  "List of definitions made while loading this source file.")(DEFVAR NON-FILE-REDEFINED-FUNCTIONS NIL  "Functions from files redefined from the keyboard and confirmed by the user.");; Query about any irregularities about redefining the given function symbol now.;; Return T to tell caller to go ahead and redefine the symbol;; (no problems or user says ok), NIL to leave it unchanged.(DEFUN QUERY-ABOUT-REDEFINITION (FUNCTION-SPEC NEW-PATHNAME TYPE OLD-PATHNAME)  ;; Detect any cross-file redefinition worth complaining about.  (COND ((OR (EQ (IF (STRINGP OLD-PATHNAME) OLD-PATHNAME     (AND OLD-PATHNAME (FUNCALL OLD-PATHNAME :TRANSLATED-PATHNAME))) (IF (STRINGP NEW-PATHNAME) NEW-PATHNAME     (AND NEW-PATHNAME (FUNCALL NEW-PATHNAME :TRANSLATED-PATHNAME))))     (MEMBER OLD-PATHNAME     (IF NEW-PATHNAME (FUNCALL NEW-PATHNAME :GET :REDEFINES-FILES) NON-PATHNAME-REDEFINED-FILES)     :TEST #'EQ)) T)(T ;; This redefinition deserves a warning or query. ;; If it is within a file operation with warnings, ;; record a warning. (WHEN (AND (VARIABLE-BOUNDP FILE-WARNINGS-DATUM) FILE-WARNINGS-DATUM)   (RECORD-WARNING 'REDEFINITION :PROBABLE-ERROR NIL   (IF NEW-PATHNAME       "~A ~S being redefined by file ~A. It was previously defined by file ~A."       "~A ~S being redefined;~* it was previously defined by file ~A.")   (OR (GET TYPE 'DEFINITION-TYPE-NAME) TYPE) FUNCTION-SPEC   NEW-PATHNAME OLD-PATHNAME)) (LET (CONDITION CHOICE)   (SETQ CONDITION (MAKE-CONDITION 'SYS:REDEFINITION (IF NEW-PATHNAME     "~A ~S being redefined by file ~A.It was previously defined by file ~A."     "~A ~S being redefined;~* it was previously defined by file ~A.") (OR (GET TYPE 'DEFINITION-TYPE-NAME) TYPE) FUNCTION-SPEC NEW-PATHNAME OLD-PATHNAME))   (SETQ CHOICE (SIGNAL CONDITION))   (UNLESS CHOICE     (UNLESS (AND INHIBIT-FDEFINE-WARNINGS  (NEQ INHIBIT-FDEFINE-WARNINGS :JUST-WARN))       (FORMAT *QUERY-IO* "~&~A" CONDITION))     (IF INHIBIT-FDEFINE-WARNINGS (SETQ CHOICE T) (SETQ CHOICE       (FQUERY `(:CHOICES ,QUERY-ABOUT-REDEFINITION-CHOICES  :HELP-FUNCTION (,(IF (FBOUNDP 'COMMON-LISP-ON-P)       (IF (COMMON-LISP-ON-P)   'LAMBDA   'GLOBAL:LAMBDA)         'LAMBDA)   (STREAM &REST IGNORE)  (PRINC "  Type Y - Yes, allow the redefinition of this one function,       N - No, don't allow this function to be redefined,       P - Proceed and not ask in the future (for this pair of files),    or E - Enter the error handler: " STREAM))  :CLEAR-INPUT T  :FRESH-LINE NIL  :SELECT T)       " OK? "))))   (CASE CHOICE     ((T :NO-ACTION) T)     ((NIL :INHIBIT-DEFINITION) NIL)     (ERROR (ERROR CONDITION) T)     (PROCEED      (IF NEW-PATHNAME  (PUSH OLD-PATHNAME (GET NEW-PATHNAME :REDEFINES-FILES))  (PUSH OLD-PATHNAME NON-PATHNAME-REDEFINED-FILES))      T))))))  ;;; A :SOURCE-FILE-NAME property is a single pathname for DEFUN of a single file,;;; or ((type . files) (type . files) ...).;;; Value returned indicates whether to go ahead with the definition.(DEFUN RECORD-SOURCE-FILE-NAME (FUNCTION-SPEC&OPTIONAL (TYPE 'DEFUN)  (NO-QUERY (EQ INHIBIT-FDEFINE-WARNINGS T))&AUX (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))  "Record a definition of FUNCTION-SPEC, of type TYPE, in the current source file.The source file's generic-pathname is found in FDEFINE-FILE-PATHNAME.FUNCTION-SPEC is actually only a function spec if TYPE is 'DEFUN,which is the default.  If TYPE is 'DEFVAR, the first arg is a variable name, etc.NO-QUERY inhibits warnings about redefinition in a different file.The value is T if you should go ahead and perform the definition,NIL if the user was asked and said no."  ;; When defining a function in a patch, record it as coming  ;; from its real source file.  So the editor knows where to find it.  (IF (AND FS:THIS-IS-A-PATCH-FILE PATCH-SOURCE-FILE-NAMESTRING)      (LET* ((FDEFINE-FILE-DEFINITIONS NIL)     (FDEFINE-FILE-PATHNAME       (SEND (FS:PARSE-PATHNAME PATCH-SOURCE-FILE-NAMESTRING) :GENERIC-PATHNAME))     (PATCH-SOURCE-FILE-NAMESTRING NIL)     (PKG-SPEC (SEND FDEFINE-FILE-PATHNAME :GET :PACKAGE))     (*PACKAGE* (OR (PKG-FIND-PACKAGE PKG-SPEC :FIND) *PACKAGE*)));; Record the source file as having defined this function.;; THIS-IS-A-PATCH-FILE is still set, to prevent querying,;; but PATCH-SOURCE-FILE-NAMESTRING is not, so we don't recurse forever.(RECORD-SOURCE-FILE-NAME FUNCTION-SPEC TYPE NO-QUERY);; Add the function to the source's list of definitions.(RECORD-FILE-DEFINITIONS FDEFINE-FILE-PATHNAME FDEFINE-FILE-DEFINITIONS NIL FDEFINE-FILE-PATHNAME)))  (LET ((PATHNAME FDEFINE-FILE-PATHNAME)(DEF (CONS-IN-AREA FUNCTION-SPEC TYPE BACKGROUND-CONS-AREA))(PROPERTY (FUNCTION-SPEC-GET FUNCTION-SPEC :SOURCE-FILE-NAME)))    (OR (NULL FDEFINE-FILE-PATHNAME)(MEMBER DEF FDEFINE-FILE-DEFINITIONS)(SETQ FDEFINE-FILE-DEFINITIONS      (CONS-IN-AREA DEF FDEFINE-FILE-DEFINITIONS BACKGROUND-CONS-AREA)))    (COND ((AND (NULL PROPERTY);Check most common case first(EQ TYPE 'DEFUN))   ;; We don't record the keyboard as a "source file"   ;; so things like the editor don't get confused.   (IF FDEFINE-FILE-PATHNAME       (FUNCTION-SPEC-PUTPROP FUNCTION-SPEC PATHNAME :SOURCE-FILE-NAME))   T)  ((IF (ATOM PROPERTY)       (AND (EQ TYPE 'DEFUN) (EQ PATHNAME PROPERTY))     (EQ PATHNAME (CADR (ASSOC TYPE PROPERTY :TEST #'EQ))))   T);This pathname already known  (T   (AND PROPERTY (ATOM PROPERTY)(SETQ PROPERTY `((DEFUN ,PROPERTY))))   (LET ((THIS-TYPE (ASSOC TYPE PROPERTY :TEST #'EQ)) (OLD-FILE))     (COND ((COND ((NULL THIS-TYPE)   (IF FDEFINE-FILE-PATHNAME       (SETQ THIS-TYPE `(,TYPE)     PROPERTY (NCONC PROPERTY     (CONS THIS-TYPE NIL))))   T)  (NO-QUERY T)  (FS:THIS-IS-A-PATCH-FILE T)  ((AND (NOT FDEFINE-FILE-PATHNAME)(MEMBER FUNCTION-SPEC NON-FILE-REDEFINED-FUNCTIONS))   ;; If user has ever confirmed redefining this function from the keyboard,   ;; it is ok to do so again.   T)  ;; Before format is loaded, don't bomb out trying to query.  ((NOT (FBOUNDP 'FQUERY)) T)  ;; If all the old definitions are from patch files, don't query.  ((NULL (SETQ OLD-FILE       (LOOP FOR FILE IN (CDR THIS-TYPE)     UNLESS (OR (STRINGP FILE);During QLD(FUNCALL FILE :GET :PATCH-FILE))     RETURN FILE)))   T)  ((QUERY-ABOUT-REDEFINITION FUNCTION-SPEC PATHNAME TYPE     OLD-FILE)   ;; Though we don't record the keyboard as a "source file",   ;; once the user confirms redefining a certain function   ;; from the keyboard, we don't ever ask about it again.   (UNLESS FDEFINE-FILE-PATHNAME     (PUSH FUNCTION-SPEC NON-FILE-REDEFINED-FUNCTIONS))   T))    ;; We don't record the keyboard as a "source file"    ;; so things like the editor don't get confused.    (WHEN FDEFINE-FILE-PATHNAME      (SETF (CDR THIS-TYPE)    (CONS PATHNAME (DELETE PATHNAME (THE LIST (CDR THIS-TYPE)) :TEST #'EQ)))      (FUNCTION-SPEC-PUTPROP FUNCTION-SPEC PROPERTY :SOURCE-FILE-NAME))    T)   (T NIL)))))))(DEFUN GET-SOURCE-FILE-NAME (FUNCTION-SPEC &OPTIONAL TYPE)  "Return source file for definition of type TYPE of FUNCTION-SPEC.If TYPE is NIL, the most recent definition is used, regardless of type.FUNCTION-SPEC really is a function spec only if TYPE is DEFUN;for example, if TYPE is DEFVAR, FUNCTION-SPEC is a variable name."  (DECLARE (VALUES PATHNAME TYPE))  (LET ((PROPERTY (FUNCTION-SPEC-GET FUNCTION-SPEC :SOURCE-FILE-NAME)))    (COND ((NULL PROPERTY) NIL)  ((ATOM PROPERTY)   (AND (MEMBER TYPE '(DEFUN NIL) :TEST #'EQ)(VALUES PROPERTY 'DEFUN)))  (T   (LET ((LIST (IF TYPE (ASSOC TYPE PROPERTY :TEST #'EQ) (CAR PROPERTY))))     (LOOP FOR FILE IN (CDR LIST)   WHEN (NOT (FUNCALL FILE :GET :PATCH-FILE))   RETURN (VALUES FILE (CAR LIST))))))))(DEFUN GET-ALL-SOURCE-FILE-NAMES (FUNCTION-SPEC)  "Return list describing source files for all definitions of FUNCTION-SPEC.Each element of the list has a type of definition as its car,and its cdr is a list of generic pathnames that made that type of definition."  (LET ((PROPERTY (FUNCTION-SPEC-GET FUNCTION-SPEC :SOURCE-FILE-NAME)))    (COND ((NULL PROPERTY) NIL)  ((ATOM PROPERTY)   (SETQ PROPERTY `((DEFUN ,PROPERTY)))   ;; May as well save this consing.   (FUNCTION-SPEC-PUTPROP FUNCTION-SPEC PROPERTY :SOURCE-FILE-NAME)   PROPERTY)  (T PROPERTY))))ERNAL (*STANDARD-INPUT* PKG NO-MSG-P)  ;; 2/5/85 DNG - Fix interpreter environment binding to not change mode.  (LET* ((FILE-ID (FUNCALL *STANDARD-INPUT* :INFO)) (PATHNAME (FUNCALL *STANDARD-INPUT* :PATHNAME)) (GENERIC-PATHNAME (FUNCALL PATHNAME :GENERIC-PATHNAME)) (*PACKAGE* *PACKAGE*) (FDEFINE-FILE-DEFINITIONS) (FDEFINE-FILE-PATHNAME GENERIC-PATHNAME) (*INTERPRETER-ENVIRONMENT* NIL) (*INTERPRETER-FUNCTION-ENVIRONMENT*   (EQ *INTERPRETER-FUNCTION-ENVIRONMENT* T)))    (FS:READ-ATTRIBUTE-LIST GENERIC-PATHNAME *STANDARD-INPUT*)    ;; Enter appropriate environment for the file    (MULTIPLE-VALUE-BIND (VARS VALS)(FS:FILE-ATTRIBUTE-BINDINGS   (IF PKG      ;; If package is specified, don't look up the file's package      ;; since that might ask the user a spurious question.      (LET ((PLIST (COPY-LIST (SEND GENERIC-PATHNAME :PLIST))))(REMPROP (LOCF PLIST) :PACKAGE)(LOCF PLIST))    GENERIC-PATHNAME))      (PROGV VARS VALS;; If package overridden, do so.  *PA