CCTypesImpl.mesa
Copyright Ó 1990 by Xerox Corporation. All rights reserved.
Sturgis: April 2, 1990 4:51 pm PDT
theimer May 17, 1989 3:56:07 pm PDT
Last changed by Theimer on August 10, 1989 3:17:00 pm PDT
Hopcroft July 26, 1989 11:02:36 am PDT
Last tweaked by Mike Spreitzer on January 9, 1992 2:32 pm PST
Laurie Horton, September 18, 1991 6:04 pm PDT
DIRECTORY
AmpersandContext USING[CreateAmpersandContextType, CreateNodeType],
Basics USING[BITXOR, HighHalf, LowHalf],
CCTypes USING[BinaryTargetTypes, CCError, CCErrorCase, CCTypeProcs, CheckConformance, ConformanceCheck, Conforms, CreateFrameNodeForSelf, IdFieldCase, IsAnIndirect, LoadIdField, LR, Operator, SelectIdField, GetScopeIndex, GetTargetTypeOfIndirect, LocalCedarTargetWorld],
CedarCode USING[CodeToGetNameContext, CodeToLoadNameScope, CodeToLoadThroughIndirect, CodeToMakeAMNode, CodeToSelectField, CodeToStoreUnpopped, CodeToDoUnaryOp, ConcatCode, CreateCedarNode, ExtractFieldFromNode, GetDataFromNode, GetTypeOfNode, LoadThroughIndirectNode, OperationsBody, Operator, SelectFieldFromNode, StoreThroughIndirectNode, AdvanceNameScope, ShowNode],
CedarNumericTypes,
CirioSyntacticOperations USING[NameArgPair, ParseTree],
CirioTypes USING[bitsPerAu, bitsPerPtr, BitAddr, BitStretch, CirioAddress, CirioAddressBody, Code, CompilerContext, CompilerContextBody, Mem, Nat, Node, PtrReg, Type, TypeBody, TypeClass, TypedCode, unspecdBA, zeroBA],
IO,
RefTypes USING[CreateNilRefType],
PointerTypes USING[CreatePointerType, CreateNilPointerType],
RefTab USING[Create, Fetch, Key, Ref, Store],
Rope USING[Fetch, ROPE, Cat],
StructuredStreams;
CCTypesImpl: CEDAR PROGRAM
IMPORTS AmpersandContext, Basics, CCTypes, CedarCode, CedarNumericTypes, IO, RefTab, RefTypes, PointerTypes, Rope, StructuredStreams
EXPORTS CCTypes, CirioTypes
SHARES CirioTypes
= BEGIN OPEN SS:StructuredStreams;
CCE: ERROR[case: CCTypes.CCErrorCase, msg: Rope.ROPENIL] ← CCTypes.CCError;
Nat: TYPE = CirioTypes.Nat;
ROPE: TYPE = Rope.ROPE;
BitAddr: TYPE = CirioTypes.BitAddr;
BitStretch: TYPE = CirioTypes.BitStretch;
PtrReg: TYPE = CirioTypes.PtrReg;
Mem: TYPE = CirioTypes.Mem;
Node: TYPE = CirioTypes.Node;
TypedCode: TYPE = CirioTypes.TypedCode;
Operator: TYPE = CCTypes.Operator;
CC: TYPE = CirioTypes.CompilerContext;
unspecdBA: BitAddr ~ CirioTypes.unspecdBA;
zeroBA: BitAddr ~ CirioTypes.zeroBA;
bitsPerAu: Nat ~ CirioTypes.bitsPerAu;
bitsPerPtr: Nat ~ CirioTypes.bitsPerPtr;
CompilerTypeContext: TYPE = REF CompilerTypeContextBody;
CompilerTypeContextBody: PUBLIC TYPE = RECORD[
finalDefaultType: Type,
wrongType: Type,
nodeType: Type,
booleanType: Type,
charType: Type,
ropeType: Type,
anyTargetType: Type,
refAnyType: Type,
nilRefType: Type,
ampersandContextType: Type,
ampersandVarType: Type,
emptyType: Type,
conformingTypePairs: RefTab.Ref,
conformanceTestDepth: INT,
nilPointerType: Type,
localCedarTargetWorld: CCTypes.LocalCedarTargetWorld,
cirioAddressType: Type,
cedarNumericTypes: RefTab.Ref
];
CreateCedarCompilerContext: PUBLIC PROC RETURNS[CirioTypes.CompilerContext] =
BEGIN
ctc: CompilerTypeContext ← NEW[CompilerTypeContextBody];
tempCC: CirioTypes.CompilerContext ← NEW[CirioTypes.CompilerContextBody←[ctc:ctc]];
ctc.finalDefaultType ← NIL;
ctc.finalDefaultType ← CreateCedarType[$finalDefault, FinalDefaultTypeTypeProcs, DefaultIndirectTypeProcs, tempCC]; -- note that cc.finalDefaultType = NIL during this call, so that the defaults placed in cc.finalDefaultType will be NIL
ctc.wrongType ← CreateCedarType[$wrong, NIL, NIL, tempCC];
ctc.nodeType ← AmpersandContext.CreateNodeType[tempCC];
ctc.booleanType ← NIL; --filled in by target world
ctc.charType ← NIL; --filled in by target world
ctc.ropeType ← NIL; --filled in by target world
ctc.anyTargetType ← CreateAnyTargetType[tempCC];
ctc.refAnyType ← NIL; --filled in by target world
ctc.nilRefType ← RefTypes.CreateNilRefType[tempCC];
ctc.nilPointerType ← PointerTypes.CreateNilPointerType[tempCC];
ctc.ampersandContextType ← AmpersandContext.CreateAmpersandContextType[tempCC];
ctc.ampersandVarType ← GetIndirectType[ctc.nodeType];
ctc.emptyType ← CreateEmptyType[tempCC];
ctc.conformingTypePairs ← RefTab.Create[equal: EqualTypePairs, hash: HashTypePairs];
ctc.conformanceTestDepth ← 0;
ctc.localCedarTargetWorld ← NIL;
ctc.cirioAddressType ← NIL;
ctc.cedarNumericTypes ← RefTab.Create[equal: EqualND, hash: HashND];
RETURN[NEW[CirioTypes.CompilerContextBody←[
ctc: ctc,
moduleScope: NIL,
nameScope: NIL]]];
END;
Type: TYPE = REF TypeBody;
TypeBody: TYPE = CirioTypes.TypeBody;
(An indirect type will have indirectType=NIL and targetType#NIL. A direct type will have indirectType#NIL and targetType=NIL.)
(TypeBody is exported to CirioTypes)
CreateCedarType: PUBLIC PROC[class: CirioTypes.TypeClass, typeOps, indirectTypeOps: REF CCTypes.CCTypeProcs, cc: CC, procData: REF ANYNIL, defaultType: Type ← NIL] RETURNS[Type] =
BEGIN
adt: Type ← IF defaultType # NIL THEN defaultType ELSE cc.ctc.finalDefaultType;
dt: Type ← NEW[TypeBody←[class, typeOps, procData, adt, NIL, NIL]];
it: Type ← NEW[TypeBody←[class, indirectTypeOps, procData, IF adt=NIL THEN NIL ELSE adt.indirectType, NIL, NIL]];
dt.indirectType ← it;
it.targetType ← dt;
RETURN[dt];
END;
13-Dec-90 MJS: I surveyed all calls on CreateCedarType, and found that only definition types (created in DefinitionsImpl) supply a non-nil defaultType.
16-Dec-91 MJS: DeferringTypes now also supply non-nil defaultTypes.
TypeIsntNil: PUBLIC PROC [t: Type, cc: CC] RETURNS [Type] ~ {
IF t=NIL THEN CCError[cirioError, "some special type isn't defined yet"];
RETURN[t]};
IsIndirectType: PUBLIC PROC [type: Type] RETURNS [BOOLEAN] =
BEGIN
IF type.indirectType = NIL THEN RETURN [TRUE]
ELSE RETURN [FALSE];
END;
GetTargetTypeOfIndirect: PUBLIC PROC[indirectType: Type] RETURNS[Type] =
BEGIN
IF indirectType.targetType = NIL THEN CCError[cirioError];
RETURN[indirectType.targetType];
END;
GetIndirectType: PUBLIC PROC[targetType: Type] RETURNS[Type] =
BEGIN
IF targetType.indirectType = NIL THEN CCError[cirioError];
RETURN[targetType.indirectType];
END;
GetTypeClass: PUBLIC PROC[type: Type] RETURNS[CirioTypes.TypeClass] = {
IF type.class # $defer THEN RETURN[type.class];
RETURN GetTypeClass[type.defaultType]};
exported to CC
GetProcDataFromType: PUBLIC PROC[type: Type] RETURNS[REF ANY] = {
IF type.class # $defer THEN RETURN[type.procData];
RETURN GetProcDataFromType[type.defaultType]};
GetDefaultTypeFromType: PUBLIC PROC[type: Type] RETURNS[Type] = {
IF type.class # $defer THEN RETURN[type.defaultType];
RETURN GetDefaultTypeFromType[type.defaultType]};
GetGroundTypeClass: PUBLIC PROC [type: Type, cc: CC] RETURNS [CirioTypes.TypeClass] = {
groundType: Type ← GetGroundType[type, cc, NIL];
RETURN GetTypeClass[groundType]};
GetProcDataFromGroundType: PUBLIC PROC[type: Type, cc: CC] RETURNS[REF ANY] = {
groundType: Type ← GetGroundType[type, cc, NIL];
RETURN GetProcDataFromType[groundType]};
should eventually add appropriate error msg stuff
FinalDefaultTypeTypeProcs: REF CCTypes.CCTypeProcs ← NEW[CCTypes.CCTypeProcs ←[
checkConformance: FinalDefaultCheckConformance,
checkFamilyInclusion: FinalDefaultCheckFamilyInclusion,
isASingleton: FinalDefaultIsASingleton,
storable: FinalDefaultStorable,
isAnIndirect: FinalDefaultIsAnIndirect,
containsVariance: FinalDefaultContainsVariance,
getNVariants: FinalDefaultGetNVariants,
coerceToType: FinalDefaultCoerceToType,
binaryOperandTypes: FinalDefaultBinaryOperandTypes,
loadIdVal: FinalDefaultLoadIdVal,
getTypeRepresentation: FinalDefaultGetTypeRepresentation,
getGroundType: FinalDefaultGetGroundType,
printType: FinalDefaultPrintType]];
a rather crude test.
FinalDefaultCheckConformance: PROC[valType, varType: Type, cc: CC, procData: REF ANY] RETURNS[CCTypes.ConformanceCheck] =
{RETURN[IF valType = varType THEN yes ELSE no]};
We only get here if the valType is a singleton.
I don't know if what I have coded here is correct. What I should be doing is checking that the valType occurs in the varType family. (That would be family inclusion.)
This test is stronger than that. (If the varType were a multi-type family including valType, then this test would fail.) However, perhaps any point at which this might be called the varType is aware that it is a special case of a collection of CedarTypes, some of which are multi-element families. This is certainly the case for RefTargetTypes.
On the other hand, this test is weaker than family inclusion, because it only checks that the singleton types conform in both directions, not that they are equal.
FinalDefaultCheckFamilyInclusion: PROC[valType, varType: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] =
{RETURN[IsASingleton[varType, cc] AND Conforms[valType, varType, cc] AND Conforms[varType, valType, cc]]};
FinalDefaultIsASingleton: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] =
{RETURN[TRUE]};
FinalDefaultStorable: PROC[valType, indirectType: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] =
{RETURN[Conforms[valType, GetLTargetType[indirectType, cc], cc]]};
FinalDefaultIsAnIndirect: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] =
{RETURN[FALSE]};
FinalDefaultContainsVariance: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] =
{RETURN[FALSE]};
FinalDefaultGetNVariants: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[INT] =
{RETURN[0]};
Its ok if we already conform
FinalDefaultCoerceToType: PROC[targetType: Type, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
IF CCTypes.Conforms[tc.type, targetType, cc] THEN
RETURN[tc]
ELSE CCError[operation, "can not coerce to an appropriate type for the given operation"];
END;
FinalDefaultBinaryOperandTypes: PROC[op: CedarCode.Operator, left, right: Type, cc: CC, procData: REF ANY] RETURNS[CCTypes.BinaryTargetTypes] =
BEGIN
rightClass: CirioTypes.TypeClass ← GetGroundTypeClass[right, cc];
SELECT rightClass FROM
$wrong, $amnode => RETURN[[right, right]];
ENDCASE => RETURN[[left, right]];
END;
Use the current nameScope
[WARNING: at least when loading frame name scopes, a run time type check should be made. This corresponds to handling union types. Therefore, some of this code will migrate out to the Type object routines?]
FinalDefaultLoadIdVal: PROC[id: ROPE, targetType: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
actualNameScope: Node ← cc.nameScope;
load: TypedCode ← CCTypes.LoadIdField[id, CedarCode.GetTypeOfNode[actualNameScope], cc];
value: TypedCode ← [
CedarCode.ConcatCode[
CedarCode.CodeToLoadNameScope[],
load.code],
load.type];
RETURN[value];
END;
FinalDefaultGetTypeRepresentation: PROC [type: Type, cc: CC, procData: REF ANY] RETURNS[REF ANY]
= {RETURN[type.procData]};
FinalDefaultGetGroundType: PROC [type: Type, cc: CC, procData: REF ANY] RETURNS [Type] = {
RETURN [type];
};
FinalDefaultPrintType: PROC [to: IO.STREAM, type: Type, printDepth: INT, printWidth: INT, cc: CC, procData: REF ANY]= {
to.PutRope["<type that doesn't know how to print>"];
RETURN};
DefaultIndirectPrintType: PROC [to: IO.STREAM, type: Type, printDepth: INT, printWidth: INT, cc: CC, procData: REF ANY] = {
to.PutRope["VAR "];
PrintType[to, GetTargetTypeOfIndirect[type], printDepth-(IF brave THEN 0 ELSE 1), printWidth, cc];
RETURN};
brave: BOOLFALSE;
CreateAnyTargetType: PROC[cc: CC] RETURNS[Type] =
{RETURN[CreateCedarType[$anyTarget, AnyTargetTypeProcs, NIL, cc, NIL]]};
not yet sure what should be here
AnyTargetTypeProcs: REF CCTypes.CCTypeProcs ← NEW[CCTypes.CCTypeProcs ←[
]];
DefaultIndirectTypeProcs: REF CCTypes.CCTypeProcs ← NEW[CCTypes.CCTypeProcs ←[
checkConformance: DefaultIndirectTypeCheckConformance,
binaryOperandTypes: DefaultIndirectTypeBinaryOperandTypes,
isAnIndirect: DefaultIndirectTypeIsAnIndirect,
getRTargetType: DefaultIndirectGetRTargetType,
getLTargetType: DefaultIndirectGetLTargetType,
operand: DefaultIndirectOperand,
coerceToType: DefaultIndirectTypeCoerceToType,
unaryOp: DefaultIndirectUnaryOp,
store: DefaultIndirectTypeStore,
load: DefaultIndirectTypeLoad,
getGroundType: FinalDefaultGetGroundType,
printType: DefaultIndirectPrintType]];
I still don't understand indirect type conformity. However, if one takes the view that an indirect really supplies two procs and that we are checking conformity of those two proc types, then we get the following test. However, this doesn't check higher order features of the indirect. Merely checks that target types are ok.
note: valType was the control parameter
DefaultIndirectTypeCheckConformance: PROC[valType, varType: Type, cc: CC, procData: REF ANY] RETURNS[CCTypes.ConformanceCheck] =
BEGIN
IF NOT CCTypes.IsAnIndirect[varType, cc] THEN RETURN[no]
ELSE
BEGIN
nominalValTarget: Type ← GetRTargetType[valType, cc];
nominalVarTarget: Type ← GetRTargetType[varType, cc];
got to be able to handle non indirect varType types without an error
IF IsASingleton[nominalValTarget, cc] AND IsASingleton[nominalVarTarget, cc] THEN
BEGIN
conforms1: CCTypes.ConformanceCheck;
conforms2: CCTypes.ConformanceCheck;
conforms1 ← CCTypes.CheckConformance[nominalValTarget, nominalVarTarget, cc];
IF conforms1 = no THEN RETURN[no];
conforms2 ← CCTypes.CheckConformance[nominalVarTarget, nominalValTarget, cc];
IF conforms2 = no THEN RETURN[no];
IF conforms1 = yes AND conforms2 = yes THEN RETURN[yes];
RETURN[dontKnow];
END
ELSE IF CheckFamilyInclusion[nominalValTarget, nominalVarTarget, cc] THEN RETURN[yes] ELSE RETURN[no];
END;
END;
DefaultIndirectTypeBinaryOperandTypes: PROC[op: CedarCode.Operator, left, right: Type, cc: CC, procData: REF ANY] RETURNS[CCTypes.BinaryTargetTypes] =
BEGIN
rightClass: CirioTypes.TypeClass ← GetGroundTypeClass[right, cc];
IF rightClass = $wrong OR rightClass = $amnode THEN RETURN[[right, right]];
SELECT op FROM
$assign =>
BEGIN
target: Type ← GetRTargetType[left, cc];
IF CCTypes.Conforms[right, target, cc] THEN RETURN[[left, right]]
ELSE RETURN[[left, target]];
END;
ENDCASE => CCError[typeConformity];
END;
DefaultIndirectTypeIsAnIndirect: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[BOOLEAN] =
{RETURN[TRUE]};
DefaultIndirectGetRTargetType: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[Type] =
{RETURN[GetTargetTypeOfIndirect[type]]};
DefaultIndirectGetLTargetType: PROC[type: Type, cc: CC, procData: REF ANY] RETURNS[Type] =
BEGIN
nominalTarget: Type ← GetTargetTypeOfIndirect[type];
IF IsASingleton[nominalTarget, cc] THEN RETURN[nominalTarget] ELSE RETURN[cc.ctc.emptyType];
END;
DefaultIndirectOperand: PROC[op: CedarCode.Operator, lr: CCTypes.LR, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
SELECT op FROM
$address => RETURN[tc];
ENDCASE => CCE[operation, "illegal operation"]; -- client error, illegal operation
END;
perhaps the first level routine could check for target type = $amnode and treat that as a special case.
DefaultIndirectTypeCoerceToType: PROC[targetType: Type, tc: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
IF CCTypes.Conforms[tc.type, targetType, cc] THEN RETURN[tc];
IF GetGroundTypeClass[targetType, cc] = $amnode THEN
RETURN[[CedarCode.ConcatCode[tc.code, CedarCode.CodeToMakeAMNode[tc.type]], GetNodeType[cc]]];
CCError[operation, "can not coerce to an appropriate type for given operation"];
END;
DefaultIndirectUnaryOp: PROC[op: CCTypes.Operator, arg: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
SELECT op FROM
$address =>
BEGIN
code: CirioTypes.Code ← CedarCode.ConcatCode[
arg.code,
CedarCode.CodeToDoUnaryOp[op, arg.type]];
ptrType: Type ← PointerTypes.CreatePointerType[GetTargetTypeOfIndirect[arg.type], cc, NIL--it's OK to give a NIL bti because the resultant pointer Type will never be asked to CreateIndirectNode or GetBitSize--];
RETURN [[code, ptrType]];
END;
ENDCASE => CCE[cirioError];
END;
DefaultIndirectTypeStore: PROC[value: TypedCode, indirect: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
code: CirioTypes.Code ← CedarCode.ConcatCode[
indirect.code,
CedarCode.ConcatCode[
value.code,
CedarCode.CodeToStoreUnpopped[indirect.type, value.type]]];
type: Type ← value.type;
we really should make a last ditch type check
RETURN[[code, type]];
END;
DefaultIndirectTypeLoad: PROC[indirect: TypedCode, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
code: CirioTypes.Code ← CedarCode.ConcatCode[
indirect.code,
CedarCode.CodeToLoadThroughIndirect[indirect.type]];
type: Type ← GetRTargetType[indirect.type, cc];
RETURN[[code, type]];
END;
The empty type will show up as the LTarget type of an attempt to store through an indirect to a non singleton family. We want to be sure nothing ever conforms to it
EmptyData: TYPE = RECORD[fillEmpty: INTEGER];
CreateEmptyType: PROC[cc: CC] RETURNS[Type] =
{RETURN[CreateCedarType[$empty, EmptyTypeTypeProcs, EmptyTypeIndirectTypeProcs, cc, NEW[EmptyData←[0]]]]};
EmptyTypeTypeProcs: REF CCTypes.CCTypeProcs ← NEW[CCTypes.CCTypeProcs ←[]];
EmptyTypeIndirectTypeProcs: REF CCTypes.CCTypeProcs ← NEW[CCTypes.CCTypeProcs ←[]];
The following are exported to CCTypes
CCError: PUBLIC ERROR[case: CCTypes.CCErrorCase, msg: ROPENIL] = CODE;
GetCedarNumericType: PUBLIC PROC[desc: CedarNumericTypes.NumericDescriptor, cc: CC, insist: BOOL] RETURNS[Type] ~ {
ctc: CompilerTypeContext ~ cc.ctc;
rnd: REF CedarNumericTypes.NumericDescriptor ~ NEW[CedarNumericTypes.NumericDescriptor ← desc];
t: Type ← NARROW[ctc.cedarNumericTypes.Fetch[rnd].val];
IF insist AND t=NIL THEN {
ndr: ROPE ~ CedarNumericTypes.NDFormat[desc];
CCError[cirioError, "fetching undefined numeric type"]};
RETURN[t]};
SetCedarNumericType: PUBLIC PROC[cc: CC, desc: CedarNumericTypes.NumericDescriptor, t: Type] ~ {
rnd: REF CedarNumericTypes.NumericDescriptor ~ NEW[CedarNumericTypes.NumericDescriptor ← desc];
news: BOOL ← cc.ctc.cedarNumericTypes.Store[rnd, t];
[] ← GetCedarNumericType[desc, cc, TRUE];
RETURN};
EqualND: PROC [key1, key2: REF ANY] RETURNS [BOOL] ~ {
r1: REF CedarNumericTypes.NumericDescriptor ~ NARROW[key1];
r2: REF CedarNumericTypes.NumericDescriptor ~ NARROW[key2];
RETURN CedarNumericTypes.NDEqual[r1^, r2^]};
HashND: PROC [key: REF ANY] RETURNS [CARDINAL] ~ {
rnd: REF CedarNumericTypes.NumericDescriptor ~ NARROW[key];
RETURN CedarNumericTypes.NDHash[rnd^]};
GetWrongType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.wrongType]};
GetNodeType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.nodeType]};
GetBooleanType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.booleanType]};
SetBooleanType: PUBLIC PROC[cc: CC, t: Type] = {cc.ctc.booleanType ← t};
GetCharType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.charType]};
SetCharType: PUBLIC PROC[cc: CC, t: Type] = {cc.ctc.charType ← t};
GetRopeType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.ropeType]};
SetRopeType: PUBLIC PROC[cc: CC, t: Type] = {cc.ctc.ropeType ← t};
GetAnyTargetType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.anyTargetType]};
GetRefAnyType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.refAnyType]};
SetRefAnyType: PUBLIC PROC[cc: CC, t: Type] = {cc.ctc.refAnyType ← t};
GetNilRefType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.nilRefType]};
GetNilPointerType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.nilPointerType]};
SetNilPointerType: PUBLIC PROC[cc: CC, t: Type] = {cc.ctc.nilPointerType ← t};
GetAmpersandContextType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.ampersandContextType]};
GetAmpersandVarType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[cc.ctc.ampersandVarType]};
GetNameScopeType: PUBLIC PROC[cc: CC] RETURNS[Type] = {RETURN[CedarCode.GetTypeOfNode[cc.nameScope]]};
Here we have the hash table code that forms the basis for conformity checking.
This algorithm is not good, but it is correct. Unfortunately, with this algorithm we can never mark any cell as knownToConform. There are several ways to modify the algorithm so that we can apply such marks. (We should visualize a large graph with nodes. Some of the nodes have been initially marked with knownNotToConform. We can mark a node as knownNotToConform if any node so marked is reachable from it. We can mark a node as knownToConform if no node reachable from it is marked knownNotToConform.)
(1) do a full scale strongly connected components algorithm. The components are connected together as an acyclic graph. We can now do a depth first walk over the graph. Any component that contains a node marked as knownNotToConform gets all of its nodes marked as knownNotToConform. Any component containing no such node, and from which there is no reachable component containing any such node, can have all of its components marked as knownToConform
(2) Have checkConformity return three cases: yes, dontKnow, and no. Never return yes unless we have explored all reachable nodes. return dontKnow whenever we bump into an onStack node. If any subnode returns no, then we mark our current node as knownNotToConform and return no. If all subnodes return yes, then mark our current node as knownToConform and return yes. If some subnode returns dontKnow, then don't mark our current node, and return dontKnow. If we return from the top level with dontKnow, then we are safe in marking that top level node as knownToConform, and returning yes. (In effect here, we know that when we return from the top level node we have explored its entire strongly connected component. We dont know this when we return from any other node.)
(3) like 2, except that when we find ourselves marking the top level node as knownToConform, then revisit all reachable nodes and mark them as knownToConform. (This is Demer's proposed scheme.)
I shall implement scheme 2.
CheckConformity: PROC[valType, varType: CirioTypes.Type, continueCheck: PROC RETURNS[CCTypes.ConformanceCheck], cc: CC] RETURNS[CCTypes.ConformanceCheck] =
BEGIN
pair: TypePair ← NEW[TypePairBody←[valType, varType]];
markRef: REF PairMark ← NARROW[RefTab.Fetch[cc.ctc.conformingTypePairs, pair].val];
IF markRef = NIL THEN
BEGIN
markRef ← NEW[PairMark ← notKnown];
IF NOT RefTab.Store[cc.ctc.conformingTypePairs, pair, markRef] THEN CCError[cirioError];
END;
IF markRef^ = currentlyUnderTest THEN
BEGIN
IF cc.ctc.conformanceTestDepth = 0 THEN CCError[cirioError]; -- shouldn't happen
RETURN[dontKnow];
END;
IF markRef^ = notKnown THEN
BEGIN
result: CCTypes.ConformanceCheck;
markRef^ ← currentlyUnderTest;
cc.ctc.conformanceTestDepth ← cc.ctc.conformanceTestDepth+1;
result ← continueCheck[
!UNWIND =>
BEGIN -- uh oh, we had better clean up
cc.ctc.conformanceTestDepth ← cc.ctc.conformanceTestDepth-1;
IF markRef^ # currentlyUnderTest THEN ERROR; -- I don't even want to think about this possibility!
markRef^ ← notKnown;
END];
cc.ctc.conformanceTestDepth ← cc.ctc.conformanceTestDepth-1;
IF markRef^ # currentlyUnderTest THEN CCError[cirioError];
markRef^ ← SELECT result FROM
yes => knownToConform,
no => knownNotToConform,
dontKnow => IF cc.ctc.conformanceTestDepth = 0 THEN knownToConform ELSE notKnown,
ENDCASE => CCError[cirioError];
IF result = dontKnow AND cc.ctc.conformanceTestDepth = 0 THEN result ← yes;
RETURN[result];
END;
RETURN[SELECT markRef^ FROM
knownToConform => yes,
knownNotToConform => no,
ENDCASE => CCError[cirioError]];
END;
PairMark: TYPE = {currentlyUnderTest, knownToConform, knownNotToConform, notKnown};
TypePair: TYPE = REF TypePairBody;
TypePairBody: TYPE = RECORD[valType, varType: CirioTypes.Type];
EqualTypePairs: PROC[key1, key2: RefTab.Key] RETURNS[BOOL] =
BEGIN
pair1: TypePair ← NARROW[key1];
pair2: TypePair ← NARROW[key2];
RETURN[(pair1.valType = pair2.valType) AND (pair1.varType = pair2.varType)];
END;
HashTypePairs: PROC[key: RefTab.Key] RETURNS[CARDINAL] =
BEGIN
pair: TypePair ← NARROW[key];
RETURN[Basics.BITXOR[
Basics.BITXOR[
Basics.HighHalf[LOOPHOLE[pair.valType, CARD32]],
Basics.LowHalf[LOOPHOLE[pair.valType, CARD32]]],
Basics.BITXOR[
Basics.HighHalf[LOOPHOLE[pair.varType, CARD32]],
Basics.LowHalf[LOOPHOLE[pair.varType, CARD32]]]]];
END;
This procedure is performed first on every attempt to perform a coercion
TryStandardCoercion: PUBLIC PROC[targetType: CirioTypes.Type, tc: TypedCode, continueCoerce: PROC RETURNS[TypedCode], cc: CC] RETURNS[TypedCode] =
BEGIN
IF CCTypes.Conforms[tc.type, targetType, cc] THEN RETURN[tc]
ELSE
BEGIN
targetClass: CirioTypes.TypeClass ← GetGroundTypeClass[targetType, cc];
SELECT targetClass FROM
$wrong => RETURN[[tc.code, GetWrongType[cc]]];
$amnode =>
RETURN[[CedarCode.ConcatCode[tc.code, CedarCode.CodeToMakeAMNode[tc.type]], GetNodeType[cc]]];
ENDCASE =>
BEGIN
newtc: TypedCode ← continueCoerce[];
IF NOT CCTypes.Conforms[newtc.type, targetType, cc] THEN CCE[cirioError];
RETURN[newtc];
END;
END;
END;
access to the local Cedar target world
RegisterLocalCedarTargetWorld: PUBLIC PROC[lctw: CCTypes.LocalCedarTargetWorld, cc: CC] =
BEGIN
IF cc.ctc.localCedarTargetWorld # NIL THEN CCE[cirioError];
cc.ctc.localCedarTargetWorld ← lctw;
BEGIN
address: CirioTypes.CirioAddress ← NEW[CirioTypes.CirioAddressBody←[NIL, NIL, NIL, NIL, NIL]];
cirioAddressType: CirioTypes.Type ← InnerGetTypeForCirioAddress[address, cc];
cc.ctc.cirioAddressType ← cirioAddressType;
END;
END;
we do this because it is easier to get to the args than to a nested block
InnerGetTypeForCirioAddress: PROC[dum: CirioTypes.CirioAddress, cc: CC] RETURNS[CirioTypes.Type] =
BEGIN
indirectFrameForSelf: CirioTypes.Node ← CCTypes.CreateFrameNodeForSelf[cc];
indirectTypeForSelf: CirioTypes.Type ← CedarCode.GetTypeOfNode[indirectFrameForSelf];
indirectArgs: CirioTypes.Node ← CedarCode.SelectFieldFromNode["&args", indirectTypeForSelf, indirectFrameForSelf, cc];
indirectTypeForArgs: CirioTypes.Type ← CedarCode.GetTypeOfNode[indirectArgs];
indirectDum: CirioTypes.Node ← CedarCode.SelectFieldFromNode["dum", indirectTypeForArgs, indirectArgs, cc];
indirectDumType: CirioTypes.Type ← CedarCode.GetTypeOfNode[indirectDum];
dumType: CirioTypes.Type ← CCTypes.GetTargetTypeOfIndirect[indirectDumType];
RETURN[dumType]
END;
can't live in a world without a workable CreateNodeFromRefAny
OldRegisterLocalCedarTargetWorld: PUBLIC PROC[lctw: CCTypes.LocalCedarTargetWorld, cc: CC] =
BEGIN
IF cc.ctc.localCedarTargetWorld # NIL THEN CCE[cirioError];
cc.ctc.localCedarTargetWorld ← lctw;
BEGIN
dummyCirioAddessNode: Node ←
CreateNodeFromRefAny[NEW[CirioTypes.CirioAddress←NIL], cc];
cirioAddressType: Type ← CedarCode.GetTypeOfNode[dummyCirioAddessNode];
cc.ctc.cirioAddressType ← cirioAddressType;
END;
END;
CreateNodeFromRefAny: PUBLIC PROC[refAny: REF ANY, cc: CC] RETURNS[Node] =
BEGIN
IF cc.ctc.localCedarTargetWorld = NIL THEN CCE[cirioError];
RETURN[cc.ctc.localCedarTargetWorld.createNodeFromRefAny[refAny, cc.ctc.localCedarTargetWorld, cc]];
END;
CreateFrameNodeForSelf: PUBLIC PROC[cc: CC] RETURNS[Node] =
BEGIN
ourselves: Node ← cc.ctc.localCedarTargetWorld.createFrameNodeForSelf[cc.ctc.localCedarTargetWorld, cc];
ourType: Type ← CedarCode.GetTypeOfNode[ourselves];
RETURN[CedarCode.ExtractFieldFromNode["&caller", ourType, ourselves, cc]];
END;
GetCirioAddressType: PUBLIC PROC[cc: CC] RETURNS[Type] =
{IF cc.ctc.cirioAddressType = NIL THEN CCError[cirioError] ELSE RETURN[cc.ctc.cirioAddressType]};
CCTypeProcs object style implementations
Conforms: PUBLIC PROC[valType, varType: Type, cc: CC, oc: Type ← NIL] RETURNS[BOOLEAN] =
BEGIN
result: CCTypes.ConformanceCheck ← CheckConformance[valType, varType, cc, oc];
IF result = dontKnow THEN CCE[cirioError];
RETURN[result = yes];
END;
CheckConformance: PUBLIC PROC[valType, varType: Type, cc: CC, oc: Type ← NIL] RETURNS[CCTypes.ConformanceCheck] = {
ConformsInner: PROC RETURNS[CCTypes.ConformanceCheck] =
{RETURN[CheckConformanceMain[valType, varType, cc, oc]]};
ans: CCTypes.ConformanceCheck ~ CheckConformity[valType, varType, ConformsInner, cc];
IF ans=no THEN someNotConform ← TRUE;
RETURN [ans]};
someNotConform: BOOLFALSE;
It is neccessary that the default code recurse through CheckConformance Main, to avoid an inner call to CheckConformity applied to the same pair of types. If such an inner call occurred, then the result would be an instant return of yes, incorrectly.
NOTE: We do "stripping" of valType and varType to their ground types (the recursive application of underType until a non-definition type is encountered in this routine. Conformance checking should be the only place where definition types aren't transparent to type operations. They matter for conformance-checking because our algorithm basically follows the type graphs for valType and varType and compares them. Stripping the definition types deals with the problem of following down an arbitrary number of definition types in each type graph. Howard thinks that definition types may be nontransparent in other places as well; so we eventually need to check if we've done things right for definition types. -MMT- May 17, 1989 10:39:36 pm PDT
CheckConformanceMain: PROC[valType, varType: Type, cc: CC, oc: Type ← NIL] RETURNS[CCTypes.ConformanceCheck] =
BEGIN
groundValType: Type ← GetGroundType[valType, cc, oc];
groundVarType: Type ← GetGroundType[varType, cc, oc];
ct: Type ← IF oc # NIL THEN oc ELSE valType;
IF ct.procs = NIL OR ct.procs.checkConformance = NIL THEN
{IF ct.defaultType = NIL THEN CCE[cirioError, "some type can't check conformance"]
ELSE RETURN[CheckConformanceMain[groundValType, groundVarType, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.checkConformance[groundValType, groundVarType, cc, ct.procData]]
END;
Even though this can not recurs back to the same type pair (it can't go through indirects or PROCS, etc) it might be useful to include a hash table mechanism.
NOTE: We do "stripping" of valType and varType to their ground types (the recursive application of underType until a non-definition type is encountered in this routine. Conformance checking should be the only place where definition types aren't transparent to type operations. They matter for conformance-checking because our algorithm basically follows the type graphs for valType and varType and compares them. Stripping the definition types deals with the problem of following down an arbitrary number of definition types in each type graph. Howard thinks that definition types may be nontransparent in other places as well; so we eventually need to check if we've done things right for definition types. -MMT- May 17, 1989 10:39:36 pm PDT
CheckFamilyInclusion: PUBLIC PROC[valType, varType: Type, cc: CC, oc: Type ← NIL] RETURNS[BOOLEAN] =
BEGIN
groundValType: Type ← GetGroundType[valType, cc, oc];
groundVarType: Type ← GetGroundType[varType, cc, oc];
ct: Type ← IF oc # NIL THEN oc ELSE valType;
IF ct.procs = NIL OR ct.procs.checkFamilyInclusion = NIL THEN
{IF ct.defaultType = NIL THEN CCE[cirioError]
ELSE RETURN[CheckFamilyInclusion[groundValType, groundVarType, cc, ct.defaultType]]}
ELSE {
ans: BOOL ~ ct.procs.checkFamilyInclusion[groundValType, groundVarType, cc, ct.procData];
IF NOT ans THEN someFamilyNotIncluded ← TRUE;
RETURN [ans]};
END;
someFamilyNotIncluded: BOOLFALSE;
IsASingleton: PUBLIC PROC[type: Type, cc: CC, oc: Type ← NIL] RETURNS[BOOLEAN] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.isASingleton = NIL THEN
{IF ct.defaultType = NIL THEN CCE[cirioError]
ELSE RETURN[IsASingleton[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.isASingleton[type, cc, ct.procData]]
END;
Storable: PUBLIC PROC[valType, indirectType: Type, cc: CC, oc: Type ← NIL] RETURNS[BOOLEAN] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE valType;
IF ct.procs = NIL OR ct.procs.storable = NIL THEN
{IF ct.defaultType = NIL THEN CCE[cirioError]
ELSE RETURN[Storable[valType, indirectType, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.storable[valType, indirectType, cc, ct.procData]]
END;
BinaryOperandTypes: PUBLIC PROC[op: Operator, left, right: Type, cc: CC, oc: Type] RETURNS[CCTypes.BinaryTargetTypes] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE left;
IF ct.procs = NIL OR ct.procs.binaryOperandTypes = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[BinaryOperandTypes[op, left, right, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.binaryOperandTypes[op, left, right, cc, ct.procData]]
END;
IsAnIndirect: PUBLIC PROC[type: Type, cc: CC, oc: Type] RETURNS[BOOLEAN] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.isAnIndirect = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[IsAnIndirect[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.isAnIndirect[type, cc, ct.procData]];
END;
GetRTargetType: PUBLIC PROC[type: Type, cc: CC, oc: Type ← NIL] RETURNS[Type] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.getRTargetType = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[GetRTargetType[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.getRTargetType[type, cc, ct.procData]];
END;
GetLTargetType: PUBLIC PROC[type: Type, cc: CC, oc: Type ← NIL] RETURNS[Type] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.getLTargetType = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[GetLTargetType[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.getLTargetType[type, cc, ct.procData]];
END;
GetFieldsType: PUBLIC PROC[rcdType: Type, cc: CC, oc: Type] RETURNS[Type] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE rcdType;
IF ct.procs = NIL OR ct.procs.getFieldsType = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[GetFieldsType[rcdType, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.getFieldsType[rcdType, cc, ct.procData]];
END;
GetRefType: PUBLIC PROC[rhs: Type, cc: CC, oc: Type] RETURNS[Type] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE rhs;
IF ct.procs = NIL OR ct.procs.getRefType = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[GetRefType[rhs, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.getRefType[rhs, cc, ct.procData]];
END;
HasIdField: PUBLIC PROC[id: ROPE, fieldContext: Type, cc: CC, oc: Type ← NIL] RETURNS[CCTypes.IdFieldCase] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE fieldContext;
IF ct.procs = NIL OR ct.procs.hasIdField = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[HasIdField[id, fieldContext, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.hasIdField[id, fieldContext, cc, ct.procData]];
END;
ContainsVariance: PUBLIC PROC[type: Type, cc: CC, oc: Type ← NIL] RETURNS[BOOLEAN] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.containsVariance = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[ContainsVariance[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.containsVariance[type, cc, ct.procData]];
END;
GetNVariants: PUBLIC PROC[type: Type, cc: CC, oc: Type ← NIL] RETURNS[INT] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.getNVariants = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[GetNVariants[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.getNVariants[type, cc, ct.procData]];
END;
AsIndexSet: PUBLIC PROC[type: Type, cc: CC, oc: Type] RETURNS[Type] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.asIndexSet = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[AsIndexSet[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.asIndexSet[type, cc, ct.procData]];
END;
Operand: PUBLIC PROC[op: Operator, lr: CCTypes.LR, tc: TypedCode, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE tc.type;
IF ct.procs = NIL OR ct.procs.operand = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation, IO.PutFR["Unable to determine operand type for op %g and TYPE %g", [atom[op]], [rope[FmtType[tc.type, 2, 16, cc]]] ]]
ELSE RETURN[Operand[op, lr, tc, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.operand[op, lr, tc, cc, ct.procData]];
END;
ApplyOperand: PUBLIC PROC[operatorType: Type, operand: CirioSyntacticOperations.ParseTree, cc: CC, oc: Type ← NIL] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE operatorType;
IF ct.procs = NIL OR ct.procs.applyOperand = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[ApplyOperand[operatorType, operand, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.applyOperand[operatorType, operand, cc, ct.procData]];
END;
IndexOperand: PUBLIC PROC[operatorType: Type, operand: CirioSyntacticOperations.ParseTree, cc: CC, oc: Type ← NIL] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE operatorType;
IF ct.procs = NIL OR ct.procs.indexOperand = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[IndexOperand[operatorType, operand, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.indexOperand[operatorType, operand, cc, ct.procData]];
END;
CoerceToType: PUBLIC PROC[targetType: Type, tc: TypedCode, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
CoerceToTypeInner: PROC RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE tc.type;
IF ct.procs = NIL OR ct.procs.coerceToType = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation, IO.PutFR["Unable to coerce TYPE %g to %g", [rope[FmtType[tc.type, 3, 16, cc]]], [rope[FmtType[targetType, 3, 16, cc]]] ]]
ELSE RETURN[CoerceToType[targetType, tc, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.coerceToType[targetType, tc, cc, ct.procData]];
END;
RETURN[TryStandardCoercion[targetType, tc, CoerceToTypeInner, cc]];
END;
BinaryOp: PUBLIC PROC[op: Operator, left, right: TypedCode, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE left.type;
IF ct.procs = NIL OR ct.procs.binaryOp = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation, IO.PutFR["Binary operation %g not implemented for TYPE %g", [atom[op]], [rope[FmtType[left.type, 2, 10, cc]]] ]]
ELSE RETURN[BinaryOp[op, left, right, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.binaryOp[op, left, right, cc, ct.procData]];
END;
UnaryOp: PUBLIC PROC[op: Operator, arg: TypedCode, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE arg.type;
IF ct.procs = NIL OR ct.procs.unaryOp = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation, IO.PutFR["Unary operation %g not implemented for TYPE %g", [atom[op]], [rope[FmtType[arg.type, 2, 10, cc]]] ]]
ELSE RETURN[UnaryOp[op, arg, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.unaryOp[op, arg, cc, ct.procData]];
END;
NAryOperandType: PUBLIC PROC[op: Operator, typeSoFar, nextType: Type, cc: CC, oc: Type] RETURNS[Type] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE typeSoFar;
IF ct.procs = NIL OR ct.procs.nAryOperandType = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[NAryOperandType[op, typeSoFar, nextType, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.nAryOperandType[op, typeSoFar, nextType, cc, ct.procData]];
END;
NAryOp: PUBLIC PROC[op: Operator, args: LIST OF TypedCode, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE args.first.type;
IF ct.procs = NIL OR ct.procs.nAryOp = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[NAryOp[op, args, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.nAryOp[op, args, cc, ct.procData]];
END;
TypeOp: PUBLIC PROC[op: Operator, type: Type, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.typeOp = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[TypeOp[op, type, cc, ct]]}
ELSE RETURN[ct.procs.typeOp[op, type, cc, ct.procData]];
END;
TypeOp2OperandType: PUBLIC PROC[op: Operator, type: Type, cc: CC, oc: Type] RETURNS[Type] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.typeOp2OperandType = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[TypeOp2OperandType[op, type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.typeOp2OperandType[op, type, cc, ct.procData]];
END;
TypeOp2: PUBLIC PROC[op: Operator, type: Type, arg: TypedCode, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.typeOp2 = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[TypeOp2[op, type, arg, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.typeOp2[op, type, arg, cc, ct]];
END;
Constructor: PUBLIC PROC[list: LIST OF CirioSyntacticOperations.ParseTree, targetType: Type, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE targetType;
IF ct.procs = NIL OR ct.procs.constructor = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[Constructor[list, targetType, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.constructor[list, targetType, cc, ct.procData]];
END;
PairConstructor: PUBLIC PROC[list: LIST OF CirioSyntacticOperations.NameArgPair, targetType: Type, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE targetType;
IF ct.procs = NIL OR ct.procs.pairConstructor = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[PairConstructor[list, targetType, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.pairConstructor[list, targetType, cc, ct.procData]];
END;
Store: PUBLIC PROC[value: TypedCode, indirect: TypedCode, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE indirect.type;
IF ct.procs = NIL OR ct.procs.store = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[Store[value, indirect, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.store[value, indirect, cc, ct.procData]];
END;
Load: PUBLIC PROC[indirect: TypedCode, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE indirect.type;
IF ct.procs = NIL OR ct.procs.load = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[Load[indirect, cc, ct.defaultType]]}
ELSE
RETURN[ct.procs.load[indirect, cc, ct.procData]];
END;
ExtractIdField: PUBLIC PROC[id: ROPE, fieldContext: Type, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE fieldContext;
IF ct.procs = NIL OR ct.procs.extractIdField = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[ExtractIdField[id, fieldContext, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.extractIdField[id, fieldContext, cc, ct.procData]];
END;
LoadIdVal: PUBLIC PROC[id: ROPE, targetType: Type, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE targetType;
IF ct.procs = NIL OR ct.procs.loadIdVal = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[LoadIdVal[id, targetType, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.loadIdVal[id, targetType, cc, ct.procData]];
END;
SelectIdField: PUBLIC PROC[id: ROPE, fieldIndirectContext: Type, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE fieldIndirectContext;
IF ct.procs = NIL OR ct.procs.selectIdField = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[SelectIdField[id, fieldIndirectContext, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.selectIdField[id, fieldIndirectContext, cc, ct.procData]];
END;
LoadIdField: PUBLIC PROC[id: ROPE, fieldIndirectContext: Type, cc: CC, oc: Type] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE fieldIndirectContext;
IF ct.procs = NIL OR ct.procs.loadIdField = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[LoadIdField[id, fieldIndirectContext, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.loadIdField[id, fieldIndirectContext, cc, ct.procData]];
END;
Apply: PUBLIC PROC[operator: TypedCode, operand: TypedCode, cc: CC, oc: Type ← NIL] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE operator.type;
IF ct.procs = NIL OR ct.procs.apply = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[Apply[operator, operand, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.apply[operator, operand, cc, ct.procData]];
END;
Index: PUBLIC PROC[operator: TypedCode, operand: TypedCode, cc: CC, oc: Type ← NIL] RETURNS[TypedCode] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE operator.type;
IF ct.procs = NIL OR ct.procs.index = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[Index[operator, operand, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.index[operator, operand, cc, ct.procData]];
END;
GetTypeRepresentation: PUBLIC PROC[type: Type, cc: CC, oc: Type ← NIL] RETURNS[REF ANY] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.getTypeRepresentation = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[GetTypeRepresentation[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.getTypeRepresentation[type, cc, ct.procData]];
END;
GetNElements: PUBLIC PROC[type: Type, cc: CC, oc: Type ← NIL] RETURNS[CARD] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.getNElements = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation, "some Type doesn't know how to getNElements"]
ELSE RETURN[GetNElements[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.getNElements[type, cc, ct.procData]];
END;
GetScopeIndex: PUBLIC PROC [type: Type, cc: CC, oc: Type ← NIL] RETURNS [CARD] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.getScopeIndex = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[GetScopeIndex[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.getScopeIndex[type, cc, ct.procData]];
END;
GetGroundType: PUBLIC PROC[type: Type, cc: CC, oc: Type ← NIL] RETURNS[Type] =
BEGIN
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF ct.procs = NIL OR ct.procs.getGroundType = NIL THEN
{IF ct.defaultType = NIL THEN CCE[operation]
ELSE RETURN[GetGroundType[type, cc, ct.defaultType]]}
ELSE RETURN[ct.procs.getGroundType[type, cc, ct.procData]];
END;
FmtType: PROC [type: Type, printDepth: INT, printWidth: INT, cc: CC, oc: Type ← NIL] RETURNS [ans: ROPE] = {
ENABLE CCE => {ans ← "??"; CONTINUE};
buf1: IO.STREAM ~ IO.ROS[];
PrintType[buf1, type, printDepth, printWidth, cc, oc];
RETURN [buf1.RopeFromROS]};
PrintType: PUBLIC PROC[to: IO.STREAM, type: Type, printDepth, printWidth: INT, cc: CC, oc: Type ← NIL] = {
ct: Type ← IF oc # NIL THEN oc ELSE type;
IF printDepth<0 THEN {to.PutRope[".."]; RETURN};
IF ct.procs = NIL OR ct.procs.printType = NIL THEN
{IF ct.defaultType = NIL THEN CCE[cirioError, IO.PutFR["a type of class %g doesn't know how to print itself", [atom[type.class]] ]]
ELSE PrintType[to, type, printDepth, printWidth, cc, ct.defaultType]}
ELSE ct.procs.printType[to, type, printDepth, printWidth, cc, ct.procData];
};
sia: PUBLIC INT ← 3;
DoObject: PUBLIC PROC [to: IO.STREAM, printit: PROC] ~ {
SS.Begin[to];
printit[!UNWIND => SS.End[to]];
SS.End[to];
RETURN};
BreakObject: PUBLIC PROC [to: IO.STREAM, printit: PROC, sep: ROPENIL] ~ {
SS.Bp[to, lookLeft, sia, sep];
DoObject[to, printit];
RETURN};
PrintTypeBracketed: PUBLIC PROC[to: IO.STREAM, type: Type, printDepth: INT, printWidth: INT, cc: CC, oc: Type ← NIL] = {
SS.Begin[to];
PrintType[to, type, printDepth, printWidth, cc, oc
!UNWIND => SS.End[to]];
SS.End[to];
RETURN};
BreakPrintType: PUBLIC PROC[to: IO.STREAM, type: Type, printDepth, printWidth: INT, cc: CC, sep: ROPENIL, oc: Type ← NIL] = {
InnerPrint: PROC ~ {PrintType[to, type, printDepth, printWidth, cc, oc]};
BreakObject[to, InnerPrint, sep]};
GetIndirectCreateNode: PUBLIC PROC[targetType: Type, mem: Mem, cc: CC] RETURNS[Node] ~ {
indirectType: Type ~ GetIndirectType[targetType];
RETURN CreateIndirectNode[indirectType, mem, cc]};
CreateIndirectNode: PUBLIC PROC[indirectType: Type, mem: Mem, cc: CC, oc: Type ← NIL] RETURNS[Node] ~ {
ct: Type ← IF oc # NIL THEN oc ELSE indirectType;
IF ct.procs#NIL AND ct.procs.createIndirectNode#NIL THEN {
targetType: Type ~ GetTargetTypeOfIndirect[indirectType];
RETURN ct.procs.createIndirectNode[cc, ct.procData, indirectType, targetType, mem]};
IF ct.defaultType=NIL THEN CCE[cirioError, "some type doesn't know how to create an indirect node"];
RETURN CreateIndirectNode[indirectType, mem, cc, ct.defaultType]};
GetBitSize: PUBLIC PROC[indirectType: Type, cc: CC, oc: Type ← NIL] RETURNS[CARD] ~ {
ct: Type ← IF oc # NIL THEN oc ELSE indirectType;
IF ct.procs#NIL AND ct.procs.getBitSize#NIL THEN {
targetType: Type ~ GetTargetTypeOfIndirect[indirectType];
RETURN ct.procs.getBitSize[indirectType, targetType, cc, ct.procData]};
IF ct.defaultType=NIL THEN {
asRope: ROPE ← FmtType[indirectType, 3, 32, cc];
CCE[cirioError, Rope.Cat["some type doesn't know how to compute its bit size (", asRope, ")"]]};
RETURN GetBitSize[indirectType, cc, ct.defaultType]};
Compound Name Scopes
The name scopes used in Cirio will contain one or more ampersand contexts followed by the target world context.
CompoundNameScopeInfo: TYPE = REF CompoundNameScopeInfoBody;
MaxNumberOfTWContext: CARDINAL = 16;
CompoundNameScopeInfoBody: TYPE = RECORD[
ampersandContext1: Node,
ampersandContext2: Node,
scopeIndex: CARDINAL,
targetWorldContexts: ARRAY [1..MaxNumberOfTWContext] OF Node];
We shall treat the two ampersandContexts as a single context. Writes always go to ampersandContext2, reads go to ampersandContext1 first, then if the name is not there, we try ampersandContext2.
advanceNameScope goes to targetWorldContext.
Note: these guys are only indirects, there are no stack values
WARNING: the world will misbehave in unbelievably bad ways if the first two nodes are not ampersand contexts. Somehow I should check this.
CreateCompoundNameScope: PUBLIC PROC[ampersandContext1, ampersandContext2, targetWorldContext: Node, cc: CC] RETURNS[Node] =
BEGIN
contextType: Type ← CedarCode.GetTypeOfNode[targetWorldContext];
scopeIndex: CARDINAL ← CCTypes.GetScopeIndex[contextType, cc];
info: CompoundNameScopeInfo ← NEW[CompoundNameScopeInfoBody];
type: Type ← CreateCedarType[$compoundNameScope, NIL, CompoundNameScopeTypeOps, cc, info];
node: Node ← CedarCode.CreateCedarNode[CompoundNameScopeNodeOps, GetIndirectType[type], info];
info.ampersandContext1 ← ampersandContext1;
info.ampersandContext2 ← ampersandContext2;
IF scopeIndex > MaxNumberOfTWContext THEN CCE[cirioError]
ELSE info.scopeIndex ← scopeIndex;
info.targetWorldContexts[scopeIndex] ← targetWorldContext;
FOR i: CARDINAL DECREASING IN [1..scopeIndex) DO
info.targetWorldContexts[i] ← CedarCode.AdvanceNameScope[info.targetWorldContexts[i+1], cc];
ENDLOOP;
RETURN[node];
END;
CompoundNameScopeTypeOps: REF CCTypes.CCTypeProcs ← NEW[CCTypes.CCTypeProcs ←[ selectIdField: CompoundNameScopeSelectIdField,
loadIdField: CompoundNameScopeLoadIdField]];
CompoundNameScopeSelectIdField: PROC[id: ROPE, fieldIndirectContext: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
info: CompoundNameScopeInfo ← NARROW[procData];
SELECT Rope.Fetch[id, 0] FROM
'&, '← => {-- we are expected to look into the ampersand contexts
an ampersand name is always defined and always has type AmpersandVar
(AmpersandVars always contain Nodes)
code: CirioTypes.Code ← CedarCode.CodeToSelectField[id, GetAmpersandContextType[cc]];
type: Type ← GetAmpersandVarType[cc];
RETURN[[
CedarCode.ConcatCode[
CedarCode.CodeToGetNameContext[0],
code],
type]]};
ENDCASE => {-- we are expected to look into the targetWorldContext
WARNING: a lot of checking should be imposed, i.e., these names scopes are frames, which are essentialy union types.
type: Type ← CedarCode.GetTypeOfNode[info.targetWorldContexts[info.scopeIndex]];
select: TypedCode ← CCTypes.SelectIdField[id, type, cc];
RETURN [select]};
END;
CompoundNameScopeLoadIdField: PROC[id: ROPE, fieldIndirectContext: Type, cc: CC, procData: REF ANY] RETURNS[TypedCode] =
BEGIN
info: CompoundNameScopeInfo ← NARROW[procData];
SELECT Rope.Fetch[id, 0] FROM
'&, '← => {-- we are expected to look into the ampersand contexts
an ampersand name is always defined and always has type AmpersandVar
(AmpersandVars always contain Nodes)
varType: Type ← GetAmpersandVarType[cc];
code: CirioTypes.Code ← CedarCode.ConcatCode[
CedarCode.CodeToSelectField[id, GetAmpersandContextType[cc]],
CedarCode.CodeToLoadThroughIndirect[varType]];
RETURN[[code, GetTargetTypeOfIndirect[varType]]]};
ENDCASE => {-- we are expected to look into the targetWorldContext
WARNING: a lot of checking should be imposed, i.e., these names scopes are frames, which are essentialy union types.
type: Type ← CedarCode.GetTypeOfNode[info.targetWorldContexts[info.scopeIndex]];
load: TypedCode ← CCTypes.LoadIdField[id, type, cc];
RETURN [load]};
END;
CompoundNameScopeNodeOps: REF CedarCode.OperationsBody ← NEW[CedarCode.OperationsBody←[
getNameContext: CompoundNameScopeGetNameContext,
selectField: CompoundNameScopeSelectField,
show: CompoundNameScopeShow]];
CompoundNameScopeGetNameContext: PROC [scopeIndex: CARDINAL, node: Node, cc: CC] RETURNS [Node] =
BEGIN
nsInfo: CompoundNameScopeInfo ← NARROW[CedarCode.GetDataFromNode[node]];
IF scopeIndex = 0 THEN RETURN [node]
ELSE RETURN [nsInfo.targetWorldContexts[scopeIndex]];
END;
CompoundNameScopeSelectField: PROC[id: ROPE, indirectType: Type, indirectNode: Node, cc: CC] RETURNS[Node] =
BEGIN
This select will always succeed, but we get a special indirect which will behave differently for loads and stores.
nsInfo: CompoundNameScopeInfo ← NARROW[CedarCode.GetDataFromNode[indirectNode]];
indirectData: DoubleAmpersandIndirectInfo ← NEW[DoubleAmpersandIndirectInfoBody←[ id, nsInfo]];
RETURN[CedarCode.CreateCedarNode[DoubleAmpersandVarOps, GetAmpersandVarType[cc], indirectData]];
END;
CompoundNameScopeShow: PROC[to: IO.STREAM, node: Node, depth: INT, width: INT, cc: CC] = {
nsInfo: CompoundNameScopeInfo ← NARROW[CedarCode.GetDataFromNode[node]];
DoPair: PROC [intro: ROPE, n: Node] ~ {
to.PutRope[intro];
CedarCode.ShowNode[to, n, depth-1, width, cc];
SS.Bp[to, always, 0];
RETURN};
to.PutChar['{];
DoPair["AmpersandContext1: ", nsInfo.ampersandContext1];
DoPair["AmpersandContext2: ", nsInfo.ampersandContext2];
DoPair["Target World Context: ", nsInfo.targetWorldContexts[nsInfo.scopeIndex] ];
to.PutChar['}];
RETURN};
DoubleAmpersandIndirectInfo: TYPE = REF DoubleAmpersandIndirectInfoBody;
DoubleAmpersandIndirectInfoBody: TYPE = RECORD[
id: ROPE,
nsInfo: CompoundNameScopeInfo];
DoubleAmpersandVarOps: REF CedarCode.OperationsBody ← NEW[CedarCode.OperationsBody←[
store: StoreToDoubleAmpersandVar,
load: LoadFromDoubleAmpersandVar]];
we always store to ampersandContext2
StoreToDoubleAmpersandVar: PROC[valType: Type, valNode: Node, indirectType: Type, indirectNode: Node, cc: CC] =
BEGIN
indirectData: DoubleAmpersandIndirectInfo ← NARROW[CedarCode.GetDataFromNode[indirectNode]];
ampersand2: Node ← indirectData.nsInfo.ampersandContext2;
ampersand2Type: Type ← CedarCode.GetTypeOfNode[ampersand2];
var: Node ← CedarCode.SelectFieldFromNode[indirectData.id, ampersand2Type, ampersand2, cc];
varType: Type ← CedarCode.GetTypeOfNode[var];
CedarCode.StoreThroughIndirectNode[valType, valNode, varType, var, cc];
END;
We try to load from ampersandContext1 first.
This implementation has the problem that it places empty vars in ampersandContext1.
LoadFromDoubleAmpersandVar: PROC[indirectType: Type, indirectNode: Node, cc: CC] RETURNS[Node] =
BEGIN
indirectData: DoubleAmpersandIndirectInfo ← NARROW[CedarCode.GetDataFromNode[indirectNode]];
ampersand1: Node ← indirectData.nsInfo.ampersandContext1;
ampersand1Type: Type ← CedarCode.GetTypeOfNode[ampersand1];
var1: Node ← CedarCode.SelectFieldFromNode[indirectData.id, ampersand1Type, ampersand1, cc];
var1Type: Type ← CedarCode.GetTypeOfNode[var1];
val1: Node ← NIL;
we CONTINUE if we get a CCE[operation], which should only be due to attempting to load from a non existent ampersandVar.
val1 ← CedarCode.LoadThroughIndirectNode[var1Type, var1, cc
! CCE => IF case = operation THEN {val1 ← NIL; CONTINUE}];
IF val1 # NIL THEN RETURN[val1];
it wasn't in ampersand1, so lets try ampersand2
BEGIN
ampersand2: Node ← indirectData.nsInfo.ampersandContext2;
ampersand2Type: Type ← CedarCode.GetTypeOfNode[ampersand2];
var2: Node ← CedarCode.SelectFieldFromNode[indirectData.id, ampersand2Type, ampersand2, cc];
var2Type: Type ← CedarCode.GetTypeOfNode[var2];
val2: Node ← CedarCode.LoadThroughIndirectNode[var2Type, var2, cc];
RETURN[val2];
END;
END;
END..