//msymb.bcpl

get "mdecl.d"
get "streams.d"

external [
// OS
	CallSwat; DoubleAdd; MoveBlock; Zero
	Puts; Wss; Wns; ReadBlock; WriteBlock; OpenFile; Closes

// MASM
	BinScan; SymbKeyComp; GetBodySize; FindBlock; @BlockTable
	Mag; Min; MoveUp; StrSize; SearchBlock

// MIOC
	SimpleTexttoDVec

// MPARSE
	ParseAddress

// MMPRGN
	DoubleNeg

// MCMD
	DisplayError

// MINIT0
	BlockRecFP

// Overlay package
	IndexedPageIO

// STATE package
	GetStorage

// Machine dependent
	@MEMNAM

// Defined here
	EvalAText; SearchBlocks; FindInTable; TVtoString; UpdateRcd
	SaveRcdFile; @BHsize; @StringVec
 
// Defined here for init only
	MakeNewBlock; GetFreeBlock
	@HeadBlock; Map; BlockUpdateRcd; @LastBlockAddr; @NextM
	@LastM1; @LastM2; NextFreePage; PBCalls; GBCalls
]

manifest [ IndexedPageRead = 0; IndexedPageWrite = -1
	BlockSize = NPagesPerStandardBlock*PageSize
]

static
[	@StringVec	 // used by TVtoString to hold string
	@BHsize = size BH/16
	@HeadBlock; BlockBreak = -(BlockSize/4)
	@LastBlockAddr; @NextM = (size BH/16)+1
	@LastM2 = -(size BH/16); @LastM1 = -(size BH/16)
	NextFreePage = 1; PBCalls = 0; GBCalls = 0
	Map 
	DebugSym = false
	ChkBlockCount = 0
]

let EvalAText(TV, lvX, AVal, ifExpectMore) = valof
[	if TV!0 < rv lvX then resultis false
	let PV = vec 72; PV!0 = 72
	let Y = 1
	unless ParseAddress(TV, lvX, PV, lv Y) then resultis false
	let NmTV =  PV + 1			//TV for symbol
	let SgnTV = NmTV + NmTV!0 + 1		//TV for sign
	let OctTV = SgnTV + SgnTV!0 + 1	//TV for offset (octal)
	let SymbDef = vec size Symb/16
	let SizeSymbDef = nil
	unless FindInTable((NmTV!0 eq 0 ? "IM",TVtoString(NmTV)),SymbDef,
		lv SizeSymbDef) do resultis false
	let Oct = vec 2; SimpleTexttoDVec(OctTV,32,Oct)
	if (SgnTV!0 eq 1) & (SgnTV!1 eq $-) then DoubleNeg(Oct)
	NmTV!0 = Min(maxsymlen,NmTV!0)
	let SName = TVtoString(NmTV)
	MoveBlock(lv AVal>>AVal.SName,SName,(maxsymlen/2)+1)
	AVal>>AVal.X = SymbDef>>Symb.A.X
	AVal>>AVal.TypeStorage = MemTypeStorage
	MoveBlock(lv AVal>>AVal.Offset,Oct,2)
	switchon SymbDef>>Symb.A.Type into
	[ case MemSymb:
		AVal>>AVal.Sign = 0
		MoveBlock(lv AVal>>AVal.Addr,Oct,2)
		endcase

	  case RegSymb:
		AVal>>AVal.TypeStorage = RegTypeStorage
		endcase

	  case AddrSymb:
		AVal>>AVal.Sign = 1
		(lv AVal>>AVal.Addr)!0 = 0
		(lv AVal>>AVal.Addr)!1 = SymbDef>>Symb.A.A2
		DoubleAdd(lv AVal>>AVal.Addr,Oct)
		endcase

	  case LAddrSymb:
		AVal>>AVal.Sign = 1
		MoveBlock(lv AVal>>AVal.Addr,Oct,2)
		DoubleAdd(lv AVal>>AVal.Addr,lv SymbDef>>Symb.LA.A1)
		endcase

	  default: CallSwat()
	]
	test ifExpectMore
	  ifso if rv lvX le TV!0 then rv lvX = rv lvX + 1 // skip seperator
	  ifnot if rv lvX < TV!0 then resultis false
	resultis true
]

