;;; -*- Mode:LISP; Readtable:ZL; Package:li; Base:8.; Cold-load: T -*- ;;; This is SYS: SYS; QFASL, a cold load file. ;;; ;;; LOAD, READFILE, and FASLOAD for the Lisp Machine ;;; ** (c) Copyright 1980, 1984 Massachusetts Institute of Technology ** ;;; ** (c) Copyright 1988 GigaMos Systems, Inc. ** ;;; 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). ;; the file property-list calls this when it is loaded in ... (defun fs:make-fasload-pathname (&rest foo) foo) (defvar *fasl-file-plist* nil "Plist of file being loaded.") (defvar *cold-load-file-plist* nil "Alist of pathnames as strings and their property lists.") ;;;QFASL-STREAM-PROPERTY-LIST, QFASL-FILE-PLIST needs to be added to these stubs in their final versions. +++ (DEFUN CHECK-MACROS-EXPANDED (MACRO-RECORD-LIST FUNCTION) "Look at a list of macros and sxhashes; report any whose sxhashes don't match." (declare (ignore macro-record-list function)) nil ) (defun RECORD-FILE-DEFINITIONS (&rest ignore) (declare (ignore ignore)) nil) (defun fasl-FIND-PACKAGE (pkg relative-package) (declare (ignore relative-package)) (find-package pkg)) ;;; The :FILE-ID-PACKAGE-ALIST property of a file-symbol is an a-list ;;; of packages and FILE-ID's for the version of that file loaded into ;;; that package. The FILE-ID is in the CADR rather the CDR, for expansibility. ;;; Record the fact that a file has been loaded (in a certain package) (defun SET-FILE-LOADED-ID (&rest ignore) (declare (ignore ignore)) nil) ;;; Get the version of a file that was loaded into a particular package, NIL if never loaded. ;;; If the package is given as NIL, the file's :PACKAGE property is used. (DEFUN GET-FILE-LOADED-ID (ACCESS-PATHNAME PKG) (declare (ignore ACCESS-PATHNAME PKG)) nil) (defun fasl-file-putprop (value property) (setf (getf *fasl-file-plist* property) value)) (defun fasl-file-remprop (property) (remf *fasl-file-plist* property)) ;;When this gets replaced in pathname its contract is to merge in properties as below. #| (DO ((PLIST PLIST (CDDR PLIST))) ((NULL PLIST)) (SEND FASL-GENERIC-PLIST-RECEIVER :PUTPROP (CADR PLIST) (CAR PLIST)) (WHEN ACCUMULATE-FASL-FORMS (PUSH `(SEND ',FASL-GENERIC-PLIST-RECEIVER :PUTPROP ',(CADR PLIST) ',(CAR PLIST)) LAST-FASL-FILE-FORMS))) |# (defun fasl-file-set-propery-list (plist) (setq *cold-load-file-plist* (delete (assoc fdefine-file-pathname *cold-load-file-plist*))) (push (cons fdefine-file-pathname plist) *cold-load-file-plist*) (setq *fasl-file-plist* plist)) (defun canonicalize-possibly-logical-pathnames () #|(LET ((SOURCE-PATHNAME (GETF PLIST :SOURCE-FILE-GENERIC-PATHNAME))) (COND ((AND SOURCE-PATHNAME (NOT (STRINGP FDEFINE-FILE-PATHNAME))) ;; If opened via a logical host, should record with that host in, even if ;; not compiled that way. (SETQ SOURCE-PATHNAME (SEND FDEFINE-FILE-PATHNAME :BACK-TRANSLATED-PATHNAME SOURCE-PATHNAME)) (SETQ FDEFINE-FILE-PATHNAME (SEND SOURCE-PATHNAME :GENERIC-PATHNAME)))))|# nil) (DEFUN FASL-OP-FILE-PROPERTY-LIST () (LET ((PLIST (FASL-NEXT-VALUE))) (SETQ FASL-FILE-PLIST PLIST) ;; Make the source file really correspond to where things were compiled from. (when FDEFINE-FILE-PATHNAME (canonicalize-possibly-logical-pathnames) (fasl-file-set-property-list plist))) (AND FASLOAD-FILE-PROPERTY-LIST-FLAG (SETQ FASL-RETURN-FLAG T))) (defun fasl-stream-pathname (stream) (declare (ignore stream)) nil) (defun fasl-generic-pathname (pathname) pathname) (defun fasl-stream-info (stream) (declare (ignore stream)) nil) ;;; So that functions can tell if they are being loaded out of, or compiled in, a patch file (DEFVAR THIS-IS-A-PATCH-FILE NIL ;;+++ Make resettable when able to. "Non-NIL while loading a patch file.") (DEFUN ATTRIBUTE-BINDINGS-FROM-LIST (ATTLIST PATHNAME) (DO* ((ATTLIST ATTLIST (CDDR ATTLIST)) (VARS NIL) (VALS NIL) (BINDING-FUNCTION) (prop (car attlist)) (val (cadr attlist))) ((NULL ATTLIST) (VALUES VARS VALS)) (MULTIPLE-VALUE-BIND (VARS1 VALS1) (if (SETQ BINDING-FUNCTION (GET (CAR ATTLIST) 'FILE-ATTRIBUTE-BINDINGS)) (FUNCALL BINDING-FUNCTION PATHNAME prop val) (case prop (:package (VALUES (NCONS '*PACKAGE*) (NCONS (PKG-FIND-PACKAGE val :ERROR ;; *package* )))) (:base (UNLESS (TYPEP VAL '(INTEGER 1 36.)) (FERROR 'INVALID-FILE-ATTRIBUTE "File ~A has an illegal -*- BASE:~*~S -*-" pathname ':BASE VAL)) (VALUES (LIST* '*READ-BASE* '*PRINT-BASE* NIL) (LIST* VAL VAL NIL))) (:Cold-load (VALUES (NCONS 'SI:FILE-IN-COLD-LOAD) (NCONS val))) (:patch-file (VALUES (NCONS 'THIS-IS-A-PATCH-FILE) (NCONS VAL))) (:readtable (VALUES (NCONS '*READTABLE*) (NCONS (SI:FIND-READTABLE-NAMED VAL :ERROR)))) (:fonts (VALUES (NCONS 'SI:READ-DISCARD-FONT-CHANGES) (NCONS T))) (:read ) (t (li:error "Unhandled Attribute list keyword" prop val)))) (SETQ VARS (NCONC VARS1 VARS) VALS (NCONC VALS1 VALS))))) ;;; Replace later (defun fset-carefully (sym data) (format t "~& ~s ~s ~s~&" (symbol-package sym) sym data) (setf (symbol-function sym) data) (unless (fboundp sym) (trap:illop "fset-carefully failed"))) (defmacro defprop (symbol value property) `(setf (get ',symbol ',property) ',value)) ;;;**************************************************************** ;;; ;;; these moved here from QMISC ;;; ;;;**************************************************************** (DEFUN ASSIGN-ALTERNATE (X) (PROG () L (COND ((NULL X) (RETURN NIL))) (SET (CAR X) (CADR X)) (SETQ X (CDDR X)) (GO L))) (DEFUN GET-ALTERNATE (X) (PROG (Y) L (COND ((NULL X) (RETURN (REVERSE Y)))) (SETQ Y (CONS (CAR X) Y)) (SETQ X (CDDR X)) (GO L))) (DEFUN ASSIGN-VALUES (INPUT-LIST &OPTIONAL (SHIFT 0) (INIT 0) (DELTA 1)) (PROG () L (COND ((NULL INPUT-LIST) (RETURN INIT))) (setf (get (car input-list) 'special) t) (SET (CAR INPUT-LIST) (global:LSH INIT SHIFT)) (SETQ INPUT-LIST (CDR INPUT-LIST)) (SETQ INIT (+ INIT DELTA)) (GO L))) ;;;**************************************************************** ;;; ;;; these moved here from QDEFS ;;; ;;;**************************************************************** ;;(GLOBAL:PROCLAIM '(GLOBAL:SPECIAL FASL-TABLE FASL-GROUP-LENGTH FASL-GROUP-FLAG FASL-RETURN-FLAG)) (DEFCONSTANT FASL-GROUP-FIELD-VALUES `( %FASL-GROUP-CHECK #o100000 %FASL-GROUP-FLAG #o40000 %FASL-GROUP-LENGTH #o37700 FASL-GROUP-LENGTH-SHIFT -6 %FASL-GROUP-TYPE #o77 %%FASL-GROUP-CHECK ,(byte 1 15.) %%FASL-GROUP-FLAG ,(byte 1 14.) %%FASL-GROUP-LENGTH ,(byte 8 6.) %%FASL-GROUP-TYPE ,(byte 6 0) )) (DEFCONSTANT FASL-TABLE-PARAMETERS '( FASL-NIL FASL-EVALED-VALUE FASL-TEM1 FASL-TEM2 FASL-TEM3 FASL-SYMBOL-HEAD-AREA FASL-SYMBOL-STRING-AREA FASL-OBARRAY-POINTER FASL-ARRAY-AREA FASL-FRAME-AREA FASL-LIST-AREA FASL-TEMP-LIST-AREA FASL-UNUSED FASL-UNUSED2 FASL-UNUSED3 FASL-UNUSED6 FASL-UNUSED4 FASL-UNUSED5 )) (defconstant FASL-TABLE-WORKING-OFFSET #o40) ;;;**************************************************************** ;;; ;;; these moved here from QCOM ;;; ;;;**************************************************************** (defconstant LENGTH-OF-FASL-TABLE 37773) ;;;**************************************************************** (DEFUN ENTER-FASL-TABLE (V) (OR (VECTOR-PUSH V FASL-TABLE) (VECTOR-PUSH-EXTEND V FASL-TABLE))) (DEFVAR FASL-GROUP-DISPATCH :UNBOUND "Array of functions to handle fasl ops, indexed by fasl op code.") (DEFCONSTant 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 fasl-op-k-compiled-function fasl-op-UNUSED13 fasl-op-UNUSED14 fasl-op-k-local-refs fasl-op-k-refs fasl-op-k-entry-points fasl-op-UNUSED15 ;; No more FASL ops; this is enough to completely fill the field, sigh. )) (DEFUN FASL-RESTART () (SETQ LAST-FASL-FILE-FORMS NIL) ;; Initialize the fasl table if necessary (SETQ FASL-GROUP-DISPATCH (ARRAY:ZL-MAKE-ARRAY (LENGTH FASL-OPS) ;; :AREA si:CONTROL-TABLES )) (DO ((I 0 (1+ I)) (L FASL-OPS (CDR L)) (N (LENGTH FASL-OPS))) ((not (< I N))) (SETF (AREF FASL-GROUP-DISPATCH I) (CAR L)))) (eval-when (compile) (defmacro import-lambda-macro (name) `(setf (nlisp:macro-function ,name) (lisp:macro-function ,name)))) (eval-when (compile) (import-lambda-macro 'loop) (import-lambda-macro 'with-open-file) (import-lambda-macro 'with-open-stream) (import-lambda-macro 'dolist) (import-lambda-macro 'with-timeout)) (defvar *fasl-nibble-peek* () "Holds a PEEKED fasl-nibble") (DEFVAR FASL-TABLE) ;;; The stream which we are fasloading off of. (DEFVAR FASL-STREAM) ;;; T if the stream supports :GET-INPUT-BUFFER (and therefore FASLOAD should use it) (DEFVAR FASL-STREAM-BYPASS-P) ;;; 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*) ;;; Bound to the object to send PUTPROP messages to, for file properties, etc. ;;; Can be a generic pathname, can be an instance of PROPERTY-LIST-MIXIN, ;;; or in MINI it is a random function which accepts appropriate args. (DEFVAR FASL-GENERIC-PLIST-RECEIVER NIL) ;;; Bound by FASL-GROUP to the length of the group being processed. (DEFVAR FASL-GROUP-LENGTH) ;;; Bound by FASL-GROUP to the flag bit of the nibble starting the group. (DEFVAR FASL-GROUP-FLAG) ;;; Bound by FASL-WHACK; set by a group to cause FASL-WHACK to return. (DEFVAR FASL-RETURN-FLAG) ;;; String reused as buffer by FASL-OP-SYMBOL. (DEFVAR FASL-OP-SYMBOL-TEMP-STRING NIL) (DEFVAR LAST-FASL-FILE-PACKAGE :UNBOUND "After FASLOAD returns, holds the package the file was loaded into.") (DEFVAR FASL-PACKAGE-SPECIFIED :UNBOUND "Holds the PKG argument to FASLOAD.") (DEFVAR FASLOAD-FILE-PROPERTY-LIST-FLAG :UNBOUND "T within FASLOAD-INTERNAL means exit after loading the file attribute list.") (DEFVAR FASL-FILE-PLIST :UNBOUND "Within FASLOAD, holds attribute list of this QFASL file.") (DEFVAR DONT-CONVERT-DESTINATIONS :UNBOUND "Within FASLOAD, T if destination fields in fefs in this QFASL file are already converted.") (DEFVAR PRINT-LOADED-FORMS NIL ;;; Needs to be resettable. +++ "Set by :PRINT argument to LOAD. Non-NIL means print the forms loaded.") (DEFVAR ACCUMULATE-FASL-FORMS NIL ;;;needs to be resettable. +++ "Non-NIL means FASLOAD should compute LAST-FASL-FILE-FORMS.") (DEFVAR LAST-FASL-FILE-FORMS :UNBOUND "FASLOAD sets this to a list of forms describing the file. Only if ACCUMULATE-FASL-FORMS is non-NIL, this variable is set to a list of forms which are equivalent to what was done by loading the file.") ;;; In this we accumulate a list of all forms evaluated at load time. ;;; Ordinary function defining is not included, nor is anything that is ;;; expected to record its action as a "definition" of any sort. ;;; This list is always created, and goes on the :RANDOM-FORMS property ;;; of the generic pathname. (DEFVAR FASL-FILE-EVALUATIONS) (DEFVAR MACRO-MISMATCH-FUNCTIONS NIL "List of functions fasloaded which had been compiled with different macro definitions. Each element of this list looks like (USING-FUNCTION-NAME MACRO-NAME GENERIC-PATHNAME).") (DEFVAR FASLOADED-FILE-TRUENAMES NIL "List of truenames of all fasl files loaded. Files loaded by MINI are represented by strings.") (defvar *fasl-table-free-list* nil) (defun allocate-fasl-table () (trap::without-interrupts (if *fasl-table-free-list* (setf (fill-pointer (setq fasl-table (pop *fasl-table-free-list*))) fasl-table-working-offset) (setq fasl-table (array:zl-make-array length-of-fasl-table ;; :area fasl-table-area :type array:art-q ;;was 'art-q-list :fill-pointer fasl-table-working-offset))))) (defun return-fasl-table () (trap::without-interrupts (when (typep fasl-table 'array) (push fasl-table *fasl-table-free-list*) (setq fasl-table nil)))) ;; T => trace nibbles, only if bypassing. ;; (so we don't trace what is done through mini) (DEFVAR FASL-TRACE-LOSSAGE NIL) #+(target lambda) (DEFVAR-RESETTABLE *READFILE-READ-FUNCTION* NIL NIL "If non-nil a function to use instead of READ") #+(target lambda) (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)))) ;;; This is the function which provides entry to fasload. ;;; NOTE WELL: If you change this, change MINI-FASLOAD too! #+(target lambda) (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))) global:(WITH-OPEN-FILE li:(STREAM (FS:MERGE-AND-SET-PATHNAME-DEFAULTS FILE-NAME FS:LOAD-PATHNAME-DEFAULTS DEFAULT-BINARY-FILE-TYPE) :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE 8.) li:(FASLOAD-INTERNAL STREAM PKG NO-MSG-P)))) (DEFUN k-FASLOAD-INTERNAL (&optional FASL-STREAM PKG NO-MSG-P) (LET* (*fasl-nibble-peek* (PATHNAME (fasl-stream-pathname fasl-stream)) (FDEFINE-FILE-PATHNAME (IF (STRINGP PATHNAME) PATHNAME (fasl-generic-pathname pathname))) (PATCH-SOURCE-FILE-NAMESTRING) (FDEFINE-FILE-DEFINITIONS) (FILE-ID (fasl-stream-info fasl-stream)) (FASL-STREAM-BYPASS-P nil) *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 t) ; dont-convert-cdr-codes (FASL-TABLE NIL) *FASL-FILE-PLIST*) ;; Set up the environment (FASL-START) (PUSH (CAR FILE-ID) FASLOADED-FILE-TRUENAMES) ;; Start by making sure the file type in the first word is really SIXBIT/QFASL/. (LET ((W1 (OR (fasl-nibble-from-8bit) 0)) (W2 (OR (fasl-nibble-from-8bit) 0))) (OR (AND (= W1 #o143150) (= W2 #o71660)) (FERROR "~A is not a QFASL file"))) (fasl-file-remprop :MACROS-EXPANDED) (WHEN (= (LOGAND (FASL-NIBBLE-FROM-8BIT-PEEK) %FASL-GROUP-TYPE) FASL-OP-version-info) (check-version-info)) ;; Read in the file property list before choosing a package. (WHEN (= (LOGAND (FASL-NIBBLE-FROM-8BIT-PEEK) %FASL-GROUP-TYPE) FASL-OP-FILE-PROPERTY-LIST) (FASL-FILE-PROPERTY-LIST)) ;; Enter appropriate environment defined by file property list #+(target lambda) (MULTIPLE-VALUE-BIND (VARS VALS) (ATTRIBUTE-BINDINGS-FROM-LIST (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 *fasl-file-plist*))) (REMF PLIST ':PACKAGE) PLIST) *fasl-file-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-FROM-8BIT-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. (fasl-file-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*)))) ;; hairy MULTIPLE-VALUE-BIND is wedging #+(target falcon) (fasl-top-level) (SETQ *FASL-STREAM-ARRAY* NIL) (SETQ LAST-FASL-FILE-FORMS (NREVERSE LAST-FASL-FILE-FORMS)))) ;;; This is the function which gets a 16-bit "nibble" from the fasl stream. ;; This is the fastest way to do this. (defun fasl-nibble-from-8bit () (cond (*fasl-nibble-peek* (prog1 *fasl-nibble-peek* (setq *fasl-nibble-peek* nil))) (t (k2:mini-fasl-read-16-bits)))) ;Previous definition of above, hacked for speed. ;(DEFSUBST FASL-NIBBLE-FROM-8BIT () ; (IF (PLUSP *FASL-STREAM-COUNT*) ; (PROG1 (AREF *FASL-STREAM-ARRAY* *FASL-STREAM-INDEX*) ; (WHEN FASL-TRACE-LOSSAGE ; (PRINT *FASL-STREAM-INDEX*) ; (PRIN1 (AREF *FASL-STREAM-ARRAY* *FASL-STREAM-INDEX*))) ; (INCF *FASL-STREAM-INDEX*) ; (DECF *FASL-STREAM-COUNT*)) ; (FASL-NIBBLE-FROM-8BIT-SLOW))) (defun fasl-nibble-from-8bit-peek () (cond (*fasl-nibble-peek* *fasl-nibble-peek*) (t (setq *fasl-nibble-peek* (fasl-nibble-from-8bit))))) (DEFUN FASL-START () (k2::kbug-stream-initialize k2:kbug-k-input-fasl-stream (hw:dpb k2:$$kbug-stream-flags-direction-to-k k2:%%kbug-stream-flags-direction 0) k2:kbug-input-fasl-stream-base (+ k2:kbug-input-fasl-stream-base k2:kbug-stream-buffer-size)) (SETQ LAST-FASL-FILE-FORMS NIL) ;; Initialize the fasl table if necessary (WHEN (NOT (BOUNDP 'FASL-GROUP-DISPATCH)) (SETQ FASL-GROUP-DISPATCH (ARRAY:ZL-MAKE-ARRAY (LENGTH FASL-OPS) ;; :AREA CONTROL-TABLES )) (DO ((I 0 (1+ I)) (L FASL-OPS (CDR L)) (N (LENGTH FASL-OPS))) ((not (< I N))) (SETF (AREF FASL-GROUP-DISPATCH I) (CAR L))))) ;(DEFUN FASL-OP-REL-FILE () ; (MULTIPLE-VALUE (*FASL-STREAM-ARRAY* *FASL-STREAM-INDEX* *FASL-STREAM-COUNT*) ; (QFASL-REL:REL-LOAD-STREAM FASL-STREAM ; *FASL-STREAM-ARRAY* ; *FASL-STREAM-INDEX* ; *FASL-STREAM-COUNT* ; FASL-PACKAGE-SPECIFIED))) ;;; FASL-GENERIC-PATHNAME-PLIST, FASL-STREAM, FASL-SOURCE-GENERIC-PATHNAME implicit arguments (DEFUN FASL-FILE-PROPERTY-LIST () ;; File property lists are all FASDed and FASLed in the keyword package, so ;; that what you FASD is what you FASL! (LET ((*PACKAGE* PKG-KEYWORD-PACKAGE) (FASLOAD-FILE-PROPERTY-LIST-FLAG T)) (FASL-WHACK-SAVE-FASL-TABLE))) (DEFUN FASL-OP-FILE-PROPERTY-LIST () (LET ((PLIST (FASL-NEXT-VALUE))) (SETQ FASL-FILE-PLIST PLIST) ;; Make the source file really correspond to where things were compiled from. (DO ((PLIST PLIST (CDDR PLIST))) ((NULL PLIST)) ; (WHEN PRINT-LOADED-FORMS ; (PRINT `(SEND ',FASL-GENERIC-PLIST-RECEIVER :PUTPROP ; ',(CADR PLIST) ',(CAR PLIST)))) (WHEN ACCUMULATE-FASL-FORMS (PUSH `,(CADR PLIST) LAST-FASL-FILE-FORMS)))) (AND FASLOAD-FILE-PROPERTY-LIST-FLAG (SETQ FASL-RETURN-FLAG T))) ;Cause FASL-WHACK to return ;;; A call to this function is written at the end of each QFASL file by the compiler. (DEFUN FASL-RECORD-FILE-MACROS-EXPANDED (FILE-MACROS-EXPANDED) ;; For files in cold load, this will be called at cold-load startup time. ;; For now, do nothing, just avoid bombing out. (WHEN FASL-GENERIC-PLIST-RECEIVER (SEND FASL-GENERIC-PLIST-RECEIVER :PUTPROP FILE-MACROS-EXPANDED :MACROS-EXPANDED) (CHECK-MACROS-EXPANDED FILE-MACROS-EXPANDED NIL))) (DEFVAR INHIBIT-MACRO-MISMATCH-WARNINGS 'BUILD-SYSTEM "Non-NIL inhibits warnings about loading functions compiled with different versions of macros.") ;;; The above variable should be off during initial system loadup. #+(target lambda) (ADD-INITIALIZATION 'SET-INHIBIT-MACRO-MISMATCH-WARNINGS '(AND (EQ INHIBIT-MACRO-MISMATCH-WARNINGS 'BUILD-SYSTEM) (not (EQ *TERMINAL-IO* COLD-LOAD-STREAM)) (SETQ INHIBIT-MACRO-MISMATCH-WARNINGS NIL #|*analyze-files-when-loaded* t|#)) '(:BEFORE-COLD :NORMAL)) ;;; This is the top-level loop of fasload, a separate function so ;;; that the file-opening and closing are separated out. ;;; The special variable FASL-STREAM is an implicit argument. (DEFUN FASL-TOP-LEVEL () (IF FASL-TABLE (INITIALIZE-FASL-TABLE)) (DO () ((EQ (FASL-WHACK) 'EOF))) T) ;;; This function processes one "whack" (independent section) of a fasl file. (DEFUN FASL-WHACK () (PROG1 (FASL-WHACK-SAVE-FASL-TABLE) (unless (null fasl-table) (return-fasl-table)))) ; (AND FASL-TABLE (RETURN-ARRAY (PROG1 FASL-TABLE (SETQ FASL-TABLE NIL)))))) (DEFUN FASL-WHACK-SAVE-FASL-TABLE (&AUX FASL-RETURN-FLAG) ; (RESET-TEMPORARY-AREA FASL-TABLE-AREA) (COND ((NULL FASL-TABLE) (allocate-fasl-table) ; (SETQ FASL-TABLE (ARRAY:ZL-MAKE-ARRAY LENGTH-OF-FASL-TABLE ; ;; :AREA FASL-TABLE-AREA ; :TYPE array:ART-Q ;;was 'art-q-LIST ; :FILL-POINTER FASL-TABLE-WORKING-OFFSET)) (INITIALIZE-FASL-TABLE))) ; (FASL-SET-MESA-EXIT-BASE) (DO () (FASL-RETURN-FLAG) (FASL-GROUP)) FASL-RETURN-FLAG) (DEFUN INITIALIZE-FASL-TABLE () #+(target lambda) (progn (SETF (AREF FASL-TABLE FASL-SYMBOL-HEAD-AREA) NR-SYM) (SETF (AREF FASL-TABLE FASL-SYMBOL-STRING-AREA) P-N-STRING) ; (SETF (AREF FASL-TABLE FASL-OBARRAY-POINTER) OBARRAY) (SETF (AREF FASL-TABLE FASL-ARRAY-AREA) WORKING-STORAGE-AREA) (SETF (AREF FASL-TABLE FASL-FRAME-AREA) MACRO-COMPILED-PROGRAM) (SETF (AREF FASL-TABLE FASL-LIST-AREA) WORKING-STORAGE-AREA) (SETF (AREF FASL-TABLE FASL-TEMP-LIST-AREA) FASL-TEMP-AREA)) ) ;;; Process one "group" (a single operation) (DEFUN FASL-GROUP () (LET (FASL-GROUP-FLAG FASL-GROUP-BITS FASL-GROUP-TYPE FASL-GROUP-LENGTH) (WHEN FASL-TRACE-LOSSAGE (PRINT 'GROUP)) (SETQ FASL-GROUP-BITS (FASL-NIBBLE-FROM-8BIT)) (WHEN (ZEROP (LOGAND FASL-GROUP-BITS %FASL-GROUP-CHECK)) (FERROR "Invalid QFASL file: first nibble of group is missing the check bit.")) (SETQ FASL-GROUP-FLAG (NOT (ZEROP (LOGAND FASL-GROUP-BITS %FASL-GROUP-FLAG)))) (SETQ FASL-GROUP-LENGTH (LDB %%FASL-GROUP-LENGTH FASL-GROUP-BITS)) (WHEN (= FASL-GROUP-LENGTH #o377) (SETQ FASL-GROUP-LENGTH (FASL-NIBBLE-FROM-8BIT))) (SETQ FASL-GROUP-TYPE (LOGAND FASL-GROUP-BITS %FASL-GROUP-TYPE)) (format *query-io* "~%FASL-GROUP-> ~S" (AREF FASL-GROUP-DISPATCH FASL-GROUP-TYPE)) (FUNCALL (AREF FASL-GROUP-DISPATCH FASL-GROUP-TYPE)))) ;;; Get next nibble out of current group (DEFUN FASL-NEXT-NIBBLE () (IF (not (MINUSP (SETQ FASL-GROUP-LENGTH (1- FASL-GROUP-LENGTH)))) (FASL-NIBBLE-FROM-8BIT) (FERROR "Invalid QFASL file: not enough nibbles in this group."))) ;;; Get next value for current group. Works by recursively evaluating a group. (DEFUN FASL-NEXT-VALUE () (let ((ans (AREF FASL-TABLE (FASL-GROUP)))) (format *error-output* "~&FASL-NEXT-VALUE -> ~s" ans) ans)) (DEFUN FASL-STORE-EVALED-VALUE (V) (SETF (AREF FASL-TABLE FASL-EVALED-VALUE) V) FASL-EVALED-VALUE) ;;;; FASL ops (DEFUN FASL-OP-ERR () (FERROR "Invalid QFASL file: group code 0 encountered.")) (DEFUN FASL-OP-NOOP () 0) (DEFUN FASL-OP-INDEX () (FASL-NEXT-NIBBLE)) (DEFUN FASL-OP-LARGE-INDEX () (DPB (FASL-NEXT-NIBBLE) (byte #o10 #o20) (FASL-NEXT-NIBBLE))) (DEFUN FASL-OP-STRING () (FASL-OP-SYMBOL T)) (DEFUN FASL-OP-SYMBOL (&OPTIONAL STRING-FLAG &AUX STRING) ;; Get reusable string to accumulate data in. (SETQ STRING (OR (trap::without-interrupts (prog1 fasl-op-symbol-temp-string (setq fasl-op-symbol-temp-string nil))) (array:zl-make-array #o1000 :element-type 'li:string-char :FILL-POINTER 0))) ;; Make sure it's long enough, though. (when (< (array-total-size STRING) (* 2 FASL-GROUP-LENGTH)) (SETQ STRING (array:zl-make-array (MAX (* 2 FASL-GROUP-LENGTH) (* 2 (array-total-size STRING))) :element-type 'li:string-char :FILL-POINTER 0))) (SETF (FILL-POINTER STRING) 0) ;; Read in the contents. (DO ((NIB)) ((ZEROP FASL-GROUP-LENGTH)) (SETQ NIB (FASL-NEXT-NIBBLE)) ;Two characters, packed. (VECTOR-PUSH (int-char (logand NIB #xff)) STRING) ;;First char. (UNLESS (hw:field= nib #x8000 (byte 8. 8.)) (VECTOR-PUSH (int-char (SI:LSH NIB -8.)) STRING))) ;;Second char. ;; Construct and record the desired object. (PROG1 (ENTER-FASL-TABLE (COND (STRING-FLAG (copy-seq STRING)) ((NOT FASL-GROUP-FLAG) (INTERN STRING)) (T (MAKE-SYMBOL (copy-seq STRING))))) ;; Arrange for reuse of the string. (SETQ FASL-OP-SYMBOL-TEMP-STRING STRING))) (DEFUN FASL-OP-PACKAGE-SYMBOL (&AUX (LEN FASL-GROUP-LENGTH) STR PKG DOUBLE-COLON) (DECLARE (SPECIAL STR PKG)) (IF (= LEN 1) (SETQ LEN (FASL-NEXT-NIBBLE)) (FORMAT *ERROR-OUTPUT* "This file is in the old format -- recompile the source.~%")) ;; This kludge is so that we can win without the package feature loaded. ;; Values of LEN that are meaningful nowadays are: ;; 402 - one prefix, double colon (ignore local package nicknames). ;; 2 -- one prefix, single colon. ;; 3 -- two prefixes, single colon (no longer produced by QFASD). ;; 4 -- three .... ;; FASL-GROUP-FLAG is non-NIL to allow internal symbols and creation of symbols. (AND (= LEN 402) (SETQ DOUBLE-COLON T LEN 2)) (SETQ STR (FASL-NEXT-VALUE)) (IF (AND FASL-GROUP-FLAG (EQUAL STR "")) ;; Prefix is just #: -- make uninterned symbol. (ENTER-FASL-TABLE (MAKE-SYMBOL STR)) ;; We want an interned symbol in some package. ;; Decode the first package prefix. (progn (SETQ PKG (OR (AND (NOT DOUBLE-COLON) (fasl-FIND-PACKAGE STR *package*)) (PKG-FIND-PACKAGE STR :ASK))) ;; Handle case of multiple prefixes (obsolete). (DO ((I (- LEN 2) (1- I))) ((<= I 0)) (SETQ STR (FASL-NEXT-VALUE)) (SETQ PKG (OR (fasl-FIND-PACKAGE STR *PACKAGE*) (PKG-FIND-PACKAGE STR :ASK)))) ;; Read in the pname. (SETQ STR (FASL-NEXT-VALUE)) (MULTIPLE-VALUE-BIND (SYM FLAG PKG-IN) ;; Get the symbol. (INTERN STR PKG) FLAG PKG-IN ; (WHEN (AND (si:MEMQ FLAG '(NIL :INTERNAL)) ; (Not (EQ PKG-IN PKG-KEYWORD-PACKAGE)) ; (NOT (PACKAGE-AUTO-EXPORT-P PKG-IN)) ; (NOT (si:MEMQ SYM FASL-INTERNAL-DONT-RECORD))) ; (PUSH (LIST SYM FDEFINE-FILE-PATHNAME) ; FASL-INTERNAL-SYMBOL-HISTORY)) ;; Ok, record the symbol we got. (ENTER-FASL-TABLE SYM))))) ;;; Generate a FIXNUM (or BIGNUM) value. (DEFUN FASL-OP-FIXED () (DO ((POS (SI:LSH (1- FASL-GROUP-LENGTH) 4) (- POS 16.)) (C FASL-GROUP-LENGTH (1- C)) (ANS 0)) ((ZEROP C) (COND (FASL-GROUP-FLAG (SETQ ANS (global:MINUS ANS)))) (format t "~& FASL-OP-FIXED ==> #d~d" ans) (ENTER-FASL-TABLE ANS)) (SETQ ANS (DPB (FASL-NEXT-NIBBLE) (byte 16. pos) ANS)))) ;;; Generate a CHARACTER value. (DEFUN FASL-OP-CHARACTER () (DO ((POS (SI:LSH (1- FASL-GROUP-LENGTH) 4) (- POS 16.)) (C FASL-GROUP-LENGTH (1- C)) (ANS 0)) ((ZEROP C) (COND (FASL-GROUP-FLAG (SETQ ANS (si:MINUS ANS)))) (SETQ ANS (hw:dpb-boxed vinc:$$dtp-character vinc:%%data-type ANS)) (ENTER-FASL-TABLE ANS)) (SETQ ANS (DPB (FASL-NEXT-NIBBLE) (byte 16. pos) ANS)))) (DEFUN FASL-OP-FLOAT () #+(target falcon) (li:error "fasl-op-float not handled on the k!") (IF FASL-GROUP-FLAG #+(target lambda)(FASL-OP-FLOAT-SMALL-FLOAT) #+(target lambda)(FASL-OP-FLOAT-FLOAT))) #+(target lambda) (DEFUN FASL-OP-FLOAT-SMALL-FLOAT NIL (LET ((AS-FIXNUM (%LOGDPB (FASL-NEXT-NIBBLE) #o2010 (FASL-NEXT-NIBBLE)))) ;; Change exponent from excess #o100 to excess #o200. (SETQ AS-FIXNUM (IF (ZEROP AS-FIXNUM) 0 (%POINTER-PLUS AS-FIXNUM #o40000000))) (ENTER-FASL-TABLE (%MAKE-POINTER DTP-SMALL-FLONUM AS-FIXNUM)))) #+(target lambda) (DEFUN FASL-OP-FLOAT-FLOAT () (LET ((ANS (FLOAT 0)) (TEM)) (%P-DPB-OFFSET (FASL-NEXT-NIBBLE) #o1013 ANS 0) (SETQ TEM (FASL-NEXT-NIBBLE)) (%P-DPB-OFFSET (LDB #o1010 TEM) #o0010 ANS 0) (%P-DPB-OFFSET (%LOGDPB TEM #o2010 (FASL-NEXT-NIBBLE)) #o0030 ANS 1) (ENTER-FASL-TABLE ANS))) ;;; hair squared (defun fasl-op-new-float () (li:error "Fasl-op-new-float needs conversion.") #+Incompatible (let ((sign (if fasl-group-flag -1 1)) (exponent-length (fasl-next-nibble)) (exponent 0) mantissa-length (mantissa 0) result) (cond ((< exponent-length 9.) ;small float (setq exponent (fasl-next-nibble)) (setq mantissa-length (fasl-next-nibble)) (cond ((< mantissa-length 18.) (do ((i 0 (1+ i)) (scale 1 (* scale (^ 2 16.)))) ((= i (ceiling mantissa-length 16.))) (setq mantissa (+ mantissa (* scale (fasl-next-nibble))))) (setq mantissa (logand mantissa (if (plusp sign) ;; nuke leading 1 (1- (^ 2 17.)) ;; nuke sign bit and leading 1 (1- (^ 2 16.))))) (setq result (%make-pointer dtp-small-flonum (%logdpb exponent (byte 8. 17.) mantissa))) ;;>> broken setf in 107 ;(setq result (%make-pointer dtp-small-flonum mantissa)) ;(setf (%short-float-exponent result) exponent)) ) (t (ferror "Fasl-op-new-float: Exponent length ~D, Mantissa length ~D" exponent-length mantissa-length)))) ((< exponent-length 12.) ;single float (setq exponent (fasl-next-nibble)) (unless (< exponent (^ 2 11.)) (setq exponent (- (logand (1- (^ 2 12.)) (^ 2 12.))))) (setq mantissa-length (fasl-next-nibble)) (cond ((< mantissa-length 32.) (do ((i 0 (1+ i)) (scale 1 (* scale (^ 2 16.)))) ((= i (ceiling mantissa-length 16.))) (setq mantissa (+ mantissa (* scale (fasl-next-nibble))))) (let ((number-cons-area working-storage-area)) (setq result (%float-double 0 1))) (setf (%single-float-mantissa result) (* sign mantissa) (%single-float-exponent result) exponent)) (t (ferror "Fasl-op-new-float: Exponent length ~D, Mantissa length ~D" exponent-length mantissa-length)))) (t (ferror "Fasl-op-new-float: Exponent length ~D" exponent-length))) (enter-fasl-table result)) ) (DEFUN FASL-OP-RATIONAL () (LET ((RAT (CL:// (FASL-NEXT-VALUE) (FASL-NEXT-VALUE)))) (ENTER-FASL-TABLE RAT))) (DEFUN FASL-OP-COMPLEX () (LET ((COMP (new-math:COMPLEX (FASL-NEXT-VALUE) (FASL-NEXT-VALUE)))) (ENTER-FASL-TABLE COMP))) ;the NEWDRAW system redefines this ... if you change it please let LMI know (DEFUN FASL-OP-LIST (&OPTIONAL AREA COMPONENT-FLAG &AUX (LIST-LENGTH (FASL-NEXT-NIBBLE)) LST) #+(target lambda) (IF (NULL AREA) (SETQ AREA (AREF FASL-TABLE FASL-LIST-AREA))) (SETQ LST (MAKE-LIST LIST-LENGTH ;; :AREA AREA )) ;Make the list (DO ((P LST (CDR P)) ;Store the contents (N LIST-LENGTH (1- N))) ((ZEROP N)) (SETF (CAR P) (FASL-NEXT-VALUE))) (COND (FASL-GROUP-FLAG (DOTIFY LST))) ;Flag means "last pair is dotted" (IF (NULL COMPONENT-FLAG) (ENTER-FASL-TABLE LST) (FASL-STORE-EVALED-VALUE LST))) (DEFUN FASL-OP-TEMP-LIST () (FASL-OP-LIST #+(target lambda) (AREF FASL-TABLE FASL-TEMP-LIST-AREA) )) ;;; This one leaves the value in FASL-EVALED-VALUE instead of adding it to FASL-TABLE, ;;; thus avoiding bloatage. (DEFUN FASL-OP-LIST-COMPONENT () (FASL-OP-LIST NIL T)) ;;; The argument must be a linear list. ;;; Note (hope) that the GC cannot unlinearize a linear list. ;;; The CAR of LAST of it becomes the CDR of LAST. (DEFUN DOTIFY (ARG) (DO ((LST ARG (CDR LST))) ;Find the 2nd to last CONS of it ((NULL (CDDR LST)) (rplacd lst (cadr lst))))) ;;;; Array stuff ;;; FASL-OP-ARRAY arguments are ;;; Area ;;; Type symbol ;;; The dimension or dimension list (use temp-list) ;;; Displace pointer (NIL if none) ;;; Leader (NIL, number, or list) (use temp-list) ;;; Index offset (NIL if none) ;;; []named-structure-p, if flag set, else this value not supplied (DEFUN FASL-OP-ARRAY () (LET ((AREA (FASL-NEXT-VALUE)) ;Area ;; With luck, this LET* does whatever the &AUX above was intended to do ;; with less disasterous byproducts. (TYPE (LET ((*PACKAGE* PKG-GLOBAL-PACKAGE)) (FASL-NEXT-VALUE))) ;Type symbol (DIMS (FASL-NEXT-VALUE)) ;Dimensions (DISP (FASL-NEXT-VALUE)) ;Displaced-p (LEAD (FASL-NEXT-VALUE)) ;Leader (IOFF (FASL-NEXT-VALUE)) ;Index-offset (NSP (IF FASL-GROUP-FLAG ;Named-structure-p (FASL-NEXT-VALUE) NIL))) (ENTER-FASL-TABLE (ARRAY:ZL-MAKE-ARRAY DIMS :TYPE TYPE ;; :AREA AREA :DISPLACED-TO DISP :DISPLACED-INDEX-OFFSET IOFF :LEADER-LENGTH (IF (CONSP LEAD) (LENGTH LEAD) LEAD) :LEADER-LIST (IF (CONSP LEAD) (REVERSE LEAD)) :NAMED-STRUCTURE-SYMBOL NSP)))) ;;; Get values and store them into an array. (DEFUN FASL-OP-INITIALIZE-ARRAY (&OPTIONAL LOAD-16BIT-MODE &AUX ARRAY NUM TEM-ARRAY HACK) (SETQ HACK (FASL-GROUP)) (SETQ ARRAY (AREF FASL-TABLE HACK)) (unless (vinc:arrayp array) (li:error "Not an array in fasl-op-initialize-array.")) (SETQ NUM (FASL-NEXT-VALUE)) ;Number of values to initialize with (SETQ TEM-ARRAY ;Indirect array used to store into it (ARRAY:ZL-MAKE-ARRAY NUM ;; :AREA FASL-TABLE-AREA :TYPE (IF (NOT LOAD-16BIT-MODE) (array:array-type ARRAY) array:ART-16B) :DISPLACED-TO ARRAY :FILL-POINTER 0)) (DO ((N NUM (1- N))) ((ZEROP N)) ;Initialize specified num of vals (LET ((N (FASL-NIBBLE-FROM-8BIT-PEEK))) (IF (= (LOGAND %FASL-GROUP-TYPE N) FASL-OP-NULL-ARRAY-ELEMENT) (PROGN (FASL-NIBBLE-FROM-8BIT) (VECTOR-PUSH NIL TEM-ARRAY) ;;;+++ Make an unbound value instead of nil. #+(target lambda) (%P-STORE-DATA-TYPE (ALOC ARRAY (1- (FILL-POINTER TEM-ARRAY))) DTP-NULL)) (VECTOR-PUSH (FASL-NEXT-VALUE) TEM-ARRAY)))) ;(RETURN-ARRAY (PROG1 TEM-ARRAY (SETQ TEM-ARRAY NIL))) (IF (array:named-structure-p ARRAY) (WHEN (si:MEMQ :FASLOAD-FIXUP (array:NAMED-STRUCTURE-INVOKE :WHICH-OPERATIONS ARRAY)) (array:NAMED-STRUCTURE-INVOKE :FASLOAD-FIXUP ARRAY))) HACK) ;;; Get nibbles and store them into 16-bit hunks of an array. (DEFUN FASL-OP-INITIALIZE-NUMERIC-ARRAY (&AUX ARRAY NUM TEM-ARRAY HACK) (SETQ HACK (FASL-GROUP)) (SETQ ARRAY (AREF FASL-TABLE HACK)) (unless (vinc:arrayp array) (li:error "Not an array in fasl-op-initialize-numeric-array.")) (SETQ NUM (FASL-NEXT-VALUE)) ;# of vals to initialize (SETQ TEM-ARRAY (ARRAY:ZL-MAKE-ARRAY NUM ;; :AREA FASL-TABLE-AREA :ELEMENT-TYPE '(UNSIGNED-BYTE 16.) :DISPLACED-TO ARRAY :FILL-POINTER 0)) (DO ((N NUM (1- N))) ((ZEROP N)) (VECTOR-PUSH (FASL-NIBBLE-FROM-8BIT) TEM-ARRAY)) ;(RETURN-ARRAY (PROG1 TEM-ARRAY (SETQ TEM-ARRAY NIL))) HACK) (DEFUN FASL-OP-ARRAY-PUSH () (LET ((VECTOR (FASL-NEXT-VALUE))) (VECTOR-PUSH (FASL-NEXT-VALUE) VECTOR)) 0) (DEFUN FASL-OP-EVAL () (ferror "Obsolete QFASL file.")) ; (LET ((FORM (AREF FASL-TABLE (FASL-NEXT-NIBBLE)))) ; (WHEN (OR (ATOM FORM) (Not (EQ (CAR FORM) 'FUNCTION))) ; (WHEN PRINT-LOADED-FORMS (PRINT FORM)) ; (WHEN ACCUMULATE-FASL-FORMS ; (PUSH FORM LAST-FASL-FILE-FORMS)) ; (PUSH FORM FASL-FILE-EVALUATIONS)) ; (FASL-STORE-EVALED-VALUE (EVAL FORM))) ; NIL) (DEFUN FASL-OP-EVAL1 () (LET ((FORM (FASL-NEXT-VALUE))) (WHEN (OR (ATOM FORM) (Not (EQ (CAR FORM) 'FUNCTION))) (WHEN PRINT-LOADED-FORMS (PRINT FORM)) (WHEN ACCUMULATE-FASL-FORMS (PUSH FORM LAST-FASL-FILE-FORMS)) (unless (AND (CONSP FORM) (OR (GET (CAR FORM) 'QFASL-DONT-RECORD) #+(target lambda)(ignore-errors (si:assq 'qfasl-dont-record (debugging-info (car form)))) (AND (EQ (CAR FORM) 'FDEFINE) (EQ (FOURTH FORM) T)) (AND (EQ (CAR FORM) 'DEFPROP) (GET (FOURTH FORM) 'QFASL-DONT-RECORD)))) (PUSH FORM FASL-FILE-EVALUATIONS))) (ENTER-FASL-TABLE (EVAL FORM)))) (DEFUN FASL-OP-MOVE () (LET ((FROM (FASL-NEXT-NIBBLE)) (TO (FASL-NEXT-NIBBLE))) (IF (= TO #o177777) (ENTER-FASL-TABLE (AREF FASL-TABLE FROM)) (progn (SETF (AREF FASL-TABLE TO) (AREF FASL-TABLE FROM)) TO)))) (DEFVAR *SNAP-INDEXED-FORWARDS* NIL) (DEFUN FASL-OP-FRAME () (li:error "Lambda function found in compiled file")) (DEFUN FASL-OP-FUNCTION-HEADER () (fasl-op-frame)) (DEFUN FASL-OP-FUNCTION-END () (fasl-op-frame)) (DEFUN FASL-OP-STOREIN-SYMBOL-CELL () (LET ((CELL (FASL-NEXT-NIBBLE)) (DATA (FASL-NEXT-VALUE)) (SYM (FASL-NEXT-VALUE))) (cond ((= 1 CELL) (SET SYM DATA) (WHEN PRINT-LOADED-FORMS (PRINT `(SETQ ,SYM ',DATA))) (WHEN ACCUMULATE-FASL-FORMS (PUSH `(SETQ ,SYM ',DATA) LAST-FASL-FILE-FORMS))) ((= 2 CELL) (SETF (SYMBOL-FUNCTION SYM) DATA) (WHEN PRINT-LOADED-FORMS (PRINT `(FSET ',SYM ',DATA))) (WHEN ACCUMULATE-FASL-FORMS (PUSH `(FSET ',SYM ',DATA) LAST-FASL-FILE-FORMS))) ((= 3 CELL) (SETF (SYMBOL-PLIST SYM) DATA) (WHEN PRINT-LOADED-FORMS (PRINT `(SETF (SYMBOL-PLIST ,SYM) ',DATA))) (WHEN ACCUMULATE-FASL-FORMS (PUSH `(SETF (SYMBOL-PLIST ',SYM) ',DATA) LAST-FASL-FILE-FORMS))) (t (li:error "FASL-OP-STOREIN-SYMBOL-CELL unhandled cell number." cell)))) 0) (DEFUN FASL-OP-STOREIN-SYMBOL-VALUE () (LET ((DATA (AREF FASL-TABLE (FASL-NEXT-NIBBLE))) (SYM (FASL-NEXT-VALUE))) (SET SYM DATA) (PUSH `(SETQ ,SYM ',DATA) FASL-FILE-EVALUATIONS) (WHEN PRINT-LOADED-FORMS (PRINT (CAR FASL-FILE-EVALUATIONS))) (WHEN ACCUMULATE-FASL-FORMS (PUSH (CAR FASL-FILE-EVALUATIONS) LAST-FASL-FILE-FORMS))) 0) (DEFUN FASL-OP-STOREIN-FUNCTION-CELL () (LET* ((index (FASL-NEXT-NIBBLE)) (DATA (AREF FASL-TABLE index)) (SYM (FASL-NEXT-VALUE))) (FSET-CAREFULLY SYM DATA) (WHEN PRINT-LOADED-FORMS (PRINT `(SETF (SYMBOL-FUNCTION ',SYM) ',DATA))) (WHEN ACCUMULATE-FASL-FORMS (PUSH `(SETF (SYMBOL-FUNCTION ',SYM) ',DATA) LAST-FASL-FILE-FORMS))) 0) (DEFUN FASL-OP-STOREIN-PROPERTY-CELL () (LET ((DATA (AREF FASL-TABLE (FASL-NEXT-NIBBLE))) (SYM (FASL-NEXT-VALUE))) (SETF (SYMBOL-PLIST SYM) DATA) (PUSH `(SETF (SYMBOL-PLIST ',SYM) ',DATA) FASL-FILE-EVALUATIONS) (WHEN PRINT-LOADED-FORMS (PRINT (CAR FASL-FILE-EVALUATIONS))) (WHEN ACCUMULATE-FASL-FORMS (PUSH (CAR FASL-FILE-EVALUATIONS) LAST-FASL-FILE-FORMS))) 0) (DEFUN FASL-OP-STOREIN-ARRAY-LEADER () (LET ((ARRAY (AREF FASL-TABLE (FASL-NEXT-NIBBLE))) (SUBSCR (AREF FASL-TABLE (FASL-NEXT-NIBBLE))) (VALUE (AREF FASL-TABLE (FASL-NEXT-NIBBLE)))) #-incompatible (li:error "Can't store into array leaders yet." array subscr value) #+Incompatible (SETF (ARRAY-LEADER ARRAY SUBSCR) VALUE)) 0) (DEFUN FASL-OP-FETCH-SYMBOL-VALUE () (ENTER-FASL-TABLE (SYMBOL-VALUE (FASL-NEXT-VALUE)))) (DEFUN FASL-OP-FETCH-FUNCTION-CELL () (ENTER-FASL-TABLE (SYMBOL-FUNCTION (FASL-NEXT-VALUE)))) (DEFUN FASL-OP-FETCH-PROPERTY-CELL () (ENTER-FASL-TABLE (SYMBOL-PLIST (FASL-NEXT-VALUE)))) (DEFUN FASL-OP-APPLY () (LET ((COUNT (FASL-NEXT-NIBBLE)) (FCTN (FASL-NEXT-VALUE)) V P) (when (plusp count) (setq v (SETQ P (si:NCONS ;;-IN-AREA (FASL-NEXT-VALUE) ;; (AREF FASL-TABLE FASL-TEMP-LIST-AREA) ))) (DOTIMES (I (1- COUNT)) (SETF (CDR P) (SETQ P (si:NCONS ;;-IN-AREA (FASL-NEXT-VALUE) ;;; (AREF FASL-TABLE FASL-TEMP-LIST-AREA) ))))) (WHEN ACCUMULATE-FASL-FORMS (PUSH `(APPLY ',FCTN ',V) LAST-FASL-FILE-FORMS)) ; (WHEN PRINT-LOADED-FORMS ; (PRINT `(APPLY ',FCTN ',V))) (PUSH `(,FCTN) FASL-FILE-EVALUATIONS) (FASL-STORE-EVALED-VALUE (APPLY FCTN V)))) (DEFUN FASL-OP-END-OF-WHACK () (SETQ FASL-RETURN-FLAG 'END-OF-WHACK) 0) (DEFUN FASL-OP-END-OF-FILE () (SETQ FASL-RETURN-FLAG 'EOF) 0) (DEFUN FASL-OP-SOAK () (LET ((COUNT (FASL-NEXT-NIBBLE))) (DOTIMES (I COUNT) (FASL-NEXT-VALUE))) (FASL-GROUP)) (DEFUN FASL-OP-SET-PARAMETER () (LET ((TO (FASL-NEXT-VALUE)) (FROM (FASL-GROUP))) (SETF (AREF FASL-TABLE (EVAL TO)) (AREF FASL-TABLE FROM))) 0) #+(target lambda) (DEFUN FASL-APPEND (OUTFILE &REST INFILES) "Concatenate the contents of QFASL files INFILES into one QFASL file named OUTFILE." global:(WITH-OPEN-FILE li:(OSTREAM (FS:MERGE-PATHNAME-DEFAULTS OUTFILE FS:LOAD-PATHNAME-DEFAULTS :QFASL) :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE 8.) li:(DO ((FILES INFILES (CDR FILES))) ((NULL FILES)) (global:WITH-OPEN-FILE (ISTREAM (FS:MERGE-PATHNAME-DEFAULTS (CAR FILES) FS:LOAD-PATHNAME-DEFAULTS :QFASL) :DIRECTION :INPUT :CHARACTERS NIL :BYTE-SIZE 8.) ;; 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)))) li:OUTFILE)) (defun fasl-make-vector (size) (array:make-vector size)) (defun fasl-op-k-compiled-function () (let* ((length (ash fasl-group-length -2)) (function (cons:allocate-structure k2:compiled-function-structure-size 0 k2:$$dtp-compiled-function (cons:make-header k2:$$dtp-compiled-function-header length))) (code-addr (fasl-k-function-instructions length function))) (setf (k2:%compiled-function-code function) (k2:addr->pc code-addr)) ;; Now that we have the actual function object (let ((name (fasl-next-value)) (local-refs (fasl-next-value)) (refs (fasl-next-value)) (entry-points (fasl-next-value))) (setf (k2:%compiled-function-name function) name) (setf (k2:%compiled-function-length function) length) (setf (k2:%compiled-function-local-refs function) local-refs) (setf (k2:%compiled-function-refs function) refs) (setf (k2:%compiled-function-entry-points function) entry-points) (fasl-k-function-immediates code-addr) (fasl-k-function-load-time-evals code-addr) (fasl-link-function function code-addr)) ;; Now we've got it all hooked up, let's put it into the FASL table. (enter-fasl-table function) (fasl-group) ;Do the store, or discard a NIL if anonymous. )) (defun fasl-write-instruction (address 1st 2nd 3rd 4th) (map-fault:call-while-allowing-write-in-read-only #'(lambda () (hw:write-md-unboxed (hw:dpb-unboxed 2nd (byte 16. 16.) 1st)) (hw:vma-start-write-no-gc-trap-unboxed address) ;; Write the high half (hw:write-md-unboxed (hw:dpb-unboxed 4th (byte 16. 16.) 3rd)) (hw:vma-start-write-no-gc-trap-unboxed (hw:24+ 1 address)) nil))) (defun fasl-link-function (function address) (k2:relocate-local-refs function address) (k2:link-refs function address)) ;;; avoid consing, read into an array 4 times bigger thane the number of insts. (defun fasl-k-function-instructions (length function) (let* ((address (cons:allocate-code-space length function gr:*default-code-area*)) (code-addr (hw:24+ 2 address))) ;; (setf (%compiled-function-starting-address function) code-addr) (do ((i 0 (1+ i)) (addr code-addr (hw:24+ 2 addr))) ((>= i length)) (fasl-write-instruction addr (fasl-next-nibble) (fasl-next-nibble) (fasl-next-nibble) (fasl-next-nibble))) code-addr)) (defun fasl-k-function-immediates (code-adr) (let ((immeds (fasl-next-value))) (dotimes (i immeds) (k2:write-boxed-immediate (hw:24+ (ash (fasl-next-value) 1) code-adr) (fasl-next-value))))) ;;; Set the load-time-eval immediate values for a particular function. (defun fasl-k-function-load-time-evals (code-adr) (loop repeat (fasl-next-value) for idx = (fasl-next-value) for form = (fasl-next-value) do (k2:write-boxed-immediate (hw:24+ (ash idx 1.) code-adr) (eval form)))) (defun fasl-op-k-local-refs () (let ((locals (fasl-next-value))) (do ((i 0 (+ i 2)) (locs (fasl-make-vector (* 2 locals)))) ((>= i (* 2 locals)) (enter-fasl-table locs)) (setf (aref locs i) (fasl-next-value)) ;ref offset (setf (aref locs (1+ i)) (fasl-next-value)) ;target offset ))) (defun fasl-op-k-refs () (let ((k-refs (fasl-next-value))) (do ((i 0 (+ i 3)) (refs (fasl-make-vector (* 3 k-refs)))) ((>= i (* 3 k-refs)) (enter-fasl-table refs)) (setf (aref refs i) (fasl-next-value)) ;ref offset (setf (aref refs (1+ i)) (fasl-next-value)) ;referenced function name (setf (aref refs (+ i 2)) (fasl-next-value)) ;number of args ))) (defun fasl-op-k-entry-points () (let ((entries (fasl-next-value))) (do ((i 0 (+ i 2)) (ents (fasl-make-vector (* 2 entries)))) ((>= i (* 2 entries)) (enter-fasl-table ents)) (setf (aref ents i) (fasl-next-value)) ;number of args (setf (aref ents (1+ i)) (fasl-next-value)) ;entry offset ))) (defvar *machine-fasling-on* #+(target lambda)(compiler::target-processor-symbol) #+(target falcon) :falcon) (defvar *fasl-version* 2) (defun check-version-info () (fasl-whack) t) (defun fasl-op-version-info () (let ((machine (fasl-next-value)) (version (fasl-next-value))) (unless (eql machine *machine-fasling-on*) (ferror "File was compiled for ~A and is being loaded on ~A." machine *machine-fasling-on*)) (cond ((eql version *fasl-version*)) ;; Versions 1 and 2 are compatible on the Lambda. ((and (eql version 1) (eql *fasl-version* 2) (eql *machine-fasling-on* :lambda))) (t (ferror "Fasl version is ~A, was expecting version ~A." version *fasl-version*))) (enter-fasl-table ())))