;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:8; Patch-File:T -*- ;;; Private patches made by rg ;;; Reason: ;;; Fix get-fild-loaded-id to stay within current hierarchy. ;;; Reason: ;;; Put check for correct package root in QC-FILE. ;;; Reason: ;;; Add Zwei command Set Package Root. ;;; Reason: ;;; allows the user to change the root associated with buffer or file ;;; Written 23-Jul-87 23:28:34 by rg at site LMI Cambridge ;;; while running on Harpo from band 4 ;;; with Experimental System 122.9, Experimental Local-File 73.0, Experimental FILE-Server 22.0, Experimental Unix-Interface 11.0, Experimental Tape 17.1, Experimental Tiger 26.0, Experimental KERMIT 33.1, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 103, GC. ; From file DJ: L.ZWEI; ZMNEW.LISP#51 at 28-Jul-87 00:56:56 #8R ZWEI#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI"))) (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; ZMNEW  " (defcom com-set-package-root "Change the package root associated with buffer or file. If a package with the same name as the current package exists in that hierarchy, select it, otherwise, offer to create it. Then you will be asked whether to resectionize the buffer. If you say yes, all function definitions in the buffer will be recorded under symbols in the new package." () (let (root-alist) (dolist (pkg *all-packages*) (let ((root (get pkg ':root))) (unless (or (null root) (cl:member root root-alist :key 'cdr)) (push (cons (package-name root) root) root-alist) (dolist (nick (package-nicknames root)) (push (cons nick root) root-alist))))) (push '("" . nil) root-alist) (push `("GLOBAL" . ,(find-package 'global)) root-alist) (let ((new-root (car (completing-read-from-mini-buffer "Set new root package: " root-alist )))) (let ((pkg (find-package (si:package-primary-name *package*) (find-package new-root))) (pkg-name (package-name *package*)) (pkg-nicknames (package-nicknames *package*))) (if pkg (pkg-goto pkg () new-root) (IF (YES-OR-NO-P (FORMAT NIL "Package ~A does not exist. Create? " PKG)) (progn (if new-root (pkg-goto new-root) (pkg-goto 'user) (pkg-goto (make-package pkg-name :nicknames pkg-nicknames))) (BARF))))))) (SETF (BUFFER-PACKAGE *INTERVAL*) *PACKAGE*) (WHEN (FQUERY NIL "Resectionize the buffer? ") (SEND *INTERVAL* ':REMPROP ':DONT-SECTIONIZE) (SECTIONIZE-BUFFER *INTERVAL*)) DIS-NONE) )) ; From file DJ: L.SYS; QCFILE.LISP#360 at 30-Jul-87 15:45:25 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (DEFUN QC-FILE (INFILE &OPTIONAL OUTFILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC FILE-LOCAL-DECLARATIONS DONT-SET-DEFAULT-P READ-THEN-PROCESS-FLAG &AUX GENERIC-PATHNAME QC-FILE-MACROS-EXPANDED (QC-FILE-RECORD-MACROS-EXPANDED T) (QC-FILE-REL-FORMAT QC-FILE-REL-FORMAT)) "Compile Lisp source file INFILE, producing a binary file and calling it OUTFILE. PACKAGE-SPEC specifies which package to read the source in (usually the file's attribute list provides the right default). LOAD-FLAG and IN-CORE-FLAG are semi-losing features; leave them NIL." ;READ-THEN-PROCESS-FLAG says read the entire file before compiling (less thrashing) ;; Default the specified input and output file names. Open files. (SETQ INFILE (FS:MERGE-PATHNAME-DEFAULTS INFILE FS:LOAD-PATHNAME-DEFAULTS NIL)) (WITH-OPEN-STREAM (INPUT-STREAM (FILE-RETRY-NEW-PATHNAME (INFILE FS:FILE-ERROR) (SEND INFILE :OPEN-CANONICAL-DEFAULT-TYPE :LISP))) ;; The input pathname might have been changed by the user in response to an error. ;; Also, find out what type field was actually found. (SETQ INFILE (SEND INPUT-STREAM :PATHNAME)) (OR DONT-SET-DEFAULT-P (FS:SET-DEFAULT-PATHNAME INFILE FS:LOAD-PATHNAME-DEFAULTS)) (SETQ GENERIC-PATHNAME (SEND INFILE :GENERIC-PATHNAME)) (SETQ OUTFILE (COND ((TYPEP OUTFILE 'PATHNAME) (IF (SEND OUTFILE :VERSION) OUTFILE (SEND OUTFILE :NEW-PATHNAME :VERSION (IF *QC-FILE-OUTPUT-SAME-VERSION* (SEND (SEND INPUT-STREAM :TRUENAME) :VERSION) :NEWEST)))) (OUTFILE (FS:MERGE-PATHNAME-DEFAULTS OUTFILE INFILE (SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE GENERIC-PATHNAME) (IF *QC-FILE-OUTPUT-SAME-VERSION* (SEND (SEND INPUT-STREAM :TRUENAME) :VERSION) :NEWEST))) (T (SEND INFILE :NEW-PATHNAME :TYPE (SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE GENERIC-PATHNAME) :VERSION (IF *QC-FILE-OUTPUT-SAME-VERSION* (SEND (SEND INPUT-STREAM :TRUENAME) :VERSION) :NEWEST))))) ;; Get the file property list again, in case we don't have it already or it changed (FS:READ-ATTRIBUTE-LIST GENERIC-PATHNAME INPUT-STREAM) (let ((compile-in-roots-prop (get generic-pathname :compile-in-roots))) (cond ((and compile-in-roots-prop (not (cl:member (si:package-root-name (if package-spec package-spec *package*)) compile-in-roots-prop :test 'string-equal))) (ferror "This file is supposed to be compiled only in ~s hierarchies, not ~s" compile-in-roots-prop (si:package-root-name (if package-spec package-spec *package*)))))) (OR QC-FILE-REL-FORMAT-OVERRIDE (CASE (SEND GENERIC-PATHNAME :GET ':FASL) (:REL (SETQ QC-FILE-REL-FORMAT T)) (:FASL (SETQ QC-FILE-REL-FORMAT NIL)) ((NIL)) (T (FERROR "File property FASL value not FASL or REL in file ~A" GENERIC-PATHNAME)))) ;; Bind all the variables required by the file property list. (MULTIPLE-VALUE-BIND (VARIABLES VALS) (FS:FILE-ATTRIBUTE-BINDINGS GENERIC-PATHNAME) (PROGV VARIABLES VALS (COND (QC-FILE-REL-FORMAT (LET ((FASD-STREAM NIL)) ;REL compiling doesn't work the same way (LOCKING-RESOURCES (FUNCALL (INTERN (STRING 'DUMP-START) 'QFASL-REL)) (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME FASD-STREAM 'QC-FILE-WORK-COMPILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC FILE-LOCAL-DECLARATIONS READ-THEN-PROCESS-FLAG) ;; Output a record of the macros expanded and their current sxhashes. (WHEN QC-FILE-MACROS-EXPANDED (FUNCALL (INTERN (STRING 'DUMP-FORM) 'QFASL-REL) `(SI:FASL-RECORD-FILE-MACROS-EXPANDED ',QC-FILE-MACROS-EXPANDED))) (LET ((*PACKAGE* (IF PACKAGE-SPEC (PKG-FIND-PACKAGE PACKAGE-SPEC) *PACKAGE*))) (FUNCALL (INTERN (STRING 'WRITE-REL-FILE) 'QFASL-REL) OUTFILE))))) (T (WITH-OPEN-STREAM (FASD-STREAM (IF *QC-FILE-OUTPUT-SAME-VERSION* (OPEN OUTFILE :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE 16. :IF-EXISTS :SUPERSEDE) (OPEN OUTFILE :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE 16.))) (FLET ((DOIT () (LOCKING-RESOURCES (SETQ OUTFILE (SEND FASD-STREAM :PATHNAME)) (FASD-INITIALIZE) (FASD-START-FILE) (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME FASD-STREAM 'QC-FILE-WORK-COMPILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC FILE-LOCAL-DECLARATIONS READ-THEN-PROCESS-FLAG T) ;; Output a record of the macros expanded and their current sxhashes. (WHEN QC-FILE-MACROS-EXPANDED (FASD-FORM `(SI::FASL-RECORD-FILE-MACROS-EXPANDED ',QC-FILE-MACROS-EXPANDED))) (FASD-END-WHACK) (FASD-END-FILE)))) (COND (*QC-FILE-OUTPUT-DRIBBLE-TYPE* (WITH-OPEN-STREAM (DRIBBLE-FILE (IF *QC-FILE-OUTPUT-SAME-VERSION* (OPEN (SEND OUTFILE :NEW-TYPE *QC-FILE-OUTPUT-DRIBBLE-TYPE*) :DIRECTION :OUTPUT :CHARACTERS T :IF-EXISTS :SUPERSEDE) (OPEN (SEND OUTFILE :NEW-TYPE *QC-FILE-OUTPUT-DRIBBLE-TYPE*) :DIRECTION :OUTPUT :CHARACTERS T))) (FORMAT DRIBBLE-FILE "Compilation log started at ~\time\ by ~S for~% INPUT: ~S~% OUTPUT: ~S~2%" (TIME:GET-UNIVERSAL-TIME) SI:USER-ID (SEND INPUT-STREAM :TRUENAME) (SEND FASD-STREAM :TRUENAME)) (LET ((DRIBBLE-STREAM (SI:MAKE-DRIBBLE-STREAM *TERMINAL-IO* DRIBBLE-FILE))) (LET ((*STANDARD-INPUT* DRIBBLE-STREAM) (*STANDARD-OUTPUT* DRIBBLE-STREAM) (*QUERY-IO* DRIBBLE-STREAM) (*ERROR-OUTPUT* DRIBBLE-STREAM) (*TRACE-OUTPUT* DRIBBLE-STREAM) (TIME (TIME)) (DW (SI:READ-METER 'SI:%DISK-WAIT-TIME))) (DOIT) (FORMAT DRIBBLE-FILE "~&~3%Compilation complete at ~\time\~ ~%~\scientific\seconds realtime ~\scientific\seconds disk wait~%" (TIME:GET-UNIVERSAL-TIME) (QUOTIENT (TIME-DIFFERENCE (TIME) TIME) 60.0) (QUOTIENT (- (SI:READ-METER 'SI:%DISK-WAIT-TIME) DW) 1.0E6)) (GC:STATUS DRIBBLE-FILE) (GC:PRINT-STATISTICS DRIBBLE-FILE))))) ('ELSE (DOIT)))))))))) OUTFILE) )) ; From file DJ: L.SYS; QFASL.LISP#495 at 1-Aug-87 17:47:27 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  " (DEFUN GET-FILE-LOADED-ID (ACCESS-PATHNAME PKG &AUX GENERIC-PATHNAME) (SETQ GENERIC-PATHNAME (IF (TYPEP ACCESS-PATHNAME 'INSTANCE) (SEND ACCESS-PATHNAME :GENERIC-PATHNAME) 'MINI-PLIST-RECEIVER)) ;In MINI, and flavors not in use yet. (AND (NULL PKG) (SETQ PKG (SEND GENERIC-PATHNAME :GET ':PACKAGE))) (CADR (LET ((PROP (SEND GENERIC-PATHNAME :GET ':FILE-ID-PACKAGE-ALIST))) (IF PKG (ASSQ (PKG-FIND-PACKAGE PKG nil *package*) PROP) (CAR PROP))))) ))