ThreeC4PrimImpl1:
CEDAR
PROGRAM
IMPORTS ThreeC4BaseDecl1Def, Convert, IO, Rope, ThreeC4Support, ThreeC4PrimImplDefs, ProcessProps
EXPORTS ThreeC4BaseDecl1Def, ThreeC4CProdAbGramDef, ThreeC4PrimImplDefs =
BEGIN OPEN ThreeC4BaseDecl1Def, ThreeC4PrimImplDefs, ThreeC4CProdAbGramDef, ThreeC4Support, ProcessProps;
-- some basic stuff
IntegerNode: TYPE = REF IntegerNodeBody;
IntegerNodeBody: PUBLIC TYPE = RECORD[data: INT, error: BOOLEAN ← FALSE];
IntegerFromRope: PUBLIC PROC[rope: Rope.ROPE] RETURNS[IntegerNode] =
{RETURN[NEW[IntegerNodeBody←[Convert.IntFromRope[rope]]]]};
Add1: PUBLIC PROC[arg: IntegerNode] RETURNS[IntegerNode] =
{RETURN[IF IsErrorInteger[arg] THEN BuildErrorInteger[] ELSE NEW[IntegerNodeBody←[arg.data+1]]]};
Add1ToInt: PUBLIC PROC[arg: INT] RETURNS[INT] = {RETURN[arg+1]};
Add: PUBLIC PROC[arg1, arg2: IntegerNode] RETURNS[IntegerNode] =
{RETURN[IF IsErrorInteger[arg1] OR IsErrorInteger[arg2] THEN BuildErrorInteger[] ELSE NEW[IntegerNodeBody←[arg1.data+arg2.data]]]};
FakeCopyInt: PUBLIC PROC[arg: INT] RETURNS[INT] = {RETURN[arg]};
EqualTreeCallFlags: PUBLIC PROC[f1, f2: TreeCallFlag] RETURNS[BOOLEAN] =
{RETURN[f1 = f2]};
AndLogical: PUBLIC PROC[b1, b2: BOOLEAN] RETURNS[BOOLEAN] =
{RETURN[b1 AND b2]};
Or: PUBLIC PROC[b1, b2: BOOLEAN] RETURNS[BOOLEAN] =
{RETURN[b1 OR b2]};
FakeCopyInteger: PUBLIC PROC[i1: IntegerNode] RETURNS[IntegerNode] =
{RETURN[i1]};
EqualInteger: PUBLIC PROC[i1, i2: IntegerNode] RETURNS[BOOLEAN] =
{RETURN[IF IsErrorInteger[i1] OR IsErrorInteger[i2] THEN TRUE ELSE i1.data = i2.data]};
RopeFromRopeNode: PUBLIC PROC[r: RopeNode] RETURNS[Rope.ROPE] =
{RETURN[r.text]};
RopeFromNonNegIntegerNode: PUBLIC PROC[n: NonNegIntegerNode] RETURNS[Rope.ROPE] =
{RETURN[n.text]};
RopeFromIdentifierNode: PUBLIC PROC[id: IdentifierNode] RETURNS[Rope.ROPE] =
{RETURN[id.text]};
ConcatRopes2: PUBLIC PROC[r1, r2: Rope.ROPE] RETURNS[Rope.ROPE] =
{RETURN[Rope.Concat[r1, r2]]};
EqualRopes: PUBLIC PROC[r1, r2: Rope.ROPE] RETURNS[BOOLEAN] =
{RETURN[Rope.Equal[r1, r2]]};
GetIntegerData: PUBLIC PROC[i: IntegerNode] RETURNS[INT] =
{RETURN[i.data]};
BuildInteger: PUBLIC PROC[i: INT] RETURNS[IntegerNode] =
{RETURN[NEW[IntegerNodeBody←[i]]]};
AddOneToInt: PUBLIC PROC[i: INT] RETURNS[INT] =
{RETURN[i+1]};
Check: PUBLIC PROC[b: BOOLEAN] RETURNS[BOOLEAN] =
{IF b THEN RETURN[TRUE] ELSE ERROR};
BuildErrorInteger: PUBLIC PROC RETURNS [IntegerNode] =
{RETURN [NEW[IntegerNodeBody ← [0, TRUE]]]};
IsErrorInteger: PUBLIC PROC [i: IntegerNode] RETURNS [BOOLEAN] =
BEGIN
RETURN [i # NIL AND i.error];
END;
EqualIntervalForm: PUBLIC PROC[f1, f2: IntervalForm] RETURNS[BOOLEAN] =
{RETURN[f1=f2]};
-- Name stuff
NameNode: TYPE = REF NameNodeBody;
NameNodeBody: PUBLIC TYPE = RECORD[
id1: IdentifierNode,
id2: IdentifierNode,
text: Rope.ROPE,
codeText: Rope.ROPE,
key: INT,
next: NameNode,
error: BOOLEAN ← FALSE];
BuildName: PUBLIC PROC[id: IdentifierNode] RETURNS[NameNode] =
{RETURN[NEW[NameNodeBody←[id, NIL, id.text, id.text, ComputeHashKey[id.text]]]]};
BuildName2: PUBLIC PROC[id1: IdentifierNode, id2: IdentifierNode] RETURNS[NameNode] =
BEGIN
text: Rope.ROPE ← Rope.Cat[id1.text, ".", id2.text];
codeText: Rope.ROPE ← Rope.Cat[id1.text, id2.text];
RETURN[NEW[NameNodeBody←[id1, id2, text, codeText, ComputeHashKey[text]]]];
END;
BuildRopeName: PUBLIC PROC[text: Rope.ROPE] RETURNS[NameNode] =
{RETURN[NEW[NameNodeBody←[NIL, NIL, text, text, ComputeHashKey[text]]]]};
BuildErrorName: PUBLIC PROC RETURNS [NameNode] =
BEGIN
name: NameNode;
name ← BuildRopeName["** ERROR **"];
name.error ← TRUE;
RETURN [name];
END;
IsErrorName: PUBLIC PROC [name: NameNode] RETURNS [BOOLEAN] =
BEGIN
RETURN [name # NIL AND name.error];
END;
ComputeHashKey: PROC[text: Rope.ROPE] RETURNS[INT] =
BEGIN
key: INT ← 0;
FOR x: INT IN [0..Rope.Length[text]) DO
key ← key + (x+1)*LOOPHOLE[Rope.Fetch[text, x]]
ENDLOOP;
RETURN[key]
END;
ShowName: PUBLIC PROC[name: NameNode, on: IO.STREAM] =
{IO.PutF[on, "%g (%g)", IO.rope[name.text], IO.int[name.key]]};
ShowNamePosition: PUBLIC PROC[name: NameNode, on: IO.STREAM] =
{IF name.id1 # NIL THEN IO.PutF[on, "[%g]", IO.int[name.id1.position]]};
PutNameR: PUBLIC PROC[name: NameNode] RETURNS[Rope.ROPE] =
BEGIN
RETURN[Rope.Concat[
IO.PutFR["%g (%g)", IO.rope[name.text], IO.int[name.key]],
IF name.id1 # NIL THEN IO.PutFR["[%g]", IO.int[name.id1.position]] ELSE NIL]];
END;
GetNameCodeText: PUBLIC PROC[name: NameNode] RETURNS[Rope.ROPE] =
{RETURN[name.codeText]};
GetNameInfo: PUBLIC PROC[name: NameNode] RETURNS[text: Rope.ROPE, key: INT] =
{RETURN[name.text, name.key]};
GetNameIds: PUBLIC PROC[name: NameNode] RETURNS[id1, id2: IdentifierNode] =
{RETURN[name.id1, name.id2]};
EqualNames: PUBLIC PROC[name1, name2: NameNode] RETURNS[BOOLEAN] =
BEGIN
IF name1.key # name2.key THEN RETURN[FALSE];
RETURN[Rope.Equal[name1.text, name2.text]];
END;
-- NameList stuff
NameListNode: TYPE = REF NameListNodeBody;
NameListNodeBody: PUBLIC TYPE = RECORD[
first: NameListItem,
last: NameListItem,
error: BOOLEAN ← FALSE];
NameListItem: TYPE = REF NameListItemBody;
NameListItemBody: TYPE = RECORD[
name: NameNode,
next: NameListItem];
BuildEmptyNameList: PUBLIC PROC RETURNS[NameListNode] = {RETURN[NIL]};
FakeCopyNameList: PUBLIC PROC[names: NameListNode] RETURNS[NameListNode] =
{RETURN[names]};
BuildOneNameList: PUBLIC PROC[name: NameNode] RETURNS[NameListNode] =
BEGIN
item: NameListItem ← NEW[NameListItemBody←[name, NIL]];
RETURN[NEW[NameListNodeBody←[item, item]]];
END;
BuildErrorNameList: PUBLIC PROC RETURNS [NameListNode] =
BEGIN
RETURN [NEW[NameListNodeBody ← [NIL, NIL, TRUE]]];
END;
IsErrorNameList: PUBLIC PROC [list: NameListNode] RETURNS [BOOLEAN] =
BEGIN
RETURN [list # NIL AND list.error];
END;
AppendToNameList: PUBLIC PROC[list: NameListNode, name: NameNode] RETURNS[NameListNode] =
BEGIN
item: NameListItem;
IF IsErrorNameList[list] THEN RETURN [BuildErrorNameList[]];
item ← NEW[NameListItemBody←[name, NIL]];
IF list = NIL THEN RETURN[NEW[NameListNodeBody←[item, item]]];
IF list.last.next # NIL THEN ERROR;
list.last.next ← item;
list.last ← item;
RETURN[list];
END;
shares name argument with result
shares list argument with result
PrefixToNameList: PUBLIC PROC[name: NameNode, list: NameListNode] RETURNS[NameListNode] =
BEGIN
item: NameListItem;
IF IsErrorNameList[list] THEN RETURN [BuildErrorNameList[]];
item ← NEW[NameListItemBody←[name, NIL]];
IF list = NIL THEN RETURN[NEW[NameListNodeBody←[item, item]]];
IF list.last.next # NIL THEN ERROR;
item.next ← list.first;
list.first ← item;
RETURN[list];
END;
damages first list argument, shares second with result
ConcatNameLists: PUBLIC PROC[list1: NameListNode, list2: NameListNode] RETURNS[NameListNode] =
BEGIN
IF IsErrorNameList[list1] OR IsErrorNameList[list2] THEN RETURN [BuildErrorNameList[]];
IF list1 = NIL OR list1.first = NIL THEN RETURN[list2];
IF list2 = NIL OR list2.first = NIL THEN RETURN[list1];
IF list1.last.next # NIL THEN ERROR;
list1.last.next ← list2.first;
list1.last ← list2.last;
RETURN[list1];
END;
InventTemps: PUBLIC PROC[nTemps: IntegerNode, firstTempX: IntegerNode] RETURNS[names: NameListNode, nextTempX: IntegerNode] =
BEGIN
nextX: INT;
IF IsErrorInteger[nTemps] OR IsErrorInteger[firstTempX] THEN RETURN [BuildErrorNameList[], BuildErrorInteger[]];
nextX ← GetIntegerData[firstTempX];
IF GetIntegerData[nTemps] = 0 THEN RETURN[NIL, firstTempX];
names ← NEW[NameListNodeBody←[NIL, NIL]];
FOR I: INT IN [0..GetIntegerData[nTemps]) DO
nameItem: NameListItem ← NEW[NameListItemBody←[BuildRopeName[IO.PutFR["temp%g", IO.int[nextX]]], NIL]];
nextX ← nextX + 1;
IF names.last = NIL THEN names.first ← nameItem ELSE names.last.next ← nameItem;
names.last ← nameItem;
ENDLOOP;
nextTempX ← BuildInteger[nextX];
END;
ShowNameList: PUBLIC PROC[nameList: NameListNode, on: IO.STREAM] =
BEGIN
IF IsErrorNameList[nameList] THEN
BEGIN
IO.PutRope[on, "** ERROR **"];
RETURN;
END;
IF nameList = NIL THEN RETURN;
ShowName[nameList.first.name, on];
FOR item: NameListItem ← nameList.first.next, item.next WHILE item # NIL DO
IO.PutRope[on, ", "];
ShowName[item.name, on];
IF item = nameList.last THEN EXIT;
ENDLOOP;
END;
CompareNameLists: PUBLIC PROC[nameList1, nameList2: NameListNode] RETURNS[BOOLEAN] =
BEGIN
I1: NameListItem;
I2: NameListItem;
IF IsErrorNameList[nameList1] OR IsErrorNameList[nameList2] THEN RETURN [TRUE];
IF nameList1 = NIL AND nameList2 = NIL THEN RETURN[TRUE];
IF nameList1.first = NIL AND nameList2.first = NIL THEN RETURN[TRUE];
I1 ← nameList1.first;
I2 ← nameList2.first;
DO
IF NOT Rope.Equal[I1.name.text, I2.name.text] THEN RETURN [FALSE];
I1 ← I1.next;
I2 ← I2.next;
IF I1 = nameList1.last AND I2 = nameList2.last THEN RETURN[TRUE];
IF I1 = nameList1.last OR I2 = nameList2.last THEN RETURN [FALSE];
IF I1 = NIL AND I2 = NIL THEN RETURN[TRUE];
IF I1 = NIL OR I2 = NIL THEN RETURN [FALSE];
ENDLOOP;
END;
incomming list is shared with outgoing list
PartitionFirstName: PUBLIC PROC[list: NameListNode] RETURNS[NameNode, NameListNode] =
BEGIN
IF IsErrorNameList[list] THEN RETURN [BuildErrorName[], BuildErrorNameList[]];
IF list = NIL OR list.first = NIL THEN
BEGIN
PrintError["list lengths do not match"];
RETURN [BuildErrorName[], BuildErrorNameList[]];
END;
IF list.first # list.last THEN
RETURN[list.first.name, NEW[NameListNodeBody←[list.first.next, list.last]]]
ELSE RETURN[list.first.name, NIL];
END;
the incomming list is shared with both results
PartitionNames: PUBLIC PROC[n: IntegerNode, list: NameListNode] RETURNS[NameListNode, NameListNode] =
BEGIN
count: INT;
IF IsErrorInteger[n] OR IsErrorNameList[list] THEN RETURN [BuildErrorNameList[], BuildErrorNameList[]];
count ← GetIntegerData[n];
IF count = 0 THEN RETURN[NIL, list];
IF list = NIL OR list.first = NIL THEN
BEGIN
PrintError["list lengths do not match"];
RETURN[BuildErrorNameList[], BuildErrorNameList[]];
END;
FOR item: NameListItem ← list.first, item.next DO
count ← count - 1;
IF count = 0 THEN
BEGIN
IF item = list.last THEN RETURN[list, NIL];
RETURN[NEW[NameListNodeBody←[list.first, item]], NEW[NameListNodeBody←[item.next, list.last]]];
END
ELSE IF item = list.last THEN
BEGIN
PrintError["list lengths do not match"];
RETURN[BuildErrorNameList[], BuildErrorNameList[]];
END;
ENDLOOP;
END;
TheOneName: PUBLIC PROC[list: NameListNode] RETURNS[NameNode] =
BEGIN
IF IsErrorNameList[list] THEN RETURN [BuildErrorName[]];
IF list.first # list.last THEN {PrintError["expected singleton name list"]; RETURN [BuildErrorName[]]};
RETURN[list.first.name]
END;
TestEmptyNameList: PUBLIC PROC[list: NameListNode] RETURNS[BOOLEAN] =
BEGIN
IF IsErrorNameList[list] THEN RETURN [TRUE];
IF list = NIL THEN RETURN[TRUE];
RETURN[list.first = NIL];
END;
GenNames: PUBLIC PROC[names: NameListNode, for: PROC[NameNode]] =
BEGIN
IF IsErrorNameList[names] THEN RETURN;
IF names = NIL OR names.first = NIL THEN RETURN;
FOR nameItem: NameListItem ← names.first, nameItem.next WHILE nameItem # NIL DO
for[nameItem.name];
IF nameItem = names.last THEN RETURN;
ENDLOOP;
END;
-- Type
TypeNode: TYPE = REF TypeNodeBody;
TypeNodeBody: PUBLIC TYPE = RECORD[
typeInfo: REF ANY];
BuildType: PUBLIC PROC[info: REF ANY] RETURNS[TypeNode] =
{RETURN[NEW[TypeNodeBody←[info]]]};
GetTypeInfo: PUBLIC PROC[type: TypeNode] RETURNS[REF ANY] =
{RETURN[type.typeInfo]};
-- TypeList
TypeListNode: TYPE = REF TypeListNodeBody;
TypeListNodeBody: PUBLIC TYPE = RECORD[
first: TypeListItem,
last: TypeListItem,
error: BOOLEAN ← FALSE];
TypeListItem: TYPE = REF TypeListItemBody;
TypeListItemBody: TYPE = RECORD[
type: TypeNode,
next: TypeListItem];
BuildEmptyTypeList: PUBLIC PROC RETURNS[TypeListNode]= {RETURN[NIL]};
BuildOneTypeList: PUBLIC PROC[type: TypeNode] RETURNS[TypeListNode] =
BEGIN
item: TypeListItem ← NEW[TypeListItemBody←[type, NIL]];
RETURN[NEW[TypeListNodeBody←[item, item]]];
END;
BuildErrorTypeList: PUBLIC PROC RETURNS [TypeListNode] =
BEGIN
RETURN [NEW[TypeListNodeBody ← [NIL, NIL, TRUE]]];
END;
IsErrorTypeList: PUBLIC PROC [list: TypeListNode] RETURNS [BOOLEAN] =
BEGIN
RETURN [list # NIL AND list.error];
END;
AppendToTypeList: PUBLIC PROC[list: TypeListNode, type: TypeNode] RETURNS[TypeListNode] =
BEGIN
item: TypeListItem;
IF IsErrorTypeList[list] THEN RETURN [BuildErrorTypeList[]];
item ← NEW[TypeListItemBody←[type, NIL]];
IF list = NIL THEN RETURN[NEW[TypeListNodeBody←[item, item]]];
IF list.last.next # NIL THEN ERROR;
list.last.next ← item;
list.last ← item;
RETURN[list];
END;
shares name argument with result
shares list argument with result
PrefixToTypeList: PUBLIC PROC[type: TypeNode, list: TypeListNode] RETURNS[TypeListNode] =
BEGIN
item: TypeListItem;
IF IsErrorTypeList[list] THEN RETURN [BuildErrorTypeList[]];
item ← NEW[TypeListItemBody←[type, NIL]];
IF list = NIL THEN RETURN[NEW[TypeListNodeBody←[item, item]]];
IF list.last.next # NIL THEN ERROR;
item.next ← list.first;
list.first ← item;
RETURN[list];
END;
damages first list argument, shares second with result
ConcatTypeLists: PUBLIC PROC[list1: TypeListNode, list2: TypeListNode] RETURNS[TypeListNode] =
BEGIN
IF IsErrorTypeList[list1] OR IsErrorTypeList[list2] THEN RETURN [BuildErrorTypeList[]];
IF list1 = NIL OR list1.first = NIL THEN RETURN[list2];
IF list2 = NIL OR list2.first = NIL THEN RETURN[list1];
IF list1.last.next # NIL THEN ERROR;
list1.last.next ← list2.first;
list1.last ← list2.last;
RETURN[list1];
END;
GetTheOneType: PUBLIC PROC[typeList: TypeListNode] RETURNS[TypeNode] =
BEGIN
IF IsErrorTypeList[typeList] THEN RETURN [BuildErrorType[]];
IF typeList = NIL OR typeList.first # typeList.last THEN
BEGIN
PrintError["expected a singleton list"];
RETURN [BuildErrorType[]];
END;
RETURN[typeList.first.type];
END;
shares argument with list result
PartitionLastType: PUBLIC PROC[typeList: TypeListNode] RETURNS[TypeListNode, TypeNode] =
BEGIN
IF IsErrorTypeList[typeList] THEN RETURN [BuildErrorTypeList[], BuildErrorType[]];
IF typeList = NIL THEN
BEGIN
PrintError["list lengths do not match"];
RETURN [BuildErrorTypeList[], BuildErrorType[]];
END;
IF typeList.first = typeList.last THEN RETURN[NIL, typeList.first.type];
FOR item: TypeListItem ← typeList.first, item.next WHILE item # NIL DO
IF item.next = typeList.last THEN
RETURN[NEW[TypeListNodeBody←[typeList.first, item]], typeList.last.type]
ENDLOOP;
ERROR;
END;
shares argument with list result
PartitionFirstType: PUBLIC PROC[typeList: TypeListNode] RETURNS[TypeNode, TypeListNode] =
BEGIN
IF IsErrorTypeList[typeList] THEN RETURN [BuildErrorType[], BuildErrorTypeList[]];
IF typeList = NIL OR typeList.first = NIL THEN
BEGIN
PrintError["list lengths do not match"];
RETURN [BuildErrorType[], BuildErrorTypeList[]];
END;
IF typeList.first = typeList.last THEN RETURN[typeList.first.type, NIL];
RETURN[typeList.first.type, NEW[TypeListNodeBody←[typeList.first.next, typeList.last]]]
END;
CountTypes: PUBLIC PROC[typeList: TypeListNode] RETURNS[IntegerNode] =
BEGIN
nTypes: INT ← 0;
IF IsErrorTypeList[typeList] THEN RETURN [BuildErrorInteger[]];
IF typeList # NIL AND typeList.first # NIL THEN
FOR t: TypeListItem ← typeList.first, t.next DO
nTypes ← nTypes+1;
IF t = typeList.last THEN EXIT;
ENDLOOP;
RETURN[BuildInteger[nTypes]];
END;
CheckForEqualTypeLists: PUBLIC PROC[list1, list2: TypeListNode] RETURNS[BOOLEAN] =
BEGIN
t1: TypeListItem;
t2: TypeListItem;
IF IsErrorTypeList[list1] OR IsErrorTypeList[list2] THEN RETURN [TRUE];
t1 ← list1.first;
t2 ← list2.first;
WHILE t1 # NIL AND t2 # NIL DO
IF NOT EqualTypes[t1.type, t2.type] THEN GOTO oops;
IF t1 = list1.last AND t2 # list2.last THEN GOTO oops;
IF t1 # list1.last AND t2 = list2.last THEN GOTO oops;
IF t1 = list1.last THEN EXIT;
t1 ← t1.next; t2 ← t2.next;
ENDLOOP;
IF t1 = NIL AND t2 # NIL THEN GOTO oops;
IF t1 # NIL AND t2 = NIL THEN GOTO oops;
RETURN[TRUE];
EXITS
oops => {PrintError["type lists do not match"]; RETURN [FALSE]};
END;
CompareValTypesWithVarTypes: PUBLIC PROC[valTypes: TypeListNode, varTypes: TypeListNode] RETURNS[BOOLEAN] =
BEGIN
val: TypeListItem;
var: TypeListItem;
IF IsErrorTypeList[valTypes] OR IsErrorTypeList[varTypes] THEN RETURN [TRUE];
IF valTypes = NIL AND varTypes = NIL THEN RETURN[TRUE];
val ← valTypes.first;
var ← varTypes.first;
WHILE val # NIL AND var # NIL DO
IF NOT CompareValTypeWithVarType[val.type, var.type] THEN
RETURN [FALSE];
IF val = valTypes.last AND var # varTypes.last THEN
{PrintError["too few arguments"]; RETURN [FALSE]};
IF val # valTypes.last AND var = varTypes.last THEN
{PrintError["too many arguments"]; RETURN [FALSE]};
IF val = valTypes.last THEN EXIT;
val ← val.next; var ← var.next;
ENDLOOP;
IF val = NIL AND var # NIL THEN {PrintError["too few arguments"]; RETURN [FALSE]};
IF val # NIL AND var = NIL THEN {PrintError["too many arguments"]; RETURN [FALSE]};
RETURN [TRUE];
END;
GetFirstType: PUBLIC PROC[list: TypeListNode] RETURNS[TypeNode] =
BEGIN
IF IsErrorTypeList[list] THEN RETURN [BuildErrorType[]];
IF list = NIL OR list.first = NIL THEN
BEGIN
PrintError["list lengths do not match"];
RETURN [BuildErrorType[]];
END;
RETURN[list.first.type]
END;
This procdure is used by lookup routines, so that certain results do not share with a context. I think there is an alternative implementation that delays the copy until absolutely needed. This involves a modified type list representation that includes a "do not modify" bit, and one level of indirection. If some procedure attempts to modify such a representation, it instantly copies it, producing a representation without that bit on, to use as input to the modify. I believe that would justify any routine that would like to claim its result is not shared with its arguments, to simply set the "do not modify" bit on.
For now, I will do a direct copy. September 16, 1985 4:09:29 pm PDT
CopyTypeList: PUBLIC PROC[list: TypeListNode] RETURNS[TypeListNode] =
BEGIN
newList: TypeListNode;
IF IsErrorTypeList[list] THEN RETURN [BuildErrorTypeList[]];
IF list = NIL OR list.first = NIL THEN RETURN[NIL];
newList ← NEW[TypeListNodeBody←[NIL, NIL]];
FOR item: TypeListItem ← list.first, item.next DO
newItem: TypeListItem;
IF item = NIL THEN ERROR;
newItem ← NEW[TypeListItemBody ← [item.type, NIL]];
IF newList.last # NIL THEN newList.last.next ← newItem ELSE newList.first ← newItem;
newList.last ← newItem;
IF item = list.last THEN RETURN[newList];
ENDLOOP;
END;
GenTypeList: PUBLIC PROC[list: TypeListNode, for: PROC[TypeNode]] =
BEGIN
IF IsErrorTypeList[list] THEN RETURN;
IF list = NIL OR list.first = NIL THEN RETURN;
FOR item: TypeListItem ← list.first, item.next DO
IF NOT IsErrorType[item.type] THEN for[item.type];
IF item = list.last THEN EXIT;
ENDLOOP;
END;
GenNameTypePairs: PUBLIC PROC[names: NameListNode, types: TypeListNode, for: PROC[NameNode, TypeNode]] =
BEGIN
nameItem: NameListItem;
typeItem: TypeListItem;
IF IsErrorNameList[names] THEN RETURN;
IF IsErrorTypeList[types] THEN
BEGIN
nameItem ← IF names = NIL THEN NIL ELSE names.first;
WHILE nameItem # NIL DO
IF NOT IsErrorName[nameItem.name] THEN
for[nameItem.name, BuildErrorType[]];
nameItem ← IF nameItem = names.last THEN NIL ELSE nameItem.next;
ENDLOOP;
RETURN;
END;
nameItem ← IF names = NIL THEN NIL ELSE names.first;
typeItem ← IF types = NIL THEN NIL ELSE types.first;
WHILE nameItem # NIL AND typeItem # NIL DO
IF NOT IsErrorName[nameItem.name] THEN
for[nameItem.name, typeItem.type];
nameItem ← IF nameItem = names.last THEN NIL ELSE nameItem.next;
typeItem ← IF typeItem = types.last THEN NIL ELSE typeItem.next;
ENDLOOP;
IF nameItem # NIL THEN
BEGIN
PrintError["list lengths do not match -- too many names"];
WHILE nameItem # NIL DO
IF NOT IsErrorName[nameItem.name] THEN
for[nameItem.name, BuildErrorType[]];
nameItem ← IF nameItem = names.last THEN NIL ELSE nameItem.next;
ENDLOOP;
END;
IF typeItem # NIL THEN
PrintError["list lengths do not match -- too few names"];
END;
PrintError: PUBLIC PROC[m1, m2, m3, m4, m5: Rope.ROPE ← NIL] =
BEGIN
msg: Rope.ROPE;
pos, len: INT;
globalEnv: GlobalEnvHandle;
msg ← Rope.Cat[m1, m2, m3, m4, m5];
[pos, len] ← SIGNAL ThreeC4Support.GetSourceInfo;
IO.PutF[SIGNAL ThreeC4Support.GetReportStream, "\N[%g..%g] %g\N", IO.int[pos], IO.int[pos+len-1], IO.rope[msg]];
globalEnv ← GetGlobalEnv[];
globalEnv.errorCount ← globalEnv.errorCount + 1;
END;
UnrecoveredError: PUBLIC ERROR = CODE;
PrintBadName: PUBLIC PROC[name: NameNode, m1, m2, m3, m4, m5: Rope.ROPE ← NIL] =
BEGIN
msg: Rope.ROPE;
s: IO.STREAM;
pos, len: INT;
globalEnv: GlobalEnvHandle;
msg ← Rope.Cat[m1, m2, m3, m4, m5];
s ← SIGNAL ThreeC4Support.GetReportStream;
IO.PutF[s, "\N%g ", IO.rope[name.text]];
[pos, len] ← SIGNAL ThreeC4Support.GetSourceInfo;
IO.PutF[s, "[%g..%g]", IO.int[pos], IO.int[pos+len-1]];
IF name.id1 # NIL THEN
IO.PutF[s, "[%g]", IO.int[name.id1.position]];
IO.PutF[s, " %g\N", IO.rope[msg]];
globalEnv ← GetGlobalEnv[];
globalEnv.errorCount ← globalEnv.errorCount + 1;
END;
GetGlobalEnv: PUBLIC PROC RETURNS [GlobalEnvHandle] =
BEGIN
globalEnv: GlobalEnvHandle;
globalEnv ← NARROW[GetProp[$ThreeCasabaFourGlobalEnv]];
IF globalEnv = NIL THEN ERROR;
RETURN [globalEnv];
END;