--File IntUtilities.mesa
--March 12, 1981 3:46 PM

DIRECTORY

ParserTypeDefs: FROM "ParserTypeDefs" USING
[Point, RemovePoint, Path, AppendPoint, CopyPath, PathLength, FreePath, FreeUserNode],

IntStorageDefs: FROM "IntStorageDefs" USING
[ObjectRecord, ObjectName, FetchObject, BBoxRecord, DeleteObject,
ReplaceObject, StoreObject, NilObjectName],

InlineDefs: FROM "InlineDefs" USING [LowHalf],

IntUtilityDefs: FROM "IntUtilityDefs",

IntSetsDefs: FROM "IntSetsDefs" USING
[EnumerateSet, FreeSet, InsertSet, StripSet, RemoveFromSet],

IntDefs: FROM "IntDefs" USING [SemanticError],

ParserErrorDefs: FROM "ParserErrorDefs" USING [ErrorType, Report];

IntUtilities: PROGRAM
IMPORTS ParserErrorDefs, IntDefs, IntStorageDefs, InlineDefs, ParserTypeDefs, IntSetsDefs
EXPORTS IntUtilityDefs =

BEGIN OPEN IntStorageDefs;

aScale, bScale: LONG CARDINAL;-- scale factors for DS
tooBigLong: LONG CARDINAL;-- largest number that can be scaled without overflow
tooBigInt: LONG INTEGER;
noScale: BOOLEAN;-- identity flag for scale
errorCount: CARDINAL;
warned: BOOLEAN;

TableSize: CARDINAL = 199;-- symbol table size
sTable: ARRAY [0..TableSize) OF ObjectName;

MaxMMStack: CARDINAL = 50;-- max depth minmax stack
left,right,bottom,top: ARRAY [1..MaxMMStack] OF LONG INTEGER;
mmPtr: CARDINAL;-- minmax stack pointer

InitUtilities: PUBLIC PROCEDURE RETURNS [BOOLEAN] =
BEGIN
i: CARDINAL;
FOR i IN [0..TableSize) DO sTable[i] ← IntStorageDefs.NilObjectName; ENDLOOP;
--sTable ← ALL[IntStorageDefs.NilObjectName];
mmPtr ← 0;
warned ← FALSE;
errorCount ← 0;
noScale ← TRUE;
RETURN[TRUE];
END;

FinishUtilities: PUBLIC PROCEDURE RETURNS [BOOLEAN] =
BEGIN
RETURN[TRUE];
END;

LogError: PUBLIC PROCEDURE [s: STRING] =
BEGIN OPEN ParserErrorDefs;
errorCount ← errorCount + 1;
Report[s,FatalSemantic];
ERROR IntDefs.SemanticError[];
END;

OKToContinue: PUBLIC PROCEDURE RETURNS [BOOLEAN] =
BEGIN
IF errorCount > 0 AND NOT warned THEN
BEGIN
warned ← TRUE;
ParserErrorDefs.Report["Fatal Semantic Errors Exist, Strange Results May Occur If You Proceed", Advisory];
RETURN [FALSE];
END
ELSE RETURN[TRUE];
END;

-- reentrant minimum/maximum stuff for finding bounding boxes
InitMM: PUBLIC PROCEDURE [x,y: LONG INTEGER] =
BEGIN
IF (mmPtr ← mmPtr+1) > MaxMMStack THEN
BEGIN
ParserErrorDefs.Report["InitMM: no stack space", FatalInternal];
RETURN;
END
ELSE
BEGIN
left[mmPtr] ← x; right[mmPtr] ← x;
bottom[mmPtr] ← y; top[mmPtr] ← y;
RETURN;
END;
END;

MinMax: PUBLIC PROCEDURE [x,y: LONG INTEGER] =
BEGIN
IF x > right[mmPtr] THEN right[mmPtr] ← x
ELSE BEGIN IF x < left[mmPtr] THEN left[mmPtr] ← x; END;
IF y > top[mmPtr] THEN top[mmPtr] ← y
ELSE BEGIN IF y < bottom[mmPtr] THEN bottom[mmPtr] ← y; END;
END;

Extent: PUBLIC PROCEDURE RETURNS [l,r,b,t: LONG INTEGER] =
BEGIN
RETURN [left[mmPtr],right[mmPtr],bottom[mmPtr],top[mmPtr]];
END;

