(FILECREATED " 3-Jan-84 13:30:59" {PHYLUM}<LISPCORE>SOURCES>BYTECOMPILER.;26 164223
changes to: (FNS OPT.INITHASH)
previous date: "17-Dec-83 04:22:50" {PHYLUM}<LISPCORE>SOURCES>BYTECOMPILER.;24)
(* Copyright (c) 1981, 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT BYTECOMPILERCOMS)
(RPAQQ BYTECOMPILERCOMS [(* THE BYTE LISP COMPILER)
(COMS (FNS BYTEBLOCKCOMPILE2 BYTECOMPILE2 COMP.ATTEMPT.COMPILE COMP.RETFROM.POINT COMPERROR
COMPPRINT COMPERRM)
(FNS COMP.TOPLEVEL.COMPILE COMP.BINDLIST COMP.CHECK.VAR COMP.BIND.VARS COMP.UNBIND.VARS)
(FNS COMP.VALN COMP.PROGN COMP.DELPOPP COMP.EXP1 COMP.EXPR COMP.TRYUSERFN COMP.USERFN
COMP.CONST COMP.CALL COMP.VAR COMP.VAL1 COMP.PROG1 COMP.EFFECT COMP.VAL COMP.MACRO)
(FNS COMP.VARTYPE COMP.LOOKUPVAR COMP.LOOKUPCONST)
(FNS COMP.ST COMP.STFN COMP.STCONST COMP.STVAR COMP.STPOP COMP.DELFN COMP.STRETURN
COMP.STTAG COMP.STJUMP COMP.STSETQ COMP.STCOPY COMP.DELPUSH COMP.DELPOP
COMP.STBIND COMP.STUNBIND)
(FNS COMP.ARGTYPE COMP.CLEANEXPP COMP.CLEANFNP COMP.CLEANFNOP COMP.GLOBALVARP
COMP.LINKCALLP COMP.ANONP)
(FNS COMP.CPI COMP.CPI1 COMP.PICOUNT)
(PROP BYTEMACRO EVQ)
(FNS COMP.EVQ)
(PROP BYTEMACRO AND OR)
(FNS COMP.BOOL)
(FNS COMP.APPLYFNP)
(PROP BYTEMACRO AC ASSEMBLE ASSEM FLOC)
(FNS COMP.AC COMP.PUNT)
(PROP BYTEMACRO FUNCTION)
(FNS COMP.FUNCTION COMP.LAM1 COMP.GENFN)
(INITVARS (COMP.GENFN.NUM 0)
(COMP.GENFN.BUF (ALLOCSTRING 100)))
(GLOBALVARS COMP.GENFN.NUM COMP.GENFN.BUF)
(PROP BYTEMACRO COND SELECTQ)
(FNS COMP.COND COMP.SELECTQ)
(PROP BYTEMACRO PROGN PROG1)
(PROP BYTEMACRO QUOTE *)
(FNS COMP.QUOTE COMP.COMMENT)
(PROP BYTEMACRO DECLARE)
(FNS COMP.DECLARE COMP.DECLARE1)
(PROP (BYTEMACRO CROPS)
* MCROPS)
(FNS COMP.CARCDR COMP.STCROP)
(PROP BYTEMACRO NOT NULL)
(FNS COMP.NOT)
(PROP BYTEMACRO SETQ SETN)
(FNS COMP.SETQ COMP.SETN)
(FNS COMP.LAMBDA)
(PROP BYTEMACRO PROG GO RETURN)
(FNS COMP.PROG COMP.GO COMP.RETURN)
(VARS NUMBERFNS (GLOBALVARFLG T)
(NEWOPTFLG)
(COMPVERSION (DATE)))
(PROP BYTEMACRO IPLUS ITIMES LOGOR LOGXOR LOGAND IDIFFERENCE IQUOTIENT IREMAINDER
IMINUS LSH LLSH RSH LRSH FIX PLUS DIFFERENCE TIMES QUOTIENT FPLUS FDIFFERENCE
FTIMES FQUOTIENT)
(FNS COMP.NUMERIC COMP.NUMBERCALL COMP.FIX COMP.STFIX COMP.DELFIX)
(PROP BYTEMACRO EQ EQUAL EQP)
(FNS COMP.EQ)
(PROP BYTEMACRO .TEST.)
(FNS COMP.NUMBERTEST)
(PROP BYTEMACRO * MAPFNS)
(PROP BYTEMACRO .DOCOLLECT. .DOJOIN.)
(FNS COMP.MAP)
(PROP BYTEMACRO LISPXWATCH)
(PROP BYTEMACRO FETCHFIELD REPLACEFIELD FFETCHFIELD FREPLACEFIELD REPLACEFIELDVAL
FREPLACEFIELDVAL)
(PROP BYTEMACRO GETPROP)
(PROP BYTEMACRO BLKAPPLY BLKAPPLY*)
(PROP BYTEMACRO ADD1VAR SUB1VAR KWOTE FRPLNODE RPLNODE LISTGET1 FRPLNODE2)
(PROP BYTEMACRO JSYS)
(PROP BYTEMACRO EQMEMB MKLIST)
[COMS (* Pass 1 listing)
(FNS COMP.MLLIST COMP.MLL COMP.MLLVAR COMP.MLLFN)
(VARS COPS)
(IFPROP MLSYM * (PROGN COPS))
(BLOCKS (COMP.MLL COMP.MLL COMP.MLLFN (NOLINKFNS . T]
[COMS (* ARJ - JUMP LENGTH RESOLVER)
(FNS OPT.RESOLVEJUMPS OPT.JLENPASS OPT.JFIXPASS OPT.JSIZE)
(BLOCKS (OPT.RESOLVEJUMPS OPT.RESOLVEJUMPS OPT.JLENPASS OPT.JFIXPASS
(NOLINKFNS . T]
(COMS (* utilities used by all files)
(FNS OPT.CALLP OPT.JUMPCHECK OPT.DREV OPT.CHLEV OPT.CHECKTAG OPT.NOTJUMP
OPT.INITHASH OPT.COMPINIT))
(P (MOVD? (QUOTE NILL)
(QUOTE REFRAME))
(AND (GETD (QUOTE OPT.COMPINIT))
(OPT.COMPINIT)))
(PROP BYTEMACRO LOADTIMECONSTANT)
(PROP BYTEMACRO FRPTQ)
(FNS OPT.CFRPTQ)
(BLOCKS (BYTECOMPBLOCK COMP.ANONP COMP.APPLYFNP COMP.ARGTYPE COMP.BINDLIST
COMP.BIND.VARS BYTEBLOCKCOMPILE2 BYTECOMPILE2 COMP.AC COMP.BOOL
COMP.CALL COMP.COMMENT COMP.COND COMP.CONST COMP.CARCDR
COMP.DECLARE COMP.DECLARE1 COMP.EFFECT COMP.EQ COMP.EXP1
COMP.EXPR OPT.CFRPTQ COMP.FUNCTION COMP.GO COMP.CHECK.VAR
COMP.LAMBDA COMP.LAM1 COMP.MACRO COMP.MAP COMP.NUMBERCALL
COMP.NOT COMP.NUMBERTEST COMP.NUMERIC COMP.CPI COMP.CPI1
COMP.PROG COMP.PROG1 COMP.PROGN COMP.QUOTE COMP.RETURN
COMP.SELECTQ COMP.SETN COMP.SETQ COMP.VAL COMP.VAL1 COMP.VALN
COMP.VAR COMP.DELPOPP COMP.GENFN COMP.LOOKUPVAR
COMP.ATTEMPT.COMPILE COMP.RETFROM.POINT COMP.TOPLEVEL.COMPILE
COMP.PICOUNT COMP.TRYUSERFN COMP.UNBIND.VARS COMP.VARTYPE
(ENTRIES BYTEBLOCKCOMPILE2 BYTECOMPILE2 COMP.VAL1 COMP.VAL
COMP.EFFECT COMP.EXPR COMP.EXP1 COMP.LAM1 COMP.CALL
COMP.LOOKUPVAR COMP.CONST COMP.PROGN)
(BLKAPPLYFNS COMP.AC COMP.BOOL COMP.COMMENT COMP.COND
COMP.CARCDR COMP.DECLARE COMP.EQ COMP.EXP1
COMP.EXPR COMP.FUNCTION COMP.GO COMP.LAM1 COMP.MAP
COMP.NUMBERCALL COMP.NOT COMP.NUMBERTEST
COMP.NUMERIC COMP.PROG COMP.PROG1 COMP.PROGN
COMP.QUOTE COMP.RETURN COMP.SELECTQ COMP.SETN
COMP.SETQ OPT.CFRPTQ)
(SPECVARS AC ALAMS1 ALLVARS ARGS ARGVARS BLKDEFS BLKFLG CODE
COMFN COMFNS COMTYPE CONSTS EFF EMFLAG EXP FRAME
FREELST FREEVARS LAPFLG LBCNT LEVEL LOCALVARS
LOCALVARS LSTFIL MACEXP NLAMS1 PIFN PREDF PROGEFF
PROGRETF RETF RETURNLABEL SPECVARS SPECVARS
SUBFNFREEVARS TAGS TOPFN TOPFRAME TOPLAB VARS
INTERNALBLKFNS)
(RETFNS COMP.VAR COMP.RETFROM.POINT)
(NOLINKFNS COMPPRINT COMPERRM))
(NIL COMP.USERFN COMPERRM (SPECVARS PLVLFILEFLG)))
(PROP BYTEMACRO IMAX2 IMIN2))
(ADDVARS (COMPILETYPELST))
(COMS * POSTOPTCOMS)
(COMS (* CONSISTENCY CHECKS)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS OPT.CCHECK)
(VARS (COMPILECOMPILERCHECKS NIL)))
(FNS OPT.COMPILERERROR OPT.OPTCHECK OPT.CCHECK))
(DECLARE: EVAL@COMPILE DONTCOPY (ALISTS (PRETTYPRINTMACROS CW CWN))
(TEMPLATES CW CWN)
(MACROS CW CWN)
(ADDVARS (NLAML CW)))
(GLOBALVARS ALAMS BLKLIBRARY BYTE.EXT BYTEASSEMFN BYTECOMPFLG COMPILERMACROPROPS CIA
CLEANFNLIST COMP.SCRATCH COMPILETYPELST COMPILEUSERFN COMPSTATLST COMPSTATS
CONDITIONALS CONST.FNS CONSTOPS DONOTHING FILERDTBL FNA FORSHALLOW FRA GLOBALVARS
HEADERBYTES HOKEYDEFPROP LAMBDANOBIND LAMS LBA LEVELARRAY LINKEDFNS LINKFNS
LOADTIMECONSTANT MAXBNILS MAXBVALS MCONSTOPS MERGEFRAMEFLG MERGEFRAMEMAX
MERGEFRAMETYPES MOPARRAY MOPCODES NLAMA NLAML NODARR NOLINKFNS NOSTATSFLG
NUMBERFNS OPCOPY OPNIL OPPOP OPRETURN PRA SELECTQFMEMB SELECTVARTYPES STATAR
STATMAX STATN SYSSPECVARS UNIQUE#ARRAY VCA VCONDITIONALS VREFFRA COUTFILE XVARFLG
MERGEFRAMEFLG OPTIMIZATIONSOFF NOFREEVARSFNS EQCONSTFN MERGEUNBINDFLG NEWOPTFLG)
(DECLARE: DONTCOPY (* for compiling compiler)
EVAL@COMPILE
(RECORDS CODELST)
(PROP MACRO OASSOC)
(RECORDS OP JUMP TAG VAR)
(RECORDS FRAME COMINFO COMP JD))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML OPT.INITHASH)
(LAMA])
(* THE BYTE LISP COMPILER)
(DEFINEQ
(BYTEBLOCKCOMPILE2
(LAMBDA (BLKNAME BLKDEFS ENTRIES) (* JonL "17-Dec-83 03:41")
(COND
((EQ BYTECOMPFLG (QUOTE NOBLOCK)) (* use PDP-10 compiler for blocks)
(RESETVARS (BYTECOMPFLG)
(RETURN (BLOCKCOMPILE2 BLKNAME BLKDEFS ENTRIES))))
(T (PROG ((BLKFLG T)
(INTERNALBLKFNS (AND (NEQ BYTECOMPFLG (QUOTE RETRY))
(for X in BLKDEFS
when (NOT (OR (FMEMB (CAR X)
ENTRIES)
(EQ (CAR X)
BLKNAME)
(FMEMB (CAR X)
RETFNS)
(AND (LISTP NOLINKFNS)
(FMEMB (CAR X)
NOLINKFNS))
(FMEMB (CAR X)
BLKAPPLYFNS)))
collect (CONS (CAR X)
(PACK* (QUOTE \)
BLKNAME
(QUOTE /)
(CAR X)))))))
(* this is a dummy block compiler)
(SETQ COMP.GENFN.NUM 0)
(RETURN (MAPCONC BLKDEFS (FUNCTION (LAMBDA (X)
(PROG1 (COMP.ATTEMPT.COMPILE (OR (CDR (FASSOC (CAR X)
INTERNALBLKFNS))
(CAR X))
(CADDR X)
(CAR X))
(* The FRPLACA allows the function definitions to be reclaimed. This is written to parallel BLOCKCOMPILE2 which
needs the list of BLKDEFS for something. -
rrb)
(FRPLACA (CDDR X)
(LIST (CAR (CADDR X))
(CADR (CADDR X))))))))))))))
(BYTECOMPILE2
(LAMBDA (FN DEF) (* JonL "17-Dec-83 03:41")
(PROG ((BLKFLG NIL))
(SETQ COMP.GENFN.NUM 0)
(COMP.ATTEMPT.COMPILE FN DEF)
(RETURN FN))))
(COMP.ATTEMPT.COMPILE
[LAMBDA (TOPFN DEF RECNAME) (* lmm "13-MAR-81 09:29")
(PROG ((EMFLAG TOPFN)
COMFNS FLG SUBFNFREEVARS)
(CW compile attempt)
(SETQ FLG (COMP.RETFROM.POINT TOPFN DEF RECNAME))
[COND
((NULL EMFLAG)
(LISPXPRIN1 (QUOTE "-----
")
T)
(COND
((NEQ COUTFILE T)
(LISPXPRIN1 (QUOTE "-----
")
COUTFILE]
(COND
(FLG (CW compile succeed)
(RETURN COMFNS))
((AND (GETD (QUOTE COMPILE2))
(NEQ BYTECOMPFLG T))
(CW retry with COMPILE2)
(LISPXPRINT (CONS TOPFN (QUOTE (-- retrying with PDP-10 compiler)))
T T)
[COND
(BLKFLG (OR (EQ SPECVARS T)
(EVAL (CONS (QUOTE SPECVARS)
LOCALFREEVARS]
(RETURN (COMPILE2 TOPFN DEF)))
(T (LISPXPRINT [LIST (CONS TOPFN (QUOTE (not compiled]
T T)
(RETURN])
(COMP.RETFROM.POINT
[LAMBDA (COMFN DEF RECNAME) (* lmm "13-MAR-81 09:29")
(PROG ((LBCNT 0)) (* This is the RETFROM point in case of an error while
compiling COMFN or any of its generated subfunctions.)
(fetch (COMP CLEAR) of T)
(* CLEAR is an accessfn which clears all of the hash tables used by any HASHLINK field in the compiler;
done this way so that the program need not know which hash tables are used)
(RETURN (PROG1 (COMP.TOPLEVEL.COMPILE COMFN DEF RECNAME)
(fetch (COMP CLEAR) of T])
(COMPERROR
[LAMBDA (X) (* lmm: "20-JUL-76 16:35:59")
(AND X (COMPERRM X))
(RETFROM (QUOTE COMP.RETFROM.POINT)
NIL])
(COMPPRINT
[LAMBDA (X) (* wt: " 9-JUL-79 21:09")
(* A separate function so it can be broken or advised)
(PRINT X COUTFILE T])
(COMPERRM
[LAMBDA (X FL) (* rrb "22-JUL-83 12:54")
(AND (NULL FL)
(SETQ FL COUTFILE))
(COND
(EMFLAG (LISPXTAB 0 0 FL)
(LISPXPRIN1 (QUOTE "-----In ")
FL)
(LISPXPRIN2 EMFLAG FL T)
(LISPXPRINT (QUOTE :)
FL)))
[COND
(X (LISPXPRIN1 (QUOTE *****)
FL T)
(PROG ((PLVLFILEFLG T))
(RESETFORM (PRINTLEVEL 2 20)
(LISPXPRINT X FL T]
(COND
((NEQ FL T) (* so message gets printed in both places)
(COMPERRM X T)))
(SETQ EMFLAG NIL])
)
(DEFINEQ
(COMP.TOPLEVEL.COMPILE
[LAMBDA (COMFN DEF RECNAME) (* lmm "16-APR-82 00:29")
(PROG (ALAMS1 NLAMS1 CONSTS ALLVARS ARGVARS ARGS COMTYPE CODE FREEVARS CI (LEVEL 0)
FRAME PIFN TOPLAB (LOCALVARS LOCALVARS)
(SPECVARS SPECVARS)
TOPFRAME MACEXP AC FRELST)
[COND
((SETQ PIFN (GETP COMFN HOKEYDEFPROP))
(CW use hokey definition)
(SETQ DEF (COND
[(EQ PIFN T)
(LIST (CAR DEF)
(CADR DEF)
(QUOTE (DECLARE (LOCALVARS . T)))
(CONS COMFN (CADR DEF]
(T PIFN]
(* * Set COMTYPE {= ARGTYPE of DEF} and ARGS)
RETRY
[OR [AND (LISTP DEF)
(LISTP (CDR DEF))
(SETQ COMTYPE (COND
[(OR (LISTP (SETQ ARGS (CADR DEF)))
(NULL ARGS))
(SELECTQ (CAR DEF)
[NLAMBDA 1]
[LAMBDA 0]
(COND
((AND COMPILEUSERFN (SETQ DEF (APPLY* COMPILEUSERFN NIL DEF)))
(GO RETRY]
(T (COND
((AND LAMBDANOBIND (EQ ARGS (QUOTE NOBIND)))
(SETQ ARGS NIL)
2)
(T (SETQ ARGS (LIST ARGS))
(SELECTQ (CAR DEF)
[LAMBDA 2]
[NLAMBDA 3]
(COND
((AND COMPILEUSERFN (SETQ DEF (APPLY* COMPILEUSERFN NIL DEF)
))
(GO RETRY]
(COMPERROR (CONS COMFN (QUOTE (not compilable]
(SETQ PIFN (COND
((EQ PIFN T) (* compile as call to self)
0)
((GETPROP COMFN OPCODEPROP)
0)
((EQ 0 COMTYPE)
(OR RECNAME COMFN))
(T 0)))
(SETQ FRAME (SETQ TOPFRAME (create FRAME
VARS ←(SETQ ARGVARS (SETQ ALLVARS (COMP.BINDLIST ARGS)))
NNILS ← 0)))
(COMP.STTAG (SETQ TOPLAB (create TAG)))
(COMP.VALN (CDDR DEF)
NIL T)
(COMP.UNBIND.VARS TOPFRAME T)
(SETQ CI (create COMINFO
COMTYPE ← COMTYPE
CODE ←(OPT.POSTOPT CODE)
TOPFRAME ← TOPFRAME
ARGS ← ARGVARS))
[COMPPRINT (CONS COMFN (CONS (CADR DEF)
(NCONC (AND (SETQ FREELST (for X in FREEVARS
when (EQ (fetch OPNAME
of X)
(QUOTE FVAR))
collect (fetch OPARG
of X)))
(LIST (CONS (QUOTE uses:)
FREELST)))
[COND
([SETQ ALAMS1 (SUBSET ALAMS1
(FUNCTION (LAMBDA (X)
(NOT (GETPROP X OPCODEPROP]
(LIST (CONS (QUOTE calls:)
ALAMS1]
(COND
(NLAMS1 (LIST (CONS (QUOTE nlams:)
NLAMS1]
(SELECTQ LAPFLG
((1 T)
(RESETFORM (OUTPUT LSTFIL)
(COMP.MLLIST COMFN CI)))
NIL) (* ASSERT: (CALLS: MASSEM))
(APPLY* BYTEASSEMFN COMFN CI)
[COND
((NEQ COMFN TOPFN)
(CW generated subfunction)
(SETQ SUBFNFREEVARS (APPEND SUBFNFREEVARS FREELST]
(SETQ COMFNS (CONS COMFN COMFNS))
(RETURN COMFN])
(COMP.BINDLIST
[LAMBDA (VARS) (* lmm: "25-OCT-76 17:37:57")
(MAPCAR VARS (FUNCTION (LAMBDA (VAR)
(create VAR
VARNAME ←(COMP.CHECK.VAR VAR T)
COMP.VARTYPE ←(COMP.VARTYPE VAR])
(COMP.CHECK.VAR
[LAMBDA (X BIND) (* lmm: "25-OCT-76 17:35:20")
[AND BIND (COMP.GLOBALVARP X)
(COND
[(NOT FORSHALLOW)
(COMPERRM (CONS X (QUOTE (- is global]
(T (SETQ SPECVARS (CONS X SPECVARS]
(OR (AND (LITATOM X)
(NEQ X T)
X)
(COMPERROR (CONS X (QUOTE (is not a legal variable name])
(COMP.BIND.VARS
[LAMBDA (ARGS VALS TYPE) (* lmm "16-APR-82 00:28")
(PROG (VLV VLN NVALS NNILS)
ALP [COND
[(NULL ARGS)
(COND
(VALS (CW extra values to open lambda)
(COMP.EFFECT (CAR VALS)))
(T (SETQ NNILS (LENGTH VLN))
[COND
((IGREATERP (SETQ NVALS (LENGTH VLV))
MAXBVALS)
(COMPERROR (CONS EXP (QUOTE (-- too many variables with values]
(RETURN (create FRAME
PARENT ← FRAME
NVALS ←(LENGTH VLV)
VARS ←(COMP.BINDLIST (OPT.DREV VLV (OPT.DREV VLN)))
FRAMETYPE ← TYPE
NNILS ← NNILS]
([OR (NULL (CAR VALS))
(PROGN (COMP.VAL (CAR VALS))
(COND
((EQ (CAR CODE)
OPNIL)
(CW prog var value is NIL)
(COMP.DELPUSH)
T]
(SETQ VLN (CONS (CAR ARGS)
VLN)))
(T (SETQ VLV (CONS (CAR ARGS)
VLV]
(SETQ ARGS (CDR ARGS))
(SETQ VALS (CDR VALS))
(GO ALP])
(COMP.UNBIND.VARS
[LAMBDA (F FLG) (* lmm "16-APR-82 00:28")
(COND
((NOT (OR FLG (AND MERGEUNBINDFLG RETF)
(OPT.JUMPCHECK CODE)))
(OPT.CCHECK (EQ F FRAME))
(COMP.STUNBIND EFF)
(replace (FRAME PRIMARYRETURN) of (CAR CODE) with T)))
(QUOTE NOVALUE])
)
(DEFINEQ
(COMP.VALN
[LAMBDA (L EFF RETF PREDF) (* lmm: " 9-AUG-76 18:38:04")
(COMP.PROGN L])
(COMP.PROGN
[LAMBDA (A) (* lmm "16-APR-82 00:28")
(COND
((NULL (CDR A))
(COMP.EXP1 (CAR A)))
(T (PROG [(FLG (COND
((AND RETF (NOT OPTIMIZATIONSOFF)
MERGEUNBINDFLG)
(OR (COMP.DELPOPP)
(CW pop even though higher PROG labels))
T]
LP (COMP.EFFECT (CAR A))
(AND FLG (while (EQ (CAR CODE)
OPPOP)
do (CW delete POP in PROGN)
(COMP.DELPOP)))
(COND
((OPT.JUMPCHECK CODE))
((CDR (SETQ A (CDR A)))
(GO LP))
(T (RETURN (COMP.EXP1 (CAR A])
(COMP.DELPOPP
[LAMBDA NIL (* DD: "27-Jan-81 02:59")
(AND RETF MERGEUNBINDFLG (PROG ((F FRAME))
LP (COND
((EQ F TOPFRAME)
(RETURN T))
((fetch PROGLABELS of F)
(RETURN NIL))
(T (SETQ F (fetch PARENT of F))
(GO LP])
(COMP.EXP1
[LAMBDA (E)
(COMP.EXPR E EFF RETF PREDF])
(COMP.EXPR
[LAMBDA (EXP EFF RETF PREDF) (* bvm: " 6-JAN-83 12:05")
(PROG (M V)
[COND
((NULL FRAME)
(COND
[(OPT.JUMPCHECK CODE)
(RETURN (COND
(PREDF (QUOTE PREDVALUE))
(T (QUOTE NOVALUE]
(T (OPT.COMPILERERROR]
TOP [SETQ V (COND
[(NLISTP EXP)
(COND
((LITATOM EXP)
(SELECTQ EXP
((T NIL)
(COMP.CONST EXP))
(COMP.VAR EXP)))
([OR (NUMBERP EXP)
(PROGN (CW non-quoted string)
(OR [NULL (SETQ M (CDR (FASSOC (TYPENAME EXP)
COMPILETYPELST]
(EQ EXP (SETQ EXP (APPLY* M EXP]
(COMP.CONST EXP))
(T (GO TOP]
[[NOT (LITATOM (SETQ M (CAR EXP]
(SELECTQ (CAR (LISTP M))
([LAMBDA NLAMBDA OPENLAMBDA]
(COMP.LAMBDA M (CDR EXP)))
(OPCODES (COMP.STFN (CAR EXP)
(for X in (CDR EXP) sum (COMP.VAL X)
1)))
(COND
((SETQ M (COMP.TRYUSERFN EXP))
(SETQ EXP M)
(GO TOP))
(T (COMPERROR (CONS M (QUOTE (- non-atomic CAR of form]
((AND (SETQ V (GETMACROPROP M COMPILERMACROPROPS))
(NEQ V T))
(COMP.MACRO EXP V))
((AND RETF (EQ M PIFN))
(COMP.CPI M (CDR EXP)))
((SETQ V (COMP.ARGTYPE M))
(COMP.CALL M (CDR EXP)
V))
((SETQ V (COMP.TRYUSERFN EXP))
(SETQ EXP V)
(GO TOP))
(T (COMP.CALL M (CDR EXP]
(RETURN (COND
(EFF (OR (EQ V (QUOTE NOVALUE))
(COMP.STPOP))
(QUOTE NOVALUE))
(RETF (OR (OPT.JUMPCHECK CODE)
(COMP.STRETURN))
(QUOTE NOVALUE))
(PREDF (COND
((NEQ V (QUOTE PREDVALUE))
(COMP.STJUMP PREDF)))
(QUOTE PREDVALUE])
(COMP.TRYUSERFN
[LAMBDA (EXP M)
(AND COMPILEUSERFN (COND
((EQ (SETQ M (COMP.USERFN EXP))
(QUOTE INSTRUCTIONS))
[COMPERRM (CONS EXP (QUOTE (COMPILEUSERFN returned INSTRUCTIONS]
NIL)
(T M])
(COMP.USERFN
[LAMBDA (X) (* lmm "26-MAY-82 10:10")
(COND
((LITATOM X)
(OR (AND COMPVARMACROHASH (GETHASH X COMPVARMACROHASH))
X))
(T (PROG [(FN TOPFN)
(OTHERVARS (MAPCAR ALLVARS (FUNCTION (LAMBDA (X)
(fetch OPARG of X]
(DECLARE (SPECVARS FN OTHERVARS)) (* uses FN DEF ARGS OTHERVARS)
(RETURN (APPLY* COMPILEUSERFN (CDR X)
X])
(COMP.CONST
[LAMBDA (X) (* bvm: " 6-JAN-83 12:12")
(COND
((AND (NOT OPTIMIZATIONSOFF)
EFF)
(CW CONST in EFF)
(QUOTE NOVALUE))
((AND (NOT OPTIMIZATIONSOFF)
PREDF)
(CW CONST in EFF)
[AND (SELECTQ (fetch OPNAME of PREDF)
(TJUMP X)
(NTJUMP (COND
(X (COMP.STCONST X)
T)))
(FJUMP (NOT X))
(NFJUMP (COND
((NOT X)
(COMP.STCONST X)
T)))
(SHOULDNT))
(COMP.STJUMP (QUOTE JUMP)
(CAR (fetch OPARG of PREDF))
(CDR (fetch OPARG of PREDF]
(QUOTE PREDVALUE))
(T (COMP.STCONST X])
(COMP.CALL
[LAMBDA (F A TYP) (* lmm "16-APR-82 00:28")
(PROG ((N 0))
(OR (fetch EXTCALL of FRAME)
(COMP.CLEANFNOP F (QUOTE FREEVARS))
(replace EXTCALL of FRAME with F))
(SELECTQ TYP
(3 (* call nlambda by applying with entire arglist as first
arg)
(pushnew NLAMS1 F)
(COMP.STCONST A)
(RETURN (COMP.STFN F 1)))
(1 (* call NLAMBDA spread merely by not compiling
arguments)
(pushnew NLAMS1 F))
(NIL (* unknown argtype, assume lambda, but warn user)
(pushnew ALAMS1 F))
NIL)
LP (COND
((LISTP A)
(SELECTQ TYP
(1 (COMP.STCONST (CAR A)))
(COMP.VAL (CAR A)))
(SETQ N (ADD1 N))
(SETQ A (CDR A))
(GO LP))
[A (COMPERROR (CONS A (QUOTE (- unusual CDR arg list]
((OR (NULL TYP)
(EQ TYP 2)) (* for LAMBDA* or unknown types, don't remove extra
NIL's)
(GO ST)))
NON (COND
((AND (IGREATERP N 1)
(EQ (CAR CODE)
OPNIL))
(CW delete NIL before fn call)
(COMP.DELPUSH)
(SUB1VAR N)
(GO NON)))
ST (RETURN (COMP.STFN F N])
(COMP.VAR
[LAMBDA (VAR) (* lmm "16-APR-82 00:19")
(COND
(EFF (CW VAR in EFF)
(QUOTE NOVALUE))
(T (COMP.STVAR (COMP.LOOKUPVAR VAR T])
(COMP.VAL1
[LAMBDA (L EFF RETF PREDF) (* lmm: " 2-AUG-76 03:14:39")
(COMP.PROG1 L])
(COMP.PROG1
[LAMBDA (A) (* lmm: " 1-OCT-76 12:46:23")
(COND
((NULL (CDR A))
(COMP.EXP1 (CAR A)))
(T (PROG1 (COMP.EXPR (CAR A)
EFF)
(MAPC (CDR A)
(FUNCTION COMP.EFFECT])
(COMP.EFFECT
[LAMBDA (E) (* lmm "13-MAR-81 09:35")
(PROG ((LV LEVEL))
(COND
((OPT.JUMPCHECK CODE)
(CW code for effect eliminated after JUMP or RETURN)
(RETURN))
(T (OPT.CCHECK LV)))
(RETURN (PROG1 (COMP.EXPR E T)
(OPT.CCHECK (OR AC (EQ LEVEL LV)
(OPT.JUMPCHECK CODE])
(COMP.VAL
[LAMBDA (X) (* lmm "13-MAR-81 09:36")
(PROG ((LV LEVEL))
(COND
((OPT.JUMPCHECK CODE)
(CW code for value eliminated after JUMP or RETURN)
(RETURN)))
(RETURN (PROG1 (COMP.EXPR X)
(OPT.CCHECK (OR (EQ (ADD1 LV)
LEVEL)
AC
(OPT.JUMPCHECK CODE])
(COMP.MACRO
[LAMBDA (EXP MAC) (* lmm "29-OCT-81 09:02")
(* ASSERT: (CALLS: COMP.SHIFT COMP.NUMERIC COMP.SPREAD COMP.PUSHNILS) (CALLS: CRPLAC CREPLACE CFETCH STCROP CLOC
CVAG CFNOPENR CFNCLOSER COMP.BOOL CAPPLY* COMP.AC COMP.PUNT COMP.FUNCTION COMP.COND COMP.SELECTQ COMP.PROGN
COMP.PROG1 COMP.QUOTE COMP.COMMENT COMP.DECLARE COMP.CARCDR COMP.SETQ COMP.SETN COMP.PROG COMP.GO COMP.RETURN
COMP.EQ COMP.NUMBERTEST COMP.MAP MBERSET CMBARG COMP.NUMERIC COMP.NUMBERCALL))
(COND
[(NLISTP MAC)
(SELECTQ MAC
[T (CW MACRO is T)
(COMP.CALL (CAR EXP)
(CDR EXP)
(COMP.ARGTYPE (CAR EXP]
(COMP.PUNT (COMP.PUNT))
(BLKAPPLY* MAC (CDR EXP]
(T (SELECTQ (CAR MAC)
(APPLY (BLKAPPLY (CADR MAC)
(CDR EXP)))
[APPLY* (BLKAPPLY (CADR MAC)
(CONS (CDR EXP)
(CDDR MAC]
[= (CW MACRO is =)
(COMP.EXP1 (CONS (CDR MAC)
(CDR EXP]
([LAMBDA NLAMBDA OPENLAMBDA]
(CW LAMBDA macro)
(COMP.LAMBDA MAC (CDR EXP)))
(PROG ((MACEXP EXP))
(RETURN (COND
[(OR (NULL (CAR MAC))
(LISTP (CAR MAC)))
(CW expand substitution macro)
[COND
([AND (IGREATERP (LENGTH (CDR EXP))
(LENGTH (CAR MAC)))
(NOT (CDR (LAST (CAR MAC]
(COMPERRM (CONS (CAR EXP)
(QUOTE (- warning: too many args for macro]
(COMP.PROGN (SUBPAIR (CAR MAC)
(CDR EXP)
(CDR MAC]
[(NEQ (SETQ MAC (APPLY (CONS (QUOTE NLAMBDA)
MAC)
(CDR EXP)))
(QUOTE IGNOREMACRO))
(CW expand computed macro)
(COND
[(EQ MAC (QUOTE INSTRUCTIONS))
(COMPERROR (CONS EXP (QUOTE (returned INSTRUCTIONS]
(T (COMP.EXP1 MAC]
(T (CW computed macro returns IGNOREMACRO)
(COMP.CALL (CAR EXP)
(CDR EXP)
(COMP.ARGTYPE (CAR EXP])
)
(DEFINEQ
(COMP.VARTYPE
[LAMBDA (VAR) (* lmm "13-MAR-81 09:36")
(OPT.CCHECK (AND VAR (LITATOM VAR)))
(COND
((COMP.ANONP VAR)
(QUOTE HVAR))
(T (QUOTE AVAR])
(COMP.LOOKUPVAR
[LAMBDA (V FORVALUE) (* lmm " 2-NOV-83 21:47")
(PROG (X)
(if (SETQ X (find VAR in ALLVARS suchthat (EQ (fetch VARNAME of VAR)
V)))
then (RETURN X))
(if (SETQ X (find VAR in FREEVARS suchthat (EQ (fetch VARNAME of VAR)
V)))
then (RETURN X))
[if (NEQ V (SETQ X (COMP.USERFN V)))
then (if FORVALUE
then (RETAPPLY (QUOTE COMP.VAR)
(FUNCTION COMP.VAL)
(LIST X)
T)
else (COMPERROR (CONS V " - is compile time constant, yet is bound or set."]
(SETQ FREEVARS (CONS (SETQ X (create VAR
COMP.VARTYPE ←(if (AND GLOBALVARFLG (COMP.GLOBALVARP
V))
then (QUOTE GVAR)
else (QUOTE FVAR))
VARNAME ←(COMP.CHECK.VAR V)))
FREEVARS))
(RETURN X])
(COMP.LOOKUPCONST
[LAMBDA (X) (* lmm "24-JUN-78 22:56")
(COND
((NULL X)
OPNIL)
(T (OR [CAR (SOME CONSTS (FUNCTION (LAMBDA (Y)
(EQ X (fetch OPARG of Y]
(PROG1 (SETQ X (create OP
OPNAME ←(QUOTE CONST)
OPARG ← X))
(SETQ CONSTS (NCONC1 CONSTS X])
)
(DEFINEQ
(COMP.ST
[LAMBDA (X DL) (* lmm "15-JAN-82 14:42")
(OPT.CCHECK DL)
(COND
[(OR LEVEL (EQ DL T))
(SETQ CODE (CONS X CODE))
(SETQ LEVEL (COND
((FIXP DL)
(IPLUS LEVEL DL]
(T (OPT.CCHECK (OPT.JUMPCHECK CODE))
(CW didn't store code after JUMP or RETURN)
NIL])
(COMP.STFN
[LAMBDA (FN N) (* lmm "16-APR-82 00:14")
(COMP.ST (create OP
OPNAME ←(QUOTE FN)
OPARG ←(CONS N (OR (AND BLKFLG (LITATOM FN)
(CDR (FASSOC FN INTERNALBLKFNS)))
FN)))
(IDIFFERENCE 1 N])
(COMP.STCONST
[LAMBDA (X) (* lmm "16-APR-82 00:14")
(COMP.ST (COMP.LOOKUPCONST X)
1])
(COMP.STVAR
[LAMBDA (VREF) (* lmm "16-APR-82 00:14")
(COMP.ST VREF 1])
(COMP.STPOP
[LAMBDA (N) (* lmm "16-APR-82 00:14")
(RPTQ (OR N 1)
(COMP.ST OPPOP -1])
(COMP.DELFN
[LAMBDA NIL (* lmm: "22-JUL-77 02:40")
[SETQ LEVEL (IPLUS (SUB1 LEVEL)
(CAR (fetch OPARG of (CAR CODE]
(SETQ CODE (CDR CODE])
(COMP.STRETURN
[LAMBDA NIL (* lmm "16-APR-82 00:13")
(COMP.ST OPRETURN T)
(SETQ LEVEL (SETQ FRAME])
(COMP.STTAG
[LAMBDA (TAG) (* lmm "16-APR-82 00:13")
(PROG ((NLV (fetch (TAG LEVEL) of TAG))
(NF (fetch (TAG FRAME) of TAG)))
(OR (COND
[(OR NLV NF)
(AND (EQ NLV (OR LEVEL (SETQ LEVEL NLV)))
(EQ NF (OR FRAME (SETQ FRAME NF]
((OR LEVEL FRAME)
(AND (replace (TAG LEVEL) of TAG with LEVEL)
(replace (TAG FRAME) of TAG with FRAME)))
(T T))
(OPT.COMPILERERROR))
[COND
((AND (EQ (fetch OPNAME of (CAR CODE))
(QUOTE JUMP))
(EQ (fetch (JUMP TAG) of (CAR CODE))
TAG))
(CW delete JUMP to next in COMP.STTAG)
(SETQ CODE (CDR CODE]
(COMP.ST TAG 0])
(COMP.STJUMP
[LAMBDA (OP TAG JT) (* lmm "16-APR-82 00:13")
(COND
((OPT.JUMPCHECK CODE)
(CW JUMP not stored after JUMP or RETURN)
NIL)
(T [COND
((NULL TAG) (* even if OP is given and in correct format, re-cons it
up since OPT.POSTOPT might smash it)
(SETQ TAG (CAR (fetch OPARG of OP)))
(SETQ JT (CDR (fetch OPARG of OP)))
(SETQ OP (fetch OPNAME of OP]
(COMP.ST (create JUMP
OPNAME ← OP
TAG ← TAG
JT ← JT)
0)
(PROG ((F (fetch FRAME of TAG))
(V (fetch (TAG LEVEL) of TAG))
NV)
(COND
(F (OPT.CCHECK (EQ F FRAME)))
(T (replace (TAG FRAME) of TAG with FRAME)))
(SETQ NV (SELECTQ OP
[JUMP (PROG1 LEVEL (SETQ FRAME (SETQ LEVEL]
((FJUMP TJUMP)
(SETQ LEVEL (SUB1 LEVEL)))
[(NFJUMP NTJUMP)
(PROG1 LEVEL (SETQ LEVEL (SUB1 LEVEL]
(ERRORSET (PROG1 (SUB1 LEVEL)
(SETQ FRAME JT)
(SETQ LEVEL 0)))
(OPT.COMPILERERROR)))
(OPT.CCHECK (OR (NULL NV)
(IGEQ NV 0)))
(OPT.CCHECK (OR (NULL LEVEL)
(IGEQ LEVEL 0)))
(COND
(V (OPT.CCHECK (EQ V NV)))
(T (replace (TAG LEVEL) of TAG with NV])
(COMP.STSETQ
[LAMBDA (VREF) (* lmm "16-APR-82 00:14")
(OPT.CCHECK (IGREATERP LEVEL 0))
(COMP.ST (create OP
OPNAME ←(QUOTE SETQ)
OPARG ← VREF)
0])
(COMP.STCOPY
[LAMBDA NIL (* lmm "16-APR-82 00:14")
(OPT.CCHECK (IGREATERP LEVEL 0))
(COMP.ST OPCOPY 1])
(COMP.DELPUSH
[LAMBDA NIL (* lmm: " 9-AUG-76 21:50:49")
(SUB1VAR LEVEL)
(SETQ CODE (CDR CODE])
(COMP.DELPOP
[LAMBDA NIL (* lmm "28-OCT-77 15:23")
(SETQ LEVEL (ADD1 LEVEL))
(SETQ CODE (CDR CODE])
(COMP.STBIND
[LAMBDA (F) (* lmm "16-APR-82 00:14")
[COND
((NULL (fetch PARENT of F))
(replace PARENT of F with FRAME))
(T (OPT.CCHECK (EQ (fetch PARENT of F)
FRAME]
[COND
[(NULL (fetch (FRAME LEVEL) of F))
(replace (FRAME LEVEL) of F with (IDIFFERENCE LEVEL (fetch NVALS of F]
(T (OPT.CCHECK (EQ (fetch (FRAME LEVEL) of F)
(IDIFFERENCE LEVEL (fetch NVALS of F]
(COND
([EVERY CODE (FUNCTION (LAMBDA (X)
(SELECTQ (fetch OPNAME of X)
((TAG HVAR AVAR GVAR CONST)
T)
[FN (OR (NULL (fetch (FRAME VARS) of F))
(COMP.CLEANFNOP (CDR (fetch OPARG of X))
(QUOTE FREEVARS]
NIL]
(CW PROG is first thing in function)
(replace CPIOK of F with T)))
(COMP.ST (create OP
OPNAME ←(QUOTE BIND)
OPARG ←(CONS NIL F))
0)
(SETQ FRAME F)
(SETQ LEVEL 0])
(COMP.STUNBIND
[LAMBDA (D) (* lmm "16-APR-82 00:14")
(COMP.ST (create OP
OPNAME ←(COND
(D (QUOTE DUNBIND))
(T (QUOTE UNBIND)))
OPARG ←(CONS LEVEL FRAME))
0)
[SETQ LEVEL (IPLUS (fetch (FRAME LEVEL) of FRAME)
(COND
(D 0)
(T 1]
(SETQ FRAME (fetch PARENT of FRAME])
)
(DEFINEQ
(COMP.ARGTYPE
[LAMBDA (FN) (* lmm "25-FEB-82 16:29")
(PROG NIL
(RETURN (COND
((NOT (LITATOM FN))
(ARGTYPE FN))
((FMEMB FN LAMA)
2)
((FMEMB FN LAMS)
0)
((FMEMB FN NLAML)
1)
((FMEMB FN NLAMA)
3)
(T (ARGTYPE (OR [AND BLKFLG (OR (CADDR (FASSOC FN BLKDEFS))
(AND (FMEMB FN BLKLIBRARY)
(GETP FN (QUOTE BLKLIBRARYDEF]
(GETPROP FN (QUOTE BROKEN))
(AND (GETD FN)
FN)
(GETPROP FN (QUOTE EXPR))
(RETURN (COND
((FMEMB FN NOFIXFNSLST)
2)
(T NIL])
(COMP.CLEANEXPP
[LAMBDA (X TYPE) (* lmm "15-APR-82 23:01")
(COND
((NLISTP X))
((COMP.CLEANFNP (CAR X)
TYPE)
(EVERY (CDR X)
(FUNCTION (LAMBDA (X)
(COMP.CLEANEXPP X TYPE])
(COMP.CLEANFNP
[LAMBDA (X TYPE) (* lmm "15-APR-82 23:02")
(COND
((LITATOM X)
(APPLY* CLEANFNTEST X))
((LISTP X)
(SELECTQ (CAR X)
[[LAMBDA OPENLAMBDA]
(EVERY (CDDR X)
(FUNCTION (LAMBDA (X)
(COMP.CLEANEXPP X TYPE]
NIL])
(COMP.CLEANFNOP
[LAMBDA (FN TYPE) (* lmm "15-APR-82 23:07")
(APPLY* CLEANFNTEST FN TYPE])
(COMP.GLOBALVARP
[LAMBDA (X) (* lmm: " 9-AUG-76 20:34:14")
(OR (GETP X (QUOTE GLOBALVAR))
(FMEMB X GLOBALVARS])
(COMP.LINKCALLP
[LAMBDA (FN) (* edited (18-NOV-75 . 2341))
(COND
((AND (LISTP NOLINKFNS)
(FMEMB FN NOLINKFNS))
NIL)
((AND BLKFLG (OR (FASSOC FN BLKDEFS)
(FMEMB FN BLKLIBRARY)))
T)
((AND (LISTP LINKFNS)
(FMEMB FN LINKFNS))
T)
((EQ NOLINKFNS T)
NIL)
((OR BLKFLG (EQ LINKFNS T))
T])
(COMP.ANONP
[LAMBDA (E) (* lmm "31-MAR-78 01:34")
(COND
((NEQ LOCALVARS T)
(FMEMB E LOCALVARS))
(T (NOT (OR (EQ SPECVARS T)
(FMEMB E SPECVARS)
(AND BLKFLG (FMEMB E LOCALFREEVARS])
)
(DEFINEQ
(COMP.CPI
[LAMBDA (FN ARGS) (* lmm "16-APR-82 00:28")
(PROG ((F FRAME))
LP (COND
((EQ F TOPFRAME)
(COMP.CPI1 ARGS ARGVARS (COMP.PICOUNT ARGS))
(while (NEQ FRAME TOPFRAME)
do (CW unbind localvar FRAME before recursion)
(COMP.STUNBIND T))
(COND
((NEQ LEVEL 0)
(CW pop stack before recursion)
(COMP.STPOP LEVEL)))
(COMP.STJUMP (QUOTE JUMP)
TOPLAB)
(CW COMP.CPI succeeds)
(RETURN (QUOTE NOVALUE)))
((SELECTQ (fetch FRAMETYPE of F)
[(PROG LAMBDA)
(COND
((OASSOC (QUOTE AVAR)
(fetch VARS of F))
(COND
((NOT (fetch CPIOK of F))
(CW can't remove recursion inside frame with SPECVARS)
T)
(T (CW COMP.CPI can succeed because SPECVARS bound first
thing in function)
NIL]
(PROGN (CW can't remove recursion inside ERRORSET)
T))
(COMP.CALL FN ARGS 0))
((SETQ F (fetch PARENT of F))
(GO LP))
(T (OPT.COMPILERERROR])
(COMP.CPI1
[LAMBDA (ARGS VARS N) (* lmm "16-APR-82 00:28")
(COND
[(NULL VARS)
(COND
((LISTP ARGS)
(COMP.EFFECT (CAR ARGS))
(COMP.CPI1 (CDR ARGS)
VARS
(SUB1 N]
([OR (IGREATERP N 0)
(NOT (LITATOM (CAR ARGS)))
(NEQ (CAR ARGS)
(fetch OPARG of (CAR VARS]
(COMP.VAL (CAR ARGS))
(COMP.CPI1 (CDR ARGS)
(CDR VARS)
(SUB1 N))
(COMP.STSETQ (CAR VARS))
(COMP.STPOP))
(T (COMP.CPI1 (CDR ARGS)
(CDR VARS)
(SUB1 N])
(COMP.PICOUNT
[LAMBDA (ARGS) (* lmm "27-OCT-81 20:57")
(PROG ((N 0)
(ND 0)
(VARS ARGVARS))
LP (COND
(VARS (SETQ N (ADD1 N))
(COND
[(AND (LITATOM (CAR ARGS))
(EQ (CAR ARGS)
(fetch OPARG of (CAR VARS]
((NOT (COMP.CLEANEXPP (CAR ARGS)
(QUOTE COMP.PICOUNT)))
(SETQ ND N)))
(SETQ VARS (CDR VARS))
(SETQ ARGS (CDR ARGS))
(GO LP)))
(RETURN ND])
)
(PUTPROPS EVQ BYTEMACRO COMP.EVQ)
(DEFINEQ
(COMP.EVQ
[LAMBDA (X) (* lmm "26-MAY-82 10:12")
(RESETVARS (COMPVARMACROHASH)
(RETURN (COMP.EXP1 (CAR X])
)
(PUTPROPS AND BYTEMACRO (APPLY* COMP.BOOL T))
(PUTPROPS OR BYTEMACRO (APPLY* COMP.BOOL NIL))
(DEFINEQ
(COMP.BOOL
[LAMBDA (A FLAG) (* lmm "16-APR-82 00:29")
(COND
((NULL A)
(CW (AND/OR))
(COMP.CONST FLAG))
((NULL (CDR A))
(CW (AND/OR expr))
(COMP.EXP1 (CAR A)))
(T (PROG ((END (create TAG))
P)
(SETQ P (create JUMP
OPNAME ←[COND
((SETQ P PREDF)
(CW AND/OR in PREDF)
(SELECTQ (fetch OPNAME of PREDF)
[(TJUMP NTJUMP)
(COND
(FLAG (QUOTE FJUMP))
(T (GO LP]
[(FJUMP NFJUMP)
(COND
(FLAG (GO LP))
(T (QUOTE TJUMP]
(OPT.COMPILERERROR)))
[EFF (CW AND/OR in EFF)
(COND
(FLAG (QUOTE FJUMP))
(T (QUOTE TJUMP]
(T (CW other AND/OR)
(COND
(FLAG (QUOTE NFJUMP))
(T (QUOTE NTJUMP]
TAG ← END))
LP (COND
((CDR A)
(COMP.EXPR (CAR A)
NIL NIL P)
(SETQ A (CDR A))
(GO LP)))
(RETURN (PROG1 (COMP.EXPR (CAR A)
EFF RETF PREDF)
(COMP.STTAG END])
)
(DEFINEQ
(COMP.APPLYFNP
[LAMBDA (X) (* edited: "21-MAY-80 09:38")
(AND (LISTP X)
(SELECTQ (CAR X)
((FUNCTION QUOTE)
(AND (NULL (CDDR X))
(SELECTQ (COMP.ARGTYPE (CADR X))
(NIL (pushnew ALAMS1 (CADR X))
T)
((0 1 2)
T)
NIL)))
NIL])
)
(PUTPROPS AC BYTEMACRO COMP.AC)
(PUTPROPS ASSEMBLE BYTEMACRO COMP.PUNT)
(PUTPROPS ASSEM BYTEMACRO COMP.PUNT)
(PUTPROPS FLOC BYTEMACRO COMP.PUNT)
(DEFINEQ
(COMP.AC
[LAMBDA NIL (* lmm: " 1-OCT-76 12:41:01")
(OR (EQ (SETQ AC EXP)
DONOTHING)
(COMP.PUNT))
NIL])
(COMP.PUNT
[LAMBDA NIL (* lmm "22-OCT-79 12:44")
(PROG [(EM (CONS (CAR EXP)
(QUOTE (-- can't compile]
(COMPERROR (COND
[MACEXP (CONS (QUOTE Under)
(CONS (CAR MACEXP)
(CONS (QUOTE -)
EM]
(T EM])
)
(PUTPROPS FUNCTION BYTEMACRO COMP.FUNCTION)
(DEFINEQ
(COMP.FUNCTION
[LAMBDA (A) (* lmm "16-APR-82 00:18")
(PROG ((FN (CAR A)))
[COND
((LISTP FN)
(SETQ FN (COMP.LAM1 FN]
(RETURN (COND
((CDR A)
(COMP.CALL (QUOTE FUNCTION)
(CONS FN (CDR A))
1))
(T (COMP.STCONST FN])
(COMP.LAM1
[LAMBDA (DEF) (* lmm "22-OCT-79 12:45")
(PROG ((FN (COMP.GENFN)))
(COMP.TOPLEVEL.COMPILE FN DEF)
[MAPC ALLVARS (FUNCTION (LAMBDA (X)
(COND
((AND (NEQ (fetch OPNAME of X)
(QUOTE AVAR))
(FMEMB (fetch OPARG of X)
SUBFNFREEVARS))
(CW change LOCALVAR to SPECVAR because subfn uses it
free)
(replace OPNAME of X with (QUOTE AVAR]
(RETURN FN])
(COMP.GENFN
(LAMBDA NIL (* JonL "17-Dec-83 03:43")
(DECLARE (SPECVARS COMP.GENFN)
(USEDFREE COMP.GENFN))
(if (ILEQ (NCHARS COMP.GENFN.BUF)
(IPLUS 12 (NCHARS COMFN)))
then (SETQ COMP.GENFN.BUF (ALLOCSTRING (IPLUS 16 (NCHARS COMP.GENFN.BUF)))))
(if (IGEQ COMP.GENFN.NUM 9999)
then (HELP "Compiler's GENSYM counter %"rolling over%", but you may continue.")
(SETQ COMP.GENFN.NUM 0))
(GENSYM COMFN (add COMP.GENFN.NUM 1)
COMP.GENFN.BUF NIL (CHARCODE A))))
)
(RPAQ? COMP.GENFN.NUM 0)
(RPAQ? COMP.GENFN.BUF (ALLOCSTRING 100))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS COMP.GENFN.NUM COMP.GENFN.BUF)
)
(PUTPROPS COND BYTEMACRO COMP.COND)
(PUTPROPS SELECTQ BYTEMACRO COMP.SELECTQ)
(DEFINEQ
(COMP.COND
[LAMBDA (A) (* lmm "16-APR-82 00:29")
(PROG (NEXT PRED CLAUSE (END (create TAG))
ENDF)
LP [SETQ PRED (CAR (SETQ CLAUSE (CAR A]
(COND
[(CDR CLAUSE)
[COMP.EXPR PRED NIL NIL (create JUMP
OPNAME ←(QUOTE FJUMP)
TAG ←(SETQ NEXT (create TAG]
[COND
((OPT.JUMPCHECK CODE)
NIL)
(T (COMP.VALN (CDR CLAUSE)
EFF RETF)
(OR RETF (OPT.JUMPCHECK CODE)
(COMP.STJUMP (QUOTE JUMP)
(SETQ ENDF END]
(COND
((OR OPTIMIZATIONSOFF (find X in CODE
suchthat (EQ (CAR (LISTP (fetch OPARG of X)))
NEXT)))
(COMP.STTAG NEXT))
(T (GO OUT]
[(CDR A)
(COMP.EXPR PRED NIL NIL (create JUMP
OPNAME ←(COND
(EFF (QUOTE TJUMP))
(T (QUOTE NTJUMP)))
TAG ←(SETQ ENDF END]
(T (COMP.EXPR PRED EFF RETF)
(GO OUT)))
(COND
((SETQ A (CDR A))
(GO LP)))
(COMP.EXPR NIL EFF)
OUT (AND ENDF (COMP.STTAG END))
(RETURN (AND EFF (QUOTE NOVALUE])
(COMP.SELECTQ
[LAMBDA (A) (* lmm "16-APR-82 00:29")
(PROG ((END (create TAG))
VAR THISLABEL NEXT TEST CLAUSE)
(CW compile SELECTQ)
(COMP.VAL (CAR A))
(SETQ A (CDR A))
(COND
((FMEMB (fetch OPNAME of (CAR CODE))
SELECTVARTYPES) (* SELECTQVARTYPES is (AVAR HVAR) for Alto and NIL for
maxc)
(CW SELECTQ var)
(SETQ VAR (CAR CODE))
(COMP.DELPUSH))
((AND (EQ (fetch OPNAME of (CAR CODE))
(QUOTE SETQ))
(FMEMB (fetch OPNAME of (fetch OPARG of (CAR CODE)))
SELECTVARTYPES))
(CW SELECTQ SETQ)
(SETQ VAR (fetch OPARG of (CAR CODE)))
(COMP.STPOP))
[(EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(CW SELECTQ of constant)
(RETURN (COMP.PROGN (PROG [(C (fetch OPARG of (CAR CODE]
(COMP.DELPUSH)
ALP (COND
((NULL (CDR A))
(RETURN A)))
[COND
((COND
((LISTP (CAAR A))
(FMEMB C (CAAR A)))
(T (EQ (CAAR A)
C)))
(RETURN (CDAR A]
(SETQ A (CDR A))
(GO ALP]
(T (SETQ THISLABEL T)))
LP [COND
((NULL (CDR A))
(AND THISLABEL (NULL VAR)
(COMP.STPOP))
(RETURN (PROG1 (COMP.EXPR (CAR A)
EFF RETF)
(OR RETF (COMP.STTAG END]
(SETQ THISLABEL)
[COND
([LISTP (SETQ TEST (CAR (SETQ CLAUSE (PROG1 (CAR A)
(SETQ A (CDR A]
(COND
((NLISTP (CDR TEST))
(SETQ TEST (CAR TEST)))
(SELECTQFMEMB (CW FMEMB in SELECTQ)
(COND
(VAR (COMP.STVAR VAR))
((CDR A)
(COMP.STCOPY)))
(COMP.STCONST (APPEND TEST))
(COMP.STFN (QUOTE FMEMB)
2)
(GO DUN))
(T (SETQ THISLABEL (create TAG))
(MAP TEST (FUNCTION (LAMBDA (Y)
(COND
((CDR Y)
(COND
(VAR (COMP.STVAR VAR))
(T (COMP.STCOPY)))
(COMP.STCONST (CAR Y))
(COMP.STFN (QUOTE EQ)
2)
(COMP.STJUMP (QUOTE TJUMP)
THISLABEL))
(T (SETQ TEST (CAR Y]
(COND
(VAR (COMP.STVAR VAR))
((OR THISLABEL (CDR A))
(COMP.STCOPY)))
(COMP.STCONST TEST)
(COMP.STFN (QUOTE EQ)
2)
DUN [COND
((AND (NULL THISLABEL)
(NULL (CDR A))
(NULL (CAR A)))
(CW SELECTQ ends in NIL)
(COMP.STJUMP (COND
(EFF (QUOTE FJUMP))
(T (QUOTE NFJUMP)))
END)
(RETURN (PROG1 (COMP.VALN (CDR CLAUSE)
EFF NIL)
(COMP.STTAG END]
(COMP.STJUMP (QUOTE FJUMP)
(SETQ NEXT (create TAG)))
(COND
(THISLABEL (COMP.STTAG THISLABEL)))
(COND
((AND (OR THISLABEL (CDR A))
(NULL VAR))
(COMP.STPOP)))
(COMP.VALN (CDR CLAUSE)
EFF RETF)
(OR RETF (COMP.STJUMP (QUOTE JUMP)
END))
(COMP.STTAG NEXT)
(GO LP])
)
(PUTPROPS PROGN BYTEMACRO COMP.PROGN)
(PUTPROPS PROG1 BYTEMACRO COMP.PROG1)
(PUTPROPS QUOTE BYTEMACRO COMP.QUOTE)
(PUTPROPS * BYTEMACRO COMP.COMMENT)
(DEFINEQ
(COMP.QUOTE
[LAMBDA (A) (* lmm: " 9-AUG-76 22:04:49")
[COND
((CDR A)
(COMPERRM (CONS EXP (QUOTE (- probable parenthesis error]
(COMP.CONST (CAR A])
(COMP.COMMENT
[LAMBDA (A) (* lmm "16-APR-82 00:18")
(COND
((NOT EFF)
[COMPERRM (CONS EXP (QUOTE (- value of comment used?]
(COMP.STCONST (CAR A)))
(T (QUOTE NOVALUE])
)
(PUTPROPS DECLARE BYTEMACRO COMP.DECLARE)
(DEFINEQ
(COMP.DECLARE
[LAMBDA (A) (* rmk: "20-NOV-79 08:13")
(CW compile DECLARE)
[MAPC A (FUNCTION (LAMBDA (B)
(SELECTQ (CAR B)
(LOCALVARS (COMP.DECLARE1 (CDR B)
(QUOTE LOCALVARS)
(QUOTE SPECVARS)
SYSSPECVARS))
(SPECVARS (COMP.DECLARE1 (CDR B)
(QUOTE SPECVARS)
(QUOTE LOCALVARS)
SYSLOCALVARS))
((ADDTOVAR DEFLIST PUTPROPS CONSTANTS SETQQ USEDFREE GLOBALVARS)
(EVAL B))
(COMPERRM (CONS B (QUOTE (- used in DECLARE]
(COMP.CONST (CAR A])
(COMP.DECLARE1
[LAMBDA (VAL VAR OTHERVAR SYSOTHERVAR) (* lmm "31-MAR-78 02:47")
(SET VAR (COND
((LISTP VAL)
(COND
((LISTP (SETQ VAR (EVALV VAR)))
(APPEND VAL VAR))
((EQ VAR T))
(T VAL)))
((EQ VAL T)
(SET OTHERVAR SYSOTHERVAR)
T)
(T VAL)))
(MAPC (fetch VARS of FRAME)
(FUNCTION (LAMBDA (V VTAG)
(COND
((NEQ (SETQ VTAG (COMP.VARTYPE (fetch OPARG of V)))
(fetch OPNAME of V)) (* Already made some decision based on localvars
(COMPERRM (CONS EXP (QUOTE (- illegal DECLARE)))))
(replace OPNAME of V with VTAG])
)
(RPAQQ MCROPS (CAR CDR CAAR CDAR CADR CDDR CAAAR CDAAR CADAR CDDAR CAADR CDADR CADDR CDDDR CAAAAR
CDAAAR CADAAR CDDAAR CAADAR CDADAR CADDAR CDDDAR CAAADR CDAADR CADADR CDDADR
CAADDR CDADDR CADDDR CDDDDR))
(PUTPROPS CAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDR BYTEMACRO COMP.CARCDR)
(PUTPROPS CAAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CADR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDDR BYTEMACRO COMP.CARCDR)
(PUTPROPS CAAAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDAAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CADAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDDAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CAADR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDADR BYTEMACRO COMP.CARCDR)
(PUTPROPS CADDR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDDDR BYTEMACRO COMP.CARCDR)
(PUTPROPS CAAAAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDAAAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CADAAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDDAAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CAADAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDADAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CADDAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDDDAR BYTEMACRO COMP.CARCDR)
(PUTPROPS CAAADR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDAADR BYTEMACRO COMP.CARCDR)
(PUTPROPS CADADR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDDADR BYTEMACRO COMP.CARCDR)
(PUTPROPS CAADDR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDADDR BYTEMACRO COMP.CARCDR)
(PUTPROPS CADDDR BYTEMACRO COMP.CARCDR)
(PUTPROPS CDDDDR BYTEMACRO COMP.CARCDR)
(PUTPROPS CAR CROPS (A))
(PUTPROPS CDR CROPS (D))
(PUTPROPS CAAR CROPS (A A))
(PUTPROPS CDAR CROPS (A D))
(PUTPROPS CADR CROPS (D A))
(PUTPROPS CDDR CROPS (D D))
(PUTPROPS CAAAR CROPS (A A A))
(PUTPROPS CDAAR CROPS (A A D))
(PUTPROPS CADAR CROPS (A D A))
(PUTPROPS CDDAR CROPS (A D D))
(PUTPROPS CAADR CROPS (D A A))
(PUTPROPS CDADR CROPS (D A D))
(PUTPROPS CADDR CROPS (D D A))
(PUTPROPS CDDDR CROPS (D D D))
(PUTPROPS CAAAAR CROPS (A A A A))
(PUTPROPS CDAAAR CROPS (A A A D))
(PUTPROPS CADAAR CROPS (A A D A))
(PUTPROPS CDDAAR CROPS (A A D D))
(PUTPROPS CAADAR CROPS (A D A A))
(PUTPROPS CDADAR CROPS (A D A D))
(PUTPROPS CADDAR CROPS (A D D A))
(PUTPROPS CDDDAR CROPS (A D D D))
(PUTPROPS CAAADR CROPS (D A A A))
(PUTPROPS CDAADR CROPS (D A A D))
(PUTPROPS CADADR CROPS (D A D A))
(PUTPROPS CDDADR CROPS (D A D D))
(PUTPROPS CAADDR CROPS (D D A A))
(PUTPROPS CDADDR CROPS (D D A D))
(PUTPROPS CADDDR CROPS (D D D A))
(PUTPROPS CDDDDR CROPS (D D D D))
(DEFINEQ
(COMP.CARCDR
[LAMBDA (A) (* lmm "16-APR-82 00:16")
(* Used for compiling CAR/CDR etc)
(SETQ A (COMP.VAL1 A EFF))
(COND
(EFF (CW CAR/CDR in EFF)
A)
(T (MAPC (GETPROP (CAR EXP)
(QUOTE CROPS))
(FUNCTION (LAMBDA (X)
(COMP.STFN (SELECTQ X
(A (QUOTE CAR))
(QUOTE CDR))
1])
(COMP.STCROP
[LAMBDA (X) (* lmm "16-APR-82 00:16")
(COMP.STFN (SELECTQ X
(A (QUOTE CAR))
(QUOTE CDR))
1])
)
(PUTPROPS NOT BYTEMACRO COMP.NOT)
(PUTPROPS NULL BYTEMACRO COMP.NOT)
(DEFINEQ
(COMP.NOT
[LAMBDA (A) (* lmm "16-APR-82 00:16")
(PROG ((PREDF (OPT.NOTJUMP PREDF)))
(RETURN (COND
((AND PREDF (NULL EFF))
(CW NULL in PREDF)
(COMP.PROG1 A))
(T (CW call to NULL)
(COMP.VAL1 A)
(COMP.STFN (QUOTE NULL)
1])
)
(PUTPROPS SETQ BYTEMACRO COMP.SETQ)
(PUTPROPS SETN BYTEMACRO COMP.SETN)
(DEFINEQ
(COMP.SETQ
[LAMBDA (A) (* lmm "16-APR-82 00:29")
(COMP.VAL1 (CDR A))
(COMP.STSETQ (COMP.LOOKUPVAR (CAR A])
(COMP.SETN
[LAMBDA (A) (* lmm: "20-OCT-76 01:33:55")
[COMPERRM (CONS (CAR A)
(QUOTE (- warning: SETN compiled as SETQ]
(COMP.SETQ A])
)
(DEFINEQ
(COMP.LAMBDA
[LAMBDA (FN VALS) (* lmm "16-APR-82 00:28")
(PROG ((VARS (CADR FN))
F
(EXPS (CDDR FN))
V E (I 0)
SUBOLD SUBNEW VAR)
[SELECTQ (ARGTYPE FN)
(0 (CW open LAMBDA))
[1 (CW open NLAMBDA nospread)
(SETQ VALS (MAPCAR VALS (FUNCTION KWOTE]
(2 (CW open LAMBDA nospread)
(RETURN (COMP.CALL (COMP.LAM1 FN)
VALS 2)))
[3 (CW open NLAMBDA spread)
(SETQ VARS (LIST VARS))
(SETQ VALS (LIST (KWOTE VALS]
(COND
[(EQ (CAR FN)
(QUOTE OPENLAMBDA))
(CW compile OPENLAMBDA expression)
[while VARS
do (COMP.VAL (pop VALS))
(COND
((EQ (fetch OP of (CAR CODE))
(QUOTE CONST))
(push SUBOLD (pop VARS))
[push SUBNEW (KWOTE (fetch OPARG of (CAR CODE]
(COMP.DELPUSH))
(T (push V (pop VARS]
(MAPC VALS (FUNCTION COMP.EFFECT))
(while (AND V (SETQ VAR (SELECTQ (fetch OP of (CAR CODE))
((AVAR HVAR FVAR GVAR)
(PROG1 (fetch OPARG of (CAR CODE))
(COMP.DELPUSH)))
(SETQ (PROG1 (fetch OPARG
of (fetch OPARG
of (CAR CODE)))
(COMP.STPOP)))
NIL)))
do (CW substitute for variable in OPENLAMBDA)
(push SUBNEW VAR)
(push SUBOLD (pop V)))
[COND
((NULL V)
(CW OPENLAMBDA with all variables substituted for)
(RETURN (COMP.PROGN (SUBPAIR SUBOLD SUBNEW EXPS]
(while V do ([push SUBNEW (CAR (push VARS (COMP.GENFN]
(push SUBOLD (pop V))
(push VALS DONOTHING)))
(SETQ EXPS (CONS (QUOTE (DECLARE (LOCALVARS . T)))
(SUBPAIR SUBOLD SUBNEW EXPS]
(T (COMPERROR (CONS FN (QUOTE (- illegal open function]
(SETQ F (COMP.BIND.VARS VARS VALS (QUOTE LAMBDA)))
(PROG ((ALLVARS (APPEND (fetch VARS of F)
ALLVARS))
(LOCALVARS LOCALVARS)
(SPECVARS SPECVARS))
(COMP.STBIND F)
(COMP.VALN EXPS EFF (AND MERGEUNBINDFLG RETF)))
(RETURN (COMP.UNBIND.VARS F])
)
(PUTPROPS PROG BYTEMACRO COMP.PROG)
(PUTPROPS GO BYTEMACRO COMP.GO)
(PUTPROPS RETURN BYTEMACRO COMP.RETURN)
(DEFINEQ
(COMP.PROG
[LAMBDA (A) (* lmm "16-APR-82 00:29")
(PROG ([VARS (MAPCAR (CAR A)
(FUNCTION (LAMBDA (X)
(COND
((LITATOM X)
X)
[(NLISTP X)
(COMPERROR (CONS X (QUOTE (- bad PROG variable]
(T (CAR X]
[VALS (MAPCAR (CAR A)
(FUNCTION (LAMBDA (X)
(AND (LISTP X)
(COND
((CDDR X)
(CONS (QUOTE PROG1)
(CDR X)))
(T (CADR X]
F)
(SETQ F (COMP.BIND.VARS VARS VALS (QUOTE PROG)))
(PROG ((ALLVARS (APPEND (fetch VARS of F)
ALLVARS))
(LOCALVARS LOCALVARS)
(SPECVARS SPECVARS)
TAGS
(RETURNLABEL (create TAG
LEVEL ←(COND
(EFF 0)
(T 1))
FRAME ← F))
PROGLEVEL
(PROGEFF EFF)
(PROGRETF RETF)
FLG
(LOCALVARS LOCALVARS))
(COMP.STBIND F)
[MAPC (CDR A)
(FUNCTION (LAMBDA (X)
(COND
((LISTP X))
[(NOT (LITATOM X))
(COMPERROR (CONS X (QUOTE (- illegal tag]
[(FASSOC X TAGS)
(COMPERROR (CONS X (QUOTE (- multiply defined tag]
(T (SETQ TAGS (CONS (CONS X (SETQ X (create TAG
LBNO ← X)))
TAGS))
(replace (TAG FRAME) of X with FRAME)
(replace (TAG LEVEL) of X with 0]
(replace PROGLABELS of F with TAGS)
(SETQ FLG (COND
((OR TAGS OPTIMIZATIONSOFF (NULL MERGEUNBINDFLG))
NIL)
(RETF (COND
((NOT (COMP.DELPOPP))
(CW pop even though higher PROG labels)))
T))) (* Check if can delete extra POP's)
[MAPC (CDR A)
(FUNCTION (LAMBDA (X)
(COND
[(LITATOM X)
(COMP.STTAG (CDR (FASSOC X TAGS]
(T (COMP.EFFECT X)
(AND FLG (while (EQ (CAR CODE)
OPPOP)
do (CW delete POP in PROG)
(COMP.DELPOP]
(COND
((NOT (OR EFF (OPT.JUMPCHECK CODE)))
(CW PROG dropped off)
(COMP.EXPR NIL NIL NIL)))
(OR (AND MERGEUNBINDFLG RETF)
(COMP.STTAG RETURNLABEL)))
(RETURN (COMP.UNBIND.VARS F])
(COMP.GO
[LAMBDA (A) (* lmm "16-APR-82 00:28")
(PROG (D ANYPROG)
[COND
((OPT.JUMPCHECK CODE)
(CW UNREACHABLE GO -- DON'T COMPILE)
(RETURN (QUOTE NOVALUE]
LP [SELECTQ (fetch FRAMETYPE of FRAME)
(PROG [COND
((SETQ D (FASSOC (CAR A)
(fetch PROGLABELS of FRAME)))
(COND
((NOT (ZEROP LEVEL))
(CW GO needs to POP)
(COMP.STPOP LEVEL)))
(COMP.STJUMP (QUOTE JUMP)
(CDR D))
(RETURN (QUOTE NOVALUE]
(SETQ ANYPROG T))
[LAMBDA]
(COMPERROR (CONS (CAR A)
(COND
(ANYPROG (QUOTE (- undefined tag)))
(T (QUOTE (- illegal GO]
(CW non local GO)
(COMP.STUNBIND T)
(GO LP])
(COMP.RETURN
[LAMBDA (A) (* lmm "16-MAY-82 12:38")
(PROG ((PROGFRAME FRAME))
[COND
((NOT (AND MERGEUNBINDFLG PROGRETF))
(COND
([NOT (OR PROGEFF (EQ LEVEL 0)
(NEQ (fetch FRAMETYPE of FRAME)
(QUOTE PROG]
(CW RETURN POPs beforehand)
(COMP.STPOP LEVEL]
CHKLP
[SELECTQ (fetch FRAMETYPE of PROGFRAME)
(PROG)
[LAMBDA (SETQ PROGFRAME (fetch PARENT of PROGFRAME))
(GO CHKLP]
(COMPERROR (CONS COMFN (QUOTE (- illegal RETURN]
(COMP.VAL1 A PROGEFF (AND MERGEUNBINDFLG PROGRETF))
[COND
((OPT.JUMPCHECK CODE)
(RETURN (QUOTE NOVALUE]
(COND
((NOT (AND MERGEUNBINDFLG PROGRETF))
[PROG NIL
LP (SELECTQ (fetch FRAMETYPE of FRAME)
(PROG (OPT.CCHECK (EQ FRAME PROGFRAME)))
[LAMBDA (CW RETURN inside LAMBDA)
(COMP.STUNBIND PROGEFF)
(GO LP]
(COMPERROR (CONS COMFN (QUOTE (- illegal RETURN]
[COND
(PROGEFF (COMP.STPOP LEVEL))
((NEQ LEVEL 1)
(OPT.COMPILERERROR (QUOTE (unimplemented RETURN]
(COMP.STJUMP (QUOTE JUMP)
RETURNLABEL)))
(RETURN (QUOTE NOVALUE])
)
(RPAQQ NUMBERFNS (ITIMES2 LOGOR2 LOGXOR2 LOGAND2 LLSH1 LRSH1 LLSH8 LRSH8 IPLUS ITIMES LOGOR LOGXOR
LOGAND IDIFFERENCE IQUOTIENT IREMAINDER IMINUS LSH LLSH RSH LRSH FIX))
(RPAQQ GLOBALVARFLG T)
(RPAQQ NEWOPTFLG NIL)
(RPAQ COMPVERSION (DATE))
(PUTPROPS IPLUS BYTEMACRO (APPLY* COMP.NUMERIC IPLUS))
(PUTPROPS ITIMES BYTEMACRO (APPLY* COMP.NUMERIC ITIMES FIX 0))
(PUTPROPS LOGOR BYTEMACRO (APPLY* COMP.NUMERIC LOGOR FIX -1))
(PUTPROPS LOGXOR BYTEMACRO (APPLY* COMP.NUMERIC LOGXOR))
(PUTPROPS LOGAND BYTEMACRO (APPLY* COMP.NUMERIC LOGAND FIX 0))
(PUTPROPS IDIFFERENCE BYTEMACRO COMP.NUMBERCALL)
(PUTPROPS IQUOTIENT BYTEMACRO COMP.NUMBERCALL)
(PUTPROPS IREMAINDER BYTEMACRO COMP.NUMBERCALL)
(PUTPROPS IMINUS BYTEMACRO ((X)
(IDIFFERENCE 0 X)))
(PUTPROPS LSH BYTEMACRO COMP.NUMBERCALL)
(PUTPROPS LLSH BYTEMACRO COMP.NUMBERCALL)
(PUTPROPS RSH BYTEMACRO COMP.NUMBERCALL)
(PUTPROPS LRSH BYTEMACRO COMP.NUMBERCALL)
(PUTPROPS FIX BYTEMACRO COMP.FIX)
(PUTPROPS PLUS BYTEMACRO (APPLY* COMP.NUMERIC PLUS PLUS))
(PUTPROPS DIFFERENCE BYTEMACRO (APPLY* COMP.NUMBERCALL PLUS))
(PUTPROPS TIMES BYTEMACRO (APPLY* COMP.NUMERIC TIMES PLUS 0))
(PUTPROPS QUOTIENT BYTEMACRO (APPLY* COMP.NUMBERCALL PLUS))
(PUTPROPS FPLUS BYTEMACRO (APPLY* COMP.NUMERIC FPLUS FLOAT))
(PUTPROPS FDIFFERENCE BYTEMACRO (APPLY* COMP.NUMBERCALL FLOAT))
(PUTPROPS FTIMES BYTEMACRO (APPLY* COMP.NUMERIC FTIMES FLOAT 0))
(PUTPROPS FQUOTIENT BYTEMACRO (APPLY* COMP.NUMBERCALL FLOAT))
(DEFINEQ
(COMP.NUMERIC
[LAMBDA (A 2FN TYPE ZERO) (* lmm "28-MAR-83 22:18")
(* compile call to number function of arbitrary args.
2FN is holder of opcode. TYPE is FIX, FLOAT, PLUS
(NIL->FIX))
(* ZERO IF GIVEN IS ZERO OF FUNCTION, E.G. 0 FOR TIMES,
-1 FOR LOGOR)
(PROG ((N 0)
V
(FN (CAR EXP)))
[COND
((AND EFF (NOT OPTIMIZATIONSOFF))
(RETURN (COMP.PROGN A]
(OR 2FN (SETQ 2FN FN))
[while A
do (COMP.VAL (pop A))
(SETQ N (ADD1 N))
(COND
((NOT OPTIMIZATIONSOFF)
(COMP.DELFIX TYPE)
(while (OPT.CALLP (CAR CODE)
2FN)
do (SETQ N (IPLUS N (CAR (fetch OPARG of (CAR CODE)))
-1))
(CW merge nested arithmetic calls)
(COMP.DELFN))
(COND
((AND (EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(IGREATERP N 0))
[SETQ V (COND
[V (CW combine number args)
(APPLY* FN V (fetch OPARG of (CAR CODE]
(T (CW move number constants to end)
(fetch OPARG of (CAR CODE]
(COMP.DELPUSH)
(SETQ N (SUB1 N]
[COND
(V (COND
((EQUAL (APPLY* FN V)
(APPLY* FN)) (* I.E., IS UNIT OF FUNCTION: 1 FOR TIMES, ETC)
)
((EQUAL V ZERO)
(FRPTQ N (COMP.STPOP))
(RETURN (COMP.STCONST V)))
((AND (IGREATERP N 0)
(MINUSP V)
(EQ 2FN (QUOTE IPLUS)))
(CW turn IPLUS of negative to IDIFFERENCE)
(COMP.STCONST (IMINUS V))
(COMP.STFN (QUOTE IDIFFERENCE)
2))
(T (COMP.STCONST V)
(add N 1]
(COND
((EQ N 0)
(CW number function, 0 args)
(COMP.STCONST (APPLY* FN)))
((EQ N 1)
(CW number fn, 1 arg)
(COMP.STFIX TYPE))
(T (FRPTQ (SUB1 N)
(COMP.STFN 2FN 2])
(COMP.NUMBERCALL
[LAMBDA (A TYPE) (* lmm "16-APR-82 00:28")
(PROG ((N 0))
[COND
((AND EFF (NOT OPTIMIZATIONSOFF))
(RETURN (COMP.PROGN A]
(while A
do (COMP.VAL (pop A))
(OR OPTIMIZATIONSOFF (COMP.DELFIX TYPE))
(SETQ N (ADD1 N)))
[COND
((AND (NOT OPTIMIZATIONSOFF)
(EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(EQ N 2))
(COND
((EQ (fetch OPNAME of (CAR (fetch PREV of CODE)))
(QUOTE CONST))
(COMP.STCONST (PROG1 (APPLY* (CAR EXP)
(fetch OPARG of (CAR (fetch PREV of CODE)))
(fetch OPARG of (CAR CODE)))
(COMP.DELPUSH)
(COMP.DELPUSH)))
(RETURN (COMP.STFIX TYPE)))
((FMEMB (CAR EXP)
(SELECTQ (fetch OPARG of (CAR CODE))
(0 (QUOTE (IDIFFERENCE LSH RSH LLSH LRSH)))
(1 (QUOTE (IQUOTIENT)))
NIL))
(COMP.DELPUSH)
(RETURN (COMP.STFIX TYPE]
(RETURN (COMP.STFN (CAR EXP)
N])
(COMP.FIX
[LAMBDA (A) (* lmm "18-APR-80 18:28")
(COMP.VAL1 A)
(COMP.STFIX])
(COMP.STFIX
[LAMBDA (TYPE) (* lmm "16-APR-82 00:28")
(OR TYPE (SETQ TYPE (QUOTE FIX)))
(COND
[[AND (EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(NUMBERP (fetch OPARG of (CAR CODE]
(CW COMPILE TIME FIX)
(COMP.STCONST (PROG1 (APPLY* TYPE (fetch OPARG of (CAR CODE)))
(COMP.DELPUSH]
((AND (EQ TYPE (QUOTE FIX))
(OPT.CALLP (CAR CODE)
NUMBERFNS)))
(T (COMP.STFN TYPE 1])
(COMP.DELFIX
[LAMBDA (TYPE) (* lmm "16-APR-82 00:19")
(* have compiled call to number function;
delete any coersions-to-TYPE)
(while (OPT.CALLP (CAR CODE)
(SELECTQ TYPE
((FIX NIL)
(QUOTE (IPLUS FIX)))
(FLOAT (QUOTE FLOAT))
(QUOTE PLUS))
1)
do (COMP.DELFN])
)
(PUTPROPS EQ BYTEMACRO COMP.EQ)
(PUTPROPS EQUAL BYTEMACRO COMP.EQ)
(PUTPROPS EQP BYTEMACRO COMP.EQ)
(DEFINEQ
(COMP.EQ
[LAMBDA (A) (* lmm "16-APR-82 00:28")
(COND
(EFF (COMP.PROGN A))
(T (PROG (C)
(COMP.VAL (pop A))
[COND
((OR OPTIMIZATIONSOFF (NEQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST)))
(COMP.VAL1 A))
([NULL (SETQ C (fetch OPARG of (CAR CODE]
(CW (EQ NIL --))
(COMP.DELPUSH)
(RETURN (COMP.NOT A)))
(T (COMP.DELPUSH)
(COMP.VAL1 A)
(COND
[(EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(CW (EQ CONST CONST))
(RETURN (COMP.STCONST (PROG1 (APPLY* (CAR EXP)
C
(fetch OPARG of (CAR CODE)))
(COMP.DELPUSH]
(T (CW (EQ CONST EXPRESSION))
(COMP.STCONST C]
(RETURN (COMP.STFN (COND
([AND (EQ (fetch OPNAME of (CAR CODE))
(QUOTE CONST))
(LITATOM (fetch OPARG of (CAR CODE]
(* EQ IFF EQUAL)
(QUOTE EQ))
(T (CAR EXP)))
2])
)
(PUTPROPS .TEST. BYTEMACRO (APPLY COMP.NUMBERTEST))
(DEFINEQ
(COMP.NUMBERTEST
[LAMBDA (X FORM FLG) (* lmm "16-APR-82 00:29")
(PROG (EXIT (TEST (SUBPAIR (QUOTE (*))
(LIST DONOTHING)
FORM))
A)
(COMP.EXPR X)
(RETURN (SELECTQ (fetch OPNAME of PREDF)
((FJUMP TJUMP NFJUMP)
(CW .TEST. in PREDF)
(COMP.EXPR TEST NIL NIL PREDF))
[NTJUMP (COND
((OR (FMEMB (fetch OPNAME of (SETQ A (CAR CODE)))
(QUOTE (AVAR HVAR GVAR FVAR)))
(AND (EQ (fetch OPNAME of A)
(QUOTE SETQ))
(PROGN (SETQ A (fetch OPARG of A))
T)))
(CW .TEST. VAR in NTJUMP)
[COMP.EXPR TEST NIL NIL (create JUMP
OPNAME ←(QUOTE FJUMP)
TAG ←(SETQ EXIT (create TAG]
(COMP.STVAR A)
(COMP.STJUMP (QUOTE JUMP)
(fetch (JUMP TAG) of PREDF))
(COMP.STTAG EXIT)
(RETURN (QUOTE PREDVALUE)))
(T (CW .TEST. in NTJUMP PREDF)
(COMP.STCOPY)
[COMP.EXPR TEST NIL NIL (create JUMP
OPNAME ←(QUOTE FJUMP)
TAG ←(SETQ EXIT (create
TAG]
(COMP.STJUMP (QUOTE JUMP)
(fetch (JUMP TAG) of PREDF))
(COMP.STTAG EXIT)
(COMP.STPOP)
(RETURN (QUOTE PREDVALUE]
(COND
((OR (FMEMB (fetch OPNAME of (SETQ A (CAR CODE)))
(QUOTE (AVAR HVAR GVAR FVAR)))
(AND (EQ (fetch OPNAME of A)
(QUOTE SETQ))
(PROGN (SETQ A (fetch OPARG of A))
T)))
(CW .TEST. VAR not in PREDF)
[COMP.EXPR TEST NIL NIL (create JUMP
OPNAME ←(QUOTE NFJUMP)
TAG ←(SETQ EXIT (create TAG]
(COMP.STVAR A)
(COMP.STTAG EXIT))
(T (CW .TEST. not in PREDF)
(COMP.STCOPY)
[COMP.EXPR TEST NIL NIL (create JUMP
OPNAME ←(QUOTE TJUMP)
TAG ←(SETQ EXIT (create TAG]
(COMP.STPOP)
(COMP.STCONST)
(COMP.STTAG EXIT])
)
(RPAQQ MAPFNS (MAP MAPC MAPLIST MAPCAR MAPCON MAPCONC SUBSET SOME EVERY NOTANY NOTEVERY))
(PUTPROPS MAP BYTEMACRO (APPLY* COMP.MAP))
(PUTPROPS MAPC BYTEMACRO (APPLY* COMP.MAP T))
(PUTPROPS MAPLIST BYTEMACRO (APPLY* COMP.MAP NIL T))
(PUTPROPS MAPCAR BYTEMACRO (APPLY* COMP.MAP T T))
(PUTPROPS MAPCON BYTEMACRO (APPLY* COMP.MAP NIL J))
(PUTPROPS MAPCONC BYTEMACRO (APPLY* COMP.MAP T J))
(PUTPROPS SUBSET BYTEMACRO (APPLY* COMP.MAP T S))
(PUTPROPS SOME BYTEMACRO (APPLY* COMP.MAP BOTH NIL TJUMP))
(PUTPROPS EVERY BYTEMACRO (APPLY* COMP.MAP BOTH NIL FJUMP T))
(PUTPROPS NOTANY BYTEMACRO (APPLY* COMP.MAP BOTH NIL TJUMP T))
(PUTPROPS NOTEVERY BYTEMACRO (APPLY* COMP.MAP BOTH NIL FJUMP NIL))
(PUTPROPS .DOCOLLECT. BYTEMACRO [(VAL TAIL ITEM)
(COND [(NOT TAIL)
(SETQ TAIL (SETQ VAL (LIST ITEM]
(T (FRPLACD TAIL (SETQ TAIL (LIST ITEM])
(PUTPROPS .DOJOIN. BYTEMACRO [(VAL TAIL ITEM)
(AND (LISTP ITEM)
(COND (TAIL (FRPLACD (SETQ TAIL (LAST TAIL))
ITEM))
(T (SETQ TAIL (SETQ VAL ITEM])
(DEFINEQ
(COMP.MAP
[LAMBDA (L CARFLG COLLECT PRED NEG WHILEF) (* lmm "16-APR-82 00:29")
(CW compile call to mapping function)
(PROG [(FROMFORM (CAR L))
(DOF (CADR L))
(BYF (CADDR L))
BOUNDVARS BINDVALS F VAL (XARG (QUOTE ($X]
[COND
[(COMP.APPLYFNP DOF)
(SETQ DOF (CADR DOF))
(COND
((AND (NOT CARFLG)
(EQ (CAR (LISTP DOF))
(QUOTE LAMBDA))) (* leave DOF alone)
NIL)
(T (SETQ DOF (LIST (QUOTE LAMBDA)
XARG
(CONS DOF (COND
([AND (EQ CARFLG (QUOTE BOTH))
(NOT (AND (COMP.CLEANFNP DOF (QUOTE NARGS))
(EQ (NARGS DOF)
1]
(QUOTE ((CAR $X)
$X)))
[CARFLG (QUOTE ((CAR $X]
(T (QUOTE ($X]
(T (CW map function with computed functional arg)
(SETQ BINDVALS (LIST DOF FROMFORM))
[SETQ BOUNDVARS (LIST (QUOTE $F1)
(SETQ FROMFORM (QUOTE $L]
(SETQ DOF (LIST (QUOTE LAMBDA)
XARG
(SELECTQ CARFLG
(BOTH (QUOTE (APPLY* $F1 (CAR $X)
$X)))
(NIL (QUOTE (APPLY* $F1 $X)))
(QUOTE (APPLY* $F1 (CAR $X]
[COND
((NULL BYF)
(SETQ BYF (QUOTE CDR)))
[(COMP.APPLYFNP BYF)
(CW mapping function with BY argument)
(OR (EQ [CAR (LISTP (SETQ BYF (CADR BYF]
(QUOTE LAMBDA))
(SETQ BYF (LIST (QUOTE LAMBDA)
XARG
(LIST BYF (QUOTE $X]
(T (CW mapping function with computed BY argument)
(SETQ BINDVALS (CONS BYF BINDVALS))
(SETQ BOUNDVARS (CONS (QUOTE $F2)
BOUNDVARS))
(SETQ BYF (QUOTE (LAMBDA ($X)
(COND
((NULL $F2)
(CDR $X))
(T (APPLY* $F2 $X]
[COND
((NULL WHILEF)
(SETQ WHILEF (QUOTE LISTP)))
[(COMP.APPLYFNP WHILEF)
(OR (EQ [CAR (LISTP (SETQ WHILEF (CADR WHILEF]
(QUOTE LAMBDA))
(SETQ WHILEF (LIST (QUOTE LAMBDA)
XARG
(LIST WHILEF (QUOTE $X]
(T (SETQ BINDVALS (CONS (LIST (QUOTE OR)
WHILEF
(QUOTE (QUOTE LISTP)))
BINDVALS))
(SETQ BOUNDVARS (CONS (QUOTE $F3)
BOUNDVARS))
(SETQ WHILEF (QUOTE (LAMBDA ($X)
(APPLY* $F3 $X]
[COND
(COLLECT (push BINDVALS NIL NIL NIL NIL)
(push BOUNDVARS (SETQ VAL (QUOTE $V))
(QUOTE $Z)
(QUOTE $W)
(QUOTE $X] (* bind extra vars)
(SETQ F (COMP.BIND.VARS (OPT.DREV BOUNDVARS)
(OPT.DREV BINDVALS)
(QUOTE MAP)))
[PROG ((ALLVARS (APPEND (fetch VARS of F)
ALLVARS))
(SPECVARS SPECVARS)
(LOCALVARS LOCALVARS)
(LP (create TAG))
(ENDLP (create TAG))
(OUT (create TAG))
NXT)
(COMP.STBIND F)
[COMP.EFFECT (QUOTE (DECLARE (LOCALVARS $F1 $F2 $X $V $Z $W $F3]
(COMP.VAL FROMFORM)
(OPT.CCHECK (AND (EQ LEVEL 1)
(EQ FRAME F)))
(COMP.STJUMP (QUOTE JUMP)
ENDLP)
(SETQ LEVEL 1)
(SETQ FRAME F)
(COMP.STTAG LP)
(COMP.STCOPY)
[COND
(COLLECT (OPT.CCHECK (NOT PRED))
(SELECTQ COLLECT
[(T J) (* collect or join)
(COMP.EFFECT (LIST (QUOTE SETQ)
(QUOTE $X)
DONOTHING))
[COMP.EFFECT (LIST (QUOTE SETQ)
(QUOTE $W)
(COND
((EQ (CADR DOF)
XARG)
(CADDR DOF))
(T (LIST DOF (QUOTE $X]
(COMP.EFFECT (SELECTQ COLLECT
(J (QUOTE (.DOJOIN. $V $Z $W)))
(QUOTE (.DOCOLLECT. $V $Z $W]
(S (* SUBSET)
[COMP.EXPR (LIST DOF DONOTHING)
NIL NIL (create JUMP
OPNAME ←(QUOTE FJUMP)
TAG ←(SETQ NXT (create TAG]
(COMP.STCOPY)
(COMP.EFFECT (LIST (QUOTE SETQ)
(QUOTE $W)
(LIST (QUOTE CAR)
DONOTHING)))
(COMP.EFFECT (QUOTE (.DOCOLLECT. $V $Z $W)))
(COMP.STTAG NXT))
(SHOULDNT)))
(PRED (COMP.EXPR (LIST DOF DONOTHING)
NIL NIL (create JUMP
OPNAME ← PRED
TAG ← OUT)))
(T (COMP.EFFECT (LIST DOF DONOTHING]
(OPT.CCHECK (EQ LEVEL 1))
(COMP.EXPR (LIST BYF DONOTHING)) (* get next element)
(COMP.STTAG ENDLP)
(COMP.EXPR (LIST WHILEF DONOTHING))
(COMP.STJUMP (QUOTE NTJUMP)
LP)
(COND
[PRED (COND
((AND (EQ PRED (QUOTE TJUMP))
(NULL NEG))
(COMP.VAL NIL)
(COMP.STTAG OUT))
(T (COMP.VAL NEG)
(COMP.STJUMP (QUOTE JUMP)
(SETQ NXT (create TAG)))
(COMP.STTAG OUT)
(COMP.STPOP)
(COMP.VAL (NULL NEG))
(COMP.STTAG NXT]
(T (COMP.VAL VAL]
(RETURN (COMP.UNBIND.VARS F])
)
(PUTPROPS LISPXWATCH BYTEMACRO T)
(PUTPROPS FETCHFIELD BYTEMACRO T)
(PUTPROPS REPLACEFIELD BYTEMACRO T)
(PUTPROPS FFETCHFIELD BYTEMACRO (= . FETCHFIELD))
(PUTPROPS FREPLACEFIELD BYTEMACRO (= . REPLACEFIELD))
(PUTPROPS REPLACEFIELDVAL BYTEMACRO T)
(PUTPROPS FREPLACEFIELDVAL BYTEMACRO (= . REPLACEFIELDVAL))
(PUTPROPS GETPROP BYTEMACRO (= . GETP))
(PUTPROPS BLKAPPLY BYTEMACRO (= . APPLY))
(PUTPROPS BLKAPPLY* BYTEMACRO (= . APPLY*))
(PUTPROPS ADD1VAR BYTEMACRO ((X)
(SETQ X (ADD1 X))))
(PUTPROPS SUB1VAR BYTEMACRO ((X)
(SETQ X (SUB1 X))))
(PUTPROPS KWOTE BYTEMACRO (OPENLAMBDA (Q)
(COND ((AND Q (NEQ Q T)
(NOT (NUMBERP Q)))
(LIST (QUOTE QUOTE)
Q))
(T Q))))
(PUTPROPS FRPLNODE BYTEMACRO (OPENLAMBDA (X A D)
(FRPLACD (FRPLACA X A)
D)))
(PUTPROPS RPLNODE BYTEMACRO (OPENLAMBDA (X A D)
(RPLACD (RPLACA X A)
D)))
(PUTPROPS LISTGET1 BYTEMACRO (OPENLAMBDA (X Y)
(CADR (MEMB Y X))))
(PUTPROPS FRPLNODE2 BYTEMACRO (OPENLAMBDA (X Y)
(FRPLACD (FRPLACA X (CAR Y))
(CDR Y))))
(PUTPROPS JSYS BYTEMACRO COMP.PUNT)
(PUTPROPS EQMEMB BYTEMACRO (OPENLAMBDA (X Y)
(OR (EQ X Y)
(AND (LISTP Y)
(FMEMB X Y)
T))))
(PUTPROPS MKLIST BYTEMACRO [OPENLAMBDA (X)
(OR (LISTP X)
(AND X (LIST X])
(* Pass 1 listing)
(DEFINEQ
(COMP.MLLIST
[LAMBDA (FN CC) (* lmm: "13-NOV-76 06:56:28")
(RESETLST (RESETSAVE (RADIX 10))
(RESETSAVE (LINELENGTH 72))
(PRIN2 FN)
(MAPRINT (fetch ARGS of CC)
NIL "(" ")" " " (FUNCTION COMP.MLLVAR))
(SPACES 5)
[PRINT (CDR (FASSOC (fetch COMTYPE of CC)
(QUOTE ((0 . LAMBDA)
(2 . LAMBDA*)
(1 . NLAMBDA)
(2 . NLAMBDA*)
(NIL . ???]
(COMP.MLL (fetch CODE of CC])
(COMP.MLL
[LAMBDA (LL) (* lmm " 8-MAY-81 23:29")
[MAPC LL (FUNCTION (LAMBDA (X)
(COND
((type? TAG X)
(OR (ZEROP (POSITION))
(TERPRI))
(PRIN2 (fetch (TAG LBNO) of X))
(PRIN1 (QUOTE :)))
(T (PROG ((S (GETP (fetch OPNAME of X)
(QUOTE MLSYM)))
(P (POSITION)))
(COND
((ILESSP P 5)
(SPACES (IDIFFERENCE 6 P)))
((IGREATERP P 60)
(TERPRI)
(SPACES 6))
(T (SPACES 1)))
(AND (CAR S)
(PRIN1 (CAR S)))
[SELECTQ (CDDR S)
(CONST (PRIN2 (fetch OPARG of X)))
(VAR (COMP.MLLVAR X))
(FN (* FN and LINKEDFN)
(COMP.MLLFN X))
(VREF (* SETQ ARG)
(COMP.MLLVAR (fetch OPARG of X)))
[JUMP (PRIN2 (fetch (TAG LBNO) of (fetch (JUMP TAG) of X]
[BIND (PROG [NN N (F (CDR (fetch OPARG of X]
(SETQ N (SETQ NN (fetch NVALS of F)))
[MAPC (fetch VARS of F)
(FUNCTION (LAMBDA (V)
[PRIN1 (COND
((EQ N NN)
(* 1st one)
"")
((ZEROP N)
(QUOTE ;))
(T (QUOTE ,]
(SETQ N (SUB1 N))
(COMP.MLLVAR V]
(COND
((ZEROP N) (* All val-bound)
(PRIN1 ";"]
[UNBIND (PRIN1 (CAR (fetch OPARG of X]
(PROGN (PRIN1 (fetch OPNAME of X))
(AND (fetch OPARG of X)
(PRIN1 (LIST (fetch OPARG of X]
(AND (CADR S)
(PRIN1 (CADR S]
(TERPRI)
(TERPRI])
(COMP.MLLVAR
[LAMBDA (X N) (* lmm "30-AUG-83 10:48")
(SETQ N (fetch (VAR VARNAME) of X))
(PRIN2 (SELECTQ (fetch OPNAME of X)
(HVAR (PRIN1 "@")
N)
(XVAR (QUOTE XVAR))
N])
(COMP.MLLFN
[LAMBDA (X FN) (* lmm "27-OCT-81 20:26")
[PRIN2 (SETQ FN (CDR (fetch OPARG of X]
(SETQ X (CAR (fetch OPARG of X)))
(AND (LITATOM FN)
(OR (AND (ZEROP (ARGTYPE FN))
(EQ (NARGS FN)
X))
(PROGN (SPACES 1)
(PRIN2 X])
)
(RPAQQ COPS (BIND UNBIND DUNBIND ERRORSET JUMP TJUMP FJUMP NTJUMP NFJUMP POP COPY RETURN TAG FN CONST
SETQ AVAR HVAR GVAR FVAR STORE))
(PUTPROPS BIND MLSYM (BIND NIL . BIND))
(PUTPROPS UNBIND MLSYM (UNBIND NIL . UNBIND))
(PUTPROPS DUNBIND MLSYM ("DUNBIND(" %) . UNBIND))
(PUTPROPS ERRORSET MLSYM (ERRORSET . JUMP))
(PUTPROPS JUMP MLSYM (JUMP . JUMP))
(PUTPROPS TJUMP MLSYM (TJUMP . JUMP))
(PUTPROPS FJUMP MLSYM (FJUMP . JUMP))
(PUTPROPS NTJUMP MLSYM (NTJUMP . JUMP))
(PUTPROPS NFJUMP MLSYM (NFJUMP . JUMP))
(PUTPROPS FN MLSYM (NIL . FN))
(PUTPROPS CONST MLSYM (' NIL . CONST))
(PUTPROPS SETQ MLSYM (SETQ< > . VREF))
(PUTPROPS AVAR MLSYM (< > . VAR))
(PUTPROPS HVAR MLSYM (< > . VAR))
(PUTPROPS GVAR MLSYM (< > . VAR))
(PUTPROPS FVAR MLSYM (< > . VAR))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: COMP.MLL COMP.MLL COMP.MLLFN (NOLINKFNS . T))
]
(* ARJ - JUMP LENGTH RESOLVER)
(DEFINEQ
(OPT.RESOLVEJUMPS
[LAMBDA (JL PROP FN) (* lmm "19-JUL-80 10:00")
(PROG ((CU 0)
Z NEW)
[for X in JL
do (replace JSN of X with (fetch JMIN of X))
(COND
[(fetch JPT of X) (* Jump)
(SETQ Z (CAR (GETPROP (fetch OPNAME of (CAR (fetch JPT of X)))
PROP)))
(replace JML of X with (CAR Z))
(add CU (replace JU of X with (IDIFFERENCE (CDR Z)
(CAR Z]
(T (* Tag)
(replace JU of X with CU]
(while (LISTP (SETQ NEW (OPT.JLENPASS JL PROP))) do (SETQ JL NEW))
(COND
(NEW (OPT.JFIXPASS JL FN])
(OPT.JLENPASS
[LAMBDA (JL PROP) (* lmm "19-JUL-80 10:08")
(PROG ((INC 0)
(DEC 0)
(CU 0)
X U U1 DEF MIN ML SMIN SMAX)
(* JPT is NIL (for tags) or a pointer into ACODE (for jumps). JMIN is the lowest possible location for the
instruction or tag. JU is the cumulative uncertainty (for tags) or the length uncertainty
(for jumps). JML is the minimum length (for jumps). JSN is a serial number (the original JMIN) used to decide
whether a jump goes forward or backward.)
(* In the loop, CU is the cumulative uncertainty, DEC is the cumulative decrease in uncertainty, and INC is the
cumulative increase in minimum location.)
[for J in JL
do (SETQ X (CAR (fetch JPT of J)))
(add (fetch JMIN of J)
INC)
(COND
((NULL X)
(SETQ DEC (IDIFFERENCE CU (fetch JU of J)))
(replace JU of J with CU))
((NEQ (SETQ U (fetch JU of J))
0)
[SETQ DEF (fetch (TAG JD) of (CAR (fetch OPARG of X]
(SETQ MIN (IDIFFERENCE (fetch JMIN of DEF)
(fetch JMIN of J)))
(SETQ SMAX (OPT.JSIZE X (IPLUS (IDIFFERENCE (fetch JU of DEF)
CU)
(COND
((IGREATERP (fetch JSN of DEF)
(fetch JSN of J))
(IPLUS (SETQ MIN (IPLUS MIN INC))
DEC))
(T MIN)))
PROP))
(SETQ SMIN (OPT.JSIZE X MIN PROP))
[COND
((NEQ SMIN (SETQ ML (fetch JML of J)))
(replace JML of J with SMIN)
(add INC (IDIFFERENCE SMIN ML]
(COND
((NEQ (SETQ U1 (IDIFFERENCE SMAX SMIN))
U)
[COND
((ILESSP U1 0)
(OPT.COMPILERERROR (QUOTE (U1 negative]
(add DEC (IDIFFERENCE U1 U))
(replace JU of J with U1)))
(add CU U1]
(RETURN (COND
((AND (NEQ DEC 0)
(NEQ CU 0))
JL)
(T T])
(OPT.JFIXPASS
[LAMBDA (JL FN) (* lmm "19-JUL-80 10:23")
(PROG (X)
(for J in JL do (COND
([NULL (SETQ X (CAR (fetch JPT of J]
(replace JU of J with 0))
(T (APPLY* FN (fetch JPT of J)
(IDIFFERENCE [fetch JMIN
of (fetch (TAG JD)
of (CAR (fetch OPARG of X]
(fetch JMIN of J])
(OPT.JSIZE
[LAMBDA (OP D FN) (* lmm "27-OCT-81 20:28")
(PROG [(Z (CDR (GETPROP (fetch OPNAME of OP)
FN]
LP (COND
((NLISTP Z)
(RETURN Z))
(T [SETQ Z (COND
((ILESSP D (CAR Z))
(CADR Z))
(T (CDDR Z]
(GO LP])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: OPT.RESOLVEJUMPS OPT.RESOLVEJUMPS OPT.JLENPASS OPT.JFIXPASS (NOLINKFNS . T))
]
(* utilities used by all files)
(DEFINEQ
(OPT.CALLP
[LAMBDA (OP FN N) (* lmm: "22-JUL-77 02:40")
(AND (EQ (fetch OPNAME of OP)
(QUOTE FN))
(OR (NULL N)
(EQ (CAR (fetch OPARG of OP))
N))
(OR (NULL FN)
(EQ (CDR (fetch OPARG of OP))
FN)
(AND (LISTP FN)
(FMEMB (CDR (fetch OPARG of OP))
FN])
(OPT.JUMPCHECK
[LAMBDA (C) (* lmm: "22-JUL-77 02:39")
(SELECTQ (fetch OPNAME of (CAR C))
((JUMP RETURN)
T)
NIL])
(OPT.DREV
[LAMBDA (L Z)
(PROG (Y)
R1 (COND
((NLISTP (SETQ Y L))
(RETURN Z)))
(SETQ L (CDR L))
(SETQ Z (FRPLACD Y Z))
(GO R1])
(OPT.CHLEV
[LAMBDA (N) (* lmm "14-MAR-81 09:54")
(COND
(LEVEL (PROG1 (add LEVEL N)
(OPT.CCHECK (IGEQ LEVEL 0])
(OPT.CHECKTAG
[LAMBDA (TAG TAGFLAG) (* lmm "14-MAR-81 09:15")
(COND
((NULL LEVEL)
(replace (TAG LEVEL) of TAG with NIL))
((NULL (fetch (TAG LEVEL) of TAG))
(AND TAGFLAG (SETQ LEVEL NIL)))
(T (OPT.CCHECK (EQ LEVEL (fetch (TAG LEVEL) of TAG)))
T])
(OPT.NOTJUMP
[LAMBDA (X) (* lmm: "22-JUL-77 03:39")
(PROG NIL
(RETURN (create OP
OPNAME ←(OR (SELECTQ (fetch OPNAME of X)
(FJUMP (QUOTE TJUMP))
(TJUMP (QUOTE FJUMP))
NIL)
(RETURN))
OPARG ←(fetch OPARG of X])
(OPT.INITHASH
[NLAMBDA (X) (* rmk: " 3-Jan-84 13:18")
(COND
([OR (HARRAYP (EVALV X))
(HARRAYP (CAR (LISTP (EVALV X]
(CLRHASH (EVALV X)))
(T (SET X (HASHARRAY 100])
(OPT.COMPINIT
[LAMBDA NIL (* lmm: "22-JUL-77 16:51")
[MAPC (QUOTE ((OPRETURN . RETURN)
(OPPOP . POP)
(OPCOPY . COPY)
(OPNIL . CONST)))
(FUNCTION (LAMBDA (X)
(SET (CAR X)
(create OP
OPNAME ←(CDR X]
(SETQ DONOTHING (LIST (QUOTE AC])
)
(MOVD? (QUOTE NILL)
(QUOTE REFRAME))
(AND (GETD (QUOTE OPT.COMPINIT))
(OPT.COMPINIT))
(PUTPROPS LOADTIMECONSTANT BYTEMACRO (= . DEFERREDCONSTANT))
(PUTPROPS FRPTQ BYTEMACRO OPT.CFRPTQ)
(DEFINEQ
(OPT.CFRPTQ
[LAMBDA (L) (* lmm "16-APR-82 00:29")
(COND
(EFF (PROG ((END (create TAG))
(ST (create TAG)))
(COMP.VAL (CAR L)) (* counter)
(COMP.STTAG ST)
(COMP.STCOPY)
(COMP.VAL 0)
(COMP.STFN (QUOTE IGREATERP)
2)
(COMP.STJUMP (QUOTE FJUMP)
END)
(COMP.VALN (CDR L)
T)
(COMP.VAL 1)
(COMP.STFN (QUOTE IDIFFERENCE)
2)
(COMP.STJUMP (QUOTE JUMP)
ST)
(COMP.STTAG END)))
(T (COMP.EXP1 (CONS (QUOTE RPTQ)
L])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: BYTECOMPBLOCK COMP.ANONP COMP.APPLYFNP COMP.ARGTYPE COMP.BINDLIST COMP.BIND.VARS
BYTEBLOCKCOMPILE2 BYTECOMPILE2 COMP.AC COMP.BOOL COMP.CALL COMP.COMMENT COMP.COND COMP.CONST
COMP.CARCDR COMP.DECLARE COMP.DECLARE1 COMP.EFFECT COMP.EQ COMP.EXP1 COMP.EXPR OPT.CFRPTQ
COMP.FUNCTION COMP.GO COMP.CHECK.VAR COMP.LAMBDA COMP.LAM1 COMP.MACRO COMP.MAP
COMP.NUMBERCALL COMP.NOT COMP.NUMBERTEST COMP.NUMERIC COMP.CPI COMP.CPI1 COMP.PROG COMP.PROG1
COMP.PROGN COMP.QUOTE COMP.RETURN COMP.SELECTQ COMP.SETN COMP.SETQ COMP.VAL COMP.VAL1
COMP.VALN COMP.VAR COMP.DELPOPP COMP.GENFN COMP.LOOKUPVAR COMP.ATTEMPT.COMPILE
COMP.RETFROM.POINT COMP.TOPLEVEL.COMPILE COMP.PICOUNT COMP.TRYUSERFN COMP.UNBIND.VARS
COMP.VARTYPE (ENTRIES BYTEBLOCKCOMPILE2 BYTECOMPILE2 COMP.VAL1 COMP.VAL COMP.EFFECT COMP.EXPR
COMP.EXP1 COMP.LAM1 COMP.CALL COMP.LOOKUPVAR COMP.CONST COMP.PROGN)
(BLKAPPLYFNS COMP.AC COMP.BOOL COMP.COMMENT COMP.COND COMP.CARCDR COMP.DECLARE COMP.EQ
COMP.EXP1 COMP.EXPR COMP.FUNCTION COMP.GO COMP.LAM1 COMP.MAP COMP.NUMBERCALL
COMP.NOT COMP.NUMBERTEST COMP.NUMERIC COMP.PROG COMP.PROG1 COMP.PROGN COMP.QUOTE
COMP.RETURN COMP.SELECTQ COMP.SETN COMP.SETQ OPT.CFRPTQ)
(SPECVARS AC ALAMS1 ALLVARS ARGS ARGVARS BLKDEFS BLKFLG CODE COMFN COMFNS COMTYPE CONSTS EFF
EMFLAG EXP FRAME FREELST FREEVARS LAPFLG LBCNT LEVEL LOCALVARS LOCALVARS LSTFIL
MACEXP NLAMS1 PIFN PREDF PROGEFF PROGRETF RETF RETURNLABEL SPECVARS SPECVARS
SUBFNFREEVARS TAGS TOPFN TOPFRAME TOPLAB VARS INTERNALBLKFNS)
(RETFNS COMP.VAR COMP.RETFROM.POINT)
(NOLINKFNS COMPPRINT COMPERRM))
(BLOCK: NIL COMP.USERFN COMPERRM (SPECVARS PLVLFILEFLG))
]
(PUTPROPS IMAX2 BYTEMACRO (OPENLAMBDA (X Y)
(COND ((NOT (IGREATERP X Y))
Y)
(T X))))
(PUTPROPS IMIN2 BYTEMACRO (OPENLAMBDA (X Y)
(COND ((IGREATERP X Y)
Y)
(T X))))
(ADDTOVAR COMPILETYPELST )
(RPAQQ POSTOPTCOMS [(* POST OPTIMIZATION)
(FNS OPT.POSTOPT OPT.SETUPOPT OPT.SCANOPT OPT.XVARSCAN OPT.XVARSCAN1 OPT.JUMPOPT OPT.JUMPTHRU
OPT.LBMERGE OPT.PRDEL OPT.UBDEL OPT.LBDEL OPT.LABELNTHPR OPT.JUMPREV OPT.COMMONBACK
OPT.DELTAGREF OPT.FINDEND OPT.RETOPT OPT.RETFIND OPT.RETPOP OPT.RETOPT1 OPT.RETTEST
OPT.RETMERGE OPT.CODELEV OPT.CODEFRAME OPT.DEFREFS OPT.SETDEFREFS)
(FNS OPT.FRAMEOPT OPT.FRAMEMERGE OPT.NONILVAR OPT.MERGEFRAMEP OPT.FRAMELOCAL OPT.CLEANFRAME
OPT.FRAMEDEL OPT.FRAMEVAR OPT.DELETEFRAMECHECK OPT.ONLYMEMB)
(VARS MERGEFRAMETYPES (OPTIMIZATIONSOFF))
(FNS OPT.SKIPPUSH OPT.DELCODE OPT.PRATTACH OPT.JUMPCOPYTEST OPT.EQOP OPT.EQVALUE
OPT.DELCOPYFN)
(FNS OPT.DEADSETQP OPT.DS1)
(BLOCKS (NIL OPT.PRDEL OPT.PRATTACH OPT.EQOP OPT.EQVALUE OPT.SKIPPUSH OPT.CODEFRAME
OPT.LABELNTHPR OPT.UBDEL OPT.DELCODE (LOCALVARS . T)
(SPECVARS CODE LEVEL))
(NIL OPT.POSTOPT OPT.SETUPOPT OPT.JUMPOPT (LOCALVARS . T)
(SPECVARS LABELS PASS ANY CODE FRAME FRAMES))
(OPT.FRAMEOPT OPT.FRAMEOPT OPT.CLEANFRAME OPT.DELETEFRAMECHECK OPT.FRAMEDEL
OPT.FRAMELOCAL OPT.FRAMEMERGE OPT.FRAMEVAR OPT.MERGEFRAMEP OPT.NONILVAR
OPT.ONLYMEMB (GLOBALVARS MERGEFRAMEMAX MERGEFRAMEFLG MERGEFRAMETYPES)
(SPECVARS VARS ANY FRAME)
(NOLINKFNS . T))
(OPT.SCANOPT OPT.SCANOPT OPT.DEADSETQP OPT.DS1 (SPECVARS TAGS)
(NOLINKFNS . T)
(LOCALFREEVARS ICNT))
(NIL OPT.DELCOPYFN OPT.JUMPTHRU OPT.LBMERGE OPT.LBDEL OPT.JUMPCOPYTEST (LOCALVARS . T)
(SPECVARS FRAME LEVEL ANY)
(NOLINKFNS . T))
(OPT.JUMPREV OPT.JUMPREV OPT.COMMONBACK OPT.DELTAGREF OPT.FINDEND
(SPECVARS FRAME LEVEL ANY)
(NOLINKFNS . T))
(OPT.RETOPT OPT.RETOPT OPT.RETFIND OPT.RETPOP OPT.RETTEST OPT.RETOPT1 OPT.RETMERGE
(SPECVARS TAGS ANY)
(NOLINKFNS . T])
(* POST OPTIMIZATION)
(DEFINEQ
(OPT.POSTOPT
[LAMBDA (CODE) (* lmm "18-DEC-82 00:05")
(COND
[OPTIMIZATIONSOFF (while CODE bind C VAL
do (SETQ TAGS NIL)
(while (EQ (fetch OPNAME of (SETQ C (pop CODE)))
(QUOTE TAG))
do (push TAGS C))
(while (AND (EQ (fetch OPNAME of C)
(QUOTE JUMP))
(FMEMB (fetch OPARG of C)
TAGS))
do (SETQ C (pop CODE)))
(for TAG in TAGS do (push VAL TAG))
(push VAL C)
finally (RETURN (CDR VAL]
(T (PROG ((FRAME TOPFRAME)
LABELS ANY (FRAMES (LIST (LIST TOPFRAME)))
(PASS 1)
DELETEDBINDS)
(SETQ CODE (CONS NIL (NCONC1 CODE NIL)))
(OPT.SETUPOPT)
OPTLP
(SETQ ANY)
(CW optimization pass)
(AND (OPT.FRAMEOPT (EQ PASS 1))
(SETQ ANY T))
(OPT.SCANOPT)
(OPT.JUMPOPT)
(OPT.RETOPT)
(OPT.CCHECK (OPT.OPTCHECK))
[COND
((NOT ANY)
(AND [NOT (OR (AND XVARFLG (PROGN (OPT.XVARSCAN)
(OPT.FRAMEOPT T NIL T)))
(AND MERGEFRAMEFLG (OPT.FRAMEOPT T T XVARFLG]
(RETURN (CDR (OPT.DREV (CDR CODE]
(SETQ PASS (ADD1 PASS))
(GO OPTLP])
(OPT.SETUPOPT
[LAMBDA NIL (* lmm: "22-JUL-77 02:59")
(* set up code list as doubly linked list, scan for
tags)
(PROG ((C CODE)
P B)
LPC (COND
((NULL C)
(RETURN)))
(SELECTQ (fetch OPNAME of (CAR C))
[TAG (COND
((SETQ B (FASSOC (CAR C)
LABELS))
(FRPLACA (CDR B)
C))
(T (SETQ LABELS (CONS (LIST (CAR C)
C)
LABELS]
[(JUMP TJUMP FJUMP NTJUMP NFJUMP ERRORSET)
(COND
((SETQ B (FASSOC (fetch (JUMP TAG) of (CAR C))
LABELS))
(NCONC1 B C))
(T (SETQ LABELS (CONS (LIST (fetch (JUMP TAG) of (CAR C))
NIL C)
LABELS]
NIL)
(SELECTQ (fetch OPNAME of (CAR C))
[(ERRORSET BIND)
(COND
((SETQ B (FASSOC (CDR (fetch OPARG of (CAR C)))
FRAMES))
(RPLACA (CDR B)
C))
(T (SETQ FRAMES (CONS (LIST (CDR (fetch OPARG of (CAR C)))
C)
FRAMES]
[(UNBIND DUNBIND)
(COND
((SETQ B (FASSOC (CDR (fetch OPARG of (CAR C)))
FRAMES))
(NCONC1 B C))
(T (SETQ FRAMES (CONS (LIST (CDR (fetch OPARG of (CAR C)))
NIL C)
FRAMES]
NIL)
(SETQ B (CDR C))
(replace PREV of C with B)
(replace NXT of C with P)
(SETQ P C)
(SETQ C B)
(GO LPC])
(OPT.SCANOPT
[LAMBDA NIL (* lmm "11-AUG-83 22:22")
(PROG ((CD CODE)
A B P X Y)
LP (SETQ B (fetch PREV of CD))
[AND P (OPT.CCHECK (EQ CD (fetch PREV of P]
(SELECTQ (fetch OPNAME of (SETQ A (CAR CD)))
(CONST (COND
((AND (OPT.CALLP (CAR P)
NIL 1)
(OR (FMEMB [SETQ X (CDR (fetch OPARG of (CAR P]
CONSTFNS)
(FMEMB X VCONDITIONALS)
(FMEMB X CONDITIONALS)))
(CW CONST FN.1 -> (FN CONST))
[RPLACA CD (create OP
OPNAME ←(QUOTE CONST)
OPARG ←(APPLY* X (fetch OPARG of A]
(OPT.PRDEL P)
(GO BLP))
([AND (SETQ A (FASSOC (fetch OPARG of A)
CONST.FNS))
(SOME (CDR A)
(FUNCTION (LAMBDA (X)
(OPT.CALLP (CAR P)
(CAR (SETQ A (CDR X)))
(CAR X]
(CW constant + fn -> otherfn)
(OPT.PRDEL CD)
(OPT.PRDEL P)
[MAPC (CDR A)
(FUNCTION (LAMBDA (X)
(SETQ B (OPT.PRATTACH (create OP
OPNAME ←(CAR X)
OPARG ←(CDR X))
B]
(GO BLP)))
(GO CHECKPUSH))
(HVAR (GO CHECKPUSH))
((AVAR GVAR FVAR)
(GO CHECKPUSH))
[SETQ (COND
((OPT.DEADSETQP (fetch OPARG of A)
P)
(CW delete dead SETQ)
(OPT.PRDEL CD)
(GO BLP]
(POP (SELECTQ (fetch OPNAME of (CAR B))
((AVAR HVAR FVAR GVAR COPY CONST)
(CW push POP deleted)
(OPT.PRDEL B)
(OPT.PRDEL CD)
(SETQ B P)
(GO BLP))
[FN (COND
((COMP.CLEANFNOP (CDR (fetch OPARG of (CAR B)))
(QUOTE NOSIDE))
(CW cleanfn POP deleted)
(RPTQ (PROG1 (CAR (fetch OPARG of (CAR B)))
(OPT.PRDEL B)
(OPT.PRDEL CD)
(SETQ B (fetch PREV of P)))
(SETQ B (OPT.PRATTACH OPPOP B)))
(GO BLP]
[SETQ (COND
([EQUAL (CAR (fetch PREV of B))
(CONSTANT (create OP
OPNAME ←(QUOTE COPY]
(CW COPY SETQ POP -> SETQ)
(OPT.PRDEL (fetch PREV of B))
(OPT.PRDEL CD)
(SETQ B P)
(GO BLP]
NIL))
[DUNBIND (COND
((EQ (CAR B)
OPPOP)
(CW merge pop with DUNBIND)
(OPT.PRDEL B) (* (DUNBIND level . frame))
[RPLACA (fetch OPARG of (CAR CD))
(ADD1 (CAR (fetch OPARG of (CAR CD]
(GO ALP]
[UNBIND (AND MERGEFRAMEFLG
(COND
((SELECTQ (fetch OPNAME of (CAR B))
[CONST (CW CONST UNBIND)
(replace OPNAME of A with (QUOTE DUNBIND))
(* change to DUNBIND)
(* level is 1 less)
(RPLACA (fetch OPARG of A)
(SUB1 (CAR (fetch OPARG of A]
(FN (COND
((AND (EQ (CAR (fetch OPARG of (CAR B)))
1)
(COMP.CLEANFNOP (CDR (fetch OPARG
of (CAR B)))
(QUOTE FREEVARS)))
(CW clean FN UNBIND)
T)))
NIL)
(RPLACA CD (CAR B))
(RPLACA B A) (* switch CONST and DUNBIND)
(RPLACA (MEMB CD (CDDR (FASSOC (CDR (fetch OPARG of A))
FRAMES)))
B)
(GO BLP]
NIL)
TAG2(COND
((NULL B)
(RETURN)))
(SETQ P CD)
(SETQ CD B)
(GO LP)
BLP (SETQ CD B)
CLP (SETQ P (fetch NXT of CD))
ALP (SETQ ANY T)
(GO LP)
CHECKPUSH
(AND NEWOPTFLG (SELECTQ (fetch OPNAME of (CAR B))
[POP (COND
((OPT.EQVALUE (fetch PREV of B)
CD)
(CW X POP X)
(OPT.PRDEL CD)
(OPT.PRDEL B)
(SETQ CD (fetch PREV of P))
(GO ALP]
NIL))
[COND
(NEWOPTFLG (COND
((SETQ X (OPT.JUMPCOPYTEST CD B)) (* can insert COPY at X and then delete CD)
(SETQ X (OPT.DELCOPYFN P X))
(SETQ P (fetch NXT of CD))
[COND
((EQ X (fetch PREV of CD))
(OPT.PRDEL CD))
(T (FRPLACA CD (QUOTE (SWAP]
(OPT.PRATTACH OPCOPY X)
(SETQ CD (fetch PREV of P))
(GO ALP)))
(COND
((AND (SETQ X (OPT.SKIPPUSH B 1 CD T))
(SETQ X (OPT.JUMPCOPYTEST CD X)))
(SETQ X (OPT.DELCOPYFN P X))
(OPT.PRATTACH OPCOPY X)
(FRPLACA CD (QUOTE (SWAP)))
(GO ALP)))
(GO TAG2))
(T (COND
((OPT.EQVALUE B CD)
(CW val val -> val COPY)
(FRPLACA CD OPCOPY))
((EQ (CAR B)
OPPOP)
(COND
((OPT.EQVALUE (fetch PREV of B)
CD)
(CW SETQ POP PUSH)
(OPT.PRDEL CD)
[OPT.PRDEL (PROG1 B (SETQ CD (fetch PREV of B]
(GO ALP]
(GO TAG2])
(OPT.XVARSCAN
[LAMBDA NIL (* lmm " 8-MAY-81 15:01")
(PROG ((CD CODE)
A)
[for X in FRAMES do (replace NOXVAR of (CAR X) with (NEQ NIL (OASSOC (QUOTE AVAR)
(fetch VARS
of (CAR X]
LP (SELECTQ (fetch OPNAME of (SETQ A (CAR CD)))
(HVAR (OPT.XVARSCAN1 A CD))
[SETQ (SETQ A (fetch OPARG of A))
(COND
((EQ (fetch OPNAME of A)
(QUOTE HVAR))
(OPT.XVARSCAN1 A CD]
((UNBIND DUNBIND)
(OR (OPT.CODELEV CD 0)
(replace NOXVAR of (CDR (fetch OPARG of A)) with T)))
NIL)
(COND
((NULL (SETQ CD (fetch PREV of CD)))
(RETURN)))
(GO LP])
(OPT.XVARSCAN1
[LAMBDA (A CD) (* lmm "22-MAY-81 17:55")
(PROG ((FR (OPT.CODEFRAME CD)))
(OR FR (OPT.COMPILERERROR))
(COND
((FMEMB A (fetch VARS of FR))
(RETURN)))
LP (SETQ FR (fetch PARENT of FR))
(COND
((FMEMB A (fetch VARS of FR))
(replace NOXVAR of FR with T)
(RETURN)))
(COND
((EQ FR TOPFRAME)
(OPT.COMPILERERROR)))
(GO LP])
(OPT.JUMPOPT
[LAMBDA NIL (* lmm "11-NOV-81 21:17")
(MAPC LABELS (FUNCTION (LAMBDA (X)
(COND
((CADR X) (* Label defined)
(COND
((OR (OPT.JUMPTHRU (CAR X)
(CDR X))
(OPT.JUMPREV (CAR X)
(CDR X)))
(SETQ ANY T])
(OPT.JUMPTHRU
[LAMBDA (TAG OPT.DEFREFS) (* lmm "19-JAN-82 21:46")
(PROG ((DR OPT.DEFREFS)
P APD ALST ANY INFO Y REF BR END (DEF (CAR OPT.DEFREFS))
PD B (FRAME (fetch (TAG FRAME) of TAG))
(LEVEL (fetch (TAG LEVEL) of TAG)))
LQ (while [OR [type? TAG (SETQ APD (CAR (fetch PREV of DEF]
(type? TAG (SETQ APD (CAR (SETQ PD (fetch NXT of DEF]
do (* two adjacent tags -
merge them)
(OPT.LBMERGE TAG APD))
[COND
((NULL (CDR DR)) (* tag which is not reference;
delete it)
(RETURN (OPT.LBDEL TAG]
[COND
[(EQ APD OPNIL) (* instruction after the tag is NIL)
(SETQQ ALST ((FJUMP NFJUMP . OPNIL]
(T (SETQ ALST (SELECTQ (fetch OPNAME of APD)
[JUMP (QUOTE ((JUMP)
(TJUMP)
(FJUMP)
(NTJUMP)
(NFJUMP]
[TJUMP (QUOTE ((NTJUMP TJUMP)
(NFJUMP FJUMP . 1]
[FJUMP (QUOTE ((NTJUMP TJUMP . 1)
(NFJUMP FJUMP]
[NTJUMP (QUOTE ((NTJUMP)
(NFJUMP FJUMP . 1]
[NFJUMP (QUOTE ((NTJUMP TJUMP . 1)
(NFJUMP]
[POP (QUOTE ((NTJUMP TJUMP . 1)
(NFJUMP FJUMP . 1)
(JUMP NIL . JP]
[RETURN (QUOTE ((JUMP NIL . R]
[(AVAR GVAR FVAR HVAR)
(QUOTE ((FJUMP NFJUMP . L)
(TJUMP NTJUMP . L)
(JUMP NIL . LL]
(RETURN]
LP (COND
((NOT (SETQ INFO (FASSOC [fetch OPNAME of (CAR (SETQ REF (CADR DR]
ALST)))
(GO NX)))
(COND
((EQ REF PD)
[COMPERRM (CONS COMFN (QUOTE (-- infinite loop]
(GO NX)))
(SETQ BR (fetch PREV of REF))
(SETQ Y
(SELECTQ (CDDR INFO)
(NIL (CW JUMP to JUMP)
(fetch (JUMP TAG) of APD))
(R (CW JUMP to RETURN)
(FRPLACA REF OPRETURN)
NIL)
[L (* VARIABLE REFERENCE)
(COND
((OR (OPT.EQVALUE BR PD)
(AND (EQ (fetch OPNAME of (CAR REF))
(QUOTE TJUMP))
(OPT.CALLP (CAR BR)
VCONDITIONALS 1)
(OPT.EQVALUE (fetch PREV of BR)
PD)))
(CW VAR CJUMP to VAR)
(OPT.LABELNTHPR DEF 1 LEVEL 1))
[(SETQ Y (OPT.JUMPCOPYTEST PD BR))
(CW VAR CJUMP .. VAR -> VAR COPY CJUMP POP ..
VAR)
(PROG ((N 1)
PDN)
[COND
(NEWOPTFLG (SETQ PDN (fetch NXT of PD))
(while (AND (OPT.CALLP (CAR (SETQ INFO
(fetch NXT of Y)))
NIL 1)
(COMP.CLEANFNOP
(CDR (fetch OPARG of (CAR INFO)))
(QUOTE NOSIDE))
(OPT.EQOP (CAR INFO)
(CAR PDN)))
do (SETQ Y INFO)
(SETQ PDN (fetch NXT of PDN))
(add N 1]
(OPT.PRATTACH OPCOPY Y)
(OPT.PRATTACH OPPOP REF)
(SETQ INFO)
(RETURN (OPT.LABELNTHPR DEF N LEVEL 1]
(T (GO NX]
[LL (COND
((AND (EQ (CAR BR)
OPPOP)
(OPT.EQVALUE (fetch PREV of BR)
PD))
(CW SETQ var POP JUMP to var)
(OPT.PRDEL BR)
(OPT.LABELNTHPR DEF 1 LEVEL 1))
(T (GO NX]
(1 (CW NTJUMP to POP)
(OPT.LABELNTHPR DEF 1 LEVEL -1))
(OPNIL (CW FJUMP to NIL)
(OPT.LABELNTHPR DEF 1 LEVEL 1))
[JP (COND
((SETQ B (OPT.SKIPPUSH BR 1 NIL T))
(CW JUMP to POP)
[PROG NIL
LPB (SETQ BR (PROG1 (fetch PREV of BR)
(OPT.PRDEL BR)))
(COND
((NEQ BR B)
(GO LPB]
(OPT.LABELNTHPR DEF 1 LEVEL -1))
(T (GO NX]
(OPT.COMPILERERROR)))
(COND
(Y (replace (JUMP TAG) of (CAR REF) with Y)
(NCONC1 (OPT.DEFREFS Y)
REF)))
(SETQ ANY T) (* Since the jump to this tag was redirected, delete the
jump from the REFS for this tag)
(FRPLACD DR (CDDR DR))
[COND
((CADR INFO)
(replace OPNAME of (CAR REF) with (CADR INFO]
(GO LX)
NX (SETQ DR (CDR DR))
LX (COND
((CDR DR)
(GO LP)))
[COND
((NULL (CDR OPT.DEFREFS))
(RETURN (OPT.LBDEL TAG]
(RETURN ANY])
(OPT.LBMERGE
[LAMBDA (TO FROM) (* lmm: "22-JUL-77 16:03")
(PROG [(REFS (CDR (OPT.DEFREFS FROM]
[MAPC REFS (FUNCTION (LAMBDA (X)
(replace (JUMP TAG) of (CAR X) with TO]
(NCONC (OPT.DEFREFS TO)
REFS)
[OR (fetch (TAG LEVEL) of FROM)
(PROGN (replace (TAG LEVEL) of TO with NIL)
(OR (fetch FRAME of FROM)
(replace FRAME of TO with NIL]
(RETURN (OPT.LBDEL FROM])
(OPT.PRDEL
[LAMBDA (X) (* lmm: "22-JUL-77 02:59")
(PROG ((B (fetch PREV of X))
(P (fetch NXT of X)))
(AND B (replace NXT of B with P))
(AND P (replace PREV of P with B))
(replace NXT of X with NIL])
(OPT.UBDEL
[LAMBDA (CD) (* lmm "14-MAR-81 09:16")
(DREMOVE CD (OR (FASSOC (CDR (fetch OPARG of (CAR CD)))
FRAMES)
(OPT.COMPILERERROR])
(OPT.LBDEL
[LAMBDA (TAG) (* lmm: "22-JUL-77 16:14")
(PROG ((DEF (CAR (OPT.DEFREFS TAG)))
B)
(SETQ B (fetch PREV of DEF))
(OPT.PRDEL DEF)
(OPT.SETDEFREFS TAG NIL)
[COND
((OPT.JUMPCHECK B)
(CW delete code before deleted tag)
(OPT.DELCODE (fetch NXT of B]
(RETURN T])
(OPT.LABELNTHPR
[LAMBDA (CODE CNT LEVEL DL) (* lmm: "22-JUL-77 16:12")
(PROG ((CD CODE)
G)
(OPT.CHLEV DL)
LP (SETQ CD (fetch NXT of CD))
(COND
((IGREATERP CNT 0)
(OR (type? TAG (CAR CD))
(SUB1VAR CNT))
(GO LP))
(T (RETURN (COND
((type? TAG (CAR CD))
(OPT.CHECKTAG (CAR CD)
T)
(CAR CD))
(T (PROG1 (SETQ G (create TAG))
(replace (TAG FRAME) of G with FRAME)
(SETQ CD (OPT.PRATTACH G (fetch PREV of CD)))
(OPT.SETDEFREFS G (LIST CD))
(replace (TAG LEVEL) of G with LEVEL])
(OPT.JUMPREV
[LAMBDA (TAG OPT.DEFREFS) (* edited: "21-DEC-79 16:05")
(* OPT.JUMPREV checks the things that PRECEDE particular
kinds of jumps)
(PROG ((DR OPT.DEFREFS)
R
(D (CAR OPT.DEFREFS))
END ANY LB CD (LEVEL (fetch (TAG LEVEL) of TAG))
(FRAME (fetch (TAG FRAME) of TAG))
BD ABD FLG BR ABR OABR PR APD OAR TMP)
LP (SETQ R (CADR DR))
(SETQ PR (fetch NXT of R))
(SETQ BD (fetch PREV of D))
(SETQ ABD (CAR BD))
(SETQ BR (fetch PREV of R))
(SETQ ABR (CAR BR))
(SETQ OABR (fetch OPNAME of ABR))
(SETQ OAR (fetch OPNAME of (CAR R)))
(* variable code: last letter is R for reference {i.e. place of jump}, D for definition {i.e.
place where TAG is} -
preceding letters: -
A for CAR -
O for COP {op code} -
P for CPR {next byte} -
B for CBR {previous byte})
(SELECTQ OAR
[JUMP (COND
((EQ R BD)
(CW JUMP to next location deleted)
(OPT.PRDEL R))
[(AND (OPT.EQOP ABD ABR)
(SETQ TMP (OPT.COMMONBACK BD R LEVEL)))
(* OPT.COMMONBACK returns NIL if does nothing; T if deleted safe code or SAME if it deleted some code that
contained a reference to the label that is now being worked on.)
(CW merge similar code before JUMP and TAG)
(* IF SAME don't continue with this label! could have
deleted other references to it)
(COND
((EQ TMP T)
(SETQ ANY T)
(GO LX))
(T (RETURN T]
[[AND (CAR PR)
(NOT (type? TAG (CAR PR]
(CW delete code after JUMP)
(COND
((OPT.DELCODE PR) (* returns T if it deleted any jumps
(may have deleted a jump for this tag))
(RETURN))
(T (GO NX]
([AND (SELECTQ (fetch OPNAME of ABD)
(RETURN T)
(JUMP (NOT (FMEMB BD DR)))
NIL)
(SETQ END (fetch NXT of (OPT.FINDEND D R]
(CW move jumped-to code in line)
(PROGN (replace NXT of BD with END)
(replace PREV of (PROG1 END (SETQ END (fetch PREV of END)))
with BD))
(PROGN (replace NXT of BR with D)
(replace PREV of D with BR)
(replace PREV of PR with END)
(replace NXT of END with PR)))
(T (SELECTQ OABR
(CONST (* CONST JUMP)
(SELECTQ (fetch OPNAME of APD)
((TJUMP NTJUMP)
(SETQ FLG (fetch OPARG of ABR)))
[(FJUMP NFJUMP)
(SETQ FLG (NULL (fetch OPARG of ABR]
(GO NX))
(NCONC1 [OPT.DEFREFS
(replace (JUMP TAG) of (CAR R)
with (COND
(FLG (SELECTQ (fetch OPNAME
of APD)
((TJUMP FJUMP)
(CW T JUMP to TJUMP)
(OPT.PRDEL BR))
(CW T JUMP to NTJUMP))
(fetch (JUMP TAG)
of APD))
(T
(CW T JUMP to NF/FJUMP)
(OPT.PRDEL BR)
(OPT.LABELNTHPR D 1 LEVEL -1]
R))
[(TJUMP FJUMP)
(COND
((EQ (fetch (JUMP TAG) of (CAR R))
(fetch (JUMP TAG) of ABR))
(CW TJUMP->TAG JUMP->TAG => POP JUMP->TAG)
(OPT.PRDEL R)
(OPT.PRATTACH OPPOP (fetch PREV of BR))
(replace OPNAME of ABR with (QUOTE JUMP)))
(T (GO NX]
(GO NX]
[(FJUMP TJUMP)
(COND
((EQ R BD)
(CW TJUMP to next location)
(FRPLACA R OPPOP))
[(EQ OABR (QUOTE CONST))
(COND
((SELECTQ OAR
(TJUMP (fetch OPARG of ABR))
(NULL (fetch OPARG of ABR)))
(CW T TJUMP -> JUMP)
(replace OPNAME of (CAR R) with (QUOTE JUMP))
(OPT.PRDEL BR)
(SETQ ANY T) (* try again)
(GO LP))
(T (CW T FJUMP -> NOOP)
(OPT.PRDEL R)
(OPT.PRDEL BR]
((OPT.CALLP ABR (QUOTE (NOT NULL))
1)
(CW NULL TJUMP)
(FRPLACA R (OPT.NOTJUMP (CAR R)))
(OPT.PRDEL BR)
(GO REDO))
((AND (EQ ABR OPCOPY)
(EQ (CAR PR)
OPPOP))
(CW COPY TJUMP POP -> NTJUMP)
(OPT.PRDEL BR)
(OPT.PRDEL PR)
(replace OPNAME of (CAR R) with (SELECTQ OAR
(TJUMP (QUOTE NTJUMP))
(QUOTE NFJUMP)))
(GO REDO))
((AND (EQ (fetch OPNAME of ABD)
(QUOTE JUMP))
(EQ (fetch PREV of BD)
R))
(CW FJUMP.1 JUMP.2 1: => TJUMP.2)
(replace OPNAME of ABD with (SELECTQ OAR
(TJUMP (QUOTE FJUMP))
(QUOTE TJUMP)))
(OPT.PRDEL R))
((SETQ CD (OPT.JUMPCOPYTEST PR BR)) (* What is before the jump is also after -
e.g. X TJUMP X)
(COND
((EQ (CAR PR)
(CAR (fetch NXT of D)))
(CW X TJUMP.1 X ... 1:X ... -> X COPY TJUMP.2 ...
1:X 2: ...)
(OPT.PRATTACH OPCOPY CD)
(SETQ LB (OPT.LABELNTHPR D 1 LEVEL 1)))
((AND (OPT.JUMPCHECK (fetch PREV of D))
(OR (OPT.EQVALUE BR PR)
(AND (EQ OAR (QUOTE FJUMP))
(OPT.CALLP ABR VCONDITIONALS 1)
(OPT.EQVALUE (fetch PREV of BR)
PR)))
(SETQ END (OPT.FINDEND D R)))
(CW X FJUMP.1 X .a. 1: .b. -> X NTJUMP.2 1: .b.
... 2: .a.)
(PROGN (replace NXT of (fetch PREV of D) with (fetch NXT of END))
(replace PREV of (fetch NXT of END) with (fetch PREV
of D)))
(PROGN (replace NXT of R with D)
(replace PREV of D with R)
(replace PREV of PR with END)
(replace NXT of END with PR))
(replace OPNAME of (CAR R) with (SELECTQ OAR
(FJUMP (QUOTE NTJUMP))
(QUOTE NFJUMP)))
(SETQ LB (OPT.LABELNTHPR PR 0 LEVEL 1)))
(T (GO NX)))
(OPT.PRDEL PR)
(replace (JUMP TAG) of (CAR R) with LB)
(NCONC1 (OPT.DEFREFS LB)
R))
(T (GO NX]
[(NFJUMP NTJUMP)
(COND
[(EQ OABR (QUOTE CONST))
(COND
((SELECTQ OAR
(NTJUMP (fetch OPARG of ABR))
(NULL (fetch OPARG of ABR)))
(CW T NTJUMP -> JUMP)
(replace OPNAME of (CAR R) with (QUOTE JUMP))
(GO REDO))
(T (CW T NFJUMP -> NOOP)
(OPT.PRDEL BR)
(OPT.PRDEL R]
((OPT.EQVALUE BR PR)
(CW X NTJUMP X -> X COPY TJUMP)
(OPT.PRATTACH OPCOPY (fetch PREV of R))
(OPT.PRDEL PR)
(replace OPNAME of (CAR R) with (SELECTQ OAR
(NTJUMP (QUOTE TJUMP))
(QUOTE FJUMP)))
(GO REDO))
[(EQ OAR (QUOTE NTJUMP))
(COND
[(NOT (OR (OPT.CALLP ABR CONDITIONALS)
(OPT.CALLP ABR VCONDITIONALS)))
(COND
((EQ (CAR (fetch NXT of R))
OPNIL)
(CW NTJUMP NIL -> COPY TJUMP)
(OPT.PRDEL (fetch NXT of R))
(OPT.PRATTACH OPCOPY BR)
(replace OPNAME of (CAR R) with (QUOTE TJUMP))
(GO REDO))
(T (GO NX]
[(OPT.CALLP ABR VCONDITIONALS 1)
(COND
((OPT.EQVALUE (fetch PREV of BR)
PR)
(CW X LISTP NTJUMP X -> X COPY LISTP TJUMP)
(OPT.PRATTACH OPCOPY (fetch PREV of BR))
(OPT.PRDEL PR)
(replace OPNAME of (CAR R) with (QUOTE TJUMP))
(GO REDO))
(T (GO NX]
(T (GO NX]
(T (GO NX]
(GO NX))
(SETQ ANY T)
(FRPLACD DR (CDDR DR))
(GO LX)
NX (SETQ DR (CDR DR))
LX (COND
((CDR DR)
(GO LP)))
(RETURN ANY)
REDO(SETQ ANY T)
(GO LP])
(OPT.COMMONBACK
[LAMBDA (BDEF REF LEVEL) (* DD: "21-FEB-83 18:29")
(* When the code preceding a jump is the same as the code preceding the label, can delete the code preceding the
jump and move the label back -
BDEF is the code preceding the label and REF is the jump and the code that precedes it)
(PROG ((BREF (fetch PREV of REF))
G FLG TMP (FRAME FRAME))
M (COND
((EQ (fetch OPNAME of (CAR BDEF))
(QUOTE TAG))
(OPT.CHECKTAG (CAR BDEF)
LEVEL)
(SETQ BDEF (fetch PREV of BDEF))
(GO M)))
(COND
((OPT.EQOP (CAR BDEF)
(CAR BREF))
[SELECTQ (fetch OPNAME of (CAR BREF))
((AVAR HVAR GVAR FVAR CONST COPY)
(OPT.CHLEV -1))
((SETQ STORE SWAP))
(POP (COND
((AND [NOT (OPT.EQOP (CAR (fetch PREV of BREF))
(CAR (fetch PREV of BDEF]
(EQ (fetch OPNAME of (CAR (fetch PREV of BREF)))
(QUOTE SETQ))
(EQ (fetch OPNAME of (CAR (fetch PREV of BDEF)))
(QUOTE SETQ)))
(CW no OPT.COMMONBACK for different SETQ pop.)
(GO EXIT)))
(OPT.CHLEV 1))
((TJUMP FJUMP NTJUMP NFJUMP)
(OPT.CHLEV 1)
[COND
((EQ (fetch (JUMP TAG) of (CAR BREF))
(fetch (JUMP TAG) of (CAR REF)))
(SETQ FLG (QUOTE SAME]
(OPT.DELTAGREF BREF))
[FN (OPT.CHLEV (SUB1 (CAR (fetch OPARG of (CAR BDEF]
[(UNBIND DUNBIND)
(OPT.UBDEL BREF)
[SETQ LEVEL (CAR (fetch OPARG of (CAR BREF]
(SETQ FRAME (CDR (fetch OPARG of (CAR BREF]
(OPT.COMPILERERROR (QUOTE (OPT.COMMONBACK shouldn't get here]
(OR FLG (SETQ FLG T))
(SETQ BDEF (fetch PREV of BDEF))
(SETQ BREF (PROG1 (fetch PREV of BREF)
(OPT.PRDEL BREF)))
(GO M)))
EXIT(COND
(FLG (SETQ G (OPT.LABELNTHPR BDEF 0 LEVEL 0))
(OPT.DELTAGREF REF)
(replace (JUMP TAG) of (CAR REF) with G)
(NCONC1 (OPT.DEFREFS G)
REF)
(RETURN FLG])
(OPT.DELTAGREF
[LAMBDA (REF) (* edited: "21-DEC-79 15:57")
(for X on (OPT.DEFREFS (fetch (JUMP TAG) of (CAR REF))) when (EQ (CADR X)
REF)
do (RETURN (RPLACD X (CDDR X))) finally (OPT.COMPILERERROR])
(OPT.FINDEND
[LAMBDA (C STOP) (* lmm: "22-JUL-77 03:38")
(PROG NIL
LP (COND
((EQ C STOP)
(RETURN)))
(COND
((OPT.JUMPCHECK C)
(RETURN C)))
(COND
((SETQ C (fetch NXT of C))
(GO LP])
(OPT.RETOPT
[LAMBDA NIL (* DD: "21-FEB-83 17:17")
(* optimizations involving RETURN)
(PROG ((RL (OPT.RETFIND CODE))
TESTL TARGL)
[MAPC RL (FUNCTION (LAMBDA (C)
(COND
((OPT.RETPOP C)
(SETQ ANY T)))
(COND
((OPT.RETTEST C C) (* Test if C is a possible test.)
(* Looking for the case where two identical sequences ending with RETURN one of which is preceded by a conditional
jump; -
TJUMP->x stuff RETURN x: ... stuff RETURN ... becomes -
FJUMP->y x: ... y: stuff RETURN)
(SETQ TESTL (CONS C TESTL)))
(T (SETQ TARGL (CONS C TARGL]
(OR TESTL (RETURN ANY))
[SETQ TESTL (SUBSET TESTL (FUNCTION (LAMBDA (X)
(NOT (OPT.RETOPT1 X TARGL]
[MAP TESTL (FUNCTION (LAMBDA (Z)
(AND (LISTP Z)
(OPT.RETOPT1 (CAR Z)
(CDR Z]
(RETURN ANY])
(OPT.RETFIND
[LAMBDA (C) (* lmm: "18-AUG-76 02:12:31")
(* returns the list of all RETURN's in the code)
(PROG ((L1 C)
R)
LP (COND
((SETQ L1 (FMEMB OPRETURN (CDR L1)))
(SETQ R (CONS L1 R))
(GO LP)))
(RETURN R])
(OPT.RETPOP
[LAMBDA (RET) (* lmm " 4-MAY-81 17:03")
(* can delete any UNBIND's preceding a RETURN -
the RETURN does it automatically)
(AND MERGEUNBINDFLG (PROG (ANY TAGS VAL)
LP (SELECTQ [fetch OPNAME of (CAR (SETQ RET (fetch PREV of RET]
[UNBIND (SELECTQ (fetch OPNAME of VAL)
((AVAR HVAR)
(CW don't delete UNBIND when followed by VAR RETURN)
)
(PROGN
(CW delete UNBIND before RETURN)
(OPT.UBDEL RET)
(GO DEL]
[POP (COND
(VAL (CW delete POP before VAR RETURN)
(GO DEL]
[DUNBIND (COND
(VAL (CW delete DUNBIND before VAR RETURN)
(OPT.UBDEL RET)
(GO DEL]
[COPY (COND
((NOT (fetch OPARG of (CAR RET)))
(CW delete COPY before RETURN)
(GO DEL]
[(AVAR HVAR FVAR GVAR CONST)
(COND
((NULL VAL)
(SETQ VAL (CAR RET))
(GO LP))
(T (CW VAR VAR RETURN)
(GO DEL]
(TAG (SETQ TAGS (CONS (CAR RET)
TAGS))
(GO LP))
NIL)
(RETURN ANY)
DEL (OPT.PRDEL RET)
DOIT(SETQ ANY T)
[MAPC TAGS (FUNCTION (LAMBDA (X)
(replace (TAG LEVEL) of X with NIL]
(SETQ TAGS)
(GO LP])
(OPT.RETOPT1
[LAMBDA (X L) (* lmm: "13-OCT-76 18:45:46")
(PROG (END Y1)
(RETURN (COND
([SETQ Y1 (SOME L (FUNCTION (LAMBDA (Y)
(SETQ END (OPT.RETTEST X Y]
(OPT.RETMERGE X END (CAR Y1))
(SETQ ANY T])
(OPT.RETTEST
[LAMBDA (TEST TARGET) (* DD: "21-FEB-83 17:38")
(PROG ((L1 TEST)
(L2 TARGET)
F1 F2 ONLYIFSAMEFRAME)
[COND
((EQ L1 L2)
(SETQ F1 (SETQ F2 T]
LP (SETQ L1 (fetch PREV of L1))
(SETQ L2 (fetch PREV of L2))
L1 (COND
((type? TAG (CAR L1))
[OR F1 (SETQ F1 (fetch (TAG FRAME) of (CAR L1]
(SETQ L1 (fetch PREV of L1))
(GO L1)))
L2 (COND
((type? TAG (CAR L2))
[OR F2 (SETQ F2 (fetch (TAG FRAME) of (CAR L2]
(SETQ L2 (fetch PREV of L2))
(GO L2)))
(SELECTQ (fetch OPNAME of (CAR L1))
(RETURN (GO RET))
(JUMP (GO RETJ))
[(FJUMP TJUMP)
(COND
((EQ (fetch (JUMP TAG) of (CAR L1))
(CAR (fetch NXT of TEST)))
(GO RETJ]
[(HVAR AVAR)
(COND
((EQ (CAR L1)
(CAR L2))
(SETQ ONLYIFSAMEFRAME T)
(GO LP]
[(UNBIND DUNBIND)
(COND
([AND [EQ [CAR (LISTP (fetch OPARG of (LISTP (CAR L1]
(CAR (LISTP (fetch OPARG of (LISTP (CAR L2]
(EQ [CDR (fetch OPARG of (LISTP (CAR L1]
(CDR (fetch OPARG of (LISTP (CAR L2]
(SETQ F1 (SETQ F2 T)) (* same frame)
(GO LP]
[FN (COND
((OPT.EQOP (CAR L1)
(CAR L2))
(GO LP]
(BIND (* don't merge binds)
NIL)
[(POP CONST FVAR GVAR SWAP)
(COND
((EQ (CAR L1)
(CAR L2))
(GO LP]
[(STORE COPY)
(COND
((EQUAL (CAR L1)
(CAR L2))
(GO LP]
NIL)
(RETURN)
RETJ[OR F1 (SETQ F1 (fetch (TAG FRAME) of (fetch (JUMP TAG) of (CAR L1]
RET [COND
(ONLYIFSAMEFRAME (COND
((NEQ (OR F1 (OPT.CODEFRAME L1))
(OR F2 (OPT.CODEFRAME L2)))
(CW OPT.RETTEST fail because not same frame)
(RETURN]
(RETURN L1])
(OPT.RETMERGE
[LAMBDA (TEST END TARGET) (* lmm "13-OCT-78 21:25")
(PROG ((L1 TEST)
(L2 TARGET)
G VEQ FEQ LEV)
[COND
([AND (SETQ LEV (OPT.CODEFRAME (fetch PREV of TEST)))
(EQ LEV (OPT.CODEFRAME (fetch PREV of TARGET]
(SETQ FEQ T)
(COND
((AND (SETQ LEV (OPT.CODELEV (fetch PREV of TEST)
0))
(EQ LEV (OPT.CODELEV (fetch PREV of TARGET)
0)))
(SETQ VEQ T]
LP (COND
((EQ L1 END)
(SELECTQ (fetch OPNAME of (CAR L1))
((TJUMP FJUMP)
[COND
[[NOT (type? TAG (SETQ G (CAR L2]
(SETQ G (create TAG))
[COND
(FEQ [replace (TAG FRAME) of G with (fetch (TAG FRAME)
of (fetch (JUMP TAG)
of (CAR L1]
(COND
(VEQ (replace (TAG LEVEL) of G
with (fetch (TAG LEVEL) of (fetch (JUMP TAG)
of (CAR L1]
(OPT.SETDEFREFS G (LIST (OPT.PRATTACH G L2]
(T (OR VEQ (replace (TAG LEVEL) of G with NIL))
(OR FEQ (replace (TAG FRAME) of G with NIL]
(FRPLACA L1 (OPT.NOTJUMP (CAR L1)))
[DREMOVE L1 (OPT.DEFREFS (fetch (JUMP TAG) of (CAR L1]
(replace (JUMP TAG) of (CAR L1) with G)
(NCONC1 (OPT.DEFREFS G)
L1))
((JUMP RETURN))
(OPT.COMPILERERROR))
(RETURN)))
(COND
((type? TAG (CAR L1))
(OR VEQ (replace (TAG LEVEL) of (CAR L1) with NIL))
(OR FEQ (replace (TAG FRAME) of (CAR L1) with NIL))
(RPLACA (OPT.DEFREFS (CAR L1))
(OPT.PRATTACH (CAR L1)
L2))
(SETQ L1 (PROG1 (fetch PREV of L1)
(OPT.PRDEL L1)))
(GO LP)))
L2 (COND
((type? TAG (CAR L2))
(OR VEQ (replace (TAG LEVEL) of (CAR L2) with NIL))
(OR FEQ (replace (TAG FRAME) of (CAR L2) with NIL))
(SETQ L2 (fetch PREV of L2))
(GO L2)))
(SELECTQ (fetch OPNAME of (CAR L1))
((UNBIND DUNBIND)
(OPT.UBDEL L1))
((TJUMP NTJUMP FJUMP NFJUMP JUMP BIND ERRORSET)
(OPT.COMPILERERROR))
NIL)
(SETQ L1 (PROG1 (fetch PREV of L1)
(OPT.PRDEL L1)))
(SETQ L2 (fetch PREV of L2))
(GO LP])
(OPT.CODELEV
[LAMBDA (CD LEV) (* lmm " 8-JAN-82 09:07")
(PROG NIL
(RETURN (IPLUS (SELECTQ (fetch OPNAME of (CAR CD))
(TAG (OR (fetch (TAG LEVEL) of (CAR CD))
(RETURN)))
[(NTJUMP NFJUMP)
(SUB1VAR LEV)
(OR (fetch (TAG LEVEL) of (fetch (JUMP TAG) of (CAR CD)))
(RETURN (OPT.CODELEV (fetch PREV of CD)
LEV]
[(TJUMP FJUMP)
(OR (fetch (TAG LEVEL) of (fetch (JUMP TAG) of (CAR CD)))
(RETURN (OPT.CODELEV (fetch PREV of CD)
(SUB1 LEV]
[(AVAR HVAR COPY CONST FVAR GVAR)
(RETURN (OPT.CODELEV (fetch PREV of CD)
(ADD1 LEV]
[FN (RETURN (OPT.CODELEV (fetch PREV of CD)
(ADD1 (IDIFFERENCE
LEV
(CAR (fetch OPARG
of (CAR CD]
[POP (RETURN (OPT.CODELEV (fetch PREV of CD)
(SUB1 LEV]
((BIND ERRORSET)
0)
[DUNBIND (fetch (FRAME LEVEL) of (CDR (fetch OPARG
of (CAR CD]
[UNBIND (ADD1 (OR [fetch (FRAME LEVEL)
of (CDR (fetch OPARG of (CAR CD]
(RETURN]
((SETQ STORE SWAP)
(RETURN (OPT.CODELEV (fetch PREV of CD)
LEV)))
(NIL (OPT.CCHECK (NOT (CDR CD)))
0)
(OPT.COMPILERERROR (CAR CD)))
LEV])
(OPT.CODEFRAME
[LAMBDA (CD) (* lmm " 8-JAN-82 09:13")
(SELECTQ (fetch OPNAME of (CAR CD))
[TAG (OR (fetch (TAG FRAME) of (CAR CD))
(OPT.CODEFRAME (fetch PREV of CD]
[(NTJUMP NFJUMP TJUMP FJUMP)
(OR (fetch (TAG FRAME) of (fetch (JUMP TAG) of (CAR CD)))
(OPT.CODEFRAME (fetch PREV of CD]
[(BIND ERRORSET)
(CDR (fetch OPARG of (CAR CD]
[(UNBIND DUNBIND)
(fetch PARENT of (CDR (fetch OPARG of (CAR CD]
(NIL TOPFRAME)
((JUMP RETURN)
NIL)
(OPT.CODEFRAME (fetch PREV of CD])
(OPT.DEFREFS
[LAMBDA (D) (* lmm: "22-JUL-77 15:58")
(CDR (FASSOC D LABELS])
(OPT.SETDEFREFS
[LAMBDA (D V) (* lmm: "22-JUL-77 15:58")
(FRPLACD [OR (FASSOC D LABELS)
(CAR (SETQ LABELS (CONS (CONS D)
LABELS]
V])
)
(DEFINEQ
(OPT.FRAMEOPT
[LAMBDA (TRYLOCAL TRYMERGE TRYXVAR) (* lmm "16-DEC-81 17:05")
(PROG (ANY)
[COND
(TRYLOCAL (MAPC FRAMES (FUNCTION (LAMBDA (X)
(AND (OPT.FRAMELOCAL (CAR X))
(SETQ ANY T]
[MAPC FRAMES (FUNCTION (LAMBDA (F)
(AND (CADR F)
(OPT.FRAMEVAR F)
(SETQ ANY T]
[COND
(TRYMERGE (MAPC FRAMES (FUNCTION (LAMBDA (F)
(AND (CADR F)
(OPT.FRAMEMERGE F)
(SETQ ANY T]
[SETQ FRAMES (SUBSET FRAMES (FUNCTION (LAMBDA (F)
(NOT (AND (CADR F)
(OPT.FRAMEDEL F TRYXVAR)
(SETQ ANY T]
(RETURN ANY])
(OPT.FRAMEMERGE
[LAMBDA (F) (* lmm "20-OCT-82 18:10")
(AND MERGEFRAMEFLG (PROG ((FR (CAR F))
VAR VARS P)
(COND
((AND (SETQ VARS (fetch VARS of FR))
(NULL (CDR (FNTH VARS MERGEFRAMEMAX)))
(SETQ P (fetch PARENT of FR))
(OPT.MERGEFRAMEP FR P VARS))
[PROG ((N (fetch NVALS of FR))
(V VARS)
(CD (fetch PREV of (CADR F)))
P2)
PLP (COND
((AND (SETQ P2 (fetch PARENT of P))
(OPT.MERGEFRAMEP FR P2 VARS))
(SETQ P P2)
(GO PLP)))
(replace VARS of P with (NCONC (fetch VARS of P)
VARS))
(replace VARS of FR with NIL)
(replace NNILS of P with (IPLUS (fetch NNILS of P)
(fetch NNILS of FR)
(fetch NVALS of FR)))
(replace NNILS of FR with (replace NVALS of FR with 0))
LP (COND
(V (SETQ VAR (create OP
OPNAME ←(QUOTE SETQ)
OPARG ←(CAR V)))
[COND
((IGREATERP N 0)
(OPT.PRATTACH OPPOP (OPT.PRATTACH VAR CD)))
(T [COND
((ZEROP N)
(SETQ CD (OPT.PRATTACH OPNIL CD]
(OR (OPT.NONILVAR (CAR V)
CD P)
(SETQ CD (OPT.PRATTACH VAR CD]
(SETQ N (SUB1 N))
(SETQ V (CDR V))
(GO LP)))
(COND
((MINUSP N)
(OPT.PRATTACH OPPOP CD]
(RETURN T])
(OPT.NONILVAR
[LAMBDA (V CD FR) (* lmm " 8-JAN-82 09:06")
(* used by OPT.FRAMEMERGE)
(PROG NIL
(RETURN (AND (SELECTQ (fetch OPNAME of (CAR CD))
((CONST POP COPY AVAR HVAR FVAR GVAR TJUMP FJUMP NTJUMP NFJUMP SETQ
STORE SWAP)
T)
(NIL NIL)
(FN (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR CD)))
(QUOTE FREEVARS)))
(BIND (COND
([EQ FR (CDR (fetch OPARG of (CAR CD]
(RETURN T))
(T T)))
((TAG RETURN)
NIL)
((UNBIND DUNBIND ERRORSET)
T)
NIL)
(OPT.NONILVAR V (CDR CD)
FR])
(OPT.MERGEFRAMEP
[LAMBDA (FR PARENT VARS) (* lmm: "22-JUL-77 02:39")
(AND (FMEMB (fetch FRAMETYPE of PARENT)
MERGEFRAMETYPES)
(COND
[(OASSOC (QUOTE AVAR)
VARS)
(AND (OPT.CLEANFRAME PARENT FR)
(PROG NIL
[for V in VARS
do [for F in FRAMES when (NEQ (CAR F)
FR)
do (for V2 in (fetch VARS of (CAR F))
do (COND
((EQ (fetch OPARG of V2)
(fetch OPARG of V))
(GO BAD]
(for V2 in FREEVARS do (COND
((EQ (fetch OPARG of V2)
(fetch OPARG of V))
(GO BAD]
(RETURN T)
BAD (RETURN]
(T (EQ MERGEFRAMEFLG T])
(OPT.FRAMELOCAL
[LAMBDA (F) (* lmm " 6-MAY-81 21:41")
(PROG (VARS)
(COND
((AND (OASSOC (QUOTE AVAR)
(SETQ VARS (fetch (FRAME VARS) of F)))
(OPT.CLEANFRAME F))
(CW make vars local when no external calls)
[MAPC VARS (FUNCTION (LAMBDA (X)
(replace OPNAME of X with (QUOTE HVAR]
(RETURN T])
(OPT.CLEANFRAME
[LAMBDA (FRAME AVOIDING) (* lmm: " 9-NOV-76 16:20:20")
(AND (NOT (fetch EXTCALL of FRAME))
(for F in FRAMES when (AND (EQ (fetch PARENT of (CAR F))
FRAME)
(NEQ (CAR F)
AVOIDING))
always (OPT.CLEANFRAME (CAR F)
AVOIDING])
(OPT.FRAMEDEL
[LAMBDA (F TRYXVAR) (* lmm " 4-APR-83 23:25")
(PROG (VARS (FRM (CAR F))
PARENT OP FLV TMP DOXVAR)
(SELECTQ (fetch FRAMETYPE of FRM)
((NIL ERRORSET)
(RETURN))
NIL)
(SETQ VARS (fetch VARS of FRM))
(SETQ FLV (fetch (FRAME LEVEL) of FRM))
(SETQ DOXVAR NIL)
(COND
([AND [NOT (SOME (CDDR F)
(FUNCTION (LAMBDA (X)
(AND (EQ (fetch OPNAME of (CAR X))
(QUOTE UNBIND))
(IGREATERP (CAR (fetch OPARG of (CAR X)))
1]
(OR (NULL VARS)
(AND (NOT (OASSOC (QUOTE AVAR)
VARS))
(OR (OPT.DELETEFRAMECHECK VARS F)
(AND TRYXVAR (NOT (fetch NOXVAR of FRM))
(SETQ DOXVAR T] (* frame with no specvars, no UNBIND's with LEVEL gt 1)
(COND
((EQ (fetch FRAMETYPE of FRM)
(QUOTE MAP))
(CW delete MAP frame))
(T (CW delete frame)))
(OR (SETQ PARENT (fetch PARENT of FRM))
(OPT.COMPILERERROR))
[COND
(DOXVAR (add FLV (fetch NNILS of FRM)
(fetch NVALS of FRM]
[for VR on VARS
do (for CD on CODE
do (COND
[(AND (EQ (fetch OPARG of (CAR CD))
(CAR VR))
(EQ (fetch OPNAME of (CAR CD))
(QUOTE SETQ)))
(COND
[DOXVAR (OPT.CCHECK (EQ FRM (OPT.CODEFRAME CD)))
(RPLACA CD (create OP
OPNAME ←(QUOTE STORE)
OPARG ←(OR (OPT.CODELEV
CD
(LENGTH (CDR VR)))
(OPT.COMPILERERROR]
(T (OPT.PRDEL CD)
(CW delete SETQ in OPT.FRAMEDEL)]
((AND DOXVAR (EQ (CAR CD)
(CAR VR)))
(OPT.CCHECK (EQ (OPT.CODEFRAME CD)
FRM))
(RPLACA CD (COND
([ZEROP (SETQ TMP (OPT.CODELEV (fetch PREV of CD)
(LENGTH (CDR VR]
OPCOPY)
(T (create OP
OPNAME ←(QUOTE COPY)
OPARG ← TMP]
[MAPC LABELS (FUNCTION (LAMBDA (X)
(COND
((EQ (fetch (TAG FRAME) of (CAR X))
FRM)
(replace (TAG FRAME) of (CAR X) with PARENT)
(AND (fetch (TAG LEVEL) of (CAR X))
FLV
(replace (TAG LEVEL) of (CAR X) with (IPLUS (fetch (TAG LEVEL)
of (CAR X))
FLV]
[PROG ((CD (CADR F))) (* delete the bind and all of the var references after)
[MAPC (CONS NIL (AND (NOT DOXVAR)
VARS))
(FUNCTION (LAMBDA NIL
(SETQ CD (PROG1 (fetch NXT of CD)
(OPT.PRDEL CD]
(FRPTQ (fetch NNILS of FRM)
(OPT.PRATTACH OPNIL (fetch PREV of CD]
(COND
((fetch EXTCALL of FRM)
(replace EXTCALL of PARENT with T)))
[MAPC (CDDR F)
(FUNCTION (LAMBDA (CD) (* change DUNBIND to POP of LEVEL)
(SELECTQ [PROG1 (fetch OPNAME of (SETQ OP (CAR CD)))
(SETQ CD (PROG1 (fetch PREV of CD)
(OPT.PRDEL CD]
[UNBIND (COND
[DOXVAR (COND
([NOT (ZEROP (SETQ TMP
(IPLUS (CAR (fetch OPARG
of OP))
(LENGTH VARS)
-1]
(SETQ CD (OPT.PRATTACH (create OP
OPNAME ←(QUOTE
STORE)
OPARG ← TMP)
CD))
(FRPTQ TMP (OPT.PRATTACH OPPOP CD]
(T (OPT.CCHECK (EQ (CAR (fetch OPARG of OP))
1]
(DUNBIND (FRPTQ [COND
(DOXVAR (IPLUS (CAR (fetch OPARG of OP))
(fetch NVALS of FRM)
(fetch NNILS of FRM)))
(T (CAR (fetch OPARG of OP]
(OPT.PRATTACH OPPOP CD)))
(OPT.COMPILERERROR]
[MAPC FRAMES (FUNCTION (LAMBDA (F2)
(COND
((EQ (fetch PARENT of (CAR F2))
FRM)
(replace PARENT of (CAR F2) with PARENT)
(replace (FRAME LEVEL) of (CAR F2) with (AND FLV (SETQ TMP
(fetch (FRAME LEVEL)
of (CAR F2)))
(IPLUS TMP FLV]
(RETURN T])
(OPT.FRAMEVAR
[LAMBDA (F) (* lmm "26-DEC-81 15:53")
(PROG (VARS CD (FR (CAR F))
VAL ANY NNILS NVALS)
[SETQ VARS (REVERSE (OR (fetch VARS of FR)
(RETURN]
(SETQ NNILS (fetch NNILS of FR))
(SETQ NVALS (fetch NVALS of FR))
[for V on VARS as I from NNILS to 0 by -1 when (NEQ (fetch OPNAME of (CAR V))
(QUOTE AVAR))
do (COND
((NOT (SETQ CD (FMEMB (CAR V)
CODE)))
[COND
((ZEROP I)
(SETQ I 1)
(OPT.PRATTACH OPPOP (fetch PREV of (CADR F)))
(SETQ NVALS (SUB1 NVALS)))
(T (SETQ NNILS (SUB1 NNILS]
(CW local var bound but not used)
(PROG ((CD CODE))
LP (COND
((NOT CD)
(RETURN))) (* delete all SETQ's)
(COND
((AND (EQ (fetch OPARG of (CAR CD))
(CAR V))
(EQ (fetch OPNAME of (CAR CD))
(QUOTE SETQ)))
(CW local var set but never used)
(OPT.PRDEL CD)))
(SETQ CD (fetch PREV of CD))
(GO LP))
(RPLACA V NIL)
(SETQ ANY T))
([NOTANY CODE (FUNCTION (LAMBDA (X)
(AND (EQ (fetch OPNAME of X)
(QUOTE SETQ))
(EQ (fetch OPARG of X)
(CAR V]
(COND
([SETQ VAL (COND
((NEQ I 0)
(CW NIL var never set)
(SETQ NNILS (SUB1 NNILS))
OPNIL)
((AND (EQ [fetch OPNAME of (SETQ VAL (CAR (fetch PREV
of (CADR F]
(QUOTE CONST))
(APPLY* EQCONSTFN (fetch OPARG of VAL)))
(SETQ I 1)
(SETQ NVALS (SUB1 NVALS)) (* delete this var, can try next)
(CW var bound to CONST and never set)
(PROG1 (CAR (fetch PREV of (CADR F)))
(OPT.PRDEL (fetch PREV of (CADR F]
(do (FRPLACA CD VAL) repeatwhile (SETQ CD (FMEMB (CAR V)
CD)))
(FRPLACA V NIL)
(SETQ ANY T]
(COND
(ANY [replace VARS of FR with (OPT.DREV (SUBSET VARS (FUNCTION (LAMBDA (X)
X]
(replace NNILS of FR with NNILS)
(replace NVALS of FR with NVALS)))
(RETURN ANY])
(OPT.DELETEFRAMECHECK
[LAMBDA (VARS F) (* lmm: "22-JUL-77 02:58")
(PROG ((CD (OPT.ONLYMEMB (CAR VARS)
CODE)))
(OR (AND CD (EQ (fetch PREV of CD)
(CADR F)))
(RETURN))
LP (SETQ VARS (CDR VARS))
(SETQ CD (fetch NXT of CD))
(COND
((NULL VARS)
(RETURN T)))
(COND
((EQ (OPT.ONLYMEMB (CAR VARS)
CODE)
CD)
(GO LP])
(OPT.ONLYMEMB
[LAMBDA (X Y) (* lmm: " 6-OCT-76 15:06:48")
(AND (SETQ Y (FMEMB X Y))
(NOT (FMEMB X (CDR Y)))
Y])
)
(RPAQQ MERGEFRAMETYPES (PROG LAMBDA MAP))
(RPAQQ OPTIMIZATIONSOFF NIL)
(DEFINEQ
(OPT.SKIPPUSH
[LAMBDA (CD N VL LEVOPFLG) (* lmm "19-JAN-82 22:16")
(OR N (SETQ N 1))
(COND
((ILESSP N 0)
NIL)
((ZEROP N)
CD)
(T (SELECTQ (fetch OPNAME of (CAR CD))
((AVAR HVAR FVAR GVAR CONST)
(OPT.SKIPPUSH (fetch PREV of CD)
(SUB1 N)
VL LEVOPFLG))
(COPY (AND (NOT (fetch OPARG of (CAR CD)))
(OPT.SKIPPUSH (fetch PREV of CD)
(SUB1 N)
VL LEVOPFLG)))
(SWAP (AND (IGEQ N 2)
(OPT.SKIPPUSH (fetch PREV of CD)
N VL LEVOPFLG)))
(POP (OPT.SKIPPUSH (fetch PREV of CD)
(ADD1 N)
VL LEVOPFLG))
((FJUMP TJUMP NFJUMP NTJUMP)
(AND NEWOPTFLG (NOT LEVOPFLG)
(OPT.SKIPPUSH (fetch PREV of CD)
(ADD1 N)
VL LEVOPFLG)))
[FN (COND
((OR (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR CD)))
(QUOTE NOSIDE))
(AND NEWOPTFLG (SELECTQ (fetch OPNAME of (CAR VL))
((CONST HVAR)
T)
((FVAR AVAR GVAR)
(COMP.CLEANFNOP (CDR (fetch OPARG
of (CAR CD)))
(QUOTE FREEVARS)))
NIL)))
(OPT.SKIPPUSH (fetch PREV of CD)
[SUB1 (IPLUS N (CAR (fetch OPARG of (CAR CD]
VL LEVOPFLG]
[SETQ (COND
([AND NEWOPTFLG VL (NEQ (CAR VL)
(fetch OPARG of (CAR CD]
(OPT.SKIPPUSH (fetch PREV of CD)
N VL LEVOPFLG]
NIL])
(OPT.DELCODE
[LAMBDA (CD) (* DD: "21-FEB-83 17:08")
(PROG (X FLG)
LP (SELECTQ (fetch OPNAME of (SETQ X (CAR CD)))
(NIL (RETURN FLG))
(TAG (RETURN FLG))
[(BIND ERRORSET)
(RPLACA (CDR (FASSOC (CDR (fetch OPARG of X))
FRAMES))
NIL)
(for LB in LABELS when (EQ (fetch (TAG FRAME) of (CAR LB))
(CDR (fetch OPARG of X)))
do (MAPC (CDR LB)
(FUNCTION OPT.PRDEL]
[(UNBIND DUNBIND)
(COND
(MERGEUNBINDFLG (DREMOVE CD (FASSOC (CDR (fetch OPARG of X))
FRAMES)))
(T (RETURN FLG]
((JUMP FJUMP TJUMP NFJUMP NTJUMP ERRORSET)
(CW delete unreachable jump)
(DREMOVE CD (OPT.DEFREFS (fetch (JUMP TAG) of X)))
(SETQ FLG T))
(CW delete unreachable code))
(SETQ ANY T)
(SETQ CD (PROG1 (fetch NXT of CD)
(OPT.PRDEL CD)))
(GO LP])
(OPT.PRATTACH
[LAMBDA (ITEM BEFORE) (* lmm: "22-JUL-77 02:58")
(PROG ((AFTER (fetch NXT of BEFORE))
(NEW (CONS)))
(replace NXT of NEW with AFTER)
(replace PREV of NEW with BEFORE)
(FRPLACA NEW ITEM)
(replace NXT of BEFORE with NEW)
(AND AFTER (replace PREV of AFTER with NEW))
(RETURN NEW])
(OPT.JUMPCOPYTEST
[LAMBDA (VL CDFROM) (* lmm "15-JAN-82 18:08")
(* Where can a COPY be inserted such that VL would be on the stack -
either returns the code list or NIL -
used by transformation -
var TJUMP->l var ... l: var -
=> var COPY TJUMP->l2 ... l: var l2:)
(COND
((OPT.EQVALUE CDFROM VL)
CDFROM)
((AND (OPT.CALLP (CAR CDFROM))
(OR (EQ (fetch OPNAME of (CAR VL))
(QUOTE HVAR))
(COMP.CLEANFNP (CDR (fetch OPARG of (CAR CDFROM)))
(QUOTE FREEVARS)))
(SETQ CDFROM (OPT.SKIPPUSH (fetch PREV of CDFROM)
[SUB1 (CAR (fetch OPARG of (CAR CDFROM]
VL T)))
(OPT.JUMPCOPYTEST VL CDFROM])
(OPT.EQOP
[LAMBDA (OP1 OP2) (* lmm " 8-JAN-82 09:04")
(OR (EQ OP1 OP2)
(AND (EQ (fetch OPNAME of OP1)
(fetch OPNAME of OP2))
(SELECTQ (fetch OPNAME of OP1)
((FVAR GVAR CONST COPY STORE)
(EQ (fetch OPARG of OP1)
(fetch OPARG of OP2)))
((POP RETURN SWAP)
[OPT.CCHECK (AND (NOT (fetch OPARG of OP1))
(NOT (fetch OPARG of OP2]
T)
(FN (EQUAL OP1 OP2))
[(JUMP TJUMP NTJUMP FJUMP NFJUMP BIND ERRORSET UNBIND DUNBIND)
(AND (EQ (CAR (fetch OPARG of OP1))
(CAR (fetch OPARG of OP2)))
(EQ (CDR (fetch OPARG of OP1))
(CDR (fetch OPARG of OP2]
(SETQ (OPT.EQOP (fetch OPARG of OP1)
(fetch OPARG of OP2)))
NIL])
(OPT.EQVALUE
[LAMBDA (CD V) (* lmm "19-JAN-82 22:25")
(PROG NIL
LP (RETURN (SELECTQ (fetch OPNAME of (CAR CD))
[COPY (COND
((NULL (fetch OPARG of (CAR CD)))
(SETQ CD (fetch PREV of CD))
(GO LP]
[SETQ (COND
((EQ (fetch OPARG of (CAR CD))
(CAR V)))
(T (SETQ CD (fetch PREV of CD))
(GO LP]
((HVAR AVAR FVAR GVAR CONST)
(EQ (CAR CD)
(CAR V)))
[(POP FJUMP TJUMP NFJUMP NTJUMP SWAP)
(COND
((SETQ CD (OPT.SKIPPUSH (fetch PREV of CD)
1 V))
(GO LP]
NIL])
(OPT.DELCOPYFN
[LAMBDA (P X) (* lmm "18-JAN-82 13:17")
(while (AND (OPT.CALLP (CAR P)
NIL 1)
(OPT.EQOP (CAR P)
(CAR (fetch NXT of X)))
(COMP.CLEANFNOP (CDR (fetch OPARG of (CAR P)))
(QUOTE NOSIDE))
(for Z←P by (fetch PREV of Z) while (AND Z (NEQ Z X))
always (SELECTQ (fetch OPNAME of (CAR Z))
(FN (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR Z)))
(QUOTE NOSIDE)))
((FVAR AVAR HVAR GVAR SETQ)
(* SETQ is OK since we have already guaranteed that the
value skipped is not modified by intervening setqs)
T)
NIL)))
do [SETQ P (fetch NXT of (PROG1 (fetch PREV of P)
(OPT.PRDEL P]
(SETQ X (fetch NXT of X)))
X])
)
(DEFINEQ
(OPT.DEADSETQP
[LAMBDA (VAR CD) (* edited: " 9-JAN-80 14:51")
(DECLARE (SPECVARS ICNT))
(SELECTQ (fetch OPNAME of VAR)
[(AVAR HVAR)
(PROG (TAGS (ICNT 50)) (* ICNT is used to limit the nmber of instructions
looked at past the setq.)
(CW look for dead SETQ)
(RETURN (OPT.DS1 VAR CD]
NIL])
(OPT.DS1
[LAMBDA (VAR CD) (* lmm "27-OCT-81 20:35")
(* test if VAR is used in CD -- TAGS is a list of tags
already visited)
(PROG (A)
LP [SELECTQ (fetch OPNAME of (SETQ A (CAR CD)))
(SETQ (AND (EQ (fetch OPARG of A)
VAR)
(RETURN T)))
(FN (AND (EQ (fetch OPNAME of VAR)
(QUOTE AVAR))
(NOT (COMP.CLEANFNOP (CDR (fetch OPARG of A))
(QUOTE FREEVARS)))
(RETURN)))
[(UNBIND DUNBIND)
(COND
([FMEMB VAR (fetch (FRAME VARS) of (CDR (fetch OPARG of A]
(RETURN T]
[RETURN (RETURN (AND (SETQ A (OPT.CODEFRAME (fetch PREV of CD)))
(never (EQ (fetch FRAMETYPE of A)
(QUOTE ERRORSET))
repeatwhile (SETQ A (fetch PARENT of A]
(JUMP (OR [SETQ CD (CAR (OPT.DEFREFS (fetch (JUMP TAG) of A]
(RETURN))
(GO LP))
((TJUMP FJUMP NTJUMP NFJUMP ERRORSET)
(OR [OPT.DS1 VAR (CAR (OPT.DEFREFS (fetch (JUMP TAG) of A]
(RETURN)))
[TAG (COND
((FMEMB A TAGS)
(RETURN T))
(T (SETQ TAGS (CONS A TAGS]
(COND
((EQ A VAR)
(RETURN]
(OR (SETQ CD (fetch NXT of CD))
(OPT.COMPILERERROR))
NX [COND
((ZEROP ICNT)
(CW DEADSETP gives up)
(RETURN))
(T (SETQ ICNT (SUB1 ICNT]
(GO LP])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL OPT.PRDEL OPT.PRATTACH OPT.EQOP OPT.EQVALUE OPT.SKIPPUSH OPT.CODEFRAME OPT.LABELNTHPR
OPT.UBDEL OPT.DELCODE (LOCALVARS . T)
(SPECVARS CODE LEVEL))
(BLOCK: NIL OPT.POSTOPT OPT.SETUPOPT OPT.JUMPOPT (LOCALVARS . T)
(SPECVARS LABELS PASS ANY CODE FRAME FRAMES))
(BLOCK: OPT.FRAMEOPT OPT.FRAMEOPT OPT.CLEANFRAME OPT.DELETEFRAMECHECK OPT.FRAMEDEL OPT.FRAMELOCAL
OPT.FRAMEMERGE OPT.FRAMEVAR OPT.MERGEFRAMEP OPT.NONILVAR OPT.ONLYMEMB (GLOBALVARS
MERGEFRAMEMAX
MERGEFRAMEFLG
MERGEFRAMETYPES)
(SPECVARS VARS ANY FRAME)
(NOLINKFNS . T))
(BLOCK: OPT.SCANOPT OPT.SCANOPT OPT.DEADSETQP OPT.DS1 (SPECVARS TAGS)
(NOLINKFNS . T)
(LOCALFREEVARS ICNT))
(BLOCK: NIL OPT.DELCOPYFN OPT.JUMPTHRU OPT.LBMERGE OPT.LBDEL OPT.JUMPCOPYTEST (LOCALVARS . T)
(SPECVARS FRAME LEVEL ANY)
(NOLINKFNS . T))
(BLOCK: OPT.JUMPREV OPT.JUMPREV OPT.COMMONBACK OPT.DELTAGREF OPT.FINDEND (SPECVARS FRAME LEVEL ANY)
(NOLINKFNS . T))
(BLOCK: OPT.RETOPT OPT.RETOPT OPT.RETFIND OPT.RETPOP OPT.RETTEST OPT.RETOPT1 OPT.RETMERGE
(SPECVARS TAGS ANY)
(NOLINKFNS . T))
]
(* CONSISTENCY CHECKS)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS OPT.CCHECK MACRO [ARGS (COND
(COMPILECOMPILERCHECKS (LIST (QUOTE AND)
(LIST (QUOTE NOT)
(CAR ARGS))
(LIST (QUOTE OPT.COMPILERERROR)
(CADR ARGS])
)
(RPAQQ COMPILECOMPILERCHECKS NIL)
)
(DEFINEQ
(OPT.COMPILERERROR
[LAMBDA (MESS1 MESS2) (* lmm " 1-MAR-78 02:55")
(LISPXPRIN1 "Compiler error
" T)
(HELP MESS1 MESS2])
(OPT.OPTCHECK
[LAMBDA NIL (* lmm "14-MAR-81 11:03")
(* set up code list as doubly linked list, scan for
tags)
(PROG ((CD CODE)
P B)
LPC (COND
((NULL CD)
[for X in LABELS do (COND
((CDR X)
[OR (FMEMB (CAR X)
CODE)
(OPT.COMPILERERROR (CAR X)
(QUOTE (not in code]
[MAPC (CDR X)
(FUNCTION (LAMBDA (Y)
(OR (TAILP Y CODE)
(OPT.COMPILERERROR Y (QUOTE (NOT CODE TAIL]
[OR (EQ (CAR (CADR X))
(CAR X))
(OPT.COMPILERERROR X (QUOTE (TAG wrong]
(EVERY (CDDR X)
(FUNCTION (LAMBDA (Y)
(OR (EQ (fetch (JUMP TAG) of (CAR Y))
(CAR X))
(OPT.COMPILERERROR X (QUOTE (TAG wrong]
[for X in FRAMES do (COND
[(EQ (CAR X)
TOPFRAME)
(AND (CDR X)
(OPT.COMPILERERROR (CONS (QUOTE TOPFRAME)
X]
(T [for Y in (CDR X)
do (OR (TAILP Y CODE)
(OPT.COMPILERERROR (LIST (QUOTE (NOT IN CODE))
Y X)))
(OR (EQ (CDR (fetch OPARG of (CAR Y)))
(CAR X))
(OPT.COMPILERERROR (LIST (QUOTE (WRONG FRAME))
Y X]
(OR (FASSOC (fetch PARENT of (CAR X))
FRAMES)
(OPT.COMPILERERROR (QUOTE (PARENT NOT FRAME))
X]
(RETURN T)))
(SELECTQ (fetch OPNAME of (CAR CD))
(TAG (OR (SETQ B (FASSOC (CAR CD)
LABELS))
(OPT.COMPILERERROR))
(OR (EQ (CAR (CDR B))
CD)
(OPT.COMPILERERROR))
(OR (OR (NULL (fetch (TAG FRAME) of (CAR CD)))
(FASSOC (fetch (TAG FRAME) of (CAR CD))
FRAMES))
(OPT.COMPILERERROR)))
((BIND ERRORSET)
(OR (EQ (CADR (FASSOC (CDR (fetch OPARG of (CAR CD)))
FRAMES))
CD)
(OPT.COMPILERERROR)))
((UNBIND DUNBIND)
(OR (FMEMB CD (CDDR (FASSOC (CDR (fetch OPARG of (CAR CD)))
FRAMES)))
(OPT.COMPILERERROR)))
[(JUMP TJUMP FJUMP NTJUMP NFJUMP)
(OR (SETQ B (FASSOC (fetch (JUMP TAG) of (CAR CD))
LABELS))
(OPT.COMPILERERROR))
(OR (MEMB CD B)
(OPT.COMPILERERROR CD (QUOTE (NOT IN JUMP LIST]
NIL)
(SETQ B (CDR CD))
(OR (AND (EQ (fetch PREV of CD)
B)
(EQ (fetch NXT of CD)
P))
(OPT.COMPILERERROR))
(SETQ P CD)
(SETQ CD B)
(GO LPC])
(OPT.CCHECK
[LAMBDA (X) (* lmm "14-MAR-81 09:18")
(OR X (OPT.COMPILERERROR])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(ADDTOVAR PRETTYPRINTMACROS (CW LAMBDA (L) (PROG ((**COMMENT**FLG
(AND **COMMENT**FLG " **compwatch** ")))
(COMMENT1 L T)))
(CWN LAMBDA (L) (PROG ((**COMMENT**FLG
(AND **COMMENT**FLG " **compwatch** ")))
(COMMENT1 L T))))
(SETTEMPLATE (QUOTE CW)
(QUOTE (NIL)))
(SETTEMPLATE (QUOTE CWN)
(QUOTE (EVAL)))
(DECLARE: EVAL@COMPILE
(PUTPROPS CW VAXMACRO (= . *))
(PUTPROPS CW MACRO (X NIL))
(PUTPROPS CWN VAXMACRO (= . *))
(PUTPROPS CWN MACRO (X NIL))
)
(ADDTOVAR NLAML CW)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS ALAMS BLKLIBRARY BYTE.EXT BYTEASSEMFN BYTECOMPFLG COMPILERMACROPROPS CIA
CLEANFNLIST COMP.SCRATCH COMPILETYPELST COMPILEUSERFN COMPSTATLST COMPSTATS CONDITIONALS
CONST.FNS CONSTOPS DONOTHING FILERDTBL FNA FORSHALLOW FRA GLOBALVARS HEADERBYTES
HOKEYDEFPROP LAMBDANOBIND LAMS LBA LEVELARRAY LINKEDFNS LINKFNS LOADTIMECONSTANT MAXBNILS
MAXBVALS MCONSTOPS MERGEFRAMEFLG MERGEFRAMEMAX MERGEFRAMETYPES MOPARRAY MOPCODES NLAMA
NLAML NODARR NOLINKFNS NOSTATSFLG NUMBERFNS OPCOPY OPNIL OPPOP OPRETURN PRA SELECTQFMEMB
SELECTVARTYPES STATAR STATMAX STATN SYSSPECVARS UNIQUE#ARRAY VCA VCONDITIONALS VREFFRA
COUTFILE XVARFLG MERGEFRAMEFLG OPTIMIZATIONSOFF NOFREEVARSFNS EQCONSTFN MERGEUNBINDFLG
NEWOPTFLG)
)
(DECLARE: DONTCOPY
(* for compiling compiler)
EVAL@COMPILE
[DECLARE: EVAL@COMPILE
(RECORD CODELST (OP . PREV)
[ACCESSFNS CODELST ((NXT (GETHASH DATUM PRA)
(PUTHASH DATUM NEWVALUE PRA])
]
(PUTPROPS OASSOC MACRO ((X Y)
(FASSOC X Y)))
[DECLARE: EVAL@COMPILE
(RECORD OP (OPNAME . OPARG))
(RECORD JUMP (OPNAME TAG . JT) (* kind of OP)
)
(TYPERECORD TAG (LBNO . LEVEL) (* kind of OP)
LBNO ←(SETQ LBCNT (ADD1 LBCNT))
[ACCESSFNS TAG ((FRAME (GETHASH DATUM FRA)
(PUTHASH DATUM NEWVALUE FRA))
(JD (GETHASH DATUM LBA)
(PUTHASH DATUM NEWVALUE LBA])
(RECORD VAR (COMP.VARTYPE . VARNAME) (* A particular kind of OP)
)
]
[DECLARE: EVAL@COMPILE
(RECORD FRAME (FRAMETYPE (NNILS . VARS)
LEVEL
(BINDLST NVALS EXTCALL . CPIOK) . PROGLABELS)
(* FRAMETYPE is one of PROG LAMBDA ERRORSET MAP NIL -
VARS are variables bound, NNILS are # which are bound to NIL -
LEVEL is # of things on stack between this and next higher frame)
(ACCESSFNS FRAME ((PARENT (GETHASH DATUM FRA)
(PUTHASH DATUM NEWVALUE FRA))
(VREFFROM (GETHASH DATUM VREFFRA)
(PUTHASH DATUM NEWVALUE VREFFRA))
(NODBIND (GETHASH DATUM NODARR)
(PUTHASH DATUM NEWVALUE NODARR))
(PRIMARYRETURN (GETHASH DATUM BCINFO)
(PUTHASH DATUM NEWVALUE BCINFO)))
(* PARENT is next higher enclosing frame -
shares hash table with TAG.FRAME)
)
(RECORD CPIOK NOXVAR (* Share the CPIOK field used by the compiler pass 1 and
the NOXVAR field used by the maxc assembler)
)
NNILS ← 0)
(RECORD COMINFO (COMTYPE TOPFRAME CODE ARGS))
(ACCESSFNS COMP (CLEAR (PROGN (OPT.INITHASH FRA)
(OPT.INITHASH LBA)
(OPT.INITHASH PRA)
(OPT.INITHASH VREFFRA)
(OPT.INITHASH NODARR)
(OPT.INITHASH BCINFO))))
(RECORD JD (JPT (JMIN . JSN)
JU . JML)
(* JPT is NIL (for tags) or a pointer into ACODE (for jumps). JMIN is the lowest possible location for the
instruction or tag. JU is the cumulative uncertainty (for tags) or the length uncertainty
(for jumps). JML is the minimum length (for jumps). JSN is a serial number (the original JMIN) used to decide
whether a jump goes forward or backward.)
)
]
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML OPT.INITHASH)
(ADDTOVAR LAMA )
)
(PUTPROPS BYTECOMPILER COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7336 11844 (BYTEBLOCKCOMPILE2 7346 . 8817) (BYTECOMPILE2 8819 . 9056) (
COMP.ATTEMPT.COMPILE 9058 . 10114) (COMP.RETFROM.POINT 10116 . 10780) (COMPERROR 10782 . 10972) (
COMPPRINT 10974 . 11225) (COMPERRM 11227 . 11842)) (11845 17038 (COMP.TOPLEVEL.COMPILE 11855 . 14955)
(COMP.BINDLIST 14957 . 15209) (COMP.CHECK.VAR 15211 . 15599) (COMP.BIND.VARS 15601 . 16692) (
COMP.UNBIND.VARS 16694 . 17036)) (17039 26891 (COMP.VALN 17049 . 17182) (COMP.PROGN 17184 . 17877) (
COMP.DELPOPP 17879 . 18233) (COMP.EXP1 18235 . 18301) (COMP.EXPR 18303 . 20113) (COMP.TRYUSERFN 20115
. 20342) (COMP.USERFN 20344 . 20815) (COMP.CONST 20817 . 21610) (COMP.CALL 21612 . 23116) (COMP.VAR
23118 . 23387) (COMP.VAL1 23389 . 23522) (COMP.PROG1 23524 . 23790) (COMP.EFFECT 23792 . 24245) (
COMP.VAL 24247 . 24688) (COMP.MACRO 24690 . 26889)) (26892 28471 (COMP.VARTYPE 26902 . 27131) (
COMP.LOOKUPVAR 27133 . 28104) (COMP.LOOKUPCONST 28106 . 28469)) (28472 34535 (COMP.ST 28482 . 28894) (
COMP.STFN 28896 . 29190) (COMP.STCONST 29192 . 29352) (COMP.STVAR 29354 . 29486) (COMP.STPOP 29488 .
29640) (COMP.DELFN 29642 . 29861) (COMP.STRETURN 29863 . 30031) (COMP.STTAG 30033 . 30854) (
COMP.STJUMP 30856 . 32272) (COMP.STSETQ 32274 . 32513) (COMP.STCOPY 32515 . 32691) (COMP.DELPUSH 32693
. 32852) (COMP.DELPOP 32854 . 33018) (COMP.STBIND 33020 . 34122) (COMP.STUNBIND 34124 . 34533)) (
34536 36777 (COMP.ARGTYPE 34546 . 35209) (COMP.CLEANEXPP 35211 . 35478) (COMP.CLEANFNP 35480 . 35796)
(COMP.CLEANFNOP 35798 . 35942) (COMP.GLOBALVARP 35944 . 36117) (COMP.LINKCALLP 36119 . 36512) (
COMP.ANONP 36514 . 36775)) (36778 39229 (COMP.CPI 36788 . 38157) (COMP.CPI1 38159 . 38731) (
COMP.PICOUNT 38733 . 39227)) (39269 39459 (COMP.EVQ 39279 . 39457)) (39563 40843 (COMP.BOOL 39573 .
40841)) (40844 41201 (COMP.APPLYFNP 40854 . 41199)) (41367 41875 (COMP.AC 41377 . 41554) (COMP.PUNT
41556 . 41873)) (41925 43428 (COMP.FUNCTION 41935 . 42280) (COMP.LAM1 42282 . 42851) (COMP.GENFN 42853
. 43426)) (43682 48328 (COMP.COND 43692 . 44865) (COMP.SELECTQ 44867 . 48326)) (48499 48989 (
COMP.QUOTE 48509 . 48736) (COMP.COMMENT 48738 . 48987)) (49037 50413 (COMP.DECLARE 49047 . 49706) (
COMP.DECLARE1 49708 . 50411)) (53068 53787 (COMP.CARCDR 53078 . 53599) (COMP.STCROP 53601 . 53785)) (
53867 54322 (COMP.NOT 53877 . 54320)) (54405 54814 (COMP.SETQ 54415 . 54598) (COMP.SETN 54600 . 54812)
) (54815 57377 (COMP.LAMBDA 54825 . 57375)) (57501 62166 (COMP.PROG 57511 . 59835) (COMP.GO 59837 .
60802) (COMP.RETURN 60804 . 62164)) (63741 68410 (COMP.NUMERIC 63751 . 66088) (COMP.NUMBERCALL 66090
. 67209) (COMP.FIX 67211 . 67359) (COMP.STFIX 67361 . 67937) (COMP.DELFIX 67939 . 68408)) (68526
69801 (COMP.EQ 68536 . 69799)) (69859 72149 (COMP.NUMBERTEST 69869 . 72147)) (73244 78432 (COMP.MAP
73254 . 78430)) (79883 82780 (COMP.MLLIST 79893 . 80424) (COMP.MLL 80426 . 82173) (COMP.MLLVAR 82175
. 82446) (COMP.MLLFN 82448 . 82778)) (83766 87454 (OPT.RESOLVEJUMPS 83776 . 84589) (OPT.JLENPASS
84591 . 86646) (OPT.JFIXPASS 86648 . 87127) (OPT.JSIZE 87129 . 87452)) (87630 89886 (OPT.CALLP 87640
. 88015) (OPT.JUMPCHECK 88017 . 88218) (OPT.DREV 88220 . 88404) (OPT.CHLEV 88406 . 88597) (
OPT.CHECKTAG 88599 . 88949) (OPT.NOTJUMP 88951 . 89305) (OPT.INITHASH 89307 . 89547) (OPT.COMPINIT
89549 . 89884)) (90094 90824 (OPT.CFRPTQ 90104 . 90822)) (94691 134600 (OPT.POSTOPT 94701 . 96073) (
OPT.SETUPOPT 96075 . 97642) (OPT.SCANOPT 97644 . 103126) (OPT.XVARSCAN 103128 . 103934) (OPT.XVARSCAN1
103936 . 104470) (OPT.JUMPOPT 104472 . 104838) (OPT.JUMPTHRU 104840 . 109761) (OPT.LBMERGE 109763 .
110313) (OPT.PRDEL 110315 . 110660) (OPT.UBDEL 110662 . 110881) (OPT.LBDEL 110883 . 111366) (
OPT.LABELNTHPR 111368 . 112063) (OPT.JUMPREV 112065 . 121258) (OPT.COMMONBACK 121260 . 123492) (
OPT.DELTAGREF 123494 . 123807) (OPT.FINDEND 123809 . 124119) (OPT.RETOPT 124121 . 125164) (OPT.RETFIND
125166 . 125541) (OPT.RETPOP 125543 . 127159) (OPT.RETOPT1 127161 . 127462) (OPT.RETTEST 127464 .
129552) (OPT.RETMERGE 129554 . 132051) (OPT.CODELEV 132053 . 133540) (OPT.CODEFRAME 133542 . 134252) (
OPT.DEFREFS 134254 . 134390) (OPT.SETDEFREFS 134392 . 134598)) (134601 146810 (OPT.FRAMEOPT 134611 .
135278) (OPT.FRAMEMERGE 135280 . 136901) (OPT.NONILVAR 136903 . 137623) (OPT.MERGEFRAMEP 137625 .
138420) (OPT.FRAMELOCAL 138422 . 138892) (OPT.CLEANFRAME 138894 . 139247) (OPT.FRAMEDEL 139249 .
143656) (OPT.FRAMEVAR 143658 . 146140) (OPT.DELETEFRAMECHECK 146142 . 146632) (OPT.ONLYMEMB 146634 .
146808)) (146892 153371 (OPT.SKIPPUSH 146902 . 148464) (OPT.DELCODE 148466 . 149574) (OPT.PRATTACH
149576 . 150037) (OPT.JUMPCOPYTEST 150039 . 150833) (OPT.EQOP 150835 . 151717) (OPT.EQVALUE 151719 .
152422) (OPT.DELCOPYFN 152424 . 153369)) (153372 155465 (OPT.DEADSETQP 153382 . 153866) (OPT.DS1
153868 . 155463)) (156945 159961 (OPT.COMPILERERROR 156955 . 157129) (OPT.OPTCHECK 157131 . 159816) (
OPT.CCHECK 159818 . 159959)))))
STOP