//MSYM.BCPL
//	5 May 1983

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

external [
// OS
	DefaultArgs; DoubleAdd; Zero; Min; OpenFile; CreateDiskStream; Puts
	ActOnDiskPages; sysDisk; CallSwat

// MINIT0
	@MBlock; BlockStoreFP

// MIDAS
	MidasSwat

// MASM
	BinScan; SymbKeyComp; GetBodySize; @BlockTable
	Mag; StrSize; SearchBlock; Wss; DoubleNeg; DummyCall1

// MIOC
	SimpleTexttoDVec; DWns; Wns

// MCMD
	ErrorExit

// MSYMOV
	PutBlock

// Machine dependent
	CertifyAV; @MEMNAM; @MEMCON; DefMemName; DefRadix; FastSearch

// Defined here
	EvalAText; SkipBlankToken; ChkToken; TVtoString
	SearchBlocks; FindInTable; GetBlock; FindFreeBlock; MapSymBlocks
	StreamFromTextName; QuickOpenFile; SetLengthHint
	@BHsize; @StringVec; Map
 
// Defined here for init only
	@HeadBlock; GBCalls; FileBlock; NQuickFiles
]

static
[	NQuickFiles = 0; FileBlock
	@StringVec	 // used by TVtoString to hold string
	@BHsize = size BH/16
	@HeadBlock; GBCalls = 0; NSearchCalls = 0
	Map 
]

//The args to the parse routines are
//	TV	a TextVec containing the text to be parsed
//	lvX	lv pointer into TV (TV!(rv lvX) is the next char)

let SkipBlankToken(TV, lvX) be
[	while ((rv lvX) le TV!0) & (TV!(rv lvX) eq $ ) do
	[ rv lvX = rv lvX + 1
	]
]


and KindofChar(C) = selecton C into
[	case $ : BlankToken
	case $+:
	case $-: SignToken
	case $(: LParToken
	case $): RParToken
	case $,: CommaToken
	case $.: DotToken
	case $':
	case $$:
	case $|:
	case $\:
	case $/:
	case $>:
	case $<:
	case $?:
	case $&:
	case $~:
	case $@: SymbToken
	case $#: MarkedOct
	case $!: MarkedDec
	case $%: MarkedHex
	default:
	  ((C < $0) % (C > $z)) ? OtherToken,
	    (C < $A ? (C le $7 ? OctToken,(C le $9 ? DecToken,OtherToken)),
	      (C le $Z ? (C le $F ? HexToken,SymbToken),
	        (C < $a ? OtherToken,SymbToken)
	      )
	    )
]


//1.  Skip leading blanks
//2.  Update rv lvSize with size of the token
//3.  Result is the kind of token--octal, decimal, hexidecimal, and
//    symbol tokens may be or'ed together so that the largest bit set
//    indicates the kind of token.
and ChkToken(TV,lvX,lvSize) = valof
[	SkipBlankToken(TV,lvX)
	let X = rv lvX
	let L = TV!0
	if X > L do
	[ rv lvSize = 0; resultis LimitToken
	]
	let Size = 1
	let Kind = KindofChar(TV!X)
	if Kind ge OctToken do
	[ let J = X+1
	  while J le L do
	  [ let Ch = TV!J
	    let K = KindofChar(Ch)
	    test K ge OctToken
	    ifso Kind = Kind % K
	    ifnot
//Must allow "-" to be SymbToken in names such as LOOP-COUNT, so kludge
//here allows "+" and "-" when not followed by decimal characters.
//**This isn't good for hex radix.
	    [ if (K ne SignToken) % ((J < L) & (TV!(J+1) le $9))
		then break
	      Kind = Kind % SymbToken
	    ]
	    J = J+1
	  ]
	  Size = J-X
	]
	rv lvSize = Size
	resultis Kind
]

