;; -*- MODE: LISP; PACKAGE: SI -*- QFASL FILE DISASSEMBLER LISPM VERSION 


(DECLARE (SPECIAL UNFASL-TABLE 
		  UNFASL-INDENTATION
		  UNFASL-GROUP-DISPATCH UNFASL-GROUP-DISPATCH-SIZE))

(DECLARE (SPECIAL UNFASL-STREAM)) 

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

(DEFUN BUFFER-UNFASL (EDITOR-BUFFER-NAME FILE-NAME)
  (LET ((BUFFER (ZWEI:FIND-BUFFER-NAMED EDITOR-BUFFER-NAME)))
    (OR BUFFER (FERROR NIL "Create buffer ~S with editor first" EDITOR-BUFFER-NAME))
    (LET ((STANDARD-OUTPUT (ZWEI:INTERVAL-STREAM
			       (ZWEI:INTERVAL-LAST-BP BUFFER)
			       (ZWEI:INTERVAL-LAST-BP BUFFER) T NIL)))
      (FUNCALL STANDARD-OUTPUT ':TYO #\FF)
      (UNFASL FILE-NAME))))

(DEFUN UNFASL (FILE-NAME)	;USER CALLS THIS
  (PROG (UNFASL-STREAM)
       (OR (BOUNDP 'UNFASL-GROUP-DISPATCH) (INITIALIZE-UNFASL-ENVIRONMENT))
       (SETQ FILE-NAME (FILE-DEFAULT-FN2 FILE-NAME "QFASL"))
       (SETQ FILE-NAME (FILE-DEFAULT-FILENAMES FILE-NAME))
       (SETQ UNFASL-STREAM (OPEN FILE-NAME '(READ FIXNUM)))
       (OR (AND (= (UNFASL-NIBBLE) 143150)		;CHECK MAGIC ID
		(= (UNFASL-NIBBLE) 71660))
	   (FERROR NIL "Not a qfasl file, ~S" FILE-NAME))
;       (DO ((^R T)
;	    (OUTFILES (LIST (OPEN (MERGEF '|* UNFASL| FILE-NAME) '(OUT BLOCK)))))
;	   ()
	 (UNFASL-TOP-LEVEL)
;	 (CLOSE (CAR OUTFILES)))
       (CLOSE UNFASL-STREAM)))

(DEFUN UNFASL-NIBBLE NIL (FUNCALL UNFASL-STREAM 'TYI))

(DEFUN UNFASL-TOP-LEVEL NIL 
  (PROG NIL 
   L	(COND ((EQ (UNFASL-WHACK) 'EOF) (RETURN T)))
	(GO L)))

(DEFUN UNFASL-WHACK (&AUX UNFASL-TABLE FASL-RETURN-FLAG UNFASL-INDENTATION)
	(SETQ UNFASL-INDENTATION 0)
	(SETQ UNFASL-TABLE (MAKE-ARRAY 'FASL-TABLE-AREA 
					   'ART-Q-LIST 
					   4000
					   NIL 
					   (LIST FASL-TABLE-WORKING-OFFSET)))
							;LEADER FOR FILLING
;CONTENTS IS A NUMBER WHICH IS A LISP MACHINE Q.
	(INITIALIZE-UNFASL-TABLE)
;	(FASL-SET-MESA-EXIT-BASE)
	(DO () (FASL-RETURN-FLAG)
	  (UNFASL-GROUP))
	(AND UNFASL-TABLE (RETURN-ARRAY UNFASL-TABLE))
	FASL-RETURN-FLAG)

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

(DEFUN UNFASL-GROUP NIL 
  (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 (AR-1 UNFASL-GROUP-DISPATCH FASL-GROUP-TYPE))
		(COND ((NOT (ZEROP FASL-GROUP-LENGTH))
		       (TERPRI) (PRINC '|FASL-GROUP-COUNT wrong; |)
		       (PRIN1 FASL-GROUP-LENGTH) (PRINC '| nibbles left over|)
		       (TERPRI)))))))

(DEFUN UNFASL-TERPRI NIL 
  (TERPRI)
  (DO I UNFASL-INDENTATION (1- I) (NOT (> I 0))
    (TYO 40)))

(DEFUN UNFASL-NEXT-NIBBLE NIL 
	(COND ((= 0 FASL-GROUP-LENGTH)
	       (FERROR NIL "FASL-GROUP-OVERFLOW"))
	      (T (SETQ FASL-GROUP-LENGTH (1- FASL-GROUP-LENGTH))
		 (UNFASL-NIBBLE))))

(DEFUN UNFASL-NEXT-NIBBLE-PR NIL
  ((LAMBDA (NIBBLE)
     (FORMAT T " [ ~S ]" NIBBLE)
     NIBBLE)
   (UNFASL-NEXT-NIBBLE)))

(DEFUN UNFASL-NEXT-VALUE NIL 
  ((LAMBDA (UNFASL-INDENTATION)
	(AR-1 UNFASL-TABLE (UNFASL-GROUP)))
   (+ 3 UNFASL-INDENTATION)))

(DEFUN ENTER-UNFASL-TABLE (V)
  (LET ((RES (ARRAY-PUSH-EXTEND UNFASL-TABLE V)))
    (FORMAT T " --> ~S" RES)
    RES))

;--FASL OPS

(DEFUN UNFASL-OP-ERR NIL
  (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)))))

(DEFUN UNFASL-OP-INDEX NIL
  (PROG (TEM)
    (SETQ TEM (UNFASL-NEXT-NIBBLE-PR))
    (TYO 40)
    (TYO 173)
    (PRINC (AR-1 UNFASL-TABLE TEM))
    (TYO 175)
    (RETURN TEM)))

(DEFUN UNFASL-OP-NOOP NIL
  T)

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

(DEFUN UNFASL-OP-SYMBOL (&OPTIONAL STRING-FLAG)
  (PROG (STRING)
	(AND FASL-GROUP-FLAG (PRINC '| UNINTERNED|))
	(SETQ STRING (MAKE-ARRAY NIL 'ART-STRING (* 2 FASL-GROUP-LENGTH)))
	(DO ((IDX 0)
	     (NIB))
	    ((ZEROP FASL-GROUP-LENGTH)
	     (ADJUST-ARRAY-SIZE STRING IDX))
	  (SETQ NIB (UNFASL-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))))
   X	(TYO 40)
	(COND (STRING-FLAG (PRIN1 STRING))
	      (T (PRINC STRING)))
        (RETURN (ENTER-UNFASL-TABLE STRING))))

(DEFUN UNFASL-OP-PACKAGE-SYMBOL ()
  (PROG (LEN LST)
	(SETQ LEN (1- (UNFASL-NEXT-NIBBLE)))
	(DO I 0 (1+ I) (NOT (< I LEN))
	  (SETQ LST (CONS (UNFASL-NEXT-VALUE) LST))	;Will print out with double quotes,
	  (TYO #/:))					;  too bad.
	(RETURN
	 (ENTER-UNFASL-TABLE				;Is this reasonable?
	  (CONS '**PACKAGE**
	        (NREVERSE (CONS (UNFASL-NEXT-VALUE) LST)))))))
		
(DEFUN UNFASL-OP-LIST (&OPTIONAL (AREA (AR-1 UNFASL-TABLE FASL-LIST-AREA)))
  (PROG (LIST-LENGTH)
	(SETQ LIST-LENGTH (UNFASL-NEXT-NIBBLE-PR))
	(PRINC '| AREA=|)
	(PRIN1 AREA)
	(AND FASL-GROUP-FLAG (PRINC '| (DOTIFY)|))
  L	(COND ((= 0 LIST-LENGTH)
		(GO X)))
        (UNFASL-NEXT-VALUE)
	(SETQ LIST-LENGTH (1- LIST-LENGTH))
	(GO L)
  X	(RETURN (ENTER-UNFASL-TABLE 'LIST))
))

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

;(DEFUN UNFASL-OP-FIXED NIL 
;  (PROG (ANS)
;	(DECLARE (FIXNUM ANS))
;	(SETQ ANS 0)
;  L	(COND ((= 0 FASL-GROUP-LENGTH)
;		(GO X)))
;	(SETQ ANS (+ (LSH ANS 20) (UNFASL-NEXT-NIBBLE)))
;	(GO L)
;  X	(COND (FASL-GROUP-FLAG (SETQ ANS (MINUS ANS))))
;        (TYO 40)
;	(PRIN1 ANS)
;	(RETURN (ENTER-UNFASL-TABLE ANS))))

;Generate a FIXNUM (or BIGNUM) value.
(DEFUN UNFASL-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))))
		 (TYO 40)
		 (PRIN1 ANS)
		 (ENTER-UNFASL-TABLE ANS))
    (SETQ ANS (DPB (UNFASL-NEXT-NIBBLE) (+ (LSH POS 6) 20) ANS))))

(DEFUN UNFASL-OP-ARRAY NIL 
 ((LAMBDA (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))
  FASL-GROUP-FLAG))

(DEFUN UNFASL-OP-MOVE NIL 
 (PROG (FROM TO)
	(SETQ FROM (UNFASL-NEXT-NIBBLE-PR))
	(SETQ TO (UNFASL-NEXT-NIBBLE-PR))
	(COND ((= TO 177777) (RETURN (ENTER-UNFASL-TABLE (AR-1 UNFASL-TABLE FROM))))
	      (T (AS-1 (AR-1 UNFASL-TABLE FROM) UNFASL-TABLE TO)
		 (RETURN TO)))))

(DEFUN UNFASL-OP-FRAME NIL 
  (DECLARE (FIXNUM Q-COUNT UNBOXED-COUNT TEM))
  (PROG (Q-COUNT UNBOXED-COUNT TEM)
	(SETQ Q-COUNT (UNFASL-NEXT-NIBBLE))
	(SETQ UNBOXED-COUNT (UNFASL-NEXT-NIBBLE))
	(SETQ FASL-GROUP-LENGTH (UNFASL-NEXT-NIBBLE))
	(PRINC '| Q-COUNT=|) (PRIN1 Q-COUNT)
	(PRINC '| UNBOXED-COUNT=|) (PRIN1 UNBOXED-COUNT)
	(PRINC '| GROUP-LENGTH=|) (PRIN1 FASL-GROUP-LENGTH)
   L1	(COND ((= 0 Q-COUNT) (GO L2)))
	(UNFASL-NEXT-VALUE)
	(SETQ TEM (UNFASL-NEXT-NIBBLE))
	(PRINC '| CDRC=|) (PRIN1 (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)))
	    (PROGN (PRINC '| OFFSET=|) (PRIN1 TEM)))
	(SETQ Q-COUNT (1- Q-COUNT))
	(GO L1)
  L2 
  L3	(COND ((= 0 UNBOXED-COUNT) (GO L4)))
        (UNFASL-TERPRI)
	(PRINC '|   UNBOXED |)
	(PRIN1 (LOGIOR (UNFASL-NEXT-NIBBLE) (LSH (UNFASL-NEXT-NIBBLE) 20)))
	(SETQ UNBOXED-COUNT (1- UNBOXED-COUNT))
	(GO L3)
  L4	(RETURN (ENTER-UNFASL-TABLE 'FEF))
))

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

(DEFUN UNFASL-OP-EVAL1 ()
  (ENTER-UNFASL-TABLE (UNFASL-NEXT-VALUE)))

(DEFUN UNFASL-OP-FILE-PROPERTY-LIST ()
  (UNFASL-NEXT-VALUE))

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

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

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

(DEFUN UNFASL-OP-STOREIN-ARRAY-LEADER NIL
  (PRINC '| ARRAY|) (UNFASL-OP-INDEX) 
  (PRINC '| SUBSCR|) (UNFASL-OP-INDEX)
  (PRINC '| VALUE|) (UNFASL-OP-INDEX))

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

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

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

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

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

(DEFUN UNFASL-OP-SOAK NIL 
  (PROG (COUNT)
	(SETQ COUNT (UNFASL-NEXT-NIBBLE-PR))
 L	(COND ((= 0 COUNT) (RETURN (UNFASL-GROUP))))
	(UNFASL-NEXT-VALUE)
	(SETQ COUNT (1- COUNT))
	(GO L)))

(DEFUN UNFASL-OP-FUNCTION-HEADER NIL		;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 NIL
	0)

(DEFUN UNFASL-OP-SET-PARAMETER NIL 
  (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 NIL
  (PROG (ARRAYP NUM)
	(SETQ ARRAYP (UNFASL-NEXT-VALUE))
	(SETQ NUM (UNFASL-NEXT-VALUE))	;# OF VALS TO INITIALIZE
	(DO IDX 0 (1+ IDX) (= IDX NUM)
	  (UNFASL-NEXT-VALUE))
	(RETURN 0)))

(DEFUN UNFASL-OP-INITIALIZE-NUMERIC-ARRAY NIL
  (PROG (ARRAYP NUM)
	(SETQ ARRAYP (UNFASL-NEXT-VALUE))
	(SETQ NUM (UNFASL-NEXT-VALUE))	;# OF VALS TO INITIALIZE
	(SETQ FASL-GROUP-LENGTH NUM)
	(DO IDX 0 (1+ IDX) (= IDX NUM)
	  (UNFASL-NEXT-NIBBLE))
	(RETURN 0)))

(DEFUN UNFASL-OP-MAKE-MICRO-CODE-ENTRY NIL 
  (PROG NIL 
	(PRINC '| FCTN|) (UNFASL-NEXT-VALUE)
	(PRINC '| ARGDESC|) (UNFASL-NEXT-VALUE)
	(PRINC '| ENTRY-INDEX|) (UNFASL-NEXT-NIBBLE-PR)
	(COND ((NOT FASL-GROUP-FLAG) (PRINC '| -> FUNCTION-CELL|)))
	(RETURN (ENTER-UNFASL-TABLE 0))))

(DEFUN UNFASL-OP-SAVE-ENTRY-POINT NIL 
  (PROG NIL 
	(RETURN (ENTER-UNFASL-TABLE 0))))

;UNFASL-OP-MICRO-CODE-SYMBOL  WINS AS MUCH AS IT CAN ANYWAY

(DEFUN UNFASL-OP-MICRO-TO-MICRO-LINK NIL 
	(UNFASL-NEXT-VALUE)
	0)

(DEFUN UNFASL-OP-QUOTE-POINTER NIL 
	(UNFASL-NEXT-VALUE)
	0)

(DEFUN UNFASL-OP-S-V-CELL NIL 
	(UNFASL-NEXT-VALUE)
	0)

(DEFUN UNFASL-OP-FUNCELL NIL 
	(UNFASL-NEXT-VALUE)
	0)

(DEFUN UNFASL-OP-CONST-PAGE NIL 
	(UNFASL-NEXT-NIBBLE-PR)
	0)


(DEFUN INITIALIZE-UNFASL-ENVIRONMENT NIL
  (SETQ UNFASL-GROUP-DISPATCH (MAKE-ARRAY NIL 'ART-Q
					  (SETQ UNFASL-GROUP-DISPATCH-SIZE
						(LENGTH FASL-OPS))))
  ;(FILLARRAY UNFASL-GROUP-DISPATCH FASL-OPS)
  (DO ((I 0 (1+ I))
       (SI (PKG-FIND-PACKAGE "SI"))
       (L FASL-OPS (CDR L)))
      ((NULL L))
    (AS-1 (LET ((FCTN (INTERN (STRING-APPEND "UN" (CAR L)) SI)))
	    (COND ((FBOUNDP FCTN) FCTN)
		  (T 'UNFASL-OP-ERR)))
	  UNFASL-GROUP-DISPATCH 
	  I)))