// RaidStack.bcpl. Raid printing routines for Lisp stack
// last edited September 19, 1981 3:05 PM by Bill van Melle
// From RaidPrint.bcpl August 26, 1981 by Bill van Melle

get "Raid.decl"

external [// procedures defined
LispStack; LispFrame; ShowStackBlocks
PrintFxtn; PrintBF; PrintAddrs; PrintBytes

// statics defined
lastFrame; linkUsed; raidStackFX

// statics used
dsp; keys; @lvNIL; @lvVPtr; @VPtr0; @VPtr1

// procedures used
PrintPtr; PrintName; Lprint; RaidReset; CRLF; ReadNum; ReadChar
GetStkBlkType; GetFXP

Negate; Divide; Usc; Min;
Wc; Ws; Wo; Wn; Wb;
EqNIL; VP; Gets; UCase
@BGetBasePtr; @XGetBasePtr; @XGetBase32; IGetBase
@SGetBase; @XSetBR; @RRead; @BGetBase; @XGetBase; @XGetBase1
GetLmarg; SetLmarg; GetBitPos
]

static [
raidStackFX = 0
lastFrame = 0
linkUsed = 0
]

manifest [ usedClink = 1
usedAlink = 2
]

let LispStack(FX; numargs na) be
[
if na ls 1 % FX eq 0
then FX = GetFXP()
let p = CheckFXP(FX)
raidStackFX = FX// now working on this stack
let r = p// do the two link chains differ?
[ if (GetAlink(r) ne GetClink(r))
then [ r = UseCLink(); break ]
r = GetAlink(r)
] repeatwhile r
CRLF()
let n = 0
[ n = n + 1
Wn(n, 10); Ws(": ")
PrintFXName(p)
p = r ? GetClink(p), GetAlink(p)
] repeatwhile p
]

and UseCLink() = valof
[
[ Ws(" following ")
switchon ReadChar() into
[ case $A: case $a:
Ws("ccess links")
linkUsed = usedAlink
resultis false; endcase
case $C: case $c:
Ws("ontrol links")
linkUsed = usedClink
resultis true; endcase
default: Ws("XXX - either Access or Control ") ]
] repeat
]

and CheckFXP(nfx, cl, ofx; numargs n) = valof
[ unless (nfx eq 0) % (GetStkBlkType(nfx) eq FxtnBlock) do
[ Wo(nfx, true); Ws(" invalid frame extension")
if n gr 1 then
[ Ws(" at "); Ws(cl ? "C", "A"); Ws("Link of "); Wo(ofx, true) ]
RaidReset("") ]
resultis nfx
]

and GetAlink(fx) = CheckFXP((SGetBase(fx + FXalink) & (not FXXMask)) - FXPvar,
false, fx)

and GetBlink(fx) = GetSlow(fx) ? SGetBase(fx + FXblink), fx-2

and GetClink(fx) = CheckFXP(SGetBase(fx + (GetSlow(fx) ? FXclink, FXalink)) - FXPvar,
false, fx)

and GetNameT(fx, lvNT) = valof
[ // store address of name table of fx into lvNT
let v = (SGetBase(fx + flagword) & FXVMask) ne 0// Name table valid?
lvNT>>VA.vahi = SGetBase(fx + (v ? FXNThi, FXFHhi))<<LoByte
lvNT>>VA.valo = SGetBase(fx + (v ? FXNTlo, FXFHlo))
resultis lvNT
]

and GetNVars (fx, lvnp, lvnf) be// number of pvars, fvars
[// use fn header, not name table, because nt does not guarantee PV field
let fnhd = vec 1
fnhd>>VA.vahi = SGetBase(fx + FXFHhi)<<LoByte
fnhd>>VA.valo = SGetBase(fx + FXFHlo)
@lvnp = BGetBase(fnhd!0, fnhd!1 + NTnPV)<<HiByte
@lvnf = (BGetBase(fnhd!0, fnhd!1 + NTPV)+1)*2 - @lvnp
]


and GetSlow(fx) = (SGetBase(fx + FXalink) & FXXMask) ne 0

and LispFrame(num, linkType; numargs na) be
// Displays both basic frame and extension.
[
let P = CheckFXP(raidStackFX)
test na ls 1
ifso num = ReadNum(10)// get frame number
ifnot [ if num le 0
then [ Ws (" at top of stack")
lastFrame = 0
return ]
Ws(" ("); Wn(num, 10); Ws(") ") ]
let useCL = false// Default until we have to choose
let LinkChosen = false// Which hasn’t happened yet
lastFrame = num// save for LF, ↑ commands
while num gr 1 do
[ let r = useCL ? GetClink(P), GetAlink(P)
unless LinkChosen
do [ let x = GetClink(P)
if x ne r
then [ test (na gr 1) & linkType
ifso [ Ws (" following ")
useCL = linkType eq usedClink
Wc (useCL ? $C , $A)
Ws ("links")
]
ifnot useCL = UseCLink()
if useCL then r = x
LinkChosen = true
]
]
unless r
do [ test na ge 2
ifso [ Ws (" at bottom of stack")
lastFrame = lastFrame-1 ]
ifnot Ws(" Invalid frame number")
return ]
num = num - 1
P = r
]
PrintBF(GetBlink(P), P)
PrintFxtn(P)
]

