//routesyms.bcpl

// Symbol table, storage allocation, and string utility module.

// last modified by McCreight, July 2, 1981 10:19 AM

get "route.defs"
get "streams.d"

static
[
hashtab = 0
hashtabLen = 251

objectZone
permanentZone
]

structure objectZone:
[

Allocate word
Free word
firstFree word
nFreeWords word
addedSpaceZone word
]

structure SB:
[

length word
pSbNext word
pSbPrevious word

]

structure zone:
[

Allocate word
Free word
OutOfSpaceRtn word
MalFormedRtn word
anchor @SB
rover word
minAdr word
maxAdr word
]


// N a m e e M a n a g e m e n t

let DefineNamee(str, type, Init, extraLength, duplicate; numargs na) = valof
[ //returns pointer to namee. Verifies new record if type<0. If duplicate
// is present and not false, then a new record is created even if it
// duplicates an existing (str, type) pair.

let realtype = type ls 0? -type, type
let nameeLen = selecton realtype into
[

case typeNet: size net/16
case typeIcinst: size icinst/16
case typeIctype: size ictype/16
case typeIcclass: size icclass/16
case typeOldinst: size oldinst/16
case typePgmsymbol: size pgmsymbol/16
case typeNull: size namee/16
default: CallSwat("Illegal namee type")

]+((na gr 3)? extraLength, 0)

let firstNamee = 0
let firstEmpty = nil

let name = DefineName(str, lv firstNamee, lv firstEmpty, nameeLen)
let namee = 0

unless firstEmpty do namee = FindNamee(name, type)

if namee eq 0 % (na ge 5 & duplicate ne false) then
[

namee = firstEmpty? firstNamee, Allocate(objectZone, nameeLen)
Zero(namee, nameeLen)
unless firstEmpty do namee>>namee.next = firstNamee>>namee.next
firstNamee>>namee.next = firstEmpty? lv name>>name.mark, namee
namee>>namee.type = realtype
if (na gr 2)&(Init ne 0) then Init(namee)

]
resultis namee

]

and MustFindNamee(string, type) = DefineNamee(string, type, Shucks)

and Shucks(namee) be CallSmartSwat("Undefined $S: $S",
selecton namee>>namee.type into
[

case typeNet: "net"
case typeIcinst: "IC position"
case typeIctype: "IC type"
case typeIcclass: "IC class/Trace-wired net/etc"
case typeOldinst: "old IC position"
case typePgmsymbol: "subroutine"
default: "confusion--call McCreight"

], FindNameesString(namee))

and TryFindingNamee(string, type) = valof
[

let name = TryFindingName(string)
resultis (name eq 0)? 0, FindNamee(name, type)

]

and MapNamees(type, Procedure) be
[

for i=0 to hashtabLen-1 do
[

let name = hashtab!i
while name ne 0 do
[

let namee = lv name>>name.firstNamee+
name>>name.nameString.length rshift 1

while @namee ne mark do
[

if namee>>namee.type eq type then Procedure(namee)
namee = namee>>namee.next

]
name = name>>name.next

]

]

]

and FindNameesString(namee) = FindNameesName(namee)+offset name.nameString/16

and FindNameesName(namee) = valof
[

while @namee ne mark do namee = @namee
resultis namee-offset name.mark/16

]

and FindNamee(name, type) = valof //returns namee if defined, else 0.
// Negative type means namee must not exist.
[

let realtype = type ge 0? type, -type

let namee = lv name>>name.firstNamee+
name>>name.nameString.length rshift 1
until @namee eq mark do
[

if namee>>namee.type eq realtype then
[

if type ls 0 then CallSwat("namee already defined")
resultis namee

]
namee = namee>>namee.next

]
resultis 0

]

// N a m e M a n a g e m e n t

