//MSYMOV.BCPL
//	Last edited: 20 December 1979

get "altofilesys.d"
get "disks.d"
get "streams.d"
get "mcommon.d"
get "mdecl.d"

external [
// OS
	Min; Zero; CallSwat; ActOnDiskPages; WriteDiskPages; sysDisk

// MINIT0
	@MBlock; EndStorage; Storage; BlockStoreFP

// MIDAS
	MidasSwat; Initialized

// MOVERLAY
	PeelOverlay

// MASM
	BinScan; SymbKeyComp; GetBodySize; @BlockTable
	Mag; MoveUp; VUsc; StrSize; SearchBlock; GetStorage

// MSYM
	GetBlock; FindFreeBlock; NextFreePage; @HeadBlock; @BHsize; Map

// MCMD
	DisplayError

// Defined here
	UpdateRcd; PutBlock; CleanUpBlocks
 
// Defined here for init only
	BlockUpdateRcd; MakeNewBlock; InitSymBlock
	@LastBlockAddr; @LastM1; @LastM2; @NextM
]

static [ @LastBlockAddr; @NextM = (size BH/16)+1
	@LastM1 = -(size BH/16); @LastM2 = -(size BH/16); NextFreePage = 1
	BlockBreak = -(BlockSize/4)
	PBCalls = 0; BSCalls = 0; DebugSym = false
]

//The initialization enters the nullstring (smaller than all others) and
//a max string into the symbol table, so that all symbols being
//inserted will be between two others already in the symbol table.
//Since symbols being inserted are ordinarily in alphabetically
//sorted order (as output by Micro), the parameters of the last symbol
//insertion are remembered and a quick check is made before embarking
//on a binary search.  The remembered stuff is as follows:
//  LastBlockAddr	the file page number of the last insertion
//  NextM		the index of the key following the last
//			insertion (in HeadBlock if < 0 else in block)
//  LastM1		the HeadBlock index for LastBlockAddr
//  LastM2		the block index for the last insertion
//Null 4th arg is artifact of call from MLOAD.
let UpdateRcd(Key,Body,BodySize,nil) be
[	let B = GetBlock(LastBlockAddr,SymKind,3)
	let Block = B>>BT.Core
	unless (SymbKeyComp(Block+Block!(-LastM2),Key) < 0) &
		(SymbKeyComp(Key,(NextM < 0 ? HeadBlock+HeadBlock!(-NextM),
			Block+Block!NextM)) < 0) do
	[ B = SetBlockIndices(Key)
	  Block = B>>BT.Core
	]
	B>>BT.Dirty = true
//BlockUpdateRcd returns true unless the block is full
	if not BlockUpdateRcd(Block,LastM2,Key,Body,BodySize) do
	[ BlockSplit(B,-LastM2)
	  unless BlockUpdateRcd(HeadBlock,LastM1,Block+Block!BHsize,
		lv LastBlockAddr,1) do MidasSwat(BadHeadUpdate)
	  B = SetBlockIndices(Key)
	  Block = B>>BT.Core
	  unless BlockUpdateRcd(Block,LastM2,Key,Body,BodySize) do
		MidasSwat(BadBlockUpdate)
	]
	LastM2 = LastM2 ge 0 ? -LastM2,LastM2-1
	NextM = -LastM2 eq Block>>BH.LastPntr ? (-Mag(LastM1)-1),(-LastM2+1)
]


and SetBlockIndices(Key) = valof
[	LastM1 = BinScan(HeadBlock,Key)
	let B = HeadBlock+HeadBlock!(Mag(LastM1))
	LastBlockAddr = B!(StrSize(B))
	B = GetBlock(LastBlockAddr,SymKind,3)
	LastM2 = BinScan(B>>BT.Core,Key)
	resultis B
]

