;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Patch-File:T; Base:8; Readtable:ZL -*-
;;; Patch file for System version 126.32
;;; Reason:
;;;  Preliminary patching for FASLOAD changes, so the real patch will be able
;;;  to load itself!
;;;  Define the variables:
;;;  Variable *FASL-NIBBLE-8BIT*: T if using 8-bit bytes.
;;;  Variable *FASL-NIBBLE-PEEK*: Holding tank for peeked-at nibble.
;;;  Variable *FASL-BYTE-SIZE*: 16 for now, but will become 8.
;;;  Use *FASL-BYTE-SIZE* in various functions:
;;;    FASLOAD, QFASL-FILE-PLIST, FASL-APPEND
;;;  Function FASLOAD-INTERNAL: Bind the new variables needed by the rest of it.
;;; Reason:
;;;  Preliminary patching for FASLOAD changes, so the real patch will be able
;;;  to load itself!
;;;  Define the variables:
;;;  Variable *FASL-NIBBLE-8BIT*: T if using 8-bit bytes.
;;;  Variable *FASL-NIBBLE-PEEK*: Holding tank for peeked-at nibble.
;;;  Variable *FASL-BYTE-SIZE*: 16 for now, but will become 8.
;;;  Use *FASL-BYTE-SIZE* in various functions:
;;;    FASLOAD, QFASL-FILE-PLIST, FASL-APPEND
;;;  Function FASLOAD-INTERNAL: Bind the new variables needed by the rest of it.
;;; Written 9-Aug-88 21:49:01 by RWK (Robert W. Kerns) at site Gigamos Cambridge
;;; while running on Claude Debussy from band 2
;;; with Experimental System 126.30, ZWEI 125.14, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 102, Kenvironment Loaded 8/2/88.



; From modified file DJ: L.SYS; QFASL.LISP#496 at 9-Aug-88 21:49:02
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  "

;;; All external symbols relating to this file either are in QDEFS, QCOM or deal with the file system...
;;; i.e. this should be a relatively portable fasloader.

;;; This gets defined early so that the defsubst in the old version of the file doesn't get used.
;;; The value is saved
;;; away in the FASL-TABLE for later use, and the index is returned (as the 
;;; result of FASL-GROUP).