and DefineName(str, pfirstNamee, pfirstEmpty, nameeLen; numargs na) = valof
[

let strExtraWords = (str>>str.length) rshift 1
let name = TryFindingName(str)
if na ls 4 then
[

if name ne 0 then resultis name
DefineNamee(str, typeNull)
resultis TryFindingName(str)

]

test name eq 0
ifnot @pfirstEmpty = false
ifso
[

@pfirstEmpty = true
name = Allocate(objectZone, offset name.firstNamee/16+strExtraWords+
nameeLen)
let h = Hash(str) //place in symbol table for this string
name>>name.next = @h
@h = name
name>>name.mark = -1
MoveBlock(lv name>>name.nameString, str, 1+strExtraWords)

]
@pfirstNamee = lv name>>name.firstNamee+strExtraWords
resultis name

]

and TryFindingName(str) = valof //returns name if defined, else 0
[

let name = @(Hash(str))
until name eq 0 do
[

if StComp(str,lv(name>>name.nameString)) eq 0 then resultis name
name = name>>name.next

]
resultis 0

]

and Hash(str) = valof
[

let r = 0
for i = 1 to str>>str.length do r = r+(str>>str.char↑i)
if hashtab eq 0 then
[

hashtab = Allocate(SilZone, hashtabLen)
Zero(hashtab,hashtabLen)

]
resultis hashtab + (r rem hashtabLen)

]

// S t o r a g e M a n a g e m e n t

and SetupSpace() be
[

permanentZone = Allocate(SilZone, size objectZone/16)
permanentZone>>objectZone.Allocate = AllocatePermanent
permanentZone>>objectZone.Free = FreePermanent

objectZone = Allocate(SilZone, size objectZone/16)
objectZone>>objectZone.Allocate = AllocateObject
objectZone>>objectZone.Free = FreeObject
objectZone>>objectZone.nFreeWords = 0
objectZone>>objectZone.addedSpaceZone = permanentZone

]

and AllocateObject(objectZone, length) = valof
[

manifest [ chunksize = 512 ; objectThreshold = chunksize/10 ]

if length gr objectThreshold then resultis
Allocate(objectZone>>objectZone.addedSpaceZone, length)

let nFreeWords = objectZone>>objectZone.nFreeWords
if length gr nFreeWords then
[

let actualspace = nil
let blocksize = chunksize
let block = Allocate(objectZone>>objectZone.addedSpaceZone, blocksize, lv actualspace)
if block eq empty then
[

blocksize = (length gr actualspace)? length,actualspace
block = Allocate(objectZone>>objectZone.addedSpaceZone,
blocksize)

]
objectZone>>objectZone.firstFree = block
objectZone>>objectZone.nFreeWords = blocksize
nFreeWords = blocksize

]
nFreeWords = nFreeWords-length
let result = objectZone>>objectZone.firstFree+nFreeWords
objectZone>>objectZone.nFreeWords = nFreeWords
resultis result

]

and FreeObject(objectZone, object) = CallSwat("Can’t free object")

