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

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

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
]

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
]