// Raid.bcpl - Raid debugger for InterLisp-D
// Last change March 20, 1985  10:30 AM by Bill van Melle
// Last change January 21, 1985  11:46 AM by Bill van Melle
// Last change May 21, 1984  3:49 PM by Bill van Melle
// 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
	DoYankDef; DoSetTopVal; FetchAtomComponent 
		// from Stack
	CtxtSwitch 
		// from VMemExtra
	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
	@BGetBase32; @BPutBase32; MkSmallPos; SmallUnbox; EqNIL
	Iresume; UCase

		// statics used
	lvAbortFlag; keys; @LispKbd; dsp; @lvKT; @lvNIL; @RMSK; @lvVPtr
	uradix; uprintlevel; ulistlength
	@dlispDsp; @DisplayAddrHi; @dspArea
	EmulatorSpace; sysFontCharWidth
		// from RaidStack	
	lastFrame; linkUsed; raidStackFX
		// from VmemB	
	SwapBufVp

		// 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 top value of atom "		// ^V
   let c30, v30 = #30, "Show frame extension"		// ^X
   let c31, v31 = #31, "Yank definition"		// ^Y
   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{atom, value}
	DoSetTopVal()
	loop
      case #30:				//^X{onum}
	AtLoc(" stack")
	PrintFxtn(ReadNum(8))
	loop
      case #31:				//^Y{atom,atom}
	DoYankDef()
	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(FetchAtomComponent(TOPVALspace,ReadAtom()))
	loop
      case $B:				//B{onum, onum, onum}
	StartLoc(""); PrintAddrs(ReadNum(8))
	loop
      case $C:				//C{}
	CRLF()
	ShowRealCore()
	loop
      case $D:				//D{onum}
	Ws(" for ")
	[ let a = ReadAtom()
	PrintAddrs(DEFspace+(a rshift 15), a 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 $N:				//N{dnum}
	uprintlevel = GetNewNum(uprintlevel, 10)
	loop
      case $O:				//O{onum, onum}
	StartLoc(" Alto")
	PrintAddrs(EmulatorSpace)
	loop
      case $P:				//P{onum}
	Lprint(FetchAtomComponent(PLISTspace,ReadAtom()))
	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(); SwapBufVp = 0
    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()
  ]