;;; -*- Mode:Lisp; Package:System-Internals; Base:8 -*-
;;; QFASL File Disassembler
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

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

(MAKUNBOUND 'UNFASL-GROUP-DISPATCH) ;SO DON'T GET SCREWED IF RELOAD IT

(DEFSUBST UNFASL-NIBBLE () (FUNCALL UNFASL-FILE ':TYI))

;User calls this
(DEFUN UNFASL (INPUT-FILE &OPTIONAL OUTPUT-FILE)
  (SETQ INPUT-FILE (FS:MERGE-AND-SET-PATHNAME-DEFAULTS INPUT-FILE FS:LOAD-PATHNAME-DEFAULTS
						       "QFASL")
	OUTPUT-FILE (FUNCALL (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 '(:IN :FIXNUM))
    (OR (AND (= (UNFASL-NIBBLE) 143150)		;CHECK MAGIC ID
	     (= (UNFASL-NIBBLE) 71660))
	(FERROR NIL "~A not a qfasl file" INPUT-FILE))
    (WITH-OPEN-FILE (STANDARD-OUTPUT OUTPUT-FILE ':PRINT)
      (FORMAT T "; -*-Text-*-~%; This is the UNFASL for ~A~2%"
	        (FUNCALL UNFASL-FILE ':TRUENAME))
      (UNFASL-TOP-LEVEL)))
  OUTPUT-FILE)

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

(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 FASL-TABLE)
    FASL-RETURN-FLAG))

(DEFUN INITIALIZE-UNFASL-TABLE ()
  (ASET 'NR-SYM FASL-TABLE FASL-SYMBOL-HEAD-AREA)
  (ASET 'P-N-STRING FASL-TABLE FASL-SYMBOL-STRING-AREA)
  (ASET 'USER-ARRAY-AREA FASL-TABLE FASL-ARRAY-AREA)
  (ASET 'MACRO-COMPILED-PROGRAM FASL-TABLE FASL-FRAME-AREA)
  (ASET 'USER-INITIAL-LIST-AREA FASL-TABLE FASL-LIST-AREA)
  (ASET 'FASL-TEMP-AREA FASL-TABLE FASL-TEMP-LIST-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)
    (PRIN1 (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)
  (DO I UNFASL-INDENTATION (1- I) (NOT (> I 0))
    (TYO #\SP)))

(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 " [~O]" NIBBLE)
    NIBBLE))

(DEFUN UNFASL-NEXT-VALUE ()
  (LET ((UNFASL-INDENTATION (+ 3 UNFASL-INDENTATION)))
    (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 NIL "FASL table overflow: ~S" V))
	(T
	 (ASET V FASL-TABLE FASL-TABLE-FILL-POINTER)
	 (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)
  (ASET V FASL-TABLE FASL-EVALED-VALUE)
  FASL-EVALED-VALUE)


;--FASL OPS

(DEFUN UNFASL-OP-ERR ()
  (PRINC '| NOT HANDLED|)
  (COND ((NOT (ZEROP FASL-GROUP-LENGTH))
	 (PRINC '| - FOLLOWING NIBBLES: |)
	 (DO I FASL-GROUP-LENGTH (1- I) (= I 0)
	     (UNFASL-NEXT-NIBBLE-PR))))
  0)

(DEFUN UNFASL-OP-INDEX ()
  (LET ((TEM (UNFASL-NEXT-NIBBLE-PR)))
    (FORMAT T " {~S}" (AREF FASL-TABLE TEM))
    TEM))

(DEFUN UNFASL-OP-NOOP ()
  T)

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

(DEFUN UNFASL-OP-SYMBOL ()
  (AND FASL-GROUP-FLAG (PRINC '| UNINTERNED|))
  (UNFASL-OP-SYMBOL1 NIL))

(DEFUN UNFASL-OP-SYMBOL1 (STRING-FLAG)
  (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 (FUNCALL S ':TYO (LOGAND 377 TEM))
			(OR (= (SETQ TEM (LSH TEM -8)) 200)
			    (FUNCALL S ':TYO TEM))))))
    (OR STRING-FLAG (SETQ STR (MAKE-SYMBOL STR)))
    (FORMAT T " ~S" 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 (FUNCALL S ':STRING-OUT (UNFASL-NEXT-VALUE))
				  UNLESS (= I 1) DO (FUNCALL S ':TYO #/:))))))
    (UNFASL-TERPRI)
    (FORMAT T "  ~A" SYM)
    (ENTER-UNFASL-TABLE SYM)))

(DEFUN UNFASL-OP-FLOAT ()
  (IF FASL-GROUP-FLAG				;Small float
      (LET ((ANS (%MAKE-POINTER DTP-SMALL-FLONUM
				(%LOGDPB (UNFASL-NEXT-NIBBLE) 2010 (UNFASL-NEXT-NIBBLE)))))
	(FORMAT T "  ~S" ANS)
	(ENTER-UNFASL-TABLE ANS))
      (LET ((ANS (FLOAT 0)) TEM)		;Big float
	(%P-DPB-OFFSET (UNFASL-NEXT-NIBBLE) 1013 ANS 0)
	(SETQ TEM (UNFASL-NEXT-NIBBLE))
	(%P-DPB-OFFSET (LDB 1010 TEM) 0010 ANS 0)
	(%P-DPB-OFFSET (%LOGDPB TEM 2010 (UNFASL-NEXT-NIBBLE)) 0030 ANS 1)
	(FORMAT T "  ~S" ANS)
	(ENTER-UNFASL-TABLE ANS))))

(DEFUN UNFASL-OP-RATIONAL ()
  (LET ((RAT (MAKE-RATIONAL (UNFASL-NEXT-VALUE) (UNFASL-NEXT-VALUE))))
    (FORMAT T "  ~S" RAT)
    (ENTER-UNFASL-TABLE RAT)))
		
(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 (COPYLIST LST))))
      (IF (NULL COMPONENT-FLAG)
	  (ENTER-UNFASL-TABLE LST)
	  (UNFASL-STORE-EVALED-VALUE LST)))))

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

(DEFUN UNFASL-OP-LIST-COMPONENT ()
  (UNFASL-OP-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 (MINUS ANS))))
		 (TYO #\SP)
		 (PRIN1 ANS)
		 (ENTER-UNFASL-TABLE ANS))
    (SETQ ANS (DPB (UNFASL-NEXT-NIBBLE) (+ (LSH POS 6) 20) ANS))))

(DEFUN UNFASL-OP-ARRAY ()
 (LET ((FLAG FASL-GROUP-FLAG))
   (UNFASL-NEXT-VALUE)
   (PRINC '| =AREA|)
   (UNFASL-NEXT-VALUE)
   (PRINC '| =TYPE|)
   (UNFASL-NEXT-VALUE)
   (PRINC '| =DIMLIST|)
   (UNFASL-NEXT-VALUE)
   (PRINC '| =DISPLACED-P|)
   (UNFASL-NEXT-VALUE)
   (PRINC '| =LEADER|)
   (UNFASL-NEXT-VALUE)
   (PRINC '| =INDEX-OFFSET|)
   (COND (FLAG
	  (UNFASL-NEXT-VALUE)
	  (PRINC '| =NAMED-STRUCTURE|)))
   (ENTER-UNFASL-TABLE 'ARRAY)))

(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 (ASET (AREF FASL-TABLE FROM) FASL-TABLE TO)
	     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 " CDRC=~O" (LSH TEM -6))
	     (OR (= 0 (LOGAND 1 (LSH TEM -5))) (PRINC '| FLAGB|))
	     (OR (= 0 (LOGAND 20 TEM)) (PRINC '| E-V-C-P|))
	     (OR (= 0 (LOGAND 400 TEM)) (PRINC '| 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 'FEF)))

(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 ()
  (PRINC '| ARRAY|) (UNFASL-OP-INDEX) 
  (PRINC '| SUBSCR|) (UNFASL-OP-INDEX)
  (PRINC '| 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)

(DEFUN UNFASL-OP-SET-PARAMETER ()
  (PROG (FROM TO)
	(SETQ TO (UNFASL-NEXT-VALUE)) (PRINC '| =TO|)
	;(SETQ FROM (UNFASL-GROUP)) (PRINC '| =FROM|)
	(SETQ FROM (UNFASL-NEXT-VALUE)) (PRINC '| =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)
	  (UNFASL-NEXT-VALUE)))
    IDX))

(DEFUN UNFASL-OP-INITIALIZE-NUMERIC-ARRAY ()
  (MULTIPLE-VALUE-BIND (NIL IDX) (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)
	  (PRIN1-THEN-SPACE (UNFASL-NEXT-NIBBLE))))
    IDX))

(DEFUN UNFASL-OP-EVAL ()
  (LET ((FORM (AREF FASL-TABLE (UNFASL-NEXT-NIBBLE))))
    (FORMAT T "*** this operation decommitted***")
    (UNFASL-STORE-EVALED-VALUE `(EVAL ,FORM))))

(DEFUN UNFASL-OP-EVAL1 ()
  (LET ((FORM (UNFASL-NEXT-VALUE)))
    (UNFASL-TERPRI)
    (ENTER-UNFASL-TABLE (PRIN1 `(EVAL ,FORM)))))

(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 (INTERN (FORMAT NIL "UN~A" (CAR L)) PKG-SYSTEM-INTERNALS-PACKAGE))
    (ASET (IF (FBOUNDP TEM) TEM 'UNFASL-OP-ERR)
	  UNFASL-GROUP-DISPATCH I)))