// RaidPrint.bcpl. Raid printing routines for Lisp objects.
// 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 & statics defined
	Lprint; PrintName; PrintPtr;  Wo; Wn; Wb; uradix; uprintlevel; ulistlength

		// statics used
	dsp; keys; @lvNIL; @lvVPtr; @VPtr0; @VPtr1

		// procedures used
	RaidReset; Negate; Divide; Usc; Min; CRLF; ReadKeys; Wc; Ws
	EqNIL; VP; Gets; UCase
	@BGetBasePtr; @XGetBasePtr; @XGetBase32; IGetBase
	@SGetBase; @XSetBR; @RRead; @BGetBase; @XGetBase; @XGetBase1
	GetLmarg; SetLmarg; GetBitPos
	]

manifest maxdigits = 32

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

let Lprint(w ;numargs n) be		// only recursion is from PrintList
  [ let savedLM = GetLmarg(dsp)
    // second arg is used to suppress CRLF and hence LMarg adjusmtment
    if n eq 1 then SetLmarg(dsp, GetBitPos(dsp))
    switchon Type(w) into
      [ case ATOMTYPE:
	     if selecton w>>AtomNumber-2 into
                  [ // One char atoms have atom numbers = 2+their char code
                    case $. : case $( : case $) : case $*s : true
                    default : false ]
	         then Wc($%)		// % indicates special atoms
	     PrintName(w>>AtomNumber)
	     endcase
        case LISTTYPE:
	     PrintList(w, uprintlevel)
	     endcase
        case SMALLTYPE:
	     PrintNum(w>>VA.vahi eq SMALLPOSspace ? 0, -1, w>>VA.valo, uradix)
	     if (uradix eq 8) then Wc($Q)
	     endcase
        case INTEGERTYPE:
             XGetBase32(w)
	     PrintNum(VPtr0, VPtr1, uradix)
	     if (uradix eq 8) then Wc($Q)
	     endcase
        case FLTPTTYPE:
             Ws("FLOATP with bits: ")
	     XGetBase32(w)
	     PrintNum(VPtr0, VPtr1, 8); Wc($Q)	// always octal
	     endcase
        case STRINGPTRTYPE:
             Wc($"); PrintStr(w); Wc($"); endcase
	case ARRAYPTRTYPE:
             PrintArray(w); endcase
	default:			//print pointer
	     PrintPtr(w!0, w!1)
	     if (Type(w) ne 0)&(VP(w) ge FirstMDSPage) then
		[ Ws(" ->"); PrintPtr(XGetBase(w), XGetBase1(w)) ]
      ]					//ends switchon
    if n eq 1 then [ CRLF(); SetLmarg(dsp, savedLM) ]
  ]

and PrintArray(lvAPtr) be
 [ XSetBR(lvAPtr)
   let w = RRead(offset Styp/16)
// Flags and type are stored in the same word of the descriptor
   Wc($[); Wc(w<<Sorig ? $1, $0); Wc($-)
   Wn(RRead(offset Slength/16) - (w<<Sorig ? 0, 1), uradix); Ws("] ")
   if w<<Sro then Ws("read only, ")
   if w<<Salgn then Ws("aligned, ")
   Ws(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 [ Ws("(type ="); Wn(w<<Styp, uradix);
                            resultis ") INVALID" ] ] )
   Ws(" 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
   Ws(" offset "); Wn(w, 8)
 ]
 
and PrintChars(charPtr, offst, n) be
 [ let w = nil
   let hibyteflg = (offst & 1) eq 0
   XSetBR(charPtr)
   for i = offst to offst+Min(n, 100)-1 do
     [ w = RRead(i rshift 1)
       Wc(hibyteflg ? w<<HiByte, w<<LoByte)
       hibyteflg = not hibyteflg
     ]
   unless n le 100 do Ws(" &")	// indicate tail suppression
 ]
 
and PrintList(w, depth) be
  [
   if depth le 0 then [ Wc($&); return ]
   Wc($()
   let len = ulistlength
   [ if len le 0 then [ Ws(" --"); break ]
     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 Wc($*S)
             ]
       ifnot [ Ws(" . "); Lprint(w, true); break ]
   ] repeat
   Ws(")")
  ]

and CAR(lvX) = valof			// lvX is known to be LISTP
  [
    XGetBase32(lvX)			// 32 bits into VPPtr0 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(name) be			// takes an atom number
 [ BGetBasePtr(PNPspace, PNPbase + (name lshift 1))	// pname ptr into VPtr
   PrintChars(lvVPtr, 1, XGetBase(lvVPtr)<<HiByte)
 ]

and PrintNum(A,B,R) 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 L, P = vec maxdigits, maxdigits
    if A ls 0 then [ Wc($-); Negate(lv A) ]
    [ L!P = Divide(lv A, R)+$0
      P = P-1
    ] repeatwhile (A ne 0) % (B ne 0)
    while P ls maxdigits do [ P = P+1; Wc(L!P) ]
  ]

and PrintPtr(hi, lo) be [ Wc(${); Wo(hi, true); Wc($,); Wo(lo, true); Wc($}) ]

and PrintStr(lvstrPtr) be
 [ XSetBR(lvstrPtr)			// point base at string descriptor
   PrintChars(XGetBasePtr(lvstrPtr),	// assumes base addr in first 2 words
              RRead(offset Soffst/16),	// offset of first byte
              RRead(offset Slength/16))	// string length
 ]

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 MoveAddr(tgt, src) = valof
  [ tgt!0 = src!0
    tgt!1 = src!1
    resultis tgt
  ]


and Type(ptr) = valof
  [ // Type is only valid for ptrs in the data zone, below PNPspace
    unless ptr>>VA.segment ls PNPspace do resultis 0
    let MDSbyte = VP(ptr) rshift 1
    let W = BGetBase(MDSTYPEspace, MDSTYPEbase + MDSbyte rshift 1)
    resultis ((MDSbyte&1) eq 0 ? W<<HiByte, W<<LoByte)
  ]
(1799)