and AllocatePermanent(zone, length, returnOnNoSpace; numargs na) = valof
[

if na ls 3 then returnOnNoSpace = false
zone = SilZone
Allocate(zone, #77777, true) // coalesce free blocks
let origRover = zone>>zone.rover
let lowestFittingBlock = -1
let biggestBlockLength = -1
let rover = origRover
[

if Usc(rover>>SB.length,biggestBlockLength) gr 0 then
biggestBlockLength = rover>>SB.length
if Usc(rover>>SB.length, length) le 0 then loop
if Usc(rover, lowestFittingBlock) ge 0 then loop
lowestFittingBlock = rover

] repeatwhile valof
[

rover = rover>>SB.pSbNext
resultis rover ne origRover

]

if lowestFittingBlock eq -1 then
resultis Allocate(zone, length, returnOnNoSpace)

zone>>zone.rover = lowestFittingBlock
let blocksize = lowestFittingBlock>>SB.length
let block = Allocate(zone, blocksize-1) // get the rover block
let remaindersize = blocksize-length-1
if remaindersize ge size SB/16 do
[

let remainder = block+length
remainder>>SB.length = -remaindersize
(block-1)>>SB.length = -(length+1)
Free(zone, remainder+1)

]
resultis block

]

and FreePermanent(zone, block) be
[

CallSwat("Warning - freeing storage declared as permament")
Free(SilZone, block)

]

// S t r i n g R o u t i n e s

and StComp(s1,s2) = valof //string compare. Returns magnitude 3 if strings are
// different, magnitude 2 if one is a prefix of another, 1 if capitalizations are
// different.
[

let ls1 = s1>>str.length
let ls2 = s2>>str.length
let s1wins = 0
for i = 1 to ((ls1 ls ls2)? ls1, ls2) do
[

let c1 = s1>>str.char↑i
let c2 = s2>>str.char↑i
if c1 eq c2 then loop
if ((c1 xor c2)&($A eqv $a)) ne 0 then
resultis ((c1%($A xor $a)) gr (c2%($A xor $a)))? 3, -3
if s1wins ne 0 then loop
s1wins = ((c1 ge $A)&(c1 le $Z))? 1, -1

]
if ls1 ne ls2 then resultis (ls1 gr ls2)? 2, -2
resultis s1wins

]

and Wss(stream,string) be
[

for i = 1 to string>>str.length do Puts(stream,string>>str.char↑i)

]

and AppendC(string,char) be
[

if char gr 255 then CallSwat() // somebody got arguments reversed
let st = string>>str.length+1
string>>str.char↑st = char
string>>str.length = st

]

and ExpandTemplate(str, template, p1, p2, p3, p4, p5, p6, p7, p8; numargs na) = valof
[

static [ string; stringlength ]
let LocalPuts(stream, item) be
[

stringlength = stringlength+1
string>>str.char↑stringlength = item

]
string = str
stringlength = 0
PutTemplate(lv LocalPuts-offset ST.puts/16, template, p1, p2, p3, p4, p5, p6, p7, p8)
str>>str.length = stringlength
resultis str

]

and CopyString(source, dest) be
[

for i=1 to source>>string.length do dest>>string.char↑i = source>>string.char↑i
dest>>string.length = source>>string.length

]

and OffsetLegal(x, modulus, min, max) = valof
[

if x ls 0 then resultis false
if x rem modulus ne 0 then resultis false
x = x/modulus
resultis (x ge min)&(x le max)

]

// E r r o r R e p o r t i n g R o u t i n e s

and Remark(Template, p1, p2, p3, p4, p5, p6; numargs na) be
[

PutTemplate(ErFile, Template, p1, p2, p3, p4, p5, p6)

]

and Warning(Template, p1, p2, p3, p4, p5, p6; numargs na) be
[

if worstErrorLevel ls warning then worstErrorLevel = warning
PutTemplate(ErFile, Template, p1, p2, p3, p4, p5, p6)

]

and Serious(Template, p1, p2, p3, p4, p5, p6; numargs na) be
[

if worstErrorLevel ls serious then worstErrorLevel = serious
PutTemplate(ErFile, Template, p1, p2, p3, p4, p5, p6)

]

and Disaster(Template, p1, p2, p3, p4, p5, p6; numargs na) be
[

PutTemplate(ErFile, Template, p1, p2, p3, p4, p5, p6)
TruncateDiskStream(ErFile)
Resets(ErFile)
Gets(ErFile)
Puts(ErFile, $0+disaster)
Closes(ErFile)
finish

]

and CallSmartSwat(Template, p1, p2, p3, p4, p5, p6; numargs na) be
[

let message = vec 100
ExpandTemplate(message, Template, p1, p2, p3, p4, p5, p6)
CallSwat(message)
]

//B i t V e c t o r R o u t i n e s

and GetBit(vector, index) = 1 & ((vector!(index rshift 4)) rshift (index & #17))

and SetBit(vector, index, value) be
[

let shift = index & #17
let newMask = (value & 1) lshift shift
let oldMask = -1 - (1 lshift shift)
let wordIndex = index rshift 4
vector!wordIndex = (vector!wordIndex & oldMask) % newMask

]