// RaidPrint.bcpl. Raid printing routines for Lisp objects.
// Changed November 16, 1982  4:39 PM by van Melle
// Changed March 8, 1982  11:38 PM by van Melle
// Changed February 2, 1982  6:29 PM by van Melle: listpage headers wrong
// Changed January 11, 1982  12:36 PM by Masinter: listpage headers wrong
// Changed December 30, 1981  10:50 PM by Bill van Melle
// Changed August 26, 1981 by Bill van Melle
// Allegro change August 4, 1981  4:27 PM by Beau Sheil
// Last change July 20, 1981  8:01 PM by Beau Sheil
// Last change May 9, 1981  12:29 AM by Beau Sheil
// Last change April 14, 1981  8:07 PM by Beau Sheil
// Tone change March 17, 1981  5:21 PM by Beau Sheil

	get "Raid.decl"

external [	// procedures defined
	SpaceCheck; CRLF; Lprint; PrintName; ReadStrng; PrintPtr; Confirm
	Wo; Wn; Wb; Type; PrintStr

		// statics defined
	uradix; uprintlevel; ulistlength

		// statics used
	dsp; keys; @lvNIL; @lvVPtr; @VPtr0; @VPtr1
	typeDecoding; crMax; crCount
	rmargBitPos; sysFontCharWidth; stringLimit

		// procedures used
	RaidReset; ReadKeys; Wc; Ws
	EqNIL; VP; UCase
	@BGetBasePtr; @XGetBasePtr; @XGetBase32; IGetBase
	@SGetBase; @XSetReadBR; @RRead; @BGetBase; @XGetBase; @XGetBase1
		// OS procs
	GetLmarg; SetLmarg; GetBitPos; EraseBits; CharWidth
	Negate; Divide; Usc; Min; Gets; FlashScreen; Resets
	SetScreenColor 

	]

manifest maxdigits = 32

static [ uradix = 8; uprintlevel = 5; ulistlength = 8 
	
	]

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

let Lprint(w, internal; numargs n) be
	// print lisp object w using current position as left margin.
	// second arg is supplied on recursive call from PrintList,
	// to suppress margin adjustment
  [ let savedLM = GetLmarg(dsp)
    if n eq 1
	then SetLmarg(dsp, GetBitPos(dsp))
    let typ = Type(w)
    switchon typ into
      [ case ATOMTYPE:
	     PrintName(w>>AtomNumber)
	     endcase
        case LISTTYPE:
	     PrintList(w, uprintlevel)
	     endcase
        case SMALLTYPE:
	     PrintNum(w>>VA.vahi eq SMALLPOSspace ? 0, -1, w>>VA.valo, uradix)
	     endcase
        case INTEGERTYPE:
             XGetBase32(w)
	     PrintNum(VPtr0, VPtr1, uradix)
	     endcase
        case FLTPTTYPE:
             WsX("{FLOATP with bits: ")
	     XGetBase32(w)
	     PrintNum(VPtr0, VPtr1, 8)	// always octal
	     WsX("}")
	     endcase
        case STRINGPTRTYPE:
             PrintStr(w)
	     endcase
	case ARRAYPTRTYPE:
             PrintArray(w)
	     endcase
	default:			//print pointer
	     [  let saved = vec 1
		MoveAddr(saved, w)	// saves w for later test
		PrintPtr(w!0, w!1, typ)
		if (typ ne 0) & (VP(saved) ge FirstMDSPage)
		   then [ WsX("->")
			  PrintPtr(XGetBase(saved), XGetBase1(saved)) ]
	     ]
      ]					//ends switchon
    if n eq 1
	then [ CRLF(); SetLmarg(dsp, savedLM) ]
  ]

and PrintArray(lvAPtr) be
 [ XSetReadBR(lvAPtr)
   let w = RRead(offset Styp/16)
// Flags and type are stored in the same word of the descriptor
   WsX("{["); WcX(w<<Sorig ? $1, $0); WcX($-)
   Wn(RRead(offset Slength/16) - (w<<Sorig ? 0, 1), uradix); Ws("] ")
   if w<<Sro then WsX("read only, ")
   if w<<Salgn then WsX("aligned, ")
   WsX(selecton w<<Styp into
         [ case 0:  "BYTE"
           case 1:  "POS16"
           case 2:  "FIXP"
           case 3:  "HASH"
           case 4:  "CCODE"
           case 5:  "BITMAP"
           case 6:  "POINTER"
           case 11: "DOUBLE POINTER"
           default: valof [ WsX("(type ="); Wn(w<<Styp, uradix);
                            resultis ") INVALID" ] ] )
   WsX(" array @ ")
   w = RRead(offset Soffst/16)	// save offset lest lvAPtr be lvVPtr
   XGetBasePtr(lvAPtr)		// knows that base ptr is in first word!!
   PrintPtr(VPtr0, VPtr1)	// prints base address as a ptr
   WsX(" offset "); Wn(w, 8)
   WcX($})
 ]
 