//AVal is unmodified if the text is invalid
and EvalAText(TV,lvX,AVal,ifExpectMore,SName; numargs NA) = valof
[	if NA < 5 then SName = DefMemName
	let Radix = DefRadix
	if TV!0 < rv lvX then resultis false
	let TSize = nil
//Parse symbol
	let NmTV = vec 80
	let SymbDef = vec size Symb/16
	let SizeSymbDef = nil
	let Styp = ChkToken(TV,lvX,lv TSize)	//"Or" of types in token
	let Styp1 = Styp & (MarkedOct-1)
	if Styp1 < OctToken then resultis false
	//If symbol rather than number then overrule Default memname
	if (Styp1 ge SymbToken) %
	   ((Styp1 ge HexToken) & (Styp < MarkedHex) & (Radix < 16)) %
	   ((Styp1 ge DecToken) & (Styp < MarkedDec) & (Radix < 10)) do
	[ MBlock(NmTV+1,TV+(rv lvX),TSize); NmTV!0 = TSize
	  rv lvX = (rv lvX)+TSize
	  SName = TVtoString(NmTV)
	]
	unless FindInTable(SName,SymbDef,lv SizeSymbDef) do resultis false
	//**Storing into SName is a poor thing to do when SName is supplied
	//**by the caller.
	SName>>lh = Min(maxsymlen,SName>>lh)
//Parse offset
	let RegOrMemX = SymbDef>>Symb.A.X
	Radix = table [ 8; 10; 16; 8 ] !
		((MEMCON+RegOrMemX)>>MRType.DefRadix)
	let Num = vec 2
//Evaluate sequence of numbers & symbols connected by "+" and "-"
	let lastX = rv lvX
	[ Styp = ChkToken(TV,lv lastX,lv TSize)
	  if (Styp ne SignToken) & (Styp < OctToken) then break
	  lastX = lastX+TSize
	] repeat
	let Nlen = lastX-(rv lvX)
	test Nlen ne 0
	ifso
	[ MBlock(NmTV+1,TV+(rv lvX),Nlen)
	  NmTV!0 = Nlen
	  unless SimpleTexttoDVec(NmTV,32,Num,Radix) do resultis false
	  rv lvX = lastX
	]
	ifnot Zero(Num,2)
	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
	let SymbAddr = lv SymbDef>>Symb.LA.A1
	let Sign = 0
	let TypeStorage = MemTypeStorage
	switchon SymbDef>>Symb.A.Type into
	[ case RegSymb:
		TypeStorage = RegTypeStorage
		SymbAddr = 0; endcase
	  case MemSymb:
		SymbAddr = Num
		unless CertifyAV(SymbAddr,RegOrMemX) do resultis false
		endcase
	  case AddrSymb:
//**Awful kludge here to make Symb.A look like Symb.LA
		SymbAddr = SymbDef; SymbAddr!0 = 0
	  case LAddrSymb:
		DoubleAdd(SymbAddr,Num)
		unless CertifyAV(SymbAddr,RegOrMemX) do resultis false
		Sign = 1; endcase
	  default:
		MidasSwat(IllStorageType)
	]
	Zero(AVal,size AVal/16)
	unless SymbAddr eq 0 do
	[ MBlock(lv AVal>>AVal.Offset,Num,2)
	  MBlock(lv AVal>>AVal.Addr,SymbAddr,2)
	]
	AVal>>AVal.Sign = Sign
	MBlock(lv AVal>>AVal.SName,SName,(maxsymlen/2)+1)
	AVal>>AVal.TypeStorage = TypeStorage
	AVal>>AVal.X = RegOrMemX
	resultis true
]


and TVtoString(TV) = valof	// can only form one string at a time
[	let Sn = TV>>rh
	for X = 0 to Sn by 2 do
	[ StringVec!(X rshift 1) = (TV!X lshift 8) + (TV+X+1)>>rh
	]
	StringVec>>CV↑(Sn+1) = 0
	resultis StringVec
]


and QuickOpenFile(Name,ksType,Item) = valof
[	let EndP = (NQuickFiles-1)*lDV
	for I = 0 to EndP by lDV do
	[ if SymbKeyComp(Name,FileBlock!I) eq 0 then resultis
		CreateDiskStream(FileBlock+I+(offset DV.fp/16),ksType,Item)
	]
	resultis OpenFile(Name,ksType,Item)
]


