;LISP MACHINE FASLOAD				-*-LISP-*-

;	** (c) Copyright 1980 Massachusetts Institute of Technology **

;NOTES-
; THIS THING DOES A PRETTY BAD JOB OF ADHERING TO STORAGE CONVENTIONS.
; SEE THE FUNCTION DOTIFY.

(SETQ FASLOAD T)

(DECLARE
  (SPECIAL FASLOAD		;If NIL don't print redefinition messages
	   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 FASL-FILE-GROUP-SYMBOL
	   PKG-IS-LOADED-P FDEFINE-FILE-SYMBOL)
  )

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

;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
			  &AUX FASL-STREAM W1 W2 FILE-ID FILE-SYMBOL
			       FASL-FILE-GROUP-SYMBOL FASLOAD-FILE-PROPERTY-LIST-FLAG
                               FDEFINE-FILE-SYMBOL
			       (FASL-PACKAGE-SPECIFIED PKG)
			       (FASL-TABLE NIL)
			       FASL-STREAM-BYPASS-P FASL-STREAM-ARRAY
			       FASL-STREAM-INDEX (FASL-STREAM-COUNT 0))
      ;;Default to QFASL and fill in defaults
      (SETQ FILE-NAME (FS:FILE-PARSE-NAME FILE-NAME NIL T ':QFASL))
      ;; Set up the environment and special-variable values
      (SETQ FILE-SYMBOL (FASL-START FILE-NAME))
      
      ;;Open the input stream in binary mode, and start by making sure
      ;;the file type in the first word is really SIXBIT/QFASL/.
      (UNWIND-PROTECT
	(PROGN
	  (SETQ FASL-STREAM (OPEN FILE-NAME '(READ FIXNUM)))
	  (SETQ FASL-STREAM-BYPASS-P (MEMQ ':GET-INPUT-BUFFER
					   (FUNCALL FASL-STREAM ':WHICH-OPERATIONS)))
	  (SETQ FILE-ID (FUNCALL FASL-STREAM ':INFO))
	  (SETQ W1 (FASL-NIBBLE)
		W2 (FASL-NIBBLE))
	  (OR (AND (= W1 143150) (= W2 71660))
	      (FERROR NIL "~A is not a QFASL file" FILE-NAME))
	  ;; 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)))
	  (LET ((PACKAGE (PKG-FIND-PACKAGE (OR PKG
					       (GET FASL-FILE-GROUP-SYMBOL ':PACKAGE)
					       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)
		(FORMAT T "~&Loading file ~A into package ~A~%" FILE-SYMBOL PACKAGE))
	    (SETQ LAST-FASL-FILE-PACKAGE PACKAGE)
	    (FASL-TOP-LEVEL)				;load it.
	    (SET-FILE-LOADED-ID FILE-SYMBOL FILE-ID PACKAGE))
	  (SETQ FASL-STREAM-ARRAY NIL))
	(AND FASL-STREAM (CLOSE FASL-STREAM)))
      (SETQ LAST-FASL-FILE-FORMS (NREVERSE LAST-FASL-FILE-FORMS))
      FILE-NAME)

(DEFUN FASL-START (FILE-NAME &AUX FILE-SYMBOL)
  (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 CONTROL-TABLES 'ART-Q (LENGTH FASL-OPS)))
	 (DO ((I 0 (1+ I))
	      (L FASL-OPS (CDR L))
	      (N (LENGTH FASL-OPS)))
	     ((>= I N))
	   (ASET (CAR L) FASL-GROUP-DISPATCH I))))
  (MULTIPLE-VALUE (FILE-SYMBOL FASL-FILE-GROUP-SYMBOL)
    (GET-FILE-SYMBOLS FILE-NAME))
  (SETQ FDEFINE-FILE-SYMBOL FASL-FILE-GROUP-SYMBOL)
  FILE-SYMBOL)

(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)))

(DEFUN FASL-FILE-PROPERTY-LIST () ;FASL-FILE-GROUP-SYMBOL, FASL-STREAM implicit arguments
  (LET ((FASLOAD-FILE-PROPERTY-LIST-FLAG T))
    (FASL-WHACK-SAVE-FASL-TABLE)))

(DEFUN FASL-OP-FILE-PROPERTY-LIST ()
  (DO ((PLIST (FASL-NEXT-VALUE) (CDDR PLIST)))
      ((NULL PLIST))
    (PUTPROP FASL-FILE-GROUP-SYMBOL (CADR PLIST) (CAR PLIST))
    (AND ACCUMULATE-FASL-FORMS
	 (PUSH `(DEFPROP ,FASL-FILE-GROUP-SYMBOL ,(CADR PLIST) ,(CAR PLIST))
	       LAST-FASL-FILE-FORMS)))
  (AND FASLOAD-FILE-PROPERTY-LIST-FLAG (SETQ FASL-RETURN-FLAG T))) ;Cause FASL-WHACK to return

;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 FASL-TABLE-AREA 
				      'ART-Q-LIST 
				      LENGTH-OF-FASL-TABLE 
				      NIL 
				      (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)
	(AS-1 'MICRO-CODE-EXIT-AREA FASL-TABLE FASL-MICRO-CODE-EXIT-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 
		      (AR-1 FASL-TABLE FASL-SYMBOL-STRING-AREA)
		      'ART-STRING 
		      (* 2 FASL-GROUP-LENGTH)))
	(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 (CDR (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
		    (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-LIST (&OPTIONAL (AREA (AR-1 FASL-TABLE FASL-LIST-AREA))
		     &AUX (LIST-LENGTH (FASL-NEXT-NIBBLE)) LST)
	(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"
	(ENTER-FASL-TABLE LST))

(DEFUN FASL-OP-TEMP-LIST NIL 
  (FASL-OP-LIST (AR-1 FASL-TABLE FASL-TEMP-LIST-AREA)))

;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 'FASL-TABLE-AREA 
			  (COND ((NOT LOAD-16BIT-MODE) 
				 (%P-MASK-FIELD %%ARRAY-TYPE-FIELD ARRAY))
				(T ART-16B))
			  NUM
			  ARRAY
			  '(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 'FASL-TABLE-AREA 
			  'ART-16B
			  NUM
			  ARRAY
			  '(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)))

;Mesa stuff, not currently used.
(COMMENT
(DEFUN FASL-OP-MESA-FEF NIL 
  (PROG (STORAGE-LENGTH MAX-EXIT-VECTOR-USAGE MAX-IP-PDL-USAGE 
	 FAST-OPTION-Q MESA-BLOCK POINTER)
	(COND (FASL-MESA-LOAD-ARRAY 
		(PRINT "ALREADY-LOADING-MESA-FCTN  FASL-OP-MESA-FEF")
		(%HALT)))
	(SETQ STORAGE-LENGTH (FASL-NEXT-NIBBLE))
	(SETQ MAX-EXIT-VECTOR-USAGE (FASL-NEXT-NIBBLE))
	(SETQ MAX-IP-PDL-USAGE (FASL-NEXT-NIBBLE))
	(SETQ FASL-MESA-FCTN-NAME (FASL-NEXT-VALUE))
	(SETQ FAST-OPTION-Q (FASL-NEXT-VALUE))
	(SETQ MESA-BLOCK 
		(SETQ POINTER (MAKE-LIST (AR-1 FASL-TABLE FASL-MESA-INST-AREA)
					 STORAGE-LENGTH)))
	(SETQ FASL-MESA-LOAD-ARRAY
		(MAKE-ARRAY 'FASL-TABLE-AREA 
			    'ART-16B 
			    (* STORAGE-LENGTH 2)
			    MESA-BLOCK 
			    (LIST (* 2 MESA-FEF-LENGTH))))
	(RPLACA POINTER FASL-MESA-FCTN-NAME)
	(SETQ POINTER (CDR POINTER))
	(RPLACA POINTER FAST-OPTION-Q)
	(SETQ POINTER (CDR POINTER))
	(RPLACA POINTER (+ (LSH MAX-IP-PDL-USAGE 7) STORAGE-LENGTH))
	(SETQ POINTER (CDR POINTER))
	(COND ((> (+ (- (FASL-GET-MESA-EXIT-AREA-TOP-POINTER)
			FASL-MESA-EXIT-BASE)
		     MAX-EXIT-VECTOR-USAGE)
		  MESA-MAX-EXIT-VECTOR-LENGTH)
		(FASL-SET-MESA-EXIT-BASE)))
	(RPLACA POINTER (GET-LIST-POINTER-INTO-ARRAY 
			  (FUNCALL (AR-1 FASL-TABLE FASL-MESA-EXIT-VECTOR-AREA)
				   FASL-MESA-EXIT-BASE)))
	(%P-STORE-CDR-CODE POINTER CDR-NIL)	;CLOSE OFF Q PART OF FEF
	(SETQ FASL-MESA-MESA-POINTER (%MAKE-POINTER DTP-MESA-FEF-POINTER MESA-BLOCK))
	(RETURN 0)
))

(DEFUN FASL-OP-MESA-INSTRUCTION NIL
  (PROG (WD)
	(COND ((OR (NULL FASL-MESA-LOAD-ARRAY)
		   (NULL (ARRAY-PUSH FASL-MESA-LOAD-ARRAY (FASL-NEXT-NIBBLE))))
		(PRINT "ERR-AT-FASL-MESA-INSTRUCTION")
		(%HALT)))
	(RETURN 0)))

(DEFUN FASL-OP-MESA-FUNCELL-PLUGIN NIL 
  (PROG (SYM ARG-Q )
	(SETQ SYM (FASL-NEXT-VALUE))
	(COND (FASL-GROUP-FLAG (SETQ ARG-Q (FASL-NEXT-VALUE))))
	(FASL-MESA-PLUGIN
	  (+ (FASL-ENTER-MESA-EXIT-VECTOR-PAIR	;EXIT-VECTOR-PAIR ALWAYS DOES EQ
			(FUNCTION-CELL-LOCATION SYM)
			ARG-Q)
	     MESA-ADDRESS-INDIRECT))
	(RETURN 0)
))

(DEFUN FASL-OP-MESA-S-V-CELL-PLUGIN NIL 
  (PROG (SYM)
	(SETQ SYM (FASL-NEXT-VALUE))
	(FASL-MESA-PLUGIN	
	  (+ (FASL-ENTER-MESA-EXIT-VECTOR (VALUE-CELL-LOCATION SYM) NIL) ;NIL SAYS DO EQ
	     MESA-ADDRESS-INDIRECT))
	(RETURN 0)))

(DEFUN FASL-OP-MESA-QUOTE-PLUGIN NIL 
  (PROG (S-EXP)
	(SETQ S-EXP (FASL-NEXT-VALUE))
	(FASL-MESA-PLUGIN 
	  (FASL-ENTER-MESA-EXIT-VECTOR S-EXP T))	;T SAYS DO EQUAL 
	(RETURN 0)))

(DEFUN FASL-OP-MESA-CONST-PAGE-PLUGIN NIL 
  (PROG NIL 
	(FASL-MESA-PLUGIN 
	  (+ MESA-ADDRESS-CONST-PAGE (FASL-NEXT-NIBBLE)))
	(RETURN 0)))

(DEFUN FASL-OP-MESA-FUNCTION-END NIL 
  (PROG NIL 
	(COND ((NULL FASL-MESA-LOAD-ARRAY)
		(PRINT "LOSE-AT-FASL-OP-MESA-END-FUNCTION")
		(%HALT)))
	(%P-STORE-CONTENTS (FUNCTION-CELL-LOCATION FASL-MESA-FCTN-NAME) FASL-MESA-MESA-POINTER)
	(RETURN-ARRAY FASL-MESA-LOAD-ARRAY)
	(SETQ FASL-MESA-LOAD-ARRAY NIL)
	(RETURN 0)))

		
;FOO

(DEFUN FASL-SET-MESA-EXIT-BASE NIL 
	(SETQ FASL-MESA-EXIT-BASE (FASL-GET-MESA-EXIT-AREA-TOP-POINTER)))

(DEFUN FASL-GET-MESA-EXIT-AREA-TOP-POINTER NIL
  (PROG (AREA)
	(SETQ AREA (AR-1 FASL-TABLE FASL-MESA-EXIT-VECTOR-AREA))
	(RETURN (ARRAY-LEADER (CDR (FUNCTION-CELL-LOCATION AREA)) 0)) ))

(DEFUN FASL-ENTER-MESA-EXIT-VECTOR (S-EXP EQUALF)
  (PROG (IDX ARRAYP EFF-LIST)
	(SETQ ARRAYP 
	   (CDR (FUNCTION-CELL-LOCATION 
		  (AR-1 FASL-TABLE FASL-MESA-EXIT-VECTOR-AREA))))
	(SETQ EFF-LIST 
		(GET-LIST-POINTER-INTO-ARRAY 
			(FUNCALL ARRAYP FASL-MESA-EXIT-BASE)))
	(SETQ IDX (COND (EQUALF (FIND-POSITION-IN-LIST-EQUAL S-EXP EFF-LIST))
			(T (FIND-POSITION-IN-LIST S-EXP EFF-LIST))))
	(COND ((NULL IDX)
		(SETQ IDX (ARRAY-PUSH ARRAYP S-EXP))
		(COND ((NULL IDX)
			(PRINT "MESA-EXIT-AREA-OVERFLOW")
			(%HALT)))
		(SETQ IDX (- IDX FASL-MESA-EXIT-BASE))))
	(RETURN (+ MESA-ADDRESS-EXIT-VECTOR IDX))))

(DEFUN FASL-ENTER-MESA-EXIT-VECTOR-PAIR (Q1 Q2)  ;RETURN POINTER TO Q1 FOLLOWED BY Q2
  (PROG (IDX ARRAYP ENDC)			 ;IN MESA EXIT VECTOR (IF Q2 IS NIL, IT
	(SETQ ARRAYP 				 ;DOESNT REALLY EXIST)
	   (CDR (FUNCTION-CELL-LOCATION 
		  (AR-1 FASL-TABLE FASL-MESA-EXIT-VECTOR-AREA))))
	(SETQ IDX FASL-MESA-EXIT-BASE)
	(SETQ ENDC (ARRAY-LEADER ARRAYP 0))
  L1	(COND ((NOT (< IDX (1- ENDC)))
		(GO ADD-NEW))
	      ((AND (EQ Q1 (AR-1 ARRAYP IDX))
		    (OR (NULL Q2)
			(EQ Q2 (AR-1 ARRAYP (1+ IDX)))))
		(GO X)))
	(SETQ IDX (1+ IDX))
	(GO L1)
  ADD-NEW
	(SETQ IDX (ARRAY-PUSH ARRAYP Q1))
	(COND ((NULL IDX)
		(GO E1))
	      ((NULL Q2)
		(GO X))
	      ((NULL (ARRAY-PUSH ARRAYP Q2))
		(GO E1)))
  X	(RETURN (+ MESA-ADDRESS-EXIT-VECTOR (- IDX FASL-MESA-EXIT-BASE)))
  E1 	(PRINT "MESA-EXIT-AREA-OVERFLOW")
	(%HALT)
))

(DEFUN FASL-MESA-PLUGIN (NEW-ADR)	;PLUG IN ADR TO LAST MESA INSTRUCTION LOADED
  (PROG (LAST-ADR) 
	(COND ((ZEROP (SETQ LAST-ADR (ARRAY-LEADER FASL-MESA-LOAD-ARRAY 0)))
		(PRINT "LOSE-AT-MESA-PLUGIN")
		(%HALT)))
	(AS-1 (+ NEW-ADR 
		 (MASK-FIELD %%MESA-OP-CODE (AR-1 FASL-MESA-LOAD-ARRAY (1- LAST-ADR))))
	      FASL-MESA-LOAD-ARRAY 
	      (1- LAST-ADR))
))
);END COMMENTING OUT OF MESA STUFF

(COMMENT 

;These are for micro compilation.  They're gone now but will return some day.
(DEFUN Q-GET-U-ENTRY-INDEX (FCTN)
  (PROG (TEM)
	(COND ((= (%DATA-TYPE (SETQ TEM (CDR (FUNCTION-CELL-LOCATION FCTN))))
		  DTP-U-ENTRY)
		(RETURN (%MAKE-POINTER DTP-FIX TEM)))		;ITS ALREADY SET UP 
	      ((SETQ TEM (FIND-POSITION-IN-VECTOR 
			   FCTN 
			   (FUNCTION MICRO-CODE-ENTRY-NAME-AREA)))
		(RETURN TEM)))
	(COND ((NULL (ARRAY-PUSH (FUNCTION MICRO-CODE-ENTRY-AREA) NIL))
		(PRINT "MICRO-CODE-ENTRY-TABLE-FULL")
		(RETURN NIL)))
	(ARRAY-PUSH (FUNCTION MICRO-CODE-ENTRY-NAME-AREA) FCTN)
	(ARRAY-PUSH (FUNCTION MICRO-CODE-ENTRY-/#-ARGS) NIL)
	(RETURN (1- (SCRATCH-STORE 'ACTIVE-MICRO-CODE-ENTRIES 
				   (ARRAY-LEADER (FUNCTION MICRO-CODE-ENTRY-AREA)
						 0))))
))

(DEFUN MICRO-ENTRY-FINALIZE (FCTN ARGDESC ADR)	;ADR IS ENTRY RELATIVE TO MEM
   (PROG (IDX)
	(SETQ IDX (GET-U-ENTRY-INDEX FCTN))
	(AS-1 ARGDESC (FUNCTION MICRO-CODE-ENTRY-/#-ARGS) IDX)
	(AS-1 (%MAKE-POINTER DTP-FIX (%GET-MEM-POINTER ADR))
	      (FUNCTION MICRO-CODE-ENTRY-AREA)
	      IDX)
	(RETURN (%MAKE-POINTER DTP-U-ENTRY IDX))))


(DEFUN FASL-SEXP-PNTR (S-EXP INDIRECT-FLAG EQUALF)
  (PROG (IDX ARRAYP)
	(SETQ ARRAYP
	   (CDR (FUNCTION-CELL-LOCATION 
		  (AR-1 FASL-TABLE FASL-MICRO-CODE-EXIT-AREA))))
	(COND (INDIRECT-FLAG (SETQ S-EXP (%GET-MEM-POINTER S-EXP))))
	(SETQ IDX (COND (EQUALF (ENTER-LIST-ARRAY-EQUAL ARRAYP S-EXP))
			(T (ENTER-LIST-ARRAY ARRAYP S-EXP))))
	(COND ((NULL IDX)
		(PRINT "MICRO-CODE-EXIT-AREA-OVERFLOW")
		(PRINT (AR-1 FASL-TABLE FASL-MICRO-CODE-EXIT-AREA))
		(%HALT))
	      (T (FASL-RELOC-LAST-INST 
		   (%GET-MEM-POINTER 
		      (GET-LIST-POINTER-INTO-ARRAY 
			(FUNCALL ARRAYP IDX)))
		   INDIRECT-FLAG)))
	(RETURN 0)))

(DEFUN FASL-OP-MAKE-MICRO-CODE-ENTRY NIL
  (PROG (FCTN ARGDESC ENTRY-INDEX TEM)
	(SETQ FCTN (FASL-NEXT-VALUE))
	(SETQ ARGDESC (FASL-NEXT-VALUE))
	(SETQ ENTRY-INDEX (FASL-NEXT-NIBBLE))
	(SETQ TEM 
	  (MICRO-ENTRY-FINALIZE 
		FCTN 
		ARGDESC 
		(+ (AR-1 (FUNCTION AREA-ORIGIN)
			 (SYMEVAL (AR-1 FASL-TABLE FASL-PDP10-INST-AREA)))
		   (AR-1 FASL-TABLE ENTRY-INDEX))))
	(COND ((NOT FASL-GROUP-FLAG)
		(%P-STORE-CONTENTS (FUNCTION-CELL-LOCATION FCTN)
				   TEM)))
	(RETURN (ENTER-FASL-TABLE TEM))))


(DEFUN FASL-OP-SAVE-ENTRY-POINT NIL
  (ENTER-FASL-TABLE 
	(AR-1 (FUNCTION AREA-FREE-POINTER)
	      (SYMEVAL (AR-1 FASL-TABLE FASL-PDP10-INST-AREA)))))
	
(DEFUN FASL-OP-MICRO-CODE-SYMBOL NIL 
  (PROG NIL
	(FASL-RELOC-LAST-INST (AR-1 (FUNCTION MICRO-CODE-SYMBOL-AREA)
				    (FASL-NEXT-NIBBLE)) NIL)
	(RETURN 0)))

(DEFUN FASL-OP-MICRO-TO-MICRO-LINK NIL
  (PROG (IDX)
	(SETQ IDX (GET-U-ENTRY-INDEX (FASL-NEXT-VALUE)))
	(FASL-RELOC-LAST-INST 
	  (%GET-MEM-POINTER 
	    (GET-LIST-POINTER-INTO-ARRAY 
	      (MICRO-CODE-ENTRY-AREA IDX)))
	  T)		;TURN ON INDIRECT
	(RETURN 0)))


(DEFUN FASL-OP-QUOTE-POINTER NIL
  (FASL-SEXP-PNTR (FASL-NEXT-VALUE) NIL T))	;NO INDIRECT, DO EQUAL

(DEFUN FASL-OP-S-V-CELL NIL 
  (FASL-SEXP-PNTR (VALUE-CELL-LOCATION (FASL-NEXT-VALUE)) T NIL)) ;INDIRECT, DO EQ

(DEFUN FASL-OP-FUNCELL NIL 
  (FASL-SEXP-PNTR (FUNCTION-CELL-LOCATION (FASL-NEXT-VALUE)) T NIL)) ;INDIRECT, DO EQ

(DEFUN FASL-OP-CONST-PAGE NIL 
  (PROG NIL 
	(FASL-RELOC-LAST-INST 
	  (%GET-MEM-POINTER 
	     (GET-LIST-POINTER-INTO-ARRAY 
		(CONSTANTS-AREA (FASL-NEXT-NIBBLE))))
	  NIL)		;NO INDIRECT
	(RETURN 0))))

(DEFUN FASL-APPEND (OUTFILE &REST INFILES &AUX FASD-STREAM)
  (SETQ FASD-STREAM (OPEN (FS:FILE-PARSE-NAME OUTFILE NIL T ':QFASL) '(WRITE FIXNUM)))
  (COMPILER:FASD-START-FILE)
  (MAPC #'(LAMBDA (INFILE)
	    (LET ((ISTREAM (OPEN (FS:FILE-PARSE-NAME INFILE NIL T ':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)
  (CLOSE FASD-STREAM))