DoneMM: PUBLIC PROCEDURE =
BEGIN
IF mmPtr = 0 THEN ParserErrorDefs.Report["DoneMM: empty stack", FatalInternal]
ELSE mmPtr ← mmPtr-1;
END;

-- kludge to effectively achieve StoreObject[@Constructor[...]] by
-- calling StoreObjectRecord[Constructor[...]]
StoreObjectRecord: PROCEDURE [object: ObjectRecord] RETURNS[ObjectName] = INLINE
BEGIN
RETURN[StoreObject[@object]];
END;

LinkObject: PUBLIC PROCEDURE [this,that: ObjectName] =
BEGIN
objRec: ObjectRecord;
FetchObject[this,@objRec];
WITH objRec SELECT FROM
STEntry => guts ← that;
Call => next ← that;
Box => next ← that;
MBox => next ← that;
Flash => next ← that;
Polygon => next ← that;
Wire => next ← that;
User => next ← that;
ENDCASE =>
ParserErrorDefs.Report["LinkObject Error", FatalInternal];
ReplaceObject[@objRec,this];
END;

-- redefine a bound symbol, return a new name
RedefineSymbol: PUBLIC PROCEDURE [symNumber: LONG CARDINAL] RETURNS [IntStorageDefs.ObjectName] =
BEGIN
oldObj: ObjectName;
oldObjRec: STEntry ObjectRecord;

oldObj ← LookUp[symNumber];
FetchObject[oldObj,@oldObjRec];

IF NOT (oldObjRec.defined AND oldObjRec.bound) THEN
BEGIN
ParserErrorDefs.Report["RedefineSymbol: cond not met", FatalInternal];
RETURN[NilObjectName];
END
ELSE
BEGIN
-- mark old one deleted, create new STEntry
oldObjRec.deleted ← TRUE;
ReplaceObject[@oldObjRec,oldObj];
FixUpAncestors[symNumber];
RemoveFromCBY[symNumber];-- this symbol calls no others (yet)
RETURN [LookUp[symNumber]];
END;
END;

-- union the aSet (modifying aSet) with bSet
Union: PROCEDURE [aSet,bSet: ObjectName] RETURNS [ObjectName] =
BEGIN OPEN IntSetsDefs;
Dummy: PROCEDURE [ignore: ObjectName,contents: LONG CARDINAL] RETURNS [BOOLEAN] =
BEGIN
aSet ← InsertSet[aSet,contents];
RETURN [FALSE];
END;
[] ← EnumerateSet[bSet,Dummy];
RETURN[aSet];
END;

--returns the set of ancestors for this STEntry
FindAncestors: PROCEDURE [sym: LONG CARDINAL] RETURNS [IntStorageDefs.ObjectName] =
BEGIN OPEN IntSetsDefs;
ans: ObjectName ← NilObjectName;
obj: ObjectName;
objRec: STEntry ObjectRecord;

-- union the ancestors with ans
UnionAncestors: PROCEDURE [ignore: ObjectName,symNumber: LONG CARDINAL] RETURNS [BOOLEAN] =
BEGIN
tempSet: ObjectName ← FindAncestors[symNumber];
ans ← Union[ans,tempSet];
FreeSet[tempSet];
RETURN [FALSE];
END;

obj ← LookUp[sym];
FetchObject[obj,@objRec];
ans ← Union[ans,objRec.cby];
[] ← EnumerateSet[objRec.cby,UnionAncestors];
RETURN [ans];
END;

--get ancestors for this STEntry, copy those that are bound
FixUpAncestors: PROCEDURE [symNumber: LONG CARDINAL] =
BEGIN OPEN IntSetsDefs;
aSet: ObjectName;-- set of ancestors that need copying

aSet ← FindAncestors[symNumber];
-- copy each ancestor in aSet, mark originals deleted, mark copies not bound
[] ← EnumerateSet[aSet,CopySymbol];
FreeSet[aSet];
END;

-- copy the guts list of a symbol (in reverse order for now)
CopyGuts: PROCEDURE [head: ObjectName] RETURNS [newHead: ObjectName] =
BEGIN
prev,curr,next: ObjectName;
currRec: ObjectRecord;

