;;; -*- Mode:Common-Lisp; Package:System-Internals; Base:8 -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved.
;; Copyright (c) 1980 Massachusetts Institute of Technology 
;;

;; FASL File Disassembler

;; 03/13/78 RMS - Original version from MIT.
;; 12/08/84 DNG - Modified to accept XFASL files as well as QFASL.
;;   3/4/86 JK  - Change to handle unfasling certain types of recursive data structures
;;                (e.g., FASL-OP-VM2-LIST).
;;  3/14/86 JK  - Converted to Common Lisp.
;;  4/01/86 JK  - Fix to UNFASL-OP-FLOAT so that each floating-point number is read into
;;                a unique memory location.
;;  4/02/86 JK  - Change UNFASL-NEXT-NIBBLE-PR to display in base 10.  Also, several other
;;                small changes to the display.
;;  4/18/86 JK  - Correct the format of the call to RETURN-ARRAY in UNFASL-WHACK.
;;  4/21/86 JK  - Added new UNFASL-OPs for handling symbols in the KEYWORD and LISP packages, 
;;                since symbols in these packages have their own special FASL-OPS in Release 3.
;;  5/16/86 JK  - Numerous changes to make the display more perspicuous.
;;  9/05/86 JK  - Added support for IEEE floating point numbers and new floating point data types.
;;  1/17/89 DNG - Updated UNFASL-OP-EVAL1, UNFASL-OP-INDEX, and 
;;		UNFASL-OP-CHARACTER, using new function PRINT-UNFASL-VALUE.  Added new 
;;		functions and UNFASL-OP-EVAL2 .   Deleted obsolete UNFASL-OP-EVAL.
;;		Made UNFASL-OP-VM2-LIST show the index again at the end.  
;;		Fixed UNFASL-OP-PACKAGE-SYMBOL to display uninterned symbols correctly.
;;  1/25/89 DNG - Update UNFASL-TERPRI to use tabs to save file space.
;;  2/01/89 DNG - Added UNFASL-OP-PROG1, UNFASL-OP-APPLY1, and UNFASL-OP-NO-PROTECT
;;		Modify INITIALIZE-UNFASL-ENVIRONMENT to use FIND-SYMBOL instead of INTERN.

(PROCLAIM '(SPECIAL FASL-TABLE FASL-TABLE-FILL-POINTER UNFASL-INDENTATION UNFASL-GROUP-DISPATCH
		    UNFASL-GROUP-DISPATCH-SIZE UNFASL-FILE))  

