;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Base:8 -*-
;;; LOAD, READFILE, and FASLOAD for the Lisp Machine
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

(DECLARE
  (SPECIAL FASL-GROUP-DISPATCH	;Array of FASL-OP- functions
	   FASL-STREAM		;The input stream
	   FASL-STREAM-BYPASS-P ;T if FASL-STREAM knows about :GET-INPUT-BUFFER 
	   FASL-STREAM-ARRAY    ; Input data in bypass mode
	   FASL-STREAM-INDEX    ;
	   FASL-STREAM-COUNT    ;
	   )
  (SPECIAL FASL-GROUP-LENGTH FASL-GROUP-FLAG FASL-RETURN-FLAG
	   FASLOAD-FILE-PROPERTY-LIST-FLAG PKG-IS-LOADED-P FDEFINE-FILE-PATHNAME
	   FASL-GENERIC-PATHNAME-PLIST)
  )

;If this is non-NIL, we accumulate a set of forms which
;describe all the side effects specified by this file.
;This is a hack not used by anything in the system.
(DECLARE (SPECIAL ACCUMULATE-FASL-FORMS))

;This is where we accumulate all the forms.
(DECLARE (SPECIAL LAST-FASL-FILE-FORMS))

;Remember which package the last qfasl file was loaded into.
(DECLARE (SPECIAL LAST-FASL-FILE-PACKAGE))

;Holds a copy of the PKG arg to FASLOAD where FASL-OP-REL-FILE can see it.
(DECLARE (SPECIAL FASL-PACKAGE-SPECIFIED))