and PrintBF(BF, fx; numargs na) be
[
let residual = (SGetBase(BF+flagword) & BFRmask)
let ivar = residual ne 0 ? BF, SGetBase(BF+BFIvar)
// ivar -> start of BF
if GetStkBlkType(BF) ne BFBlock % (Usc(ivar, BF) gr 0)
then [ CRLF(); Wo(BF, true);
Ws(" is not a basic frame"); return]
test residual
ifso Ws ("*NResidual ")
ifnot Ws ("*N")
Ws("Basic Frame at "); Wo(BF, true); CRLF()
if BF ne ivar
then [
let padded = SGetBase(BF + flagword) & BFPmask
let nvars = ((BF-ivar)-(padded ? 2, 0)) rshift 1
test na gr 1
ifso [// names are available
let NT = vec 1
GetNameT (fx, NT)
PrintVars (ivar, 0, nvars, NT, ivarCode, false)
]
ifnot PrintVals(ivar, nvars)
if padded
then [// one 2word pad
PrintStk(BF-2)
CRLF()
]
]
PrintStk(BF)// the BF word itself
]

and PrintFxtn(P) be
[
CheckFXP(P)
let NT = vec 1
GetNameT (P, NT)// get name table into NT
Ws("*NFrame Extension at "); Wo(P, true);
Ws(" Frame Name is: "); PrintFXName(P)
// print Fx header
PrintStk(P); Ws (" ["); PrintFXFlags (P); Ws (", alink]"); CRLF()
PrintStk(P+2); Ws (" [fn header]"); CRLF()
PrintStk(P+4); Ws (" [next, PC]"); CRLF()
PrintStk(P+6); Ws (" [name table]"); CRLF()
PrintStk(P+8); Ws (" [blink, clink]"); CRLF()

let npv, nfv = nil, nil
GetNVars (P, lv npv, lv nfv)// find out how many of each
// print PVars
let pvStart = P+FXPvar
PrintVars(pvStart, 0, npv, NT, pvarCode, false)

let start = pvStart + npv lshift 1
// print FVars
PrintFVars(start, nfv, npv, NT)

start = start + nfv lshift 1 + 6
PrintStk(start-6); CRLF()// 3 junk cells (should be 2?)
PrintStk(start-4); CRLF()
PrintStk(start-2); CRLF()

let nextblk = SGetBase(P + FXnxt)
// print temporary values
if (NT!0 eq STACKspace) & (NT!1 gr P) & (NT!1 ls nextblk)
then [// name table is on stack, so we must be sure to skip over it
nfv = (NT!1 - start) rshift 1
if nfv gr 0
then PrintVars (start, (start-pvStart) rshift 1, nfv, NT, pvarCode, true)
// print stuff before nt. Use PrintVars because there may be funny PVars in here
start = NT!1
let ntlen = SGetBase (NT!1+offNtSize) + (ntOvheadWords rshift 1)
// number of double words in nt
for i = 1 to ntlen// print nt simply
do [ PrintStk(start); CRLF()
start = start+2 ]
]
test nextblk ls start
ifso [ Ws ("Next blk too soon??"); CRLF() ]
ifnot PrintVals(start, (nextblk-start) rshift 1)
]

and PrintFXName(s) be
[ let ntp = vec 1
GetNameT(s, ntp)
ntp>>VA.valo = ntp>>VA.valo + NTfname
Lprint(XGetBasePtr(ntp))
]

and PrintFXFlags(FX) be// interpret the FX flags
[ let flags = SGetBase(FX+flagword)
if (flags & FXFMask) ne 0
then Wc ($F)
if (flags & FXLMask) ne 0
then Wc ($L)
if (flags & FXCMask) ne 0
then Wc ($C)
if (flags & FXVMask) ne 0
then Wc ($V)
if (flags & FXNMask) ne 0
then Wc ($N)
let X = SGetBase(FX+FXalink) & FXXMask
test X
ifso Wc ($X)
ifnot if (flags & (FXFMask % FXLMask % FXCMask % FXVMask % FXNMask)) eq 0
then Wc ($-)
]

and PrintStk(i) be// print the two stack words at i,i+1
[ Ws(" "); Wo(i); Ws(": ")
Wo(SGetBase(i)); Wc($*S); Wo(SGetBase(i+1))
]

and PrintVals(p, n) be// print n val ptrs starting at p
for i = 1 to n
do [ PrintStk(p)
test SGetBase(p)<<HiByte eq 0
ifso [ Wc($*S)
Lprint(BGetBasePtr(STACKspace, p))]
ifnot CRLF()
p = p + 2 ]