prev ← NilObjectName;
FOR curr ← head, next UNTIL curr = NilObjectName DO
FetchObject[curr,@currRec];
-- duplicate this object, link to last one stored
WITH foo:currRec SELECT FROM
Call =>
BEGIN
next ← foo.next;
foo.uniqueID ← NilObjectName;
foo.next ← prev;
END;
Wire =>
BEGIN OPEN ParserTypeDefs;
next ← foo.next;
foo.next ← prev;
END;
Flash =>
BEGIN
next ← foo.next;
foo.next ← prev;
END;
Polygon =>
BEGIN OPEN ParserTypeDefs;
next ← foo.next;
foo.next ← prev;
END;
Box =>
BEGIN
next ← foo.next;
foo.next ← prev;
END;
MBox =>
BEGIN
next ← foo.next;
foo.next ← prev;
END;
User =>
BEGIN
next ← foo.next;
foo.next ← prev;
END;
ENDCASE;
prev ← newHead ← StoreObject[@currRec];
WITH foo:currRec SELECT FROM
Wire => ParserTypeDefs.FreePath[foo.p];
Polygon => ParserTypeDefs.FreePath[foo.p];
User => ParserTypeDefs.FreeUserNode[foo.data];
ENDCASE;
ENDLOOP;
RETURN [newHead];
END;

-- copy a symbol, mark original deleted, mark copy not bound
CopySymbol: PROCEDURE [ignore: ObjectName,sym: LONG CARDINAL] RETURNS [BOOLEAN] =
BEGIN
old,new: ObjectName;
oldRec,newRec: STEntry ObjectRecord;

old ← LookUp[sym];
FetchObject[old,@oldRec];
IF NOT oldRec.bound THEN RETURN [FALSE];-- no need to copy
oldRec.deleted ← TRUE;
ReplaceObject[@oldRec,old];-- save original, now deleted
new ← LookUp[sym];-- create a new STEntry
FetchObject[new,@newRec];
newRec.defined ← TRUE;-- copy is defined
newRec.guts ← CopyGuts[oldRec.guts];-- copy contents
ReplaceObject[@newRec,new];-- save copy, not bound, bb not valid
RETURN [FALSE];
END;

DeleteSymbol: PUBLIC PROCEDURE [definedSet: ObjectName, n: LONG CARDINAL] RETURNS [ObjectName] =
BEGIN OPEN IntSetsDefs;
ancSet: ObjectName ← NilObjectName;-- set of ancestors

-- find ancestors, mark deleted
Delete: PROCEDURE [ignore: ObjectName,symNumber: LONG CARDINAL] RETURNS [BOOLEAN] =
BEGIN OPEN IntSetsDefs;
IF symNumber >= n THEN
BEGIN
tempSet,sym: ObjectName;
symRec: STEntry ObjectRecord;

tempSet ← FindAncestors[symNumber];
ancSet ← Union[ancSet,tempSet];
FreeSet[tempSet];

sym ← LookUp[symNumber];
FetchObject[sym,@symRec];
IF NOT symRec.defined THEN
BEGIN
ParserErrorDefs.Report["Delete: sym not defined", FatalInternal];
RETURN [TRUE];
END
ELSE symRec.deleted ← TRUE;-- mark deleted
IF NOT symRec.bound THEN-- free insides if not bound
BEGIN
FreeGuts[symRec.guts];
symRec.guts ← NilObjectName;
END;
ReplaceObject[@symRec,sym];
END;
RETURN [FALSE];
END;

[] ← EnumerateSet[definedSet,Delete];-- also creates ancSet
definedSet ← StripSet[definedSet,n];-- update the defined set
ancSet ← StripSet[ancSet,n];-- remove ancestors that will be deleted

[] ← EnumerateSet[ancSet,CopySymbol];-- delete and copy the bound ancestors
FreeSet[ancSet];
StripCBY[n];-- remove deleted symbols from cby sets
RETURN [definedSet];
END;

LookUp: PUBLIC PROCEDURE [symNumber: LONG CARDINAL] RETURNS [ObjectName] =
BEGIN
hAddr: CARDINAL = Hash[symNumber];