// if M ge 0, updates record with index M
// if M < 0 , inserts a record following index -M
and BlockUpdateRcd(Block,M,Key,Body,BodySize) = valof
[	let KeySize = StrSize(Key)
	let RcdSize = KeySize + BodySize
	let Plast = Block>>BH.LastPntr
	let FirstR = Block>>BH.FirstRcd - RcdSize
	test M ge 0	//Match existing Key?
	ifso
	[ let Lim = Block!M
	  let OldBody = Block+Lim+KeySize
	  let OldSize = KeySize+(Block eq HeadBlock ? 1,GetBodySize(OldBody))
//Accept duplicate definitions silently
	  if OldSize eq RcdSize do
	    if VUsc(OldBody,Body,BodySize) eq 0 then resultis true
//Give error and allow user to ignore redefinition of memories & registers
	  if OldBody>>Symb.M.Type le RegSymb do
	  [ DisplayError(Key,"Ignore","Can't redefine mem/reg def ")
	    resultis true
	  ]
	  FirstR = FirstR+OldSize
//Return false if redefinition won't fit in block--BlockUpdateRcd will then
//be called again after the BlockSplit.
	  if FirstR le Plast+1 then resultis false
//****CHANGE HERE FOR D0****
	  if OldBody!0 ne Body!0 do	//Changing MemX?  ifso, query
	    DisplayError(Key,"Redefine")
//Squeeze out old block
	  MoveUp(Block+OldSize+Lim-1,Block+Lim-1,Lim-(FirstR+RcdSize-OldSize))
	  for I = BHsize to Plast do
	    if Block!I < Lim then Block!I = (Block!I)+OldSize
	]
	ifnot
	[ if FirstR le Plast+1 then resultis false
	  MoveUp(Block+Plast+1,Block+Plast,Plast+M)
	  M = -M + 1
	  Block>>BH.LastPntr = Plast+1
	]
	Block!M = FirstR
	let NewR = Block + FirstR
	MBlock(NewR, Key, KeySize)
	MBlock(NewR + KeySize, Body, BodySize)
	Block>>BH.FirstRcd = FirstR
	if DebugSym then ChkBlock(Block)
	resultis true
]


//Symbol table debugging procedure.
and ChkBlock(Block) be
	for I = BHsize to (Block>>BH.LastPntr)-1 do
	[ unless SymbKeyComp(Block+Block!I,Block+Block!(I+1)) < 0 do
		MidasSwat(BadSymOrder,Block,I,I+1)
	]

//Split Block by first freeing another block (via PutBlock if busy & dirty)
//and then copying part of the full block into the free one.  The M2 arg is
//the index of the greatest record le the one being inserted.
//Returns a pointer to the new block.
//**Note:  Algorithm must never leave an empty block.

and BlockSplit(B,M2) be
[	BSCalls = BSCalls+1
	let Block = B>>BT.Core
	let OB = MakeNewBlock(NPagesPerStandardBlock,SymKind,3,Block)
	let OtherBlock = InitSymBlock(OB,BlockSize)
//Interchange BlockAddr's.  Due to the interchange, we wind up
//updating the HeadBlock for the old block (but the new BlockAddr);
//have to init. LastBlockAddr so that the HeadBlock update works correctly.
	LastBlockAddr = OB>>BT.BlockAddr
	let X = B!1; B!1 = OB!1; OB!1 = X
//First sort Block into OtherBlock, so that the records will be in order,
//and compute the record at which to split the block.
//Then move the records above the split point back to Block, winding
//up with low addresses in OtherBlock, high in Block.
	let LastPntr,FirstRcd = Block>>BH.LastPntr,Block>>BH.FirstRcd
	let OrigLast,OrigFirstRcd,PR = LastPntr,FirstRcd,BlockSize
	for I = BHsize to OrigLast do
	[ let R = Block + (Block!I)		//Pointer to next record
	  let Size = StrSize(R)			//Key size
	  Size = Size+GetBodySize(R+Size)	//Record size
	  if ((I-PR) ge BlockBreak) & (I ge M2) then
	  [ LastPntr,FirstRcd,M2 = I-1,PR,BlockSize
	  ]
	  PR = PR-Size
	  MBlock(OtherBlock+PR,R,Size)		//Copy key & body
	  OtherBlock!I = PR			//Set new pointer
	]
	if PR ne OrigFirstRcd then MidasSwat(BlockSplitBug)
//Copy stuff beyond the split point back into Block.
	let NPtrs = OrigLast - LastPntr
	let NRcdWds = FirstRcd - OrigFirstRcd
	if (NPtrs eq 0) % (NRcdWds eq 0) then MidasSwat(BlockSplitBug)
	MBlock(Block+BlockSize-NRcdWds,OtherBlock+OrigFirstRcd,NRcdWds)
	MBlock(Block+BHsize,OtherBlock+LastPntr+1,NPtrs)
	let Y = BlockSize-FirstRcd
	for I = Block+BHsize to Block+NPtrs+(size BH/16 -1) do
	[ rv I = (rv I)+Y
	]
	Block>>BH.FirstRcd = BlockSize-NRcdWds
	Block>>BH.LastPntr = NPtrs +(size BH/16 - 1)
	OtherBlock>>BH.FirstRcd = FirstRcd
	OtherBlock>>BH.LastPntr = LastPntr
	if DebugSym do
	[ ChkBlock(Block); ChkBlock(OtherBlock)
	]
]