//Search all of the symbols to find the nearest address le a particular
//location in a particular memory.  Output the name and offset to the
//given stream.
and SearchBlocks(S,MemX,AVec,IMA; numargs NA) be
[	let Addr = AVec!1
	let BName = vec 20
	MoveBlock(BName,MEMNAM!MemX,StrSize(MEMNAM!MemX))
	let BOffset = vec 0; BOffset!0 = Addr
//Construct table of already-checked blocks
	let CheckedBlocks = vec 40; Zero(CheckedBlocks,40)
	let BlockAddr = nil
//Search in-core blocks first
	for I = 1 to BlockTable!0 do
	[ let Block = BlockTable!I
	  BlockAddr = Block>>BH.BlockAddr
	  if BlockAddr > 0 do
	  [ SearchBlock(Block,BOffset,BName,Addr,MemX)
	    CheckedBlocks!0 = CheckedBlocks!0 + 1
	    CheckedBlocks!(CheckedBlocks!0) = BlockAddr
	  ]
	]
//Now do not-in-core blocks
	for I = BHsize to HeadBlock>>BH.LastPntr do
	[ let Sym = HeadBlock+(HeadBlock!I)
	  BlockAddr = Sym!(StrSize(Sym))
	  for J = 1 to CheckedBlocks!0 do
	  [ if CheckedBlocks!J eq BlockAddr then goto NoChk ]
	  if FindBlock(BlockAddr) eq 0 do
	  [ SearchBlock(GetBlock(BlockAddr),BOffset,BName,Addr,MemX)
	    CheckedBlocks!0 = CheckedBlocks!0 + 1
	    CheckedBlocks!(CheckedBlocks!0) = BlockAddr
	  ]
NoChk:	]
	if (BOffset!0 ne 0) & (NA > 3) do
	[ let Disp = Addr-IMA
	  if (Disp ge -3) & (Disp le 3) do
	  [ test Disp eq 0
	    ifso [ Puts(S,$.); return ]
	    ifnot
	    [ test Disp > 0
	      ifso Wss(S,".+")
	      ifnot [ Wss(S,".-"); Disp = -Disp ]
	      Wns(S,Disp,0,8); return
	    ]
	  ]
	]
	Wss(S,BName)
	if BOffset!0 ne 0 do [ Puts(S,$+); Wns(S,BOffset!0,0,8) ]
]


//This has been hand-coded
//and SearchBlock(Block,BOffset,BName,Addr,MemX) be
//[	let LastPntr = Block>>BH.LastPntr
//	let Sym,SymSize,TypePtr,Offset = nil,nil,nil,nil
//	for I = BHsize to LastPntr do
//	[ Sym = Block+(Block!I)
//	  SymSize = StrSize(Sym)
//	  TypePtr = Sym+SymSize
//	  if (TypePtr>>Symb.A.Type eq AddrSymb) &
//		(TypePtr>>Symb.A.X eq MemX) do
//	  [ Offset = Addr - TypePtr>>Symb.A.A2
//	    if (Offset < BOffset!0) & (Offset ge 0) do
//	    [ MoveBlock(BName,Sym,SymSize); BOffset!0 = Offset ]
//	  ]
//	]
//]

//**long address case deimplemented
//	let AVec = vec 1
//	  switchon TypePtr>>Symb.A.Type into
//	  [
//default:	loop

//case AddrSymb:	if TypePtr>>Symb.A.X ne MemX then loop
//		AVec!0 = 0; AVec!1 = TypePtr>>Symb.A.A2
//		endcase

//case LAddrSymb: if TypePtr>>Symb.LA.X ne MemX then loop
//		MoveBlock(AVec,lv TypePtr>>Symb.LA.A1,2)
//		endcase
//	  ]
//	  DoubleAdd(AVec,NAddr); DoubleNeg(AVec)
//	  if (AVec!0 eq 0) & (AVec!1 < BOffset!1) do
//	  [ MoveBlock(BOffset,AVec,2)
//	    MoveBlock(BName,Sym,SymSize)
//	  ]
//	]
//]

// useful procedure