(MAKUNBOUND 'UNFASL-GROUP-DISPATCH)		;In case it is reloaded

(DEFSUBST UNFASL-NIBBLE () (SEND UNFASL-FILE :TYI))

;;; User calls this

(DEFUN UNFASL (INPUT-FILE &OPTIONAL OUTPUT-FILE)
  "Write a description of the contents of FASL file INPUT-FILE into OUTPUT-FILE.
The output file defaults to same name as input, with type = UNFASL."
  (SETQ INPUT-FILE (FS:MERGE-AND-SET-PATHNAME-DEFAULTS INPUT-FILE FS:LOAD-PATHNAME-DEFAULTS
						       (LOCAL-BINARY-FILE-TYPE))
	OUTPUT-FILE (SEND (IF OUTPUT-FILE
				 (FS:MERGE-PATHNAME-DEFAULTS OUTPUT-FILE INPUT-FILE)
				 INPUT-FILE)
			     :NEW-TYPE :UNFASL))
  (OR (BOUNDP 'UNFASL-GROUP-DISPATCH) (INITIALIZE-UNFASL-ENVIRONMENT))
  (WITH-OPEN-FILE (UNFASL-FILE INPUT-FILE :CHARACTERS NIL :DIRECTION :INPUT)
    (VALIDATE-BINARY-FILE UNFASL-FILE NIL)
    (WITH-OPEN-FILE (*STANDARD-OUTPUT* OUTPUT-FILE :CHARACTERS T :DIRECTION :OUTPUT)
      (FORMAT T "; -*-Text-*-~%; This is the UNFASL for ~A~2%"
	      (SEND UNFASL-FILE :TRUENAME))
      (UNFASL-TOP-LEVEL)))
  OUTPUT-FILE)

(DEFUN UNFASL-PRINT (INPUT-FILE)
  "Print a description of the contents of FASL file INPUT-FILE."
  (SETQ INPUT-FILE (FS:MERGE-AND-SET-PATHNAME-DEFAULTS INPUT-FILE FS:LOAD-PATHNAME-DEFAULTS
						       (LOCAL-BINARY-FILE-TYPE)))
  (OR (BOUNDP 'UNFASL-GROUP-DISPATCH) (INITIALIZE-UNFASL-ENVIRONMENT))
  (WITH-OPEN-FILE (UNFASL-FILE INPUT-FILE :CHARACTERS NIL :DIRECTION :INPUT)
    (VALIDATE-BINARY-FILE UNFASL-FILE NIL)
    (FORMAT T "; -*-Text-*-~%; This is the UNFASL for ~A~2%"
	    (SEND UNFASL-FILE :TRUENAME))
    (UNFASL-TOP-LEVEL))
  T)

(DEFUN UNFASL-TOP-LEVEL ()
  (LOOP UNTIL (EQ (UNFASL-WHACK) 'EOF)))

;;  4/18/86 JK  - Correct the format of the call to RETURN-ARRAY in UNFASL-WHACK.
(DEFUN UNFASL-WHACK ()
  (LET ((FASL-TABLE (MAKE-ARRAY LENGTH-OF-FASL-TABLE
				:AREA 'FASL-TABLE-AREA
				:TYPE 'ART-Q-LIST
				:LEADER-LIST (LIST FASL-TABLE-WORKING-OFFSET)))
	(UNFASL-INDENTATION 0)
	FASL-RETURN-FLAG)
    (SETQ FASL-TABLE-FILL-POINTER FASL-TABLE-WORKING-OFFSET)
    (INITIALIZE-UNFASL-TABLE)
    (LOOP DOING (UNFASL-GROUP) UNTIL FASL-RETURN-FLAG)
    (RETURN-ARRAY (PROG1 FASL-TABLE (SETQ FASL-TABLE NIL)))
    FASL-RETURN-FLAG))

(DEFUN INITIALIZE-UNFASL-TABLE ()
  (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-ARRAY-AREA) 'USER-ARRAY-AREA)
  (SETF (AREF FASL-TABLE FASL-FRAME-AREA) 'MACRO-COMPILED-PROGRAM)
  (SETF (AREF FASL-TABLE FASL-LIST-AREA) 'USER-INITIAL-LIST-AREA)
  (SETF (AREF FASL-TABLE FASL-TEMP-LIST-AREA) 'FASL-TEMP-AREA)) 

(DEFUN UNFASL-GROUP ()
  (PROG (FASL-GROUP-FLAG FASL-GROUP-BITS FASL-GROUP-TYPE FASL-GROUP-LENGTH)
	(SETQ FASL-GROUP-BITS (UNFASL-NIBBLE))
	(COND ((= 0 (LOGAND FASL-GROUP-BITS %FASL-GROUP-CHECK))
	       (FERROR NIL "Fasl group nibble without check bit: ~O" FASL-GROUP-BITS)))
	(SETQ FASL-GROUP-FLAG (NOT (= 0 (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 (UNFASL-NIBBLE)))
	(SETQ FASL-GROUP-TYPE (LOGAND FASL-GROUP-BITS %FASL-GROUP-TYPE))
	(OR (< FASL-GROUP-TYPE UNFASL-GROUP-DISPATCH-SIZE)
	    (FERROR NIL "erroneous fasl group type: ~O" FASL-GROUP-TYPE))
	(UNFASL-TERPRI)
	(PRINC (NTH FASL-GROUP-TYPE FASL-OPS))
	(RETURN (PROG1 (FUNCALL (AREF UNFASL-GROUP-DISPATCH FASL-GROUP-TYPE))
		       (COND ((NOT (ZEROP FASL-GROUP-LENGTH))
			      (FORMAT T "~%FASL-GROUP-COUNT wrong: ~D nibbles left over.~%"
				      FASL-GROUP-LENGTH)))))))

(DEFUN UNFASL-TERPRI ()
  (TERPRI)
  (LET ((N UNFASL-INDENTATION))
    (LOOP WHILE (>= N 8)
	  DO (PROGN (WRITE-CHAR #\TAB) (DECF N 8)))
    (LOOP WHILE (> N 0)
	  DO (PROGN (WRITE-CHAR #\SPACE) (DECF N 1))))
  (VALUES))

(DEFUN UNFASL-NEXT-NIBBLE ()
  (SETQ FASL-GROUP-LENGTH (1- FASL-GROUP-LENGTH))
  (UNFASL-NIBBLE))

(DEFUN UNFASL-NEXT-NIBBLE-PR ()
  (LET ((NIBBLE (UNFASL-NEXT-NIBBLE)))
    (FORMAT T " [~D]" NIBBLE)			
    NIBBLE))

(DEFMACRO UNFASL-INDENTED (&BODY FORMS)
  `(LET ((UNFASL-INDENTATION (+ 3 UNFASL-INDENTATION)))
     . ,FORMS))

(DEFUN UNFASL-NEXT-VALUE ()
  (UNFASL-INDENTED
    (LET ((IDX (UNFASL-GROUP)))
      (VALUES (AREF FASL-TABLE IDX) IDX))))

(DEFUN ENTER-UNFASL-TABLE (V)
  (COND
    ((NOT (< FASL-TABLE-FILL-POINTER LENGTH-OF-FASL-TABLE))
     (FERROR () "FASL table overflow: ~S" V))
    (T (SETF (AREF FASL-TABLE FASL-TABLE-FILL-POINTER) V)
       (FORMAT T "  --> ~S" FASL-TABLE-FILL-POINTER)
       (PROG1 FASL-TABLE-FILL-POINTER
	      (SETQ FASL-TABLE-FILL-POINTER (1+ FASL-TABLE-FILL-POINTER)))))) 

(DEFUN UNFASL-STORE-EVALED-VALUE (V)
  (UNFASL-TERPRI)
  (FORMAT T "~S -> FASL-EVALED-VALUE(~O)" V FASL-EVALED-VALUE)
  (SETF (AREF FASL-TABLE FASL-EVALED-VALUE) V)
  FASL-EVALED-VALUE) 


;;; FASL OPS

(DEFUN UNFASL-OP-ERR ()
  (WRITE-STRING " NOT HANDLED")
  (COND
    ((NOT (ZEROP FASL-GROUP-LENGTH))
     (WRITE-STRING " - FOLLOWING NIBBLES: ")
     (DO ((I FASL-GROUP-LENGTH (1- I)))
	 ((= I 0) NIL)
       (UNFASL-NEXT-NIBBLE-PR))))
  0) 

(DEFUN UNFASL-OP-INDEX ()
  (LET* ((TEM (UNFASL-NEXT-NIBBLE-PR))
	 (FASL-TABLE-ENTRY (AREF FASL-TABLE TEM)))
    (WRITE-STRING " {")
    (LET ((*PRINT-LENGTH* 6) (*PRINT-LEVEL* 3))
      (PRINT-UNFASL-VALUE FASL-TABLE-ENTRY))
    (WRITE-CHAR #\})
    TEM))
(comment ; old way (before rel6)
(DEFUN UNFASL-OP-INDEX ()
  (LET* ((TEM (UNFASL-NEXT-NIBBLE-PR))
	 (FASL-TABLE-ENTRY (AREF FASL-TABLE TEM)))
    (FORMAT T " {~?}" (IF (STRINGP FASL-TABLE-ENTRY) "~S" "~A") `(,FASL-TABLE-ENTRY))
    TEM))
)

(DEFF UNFASL-OP-NOOP #'TRUE)

(DEFUN UNFASL-OP-STRING ()
  (UNFASL-OP-SYMBOL1 T))

(DEFUN UNFASL-OP-SYMBOL ()
  (AND FASL-GROUP-FLAG (WRITE-STRING " UNINTERNED"))
  (UNFASL-OP-SYMBOL1 NIL))

;;  4/21/86 JK  - Added new UNFASL-OPs for handling symbols in the KEYWORD and LISP packages, 
;;                since symbols in these packages have their own special FASL-OPS in Release 3.
(DEFUN UNFASL-OP-LISP-SYMBOL ()
  (UNFASL-OP-SYMBOL1 NIL))

(DEFUN UNFASL-OP-KEYWORD-SYMBOL ()
  (UNFASL-OP-SYMBOL1 NIL T))

(DEFUN UNFASL-OP-SYMBOL1 (STRING-FLAG &OPTIONAL COLON)	
  (LET ((STR (WITH-OUTPUT-TO-STRING (S)
	       (LOOP UNTIL (ZEROP FASL-GROUP-LENGTH)
		     AS TEM = (UNFASL-NEXT-NIBBLE)
		     ;; TEM contains two 8-bit Lisp Machine characters.
		     ;; 200 is a null character.
		     DO (SEND S :TYO (LOGAND 377 TEM))
		     (OR (= (SETQ TEM (LSH TEM -8.)) 200)
			 (SEND S :TYO TEM))))))
    (OR STRING-FLAG (SETQ STR (MAKE-SYMBOL STR)))
    (IF COLON
	;; Symbol was dumped with FASL-OP-KEYWORD-SYMBOL, so display a colon
	(PROGN
	  (FORMAT T " :~?" (IF STRING-FLAG "~S" "~A") `(,STR))
	  (ENTER-UNFASL-TABLE (MAKE-SYMBOL (STRING-APPEND ":" STR))))
	(PROGN 
	  (FORMAT T " ~?" (IF STRING-FLAG "~S" "~A") `(,STR))
	  (ENTER-UNFASL-TABLE STR)))))

(DEFUN UNFASL-OP-PACKAGE-SYMBOL ()
  (LET ((SYM (MAKE-SYMBOL (WITH-OUTPUT-TO-STRING (S)
			    (LOOP FOR I FROM (UNFASL-NEXT-NIBBLE) ABOVE 0
				  DO (LET ((STRING (UNFASL-NEXT-VALUE)))
				       (IF (= (LENGTH STRING) 0) ; uninterned symbol
					   (SEND S :TYO #\#)
					 (SEND S :STRING-OUT STRING)))
				  UNLESS (= I 1) DO (SEND S :TYO #\:))))))
    (UNFASL-TERPRI)
    (FORMAT T "~A" SYM)				;kludge since SYM should not be interned
    (ENTER-UNFASL-TABLE SYM)))

;;  4/01/86 JK  - Fix to UNFASL-OP-FLOAT so that each floating-point number is read into
;;                a unique memory location.
;;  9/5/86  JK  - Added support for VM2 floating point data types.
(DEFUN UNFASL-OP-FLOAT ()
  (IF FASL-GROUP-FLAG				;Small float
      (LET* ((ANS 0)
	     (SIGN-BIT 0)
	     (EXPONENT (UNFASL-NEXT-NIBBLE))
	     (FRACTION (UNFASL-NEXT-NIBBLE)))
	(UNLESS (ZEROP EXPONENT)		;Top nibble 0 => 0.0s0
	  (IF (EVENP EXPONENT)			;Extract the (inverted) sign bit
	      (SETQ SIGN-BIT 1			;Convert from 2's complement to signed magnitude notation
		    FRACTION (- #x20000 FRACTION))	   
	      (SETQ SIGN-BIT 0
		    FRACTION (+ #X10000 FRACTION)))	;Add top bit back in if positive
	  (SETQ EXPONENT (+ (ASH EXPONENT -1) 62.))
	  (IF (= FRACTION #X20000)		;Negation overflow condition
	      (SETQ FRACTION (ASH FRACTION -1)
		    EXPONENT (1+ EXPONENT)))
	  (SETQ ANS (%MAKE-POINTER DTP-SHORT-FLOAT
				   (%LOGDPB SIGN-BIT #O3001 (DPB EXPONENT (BYTE 10 20) FRACTION))))
	  (FORMAT T "  ~S" ANS)
	  (ENTER-UNFASL-TABLE (DONT-OPTIMIZE (COPY-FLOAT ANS)))))
					;Big float
      (LET* ((ANS (DONT-OPTIMIZE (FLOAT 0)))	;Allocate a fresh single float
	     (SIGN-BIT 0)
	     (EXPONENT (UNFASL-NEXT-NIBBLE))	;First nibble only contains exponent
	     (FRACTION (DPB (UNFASL-NEXT-NIBBLE) (BYTE 20 20) (UNFASL-NEXT-NIBBLE)))
	     (GUARD 0))
	(UNLESS (ZEROP EXPONENT)
	  (IF (NOT (ZEROP (SETQ SIGN-BIT (LDB (BYTE 1 37) FRACTION))))	;Extract sign bit
	      (SETQ FRACTION (- #X100000000 FRACTION)))	;Negate fraction if necessary
	  (SETQ GUARD (LDB (BYTE 7 0) FRACTION))
	  (SETQ FRACTION (LDB (BYTE 30 7) FRACTION))	;Use only 24 bits out of the fraction
	  (SETQ EXPONENT (- EXPONENT 898.))	;Set new bias for exponent
						;Perform proper rounding for the fraction (round to nearest)
	  (IF (OR (> GUARD #X40) (AND (= GUARD #X40) (ODDP FRACTION)))
	      (IF (>= (SETQ FRACTION (1+ FRACTION)) #X1000000)
		  (SETQ FRACTION (ASH FRACTION -1)	;Catch fraction overflow
			EXPONENT (1+ EXPONENT))))
	  (UNLESS (ZEROP SIGN-BIT)		;Correct for hidden top bit in negative numbers.
	    (IF (ZEROP FRACTION)		 
		(SETQ FRACTION #X800000
		      EXPONENT (1+ EXPONENT))))
	  (%P-DPB-OFFSET FRACTION (BYTE 27 0) ANS 1)	;Store the three individual components in the allocated
	  (%P-DPB-OFFSET EXPONENT (BYTE 10 27) ANS 1)	;single precision float.  
	  (%P-DPB-OFFSET SIGN-BIT (BYTE 1 37) ANS 1))	     
	(FORMAT T "  ~S" ANS)
	(ENTER-UNFASL-TABLE (DONT-OPTIMIZE (COPY-FLOAT ANS))))
      ))

;;  9/5/86  JK  - Added support for IEEE floating point numbers.
(DEFUN UNFASL-OP-IEEE-FLOAT ()
  (COND (FASL-GROUP-FLAG			;IEEE Short Float
	 (LET ((ANS (%MAKE-POINTER
		      DTP-SHORT-FLOAT (%LOGDPB (UNFASL-NEXT-NIBBLE) #O2011 (UNFASL-NEXT-NIBBLE)))))
	   (FORMAT T "  ~S" ANS)
	   (ENTER-UNFASL-TABLE (DONT-OPTIMIZE (COPY-FLOAT ANS)))))
	(T (IF (> FASL-GROUP-LENGTH 2)		;IEEE Double Float
	       (LET ((ANS (%ALLOCATE-AND-INITIALIZE
			    DTP-EXTENDED-NUMBER
			    DTP-HEADER
			    (DPB %HEADER-TYPE-DOUBLE-FLOAT %%HEADER-TYPE-FIELD 0)
			    0
			    ()
			    3)))
		 (%P-DPB-OFFSET (UNFASL-NEXT-NIBBLE) (BYTE 20 20) ANS 1)
		 (%P-DPB-OFFSET (UNFASL-NEXT-NIBBLE) (BYTE 20 0) ANS 1)
		 (%P-DPB-OFFSET (UNFASL-NEXT-NIBBLE) (BYTE 20 20) ANS 2)
		 (%P-DPB-OFFSET (UNFASL-NEXT-NIBBLE) (BYTE 20 0) ANS 2)
		 (FORMAT T "  ~S" ANS)
		 (ENTER-UNFASL-TABLE (DONT-OPTIMIZE (COPY-FLOAT ANS))))
	       (LET ((ANS (%ALLOCATE-AND-INITIALIZE	;IEEE Single Float
			    DTP-SINGLE-FLOAT
			    DTP-HEADER
			    (DPB %HEADER-TYPE-SINGLE-FLOAT %%HEADER-TYPE-FIELD 0)
			    0
			    ()
			    2)))
		 (%P-DPB-OFFSET (UNFASL-NEXT-NIBBLE) (BYTE 20 20) ANS 1)
		 (%P-DPB-OFFSET (UNFASL-NEXT-NIBBLE) (BYTE 20 0) ANS 1)
		 (FORMAT T "  ~S" ANS)
		 (ENTER-UNFASL-TABLE (DONT-OPTIMIZE (COPY-FLOAT ANS)))))))
  )


(DEFUN UNFASL-OP-RATIONAL ()
  (LET ((RAT (MAKE-RATIONAL (UNFASL-NEXT-VALUE) (UNFASL-NEXT-VALUE))))
    (FORMAT T "  ~S" RAT)
    (ENTER-UNFASL-TABLE RAT)))

		
(DEFUN PRINT-UNFASL-VALUE (VALUE &OPTIONAL (DEPTH 0))
  (TYPECASE VALUE
    (CONS (COND ((AND (CONSP (CDR VALUE))
		      (NULL (CDDR VALUE))
		      (SYMBOLP (FIRST VALUE))
		      (IF (EQ (FIRST VALUE) 'EVAL)
			  (PROGN (WRITE-CHAR #\,) T)
			(LET ((NAME (SYMBOL-NAME (FIRST VALUE))))
			  (COND ((EQUAL NAME "QUOTE")
				 (WRITE-CHAR #\') T)
				((EQUAL NAME "FUNCTION")
				 (WRITE-STRING "#'") T)))))
		 (PRINT-UNFASL-VALUE (SECOND VALUE) DEPTH))
		((AND *PRINT-LEVEL* (> DEPTH *PRINT-LEVEL*))
		 (FORMAT T "#"))
		(T (LET ((DEPTH (+ DEPTH 1)))
		     (FORMAT T "(")
		     (DO ((SUBLIST VALUE (CDR SUBLIST))
			  (COUNT (OR *PRINT-LENGTH* MOST-POSITIVE-FIXNUM) (- COUNT 1)))
			 ((ATOM SUBLIST)
			  (UNLESS (NULL SUBLIST)
			    (WRITE-STRING " . ")
			    (PRINT-UNFASL-VALUE SUBLIST DEPTH)))
		       (WHEN (AND (<= COUNT 0) (CDR SUBLIST))
			 (WRITE-STRING "...")
			 (RETURN))
		       (PRINT-UNFASL-VALUE (CAR SUBLIST) DEPTH)
		       (UNLESS (ATOM (CDR SUBLIST))
			 (WRITE-CHAR #\SPACE)))
		     (FORMAT T ")")))))
    (SYMBOL (WRITE-STRING (SYMBOL-NAME VALUE)))
    (T (PRIN1 VALUE))))

(DEFSUBST PRINT-IN-MIXED-FORMAT (LST FLAG)
  (DECLARE (IGNORE FLAG)) ; not needed anymore
  (PRINT-UNFASL-VALUE LST))

(comment ; old way (before rel 6)
(DEFUN PRINT-IN-MIXED-FORMAT (LST FLAG)
  (FORMAT T "(")
  (PRINT-MIXED LST FLAG)
  (FORMAT T ")"))

(DEFUN PRINT-MIXED (LST FLAG)
  (DO ((SUBLIST LST (CDR SUBLIST))
       (N (LENGTH LST) (1- N)))
      ((= 0 N))
    (LET* ((ITEM-TO-PRINT (CAR SUBLIST))
	   (DIRECTIVE (IF (STRINGP ITEM-TO-PRINT) "~S" "~A"))) 
      (IF (CONSP ITEM-TO-PRINT)
	  (PRINT-IN-MIXED-FORMAT ITEM-TO-PRINT (NOT (NULL (CDR (LAST ITEM-TO-PRINT)))))
	  (FORMAT T "~?" DIRECTIVE `(,ITEM-TO-PRINT))))
    (IF (> N 1)(FORMAT T " ")))
  (AND FLAG
       (FORMAT T " . ~?" (IF (STRINGP (CDR (LAST LST))) "~S" "~A") `(,(CDR (LAST LST))))))
)

;; Used only in object files written by release 1 or 2.
(DEFUN UNFASL-OP-LIST (&OPTIONAL AREA COMPONENT-FLAG)
  (IF (NULL AREA) (SETQ AREA (AREF FASL-TABLE FASL-LIST-AREA)))
  (LET ((LIST-LENGTH (UNFASL-NEXT-NIBBLE-PR)))
    (FORMAT T " Area=~A~:[~; (dotify)~]" AREA FASL-GROUP-FLAG)
    (LET ((LST (LOOP UNTIL (ZEROP LIST-LENGTH)
		     COLLECTING (UNFASL-NEXT-VALUE)
		     DOING (SETQ LIST-LENGTH (1- LIST-LENGTH))) ))
      (AND FASL-GROUP-FLAG (DOTIFY (SETQ LST (COPY-LIST LST))))
      (UNFASL-TERPRI)
      ;; LST typically consists of strings and uninterned symbols, some of which have colons in
      ;; their pnames (see UNFASL-OP-PACKAGE-SYMBOL).   Uninterned symbols of the form A:B are
      ;; intended to represent the symbol B that would be interned in package A at load time, so
      ;; LST cannot be printed with the ~S format directive.
      (PRINT-IN-MIXED-FORMAT LST FASL-GROUP-FLAG)	
;     (format t "(~{~?~^ ~})" (mapcan #'(lambda (x)(if (stringp x) `("~s" (,x))  `("~a" (,x)))) lst))
    (IF (NULL COMPONENT-FLAG)
	(ENTER-UNFASL-TABLE LST)
	(UNFASL-STORE-EVALED-VALUE LST)))))

(DEFUN UNFASL-OP-VM2-LIST (&OPTIONAL AREA COMPONENT-FLAG)	
  (IF (NULL AREA) (SETQ AREA (AREF FASL-TABLE FASL-LIST-AREA)))
  (LET ((LIST-LENGTH (UNFASL-NEXT-NIBBLE-PR)))
    (FORMAT T " AREA=~A~:[~; (DOTIFY)~]" AREA FASL-GROUP-FLAG)
    (LET* ((LST (MAKE-LIST LIST-LENGTH))
	   (INDEX FASL-TABLE-FILL-POINTER)
	   (RETURN-VALUE (IF (NULL COMPONENT-FLAG)
			     (ENTER-UNFASL-TABLE LST)
			     (UNFASL-STORE-EVALED-VALUE LST))))
      (DO ((P LST (CDR P))			
	   (N LIST-LENGTH (1- N)))
	  ((ZEROP N))
	(RPLACA P (UNFASL-NEXT-VALUE)))
      (AND FASL-GROUP-FLAG (DOTIFY (SETQ LST (COPY-LIST LST))))
      (UNFASL-TERPRI)
      (LET ((*PRINT-LEVEL* 2) (*PRINT-LENGTH* (MAX LIST-LENGTH 8)))
	(PRINT-IN-MIXED-FORMAT LST FASL-GROUP-FLAG))
      (UNLESS (= FASL-TABLE-FILL-POINTER (1+ INDEX))
	(FORMAT T " [-->~S]" INDEX))
      RETURN-VALUE)))

(DEFUN UNFASL-OP-TEMP-LIST ()
  (UNFASL-OP-LIST (AREF FASL-TABLE FASL-TEMP-LIST-AREA)))

(DEFUN UNFASL-OP-VM2-TEMP-LIST ()
  (UNFASL-OP-VM2-LIST (AREF FASL-TABLE FASL-TEMP-LIST-AREA)))

(DEFUN UNFASL-OP-LIST-COMPONENT ()
  (UNFASL-OP-LIST NIL T))

(DEFUN UNFASL-OP-VM2-LIST-COMPONENT ()
  (UNFASL-OP-VM2-LIST NIL T))

;;Generate a FIXNUM (or BIGNUM) value.
(DEFUN UNFASL-OP-FIXED ()
  (DO ((POS (* (1- FASL-GROUP-LENGTH) 20) (- POS 20))
       (C FASL-GROUP-LENGTH (1- C))
       (ANS 0))
      ((ZEROP C) (COND (FASL-GROUP-FLAG (SETQ ANS (- ANS))))
		 (WRITE-CHAR #\SPACE)
		 (PRIN1 ANS)
		 (ENTER-UNFASL-TABLE ANS))
    (SETQ ANS (DPB (UNFASL-NEXT-NIBBLE) (+ (LSH POS 6) 20) ANS))))  

(DEFUN UNFASL-OP-CHARACTER ()
  (DO ((POS (* (1- FASL-GROUP-LENGTH) 20) (- POS 20))
       (C FASL-GROUP-LENGTH (1- C))
       (ANS 0))
      ((ZEROP C)
       (WHEN FASL-GROUP-FLAG (SETQ ANS (- ANS)))
       (LET ((CHAR (INT-CHAR ANS)))
	 (WRITE-CHAR #\SPACE)
	 (FORMAT T "~:C" CHAR)
	 (ENTER-UNFASL-TABLE CHAR)))
    (SETQ ANS (DPB (UNFASL-NEXT-NIBBLE) (+ (LSH POS 6) 20) ANS))))

(DEFUN UNFASL-OP-ARRAY ()
 (LET ((FLAG FASL-GROUP-FLAG))
   (UNFASL-NEXT-VALUE)
   (WRITE-STRING " =AREA")
   (UNFASL-NEXT-VALUE)
   (WRITE-STRING " =TYPE")
   (UNFASL-NEXT-VALUE)
   (WRITE-STRING " =DIMLIST")
   (UNFASL-NEXT-VALUE)
   (WRITE-STRING " =DISPLACED-P")
   (UNFASL-NEXT-VALUE)
   (WRITE-STRING " =LEADER")
   (UNFASL-NEXT-VALUE)
   (WRITE-STRING " =INDEX-OFFSET")
   (COND (FLAG
	  (UNFASL-NEXT-VALUE)
	  (WRITE-STRING " =NAMED-STRUCTURE")))
   (unfasl-terpri)
   (let ((result '|#<DTP-ARRAY>|))
     (PRINT-UNFASL-VALUE result)
     (ENTER-UNFASL-TABLE result))))



(DEFUN UNFASL-OP-MOVE ()
  (LET ((FROM (UNFASL-NEXT-NIBBLE-PR))
	(TO (UNFASL-NEXT-NIBBLE-PR)))
    (COND
      ((= TO 177777) (ENTER-UNFASL-TABLE (AREF FASL-TABLE FROM)))
      (T (SETF (AREF FASL-TABLE TO) (AREF FASL-TABLE FROM))
	 TO))))

(DEFUN UNFASL-OP-FRAME ()
  (LET ((Q-COUNT (UNFASL-NEXT-NIBBLE))
	(UNBOXED-COUNT (UNFASL-NEXT-NIBBLE))
	(FASL-GROUP-LENGTH (UNFASL-NEXT-NIBBLE)))
    (FORMAT T " Q-Count=~D, Unboxed-Count=~D, Group-Length=~D"
	      Q-COUNT UNBOXED-COUNT FASL-GROUP-LENGTH)
    (LOOP UNTIL (ZEROP Q-COUNT) WITH TEM
	  DO (UNFASL-NEXT-VALUE)
	     (SETQ TEM (UNFASL-NEXT-NIBBLE))
	     (FORMAT T " Cdrcode=~A" (case (LSH TEM -6)
					   (0 "Normal")(1 "Error")(2 "Nil")(3 "Next")))
	     (OR (= 0 (LOGAND 1 (LSH TEM -5))) (WRITE-STRING " FLAGB"))
	     (OR (= 0 (LOGAND 20 TEM)) (WRITE-STRING " E-V-C-P"))
	     (OR (= 0 (LOGAND 400 TEM)) (WRITE-STRING " LOCATIVE"))
	     (OR (= 0 (SETQ TEM (LOGAND TEM 17)))
		 (FORMAT T " Offset=~O" TEM))
	     (SETQ Q-COUNT (1- Q-COUNT)))
    (LOOP UNTIL (ZEROP UNBOXED-COUNT)
	  DO (UNFASL-TERPRI)
	     (FORMAT T "   UNBOXED ~O ~O" (UNFASL-NEXT-NIBBLE) (UNFASL-NEXT-NIBBLE))
	     (SETQ UNBOXED-COUNT (1- UNBOXED-COUNT)))
    (ENTER-UNFASL-TABLE '|#<DTP-FUNCTION>|)))

(DEFF UNFASL-OP-FEF #'UNFASL-OP-FRAME) 

(DEFUN UNFASL-OP-ARRAY-PUSH ()
  (UNFASL-NEXT-VALUE)
  (UNFASL-NEXT-VALUE))



(DEFUN UNFASL-OP-FILE-PROPERTY-LIST ()
  (UNFASL-NEXT-VALUE))

(DEFUN UNFASL-OP-STOREIN-SYMBOL-VALUE ()
  (UNFASL-OP-INDEX)
  (UNFASL-NEXT-VALUE))

(DEFUN UNFASL-OP-STOREIN-FUNCTION-CELL ()
  (UNFASL-OP-INDEX)
  (UNFASL-NEXT-VALUE))

(DEFUN UNFASL-OP-STOREIN-PROPERTY-CELL ()
  (UNFASL-OP-INDEX)
  (UNFASL-NEXT-VALUE))

(DEFUN UNFASL-OP-STOREIN-ARRAY-LEADER ()
  (WRITE-STRING " ARRAY") (UNFASL-OP-INDEX) 
  (WRITE-STRING " SUBSCR") (UNFASL-OP-INDEX)
  (WRITE-STRING " VALUE") (UNFASL-OP-INDEX))

(DEFUN UNFASL-OP-FETCH-SYMBOL-VALUE ()
  (ENTER-UNFASL-TABLE (UNFASL-NEXT-VALUE)))

(DEFUN UNFASL-OP-FETCH-FUNCTION-CELL ()
  (ENTER-UNFASL-TABLE (UNFASL-NEXT-VALUE)))

(DEFUN UNFASL-OP-FETCH-PROPERTY-CELL ()
  (ENTER-UNFASL-TABLE (UNFASL-NEXT-VALUE)))

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

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

(DEFUN UNFASL-OP-SOAK ()
  (LOOP FOR I FROM (UNFASL-NEXT-NIBBLE-PR) ABOVE 0
	DO (UNFASL-NEXT-VALUE)))

(DEFUN UNFASL-OP-FUNCTION-HEADER ()		;WHAT?  COPIED DIRECT FROM QFASL, THOUGH
  (PROG (FCTN F-SXH)
	(SETQ FCTN (UNFASL-NEXT-VALUE))
	(SETQ F-SXH (UNFASL-NEXT-VALUE))
	(RETURN 0)))

(DEFUN UNFASL-OP-FUNCTION-END ()
	0)



(comment ; this is not used anymore.  -- DNG 1/17/89
(DEFUN UNFASL-OP-SET-PARAMETER ()
  (PROG (FROM TO)
	(SETQ TO (UNFASL-NEXT-VALUE)) (WRITE-STRING " =TO")
	;(SETQ FROM (UNFASL-GROUP)) (WRITE-STRING " =FROM")
	(SETQ FROM (UNFASL-NEXT-VALUE)) (WRITE-STRING " =FROM")
	(RETURN 0)))
)

(DEFUN UNFASL-OP-INITIALIZE-ARRAY ()
  (MULTIPLE-VALUE-BIND (NIL IDX)
      (UNFASL-NEXT-VALUE)
    (LET ((NUM (UNFASL-NEXT-VALUE)))		;# OF VALS TO INITIALIZE
      (DO ((IDX 0 (1+ IDX)))
	  ((= IDX NUM) NIL)
	(UNFASL-NEXT-VALUE)))
    IDX)) 

(DEFUN UNFASL-OP-INITIALIZE-NUMERIC-ARRAY ()
  (MULTIPLE-VALUE-BIND (NIL IDX)
      (UNFASL-NEXT-VALUE)
    (IF FASL-GROUP-FLAG (UNFASL-NEXT-VALUE))	
    (LET ((NUM (UNFASL-NEXT-VALUE)))		;# OF VALS TO INITIALIZE
      (SETQ FASL-GROUP-LENGTH NUM)
      (UNFASL-TERPRI)
      (DO ((IDX 0 (1+ IDX)))
	  ((= IDX NUM) NIL)
	(PRIN1-THEN-SPACE (UNFASL-NEXT-NIBBLE))))
    IDX)) 

(DEFUN UNFASL-OP-EVAL1 (&OPTIONAL DONT-ENTER)
  (LET ((FORM (UNFASL-NEXT-VALUE)))
    (UNFASL-TERPRI)
    (LET* ((RESULT `(EVAL ,FORM)))
      (FORMAT T "(EVAL `")
      (PRINT-UNFASL-VALUE FORM)
      (FORMAT T ")")
      (IF (OR DONT-ENTER FASL-GROUP-FLAG)
	  RESULT
	(ENTER-UNFASL-TABLE RESULT))
      )))

(DEFUN UNFASL-OP-EVAL2 ()
  (LET* ((I1 (UNFASL-OP-EVAL1))
	 (FORM2 (UNFASL-OP-EVAL1 T)))
    (SETF (AREF FASL-TABLE I1)
	  `(EVAL (LET ((* ,(SECOND (AREF FASL-TABLE I1))))
		   (PROG1 * ,(SECOND FORM2)))))
    I1))

(DEFUN UNFASL-OP-APPLY1 ()
  (LET* ((LIST-LENGTH (UNFASL-NEXT-NIBBLE-PR))
	 (FUNCTION (UNFASL-NEXT-VALUE))
	 (LST (LOOP UNTIL (ZEROP LIST-LENGTH)
		    COLLECTING (UNFASL-NEXT-VALUE)
		    DOING (DECF LIST-LENGTH)) )
	 (FORM `(APPLY ',FUNCTION ',LST)))
    (UNFASL-TERPRI)
    (PRINT-UNFASL-VALUE FORM)
    (LET ((RESULT `(EVAL ,FORM)))
      (IF FASL-GROUP-FLAG
	  RESULT
	(ENTER-UNFASL-TABLE RESULT)))))

(DEFUN UNFASL-OP-PROG1 ()
  (MULTIPLE-VALUE-BIND (VALUE INDEX)
      (UNFASL-NEXT-VALUE)
    (DECLARE (IGNORE VALUE))
    (UNFASL-INDENTED
      (UNFASL-GROUP))
    INDEX))

(DEFUN UNFASL-OP-NO-PROTECT ()
  (UNFASL-INDENTED
    (UNFASL-GROUP)))

(DEFUN INITIALIZE-UNFASL-ENVIRONMENT ()
  (SETQ UNFASL-GROUP-DISPATCH-SIZE (LENGTH FASL-OPS))
  (SETQ UNFASL-GROUP-DISPATCH (MAKE-ARRAY UNFASL-GROUP-DISPATCH-SIZE))
						;(FILLARRAY UNFASL-GROUP-DISPATCH FASL-OPS)
  (DO ((I 0 (1+ I))
       (L FASL-OPS (CDR L))
       (TEM))
      ((NULL L))
    (SETQ TEM (FIND-SYMBOL (FORMAT NIL "UN~A" (CAR L)) PKG-SYSTEM-INTERNALS-PACKAGE))
    (SETF (AREF UNFASL-GROUP-DISPATCH I) (IF (AND TEM (FBOUNDP TEM))
					     TEM
					     'UNFASL-OP-ERR))))