//Block file procedures

//If enough core is available, allocate a new block; otherwise, free an old
//block different from Block.  Return pointer to BlockTable entry.
and MakeNewBlock(NPages,Kind,Strategy,Block; numargs NA) = valof
[	if NA < 4 then Block = 0
	let Size = NPages*PageSize
	let NewB = 0
	if BlockTable!0 < MaxInCoreBlocks*(size BT/16) do
	[ while (EndStorage-Storage) le Size do
	  [ if not PeelOverlay() then break
	  ]
	  if (EndStorage-Storage) > Size do
	  [ BlockTable!0 = BlockTable!0+size BT/16
	    NewB = BlockTable+BlockTable!0
	    NewB>>BT.Core = GetStorage(Size)
	  ]
	]
	if NewB eq 0 then NewB = FindFreeBlock(Block,Strategy)
	NewB>>BT.Dirty = true
	NewB>>BT.BlockAddr = NextFreePage
	NewB>>BT.Kind = Kind
	NextFreePage = NextFreePage+NPages
	if NextFreePage ge MaxBlockPages then MidasSwat(SymTabOvf)
	resultis NewB
]


and InitSymBlock(B,Size) = valof
[	let Block = B>>BT.Core
	Block>>BH.LastPntr = size BH/16 - 1
	Block>>BH.FirstRcd = Size
	resultis Block
]


//Write Block on the disk.
and PutBlock(B) be
[	B>>BT.Dirty = 0		//Clear Dirty before writing
	let CAs,Core = vec NPagesPerStandardBlock,B>>BT.Core
	for I = 0 to NPagesPerStandardBlock-1 do
	[ CAs!I = Core; Core = Core+PageSize
	]
	let FirstPage = B>>BT.BlockAddr
	let LastPage = FirstPage+NPagesPerStandardBlock-1
//Fill in Map entries from previous valid one through FirstPage, if necessary
	if Map!FirstPage eq fillInDA do
	[ let firstpg,scratch = FirstPage-1,vec PageSize
	  until Map!firstpg ne fillInDA do firstpg = firstpg-1
	  if (FirstPage-1) ne ActOnDiskPages(sysDisk,0,Map,BlockStoreFP,
		firstpg,FirstPage-1,DCreadD,lv firstpg,DCreadD,scratch) do
			CallSwat()
	]
	if LastPage ne WriteDiskPages(sysDisk,CAs-FirstPage,Map,BlockStoreFP,
		FirstPage,LastPage) do CallSwat()
	PBCalls = PBCalls+1
]


//Write all dirty in-core blocks on symtab file (called after Load)
//HeadBlock and first one or two symbol blocks are also preserved by
//SaveState.  Hence, after starting Midas there are one or two dirty
//blocks in core and none on the disk (*Midas will crash if initialization
//overflows available core blocks*).
and CleanUpBlocks() be
[	if DebugSym then ChkBlock(HeadBlock)
	if Initialized then for I = 1 to BlockTable!0 by size BT/16 do
	[ let B = BlockTable+I
	  if B>>BT.Dirty ne 0 then PutBlock(B)
	]
]