;;; -*- Mode:Common-Lisp; Package:Compiler; Base:10; Cold-Load:T -*-

;;;                           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) 1985-1989 Texas Instruments Incorporated. All rights reserved.
;;; Copyright (c) 1980 Massachusetts Institute of Technology 

;;;;   *-----------------------------------------------------------*
;;;;   |							   |
;;;;   |		      Disassembler			   |
;;;;   |							   |
;;;;   *-----------------------------------------------------------*

;; Disassemble is used by EH.
;; If you change things around, make sure not to break EH.

;;;  3/01/86 DNG - Converted from Zetalisp to Common Lisp.
;;;  8/08/86 DNG - Changed remaining ~D to ~A.
;;; 11/17/86 DNG - Use %P-DATA-TYPE-OFFSET and %P-POINTER-OFFSET instead of %P-LDB-OFFSET.
;;;  3/15/89 DNG - For release 6, include support for CLOS.  Remove obsolete code for release 2.

(DEFVAR DISASSEMBLE-OBJECT-OUTPUT-FUN NIL) 

(DEFUN DISASSEMBLE (FUNCTION &KEY ((:BASE PRINT-BASE)) VERBOSE START END)
  "Print a disassembly of FUNCTION on *STANDARD-OUTPUT*.
FUNCTION can be a compiled function, a LAMBDA-expression (which will be compiled),
a compiled closure, or a function spec (whose definition will be used)."
  (DECLARE (ARGLIST FUNCTION &KEY :BASE :VERBOSE :START :END))
  ;;  2/06/86 DNG - Use BACKGROUND-CONS-AREA in case output stream has side-effects.
  ;;  3/06/86 DNG - Add VERBOSE option [SPR 1176]; add handling for closures;
  ;;		use *PRINT-BASE*, *PRINT-LENGTH* and *PRINT-LEVEL*.
  ;;  3/13/86 DNG - Don't try to compile an interpreted closure.
  ;;  5/06/86 DNG - Optional :START and :END keywords.
  (LET ( FEF LIM-PC ILEN
	(DISASSEMBLE-OBJECT-OUTPUT-FUN NIL)
	(DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) ;Stream may cons
	(*PRINT-BASE* (OR PRINT-BASE *PRINT-BASE* 10.))
	(*PRINT-LENGTH* (OR *PRINT-LENGTH* (AND (NOT VERBOSE) 10)))
	(*PRINT-LEVEL* (OR *PRINT-LEVEL* (AND (NOT VERBOSE) 5))) )
    (DO ((FUNCTION2 FUNCTION))
	(NIL)
      (COND
	((TYPEP FUNCTION2 'COMPILED-FUNCTION)
	 (SETQ FEF FUNCTION2)
	 (RETURN))
	((AND (CONSP FUNCTION2)
	      (MEMBER (CAR FUNCTION2)
		      '(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA LAMBDA NAMED-LAMBDA
			 GLOBAL:SUBST SUBST GLOBAL:NAMED-SUBST)
		      :TEST #'EQ))
	 (SETQ FEF (COMPILE NIL FUNCTION2))
	 (RETURN))
	((EQ (CAR-SAFE FUNCTION2) 'MACRO)
	 (FORMAT T "~%Definition as macro")
	 (SETQ FUNCTION2 (CDR FUNCTION2)))
	((CLOSUREP FUNCTION2)
	 (FORMAT T "~%Closure over: ")
	 (UNLESS (IGNORE-ERRORS 
		   (PRIN1 (CLOSURE-ALIST FUNCTION2))
		   T)
	   (PRINC " ...<error in printing>..."))
	 (SETQ FUNCTION2 (CLOSURE-FUNCTION FUNCTION2))
	 (UNLESS (TYPEP FUNCTION2 'COMPILED-FUNCTION)
	   (FORMAT T "~%The function is not compiled.")
	   (RETURN-FROM DISASSEMBLE FUNCTION) ) )
	(T
	 (WHEN (FBOUNDP 'SI:DWIMIFY-PACKAGE) ; may not be in minimal kernel
	   (SETQ FUNCTION2 (SI:DWIMIFY-PACKAGE FUNCTION2)))
	 (SETQ FUNCTION2 (FDEFINITION (SI:UNENCAPSULATE-FUNCTION-SPEC FUNCTION2))))))
    (SETQ LIM-PC (DISASSEMBLE-LIM-PC FEF))
    (WHEN (AND END (< END LIM-PC))
      (SETQ LIM-PC END))
    (DO ((PC (IF START
		 (MAX START (FEF-INITIAL-PC FEF))
	       (FEF-INITIAL-PC FEF))
	     (+ PC ILEN)))
	((>= PC LIM-PC))
      (TERPRI)
      (SETQ ILEN (DISASSEMBLE-INSTRUCTION FEF PC VERBOSE)))
    (TERPRI)
    FUNCTION)) 

(DEFF DISASSEMBLE-INSTRUCTION-LENGTH 'FEF-INSTRUCTION-LENGTH) 
(DEFF DISASSEMBLE-FETCH 'FEF-INSTRUCTION) 
(DEFF DISASSEMBLE-LIM-PC 'FEF-LIMIT-PC) 


(DEFUN DISASSEMBLE-INSTRUCTION (FEF PC &OPTIONAL VERBOSE)
  "Print on STANDARD-OUTPUT the disassembly of the instruction at PC in FEF.
Returns the length of that instruction."
  ;;  9/17/85 DNG - Display PC in default base instead of octal.
  ;; 10/01/85 DNG - Allow 4 digits for PC instead of 3.
  ;;  3/06/86 DNG - Add VERBOSE option.  [SPR 1176]
  ;;  8/08/86 DNG - When base 16 has been selected, use ~X for the instructions also.
  (LET (WD ILEN SECOND-WORD FORMAT-SPEC)
    (SETQ ILEN (DISASSEMBLE-INSTRUCTION-LENGTH FEF PC))
    (SETQ WD (DISASSEMBLE-FETCH FEF PC))
    (FORMAT T "~4@A " PC)
    (WHEN VERBOSE
      (SETQ FORMAT-SPEC
	    (IF (EQL *PRINT-BASE* 16.) "~4,'0X " "~6,'0O "))
      (FORMAT T FORMAT-SPEC WD))
    (WHEN (>= ILEN 2)
      (INCF PC)
      (SETQ SECOND-WORD (DISASSEMBLE-FETCH FEF PC)))
    (DISASSEMBLE-ONE-INSTRUCTION WD SECOND-WORD FEF PC)
    (WHEN (AND VERBOSE SECOND-WORD)
      (TERPRI)
      (FORMAT T "~4@A " PC)
      (FORMAT T FORMAT-SPEC SECOND-WORD) )
    ILEN)) 


(DEFUN DISASSEMBLE-ONE-INSTRUCTION (WD &OPTIONAL SECOND-WORD FEF PC)
  "Print on STANDARD-OUTPUT the disassembly of the instruction."
  ;;  8/10/85 DNG - Fix to correctly display CEILING, TRUNCATE, and ROUND. [SPR 233]
  ;;  8/21/85 DNG - Fix to not error on old-style long branch in V2 mode.
  ;;  9/17/85 DNG - Display PC in default base instead of octal.
  ;; 10/23/85 DNG - Change names ADD-IMMEDIATE etc. to ADD-IMMED etc.
  ;; 11/09/85 DNG - Fix to show correct variable name for STACK-CLOSURE-UNSHARE.
  ;; 11/23/85 DNG - Support module-op instructions.
  ;; 12/09/85 CLM - Support the new aux-op long branches; changed to print PDL-PUSH
  ;;                instead of PDL-POP in those cases where instruction DEST property
  ;;                equals D-STORE and the displacement equals #o777.
  ;; 12/18/85 CLM - For Rel.3, added code to print the contents of a dispatch table
  ;;                in the comment field.
  ;;  1/09/86 DNG - Re-design to key off of NO-REG and DISP properties instead of name.
  ;;  1/20/86 CLM - Corrected long-branch addressing to absolute instead of relative.
  ;;  2/17/86 DNG - Use MISC-OP-NAME-TABLE for VM2 native mode.
  ;;  7/11/86 DNG - Modify to show "(MISC) PUSH OP" instead of "(MISC) OP D-PDL" etc.
  ;;  7/16/86 DNG - Show name of variable accessed by "higher-context" instructions.
  ;;  9/06/86 DNG - Add special handling for SELECT and complex call instructions.
  ;;  2/10/87 CLM - Fixed to handle UNBIND's and POP-PDL's of greater than 16 (SPR 3111).
  ;;  1/18/88 DNG - Enable displaying call-info description on COMPLEX-CALL to %FUNCTION-INSIDE-SELF.
  ;; 11/28/88 DNG - Enable displaying call-info when CALL-NEXT-METHOD used PUSH-CAR for the function.
  ;;  3/15/89 DNG - Deleted handling of VM1 instructions.
  (LET ( OP SUBOP DEST DISP REG )
    (BLOCK NIL
      (SETQ OP    (LDB (BYTE 4  9) WD)
	    SUBOP (LDB (BYTE 3 13) WD)
	    DEST  (LDB (BYTE 2 14) WD)
	    DISP  (LDB (BYTE 9  0) WD)
	    REG   (LDB (BYTE 3  6) WD))
      (WHEN (< OP #o11)
	(SETQ OP (LDB (BYTE 5 9) WD)))
      (SETQ OP (ASH WD -9))
      (LET* ((NAME (AREF (INSTRUCTION-DECODE-TABLE) OP))
	     (NO-REG (GET NAME 'NO-REG)))
	  (FLET (( DESTINATION-FOR-PRINTING (NAME)
		  (LET (( D (GET NAME 'DEST) ))
		    (COND ((EQ D 'D-PDL) 'PUSH)
			  ((EQ D 'D-INDS) 'TEST)
			  ((EQ D 'D-RETURN) 'RETURN)
			  (T D) )) ))
	   (COND
	     ((EQ NO-REG 'MISC)
	      (LET ((MISC-NAME (AREF (MISC-OP-NAME-TABLE) DISP)))
		(FORMAT T "(~A) ~A ~A "
			'MISC (DESTINATION-FOR-PRINTING NAME)
			(IF (NULL MISC-NAME) DISP MISC-NAME))
		(WHEN (AND (MEMBER MISC-NAME '(LOAD-FROM-HIGHER-CONTEXT LOCATE-IN-HIGHER-CONTEXT))
			   PC)
		  (LET (( NUM (PUSH-NUMBER-VALUE FEF (1- PC)) ))
		    (UNLESS (NULL NUM)
		      (DISASSEMBLE-LEXICAL-VAR-COMMENT
			FEF
			(LDB SI:%%CONTEXT-DESC-REL-LEVEL NUM)
			(LDB SI:%%CONTEXT-DESC-SLOT NUM)
			T) )))))
	     ((EQ NO-REG 'AREFI)
	      (FORMAT T "~A ~A (~A) "
		      (DESTINATION-FOR-PRINTING NAME)
		      (NTH REG
			   '(GLOBAL:AR-1 ARRAY-LEADER %INSTANCE-REF COMMON-LISP-AR-1 SET-AR-1
					 SET-ARRAY-LEADER SET-%INSTANCE-REF UNUSED-AREFI))
		      (+ (LDB (BYTE 6 0) DISP)
			 (IF (MEMBER REG '(2 6) :TEST #'EQL) 1 0))))
	     ((NULL NAME) (FORMAT T "#o~6O " WD))
	     ((EQ NO-REG 'AUX)
	      (IF (OR (= REG 4)
		      (= REG 5))
		  (FORMAT T "(~A) ~A ~16,2T~S" 'AUX (IF (= REG 4) 'UNBIND 'POP-PDL)
			  (1+ (LDB (BYTE 6 0) WD)))
		(LET ((AUX-NAME (AREF (AUX-OP-NAME-TABLE) DISP)))
		  (FORMAT T "(~A) ~A " 'AUX (IF (NULL AUX-NAME) DISP AUX-NAME))
		  ;;12/09/85 CLM added long branches
		  (COND ((<= #O160 DISP #O177)
			 (UNLESS (NULL SECOND-WORD)
			   (SETQ DISP SECOND-WORD)
			   (WHEN (>= DISP #O100000)
			     (SETQ DISP (LOGIOR #O-100000 DISP)))
			   (WRITE-CHAR #\SPACE)
			   (PRINC DISP) ))
			((EQ AUX-NAME 'STORE-IN-HIGHER-CONTEXT)
			 (UNLESS (NULL PC)
			   (LET (( NUM (PUSH-NUMBER-VALUE FEF (1- PC)) ))
			     (UNLESS (NULL NUM)
			       (DISASSEMBLE-LEXICAL-VAR-COMMENT
				 FEF
				 (LDB SI:%%CONTEXT-DESC-REL-LEVEL NUM)
				 (LDB SI:%%CONTEXT-DESC-SLOT NUM)
				 T) ))))
			((<= #O100 DISP #O103)	   ; complex call
			 (UNLESS
			   (OR (NULL PC)
			       (LET* ((TEM (DISASSEMBLE-FETCH FEF (- PC 1)))
				      (NAME (AREF (INSTRUCTION-DECODE-TABLE)
						  (LDB (SYMEVAL-FOR-TARGET '%%QMI-FULL-OPCODE)
						       TEM))))
				 (NOT (OR (MEMBER NAME '(PUSH PUSH-LONG-FEF))
					  (EQL TEM '#.(+ (LAP-VALUE 'PUSH-MISC-GROUP)
							 (MISC-OP-EVAL '%FUNCTION-INSIDE-SELF)))
					  (AND (EQ (GET NAME 'DEST) 'D-PDL)
					       (EQ (GET NAME 'NO-REG) 'NIL)
					       (NOT (EQL (LDB (BYTE 9 0) TEM) (LAP-VALUE 'PDL-POP))))
					  ))))
			   (LET (( CALL-INFO (PUSH-NUMBER-VALUE FEF (- PC 2)) ))
			     (UNLESS (NULL CALL-INFO)
			       (FORMAT T "~30,2T; ")
			       (DISASSEMBLE-CALL-INFO-WORD CALL-INFO)
			       ))))
			))  ) )
	     ((EQ NO-REG 'MODULE)
	      (LET ((TEM (MODULE-OP-NAME-TABLE)))
		(IF (AND TEM
			 (SETQ TEM
			       (AREF TEM
				     (LDB (SYMEVAL-FOR-TARGET '%%QMI-EXTERNAL-MODULE-NUMBER)
					  DISP))))
		    (LET ((OPNUM (LDB (SYMEVAL-FOR-TARGET '%%QMI-MODULE-OP)
				      DISP)))
		      (FORMAT T "(~A) ~A ~A "
			      (ARRAY-LEADER TEM 0)
			      (DESTINATION-FOR-PRINTING NAME)
			      (OR (AREF TEM OPNUM) OPNUM)))
		  (FORMAT T "~A ~20,1T~S" NAME DISP))))
	     ((EQ NO-REG 'CALL)
	      (PRINC (NTH (LDB (SYMEVAL-FOR-TARGET '%%QMI-CALL-DEST) WD)
			  '(TEST PUSH RETURN TAIL-REC)))
	      (WRITE-CHAR #\SPACE)
	      (PRINC NAME)
	      (DISASSEMBLE-ADDRESS FEF REG DISP SECOND-WORD))
	     ((SYMBOLP NAME)
	      (PRINC NAME)
	      (COND
		((EQ NO-REG 'NIL) ; does use register
		 ;;12/09/85 CLM now prints PDL-PUSH instead of PDL-POP
		 (IF (AND (EQ (GET NAME 'DEST) 'D-STORE)
			  (EQ DISP (LAP-VALUE 'PDL-PUSH)))
		     (FORMAT T " ~20,1T~A" 'PDL-PUSH)
		   (DISASSEMBLE-ADDRESS FEF REG DISP SECOND-WORD)))
		((EQ NO-REG 'BRANCH)
		 (FORMAT T " ~16,1T")
		 (WHEN (> DISP #o400)
		   (SETQ DISP (LOGIOR #o-400 DISP)))	   ;Sign-extend
		 (IF (NULL PC)
		     (PRINC DISP)
		   (PRINC (+ PC DISP 1))))
		((EQ NO-REG 'IMMED)
		 (FORMAT T " ~20,1T~S" (IF (> DISP #o377)
					   (DPB DISP (BYTE 9 0) -1)
					 DISP)))
		((EQ NO-REG 'NOTHING)
		 (COND
		   ((EQ NAME 'DISPATCH)
		    (DISASSEMBLE-DISPATCH-TABLE FEF DISP))
		   ((EQ NAME 'PUSH-LONG-FEF)
		    (DISASSEMBLE-ADDRESS FEF 0 DISP NIL))
		   ((EQ NAME 'SELECT)
		    (DISASSEMBLE-SELECT-TABLE FEF DISP))
		   (T
		    (FORMAT T " ~20,1T~S" DISP)
		    (COND
		      ((EQ NAME 'LDB-IMMED)
		       (DISASSEMBLY-COMMENT)
		       (FORMAT T "(~A ~A ~A)" 'BYTE
			       (LDB (BYTE 4 0) DISP) ; 4-bit length
			       (LDB (BYTE 5 4) DISP) ; 5-bit position
			       ))
		      ((EQ NAME 'LEXICAL-UNSHARE)
		       (UNLESS (NULL FEF)
			 (LET ((VARNAME
				(NTH DISP
				     (SI:GET-DEBUG-INFO-FIELD
				       (FUNCTION-DEBUGGING-INFO FEF)
				       :VARIABLES-USED-IN-LEXICAL-CLOSURES))))
			   (UNLESS (NULL VARNAME)
			     (DISASSEMBLY-COMMENT VARNAME)))))))))
		(T (FORMAT T " ~20,1T~S" DISP))))
	     (T (FORMAT T "#o~O" OP))))))
    (VALUES) ))

(comment ; not needed anymore
;; This ought to figure out which flavor's mapping table is going to be current
;; at a certain PC, assuming that the compiled code explicitly sets it up.
(DEFUN DISASSEMBLE-CURRENT-FLAVOR (FEF PC)
  FEF PC
  NIL
  )
)

(DEFUN DISASSEMBLE-ADDRESS (FEF REG DISP &OPTIONAL SECOND-WORD PC
			    &AUX TEM)
  "Print out the disassembly of an instruction source address.
REG is the register number of the address, and DISP is the displacement.
SECOND-WORD should be the instruction's second word if it has two.
PC should be where the instruction was found in the FEF."
  ;;  9/21/85 DNG - Modified for new non-local lexical addressing mode,
  ;;                and to use new function DISASSEMBLY-COMMENT.
  ;;  1/14/86 DNG - Updated LEX addressing mode.
  ;;  2/01/86 DNG - Add comment with name of LEX variables.
  ;;  6/09/86 DNG - Wrap IGNORE-ERRORS around printing of LEX variable name to
  ;;		work around problem with bad debug info created by Genasys.
  ;;  6/11/86 DNG - For lex var's function name, don't show whole :TARGET spec.
  ;;  7/14/86 DNG - Say LEX-A|0 instead of LEX-0|0; use ~A to format the register
  ;;		name so that it obeys *PRINT-CASE*.
  (FORMAT T " ~20,1T")
  ;; In a one-word instruction, the displacement for types 4 thru 7 is only 6 bits,
  ;; so ignore the rest.  In a two word insn, we have been fed the full disp from word 2.
  (WHEN (AND (>= REG 4) (NOT SECOND-WORD))
    (SETQ DISP (LOGAND #o77 DISP)))
  (COND
    ((= REG 5)
     (FORMAT T "~A|~A" 'LOCAL DISP)
     (UNLESS (NULL FEF)
       (SETQ TEM (DISASSEMBLE-LOCAL-NAME FEF DISP))
       (UNLESS (NULL TEM)
	 (DISASSEMBLY-COMMENT TEM))))
    ((= REG 6)
     (FORMAT T "~A|~A" 'ARG DISP)
     (UNLESS (NULL FEF)
       (SETQ TEM (DISASSEMBLE-ARG-NAME FEF DISP))
       (UNLESS (NULL TEM)
	 (DISASSEMBLY-COMMENT TEM))))
    ((EQ REG (SYMEVAL-FOR-TARGET '%QMI-REG-LEX))
     (LET ((LEVEL (LDB (BYTE 1 5) DISP))
	   (OFFSET (LDB (BYTE 5 0) DISP)))
       (FORMAT T "~A-~A|~A" 'LEX (NTH LEVEL '(A B)) OFFSET)
       (DISASSEMBLE-LEXICAL-VAR-COMMENT FEF LEVEL OFFSET NIL) ))
    ((< REG 4)
     (FORMAT T "FEF|~A" DISP)
     (UNLESS (NULL FEF)
       (DISASSEMBLY-COMMENT)
       (DISASSEMBLE-POINTER FEF DISP PC)))
    ((AND (= REG 7) (NOT SECOND-WORD) (= DISP 63))
     (PRINC 'PDL-POP))
    ((EQ REG (SYMEVAL-FOR-TARGET '%QMI-REG-IVAR))
     (IF (< DISP 32)
	 (PROGN
	   (FORMAT T "~A|~A" 'SELF DISP)
	   (UNLESS (NULL FEF)
	     (SETQ TEM (DISASSEMBLE-INSTANCE-VAR-NAME FEF DISP))
	     (UNLESS (NULL TEM)
	       (DISASSEMBLY-COMMENT TEM " in SELF"))))
       (PROGN
	 (FORMAT T "~A|~A" 'SELF-MAP (- DISP 32))
	 (UNLESS (NULL FEF)
	   (SETQ TEM (DISASSEMBLE-MAPPED-INSTANCE-VAR-NAME FEF (- DISP 32)))
	   (UNLESS (NULL TEM)
	     (DISASSEMBLY-COMMENT TEM " in SELF"))))))
    (T (FORMAT T "~A|~A" REG DISP)))
  NIL)

(DEFUN DISASSEMBLY-COMMENT (&REST VALUES)
 ;;  9/21/85 DNG - Original version separated from DISASSEMBLE-ADDRESS.
 ;;  2/06/86 DNG - Don't write a space before the tab -- makes partial
 ;;                disassembly displayed by error handler look better.
  (FORMAT T "~30,8T; ")
  (DOLIST (VALUE VALUES)
    (PRINC VALUE))) 

(DEFSUBST DTP-PRINTABLE-P (DTP)
  ;; Is this a data type that can be "in the machine"?
  ;; 12/05/88 DNG - Add DTP-Lexical-Closure.
  ;;  2/07/89 DNG - Add DTP-Stack-List.
  ;;  3/15/89 DNG - Redesigned to use AREF instead of MEMBER.
  (NOT (ZEROP
	 (AREF '#.(LET ((ARRAY (MAKE-ARRAY (EXPT 2 (BYTE-SIZE %%Q-DATA-TYPE))
					   :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT 0)))
		    (DOLIST (DTP '( DTP-Symbol DTP-Fix DTP-Extended-Number
				   DTP-Locative DTP-List DTP-Stack-List DTP-U-Entry DTP-FEF-Pointer 
				   DTP-Array-Pointer DTP-Closure DTP-Lexical-Closure 
				   DTP-Small-Flonum DTP-Instance DTP-Character DTP-Single-Float))
		      (SETF (AREF ARRAY (SYMBOL-VALUE DTP)) 1))
		    ARRAY)
	       DTP))))

(DEFUN DISASSEMBLE-POINTER (FEF DISP &OPTIONAL PC SUPPRESS-QUOTE-P)
 ;;  7/25/85 - Avoid trying to print illegal data types.
 ;; 11/16/85 - Use PRINC instead of PRIN1 for instance variable names.
 ;;  7/09/86 - Handle pointer to :INTERNAL function in another FEF.
 ;;  9/08/86 - New argument SUPPRESS-QUOTE-P.
 ;;  4/25/88 DNG - Updated to recognize pointers to function cells for CLOS 
 ;;		methods and (SETF ...) functions and show the right function spec.
 ;;  5/05/88 DNG - Fix 4/25 change to work right in the inspector.  Avoid 
 ;;		crashing trying to print a list of DTP-SELF-REF-POINTERs.
 ;;		Preliminary handling for CLOS instance references.
 ;;  5/09/88 DNG - Show names of CLOS instance variables.
 ;;  8/09/88 DNG - Fix handling of DTP-SELF-REF-POINTER that can't be decoded.
 ;; 11/08/88 DNG - Fix to not error on a list having a DTP-SELF-REF-POINTER as its second element.
  (declare (ignore PC))
  (LET ((LOC (%MAKE-POINTER-OFFSET DTP-LOCATIVE FEF DISP))
	(DTP (SI:%P-DATA-TYPE-OFFSET FEF DISP))
	CELL PTR OFFSET TEM)
    (COND
      ((= DTP DTP-SELF-REF-POINTER)
       (LET ((NUMBER (SI:%P-POINTER-OFFSET FEF DISP)))
	 (IF (ZEROP (%LOGLDB SYS:%%SELF-REF-TYPE-FLAG NUMBER))
	     ;; Flavors reference
	     (MULTIPLE-VALUE-BIND (PTR COMPONENT-FLAVOR-FLAG)
		 (SI:FLAVOR-DECODE-SELF-REF-POINTER
		   (OR ;;(DISASSEMBLE-CURRENT-FLAVOR FEF PC)
		       (SI:FEF-FLAVOR-NAME FEF))
		   NUMBER)
	       (IF (NULL PTR)
		   (FORMAT T "'#<~A ~O>" 'DTP-SELF-REF-POINTER (SI:CONVERT-TO-UNSIGNED NUMBER))
		 (PROGN
		   (SETQ CELL (IF COMPONENT-FLAVOR-FLAG "mapping table for " ""))
		   (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
		       (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN PTR CELL LOC T)
		     (PROGN
		       (PRINC CELL)
		       (PRINC PTR)
		       (WHEN (EQUAL CELL "")
			 (PRINC " in SELF")))))))
	   ;; Else CLOS reference.
	   (MULTIPLE-VALUE-BIND (NAME MAP-FLAG)
	       (DECODE-CLOS-SELF-REF-POINTER FEF NUMBER)
	     (LET ((ARG (IF (ZEROP (LDB SYS:%%CLOS-SELF-REF-INSTANCE-REF-ADDRESSING-MODE NUMBER))
			   (DISASSEMBLE-ARG-NAME
			     FEF (LDB SYS:%%CLOS-SELF-REF-INSTANCE-REF-INDEX NUMBER))
			 (DISASSEMBLE-LOCAL-NAME
			   FEF (LDB SYS:%%CLOS-SELF-REF-INSTANCE-REF-INDEX NUMBER)))))
	       (IF (AND NAME ARG)
		   (FORMAT T (IF MAP-FLAG "map for ~S in ~A" "slot ~S in ~A")
			   NAME ARG)
		 (FORMAT T "'#<~A ~O>" 'DTP-SELF-REF-POINTER (SI:CONVERT-TO-UNSIGNED NUMBER)))
	   )))))
      ((= DTP DTP-EXTERNAL-VALUE-CELL-POINTER)
       (SETQ PTR (%FIND-STRUCTURE-HEADER (SETQ TEM (%P-CONTENTS-AS-LOCATIVE-OFFSET FEF DISP)))
	     OFFSET (%POINTER-DIFFERENCE TEM PTR))
       (LET (NAME)
	 (COND
	   ((SYMBOLP PTR)
	    (SETQ CELL (NTH OFFSET '("@+0?? " "" "#'" "@PLIST-HEAD-CELL " "@PACKAGE-CELL ")))
	    (SETQ NAME PTR))
	   ((CONSP PTR)
	    (COND ((AND (CONSP (CAR PTR))
			(SYMBOLP (CAAR PTR))
			(GET (CAAR PTR) 'FUNCTION-SPEC-HANDLER))
		   ;; The list could be a flavor "meth" list, or a CLOS
		   ;; "method-spec-object", or a SETF-GENERIC-FUNCTION property.
		   ;; In all of these cases, the function spec is the first
		   ;; element of the list.
		   (SETQ NAME (CAR PTR)))
		  ;; If the cell holds a named function, use its name.
		  ((AND (FUNCTIONP (NTH OFFSET PTR) T)
			(SETQ NAME (FUNCTION-NAME (NTH OFFSET PTR)))))
		  ;; Else can't figure out the name for this cell.
		  (T (SETQ NAME `(:LOCATION ,TEM))))
	    (SETQ CELL "#'"))
	   ((COMPILED-FUNCTION-P PTR) ; probably an :INTERNAL function in the parent FEF
	    (RETURN-FROM DISASSEMBLE-POINTER
	      (DISASSEMBLE-POINTER PTR OFFSET NIL)))
	   (T (SETQ CELL "" NAME PTR)))
	 (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
	     (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN NAME CELL LOC T)
	   (PROGN
	     (PRINC CELL)
	     (PRIN1 NAME)))))
      ((NOT (DTP-PRINTABLE-P DTP))
       ;; Data type that cannot be "in the machine"; don't try to print it.
       (FORMAT T "#<~A ~O>" (OR (NTH DTP Q-DATA-TYPES) DTP)
	       (SI:%P-POINTER-OFFSET FEF DISP)))
      (T
       (LET ((VALUE (CONTENTS LOC)))
	 (SETQ CELL (IF (AND SUPPRESS-QUOTE-P
			     (OR (NUMBERP VALUE) (KEYWORDP VALUE)))
			""
		      "'"))
	 (IF (AND (CONSP VALUE)
		  (OR (NOT (DTP-PRINTABLE-P (SI:%P-DATA-TYPE-OFFSET VALUE 0)))
		      (AND (EQL (SI:%P-CDR-CODE-OFFSET VALUE 0) SI:CDR-NEXT)
			   (NOT (DTP-PRINTABLE-P (SI:%P-DATA-TYPE-OFFSET VALUE 1))))))
	     ;; Careful handling of lists of DTP-SELF-REF-POINTERs used by CLOS.
	     (PROGN (PRINC CELL)
		    (WRITE-CHAR #\()
		    (DO ((TAIL VALUE (CDR TAIL)))
			((NULL TAIL))
		      (LET ((DTP (SI:%P-DATA-TYPE-OFFSET TAIL 0)))
			(IF (DTP-PRINTABLE-P DTP)
			    (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
				(FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN
					 (CAR TAIL) "" (LOCF (CAR TAIL)) NIL)
			      (PRIN1 (CAR TAIL)))
			  (FORMAT T "#<~A ~O>" (NTH DTP Q-DATA-TYPES)
				  (SI:CONVERT-TO-UNSIGNED (SI:%P-POINTER-OFFSET TAIL 0)))))
		      (UNLESS (NULL (CDR TAIL)) (WRITE-CHAR #\SPACE)) )
		    (WRITE-CHAR #\)))
	   (IF DISASSEMBLE-OBJECT-OUTPUT-FUN
	       (FUNCALL DISASSEMBLE-OBJECT-OUTPUT-FUN VALUE CELL LOC NIL)
	     (PROGN
	       (PRINC CELL)
	       (PRIN1 VALUE)))))))))

(DEFUN FEF-FLAVOR-NAME (FEF)
  (AND (TYPEP FEF 'COMPILED-FUNCTION)
       (NOT (ZEROP (%P-LDB-OFFSET (SYMEVAL-FOR-TARGET 'SI::%%FEF-HEADER-SELF-MAPPING-TABLE)
				  FEF 0)))
       (%P-CONTENTS-OFFSET FEF
			   (IF (= (%P-LDB-OFFSET (SYMEVAL-FOR-TARGET 'SI::%%FEF-HEADER-CALL-TYPE)
						 FEF
						 0)
				  (SYMEVAL-FOR-TARGET 'SI::%FEF-CALL-LONG))
			       (SYMEVAL-FOR-TARGET 'SI::%FEF-SECOND-OPTIONAL-WORD)
			     (SYMEVAL-FOR-TARGET 'SI::%FEF-FIRST-OPTIONAL-WORD)))))

;; Given a fef and an instance variable slot number,
;; find the name of the instance variable,
;; if the fef knows which flavor is involved.
(DEFUN DISASSEMBLE-INSTANCE-VAR-NAME (FEF SLOTNUM)
  (LET ((FLAVOR (GET (FEF-FLAVOR-NAME FEF) 'SI:FLAVOR)))
    (AND FLAVOR (NTH SLOTNUM (SI:FLAVOR-ALL-INSTANCE-VARIABLES FLAVOR))))) 

(DEFUN DISASSEMBLE-MAPPED-INSTANCE-VAR-NAME (FEF MAPSLOTNUM)
  (LET ((FLAVOR (GET (FEF-FLAVOR-NAME FEF) 'SI:FLAVOR)))
    (AND FLAVOR (NTH MAPSLOTNUM (SI:FLAVOR-MAPPED-INSTANCE-VARIABLES FLAVOR))))) 

(defun decode-clos-self-ref-pointer (FEF pointer-number)
  "Decode the pointer field of a DTP-SELF-REF-POINTER.
Values are a slot name and NIL, or a component class name and T."
  ;;  5/09/88 DNG - Original (adapted from FLAVOR-DECODE-SELF-REF-POINTER).
  ;;  2/21/89 DNG - Fix to handle (EQL #) specializers.
  (declare (values instance-var-or-component-class t-if-component-class))
  (let* ((LOCAL-SLOT (LDB SYS:%%CLOS-SELF-REF-MAPPING-TABLE-LOCAL-INDEX POINTER-NUMBER))
	 (ARG-SLOT (IF (= LOCAL-SLOT SYS:LOCAL-FOR-FIRST-MAPPING-TABLE)
		       0
		     (- LOCAL-SLOT (- SYS:LOCALS-FOR-MAPPING-TABLE-BASE 1))))
	 (CLASS-NAME (AND (>= ARG-SLOT 0)
			  (NTH ARG-SLOT (FUNCTION-SPECIALIZERS FEF)))))
    (UNLESS (OR (NULL CLASS-NAME)
		(NOT (FBOUNDP 'ticlos:class-named)))
      (compiler-let ((INHIBIT-STYLE-WARNINGS-SWITCH T)) ; inhibit "not in cold load" warnings on CLOS functions
	(LET ((class-object (if (ticlos:individual-typep class-name)
				(ticlos:class-of (ticlos:individual-type class-name))
			      (ticlos:class-named class-name t)))
	      (offset (ldb sys:%%CLOS-SELF-REF-SLOT-OFFSET pointer-number)))
	  (cond
	    ((null class-object) nil)
	    ((ldb-test sys:%%CLOS-SELF-REF-MAP-LEADER-FLAG pointer-number)
	     (values (ticlos:class-name (nth offset (ticlos:class-mapped-supers class-object)))
		     t))
	    ((ldb-test sys:%%CLOS-SELF-REF-RELOCATE-FLAG pointer-number)
	     (nth offset (ticlos:class-mapped-slot-names class-object)))
	    (t NIL)))))))

(DEFUN FUNCTION-SPECIALIZERS (FCT)
  ;; Given a function, which should be for a CLOS method, return the list of class names.
  ;;  2/10/89 DNG - Add use of debug info if name is not a method.
  (LET ((FNAME (FUNCTION-NAME FCT)))
    (IF (EQ (CAR-SAFE FNAME) 'TICLOS:METHOD)
	(CAR (LAST FNAME))
      (GET-DEBUG-INFO-FIELD (GET-DEBUG-INFO-STRUCT FCT) 'ARG-CLASSES)
      )))

(DEFUN FUNCTION-DEBUGGING-INFO (FUNCTION)
  ;; 11/02/85 DNG - Modify to handle either Explorer release 1 or 3 FEF formats.
  ;; 11/22/85 DNG - Allow argument to be an interpreted definition. [for MAYBE-INTEGRATE]
  ;; 12/04/85 DNG - Allow argument to be a symbol.
  ;;  2/14/86 DNG - Fix for old FEFs with non-symbol names.
  (COND
    ((CONSP FUNCTION)
     (AND (MEMBER (CAR FUNCTION) '(GLOBAL:NAMED-LAMBDA GLOBAL:NAMED-SUBST
						       NAMED-LAMBDA NAMED-SUBST)
		  :TEST #'EQ)
	  (CONSP (CADR FUNCTION))
	  (CDADR FUNCTION)))
    ((SYMBOLP FUNCTION)
     (AND (FBOUNDP FUNCTION)
	  (FUNCTION-DEBUGGING-INFO (SYMBOL-FUNCTION FUNCTION))))
    ((EQ TARGET-PROCESSOR HOST-PROCESSOR)
     (GET-DEBUG-INFO-STRUCT FUNCTION))
    (T
     #+compiler:debug
     (CHECK-TYPE FUNCTION COMPILED-FUNCTION)
     (%P-CONTENTS-OFFSET FUNCTION (SYMEVAL-FOR-TARGET 'SI::%FEF-DEBUGGING-INFO-WORD)))
    ))

;; Given a fef and the number of a slot in the local block,
;; return the name of that local (or NIL if unknown).
;; If it has more than one name due to slot-sharing, we return a list of
;; the names, but if there is only one name we return it.
(DEFUN DISASSEMBLE-LOCAL-NAME (FEF LOCALNUM)
 ;;  9/25/85 DNG - Allow map entry to be a symbol instead of a list.
 ;; 11/03/85 DNG - Permit use of new debug-info structure.
 ;;  7/21/86 DNG - Use ELT instead of NTH to allow use of a vector.
  (LET* ((FDI (FUNCTION-DEBUGGING-INFO FEF))
	 (MAP (IF (LISTP FDI)
		  ;; Old-style debugging info association list.
		  (CADR (ASSOC 'COMPILER::LOCAL-MAP FDI :TEST #'EQ))
		;; Else, new debug-info structure.
		(SI:DBI-LOCAL-MAP FDI)))
	 (NAMES (AND MAP (ELT MAP LOCALNUM))))
    (COND ((ATOM NAMES) NAMES)
	  ((NULL (REST1 NAMES)) (FIRST NAMES))
	  (T NAMES)))) 

;; Given a fef and the number of a slot in the argument block,
;; return the name of that argument (or NIL if unknown).
;; First we look for an arg map, then we look for a name in the ADL.
(DEFUN DISASSEMBLE-ARG-NAME (FEF ARGNUM)
 ;;  9/25/85 DNG - Allow map entry to be a symbol instead of a list.
 ;; 11/03/85 DNG - Permit use of new debug-info structure; get rid of ADL code.
  (LET* ((FDI (FUNCTION-DEBUGGING-INFO FEF)))
    (IF (LISTP FDI)
	;; Old-style debugging info association list.
	(LET* ((ARGMAP (CADR (ASSOC 'COMPILER::ARG-MAP FDI :TEST #'EQ)))
	       (NAMES (NTH ARGNUM ARGMAP)))
	  (IF (ATOM NAMES) NAMES (FIRST NAMES)))
      ;; Else, new debug-info structure;
      ;; count off the names in the argument list.
      (LET ((COUNT 0))
	(DOLIST (ARG (SI:DBI-ARGLIST FDI) NIL)
	  (IF (AND (ATOM ARG)
		   (MEMBER ARG LAMBDA-LIST-KEYWORDS :TEST #'EQ))
	      (WHEN (MEMBER ARG '(&REST &KEY &AUX) :TEST #'EQ)
		(RETURN NIL))
	    (IF (= COUNT ARGNUM)
		(RETURN (IF (ATOM ARG) ARG (FIRST ARG)))
	      (INCF COUNT)))))))) 

(DEFUN PUSH-NUMBER-VALUE (FEF PC)
  ;; If the instruction in FEF at PC has the effect a pushing a fixnum
  ;; constant on the stack, then return the number pushed.  Else, nil.
  ;;  7/16/86 DNG - Original.  Note this assumes VM2.
  (AND FEF
       PC
       (LET* ((WD (DISASSEMBLE-FETCH FEF PC))
	      (OP (LDB (SYMEVAL-FOR-TARGET '%%QMI-FULL-OPCODE) WD))
	      (NAME (AREF (INSTRUCTION-DECODE-TABLE) OP))
	      (DISP (LDB (SYMEVAL-FOR-TARGET '%%QMI-INST-ADR) WD)))
	 (COND ((EQ NAME 'PUSH-NUMBER)
		DISP)
	       ((EQ NAME 'PUSH-NEG-NUMBER)
		(- 0 DISP))
	       ((EQ NAME 'PUSH)
		(AND (< DISP #o300)
		     (EQL DTP-FIX (SI:%P-DATA-TYPE-OFFSET FEF DISP))
		     (%P-CONTENTS-OFFSET FEF DISP)))
	       ((EQ NAME 'PUSH-LONG-FEF)
		(AND (EQL DTP-FIX (SI:%P-DATA-TYPE-OFFSET FEF DISP))
		     (%P-CONTENTS-OFFSET FEF DISP)))
	       (T NIL)))))

(DEFUN DISASSEMBLE-LEXICAL-VAR-COMMENT (FEF LEVEL OFFSET REAL-LEVEL)
  ;;  7/16/86 DNG - Original version separated from DISASSEMBLE-ADDRESS.
  ;;  9/12/86 DNG - Don't show function name when it is a gensym.
  (UNLESS (NULL FEF)
    (IGNORE-ERRORS			   ; in case of invalid debug info 
      (MULTIPLE-VALUE-BIND (VARNAME FNAME)
	  (DISASSEMBLE-LEXICAL-NAME FEF LEVEL OFFSET REAL-LEVEL)
	(UNLESS (NULL VARNAME)
	  (DISASSEMBLY-COMMENT VARNAME)
	  (UNLESS (OR (NULL FNAME)
		      (AND (SYMBOLP FNAME) (NULL (SYMBOL-PACKAGE FNAME))))
	    (FORMAT T " in ~S"
		    (IF (AND (CONSP FNAME)
			     (MEMBER (FIRST FNAME) '(:INTERNAL :TARGET))
			     (SYMBOLP (THIRD FNAME)))
			(THIRD FNAME)
		      FNAME))))))))

(DEFUN DISASSEMBLE-CALL-INFO-WORD (CALL-INFO)
  ;;  9/06/86 DNG - Original.
  ;;  8/09/88 DNG - Added recognition of the CLOS bit.
  (WHEN (PLUSP (LDB (SYMEVAL-FOR-TARGET 'SI:%%call-info-lexpr-funcall-flag) CALL-INFO))
    (PRINC 'APPLY) (WRITE-CHAR #\SPACE))
  (FORMAT T "~A arg~:P, "
	  (LDB (SYMEVAL-FOR-TARGET 'SI:%%call-info-number-of-arguments) CALL-INFO))
  (WHEN (PLUSP (LDB (SYMEVAL-FOR-TARGET 'SI:%%call-info-self-map-table-provided) CALL-INFO))
    (PRINC "self-map, "))
  (WHEN (PLUSP (LDB (SYMEVAL-FOR-TARGET 'si:%%call-info-clos-info-provided) CALL-INFO))
    (PRINC "next-method-list, maps, "))
  (LET ((RETURN-TYPE (LDB (SYMEVAL-FOR-TARGET 'SI:%%call-info-return-type) CALL-INFO)))
    (DECLARE (FIXNUM RETURN-TYPE))
    (COND ((EQL RETURN-TYPE (SYMEVAL-FOR-TARGET 'SI:%only-one-result-needed))
	   (PRINC "1 value"))
	  ((EQL RETURN-TYPE (SYMEVAL-FOR-TARGET 'SI:%normal-return))
	   (FORMAT T "~A values"
		   (LDB (SYMEVAL-FOR-TARGET 'SI:%%call-info-number-of-results) CALL-INFO)))
	  ((EQL RETURN-TYPE (SYMEVAL-FOR-TARGET 'SI:%multiple-value-list-return))
	   (PRINC 'multiple-value-list))
	  ((EQL RETURN-TYPE (SYMEVAL-FOR-TARGET 'SI:%return-all-values-with-count-on-stack))
	   (PRINC "return values and count")))))


(DEFUN DISASSEMBLE-LEXICAL-NAME (FEF LEVEL OFFSET REAL-LEVEL)
 ;; Return the name of a lexical variable in a higher context.
 ;; The second value returned is the name of the variable's function.
 ;;  2/01/86 DNG - Original.
 ;;  7/12/86 DNG - Use :LEXICAL-REGISTER-LEVELS from debug info.
  (LET ((DBI (FUNCTION-DEBUGGING-INFO FEF)))
    (UNLESS REAL-LEVEL
      ;; The level is a 0 or 1 indicating LEX-A or LEX-B addressing.
      (LET ((LEX-LEVELS (SI:GET-DEBUG-INFO-FIELD DBI 'LEXICAL-REGISTER-LEVELS)))
	(UNLESS (NULL LEX-LEVELS)
	  (SETQ LEVEL (NTH LEVEL LEX-LEVELS)))))
    (DOTIMES (I (1+ LEVEL))
      (IF (NULL DBI)
	  (RETURN)
	(SETQ DBI (SI:GET-DEBUG-INFO-FIELD DBI :LEXICAL-PARENT-DEBUG-INFO))))
    (UNLESS (NULL DBI)
      (VALUES (ELT (SI:GET-DEBUG-INFO-FIELD DBI :VARIABLES-USED-IN-LEXICAL-CLOSURES) OFFSET)
	      (SI:GET-DEBUG-INFO-FIELD DBI :NAME))))) 

(DEFUN DISASSEMBLE-DISPATCH-TABLE (FEF DISP)
  ;; 12/18/85 CLM - For Rel.3, print out the contents of a
  ;;                dispatch table in the comment field.
  (FORMAT T "~20,1TFEF|~A" DISP)
  (DISASSEMBLY-COMMENT)
  (WRITE-CHAR #\[)
  (LET ((MAX-INDEX (%P-CONTENTS-OFFSET FEF DISP)))
    (DO ((INDEX 0 (1+ INDEX))
	 (TAB-DISP (+ DISP 2) (1+ TAB-DISP)))
	((> INDEX MAX-INDEX))
      (UNLESS (= INDEX 0)
	(PRINC ";"))
      (FORMAT T "~A~A" INDEX (%P-CONTENTS-OFFSET FEF TAB-DISP))))
  (FORMAT T ";~A~A" 'ELSE (%P-CONTENTS-OFFSET FEF (1+ DISP)))
  (WRITE-CHAR #\]) )

(DEFUN DISASSEMBLE-SELECT-TABLE (FEF DISP)
  ;;  9/06/86 DNG - Original.
  ;;  9/08/86 DNG - Fix to increment DISPATCH-INDEX.
  (FORMAT T "~20,1TFEF|~A" DISP)
  (DISASSEMBLY-COMMENT)
  (IF (EQL (SI:%P-DATA-TYPE-OFFSET FEF DISP) DTP-FIX)
      (PROGN ; print select table
	(WRITE-CHAR #\[)
	(LET* ((TABLE-LENGTH (%P-CONTENTS-OFFSET FEF DISP))
	       (MAX-INDEX (+ DISP TABLE-LENGTH)))
	  (DECLARE (FIXNUM TABLE-LENGTH MAX-INDEX))
	  (DO ((TABLE-INDEX (+ DISP 1) (1+ TABLE-INDEX))
	       (DISPATCH-INDEX (+ DISP TABLE-LENGTH 3) (1+ DISPATCH-INDEX)))
	      ((> TABLE-INDEX MAX-INDEX))
	    (DISASSEMBLE-POINTER FEF TABLE-INDEX NIL T)
	    (WRITE-CHAR #\RIGHT-ARROW)
	    ;; The following should be a fixnum, but don't want to crash if it isn't.
	    (IF (EQL (SI:%P-DATA-TYPE-OFFSET FEF DISPATCH-INDEX) DTP-FIX)
		(PRINC (%P-CONTENTS-OFFSET FEF DISPATCH-INDEX))
	      (DISASSEMBLE-POINTER FEF DISPATCH-INDEX))
	    (WRITE-CHAR #\;))
	  (FORMAT T "~A~A" 'ELSE (%P-CONTENTS-OFFSET FEF (+ DISP TABLE-LENGTH 2))))
	(WRITE-CHAR #\]))
    ;; else something is wrong.
    #+compiler:debug
    (DISASSEMBLE-POINTER FEF DISP)))