and PrintChars(charPtr, offst, n, limit; numargs na) be
 [ let w = nil
   let hibyteflg = (offst & 1) eq 0
   XSetReadBR(charPtr)
   let last = n
   if na gr 3 & limit gr 0 & n gr limit
      then last = limit
   for i = offst to offst+last-1 do
     [ w = RRead(i rshift 1)
       Wc(hibyteflg ? w<<HiByte, w<<LoByte)
       hibyteflg = not hibyteflg
     ]
   if last ne n then Ws(" &")	// indicate tail suppression
 ]
 
and PrintList(w, depth) be
  [
   if depth le 0
      then [ WcX($&); return ]
   compileif CDRCODING then 
	[ if w>>VA.wordN eq 0
	     then [		// not really a cons
		WsX("{list page header @ ")
	    	PrintPtr (w>>VA.vahi, w>>VA.valo)
		WcX($})
		return
		]
	]
   if (w>>VA.valo & 1) eq 1
      then [		// odd pointer??
	    WsX("{bogus cons @ ")
	    PrintPtr (w>>VA.vahi, w>>VA.valo)
	    WcX($})
	    return
	   ]
   WcX($()
   let len = ulistlength
   [ test len le 0
	ifso  [ WsX("--")
		break ]
      ifnot test Type(w) eq LISTTYPE
	ifso  [ let saved = vec 1
		MoveAddr(saved, w)		// saves w for later cdr
		let car = CAR(w)
		test Type(car) eq LISTTYPE
                   ifso  PrintList(car, depth-1)
                   ifnot Lprint(car, true)
		w = CDR(saved)
		len=len-1
		test EqNIL(w)
		   ifso break
		   ifnot if SpaceCheck(1) then Wc($*S)
	      ]
	ifnot [ WsX(". ")
		Lprint(w, true)
		break
	      ]
   ] repeat
   WcX($))
  ]

and CAR(lvX) = valof			// lvX is known to be LISTP
  [
    XGetBase32(lvX)			// 32 bits into VPtr0 and 1
    compileif CDRCODING then [
	unless lvVPtr>>ConsCell.Qfield	// indirect cell. Take 1 level of
	    do XGetBase32(lvVPtr)	// indirection, to the correct cell
	lvVPtr>>ConsCell.Qfield = 0	// Turn off the CDR bits
	]
    resultis lvVPtr
  ]

and CDR(lvX) = valof			// lvX is known to be LISTP # lvVPtr 
  [
    compiletest CDRCODING
      ifso [
	XGetBase32(lvX)			// 32 bits into VPPtr0 and 1
	unless lvVPtr>>ConsCell.Qfield	// indirect cell. Save its address
	   do [ MoveAddr(lvX, lvVPtr)	// for later offset, then indirect
		XGetBase32(lvVPtr)	]	// to it
	let D = lvVPtr>>ConsCell.dfield
	unless D then resultis lvNIL
	let F = lvVPtr>>ConsCell.ibit
	MoveAddr(lvVPtr, lvX)		// address is in same page as lvX
	lvVPtr>>VA.wordN = D lshift 1
	unless F do XGetBasePtr(lvVPtr)	// indirection for CDR
	]
      ifnot [
	MoveAddr(lvVPtr, lvX)		// address is in same page as lvX
	lvVPtr>>VA.valo = lvVPtr>>VA.valo + 2
	XGetBasePtr(lvVPtr)
	]
    resultis lvVPtr
  ]

and PrintName(atomnum) be			// print pname of atom
 [ BGetBasePtr(PNPspace, PNPbase + (atomnum lshift 1))	// pname ptr into VPtr
   let nchars = XGetBase(lvVPtr)<<HiByte
   SpaceCheck (nchars + valof [
	if (selecton atomnum-2 into
                  [ // One char atoms have atom numbers = 2+their char code
                    case $. : case $( : case $) : case $*s : true
                    default : false ])	// special atoms needing %
	   then [ Wc ($%); resultis 1 ]
	resultis 0
	])
   PrintChars(lvVPtr, 1, nchars, stringLimit)
 ]