;Load a file, the appropriate way, into the appropriate package.
;If the type is specified, we use it;  otherwise, we try QFASL and then LISP.
;NONEXISTENT-OK-FLAG if non-NIL means no error if file doesn't exist.
;DONT-SET-DEFAULT-P = NIL means update the defaults as well.
(DEFUN LOAD (FILENAME &OPTIONAL PKG NONEXISTENT-OK-FLAG DONT-SET-DEFAULT-P NO-MSG-P
		      &AUX PATHNAME OPEN-PATHNAME STREAM)
  (SETQ PATHNAME (FS:PARSE-PATHNAME FILENAME NIL FS:LOAD-PATHNAME-DEFAULTS))
  (UNWIND-PROTECT
    (DO () (NIL)	;Loop until we get a file open
      ;; If no file type or version (no ITS fn2) was specified, first look for the QFASL.
      (OR (AND (MEMQ (FUNCALL PATHNAME ':TYPE) '(NIL :UNSPECIFIC))
	       (MEMQ (FUNCALL PATHNAME ':VERSION) '(NIL :UNSPECIFIC))
	       (NOT (STRINGP (SETQ STREAM
				   (OPEN (SETQ OPEN-PATHNAME
					       (FS:MERGE-PATHNAME-DEFAULTS PATHNAME
							FS:LOAD-PATHNAME-DEFAULTS "QFASL"))
					 ':ERROR NIL ':CHARACTERS ':DEFAULT)))))
	  (SETQ STREAM (OPEN (SETQ OPEN-PATHNAME
				   (FS:MERGE-PATHNAME-DEFAULTS PATHNAME
						FS:LOAD-PATHNAME-DEFAULTS "LISP"))
			     ':ERROR NIL ':CHARACTERS ':DEFAULT)))
      (COND ((NOT (STRINGP STREAM))		;Okay, we have a file open
	     ;; Set the defaults from the pathname we finally opened
	     (OR DONT-SET-DEFAULT-P
		 (FS:SET-DEFAULT-PATHNAME OPEN-PATHNAME FS:LOAD-PATHNAME-DEFAULTS))
	     ;; If the file was a character file, read it, else try to fasload it.
	     (RETURN (FUNCALL (IF (FUNCALL STREAM ':CHARACTERS)
				  #'READFILE-INTERNAL #'FASLOAD-INTERNAL)
			      STREAM PKG NO-MSG-P)))
	    (NONEXISTENT-OK-FLAG		;User wants to ignore errors
	     (RETURN NONEXISTENT-OK-FLAG))
	    (T					;Get a new pathname from the user
	     (SETQ PATHNAME
		   (FS:FILE-PROCESS-ERROR STREAM OPEN-PATHNAME T NIL
		     (FS:MERGE-PATHNAME-DEFAULTS PATHNAME FS:LOAD-PATHNAME-DEFAULTS NIL NIL)
		     NIL NIL)))))
    ;; Cleanup form
    (AND STREAM (NOT (STRINGP STREAM)) (CLOSE STREAM))))

(DEFUN READFILE (FILE-NAME &OPTIONAL PKG NO-MSG-P)
  (WITH-OPEN-FILE (STREAM (FS:MERGE-AND-SET-PATHNAME-DEFAULTS FILE-NAME
			    FS:LOAD-PATHNAME-DEFAULTS "LISP")
			  '(:READ))
    (READFILE-INTERNAL STREAM PKG NO-MSG-P)))

(DEFUN READFILE-INTERNAL (STANDARD-INPUT PKG NO-MSG-P)
  (LET* ((FILE-ID (FUNCALL STANDARD-INPUT ':INFO))
	 (PATHNAME (FUNCALL STANDARD-INPUT ':PATHNAME))
	 (GENERIC-PATHNAME (FUNCALL PATHNAME ':GENERIC-PATHNAME))
	 (PACKAGE PACKAGE)
	 (FDEFINE-FILE-PATHNAME GENERIC-PATHNAME))
    (FS:FILE-READ-PROPERTY-LIST GENERIC-PATHNAME STANDARD-INPUT)
    ;; Enter appropriate environment for the file
    (MULTIPLE-VALUE-BIND (VARS VALS) (FS:FILE-PROPERTY-BINDINGS GENERIC-PATHNAME)
      (PROGV VARS VALS
	;; If package overridden, do so.  PACKAGE is bound in any case.
	(COND (PKG (SETQ PACKAGE (PKG-FIND-PACKAGE PKG)))
	      (NO-MSG-P)			;And tell user what it was unless told not to
	      (T (FORMAT T "~&Loading ~A into package ~A~%" PATHNAME PACKAGE)))
	(DO ((EOF '(()))
	     (FORM))
	    ((EQ (SETQ FORM (READ STANDARD-INPUT EOF)) EOF))
	  (EVAL FORM))
	(SET-FILE-LOADED-ID PATHNAME FILE-ID PACKAGE)
	PATHNAME))))

;This is the function which provides entry to fasload.
;NOTE WELL: If you change this, change MINI-FASLOAD too!
(DEFUN FASLOAD (FILE-NAME &OPTIONAL PKG NO-MSG-P)
  (WITH-OPEN-FILE (STREAM (FS:MERGE-AND-SET-PATHNAME-DEFAULTS FILE-NAME
			    FS:LOAD-PATHNAME-DEFAULTS "QFASL")
			  '(:READ :FIXNUM))
    (FASLOAD-INTERNAL STREAM PKG NO-MSG-P)))

(DEFUN FASLOAD-INTERNAL (FASL-STREAM PKG NO-MSG-P)
  (LET* ((PATHNAME (FUNCALL FASL-STREAM ':PATHNAME))
	 (FDEFINE-FILE-PATHNAME (FUNCALL PATHNAME ':GENERIC-PATHNAME))
	 (FASL-GENERIC-PATHNAME-PLIST
			(LOCF (FS:PATHNAME-PROPERTY-LIST FDEFINE-FILE-PATHNAME)))
	 (FILE-ID (FUNCALL FASL-STREAM ':INFO))
	 (FASL-STREAM-BYPASS-P
			(MEMQ ':GET-INPUT-BUFFER (FUNCALL FASL-STREAM ':WHICH-OPERATIONS)))
	 FASL-STREAM-ARRAY FASL-STREAM-INDEX (FASL-STREAM-COUNT 0)
	 (FASLOAD-FILE-PROPERTY-LIST-FLAG NIL)
	 (FASL-PACKAGE-SPECIFIED PKG)
	 (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 143150) (= W2 71660))
	    (FERROR NIL "~A is not a QFASL file" PATHNAME)))
      ;; 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)))
      ;; Enter appropriate environment defined by file property list
      (MULTIPLE-VALUE-BIND (VARS VALS) (FS:FILE-PROPERTY-BINDINGS FDEFINE-FILE-PATHNAME)
	(PROGV VARS VALS
	  (LET ((PACKAGE (PKG-FIND-PACKAGE (OR PKG PACKAGE) ':ASK)))
	    (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 T "~&Loading ~A into package ~A~%" PATHNAME PACKAGE))
	    (SETQ LAST-FASL-FILE-PACKAGE PACKAGE)
	    (FASL-TOP-LEVEL)		;load it.
	    (SET-FILE-LOADED-ID PATHNAME FILE-ID PACKAGE))))
      (SETQ FASL-STREAM-ARRAY NIL)
      (SETQ LAST-FASL-FILE-FORMS (NREVERSE LAST-FASL-FILE-FORMS))
      PATHNAME))

(DEFUN QFASL-STREAM-PROPERTY-LIST (FASL-STREAM &AUX PLIST)
  (LET ((FASL-GENERIC-PATHNAME-PLIST (LOCF PLIST))
	(FASL-STREAM-BYPASS-P
	  (MEMQ ':GET-INPUT-BUFFER (FUNCALL FASL-STREAM ':WHICH-OPERATIONS)))
	FASL-STREAM-ARRAY FASL-STREAM-INDEX (FASL-STREAM-COUNT 0)
	(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 143150) (= W2 71660))
	  (FERROR NIL "~A is not a QFASL file" (FUNCALL FASL-STREAM ':PATHNAME))))
    ;; 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)))
    (AND FASL-TABLE (RETURN-ARRAY (PROG1 FASL-TABLE (SETQ FASL-TABLE NIL)))))
  PLIST)

;This is the function which gets a 16-bit "nibble" from the fasl file.
(DEFUN FASL-NIBBLE NIL
    (COND (FASL-STREAM-BYPASS-P
	   (COND ((<= FASL-STREAM-COUNT 0)
		  (COND (FASL-STREAM-ARRAY
			 (FUNCALL FASL-STREAM ':ADVANCE-INPUT-BUFFER)))
		  (MULTIPLE-VALUE (FASL-STREAM-ARRAY FASL-STREAM-INDEX FASL-STREAM-COUNT)
		    (FUNCALL FASL-STREAM ':GET-INPUT-BUFFER))))
	   (PROG1 (AREF FASL-STREAM-ARRAY FASL-STREAM-INDEX)
		  (SETQ FASL-STREAM-INDEX (1+ FASL-STREAM-INDEX))
		  (SETQ FASL-STREAM-COUNT (1- FASL-STREAM-COUNT))))
	  (T (FUNCALL FASL-STREAM ':TYI))))

;Look ahead at the next nibble without discarding it.
(DEFUN FASL-NIBBLE-PEEK ()
  (COND (FASL-STREAM-BYPASS-P
	  (PROG1 (FASL-NIBBLE)
		 (SETQ FASL-STREAM-COUNT (1+ FASL-STREAM-COUNT))
		 (SETQ FASL-STREAM-INDEX (1- FASL-STREAM-INDEX))))
	(T (LET ((TEM (FUNCALL FASL-STREAM ':TYI)))
	     (FUNCALL FASL-STREAM ':UNTYI TEM)
	     TEM))))

(DEFUN FASL-START ()
  (OR (BOUNDP 'ACCUMULATE-FASL-FORMS) (SETQ ACCUMULATE-FASL-FORMS NIL))
  (SETQ LAST-FASL-FILE-FORMS NIL)
  ;;Initialize the fasl table if necessary
  (COND ((NOT (BOUNDP 'FASL-GROUP-DISPATCH))
	 (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))
	   (ASET (CAR L) FASL-GROUP-DISPATCH I)))))

(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 "" package, so
  ;; that what you FASD is what you FASL!
  (LET ((PACKAGE (PKG-FIND-PACKAGE ""))
	(FASLOAD-FILE-PROPERTY-LIST-FLAG T))
    (FASL-WHACK-SAVE-FASL-TABLE)))

(DEFUN FASL-OP-FILE-PROPERTY-LIST ()
  (LET ((PLIST (FASL-NEXT-VALUE)))
    ;; Make the source file really correspond to where things were compiled from.
    (AND FDEFINE-FILE-PATHNAME
	 (LET ((SOURCE-PATHNAME (GET (LOCF 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 (FUNCALL FDEFINE-FILE-PATHNAME
						 ':BACK-TRANSLATED-PATHNAME SOURCE-PATHNAME))
		  (SETQ FDEFINE-FILE-PATHNAME (FUNCALL SOURCE-PATHNAME
						       ':GENERIC-PATHNAME))
		  (SETQ FASL-GENERIC-PATHNAME-PLIST
			(LOCF (FS:PATHNAME-PROPERTY-LIST FDEFINE-FILE-PATHNAME)))))))
    (DO ((PLIST PLIST (CDDR PLIST)))
	((NULL PLIST))
      (PUTPROP FASL-GENERIC-PATHNAME-PLIST (CADR PLIST) (CAR PLIST))
      (AND ACCUMULATE-FASL-FORMS
	   (PUSH `(DEFPROP ,FASL-GENERIC-PATHNAME-PLIST ,(CADR PLIST) ,(CAR PLIST))
		 LAST-FASL-FILE-FORMS))))
  (AND FASLOAD-FILE-PROPERTY-LIST-FLAG (SETQ FASL-RETURN-FLAG T))) ;Cause FASL-WHACK to return

;;; 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 (ACCESS-PATHNAME FILE-ID PKG &AUX GENERIC-PATHNAME TEM)
  (SETQ GENERIC-PATHNAME
	(IF (TYPEP ACCESS-PATHNAME ':INSTANCE)
	    (FUNCALL ACCESS-PATHNAME ':GENERIC-PATHNAME)
	    ACCESS-PATHNAME))
  (IF (SETQ TEM (ASSQ PKG (FUNCALL GENERIC-PATHNAME ':GET ':FILE-ID-PACKAGE-ALIST)))
      (RPLACA (CDR TEM) FILE-ID)
      (FUNCALL GENERIC-PATHNAME ':PUSH-PROPERTY
	       (LIST PKG FILE-ID ACCESS-PATHNAME)
		  ':FILE-ID-PACKAGE-ALIST)))

;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 (PATHNAME PKG)
  (AND (NULL PKG)
       (SETQ PKG (FUNCALL (FUNCALL PATHNAME ':GENERIC-PATHNAME) ':GET ':PACKAGE)))
  (CADR (LET ((PROP (FUNCALL PATHNAME ':GET ':FILE-ID-PACKAGE-ALIST)))
	  (IF PKG (ASSQ (PKG-FIND-PACKAGE PKG) PROP) (CAR PROP)))))

;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 ()
  (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)
	 (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)
	 (SETQ FASL-TABLE (MAKE-ARRAY LENGTH-OF-FASL-TABLE
				      ':AREA FASL-TABLE-AREA
				      ':TYPE 'ART-Q-LIST 
				      ':LEADER-LIST (LIST FASL-TABLE-WORKING-OFFSET)))
	 ;LEADER FOR FILLING
	 (INITIALIZE-FASL-TABLE)))
;   (FASL-SET-MESA-EXIT-BASE)
    (DO () (FASL-RETURN-FLAG)
	(FASL-GROUP))
    FASL-RETURN-FLAG)

(DEFUN INITIALIZE-FASL-TABLE NIL 
	(AS-1 'NR-SYM FASL-TABLE FASL-SYMBOL-HEAD-AREA)
	(AS-1 'P-N-STRING FASL-TABLE FASL-SYMBOL-STRING-AREA)
;	(AS-1 OBARRAY FASL-TABLE FASL-OBARRAY-POINTER)
	(AS-1 'FASL-CONSTANTS-AREA FASL-TABLE FASL-ARRAY-AREA)
	(AS-1 'MACRO-COMPILED-PROGRAM FASL-TABLE FASL-FRAME-AREA)
	(AS-1 'FASL-CONSTANTS-AREA FASL-TABLE FASL-LIST-AREA)
	(AS-1 'FASL-TEMP-AREA FASL-TABLE FASL-TEMP-LIST-AREA)
)

;Process one "group" (a single operation)
(DEFUN FASL-GROUP NIL 
  (PROG (FASL-GROUP-FLAG FASL-GROUP-BITS FASL-GROUP-TYPE FASL-GROUP-LENGTH)
	(SETQ FASL-GROUP-BITS (FASL-NIBBLE))
	(COND ((ZEROP (LOGAND FASL-GROUP-BITS %FASL-GROUP-CHECK))
	       (FERROR NIL "FASL-GROUP-NIBBLE-WITHOUT-CHECK-BIT: ~O" FASL-GROUP-BITS)))
	(SETQ FASL-GROUP-FLAG (NOT (ZEROP (LOGAND FASL-GROUP-BITS 
						  %FASL-GROUP-FLAG))))
	(SETQ FASL-GROUP-LENGTH (LDB %%FASL-GROUP-LENGTH FASL-GROUP-BITS))
	(AND (= FASL-GROUP-LENGTH 377)
	     (SETQ FASL-GROUP-LENGTH (FASL-NIBBLE)))
	(SETQ FASL-GROUP-TYPE (LOGAND FASL-GROUP-BITS %FASL-GROUP-TYPE))
	(RETURN (FUNCALL (AR-1 FASL-GROUP-DISPATCH FASL-GROUP-TYPE)))
))

;Get next nibble out of current group
(DEFUN FASL-NEXT-NIBBLE NIL 
	(COND ((ZEROP FASL-GROUP-LENGTH)
	       (FERROR NIL "FASL-GROUP-OVERFLOW"))
	      (T (SETQ FASL-GROUP-LENGTH (1- FASL-GROUP-LENGTH))
		 (FASL-NIBBLE))))

;Get next value for current group.  Works by recursively evaluating a group.
(DEFUN FASL-NEXT-VALUE NIL 
  (AR-1 FASL-TABLE (FASL-GROUP)))

(DEFUN FASL-STORE-EVALED-VALUE (V)
  (AS-1 V FASL-TABLE FASL-EVALED-VALUE)
  FASL-EVALED-VALUE)

;FASL-OP's that create a value end up by calling this.  The value is saved
;away in the FASL-TABLE for later use, and the index is returned (as the 
;result of FASL-GROUP).
(DEFUN ENTER-FASL-TABLE (V)
  (OR (ARRAY-PUSH FASL-TABLE V)
      (FERROR NIL "FASL table overflow in ~S" V)))

;--FASL OPS

(DEFUN FASL-OP-ERR NIL
       (FERROR NIL "FASL-OP-ERR ENCOUNTERED"))

(DEFUN FASL-OP-NOOP NIL 0)

(DEFUN FASL-OP-INDEX NIL (FASL-NEXT-NIBBLE))

(DEFUN FASL-OP-STRING NIL (FASL-OP-SYMBOL T))

(DEFUN FASL-OP-SYMBOL (&OPTIONAL STRING-FLAG
		       &AUX STRING SYM TEM)
	(SETQ STRING (MAKE-ARRAY (* 2 FASL-GROUP-LENGTH)
				 ':AREA (AR-1 FASL-TABLE FASL-SYMBOL-STRING-AREA)
				 ':TYPE 'ART-STRING))
	(DO ((IDX 0)
	     (NIB))
	    ((ZEROP FASL-GROUP-LENGTH)
	     (ADJUST-ARRAY-SIZE STRING IDX))
	  (SETQ NIB (FASL-NEXT-NIBBLE))		;Two characters, packed.
	  (AS-1 NIB STRING IDX)
	  (SETQ IDX (1+ IDX))
	  (OR (= (AS-1 (LSH NIB -8) STRING IDX)	;Pad doesn't count toward length
		 200)
	      (SETQ IDX (1+ IDX))))
	(ENTER-FASL-TABLE (COND (STRING-FLAG STRING)
				((NOT FASL-GROUP-FLAG)
				 (MULTIPLE-VALUE (SYM TEM)
				   (INTERN STRING 
					   ;(AR-1 FASL-TABLE FASL-OBARRAY-POINTER)
					   ))
				 (COND (TEM (RETURN-ARRAY STRING)))
				 SYM)
				(T (MAKE-SYMBOL STRING))))) ;DON'T INTERN IF FLAG SET

(LOCAL-DECLARE ((SPECIAL STR PKG))
(DEFUN FASL-OP-PACKAGE-SYMBOL (&AUX (LEN FASL-GROUP-LENGTH) STR PKG OLDP)
    (COND ((NOT (= LEN 1))
	   (FORMAT T "This file is in the old format -- recompile the source.~%")
	   )
	  (T (SETQ LEN (FASL-NEXT-NIBBLE))))
    ;; This kludge is so that we can win without the package feature loaded.    
    (COND ((AND (BOUNDP 'PKG-IS-LOADED-P)
		PKG-IS-LOADED-P)
	   (SETQ STR (FASL-NEXT-VALUE))
	   (SETQ PKG (PKG-FIND-PACKAGE STR ':ASK))
	   (DO I (- LEN 2) (1- I) (<= I 0)
	     (SETQ STR (FASL-NEXT-VALUE))
	     (SETQ PKG (OR (CADR (ASSOC STR (PKG-REFNAME-ALIST PKG))) PKG)))
	   (ENTER-FASL-TABLE (INTERN (FASL-NEXT-VALUE) PKG)))
	  (T (COND ((> LEN 2)
		    (PRINT "PACKAGE LEADER MORE THAN 2 LONG")
		    (DO I (- LEN 2) (1- I) (<= I 0) (FASL-NEXT-VALUE))))
	     (COND ((= LEN 1)
		    (ENTER-FASL-TABLE (INTERN (FASL-NEXT-VALUE))))
		   (T	;Must search through the world to find the correct symbol.  First
			;try the obarray.
		    (SETQ PKG (INTERN (FASL-NEXT-VALUE)))	;Package name in SI
		    (IF (MEMQ PKG '(SI SYSTEM-INTERNALS GLOBAL))
			(SETQ PKG NIL))				;As COLDLD does
		    (MULTIPLE-VALUE (STR OLDP) (INTERN (FASL-NEXT-VALUE)))
		    (COND ((EQ (CAR (PACKAGE-CELL-LOCATION STR)) PKG))	;Right one
			  ((NOT OLDP)			;Making symbol afresh
			   (RPLACA (PACKAGE-CELL-LOCATION STR) PKG))
			  ((*CATCH 'FASL-OP-PACKAGE-SYMBOL	;Must be uninterned, search
				   (MAPATOMS-NR-SYM
				     #'(LAMBDA (SYM)
					 (AND (EQ (CAR (PACKAGE-CELL-LOCATION SYM)) PKG)
					      (STRING-EQUAL (GET-PNAME SYM) (GET-PNAME STR))
					      (*THROW 'FASL-OP-PACKAGE-SYMBOL
						      (SETQ STR SYM)))))))
			  (T				;Not around, make new uninterned sym
			   (SETQ STR (MAKE-SYMBOL (GET-PNAME STR) T))
			   (RPLACA (PACKAGE-CELL-LOCATION STR) PKG)))
		    (ENTER-FASL-TABLE STR)))))))

;Generate a FIXNUM (or BIGNUM) value.
(DEFUN FASL-OP-FIXED NIL 
  (DO ((POS (LSH (1- FASL-GROUP-LENGTH) 4) (- POS 20))
       (C FASL-GROUP-LENGTH (1- C))
       (ANS 0))
      ((ZEROP C) (COND (FASL-GROUP-FLAG (SETQ ANS (MINUS ANS))))
		 (ENTER-FASL-TABLE ANS))
    (SETQ ANS (DPB (FASL-NEXT-NIBBLE) (+ (LSH POS 6) 20) ANS))))

(DEFUN FASL-OP-FLOAT NIL
  (COND (FASL-GROUP-FLAG (FASL-OP-FLOAT-SMALL-FLOAT))
	(T (FASL-OP-FLOAT-FLOAT))))

(DEFUN FASL-OP-FLOAT-SMALL-FLOAT NIL
  (PROG (ANS)
	(SETQ ANS (%LOGDPB (FASL-NEXT-NIBBLE) 2010 (FASL-NEXT-NIBBLE)))
	(RETURN (ENTER-FASL-TABLE (%MAKE-POINTER DTP-SMALL-FLONUM ANS)))))

(DEFUN FASL-OP-FLOAT-FLOAT NIL
  (PROG (ANS TMP)
	(SETQ ANS (FLOAT 0))
	(%P-DPB-OFFSET (FASL-NEXT-NIBBLE) 1013 ANS 0)
	(SETQ TMP (FASL-NEXT-NIBBLE))
	(%P-DPB-OFFSET (LDB 1010 TMP) 0010 ANS 0)
	(%P-DPB-OFFSET (%LOGDPB TMP 2010 (FASL-NEXT-NIBBLE)) 0030 ANS 1)
	(RETURN (ENTER-FASL-TABLE ANS))))

(DEFUN FASL-OP-RATIONAL ()
  (LET ((RAT (MAKE-RATIONAL (FASL-NEXT-VALUE) (FASL-NEXT-VALUE))))
    (ENTER-FASL-TABLE RAT)))
		
(DEFUN FASL-OP-LIST (&OPTIONAL AREA COMPONENT-FLAG
		     &AUX (LIST-LENGTH (FASL-NEXT-NIBBLE)) LST)
  (IF (NULL AREA) (SETQ AREA (AR-1 FASL-TABLE FASL-LIST-AREA)))
  (SETQ LST (MAKE-LIST AREA LIST-LENGTH))	;MAKE THE LIST
  (DO ((P LST (CDR P))			;STORE THE CONTENTS
       (N LIST-LENGTH (1- N)))
      ((ZEROP N))
    (RPLACA 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 NIL 
  (FASL-OP-LIST (AR-1 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 NIL
  (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))
       (OR (= (%P-CDR-CODE LST) CDR-NEXT)	;Make sure someone didn't screw up
	   (FERROR NIL "~S is not a linear list" ARG))
       (%P-STORE-CDR-CODE LST CDR-NORMAL)	;Change last 2 single-Q nodes to one double-Q node
       (%P-DPB-OFFSET CDR-ERROR %%Q-CDR-CODE LST 1)	;Fix 2nd cdr code for error checking
       ARG)))

;Array stuff

;FASL-OP-ARRAY arguments are
; <value>  Area 
; <value>  Type symbol
; <value>  The dimension or dimension list (use temp-list)
; <value>  Displace pointer (NIL if none)
; <value>  Leader (NIL, number, or list) (use temp-list)
; <value>  Index offset (NIL if none)
(DEFUN FASL-OP-ARRAY ()
  (ENTER-FASL-TABLE (MAKE-ARRAY (FASL-NEXT-VALUE) 	;AREA
				(FASL-NEXT-VALUE)	;TYPE SYMBOL
				(FASL-NEXT-VALUE)	;DIMENSIONS
				(FASL-NEXT-VALUE)	;DISPLACED-P
				(FASL-NEXT-VALUE)	;LEADER
				(FASL-NEXT-VALUE) 	;INDEX-OFFSET
				(COND (FASL-GROUP-FLAG
				       (FASL-NEXT-VALUE))
				      (T NIL)))))

;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 (AR-1 FASL-TABLE HACK))
	(CHECK-ARG ARRAY ARRAYP "an array")
	(SETQ NUM (FASL-NEXT-VALUE))	;NUMBER OF VALUES TO INITIALIZE WITH
	(SETQ TEM-ARRAY			;INDIRECT ARRAY USED TO STORE INTO IT
	      (MAKE-ARRAY NUM
			  ':AREA 'FASL-TABLE-AREA 
			  ':TYPE (COND ((NOT LOAD-16BIT-MODE) 
					(%P-MASK-FIELD %%ARRAY-TYPE-FIELD ARRAY))
				       (T ART-16B))
			  ':DISPLACED-TO ARRAY
			  ':LEADER-LIST '(0)))
	(DO N NUM (1- N) (ZEROP N)	;INITIALIZE SPECIFIED NUM OF VALS
	  (ARRAY-PUSH TEM-ARRAY (FASL-NEXT-VALUE)))
	(RETURN-ARRAY TEM-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 (AR-1 FASL-TABLE HACK))
	(CHECK-ARG ARRAY ARRAYP "an array")
	(SETQ NUM (FASL-NEXT-VALUE))	;# OF VALS TO INITIALIZE
	(SETQ TEM-ARRAY 
	      (MAKE-ARRAY NUM
			  ':AREA 'FASL-TABLE-AREA 
			  ':TYPE 'ART-16B
			  ':DISPLACED-TO ARRAY
			  ':LEADER-LIST '(0)))
	(DO N NUM (1- N) (ZEROP N)
	  (ARRAY-PUSH TEM-ARRAY (FASL-NIBBLE)))
	(RETURN-ARRAY TEM-ARRAY)
	HACK)

(DEFUN FASL-OP-ARRAY-PUSH NIL 
  (PROG (ARRAY DATA) 
	(COND ((NULL (ARRAY-PUSH 
			(SETQ ARRAY (FASL-NEXT-VALUE))
			(SETQ DATA (FASL-NEXT-VALUE))))
		(FERROR NIL "ARRAY-PUSH failed for ~S" ARRAY)))
	(RETURN 0)))

(DEFUN FASL-OP-EVAL NIL 	;MUST NOT BE USED UNTIL EVAL LOADED!!
  (PROG ((FORM (AR-1 FASL-TABLE (FASL-NEXT-NIBBLE))))
	(AND ACCUMULATE-FASL-FORMS
	     (NOT (EQ (CAR FORM) 'FUNCTION))
	     (PUSH FORM
		   LAST-FASL-FILE-FORMS))
	(FASL-STORE-EVALED-VALUE (EVAL FORM))))

(DEFUN FASL-OP-EVAL1 NIL 
  (PROG ((FORM (FASL-NEXT-VALUE)))
	(AND ACCUMULATE-FASL-FORMS
	     (NOT (EQ (CAR FORM) 'FUNCTION))
	     (PUSH FORM LAST-FASL-FILE-FORMS))
	(RETURN (ENTER-FASL-TABLE (EVAL FORM)))))

(DEFUN FASL-OP-MOVE NIL 
 (PROG (FROM TO)
	(SETQ FROM (FASL-NEXT-NIBBLE))
	(SETQ TO (FASL-NEXT-NIBBLE))
	(COND ((= TO 177777) (RETURN (ENTER-FASL-TABLE (AR-1 FASL-TABLE FROM))))
	      (T (AS-1 (AR-1 FASL-TABLE FROM) FASL-TABLE TO)
		 (RETURN TO)))))

(DEFUN FASL-OP-FRAME NIL 
  (LET ((Q-COUNT (FASL-NEXT-NIBBLE))		;NUMBER OF BOXED QS
	(UNBOXED-COUNT (FASL-NEXT-NIBBLE))	;NUMBER OF UNBOXED QS (HALF NUM INSTRUCTIONS)
	(SIZE NIL)				;TOTAL NUMBER OF QS
	(FEF NIL)				;THE FEF BEING CREATED
	(OBJ NIL)
	(TEM NIL)
	(OFFSET NIL)
	)
     (SETQ FASL-GROUP-LENGTH (FASL-NEXT-NIBBLE))	;AMOUNT OF STUFF THAT FOLLOWS
     (SETQ FEF (%ALLOCATE-AND-INITIALIZE	;CREATE THE FEF
		  DTP-FEF-POINTER		;DATA TYPE OF RETURNED POINTER
		  DTP-HEADER (FASL-NEXT-VALUE)		;HEADER (1ST WORD OF FEF)
		  (SETQ SIZE (+ Q-COUNT UNBOXED-COUNT))	;TOTAL SIZE Q (2ND WORD OF FEF)
		  (AR-1 FASL-TABLE FASL-FRAME-AREA)	;AREA TO ALLOCATE IN
		  SIZE))			;AMOUNT TO ALLOCATE
     (FASL-NEXT-NIBBLE)				;SKIP MODIFIER NIBBLE FOR HEADER Q
     (DO I 1 (1+ I) (>= I Q-COUNT)		;FILL IN BOXED QS
       (SETQ OBJ (FASL-NEXT-VALUE))		;GET OBJECT TO BE STORED
       (SETQ TEM (FASL-NEXT-NIBBLE))		;GET ULTRA-KLUDGEY MODIFIER
       (OR (ZEROP (SETQ OFFSET (LOGAND 17 TEM)))	;ADD OFFSET IF NECESSARY
	   (SETQ OBJ (%MAKE-POINTER-OFFSET DTP-LOCATIVE OBJ OFFSET)))
       (%P-STORE-CONTENTS-OFFSET OBJ FEF I)		;STORE IT
       (%P-DPB-OFFSET (LSH TEM -6) %%Q-CDR-CODE FEF I)	;MUNG CDR CODE
;      (%P-DPB-OFFSET (LSH TEM -5) %%Q-FLAG-BIT FEF I)	;MUNG FLAG BIT
       (AND (BIT-TEST 20 TEM)			;MAKE INTO EXTERNAL VALUE CELL POINTER
	    (%P-DPB-OFFSET DTP-EXTERNAL-VALUE-CELL-POINTER
			   %%Q-DATA-TYPE FEF I))
       (AND (BIT-TEST 400 TEM)			;MAKE INTO LOCATIVE
	    (%P-DPB-OFFSET DTP-LOCATIVE %%Q-DATA-TYPE FEF I)))
     (DO ((I Q-COUNT (1+ I)))			;NOW STORE UNBOXED QS
	 ((>= I SIZE))
       (%P-DPB-OFFSET (FASL-NEXT-NIBBLE)	;STORE LOW-ORDER HALFWORD
		      %%Q-LOW-HALF FEF I)
       (%P-DPB-OFFSET (FASL-NEXT-NIBBLE)	;THEN HIGH-ORDER HALFWORD
		      %%Q-HIGH-HALF FEF I))
     (ENTER-FASL-TABLE FEF)))

(DEFUN FASL-OP-FUNCTION-HEADER NIL 
  (PROG (FCTN F-SXH)
	(SETQ FCTN (FASL-NEXT-VALUE))
	(SETQ F-SXH (FASL-NEXT-VALUE))
	(RETURN 0)))

(DEFUN FASL-OP-FUNCTION-END NIL
	0)

(DEFUN FASL-OP-STOREIN-SYMBOL-VALUE NIL 
  (PROG (DATA SYM)
	(SETQ DATA (AR-1 FASL-TABLE (FASL-NEXT-NIBBLE)))
	(SETQ SYM (FASL-NEXT-VALUE))
	(SET SYM DATA)
	(AND ACCUMULATE-FASL-FORMS
	     (PUSH `(SETQ ,SYM ',DATA)
		   LAST-FASL-FILE-FORMS))
	(RETURN 0)))

(DEFUN FASL-OP-STOREIN-FUNCTION-CELL NIL 
  (PROG (DATA SYM)
	(SETQ DATA (AR-1 FASL-TABLE (FASL-NEXT-NIBBLE)))
	(SETQ SYM (FASL-NEXT-VALUE))
	(FSET-CAREFULLY SYM DATA)
	(AND ACCUMULATE-FASL-FORMS
	     (PUSH `(FSET ',SYM ',DATA)
		   LAST-FASL-FILE-FORMS))
	(RETURN 0)))

(DEFUN FASL-OP-STOREIN-PROPERTY-CELL NIL 
  (PROG (SYM DATA)
	(SETQ DATA (AR-1 FASL-TABLE (FASL-NEXT-NIBBLE)))
	(%P-STORE-CONTENTS (PROPERTY-CELL-LOCATION (SETQ SYM (FASL-NEXT-VALUE)))
			   DATA)
	(AND ACCUMULATE-FASL-FORMS
	     (PUSH `(SETPLIST ',SYM ',DATA)
		   LAST-FASL-FILE-FORMS))
	(RETURN 0)))

(DEFUN FASL-OP-STOREIN-ARRAY-LEADER NIL
   (PROG (ARRAY SUBSCR VALUE)
	(SETQ ARRAY (AR-1 FASL-TABLE (FASL-NEXT-NIBBLE)))
	(SETQ SUBSCR (AR-1 FASL-TABLE (FASL-NEXT-NIBBLE)))
	(SETQ VALUE (AR-1 FASL-TABLE (FASL-NEXT-NIBBLE)))
	(STORE-ARRAY-LEADER VALUE ARRAY SUBSCR)
	(RETURN 0)))

(DEFUN FASL-OP-FETCH-SYMBOL-VALUE NIL 
  (PROG (SYM)
	(RETURN (ENTER-FASL-TABLE (SYMEVAL (SETQ SYM (FASL-NEXT-VALUE)))))))

(DEFUN FASL-OP-FETCH-FUNCTION-CELL NIL 
  (PROG (SYM)
	(RETURN (ENTER-FASL-TABLE (CDR (FUNCTION-CELL-LOCATION 
					   (SETQ SYM (FASL-NEXT-VALUE))))))))

(DEFUN FASL-OP-FETCH-PROPERTY-CELL NIL 
  (PROG (SYM)
	(RETURN (ENTER-FASL-TABLE (CDR (PROPERTY-CELL-LOCATION 
					  (SETQ SYM (FASL-NEXT-VALUE))))))))

(DEFUN FASL-OP-APPLY NIL 
  (PROG (COUNT FCTN V P)
	(SETQ COUNT (FASL-NEXT-NIBBLE))
	(SETQ FCTN (FASL-NEXT-VALUE))
	(SETQ P (VALUE-CELL-LOCATION V))
L	(COND ((ZEROP COUNT) (GO X)))
	(RPLACD P (SETQ P (NCONS-IN-AREA (FASL-NEXT-VALUE) 
					 (AR-1 FASL-TABLE 
					       FASL-TEMP-LIST-AREA))))
	(SETQ COUNT (1- COUNT))
	(GO L)
X	(AND ACCUMULATE-FASL-FORMS
	     (PUSH `(APPLY ',FCTN ',V)
		   LAST-FASL-FILE-FORMS))
	(RETURN (FASL-STORE-EVALED-VALUE (APPLY FCTN V)))))

(DEFUN FASL-OP-END-OF-WHACK NIL 
  (SETQ FASL-RETURN-FLAG 'END-OF-WHACK)
  0)

(DEFUN FASL-OP-END-OF-FILE NIL 
  (SETQ FASL-RETURN-FLAG 'EOF)
  0)

(DEFUN FASL-OP-SOAK NIL 
  (PROG (COUNT)
	(SETQ COUNT (FASL-NEXT-NIBBLE))
 L	(COND ((ZEROP COUNT) (RETURN (FASL-GROUP))))
	(FASL-NEXT-VALUE)
	(SETQ COUNT (1- COUNT))
	(GO L)))

(DEFUN FASL-OP-SET-PARAMETER NIL 
  (PROG (FROM TO)
	(SETQ TO (FASL-NEXT-VALUE))
	(SETQ FROM (FASL-GROUP))
	(AS-1 (AR-1 FASL-TABLE FROM)
	       FASL-TABLE 
	      (EVAL TO))
	(RETURN 0)))

(DEFUN FASL-APPEND (OUTFILE &REST INFILES)
  (WITH-OPEN-FILE (FASD-STREAM (FS:MERGE-PATHNAME-DEFAULTS OUTFILE FS:LOAD-PATHNAME-DEFAULTS
							   "QFASL")
			       '(:WRITE :FIXNUM))
    (COMPILER:FASD-START-FILE)
    (MAPC #'(LAMBDA (INFILE)
	      (WITH-OPEN-FILE (ISTREAM (FS:MERGE-PATHNAME-DEFAULTS
					 INFILE FS:LOAD-PATHNAME-DEFAULTS "QFASL")
				       '(:READ :FIXNUM))
		(FUNCALL ISTREAM ':TYI)
		(FUNCALL ISTREAM ':TYI)
		(DO ((NIBBLE (FUNCALL ISTREAM ':TYI))
		     (NEXT1 (FUNCALL ISTREAM ':TYI))
		     (NEXT2))
		    ((NULL NIBBLE))
		  (SETQ NEXT2 (FUNCALL ISTREAM ':TYI))
		  (AND (OR NEXT2 (AND NEXT1 (NOT (ZEROP NEXT1))))
		       (COMPILER:FASD-NIBBLE NIBBLE))
		  (SETQ NIBBLE NEXT1
			NEXT1 NEXT2))))
	  INFILES)
    (COMPILER:FASD-END-FILE)))