// SpruceUtils.Bcpl -- Utilities (swappable in Sprint)
// Errors 100 (old Spruce), 2500

//get "Spruce.D"
get "spruceFont.d"
get "sprucedoc.d"
get "sprucemisc.d"
get "Sprucefiles.D"
get "AltofileSys.D"
get "PressFile.D"

compileif newname SpruceSw then [ manifest [ SpruceSw = true ] ]
manifest SprintSw = not SpruceSw

// defined here
external
[
Comment
DblShift
DisableComments
EnableComments
FillInNames
FindErrorMessage
ForEach
FSGet
FSGetX
FSInit
FSPut
PageToPos
PosToPage
RpageToVpage
Reclaim
StorageStats
Wss
// Sprint only:
EmergencyAverted // function that tries to avert storage emergency, and reports success
EmergencyOver // function that restores emergency reaction capability
emergencyStorage // if this static is 0, EmergencyAverted will fail.
ChooseMailboxBin//select correct output bin from a letter (Penguin)
]

// incoming procedures

external
[
// OS
CallSwat
Closes
DefaultArgs
Endofs
FileLength
Gets
MoveBlock
OpenFileFromFp
Puts
ReturnFrom
SetBlock
SysErr

// SpruceFiles, SpruceStreams
CurrentPos
FileLeng
InitSpruceFile
ResetSpruceFile
SetupWindowStream
WindowCreateStream
WindowReadBlock
WindowSetPosition
WindowWriteByte

// SpruceCheck
ActOnEntry
// SpruceUtilsRes
Max; Min; MulDiv
SpruceError

// SpruceMl
DoubleSub
DoubleAdd
Ugt
DoubleCop

// Alloc
AddToZone
Allocate
Free
InitializeZone
CheckZone

// Queues
Dequeue

// StringUtils
StringCompare

// Template
PutTemplate
]

// incoming statics
external
[
commentFree
comments
DebugSystem
ErrorFile
QueueFile
printDoc; mapTemp; PressFile
SpoolVec
allocLogFile
numComments
sysDisk
Verbose
FSTrap
SpruceZone; OverlayTop; PermanentBottom
MoreLow; MoreHigh // (Spruce Only)
]

// ~~ FM structure from isf.d, since compiler couldn’t handle the whole thing
structure FM: // ~~ paraphrase of isf’s FM structure
[
fp: @FP
blank word 3
blank word 3
blank word// index of last word (a da)
end word// index of end of available space
] // ...
structure SV: [ H [ blank word 4; blank↑2, 11 word ]]

static [ allocLogFile ]

compileif SprintSw then
[ static [ emergencyStorage ]
manifest [ EStorageSize = 1500 ] ] // one largest disk buffer + a little

// Procedures

let PosToPage(pos, pPage, pChars, itemSize, spruceFile) be
[
// pos interpreted in terms of itemSize
let lnIS = itemSize-1 // ln itemSize
let lnEPP = (spruceFile>>SPruceFile.lnPageSize+1)-lnIS // ln entries/page
@pPage = pos>>FPOS.msAddr lshift (16-lnEPP) +
pos>>FPOS.lsAddr rshift lnEPP+1
@pChars = (pos>>FPOS.lsAddr & (-1 rshift (16-lnEPP))) lshift lnIS
]

and PageToPos(pos, page, chars, itemSize, spruceFile) = valof
[
// produce pos in terms of itemSize
let lnIS = itemSize-1 // ln itemSize
let lnEPP = (spruceFile>>SPruceFile.lnPageSize+1)-lnIS // ln entries/page
page = page-1 // Alto files start page 1
pos>>FPOS.msAddr = page rshift (16-lnEPP)
pos>>FPOS.lsAddr = page lshift lnEPP
page, chars = 0, chars rshift lnIS
DoubleAdd(pos, lv page)// May overflow and increment msAddr 2-22-78
resultis pos>>FPOS.lsAddr
]

