// Raid.bcpl - Raid debugger for InterLisp-D
// 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
// Last change May 22, 1981  12:01 PM by Beau Sheil
// Last change May 20, 1981  9:56 PM by Beau Sheil
// Last change April 14, 1981  8:26 PM by Beau Sheil
// Tone change April 5, 1981  4:14 PM by Beau Sheil

	get "Raid.decl"
	get "Streams.d"

external [	// procedures defined
	RAID; uCodeCheck; RAIDCode; RaidReset
	CRLF; ReadNum; ReadStrng; ReadChar

		// from RaidStack
	PrintFxtn; PrintBF; PrintAddrs; PrintBytes
		// from RaidPrint
	Lprint; LispStack; LispFrame; ShowStackBlocks; Wb; Wn; Wo 
		// from RaidProcs
	ShowRealCore; TeleRaid; AtomNum
		// from Stack
	CONTEXTSWITCH; GetFXP 

		// from OS
	ShowDisplayStream; Endofs; Gets; Resets; Puts; Wc; Ws
        GetBitPos; SetBitPos; SetLmarg; EraseBits; CharWidth
        CallSwat; MyFrame
	SetScreenColor; FlashScreen 
		// misc
	ReadFlags; ReadRP; @BGetBasePtr; @BGetBase; @BPutBase; IGetBase
	@APutBase32; @AtomNotNIL; MkSmallPos; SmallUnbox
	Iresume; MoveValue
	uPCTracing; UCase; DisplayVMinBitMap
	OpenSoc; CloseSoc

		// statics used
	keys; @LispKbd; dsp; @lvKT; @lvNIL; @InterruptChar
	uradix; uprintlevel; ulistlength
	@dlispDsp; @DisplayAddrHi; VMDisplay
	EmulatorSpace; @uPCTraceAddr
		// from RaidStack	
	lastFrame; linkUsed; raidStackFX

	doRaid	// label used to abort typein
	]

static [ crCount = 1; crMax = 60 ; RaidFrame; TeleRaidSocket ]

manifest  RaidSoc = #33		// TeleRaid socket number

structure String: [ length byte; char↑1,255 byte ]
 

let RAID(X ;numargs na) = na ? RAIDCode("Called from Lisp", X) ,
                               RAIDCode("Called from Swat", lvNIL)

and uCodeCheck(code) = RAIDCode("Called from uCode", SmallUnbox(code))