IF sTable[hAddr] = NilObjectName THEN
RETURN [sTable[hAddr] ← StoreObjectRecord[
ObjectRecord[STEntry[
bb: BBoxRecord[left:0,right:0,bottom:0,top:0],
bbValid: FALSE,
guts: NilObjectName,
symNumber: symNumber,
deleted: FALSE, expanded: FALSE, bound: FALSE, defined: FALSE,
overflow: NilObjectName, sameNumber: NilObjectName,
cby: NilObjectName]]]]
ELSE
BEGIN
cur,old: ObjectName;
curRec,oldRec: STEntry ObjectRecord;
FOR cur ← sTable[hAddr],curRec.overflow UNTIL cur = NilObjectName DO
FetchObject[cur,@curRec];-- get entry into core
IF curRec.symNumber = symNumber THEN-- found the right group
BEGIN
DO
IF curRec.deleted THEN
BEGIN
oldRec ← curRec; old ← cur;-- save contents,name
cur ← curRec.sameNumber;
IF cur = NilObjectName THEN EXIT ELSE FetchObject[cur,@curRec];
END
ELSE RETURN[cur];-- found an undeleted match
ENDLOOP;

-- all are deleted, so create a new one
oldRec.sameNumber ← StoreObjectRecord[
ObjectRecord[STEntry[
bb: BBoxRecord[left:0,right:0,bottom:0,top:0],
bbValid: FALSE,
guts: NilObjectName,
symNumber: symNumber,
deleted: FALSE, expanded: FALSE,
bound: FALSE, defined: FALSE,
overflow: NilObjectName, sameNumber: NilObjectName,
cby: curRec.cby]]];-- called by the same symbols as last deleted
ReplaceObject[@oldRec,old];-- save updated entry
RETURN[oldRec.sameNumber];
END
ELSE
BEGIN
oldRec ← curRec; old ← cur;-- save contents,name
END;
ENDLOOP;

-- no matching symbol numbers, so create a new one
oldRec.overflow ← StoreObjectRecord[
ObjectRecord[STEntry[
bb: BBoxRecord[left:0,right:0,bottom:0,top:0],
bbValid: FALSE,
guts: NilObjectName,
symNumber: symNumber,
deleted: FALSE, expanded: FALSE,
bound: FALSE, defined: FALSE,
overflow: NilObjectName, sameNumber: NilObjectName,
cby: NilObjectName]]];
ReplaceObject[@oldRec,old];-- save updated entry
RETURN[oldRec.overflow];
END;
END;

-- free the guts of a symbol
FreeGuts: PUBLIC PROCEDURE [head: IntStorageDefs.ObjectName] =
BEGIN OPEN IntStorageDefs, ParserTypeDefs;
temp,nextTemp: ObjectName;
tempRec: ObjectRecord;

FOR temp ← head, nextTemp UNTIL temp = NilObjectName DO
FetchObject[temp,@tempRec];-- get next object in symbol def
WITH foo:tempRec SELECT FROM
Call => nextTemp ← foo.next;
Wire =>
BEGIN OPEN ParserTypeDefs;
nextTemp ← foo.next;
FreePath[foo.p];
END;
Flash => nextTemp ← foo.next;
Polygon =>
BEGIN OPEN ParserTypeDefs;
nextTemp ← foo.next;
FreePath[foo.p];
END;
Box => nextTemp ← foo.next;
MBox => nextTemp ← foo.next;
User =>
BEGIN
nextTemp ← foo.next;
ParserTypeDefs.FreeUserNode[foo.data];
END;
ENDCASE;
DeleteObject[temp];
ENDLOOP;
END;

RemoveFromCBY: PROCEDURE [n: LONG CARDINAL] =
BEGIN
Proc: PROCEDURE [oldSet: ObjectName] RETURNS [ObjectName] =
BEGIN
RETURN [IntSetsDefs.RemoveFromSet[oldSet,n]];
END;
EnumerateCBYSets[Proc];
END;

StripCBY: PROCEDURE [n: LONG CARDINAL] =
BEGIN
Proc: PROCEDURE [oldSet: ObjectName] RETURNS [ObjectName] =
BEGIN RETURN [IntSetsDefs.StripSet[oldSet,n]]; END;
EnumerateCBYSets[Proc];
END;

EnumerateCBYSets: PROCEDURE [proc: PROCEDURE [ObjectName] RETURNS [ObjectName]] =
BEGIN
i: CARDINAL;
locRec: STEntry ObjectRecord;
outer,addr,next: ObjectName;

