DIRECTORY
ThreeC4BaseDecl1Def USING[TreeCallFlag, CompareValTypeWithVarType, IdentifierNode, NonNegIntegerNode, RopeNode],
ThreeC4CProdAbGramDef USING[IntervalForm],
ThreeC4PrimImplDefs USING[BuildErrorType, IsErrorType,  EqualTypes, GlobalEnvHandle],
ThreeC4Support USING [GetReportStream, GetSourceInfo],

Convert USING[IntFromRope],
IO USING[int, PutF, PutFR, PutRope, rope, STREAM],
ProcessProps USING [GetProp],
Rope USING[Cat, Concat, Equal, Fetch, Length, ROPE];


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;

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;

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;

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;

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;

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;

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;

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;

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;


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;


END..
 
φThreeC4PrimImpl1.mesa: October 18, 1985 9:25:36 am PDT
Sturgis, May 7, 1986 6:20:43 pm PDT
Shoup, July 1, 1986 1:27:13 am PDT
damages list argument
shares name argument with result
shares list argument with result
damages first list argument, shares second with result
incomming list is shared with outgoing list
the incomming list is shared with both results
damages list argument
shares name argument with result
shares list argument with result
damages first list argument, shares second with result
shares argument with list result
shares argument with list result
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
Κ	‡˜Jš
œ6™6š
œ#™#Icode™"—J˜š
Οk	˜	Jšœœnœ˜›
J˜UJ˜6J˜J˜J˜2J˜J˜4J˜—J˜š	œœ
œ
œ\œC˜Ν
Jšœ
œ_˜iJ˜J˜J˜J˜J˜J˜(J˜JJ˜š
œD˜DJ˜;—J˜˜;J˜a—J˜J˜AJ˜˜AJ˜ƒ
J˜—˜AJ˜—˜IJ˜—J˜˜;J˜J˜—˜3J˜—J˜˜DJ˜
J˜—˜AJ˜W—J˜˜?J˜—J˜˜QJ˜—J˜˜LJ˜J˜—˜AJ˜J˜—˜=J˜—J˜˜:J˜—J˜˜8J˜#—J˜˜/J˜—J˜˜1J˜$J˜—˜7J˜,J˜—˜@J˜J˜J˜—J˜˜GJ˜—J˜J˜
J˜J˜"˜#J˜J˜J˜J˜J˜	J˜J˜—J˜˜>J˜Q—J˜˜UJ˜J˜4J˜3J˜KJ˜—J˜˜?J˜I—J˜˜0J˜J˜J˜$J˜J˜J˜—J˜˜=J˜J˜#J˜J˜—˜4J˜J˜
˜'J˜/J˜—J˜J˜—J˜˜6J˜?—J˜˜>J˜H—J˜˜:J˜˜J˜:J˜N—J˜—J˜˜AJ˜—J˜˜MJ˜J˜—˜KJ˜—J˜˜BJ˜J˜,J˜+J˜—J˜J˜J˜J˜J˜J˜*˜'J˜J˜J˜—J˜J˜*˜ J˜J˜—J˜J˜FJ˜˜JJ˜—J˜˜EJ˜J˜7J˜+J˜J˜—˜8J˜J˜2J˜—J˜˜EJ˜J˜#J˜—˜J™—˜YJ˜J˜J˜J˜<J˜J˜*J˜>J˜#J˜J˜J˜
J˜—˜J™ J™ —˜YJ˜J˜J˜J˜<J˜J˜)J˜>J˜#J˜J˜J˜
J˜—˜J™6—˜^J˜J˜J˜WJ˜J˜7J˜7J˜$J˜J˜J˜J˜—J˜J˜˜}J˜J˜J˜J˜pJ˜J˜#J˜;J˜)˜,J˜gJ˜J˜PJ˜J˜—J˜ J˜—J˜˜BJ˜˜"J˜J˜J˜J˜J˜—J˜J˜"˜KJ˜J˜J˜"J˜—J˜—J˜˜TJ˜J˜J˜J˜J˜OJ˜J˜9J˜EJ˜J˜˜J˜BJ˜
J˜
J˜AJ˜BJ˜+J˜,J˜—J˜—˜J™+—˜UJ˜J˜N˜&J˜J˜(J˜0J˜J˜—˜J˜KJ˜"—J˜—˜J™.—˜eJ˜J˜J˜J˜gJ˜J˜J˜$˜'J˜J˜(J˜3J˜J˜—˜1J˜˜J˜J˜+J˜_J˜—˜J˜J˜(J˜3J˜—J˜	—J˜—J˜˜?J˜J˜8J˜gJ˜J˜—J˜˜EJ˜J˜,J˜J˜ J˜J˜J˜—J˜˜AJ˜J˜&J˜J˜0˜OJ˜J˜%J˜—J˜—J˜J˜J˜J˜"˜#J˜—J˜J˜J˜J˜˜9J˜#—J˜˜;J˜J˜
—J˜J˜J˜J˜J˜J˜J˜*˜'J˜J˜J˜—J˜J˜*˜ J˜J˜—J˜J˜EJ˜˜EJ˜J˜7J˜+J˜J˜—˜8J˜J˜2J˜—J˜˜EJ˜J˜#J˜—˜J™—˜YJ˜J˜J˜J˜<J˜)J˜>J˜#J˜J˜J˜
J˜—˜J™ J™ —˜YJ˜J˜J˜J˜<J˜)J˜>J˜#J˜J˜J˜
J˜—˜J™6—˜^J˜J˜WJ˜J˜7J˜7J˜$J˜J˜J˜J˜—J˜J˜J˜˜FJ˜J˜<J˜˜9J˜J˜(J˜J˜—J˜J˜˜J™ ——˜XJ˜J˜RJ˜˜J˜J˜(J˜0J˜—J˜H˜F˜!J˜H—J˜—J˜J˜—˜J™ —˜YJ˜J˜R˜/J˜J˜(J˜0J˜—J˜HJ˜WJ˜—J˜J˜J˜˜FJ˜J˜J˜J˜?J˜˜/˜/J˜J˜J˜——J˜J˜—J˜J˜J˜˜RJ˜J˜J˜J˜J˜GJ˜J˜J˜˜J˜3J˜6J˜6J˜J˜J˜—J˜(J˜(J˜
J˜˜J˜@—J˜—J˜˜kJ˜J˜J˜J˜J˜MJ˜J˜7J˜J˜˜ ˜:J˜—˜4J˜2—˜4J˜3—J˜!J˜J˜—J˜RJ˜SJ˜J˜J˜—J˜˜AJ˜J˜8˜'J˜J˜(J˜J˜J˜—J˜J˜—J˜˜J™ρJ™C—˜EJ˜J˜J˜J˜<J˜J˜3J˜+˜1J˜J˜J˜3J˜TJ˜J˜)J˜—J˜—J˜˜CJ˜J˜%J˜J˜.˜1J˜2J˜J˜—J˜—J˜˜hJ˜J˜J˜J˜J˜J˜&J˜˜˜J˜4˜˜&J˜%—J˜@—J˜J˜—J˜J˜—J˜J˜4J˜4J˜˜*˜&J˜"—J˜@J˜@—J˜J˜˜˜J˜:˜˜&J˜%—J˜@—J˜—J˜J˜—˜J˜9——˜˜J˜J˜—J˜J˜J˜˜>J˜J˜J˜J˜J˜J˜#J˜1J˜pJ˜J˜J˜0J˜J˜—˜&J˜—J˜J˜J˜˜PJ˜J˜J˜
J˜J˜J˜J˜#J˜*J˜J˜(J˜J˜J˜1J˜7J˜˜J˜.—˜J˜—J˜"J˜J˜J˜0J˜J˜—J˜—J˜˜5J˜J˜J˜7J˜J˜J˜—J˜J˜šœ˜Jš
Οb
˜
———…—OΠ^M