;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Private patches made by rg ;;; Reason: ;;; reload CLPACK and editor and fasload changes for :compile-in-root attribute. ;;; Written 19-Jul-87 09:42:39 by rg at site LMI Cambridge ;;; while running on Alex 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; COMC.LISP#220 at 19-Jul-87 09:42:59 #8R ZWEI#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI"))) (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; COMC  " (DEFUN COMPILE-INTERVAL (COMPILE-P PRINT-RESULTS-STREAM DEFVAR-HACK BP1 BP2 IN-ORDER-P COMPILE-PROCESSING-MODE &AUX GENERIC-PATHNAME STREAM WHOLE-FILE ;T if processing the entire file. SI:FDEFINE-FILE-DEFINITIONS) "Compile or evaluate the interval specified by BP1, BP2, IN-ORDER-P. Does not print any sort of message saying what is being compiled, does not know about sectionization. COMPILE-P is T to compile, NIL to eval, or else a function to evaluate and print a form. PRINT-RESULTS-STREAM is a stream for printing the results of evaluation, or NIL not to print. DEFVAR-HACK says always re-set variables if DEFVARs are evaluated. Normally this is only done if there is no region. COMPILE-PROCESSING-MODE is a keyword list. The :MODE item should be either COMPILER:MACRO-COMPILE or COMPILER:MICRO-COMPILE. ALREADY-RESECTIONIZED-FLAG should be T to inhibit resectionization." (DECLARE (SPECIAL COMPILE-P PRINT-RESULTS-STREAM DEFVAR-HACK COMPILE-PROCESSING-MODE)) (SETQ GENERIC-PATHNAME (SEND *INTERVAL* :GENERIC-PATHNAME)) ;; Does not reparse the mode line; we should let the user decide whether to do that.! ;; Should not override the user's Set Package if he has done one. (GET-INTERVAL BP1 BP2 IN-ORDER-P) ;; Decide whether the entire file is being processed or just a part. ;; If the whole file, we want to notice if any function present in the file previously ;; is now missing. If just a part, anything we don't notice now we must assume ;; is elsewhere in the file. (SETQ WHOLE-FILE (AND (BP-= BP1 (INTERVAL-FIRST-BP *INTERVAL*)) (BP-= BP2 (INTERVAL-LAST-BP *INTERVAL*)))) (SETQ STREAM (INTERVAL-STREAM BP1 BP2 T)) ;; Arrange for first read-error's location to be saved in q-reg ".". (REMPROP (MAKE-REGISTER-NAME #/.) 'POINT) (LET ((SI:*ALL-FREE-INTERPRETER-VARIABLE-REFERENCES-SPECIAL* T)) (MULTIPLE-VALUE-BIND (VARS VALS) (SEND *INTERVAL* :ATTRIBUTE-BINDINGS) (PROGV VARS VALS (let ((compile-in-roots-prop (get *interval* :compile-in-roots))) (cond ((and (eq compile-p t) compile-in-roots-prop (not (cl:member (si:package-root-name *package*) compile-in-roots-prop :test 'string-equal))) (cond ((not (= 1 (length compile-in-roots-prop))) (fsignal "The current heirarchy ~S is not among those acceptable ~s." (si:package-root-name *package*) compile-in-roots-prop)) (t (format print-results-stream " Transferring to hierarchy ~s" (car compile-in-roots-prop)) (pkg-goto (si:pkg-name *package*) nil (pkg-find-package (car compile-in-roots-prop)))))))) (WHEN FS:THIS-IS-A-PATCH-FILE ;; If compiling out of the editor buffer of a patch file, ;; make sure the file itself is marked ;; so that Meta-. will behave right. (PUTPROP GENERIC-PATHNAME T :PATCH-FILE)) ;; Bind off this flag -- our stream is not generating font changes ;; so READ should not try to remove any. (LET ((SI:READ-DISCARD-FONT-CHANGES NIL)) (FLET ((DO-IT () (COMPILER:COMPILE-STREAM STREAM GENERIC-PATHNAME NIL ;FASD-FLAG (IF (AND COMPILE-P (NOT (EQ COMPILE-P T))) ;if using user supplied evaluator, avoid any possible macro-expanding, etc ; in COMPILE-DRIVER. 'SIMPLE-COMPILE-INTERVAL-PROCESS-FN 'COMPILE-INTERVAL-PROCESS-FN) T ;QC-FILE-LOAD-FLAG NIL ;QC-FILE-IN-CORE-FLAG *PACKAGE* NIL ;FILE-LOCAL-DECLARATIONS NIL ;Unused WHOLE-FILE))) (IF COMPILE-P (COMPILER:LOCKING-RESOURCES-NO-QFASL (DO-IT)) (DO-IT))))))) (OR (NULL GENERIC-PATHNAME) (SI:RECORD-FILE-DEFINITIONS GENERIC-PATHNAME SI:FDEFINE-FILE-DEFINITIONS WHOLE-FILE))) )) ; From file DJ: L.ZWEI; ZMACS.LISP#563 at 19-Jul-87 09:43:12 #8R ZWEI#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI"))) (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; ZMACS  " (DEFUN EDITOR-COMPILE-FILE (PATHNAME &OPTIONAL EVEN-IF-UNCHANGED) "Compile PATHNAME if it has changed or if EVEN-IF-UNCHANGED. If PATHNAME is visited in an editor buffer and has changed, offers to save the buffer first." (LET* ((GENERIC-PATHNAME (SEND PATHNAME :GENERIC-PATHNAME)) JUST-WRITTEN PKG SUCCESS (compile-in-roots-prop (get generic-pathname :compile-in-roots)) (package-from-pathname (get generic-pathname :package)) (intended-package (cond (package-from-pathname (find-package package-from-pathname *package*)) (T *package*))) (package-from-hierarchy-stuff nil)) (cond ((and compile-in-roots-prop (not (cl:member (si:package-root-name intended-package) compile-in-roots-prop :test 'string-equal))) (cond ((not (= 1 (length compile-in-roots-prop))) (fsignal "The current heirarchy ~S is not among those acceptable ~s." (si:package-root-name intended-package) compile-in-roots-prop)) (t (format *query-io* " Transferring to hierarchy ~s" (car compile-in-roots-prop)) (setq package-from-hierarchy-stuff (find-package (si:pkg-name intended-package) (pkg-find-package (car compile-in-roots-prop)))))))) (DOLIST (ELT *ZMACS-BUFFER-NAME-ALIST*) (LET ((BUFFER (CDR ELT))) (WHEN (EQ (BUFFER-GENERIC-PATHNAME BUFFER) GENERIC-PATHNAME) (SETQ PKG (BUFFER-PACKAGE BUFFER)) (AND (BUFFER-NEEDS-SAVING-P BUFFER) (FQUERY () "Save buffer ~A first? " (BUFFER-NAME BUFFER)) (PROGN (SETQ JUST-WRITTEN T) (SAVE-BUFFER BUFFER)))))) (IF (OR EVEN-IF-UNCHANGED JUST-WRITTEN (AND (FILE-HAS-CHANGED PATHNAME) (Y-OR-N-P (FORMAT NIL "File ~A has changed. Recompile it? " PATHNAME)))) (UNWIND-PROTECT (PROGN (FORMAT *QUERY-IO* "~&Compiling ~A" PATHNAME) (COMPILE-FILE PATHNAME :PACKAGE (cond (package-from-hierarchy-stuff) (t PKG))) (SETQ SUCCESS T)) (IF SUCCESS (FORMAT *QUERY-IO* "~&~A compiled." PATHNAME) (FORMAT *QUERY-IO* " -- Compilation aborted.")))))) ))