(FILECREATED "20-Jun-86 15:38:18" {ERIS}<TAMARIN>WORK>DT>PC.;40 143453Q
changes to: (FNS PC.STUDYCODE)
previous date: "13-Jun-86 10:48:49" {ERIS}<TAMARIN>WORK>DT>PC.;39)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PCCOMS)
(RPAQQ PCCOMS ((* * towards a new PRINTCODE -- will be a little more helpful and will stack-model
better)
(FILES TAMGETMACHINE)
(GLOBALVARS \PC.STACK \PC.BMS \PC.JUMPTO \PC.FLAGS)
(FNS PC.1)
(FNS PC.DOHDR PC.DO1NT)
(FNS PC.DOFNHDR.D PC.DOFNHDR.D.PRINT2W)
(FNS PC.DOFNHDR.T PC.DOFNHDR.T.PRINT1C)
(FNS PC.STUDYCODE PC.S.MODELSOME PC.S.LEVADJ PC.S.ADD PC.S.DOJUMP)
(FNS PC.PRINTCODE PC.P.INSTR PC.P.OPPRINT)
(COMS (* * utility)
(FNS PC.NUMWIDTH)
(FNS PC.GETBYTE PC.GETBYTES PC.FINDOP)
(FNS PC.OPBYTE PC.OPBYTES)
(FNS PC.GETOPKARG PC.GETVARSLOT PC.GETJUMPTARG PC.GETJUMPTARG.D
PC.GETJUMPTARG.T)
(FNS PC.VARNAME PC.VARNAME.1NT.D))
(COMS (* * access memory built during stack-modelling passes -- dummies for now)
(FNS PC.STACK PC.SETSTACK PC.STACKMAX PC.STACKAMBIG? PC.NOTESTACKAMBIG)
(FNS PC.BMS PC.SETBMS PC.BMSMAX PC.BMSAMBIG? PC.NOTEBMSAMBIG)
(FNS PC.JUMPTO PC.INCJUMPTO PC.JUMPTOMAX))))
(* * towards a new PRINTCODE -- will be a little more helpful and will stack-model better)
(FILESLOAD TAMGETMACHINE)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \PC.STACK \PC.BMS \PC.JUMPTO \PC.FLAGS)
)
(DEFINEQ
(PC.1
[LAMBDA (FN MACHINE OUTF)
(DECLARE (SPECVARS OUTF)) (* jmh "23-May-86 11:27")
(* * ad-hoc "global" mode switches -- # of code bytes printed on line 1 of an instr line -- are we printing the
stack and jump-to columns?)
(PROG ((NRBYTESLINE1 3)
(PRINTSTACK? T))
(DECLARE (SPECVARS NRBYTESLINE1 PRINTSTACK?))
(* * digest machine type)
(RETURN (LET (TAM.OUTPUTSTYLE TAM.FNHDRSTYLE TAM.NTSTYLE TAM.OPCODEARRAY TAM.STACKSTYLE
TAM.MAXSTACK TAM.ALPHASTYLE TAM.VARXSTYLE TAM.OPKSTYLE
TAM.JUMPSTYLE TAM.LAMBDAEVS)
(DECLARE (SPECVARS TAM.OUTPUTSTYLE TAM.FNHDRSTYLE TAM.NTSTYLE
TAM.OPCODEARRAY TAM.STACKSTYLE TAM.MAXSTACK
TAM.ALPHASTYLE TAM.VARXSTYLE TAM.JUMPSTYLE
TAM.JUMPFROMBEG TAM.LAMBDAEVS))
(TAM.GETMACHINE MACHINE)
(LET [(HASBMS? (EQ TAM.STACKSTYLE (QUOTE D]
(DECLARE (SPECVARS HASBMS?))
(* * get CODEARRAY)
(LET (CODEARRAY)
(DECLARE (SPECVARS CODEARRAY))
(SELECTQ TAM.OUTPUTSTYLE
[D (SETQ CODEARRAY (if (AND FN (LITATOM
FN))
then (GETD FN)
else FN))
(if (NOT (AND CODEARRAY (MCODEP CODEARRAY)))
then (RETURN (DT.ERROR FN
"not compiled D-machine code"
(QUOTE PC.1]
[B (SETQ CODEARRAY (if (AND FN (LITATOM
FN))
then (GETPROP
FN
(QUOTE TCODE))
else FN))
(if (LISTP CODEARRAY)
then (SETQ CODEARRAY (CAR CODEARRAY)))
(if [NOT (AND CODEARRAY (ARRAYP CODEARRAY)
(EQ (ARRAYTYP CODEARRAY)
(QUOTE BYTE]
then (RETURN (DT.ERROR FN
"not byte-array code thingy"
(QUOTE PC.1]
(ERROR "unimpl code-thingy style" TAM.OUTPUTSTYLE))
(* * "global" specvars describing the CODEARRAY)
(* * NTBASEB is the offset in bytes of the global name table -- NTSIZEW is the length in words of half the global
name table -- it differs from the NTSIZE field of the fn hdr in that if NTSIZE is 0, NTSIZEW is 2 since the global
name table always physically exists -- detect emptiness of global name table by zeroness of 0th word)
(* * LTBASEB is the offset in bytes of the local name table -- LTSIZEW is correspondingly for local name table --
however, if the local name table is empty it doesn't exist, and then LTSIZEW is 0)
(LET (STARTPC INITSTACK FNTYPE NTBASEB NTSIZEW LTBASEB LTSIZEW
MAXPC MAXSTACK)
(DECLARE (SPECVARS STARTPC INITSTACK FNTYPE NTBASEB
NTSIZEW LTBASEB LTSIZEW MAXPC
MAXSTACK))
(* * hey, let's do it!)
(PC.DOHDR)
(PC.STUDYCODE)
(PC.PRINTCODE)
FN])
)
(DEFINEQ
(PC.DOHDR
[LAMBDA NIL (* jmh "12-Jun-86 14:04")
(* * digest and print function header proper and name tables, per machine style)
(DECLARE (USEDFREE TAM.FNHDRSTYLE TAM.NTSTYLE)
(USEDFREE NTBASEB NTSIZEW LTBASEB LTSIZEW))
(* * fn header proper)
[SELECTQ TAM.FNHDRSTYLE
(D (PC.DOFNHDR.D)
(SETQ NTBASEB (UNFOLD (fetch (CODEARRAY OVERHEADWORDS) of T)
BYTESPERWORD)))
(PROGN (PC.DOFNHDR.T)
(SETQ NTBASEB (UNFOLD (PLUS (fetch (TFNHDR OVERHEADCELLS) of T)
(PROG1 8
(* for entry vector)))
BYTESPERCELL]
(* * global name table)
(SELECTQ TAM.NTSTYLE
(D (if (NOT (ZEROP (PC.GETBYTES NTBASEB 2)))
then (printout OUTF " name table--" T)
(PC.DO1NT NTBASEB NTSIZEW)))
(ERROR "unimpl name table style"))
(* * local name table)
(SELECTQ TAM.NTSTYLE
(D [SETQ LTBASEB (IPLUS NTBASEB (ITIMES 2 (UNFOLD NTSIZEW BYTESPERWORD]
(SETQ LTSIZEW (IQUOTIENT (FOLDLO (IDIFFERENCE STARTPC LTBASEB)
BYTESPERWORD)
2))
(if (NOT (ZEROP LTSIZEW))
then (printout OUTF " local name table--" T)
(PC.DO1NT LTBASEB LTSIZEW)))
(ERROR "unimpl name table style"])
(PC.DO1NT
[LAMBDA (NTBASEB NTSIZEW) (* jmh
" 6-Mar-86 15:27")
(* * print a name table)
(DECLARE (USEDFREE OUTF))
(LET*((NTSIZEB (UNFOLD NTSIZEW BYTESPERWORD))
(PCFORMAT (LIST (QUOTE FIX)
(PC.NUMWIDTH (IPLUS NTBASEB (ITIMES 2 NTSIZEB))
8)
8 T)))
(for P1 from NTBASEB by BYTESPERWORD as P2 from (IPLUS NTBASEB NTSIZEB) by BYTESPERWORD
as I from 1 to NTSIZEW bind (W1 W2 VARTYPE)
do (SETQ W1 (PC.GETBYTES P1 2))
(SETQ W2 (PC.GETBYTES P2 2))
(printout OUTF .N PCFORMAT P1 ": " .I6.8.T W1 , .N PCFORMAT P2 ": " .I6.8.T W2 ,)
(if (NOT (ZEROP W1))
then (SETQ VARTYPE (LOGAND W2 49152))
(printout OUTF (if (EQ VARTYPE IVARCODE)
then "i"
elseif (EQ VARTYPE PVARCODE)
then "p"
elseif (EQ VARTYPE FVARCODE)
then "f"
else "?")
"var "
(LOGAND W2 255)
": "
(\INDEXATOMPNAME W1)))
(printout OUTF T])
)
(DEFINEQ
(PC.DOFNHDR.D
[LAMBDA NIL (* jmh
"29-Mar-86 11:02")
(* * digest & print the function header proper for a D-machine)
(DECLARE (USEDFREE OUTF CODEARRAY)
(USEDFREE STARTPC INITSTACK FNTYPE NTSIZEW LTSIZEW))
(SETQ INITSTACK 0)
(* * 2 words -- min stack required <for printing only> --
number of arguments expected <-1 for LAMBDA*> <for printing only>)
(PC.DOFNHDR.D.PRINT2W 0)
(printout OUTF "stk" , (fetch (CODEARRAY STKMIN) of CODEARRAY)
,, "na" , (fetch (CODEARRAY NA) of CODEARRAY)
T)
(* * 2 words -- number of quadwords required for pvar region <for printing
only> -- start pc)
(PC.DOFNHDR.D.PRINT2W 4)
(SETQ STARTPC (fetch (CODEARRAY STARTPC) of CODEARRAY))
(printout OUTF "pv" , (fetch (CODEARRAY PV) of CODEARRAY)
,, "start" , .I0.8 STARTPC "q" T)
(* * 2 words -- some bits -- fn type <we have to detect LAMBDA* later> --
atomindex of framename <for printing only>)
(PC.DOFNHDR.D.PRINT2W 8)
(SETQ FNTYPE (SELECTQ (fetch (CODEARRAY ARGTYPE) of CODEARRAY)
(0 (QUOTE LAMBDA))
(1 (QUOTE NLAMBDA))
(2 (QUOTE LAMBDA*))
(QUOTE NLAMBDA*)))
(printout OUTF "aty" , FNTYPE ,, "framename" , (fetch (CODEARRAY FRAMENAME) of CODEARRAY)
T)
(* * 2 words -- size in words of half the global name table <but 0 if
empty, tho table is 4 words of 0> <our NTSIZEW is 2 in that case> --
number of pvars <for printing only> --
offset in words from start of fn header to 1st fvar in name table <for
printing only>)
(PC.DOFNHDR.D.PRINT2W 12)
(SETQ NTSIZEW (fetch (CODEARRAY NTSIZE) of CODEARRAY))
(printout OUTF "ntsize" , NTSIZEW ,, "nlocals" , (fetch (CODEARRAY NLOCALS) of CODEARRAY)
,, "fvaroffset" , (fetch (CODEARRAY FVAROFFSET) of CODEARRAY)
T)
(if (ZEROP NTSIZEW)
then (SETQ NTSIZEW (FOLDLO WORDSPERQUAD 2])
(PC.DOFNHDR.D.PRINT2W
[LAMBDA (BASEB) (* jmh
" 6-Mar-86 12:50")
(* * print "77: 177777 177777 " for 2 words starting at byte BASEB)
(DECLARE (USEDFREE OUTF))
(printout OUTF .I2.8.T BASEB ": " .I6.8.T (PC.GETBYTES BASEB 2)
, .I6.8.T (PC.GETBYTES (IPLUS BASEB 2)
2)
,])
)
(DEFINEQ
(PC.DOFNHDR.T
[LAMBDA NIL (* jmh "13-Jun-86 10:38")
(* * digest and print the function header proper and entry vector for a Tamarin -- note some fields are not
initialized until loaded to Tamarin -- note some fields are in a D-machine format until loaded to Tamarin)
(DECLARE (USEDFREE OUTF CODEARRAY)
(USEDFREE STARTPC INITSTACK FNTYPE NTSIZEW LTSIZEW))
(LET ((TFNHDR (ARRAYBASEPTR CODEARRAY))
(NRCELLSINHDR 8))
(if (NEQ NRCELLSINHDR (fetch (TFNHDR OVERHEADCELLS) of T))
then (SHOULDNT "fn hdr size -- what a surprise!"))
(* * first quad of fn hdr proper)
(* * first 2 cells aren't really loaded until sent to Tamarin -- OBJECTHEADERCELL OBJECTSIZE)
(PC.DOFNHDR.T.PRINT1C 0)
(printout OUTF T)
(PC.DOFNHDR.T.PRINT1C 1)
(printout OUTF T)
(* * cell -- FRAMENAME)
(PC.DOFNHDR.T.PRINT1C 2)
(printout OUTF "framename" , (fetch (TFNHDR FRAMENAME) of TFNHDR)
T)
(* * cell -- NTSIZE size in words of half the global name table <but 0 if empty, tho table is 4 words of 0> <our
NTSIZEW is 2 in that case> -- NLOCALS number of pvars <for printing only> -- FVAROFFSET offset in words from start
of fn header to 1st fvar in name table <for printing only>)
(PC.DOFNHDR.T.PRINT1C 3)
(SETQ NTSIZEW (fetch (TFNHDR NTSIZE) of TFNHDR))
(printout OUTF "ntsize" , NTSIZEW ,, "nlocals" , (fetch (TFNHDR NLOCALS) of TFNHDR)
,, "fvaroffset" , (fetch (TFNHDR FVAROFFSET) of TFNHDR)
T)
(if (ZEROP NTSIZEW)
then (SETQ NTSIZEW (FOLDLO WORDSPERQUAD 2)))
(* * 2nd quad of fn hdr proper)
(* * cell -- FLAGS -- MAXVAR max pvar slot used -- SP initial stack pointer)
(PC.DOFNHDR.T.PRINT1C 4)
(SETQ FNTYPE (QUOTE WHOKNOWS??)) (* just in case someone tries to use it)
(SETQ INITSTACK (fetch (TFNHDR SP) of TFNHDR))
(printout OUTF "maxvar" , (fetch (TFNHDR MAXVAR) of TFNHDR)
,, "initsp" , INITSTACK T)
(* * cell -- STARTPC 1st pc)
(PC.DOFNHDR.T.PRINT1C 5)
(SETQ STARTPC (fetch (TFNHDR PC) of TFNHDR))
(printout OUTF "1st pc" , .I0.8 STARTPC "q" T)
(* * last 2 cells aren't really loaded until sent to Tamarin -- NAMETABLE CODEBASE)
(PC.DOFNHDR.T.PRINT1C 6)
(printout OUTF T)
(PC.DOFNHDR.T.PRINT1C 7)
(printout OUTF T)
(* * 8 cells of entry vector -- still D-machine integers at this point, will be Tamarin integers after loading)
(for I from 0 to 7
do (PC.DOFNHDR.T.PRINT1C (IPLUS I NRCELLSINHDR))
(printout OUTF "ev" I , .I0.8 (TFNHDR.EVN TFNHDR I)
"q" T])
(PC.DOFNHDR.T.PRINT1C
[LAMBDA (BASEC) (* jmh "15-May-86 15:51")
(* * print "77: 177777 177777 " for the cell relative BASEC)
(DECLARE (USEDFREE OUTF))
(LET ((BASEB (UNFOLD BASEC BYTESPERCELL)))
(printout OUTF .I2.8.T BASEB ": " .I6.8.T (PC.GETBYTES BASEB 2)
, .I6.8.T (PC.GETBYTES (IPLUS BASEB 2)
2)
,])
)
(DEFINEQ
(PC.STUDYCODE
[LAMBDA NIL (* jmh "20-Jun-86 15:37")
(* * no stack-modelling etc as yet -- just estimate max PC from CODEARRAY size)
(DECLARE (USEDFREE PRINTSTACK? HASBMS? TAM.FNHDRSTYLE)
(USEDFREE CODEARRAY STARTPC MAXPC INITSTACK MAXSTACK)
(GLOBALVARS \PC.STACK \PC.BMS \PC.JUMPTO \PC.FLAGS))
(SETQ MAXPC (SUB1 (fetch (ARRAYP LENGTH) of CODEARRAY)))
(if PRINTSTACK?
then
(* * these arrays could be compacted some -- \PC.STACK maps PC -> stack depth if known, else NIL -- for D-machines,
\PC.BMS maps PC -> list <possibly NIL> of binding-marker depths -- \PC.JUMPTO maps PC -> # of times this PC is
jumped to -- \PC.FLAGS maps PC -> 1-bit = stack depth deserves to be printed with "?", 2-bit same for
binding-marker list)
(if (AND (BOUNDP (QUOTE \PC.STACK))
\PC.STACK
(ILESSP MAXPC (ARRAYSIZE \PC.STACK)))
then (for I from 0 to MAXPC do (SETA \PC.STACK I NIL))
else (SETQ \PC.STACK (ARRAY (ADD1 MAXPC)
(QUOTE POINTER)
NIL 0)))
[if HASBMS?
then (if (AND (BOUNDP (QUOTE \PC.BMS))
\PC.BMS
(ILESSP MAXPC (ARRAYSIZE \PC.BMS)))
then (for I from 0 to MAXPC do (SETA \PC.BMS I NIL))
else (SETQ \PC.BMS (ARRAY (ADD1 MAXPC)
(QUOTE POINTER)
NIL 0]
(if (AND (BOUNDP (QUOTE \PC.JUMPTO))
\PC.JUMPTO
(ILESSP MAXPC (ARRAYSIZE \PC.JUMPTO)))
then (for I from 0 to MAXPC do (SETA \PC.JUMPTO I 0))
else (SETQ \PC.JUMPTO (ARRAY (ADD1 MAXPC)
(QUOTE POINTER)
0 0)))
(if (AND (BOUNDP (QUOTE \PC.FLAGS))
\PC.FLAGS
(ILESSP MAXPC (ARRAYSIZE \PC.FLAGS)))
then (for I from 0 to MAXPC do (SETA \PC.FLAGS I 0))
else (SETQ \PC.FLAGS (ARRAY (ADD1 MAXPC)
(QUOTE BYTE)
0 0)))
(SETQ MAXPC STARTPC)
(SETQ MAXSTACK INITSTACK)
(if TAM.FNHDRSTYLE
then (* D-machine)
(PC.S.MODELSOME STARTPC INITSTACK NIL NIL NIL T)
else (LET ((TFNHDR (ARRAYBASEPTR CODEARRAY))
NEWSTARTPC)
(for I from 0 to 7
do (SETQ NEWSTARTPC (TFNHDR.EVN TFNHDR I))
(PC.INCJUMPTO NEWSTARTPC)
(PC.S.MODELSOME (TFNHDR.EVN TFNHDR I)
INITSTACK NIL NIL NIL NIL])
(PC.S.MODELSOME
[LAMBDA (PC STACK STKAMB? BMS BMSAMB? FLOW?) (* jmh
"29-Mar-86 08:36")
(* * model onwards from PC, starting with the stack situation described by
STACK STKAMB? BMS BMSAMB? -- FLOW? = are we flowing into this pc <vs
jumping there> -- propagates stack modelling across jumps, and generally
until no more progress can be made -- counts jump-to's too)
(DECLARE (USEDFREE HASBMS? MAXPC MAXSTACK)
(SPECVARS PC STACK STKAMB? BMS BMSAMB? FLOW?))
(PROG (FLOWEDIN? OLDSTACK OLDSTKAMB? OLDBMS OLDBMSAMB? OPBYTE OPCODE OPNARGS)
(DECLARE (SPECVARS OLDSTACK OPBYTE OPCODE OPNARGS)) (* OLDSTACK is NIL iff
we've never been at
this PC before)
NEXTPC
(* * compare old knowledge of this PC with the information we are
attributing to it now)
(SETQ FLOWEDIN? FLOW?)
(SETQ FLOW? NIL)
(SETQ OLDSTACK (PC.STACK PC))
(SETQ OLDSTKAMB? (PC.STACKAMBIG? PC))
(SETQ OLDBMS (AND HASBMS? (PC.BMS PC)))
(SETQ OLDBMSAMB? (AND HASBMS? (PC.BMSAMBIG? PC)))
[if (NOT OLDSTACK)
then (PC.SETSTACK PC STACK)
(if HASBMS?
then (PC.SETBMS PC BMS))
(SETQ FLOW? T)
else (if (NEQ STACK OLDSTACK)
then (SETQ STKAMB? T)
(if FLOWEDIN?
then (PC.SETSTACK PC STACK)
(SETQ FLOW? T)
else (SETQ STACK OLDSTACK)))
(if (AND HASBMS? (NOT (EQUAL BMS OLDBMS)))
then (SETQ BMSAMB? T)
(if FLOWEDIN?
then (PC.SETBMS PC BMS)
(SETQ FLOW? T)
else (SETQ BMS OLDBMS]
(if (AND STKAMB? (NOT OLDSTKAMB?))
then (PC.NOTESTACKAMBIG PC)
(SETQ FLOW? T))
(if (AND BMSAMB? (NOT OLDBMSAMB?))
then (PC.NOTEBMSAMBIG PC)
(SETQ FLOW? T))
(if (NOT FLOW?)
then (RETURN)) (* done if no new
information)
(if OLDSTKAMB?
then (SETQ STKAMB? T))
(if OLDBMSAMB?
then (SETQ BMSAMB? T))
(* * apply LEVADJ of this opcode)
(SETQ OPBYTE (PC.OPBYTE)) (* look at instr)
(SETQ OPCODE (PC.FINDOP OPBYTE))
(SETQ OPNARGS (fetch (OPCODE OPNARGS) of OPCODE))
(PC.S.LEVADJ) (* apply LEVADJ)
(if (IGREATERP PC MAXPC)
then (SETQ MAXPC PC)) (* update max's)
(if (IGREATERP STACK MAXSTACK)
then (SETQ MAXSTACK STACK))
(if (NOT FLOW?)
then (RETURN)) (* done if a
non-flowing instr, e.g.
-X- or JUMP)
(* * next instr)
(add PC OPNARGS 1)
(GO NEXTPC])
(PC.S.LEVADJ
[LAMBDA NIL (* jmh " 4-Jun-86 13:36")
(* * apply LEVADJ for this instr)
(DECLARE (USEDFREE HASBMS?)
(USEDFREE PC STACK STKAMB? BMS BMSAMB? FLOW?)
(USEDFREE OPBYTE OPCODE OPNARGS))
(if (EQ OPCODE (QUOTE -X-))
then (SETQ FLOW? NIL)
else (LET [(LEVADJ (OR (fetch (OPCODE LEVADJ) of OPCODE)
(fetch (OPCODE OPCODENAME) of OPCODE]
(SELECTQ LEVADJ
(RETURN (SETQ FLOW? NIL))
(JUMP (PC.S.DOJUMP)
(SETQ FLOW? NIL))
(CJUMP (PC.S.ADD -1)
(PC.S.DOJUMP))
(NCJUMP (PC.S.DOJUMP)
(PC.S.ADD -1))
[FNX (PC.S.ADD (ADD1 (IMINUS (PC.OPBYTE 1]
[SUBRCALL (PC.S.ADD (ADD1 (IMINUS (PC.OPBYTE 2]
(BIND (if (NOT HASBMS?)
then (ERROR "D opcode on non-D-machine"
(fetch (OPCODE OPCODENAME) of OPCODE)))
[PC.S.ADD (ADD1 (IMINUS (LOGAND 15 (PC.OPBYTE 1]
(push BMS STACK))
(UNBIND (if (NOT HASBMS?)
then (ERROR "D opcode on non-D-machine"
(fetch (OPCODE OPCODENAME) of OPCODE)))
(PC.S.ADD -1)
(if (NULL BMS)
then (SETQ BMSAMB? T)
(SETQ STACK 0)
else (SETQ STACK (pop BMS)))
(if BMSAMB?
then (SETQ STKAMB? T))
(PC.S.ADD -1)
(PC.S.ADD 1))
(DUNBIND (if (NOT HASBMS?)
then (ERROR "D opcode on non-D-machine"
(fetch (OPCODE OPCODENAME) of OPCODE)))
(if (NULL BMS)
then (SETQ BMSAMB? T)
(SETQ STACK 0)
else (SETQ STACK (pop BMS)))
(if BMSAMB?
then (SETQ STKAMB? T))
(PC.S.ADD -1))
(TUNBIND (if HASBMS?
then (ERROR "Tam opcode on D-machine"
(fetch (OPCODE OPCODENAME) of OPCODE)))
(SETQ STACK (PC.OPBYTE 1))
(SETQ STKAMB? NIL)
(PC.S.ADD 0))
(PROGN (* else)
(if (NUMBERP LEVADJ)
then (PC.S.ADD LEVADJ)
elseif (LISTP LEVADJ)
then (SELECTQ (CAR LEVADJ)
(JUMP
(* RETURN)
(SETQ FLOW? NIL))
[POP.N (PC.S.ADD (IMINUS
(PC.OPBYTE 1]
(PROGN
(* else)
(if (NUMBERP (CAR LEVADJ))
then (PC.S.ADD
(CAR LEVADJ])
(PC.S.ADD
[LAMBDA (DELTA) (* jmh
"30-Mar-86 10:34")
(* * add DELTA to STACK)
(DECLARE (USEDFREE HASBMS?)
(USEDFREE STACK BMS BMSAMB?))
(add STACK DELTA)
(if (AND HASBMS? BMS (ILESSP STACK (CAR BMS)))
then (SETQ BMSAMB? T])
(PC.S.DOJUMP
[LAMBDA NIL (* jmh
"29-Mar-86 08:39")
(* * figure jump target from current instr --
count jump-to if if this is the first time we've modelled this instr --
model from target)
(DECLARE (USEDFREE OLDSTACK STACK STKAMB? BMS BMSAMB?))
(LET ((TARGETPC (PC.GETJUMPTARG)))
(if (NOT OLDSTACK)
then (PC.INCJUMPTO TARGETPC))
(PC.S.MODELSOME TARGETPC STACK STKAMB? BMS BMSAMB? NIL])
)
(DEFINEQ
(PC.PRINTCODE
[LAMBDA NIL (* jmh "22-May-86 15:18")
(* * print the code itself)
(DECLARE (USEDFREE OUTF PRINTSTACK? STARTPC MAXPC MAXSTACK HASBMS?))
(LET (PCFORMAT PCWIDTH DEPTHFORMAT DEPTHWIDTH BMSFORMAT BMSWIDTH JUMPTOFORMAT JUMPTOWIDTH)
(DECLARE (SPECVARS PCFORMAT PCWIDTH DEPTHFORMAT DEPTHWIDTH BMSFORMAT BMSWIDTH
JUMPTOFORMAT JUMPTOWIDTH))
(* * initialize the numeric-column format specvars for the printcode pass)
(SETQ PCFORMAT (LIST (QUOTE FIX)
(SETQ PCWIDTH (PC.NUMWIDTH (ADD1 MAXPC)
8))
8 T))
[if PRINTSTACK?
then [SETQ DEPTHFORMAT (LIST (QUOTE FIX)
(SETQ DEPTHWIDTH (PC.NUMWIDTH (PC.STACKMAX)
10]
[if HASBMS?
then (SETQ BMSFORMAT (LIST (QUOTE FIX)
(SETQ BMSWIDTH (PC.NUMWIDTH (PC.BMSMAX)
10]
(SETQ JUMPTOFORMAT (LIST (QUOTE FIX)
(SETQ JUMPTOWIDTH (PC.NUMWIDTH (PC.JUMPTOMAX)
10]
(* * flag beginning of code, perhaps display max stack)
(printout OUTF " -----")
(if (AND PRINTSTACK? MAXSTACK)
then (printout OUTF " maxStack= " .N DEPTHFORMAT MAXSTACK)
(if (AND TAM.MAXSTACK (IGREATERP MAXSTACK TAM.MAXSTACK))
then (printout OUTF " >" TAM.MAXSTACK)))
(printout OUTF T)
(* * loop on instrs)
(LET ((PC STARTPC)
OPBYTE OPCODE)
(DECLARE (SPECVARS OPBYTE OPCODE))
(repeatuntil (EQ (fetch (OPCODE OPCODENAME) of OPCODE)
(QUOTE -X-))
do (SETQ OPBYTE (PC.OPBYTE))
(SETQ OPCODE (PC.FINDOP OPBYTE))
(PC.P.INSTR PC)
(add PC 1 (fetch (OPCODE OPNARGS) of OPCODE])
(PC.P.INSTR
[LAMBDA (PC) (* jmh
"30-Mar-86 10:35")
(* * print the code line<s> for the instr at PC)
(DECLARE (USEDFREE NRBYTESLINE1 PRINTSTACK? INITSTACK TAM.MAXSTACK)
(USEDFREE OPBYTE OPCODE)
(USEDFREE PCFORMAT PCWIDTH DEPTHFORMAT DEPTHWIDTH BMSFORMAT BMSWIDTH JUMPTOFORMAT
JUMPTOWIDTH))
(LET ((OPNARGS (fetch (OPCODE OPNARGS) of OPCODE))
(OPCODENAME (fetch (OPCODE OPCODENAME) of OPCODE))
(COL 0))
(* * pc, as "777: ")
(printout OUTF .TAB0 COL .N PCFORMAT PC ": ")
(add COL PCWIDTH 2)
(* * first bytes of instr, each followed by a space, then one more space)
(for I from 0 to (MIN (SUB1 NRBYTESLINE1)
OPNARGS) do (printout OUTF .I3.8.T (PC.OPBYTE I)
,))
(printout OUTF ,)
(add COL (ADD1 (ITIMES 4 NRBYTESLINE1)))
(* * stack depth and number of binding marks, then extra space)
(if PRINTSTACK?
then (LET [(DEPTH (PC.STACK PC))
(STKAMB? (PC.STACKAMBIG? PC))
[BMS (AND BMSFORMAT (LENGTH (PC.BMS PC]
(BMSAMB? (AND BMSFORMAT (PC.BMSAMBIG? PC]
(if DEPTH
then (printout OUTF .TAB0 COL .N DEPTHFORMAT DEPTH))
(add COL DEPTHWIDTH)
(if (NEQ OPCODENAME (QUOTE -X-))
then (if (OR STKAMB? (NOT DEPTH)
(ILESSP DEPTH INITSTACK)
(AND TAM.MAXSTACK (IGREATERP DEPTH TAM.MAXSTACK)))
then (printout OUTF .TAB0 COL "?")
elseif (OR (AND BMS (NEQ 0 BMS))
BMSAMB?)
then (printout OUTF .TAB0 COL "|")))
(add COL 1)
(if BMSFORMAT
then (if (AND BMS (NOT (ZEROP BMS)))
then (printout OUTF .TAB0 COL .N BMSFORMAT BMS))
(add COL BMSWIDTH)
(if BMSAMB?
then (printout OUTF "?"))
(add COL 1))
(add COL 1)))
(* * number of jumps to here, then extra space)
(if PRINTSTACK?
then (LET ((NJT (PC.JUMPTO PC)))
(if (AND NJT (NOT (ZEROP NJT)))
then (printout OUTF .TAB0 COL .N JUMPTOFORMAT NJT))
(add COL JUMPTOWIDTH)
(if (AND NJT (NOT (ZEROP NJT)))
then (printout OUTF .TAB0 COL ">"))
(add COL 2)))
(* * opcodename; args if any)
(LET (TOARGCOL)
(DECLARE (SPECVARS TOARGCOL)) (* TOARGCOL is spacing
to arg col from after
opcodename)
(printout OUTF .TAB0 COL OPCODENAME)
[SETQ TOARGCOL (MAX 1 (IDIFFERENCE 8 (NCHARS OPCODENAME]
(PC.P.OPPRINT))
(* * excess arg bytes if any on an overflow line)
[if (IGEQ OPNARGS NRBYTESLINE1)
then (printout OUTF T .TAB0 4 "...")
(for I from NRBYTESLINE1 to OPNARGS do (printout OUTF , .I3.8.T (PC.OPBYTE I]
(* * end of line)
(printout OUTF T])
(PC.P.OPPRINT
[LAMBDA NIL (* jmh "28-May-86 11:58")
(DECLARE (USEDFREE OUTF TOARGCOL OPCODE OPBYTE OPNARGS PCFORMAT TAM.JUMPSTYLE))
(* TOARGCOL is spacing out to arg col)
(LET ((OPPRINT (fetch (OPCODE OPPRINT) of OPCODE)))
(if (MEMB OPPRINT (QUOTE (NIL T)))
then (SETQ OPPRINT (fetch (OPCODE OPCODENAME) of OPCODE)))
(SELECTQ OPPRINT
(SNIC (printout OUTF .SP TOARGCOL (IDIFFERENCE (PC.OPBYTE 1)
256)))
(SICX (printout OUTF .SP TOARGCOL (PC.OPBYTES 1 2)))
[GCONST (printout OUTF .SP TOARGCOL .P2 (1ST (\VAG2 (PC.OPBYTE 1)
(PC.OPBYTES 2 2]
[PCONST (if (NOT (ZEROP (PC.OPBYTE 4)))
then (HELP "can't handle PCONST w/ arg not backwards-compat ptr"))
(printout OUTF .SP TOARGCOL .P2 (1ST (\VAG2 (PC.OPBYTE 3)
(PC.OPBYTES 1 2]
(ICONST (LET ((N (PC.OPBYTES 1 4)))
(if (IGREATERP N MAX.FIXP)
then (* sign-extend if necessary)
(SETQ N (LOGOR N MIN.FIXP)))
(printout OUTF .SP TOARGCOL N)))
[TYPEP (LET* [(TYPENR (PC.OPBYTE 1))
(TYPENAME (COND
((EQ TYPENR \ARRAYP)
(QUOTE ARRAYP))
((EQ TYPENR \STRINGP)
(QUOTE STRINGP))
((EQ TYPENR \FLOATP)
(QUOTE FLOATP))
((EQ TYPENR \SMALLP)
(QUOTE SMALLP))
((EQ TYPENR \STACKP)
(QUOTE STACKP))
((EQ TYPENR \FIXP)
(QUOTE FIXP))
((EQ TYPENR \LITATOM)
(QUOTE LITATOM))
(T TYPENR]
(printout OUTF .SP 1 (CONCAT "[" TYPENAME "]"]
[(ATOM FN)
(printout OUTF .SP TOARGCOL (\INDEXATOMPNAME (PC.OPBYTES 1 OPNARGS]
[FNX (printout OUTF .SP 1 "[" (PC.OPBYTE 1)
"]" , (\INDEXATOMPNAME (PC.OPBYTES 2 2]
(IVAR (printout OUTF .SP TOARGCOL (PC.VARNAME (PC.GETVARSLOT)
T)))
[PVAR (printout OUTF .SP TOARGCOL (PC.VARNAME (PC.GETVARSLOT]
[FVAR (printout OUTF .SP TOARGCOL (PC.VARNAME (PC.GETVARSLOT]
((JUMP JUMPX JUMPXX NEGJUMP)
(printout OUTF .SP 1 (if (EQ (fetch (OPCODE LEVADJ) of OPCODE)
(QUOTE JUMP))
then "===>"
else "--->")
, .N PCFORMAT (PC.GETJUMPTARG)))
(RETURN (printout OUTF .SP 1 "******"))
[(GETBITS.N.FD PUTBITS.N.FD)
(LET ((B2 (PC.OPBYTE 2)))
(printout OUTF .SP TOARGCOL (PC.OPBYTE 1)
,
(LRSH B2 4)
,
(ADD1 (LOGAND 15 B2]
[BIND (LET* ((B1 (PC.OPBYTE 1))
(NBV (LOGAND B1 15))
(NBN (LRSH B1 4))
(SLOTNR (PC.OPBYTE 2))
(1ST T))
(add SLOTNR 1 (MINUS NBN)
(MINUS NBV))
(for I from 1 to NBV
do (printout OUTF .SP (if 1ST
then TOARGCOL
else 1)
(PC.VARNAME SLOTNR))
(add SLOTNR 1)
(SETQ 1ST NIL))
(printout OUTF .SP (if 1ST
then TOARGCOL
else 1)
";")
(for I from 1 to NBN
do (printout OUTF .SP 1 (PC.VARNAME SLOTNR))
(add SLOTNR 1]
(if (LISTP OPPRINT)
then (LET* ((SUBOPNR (PC.OPBYTE 1))
(SUBOPNAME (if (CAR (NTH OPPRINT (ADD1 SUBOPNR)))
else SUBOPNR)))
(printout OUTF .SP 1 (CONCAT "[" SUBOPNAME "]")))
else (LET ((OPNR (fetch (OPCODE OP#) of OPCODE))
NOT1ST)
(if (OR (IGREATERP OPNARGS 0)
(LISTP OPNR))
then (printout OUTF .SP TOARGCOL)
(SETQ NOT1ST T))
(if (LISTP OPNR)
then (printout OUTF (PC.GETOPKARG)))
(for I from 1 to OPNARGS
do (if NOT1ST
then (printout OUTF ,))
(printout OUTF (PC.OPBYTE I))
(SETQ NOT1ST T])
)
(* * utility)
(DEFINEQ
(PC.NUMWIDTH
[LAMBDA (NUM BASE) (* jmh
" 1-Mar-86 12:15")
(* * returns how many spaces it would take to print that number in that
base)
(LET ((WIDTH 0))
(if (LESSP NUM 0)
then (SETQ NUM (MINUS NUM))
(add WIDTH 1))
(repeatuntil (LESSP NUM 1) do (SETQ NUM (QUOTIENT NUM BASE))
(add WIDTH 1))
WIDTH])
)
(DEFINEQ
(PC.GETBYTE
[LAMBDA (PC) (* jmh
" 7-Mar-86 16:14")
(* * get byte of code thingy)
(DECLARE (USEDFREE TAM.OUTPUTSTYLE CODEARRAY))
(SELECTQ TAM.OUTPUTSTYLE
(D (CODELT CODEARRAY PC))
(B (ELT CODEARRAY PC))
(ERROR "unimpl code-thingy style" TAM.OPSTYLE])
(PC.GETBYTES
[LAMBDA (PC NBYTES) (* jmh
" 7-Mar-86 13:38")
(* * return concatenation of NBYTES bytes of object code thingy)
(LET ((V 0))
[for BYTENR from PC as I from 1 to NBYTES
do (SETQ V (IPLUS (LLSH V 8)
(PC.GETBYTE BYTENR]
V])
(PC.FINDOP
[LAMBDA (OP) (* jmh
"28-Mar-86 13:22")
(* * get OPCODE record for OP)
(DECLARE (USEDFREE TAM.OPCODEARRAY))
(OR (ELT TAM.OPCODEARRAY OP)
(ERROR "no OPCODE rec for" OP])
)
(DEFINEQ
(PC.OPBYTE
[LAMBDA (OFFSET) (* jmh
" 5-Mar-86 17:44")
(* * return OFFSET'th byte of current instr)
(DECLARE (USEDFREE PC))
(PC.GETBYTE (IPLUS PC (OR OFFSET 0])
(PC.OPBYTES
[LAMBDA (STARTBYTE NBYTES) (* jmh
" 5-Mar-86 15:22")
(* * return concatenation of NBYTES bytes of current instr, starting
with instr-relative byte STARTBYTE and respecting alpha-byte order of
machine)
(DECLARE (USEDFREE TAM.ALPHASTYLE))
(LET ((V 0))
[SELECTQ TAM.ALPHASTYLE
(D (* most sig byte
frist)
[for BYTENR from STARTBYTE as I from 1 to NBYTES
do (SETQ V (IPLUS (LLSH V 8)
(PC.OPBYTE BYTENR])
(PROGN (* least sig byte 1st)
(for BYTENR from (IPLUS STARTBYTE NBYTES -1) by -1 as I
from 1 to NBYTES do (SETQ V (IPLUS (LLSH V 8)
(PC.OPBYTE BYTENR]
V])
)
(DEFINEQ
(PC.GETOPKARG
[LAMBDA NIL (* jmh "16-May-86 14:45")
(* * return implicit argument of a range-OP# opcode)
(DECLARE (USEDFREE TAM.OPKSTYLE OPBYTE OPCODE))
(LET ((OPNR (fetch (OPCODE OP#) of OPCODE)))
(if [OR (NLISTP OPNR)
(AND (LESSP OPBYTE (CAR OPNR))
(GREATERP OPBYTE (CADR OPNR)))
(NEQ (LOGAND 240 (CAR OPNR))
(LOGAND 240 (CADR OPNR]
then (SHOULDNT "funny opcode # range here"))
(SELECTQ TAM.OPKSTYLE
(D (IDIFFERENCE OPBYTE (CAR OPNR)))
(LOGAND 15 OPBYTE])
(PC.GETVARSLOT
[LAMBDA NIL (* jmh "16-May-86 14:46")
(* * return slot-nr arg of current instr, respecting OPNARGS and machine's VARXSTYLE)
(DECLARE (USEDFREE OPCODE OPNARGS TAM.VARXSTYLE))
(LET ((OPNR (fetch (OPCODE OP#) of OPCODE)))
(SELECTQ OPNARGS
(0 (* in 1-byte instr, slot# is offset of op in its OPNR
range)
(PC.GETOPKARG))
(SELECTQ TAM.VARXSTYLE
(D (* in 2-byte instr on D-machine, alpha byte is twice
slot#)
(LRSH (PC.OPBYTE 1)
1))
(PROGN (* in 2-byte instr on Tamarin, alpha byte is slot#)
(PC.OPBYTE 1])
(PC.GETJUMPTARG
[LAMBDA NIL
(DECLARE (USEDFREE TAM.JUMPSTYLE)) (* jmh "23-May-86 12:17")
(SELECTQ TAM.JUMPSTYLE
(D (PC.GETJUMPTARG.D))
(PC.GETJUMPTARG.T])
(PC.GETJUMPTARG.D
[LAMBDA NIL (* jmh "23-May-86 11:36")
(* * return target of current jump instr, per OPNARGS)
(DECLARE (USEDFREE PC OPCODE OPNARGS TAM.JUMPSTYLE))
(if (NEQ TAM.JUMPSTYLE (QUOTE D))
then (ASM.HELP "bad jumpstyle" TAM.JUMPSTYLE))
(IPLUS PC (if (EQ (fetch (OPCODE OPCODENAME) of OPCODE)
(QUOTE NOP))
then 1
else (SELECTQ OPNARGS
(0 (IPLUS (PC.GETOPKARG)
2))
[1 (LET ((N (PC.OPBYTE 1)))
(if (ILEQ N 127)
then N
else (IDIFFERENCE N 256]
(LET ((N (PC.OPBYTES 1 2)))
(if (ILEQ N 32767)
then N
else (IDIFFERENCE N 65536])
(PC.GETJUMPTARG.T
[LAMBDA NIL (* jmh "28-May-86 12:00")
(* * return target of current jump instr, per OPNARGS)
(DECLARE (USEDFREE PC OPCODE OPNARGS TAM.JUMPSTYLE))
(if TAM.JUMPSTYLE
then (ASM.HELP "bad jumpstyle" TAM.JUMPSTYLE))
(LET ((OFFSET (SELECTQ OPNARGS
(0 (PC.GETOPKARG))
(1 (PC.OPBYTE 1))
(PC.OPBYTES 1 2)))
(OPPRINT (fetch (OPCODE OPPRINT) of OPCODE)))
(IPLUS PC (ADD1 OPNARGS)
(SELECTQ OPPRINT
(NEGJUMP (MINUS OFFSET))
(PROGN OFFSET])
)
(DEFINEQ
(PC.VARNAME
[LAMBDA (SLOTNR IVARS?) (* jmh
" 7-Mar-86 13:38")
(* * returns var name if any else pseudoname --
if IVARS? then only considers ivars; else only considers non-ivars --
if LAMBDA* ivar on D-machine, return pseudoname "[arg 9]" <1-based arg #>)
(DECLARE (USEDFREE TAM.NTSTYLE TAM.VARXSTYLE FNTYPE)
(USEDFREE NTBASEB NTSIZEW LTBASEB LTSIZEW))
(if (AND (EQ TAM.VARXSTYLE (QUOTE D))
(EQ FNTYPE (QUOTE LAMBDA*))
IVARS?)
then (CONCAT "[arg" (ADD1 SLOTNR)
"]")
else (SELECTQ TAM.NTSTYLE
(D (OR (PC.VARNAME.1NT.D NTBASEB NTSIZEW SLOTNR IVARS?)
(PC.VARNAME.1NT.D LTBASEB LTSIZEW SLOTNR IVARS?)
(CONCAT "[" (if IVARS?
then "i"
else "p")
"var" SLOTNR "]")))
(ERROR "unimpl name table style" TAM.NTSTYLE])
(PC.VARNAME.1NT.D
[LAMBDA (TBASEB TSIZEW SLOTNR IVARS?) (* jmh
"13-Mar-86 16:13")
(* * if the var with slot# SLOTNR and of type <if IVARS? then ivar else
not ivar> is defined in the name table which starts at byte-offset TBASEB
and has length TSIZEW words -- then return the var's name, else return NIL)
(LET ((TSIZEB (UNFOLD TSIZEW BYTESPERWORD)))
(for I from 1 to TSIZEW as P1 from TBASEB by BYTESPERWORD
bind ATOMIX until [OR (ZEROP (SETQ ATOMIX (PC.GETBYTES P1 2)))
(AND (EQ SLOTNR (PC.GETBYTE (IPLUS P1 TSIZEB 1)))
(if (EQ (LRSH IVARCODE 10Q)
(PC.GETBYTE (IPLUS P1 TSIZEB)))
then IVARS?
else (NOT IVARS?]
finally (RETURN (if (OR (NULL ATOMIX)
(ZEROP ATOMIX))
then NIL
else (\INDEXATOMPNAME ATOMIX])
)
(* * access memory built during stack-modelling passes -- dummies for now)
(DEFINEQ
(PC.STACK
[LAMBDA (PC) (* jmh
"28-Mar-86 16:15")
(* * return saved stack depth for PC)
(DECLARE (GLOBALVARS \PC.STACK))
(ELT \PC.STACK PC])
(PC.SETSTACK
[LAMBDA (PC NEWVAL) (* jmh
"28-Mar-86 16:15")
(* * set saved stack depth for PC)
(DECLARE (GLOBALVARS \PC.STACK))
(if (NUMBERP NEWVAL)
then (SETA \PC.STACK PC NEWVAL)
else (ERROR "bad stack depth" NEWVAL])
(PC.STACKMAX
[LAMBDA NIL (* jmh
"29-Mar-86 10:38")
(* * return max value in stack-depth array)
(DECLARE (GLOBALVARS \PC.STACK)
(USEDFREE MAXPC))
(LET ((MAXVAL 0))
(for I from 0 to MAXPC bind VAL do (if (AND (SETQ VAL (ELT \PC.STACK I))
(IGREATERP VAL MAXVAL))
then (SETQ MAXVAL VAL)))
MAXVAL])
(PC.STACKAMBIG?
[LAMBDA (PC) (* jmh
"28-Mar-86 16:16")
(* * return: is stack known to be ambiguous at PC?)
(DECLARE (GLOBALVARS \PC.FLAGS))
(BITTEST (ELT \PC.FLAGS PC)
1])
(PC.NOTESTACKAMBIG
[LAMBDA (PC) (* jmh
"28-Mar-86 16:16")
(* * note that stack is known to be ambig at PC)
(DECLARE (GLOBALVARS \PC.FLAGS))
(SETA \PC.FLAGS PC (LOGOR 1 (ELT \PC.FLAGS PC])
)
(DEFINEQ
(PC.BMS
[LAMBDA (PC) (* jmh
"28-Mar-86 16:17")
(* * return saved binding-marker list for PC)
(DECLARE (GLOBALVARS \PC.BMS))
(ELT \PC.BMS PC])
(PC.SETBMS
[LAMBDA (PC NEWVAL) (* jmh
"28-Mar-86 16:17")
(* * set saved binding-marker list for PC)
(DECLARE (GLOBALVARS \PC.BMS))
(if [AND (OR (NULL NEWVAL)
(LISTP NEWVAL))
(NOT (for X in NEWVAL thereis (NOT (NUMBERP X]
then (SETA \PC.BMS PC NEWVAL)
else (ERROR "bad binding-marker list" NEWVAL])
(PC.BMSMAX
[LAMBDA NIL (* jmh
"28-Mar-86 14:09")
(* * return max length-of-value in binding-marks array)
(DECLARE (GLOBALVARS \PC.BMS)
(USEDFREE MAXPC))
(LET ((MAXVAL 0))
(for I from 0 to MAXPC bind VAL do (if (IGREATERP (SETQ VAL (LENGTH (ELT \PC.BMS I)))
MAXVAL)
then (SETQ MAXVAL VAL)))
MAXVAL])
(PC.BMSAMBIG?
[LAMBDA (PC) (* jmh
"28-Mar-86 16:17")
(* * return: is binding-marker list known to be ambiguous at PC?)
(DECLARE (GLOBALVARS \PC.FLAGS))
(BITTEST (ELT \PC.FLAGS PC)
2])
(PC.NOTEBMSAMBIG
[LAMBDA (PC) (* jmh
"28-Mar-86 16:18")
(* * note that binding-marker list is known to be ambig at PC)
(DECLARE (GLOBALVARS \PC.FLAGS))
(SETA \PC.FLAGS PC (LOGOR 2 (ELT \PC.FLAGS PC])
)
(DEFINEQ
(PC.JUMPTO
[LAMBDA (PC) (* jmh
"28-Mar-86 16:18")
(* * return saved number of jumps-to for PC)
(DECLARE (GLOBALVARS \PC.JUMPTO))
(ELT \PC.JUMPTO PC])
(PC.INCJUMPTO
[LAMBDA (PC) (* jmh
"28-Mar-86 16:18")
(* * increment saved number of jumps-to for PC)
(DECLARE (GLOBALVARS \PC.JUMPTO))
(add (ELT \PC.JUMPTO PC)
1])
(PC.JUMPTOMAX
[LAMBDA NIL (* jmh
"28-Mar-86 14:06")
(* * return max value in jump-to array)
(DECLARE (GLOBALVARS \PC.JUMPTO)
(USEDFREE MAXPC))
(LET ((MAXVAL 0))
(for I from 0 to MAXPC bind VAL do (if (IGREATERP (SETQ VAL (ELT \PC.JUMPTO I))
MAXVAL)
then (SETQ MAXVAL VAL)))
MAXVAL])
)
(PUTPROPS PC COPYRIGHT ("Xerox Corporation" 3702Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2740Q 11135Q (PC.1 2752Q . 11133Q)) (11136Q 17215Q (PC.DOHDR 11150Q . 14127Q) (PC.DO1NT
14131Q . 17213Q)) (17216Q 25000Q (PC.DOFNHDR.D 17230Q . 23776Q) (PC.DOFNHDR.D.PRINT2W 24000Q . 24776Q
)) (25001Q 33654Q (PC.DOFNHDR.T 25013Q . 32773Q) (PC.DOFNHDR.T.PRINT1C 32775Q . 33652Q)) (33655Q
60604Q (PC.STUDYCODE 33667Q . 41203Q) (PC.S.MODELSOME 41205Q . 50774Q) (PC.S.LEVADJ 50776Q . 56464Q) (
PC.S.ADD 56466Q . 57364Q) (PC.S.DOJUMP 57366Q . 60602Q)) (60605Q 105210Q (PC.PRINTCODE 60617Q . 64464Q
) (PC.P.INSTR 64466Q . 74671Q) (PC.P.OPPRINT 74673Q . 105206Q)) (105235Q 106412Q (PC.NUMWIDTH 105247Q
. 106410Q)) (106413Q 111116Q (PC.GETBYTE 106425Q . 107342Q) (PC.GETBYTES 107344Q . 110320Q) (
PC.FINDOP 110322Q . 111114Q)) (111117Q 114234Q (PC.OPBYTE 111131Q . 111664Q) (PC.OPBYTES 111666Q .
114232Q)) (114235Q 122546Q (PC.GETOPKARG 114247Q . 115536Q) (PC.GETVARSLOT 115540Q . 117250Q) (
PC.GETJUMPTARG 117252Q . 117614Q) (PC.GETJUMPTARG.D 117616Q . 121327Q) (PC.GETJUMPTARG.T 121331Q .
122544Q)) (122547Q 127605Q (PC.VARNAME 122561Q . 125072Q) (PC.VARNAME.1NT.D 125074Q . 127603Q)) (
127727Q 134144Q (PC.STACK 127741Q . 130460Q) (PC.SETSTACK 130462Q . 131343Q) (PC.STACKMAX 131345Q .
132545Q) (PC.STACKAMBIG? 132547Q . 133341Q) (PC.NOTESTACKAMBIG 133343Q . 134142Q)) (134145Q 140614Q (
PC.BMS 134157Q . 134700Q) (PC.SETBMS 134702Q . 135754Q) (PC.BMSMAX 135756Q . 137165Q) (PC.BMSAMBIG?
137167Q . 137775Q) (PC.NOTEBMSAMBIG 137777Q . 140612Q)) (140615Q 143341Q (PC.JUMPTO 140627Q . 141360Q)
(PC.INCJUMPTO 141362Q . 142146Q) (PC.JUMPTOMAX 142150Q . 143337Q)))))
STOP