CrankOneImpl.mesa
Copyright Ó 1987, 1991 by Xerox Corporation. All rights reserved.
Michael Plass, March 22, 1993 5:22 pm PST
DIRECTORY List, ProcessProps, IO, VersionMap, VersionMapDefaults, CrankIO, CrankTypes, FS, MPTree, MPLeaves, Rope, CrankOps, CrankAnalyze, SymTab, CedarProcess;
CrankOneImpl: CEDAR MONITOR
IMPORTS List, ProcessProps, IO, VersionMap, VersionMapDefaults, CrankIO, FS, Rope, CrankOps, CrankAnalyze, SymTab, CedarProcess
EXPORTS CrankAnalyze
~ BEGIN OPEN CrankTypes, CrankOps, CrankAnalyze;
ROPE: TYPE = Rope.ROPE;
Driver
runOn: BOOL ¬ TRUE; -- If TRUE, errors with non-empty messages will get caught and logged.
saveContext: BOOL ¬ TRUE; -- hack to avoid re-doing a lot of interfaces.
globalContext: Context ¬ NIL; -- monitored
warnPointerArith: BOOL ¬ FALSE;
mimosa: BOOL = TRUE;
AllocContext: ENTRY PROC RETURNS [context: Context] = {
ENABLE UNWIND => NULL;
IF saveContext AND globalContext # NIL
THEN { context ¬ globalContext; globalContext ¬ NIL }
ELSE {
context ¬ NewContext[NIL];
DeclareBuiltIns[context];
};
context ¬ NewContext[context]; -- don't pass out the context with the builtins without shadowing it.
};
FreeContext: ENTRY PROC [context: Context] = {
IF saveContext THEN globalContext ¬ Root[context];
};
SrcLoc: PROC [tree: Tree] RETURNS [loc: INT ¬ INT.LAST] = {
WITH tree SELECT FROM
aNode: AttributedNode => {
WITH aNode.syntaxNode SELECT FROM
node: REF MPTree.Node => {
FOR i: NAT IN [1..node.sonLimit) DO
loc ¬ SrcLoc[node.son[i]];
IF loc # INT.LAST THEN RETURN;
ENDLOOP;
};
ht: REF MPLeaves.HTNode => RETURN [ht.index];
lt: REF MPLeaves.LTIndex => RETURN [lt.index];
ENDCASE => NULL;
};
ENDCASE => NULL;
};
PushSource: SIGNAL [newSource: ROPE] = CODE;
PopSource: SIGNAL = CODE;
Convert: PUBLIC PROC [fileName: ROPE, analyze: BOOL, action: PROC [tree: Tree, context: Context]] ~ {
Inner: PROC = {
fullFName: ROPE = GetFullName[fileName];
attachedName: ROPE = FS.FileInfo[fullFName].attachedTo;
sourceName: ROPE = IF attachedName # NIL THEN attachedName ELSE FS.FileInfo[fullFName].fullFName;
sources: LIST OF ROPE ¬ LIST[sourceName];
logName: ROPE = CrankIO.MakeOutputName[fullFName, "crankErrors"];
log: IO.STREAM = FS.StreamOpen[fileName: logName, accessOptions: create];
tree: Tree ¬ CrankIO.AddAttributeNodes[CrankIO.ParseFile[fullFName]];
errorCount: INT ¬ 0;
IF analyze
THEN {
context: Context = AllocContext[];
AnalyzeModule[context, tree !
CrankOps.Error => IF runOn AND Rope.Size[message] > 0 THEN {
loc: INT ¬ SrcLoc[tree];
errorCount ¬ errorCount + 1;
WITH ProcessProps.GetProp[$StdOut] SELECT FROM
errout: IO.STREAM => {
IO.PutRope[errout, " Error: "];
IO.PutRope[errout, message];
IF loc # INT.LAST THEN IO.PutF[errout, " \"%g|%g\"", [rope[sources.first]], [integer[loc]]];
IO.PutRope[errout, "\n"];
};
ENDCASE => NULL;
IO.PutRope[log, " Error: "];
IO.PutRope[log, message];
IF loc # INT.LAST THEN IO.PutF[log, " \"%g|%g\"", [rope[sources.first]], [integer[loc]]];
IF tree # NIL THEN IO.PutF1[log, " %g", [refAny[CrankIO.RopeFromTree[tree]]]];
IO.PutRope[log, "\n"];
IO.Flush[log];
RESUME;
};
PushSource => {sources ¬ CONS[newSource, sources]; RESUME};
PopSource => {sources ¬ sources.rest; RESUME};
];
ComputeExternalTypeRep[context.types];
FillTypeAttributes[context.types, tree];
action[tree, context];
FreeContext[context];
}
ELSE { action[tree, NIL] };
IF errorCount # 0
THEN {
IO.PutF[log, "\n %g error%g reported.\n", [integer[errorCount]], [rope[IF errorCount = 1 THEN "" ELSE "s"]]];
IO.Close[log];
}
ELSE {
fullLogName: ROPE = FS.GetName[FS.OpenFileFromStream[log]].fullFName;
IO.Close[self: log, abort: TRUE];
FS.Delete[name: fullLogName ! FS.Error => CONTINUE];
};
};
CedarProcess.DoWithPriority[priority: background, action: Inner]
};
ConvertFile: PUBLIC PROC [fileName: ROPE, structure: BOOL, analyze: BOOL, skipAttributes: LIST OF ATOM] RETURNS [resultFileName: ROPE ¬ NIL] = {
fullFName: ROPE = GetFullName[fileName];
attachedName: ROPE = FS.FileInfo[fullFName].attachedTo;
outputName: ROPE = CrankIO.MakeOutputName[fullFName, "sexpr"];
sourceName: ROPE = IF attachedName # NIL THEN attachedName ELSE FS.FileInfo[fullFName].fullFName;
Inner: PROC [tree: Tree, context: Context] = {
resultFileName ¬ (IF structure THEN CrankIO.WriteSTree[tree, outputName, united, sourceName, skipAttributes] ELSE CrankIO.WriteTree[tree, outputName, sourceName, skipAttributes]);
};
Convert[fileName: fullFName, analyze: analyze, action: Inner];
};
Support
GetUnderQualifier: PROC [context: Context, qual: ROPE, id: ROPE, typeCode: TypeCode] RETURNS [ROPE] = {
If a type, finds the right qualifier for the original definition.
WITH UnderType[context.types, typeCode] SELECT FROM
ty: REF TypeRep.type => {
IF ty.value # nullTypeCode THEN {
tc: TypeCode ¬ ty.value;
DO
WITH TypeFromTypeCode[context.types, tc] SELECT FROM
d: REF TypeRep.definition => {
IF Rope.Equal[d.shortName, id] THEN qual ¬ d.qualifier;
tc ¬ d.groundType;
};
i: REF TypeRep.initial => {
tc ¬ i.groundType;
};
ENDCASE => EXIT;
ENDLOOP;
};
};
ENDCASE => NULL;
RETURN [qual];
};
HasInitialValuesForAllArgs: PROC [typeGraph: TypeGraph, c: REF TypeRep.control] RETURNS [BOOL] ~ {
WITH UnderType[typeGraph, c.argumentType] SELECT FROM
s: REF TypeRep.record => {
FOR f: FieldList ¬ s.fieldList, f.rest UNTIL f = NIL DO
IF TypeFromTypeCode[typeGraph, f.first.rangeType].class # $INITIAL THEN RETURN [FALSE]
ENDLOOP;
};
ENDCASE => NULL;
RETURN [TRUE]
};
TypeCodePair: TYPE = RECORD [aCode, bCode: TypeCode];
maxTypeImplNest: NAT ¬ 20;
Implies: PROC [context: Context, aCode, bCode: TypeCode] RETURNS [BOOL] = {
typeGraph: TypeGraph ~ context.types;
nestLimit: NAT ¬ maxTypeImplNest;
inductiveEquivalents: LIST OF TypeCodePair ¬ NIL;
InductivelyEquivalent: PROC [ac, bc: TypeCode] RETURNS [BOOL] = {
FOR each: LIST OF TypeCodePair ¬ inductiveEquivalents, each.rest UNTIL each = NIL DO
IF ac = each.first.aCode AND bc = each.first.bCode THEN RETURN [TRUE]
ENDLOOP;
RETURN [FALSE];
};
Imp: PROC [aCode, bCode: TypeCode] RETURNS [ans: BOOL ¬ FALSE] = {
nestLimit ¬ nestLimit - 1;
Assert[nestLimit > 0, "Type recursion too deep"];
IF nestLimit > 0 THEN ans ¬ Imp1[aCode, bCode];
nestLimit ¬ nestLimit + 1;
};
Imp1: PROC [aCode, bCode: TypeCode] RETURNS [BOOL] = {
a: Type = UnderType[typeGraph, aCode];
b: Type = UnderType[typeGraph, bCode];
nestLimit ¬ nestLimit - 1;
IF a = b OR (b#NIL AND b.class = $ANY) OR (a#NIL AND a.class = $UNSPECIFIED) OR (b#NIL AND b.class = $UNSPECIFIED) OR (a#NIL AND b#NIL AND InductivelyEquivalent[a.typeCode, b.typeCode]) THEN RETURN [TRUE];
IF a = NIL OR b = NIL THEN RETURN [FALSE];
IF b.class = $OPAQUE THEN {
concrete: TypeCode = GetConcreteTypeCode[context, b.typeCode];
IF concrete # nullTypeCode THEN RETURN [Imp[a.typeCode, concrete]]
};
WITH a SELECT FROM
a: REF TypeRep.scalar => {
WITH b SELECT FROM
b: REF TypeRep.subrange => {
RETURN [Imp[a.typeCode, b.groundType]] -- This is more generous than it should be; may need a range check.
};
ENDCASE => NULL;
RETURN [a.class = b.class];
};
a: REF TypeRep.subrange => { RETURN [Imp[a.groundType, b.typeCode]] };
a: REF TypeRep.reference => {
WITH b SELECT FROM
b: REF TypeRep.reference => {
save: LIST OF TypeCodePair ¬ inductiveEquivalents;
imp: BOOL ¬ FALSE;
IF a.class = b.class THEN {
inductiveEquivalents ¬ CONS[[a.typeCode, b.typeCode], inductiveEquivalents];
};
IF a.class = $LIST AND b.class = $LIST
THEN {
Since the record pointed to by a LIST is not painted, we base the result on the type implication of the "first" field.
WITH UnderType[typeGraph, a.referentType] SELECT FROM
ar: REF TypeRep.record => {
WITH b SELECT FROM
b: REF TypeRep.reference => {
WITH UnderType[typeGraph, b.referentType] SELECT FROM
br: REF TypeRep.record => {
imp ¬ Imp[ar.fieldList.first.rangeType, br.fieldList.first.rangeType];
};
ENDCASE => NULL;
};
ENDCASE => NULL;
};
ENDCASE => NULL;
}
ELSE {
imp ¬ (a.class = b.class OR (a.class = $POINTER AND b.class = $LONGPOINTER) OR (a.class = $LIST AND b.class = $REF)) AND Imp[a.referentType, b.referentType];
};
inductiveEquivalents ¬ save;
RETURN [imp]
};
ENDCASE => RETURN [FALSE];
};
a: REF TypeRep.record => {
IF a.class = $STRUCTURE AND b.class = $STRUCTURE THEN {
WITH b SELECT FROM
b: REF TypeRep.record => {
af: FieldList ¬ a.fieldList;
bf: FieldList ¬ b.fieldList;
WHILE af # NIL AND bf # NIL DO
IF Imp[af.first.rangeType, bf.first.rangeType]
THEN { af ¬ af.rest; bf ¬ bf.rest }
ELSE EXIT;
ENDLOOP;
IF af = NIL AND bf = NIL THEN RETURN [TRUE];
};
ENDCASE => NULL;
};
IF a.fieldList # NIL AND a.fieldList.rest = NIL THEN {
RETURN [Imp[a.fieldList.first.rangeType, b.typeCode]]
};
};
a: REF TypeRep.qualifiedVariant => {
WITH b SELECT FROM
b: REF TypeRep.qualifiedVariant => {
IF (Rope.Equal[a.qualifier, b.qualifier] AND Imp[a.groundType, b.groundType]) THEN RETURN [TRUE];
};
ENDCASE => NULL;
IF Imp[a.groundType, b.typeCode] THEN RETURN [TRUE];
};
a: REF TypeRep.array => {
WITH b SELECT FROM
b: REF TypeRep.array => {
RETURN [Imp[a.rangeType, b.rangeType]] -- This is sloppy; should check the sizes, too.
};
ENDCASE => NULL;
};
a: REF TypeRep.enumerated => {
WITH b SELECT FROM
b: REF TypeRep.subrange => {
RETURN [Imp[a.typeCode, b.groundType]] -- This is more generous than it should be; may need a range check.
};
ENDCASE => NULL;
RETURN [FALSE]; -- assume always painted
};
a: REF TypeRep.control => {
WITH b SELECT FROM
b: REF TypeRep.control => {
save: LIST OF TypeCodePair ¬ inductiveEquivalents;
imp: BOOL ¬ FALSE;
inductiveEquivalents ¬ CONS[[a.typeCode, b.typeCode], inductiveEquivalents];
imp ¬ a.class = b.class AND Imp[b.argumentType, a.argumentType] AND Imp[a.returnType, b.returnType];
inductiveEquivalents ¬ save;
RETURN [imp];
};
ENDCASE => NULL;
};
a: REF TypeRep.simple => {
IF a.class = $OPAQUE THEN {
concrete: TypeCode = GetConcreteTypeCode[context, a.typeCode];
RETURN [IF concrete # nullTypeCode THEN Imp[concrete, b.typeCode] ELSE FALSE];
};
RETURN [a.class = b.class];
};
a: REF TypeRep.type => RETURN [a.class = b.class];
ENDCASE => NULL;
RETURN [FALSE];
};
RETURN [Imp[aCode, bCode]];
};
Coercions: PROC [context: Context, from: TypeCode, to: TypeCode, tree: Tree] RETURNS [LIST OF REF] = {
The tree is used only for indicating errors.
$DEREFERENCE, $FLOAT, $SELECTSINGLETON, $PROCAPPLY, $WIDEN, $BOUNDSCHECK, $LOOPHOLE, $ERRORVALUE
typeGraph: TypeGraph ~ context.types;
coercions: LIST OF REF ¬ NIL;
toType: Type ¬ UnderType[typeGraph, to];
tc: TypeCode ¬ from;
DO
WITH toType SELECT FROM
t: REF TypeRep.record => {
IF t.fieldList # NIL AND t.fieldList.rest = NIL THEN {
toType ¬ UnderType[typeGraph, t.fieldList.first.rangeType];
LOOP;
};
};
ENDCASE => NULL;
EXIT;
ENDLOOP;
IF toType.class = $UNSPECIFIED THEN RETURN [CONS[$LOOPHOLE, coercions]];
WHILE tc # nullTypeCode DO
type: Type = UnderType[typeGraph, tc];
IF type = NIL THEN EXIT;
IF type.class = $UNSPECIFIED THEN RETURN [CONS[$LOOPHOLE, coercions]];
IF Implies[context, type.typeCode, toType.typeCode] THEN RETURN [coercions];
WITH type SELECT FROM
t: REF TypeRep.scalar => {
IF toType.class = $REAL THEN {
SELECT t.class FROM
$INT16, $INT32, $DINT, $CARD16, $CARD32, $DCARD => RETURN [CONS[$FLOAT, coercions]];
$REAL, $DREAL => RETURN [coercions];
ENDCASE => NULL;
};
WITH toType SELECT FROM
s: REF TypeRep.subrange => {
coercions ¬ CONS[$BOUNDSCHECK, coercions];
toType ¬ UnderType[typeGraph, s.groundType];
LOOP;
};
s: REF TypeRep.scalar => {
SELECT t.class FROM
$INT16, $INT32, $DINT, $CARD16, $CARD32, $DCARD => {
SELECT s.class FROM
$INT16, $INT32, $DINT, $CARD16, $CARD32, $DCARD => {
RETURN [CONS[$BOUNDSCHECK, coercions]];
};
ENDCASE => NULL;
};
ENDCASE => NULL;
};
s: REF TypeRep.enumerated => {
IF t.class = $ATOM THEN {
RETURN [CONS[$ENUMERATIONLITERALFROMATOM, coercions]];
};
};
ENDCASE => NULL;
};
t: REF TypeRep.record => {
IF t.fieldList # NIL AND t.fieldList.rest = NIL THEN {
tc ¬ t.fieldList.first.rangeType;
LOOP;
};
};
t: REF TypeRep.qualifiedVariant => {
coercions ¬ CONS[$WIDEN, coercions];
tc ¬ t.groundType;
LOOP;
};
t: REF TypeRep.reference => {
coercions ¬ CONS[$DEREFERENCE, coercions];
tc ¬ t.referentType;
LOOP;
};
t: REF TypeRep.control => {
IF t.class = $PROC THEN {
IF HasInitialValuesForAllArgs[typeGraph, t] THEN {
coercions ¬ CONS[$PROCAPPLY, coercions];
tc ¬ t.returnType;
LOOP
};
};
IF t.class = $ERROR THEN {
coercions ¬ CONS[$ERRORVALUE, coercions];
RETURN [coercions];
};
};
t: REF TypeRep.subrange => {
coercions ¬ CONS[$WIDEN, coercions];
tc ¬ t.groundType;
LOOP;
};
t: REF TypeRep.enumerated => {
WITH toType SELECT FROM
s: REF TypeRep.subrange => {
coercions ¬ CONS[$BOUNDSCHECK, coercions];
toType ¬ UnderType[typeGraph, s.groundType];
LOOP;
};
ENDCASE => NULL;
};
ENDCASE => NULL;
EXIT;
ENDLOOP;
RETURN [NARROW[Help["Could not do this coercion",,tree]]];
};
BuiltinType: PROC [context: Context, id: ROPE, type: Type] = {
dtype: Type = IF type.infoClass = record OR type.infoClass = enumerated THEN NEW[TypeRep.definition ¬ [class: $DEFINITION, v: definition[qualifier: NIL, shortName: id, groundType: NewType[context.types, type]]]] ELSE type;
typeCode: TypeCode = NewType[context.types, dtype];
typeTypeCode: TypeCode = NewTypeType[context.types, typeCode];
AddSymbol[context, id, NEW[SymbolTableEntryRep.other ¬ [other[typeCode: typeTypeCode, readonly: TRUE]]]];
};
GetSequenceInfo: PROC [typeGraph: TypeGraph, typeCode: TypeCode] RETURNS [domain: Type ¬ NIL, sequenceFieldName: ROPE ¬ NIL, sequenceTypeCode: TypeCode ¬ nullTypeCode] = {
Action: PROC [fieldIndex: INT, fieldName: ROPE, fieldTypeCode: TypeCode, tagName: ROPE, tagTypeCode: TypeCode] RETURNS [quit: BOOL ¬ FALSE] = {
IF tagTypeCode # nullTypeCode AND UnderType[typeGraph, fieldTypeCode].class = $SEQUENCE THEN {
domain ¬ TypeFromTypeCode[typeGraph, tagTypeCode];
sequenceFieldName ¬ fieldName;
sequenceTypeCode ¬ fieldTypeCode;
RETURN [TRUE]
}
};
WITH UnderType[typeGraph, typeCode] SELECT FROM
r: REF TypeRep.record => {
[] ¬ EnumerateFields[typeGraph, typeCode, Action];
};
q: REF TypeRep.qualifiedVariant => {
[] ¬ EnumerateFields[typeGraph, typeCode, Action];
};
ENDCASE => NULL;
};
GetListElementTypeCode: PROC [typeGraph: TypeGraph, listTypeCode: TypeCode] RETURNS [TypeCode] = {
listType: Type = UnderType[typeGraph, listTypeCode];
WITH listType SELECT FROM
lt: REF TypeRep.reference => {
WITH UnderType[typeGraph, lt.referentType] SELECT FROM
rt: REF TypeRep.record => {
IF rt.fieldList # NIL THEN RETURN [rt.fieldList.first.rangeType]
};
ENDCASE => NULL;
};
ENDCASE => NULL;
RETURN [nullTypeCode]
};
princopbuiltins: ROPE = "
BUILTIN: CEDAR DEFINITIONS = {
BOOL: TYPE = {FALSE, TRUE};
FALSE: BOOL = FALSE;
TRUE: BOOL = TRUE;
BOOLEAN: TYPE = BOOL;
NAT: TYPE = INT16[0..32767];
BYTE: TYPE = INT16[0..255];
CHARACTER: TYPE = CHAR;
INTEGER: TYPE = INT16;
INT: TYPE = INT32;
CARD: TYPE = CARD32;
CARDINAL: TYPE = CARD16;
WORD: TYPE = CARD16;
UNIT: TYPE = CARD16;
AtomRep: PRIVATE TYPE;
ATOM: TYPE = REF AtomRep;
MONITORLOCK, LOCK: TYPE;
CONDITION: TYPE;
TEXT: TYPE = MACHINE DEPENDENT RECORD [length: NAT15, text: PACKED SEQUENCE maxLength: NAT15 OF CHAR];
-- VAL: PROC [CARDINAL] RETURNS [UNSPECIFIED] = MACHINE CODE {};
-- ORD: PROC [UNSPECIFIED] RETURNS [CARDINAL] = MACHINE CODE {};
REAL32: TYPE ~ REAL;
NAT15: TYPE ~ INT16[0..32767];
StringBody: TYPE = MACHINE DEPENDENT RECORD [length: NAT15, text: PACKED SEQUENCE maxlength: NAT15 OF CHAR];
STRING: TYPE ~ POINTER TO StringBody;
}.
";
builtins: ROPE = "
BUILTIN: CEDAR DEFINITIONS = {
BOOL: TYPE = {FALSE, TRUE};
FALSE: BOOL = FALSE;
TRUE: BOOL = TRUE;
BOOLEAN: TYPE = BOOL;
NAT15: TYPE ~ INT16[0..32767];
NAT31: TYPE ~ INT32[0..INT32.LAST];
NAT: TYPE = NAT31;
BYTE: TYPE = INT16[0..255];
CHARACTER: TYPE = CHAR;
INTEGER: TYPE = INT32;
INT: TYPE = INT32;
CARD: TYPE = CARD32;
CARDINAL: TYPE = CARD32;
WORD: TYPE = CARD32;
UNIT: TYPE = BYTE;
AtomRep: PRIVATE TYPE;
ATOM: TYPE = REF AtomRep;
MONITORLOCK, LOCK: TYPE;
CONDITION: TYPE;
TEXT: TYPE = MACHINE DEPENDENT RECORD [length: NAT15, text: PACKED SEQUENCE maxLength: NAT15 OF CHAR];
REAL32: TYPE ~ REAL;
StringBody: TYPE = MACHINE DEPENDENT RECORD [length: NAT15, text: PACKED SEQUENCE maxlength: NAT15 OF CHAR];
STRING: TYPE ~ POINTER TO StringBody;
}.
";
DeclareBuiltIns: PROC [context: Context] = {
builtinTree: Tree = CrankIO.AddAttributeNodes[CrankIO.ParseRope[builtins]];
word64: REF TypeRep.scalar= NEW[TypeRep.scalar ¬ [class: $DCARD, v: scalar[]]];
word32: REF TypeRep.scalar= NEW[TypeRep.scalar ¬ [class: $CARD32, v: scalar[]]];
word16: REF TypeRep.scalar= NEW[TypeRep.scalar ¬ [class: $CARD16, v: scalar[]]];
BuiltinType[context, "INT16", NEW[TypeRep.scalar ¬ [class: $INT16, v: scalar[]]]];
BuiltinType[context, "REAL", NEW[TypeRep.scalar ¬ [class: $REAL, v: scalar[]]]];
BuiltinType[context, "DREAL", NEW[TypeRep.scalar ¬ [class: $DREAL, v: scalar[]]]];
BuiltinType[context, "DINT", NEW[TypeRep.scalar ¬ [class: $DINT, v: scalar[]]]];
BuiltinType[context, "DCARD", word64];
BuiltinType[context, "DWORD", word64];
BuiltinType[context, "INT32", NEW[TypeRep.scalar ¬ [class: $INT32, v: scalar[]]]];
BuiltinType[context, "CHAR", NEW[TypeRep.scalar ¬ [class: $CHAR, v: scalar[]]]];
BuiltinType[context, "CARD32", word32];
BuiltinType[context, "WORD32", word32];
BuiltinType[context, "CARD16", word16];
BuiltinType[context, "WORD16", word16];
BuiltinType[context, "UNSPECIFIED", NEW[TypeRep.scalar ¬ [class: $UNSPECIFIED, v: scalar[]]]];
AnalyzeModule[context, builtinTree];
WITH TypeFromTypeCode[context.types, GetTypeCodeAttribute[builtinTree]] SELECT FROM
r: REF TypeRep.record => IF r.class = $DEFINITIONS THEN {
FOR each: FieldList ¬ r.fieldList, each.rest UNTIL each = NIL DO
AddSymbol[context, each.first.name, NEW[SymbolTableEntryRep.other ¬ [other[typeCode: each.first.rangeType, readonly: TRUE, constantValue: NIL]]]];
ENDLOOP;
};
ENDCASE => ERROR;
Assert[SymTab.Delete[context.symbols, "AtomRep"]];
Assert[SymTab.Delete[context.symbols, "BUILTIN"]];
context.moduleName ¬ NIL;
};
NumericTypeClass: TYPE = { signed, unsigned, real, pointer, char, unspecified, reference, enumeration, nonnumeric };
reference allows only eq tests
enumeration allows only comparisons
nonnumeric allows only composite equality tests
NumericTypeClassOf: PROC [typeGraph: TypeGraph, typeCode: TypeCode] RETURNS [NumericTypeClass] = {
WITH UnderType[typeGraph, typeCode] SELECT FROM
s: REF TypeRep.subrange => { RETURN [NumericTypeClassOf[typeGraph, s.groundType]] };
s: REF TypeRep.record => {
IF s.fieldList # NIL AND s.fieldList.rest = NIL THEN RETURN [NumericTypeClassOf[typeGraph, s.fieldList.first.rangeType]];
};
s: REF TypeRep.scalar => {
SELECT s.class FROM
$INT16, $INT32, $DINT => RETURN [signed];
$CARD16, $CARD32, $DCARD => RETURN [unsigned];
$UNSPECIFIED => RETURN [unspecified];
$CHAR => RETURN [char];
$REAL, $DREAL => RETURN [real];
ENDCASE => NULL;
};
s: REF TypeRep.reference => {
SELECT s.class FROM
$POINTER, $LONGPOINTER => RETURN [pointer];
$REF, $LIST => RETURN [reference];
ENDCASE => NULL;
};
s: REF TypeRep.control => { RETURN [reference] };
s: REF TypeRep.enumerated => { RETURN [enumeration] };
ENDCASE => NULL;
RETURN [nonnumeric];
};
NamesFromFieldList: PROC [fieldList: FieldList] RETURNS [LIST OF REF] = {
IF fieldList = NIL OR fieldList.first.name = NIL THEN RETURN [NIL];
RETURN [CONS[fieldList.first.name, NamesFromFieldList[fieldList.rest]]]
};
GetTags: PROC [typeGraph: TypeGraph, typeCode: TypeCode] RETURNS [LIST OF REF] = {
tc: TypeCode ¬ typeCode;
tags: LIST OF REF ¬ NIL;
DO
WITH UnderType[typeGraph, tc] SELECT FROM
q: REF TypeRep.qualifiedVariant => {
tc ¬ q.groundType;
tags ¬ List.Nconc1[tags, q.qualifier];
};
ENDCASE => EXIT;
ENDLOOP;
RETURN [tags];
};
Symbols from Interfaces
NameFromVersionMap: PROC [shortName: ROPE] RETURNS [fullFName: ROPE] = {
rangeList: VersionMap.RangeList ¬ VersionMap.ShortNameToRanges[VersionMapDefaults.GetMapList[$Source], shortName];
FOR each: VersionMap.RangeList ¬ rangeList, each.rest UNTIL each = NIL DO
SELECT each.first.len FROM
0 => NULL;
1 => RETURN [VersionMap.RangeToEntry[each.first].name]
ENDCASE => RETURN [NARROW[Help["\"%g\" is ambiguous", [rope[shortName]]]]];
ENDLOOP;
RETURN [NIL];
};
GetFullName: PROC [fileName: ROPE] RETURNS [ROPE] = {
This supplies a .mesa extension if needed. If no directory is provided, it looks first in the local directory and then in the version map.
fullFName: ROPE;
cp: FS.ComponentPositions;
found: BOOL ¬ TRUE;
[fullFName, cp] ¬ FS.ExpandName[fileName];
IF cp.ext.length = 0 THEN {
[fullFName, cp] ¬ FS.ExpandName[Rope.Replace[base: fullFName, start: cp.base.start+cp.base.length, len: cp.ver.start-(cp.base.start+cp.base.length), with: ".mesa"]];
};
fullFName ¬ FS.FileInfo[name: fullFName ! FS.Error => IF error.group=user THEN {found ¬ FALSE; CONTINUE}].fullFName;
IF NOT found AND Rope.Fetch[fileName, 0] >= 'A THEN {
fullFName ¬ NameFromVersionMap[Rope.Substr[fullFName, cp.base.start, cp.base.length+cp.ext.length+1]];
};
RETURN [fullFName]
};
GetSymbols: PUBLIC PROC [context: Context, interfaceFileName: ROPE] RETURNS [REF TypeRep.record] = {
fullFName: ROPE = GetFullName[interfaceFileName];
WITH SymTab.Fetch[context.types.interfaceTable, fullFName].val SELECT FROM
r: REF TypeRep.record => RETURN [r];
a: ATOM => Assert[a # $INPROGRESS, "Recursive interface structure"];
ENDCASE => {
IF fullFName # NIL THEN {
tree: Tree = CrankIO.AddAttributeNodes[CrankIO.ParseFile[fullFName]];
innerContext: Context = NewContext[context];
Assert[SymTab.Insert[context.types.interfaceTable, fullFName, $INPROGRESS]];
WITH ProcessProps.GetProp[$StdOut] SELECT FROM
errout: IO.STREAM => IO.PutF[errout, "[%g from %g\n", [rope[interfaceFileName]], [rope[fullFName]]];
ENDCASE => NULL;
SIGNAL PushSource[fullFName];
AnalyzeModule[innerContext, tree];
SIGNAL PopSource;
WITH ProcessProps.GetProp[$StdOut] SELECT FROM
errout: IO.STREAM => IO.PutF1[errout, "End %g ]\n", [rope[interfaceFileName]]];
ENDCASE => NULL;
WITH TypeFromTypeCode[context.types, GetTypeCodeAttribute[tree]] SELECT FROM
r: REF TypeRep.record => IF r.class = $DEFINITIONS THEN {
[] ¬ SymTab.Store[context.types.interfaceTable, fullFName, r];
RETURN [r];
};
ENDCASE => NULL;
[] ¬ Help["\"%g\" is not a DEFINITIONS file", [rope[fullFName]],tree];
};
};
RETURN [NIL]
};
Semantic analysis
GetLeftRelOperand: SIGNAL RETURNS [Tree] = CODE;
AnalyzeBlockOrBody: PROC [context: Context, tree: Tree] = {
AnalyzeBodyOrExpression[context, tree, NIL, 1];
AnalyzeBodyOrExpression[context, tree, NIL, 2];
AnalyzeBodyOrExpression[context, tree, NIL, 3];
};
AnalyzeBodyOrExpression: PUBLIC PROC [context: Context, tree: Tree, parent: AttributedNode, pass: [1..3]] = {
self: AttributedNode = NARROW[tree];
Block: PROC [declarationsNode, bodyContentsNode: REF] = {
Body[openNode: NIL, declarationsNode: declarationsNode, bodyContentsNode: bodyContentsNode, exitsNode: NIL];
};
Open: PROC [itemNode, bodyContentsNode: REF] = {
Body[openNode: itemNode, declarationsNode: NIL, bodyContentsNode: bodyContentsNode, exitsNode: NIL];
};
Body: PROC [openNode, declarationsNode, bodyContentsNode, exitsNode: REF] = {
innerContext: Context ¬ NIL;
EachDecl: PROC [item: Tree] = {
Assert[AnalyzeDecl[innerContext, item, self, pass] OR AnalyzeTypeDecl[innerContext, item, self, pass]];
};
EachStatement: PROC [item: Tree] = {
AnalyzeStatement[innerContext, item];
};
IF pass = 1
THEN {
innerContext ¬ NewContext[context];
IF openNode # NIL THEN {
OpenItem: PROC [itemNode: REF] = {
Item: PROC [renameNode, exprNode: REF] = {
tc: TypeCode ¬ nullTypeCode;
dereferenceCount: INT ¬ 0;
AddFields: PROC = {
openId: ROPE = GenSym[context.types, "OPEN$"];
AddAttribute[NARROW[openNode], $OPENID, openId];
IF dereferenceCount > 0 THEN {
AddAttribute[NARROW[openNode], $DEREFERENCE, NEW[INT ¬ dereferenceCount]];
};
IF renameNode # NIL
THEN {
renameID: ROPE = GetIdentifier[renameNode];
AddSymbol[innerContext, renameID, NEW[SymbolTableEntryRep.other ¬ [other[typeCode: tc, readonly: TRUE, constantValue: NIL, qualifier: openId]]]];
}
ELSE {
Action: PROC [fieldIndex: INT, fieldName: ROPE, fieldTypeCode: TypeCode, tagName: ROPE, tagTypeCode: TypeCode] RETURNS [quit: BOOL ¬ FALSE] = {
IF fieldName # NIL THEN {
AddSymbol[innerContext, fieldName, NEW[SymbolTableEntryRep.other ¬ [other[typeCode: fieldTypeCode, readonly: FALSE, constantValue: NIL, qualifier: openId]]]];
};
IF tagName # NIL THEN {
AddSymbol[innerContext, tagName, NEW[SymbolTableEntryRep.other ¬ [other[typeCode: tagTypeCode, readonly: TRUE, constantValue: NIL, qualifier: openId]]]];
};
};
[] ¬ EnumerateFields[context.types, tc, Action];
};
};
Assert[AnalyzeExpression[context, exprNode]];
tc ¬ GetTypeCodeAttribute[exprNode];
DO
WITH UnderType[context.types, tc] SELECT FROM
t: REF TypeRep.record => {
SELECT t.class FROM
$STRUCTURE => {
IF t.fieldList # NIL AND t.fieldList.rest = NIL AND t.fieldList.first.name = NIL THEN {
tc ¬ t.fieldList.first.rangeType;
LOOP;
};
AddFields[];
};
$DEFINITIONS => {
IF renameNode # NIL
THEN AddFields[]
ELSE {
id: ROPE = GetIdentifier[exprNode];
WITH LookupSymbol[context, id] SELECT FROM
ste: REF SymbolTableEntryRep.directory => {
fieldList: FieldList = ste.interfaceRecordType.fieldList;
FOR each: FieldList ¬ fieldList, each.rest UNTIL each = NIL DO
name: ROPE = each.first.name;
use: BOOL ¬ NOT ste.hasUsing;
FOR u: LIST OF ROPE ¬ ste.using, u.rest UNTIL use OR u=NIL DO
use ¬ Rope.Equal[name, u.first];
ENDLOOP;
IF use THEN {
AddSymbol[innerContext, each.first.name, NEW[SymbolTableEntryRep.other ¬ [other[typeCode: each.first.rangeType, readonly: FALSE, constantValue: NIL, qualifier: GetUnderQualifier[context, id, each.first.name, each.first.rangeType]]]]];
};
ENDLOOP;
};
ENDCASE => [] ¬ Help["%g is not a DIRECTORY item", [rope[id]], openNode];
};
};
$RECORD => {AddFields[]};
ENDCASE => NULL;
};
t: REF TypeRep.qualifiedVariant => {AddFields[]};
t: REF TypeRep.simple => {
IF t.class = $OPAQUE
THEN {
concrete: TypeCode = GetConcreteTypeCode[context, t.typeCode];
IF concrete # nullTypeCode THEN {tc ¬ concrete; LOOP};
}
ELSE EXIT;
};
t: REF TypeRep.reference => {
tc ¬ t.referentType; -- try some dereferencing
dereferenceCount ¬ dereferenceCount + 1;
LOOP;
};
ENDCASE => NULL;
EXIT;
ENDLOOP;
innerContext ¬ NewContext[innerContext];
};
Assert[With2[itemNode, item, Item]];
};
DoList[openNode, OpenItem];
};
AddAttribute[self, $CONTEXT, innerContext];
WITH UnderType[context.types, GetTypeCodeAttribute[self, $NEEDTYPECODE]] SELECT FROM
type: REF TypeRep.control => {
arguments: REF TypeRep.record = NARROW[TypeFromTypeCode[context.types, type.argumentType]];
returns: REF TypeRep.record = NARROW[TypeFromTypeCode[context.types, type.returnType]];
AddSymbol[innerContext, "*RETURN-VALUE*", NEW[SymbolTableEntryRep.other ¬ [other[typeCode: type.returnType, readonly: FALSE, constantValue: NIL]]]];
AddFieldListToContext[innerContext, arguments.fieldList];
-- makes the names of the arguments known within the body.
AddFieldListToContext[innerContext, returns.fieldList];
-- makes the names of the return values known within the body.
IF type.class = $PROGRAM THEN { innerContext.scopeKind ¬ globalImpl };
};
type: REF TypeRep.record => {
Assert[type.class = $DEFINITIONS];
innerContext.fieldListLast ¬ type.fieldList ¬ LIST[[NIL, nullTypeCode]];
This creates a list head to accumulate the defined fields of the interface. This list head gets removed by AnalyzeDecl
innerContext.scopeKind ¬ globalDefs;
};
ENDCASE => NULL;
}
ELSE { innerContext ¬ NARROW[GetAttribute[self, $CONTEXT]] };
DoList[declarationsNode, EachDecl];
IF pass = 3 THEN DoList[bodyContentsNode, EachStatement];
Assert[exitsNode = NIL, "EXITS not implemented",, tree];
};
Inline: PROC [listNode: REF] = {
This is MACHINE CODE; it takes a list of lists, but we will just ignore it.
};
EntryOrInternal: PROC [bodyNode: REF] = {
IF pass = 1 THEN PropagateAttribute[bodyNode, $NEEDTYPECODE, self, $NEEDTYPECODE];
AnalyzeBodyOrExpression[context, bodyNode, NIL, pass];
};
Assert[With2[tree, block, Block] OR With4[tree, body, Body] OR With1[tree, entry, EntryOrInternal] OR With1[tree, internal, EntryOrInternal] OR With1[tree, inline, Inline] OR With2[tree, open, Open] OR (pass < 3 OR AnalyzeExpression[context, tree])];
};
AnalyzeExpression: PUBLIC PROC [context: Context, tree: Tree] RETURNS [BOOL] = {
RETURN [AnalyzeExpressionOrStatement[context, tree, FALSE]];
};
AnalyzeStatement: PUBLIC PROC [context: Context, tree: Tree] = {
Assert[AnalyzeExpressionOrStatement[context, tree, TRUE], "Statement expected here",,tree];
};
AnalyzeInterval: PROC [context: Context, tree: Tree, needType: TypeCode] = {
self: AttributedNode = NARROW[tree];
Interval: PROC [lowBoundNode, highBoundNode: REF] = {
AddTypeCodeAttribute[lowBoundNode, $NEEDTYPECODE, needType];
Assert[AnalyzeExpression[context, lowBoundNode],"Need expr",,lowBoundNode];
AddTypeCodeAttribute[highBoundNode, $NEEDTYPECODE, needType];
Assert[AnalyzeExpression[context, highBoundNode],"Need expr",,highBoundNode];
};
IF NOT (With2[self, intOO, Interval] OR With2[self, intCO, Interval] OR With2[self, intOC, Interval] OR With2[self, intCC, Interval]) THEN {
Must be a enumeration or subrange type
AnalyzeType[context, self];
WITH UnderType[context.types, GetTypeValueAttribute[context.types, self]] SELECT FROM
t: REF TypeRep.enumerated => {
};
t: REF TypeRep.subrange => {
};
ENDCASE => Assert[FALSE, "Interval, enumeration or subrange required here",, self];
};
};
FieldSelect: PROC [context: Context, self: AttributedNode, leftTypeCode: TypeCode, t: Type, id: ROPE, dereferenceCount: NAT] RETURNS [BOOL] = {
Action: PROC [fieldIndex: INT, fieldName: ROPE, fieldTypeCode: TypeCode, tagName: ROPE, tagTypeCode: TypeCode] RETURNS [quit: BOOL ¬ FALSE] = {
NoteAttributes: PROC [tc: TypeCode] = {
AddAttribute[self, $SLOTNUMBER, NEW[INT ¬ fieldIndex]];
IF dereferenceCount > 0 THEN {
AddAttribute[self, $DEREFERENCE, NEW[INT ¬ dereferenceCount]];
};
AddTypeCodeAttribute[self, $TYPECODE, tc];
};
IF Rope.Equal[fieldName, id] THEN {
N.B.: If there are nested variants, and the tags have the same name, this will select the first tag, but the compiler selects the last.
SELECT t.class FROM
$RECORD => {
self.syntaxNodeName ¬ $RECORDFIELDSELECT;
AddAttribute[self, $FROM, GetTypeName[context, leftTypeCode, FALSE]];
};
$STRUCTURE => {
self.syntaxNodeName ¬ $RETURNVALUESELECT;
};
$DEFINITIONS => {
self.syntaxNodeName ¬ $INTERFACESELECT;
};
$QUALIFIEDVARIANT => {
self.syntaxNodeName ¬ $VARIANTRECORDFIELDSELECT;
AddAttribute[self, $FROM, GetTypeName[context, leftTypeCode, FALSE]];
};
ENDCASE => [] ¬ Help["Unknown type class: %g", [atom[t.class]], self];
NoteAttributes[fieldTypeCode];
RETURN [TRUE];
};
IF Rope.Equal[tagName, id] AND tagTypeCode # nullTypeCode THEN {
AddAttribute[self, $FROM, GetTypeName[context, leftTypeCode, FALSE]];
NoteAttributes[tagTypeCode];
WITH UnderType[context.types, fieldTypeCode] SELECT FROM
u: REF TypeRep.union => {
self.syntaxNodeName ¬ $TAGFIELDSELECT;
};
s: REF TypeRep.sequence => {
self.syntaxNodeName ¬ $SEQUENCELIMITFIELDSELECT;
};
ENDCASE => Assert[FALSE];
RETURN [TRUE];
};
};
RETURN [EnumerateFields[context.types, leftTypeCode, Action]];
};
GetConstructorFieldList: PUBLIC PROC [context: Context, neededTypeCode: TypeCode] RETURNS [FieldList] = {
IF neededTypeCode # nullTypeCode THEN {
type: Type = UnderType[context.types, neededTypeCode];
WITH type SELECT FROM
t: REF TypeRep.record => { RETURN [t.fieldList] };
t: REF TypeRep.array => {
WITH UnderType[context.types, t.domainType] SELECT FROM
d: REF TypeRep.enumerated => {
RETURN [FieldListFromEnumeration[d.items, t.rangeType]]
};
ENDCASE => {
f: FieldList = LIST[[name: NIL, rangeType: t.rangeType]];
Here we create one node that points to itself. This should be OK, because
A. it is not enough circular garbage to matter,
B. we don't try to print it out,
C. the place it is used below does not try to traverse it.
We do it this way because we don't have enough static constant evaluation to know how to do any better.
f.rest ¬ f;
RETURN [f]
};
};
ENDCASE => NULL;
};
Assert[FALSE, "Constructor of unknown type"];
RETURN [NIL]
};
AnalyzeExpressionOrStatement: PROC [context: Context, tree: Tree, analyzeStatement: BOOL] RETURNS [BOOL] = {
self: AttributedNode = NARROW[tree];
FunnyApply: PROC [applyNode: REF] = {
PropagateAttribute[applyNode, $NEEDTYPECODE, self, $NEEDTYPECODE];
IF GetNodeName[applyNode] = $APPLY
THEN { Assert[AnalyzeExpression[context, applyNode]] }
ELSE { Apply[applyNode, NIL, NIL] };
};
Apply: PROC [operatorNode, operandListNode, catchNode: REF] = {
typeCode: TypeCode ¬ GetTypeCodeAttribute[self, $NEEDTYPECODE];
fieldList: FieldList ¬ NIL;
keywordOperands: BOOL ¬ FALSE;
positionalOperands: BOOL ¬ FALSE;
AnalyzeOperand: PROC [exprNode: REF, rangeType: TypeCode] = {
AddTypeCodeAttribute[exprNode, $NEEDTYPECODE, rangeType];
Assert[AnalyzeExpression[context, exprNode]]
};
EachOperand: PROC [operandListItemNode: REF] = {
NamedOperand: PROC [nameNode, exprNode: REF] = {
id: ROPE = GetIdentifier[nameNode];
keywordOperands ¬ TRUE;
Assert[NOT positionalOperands, "Mixed keyword/positional notation",, tree];
FOR each: FieldList ¬ fieldList, each.rest UNTIL each = NIL DO
IF Rope.Equal[each.first.name, id, TRUE] THEN {
AnalyzeOperand[exprNode, each.first.rangeType];
RETURN;
};
ENDLOOP;
Assert[FALSE, "Unknown field name: %g", [rope[id]], self];
};
IF NOT With2[operandListItemNode, item, NamedOperand] THEN {
positionalOperands ¬ TRUE;
Assert[NOT keywordOperands, "Mixed keyword/positional notation",, tree];
IF fieldList = NIL
THEN { [] ¬ Help["Too many items in group",,self] }
ELSE {
AnalyzeOperand[operandListItemNode, fieldList.first.rangeType];
fieldList ¬ fieldList.rest;
};
};
};
WITH UnderType[context.types, typeCode] SELECT FROM
u: REF TypeRep.union => {
id: ROPE = GetIdentifier[operatorNode];
found: BOOL ¬ FALSE;
FOR each: VariantList ¬ u.variantList, each.rest UNTIL found OR each = NIL DO
IF Rope.Equal[id, NARROW[each.first.value]] THEN {
fieldList ¬ each.first.chooses;
found ¬ TRUE;
self.syntaxNodeName ¬ $MAKEVARIANT;
};
ENDLOOP;
Assert[found, "%g does not name a variant", [rope[id]], self];
};
ENDCASE => {
IF operatorNode = NIL
THEN {
A constructor of some sort.
tc: TypeCode ¬ typeCode;
DO
WITH UnderType[context.types, tc] SELECT FROM
t: REF TypeRep.array => {
self.syntaxNodeName ¬ $MAKEARRAY;
AddAttribute[self, $DOMAINTYPE, GetTypeName[context, t.domainType, TRUE]];
EXIT
};
t: REF TypeRep.record => {
SELECT t.class FROM
$RECORD => {
self.syntaxNodeName ¬ $MAKERECORD;
AddAttribute[self, $FROM, GetTypeName[context, typeCode, TRUE]];
};
ENDCASE => [] ¬ Help["I don't think this should happen",,tree];
EXIT;
};
t: REF TypeRep.qualifiedVariant => tc ¬ t.groundType;
ENDCASE => {[] ¬ Help["vasis?",,tree]; EXIT};
ENDLOOP;
fieldList ¬ GetConstructorFieldList[context, tc];
}
ELSE {
tc: TypeCode ¬ nullTypeCode;
dereferenceCount: NAT ¬ 0;
Assert[AnalyzeExpression[context, operatorNode]];
tc ¬ GetTypeCodeAttribute[operatorNode, $TYPECODE];
DO
WITH UnderType[context.types, tc] SELECT FROM
t: REF TypeRep.control => {
AssertNotVar[self];
fieldList ¬ GetConstructorFieldList[context, t.argumentType];
self.syntaxNodeName ¬ (
SELECT t.class FROM
$PROC => $FUNCTIONAPPLY,
$SIGNAL => $SIGNALAPPLY,
$ERROR => $ERRORAPPLY,
$PROGRAM => $STARTAPPLY,
ENDCASE => ERROR);
IF t.class # $ERROR THEN typeCode ¬ t.returnType;
};
t: REF TypeRep.array => {
fieldList ¬ LIST[[name: NIL, rangeType: t.domainType]];
self.syntaxNodeName ¬ $ARRAYACCESS;
typeCode ¬ t.rangeType;
};
t: REF TypeRep.type => {
This might be a coercion, or an obsolete notation for variant records, or a concrete sequence type in a NEW or SIZE.
need: Type = UnderType[context.types, GetTypeCodeAttribute[self, $NEEDTYPECODE]];
IF need#NIL AND need.class = $TYPE
THEN {
Looking for a type, so it can't be a coercion
IF GetAttribute[self, $SIZEORNEW] # NIL THEN {
This is inside a SIZE or NEW, so it is OK to dive in deeper to see if we have a SEQUENCE type.
d: Type = GetSequenceInfo[context.types, t.value].domain;
IF d # NIL THEN {
AddTypeCodeAttribute[operandListNode, $NEEDTYPECODE, d.typeCode];
Assert[AnalyzeExpression[context, operandListNode], "expr required",,self];
AddTypeCodeAttribute[self, $TYPECODE, tc];
self.syntaxNodeName ¬ $SEQUENCEALLOC;
RETURN
};
};
{
This must be an obsolete notation for variant records
id: ROPE = GetIdentifier[operandListNode];
q: TypeCode = QualifyVariant[context.types, t.value, id];
AddTypeCodeAttribute[self, $TYPECODE, NewTypeType[context.types, q]];
self.syntaxNodeName ¬ $DISCRIMINATE;
RETURN; -- don't process the operand further!
};
}
ELSE {
Looking for a non-type, so it must be a coercion or a named constructor
WITH UnderType[context.types, t.value] SELECT FROM
r: REF TypeRep.record => {
self.syntaxNodeName ¬ $MAKERECORD;
AddAttribute[self, $FROM, GetTypeName[context, t.value, TRUE]];
fieldList ¬ r.fieldList;
};
a: REF TypeRep.array => {
self.syntaxNodeName ¬ $MAKEARRAY;
AddAttribute[self, $DOMAINTYPE, GetTypeName[context, a.domainType, TRUE]];
};
ENDCASE => {
self.syntaxNodeName ¬ $COERCE;
fieldList ¬ LIST[[name: NIL, rangeType: t.value]]
};
typeCode ¬ t.value;
};
};
t: REF TypeRep.qualifiedVariant => {
This is probably a sugared sequence access.
r: ROPE; s: TypeCode;
[sequenceFieldName: r, sequenceTypeCode: s] ¬ GetSequenceInfo[context.types, t.typeCode];
IF s # nullTypeCode THEN {
AddAttribute[self, $SEQUENCEFIELDNAME, r];
AddAttribute[self, $TAGS, GetTags[context.types, t.typeCode]];
tc ¬ s;
LOOP;
};
Assert[FALSE, "Unknown operator type for apply",,self];
};
t: REF TypeRep.record => {
This is probably a sugared sequence access.
r: ROPE; s: TypeCode;
[sequenceFieldName: r, sequenceTypeCode: s] ¬ GetSequenceInfo[context.types, t.typeCode];
IF s # nullTypeCode THEN {
AddAttribute[self, $SEQUENCEFIELDNAME, r];
AddAttribute[self, $FROM, GetTypeName[context, GetTypeCodeAttribute[operatorNode, $TYPECODE], FALSE]];
tc ¬ s;
LOOP;
};
Assert[FALSE, "Unknown operator type for apply",,self];
};
t: REF TypeRep.sequence => {
fieldList ¬ LIST[[name: NIL, rangeType: t.domainType]];
self.syntaxNodeName ¬ $SEQUENCEACCESS;
typeCode ¬ t.rangeType;
};
t: REF TypeRep.reference => {
Dereference until we can apply
tc ¬ t.referentType;
dereferenceCount ¬ dereferenceCount + 1;
LOOP;
};
ENDCASE => Assert[FALSE, "Unknown operator type for apply",,self];
EXIT;
ENDLOOP;
IF dereferenceCount > 0 THEN {
AddAttribute[self, $DEREFERENCE, NEW[INT ¬ dereferenceCount]];
};
};
};
{ fieldNames: LIST OF REF = NamesFromFieldList[fieldList];
IF fieldNames # NIL THEN {
AddAttribute[self, $FIELDNAMES, fieldNames];
};
};
DoList[operandListNode, EachOperand];
IF catchNode # NIL THEN Assert[With2[catchNode, catch, Catch]];
AddTypeCodeAttribute[self, $TYPECODE, typeCode];
};
Error: PROC [operandNode: REF] = {
Assert[AnalyzeExpression[context, operandNode]];
};
SysError: PROC = { };
ListCons: PROC [zoneNode, listNode: REF ] = {
elementTypeCode: TypeCode = GetListElementTypeCode[context.types, GetTypeCodeAttribute[self, $NEEDTYPECODE]];
EachElement: PROC [elementNode: REF] = {
AddTypeCodeAttribute[elementNode, $NEEDTYPECODE, elementTypeCode];
Assert[AnalyzeExpression[context, elementNode], "Expr needed here",, self];
};
DoList[listNode, EachElement];
};
If: PROC [conditionalNode, truePartNode, falsePartNode: REF] = {
tc: TypeCode ¬ IF analyzeStatement THEN nullTypeCode ELSE GetTypeCodeAttribute[self, $NEEDTYPECODE];
AddTypeCodeAttribute[conditionalNode, $NEEDTYPECODE, LookupTypeCode[Root[context], "BOOL"]];
IF tc # nullTypeCode THEN PropagateAttribute[truePartNode, $NEEDTYPECODE, self, $NEEDTYPECODE];
Assert[AnalyzeExpression[context, conditionalNode]];
Assert[AnalyzeExpressionOrStatement[context, truePartNode, analyzeStatement]];
IF NOT analyzeStatement THEN {
IF tc = nullTypeCode THEN tc ¬ GetTypeCodeAttribute[truePartNode];
AddTypeCodeAttribute[falsePartNode, $NEEDTYPECODE, tc];
};
Assert[AnalyzeExpressionOrStatement[context, falsePartNode, analyzeStatement]];
IF tc # nullTypeCode THEN AddTypeCodeAttribute[self, $TYPECODE, tc];
};
Do: PROC [iterationControlNode, terminationTestNode, whatsitNode, loopBodyNode, huhNode, whyNode: REF] = {
innerContext: Context = NewContext[context];
EachStatement: PROC [item: Tree] = {
AnalyzeStatement[innerContext, item];
};
ForSeq: PROC [declNode, initValueNode, nextValueNode: REF] = {
IF GetNodeName[declNode] = $DECL
THEN {
Assert[AnalyzeDecl[innerContext, declNode, self, 1]];
Assert[AnalyzeDecl[innerContext, declNode, self, 2]];
Assert[AnalyzeDecl[innerContext, declNode, self, 3]];
PropagateAttribute[initValueNode, $NEEDTYPECODE, NARROW[declNode], $DECLTYPECODE];
}
ELSE {
AddAttribute[NARROW[declNode], $VAR, $TRUE];
Assert[AnalyzeExpression[innerContext, declNode]];
PropagateAttribute[initValueNode, $NEEDTYPECODE, NARROW[declNode], $TYPECODE];
};
Assert[AnalyzeExpression[context, initValueNode]];
IF nextValueNode # NIL THEN {
PropagateAttribute[nextValueNode, $NEEDTYPECODE, NARROW[initValueNode], $NEEDTYPECODE];
Assert[AnalyzeExpression[innerContext, nextValueNode]];
};
};
Thru: PROC [declNode, rangeNode, whatsthisNode: REF] = {
needType: TypeCode ¬ nullTypeCode;
Assert[whatsthisNode=NIL];
IF declNode # NIL THEN {
IF GetNodeName[declNode] = $DECL
THEN {
Assert[AnalyzeDecl[innerContext, declNode, self, 1]];
Assert[AnalyzeDecl[innerContext, declNode, self, 2]];
Assert[AnalyzeDecl[innerContext, declNode, self, 3]];
needType ¬ GetTypeCodeAttribute[declNode, $DECLTYPECODE];
}
ELSE {
AddAttribute[NARROW[declNode], $VAR, $TRUE];
Assert[AnalyzeExpression[innerContext, declNode]];
needType ¬ GetTypeCodeAttribute[declNode, $TYPECODE];
};
};
AnalyzeInterval[innerContext, rangeNode, needType];
};
Assert[analyzeStatement AND whatsitNode=NIL AND huhNode=NIL AND whyNode=NIL, "Unimplemented loop construct",,self];
Assert[iterationControlNode = NIL OR With3[iterationControlNode, forseq, ForSeq] OR With3[iterationControlNode, upthru, Thru] OR With3[iterationControlNode, downthru, Thru]];
IF terminationTestNode # NIL THEN {
AddTypeCodeAttribute[terminationTestNode, $NEEDTYPECODE, LookupTypeCode[Root[innerContext], "BOOL"]];
Assert[AnalyzeExpression[innerContext, terminationTestNode]];
};
DoList[loopBodyNode, EachStatement];
};
Return: PROC [returnValuesNode: REF] = {
IF returnValuesNode # NIL THEN {
fieldList: FieldList ¬ NIL;
keywordOperands: BOOL ¬ FALSE;
positionalOperands: BOOL ¬ FALSE;
EachReturnValue: PROC [returnValueItemNode: REF] = {
Named: PROC [nameNode, exprNode: REF] = {
id: ROPE = GetIdentifier[nameNode];
keywordOperands ¬ TRUE;
Assert[NOT positionalOperands, "Mixed keyword/positional notation",, tree];
FOR each: FieldList ¬ fieldList, each.rest UNTIL each = NIL DO
IF Rope.Equal[each.first.name, id, TRUE] THEN {
AddTypeCodeAttribute[exprNode, $NEEDTYPECODE, each.first.rangeType];
Assert[AnalyzeExpression[context, exprNode]];
RETURN;
};
ENDLOOP;
Assert[FALSE, "Unknown field name: %g", [rope[id]], self];
};
IF NOT With2[returnValueItemNode, item, Named] THEN {
positionalOperands ¬ TRUE;
Assert[NOT keywordOperands, "Mixed keyword/positional notation",, tree];
IF fieldList = NIL
THEN { [] ¬ Help["Too many items in group",,self] }
ELSE {
AddTypeCodeAttribute[returnValueItemNode, $NEEDTYPECODE, fieldList.first.rangeType];
Assert[AnalyzeExpression[context, returnValueItemNode], "Expr expected in returnValuesNode",, tree];
fieldList ¬ fieldList.rest;
};
};
};
WITH LookupSymbol[context, IF GetNodeName[self] = $RETURN THEN "*RETURN-VALUE*" ELSE "*RESUME-VALUE*"] SELECT FROM
ste: REF SymbolTableEntryRep.other => {
WITH UnderType[context.types, ste.typeCode] SELECT FROM
r: REF TypeRep.record => fieldList ¬ r.fieldList;
ENDCASE => NULL;
};
ENDCASE => Assert[FALSE, "No return value expected here",,self];
DoList[returnValuesNode, EachReturnValue];
};
};
Case: PROC [exprNode, caseListNode, endcaseNode: REF] = {
needTypeCode: TypeCode ¬ GetTypeCodeAttribute[self, $NEEDTYPECODE];
first: BOOL ¬ TRUE;
booleanTypeCode: TypeCode = LookupTypeCode[Root[context], "BOOL"];
EachCase: PROC [itemNode: Tree] = {
DoItem: PROC [conditionNode, choosesNode: REF] = {
EachCond: PROC [condItemNode: Tree] = {
AddTypeCodeAttribute[condItemNode, $NEEDTYPECODE, booleanTypeCode];
Assert[AnalyzeExpression[context, condItemNode
! GetLeftRelOperand => { RESUME[exprNode] }
], "Expr expected",, condItemNode];
};
DoList[conditionNode, EachCond];
IF NOT analyzeStatement THEN AddTypeCodeAttribute[choosesNode, $NEEDTYPECODE, needTypeCode];
Assert[AnalyzeExpressionOrStatement[context, choosesNode, analyzeStatement],,,choosesNode];
IF NOT analyzeStatement AND first AND needTypeCode = nullTypeCode THEN {
needTypeCode ¬ GetTypeCodeAttribute[choosesNode, $TYPECODE];
};
first ¬ FALSE;
};
Assert[With2[itemNode, item, DoItem], "Item expected",, itemNode];
};
Assert[AnalyzeExpression[context, exprNode]];
DoList[caseListNode, EachCase];
IF NOT analyzeStatement THEN AddTypeCodeAttribute[endcaseNode, $NEEDTYPECODE, needTypeCode];
Assert[AnalyzeExpressionOrStatement[context, endcaseNode, analyzeStatement],,,endcaseNode];
IF NOT analyzeStatement THEN AddTypeCodeAttribute[self, $TYPECODE, needTypeCode];
};
Bind: PROC [selectOnNode, whatsitNode, caseListNode, endcaseNode: REF] = {
needTypeCode: TypeCode ¬ GetTypeCodeAttribute[self, $NEEDTYPECODE];
first: BOOL ¬ TRUE;
unsafeSelectID: ROPE ¬ NIL;
unsafeSelectType: Type ¬ NIL;
SelectOn: PROC [renameNode, exprNode: REF] = {
Assert[AnalyzeExpression[context, exprNode]];
IF renameNode # NIL THEN {
unsafeSelectID ¬ GetIdentifier[renameNode];
unsafeSelectType ¬ UnderType[context.types, GetTypeCodeAttribute[exprNode]];
};
};
CaseList: PROC [selectBranchItemNode: Tree] = {
SelectBranchItem: PROC [declNode, choosesNode: REF] = {
innerContext: Context = NewContext[context];
IF unsafeSelectType # NIL
THEN {
q: TypeCode = QualifyVariant[context.types, unsafeSelectType.typeCode, GetIdentifier[declNode]];
AddSymbol[context: innerContext, id: unsafeSelectID, val: NEW[SymbolTableEntryRep.other ¬ [other[typeCode: q, readonly: TRUE]]]];
}
ELSE {
Assert[AnalyzeDecl[innerContext, declNode, NIL, 1], "Decl expected",,declNode];
[] ¬ AnalyzeDecl[innerContext, declNode, NIL, 2];
[] ¬ AnalyzeDecl[innerContext, declNode, NIL, 3];
};
IF NOT analyzeStatement THEN AddTypeCodeAttribute[choosesNode, $NEEDTYPECODE, needTypeCode];
Assert[AnalyzeExpressionOrStatement[innerContext, choosesNode, analyzeStatement],,,choosesNode];
IF NOT analyzeStatement AND first AND needTypeCode = nullTypeCode THEN {
needTypeCode ¬ GetTypeCodeAttribute[choosesNode, $TYPECODE];
};
};
Assert[With2[selectBranchItemNode, item, SelectBranchItem]];
};
Assert[With2[selectOnNode, item, SelectOn]];
Assert[whatsitNode=NIL,"What's the second node mean?",,self];
DoList[caseListNode, CaseList];
Assert[AnalyzeExpressionOrStatement[context, endcaseNode, analyzeStatement],,,endcaseNode];
IF NOT analyzeStatement THEN AddTypeCodeAttribute[self, $TYPECODE, needTypeCode];
};
Assign: PROC [lhsNode, rhsNode: REF] = {
AddAttribute[NARROW[lhsNode], $VAR, $TRUE];
Assert[AnalyzeExpression[context, lhsNode]];
PropagateAttribute[rhsNode, $NEEDTYPECODE, NARROW[lhsNode], $TYPECODE];
WITH UnderType[context.types, GetTypeCodeAttribute[lhsNode]] SELECT FROM
t: REF TypeRep => {
AddAttribute[self, $ASSIGNTYPECLASS, t.class];
IF t.class = $RECORD THEN {
AddAttribute[self, $FROM, GetTypeName[context, GetTypeCodeAttribute[lhsNode], FALSE]];
};
};
ENDCASE => NULL;
Assert[AnalyzeExpression[context, rhsNode]];
IF NOT analyzeStatement THEN PropagateAttribute[self, $TYPECODE, NARROW[lhsNode], $TYPECODE];
};
Extract: PROC [lhsNode, rhsNode: REF] = {
keywordOperands: BOOL ¬ FALSE;
positionalOperands: BOOL ¬ FALSE;
fieldList: FieldList ¬ NIL;
AnalyzeDest: PROC [destNode: REF, typeCode: TypeCode] = {
AddAttribute[NARROW[destNode], $VAR, $TRUE];
AddTypeCodeAttribute[destNode, $NEEDTYPECODE, typeCode];
Assert[AnalyzeExpression[context, destNode]];
};
Each: PROC [lhsElementNode: REF] = {
Named: PROC [nameNode, destNode: REF] = {
id: ROPE = GetIdentifier[nameNode];
keywordOperands ¬ TRUE;
Assert[NOT positionalOperands, "Mixed keyword/positional notation",, tree];
FOR each: FieldList ¬ fieldList, each.rest UNTIL each = NIL DO
IF Rope.Equal[each.first.name, id, TRUE] THEN {
AnalyzeDest[destNode, each.first.rangeType];
RETURN;
};
ENDLOOP;
Assert[FALSE, "Unknown field name: %g", [rope[id]], self];
};
IF lhsElementNode = NIL OR NOT With2[lhsElementNode, item, Named] THEN {
positionalOperands ¬ TRUE;
Assert[NOT keywordOperands, "Mixed keyword/positional notation",, tree];
IF fieldList = NIL
THEN { [] ¬ Help["Too many items in group",,self] }
ELSE {
IF lhsElementNode # NIL THEN AnalyzeDest[lhsElementNode, fieldList.first.rangeType];
fieldList ¬ fieldList.rest;
};
};
};
Assert[AnalyzeExpression[context, rhsNode]];
fieldList ¬ GetConstructorFieldList[context, GetTypeCodeAttribute[rhsNode]];
DoList[lhsNode, Each];
IF NOT analyzeStatement THEN PropagateAttribute[self, $TYPECODE, NARROW[rhsNode], $TYPECODE];
};
Unary: PROC [operandNode: REF] = {
AssertNotVar[self];
PropagateAttribute[operandNode, $NEEDTYPECODE, self, $NEEDTYPECODE];
Assert[AnalyzeExpression[context, operandNode]];
PropagateAttribute[self, $TYPECODE, NARROW[operandNode], $TYPECODE];
};
BinaryOp: PROC [aNode, bNode: REF] = {
aClass, bClass, dClass: NumericTypeClass ¬ nonnumeric;
AssertNotVar[self];
Assert[AnalyzeExpression[context, aNode]];
Assert[AnalyzeExpression[context, bNode]];
aClass ¬ NumericTypeClassOf[context.types, GetTypeCodeAttribute[aNode]];
bClass ¬ NumericTypeClassOf[context.types, GetTypeCodeAttribute[bNode]];
dClass ¬ NumericTypeClassOf[context.types, GetTypeCodeAttribute[self, $NEEDTYPECODE]];
IF self.syntaxNodeName = $PLUS OR self.syntaxNodeName = $MINUS THEN {
IF aClass = unspecified AND bClass = unspecified THEN {
PropagateAttribute[self, $TYPECODE, self, $NEEDTYPECODE];
RETURN;
};
IF aClass = unspecified THEN {
PropagateAttribute[self, $TYPECODE, NARROW[bNode], $TYPECODE];
RETURN;
};
IF bClass = unspecified THEN {
PropagateAttribute[self, $TYPECODE, NARROW[aNode], $TYPECODE];
RETURN;
};
IF warnPointerArith AND aClass = pointer THEN Assert[true: FALSE, format: "warning: Pointer arithmetic", tree: self];
SELECT aClass FROM
pointer, char => {
IF bClass IN [signed..unsigned] THEN {
PropagateAttribute[self, $TYPECODE, NARROW[aNode], $TYPECODE];
RETURN;
};
IF bClass = aClass AND self.syntaxNodeName = $MINUS THEN {
AddTypeCodeAttribute[self, $TYPECODE, LookupTypeCode[Root[context], "INT"]];
RETURN;
};
};
ENDCASE => NULL;
IF self.syntaxNodeName = $PLUS THEN SELECT bClass FROM
pointer, char => {
IF aClass IN [signed..unsigned] THEN {
PropagateAttribute[self, $TYPECODE, NARROW[bNode], $TYPECODE];
RETURN;
};
};
ENDCASE => NULL;
};
Assert[aClass IN [signed..real] AND bClass IN [signed..real], "Can't do arithmetic with this type",,self];
IF aClass # real AND bClass # real AND self.syntaxNodeName = $DIV THEN {
self.syntaxNodeName ¬ $IDIV
};
IF aClass = real OR bClass = real OR dClass = real
THEN {
realCode: TypeCode = LookupTypeCode[Root[context], "REAL"];
AddAttribute[self, $ARITHTYPE, $REAL];
IF aClass # real THEN {
AddAttribute[NARROW[aNode], $COERCIONS, Coercions[context: context, from: GetTypeCodeAttribute[aNode], to: realCode, tree: aNode]];
};
IF bClass # real THEN {
AddAttribute[NARROW[bNode], $COERCIONS, Coercions[context: context, from: GetTypeCodeAttribute[bNode], to: realCode, tree: bNode]];
};
AddTypeCodeAttribute[self, $TYPECODE, realCode];
}
ELSE {
IF self.syntaxNodeName = $DIV THEN self.syntaxNodeName ¬ $IDIV;
PropagateAttribute[self, $TYPECODE, NARROW[aNode], $TYPECODE];
};
};
BinaryBoolOp: PROC [aNode, bNode: REF] = {
AssertNotVar[self];
PropagateAttribute[aNode, $NEEDTYPECODE, self, $NEEDTYPECODE];
Assert[AnalyzeExpression[context, aNode]];
PropagateAttribute[bNode, $NEEDTYPECODE, self, $NEEDTYPECODE];
Assert[AnalyzeExpression[context, bNode]];
PropagateAttribute[self, $TYPECODE, NARROW[bNode], $TYPECODE];
};
RelOp: PROC [aNode, bNode: REF] = {
typeCode: TypeCode ¬ nullTypeCode;
aClass, bClass: NumericTypeClass ¬ nonnumeric;
AssertNotVar[self];
IF aNode = NIL
THEN {
If aNode is NIL, we are probably inside a case or casex, and need to get aNode from above. In this case, it has already been analyzed.
aNode ¬ SIGNAL GetLeftRelOperand[];
}
ELSE Assert[AnalyzeExpression[context, aNode]];
typeCode ¬ GetTypeCodeAttribute[aNode, $TYPECODE];
WITH UnderType[context.types, typeCode] SELECT FROM
t: REF TypeRep.record => {
IF t.class = $STRUCTURE AND t.fieldList # NIL AND t.fieldList.rest = NIL
THEN {
one-component structure; try coercion to element type
typeCode ¬ t.fieldList.first.rangeType
};
};
ENDCASE => NULL;
WITH UnderType[context.types, typeCode] SELECT FROM
t: REF TypeRep.scalar => NULL;
ENDCASE => AddTypeCodeAttribute[bNode, $NEEDTYPECODE, typeCode];
Assert[AnalyzeExpression[context, bNode]];
aClass ¬ NumericTypeClassOf[context.types, GetTypeCodeAttribute[aNode]];
bClass ¬ NumericTypeClassOf[context.types, GetTypeCodeAttribute[bNode]];
IF aClass = real OR bClass = real
THEN {
realCode: TypeCode = LookupTypeCode[Root[context], "REAL"];
AddAttribute[self, $COMPARETYPE, $REAL];
IF aClass # real THEN {
AddAttribute[NARROW[aNode], $COERCIONS, Coercions[context: context, from: GetTypeCodeAttribute[aNode], to: realCode, tree: aNode]];
};
IF bClass # real THEN {
AddAttribute[NARROW[bNode], $COERCIONS, Coercions[context: context, from: GetTypeCodeAttribute[bNode], to: realCode, tree: bNode]];
};
}
ELSE {
ct: ATOM ¬ NIL;
SELECT TRUE FROM
aClass IN [signed..unsigned] AND aClass IN [signed..unsigned] => ct ¬ $INTEGER;
aClass = unspecified OR bClass = unspecified => ct ¬ $UNSPECIFIED;
aClass = pointer AND bClass = pointer => ct ¬ $POINTER;
aClass = reference AND bClass = reference => ct ¬ $POINTER;
aClass = char AND bClass = char => ct ¬ $CHAR;
aClass = enumeration AND bClass = enumeration => ct ¬ $ENUMERATION;
aClass = nonnumeric AND bClass = nonnumeric => ct ¬ $COMPOSITE;
ENDCASE => Assert[FALSE, "Bad comparison",,self];
IF ct # NIL THEN AddAttribute[self, $COMPARETYPE, ct];
};
AddTypeCodeAttribute[self, $TYPECODE, LookupTypeCode[Root[context], "BOOL"]];
};
All: PROC [operandNode: REF] = {
AssertNotVar[self];
WITH UnderType[context.types, GetTypeCodeAttribute[self, $NEEDTYPECODE]] SELECT FROM
t: REF TypeRep.array => {
AddTypeCodeAttribute[operandNode, $NEEDTYPECODE, t.rangeType];
Assert[AnalyzeExpression[context, operandNode]];
AddTypeCodeAttribute[self, $TYPECODE, t.typeCode];
};
ENDCASE => Assert[FALSE, "ALL's not well here",, self];
};
In: PROC [exprNode, rangeNode: REF] = {
typeCode: TypeCode ¬ nullTypeCode;
AssertNotVar[self];
IF exprNode = NIL
THEN {
If exprNode is NIL, we are probably inside a case or casex, and need to get aNode from above. In this case, it has already been analyzed.
exprNode ¬ SIGNAL GetLeftRelOperand[];
}
ELSE Assert[AnalyzeExpression[context, exprNode]];
typeCode ¬ GetTypeCodeAttribute[exprNode, $TYPECODE];
WITH UnderType[context.types, typeCode] SELECT FROM
t: REF TypeRep.record => {
IF t.fieldList # NIL AND t.fieldList.rest = NIL
THEN {
one-component structure; try coercion to element type
typeCode ¬ t.fieldList.first.rangeType
};
};
ENDCASE => NULL;
AnalyzeInterval[context, rangeNode, typeCode];
AddTypeCodeAttribute[self, $TYPECODE, LookupTypeCode[Root[context], "BOOL"]];
};
Dot: PROC [leftNode, rightNode: REF] = {
id: ROPE ¬ GetIdentifier[rightNode];
dereferenceCount: NAT ¬ 0;
leftTypeCode: TypeCode ¬ nullTypeCode;
Assert[AnalyzeExpression[context, leftNode]];
leftTypeCode ¬ GetTypeCodeAttribute[leftNode];
DO
WITH UnderType[context.types, leftTypeCode] SELECT FROM
t: REF TypeRep.type => {
WITH UnderType[context.types, t.value] SELECT FROM
et: REF TypeRep.enumerated => {
WITH rightNode SELECT FROM
a: AttributedNode => {
a.syntaxNodeName ¬ $ENUMERATIONLITERAL;
AddTypeCodeAttribute[a, $TYPECODE, t.value];
AddAttribute[a, $FROM, GetTypeName[context, t.value, FALSE]];
self.syntaxNodeName ¬ $ENUMERATIONSELECT;
AddTypeCodeAttribute[self, $TYPECODE, t.value];
};
ENDCASE => ERROR;
};
ENDCASE => {
q: TypeCode = QualifyVariant[context.types, t.value, id];
self.syntaxNodeName ¬ $DISCRIMINATE;
AddTypeCodeAttribute[self, $TYPECODE, NewTypeType[context.types, q]];
};
RETURN;
};
t: REF TypeRep.record => {
IF FieldSelect[context, self, leftTypeCode, t, id, dereferenceCount] THEN {
IF t.class = $DEFINITIONS THEN {
QualifyIdentifierNode[rightNode, GetUnderQualifier[context, GetIdentifier[leftNode], id, GetTypeCodeAttribute[self]]];
};
RETURN;
};
IF t.fieldList # NIL AND t.fieldList.rest = NIL
THEN {
one-component structure; try coercion to element type
leftTypeCode ¬ t.fieldList.first.rangeType
}
ELSE EXIT;
};
t: REF TypeRep.qualifiedVariant => {
IF FieldSelect[context, self, leftTypeCode, t, id, dereferenceCount] THEN RETURN ELSE EXIT;
};
t: REF TypeRep.simple => {
IF t.class = $OPAQUE
THEN {
concrete: TypeCode = GetConcreteTypeCode[context, t.typeCode];
IF concrete = nullTypeCode THEN EXIT ELSE leftTypeCode ¬ concrete;
}
ELSE EXIT;
};
t: REF TypeRep.reference => {
leftTypeCode ¬ t.referentType; -- try some dereferencing
dereferenceCount ¬ dereferenceCount + 1;
};
t: REF TypeRep.control => {
IF NARROW[leftNode, AttributedNode].syntaxNodeName = $FUNKYAPPLY
THEN { leftTypeCode ¬ t.returnType }
ELSE EXIT;
};
ENDCASE => EXIT;
ENDLOOP;
It is not a type or a structure or a reference to a structure, so it must be object notation.
WITH GetTypeName[context, GetTypeCodeAttribute[leftNode], FALSE] SELECT FROM
l: LIST OF REF => {
WITH LookupSymbol[context, NARROW[l.first]] SELECT FROM
ste: REF SymbolTableEntryRep.directory => {
Action: PROC [fieldIndex: INT, fieldName: ROPE, fieldTypeCode: TypeCode, tagName: ROPE, tagTypeCode: TypeCode] RETURNS [quit: BOOL ¬ FALSE] = {
Assert[tagTypeCode=nullTypeCode];
IF Rope.Equal[fieldName, id] THEN {
use: BOOL ¬ NOT ste.hasUsing;
FOR u: LIST OF ROPE ¬ ste.using, u.rest UNTIL use OR u=NIL DO
use ¬ Rope.Equal[id, u.first];
ENDLOOP;
IF use THEN {
WITH UnderType[context.types, fieldTypeCode] SELECT FROM
p: REF TypeRep.control => {
WITH UnderType[context.types, p.argumentType] SELECT FROM
s: REF TypeRep.record => {
IF s.fieldList # NIL THEN {
Should make sure that leftNode type is compatible with s.fieldList.first.rangeType
newArgumentType: TypeCode = NewType[context.types, NEW[TypeRep.record ¬ [class: $STRUCTURE, v: record[fieldList: s.fieldList.rest]]]];
procTypeCode: TypeCode = NewType[context.types, NEW[TypeRep.control ¬ [class: $PROC, v: control[argumentType: newArgumentType, returnType: p.returnType]]]];
self.syntaxNodeName ¬ $FUNKYAPPLY;
QualifyIdentifierNode[rightNode, NARROW[l.first]];
AddAttribute[self, $FROMINTERFACE, l.first];
AddTypeCodeAttribute[self, $TYPECODE, procTypeCode];
RETURN [TRUE];
};
};
ENDCASE => NULL;
};
ENDCASE => NULL;
};
};
};
IF ste.interfaceRecordType # NIL AND EnumerateFields[context.types, ste.interfaceRecordType.typeCode, Action] THEN RETURN;
};
ENDCASE => NULL;
};
ENDCASE => NULL;
[] ¬ Help["Unable to deciper this dot notation",,self];
};
Addr: PROC [operandNode: REF] = {
AddAttribute[NARROW[operandNode], $VAR, $TRUE];
WITH UnderType[context.types, GetTypeCodeAttribute[self, $NEEDTYPECODE]] SELECT FROM
t: REF TypeRep.reference => {AddTypeCodeAttribute[operandNode, $NEEDTYPECODE, t.referentType]};
ENDCASE => NULL;
Assert[AnalyzeExpression[context, operandNode]];
IF GetTypeCodeAttribute[self, $NEEDTYPECODE] # nullTypeCode
THEN { PropagateAttribute[self, $TYPECODE, self, $NEEDTYPECODE] }
ELSE {
AddTypeCodeAttribute[self, $TYPECODE, NewReferenceType[typeGraph: context.types, referentType: GetTypeCodeAttribute[operandNode], class: $LONGPOINTER]];
};
};
Uparrow: PROC [operandNode: REF] = {
Assert[AnalyzeExpression[context, operandNode]];
WITH UnderType[context.types, GetTypeCodeAttribute[operandNode]] SELECT FROM
t: REF TypeRep.reference => {AddTypeCodeAttribute[self, $TYPECODE, t.referentType]};
ENDCASE => Assert[FALSE, "Reference type required here",, operandNode];
};
MinMax: PROC [listNode: REF] = {
needTypeCode: TypeCode ¬ GetTypeCodeAttribute[self, $NEEDTYPECODE];
first: BOOL ¬ TRUE;
EachOperand: PROC [operandNode: REF] = {
AddTypeCodeAttribute[operandNode, $NEEDTYPECODE, needTypeCode];
Assert[AnalyzeExpression[context, operandNode]];
IF first THEN {
needTypeCode ¬ GetTypeCodeAttribute[operandNode, $TYPECODE];
first ¬ FALSE;
};
};
AssertNotVar[self];
DoList[listNode, EachOperand];
AddTypeCodeAttribute[self, $TYPECODE, needTypeCode];
};
Lengthen: PROC [operandNode: REF] = {
typeCode: TypeCode ¬ GetTypeCodeAttribute[self, $NEEDTYPECODE];
IF typeCode # nullTypeCode THEN {
typeCode ← LengthenTypeCode[context, typeCode]; do this later
AddTypeCodeAttribute[operandNode, $NEEDTYPECODE, typeCode];
};
Assert[AnalyzeExpression[context, operandNode]];
typeCode ¬ GetTypeCodeAttribute[operandNode, $TYPECODE];
typeCode ← LengthenTypeCode[context, typeCode]; do this later
AddTypeCodeAttribute[self, $TYPECODE, typeCode];
};
Size: PROC [typeNode, packingNode: REF] = {
AssertNotVar[self];
AddAttribute[NARROW[typeNode], $SIZEORNEW, $TRUE];
AnalyzeType[context, typeNode];
IF packingNode # NIL THEN {
AddTypeCodeAttribute[packingNode, $NEEDTYPECODE, LookupTypeCode[Root[context], "INT"]];
Assert[AnalyzeExpression[context, packingNode]];
};
AddTypeCodeAttribute[self, $TYPECODE, LookupTypeCode[Root[context], "INT"]];
};
FirstLast: PROC [typeNode: REF] = {
AnalyzeType[context, typeNode];
AddTypeCodeAttribute[self, $TYPECODE, GetTypeValueAttribute[context.types, typeNode]];
WITH UnderType[context.types, GetTypeValueAttribute[context.types, typeNode]] SELECT FROM
t: REF TypeRep.subrange => NULL;
t: REF TypeRep.scalar => NULL;
t: REF TypeRep.enumerated => NULL;
ENDCASE => Assert[FALSE, "Scalar, subrange, or enumeration type required here",, typeNode];
};
Narrow: PROC [exprNode, typeNode: REF] = {
Assert[AnalyzeExpression[context, exprNode]];
IF typeNode = NIL
THEN {
PropagateAttribute[self, $TYPECODE, self, $NEEDTYPECODE];
}
ELSE {
AnalyzeType[context, typeNode];
AddTypeCodeAttribute[self, $TYPECODE, GetTypeValueAttribute[context.types, typeNode]];
};
};
Nil: PROC [typeNode: REF] = {
IF typeNode = NIL
THEN {PropagateAttribute[self, $TYPECODE, self, $NEEDTYPECODE]}
ELSE {
AnalyzeType[context, typeNode];
AddTypeCodeAttribute[self, $TYPECODE, GetTypeValueAttribute[context.types, typeNode]];
WITH UnderType[context.types, GetTypeValueAttribute[context.types, typeNode]] SELECT FROM
t: REF TypeRep.reference => NULL;
ENDCASE => Assert[FALSE, "Reference type required here",, typeNode];
};
};
New: PROC [zoneNode, typeNode, valueNode: REF] = {
AssertNotVar[self];
AddAttribute[NARROW[typeNode], $SIZEORNEW, $TRUE];
AnalyzeType[context, typeNode];
IF valueNode # NIL THEN {
AddTypeCodeAttribute[valueNode, $NEEDTYPECODE, GetTypeValueAttribute[context.types, typeNode]];
Assert[AnalyzeExpression[context, valueNode]];
};
AddTypeCodeAttribute[self, $TYPECODE, NewReferenceType[context.types, GetTypeValueAttribute[context.types, typeNode], $REF]];
};
CharLit: PROC [exprNode: REF] = {
AddTypeCodeAttribute[exprNode, $NEEDTYPECODE, LookupTypeCode[Root[context], "CHAR"]];
Assert[AnalyzeExpression[context, exprNode]];
AddTypeCodeAttribute[self, $TYPECODE, LookupTypeCode[Root[context], "CHAR"]];
};
Cons: PROC [zoneNode, argListNode: REF] = {
ArgList: PROC [newElementNode, oldListNode: REF] = {
listTypeCode: TypeCode = GetTypeCodeAttribute[self, $NEEDTYPECODE];
elementTypeCode: TypeCode = GetListElementTypeCode[context.types, listTypeCode];
AddTypeCodeAttribute[newElementNode, $NEEDTYPECODE, elementTypeCode];
Assert[AnalyzeExpression[context, newElementNode]];
AddTypeCodeAttribute[oldListNode, $NEEDTYPECODE, listTypeCode];
Assert[AnalyzeExpression[context, oldListNode]];
};
Assert[With2[argListNode, list, ArgList], "CONS takes two arguments",,self];
};
Atom: PROC [operandNode: REF] = {
AddTypeCodeAttribute[operandNode, $NEEDTYPECODE, LookupTypeCode[Root[context], "ATOM"]];
Assert[AnalyzeExpression[context, operandNode]];
PropagateAttribute[self, $TYPECODE, NARROW[operandNode], $NEEDTYPECODE];
};
Cast: PROC [operandNode: REF] = {
IF operandNode # NIL THEN {
PropagateAttribute[operandNode, $NEEDTYPECODE, self, $NEEDTYPECODE];
Assert[AnalyzeExpression[context, operandNode]];
PropagateAttribute[self, $TYPECODE, self, $NEEDTYPECODE];
};
};
Float: PROC [operandNode: REF] = {
AddTypeCodeAttribute[operandNode, $NEEDTYPECODE, LookupTypeCode[Root[context], "REAL"]];
Assert[AnalyzeExpression[context, operandNode]];
PropagateAttribute[self, $TYPECODE, NARROW[operandNode], $NEEDTYPECODE];
};
Ord: PROC [operandNode: REF] = {
Assert[AnalyzeExpression[context, operandNode]];
PropagateAttribute[self, $TYPECODE, self, $NEEDTYPECODE];
};
MWConst: PROC [operandNode: REF] = {
IF operandNode # NIL THEN {
PropagateAttribute[operandNode, $NEEDTYPECODE, self, $NEEDTYPECODE];
Assert[AnalyzeExpression[context, operandNode]];
PropagateAttribute[self, $TYPECODE, NARROW[operandNode], $TYPECODE];
};
};
Identifier: PROC [id: ROPE] = {
WITH BaseType[context.types, GetTypeCodeAttribute[self, $NEEDTYPECODE]] SELECT FROM
t: REF TypeRep.enumerated => {
FOR each: LIST OF EnumerationItem ¬ t.items, each.rest UNTIL each = NIL DO
IF Rope.Equal[each.first.name, id] THEN {
AssertNotVar[self];
PropagateAttribute[self, $TYPECODE, self, $NEEDTYPECODE];
self.syntaxNodeName ¬ $ENUMERATIONLITERAL;
AddAttribute[self, $FROM, GetTypeName[context, GetTypeCodeAttribute[self, $NEEDTYPECODE], FALSE]];
AddAttribute[self, $ORDINALVALUE, NEW[CARD ¬ each.first.value]];
RETURN;
};
ENDLOOP;
};
ENDCASE => NULL;
WITH LookupSymbol[context, id] SELECT FROM
ste: REF SymbolTableEntryRep.directory => {
AssertNotVar[self];
AddTypeCodeAttribute[self, $TYPECODE, ste.interfaceRecordType.typeCode];
};
ste: REF SymbolTableEntryRep.other => {
IF ste.readonly THEN AssertNotVar[self];
AddTypeCodeAttribute[self, $TYPECODE, ste.typeCode];
QualifyIdentifierNode[self, ste.qualifier];
};
ENDCASE => Assert[FALSE, "Identifier not an expression: %g", [rope[id]], self];
};
Enable: PROC [catchNode, statementNode: REF] = {
IF catchNode # NIL THEN Assert[With2[catchNode, catch, Catch]];
AnalyzeStatement[context, statementNode];
};
Label: PROC [statementNode, itemsNode: REF] = {
LabelItem: PROC [itemNode: REF] = {
LabelledStatement: PROC [labelNode, labelledStatementNode: REF] = {
AnalyzeStatement[context, labelledStatementNode];
};
Assert[With2[itemNode, item, LabelledStatement], "???",,itemsNode];
};
AnalyzeStatement[context, statementNode];
DoList[itemsNode, LabelItem];
};
Catch: PROC [itemNode, whatsitNode: REF] = {
CatchItem: PROC [signalNode, statementNode: REF] = {
innerContext: Context ¬ context;
IF GetNodeName[signalNode] = $ID AND Rope.Equal[GetIdentifier[signalNode], "UNWIND"]
THEN NULL
ELSE {
IF AnalyzeExpression[context, signalNode] THEN {
signalTypeCode: TypeCode = GetTypeCodeAttribute[signalNode];
innerContext ¬ NewContext[context];
WITH UnderType[context.types, signalTypeCode] SELECT FROM
type: REF TypeRep.control => {
WITH UnderType[context.types, type.argumentType] SELECT FROM
arguments: REF TypeRep.record => {
AddFieldListToContext[innerContext, arguments.fieldList];
-- makes the names of the arguments known within the body.
};
ENDCASE => NULL;
IF type.class = $SIGNAL THEN {
WITH UnderType[context.types, type.returnType] SELECT FROM
returns: REF TypeRep.record => {
AddSymbol[innerContext, "*RESUME-VALUE*", NEW[SymbolTableEntryRep.other ¬ [other[typeCode: type.returnType, readonly: FALSE, constantValue: NIL]]]];
AddFieldListToContext[innerContext, returns.fieldList];
};
ENDCASE => NULL;
};
};
ENDCASE => NULL;
};
};
AnalyzeStatement[innerContext, statementNode];
};
Assert[whatsitNode = NIL, "whatsit?",,whatsitNode];
Assert[With2[itemNode, item, CatchItem], "Bad catch",,self];
};
Literal: PROC [literal: REF MPLeaves.LTNode] = {
Should do some checking here.
typeName: ROPE ¬ NIL;
WITH literal.value SELECT FROM
r: REF REAL => typeName ¬ "REAL";
r: REF DREAL => typeName ¬ "DREAL";
r: REF INT => typeName ¬ "INT32";
r: REF DINT => IFIN INT32 THEN typeName ¬ "INT32" ELSE IFIN DINT[0..CARD32.LAST] THEN typeName ¬ "CARD32" ELSE typeName ¬ "DINT";
r: REF CARD => typeName ¬ "CARD32";
r: REF DCARD => IFIN CARD32 THEN typeName ¬ "CARD32" ELSE typeName ¬ "DCARD";
r: REF CHAR => typeName ¬ "CHAR";
ENDCASE => NULL;
IF typeName # NIL
THEN {AddTypeCodeAttribute[self, $TYPECODE, LookupTypeCode[Root[context], typeName]]}
ELSE {PropagateAttribute[self, $TYPECODE, self, $NEEDTYPECODE]};
};
IF analyzeStatement
THEN {
Oops: PROC = {
[] ¬ Help["Unimplemented statement kind: %g", [refAny[GetNodeName[self]]], self];
};
EachStatement: PROC [item: Tree] = { AnalyzeStatement[context, item] };
IF self = NIL THEN RETURN [TRUE];
IF GetNodeName[self] = $ID THEN {
Should be a proc (or signal or error) with no arguments.
FunnyApply[self];
Should inspect GetAttribute[self, $TYPECODE];
RETURN [TRUE]
};
IF WithId[self, Identifier] THEN {
Should check that this is a proc (or signal or error) with no arguments.
RETURN [TRUE]
};
SELECT GetNodeNameCode[self] FROM
void => NULL;
list => DoList[self, EachStatement];
block => AnalyzeBlockOrBody[context, self];
body => AnalyzeBlockOrBody[context, self];
apply => DoWith3[self, Apply];
assign => DoWith2[self, Assign];
extract => DoWith2[self, Extract];
if => DoWith3[self, If];
case => DoWith3[self, Case];
bind => DoWith4[self, Bind];
do => DoWith6[self, Do];
return => DoWith1[self, Return];
result => Oops[];
goto => NULL;
exit => NULL;
loop => NULL;
free => Oops[];
resume => DoWith1[self, Return];
reject => NULL;
continue => NULL;
retry => Oops[];
lock, wait, notify, broadcast, unlock => Oops[];
null => NULL;
label => DoWith2[self, Label];
open => AnalyzeBlockOrBody[context, self];
enable => DoWith2[self, Enable];
dst, lst, lstf => Oops[];
syscall => NULL;
checked => DoWith1[self, EachStatement];
subst, call, portcall => Oops[];
signal => DoWith1[self, FunnyApply];
error => DoWith1[self, FunnyApply];
syserror => NULL;
xerror => DoWith1[self, FunnyApply];
start, join => Oops[];
ENDCASE => RETURN [FALSE];
RETURN [TRUE]
}
ELSE {
Oops: PROC = {
[] ¬ Help["Unimplemented expression kind: %g", [refAny[GetNodeName[self]]], self];
};
IF NOT (WithId[self, Identifier] OR WithLiteral[self, Literal]) THEN {
SELECT GetNodeNameCode[self] FROM
apply => DoWith3[self, Apply];
errorx => DoWith1[self, FunnyApply];
syserrorx => NULL;
callx, portcallx, signalx, startx, fork, joinx => Oops[];
index, dindex, seqindex, reloc => Oops[];
construct, union, rowcons, sequence => Oops[];
listcons => DoWith2[self, ListCons];
substx => Oops[];
ifx => DoWith3[self, If];
casex => DoWith3[self, Case];
bindx => DoWith4[self, Bind];
assignx => DoWith2[self, Assign];
or => DoWith2[self, BinaryBoolOp];
and => DoWith2[self, BinaryBoolOp];
relE => DoWith2[self, RelOp];
relN => DoWith2[self, RelOp];
relL => DoWith2[self, RelOp];
relGE => DoWith2[self, RelOp];
relG => DoWith2[self, RelOp];
relLE => DoWith2[self, RelOp];
in => DoWith2[self, In];
notin => DoWith2[self, In];
plus => DoWith2[self, BinaryOp];
minus => DoWith2[self, BinaryOp];
times => DoWith2[self, BinaryOp];
div => DoWith2[self, BinaryOp];
mod => DoWith2[self, BinaryOp];
power => DoWith2[self, BinaryOp];
dot => DoWith2[self, Dot];
cdot, dollar, create => Oops[];
not => DoWith1[self, Unary];
uminus => DoWith1[self, Unary];
addr => DoWith1[self, Addr];
uparrow => DoWith1[self, Uparrow];
min => DoWith1[self, MinMax];
max => DoWith1[self, MinMax];
lengthen => DoWith1[self, Lengthen];
abs => DoWith1[self, Unary];
all => DoWith1[self, All];
size => DoWith2[self, Size];
first => DoWith1[self, FirstLast];
last => DoWith1[self, FirstLast];
pred => DoWith1[self, Unary];
succ => DoWith1[self, Unary];
val => DoWith1[self, Ord];
ord => DoWith1[self, Ord];
arraydesc, length, base => Oops[];
loophole => DoWith2[self, Narrow];
nil => DoWith1[self, Nil];
new => DoWith3[self, New];
void => PropagateAttribute[self, $TYPECODE, self, $NEEDTYPECODE];
clit => DoWith1[self, CharLit];
llit => Oops[];
cast => DoWith1[self, Cast];
float => DoWith1[self, Float];
check, float, pad, chop, safen => Oops[];
syscallx => Oops[];
narrow => DoWith2[self, Narrow];
istype, openx => Oops[];
mwconst => DoWith1[self, MWConst];
cons => DoWith2[self, Cons];
atom => DoWith1[self, Atom];
typecode, stringinit, textlit => Oops[];
signalinit => NULL;
procinit => Oops[];
ENDCASE => RETURN [FALSE];
};
{ need: TypeCode = GetTypeCodeAttribute[self, $NEEDTYPECODE];
have: TypeCode = GetTypeCodeAttribute[self, $TYPECODE];
IF need # nullTypeCode AND have # nullTypeCode THEN {
coercions: LIST OF REF ¬ Coercions[context: context, from: have, to: need, tree: self];
IF coercions # NIL THEN { AddAttribute[self, $COERCIONS, coercions] };
};
};
RETURN [TRUE];
};
};
END.