// BLDR-BR.BCPL
// Copyright Xerox Corporation 1979, 1981
//  Swinehart, November 13, 1981  2:55 PM
//  Swinehart, June 20, 1977  10:00 PM

get "bldr.decl"

structure ADdrWord: [ ind bit 1; addr bit 15 ]
structure INstWord: [ blank bit 8; addr bit 8]

let READRELFILE(event, kind) be
  [	//PROCESS A NEW RELFILE
  if KSTATICCOUNT then [ CODEWARNING("Ignoring .BR file after .BK file"); return ]
  if kind eq $I then [ RELPAIRSW = true; LABLISTBASE = LABLIST!0*2 ]
  let RBASE=0
  let RFILE = FINDNEXTINPUTFILE(event)
  
  if BFILE>>BFile.codeLoc eq -1 then
	[ BFILE>>BFile.codeLoc = CODELOC
	BFILE>>BFile.maxCodeLoc = CODELOC
	]
  BFILE>>BFile.rFileCodeLoc = CODELOC
  
  PutTemplate(LSTREAM,"*T*T*T$6UO*N",CODELOC)
  let CODELOCSAVED = CODELOC
  
  let WARN = false
  if BFILEMODE eq 0 do
	[ if Usc(CODELOC , USERBOTTOM) ls 0 do
	  [ WARN = true; CODEWARNING(" IS BELOW USERBOTTOM") ]
	if BETWEEN(CODELOC, STATICSTART, STATICMAX) do
	  [ WARN = true; CODEWARNING(" OVERLAPS STATIC AREA") ]
	]
  
  RSTREAM = Openfile(RFILENUM,ksTypeReadOnly,wordItem)
  
    [
    RFILE>>RFile.codeLoc = BFILE>>BFile.rFileCodeLoc
    RFILE>>RFile.fileCode = BFILE>>BFile.rFileCodeLoc - BFILE>>BFile.codeLoc
    ReadBlock(RSTREAM,RHEAD,RHEADLENGTH)
    
    unless (RHEAD>>BRHeader.version rshift 8) eq (VERSION rshift 8) do 
  	ERROR("$S is incompatible with this version of BLDR*N", RFILENAME)
    
    SETBIPOS(RBASE+RHEAD>>BRHeader.namesAddr); READSTATICS()
    SETBIPOS(RBASE+RHEAD>>BRHeader.labelsAddr); READLABELS()
    SETBIPOS(RBASE+RHEAD>>BRHeader.codeAddr); READCODE()
    SETBIPOS(RBASE+RHEAD>>BRHeader.chainsAddr); READCHAINS()
    if RHEAD>>BRHeader.zChainsAddr then
	[ SETBIPOS(RBASE+RHEAD>>BRHeader.zChainsAddr); READZCHAINS() ]
    
    RFILE>>RFile.codeLength = RFILE>>RFile.codeLength+CODELENGTH
    
    let FIRSTKLUDGE=0

    if BFILE eq SFILE then [
	if BFILE>>BFile.rFileCodeLoc eq CODESTART then FIRSTKLUDGE = 1
	SETBOPOS(BSTREAM,
	  BFILE>>BFile.rFileCodeLoc-CODESTART+STARTCODEIMAGE-1+FIRSTKLUDGE) ]
    
    WriteBlock(BSTREAM, CODE+FIRSTKLUDGE, CODELENGTH-FIRSTKLUDGE)
    
    BFILE>>BFile.rFileCodeLoc = BFILE>>BFile.rFileCodeLoc + CODELENGTH
    if BFILE>>BFile.rFileCodeLoc gr BFILE>>BFile.maxCodeLoc then
	BFILE>>BFile.maxCodeLoc = BFILE>>BFile.rFileCodeLoc
    CODELOC = BFILE>>BFile.rFileCodeLoc
    RBASE=RBASE+RHEAD>>BRHeader.fileLength
    SetFilePos(RSTREAM,0,RBASE*2)
    if Endofs(RSTREAM) break
    ] repeat
  
  Closes(RSTREAM)
  
  PutTemplate(LSTREAM,"*T*T*T*T$6UO*T*T$6UO ($D)*N",
	CODELOC-1, CODELOC-CODELOCSAVED, CODELOC-CODELOCSAVED)
  
  if BFILEMODE eq 0 then
	[
	if Usc(CODELOC , COREMAX) gr 0  then CODEWARNING(" overlaps OS")
	if WARN eq 0 & BETWEEN(CODELOC-1, STATICSTART, STATICMAX) then
	  CODEWARNING(" overlaps static area")
	]
  ]

