LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030347. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "LAP" :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 2758302569. :AUTHOR "REL3" :LENGTH-IN-BYTES 81247. :LENGTH-IN-BLOCKS 80. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               ;;;;     -*- Mode:Common-lisp; Package:COMPILER2; Base:10. -*-;;;; LAP FOR FEFS;;;;;;                           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.;;;;;   *-----------------------------------------------------------*;;;;   |           --  TI Explorer Lisp Compiler  --               |;;;;   |  This file defines the QLAPP routine, which creates FEFs  |;;;;   |  from the code array created by pass 2.   |;;;;   *-----------------------------------------------------------*;;; Feb. 1984 - Version 98 from MIT via LMI.;;; 12/06/84 DNG - Support new FEF header format for Explorer;;;;                clean up a couple of error messages.;;; 12/13/84 DNG - Fix LAP-HEADER to use FASL-OP-FEF for Explorer.;;;  4/26/85 DNG - Declare FASL-OP-FEF special.;;;  6/27/85 DNG - Some minor modifications to make compiler faster.;;;  7/10/85 DNG - Began making modifications for release 3.;;;  8/21/85 DNG - ;;;  9/30/85 DNG - New FEF header format for release 3.;;; 10/07/86 DNG - Minor adjustments to compile without warnings under VM2.;;; 12/16/86 DNG - Update LAP-MODIFY-LASTQ for TGC.;;; 12/24/86 DNG - Improve message for too many constants.;;;  1/15/87 DNG - Change order of arguments for %P-STORE-DATA-TYPE-OFFSET etc.;;;  1/22/87 DNG - Fix QLAPP for :INTERNAL functions in macros.;;Available info on variables in function being lapped:;ALLVARS is the list, reversed from what it was in the compiler,; so that arguments come first, in order, and so that the order of appearance; of the bound special variables matches their order in SPECVARS; (except that a special may appear more than once in ALLVARS).;SPECVARS is the list of names of all special variables, bound or free.; These are in the order that their value cell pointers should go in the fef.; Vars bound at function entry must come first, and duplicates among them; must not be eliminated.  SPECVARS-BIND-COUNT is the number of them; which are bound at function entry.;FREEVARS is the list of all free variables.;At the moment, to avoid having to change the compiler at the same time,;  SPECVARS is generated by LAP out of ALLVARS and FREEVARS.;This is the interface from the compiler to LAP:;The format of ALLVARS is described in LISPM;QCDEFS.;FREEVARS is just a list of all free variables.;ALLVARS and FREEVARS are contained in the first element of a list;which contains the full description of the code.;The list describing the code, called QCMP-OUTPUT in the compiler,;contains these things:;;(MFEF functionname specialflag allvars freevars &OPTIONAL name-to-put-in-function);(CONSTRUCT-MACRO)              ;This, if present, means that lap should cons MACRO;                               ;onto the fef before outputting the definition.;(QTAG S-V-BASE)                ;This defines a symbol usable for referring to value cell ptrs;(S-V-BLOCK)                    ;This outputs the value cell pointers.;(SELF-FLAVOR flavor-name)      ;This, if present, outputs the self flavor name.;(QTAG DESC-LIST-ORG)           ;This defines a symbol pointing at the start of the ADL.;(A-D-L)                        ;This outputs the ADL.;(A-D-L)                        ;For historic reasons, there can be extra of these.;...                            ;They do nothing.;(ENDLIST)                      ;This puts CDR-NIL in the last Q of the ADL.;                               ;It is not actually necessary, now.;(PARAM LLOCBLOCK n)            ;This specifies the length of the function's local block;(QTAG QUOTE-BASE)              ;This defines a symbol usable for referring to quoted constants                                ;pointers to which live in the FEF starting here.;Lap pass 1 inserts things to define the quoted constants in the list here.;(ENDLIST)                      ;Put CDR-NIL in last constant pointer.;(BREAKOFFS ('(:INTERNAL fnname 0) '(:INTERNAL fnname 1) ...))                                ;List quoted constants that ought to be                                ;replaced by pointers to FEFs somehow.                                ;On pass 2, each '(:internal ...) is rplaca'd                                ;with the fef index of where the internal fef ptr will go.                                ;The list structure is shared with the debugging-info                                ;entry INTERNAL-FEF-OFFSETS; this is how that entry                                ;gets the data it is supposed to have.;(VARIABLES-USED-IN-LEXICAL-CLOSURES coden ... code1 code0)                                ;Codes describing variables of this function                                ;that are used in lexical closures of the function.                                ;A code is either the number of an argument                                ;or the sign bit plus an index in the local block.                                ;The microcode requires the codes to be in reverse order!;(DEBUG-INFO debugging info)    ;Optionally, specify the debugging information ALIST.;                               ;The defined entry type now is (ARGLIST <arglist>), as in;                               ;(DEBUG-INFO (ARGLIST (X &OPTIONAL Y)));                               ;Sets %%FEFHI-MS-DEBUG-INFO-PRESENT bit in the fef misc wd.;PROGSA                         ;This identifies the start of the unboxed part of the FEF.;macro instructions follow.;(PARAM MXPDL n)                ;This specifies the maximum stack frame size this function needs.;A macro instruction has one of these formats:;(BRANCH condition state pop-flag tag);  condition is ALWAYS, NULL or ATOM.;  state is which way the branch should go.  For ALWAYS, state should be NIL.;  NULL T means branch if NIL, whereas NULL NIL means branch if not NIL.;  pop-flag is T to mean pop one object off the pdl if the branch is not taken.;(MOVE destination source);  destination is D-IGNORE (or 0), D-PDL, D-INDS, D-NEXT, D-LAST, D-NEXT-LIST, D-RETURN.;  source is an operand address.;  This format applies to all 2-operand instructions.;(+ source);  This format applies to all non-destination instructions.;(MISC destination name);  name is the name of the miscellaneous instruction, such as CADDDR.;A source operand has one of these formats:;(LOCBLOCK n)   address n relative to the local block on the stack.;(ARG n)        address n relative to the argument block on the stack.;PDL-POP        pop the stack and use the value popped.;EXTEND         next instruction is an EXTENDED-ADDRESS and specifies our source.;(SPECIAL sym)  the value cell of sym, actually relative to the;               invisible pointer stored in the FEF.;(SPECIAL n)    similar, except that the index in the list of special variables;               is specified instead of the symbol name.  This number is the;               offset of the invisible pointer in the FEF with respect to;               the first such invisible pointer.;(QUOTE-VECTOR <s-exp>)   s-exp  placed in quote vector of FEF, and operand ref's it.;               s-exp should have one of these forms:;                 (QUOTE object)            The object is stored in the FEF;                 (FUNCTION symbol)         A fwding ptr to the fn cell is stored;                 (BREAKOFF-FUNCTION name)  The name is stored,;                                           but the offset of this q is put into;                                           the INTERNAL-FEF-OFFSETS debugging info item.;                                           When (:INTERNAL thisfn n) is defined,;                                           its definition replaces the name.;                 (SELF-REF flavor varname) Stores a DTP-SELF-REF-POINTER;                                           to that variable in that flavor.;It is the compiler's responsibility to generate an EXTENDED-ADDRESS;when the parameter n is too big to fit the available field in a simple source address.;The maximum is 77 for LOCBLOCK and ARG sources.;An EXTENDED-ADDRESS is treated as an instruction by lap.;It follows an instruction with EXTEND as a source address.;It looks like;(EXTENDED-ADDRESS dest source).;The dest must match that or the previous instruction, if that has a dest.;The source looks like an ordinary source but indices of up to 10. bits are allowed.(PROCLAIM '(SPECIAL ADR SYMPTR SYMTAB QLP-A-D-L-DONE ADL-LENGTH A-D-L-NEEDED-P SPECVARS     SPECVARS-BIND-COUNT LOW-HALF-Q BREAKOFF-FUNCTION-OFFSETS ;N-SVS     MAX-ARGS MIN-ARGS SM-ARGS-NOT-EVALD REST-ARG HAIRY-INIT-FLAG S-V-BITMAP-ACTIVE     DATA-TYPE-CHECKING-FLAG LENGTH-OF-PROG PROG-ORG FCTN-NAME LAP-OUTPUT-AREA BIND-CONS-AREA     FEF-NAME-PRESENT FEF-SV-BIT FEF-DES-DT FEF-DES-EVALAGE FEF-ARG-SYNTAX FEF-INIT-OPTION     LAP-MODE FASD-GROUP-LENGTH %FEFH-NO-ADL %FEFH-FAST-ARG %FEFH-SV-BIND LAP-ADL-NOSTORE     %FEFHI-SVM-ACTIVE LAP-NO-ADL LAP-LASTQ-MODIFIER FASL-OP-FRAME FASL-OP-STOREIN-FUNCTION-CELL     FASL-OP-FEF LAP-FASD-NIBBLE-COUNT QUOTE-LIST QUOTE-COUNT CONSTANTS-PAGE     QFEFHI-FAST-ARG-OPT-OPERATIVE LAP-OUTPUT-BLOCK LAP-OUTPUT-BLOCK-LENGTH LAP-STORE-POINTER     LAP-MACRO-FLAG %HEADER-TYPE-FEF %%HEADER-TYPE-FIELD %FEF-NAME-PRESENT     DISPATCH-LIST DISPATCH-OFFSET-LIST)) (DEFSTRUCT (FEF-HEADER     ; data for FEF header; not necessarily in final order.     (:COPIER NIL)     (:PREDICATE NIL)     (:TYPE VECTOR))  HEADER       ; header word at the beginning of the FEF  LENGTH       ; length of the FEF  DEBUG-INFO   ; debugging information list  LONG-ARGS    ; long-args word -- see %FEF-LONG-ARGS-WORD-FIELDS  LOCAL-LENGTH ; number of local variables  SELF-FLAVOR  ; flavor of method ) (DEFVAR QLP-FEF-HEADER)  ; information for FEF header -- an instance of FEF-HEADER(DEFVAR BREAKOFF-FUNCTION-OFFSETS) ;Alist of (offset-in-function . internal-function-number);accumulated about breakoff-functions as the pointers to them are seen,;and then stored into the debugging info :internal-fef-offsets item.(DEFVAR QUOTE-LIST-LENGTH) ;;Length of the quote-vector, reflecting the;;actual number of constants in the vector(DEFVAR QB);;This variable is used to record the fef offset of the quote-base(DEFVAR SHORT-FEF-MAX-QUOTE-LENGTH) ;;The maximum number of words available ;;for constants in the quote vector.  This;;is calculated after the length of the fef header,;;the number of optional header words, and the number;;of special variables are known.(DEFPARAMETER HEADER-TYPE-FEF 524288) ;LAP-MODE may be QFASL, QFASL-NO-FDEFINE, REL, COMPILE-TO-CORE, DISASSEMBLE, or :JUST-COUNT.;FOR QFASL-NO-FDEFINE, RETURNS FASL-TABLE INDEX OF FEF(DEFUN QLAPP (FCTN LAP-MODE)  ;;  8/26/85 - Add binding of LOCAL-BLOCK-LENGTH.  [SPR 558]  ;;  9/30/85 - Include LOCAL-BLOCK-LENGTH with new structure QLP-FEF-HEADER.  ;; 12/19/85 - Move setting of ALLVARS, FREEVARS, and SPECVARS to QLP1.  ;;  1/05/86 - CLM When lap-mode is disassemble, LAP-OUTPUT-BLOCK will be called.  ;;  3/05/86 - CLM Modify for FEF offsets greater than 191.  ;;  7/29/86 DNG - When LAP-MODE is COMPILE-TO-CORE and the name is NIL, return the FEF.  ;;  8/04/86 DNG - In COMPILE-TO-CORE mode, if the FDEFINE fails, then don't  ;;try to define its :INTERNAL functions either.  [SPR 1730 and 2632]  ;;  9/24/86 DNG - Fix definition of :INTERNAL functions in encapsulations. [SPR 3 and 1167]  ;;  1/22/87 DNG - Fix installation of :INTERNAL functions in parent that is a macro.  (PROG (SYMTAB ADR NBR SYMPTR QLP-A-D-L-DONE SPECVARS SPECVARS-BIND-COUNT LOW-HALF-Q MAX-ARGS MIN-ARGS SM-ARGS-NOT-EVALD REST-ARG HAIRY-INIT-FLAG DATA-TYPE-CHECKING-FLAG LENGTH-OF-PROG PROG-ORG FCTN-NAME LAP-OUTPUT-AREA TEM LAP-NO-ADL LAP-LASTQ-MODIFIER ADL-LENGTH A-D-L-NEEDED-P QUOTE-LIST QUOTE-COUNT S-V-BITMAP-ACTIVE ALLVARS FREEVARS LAP-OUTPUT-BLOCK LAP-OUTPUT-BLOCK-LENGTH LAP-STORE-POINTER LAP-MACRO-FLAG BREAKOFF-FUNCTION-OFFSETS DISPATCH-LIST DISPATCH-OFFSET-LIST QUOTE-LIST-LENGTH SHORT-FEF-MAX-QUOTE-LENGTH (QLP-FEF-HEADER (MAKE-FEF-HEADER)))(SETQ LAP-OUTPUT-AREA 'MACRO-COMPILED-PROGRAM)(SETQ MIN-ARGS 0)(SETQ MAX-ARGS 0)(SETQ SYMTAB (LIST NIL))(SETQ QUOTE-COUNT 0)(SETQ QUOTE-LIST-LENGTH 0)(SETQ ADR 0)(QLAP-PASS1 FCTN)(RPLACD SYMTAB (NREVERSE (CDR SYMTAB)))(SETQ QUOTE-LIST (NREVERSE QUOTE-LIST));JUST SO FIRST ONES WILL BE FIRST(SETQ TEM (LAP-SYMTAB-PLACE 'QUOTE-BASE))(LAP-SYMTAB-RELOC (CADDAR TEM);VALUE OF QUOTE-BASE  (* 2 (LENGTH QUOTE-LIST)) (CDR TEM))(SETQ NBR (QLAP-ADJUST-SYMTAB));NUMBER BRANCHES TAKING EXTRA WD(SETQ LENGTH-OF-PROG (+ ADR (+ NBR (* 2 (LENGTH QUOTE-LIST)))))(SETQ SYMPTR SYMTAB)(SETQ QUOTE-COUNT 0)(SETQ ADR 0)(SETQ ADL-LENGTH (OR QLP-A-D-L-DONE 0))(SETQ QLP-A-D-L-DONE NIL)(QLAP-PASS2 FCTN);Don't call FASD with the temporary area in effect(LET-IF QC-FILE-IN-PROGRESS ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))  (WHEN (OR LOW-HALF-Q    (AND (OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (NOT (= 0 (LOGAND ADR 1)))))    (LAP-OUTPUT-WORD 0 #+compiler:debug T))  #+compiler:debug  (LET (OLD-FEF-LEN NEW-FEF-LEN)    (WHEN (AND (NOT '#.SI:FILE-IN-COLD-LOAD)       (SETQ OLD-FEF-LEN (FEF-LEN FCTN-NAME))       (SETQ NEW-FEF-LEN LAP-OUTPUT-BLOCK-LENGTH)       (STRING-EQUAL USER-ID "GRAY")); no one else is interested      ;; check that not generating worse code than previous version      (COND ((< OLD-FEF-LEN NEW-FEF-LEN)     (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA));Stream may cons       (FORMAT T "~%Warning: the new FEF for ~S is ~D words longer than the old one."       FCTN-NAME (- NEW-FEF-LEN OLD-FEF-LEN))))    ((AND (> OLD-FEF-LEN NEW-FEF-LEN) COMPILER-VERBOSE)     (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA));Stream may cons       (FORMAT T "~D words shorter" (- OLD-FEF-LEN NEW-FEF-LEN)))))))  (COND ((EQ LAP-MODE 'QFASL) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL))) (UNLESS (= 0 LAP-FASD-NIBBLE-COUNT)   (BARF LAP-FASD-NIBBLE-COUNT 'LAP-FASD-NIBBLE-COUNT 'BARF)) ;; If this function is supposed to be a macro, ;; dump directions to cons MACRO onto the fef. (WHEN LAP-MACRO-FLAG   (FASD-START-GROUP T 1 FASL-OP-LIST)   (FASD-NIBBLE 2)   (FASD-CONSTANT 'MACRO)   (FASD-START-GROUP NIL 1 FASL-OP-INDEX)   (FASD-NIBBLE TEM)   (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL)))) (FASD-STOREIN-FUNCTION-CELL FCTN-NAME TEM) (FASD-FUNCTION-END) (RETURN NIL))((EQ LAP-MODE 'QFASL-NO-FDEFINE) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL))) (UNLESS (= 0 LAP-FASD-NIBBLE-COUNT)   (BARF LAP-FASD-NIBBLE-COUNT 'LAP-FASD-NIBBLE-COUNT 'BARF)) ;; If this function is supposed to be a macro, ;; dump directions to cons MACRO onto the fef. (WHEN LAP-MACRO-FLAG   (FASD-START-GROUP T 1 FASL-OP-LIST)   (FASD-NIBBLE 2)   (FASD-CONSTANT 'MACRO)   (FASD-START-GROUP NIL 1 FASL-OP-INDEX)   (FASD-NIBBLE TEM)   (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL)))) (RETURN TEM))((EQ LAP-MODE 'COMPILE-TO-CORE) (LET (( DEF (IF LAP-MACRO-FLAG (CONS-IN-AREA 'MACRO LAP-OUTPUT-BLOCK BACKGROUND-CONS-AREA)       LAP-OUTPUT-BLOCK) )       PARENT)   (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'FEF) DEF)   (IF (NULL FCTN-NAME)       (RETURN DEF)     (UNLESS (IF (AND (EQ (CAR-SAFE FCTN-NAME) ':INTERNAL)      (SETQ PARENT    (COMPILAND-PARENT *CURRENT-COMPILAND*))      (DEBUG-ASSERT (EQUAL (SECOND FCTN-NAME)   (COMPILAND-FUNCTION-SPEC PARENT)))) ;; Refer directly to the parent FEF instead of its ;; name so that if we are compiling an encapsulation, ;; we don't try to store into the function being ;; encapsulated.  [SPR 3 and 1167] (LET ((PARENT-FEF (GETF (COMPILAND-PLIST PARENT) 'FEF)))   (WHEN (EQ (CAR-SAFE PARENT-FEF) 'MACRO)     (SETQ PARENT-FEF (CDR PARENT-FEF)))   (FDEFINE `(:INTERNAL ,PARENT-FEF . ,(CDDR FCTN-NAME))    DEF NIL))       ;; Else normal definition of unencapsulated function.       (FDEFINE FCTN-NAME DEF T))       ;; If the function definition fails, then don't try to define       ;; its :INTERNAL functions either.  [SPR 1730 and 2632]       (SETQ COMPILER-QUEUE NIL)       (WHEN (< *RETURN-STATUS* FATAL) (SETQ *RETURN-STATUS* FATAL))))))#+compiler:debug((EQ LAP-MODE :JUST-COUNT))#+compiler:debug((EQ LAP-MODE 'DISASSEMBLE) (LOCALLY (DECLARE (SPECIAL *DISASSEMBLE-OPTIONS*))   (APPLY #'DISASSEMBLE LAP-OUTPUT-BLOCK *DISASSEMBLE-OPTIONS*)))#+compiler:debug((EQ LAP-MODE :DUMP) (DUMP-FEF LAP-OUTPUT-BLOCK))(T (FERROR NIL "~S is a bad lap mode" LAP-MODE)))))) #+compiler:debug(DEFUN FEF-LEN (F)  (COND ((EQ (%DATA-TYPE F) DTP-FEF-POINTER) (FEF-LENGTH F))((AND (VALIDATE-FUNCTION-SPEC F)      (OR (NOT (EQ (CAR-SAFE F) :INTERNAL))  (AND (NEQ (CAR-SAFE (SECOND F)) :INTERNAL)       (TYPEP (SI:FDEFINITION-SAFE (SECOND F)) 'COMPILED-FUNCTION)))      (NOT (EQ (CAR-SAFE F) :SELECT-METHOD)) ; FDEFINEDP doesn't work right for these      (FDEFINEDP F)) (FEF-LEN (FDEFINITION F)))(T NIL))) (DEFUN QLAP-PASS1 (PNTR)  (PROG ()    P1    (WHEN (NULL PNTR)      (RETURN NIL))   ;PASS 1    (QLP1 (CAR PNTR))    (SETQ PNTR (CDR PNTR))    (GO P1)))                                                                                                                 (DEFUN QLAP-ADJUST-SYMTAB () ;;  1/30/86 CLM - Modified for LONG-PUSHJ long branches.  (PROG (T1 NBR)    (SETQ NBR 0)    (SETQ T1 SYMTAB)    P2A    (COND      ((NULL (CDR T1)) (RETURN NBR))     ;FINALIZE SYM DEFS      ((MEMBER (CADADR T1) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ) (GO P2B))      ((EQ (CADADR T1) 'TDEF) (GO P2C)))    P2A1    (SETQ T1 (CDR T1))    (GO P2A)    P2B    (QLRLC (CADR T1) NBR)                ;THIS IS ONLY ADR AT WHICH TO HACK THIS.    (SETQ NBR (1+ NBR))                  ;DOESNT AFFECT VALUE OF EVENTUAL BRANCH    (GO P2A1)    P2C    (QLRLC (CADR T1) NBR)    (GO P2A1))) (DEFUN QLAP-PASS2 (PNTR)  (PROG ((%INHIBIT-READ-ONLY T))         ;For storing into the FEF.    P3A    (COND ((NULL PNTR) (RETURN NIL))         ;PASS 2  ((QLP2-Q (CAR PNTR)) (GO P3C)));XFER ON ADVANCE TO UNBOXED AREA    (SETQ PNTR (CDR PNTR))    (GO P3A)    P3C    (WHEN LAP-LASTQ-MODIFIER      (LAP-MODIFY-LASTQ LAP-LASTQ-MODIFIER))    (DO ((P PNTR (CDR P)))((NULL P))      (QLP2-U (CAR P))))) (DEFUN LAP-D-OUT (S-EXP)  (LAP-Q-OUT NIL NIL NIL S-EXP)) ;On pass 2, output a Q, specified by components.;S-EXP is the contents of the Q.;INVZ-P is non-NIL to modify the data type of the Q:;  QZEVCP for an external value cell pointer, or;  QZLOC for a locative.;  QZSRP for an instance var pointer.;OFFSET is added to the Q.  It is useful for making pointers to;  value cells or function cells of symbols.(DEFUN LAP-Q-OUT (IGNORE INVZ-P OFFSET S-EXP)  ;;  5/08/86 DNG - Give second arg of T to COPY-OBJECT-TREE so copying will  ;;stop on sub-object that is not in the temporary area.  (WHEN LAP-LASTQ-MODIFIER    (LAP-MODIFY-LASTQ LAP-LASTQ-MODIFIER))  (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) ;; Don't call FASD with the temporary area in effect (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))   (FASD-CONSTANT S-EXP)))((MEMBER LAP-MODE '(COMPILE-TO-CORE     #+compiler:debug DISASSEMBLE     #+compiler:debug :DUMP) :TEST #'EQ) #+compiler:debug (WHEN (>= LAP-STORE-POINTER LAP-OUTPUT-BLOCK-LENGTH)   (BARF S-EXP 'DOESNT-FIT-IN-ALLOCATED-BLOCK 'BARF)) ;QC-TRANSLATE-FUNCTION may have consed some lists which end up here, ;such as the function's debug info, in the temporary area even though ;QC-FILE-LOAD-FLAG is set, so copy them out. (WHEN (AND #+compiler:debug    (NEQ LAP-MODE 'DISASSEMBLE)    (EQ (%AREA-NUMBER S-EXP) QCOMPILE-TEMPORARY-AREA))   (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))     (SETQ S-EXP (SI:COPY-OBJECT-TREE S-EXP T)))) (%P-STORE-CONTENTS-OFFSET S-EXP LAP-OUTPUT-BLOCK LAP-STORE-POINTER) (SETQ LAP-STORE-POINTER (1+ LAP-STORE-POINTER)))#+compiler:debug((EQ LAP-MODE :JUST-COUNT) (SETQ LAP-STORE-POINTER (1+ LAP-STORE-POINTER))))  (SETQ LAP-LASTQ-MODIFIER(+ 192                        ;NXTCDR   (COND ((NULL INVZ-P) 0) ((EQ INVZ-P 'QZEVCP) 16) ((EQ INVZ-P 'QZLOC) 256) ((EQ INVZ-P 'QZSRP) 512) (T (BARF INVZ-P 'LAP-Q-OUT 'BARF)))   (IF OFFSET OFFSET 0)))) #+Elroy(DEFUN LAP-MODIFY-LASTQ (CODE)  ;; 12/16/86 DNG - Update for TGC.  ;;  1/15/87 DNG - Rel3 has different arg order for %P-STORE-DATA-TYPE-OFFSET etc.  (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (LAP-FASD-NIBBLE CODE))#+compiler:debug((EQ LAP-MODE :JUST-COUNT))(T (LET ((OFFSET (LOGAND CODE 15))       (IDX (1- LAP-STORE-POINTER)))   (SI:%P-STORE-CDR-CODE-OFFSET (LSH CODE -6) LAP-OUTPUT-BLOCK IDX)   (UNLESS (ZEROP OFFSET)     (%P-STORE-CONTENTS-OFFSET       (%MAKE-POINTER-OFFSET DTP-LOCATIVE (%P-CONTENTS-OFFSET LAP-OUTPUT-BLOCK IDX) OFFSET)       LAP-OUTPUT-BLOCK IDX))   (COND ((LOGTEST 16 CODE)  (SI:%P-STORE-DATA-TYPE-OFFSET DTP-EXTERNAL-VALUE-CELL-POINTERLAP-OUTPUT-BLOCKIDX)) ((LOGTEST 256 CODE)  (SI:%P-STORE-DATA-TYPE-OFFSET DTP-LOCATIVE LAP-OUTPUT-BLOCK IDX)) ((LOGTEST 512 CODE)  (SI:%P-STORE-DATA-TYPE-OFFSET DTP-SELF-REF-POINTER LAP-OUTPUT-BLOCK IDX))    )))))#-Elroy(DEFUN LAP-MODIFY-LASTQ (CODE)  ;; 12/16/86 DNG - Update for TGC (release 2.1 version).  (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (LAP-FASD-NIBBLE CODE))#+compiler:debug((EQ LAP-MODE :JUST-COUNT))(T (LET ((OFFSET (LOGAND CODE 15))       (IDX (1- LAP-STORE-POINTER)))   (SI:%P-STORE-CDR-CODE-OFFSET LAP-OUTPUT-BLOCK IDX (LSH CODE -6))   (UNLESS (ZEROP OFFSET)     (%P-STORE-CONTENTS-OFFSET       (%MAKE-POINTER-OFFSET DTP-LOCATIVE (%P-CONTENTS-OFFSET LAP-OUTPUT-BLOCK IDX) OFFSET)       LAP-OUTPUT-BLOCK IDX))   (COND ((LOGTEST 16 CODE)  (SI:%P-STORE-DATA-TYPE-OFFSET LAP-OUTPUT-BLOCKIDXDTP-EXTERNAL-VALUE-CELL-POINTER)) ((LOGTEST 256 CODE)  (SI:%P-STORE-DATA-TYPE-OFFSET LAP-OUTPUT-BLOCK IDX DTP-LOCATIVE)) ((LOGTEST 512 CODE)  (SI:%P-STORE-DATA-TYPE-OFFSET LAP-OUTPUT-BLOCK IDX DTP-SELF-REF-POINTER))    ))))) (DEFUN LAP-OUTPUT-WORD #-compiler:debug (WD)                       #+compiler:debug (wd &OPTIONAL NOT-INSTRUCTION) ;; 09/07/85 DNG - Fix to not count non-instructions such as the second ;;                half of a long branch. ;;  1/05/86 CLM - Commented out the code for lap-mode = disassemble.  This ;;                is now done in LAP-OUTPUT-BLOCK.  (IF (OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE))    (LAP-FASD-NIBBLE WD)    (PROGN      #+compiler:debug      (UNLESS NOT-INSTRUCTION(WHEN (EQ LAP-MODE :JUST-COUNT) ;; Just count how many times each instruction is used.  (UNLESS (= WD 0)                   ; 0 is used for filler at end    (LET ((INSTR-USE-ARRAY (GET 'INST-USE-ARRAY TARGET-PROCESSOR)))      (UNLESS (NULL INSTR-USE-ARRAY)(INCF (AREF INSTR-USE-ARRAY WD))))));;this is now done by lap-output-block#|(WHEN (EQ LAP-MODE 'DISASSEMBLE)  (LET (( PC (* LAP-STORE-POINTER 2) ))    (UNLESS (NULL LOW-HALF-Q)      (INCF PC 1))    (FORMAT T "~&~4@A " PC)    (DISASSEMBLE-ONE-INSTRUCTION WD NIL LAP-OUTPUT-BLOCK PC) ) )|#)      (IF (NULL LOW-HALF-Q)(SETQ LOW-HALF-Q WD)(PROGN  #+compiler:debug  (WHEN (>= LAP-STORE-POINTER LAP-OUTPUT-BLOCK-LENGTH)    (BARF WD 'DOESNT-FIT-IN-ALLOCATED-BLOCK 'BARF))  (OR #+compiler:debug (NULL LAP-OUTPUT-BLOCK)     (LET ((%INHIBIT-READ-ONLY T))       (%P-DPB-OFFSET WD %%Q-HIGH-HALF LAP-OUTPUT-BLOCK LAP-STORE-POINTER)       (%P-DPB-OFFSET LOW-HALF-Q %%Q-LOW-HALF LAP-OUTPUT-BLOCK LAP-STORE-POINTER)))  (SETQ LOW-HALF-Q NIL)  (SETQ LAP-STORE-POINTER (1+ LAP-STORE-POINTER))))))) (DEFUN LAP-STORE-NXTNIL-CDR-CODE ()  (SETQ LAP-LASTQ-MODIFIER (+ 128 (BOOLE 4 LAP-LASTQ-MODIFIER 192)))) (DEFUN LAP-HEADER (Q-LENGTH UNBOXED-LENGTH) ;;  3/05/86 CLM - Can now handle FEF offsets greater than 191 but less than ;;                512. ;;  5/08/86 DNG - Remove obsolete %HEADER-TYPE-FEF. ;; 12/24/86 DNG - Improve message for too many constants.  (WHEN (> Q-LENGTH 512)    (WARN 'Q-LENGTH :IMPLEMENTATION-LIMIT     "This function is too big!   The total number of distinct special variables,functions, and constants referenced is ~D, which is more than the maximumof 512 currently allowed in one FEF." Q-LENGTH))    (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) ;Don't call FASD with the temporary area in effect (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))   (WHEN (EQ LAP-MODE 'QFASL)     (FASD-FUNCTION-HEADER FCTN-NAME))   (FASD-START-GROUP NIL 3 (IF (COMPILING-FOR-EXPLORER-P)       ;; new FEF header for Explorer       FASL-OP-FEF     ;; else old Cadr and Lambda format     FASL-OP-FRAME))   (FASD-NIBBLE Q-LENGTH)   (FASD-NIBBLE UNBOXED-LENGTH)   (SETQ LAP-FASD-NIBBLE-COUNT (+ Q-LENGTH (* 2 UNBOXED-LENGTH)))   (FASD-NIBBLE LAP-FASD-NIBBLE-COUNT)   (SETQ FASD-GROUP-LENGTH LAP-FASD-NIBBLE-COUNT)))#+compiler:debug((EQ LAP-MODE :JUST-COUNT) (SETQ LAP-OUTPUT-BLOCK-LENGTH;TOTAL SIZE Q (2ND WORD OF FEF)       (+ Q-LENGTH UNBOXED-LENGTH)) (SETQ LAP-STORE-POINTER 2))(T (SETQ LAP-OUTPUT-BLOCK;CREATE THE FEF       (%ALLOCATE-AND-INITIALIZE DTP-FEF-POINTER;DATA TYPE OF RETURNED POINTER #-Explorer DTP-HEADER #+Explorer DTP-FEF-HEADER ;HEADER (1ST WORD OF FEF) #-Explorer (%LOGDPB %HEADER-TYPE-FEF %%HEADER-TYPE-FIELD 0) #+Explorer 0 (SETQ LAP-OUTPUT-BLOCK-LENGTH;TOTAL SIZE Q (2ND WORD OF FEF)       (+ Q-LENGTH UNBOXED-LENGTH)) (WHEN (EQ LAP-MODE 'COMPILE-TO-CORE)   MACRO-COMPILED-PROGRAM) LAP-OUTPUT-BLOCK-LENGTH));AMOUNT TO ALLOCATE (SETQ LAP-STORE-POINTER 2))));1ST TWO WDS DONE EXCEPT REST OF HEADER                                                ;Q WILL BE FILLED IN LATER.(DEFUN LAP-FASD-NIBBLE (N)  ;Don't call FASD with the temporary area in effect  (DECLARE (INLINE FASD-NIBBLE))  (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))    (SETQ LAP-FASD-NIBBLE-COUNT (1- LAP-FASD-NIBBLE-COUNT))    (FASD-NIBBLE N))) (DEFUN LAP-ARGP (VARHOME)  (MEMBER (VAR-KIND VARHOME)  '(FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-KEY FEF-ARG-REST FEF-ARG-AUX)  :TEST #'EQ)) ;This function is called before pass 1 and duplicates some of the work done in;pass 2 by LAP-MFEF, in order to determine whether the A-D-L will be required.;This organization is somewhat poor...(DEFUN COMPUTE-A-D-L-NEEDED-P () ;;  9/28/85 DNG - For release 3, do nothing.  (UNLESS (COMPILING-FOR-V2)    (LET (QFEFHI-FAST-ARG-OPT-OPERATIVE  S-V-BITMAP-ACTIVE  FA)      (COMPUTE-S-V-MAP)                ;Compute S-V-BITMAP-ACTIVE      (SETQ FA (COMPUTE-FAST-OPT-Q))   ;Compute QFEFHI-FAST-ARG-OPT-OPERATIVE      (SETQ A-D-L-NEEDED-P    (OR (LOGTEST (SYMEVAL-FOR-TARGET '%ARG-DESC-FEF-QUOTE-HAIR) FA)                           ;Needed by interpreter       (NOT QFEFHI-FAST-ARG-OPT-OPERATIVE)       ;Needed by microcode       (DOLIST (V ALLVARS)           ;Needed for extra info on args (OR (LAP-ARGP V) (RETURN NIL));(such as &functional) (AND (VAR-MISC V) (RETURN T)))))))  NIL) ;; At the start of pass 2, when the MFEF pseudo is encountered,;; output the fixed header Qs of the fef.(DEFUN LAP-MFEF (WD) ;; 1/25/85 DNG Move old FEF symbols to SI package. ;;10/02/85 DNG Modified for Explorer release 3. ;;12/19/85 DNG Added call to new function COMPUTE-BREAKOFF-OFFSETS. ;; 1/08/86 DNG Set the two flag bits in the CDR-CODE field of the header word.  (LET (HEADERQFEFHI-FCTN-NAMEQFEFHI-FAST-ARG-OPTQFEFHI-SV-BITMAPQFEFHI-MISCQFEFHI-STORAGE-LENGTHUNBOXED-ORGQFEFHI-FAST-ARG-OPT-OPERATIVE(LOCAL-BLOCK-LENGTH    ; actual size of local variable block (FEF-HEADER-LOCAL-LENGTH QLP-FEF-HEADER))(LOCAL-LIMIT 63)       ; maximum allowed size of local variable block)    (SETQ FCTN-NAME (SECOND WD))    (SETQ QFEFHI-FCTN-NAME (OR (SIXTH WD) FCTN-NAME))    (SETQ UNBOXED-ORG (QLEVAL 'PROGSA 'T))  ; PC halfword offset    ;; Compute the header.    (IF (COMPILING-FOR-V2);; Explorer release 3 header format    October 1985(SETQ HEADER      (DPB (TRUNCATE UNBOXED-ORG 2); PC word offset   (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-LOCATION-COUNTER-OFFSET)   (FEF-HEADER-HEADER QLP-FEF-HEADER))      LOCAL-LIMIT      (LDB (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-NUMBER-OF-LOCALS) (LOGNOT 0)))      (PROGN; else Explorer release 1 or LMI machine.(SETQ QFEFHI-SV-BITMAP (COMPUTE-S-V-MAP));DO THIS FIRST, SO S-V-BITMAP-ACTIVE(SETQ QFEFHI-FAST-ARG-OPT (COMPUTE-FAST-OPT-Q)); IS SET FOR COMPUTE-FAST-OPT-Q(IF (NOT (COMPILING-FOR-EXPLORER-P))    (PROGN; old FEF header format (MIT version 98)      (SETQ HEADER (DPB %HEADER-TYPE-FEF %%HEADER-TYPE-FIELD UNBOXED-ORG))      (WHEN (SPECIAL-BIND-NEEDED-P)(SETQ HEADER (DPB 1 (SYMEVAL-FOR-TARGET '%%FEFH-SV-BIND) HEADER)))      (WHEN QFEFHI-FAST-ARG-OPT-OPERATIVE(SETQ HEADER (DPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEFH-FAST-ARG) HEADER)))      (UNLESS A-D-L-NEEDED-P(SETQ HEADER (DPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEFH-NO-ADL) HEADER)))      (WHEN (FEF-HEADER-SELF-FLAVOR QLP-FEF-HEADER)(SETQ HEADER (DPB 1 (SYMEVAL-FOR-TARGET '%%FEFH-GET-SELF-MAPPING-TABLE) HEADER))))                               ; end of old FEF header format  ;; else FEF header format for Explorer release 1   November 1984  (LET (CALL-TYPEOPT-ARGS)    (SETQ HEADER  (DPB (TRUNCATE UNBOXED-ORG 2); PC word offset       (SYMEVAL-FOR-TARGET '%%FEFHI-HD-LOCATION-COUNTER-OFFSET) 0))    (WHEN (SPECIAL-BIND-NEEDED-P)      (SETQ HEADER (%LOGDPB 1 (SYMEVAL-FOR-TARGET '%%FEFHI-HD-SPECIAL) HEADER)))    (WHEN (FEF-HEADER-SELF-FLAVOR QLP-FEF-HEADER)      (SETQ HEADER (%LOGDPB 1 (SYMEVAL-FOR-TARGET '%%FEFHI-HD-SELF-MAPPING-TABLE) HEADER)))    ;; The "call type" field in the header is one of:    ;;   0 -- No local variables    ;;   1 -- Some local variables    ;;   2 -- Has a &REST arg (with or without other locals)    ;;   3 -- Long call -- either the ADL must be used or the    ;;            number of locals or args is to big to fit in    ;;            the first word of the header.    (SETQ CALL-TYPE  (COND ((NOT QFEFHI-FAST-ARG-OPT-OPERATIVE) 3)(REST-ARG 2)((ZEROP LOCAL-BLOCK-LENGTH) 0)(T 1)))    (SETQ QFEFHI-FAST-ARG-OPT  (%LOGDPB CALL-TYPE (SYMEVAL-FOR-TARGET '%%FEFHI-FSO-CALL-TYPE)   QFEFHI-FAST-ARG-OPT))    (SETQ QFEFHI-FAST-ARG-OPT  (%LOGDPB LOCAL-BLOCK-LENGTH   (SYMEVAL-FOR-TARGET '%%FEFHI-FSO-LOCAL-BLOCK-LENGTH)   QFEFHI-FAST-ARG-OPT))    (LET ((BYTE-DESC (SYMEVAL-FOR-TARGET '%%FEFHI-HD-NUMBER-LOCALS)))      (IF (<= LOCAL-BLOCK-LENGTH (LDB BYTE-DESC (LOGNOT 0)))  ;; Few enough locals for count to fit in header word  (SETQ HEADER (%LOGDPB LOCAL-BLOCK-LENGTH BYTE-DESC HEADER));; Else "long call", need to look at Misc. word for length.(SETQ CALL-TYPE 3)))    (LET ((BYTE-DESC (SYMEVAL-FOR-TARGET '%%FEFHI-HD-NUMBER-ARGS)))      (IF (<= MIN-ARGS (LDB BYTE-DESC (LOGNOT 0)))  ;; Few enough required args for count to fit in header word  (SETQ HEADER (%LOGDPB MIN-ARGS BYTE-DESC HEADER));; Else "long call", need to look at Numeric Arg Descriptor(SETQ CALL-TYPE 3)))    (SETQ OPT-ARGS (- MAX-ARGS MIN-ARGS)); number of optional arguments    (LET ((BYTE-DESC (SYMEVAL-FOR-TARGET '%%FEFHI-HD-NUMBER-OPTIONAL-ARGS)))      (IF (<= OPT-ARGS (LDB BYTE-DESC (LOGNOT 0)))  ;; Few enough optional args for count to fit in header word  (SETQ HEADER (%LOGDPB OPT-ARGS BYTE-DESC HEADER));; Else "long call", need to look at Numeric Arg Descriptor(SETQ CALL-TYPE 3)))    (SETQ HEADER (%LOGDPB CALL-TYPE (SYMEVAL-FOR-TARGET '%%FEFHI-HD-CALL-TYPE) HEADER))));; Compute the MISC word.(SETQ QFEFHI-MISC      (%LOGDPB (IF (FEF-HEADER-DEBUG-INFO QLP-FEF-HEADER)   1 0)       (SYMEVAL-FOR-TARGET '%%FEFHI-MS-DEBUG-INFO-PRESENT)       (DPB ADL-LENGTH (SYMEVAL-FOR-TARGET '%%FEFHI-MS-BIND-DESC-LENGTH)    (DPB (QLEVAL 'DESC-LIST-ORG 'T) (SYMEVAL-FOR-TARGET '%%FEFHI-MS-ARG-DESC-ORG) LOCAL-BLOCK-LENGTH)))))); end of not for release 3    (WHEN (> LOCAL-BLOCK-LENGTH LOCAL-LIMIT)      (BARF (- LOCAL-BLOCK-LENGTH LOCAL-LIMIT)    "more local block slots than maximum allowed."    'DATA))    (SETQ QFEFHI-STORAGE-LENGTH (LSH (1+ LENGTH-OF-PROG) -1))    (SETQ ADR (+ ADR (* 2 (SYMEVAL-FOR-TARGET '%FEF-HEADER-LENGTH))))    (WHEN (AND (COMPILING-FOR-V2) (NOT (NULL (FEF-HEADER-LONG-ARGS QLP-FEF-HEADER))))      (INCF ADR 2))    (LAP-HEADER (TRUNCATE UNBOXED-ORG 2)                            ;Q PART LENGTH(- QFEFHI-STORAGE-LENGTH (TRUNCATE UNBOXED-ORG 2))) ;UNBOXED PART LENGTH    (LET ((HEADER-CDR-CODE   (AND (COMPILING-FOR-V2)      (LET ((TEM 0))(WHEN (OR SM-ARGS-NOT-EVALD (MEMBER '&FUNCTIONAL (EIGHTH WD) :TEST #'EQ)) ;; Will need to look at the argument list when compiling ;; calls to this function.  (SETQ TEM (DPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-SPECIAL-FORM) TEM)))(WHEN (SEVENTH WD); SUBST-FLAG ;; This is a DEFSUBST -- mark it for inline expansion.  (SETQ TEM (DPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-SUBST) TEM)))(LDB %%Q-CDR-CODE TEM)))))      (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE))     (SETQ PROG-ORG (LAP-D-OUT HEADER))     (WHEN (COMPILING-FOR-V2)       (SETQ LAP-LASTQ-MODIFIER (LSH HEADER-CDR-CODE 6)))     (LAP-D-OUT QFEFHI-STORAGE-LENGTH))    #+compiler:debug    ((EQ LAP-MODE :JUST-COUNT))    ((COMPILING-FOR-EXPLORER-P)     (%P-DPB DTP-FEF-HEADER %%Q-DATA-TYPE LAP-OUTPUT-BLOCK)     (%P-DPB HEADER %%Q-POINTER LAP-OUTPUT-BLOCK)     (WHEN (COMPILING-FOR-V2)       (%P-DPB HEADER-CDR-CODE %%Q-CDR-CODE LAP-OUTPUT-BLOCK)))    (T     #+compiler:debug     (UNLESS (EQ TARGET-PROCESSOR HOST-PROCESSOR)       (FERROR NIL "Can't compile in memory for a ~A." TARGET-PROCESSOR))     (%P-DPB HEADER (SYMEVAL-FOR-TARGET '%%HEADER-REST-FIELD) LAP-OUTPUT-BLOCK))))    (IF (COMPILING-FOR-V2)      (PROGN(LET ((DEBUG-INFO (FEF-HEADER-DEBUG-INFO QLP-FEF-HEADER)))  (COMPUTE-BREAKOFF-OFFSETS DEBUG-INFO)  (LAP-D-OUT   (IF (LISTP DEBUG-INFO)     (CONS `(:NAME ,QFEFHI-FCTN-NAME) DEBUG-INFO)     DEBUG-INFO)))(LET ((ARGS-INFO (FEF-HEADER-LONG-ARGS QLP-FEF-HEADER)))  (UNLESS (NULL ARGS-INFO)    (LAP-D-OUT ARGS-INFO))))      (PROGN(LAP-D-OUT QFEFHI-FCTN-NAME)(LAP-D-OUT QFEFHI-FAST-ARG-OPT)(LAP-D-OUT QFEFHI-SV-BITMAP)(LAP-D-OUT QFEFHI-MISC)))    (LAP-STORE-NXTNIL-CDR-CODE))) (DEFUN COMPUTE-BREAKOFF-OFFSETS (DEBUG-INFO)  ;; If this function contains any internal functions, then update  ;; the :INTERNAL-FEF-OFFSETS entry in the debug info with the actual  ;; offsets in the FEF where the pointers to the internal FEFs are  ;; stored.  ;;  ;; 12/19/85 DNG - Original version.  ;;  7/23/86 CLM - Changed to handle the new format of the quote-list.  For Rel. 3 only.  ;;  8/08/86 DNG - Remove error on missing breakoff function.  (LET (OFFSETS NAMES)    (IF (LISTP DEBUG-INFO)(WHEN (SETQ OFFSETS (CDR (ASSOC :INTERNAL-FEF-OFFSETS DEBUG-INFO :TEST #'EQ)))  (SETQ NAMES (CDR (ASSOC :INTERNAL-FEF-NAMES DEBUG-INFO :TEST #'EQ))))      (WHEN (SETQ OFFSETS (SI:GET-DEBUG-INFO-FIELD DEBUG-INFO :INTERNAL-FEF-OFFSETS))(SETQ NAMES (SI:GET-DEBUG-INFO-FIELD DEBUG-INFO :INTERNAL-FEF-NAMES))))    (UNLESS (NULL OFFSETS)   ; if there are any internal functions      (DO ((QL QUOTE-LIST (CDR QL))   ; look for references in the quote vector   (OFFSET     (+ (TRUNCATE ADR 2) ; FEF offset in words(LENGTH SPECVARS) (IF (FEF-HEADER-SELF-FLAVOR QLP-FEF-HEADER) 1 0))     (+ OFFSET 1)))  ((NULL QL))(LET ((WD (if (compiling-for-v2) (FIRST QL) (car (first ql)))))  (WHEN (EQ (FIRST WD) 'BREAKOFF-FUNCTION)    ;; WD = (BREAKOFF-FUNCTION (:INTERNAL parent child))    (LET ((F (THIRD (SECOND WD))))      (PUSH (CONS OFFSET F) BREAKOFF-FUNCTION-OFFSETS); for verification in QLP2-Q.      (UNLESS (FIXNUMP F) ; map name to number.(SETQ F (POSITION F (THE LIST NAMES) :TEST #'EQ)))      ;; Store the offset into the debug info.      (SETF (NTH F OFFSETS) OFFSET)))))      )))(DEFUN LIST-SUM (X)  "Returns the sum of the values of the elements of X"  (DO ((L X (CDR L))       (ANS 0))      ((NULL L)       ANS)    (SETQ ANS  (+ ANS     ;(TRANSL::WARNING "Make sure that the argument to eval is a common lisp form"(EVAL (CAR L))    ; )     )))) ;Looking at ALLVARS, compute these quantities:;MIN-ARGS, the minimum number of args required by the function.;MAX-ARGS, the maximum number of args accepted by the function, not including a rest arg.;HAIRY-INIT-FLAG, T if any variable is initialized at function entry other than to NIL.;SM-VARS-NOT-EVALD, T if any arguments are not evaluated.(DEFUN SCAN-ARGS () ;;  1/08/86 DNG - Use DOLIST instead of DO.  (DOLIST (V ALLVARS)    (CASE (VAR-KIND V)      (FEF-ARG-REQ (SETQ MAX-ARGS (1+ MAX-ARGS)) (SETQ MIN-ARGS (1+ MIN-ARGS)))      (FEF-ARG-OPT (SETQ MAX-ARGS (1+ MAX-ARGS)))      (FEF-ARG-REST (SETQ REST-ARG V)))    (CASE (CAR (VAR-INIT V))      ((FEF-INI-NONE FEF-INI-NIL))      (FEF-INI-COMP-C (UNLESS (EQ (VAR-KIND V) 'FEF-ARG-INTERNAL-AUX)(SETQ HAIRY-INIT-FLAG T)))      (OTHERWISE (SETQ HAIRY-INIT-FLAG T)))    (WHEN (EQ (VAR-EVAL V) 'FEF-QT-QT)      (SETQ SM-ARGS-NOT-EVALD T)))) (DEFUN COMPUTE-FAST-OPT-Q ()    ;SETS SPEC VAR QFEFHI-FAST-ARG-OPT-OPERATIVE ;;  9/30/85 DNG - Not applicable for release 3.  (UNLESS (COMPILING-FOR-V2)    (SETQ QFEFHI-FAST-ARG-OPT-OPERATIVE NIL)      ;ASSUME INOPERATIVE    (OR HAIRY-INIT-FLAG                    ;CHECK REASONS NOT TO HAVE FAST OPT OPERATIVE       DATA-TYPE-CHECKING-FLAG             ;FOR LINEAR ENTER       (NULL S-V-BITMAP-ACTIVE)            ;MICRO-CODE DOESNT FEEL LIKE HANDLING THIS CASE..                                           ; (GOING TO HAVE TO GRUBBLE THRU A-D-L ANYWAY, SO                                           ; MIGHT AS WELL DO SLOW ENTER).       (SETQ QFEFHI-FAST-ARG-OPT-OPERATIVE T))    (LOGIOR     (DPB MIN-ARGS (SYMEVAL-FOR-TARGET '%%ARG-DESC-MIN-ARGS)  (DPB MAX-ARGS (SYMEVAL-FOR-TARGET '%%ARG-DESC-MAX-ARGS) 0))     (COND ((NULL REST-ARG) 0)   ((EQ (VAR-EVAL REST-ARG) 'FEF-QT-QT)    (SYMEVAL-FOR-TARGET '%ARG-DESC-QUOTED-REST))   (T (SYMEVAL-FOR-TARGET '%ARG-DESC-EVALED-REST)))     (IF (AND SM-ARGS-NOT-EVALD (> MAX-ARGS 0))       (SYMEVAL-FOR-TARGET '%ARG-DESC-FEF-QUOTE-HAIR)       0)     (IF QFEFHI-FAST-ARG-OPT-OPERATIVE       0       (SYMEVAL-FOR-TARGET '%ARG-DESC-FEF-BIND-HAIR))))) (DEFUN COMPUTE-FEF-HEADER () ;; Compute the FEF header word (except for the starting PC, which will ;; be filled in later) and the long-args word, if needed. ;;  9/30/85 - Original version. ;;  5/08/86 - Use %%FEF-HEADER-NUMBER-OPTIONAL-ARGS instead of %%FEFHI-HD-NUMBER-OPTIONAL-ARGS.  #+compiler:debug  (ASSERT (COMPILING-FOR-V2))  (LET (CALL-TYPE(HEADER 0)(OPT-ARGS (- MAX-ARGS MIN-ARGS))      ; number of optional arguments(LONG-ARGS-WORD NIL)(LOCAL-BLOCK-LENGTH (FEF-HEADER-LOCAL-LENGTH QLP-FEF-HEADER)))    (WHEN (FEF-HEADER-SELF-FLAVOR QLP-FEF-HEADER)      (SETQ HEADER (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-SELF-MAPPING-TABLE) HEADER)))    (SETQ CALL-TYPE  (COND    ((> OPT-ARGS 0)     ;; There are some optional arguments.     (COND (REST-ARG (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-OPTIONALS-AND-REST))   ((NOT (ZEROP LOCAL-BLOCK-LENGTH)); also some locals    (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-OPTIONALS-AND-LOCALS))   (T (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-OPTIONALS))))    (REST-ARG (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-REST))    ((ZEROP LOCAL-BLOCK-LENGTH) (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-SIMPLE))    (T (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-LOCALS))))    (LET ((BYTE-DESC (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-NUMBER-LOCALS)))      (IF (<= LOCAL-BLOCK-LENGTH (LDB BYTE-DESC (LOGNOT 0)))       ;; Few enough locals for count to fit in header word(SETQ HEADER (%LOGDPB LOCAL-BLOCK-LENGTH BYTE-DESC HEADER));; Else "long call", need to look at long-args word for length.(SETQ LONG-ARGS-WORD T)))    (LET ((BYTE-DESC (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-NUMBER-ARGS)))      (IF (<= MIN-ARGS (LDB BYTE-DESC (LOGNOT 0)))       ;; Few enough required args for count to fit in header word(SETQ HEADER (%LOGDPB MIN-ARGS BYTE-DESC HEADER));; Else "long call", need to look at long-args word.(SETQ LONG-ARGS-WORD T)))    (LET ((BYTE-DESC (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-NUMBER-OPTIONAL-ARGS)))      (IF (<= OPT-ARGS (LDB BYTE-DESC (LOGNOT 0)))       ;; Few enough optional args for count to fit in header word(SETQ HEADER (%LOGDPB OPT-ARGS BYTE-DESC HEADER));; Else "long call", need to look at Numeric Arg Descriptor(SETQ LONG-ARGS-WORD T)))    (WHEN LONG-ARGS-WORD      (SETQ CALL-TYPE (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-LONG))      (SETQ LONG-ARGS-WORD    (%LOGDPB LOCAL-BLOCK-LENGTH     (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-NUMBER-OF-LOCALS)     (%LOGDPB MIN-ARGS (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-MIN-ARGS)      (%LOGDPB MAX-ARGS       (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-MAX-ARGS) 0))))      (UNLESS (ZEROP LOCAL-BLOCK-LENGTH)(SETQ LONG-ARGS-WORD      (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-LOCALS) LONG-ARGS-WORD)))      (WHEN (> OPT-ARGS 0)(SETQ LONG-ARGS-WORD      (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-OPTIONALS) LONG-ARGS-WORD)))      (WHEN REST-ARG(SETQ LONG-ARGS-WORD      (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-REST-ARG) LONG-ARGS-WORD))))    (SETQ HEADER (%LOGDPB CALL-TYPE (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-CALL-TYPE) HEADER))    (SETF (FEF-HEADER-LONG-ARGS QLP-FEF-HEADER) LONG-ARGS-WORD)    (SETF (FEF-HEADER-HEADER QLP-FEF-HEADER) HEADER))) ;Return T if any special variables must be bound at entry to this function.(DEFUN SPECIAL-BIND-NEEDED-P ()  (DO ((VS ALLVARS (CDR VS)))      ((NULL VS)       NIL)    (AND (LAP-ARGP (CAR VS)) (NEQ (VAR-TYPE (CAR VS)) 'FEF-LOCAL) (RETURN T)))) ;Compute and return the special-variable bitmap for the function.;The bit saying whether the map is active is correctly set in the value returned.;In addition, S-V-BITMAP-ACTIVE is left T if the bitmap is active.;The map is active if the AP-relative addresses of all the values;to be bound to specials are constant, and if the addresses are not;too large to be expressed in a 1-word bit map.(DEFUN COMPUTE-S-V-MAP ()  (PROG (S-MAP)    (COND ((NOT (SPECIAL-BIND-NEEDED-P))   (SETQ S-V-BITMAP-ACTIVE T)   (RETURN %FEFHI-SVM-ACTIVE));Null bitmap, no specials  (REST-ARG (RETURN 0)));Can't predict addresses    (SETQ S-MAP 0  S-V-BITMAP-ACTIVE T);Assume will use bitmap, unless too many to fit    (DO ((BIT (LSH %FEFHI-SVM-ACTIVE -1) (LSH BIT -1)) (ENDARG) (VS ALLVARS (CDR VS)))((NULL VS))      (COND ((LAP-ARGP (CAR VS))     (AND ENDARG (BARF NIL "Arg-types out of order" 'BARF))     (OR (EQ (VAR-TYPE (CAR VS)) 'FEF-LOCAL) (COND   ((ZEROP BIT);Special past the end of the bit map    (SETQ S-V-BITMAP-ACTIVE NIL);so give up on using bit map    (RETURN NIL))   (T (SETQ S-MAP (+ S-MAP BIT))))))    (T (SETQ ENDARG T))))    (IF S-V-BITMAP-ACTIVE      (RETURN (+ S-MAP %FEFHI-SVM-ACTIVE))      (RETURN 0))))                  ;Couldn't use bit map after all;Get a list of all special variables referred to by the function,;either free or bound, suitable for constructing the indirect pointers;to their value cells.;Specials bound at entry to the function must come first, one for one,;even if there are duplicates.  SPECVARS-BIND-COUNT is the number of such.;Specials bound internally or used free can have duplicates removed.(DEFUN EXTRACT-SPECVARS ()  (PROG (SVS)    (SETQ SPECVARS-BIND-COUNT 0)    (DO ((VS ALLVARS (CDR VS)))((NULL VS))      (AND (NEQ (VAR-TYPE (CAR VS)) 'FEF-LOCAL) (OR (WHEN (LAP-ARGP (CAR VS))       (SETQ SPECVARS-BIND-COUNT (1+ SPECVARS-BIND-COUNT))       T)    (NOT (MEMBER (VAR-NAME (CAR VS)) SVS :TEST #'EQ))) (PUSH (VAR-NAME (CAR VS)) SVS)))    (DO ((VS FREEVARS (CDR VS)))((NULL VS))      (OR (MEMBER (CAR VS) SVS :TEST #'EQ) (PUSH (CAR VS) SVS)))    (RETURN (REVERSE SVS)))) (DEFUN QLP2-DEFSYM (SYM VAL)  (PROG ()    S1    (COND ((NULL (CDR SYMPTR)) (GO S1E))   ;SYMBOL  ((NOT (EQ (CADADR SYMPTR) 'TDEF))   (SETQ SYMPTR (CDR SYMPTR))   (GO S1))  ((OR (NOT (EQ SYM (CAADR SYMPTR)));SHOULD BE IN SAME ORDER AS PASS 1       (NOT (= VAL (CADDR (CADR SYMPTR))))) (GO S1E)))    (RETURN (SETQ SYMPTR (CDR SYMPTR)))    S1E    (RETURN (BARF (LIST (CAR SYMPTR) SYM VAL) 'SYMPTR-LOSES 'BARF)))) (DEFUN QLP2-U (WD)           ;PASS2 FOR UNBOXED AREA ;; 12/17/85 CLM - For release 3, added code for the DISPATCH instruction. ;;  5/15/86 DNG - MISC-INSTRUCTION-REQUIRED-DESTINATION-ALIST goes away in rel 3. ;;  9/08/86 CLM - Added code for SELECT instruction.  (DECLARE (OPTIMIZE SPEED))  (PROG ()    (COND ((NULL WD) (RETURN NIL))  ((ATOM WD) (GO S1))  ((EQ (CAR WD) 'RESTART-TAG) (SETQ WD (CADR WD)) (GO S1))  ((EQ (CAR WD) 'BRANCH) (GO B1))  ((MEMBER (CAR WD) '(COMMENT       NO-DROP-THROUGH       PARAM)   :TEST #'EQ) (RETURN NIL))  ((EQ (CAR WD) 'ADI-CALL) (LAP-P2-ADI (CDR WD)) (RETURN NIL))  ((EQ (CAR WD) 'MISC);(MISC destination function)   #+(and compiler:debug (not Elroy))   (LET (TEM)     (DECLARE (SPECIAL MISC-INSTRUCTION-REQUIRED-DESTINATION-ALIST))     (AND       (SETQ TEM (ASSOC (CADDR WD) MISC-INSTRUCTION-REQUIRED-DESTINATION-ALIST :TEST #'EQ))       (NOT (MEMBER (CADR WD) (CDR TEM) :TEST #'EQ))       (BARF WD "Illegal destination for this misc instruction" 'BARF)))   (LAP-OUTPUT-WORD (LAP-WORD-EVAL WD)) (GO X1))  ;;added 12/17/85 by CLM for release 3 DISPATCH instruction  ((MEMBER (CAR WD) '(DISPATCH SELECT) :TEST #'EQ)   (LET ((OFFSET (TRUNCATE (CAR DISPATCH-OFFSET-LIST) 2)))     (IF (> OFFSET 511) (BARF OFFSET "FEF-offset of dispatch table is too large" 'BARF)       (PROGN (LAP-OUTPUT-WORD (+ (LAP-VALUE (CAR WD)) (TRUNCATE (CAR DISPATCH-OFFSET-LIST) 2))) (POP DISPATCH-OFFSET-LIST) (GO X1)))))  (T (LAP-OUTPUT-WORD (LAP-WORD-EVAL WD)) (GO X1)))    B1    (QB2 (LIST (CADR WD) (CADDR WD) (CADDDR WD))      ;BRANCH (CAR (LAST WD)))    X1    (SETQ ADR (1+ ADR))    (RETURN NIL)    S1    (QLP2-DEFSYM WD ADR)    (RETURN NIL))) (DEFUN LAP-P2-DISPATCH (D-LIST) ;; 12/17/85  CLM - For release 3, code to emit dispatch tables.  FEF offsets ;;                 for each table are recorded in dispatch-offset-list. ;; 12/20/85  DNG - Deleted call to LAP-MODIFY-LASTQ since it will be done ;;                 by QLAP-PASS2 and we get in trouble if we do it twice ;;                 when writing an XFASL file. ;;  4/03/86  CLM - Fixed a problem in calculating the FEF offset for a dispatch table. ;;  9/08/86  CLM - Added code for SELECT instruction.  (DOLIST (ITEM D-LIST)    (let ((pc-array (cadr item)))      (PUSH ADR DISPATCH-OFFSET-LIST)      ;;if this is a select, do the value-array first      (when (cddr item)(let ((value-list (caddr item)))  (lap-d-out (length value-list))            ;number of values  (dolist (val value-list)     (lap-d-out  val))  (incf adr (* 2 (+ (length value-list) 1)))) )            (LAP-D-OUT (1- (LENGTH PC-ARRAY)))            ;the max index      (LAP-D-OUT (QLEVAL (CAR ITEM) 'T))            ;the otherwise-pc         (DO ((I 0 (1+ I)))  ((= I (LENGTH PC-ARRAY)))(LAP-D-OUT (QLEVAL (AREF PC-ARRAY I) 'T)))      (LAP-STORE-NXTNIL-CDR-CODE)      (INCF ADR (* 2 (+ (LENGTH PC-ARRAY) 2)))))  (SETQ DISPATCH-OFFSET-LIST (NREVERSE DISPATCH-OFFSET-LIST))) (DEFUN QLP2-Q (WD);PASS2 FOR Q AREA ;;  7/24/85 - Allow :INTERNAL function specs with names in place of numbers. ;;  9/28/85 - For release 3, DEBUG-INFO is output LAP-MFEF instead of here. ;; 12/17/85 - For release 3, code added for the DISPATCH instruction. ;; 12/19/85 - Modify BREAKOFF-FUNCTION handling for release 3. ;;  6/14/86 DNG - Fix handling of method functions and self-ref for LAP-MODE of DISASSEMBLE. ;;  7/23/86 CLM - Changed the dumping of the quote-list to handle the new format of the list ;;                for rel.3 only. ;;  8/08/86 DNG - Remove error on missing breakoff function. ;;  9/08/86 CLM - Added code for SELECT isntruction.  (PROG ()    (COND ((ATOM WD)   (IF (NOT (EQ WD 'PROGSA));TAG HAD BETTER BE PROGSA       (PROGN (BARF WD 'TAG-IN-Q-AREA 'BARF) (RETURN NIL))     (RETURN T)));ADVANCE TO UNBOXED AREA)  ((EQ (CAR WD) 'QTAG)   (QLP2-DEFSYM (CADR WD) (TRUNCATE ADR 2))   (WHEN (EQ (CADR WD) 'QUOTE-BASE)     (MAPC #'(LAMBDA (CONST-ELT)       (QLP2-Q (IF (COMPILING-FOR-V2)     CONST-ELT      ;changed the format of the quote-list for rel.3   (CAR CONST-ELT))))   QUOTE-LIST));DUMP QUOTE TABLE   (RETURN NIL))  ((EQ (CAR WD) 'PARAM) (RETURN NIL))  ((EQ (CAR WD) 'ENDLIST);TERMINATE LIST THAT HAS JUST   (LAP-STORE-NXTNIL-CDR-CODE);BEEN ASSEMBLED   ;;code added 12/17/85 by CLM for dispatch tables   (WHEN (AND (COMPILING-FOR-V2) DISPATCH-LIST)     (SETQ DISPATCH-LIST (NREVERSE DISPATCH-LIST))     (LAP-P2-DISPATCH DISPATCH-LIST))   (RETURN NIL))  ((EQ (CAR WD) 'MFEF) (LAP-MFEF WD)   (RETURN NIL))  ((EQ (CAR WD) 'S-V-BLOCK)   (SETQ ADR (QLP2-S-V-BLOCK ADR))   (RETURN NIL))  ((EQ (CAR WD) 'CONSTRUCT-MACRO)   (SETQ LAP-MACRO-FLAG T)   (RETURN NIL))  ((EQ (CAR WD) 'A-D-L)   (SETQ ADR (QLP-A-D-L ADR T))   (RETURN NIL))  ((EQ (CAR WD) 'DEBUG-INFO)   (IF (COMPILING-FOR-V2)       ;; Already output by LAP-MFEF.       (RETURN NIL)     (PROGN       (LAP-D-OUT (CDR WD))       (LAP-STORE-NXTNIL-CDR-CODE)       (GO X2))))  ((EQ (CAR WD) 'VARIABLES-USED-IN-LEXICAL-CLOSURES)   (LAP-D-OUT (CDR WD))   (LAP-STORE-NXTNIL-CDR-CODE)   (GO X2))  ((EQ (CAR WD) 'SELF-FLAVOR)   (LAP-D-OUT (CADR WD))   (LAP-STORE-NXTNIL-CDR-CODE)   (GO X2))  ((EQ (CAR WD) 'BREAKOFFS)   (UNLESS (COMPILING-FOR-V2)     ;; When we see the BREAKOFFS command,     ;; we copy the fef offsets of where the ptrs to broken-off fns should go     ;; into the cars of the list which is the cadr of the breakoffs command.     ;; That list is shared with a debug-info item     ;; which is supposed to contain a list of those offsets.     (DOLIST (OFFSET BREAKOFF-FUNCTION-OFFSETS)       (SETF (NTH (CDR OFFSET) (CADR WD)) (CAR OFFSET))))   (RETURN NIL))  ((EQ (CAR WD) 'QUOTE)   (LAP-D-OUT (CADR WD))   (GO X2))  ((EQ (CAR WD) 'LOCATIVE-TO-S-V-CELL)   (LAP-Q-OUT NIL 'QZLOC '1 (CADR WD))   (GO X2))  ((EQ (CAR WD) 'FUNCTION)   (IF (SYMBOLP (CADR WD))       (LAP-Q-OUT NIL 'QZEVCP '2 (CADR WD))     (LAP-Q-OUT NIL 'QZEVCP NIL(IF (MEMBER LAP-MODE '(COMPILE-TO-CORE#+compiler:debug DISASSEMBLE#+compiler:debug :DUMP)    :TEST #'EQ)    (FDEFINITION-LOCATION (CADR WD))  (CONS EVAL-AT-LOAD-TIME-MARKER `(FDEFINITION-LOCATION ',(CADR WD))))))   (FUNCTION-REFERENCED (CADR WD) FCTN-NAME) (GO X2))  ((EQ (CAR WD) 'SELF-REF)   (LAP-Q-OUT NIL 'QZSRP NIL      (IF (MEMBER LAP-MODE '(COMPILE-TO-CORE      #+compiler:debug DISASSEMBLE      #+compiler:debug :DUMP)  :TEST #'EQ)  (SI:FLAVOR-VAR-SELF-REF-INDEX (CDR WD))(CONS EVAL-AT-LOAD-TIME-MARKER `(SI:FLAVOR-VAR-SELF-REF-INDEX ',(CDR WD)))))   (GO X2))  ((EQ (CAR WD) 'BREAKOFF-FUNCTION)   (LET ((F (CADDR (CADR WD))))     (IF (COMPILING-FOR-V2) (UNLESS (EQ (TRUNCATE ADR 2) (CAR (RASSOC F BREAKOFF-FUNCTION-OFFSETS :TEST #'EQ)))   (BARF WD "offset discrepency" 'BARF))       (PROGN (UNLESS (NUMBERP F)   (LET ((DEBUG-INFO (FEF-HEADER-DEBUG-INFO QLP-FEF-HEADER)))     (SETQ F   (POSITION F     (THE LIST  (CDR (ASSOC :INTERNAL-FEF-NAMES DEBUG-INFO :TEST #'EQ)))     :TEST #'EQ)))) (PUSH (CONS (TRUNCATE ADR 2) F) BREAKOFF-FUNCTION-OFFSETS))))   (LAP-D-OUT (CADR WD))   (GO X2))  ((EQ (CAR WD) 'TAG)   (LAP-D-OUT (QLEVAL (CADR WD) T))   (GO X2))  ((EQ (CAR WD) 'FIXE)   (LAP-D-OUT (LAP-WORD-EVAL `(EXTENDED-ADDRESS 0 ,(CADR WD))))   (GO X2))  (T (BARF WD 'UNKNOWN-OP-IN-Q-AREA-LAP 'BARF) (RETURN NIL)))    X2    (SETQ ADR (+ 2 ADR))))(DEFUN FUNCTION-REFERENCED (WHAT BY) ;; Collect functions referenced ;;  3/14/86 DNG - Don't use FUNCTION-P when cross-compiling without defaulting.  (UNLESS (AND (OR *DEFAULT-DEFS-FROM-HOST*   (EQ TARGET-PROCESSOR HOST-PROCESSOR))       (FUNCTION-P WHAT))      ;defined in QCP1    (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)  (ENTRY (ASSOC WHAT FUNCTIONS-REFERENCED :TEST #'EQUAL)))      (SETQ BY (COPY-TREE BY))         ;Could be (:METHOD ...)      (IF ENTRY(RPLACD ENTRY (CONS BY (CDR ENTRY)))(PUSH (LIST (COPY-TREE WHAT) BY) FUNCTIONS-REFERENCED))))) ;Output the block of forwarding pointers to value cells of special variables.;We make one forwarding pointer for each entry in SPECVARS,;and assume that the first SPECVARS-BIND-COUNT of them are bound at function entry.;The argument of this function is the location counter (in half-Qs) in the fef,;and the updated location counter is returned.(DEFUN QLP2-S-V-BLOCK (ADR)  (DO ((SVS SPECVARS (CDR SVS))       (NUMARGS SPECVARS-BIND-COUNT (1- NUMARGS)))      ((NULL SVS)       (LAP-STORE-NXTNIL-CDR-CODE))    (LAP-Q-OUT NIL 'QZEVCP 1 (CAR SVS))    (INCF ADR 2))  ADR) ;Output the argument descriptor list, based entirely on ALLVARS.;Only bound variables go in the ADL.;On pass 1, PASS2-FLAG is NIL and all we do is advance ADR.;Since, at the moment, there are many A-D-L lists output in the lap code,;QLP-A-D-L-DONE is used to make sure that QLP-A-D-L does its work only once.;It starts out as NIL, and is set to the number of variables in the ADL.(DEFUN QLP-A-D-L (ADR PASS2-FLAG) ;;  8/26/85 - Use variable LOCAL-BLOCK-LENGTH instead of ;;            (QLEVAL 'LLOCBLOCK 'NIL).  [SPR 558] ;;  9/30/85 - LOCAL-BLOCK-LENGTH made part of QLP-FEF-HEADER structure.  (WHEN (AND A-D-L-NEEDED-P (NOT QLP-A-D-L-DONE) (NOT (COMPILING-FOR-V2)))    (SETQ QLP-A-D-L-DONE 0)    (LET ((ADL-MAX-LOCAL-SLOT 0))      (DO ((VS ALLVARS (CDR VS))   (V)   (KIND)   (INTL))  ((NULL VS))(SETQ V (CAR VS))(SETQ KIND (VAR-KIND V))(SETQ QLP-A-D-L-DONE (1+ QLP-A-D-L-DONE))(AND (CONSP (VAR-LAP-ADDRESS V))     (EQ (CAR (VAR-LAP-ADDRESS V)) 'LOCBLOCK)     (SETQ ADL-MAX-LOCAL-SLOT (MAX ADL-MAX-LOCAL-SLOT   (CADR (VAR-LAP-ADDRESS V)))));; First, output the word of bits.(AND PASS2-FLAG     (LAP-D-OUT (+ (SYMBOL-VALUE KIND)   (SYMBOL-VALUE (VAR-TYPE V))   (SYMBOL-VALUE (VAR-EVAL V))   (SYMBOL-VALUE (CAR (VAR-INIT V)))   (LIST-SUM (VAR-MISC V)))))(SETQ ADR (+ 2 ADR));; Now output the initialization data, if any.(SETQ INTL (VAR-INIT V))(COND ((NOT (LAP-ARGP V)))      ((EQ (CAR INTL) 'FEF-INI-COMP-C))      ((EQ (CAR INTL) 'FEF-INI-OPT-SA)       ;; optional arg with alternate starting address: output tag to jump to.       (IF PASS2-FLAG   (QLP2-Q (LIST 'TAG (CADR INTL))) (SETQ ADR (+ 2 ADR))))      ((CADR INTL) (IF PASS2-FLAG       (QLP2-Q (CADR INTL))     (SETQ ADR (+ 2 ADR))))))      ;; Deal with any local slots the function wants to have      ;; but which don't correspond to variables in ALLVARS.      ;; We must make ADL entries for them so the microcode will push the slots.      (DOTIMES (I (- (FEF-HEADER-LOCAL-LENGTH QLP-FEF-HEADER)     (1+ ADL-MAX-LOCAL-SLOT)))#+Elroy (DECLARE (SPECIAL FEF-INI-COMP-C FEF-ARG-INTERNAL-AUX))(SETQ QLP-A-D-L-DONE (1+ QLP-A-D-L-DONE))(WHEN PASS2-FLAG  (LAP-D-OUT (+ FEF-INI-COMP-C FEF-ARG-INTERNAL-AUX)))(INCF ADR 2)))    (AND PASS2-FLAG (LAP-STORE-NXTNIL-CDR-CODE)))  ADR) (PROCLAIM '(INLINE LAP-ADR-P1)) (DEFUN LAP-ADR-P1 (ADDRESS &OPTIONAL WD) ;;  9/30/85 - Change name of argument so it is not a special variable. ;;  3/05/86 - CLM Pass WD to QADD in order to check for certain instructions. ;;  3/07/86 - CLM Change WD to an optional argument to prevent breakage by ;;            old style adi-call's.  (COND ((ATOM ADDRESS) NIL)((EQ (CAR ADDRESS) 'QUOTE-VECTOR) (QADD (CADR ADDRESS) WD)))) (DEFUN QLP1 (WD) ;;  8/26/85 - Set variable LOCAL-BLOCK-LENGTH directly here.  [SPR 558] ;;  9/30/85 - For release 3, don't increment ADR for DEBUG-INFO; ;;            make %FEF-HEADER-LENGTH target-dependent; move ;;            LOCAL-BLOCK-LENGTH into QLP-FEF-HEADER. ;; 12/17/85 - For release 3, added code for the DISPATCH instruction. ;; 12/19/85 - Moved setting of ALLVARS, FREEVARS, and SPECVARS here from QLAPP. ;;  1/30/86 CLM - Modified so that a branch to UNWIND-PROTECT cleanup-forms ;;                will be handled as a LONG-PUSHJ long-branch. ;;  3/05/86 CLM - Modified to keep track of short-fef-max-quote-length.  Done to ;;                handle fef offsets greater than 191. ;;  3/07/86 CLM - Only use the above patch if compiling for vm2. ;;  3/25/86 DNG - Set mapping table flag in the FEF header when the SELF-FLAVOR ;;      declaration is encountered because the header has already been computed. ;;  4/03/86 CLM - Fixed a problem in calculating the FEF offset of a dispatch table. ;;  7/23/86 CLM - Record the position of QUOTE-BASE in the var QB; will be used in QADD ;;                to determine positions of constants in the quote-list.  For rel.3 only. ;;  9/08/86 CLM - Added code for SELECT instruction. ;; 01/16/87 CLM - When calculating SHORT-FEF-MAX-QUOTE-LENGTH, use 192 (not 191).  The value ;;                should indicate length not an offset.  (PROG NIL    (COND ((NULL WD) (RETURN NIL))  ((ATOM WD) (GO S1))  ((EQ (CAR WD) 'RESTART-TAG) (SETQ WD (CADR WD)) (GO S1))  ((EQ (CAR WD) 'QTAG)   (WHEN (EQ (CADR WD) 'QUOTE-BASE)     (IF (COMPILING-FOR-V2) (SETQ SHORT-FEF-MAX-QUOTE-LENGTH (- 192 (TRUNCATE ADR 2)))       (SETQ SHORT-FEF-MAX-QUOTE-LENGTH MOST-POSITIVE-FIXNUM))     )   (DEFLAPSYM (CADR WD) (TRUNCATE ADR 2) 'TDEF)   (WHEN (and (compiling-for-v2)      (EQ (CADR WD) 'QUOTE-BASE))     (SETF QB (QLEVAL 'QUOTE-BASE T)))   (RETURN ADR))  ((EQ (CAR WD) 'BRANCH)   ;;the following clause added 1/30/86 by CLM   ;;'pushj was an arbitrary choice, it may change   (IF (EQ (CADR WD) 'PUSHJ)       (DEFLAPSYM (CAR (LAST WD)) ADR 'BRANCH-PUSHJ)     (DEFLAPSYM (CAR (LAST WD)) ADR 'BRANCH))   (GO X1))  ((EQ (CAR WD) 'PARAM)   (IF (EQ (CADR WD) 'LLOCBLOCK)       (PROGN (SETF (FEF-HEADER-LOCAL-LENGTH QLP-FEF-HEADER) (CADDR WD)) (WHEN (COMPILING-FOR-V2)   (COMPUTE-FEF-HEADER)   (UNLESS (NULL (FEF-HEADER-LONG-ARGS QLP-FEF-HEADER))     ;; The long-args word will be present.     (INCF ADR 2))) (RETURN NIL))     (RETURN (SETF (LAP-VALUE (CADR WD)) (QLEVAL (CADDR WD) T)))))  ((MEMBER (CAR WD) '(ENDLIST COMMENT NO-DROP-THROUGH) :TEST #'EQ) (RETURN NIL))  ((EQ (CAR WD) 'MFEF)   (SETQ ALLVARS (FOURTH WD) FREEVARS (FIFTH WD))   (SETQ SPECVARS (EXTRACT-SPECVARS)) (SCAN-ARGS) (COMPUTE-A-D-L-NEEDED-P)   (INCF ADR (* 2 (SYMEVAL-FOR-TARGET '%FEF-HEADER-LENGTH))) (RETURN NIL))  ((EQ (CAR WD) 'S-V-BLOCK)   (SETQ ADR (+ ADR (* 2 (LENGTH SPECVARS))))   (RETURN NIL))  ((EQ (CAR WD) 'CONSTRUCT-MACRO) (RETURN NIL))  ((EQ (CAR WD) 'A-D-L)   (SETQ ADR (QLP-A-D-L ADR NIL))   (RETURN NIL))  ((EQ (CAR WD) 'DEBUG-INFO)   (SETF (FEF-HEADER-DEBUG-INFO QLP-FEF-HEADER) (CDR WD))   (UNLESS (COMPILING-FOR-V2)     (INCF ADR 2))   (RETURN ADR))  ((EQ (CAR WD) 'VARIABLES-USED-IN-LEXICAL-CLOSURES)   (RETURN (SETQ ADR (+ 2 ADR))))  ((EQ (CAR WD) 'SELF-FLAVOR)   (SETF (FEF-HEADER-SELF-FLAVOR QLP-FEF-HEADER) (CADR WD))   (WHEN (COMPILING-FOR-V2)     (SETF (FEF-HEADER-HEADER QLP-FEF-HEADER)   (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-SELF-MAPPING-TABLE)    (FEF-HEADER-HEADER QLP-FEF-HEADER))))   (RETURN (SETQ ADR (+ 2 ADR))))  ((MEMBER (CAR WD) '(QUOTE LOCATIVE-TO-S-V-CELL FIXE TAG) :TEST #'EQ)   (RETURN (SETQ ADR (+ 2 ADR))))  ((EQ (CAR WD) 'BREAKOFFS) (RETURN NIL))  ((EQ (CAR WD) 'ADI-CALL)   (LAP-P1-ADI (CDR WD))   (RETURN NIL))  ;;added 12/17/85 by CLM for rel.3 to adjust the current adr  ;;and the symtab adrs for a dispatch table.  ((EQ (CAR WD) 'DISPATCH)   (LET ((TEM (LAP-SYMTAB-PLACE 'PROGSA)))     (LAP-SYMTAB-RELOC (CADDAR TEM) (* 2 (+ (LENGTH (CADDR WD)) 2)) (CDR SYMTAB))     (PUSH (CDR WD) DISPATCH-LIST)     (INCF ADR (* 2 (+ (LENGTH (CADDR WD)) 2))))   (GO X1))  ((eq (car wd) 'select)   (let ((tem (lap-symtab-place 'progsa)))     (lap-symtab-reloc (caddar tem)       ;;the length of the pc-array should equal the length of       ;;the value-array       ;;the other 3 words are for the length of the select table       ;;the max dispatch index and the otherwise pc       (* 2 (+ (* 2 (length (caddr wd))) 3))       (cdr symtab))     (push (cdr wd) dispatch-list)     (incf adr (* 2 (+ (* 2 (length (caddr wd))) 3)))     )   (go x1))    (T (LAP-ADR-P1 (CADDR WD) WD) (GO X1)))    X1    (RETURN (SETQ ADR (1+ ADR)))    S1    (RETURN (DEFLAPSYM WD ADR 'TDEF))))(DEFUN LAP-P1-ADI (X)  (PROG (L ADI)    (SETQ ADI (CADDDR X))    (MAPC-ALTERNATE #'LAP-ADR-P1             ;ODD POSITIONS OF ADI LIST    (CDR ADI))    (SETQ L 1)                               ;A MISC (OF SOME SORT)    (UNLESS (AND (EQ (CAR-SAFE (CADDR X)) 'QUOTE-VECTOR) (MEMBER (CADR (CADDR X)) '((FUNCTION *CATCH) (FUNCTION :*CATCH)) :TEST #'EQUAL))      (LAP-ADR-P1 (CADDR X))      (SETQ L (1+ L)));MOVE D-PDL <FUNCTION ..>    (WHEN (MEMQ-ALTERNATE 'RESTART-PC ADI)      (SETQ L (1+ L)));MOVE D-PDL <TAG XXX>    (WHEN (MEMQ-ALTERNATE 'MULTIPLE-VALUE ADI)      (SETQ L (1+ L)))    (SETQ ADR (+ ADR L))    (RETURN L))) (DEFUN LAP-P2-ADI (X)  (PROG (ADI TM MISC-TYPE)(SETQ MISC-TYPE (CAR X));TYPE CALL INST WOULD HAVE USED(SETQ ADI (CADDDR X))(IF (NOT      (AND (EQ (CAR-SAFE (CADDR X)) 'QUOTE-VECTOR)   (MEMBER (SETQ TM (CADR (CADDR X)))   '((FUNCTION *CATCH) (FUNCTION :*CATCH)) :TEST #'EQUAL)))    (QLP2-U (LIST 'MOVE 'D-PDL (CADDR X)))  (SETQ MISC-TYPE '%CATCH-OPEN))(WHEN (SETQ TM (MEMQ-ALTERNATE 'RESTART-PC ADI))  (QLP2-U (LIST 'MOVE 'D-PDL (CADR TM)))  (UNLESS (MEMBER MISC-TYPE '(%CATCH-OPEN) :TEST #'EQ)    (BARF TM 'BAD-ADI-CALL-WITH-RESTART-PC 'BARF)))(WHEN (MEMQ-ALTERNATE 'FEXPR-CALL ADI)  (UNLESS (EQ MISC-TYPE 'CALL)    (BARF MISC-TYPE 'BAD-FEXPR-ADI 'BARF))  (SETQ MISC-TYPE '%FEXPR-CALL))(WHEN (MEMQ-ALTERNATE 'LEXPR-CALL ADI)  (UNLESS (EQ MISC-TYPE 'CALL)    (BARF MISC-TYPE 'BAD-LEXPR-ADI 'BARF))  (SETQ MISC-TYPE '%LEXPR-CALL))(WHEN (SETQ TM (MEMQ-ALTERNATE 'MULTIPLE-VALUE ADI))  (QLP2-U (LIST 'MOVE 'D-PDL (CADR TM)))  (SETQ MISC-TYPE(CDR (ASSOC MISC-TYPE '((CALL . %CALL-MULT-VALUE)(CALL0 . %CALL0-MULT-VALUE)(%FEXPR-CALL . %FEXPR-CALL-MV)(%CATCH-OPEN . %CATCH-OPEN-MV)) :TEST #'EQ))))(WHEN (MEMQ-ALTERNATE 'MULTIPLE-VALUE-LIST ADI)  (SETQ MISC-TYPE (CDR (OR (ASSOC MISC-TYPE  '((CALL . %CALL-MULT-VALUE-LIST)    (CALL0 . %CALL0-MULT-VALUE-LIST)    (%FEXPR-CALL . %FEXPR-CALL-MV-LIST)    (%CATCH-OPEN . %CATCH-OPEN-MV-LIST))  :TEST #'EQ)   (BARF MISC-TYPE 'CALL-TYPE-ILLEGAL-WITH-MULTIPLE-VALUE-LIST 'BARF)))))(WHEN (MEMBER MISC-TYPE '(NIL CALL CALL0) :TEST #'EQ)  (BARF X 'BAD-ADI 'BARF))(QLP2-U (LIST 'MISC (CADR X) MISC-TYPE))(RETURN NIL))) (DEFUN MAPC-ALTERNATE (FN LST)  (PROG NIL    L    (WHEN (NULL LST)      (RETURN NIL))    (FUNCALL FN (CAR LST))    (WHEN (NULL (SETQ LST (CDR LST)))      (RETURN NIL))    (SETQ LST (CDR LST))    (GO L)))                                                                                                                 ;; Return position of ITEM in constants page, or NIL if it doesn't appear there.(PROCLAIM '(INLINE QFIND-CONSTANTS-PAGE)) (DEFUN QFIND-CONSTANTS-PAGE (ITEM)  (AND (EQ (CAR ITEM) 'QUOTE) (ATOM (CADR ITEM))     (POSITION (CADR ITEM) (THE LIST CONSTANTS-PAGE) :TEST #'EQ)))               ;; On pass 1, add an entry for the constant X to the quote vector if necessary.;; It is necessary if X is not in the constants page, and not already in the;; quote vector,;; or if X is a load-time eval.(DEFUN QADD (X &OPTIONAL WD)  ;;  3/05/86 CLM - If number of constants is greater than max allowed in a "short"  ;;                fef, must use the PUSH-LONG-FEF instruction perhaps in conjunction   ;;                with the original instruction.  If two instructions are needed,   ;;                incf the adr to account for the second instruction.  ;;  3/07/86 CLM - Change WD to an optional argument to prevent breakage by old  ;;                style adi-call's.  ;;  6/20/86 CLM - If the constant is already in the quote-list, check to see if the  ;;                instruction will require the use of PUSH-LONG-FEF; i.e., the  ;;                constant occurs in the quote-list at a point beyond SHORT-FEF-MAX-  ;;                QUOTE-LENGTH.  ;;  7/23/86 CLM - Changed the handling of instructions containing constants.  Now the  ;;                fef offset of the constant is placed into the instruction itself  ;;                during pass 1.  This makes the pass 2 function LAP-QUOTE-ADR no   ;;                longer necessary.  The format of the quote-list has also changed  ;;                - consing the quote-count onto an entry is no longer necessary.  ;;                QB holds the offset of the quote-base.  This is for Rel. 3 only.  (DECLARE (INLINE ASSOC))  (LET ( #-Common-Lisp (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T)TM)    (OR (NULL X)(AND (LAP-VALUE 'CONST-PAGE)   ;not there in rel.3     (QFIND-CONSTANTS-PAGE X))(IF (COMPILING-FOR-V2)    (OR      (NUMBERP X)  ;to prevent problems from an istruction already modified      (PROGN(AND (NOT (CONTAINS-LOAD-TIME-EVAL X))     (SETQ TM (POSITION X (THE LIST QUOTE-LIST) :TEST #'EQUAL))   ;it's already on the list     (SETF (CADR (THIRD WD))   (+ QB (- QUOTE-LIST-LENGTH TM 1)) )     (PROG1       T       (WHEN (> (- QUOTE-LIST-LENGTH TM)SHORT-FEF-MAX-QUOTE-LENGTH)  (UNLESS (AND (EQ (CAR WD) 'MOVE)      (EQ (CADR WD) 'D-PDL))   (INCF ADR) ) ))))      (PROGN(PUSH X QUOTE-LIST)(INCF QUOTE-LIST-LENGTH)(SETF (CADR (THIRD WD)) (+ QUOTE-COUNT QB))(WHEN (> QUOTE-LIST-LENGTH SHORT-FEF-MAX-QUOTE-LENGTH)  (UNLESS (AND (EQ (CAR WD) 'MOVE)       (EQ (CADR WD) 'D-PDL))    (INCF ADR)    ))(SETQ QUOTE-COUNT (1+ QUOTE-COUNT)))  )   ;or    (OR       (PROGN(SETQ QUOTE-COUNT (1+ QUOTE-COUNT))(AND (NOT (CONTAINS-LOAD-TIME-EVAL X))     (SETQ TM (ASSOC X QUOTE-LIST :TEST #'EQUAL))     (PROG1       T       (WHEN (> (- QUOTE-LIST-LENGTH         (POSITION TM (THE LIST QUOTE-LIST) :TEST #'EQ))SHORT-FEF-MAX-QUOTE-LENGTH)  (UNLESS (AND (EQ (CAR WD) 'MOVE)      (EQ (CADR WD) 'D-PDL))   (INCF ADR) ) ))))            (PROGN(PUSH (CONS X QUOTE-COUNT) QUOTE-LIST)(INCF QUOTE-LIST-LENGTH)(WHEN (> QUOTE-LIST-LENGTH SHORT-FEF-MAX-QUOTE-LENGTH)  (UNLESS (AND (EQ (CAR WD) 'MOVE)       (EQ (CADR WD) 'D-PDL))    (INCF ADR))) ) )    ))));; Return T if FORM contains a load-time eval (#,) or other special;; marker that means it should not be made EQ to things that look equal.(DEFUN CONTAINS-LOAD-TIME-EVAL (FORM)  (DECLARE (OPTIMIZE SPEED) (INLINE CONTAINS-LOAD-TIME-EVAL))  (DO ((F FORM (CDR F)))      ((ATOM F)       NIL)    (AND (OR (AND FASD-MAGIC-AREAS-ALIST (ASSOC (%AREA-NUMBER F) FASD-MAGIC-AREAS-ALIST :TEST #'EQ))     (IF (ATOM (CAR F)) (ASSOC (CAR F) FASD-MARKERS-ALIST :TEST #'EQ)       (CONTAINS-LOAD-TIME-EVAL (CAR F)))) (RETURN T)))) (DEFUN LAP-QUOTE-ADR (ITEM) ;;  6/27/85 - Modified order of tests for efficiency. ;;  9/21/85 - No constants page for release 3.  (LET ( #-Common-Lisp (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T) ;for EQUALTM(CONST-PAGE (LAP-VALUE 'CONST-PAGE)))    (COND ((AND (NOT (NULL CONST-PAGE))(SETQ TM (QFIND-CONSTANTS-PAGE ITEM)))   (+ TM CONST-PAGE))  ((PROGN     (SETQ QUOTE-COUNT (1+ QUOTE-COUNT))     (DO ((IDX 0 (1+ IDX))  (QUOTE-LIST QUOTE-LIST (CDR QUOTE-LIST))) ((NULL QUOTE-LIST)  (SETQ TM NIL))       (AND (EQUAL ITEM (CAAR QUOTE-LIST))    (OR (= QUOTE-COUNT (CDAR QUOTE-LIST))(NOT (CONTAINS-LOAD-TIME-EVAL ITEM)))    (RETURN (SETQ TM IDX)))))   (+ TM (QLEVAL 'QUOTE-BASE T)))  (T (BARF ITEM "NOT-ON-QUOTE-LIST" 'BARF) 0)))) ;Var is either the name or the index of a special variable.(DEFUN LAP-SPECIAL-ADR (VAR)  (PROG (TM)    (COND ((NUMBERP VAR) (RETURN (+ VAR (QLEVAL 'S-V-BASE T))))  ((SETQ TM (POSITION VAR (THE LIST SPECVARS) :TEST #'EQ))   (RETURN (+ TM (QLEVAL 'S-V-BASE T))))  (T (BARF VAR 'NOT-ON-SPECIAL-VAR-LIST 'BARF) (RETURN 0))))) ;QLAP SYMBOL TABLE..; IS A LIST, STARTING FROM (CDR SYMTAB); ORDER IS IMPORTANT. ON PASS 1 IT IS IN REVERSE ORDER FROM THAT IN WHICH; ENTIRES WHERE MADE. IT IS NREVERSE D PRIOR TO PASS2.;ENTRIES ARE OF TWO TYPES, DEFINITIONS OF SYMBOLS AND NOTATIONS THAT A; BRANCH WHICH MIGHT TAKE TWO "WORDS" OCCURRED.  THESE LATER ARE REMOVED AS; SOON AS IT CAN BE DETERMINED THAT THE BRANCH CAN DEFINITELY "MAKE IT" IN; ONE WORD (IE MAGNITUDE OF DELTA IS < OR = 377).;EACH ENTRY IS A 3 LIST, SYM TYPE VAL.  TYPE IS EITHER TDEF OR BRANCH.; VAL IS VALUE IF TYPE IS SYM, OR THE ADR OF THE BRANCH IF TYPE IS BRANCH.(DEFUN LAP-SYMTAB-PLACE (SYM)  (PROG (STP)    (SETQ STP (CDR SYMTAB))    L    (COND ((NULL STP) (BARF SYM 'CANT-FIND-PLACE 'BARF))  ((EQ (CAAR STP) SYM) (RETURN STP)))    (SETQ STP (CDR STP))    (GO L))) (DEFUN LAP-SYMTAB-RELOC (BOTTOM AMT STP);RELOCATE SYMTAB ITEMS IN SYMTAB SEGMENT POINTED;TO BY STP BY AMOUNT AMT  (PROG (TEM);IF THEY ARE .GE. BOTTOM(SETQ TEM STP)     A(COND ((NULL TEM) (RETURN NIL))      ((NOT (< (CADDAR TEM) BOTTOM))       (RPLACA (CDDAR TEM) (+ AMT (CADDAR TEM)))))(SETQ TEM (CDR TEM))(GO A)))                                                                                                                (DEFUN DEFLAPSYM (SYM VAL TYPE)  ;;  1/30/86 CLM - Modified to handle LONG-PUSHJ long branches  ;;  4/04/86 CLM - Prevent a branch instruction to itself from  ;;                being compiled into a long-branch instruction.  ;;                Also emit a warning for such cases that an infinite   ;;                loop has been created.  (PROG (STP NBR TM)(SETQ STP SYMTAB)(SETQ NBR 0)     L(COND ((NULL (CDR STP)) (GO L1))      ((EQ (CAADR STP) SYM) (GO L2))      ((MEMBER (CADADR STP) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ)       (SETQ NBR (1+ NBR))))     L3(SETQ STP (CDR STP))(GO L)     L1(RETURN (RPLACD SYMTAB (CONS (LIST SYM TYPE VAL) (CDR SYMTAB))))     L2(COND ((MEMBER TYPE '(BRANCH BRANCH-PUSHJ) :TEST #'EQ)       (GO L2C))      ((MEMBER (CADADR STP) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ)       (GO L2A));NOW DEFINING SYM BRANCHED TO THEN;  ((AND (EQ (CADADR STP) 'TDEF);        (EQ TYPE 'TDEF));        (RETURN (RPLACA (CDDADR STP) VAL)))           ;REDEFINING      (T (BARF (LIST SYM VAL TYPE) 'MULT-DEF 'DATA)))     L2A(UNLESS (EQ TYPE 'TDEF)  (BARF TYPE 'BAD-TYPE 'BARF))(SETQ TM (+ VAL NBR));HIGHEST POSSIBLE VALUE     L2B(COND ((EQ (CADADR STP) 'BRANCH-PUSHJ))      ((< (- TM (CADDR (CADR STP))) 255)       (RPLACD STP (CDDR STP));short branches removed here       (GO L)));THAT BRANCH WILL MAKE IT(GO L3);MAYBE IT WONT     L2C(COND ((MEMBER (CADADR STP) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ)       (GO L1));THAT BRANCH DIDNT MAKE IT;SO THIS ONE WONT      ((= VAL (CADDR (CADR STP)))       (IF (COMPILING-FOR-V2)   (PROGN     (WARN 'DEFLAPSYM :IMPLAUSIBLE "AN INFINITE LOOP HAS BEEN CREATED.")     (RETURN NIL)) (GO L1)));EITHER JMP . LOSES!      ((EQ TYPE 'BRANCH-PUSHJ));force a long branch      ((< (- (+ VAL NBR) (CADDR (CADR STP))) 255) (RETURN NIL)));THIS ONE DEFINITELY MAKES IT(GO L1))) (DEFUN LAP-WORD-EVAL (WORD)  ;;  7/10/85 - Modified for release 3 instruction set.  ;;  7/20/85 - Keep MISC-op values separate from main opcodes.  ;;  8/10/85 - Add case for AUX-op.  ;;  8/21/85 - Re-instate EXTENDED-ADDRESS; eliminate use of PROG;  ;;            add debug calls to WARN.  ;;  9/26/85 - Add special handling for AREFI and MODULE-GROUP;  ;;            modify destination handling for CALL.  ;;  3/05/86 - CLM Add special handling for fef offsets greater than  ;;            191.  ;;  7/23/86 CLM - No longer call LAP-QUOTE-ADR to get offset of constants.  This  ;;                is now handled in pass 1.  For Rel. 3 only.  ;; 10/11/86 DNG - Permit misc-op numbers instead of names.  (DECLARE (INLINE GET-FOR-TARGET #-compiler:debug LAP-VALUE)   (OPTIMIZE (SPEED 2) (SPACE 1)))  (LET ((WD WORD)(VL 0)TM)    (IF (EQ (FIRST WD) 'EXTENDED-ADDRESS); used for FIXE in ADL;; Handle (EXTENDED-ADDRESS dest (SELF-REF index));; Index must be split into two parts, and put into VL.;; Leave WD set to (dest SELF-REF) so that those are added in.(LET ((INDEX (CADR (CADDR WD))))  (SETQ VL (+ (LSH (LDB (BYTE 4 6) INDEX) 9) (LDB (BYTE 6 0) INDEX)))  (SETQ WD (LIST (CADR WD) (CAR (CADDR WD)))))      (IF (COMPILING-FOR-V2)  ;; Compiling for Explorer release 3 and later.  (CASE (FIRST WD)(MOVE (SETQ VL       (LAP-VALUE (CASE (SECOND WD)       ((D-INDS D-IGNORE 0) 'TEST)       (D-PDL 'PUSH)       (D-RETURN 'RETURN)       #+compiler:debug       ((D-LAST D-NEXT) 'PUSH); temporary until *CATCH is updated       (OTHERWISE (BARF (SECOND WD) "invalid destination" 'BARF))))) (SETQ WD (CDDR WD)))(MISC (SETQ VL       (LAP-VALUE (CASE (SECOND WD)       (D-PDL 'PUSH-MISC-GROUP)       ((D-INDS D-IGNORE 0) 'TEST-MISC-GROUP)       #+compiler:debug       ((D-RETURN D-NEXT D-LAST)(WARN 'LAP-WORD-EVAL :BUG "Invalid destination:  ~A" WORD)(RETURN-FROM LAP-WORD-EVAL 0))       (OTHERWISE (BARF WD "invalid destination" 'BARF))))) (LET ((MISCVAL (THIRD WD)))   (UNLESS (FIXNUMP MISCVAL)     (SETQ MISCVAL (MISC-OP-EVAL MISCVAL))     #+compiler:debug     (WHEN (NULL MISCVAL)       (WARN 'LAP-WORD-EVAL :BUG "Undefined Misc-op:  ~A" WORD)       (RETURN-FROM LAP-WORD-EVAL 0)))   (SETQ VL (+ VL MISCVAL))) (SETQ WD (CDDDR WD)));; (CALL dest function count)(CALL (SETQ VL       (DPB (LAP-VALUE (SECOND WD)) (SYMEVAL-FOR-TARGET '%%QMI-CALL-DEST)    (DPB (FOURTH WD); number of arguments (SYMEVAL-FOR-TARGET '%%QMI-CALL-NUMARGS) (LAP-VALUE 'CALL-0)))) (SETQ WD (LIST (THIRD WD))));; (CALL-N dest function)(CALL-N (SETQ VL       (DPB (LAP-VALUE (SECOND WD)) (SYMEVAL-FOR-TARGET '%%QMI-CALL-DEST)    (LAP-VALUE 'CALL-N))) (SETQ WD (CDDR WD)))(BRANCH NIL)(AUX (SETQ WD (CDR WD)));;  (AREFI dest operation index)(AREFI (SETQ VL       (LOGIOR (LAP-VALUE   (CASE (SECOND WD) (D-PDL 'PUSH-AREFI) ((D-INDS D-IGNORE 0) 'TEST-AREFI) #+compiler:debug ((D-RETURN D-NEXT D-LAST)  (WARN 'LAP-WORD-EVAL :BUG "Invalid destination:  ~A" WORD)  (RETURN-FROM LAP-WORD-EVAL 0)) (OTHERWISE (BARF WD "invalid destination" 'BARF)))) (GET (THIRD WD) 'AREFI))) (SETQ WD (CDDDR WD)))(MODULE-GROUP (SETQ VL       (LAP-VALUE (CASE (SECOND WD)       (D-PDL 'PUSH-MODULE-GROUP)       ((D-INDS D-IGNORE 0) 'TEST-MODULE-GROUP)       #+compiler:debug       ((D-RETURN D-NEXT D-LAST)(WARN 'LAP-WORD-EVAL :BUG "Invalid destination:  ~A" WORD)(RETURN-FROM LAP-WORD-EVAL 0))       (OTHERWISE (BARF WD "invalid destination" 'BARF))))) (SETQ WD (CDDR WD)))((SELECT DISPATCH) (WARN 'LAP-WORD-EVAL :IMPLEMENTATION-LIMIT       "QLAPP does not yet support the ~S instruction." (FIRST WD)) (SETQ VL (LAP-VALUE (FIRST WD))) (SETQ WD NIL))(OTHERWISE (SETQ VL (IF (SYMBOLP (FIRST WD))      (LAP-VALUE (FIRST WD))    (FIRST WD))) #+compiler:debug (UNLESS (FIXNUMP VL)   (WARN 'LAP-WORD-EVAL :BUG "Undefined instruction:  ~A" WORD)   (RETURN-FROM LAP-WORD-EVAL 0)) (SETQ WD (CDR WD))));; Else, compiling for Explorer release 1.(COND ((EQ (CAR WD) 'SETE)       (SETQ VL (+ 37888   (CDR (ASSOC (CADR WD)       '((CDR . 0) (CDDR . 8192) (1+ . 16384) (1- . 24576)) :TEST #'EQ))))       (SETQ WD (CDDR WD)))      ;;  (AREFI dest operation index)      ((EQ (CAR WD) 'AREFI)       (SETQ VL     (LOGIOR (LAP-VALUE (FIRST WD))     (LAP-VALUE (SECOND WD))     (GET (THIRD WD) 'AREFI)))       (SETQ WD (CDDDR WD)))))); end of IFs    (LOOP      (COND ((NULL WD) (RETURN-FROM LAP-WORD-EVAL VL))    ((NUMBERP (SETQ TM (CAR WD))))    ((ATOM (CAR WD))     (WHEN (NULL (SETQ TM (LAP-VALUE (CAR WD))))       (BARF WD 'UNDEFINED-IN-WORD 'BARF)       (SETQ TM 0)))    ((EQ (CAAR WD) 'QUOTE-VECTOR)     (if (compiling-for-v2) (SETQ TM  (CADAR WD))       (setq tm (lap-quote-adr (cadar wd))))     ;;if tm > #o277 then need to do long-fef     ;;addressing.     (WHEN (AND (COMPILING-FOR-V2) (> TM 191))       (LET ((VL2 (LAP-VALUE 'PUSH-LONG-FEF))) (SETQ VL2 (+ VL2 TM)) (IF (= VL (LAP-VALUE 'PUSH))     ;;don't need the extra push inst     (RETURN-FROM LAP-WORD-EVAL VL2)   (PROGN     (LAP-OUTPUT-WORD VL2)     (SETQ ADR (1+ ADR))     (SETQ TM (LAP-VALUE 'PDL-POP)))))))    ((EQ (CAAR WD) 'SPECIAL)     (SETQ TM (LAP-SPECIAL-ADR (CADAR WD))))    (T (SETQ TM (QLEVAL (CAR WD) NIL))))      (SETQ VL (+ VL TM)) (SETQ WD (CDR WD))); end of DO-FOREVER    )); end of LAP-WORD-EVAL(DEFUN QLEVAL (X FLAG);FLAG ->T, USE SYMTAB, NIL-> QLVAL PROPS ;;  1/30/86 CLM - Modified for LONG-PUSHJ long branches.  (DECLARE (OPTIMIZE SPEED) (INLINE GET-FOR-TARGET #-compiler:debug LAP-VALUE))  (PROG (VL)    (SETQ VL 0)    (COND      ((NUMBERP X) (RETURN X))      ((ATOM X) (GO S1)))    L1    (SETQ VL (+ (QLEVAL (CAR X) FLAG) VL))    (WHEN (NULL (SETQ X (CDR X)))      (RETURN VL))    (GO L1)    S1    (COND      (FLAG (GO S1A))      ((NULL (SETQ VL (LAP-VALUE X))) (GO S1A))      (T (RETURN VL)))    S1A    (SETQ VL SYMTAB)    S2    (COND      ((NULL (CDR VL)) (GO E1))      ((AND (EQ (CAADR VL) X)    (NOT (MEMBER (CADADR VL) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ)))       (RETURN (CADDR (CADR VL)))))    (SETQ VL (CDR VL))    (GO S2)    E1    (BARF X 'UNDEFINED 'DATA))) (DEFUN QLRLC (ENTRY AMT)  (UNLESS (= 0 AMT)    (RPLACA (CDDR ENTRY) (+ AMT (CADDR ENTRY)))))                                                                                                                 (DEFUN QB2 (CONDITION TAG) ;;  7/23/85 - Modifed for Explorer release 3. ;; 12/05/85 CLM - Modified for Rel.3 to output the correct ;;                long-branch instructions. ;;  1/20/86 CLM - Corrected for long branches to use absolute ;;                addressing instead of relative. ;;  1/30/86 CLM - Modified for LONG-PUSHJ long branches. ;;  1/16/87 CLM - Fixed to not barf on infinite loops in Rel3.  (LET (VL TM2)    (IF (EQL (CAR CONDITION) 'PUSHJ)(SETQ VL (LSH (LAP-VALUE 'LONG-PUSHJ) 9))      (SETQ VL    (CDR      (ASSOC CONDITION (GET-FOR-TARGET (FIRST CONDITION) 'DEF-BRANCH-OP) :TEST #'EQUAL))))    (WHEN (NULL VL)      (BARF CONDITION 'NON-EXISTANT-CONDITION 'BARF))    (SETQ TM2 (- (QLEVAL TAG T) ADR))    (COND      ((NULL (CDR SYMPTR)))      ((AND (EQ (CAADR SYMPTR) TAG)    (MEMBER (CADADR SYMPTR) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ)    (= ADR (CADDR (CADR SYMPTR))))       (SETQ SYMPTR (CDR SYMPTR));COMMITTED TO 2 WD BRANCH       (IF (COMPILING-FOR-V2)   (LAP-OUTPUT-WORD (LSH VL -9)) (LAP-OUTPUT-WORD (+ 511 VL)))       (SETQ ADR (1+ ADR))       (LAP-OUTPUT-WORD (LOGAND 65535 (IF (COMPILING-FOR-V2)  (QLEVAL TAG T)(- TM2 2)))#+compiler:debug T);- NUMBERS DONT WIN!       (RETURN-FROM QB2 NIL));-1 BECAUSE PC IS INCREMENTED                                       ; ANOTHER -1 BECAUSE ADR IS 1 MORE NOW      ((OR (AND (NOT (COMPILING-FOR-V2))       (= 0 TM2))                      ;in Rel3 indicates an infinite loop   (> (ABS TM2) 254))       (BARF (LIST TAG TM2) 'NOT-IN-RANGE 'BARF)))    (LAP-OUTPUT-WORD (+ VL (LOGAND 511 (1- TM2))))))(DEFUN MEMQ-ALTERNATE (X Y)  (PROG ()    L    (COND      ((NULL Y) (RETURN NIL))      ((EQ X (CAR Y)) (RETURN Y)))    (SETQ Y (CDDR Y))    (GO L)))     $                                                              $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $      $      $      $      $      $      $      $      $       $       $       $       $       $       $       $       $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $       $       $       $       $       $       $       $       $      $      $      $      $      $      $      $      $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   