LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030416. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "UNFASL" :DIRECTORY ("REL3-SOURCE" "COMPILER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758303031. :AUTHOR "REL3" :LENGTH-IN-BYTES 21420. :LENGTH-IN-BLOCKS 21. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ;;; -*- 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 (b)(3)(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) 1980 Massachusetts Institute of Technology ;; Copyright (c) 1984,1987 Texas Instruments Incorporated.  All Rights Reserved.;;;; 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/5/86  JK  - Added support for IEEE floating point numbers and new floating point data types.(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 () (FUNCALL 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 (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 :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%"      (FUNCALL 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%"    (FUNCALL 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)  (DO ((I UNFASL-INDENTATION (1- I)))      ((NOT (> I 0)) NIL)    (WRITE-CHAR #\SPACE))) (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))(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 () "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 ()  (PRINC '| NOT HANDLED|)  (COND    ((NOT (ZEROP FASL-GROUP-LENGTH))     (PRINC '| - 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)))    (FORMAT T " {~?}" (IF (STRINGP FASL-TABLE-ENTRY) "~S" "~A") `(,FASL-TABLE-ENTRY))    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));;  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 (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)))    (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 (FUNCALL S :STRING-OUT (UNFASL-NEXT-VALUE))  UNLESS (= I 1) DO (FUNCALL 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      #+Elroy      (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)))))      #-Elroy      (LET ((ANS (%MAKE-POINTER DTP-SMALL-FLONUM(%LOGDPB (UNFASL-NEXT-NIBBLE) (BYTE 10 20) (UNFASL-NEXT-NIBBLE)))))(FORMAT T "  ~S" ANS)(ENTER-UNFASL-TABLE (DONT-OPTIMIZE (COPY-FLOAT ANS))))      #+Elroy;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 overflowEXPONENT (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))))      #-Elroy      (LET ((ANS (FLOAT 0)) TEM)(%P-DPB-OFFSET (UNFASL-NEXT-NIBBLE) (BYTE 13 10) ANS 0)(SETQ TEM (UNFASL-NEXT-NIBBLE))(%P-DPB-OFFSET (LDB (BYTE 10 10) TEM) (BYTE 10 0) ANS 0)(%P-DPB-OFFSET (%LOGDPB TEM (BYTE 10 20) (UNFASL-NEXT-NIBBLE)) (BYTE 30 0) 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 ()  #+Elroy  (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)))))))  #-Elroy  (PROGN    (FORMAT T ": IEEE floating point numbers not handled in VM1 (releases prior to 3.0).")    (UNFASL-TERPRI)    (UNFASL-OP-ERR)))(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 (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 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))))))(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))   (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)      (PRINT-IN-MIXED-FORMAT LST FASL-GROUP-FLAG)      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))))  ;; Generate a FIXNUM (or BIGNUM) value.(DEFUN UNFASL-OP-CHARACTER ()  (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) (FORMAT T "~:C" 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|)))   (unfasl-terpri)   (format t "ARRAY")   (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 (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))) (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)))(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 ()  (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 0DO (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) 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-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)    (LET ((ITEM `(EVAL ,FORM)))      (ENTER-UNFASL-TABLE(IF (CONSP FORM)    (PROG1 ITEM   (PRINT-IN-MIXED-FORMAT ITEM  (CDR (LAST FORM))))    (PRIN1 ITEM))))))(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))    (SETF (AREF UNFASL-GROUP-DISPATCH I) (IF (FBOUNDP TEM)     TEM     'UNFASL-OP-ERR)))) TION) :TEST #'EQ)    (EQUAL (SECOND ARG) (SECOND AP))) (RETURN-FROM MATCH))