// Raid.bcpl - Raid debugger for InterLisp-D
// Last change November 15, 1983 5:50 PM by Bill van Melle
// Last change March 30, 1983 11:27 AM by Bill van Melle
// Last change December 16, 1982 10:15 PM by Bill van Melle
// Last change April 15, 1982 4:23 PM by Bill van Melle
// Last change December 30, 1981 10:49 PM by Bill van Melle
// Last change September 27, 1981 9:36 PM by Bill van Melle
// Last change September 19, 1981 2:02 PM by Bill van Melle
// Last change August 4, 1981 12:41 PM by Beau Sheil
get "Raid.decl"
get "Streams.d"
get "AltoDefs.d"
external [ // procedures defined
RAID; uCodeCheck; RAIDCode; RaidReset; ReadChar
// from RaidStack
PrintFxtn; PrintBF; PrintAddrs; PrintBytes; GetFXP
// from RaidPrint
Lprint; LispStack; LispFrame; ShowStackBlocks
Wb; Wn; Wo; PrintPtr; PrintStr; Confirm; Type; SpaceCheck
CRLF
// from RaidProcs
ShowRealCore; TeleRaid; ReadNum; ReadAtom; AtomNum
DisplayVMinBitMap; DoYankDef
// from Stack
CtxtSwitch
// from VMemExtra
CheckMap; PrintPageTable
// from vmem
LISPFINISH; WriteSwapBuf
// from OS
ShowDisplayStream; Endofs; Gets; Resets; Puts; Wc; Ws
GetBitPos; SetBitPos; GetRmarg; GetLmarg; SetLmarg
CallSwat; MyFrame; Min
// misc
ReadFlags; ReadRP; @BGetBasePtr; @BGetBase; @BPutBase; IGetBase
@APutBase32; @BGetBase32; @BPutBase32; MkSmallPos; SmallUnbox; EqNIL
Iresume; UCase
// statics used
lvAbortFlag; keys; @LispKbd; dsp; @lvKT; @lvNIL; @RMSK; @lvVPtr
uradix; uprintlevel; ulistlength
@dlispDsp; @DisplayAddrHi; VMDisplay; @dspArea
EmulatorSpace; sysFontCharWidth
// from RaidStack
lastFrame; linkUsed; raidStackFX
// statics defined
doRaid // label used to abort typein
insideRaid; typeDecoding; crCount; crMax
TeleRaidSocket; rmargBitPos; stringLimit
]
static [ insideRaid = false
crCount = 1 // count for autohold after screenful
crMax = 0
typeDecoding = true // => decode type names where possible
rmargBitPos
RaidFrame // for RaidReset
stringLimit = 200 // point at which to truncate strings
]
manifest SubrArgsAddr = #210
structure String: [ length byte; char↑1,255 byte ]
let RAID(Mess1, Mess2, Flg; numargs na) =
na eq 0 ? RAIDCode("Called from Swat", lvNIL) ,
(na eq 1) % EqNIL(Mess2) ? RAIDCode("Called from Lisp:", Mess1) ,
na eq 2 ? RAIDCode(Mess1, Mess2) ,
RAIDCode(Mess1, Mess2, not EqNIL(Flg))
and uCodeCheck(code) = RAIDCode("Called from uCode", code)
and RAIDCode(st, param, isaddr; numargs na) = valof
[
RaidFrame = MyFrame()
let wasInsideRaid = insideRaid
insideRaid = true
if crMax eq 0
then crMax = Min(60, dspArea rshift 8)
if dsp eq 0
then CallSwat("Raid: No dsp", st)
if DisplayAddrHi
then ShowDisplayStream(dsp, DSalone)
rmargBitPos = GetRmarg (dsp)
Ws("*NRaid: ")
PrintErrorMsg (st, param, (na gr 2) & isaddr)
[ if ((not @kbdAd) % (not @(kbdAd+1)) %
((not @(kbdAd+2)) & #173677) % ((not @(kbdAd+3)) & #177567)) eq 0
then break ] repeat
// wait until all keys (but ctrl/shift) up
Resets(keys) // clear any type-ahead
// @lvAbortFlag = 0 // allow shift-swat
raidStackFX = GetFXP()
lastFrame = 0
linkUsed = 0
// This ATROCITY is due to Bcpl's refusal to allow strings as table entries
// The effect of this series of bindings is to create a table of character
// code, prompt message pairs on the stack
let c2, v2 = #2, "Show bytes" // ↑B
let c4, v4 = #4, "Return to top level" // ↑D
let c6, v6 = #6, "Show basic frame" // ↑F
let c7, v7 = #7, "Show stack blocks" // ↑G
let c12, v12 = #12, "Next frame" // LF
let c13, v13 = #13, "Kill Lisp" // ↑K
let c14, v14 = #14, "Lisp Stack from frame" // ↑L
let c16, v16 = #16, "Return NIL" // ↑N
let c17, v17 = #17, "Atom number for atom " // ↑O
// let c20, v20 = #20, "Turn microcode PC tracing " // ↑P
let c23, v23 = #23, "Call Swat" // ↑S
let c24, v24 = #24, "Return T" // ↑T
let c25, v25 = #25, "Show Lisp user screen" // ↑U
let c26, v26 = #26, "Set to NIL the atom " // ↑V
let c30, v30 = #30, "Show frame extension" // ↑X
let c31, v31 = #31, "Yank definition" // ↑Y
let c32, v32 = #32, "Turn VM display " // ↑Z
let cc, vc = $,, "Word from 2 bytes "
let ce, ve = $., "2 bytes from word "
let cf, vf = $;, "Page# from virtual address "
let cp, vp = $+, "Add 2 octal numbers "
let ca, va = $←, "Set word"
let cd, vd = $<, "Set cell"
let cb, vb = $↑, "Previous frame"
let cq, vq = $?, "Show help"
let cA, vA = $A, "Atom top level value"
let cB, vB = $B, "Show virtual addrs"
let cC, vC = $C, "Coremap"
let cD, vD = $D, "Atom definition"
let cE, vE = $E, "Error msg"
let cF, vF = $F, "Show frame number "
let cJ, vJ = $J, "Set Raid list length"
let cL, vL = $L, "Lisp stack"
let cM, vM = $M, "Memory map check"
let cN, vN = $N, "Set Raid list depth"
let cO, vO = $O, "Show emulator addrs"
let cP, vP = $P, "Property list of atom "
let cQ, vQ = $Q, "Set Raid screen size"
let cR, vR = $R, "switch to teleRaid"
let cS, vS = $S, "Show stack addrs"
let cT, vT = $T, "Type decoding "
let cU, vU = $U, "Set Raid radix"
let cV, vV = $V, "Show Lisp object"
let cW, vW = $W, "Walk stack blocks"
let cY, vY = $Y, "Show page table"
let cZ, vZ = $Z, "Show Vmem flags"
let cend = 0 // 0 marks end of command table
let V = nil
[
doRaid: Ws("*N@"); crCount = 1
switchon GetCom(lv c2) into
[
case 0: //Noop
loop
case 2: //↑B{onum, onum, onum}
StartLoc(""); PrintBytes()
loop
case 4: //↑D{} call \RAIDEXITFN
if Confirm() then
[
V = 0; break
]
CRLF()
loop
case 6: //↑F{onum}
AtLoc(" stack"); PrintBF(ReadNum(8))
loop
case 7: //↑G{onum}
StartLoc(" stack"); ShowStackBlocks(ReadNum(8), true)
loop
case #13: //↑K{} to kill
Ws(" Note: (LOGOUT T) is much safer!*N Type OK to confirm: ")
if UCase(ReadChar()) eq $O & UCase(ReadChar()) eq $K
then LISPFINISH()
Ws(" xxx")
loop
case #14: //↑L{from fx; $A or $C}
AtLoc(" stack"); Ws ("/ context# ")
LispStack(ReadNum(8))
lastFrame = 0
loop
case $*N: //do nothing
loop
case #16: //↑N{} return NIL
V = lvNIL
break
case #17: //↑O{string} get atom number
[ let a = ReadAtom(); Ws("is "); Wo(a) ]
CRLF()
loop
// case #20: //↑P{} uPC tracing
// if Confirm(uPCTraceAddr ? "off", "on") then uPCTracing(true)
// loop
case #23: //↑S{} gets Swat
if Confirm() then CallSwat("Raid")
loop
case #24: //↑T{} return T
V = lvKT
break
case #25: //↑U{} show Lisp display
if Confirm() then
[ unless DisplayAddrHi do [ Ws(" No Lisp display to show"); loop ]
ShowDisplayStream(dlispDsp, DSalone) // show lisp display
until Gets(keys) do loop // wait for a keystroke
ShowDisplayStream(dsp, DSalone) // restore Raid dsp
]
loop
case #26: //↑V{onum}
[ let a = ReadAtom()
if Confirm() then APutBase32(a, lvNIL) ]
loop
case #30: //↑X{onum}
AtLoc(" stack")
PrintFxtn(ReadNum(8))
loop
case #31: //↑Y{atom,atom}
DoYankDef()
loop
case #32: //↑Z{} displayVM
if Confirm(VMDisplay ? "off", "on")
then DisplayVMinBitMap()
loop
case $,: //,(onum}: 2 bytes -> word
Wo(ReadNum(8) lshift 8 + ReadNum(8))
CRLF()
loop
case $.: //.(onum}: word -> 2 bytes
[ let a = ReadNum(8)
Wo(a rshift 8); Wc($*S); Wo(a & RMSK)
]
CRLF()
loop
case $;: //;(onum}: Va -> VP
Wo(ReadNum(8) lshift 8 + ReadNum(8) rshift 8)
CRLF()
loop
case $+: //+(onum}
Wo(ReadNum(8) + ReadNum(8))
CRLF()
loop
case $←: //←(onum, onum, onum}
AtLoc("")
[ let v0, v1 = ReadNum(8), ReadNum(8)
BPutBase(v0, v1, GetNewNum(BGetBase(v0, v1), 8)) ]
CRLF()
loop
case $<: //<(onum, onum, onum, onum}
AtLoc("")
[ let v0, v1 = ReadNum(8), ReadNum(8)
Ws(" currently ")
Wo(BGetBase(v0, v1)); Wc($*S); Wo(BGetBase(v0, v1+1))
Ws(" to ")
let n0, n1 = ReadNum(8), ReadNum(8)
if Confirm()
then [ BPutBase(v0, v1, n0); BPutBase(v0, v1+1, n1) ]
]
CRLF()
loop
case $?: //help
ShowHelp(lv c2)
loop
case $A: //A{onum}
Ws(" for ")
Lprint(BGetBasePtr(TOPVALspace,TOPVALbase+ReadAtom() lshift 1))
loop
case $B: //B{onum, onum, onum}
StartLoc(""); PrintAddrs(ReadNum(8))
loop
case $C: //C{}
CRLF()
ShowRealCore()
loop
case $D: //D{onum}
Ws(" for ")
PrintAddrs(DEFspace,DEFbase+ReadAtom() lshift 1, 2)
loop
case $E: //E
Ws(" was: "); PrintErrorMsg(st, param, (na gr 2) & isaddr)
loop
case $F: //F{dnum, $A or $C}
LispFrame()
loop
case #12: //LF (next frame)
LispFrame(lastFrame+1, linkUsed)
loop
case $↑: //↑ (previous frame)
LispFrame(lastFrame-1, linkUsed)
loop
case $J: //J{dnum}
ulistlength = GetNewNum(ulistlength, 10)
loop
case $L: //L{$A or $C}
LispStack()
loop
case $M: //Memory map diagnostic
CheckMap()
loop
case $N: //N{dnum}
uprintlevel = GetNewNum(uprintlevel, 10)
loop
case $O: //O{onum, onum}
StartLoc(" Alto")
PrintAddrs(EmulatorSpace)
loop
case $P: //P{onum}
Lprint(BGetBasePtr(PLISTspace,PLISTbase+ReadAtom() lshift 1))
loop
case $Q: //Q{dnum}
crMax = GetNewNum(crMax, 10)
loop
case $R: //R call teleRaid
if Confirm() then
[
V = -1; break
]
CRLF()
loop
case $S: //S{onum, onum}
StartLoc(" stack")
PrintAddrs(STACKspace)
loop
case $T: //T type decode switch
if Confirm(typeDecoding ? "off", "on")
then typeDecoding = not typeDecoding
loop
case $U: //U{dnum}
[ let N = GetNewNum(uradix, 10)
test (N ge 2)&(N le 10)
ifso uradix = N
ifnot Ws("Invalid, uradix not set") ]
loop
case $V: //V{onum, onum}
AtLoc("")
[ let v0, v1 = ReadNum(8), ReadNum(8)
Lprint(lv v0) ]
loop
case $W: //W
StartLoc(" stack")
ShowStackBlocks(ReadNum(8), false)
loop
case $Y: //Y
if Confirm()
then PrintPageTable()
loop
case $Z: //Z{onum, onum}
Ws(" for virtual pages from ")
[ let s = ReadNum(8); Ws(" to ")
let f = ReadNum(8)
Ws("*N VP Flags RealP*N")
for i = s to f
do [ Wo(i); Ws(" ")
Wo(ReadFlags(i))
Wo(ReadRP(i))
CRLF() ]
]
loop
default: Ws("??"); Resets(keys)
loop
]
] repeat
// Exit sequence. Just return, unless ↑D, in which case reset Lisp
insideRaid = wasInsideRaid
CRLF()
Resets(keys)
[ if ((not @kbdAd) % (not @(kbdAd+1)) %
(not @(kbdAd+2)) % ((not @(kbdAd+3)) & #177577)) eq 0
then break // Wait until everything but shiftlock up
] repeat
if DisplayAddrHi
then ShowDisplayStream(dlispDsp, DSalone)
WriteSwapBuf()
if (V ne 0) & (V ne -1) then resultis V
// ↑D exit (V=0) used to worry about flushing the Bcpl stack. But reentry
// from Lisp does this automatically since the Chord change.
test V eq 0
ifso [
// disable Lisp kbd
@displayInterrupt = @displayInterrupt & (not LispKeyMask)
V = ResetFXP
]
ifnot V = TeleRaidFXP
CtxtSwitch(V)
resultis Iresume(MkSmallPos(V))
]
and PrintErrorMsg (str1, param, isaddr) be
[
test str1 ne SubrArgsAddr
ifso Ws(str1)
ifnot // Gross hack: Raid's first arg from Lisp
test Type(str1) eq STRINGPTRTYPE
ifso PrintStr(str1, true)
ifnot Lprint (str1, true)
test (GetBitPos(dsp) gr (rmargBitPos rshift 1)) & LongType(param)
ifso Ws("*N ") // if far to right, start new line
ifnot Wc($*S)
test isaddr
ifso // param is explicitly an addr, don't interpret
[ PrintPtr (param>>VA.vahi, param>>VA.valo)
CRLF()
]
ifnot test Type(param) eq STRINGPTRTYPE
ifso [ PrintStr(param, true); CRLF() ]
ifnot Lprint (param)
]
and LongType(obj) = valof // true if obj might be long
[
let typ = Type(obj)
resultis (typ le ATOMTYPE) % (typ eq STRINGPTRTYPE)
]
and GetCom(CT, s) = valof // CT => command table
[
let c = UCase(ReadChar())
[ if c eq CT!0
then [ Ws(" - ") // found it
Ws(CT!1)
break ]
CT=CT+2
] repeatwhile CT!0 // 0 entry ends the table
resultis c
]
and GetNewNum(old, rad) = valof
[
Ws(" currently "); Wn(old, rad); Ws(" to ")
resultis ReadNum(rad)
]
and AtLoc(s) be // prints common msg
[ Ws(" at"); Ws(s); Ws(" location ") ]
and StartLoc(s) be // prints common msg
[ Ws(" starting at"); Ws(s); Ws(" location ") ]
and ReadChar() = valof // read character and echo it, abort on DEL
[
let c = Gets(keys)
if c eq DEL then RaidReset(" XXX")
PrintComChar (c)
resultis c
]
and PrintComChar (ch) be
[
test (ch ge $*S) % (ch eq $*N)
ifso Wc(ch)
ifnot test ch eq #12
ifso Ws ("LF")
ifnot [ Wc($↑); Wc (ch%#100) ]
]
and RaidReset(errmsg; numargs na) be // retto Raid command loop
[
if na gr 0 then Ws(errmsg)
Wc($*N)
SetLmarg(dsp, 8) // reset margin
MyFrame()!0 = RaidFrame
RaidFrame!1 = doRaid - 1 // to restart command loop
]
and ShowHelp(CT) be // CT => start of command table
[
Ws("*N*NRAID commands*N*N")
[ PrintComChar(CT!0); Ws(" - "); Ws(CT!1)
test GetBitPos(dsp) gr 300
ifso CRLF()
ifnot SetBitPos(dsp, 300)
CT=CT+2
] repeatwhile CT!0 // 0 entry ends the table
CRLF()
]