;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Private patches made by rg ;;; Reason: ;;; install multi-root package feature ;;; Written 18-Jul-87 15:47:05 by rg (Richard Greenblatt) 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.IO; READ.LISP#461 at 18-Jul-87 15:47:35 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: IO; READ  " (DEFUN XR-FEATURE-PRESENT (FEATURE) (COND ((SYMBOLP FEATURE) ;; recent common-lisp flamage claims that this should be memq, not member :test #'string= ;; Personally, I can't think of a more poorly-designed advertised feature in the ;; clisp manual than *features* and *modules* (MEMQ FEATURE *FEATURES*)) ((NUMBERP FEATURE) (MEMBER-EQL FEATURE *FEATURES*)) ((ATOM FEATURE) (READ-ERROR "Unknown form ~S in #+ or #- feature list." FEATURE)) ((EQ (CAR FEATURE) ':NOT) (NOT (XR-FEATURE-PRESENT (CADR FEATURE)))) ((EQ (CAR FEATURE) ':AND) (CL:EVERY #'XR-FEATURE-PRESENT (CDR FEATURE))) ((EQ (CAR FEATURE) ':OR) (CL:SOME #'XR-FEATURE-PRESENT (CDR FEATURE))) ((eq (car feature) ':=) ;extension, 7/18/87, RG. Semi-necessary for conditionalization (= (eval (cadr feature)) (eval (caddr feature)))) ;on multiple PACKAGE-ROOTs. (T (READ-ERROR "Unknown form ~S in #+ or #- feature list." FEATURE)))) )) ; From file DJ: L.SYS; CLPACK.LISP#232 at 18-Jul-87 15:48:25 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; CLPACK  " (defun pkg-goto (&optional (pkg pkg-user-package) globallyp ;reference is a new feature 7/9/87 which allows you to ;stay within an environment. It is passed thru to PKG-FIND-PACKAGE. reference) ;Go to type-in package. "Set the current binding of *PACKAGE* to the package you specify (by name). If GLOBALLY-P is non-NIL, then we do a PKG-GOTO-GLOBALLY as well." (let ((pk (pkg-find-package pkg () reference))) (when (or ;(pkg-auto-export-p pk) ;let the guy go ahead, if he gets errors ... (pkg-read-lock-p pk)) (ferror "Package ~A is ~:[read locked~;auto-exporting~]; it should not be the current package." pk (pkg-auto-export-p pk))) (and globallyp (pkg-goto-globally pk)) (setq *package* pk))) )) ; From file DJ: L.SYS; CLPACK.LISP#232 at 18-Jul-87 15:48:36 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; CLPACK  " (defun in-package (name &rest options &key use nicknames (reference *package*)) (declare (arglist name &key nicknames (use '("GLOBAL")) (size #o200) shadow export)) (let ((pkg (pkg-find-package name () reference))) (cond ((and pkg options) (progn (use-package use pkg) (pkg-add-nicknames pkg nicknames))) ;; if no options are supplied, and the package already exists, just do a pkg-goto (pkg) (t (setq pkg (apply #'make-package name options)))) (pkg-goto pkg () reference))) )) ; From file DJ: L.IO; READ.LISP#461 at 18-Jul-87 15:48:48 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: IO; READ  " (defun read-intern-soft (string) (multiple-value-bind (sym flag pkg) (find-symbol string) (unless flag (read-error "Package ~A is ~:[autoexporting~;read-locked~]; ~ the reader cannot make a symbol ~S there." *package* (pkg-read-lock-p *package*) string) (multiple-value-setq (sym flag pkg) (intern string *package*))) ;was pkg-keyword-package?? (values sym flag pkg))) )) ; From file DJ: L.SYS; QFASL.LISP#493 at 18-Jul-87 15:48:59 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  " (DEFUN READFILE-INTERNAL (*STANDARD-INPUT* PKG NO-MSG-P) (LET* ((FILE-ID (SEND *STANDARD-INPUT* :INFO)) (PATHNAME (SEND *STANDARD-INPUT* :PATHNAME)) (GENERIC-PATHNAME (SEND PATHNAME :GENERIC-PATHNAME)) (*PACKAGE* *PACKAGE*) (FDEFINE-FILE-DEFINITIONS) (FDEFINE-FILE-PATHNAME GENERIC-PATHNAME)) (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 :PROPERTY-LIST)))) (REMF PLIST ':PACKAGE) (LOCF PLIST)) GENERIC-PATHNAME)) (PROGV VARS VALS ;; If package overridden, do so. *PACKAGE* is bound in any case. (COND (PKG (SETQ *PACKAGE* (PKG-FIND-PACKAGE PKG () *package*))) ;added () and *package* (NO-MSG-P) ;And tell user what it was unless told not to (T (FORMAT *QUERY-IO* "~&Loading ~A into package ~A~%" PATHNAME *PACKAGE*))) (DO ((EOF '(())) ;; If the file contains a SETQ, don't alter what package we recorded loading in (*PACKAGE* *PACKAGE*) (FORM)) ;Unfortunately, we have to use ZL:READ here, because the analogous thing in compile file ; might call READ-CHECK-INDENTATION which takes args the old way. There should be a ; way to check indentation here too. ((EQ (SETQ FORM (FUNCALL (OR *READFILE-READ-FUNCTION* #'ZL:READ) *STANDARD-INPUT* EOF)) EOF)) (IF PRINT-LOADED-FORMS (PRINT (eval FORM)) (EVAL FORM))) (SET-FILE-LOADED-ID PATHNAME FILE-ID *PACKAGE*) (RECORD-FILE-DEFINITIONS PATHNAME (NREVERSE FDEFINE-FILE-DEFINITIONS)) PATHNAME)))) )) ; From file DJ: L.SYS; QFASL.LISP#493 at 18-Jul-87 15:49:17 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  " (DEFUN FASLOAD-INTERNAL (FASL-STREAM PKG NO-MSG-P) (LET* ((PATHNAME (SEND FASL-STREAM :PATHNAME)) (FDEFINE-FILE-PATHNAME (IF (STRINGP PATHNAME) PATHNAME (SEND PATHNAME :GENERIC-PATHNAME))) (PATCH-SOURCE-FILE-NAMESTRING) (FDEFINE-FILE-DEFINITIONS) (FASL-GENERIC-PLIST-RECEIVER (SEND FASL-STREAM :GENERIC-PATHNAME)) (FILE-ID (SEND FASL-STREAM :INFO)) (FASL-STREAM-BYPASS-P (OPERATION-HANDLED-P FASL-STREAM :GET-INPUT-BUFFER)) FASL-STREAM-ARRAY FASL-STREAM-INDEX (FASL-STREAM-COUNT 0) (FASLOAD-FILE-PROPERTY-LIST-FLAG NIL) (FASL-PACKAGE-SPECIFIED PKG) ;(last-fasl-file-forms nil) ;last-fasl-file-package FASL-FILE-EVALUATIONS FASL-FILE-PLIST DONT-CONVERT-DESTINATIONS dont-convert-cdr-codes (FASL-TABLE NIL)) ;; Set up the environment (FASL-START) (PUSH (CAR (SEND FASL-STREAM :INFO)) FASLOADED-FILE-TRUENAMES) ;; Start by making sure the file type in the first word is really SIXBIT/QFASL/. (LET ((W1 (OR (SEND FASL-STREAM :TYI) 0)) (W2 (OR (SEND FASL-STREAM :TYI) 0))) (OR (AND (= W1 #o143150) (= W2 #o71660)) (FERROR "~A is not a QFASL file" PATHNAME))) (SEND FASL-GENERIC-PLIST-RECEIVER :REMPROP :MACROS-EXPANDED) ;; Read in the file property list before choosing a package. (WHEN (= (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-FILE-PROPERTY-LIST) (FASL-FILE-PROPERTY-LIST) (let* ((fasd-data (OR (GET (LOCF FASL-FILE-PLIST) :FASD-DATA) (GET (LOCF FASL-FILE-PLIST) :COMPILE-DATA))) (fasd-data-plist (sixth fasd-data))) (let ((version (fourth fasd-data))) (and (not (null version)) (< version 98.) (cerror "Try to load it anyway" "~This QFASL file was written from system version ~D~%~ and may be dangerous to load into this system.~" version)) (when fasd-data-plist (setq dont-convert-destinations (if (> version 98.) t (getf fasd-data-plist 'compiler::new-destinations))) (setq dont-convert-cdr-codes (getf fasd-data-plist 'compiler::new-cdr-codes)))))) ;; Enter appropriate environment defined by file property list (MULTIPLE-VALUE-BIND (VARS VALS) (IF (NOT (STRINGP PATHNAME)) (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 FDEFINE-FILE-PATHNAME :PROPERTY-LIST)))) (REMF PLIST ':PACKAGE) (LOCF PLIST)) FDEFINE-FILE-PATHNAME))) (PROGV VARS VALS (LET ((*PACKAGE* (PKG-FIND-PACKAGE (OR PKG *PACKAGE*) :ASK))) (LET ((*PACKAGE* *PACKAGE*)) (OR PKG ;; Don't want this message for a REL file ;; since we don't actually know its package yet ;; and it might have parts in several packages. (= (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-REL-FILE) NO-MSG-P (FORMAT *QUERY-IO* "~&Loading ~A into package ~A~%" PATHNAME *PACKAGE*)) (SETQ LAST-FASL-FILE-PACKAGE *PACKAGE*) (FASL-TOP-LEVEL)) ;load it. (SEND FASL-GENERIC-PLIST-RECEIVER :PUTPROP FASL-FILE-EVALUATIONS ':RANDOM-FORMS) (RECORD-FILE-DEFINITIONS PATHNAME (NREVERSE FDEFINE-FILE-DEFINITIONS) T FASL-GENERIC-PLIST-RECEIVER) (SET-FILE-LOADED-ID PATHNAME FILE-ID *PACKAGE*)))) (SETQ FASL-STREAM-ARRAY NIL) (SETQ LAST-FASL-FILE-FORMS (NREVERSE LAST-FASL-FILE-FORMS)) PATHNAME)) )) ; From file DJ: L.IO.FILE; OPEN.LISP#206 at 18-Jul-87 15:50:38 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; OPEN  " (DEFUN (:PACKAGE FILE-ATTRIBUTE-BINDINGS) (IGNORE IGNORE PKG) (VALUES (NCONS '*PACKAGE*) (NCONS (PKG-FIND-PACKAGE PKG :ERROR *package*)))) (defun (:compile-in-roots file-attribute-bindings) (ignore ignore roots-to-compile-in) (values (ncons 'si:roots-to-compile-in) (ncons roots-to-compile-in))) )) ; From file DJ: L.SYS; CLPACK.LISP#232 at 18-Jul-87 15:51:49 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; CLPACK  " (defun package-root (pkg) (let ((root (get pkg ':root))) (if root root (pkg-find-package 'global)))) (defun package-root-name (pkg) (let ((root (package-root pkg))) (package-name root))) ))