and PrintVars(s, off0, nvars, lvNT, varcode, namesOptional) be
// prints PVars and IVars, together with their names
// off0 is offset of s in nt sense, nvars how many to print
for j = off0 to off0+nvars-1 do
[ PrintStk(s); Wc($*S)
let name = FindName(lvNT, varcode+j)
test name ne 0
ifso [ PrintName (name); Wc($*s) ]
ifnot unless namesOptional do Ws ("**local** ")
test SGetBase(s)<<HiByte eq 0// is var bound?
ifso Lprint(BGetBasePtr(STACKspace, s))
ifnot [ unless namesOptional do Ws("unbound")
CRLF() ]
s = s+2
]

and PrintFVars(s, nf, nlocals, lvNT) be
// prints FVars, together with their names
for j = 1 to nf do
[ PrintStk(s); Wc($*S)
let name = FindName(lvNT, fvarCode+j-1+nlocals)
test name ne 0
ifso PrintName (name)
ifnot test (j eq nf) & ((SGetBase(s) & fvarmask) ne 0)
ifso [// not really a fvar, just the final padding of the pvar region
CRLF(); return
]
ifnot Ws ("??")
Wc($*s)
test (SGetBase(s) & fvarmask) ne 0// is var looked up?
ifso Ws("not looked up")
ifnot test SGetBase(s+1)<<LoByte eq STACKspace
ifso Ws ("stack binding")
ifnot Ws ("top value")
CRLF()
s = s+2
]

and FindName (lvNT, entry) = valof
// looks for a name table entry, and if found returns the atom number of the var so named
[
let nthi = lvNT!0
let ntlo = lvNT!1
let NT1 = ntlo + ntOvheadWords// where first part starts
let NT2 = NT1 + BGetBase (nthi, ntlo+offNtSize)
[let atom = BGetBase (nthi, NT1)
if atom eq 0
then resultis 0// table terminates on a zero
if BGetBase (nthi, NT2) eq entry
then resultis atom
NT1 = NT1 + 1
NT2 = NT2 + 1
] repeat
]

and ShowStackBlocks(px, wait) be
[
let easp = IGetBase(IFPEndOfStack)
[ switchon GetStkBlkType(px) into
[ case FreeStackBlock:
ShowStackEntry("Free Block ", px); CRLF()
px=px+SGetBase(px+FreeBlkLen)
endcase
case GuardBlock:
ShowStackEntry("Guard Block", px); CRLF()
px=px+SGetBase(px+GrdBlkLen)
endcase
case FxtnBlock:
ShowStackEntry("Frame Xtnsn", px); Ws(" = ")
PrintFXName(px)// does its own crlf
px=SGetBase(px+FXnxt)
endcase
default: let start = px// save start for consistency check
until SGetBase(px) ls 0 do px=px+2// skip to end
unless GetStkBlkType(px) eq BFBlock do
[ ShowStackEntry("Garbage ", start); Wc($*N); break ]
let r = (SGetBase(px+flagword)&BFRmask)
test r
ifso [ ShowStackEntry("Residual BF", px)
Ws(" with IVar at ")
Wo(SGetBase(px+BFIvar), true)
]
ifnot [ ShowStackEntry("Basic Frame", px)
unless start eq SGetBase(px+BFIvar)
do Ws(" preceded by garbage")
]
CRLF()
px=px+2// skip over BF double word
]
] repeatuntil (px eq easp) % (wait & (Gets(keys) eq DEL))
]

and ShowStackEntry(s, p) be [ Ws(s); Ws(" at "); Wo(p) ]

and PrintAddrs(hi, lo, N; numargs na) be
[
if na ne 3
then [ lo = ReadNum(8); Ws(" showing "); N = ReadNum(8) ]
let end = lo+N-1
Wn(N, 8); Ws("Q words from "); PrintPtr(hi, lo)
Ws(" to "); PrintPtr(hi, end); CRLF()
for i = 1 to 8 do Wc($*S)// print labeling line
for i = 0 to 7 do [ Wc($*S); Wo(i) ]
for i = (lo & #177770) to end
do [ if (i&7) eq 0
do [ CRLF(); Wo(i); Ws(": ") ]
Wc($*S)
test i ls lo
ifso Ws (" ")// don’t print data yet
ifnot Wo(BGetBase(hi, i))
]
CRLF()
]

and PrintBytes() be
[
let hi = ReadNum(8); let lo = ReadNum(8)
Ws(" showing "); let N = ReadNum(8)
Wn(N, 8); Ws("Q words, as bytes, starting at ")
PrintPtr(hi, lo); CRLF()
for i = 0 to N-1 do
[ let w = BGetBase(hi, lo+i)
Wb(w<<HiByte); Wc($*S); Wb(w); Ws(" ")
if (i&7) eq 7 then CRLF()
]
CRLF()
]