and TVtoString(TV) = valof	// can only form one string at a time
[	let Sn = 255
	if TV!0 < Sn then Sn = TV!0
	StringVec>>lh = Sn; StringVec>>rh = TV!1
	let X = 2; let Y = 1
	while X le Sn do
	[ StringVec!Y = (TV!X lshift 8) % (TV!(X+1) & #377)
	  Y = Y+1; X = X+2
	]
	if Sn & 1 eq 0 then StringVec!(Y-1) = StringVec!(Y-1) & #177400
	resultis StringVec
]


//These have been hand-coded

// Returns index of greatest record in block with key le Key
// if equal returns + index; if not equal returns - index
// assumes SymbKeyComp(K1, K2) roughly is "K1 - K2"
//and BinScan(Block, Key) = valof
//[	let k,l = BHsize,Block>>BH.LastPntr
//	let C = SymbKeyComp(Key, Block+Block!l)
//	if C ge 0 then resultis (C > 0 ? -l, l)
//Now know (symbol at k le Key) & (Key < symbol at l)
//	while k < l do
//	[ let m = (k+l) rshift 1
//	  C = SymbKeyComp(Key,Block+Block!m)
//	  if C eq 0 then resultis m
//	  test C < 0; ifso l = m; ifnot test k ne m
//	    ifso k = m; ifnot resultis -k
//	]
//	resultis -k
//]


//and SymbKeyComp(K1, K2) = valof  // "K1" - "K2"
//[	let N1, N2 = K1>>lh, K2>>lh
//	if N1 eq 0 then 
//	  resultis (N2 eq 0? 0, -1) // empty string preceeds all others
//	if N2 eq 0 then resultis +1 // empty string wins
//	let Dif = K1>>rh - K2>>rh
//	if Dif ne 0 then resultis Dif
//	let Nmin = (N1<N2? N1, N2)
//	let Xmax = (Nmin-1) rshift 1
//	for X = 1 to Xmax do
//	[ Dif = K1!X - K2!X; if Dif ne 0 then resultis Dif ]
//	if (Nmin & 1) eq 0 do
//	[ Xmax = Xmax+1; Dif = (K1!Xmax)<<lh - (K2!Xmax)<<lh
//	  if Dif ne 0 then resultis Dif
//	]
//	resultis N1 - N2
//]


and FindInTable(Key, Body, lvBodySize) = valof
[	let E = nil
	unless GetRcdLe(Key,lv E) do resultis false
//1st byte of record = nbytes in name
	let BPoint = E + StrSize(E)
	let N = GetBodySize(BPoint)
	if N < 0 then CallSwat()
	rv lvBodySize = N
	MoveBlock(Body,BPoint,N)
	resultis true
]

// GetRcdLe and UpdateRcd initially setup Block, M1, and M2 as follows:
//   Block points at in-core block containing the greatest symbol le Key
//   M1 is the index into HeadBlock for Block
//   M2 is pos. if the symbol already is in symtab, else it is
//	-pos. of greatest symbol le Key
// Since the initialization enters min & max strings in the table, and
// since BlockSplit never leaves an empty block, these are the only cases.

and GetRcdLe(Key, lvRcd) = valof
[	let M1 = BinScan(HeadBlock,Key)
	let Block = HeadBlock+HeadBlock!(Mag(M1))
	let BlockAddr = Block!(StrSize(Block))
	Block = FindBlock(BlockAddr)
	if Block eq 0 then Block = GetBlock(BlockAddr)
	let M2 = BinScan(Block,Key)
	rv lvRcd = Block + Block!(Mag(M2))
	resultis  M2 ge 0
]


//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 the 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
and UpdateRcd(Key,Body,BodySize) be
[	let Block = FindBlock(LastBlockAddr)
	while true do
	[ if Block ne 0 do	//Check for immediately after last symbol
	  [ if (SymbKeyComp(Block+Block!(-LastM2),Key) < 0) &
		(SymbKeyComp(Key,(NextM < 0 ? HeadBlock+HeadBlock!(-NextM),
			Block+Block!NextM)) < 0) then break
	  ]
	  LastM1 = BinScan(HeadBlock,Key)
	  Block = HeadBlock+HeadBlock!(Mag(LastM1))
	  LastBlockAddr = Block!(StrSize(Block))
	  Block = FindBlock(LastBlockAddr)
	  if Block eq 0 then Block = GetBlock(LastBlockAddr)
	  LastM2 = BinScan(Block,Key); break
	]
//BlockUpdateRcd returns true unless the block is full
	if not BlockUpdateRcd(Block,LastM2,Key,Body,BodySize) do
	[ Block = BlockSplit(Block,-LastM2)
	  LastBlockAddr = Block>>BH.BlockAddr
	  if Block>>BH.LastPntr < BHsize
		then CallSwat()
	  unless BlockUpdateRcd(HeadBlock,LastM1,Block + Block!BHsize,
		lv Block>>BH.BlockAddr,1)
	  do CallSwat("HeadBlock full")
	  LastM2 = BinScan(Block,Key)
	  unless BlockUpdateRcd(Block,LastM2,Key,Body,BodySize)
		do CallSwat()
	]
	LastM2 = -(Mag(LastM2))-1
	NextM = -LastM2 eq Block>>BH.LastPntr ? (-LastM1-1),(-LastM2+1)
]

// Local Procedures

// 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 OldSize = KeySize+(Block eq HeadBlock ? 1,
		GetBodySize(Block+Lim+KeySize))
BlUpT1:	  FirstR = FirstR + OldSize
	  if OldSize eq RcdSize do
	  [ MoveBlock(Block+Lim+KeySize,Body,BodySize)
	    Block>>BH.Dirty = true; resultis true
	  ]
	  if OldSize < 0 then CallSwat()
	  if FirstR le Plast+1 then resultis false
	  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
	MoveBlock(NewR, Key, KeySize)
	MoveBlock(NewR + KeySize, Body, BodySize)
	Block>>BH.FirstRcd = FirstR
	Block>>BH.Dirty = true