FOR i IN [0..TableSize) DO
FOR outer ← sTable[i], next UNTIL outer = NilObjectName DO
FetchObject[outer,@locRec];
next ← locRec.overflow;
addr ← outer;
-- grab an entry that is not deleted (or take the end of the list)
WHILE locRec.deleted AND locRec.sameNumber # NilObjectName DO
addr ← locRec.sameNumber;
FetchObject[addr,@locRec];
ENDLOOP;
locRec.cby ← proc[locRec.cby];
ReplaceObject[@locRec,addr];
ENDLOOP;
ENDLOOP;
END;

-- compare two shortnames
FastEqualString: PUBLIC PROCEDURE [s1,s2: STRING] RETURNS [BOOLEAN] =
BEGIN
IF s1.length > 4 OR s2.length > 4 THEN
ParserErrorDefs.Report["IntUtilities.FastEqualString Length Error",FatalInternal]
ELSE
SELECT s1.length FROM
0 => RETURN[s2.length=0];
1 => RETURN[s2.length=1 AND s2[0]=s1[0]];
2 => RETURN[s2.length=2 AND s2[1]=s1[1] AND s2[0]=s1[0]];
3 => RETURN[s2.length=3 AND s2[2]=s1[2] AND s2[1]=s1[1] AND s2[0]=s1[0]];
4 => RETURN[s2.length=4 AND s2[3]=s1[3] AND s2[2]=s1[2]
AND s2[1]=s1[1] AND s2[0]=s1[0]];
ENDCASE;
RETURN[FALSE];
END;

-- set up scale factors for DS
SetScale: PUBLIC PROCEDURE [a,b: LONG CARDINAL] =
BEGIN
IF a = 0 OR b = 0 THEN LogError["Illegal Scale Factor"];
IF a = b THEN noScale ← TRUE-- no need to do any computation
ELSE
BEGIN
aScale ← a; bScale ← b;
tooBigLong ← LAST[LONG CARDINAL]/aScale;
tooBigInt ← LAST[LONG INTEGER]/aScale;
noScale ← FALSE;
--IF ((aScale/bScale)*bScale) # aScale THEN
--ParserErrorDefs.Report["Scale Factor not an Integer, precision may be lost", Advisory];
END;
END;

-- scale a long cardinal by factors set up by a call to SetScale
ScaleLong: PUBLIC PROCEDURE [n: LONG CARDINAL] RETURNS [LONG CARDINAL] =
BEGIN
IF noScale THEN RETURN[n]
ELSE
BEGIN
IF n > tooBigLong THEN
BEGIN
LogError["Number Too Large to Scale"];
RETURN[LAST[LONG CARDINAL]];
END;
RETURN[(aScale*n)/bScale];
END;
END;

-- scale all the points in a path
ScalePath: PUBLIC PROCEDURE [s,d: ParserTypeDefs.Path] =
BEGIN OPEN ParserTypeDefs;
pt: Point;
-- scale all points in path
IF noScale THEN
BEGIN
CopyPath[s,d];
RETURN;
END
ELSE
THROUGH [1..PathLength[s]] DO
[,pt] ← RemovePoint[s];
AppendPoint[d,ScalePoint[pt]];
ENDLOOP;
END;

-- scale a point by factors set up by a call to SetScale
ScalePoint: PUBLIC PROCEDURE [p: ParserTypeDefs.Point] RETURNS [ParserTypeDefs.Point] =
BEGIN
temp: ParserTypeDefs.Point;
temp.x ← ScaleLongInt[p.x];
temp.y ← ScaleLongInt[p.y];
RETURN[temp];
END;

-- scale a long integer by factors set up by a call to SetScale
ScaleLongInt: PUBLIC PROCEDURE [n: LONG INTEGER] RETURNS [LONG INTEGER] =
BEGIN
IF noScale THEN RETURN[n]
ELSE
BEGIN
IF ABS[n] > tooBigInt THEN
BEGIN
LogError["Integer Magnitude Too Large to Scale"];
RETURN[IF n < 0 THEN FIRST[LONG INTEGER] ELSE LAST[LONG INTEGER]];
END;
RETURN[(aScale*n)/bScale];
END;
END;

-- private procedures
Hash: PROCEDURE [n: LONG CARDINAL] RETURNS [[0..TableSize)] = INLINE
BEGIN
RETURN[InlineDefs.LowHalf[n MOD TableSize]];
END;

END.