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