and SETBIPOS(idx) be SetFilePos(RSTREAM,0, idx lshift 1)

and FINDNEXTINPUTFILE(event) = valof
	[
	RFILE = event
	RFILENUM = RFILE>>RFile.fileNum
	RFILENAME = fileNameVec!RFILENUM

	rFileCount = rFileCount+1
	RFILE>>RFile.rFileId = rFileCount
	RFILE>>RFile.bFileId = BFILE>>BFile.bFileId
	PutTemplate(LSTREAM,"   $S$S",
		RFILENAME,(RFILENAME!0 rshift 8)+3 < 8? "*T","")
	resultis RFILE
	]

and READSTATICS() be
  [	//PROCESS THE STATICS IN THE CURRENT RELFILE
  let sym = vec lSYm
  let SYMSTRING = vec NAMELENGTH/2
  SYMLIST!0 = 0

  let N = Gets(RSTREAM)
  for I = 1 to N do [ // static entry
	sym>>SYm.rFile = RFILE
	let flags = Gets(RSTREAM)
	sym>>SYm.flags = (flags&#177760) // last 4 bits record "local"
	if (flags&#17) ne 0 then sym>>SYm.local = 1
	sym>>SYm.initialValue = Gets(RSTREAM)
	sym>>SYm.staticAddress = -1
	SYMSTRING!0 = Gets(RSTREAM)
	ReadBlock(RSTREAM,lv SYMSTRING!1,(SYMSTRING!0 rshift 8)/2)
	sym>>SYm.dictEntry = DICTENTRY(SYMSTRING)

	let entry, symType = SYMENTRY(sym, false), sym>>SYm.type
	test entry then [
	    entry>>SYm.jOnly = false
	    if sym>>SYm.z ne entry>>SYm.z then
		[ COMMONERROR(sym, entry); entry>>SYm.z = 1 ]
	    if symType > 0 & entry>>SYm.type > 0 then
		[ MULTDEFERROR(sym, entry); entry>>SYm.dupDef = true ]
	    ]
	  or entry = NEWSYMENTRY(sym)
	if symType > 0 then [ // defining symbol
	   if RELPAIRSW &symType > 1 then entry>>SYm.relocatable = true
	   unless entry>>SYm.dupDef do [
	      if BFILEMODE eq 1 & symType > 1 then entry>>SYm.initSwappedOut = true
	      entry>>SYm.initialValue = sym>>SYm.initialValue
	      entry>>SYm.rFile = sym>>SYm.rFile
	      entry>>SYm.type = symType ]
	   ]
	let P = SYMLIST!0 + 1
	SYMLIST!0 = P
	SYMLIST!P = entry
      ] // static entry
 ]

and READLABELS() be
[	//PROCESS THE LABELS IN THE CURRENT RELFILE
  let LFIRST = LABLIST!0*2 + 1
  let N = Gets(RSTREAM)
  for I = 1 to N do
    [	let ENTRY = SYMLIST!(Gets(RSTREAM))
	let PC = Gets(RSTREAM)
	let P = LABLIST!0*2 + 1
	LABLIST!0 = LABLIST!0 + 1
	LABLIST!(P+0) = ENTRY
	LABLIST!(P+1) = PC
	if ENTRY>>SYm.dupDef eq 0 then
		ENTRY>>SYm.initialValue = PC + RFILE>>RFile.codeLoc
      ]
  let LLAST = LABLIST!0*2 - 1
  if LISTLABSW do
[
    [	let PMIN = -1
	let PCMIN = CODEMAX
	for P = LFIRST to LLAST by 2 do
	 [  let PC = LABLIST!(P+1)
	    if (PC & #100000) eq 0 do
		if PC ls PCMIN do PMIN, PCMIN = P, PC
	  ]
	if PMIN eq -1 break
	PRINTSYM(LABLIST!PMIN)
	LABLIST!(PMIN+1) = LABLIST!(PMIN+1) + #100000
     ] repeat
  ]
  for P = LFIRST to LLAST by 2 do
    [	LABLIST!P = (LABLIST!P)>>SYm.staticAddress
	LABLIST!(P+1) = (LABLIST!(P+1) & #77777) + RFILE>>RFile.fileCode
     ]
 ]

and READCODE() be
[	//READ THE CODE IMAGE IN THE CURRENT RELFILE
  CODELENGTH = Gets(RSTREAM)
  if CODELENGTH gr CODEMAX do ERROR("RELFILE TOO BIG")

if ReadBlock(RSTREAM,CODE,CODELENGTH) ne CODELENGTH then
  ERROR("PREMATURE END OF FILE")
 ]

and READCHAINS() be
[	//PROCESS THE STATIC CHAINS IN THE CURRENT RELFILE
  let N, T = Gets(RSTREAM), nil
  for I = 1 to N do
    [	let PC = Gets(RSTREAM)
	let P = (I-1)*1 + 1
	let ENTRY = SYMLIST!P

	test not PC<<ADdrWord.ind
	  then while PC do
	    [	T   = CODE!PC
		CODE!PC = ENTRY>>SYm.staticAddress
		PC = T
	    ]
	  or  [	unless ENTRY>>SYm.z do ERROR("BUG #1")
		PC = PC<<ADdrWord.addr
		[ T  =  (CODE!PC)<<INstWord.addr
		  (CODE!PC)<<INstWord.addr = ENTRY>>SYm.staticAddress
		  PC = PC - T
		] repeatuntil T eq 0
	     ]
      ]
 ]


and READZCHAINS() be
[ let N, T = Gets(RSTREAM), nil
  for I = 1 to N do
    [	let ENTRY = SYMLIST!(Gets(RSTREAM))
	let PC = Gets(RSTREAM)<<ADdrWord.addr
	unless ENTRY>>SYm.z do ERROR("BUG #2")
	[ T  =  (CODE!PC)<<INstWord.addr
	  (CODE!PC)<<INstWord.addr = ENTRY>>SYm.staticAddress
	  PC = PC - T
	] repeatuntil T eq 0
     ]
 ]

and DICTENTRY(name, enterNew; numargs na) = valof
  [	// find name in DICT or enter it, or return false (depends on enterNew)
  if na eq 1 then enterNew = true
  let lN = name>>STRING.length
  if CASESW then for i = 1 to lN do
	name>>STRING.char↑i = CAPITALIZE(name>>STRING.char↑i)
  lN = lN rshift 1 // # words - 1
  let c = name>>STRING.char↑1 // hash character
  let bucket = CAPITALIZE(c)
  bucket = (bucket-$A)*2+(c eq bucket? 1, 2)
  if c eq $. then bucket = 1
  unless 0 le bucket & bucket le 26*2 do ERROR("Symbol $S invalid*N",name)
  let prevEnt, dictEnt = lv DICT!bucket, nil
  // comparison loop
	[
	dictEnt = @prevEnt
	unless dictEnt break // loop control
	let dictName = lv dictEnt>>DIct.name
	if valof [
		for i = 0 to lN do if dictName!i ne name!i resultis false
		resultis true ] resultis dictEnt
	prevEnt = dictEnt
	] repeat
  unless enterNew resultis false
  dictEnt = Zmem(offsetDIctName+lN+1)
  prevEnt>>DIct.link = dictEnt // join name to tail of bucket
  MoveBlock(lv dictEnt>>DIct.name,name,lN+1)
  resultis dictEnt
  ]

and SYMENTRY(sym) = valof
	[
	let name = sym>>SYm.dictEntry
	let nextEntry = name>>DIct.sym
	let isSymLocal = sym>>SYm.local
	while nextEntry do
	    [
	    let entry = nextEntry; nextEntry = @nextEntry
	    if isSymLocal ne entry>>SYm.local loop
	    unless isSymLocal resultis entry
	    // local, must appear in same .BR file
	    let symFile, entFile = sym>>SYm.rFile, entry>>SYm.rFile
	    if symFile eq entFile % (DUPSW &
	 	 fileNameVec!(symFile>>RFile.fileNum) eq
	 	 fileNameVec!(entFile>>RFile.fileNum) ) resultis entry
	    ]
	 resultis 0
	 ]

and NEWSYMENTRY(sym) = valof
	[
	let entry = Zmem(lSYm) // next three lines obsolete
	 SYMTAB!0 = SYMTAB!0 + 1
	 if SYMTAB!0 > SYMMAX then ERROR("Too many symbols")
	 SYMTAB!(SYMTAB!0) = entry
	MoveBlock(entry,sym,lSYm)
	let dict = entry>>SYm.dictEntry
	// join new sym to head of syms with same name
	entry>>SYm.link = dict>>DIct.sym
	dict>>DIct.sym = entry
 	if entry>>SYm.staticAddress ne -1 resultis entry
	test entry>>SYm.z then [ // page 0
		if COMMONLOC eq JCOMMONMIN then
			COMMONLOC = JCOMMONMAX+1
		entry>>SYm.staticAddress = COMMONLOC
		COMMONLOC = COMMONLOC + 1
		]
	or	[ // normal static
		if STATICLOC eq JSTATICMIN then
			STATICLOC = JSTATICMAX+1
		entry>>SYm.staticAddress = STATICLOC
		STATICLOC = STATICLOC + 1
     		]
	resultis entry
	]

and READJKFILE(event, kind) be
	[
	let RFILE = FINDNEXTINPUTFILE(event)
	Puts(LSTREAM,$*N)
	Closes(READJKSTATICS(Openfile(RFILENUM,ksTypeReadOnly,charItem), kind))
	]

and SKIPTO(STREAM, CHAR) = valof // ****
	[
	let KCHAR = nil
	KCHAR = Endofs(STREAM)? 1000, Gets(STREAM)
		repeatuntil KCHAR eq CHAR % KCHAR eq 1000
	resultis KCHAR
	]

and READJKSTATICS(STREAM, kind) = valof // returns STREAM
[	//PROCESS THE STATICS IN THE CURRENT .BJ or .BK FILE
let sym, entry = vec lSYm, nil
let SYMSTRING = vec NAMELENGTH/2
let GOTNAME, GOTOCTAL = 0, 0
let TYPE, RELOC = nil, nil
let BASE = 0
let KCHAR = $*C
  [CLOOP
  switchon KCHAR into
	    [CASES
  case $*S: case $*L: case $*T: endcase
  case $/: KCHAR = SKIPTO(STREAM, $*C)
  case 1000:
  case $*C:
  	if GOTNAME & GOTOCTAL then
  		[
  		let dict = DICTENTRY(SYMSTRING, kind ne $K)
  		sym>>SYm.dictEntry = dict
  		sym>>SYm.flags = 0
		if kind eq $H then TYPE = 0 // for /H
  		sym>>SYm.type = TYPE
  		sym>>SYm.relocatable = TYPE gr 1? RELOC, 0
  		sym>>SYm.rFile = RFILE
  		test kind eq $K
  			ifso if dict then PROCESSKSTATIC(sym)
  			ifnot PROCESSJSTATIC(sym)
  		]
	if KCHAR eq 1000 then break
  	sym>>SYm.initialValue, sym>>SYm.staticAddress = 0, -1
  	GOTNAME, GOTOCTAL = false, false
  	TYPE = kind eq $K? 2, 0
  	RELOC = 0
  	endcase
  case $0 to $7:
  	[
  	let I = 0
  	while BETWEEN(KCHAR,$0,$7+1) do
  		[
  		I = I lshift 3 + (KCHAR-$0)
  		KCHAR = Endofs(STREAM)? 1000, Gets(STREAM)
  		]
  	test GOTNAME
  	ifso	[
  		test kind ne $K
  		ifso unless GOTOCTAL then
			sym>>SYm.staticAddress = I+BASE
  		ifnot sym>>SYm.initialValue = I+BASE
  		GOTOCTAL = true
  		]
  	ifnot	[
  		BASE = I
  		if KCHAR ne $*C do KCHAR = SKIPTO(STREAM, $*C)
		endcase
  		]
  	loop
  	]
  default:
	[
  	if GOTNAME then
  		[
  		switchon KCHAR into
  			[
  		case $V:	TYPE = 1 ; endcase
  		case $P: TYPE = 2 ; endcase
  		case $L: TYPE = 3 ; endcase
  		case $R: RELOC = 1 ; endcase
  		default:	endcase
  			]
  		endcase
  		]
  	let I = 0
  	while BETWEEN(KCHAR,$a,$z+1) % BETWEEN(KCHAR,$A,$Z+1) %
			BETWEEN(KCHAR,$0,$9+1) do
  		[
  		I = I + 1
  		SYMSTRING>>STRING.char↑I = KCHAR
  		KCHAR = Endofs(STREAM)? 1000, Gets(STREAM)
  		]
  	if I eq 0 then endcase
  	SYMSTRING>>STRING.char↑(I+1) = 0
  	SYMSTRING>>STRING.length = I
  	GOTNAME = true
  	loop
  	]
      ]CASES
  KCHAR = Endofs(STREAM)? 1000, Gets(STREAM)
  ]CLOOP repeat
 resultis STREAM
 ]

and PROCESSJSTATIC(sym) be // ****
	[
	let entry = SYMENTRY(sym)
	let ADDR = sym>>SYm.staticAddress
  	sym>>SYm.z = BETWEEN(ADDR,1,#400)
	test entry
	ifso	[
		let OLDADDR = entry>>SYm.staticAddress
		if OLDADDR ne -1 & OLDADDR ne ADDR %
			sym>>SYm.type > 0 & entry>>SYm.type > 0 then
			 MULTDEFERROR(sym, entry, true)
		entry>>SYm.staticAddress = ADDR
		if sym>>SYm.type > 0 then
			entry>>SYm.rFile = RFILE // e.g., sym>>SYm.rFile
		]
	ifnot entry = NEWSYMENTRY(sym)
	entry>>SYm.jOnly = 1
	test BETWEEN(ADDR, COMMONSTART, COMMONMAX)
	ifso	[
		JCOMMONMIN = Umin(JCOMMONMIN, ADDR)
		JCOMMONMAX = Umax(JCOMMONMAX, ADDR)
		]
	ifnot if BETWEEN(ADDR, STATICSTART, STATICMAX) then
		[
		JSTATICMIN = Umin(JSTATICMIN, ADDR)
		JSTATICMAX = Umax(JSTATICMAX, ADDR)
		]
	]

and PROCESSKSTATIC(sym) be // ****
	[
	let entry = SYMENTRY(sym)
	if entry & not entry>>SYm.type & not entry>>SYm.jOnly then
		[
		entry>>SYm.initialValue = sym>>SYm.initialValue
		sym>>SYm.z = entry>>SYm.z
		entry>>SYm.flags = sym>>SYm.flags
		CODE ! KSTATICCOUNT = entry
		KSTATICCOUNT = KSTATICCOUNT + 1
		entry>>SYm.rFile = RFILE // e.g., sym>>SYm.rFile
		if LISTLABSW & sym>>SYm.type gr 1 then
			PRINTSYM(entry)
		]
	]