and PrintNum(A,B,radx) be
	//  A and B are hi and lo parts of the same number.
	// This procedure depends on them being put into AC0
	// and AC1 for double word Divide. Hence, 2 args.
  [ 
    let doQ = (radx eq 8) & (A eq 0? (B gr 7 % B ls 0),
			 A eq -1? (B gr 0 % B ls -7), true)
		// will add "Q" when radix 8 and |number| > 7
    let L, P = vec maxdigits, maxdigits
    let sgn = 0
    if A ls 0
	then [ sgn = 1; Negate(lv A) ]
    [ L!P = Divide(lv A, radx)+$0
      P = P-1
    ] repeatwhile (A ne 0) % (B ne 0)		// fill L backwards
    SpaceCheck (maxdigits-P+sgn+(doQ? 1, 0))
    if sgn then Wc($-)
    while P ls maxdigits do [ P = P+1; Wc(L!P) ]
    if doQ
	then Wc($Q)
  ]

and PrintPtr(hi, lo, typ; numargs na) be	// print ptr as {hi,lo}
 [ let name = (na gr 2) & typ ? TypeName (typ), 0
   if name			// pointer has an interesting type name
      then [ BGetBasePtr(PNPspace, PNPbase + (name lshift 1))
				// pname ptr into VPtr (see PrintName)
	     name = XGetBase(lvVPtr)<<HiByte
	   ]
   SpaceCheck (11+(name ? name+2, 0))
   Wc(${)
   if name then [ PrintChars (lvVPtr, 1, name, stringLimit); Ws(": ") ]
   Wo(hi, true); Wc($,)
   Wo(lo, true); Wc($})
 ]

and PrintStr(lvstrPtr, noquotes; numargs na) be
 [ XSetReadBR(lvstrPtr)			// point base at string descriptor
   let nchars = RRead(offset Slength/16)	// string length
   SpaceCheck (nchars+2)
   let quoted = (na eq 1) % (not noquotes)
   if quoted then Wc ($")
   PrintChars(XGetBasePtr(lvstrPtr),	// assumes base addr in first 2 words
              RRead(offset Soffst/16),	// offset of first byte
              nchars, quoted? stringLimit, -1)
   if quoted then Wc ($")
 ]

and Wo(n, nopad; numargs na) be
  [ let pad = (na ls 2) % (nopad eq 0)
    for i = 15 to 3 by -3 do
      [ let d = n rshift i
        test d ne 0
	   ifso Wc((d&7)+$0)
	   ifnot if pad then Wc($*S)	// pad number to fixed width (6)
      ]
    Wc((n&7)+$0)			// ensures at least one digit
  ]

and Wn(n, rad) be PrintNum(0, n, rad)	// n is assumed +ve; rad is radix
(1792)
and Wb(n) be		// Write a byte
  [ Wc($0 + ((n rshift 6) & 3))
    Wc($0 + ((n rshift 3) & 7))
    Wc($0 + (n & 7))
  ]

and WcX (char) be
  [ SpaceCheck(1)
    Wc(char)
  ]

and WsX (str) be
  [ SpaceCheck (str>>String.length)
    Ws (str)
  ]

and MoveAddr(tgt, src) = valof
  [ tgt!0 = src!0
    tgt!1 = src!1
    resultis tgt
  ]

and Type(ptr) = 
    (ptr>>VA.segment gr #77 ? 0,	// invalid pointer
    	BGetBase(MDSTYPEspace, MDSTYPEbase + VP(ptr) rshift 1))<<LoByte

and TypeName (type) =			// returns an atom number
	typeDecoding? BGetBase(DTDspace, DTDbase + (type lshift 4)), 0(1799)

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 % (ch eq #27) % (ch eq #21)	// ^W or ^Q
		   then [	// overwriting/erasing init string
			unless noecho
			   do [ let width = 0
				for i = 1 to index
			 	  do width = width + CharWidth(dsp, str>>String.char^i)
				EraseBits (dsp, -width)
				]
			index = 0
			inited = false
			if (ch eq #27) % (ch eq #21)
			   then loop
			]
		if ch eq $*N
		   then [ Wc (ch); break ]
		unless noecho do Wc(ch)
		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
 ]
(1792)
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 CRLF() be
  [ 
    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
    Wc($*N)
  ]
 
and SpaceCheck (n) = valof	// see if there is room to print n chars
			// if so, return true; else do CRLF() and return false
 [
   test (GetBitPos(dsp) + (n*sysFontCharWidth) gr rmargBitPos) &
	(n*sysFontCharWidth ls rmargBitPos-GetLmarg(dsp))
	ifso [ CRLF(); resultis false ]
	ifnot resultis true
 ]