[eris]<Lisp>Harmony>BCPL>BCPLENV.DM!1>RaidPrint.bcpl

// 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