and StreamFromTextName(TV,DotExt,ksType,ItemSize) = valof
[	let BFName = "Bad file name "
	if TV!0 > 0 do
	[ let TSize,X = nil,1
	  let Kind = ChkToken(TV,lv X,lv TSize)
	  if Kind ge HexToken do
	  [ for I = 1 to TSize do StringVec>>CV↑I = TV!I
	    unless Kind ge DotToken if DotExt>>rh eq $. then
		for I = 1 to DotExt>>lh do
	    [ TSize = TSize+1; StringVec>>CV↑TSize = DotExt>>CV↑I
	    ]
	    StringVec>>lh = TSize
	    let S = QuickOpenFile(StringVec,ksType,ItemSize)
	    if S ne 0 then resultis S
	    ErrorExit(BFName,StringVec)
	  ]
	]
	ErrorExit(BFName)
]


//**Temporary kludge until SetLengthHint is put in Sys.Bk**
and SetLengthHint(nil) be return

//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.  If the IMA arg is provided, AVec will be printed as
//".+3", ".-3" etc. if AVec is within 3 locations of IMA.  If MemNameP is
//omitted or true, AVec is printed as "memname val" when no address symbols
//are in the table, else just as "val".  Returns true if an address symbol
//is found & printed, false if not (in which case "memname val" or just
//"val" was printed).
and SearchBlocks(S,MemX,AVec,IMA,MemNameP,Radix,MaxOffset; numargs NA) = valof
[	DefaultArgs(lv NA,3,-1,true,DefRadix,#177777)
	NSearchCalls = NSearchCalls+1
	let Addr = AVec!1
	let BName = vec 20
	MBlock(BName,MEMNAM!MemX,StrSize(MEMNAM!MemX))
	let BOffset = vec 0; BOffset!0 = 77777B
//Don't search unless some hope of finding symbol
	if (MEMCON+MemX)>>MRType.MaybeAddresses ne 0 do
	[ let B = FastSearch(Addr,MemX)
	  test B ne 0
	  ifso SearchBlock(B,BOffset,BName,Addr,MemX)
	  ifnot MapSymBlocks(SearchBlock,0,BOffset,BName,Addr,MemX)
	]
	if (BOffset!0 ne 0) & (IMA > 0) do
	[ let Disp = Addr-IMA
	  if (Disp ge -3) & (Disp le 3) do
	  [ Puts(S,$.)
//Print Disp as a signed number unless it is 0
	    DWns(S,lv Disp,16,0,-Radix,1,0); resultis true
	  ]
	]
	test (SymbKeyComp(BName,MEMNAM!MemX) eq 0) %
		((MaxOffset ne #177777) & ((MaxOffset-BOffset!0) < 0))
	ifso
	[ if MemNameP do
	  [ Wss(S,BName); Puts(S,$ )
	  ]
	  DWns(S,AVec,32,0,Radix); resultis false
	]
	ifnot
	[ Wss(S,BName)
	  if BOffset!0 ne 0 do
	  [ Puts(S,$+); DWns(S,BOffset,16,0,Radix)
	  ]
	  resultis true
	]
]


//Apply Proc(B,A1,A2,A3,A4) to each symbol block
//**Overlapped disk reads and less block fragmentation improve this.
and MapSymBlocks(Proc,Strategy,A1,A2,A3,A4; numargs NA) be
[	let CheckedBlocks = vec MaxInCoreBlocks
	let BlockAddr,NCBlocks = nil,0
//Search in-core blocks first
	for I = 1 to BlockTable!0 by size BT/16 do
	[ let B = BlockTable+I
	  BlockAddr = B>>BT.BlockAddr
	  if (BlockAddr > 0) & (B>>BT.Kind eq SymKind) do
	  [ Proc(B,A1,A2,A3,A4)
	    NCBlocks = NCBlocks+1
	    CheckedBlocks!NCBlocks = 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 NCBlocks do
	    if CheckedBlocks!J eq BlockAddr then goto NoChk
	  Proc(GetBlock(BlockAddr,SymKind,Strategy),A1,A2,A3,A4)
NoChk:	]
]

//These have been hand-coded
//and SearchBlock(B,BOffset,BName,Addr,MemX) be
//[	let Block = B>>BT.Core
//	let LastPntr = Block>>BH.LastPntr
//	let Sym,SymSize,TypePtr,Offset = nil,nil,nil,nil
//	MemX<<lh = AddrSymb
//	for I = BHsize to LastPntr do
//	[ Sym = Block+(Block!I)
//	  SymSize = StrSize(Sym)
//	  TypePtr = Sym+SymSize
//	  if (TypePtr!0 eq MemX) do
//	  [ Offset = Addr - TypePtr>>Symb.A.A2
//	    if (Offset < BOffset!0) & (Offset ge 0) do
//	    [ MBlock(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
//		MBlock(AVec,lv TypePtr>>Symb.LA.A1,2)
//		endcase
//	  ]
//	  DoubleAdd(AVec,NAddr); DoubleNeg(AVec)
//	  if (AVec!0 eq 0) & (AVec!1 < BOffset!1) do
//	  [ MBlock(BOffset,AVec,2)
//	    MBlock(BName,Sym,SymSize)
//	  ]
//	]
//]

//FindInTable 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.
//FindInTable returns false if Key is not in the symbol table; otherwise
//it returns the symbol's BodySize (i.e., number of words in the body
//exclusive of the print name) and a copy of the Body.
and FindInTable(Key,Body,lvBodySize) = valof
[	let Block = HeadBlock+HeadBlock!(Mag(BinScan(HeadBlock,Key)))
	Block = (GetBlock(Block!(StrSize(Block)),SymKind,0))>>BT.Core
	let M2 = BinScan(Block,Key)
	if M2 < 0 then resultis false
	if (M2 < BHsize) % (M2 > Block>>BH.LastPntr) then
		MidasSwat(ImpBinScan,M2)
	let E = Block+Block!M2		//Pointer to symbol
	let BPoint = E+StrSize(E)	//Pointer to symbol body
	rv lvBodySize = GetBodySize(BPoint)
	MBlock(Body,BPoint,rv lvBodySize)
	resultis true
]


//Ensure that the block having BlockAddr as its record file address is in
//core, reading from the disk if necessary.  Return its BlockTable index.
//If the block is read from the disk, use Strategy to find a free block,
//avoiding replacing Block.
and GetBlock(BlockAddr,Kind,Strategy,Block; numargs NA) = valof
[	if BlockAddr le 0 then resultis 0
	for I = 1 to BlockTable!0 by size BT/16 do
	[ if (BlockTable+I)>>BT.BlockAddr eq BlockAddr then
		resultis BlockTable+I 
	]
	if BlockAddr ge MaxBlockPages then MidasSwat(BadBlockAddr)
	if NA < 4 do
	[ Block = 0
	  if NA < 3 then Strategy = 0
	]
	let B = FindFreeBlock(Block,Strategy)
//Build table with one core address per page of block
	let CAs,Core = vec NPagesPerStandardBlock,B>>BT.Core
	for I = 0 to NPagesPerStandardBlock-1 do
	[ CAs!I = Core; Core = Core+PageSize
	]
	let LastPage = BlockAddr+NPagesPerStandardBlock-1
	if LastPage ne ActOnDiskPages(sysDisk,CAs-BlockAddr,Map,BlockStoreFP,
		BlockAddr,LastPage,DCreadD) then CallSwat()
	B>>BT.BlockAddr = BlockAddr
	B>>BT.Dirty = 0
	B>>BT.Kind = Kind
	GBCalls = GBCalls+1
	resultis B
]

//Patterns of block reference seem to be as follows:
// (1)	A Ld, LdSyms, LdData, etc. has the following phases:
//	(a) Memory definition lookup (calls to FindInTable(..));
//	(b) Data words loaded (fill in VA and AA tables for IM words);
//	(c) Symbols loaded in alphabetical order;
//	(d) IMsym table built by scanning all symbol blocks and finding the
//	    greatest IM address le each VA.
// (2)	A Go, SS, etc. has the following phases:
//	(a) SearchBlocks(..) is called for the starting address; IMsym
//	    is used so that only one symbol block will have to be scanned.
//	(b) VA is transformed to AA to get starting address;
//	(c) AA is transformed to VA for break address;
//	(d) SearchBlocks(..) is called for the break address (uses IMsym);
//	(e) AA is transformed to VA for halt address;
//	(f) SearchBlocks(..) is called for the halt address (uses IMsym);
//	(g) Display update will generally do 3 AA to VA conversions.
// (3)	A+1, A-1 make one call to SearchBlocks(..).
// (4)	Examining new items on the display makes call on FindInTable(..)
//	which calls GetBlock(..) once.  In command files, there are
//	frequently a number of consecutive examines.
// (5)	Pretty-printing an IM word typically calls SearchBlocks(..)
//	twice for IM addresses and once for an RM address.

//These patterns suggest the following strategies for block replacement:
// (1)	The block replaced by a call from FindInTable(..) should be
//	a non-symbol block if possible.
// (2)	Non-IM calls of SearchBlocks(..) should prefer to replace non-symbol
//	blocks because repeated A+1 or A-1 actions occur sometimes.
// (3)	IM calls of SearchBlocks(..) should prefer to replace AA and VA
//	blocks; next best is another symbol block; worst is an IMsym block.
// (4)	While data words are loaded, both VA and AA blocks are needed to
//	build the VM, so prefer to replace other block types.  Also, VA
//	words are loaded in increasing order, so an earlier VA block is an
//	ideal choice.
// (5)	When symbols are loaded, it is best to replace VA and AA blocks,
//	which are no longer needed; earlier symbol blocks are the next
//	best choice, but a block being split cannot be replaced.
// (6)	At the end of a Ld, the IMsym blocks are created; VA and AA blocks
//	are the best choice for replacement, then symbol blocks different
//	from the one being scanned; finally IMsym blocks.
// (7)	LookUpAA is most importantly called in the context of a Go, SS,
//	Brk, UnBrk, etc., so the IMsym blocks should be avoided; a
//	different VA block from the one used is a good choice; an AA
//	block or symbol block is a mediocre choice.
// (8)	LookUpVA is called twice at the end of a Go, SS, etc. and usually
//	three more times to update TPC 20, TLINK 20, and OLINK 20 on the
//	display; VA blocks are the best choice for replacement; AA blocks
//	should be avoided for the display update case; an IMsym and then
//	a symbol block will be referenced next for the Go case.

//The algorithm need not distinguish dirty blocks from clean ones in
//deciding what block to replace.  Dirty blocks are written on the disk
//after a Ld so that PutBlock can be in the Load overlay, not resident.
//During the Ld, all in-core blocks are normally dirty.

//Return the BlockTable index of a free block different from Block.
//Block should be 0 when no reason to avoid any existing block.
and FindFreeBlock(Block,Strategy) = valof
[	let Sym,VA,AA,IM = 0,0,0,0
	for I = 1 to BlockTable!0 by size BT/16 do
	[ let B = BlockTable+I
	  if B>>BT.Core ne Block then switchon B>>BT.Kind into
	  [ case SymKind: Sym = B; endcase
	    case AAKind:  AA = B; endcase
	    case VAKind:  VA = B; endcase
	    case IMKind:  IM = B; endcase
	  ]
	]
	let BestB = selecton Strategy into
	[
//For FindInTable(..), non-IM calls to SearchBlocks(..)
	  case 0: FirstNZ(AA,VA,IM,Sym)
//IM calls of SearchBlocks(..), building IM symbol pointers, LookUpAA.
	  case 1: FirstNZ(VA,AA,Sym,IM)
	  case 2: FirstNZ(IM,Sym,VA,AA) //For AddToVM
	  case 3: FirstNZ(VA,AA,IM,Sym) //For UpdateRcd and BlockSplit
	  case 4: FirstNZ(VA,Sym,IM,AA) //For LookUpVA
	  default: -1
	]
	if BestB eq -1 do MidasSwat(UndefStrategy)
	if BestB eq 0 then MidasSwat(NoFreeBlock)
//Dirty blocks only occur during Ld, LdSyms, etc. actions, when MSYMOV
//is in core, so the PutBlock procedure will be resident then.
	if BestB>>BT.Dirty ne 0 then PutBlock(BestB)
	resultis BestB
]


and FirstNZ(A,B,C,D) = A ne 0 ? A,(B ne 0 ? B,(C ne 0 ? C,D))