// 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"
get "BcplFiles.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
	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
	CallersFrame
	Closes
	DefaultArgs
	Endofs
	FileLength
	Gets
	MoveBlock
	OpenFileFromFp
	Puts
	ReadBlock
	ReturnFrom
	SetBlock
	SetFilePos
	SysErr

  // SpruceFiles, SpruceStreams
	CurPosition
	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
	symsFile
	numComments
	sysDisk
	Verbose
	FSTrap
	SpruceZone; OverlayTop; PermanentBottom
	MoreLow; MoreHigh // (Spruce Only)
	]

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 FSInit() be
    [
    //Maximum size of an individual block is 32K. But we can give two blocks
    // to FS package.  They will never be merged.
    let len=PermanentBottom-OverlayTop-1
    let flen=len
    if Ugt(flen, #77776) then flen=#77776
    SpruceZone=InitializeZone(OverlayTop+1, flen, SysErr, ((DebugSystem&#10000) 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)
	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 
 [
	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&#77777
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 = CurPosition(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, backwards; numargs na) = 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)
	[
	if na ls 4 then backwards = false
	let direction = (backwards ? -1, 1)
	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, (backwards ? v!0, 1)
		[
		if v!pos ne 0 then 		// null entry
			[
			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:
					[
					Closes(s)							// clean up filestream
					ResetSpruceFile(QueueFile)	// free disk buffers, invalidate file
					resultis printDoc
					]
				default: endcase
				]
			]
		pos = pos + direction
		test backwards	// Don't reclaim if this is SpoolVec's last entry
			ifso	if pos ne 0 then Reclaim()
			ifnot	if pos le len then Reclaim()
		] repeatwhile (backwards ? (pos ne 0), (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
(635)\524b9B369b24B58b16B6b11B22b12B190b29B159b11B164b61B2414b23B212b286B8197b23B10b2B3b2B18b2B18b2B6b2B22b2B23b2B30b2B22b2B9b2B35b2B69b2B28b2B18b2B24b2B9b2B6b2B12b2B3b2B1b284B1b2B1b133B1b110B1b3B1b36B1b4B1b46B1b36B1b23B1b5B1b131B1b49B1b12B1b6B1b11B1b6B1b158B1b34B1b6B1b11B1b6B6b38B6b64B1b22B1b27B1b5B1b4B1b23B1b310B