and RAIDCode(st, param) = valof
  [
   RaidFrame = MyFrame()
   if dsp eq 0 then CallSwat("Raid: No dsp", st) // Before APutBase32
   Resets(keys); Resets(LispKbd)		// clear any type-ahead
   APutBase32(InterruptChar, lvNIL)		// clear any InterruptChar
   if DisplayAddrHi then ShowDisplayStream(dsp, DSalone)
   Ws("*NRaid: ");  Ws(st);  Wc($*S); Lprint(param)
   TeleRaidSocket = OpenSoc(0, RaidSoc)		// Open TeleRaid socket
   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"
   let c4,  v4  = #4,  "Return to top level"
   let c5,  v5  = #5,  "Enable interrupts"
   let c6,  v6  = #6,  "Show basic frame"
   let c7,  v7  = #7,  "Show stack blocks"
   let c12, v12 = #12, "Next frame"
   let c13, v13 = #13, "Kill Lisp"
   let c14, v14 = #14, "Lisp Stack from frame"
   let c16, v16 = #16, "Return NIL"
   let c17, v17 = #17, "Atom number for atom "
   let c20, v20 = #20, "Turn microcode PC tracing "
   let c23, v23 = #23, "Call Swat"
   let c24, v24 = #24, "Return T"
   let c25, v25 = #25, "Show Lisp user screen"
   let c26, v26 = #26, "Set to NIL the atom "
   let c30, v30 = #30, "Show frame extension"
   let c32, v32 = #32, "Turn VM display "
   let cc,  vc  = $,,  "Word from 2 bytes "
   let cp,  vp  = $+,  "Add 2 octal numbers "
   let ca,  va  = $←,  "Set word"
   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 cS,  vS  = $S,  "Show stack addrs"
   let cU,  vU  = $U,  "Set Raid radix"
   let cV,  vV  = $V,  "Show Lisp object"
   let cW,  vW  = $W,  "Walk stack blocks"
   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
	   [ 
	   test AtomNotNIL(IGetBase(IFPInterruptEnable))
	     ifso  [ V = 0; break ]
	     ifnot Ws("Interrupts are off. Restore them using ↑E first.")
	   ]
	CRLF()
	loop
      case 5:				//↑E
	if Confirm() then APutBase32(IGetBase(IFPInterruptEnable), lvKT) 
	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
	if Confirm() then finish
	loop
      case #14:				//↑L{from fx; $A or $C}
	AtLoc(" stack");
	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 #32:				//↑Z{} displayVM
	if Confirm(VMDisplay ? "off", "on") then DisplayVMinBitMap()
	loop
      case $,:				//,(onum}
	Wo(ReadNum(8) lshift 8 + ReadNum(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 $?:				//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: "); Ws(st); Wc($*S); Lprint(param)
	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
	if Confirm() then Ws("Sorry, not yet implemented")
	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 $S:				//S{onum, onum}
	StartLoc(" stack"); PrintAddrs(STACKspace)
	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
	CRLF()
	ShowStackBlocks(0, false)
	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 call RaidExitFn
    CloseSoc(TeleRaidSocket); CRLF(); Resets(keys); Resets(LispKbd)
    if DisplayAddrHi then ShowDisplayStream(dlispDsp, DSalone)
//  ↑D exit (V=0) used to worry about flushing the Bcpl stack. But reentry
//  from Lisp does this automatically since the Chord change.
    resultis V ? V, (IGetBase(1) ? Iresume(CONTEXTSWITCH(MkSmallPos(1))),
                                   CallSwat("No hard return context"))
  ]
 
and CRLF() be
  [ 
    Wc($*N)
    test crCount gr crMax
	ifso  [ crCount = 1
		SetScreenColor(true)	// flash screen
		let c = Gets(keys)	// wait for keystroke
		SetScreenColor(false)	// restore screen
		if c eq DEL then RaidReset()
		]
	ifnot crCount = crCount + 1
  ]
 
and Confirm(s ;numargs n) = valof
  [ Resets(keys)
    if n gr 0 then Ws(s)
    Ws(" [Confirm] ")
    let val = (Gets(keys) eq $*N)
    unless val do Ws("XXX")
    Wc($*N)
    resultis val
  ]

and GetCom(CT, s) = valof			// CT => command table
  [ 
    while Endofs(keys) do
        [ let v = TeleRaid(TeleRaidSocket)	// v is 0 or a Raid command
          if v then resultis v ]		// Execute Raid command
    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 ReadNum(radix) = valof	// read number in given radix
  [
   let s = vec 50
   unless ReadStrng(s) do RaidReset(" XXX")
   let num=0
   for i=1 to s>>String.length do
        [ let c = (s>>String.char↑i)-$0
          test (c ge 0) & (c ls radix)
            ifso  num=num*radix+c
            ifnot RaidReset(" XXX")
        ]
   resultis num
  ]

and ReadAtom() = valof			// obtains atom number from typein
  [ let s = vec 50
    unless ReadStrng(s) do RaidReset(" XXX")
    let num=0
    for i=1 to s>>String.length do
        [ let c = (s>>String.char↑i)-$0
          test (c ge 0) & (c le 7)
            ifso  num=num*8+c
            ifnot resultis AtomNum(s)
        ]
    resultis num
  ]

and ReadStrng(str, maxlen, inited, noecho; numargs na) = valof
	// Read string (up to space or cr) into str, return 0 if DEL typed
 [ if na ls 4 then noecho = false
   if na ls 3 then inited = false
   if na ls 2 then maxlen = 99
   let index = inited ? str>>String.length , 0
   [ let ch=Gets(keys)
	if ch eq DEL then resultis 0
	test (ch eq 1) % (ch eq #10)		// ↑A or BS
	   ifso test index gr 0
		   ifso [ unless noecho 
			   do EraseBits(dsp, -CharWidth(dsp, str>>String.char↑index))
			  index = index - 1
			]
		   ifnot FlashScreen()
	  ifnot test ch eq $*s
		   ifso [ if index eq 0 then loop // flush leading space
			  unless noecho do Wc(ch)
			  break ]
		  ifnot [
			if inited
			   then [	// overwriting init string
				let width = 0
				for i = 1 to index
				   do width = width + CharWidth(dsp, str>>String.char↑i)
				EraseBits (dsp, -width)
				index = 0
				inited = false
				]
			unless noecho do Wc(ch)
			if ch eq $*N then break
			if index ge maxlen
			   then [ FlashScreen(); loop ]
			index = index+1
			str>>String.char↑index = ch
			]
   ] repeat
   unless (index&1) ne 0
      do str>>String.char↑(index+1) = 0	// null last byte
   str>>String.length = index
   resultis str
 ]

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()
  ]