(DEFUN ASSIGN-VALUES (INPUT-LIST &OPTIONAL (SHIFT 0) (INIT 0) (DELTA 1))
    (PROG ()
       L  (COND ((NULL INPUT-LIST) (RETURN INIT)))
	  (proclaim `(special ,(car input-list)))
	  (SET (CAR INPUT-LIST) (LSH INIT SHIFT))
	  (SETQ INPUT-LIST (CDR INPUT-LIST))
	  (SETQ INIT (+ INIT DELTA))		
	  (GO L)))

(DEFVAR FASL-GROUP-DISPATCH :UNBOUND
  "Array of functions to handle fasl ops, indexed by fasl op code.")

(DEFCONST FASL-OPS '(
  FASL-OP-ERR
  FASL-OP-NOOP
  FASL-OP-INDEX
  FASL-OP-SYMBOL
  FASL-OP-LIST
  FASL-OP-TEMP-LIST
  FASL-OP-FIXED
  FASL-OP-FLOAT
  FASL-OP-ARRAY
  FASL-OP-EVAL
  FASL-OP-MOVE 
  FASL-OP-FRAME
  FASL-OP-LIST-COMPONENT
  FASL-OP-ARRAY-PUSH
  FASL-OP-STOREIN-SYMBOL-VALUE 
  FASL-OP-STOREIN-FUNCTION-CELL
  FASL-OP-STOREIN-PROPERTY-CELL 
  FASL-OP-FETCH-SYMBOL-VALUE
  FASL-OP-FETCH-FUNCTION-CELL 
  FASL-OP-FETCH-PROPERTY-CELL
  FASL-OP-APPLY
  FASL-OP-END-OF-WHACK 
  FASL-OP-END-OF-FILE
  FASL-OP-SOAK
  FASL-OP-FUNCTION-HEADER
  FASL-OP-FUNCTION-END 
  FASL-OP-NULL-ARRAY-ELEMENT
  FASL-OP-NEW-FLOAT
  FASL-OP-UNUSED10 
  FASL-OP-UNUSED11
  FASL-OP-UNUSED12
  FASL-OP-QUOTE-POINTER
  FASL-OP-S-V-CELL 
  FASL-OP-FUNCELL
  FASL-OP-CONST-PAGE
  FASL-OP-SET-PARAMETER
  FASL-OP-INITIALIZE-ARRAY 
  FASL-OP-CHARACTER
  FASL-OP-UNUSED1
  FASL-OP-UNUSED2 
  FASL-OP-UNUSED3
  FASL-OP-UNUSED4
  FASL-OP-UNUSED5  
  FASL-OP-UNUSED6
  FASL-OP-STRING
  FASL-OP-STOREIN-ARRAY-LEADER 
  FASL-OP-INITIALIZE-NUMERIC-ARRAY
  FASL-OP-REMOTE-VARIABLE
  FASL-OP-PACKAGE-SYMBOL
  FASL-OP-EVAL1
  FASL-OP-FILE-PROPERTY-LIST
  FASL-OP-REL-FILE
  FASL-OP-RATIONAL
  FASL-OP-COMPLEX
  FASL-OP-LARGE-INDEX
  FASL-OP-STOREIN-SYMBOL-CELL
  FASL-OP-VERSION-INFO ; Here is where we'd add the extra ops.
  fasl-op-k-compiled-function
  fasl-op-k-instructions
  fasl-op-k-immediates
  fasl-op-k-local-refs
  fasl-op-k-refs
  fasl-op-k-entry-points
  fasl-op-k-load-time-evals
  ;; *** NO SPARES ***
  ))

(ASSIGN-VALUES FASL-OPS 0)

(DEFUN FASL-RESTART ()
  (SETQ LAST-FASL-FILE-FORMS NIL)
  (let ((fasl-op-limit (lsh 1 (byte-size %%fasl-group-type)))
	(fasl-op-count (length fasl-ops)))
    (when (> fasl-op-count fasl-op-limit)
      (error "Too many FASL ops defined.  Limit is ~D, but ~D are defined."
	     fasl-op-limit fasl-op-count))
    ;; Initialize the fasl table if necessary
    (SETQ FASL-GROUP-DISPATCH (MAKE-ARRAY (LENGTH FASL-OPS) :AREA CONTROL-TABLES))
    (DO ((I 0 (1+ I))
	 (L FASL-OPS (CDR L))
	 (N (LENGTH FASL-OPS)))
	(( I N))
      (SETF (AREF FASL-GROUP-DISPATCH I) (CAR L)))))

(fasl-restart)

;;; The three values returned by the :GET-INPUT-BUFFER stream operation
;;; are put in these three values; the index and count are updated as the
;;; elements are read from the array.
(DEFVAR *FASL-STREAM-ARRAY*)
(DEFVAR *FASL-STREAM-INDEX*)
(DEFVAR *FASL-STREAM-COUNT*)


(defvar *fasl-nibble-8bit* :unbound "If T, using 8-bit bytes.")

(defvar *fasl-nibble-peek* () "Holds a PEEKED fasl-nibble-from-8bit")
))

; From modified file DJ: L.SYS; QFASL.LISP#496 at 9-Aug-88 21:51:12
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  "

(defvar *fasl-byte-size* 16.)

))

; From modified file DJ: L.SYS; QFASL.LISP#496 at 9-Aug-88 21:51:34
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  "

(DEFUN FASLOAD (FILE-NAME &OPTIONAL PKG NO-MSG-P)
  "Load a binary file.  PKG specifies package to load in.
NO-MSG-P inhibits the message announcing that the loading is taking place."
  (LET* ((DEFAULTED-NAME (FS:MERGE-PATHNAME-DEFAULTS FILE-NAME FS:LOAD-PATHNAME-DEFAULTS NIL))
	 (DEFAULT-BINARY-FILE-TYPE (PATHNAME-DEFAULT-BINARY-FILE-TYPE DEFAULTED-NAME)))
    (WITH-OPEN-FILE (STREAM (FS:MERGE-AND-SET-PATHNAME-DEFAULTS FILE-NAME
								FS:LOAD-PATHNAME-DEFAULTS
								DEFAULT-BINARY-FILE-TYPE)
			    :DIRECTION :INPUT
			    :CHARACTERS NIL
			    :BYTE-SIZE *fasl-byte-size*)
      (FASLOAD-INTERNAL STREAM PKG NO-MSG-P))))

))

; From modified file DJ: L.SYS; QFASL.LISP#496 at 9-Aug-88 21:52:25
#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))
	 (size (or (send-if-handles fasl-stream :byte-size)
		   (send fasl-stream :get :byte-size)))
	 *fasl-nibble-peek* 
	 (*fasl-nibble-8bit* (ecase size
			       (8. t)
			       (16. nil)))
	 (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)
;; Patch-file-only versions of these, for compatibilty while loading.
	 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 (fasl-nibble) 0))
	  (W2 (OR (fasl-nibble) 0)))
      (OR (AND (= W1 #o143150) (= W2 #o71660))
	  (FERROR "~A is not a QFASL file" PATHNAME)))
    (WHEN (= (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-version-info)
      (check-version-info))
    (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.
		;; (WHEN (= (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-version-info)
		;;   (check-version-info))
		;; The above lines have been added in other places where files are loaded.
		;; I don't know if they are needed here or not, since I don't think that this
		;; code works anyway -- Jim
		(= (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 modified file DJ: L.SYS; QFASL.LISP#496 at 9-Aug-88 21:53:59
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  "

(DEFUN QFASL-FILE-PLIST (FILE)
  "Return the attribute list of a compiled file."
  (WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE *fasl-byte-size*)
    (QFASL-STREAM-PROPERTY-LIST STREAM)))

))


; From modified file DJ: L.SYS; QFASL.LISP#496 at 9-Aug-88 21:54:29
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  "

(DEFUN FASL-APPEND (OUTFILE &REST INFILES)
  "Concatenate the contents of QFASL files INFILES into one QFASL file named OUTFILE."
  (WITH-OPEN-FILE (OSTREAM
		    (FS:MERGE-PATHNAME-DEFAULTS OUTFILE FS:LOAD-PATHNAME-DEFAULTS
						:QFASL)
		    :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE *fasl-byte-size*)
    (DO ((FILES INFILES (CDR FILES)))
	((NULL FILES))
      (WITH-OPEN-FILE (ISTREAM (FS:MERGE-PATHNAME-DEFAULTS
				 (CAR FILES) FS:LOAD-PATHNAME-DEFAULTS :QFASL)
			       :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE *fasl-byte-size*)
	;; Skip first two nibbles of all but the first file.
	(UNLESS (EQ FILES INFILES)
	  (SEND ISTREAM :TYI)
	  (SEND ISTREAM :TYI))
	(DO ((NIBBLE (SEND ISTREAM :TYI))
	     (NEXT1 (SEND ISTREAM :TYI))
	     (NEXT2))
	    ((NULL NIBBLE))
	  (SETQ NEXT2 (SEND ISTREAM :TYI))
	  (AND (OR NEXT2
		   (AND NEXT1 (NOT (ZEROP NEXT1)))
		   (AND (NULL (CDR FILES))	;Skip the last nonzero nibble
			(NOT (ZEROP NIBBLE))))	;of all files except the last.
	       (SEND OSTREAM :TYO NIBBLE))
	  (SETQ NIBBLE NEXT1
		NEXT1 NEXT2))))
    OUTFILE))

))

; From modified file DJ: L.SYS; QFASL.LISP#514 at 12-Aug-88 18:01:34
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFASL  "

(DEFUN QFASL-STREAM-PROPERTY-LIST (FASL-STREAM)
  (LET ((FASL-GENERIC-PLIST-RECEIVER (MAKE-INSTANCE 'SI:PROPERTY-LIST-MIXIN))
	(FASL-STREAM-BYPASS-P (OPERATION-HANDLED-P FASL-STREAM :GET-INPUT-BUFFER))
	*FASL-STREAM-ARRAY* *FASL-STREAM-INDEX* (*FASL-STREAM-COUNT* 0)
	;; smh 12aug88
	(*fasl-nibble-peek* ())
	(*fasl-nibble-8bit* (ecase (or (send-if-handles fasl-stream :byte-size)
				       (send fasl-stream :get :byte-size))
			      (8. t)
			      (16. nil)))
	(FASLOAD-FILE-PROPERTY-LIST-FLAG NIL)
	(FASL-TABLE NIL))
    ;; Set up the environment
    (FASL-START)
    ;; Start by making sure the file type in the first word is really SIXBIT/QFASL/.
    (LET ((W1 (FASL-NIBBLE))
	  (W2 (FASL-NIBBLE)))
      (OR (AND (= W1 #o143150) (= W2 #o71660))
	  (FERROR "~A is not a QFASL file" (SEND FASL-STREAM :PATHNAME))))
    (WHEN (= (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-version-info)
      (check-version-info))
    ;; Read in the file property list before choosing a package.
    (COND ((= (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-FILE-PROPERTY-LIST)
	   (FASL-FILE-PROPERTY-LIST)))
    (return-fasl-table)
;   (AND FASL-TABLE (RETURN-ARRAY (PROG1 FASL-TABLE (SETQ FASL-TABLE NIL))))
    (SEND FASL-GENERIC-PLIST-RECEIVER :PROPERTY-LIST)))

))