//	if DebugSym then ChkBlock(Block)
	resultis true
]

//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.

//The block managing algorithm uses all the available blocks.  When they
//are all dirty it cycles through the first two blocks repeatedly.
and BlockSplit(Block,M2) = valof
[	let OtherBlock = GetFreeBlock(FindFreeBlock(Block))
//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
	let V = vec size BH/16
	MoveBlock(V,OtherBlock,BHsize)	//Interchange block headers
	MoveBlock(OtherBlock,Block,BHsize)
	MoveBlock(Block,V,BHsize)
	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 Size < 0 then CallSwat()
	  if ((I-PR) ge BlockBreak) & (I ge M2) then
	  [ LastPntr,FirstRcd,M2 = I-1,PR,BlockSize ]
	  PR = PR-Size
	  MoveBlock(OtherBlock+PR,R,Size)	//Copy block
	  OtherBlock!I = PR			//New pointer
	]
	if PR ne OrigFirstRcd then CallSwat()
//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 CallSwat()
	MoveBlock(Block+BlockSize-NRcdWds,OtherBlock+OrigFirstRcd,NRcdWds)
	MoveBlock(Block+BHsize,OtherBlock+LastPntr+1,NPtrs)
	let X,Y = Block+NPtrs+(size BH/16 -1),BlockSize-FirstRcd
	for I = Block+BHsize to X 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
	OtherBlock>>BH.Dirty = true
//	if DebugSym then [ ChkBlock(Block); ChkBlock(OtherBlock)]
	resultis Block
]


//and ChkBlock(Block) be
//  for I = BHsize to (Block>>BH.LastPntr)-1 do
//  [ ChkBlockCount = ChkBlockCount + 1
//    let R1 = (Block!I) + Block
//    let R2 = (Block!(I+1)) + Block
//    ChkOrder(R1, R2)
// ]


// and ChkOrder(R1, R2) be
// 	unless
// 	  SymbKeyComp(R1, R2) < 0
// 	    do CallSwat("Bad KeyComp in RcdStore")
// ] 

// block file procedures

and GetFreeBlock(Block) = valof
[	if Block>>BH.Dirty then PutBlock(Block)
	let NPages = Block>>BH.NPages
	Block>>BH.BlockAddr = NextFreePage
	NextFreePage = NextFreePage + NPages
	if NextFreePage + 1 > MaxBlockPages
	  then CallSwat("Midas.Symtab overflowed")
	Block>>BH.LastPntr = size BH/16 - 1
	Block>>BH.FirstRcd = NPages * PageSize
	Block>>BH.Dirty = true
	resultis Block
]


//GetBlock is only called when the required block is not in core
and GetBlock(BlockAddr) = valof
[	let Block = FindFreeBlock(0)
	if Block>>BH.Dirty then PutBlock(Block)
	IndexedPageIO(Map,BlockAddr,Block,Block>>BH.NPages,IndexedPageRead)
	if Block>>BH.BlockAddr ne BlockAddr then CallSwat()
	GBCalls = GBCalls+1
	resultis Block
]


and PutBlock(Block) be
[	let NPages = Block>>BH.NPages
	if NPages ne NPagesPerStandardBlock then CallSwat()
	let BlockAddr = Block>>BH.BlockAddr
	if BlockAddr le 0 then CallSwat()
	Block>>BH.Dirty = false	//Clear Dirty before writing
	IndexedPageIO(Map, BlockAddr, Block, NPages, IndexedPageWrite)
	PBCalls = PBCalls+1
]


and FindFreeBlock(Block) = valof
[	for I = 1 to BlockTable!0 do
	[ let B = BlockTable!I
	  if not B>>BH.Dirty then [ if B ne Block then resultis B ]
	]
//All blocks are dirty
	resultis BlockTable!(BlockTable!1 ne Block ? 1,2)
]


//Used by initialization only
and MakeNewBlock(NPages) = valof
[	let Block = GetStorage(NPages*PageSize)
	Block>>BH.Dirty = false
	Block>>BH.NPages = NPages
	Block>>BH.BlockAddr = -1
	resultis Block
]

//Used before calling another subsystem to preserve the state of extra
//symbol blocks by writing them onto "Midas.SymTab".  The HeadBlock
//and the first two symbol blocks are preserved by SaveState, so they
//don't have to be preserved.
and SaveRcdFile() be
[	for I = 3 to BlockTable!0 do
	[ let Block = BlockTable!I
	  if Block>>BH.Dirty then PutBlock(Block)
	]
	BlockTable!0 = 2	//Undo initialization of extra blocks
]