;;; -*- 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  "

(defvar *previous-package* nil)

(DEFUN XR-#+-MACRO (STREAM IGNORE &OPTIONAL IGNORE)
  (LET* ((*previous-package* *package*)
	 (FEATURE (LET ((*PACKAGE* PKG-KEYWORD-PACKAGE)
			(*READ-BASE* 10.))
		   (INTERNAL-READ STREAM T NIL T))))	;feature or feature list
    (COND (*READ-SUPPRESS*
	   (VALUES))
	  ((NOT (XR-FEATURE-PRESENT FEATURE))
	   (LET ((*READ-SUPPRESS* T))
	     (INTERNAL-READ STREAM T NIL T))
	   (VALUES))
	  (T
	   (VALUES (INTERNAL-READ STREAM T NIL T))))))

;;;  #-<FEATURE-FORM> is equivalent to #+(NOT FEATURE-FORM).

(DEFUN XR-#--MACRO (STREAM IGNORE &OPTIONAL IGNORE)
  (LET* ((*previous-package* *package*)
	 (FEATURE (LET ((*PACKAGE* PKG-KEYWORD-PACKAGE)
			(*READ-BASE* 10.))
		   (INTERNAL-READ STREAM T NIL T))))	;feature or feature list
    (COND (*READ-SUPPRESS*
	   (VALUES))
	  ((XR-FEATURE-PRESENT FEATURE)
	   (LET ((*READ-SUPPRESS* T))
	     (INTERNAL-READ STREAM T NIL T))
	   (VALUES))
	  (T
	   (VALUES (INTERNAL-READ STREAM T NIL T))))))

;;;  Here, FEATURE is either a symbol to be looked up in (STATUS FEATURES) or
;;;  a list whose car is either AND, OR, or NOT.
;;;  Numbers may also be used--they are always taken to be decimal.
;;;  This is useful since people tend to name computers with numbers for some reason.

(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) ':PACKAGE-ROOT-NAME) ;extension, 7/18/87, RG.
	 (string-equal (si:package-root-name *previous-package*)
		       (cadr feature)))
	(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 ((compile-in-roots-prop (get (locf fasl-file-plist) :compile-in-roots)))
	(cond ((and compile-in-roots-prop
		    (not (cl:member (si:package-root-name (if pkg pkg *package*))
				    compile-in-roots-prop
				    :test 'string-equal)))
       ;gee, we're not supposed to load compiled code into this heirarchy.  Force READFILE.
	       (close fasl-stream)
	       (return-from fasload-internal
		 (readfile (fs:merge-pathname-defaults (send pathname :new-type :unspecified)
						       nil :LISP) pkg no-msg-p)))
	      (t
	       (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)))
))