and StorageStats(string, number, zoneStr; numargs na) be
[
if (DebugSystem & #100000) eq 0 then return
//Disable furthur statistics gathering
DebugSystem = DebugSystem & #77777
let s = OpenFileFromFp(lv (allocLogFile>>SPruceFile.map>>FM.fp))
PutTemplate(s, "*N$S $S $UO*NSpruceZone>>minAdr: $UO SpruceZone>>maxAdr: $UO PermanentBottom: $UO", string, zoneStr, number, SpruceZone!8, SpruceZone!9, PermanentBottom)
Closes(s)
//Re-Enable statistics gathering
DebugSystem = DebugSystem & #177777
]

and FSInit() be
[
//Maximum size of an individual block is 32K. But we can give two blocks
// to FS package. They will never be merged.
StorageStats("FSInit", 0)
let len=PermanentBottom-OverlayTop-1
let flen=len
if Ugt(flen, #77776) then flen=#77776
SpruceZone=InitializeZone(OverlayTop+1, flen, SysErr, ((DebugSystem✐) ne 0? SysErr,0))
if len-flen gr 30 then
[
let b=OverlayTop+1+flen+10
AddToZone(SpruceZone, b, len-flen-10)
]
// Client may have another hunk of usable space lying around
compiletest SpruceSw then [ if MoreLow then AddToZone(SpruceZone, MoreLow, MoreHigh-MoreLow) ]
or [ emergencyStorage = FSGet(EStorageSize) ]
]

and FSGet(Size, zone, value; numargs na) = valof
[
DefaultArgs(lv na, 1, SpruceZone, -2)
StorageStats("FSGet", Size, (zone eq SpruceZone ? "SpruceZone", "zone"))
let ptr=Allocate(zone, Size, -1)
unless ptr resultis 0
if ptr eq FSTrap then SpruceError(103)
if value ne -2 then SetBlock(ptr,value,Size)
resultis ptr
]

and FSGetX(Size, zone, value; numargs na) = valof
[
DefaultArgs(lv na, 1, SpruceZone, -2)
let p=FSGet(Size, zone, value)
if p eq 0 then
[
compileif SprintSw then [ if EmergencyAverted(zone) loop ]
SpruceError(104)
]
resultis p
] repeat

and FSPut(ptr, zone; numargs na) = valof
[
StorageStats("FSPut", ptr!0, (zone eq SpruceZone ? "SpruceZone", "zone"))
if ptr eq FSTrap then SpruceError(103)
Free((na < 2? SpruceZone, zone), ptr)
CheckZone(SpruceZone)
resultis 0
]

and EmergencyAverted(zone) = valof
[ compileif SprintSw then [
if emergencyStorage eq 0 % zone ne SpruceZone resultis false
emergencyStorage = FSPut(emergencyStorage) // 0
resultis true
] ]

and Reclaim() be
[
// reclaim core used for DocG, SPruceFile, and map structures.
unless PressFile>>SPruceFile.isSubFile do
[ FSPut(mapTemp); mapTemp = 0 ]
if PressFile ne 0 then
[ FSPut(PressFile); PressFile = 0 ]
if printDoc ne 0 then
[ FSPut(printDoc); printDoc = 0 ]
]

and DblShift(dblwordlv,amount) = valof
[
test amount ls 0 then//Left shift
[
amount=-amount
let temp=(dblwordlv!1) rshift (16-amount)
@dblwordlv=(@dblwordlv lshift amount)+temp
dblwordlv!1=(dblwordlv!1) lshift amount
]
or
[
let temp=@dblwordlv lshift (16-amount)
@dblwordlv=@dblwordlv rshift amount
dblwordlv!1=((dblwordlv!1) rshift amount)+temp
]
resultis dblwordlv!1//low order 16 bits
]

and RpageToVpage(spruceFile, pageNumber) = valof
[
// The inverse, VpageToRpage, is in SpruceFilesMl.asm
// Given pageNumber within spruceFile’s superFile, determine its
// logical position within spruceFile. Do not complain if the
// result is larger than spruceFile.numPages (garbage for backwards file)
if pageNumber le 0 % pageNumber > spruceFile>>SPruceFile.maxPages then
SpruceError(2500)
let result = pageNumber - spruceFile>>SPruceFile.offSet
if result le 0 then result = result+spruceFile>>SPruceFile.maxPages
if spruceFile>>SPruceFile.backwards then
result = spruceFile>>SPruceFile.numPages+1-result
resultis result
]

and FillInNames(s, doc, file, pDocDir; numargs na) = valof
[
// Obtain creator and file name strings from press file
// s ne 0: s is a stream
// s eq 0: must open a stream on file
// results to proper places in doc>>DocG....
// returns 0 if all is well, else Spruce Error code
// if pDocDir arg is present, places Press Document Dir. pointer in @pDocDir
let pressLength = vec 1
let newStream = s eq 0
unless newStream do file = s>>SS.spruceFile
if (FileLeng(file, pressLength, charItem)&1) ne 0 resultis 611 // odd length file
if newStream then s = WindowCreateStream(file, ksTypeReadOnly)
let DocDir=FSGetX(PressRecordSize+3) // ~~ known to be size of file buffer, reduces thrashing
let result = valof
[
FileLeng(s>>SS.spruceFile, pressLength, wordItem)
DoubleSub(pressLength, table [ 0;PressRecordSize ])
if pressLength!0 ls 0 resultis 600

WindowSetPosition(s, pressLength)//Get to doc dir.
WindowReadBlock(s, DocDir, PressRecordSize)

unless DocDir>>DDV.Passwd eq PressPasswd resultis 602
if (lv doc>>DocG.CreatStr)>>STR.length eq 0 do// unless filled by Plist
[ MoveAndSuppress(lv doc>>DocG.CreatStr, lv DocDir>>DDV.CreatStr, size DocG.CreatStr/8) ]
compileif SpruceSw then [ // these are EL and DL, or something, in Sprint!!!
doc>>DocG.nParts = Max(DocDir>>DDV.nParts-1, 1) // est., for informing user,
doc>>DocG.waitTime = 1 // computing priority
if StringCompare(lv doc>>DocG.CreatStr, lv doc>>DocG.ByStr ) eq 0 do
[ (lv doc>>DocG.ByStr)>>STR.length = 0 ]// omit BY if same as FOR
]
DoubleCop(lv doc>>DocG.date, lv DocDir>>DDV.date)
MoveAndSuppress(lv doc>>DocG.FileStr, lv DocDir>>DDV.FileStr, size DocG.FileStr/8)
MoveAndSuppress(lv doc>>DocG.DateStr, lv DocDir>>DDV.DateStr, size DocG.DateStr/8)
resultis 0
]
if newStream then Closes(s)
test na ge 4 then @pDocDir = DocDir or FSPut(DocDir)
resultis result
]

and MoveAndSuppress(dStr, sStr, limit) be
[ // move up to limit chars from sStr to dStr, suppressing trailing blanks
let len = Min(limit-1, sStr>>STRING.length); unless len return
for i=len by -1 to 1 do [ len = i; unless sStr>>STRING.char↑i eq $*S break ]
MoveBlock(dStr, sStr, len/2+1)
dStr>>STRING.length = len
]

and Wss(s, str) be for i = 1 to str>>STRING.length do Puts(s, str>>STRING.char↑i)

// Error message extracter -- derived from SWAT.
// FindErrorMessage(errorVec, str, lenStr, fatal [true])
// spruceFile describes Spruce.Errors
// errorvec = a pointer to table [ errCode; p1; p2; p3; ... ]
// The result goes in str -- lenStr is length of str in words
// The high order bit of errcode is ignored
// -- so really error numbers run from 0 to 32000
//
// An error message in the file is:
// 1. An unsigned decimal number.
// 2. Optionally followed by C, M, or L (ignored)
// 3. Followed by a space.
// 4. Followed by the message text. To get a parameter formatted,
//give $
//followed by a single digit specifying the parameter # (1,2,...)
//followed by how to print (o=octal; d=decimal; s=BCPL string)
// 5. End the message text with $$
// This function quits after the first error message line. It returns the result
// "Unknown Error" if it does not locate the error code. It does not include
// a carriage return in the result. It quites early if str is not big enough.
// If fatal, include the error code in the message, along with the message itself.
// Always returns true, if it returns under its own power. An error procedure
//may substitute a false return

and FindErrorMessage(errorVec, str, lenStr, fatal; numargs na) = valof
[
if na<4 then fatal = true
let Quit(s) be [ Closes(s>>FSx.par1); FSPut(s); ReturnFrom(FindErrorMessage, true) ]
InitSpruceFile(ErrorFile, 1, 3)
let s= WindowCreateStream(ErrorFile, ksTypeReadOnly, charItem)
// set up memory stream for PutTemplate
let mS = FSGetX(lFSx, SpruceZone, 0)
mS>>FSx.puts = WindowWriteByte
mS>>FSx.putOverflow = Quit
mS>>FSx.par1 = s // save where Quit can get at it
SetupWindowStream(mS, str, 1, lenStr*2)
let errCode=errorVec!0𒿑
let found = false
str>>STR.length = lenStr*2-1
until Endofs(s) do
[
let n=0
let c=nil
let message=false
until Endofs(s) do
[
c=Gets(s)
test c ge $0 & c le $9 then n=n*10+c-$0 or break
]
if n eq errCode then
[
found=true
if fatal then PutTemplate(mS, "[$D] ", errCode) // Actual code causing err. -- for maint. personnel
while Endofs(s) eq 0 & c ne $*s do c = Gets(s)
until Endofs(s) do
[
c=Gets(s)
if c eq $*N break
test c eq $$ then
[
let i=Gets(s)
if i eq $$ then break//end of message
let spec = vec 1
spec!0 = 2 lshift 8 + $$
c = Gets(s)
compileif SprintSw then [ if c eq $f then [
let fn = errorVec!(i-$0)
test fn>>FN.face le 17
ifso
PutTemplate(mS, "$S$D($Dmi)$S",lv fn>>FN.name,MulDiv(fn>>FN.siz+3, 72, 2540), fn>>FN.siz, selecton fn>>FN.face into [ case 0: ""; case 1: "I"; case 2: "B"; case 3: "BI"; default: "?" ] )
ifnot //Funny TEX-style face
PutTemplate(mS,"$S$D($Dmi)",lv fn>>FN.name,(254-fn>>FN.face)/2,fn>>FN.siz)
if fn>>FN.rotation then PutTemplate(mS, "rot$D", fn>>FN.rotation/60)
loop
] ]
if c eq $F then c = $O // File call just prints file index in octal, for now
spec!1 = c lshift 8
PutTemplate(mS, spec, errorVec!(i-$0))
]
or Puts(mS, c)
]
break // from main search loop
]
until Endofs(s) % (c eq $$ & Gets(s) eq $$) do c = Gets(s)
]
unless found do Wss(mS,"Unknown Error")
str>>STR.length = CurrentPos(mS)-1
FSPut(mS)
Closes(s)
ResetSpruceFile(ErrorFile)
resultis true
]

compileif SprintSw then [

let Comment(str, insist) be
[
unless str & comments & commentFree return
if numComments ge maxComments then
[
unless insist return // stop with the comments already
numComments = maxComments-2 // throw out last two to make room
commentFree = comments!(maxComments-1)
Comment("... more problems not listed ...", true)
]
let len = str>>STR.length/2+1
let end = commentFree+len
if end > maxCommentWords+maxComments+1 return // out of space; throw up hands and quit
numComments = numComments+1
comments!numComments = commentFree
MoveBlock(comments+commentFree, str, len)
commentFree = end
]

and DisableComments() be commentFree = 0 // no more will be added

and EnableComments() be
[
comments = FSGetX(maxComments+maxCommentWords+1,SpruceZone, 0) // never released
numComments = -1
commentFree = maxComments+1
Comment("Problems encountered:") // now numComments = 0 -- won’t trigger unless >0
]

and EmergencyOver() be unless emergencyStorage do emergencyStorage = FSGet(EStorageSize)

and ChooseMailboxBin(char)=selecton ((char ge $a)&(char le $z)?char-$a+$A,char) into
[
case $A: 18
case $B: 17
case $C: 16
case $D: 15
case $E: 14
case $F: 13
case $G: 12
case $H: case $I: 11
case $J: case $K: 10
case $L: 9
case $M: 8
case $N: case $O: 7
case $P: case $Q: 6
case $R: 5
case $S: 4
case $T: case $U: case $V: 3
case $W: 2
case $X: case $Y: case $Z: 1
default: 0
]

] // SprintSw

compileif SpruceSw then [
let ForEach(q, proc, pArg) = valof
//[
//let nextElt = @q
//while nextElt do
// [
// let elt = nextElt
// nextElt = @nextElt
// let res = proc(elt, pArg)
// switchon res into
// [
// case 1: Dequeue(q); endcase
// case 2: Dequeue(q); FSPut(elt); endcase // assumes SpruceZone
// case 3: resultis elt
// // case 0:
// default: endcase
// ]
// ]
//resultis 0
//]
//
// ------------------------------------------------------
// and EvalEachEntry(v, proc, pArg) = valof
// ------------------------------------------------------
// Read each entry in SpoolVec into core, and then
//call proc for each entry in vector (similar to ForEach in SpruceUtils)
[
//should call swat if v ne sproullerq
let v = SpoolVec
if v!0 eq 0 then resultis 0// null vector
let s = WindowCreateStream(QueueFile, ksTypeReadWrite, wordItem, 4)
let len, pos = v!0, 1
[
if v!pos ne 0 then // null entry
[
//if v!pos ne pos then CallSwat("SpoolVec error")
ActOnEntry(v!pos, true, s)//read into core
let result = proc(printDoc, pArg)
switchon result into
[
case 1:
[
v!pos = 0
//printDoc>>DocG.invalid = true
//MoveBlock(v!pos, v!(pos+1), len - pos); pos = pos - 1
//ActOnEntry(v!pos, false, s)//save on disk
endcase
]
case 2:
[
v!pos = 0
printDoc>>DocG.invalid = true
//MoveBlock(v!pos, v!(pos+1), len - pos); pos = pos - 1
ActOnEntry(v!pos, false, s)//save on disk
endcase // assumes SpruceZone
]
case 3:
[
// clean up filestream
Closes(s)
ResetSpruceFile(QueueFile) // free disk buffers, invalidate file
resultis printDoc
]
default: endcase
]
]
pos = pos + 1

// Don’t reclaim if this is SpoolVec’s last entry
if pos le len then Reclaim()
] repeatwhile pos le len
// clean up filestream
Closes(s)
ResetSpruceFile(QueueFile) // free disk buffers, invalidate file
resultis 0
]

] // SpruceSw


// January 20, 1978 11:51 PM, vast reorg., share with SpruceUtilsRes
// February 22, 1978 5:36 PM, PageToPos bug!!!! v5.(2,5)
// March 11, 1978 1:54 PM, memory usage microoptimization
// May 9, 1978 11:15 AM, copy DDV.date into DocG.date
// May 15, 1978 10:04 PM, improve break page comments a lot
// September 1, 1978 10:48 AM, add code itself to result of FindErrorMessage
// September 4, 1978 3:25 PM, suppress trailing blanks in FillInNames
// September 5, 1978 8:58 PM, add estimaed nPages (nParts), initial waiting time in FillInNames
// September 18, 1978 9:53 AM, CreateFPRD -> SpruceInUtil
// September 22, 1978 2:26 PM, include message # in error message only if serious
// October 16, 1978 9:34 AM, modify interfaces for fast files
// October 19, 1978 11:16 AM, (Spruce only) FSInit adds segment between MoreLow and MoreHigh
//if MoreLow is non-zero -- an extra client-supplied hunk of memory
//(used in SpruceInstall to get memory for doing the installation -- ugh)
// October 24, 1978 1:34 PM, add emergency storage management
// November 10, 1978 2:28 PM, add $nf case to error message: font description
// July 31, 1979 10:59 AM, pare get ~~.d so dictionary won’t be too big
// August 7, 1979 3:51 PM, FillInNames: don’t get creator from pressfile if already filled in
// August 15, 1979 1:39 PM, omit By if same as creator (Spruce only)
// September 13, 1979 4:24 PM, fix it
// January 27, 1981 12:45 PM, added TEX-style faces to font error msg (Sprint only)
// January 28, 1981 12:45 PM, readjusted font error msg (Sprint only)
// February 5, 1981 10:49 AM, add bin chosing code from SprucePrinPenguin.sr