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

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

(1799)