<> <> <> <> <> DIRECTORY FS USING[ComponentPositions, Error, ExpandName, StreamOpen], IO USING [Close, PutF, rope, STREAM], Rope USING [ Cat, Concat, Equal, ROPE, Substr ], SaffronAG1Def USING[TopmodulepProdData], SaffronATDef USING [ DefBodyNode, ExpNode, ModulePNode, ScopeNode, TopNode ], SaffronBaseDef USING [ ], SaffronCentralDef USING[ParseOneStream], SaffronGenericDef USING [ IdNode, IdNodeBody, StringNode ], SaffronContext USING [ ], SaffronContextPrivateTypes, ThreeC4Support USING[GetReportStream], VersionMap USING[MapAndNameList, MapList, ShortNameToNames], VersionMapDefaults USING[GetMapList]; SaffronContextCreateCTImpl: CEDAR PROGRAM IMPORTS FS, IO, Rope, SaffronCentralDef, ThreeC4Support, VersionMap, VersionMapDefaults EXPORTS SaffronATDef, SaffronBaseDef, SaffronContext, SaffronContextPrivateTypes ~ { OPEN SaffronATDef, SaffronContextPrivateTypes, SaffronGenericDef; <<>> <> <> <> ReadDefFile: PUBLIC PROC [ fname: Rope.ROPE ] RETURNS [ ModulePPTreeNode ] ~ { actualFileName: Rope.ROPE; data: IO.STREAM; root: SaffronATDef.TopNode; rootData: SaffronAG1Def.TopmodulepProdData; reportStream: IO.STREAM _ ThreeC4Support.GetReportStream[]; [actualFileName, data] _ FindFile[fname]; IF data = NIL THEN BEGIN IO.PutF[reportStream, "\N\N\NFailed to find %g \N\N\N", IO.rope[fname]]; ERROR; END; IO.PutF[reportStream, "\N\N\N parsing from %g \N\N\N", IO.rope[actualFileName]]; root _ NARROW [SaffronCentralDef.ParseOneStream[data, 0, reportStream]]; IO.Close[data]; rootData _ NARROW[root.data]; RETURN[ModulePPTreeVal[rootData.ModuleP]]; }; <> <> <> FindFile: PUBLIC PROC[short: Rope.ROPE, extension: Rope.ROPE _ NIL] RETURNS[fullName: Rope.ROPE, s: IO.STREAM _ NIL] = BEGIN fileName: Rope.ROPE; mapList: VersionMap.MapList ~ VersionMapDefaults.GetMapList[$Symbols]; list: VersionMap.MapAndNameList; IF ( extension = NIL ) THEN extension _ "Mesa"; fileName _ Rope.Cat[short, ".", extension]; IF ( (s _ FS.StreamOpen[fileName ! FS.Error => CONTINUE]) # NIL ) THEN RETURN[fileName, s]; list _ VersionMap.ShortNameToNames[mapList, Rope.Cat[short, ".", "BCD"]]; FOR p: VersionMap.MapAndNameList _ list, p.rest UNTIL p=NIL DO remoteFileName: Rope.ROPE ~ p.first.name; cp: FS.ComponentPositions; package: Rope.ROPE; src: Rope.ROPE; fullFName: Rope.ROPE; [fullFName, cp] _ FS.ExpandName[remoteFileName]; package _ Rope.Substr[fullFName, 0, cp.ext.start]; src _ Rope.Concat[package, extension]; IF ( (s _ FS.StreamOpen[src ! FS.Error => LOOP]) # NIL ) THEN RETURN[src, s]; ENDLOOP; END; <> EnvironmentNode: TYPE ~ REF EnvironmentNodeBody; EnvironmentNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.EnvironmentNodeBody; CreateEmptyEnvironment: PUBLIC PROC RETURNS [EnvironmentNode] ~ { RETURN[NEW [EnvironmentNodeBody _ [CreateEmptyRopeNames[]] ]]; }; <> AddInterfaceToEnvironment: PUBLIC PROC [env: EnvironmentNode, fileName: Rope.ROPE, ifc: InterfaceValNode] RETURNS [EnvironmentNode] ~ { RecordRopeName[env.interfaces, fileName, ifc]; RETURN[env]; }; LookupInterfaceInEnv: PUBLIC PROC [env: EnvironmentNode, fileName: Rope.ROPE] RETURNS [InterfaceValNode] ~ { RETURN[NARROW[LookupRopeName[env.interfaces, fileName]]]; }; IsInterfaceInEnv: PUBLIC PROC [env: EnvironmentNode, fileName: Rope.ROPE] RETURNS [BOOLEAN] ~ { RETURN[LookupRopeName[env.interfaces, fileName] # NIL]; }; <> FakeDamageEnvironment: PUBLIC PROC [env: EnvironmentNode] RETURNS [EnvironmentNode] = {RETURN[env]}; <> <<>> InterfaceValNode: TYPE ~ REF InterfaceValNodeBody; InterfaceValNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.InterfaceValNodeBody; <> <> <<>> <> CreateInterfaceFromContextTree: PUBLIC PROC [ct: ContextTreeNode, ns: NameSequenceNode] RETURNS [in: InterfaceValNode] ~ { entries: VisibleNames _ CreateEmptyVisibleNames[]; typeNames: VisibleNames _ ct.rib.lc.lvtn; -- herein lies the crock EnterOneName: PROC [name: IdNode, access: AccessValNode, value: REF ANY] ~ { tgn: TypeGraphNodeNode _ NARROW[value]; -- check RecordVisibleName[entries, name, access, tgn]; }; GenVisibleNames[typeNames, EnterOneName]; RETURN[NEW [InterfaceValNodeBody _ [ns, entries, ct]]]; }; <> GenInterfaceEntries: PROC [in: InterfaceValNode, for: PROC [IdNode, AccessValNode, TypeGraphNodeNode] ] ~ { SeeOne: PROC [name: IdNode, access: AccessValNode, value: REF ANY] ~ { for[name, access, NARROW[value]]; }; GenVisibleNames[in.entries, SeeOne]; }; LookupInterfaceEntry: PUBLIC PROC [in: InterfaceValNode, name: IdNode] RETURNS [access: AccessValNode, tgn: TypeGraphNodeNode] ~ { value: REF ANY; [access, value] _ LookupVisibleName[in.entries, name]; RETURN[access, NARROW[value]]; }; <<>> <> ContextTreeNode: TYPE ~ REF ContextTreeNodeBody; ContextTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.ContextTreeNodeBody; <> EmptyContextTree: PUBLIC PROC [ rib: ContextRibNode ] RETURNS [ ContextTreeNode ] ~ { RETURN[NEW [ContextTreeNodeBody _ [rib, NIL, NIL]]] }; <<(declared as damages ctn)>> FakeDamageContextTree: PUBLIC PROC [ ctn: ContextTreeNode ] RETURNS [ ctnp: ContextTreeNode ] ~ { RETURN[ctn] }; <<(damages ctn)>> AddSubContextTree: PUBLIC PROC [ ctn: ContextTreeNode, subCtn: ContextTreeNode ] RETURNS [ ctnp: ContextTreeNode ] ~ { cell: CTCell _ NEW [CTCellBody_[subCtn, NIL]]; IF subCtn.rib.lc.rib # ctn.rib THEN ErrorSignal[]; IF ctn.subTrees = NIL THEN ctn.subTrees _ cell ELSE ctn.lastSubTree.next _ cell; ctn.lastSubTree _ cell; RETURN[ctn]; }; <> ContextRibNode: TYPE ~ REF ContextRibNodeBody; ContextRibNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.ContextRibNodeBody; RootContextRib: PUBLIC PROC RETURNS [ rib: ContextRibNode ] ~ { RETURN[FreezeLocalContext[CreateRootLocalContext[]]] }; <<(damages lc)>> FreezeLocalContext: PUBLIC PROC [ lc: LocalContextNode ] RETURNS [ rib: ContextRibNode ] ~ { lc.frozen _ TRUE; RETURN[NEW [ContextRibNodeBody _ [lc]]]; }; <> LocalContextNode: TYPE ~ REF LocalContextNodeBody; LocalContextNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.LocalContextNodeBody; CreateBasicLocalContext: PROC RETURNS [ LocalContextNode ] ~ { lc: LocalContextNode _ NEW [LocalContextNodeBody]; lc.lvtn _ CreateEmptyVisibleNames[]; lc.paintIndex _ 0; RETURN[lc]; }; CreateRootLocalContext: PROC RETURNS [ LocalContextNode ] ~ { lc: LocalContextNode _ CreateBasicLocalContext[]; lc.rib _ NIL; [lc.top, lc.bottom] _ CreateTopAndBottom[lc]; lc.unpaintedPaint _ CreateUnpaintedPaint[lc]; InstallBaseTypes[lc]; RETURN[lc]; }; CreateEmptyContext: PUBLIC PROC [ rib: ContextRibNode ] RETURNS [ LocalContextNode ] ~ { lc: LocalContextNode _ CreateBasicLocalContext[]; lc.rib _ rib; lc.top _ rib.lc.top; lc.bottom _ rib.lc.bottom; lc.unpaintedPaint _ rib.lc.unpaintedPaint; RETURN[lc]; }; FakeDamageContext: PUBLIC PROC [lc: LocalContextNode] RETURNS [lcp: LocalContextNode] ~ { lcp _ lc; }; <> TypeGraphNodeNode: TYPE ~ REF TypeGraphNodeNodeBody; TypeGraphNodeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.TypeGraphNodeNodeBody; CreateTGN: PROC [ lc: LocalContextNode, body: REF ANY ] RETURNS [ tgn: TypeGraphNodeNode ] ~ { tgn _ NEW [TypeGraphNodeNodeBody _ [ shown: FALSE, index: lc.maxTGNodeIndex + 1, localContext: lc, body: body, next: lc.tgNodes]]; lc.maxTGNodeIndex _ tgn.index; lc.tgNodes _ tgn; }; <<( FIX: This should be a procedure to be applied to a RIB, we will change as soon as we get ribs )>> FindBottomTGN: PUBLIC PROC [ lc: LocalContextNode ] RETURNS [ tgn: TypeGraphNodeNode ] ~ { RETURN[lc.bottom]; }; <<( FIX: This should be a procedure to be applied to a RIB, we will change as soon as we get ribs )>> FindTopTGN: PUBLIC PROC [ lc: LocalContextNode ] RETURNS [ tgn: TypeGraphNodeNode ] ~ { RETURN[lc.top]; }; <<( Upon reaching top level context, then looks up names of frames and interfaces, then root context. Must add this later. )>> FindLocallyVisibleTGN: PUBLIC PROC [ lc: LocalContextNode, name: IdNode ] RETURNS [ TypeGraphNodeNode ] ~ { FOR lcx: LocalContextNode _ lc, lcx.rib.lc WHILE ( lcx # NIL ) DO tgn: TypeGraphNodeNode _ NARROW[LookupVisibleName[lcx.lvtn, name].value]; IF tgn # NIL THEN RETURN[tgn]; IF lcx.rib = NIL THEN EXIT; ENDLOOP; ErrorSignal[]; }; <> <> <> <> InstallBaseTypes: PROC [ lc: LocalContextNode ] ~ { <> InstallBaseType[lc, "ATOM"]; InstallBaseType[lc, "BOOL"]; InstallBaseType[lc, "BOOLEAN"]; InstallBaseType[lc, "CHAR"]; InstallBaseType[lc, "CHARACTER"]; InstallBaseType[lc, "CONDITION"]; InstallBaseType[lc, "MONITORLOCK"]; InstallBaseType[lc, "REAL"]; InstallBaseType[lc, "STRING"]; InstallBaseType[lc, "UNSPECIFIED"]; InstallBaseType[lc, "WORD"]; -- bpw? InstallBaseType[lc, "BYTE"]; -- 8 InstallBaseType[lc, "DINT"]; -- bdpw InstallBaseType[lc, "INT"]; -- bplw InstallBaseType[lc, "INTEGER"]; -- bpw InstallBaseType[lc, "INT16"]; -- 16 InstallBaseType[lc, "INT32"]; -- 32 InstallBaseType[lc, "INT64"]; -- 64 InstallBaseType[lc, "DCARD"]; -- bdpw InstallBaseType[lc, "CARD"]; -- bplw InstallBaseType[lc, "CARDINAL"]; -- bpw InstallBaseType[lc, "CARD16"]; -- 16 InstallBaseType[lc, "CARD32"]; -- 32 InstallBaseType[lc, "CARD64"]; -- 64 InstallBaseType[lc, "NAT"]; -- bpw-1 InstallBaseType[lc, "NATURAL"]; -- bpw-1 InstallBaseType[lc, "NAT15"]; -- 15 InstallBaseType[lc, "NAT31"]; -- 31 InstallBaseType[lc, "NAT63"]; -- 63 }; InstallBaseType: PROC [ lc: LocalContextNode, typeName: Rope.ROPE ] ~ { body: BaseTypeTGN _ NEW [BaseTypeTGNBody _ [typeName: typeName]]; tgn: TypeGraphNodeNode _ CreateTGN[lc, body]; nameAsIdNode: IdNode _ NEW [IdNodeBody _ [typeName, 0, 0]]; RecordVisibleName[lc.lvtn, nameAsIdNode, NIL, tgn]; }; <> CreateTopAndBottom: PROC [ lc: LocalContextNode ] RETURNS [ top, bottom: TypeGraphNodeNode ] ~ { topBody: SpecialTGN _ NEW [SpecialTGNBody _ [top]]; bottomBody: SpecialTGN _ NEW [SpecialTGNBody _ [bottom]]; top _ CreateTGN[lc, topBody]; bottom _ CreateTGN[lc, bottomBody]; }; <> CreateLocallyVisibleTGN: PUBLIC PROC [ lc: LocalContextNode, name: IdNode, access: AccessValNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: NamedTGN _ NEW [NamedTGNBody _ [name: name]]; tgn _ CreateTGN[lc, body]; RecordVisibleName[lc.lvtn, name, access, tgn]; RETURN[lc, tgn]; }; AddArcFromLVTGNToTGN: PUBLIC PROC [ lc: LocalContextNode, lvTgn: TypeGraphNodeNode, access: AccessValNode, tgn: TypeGraphNodeNode, default: DefaultExpNode ] RETURNS [ lcp: LocalContextNode ] ~ { namedNode: NamedTGN _ NARROW[lvTgn.body]; namedNode.access _ access; namedNode.type _ tgn; namedNode.default _ default; RETURN[lc]; }; <> ResolveNamedNodes: PROC[tgn: TypeGraphNodeNode] RETURNS[TypeGraphNodeNode] = BEGIN x: TypeGraphNodeNode _ tgn; WHILE TRUE DO WITH x.body SELECT FROM namedNode: NamedTGN => x _ namedNode.type; ENDCASE => RETURN[x]; ENDLOOP; ERROR; END; <> CreateSubrangeTGN: PUBLIC PROC [ lc: LocalContextNode, subrangeOf: TypeGraphNodeNode, bounds: BoundsValNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: SubrangeTGN _ NEW [SubrangeTGNBody _ [subrangeOf, bounds]]; RETURN[lc, CreateTGN[lc, body]]; }; <> CreateRecordTGN: PUBLIC PROC [ lc: LocalContextNode, p: PaintNode, machineDependent, monitoredRecord: BOOLEAN, ffl: FrozenFieldListNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: RecordTGN _ NEW [RecordTGNBody _ [p, machineDependent, monitoredRecord, ffl]]; RETURN[lc, CreateTGN[lc, body]]; }; <> <> <<>> <> <<>> CreatePointerTGN: PUBLIC PROC [ lc: LocalContextNode, ordered, base: BOOLEAN, bounds: BoundsValNode, readOnly: BOOLEAN, targetTgn: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: PointerTGN _ NEW [PointerTGNBody _ [ordered, base, readOnly, bounds, targetTgn]]; RETURN[lc, CreateTGN[lc, body]]; }; CreateRefTGN: PUBLIC PROC [ lc: LocalContextNode, machineDependent: BOOLEAN, contentsTgn: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { referent: ReferentTGN _ NEW [ReferentTGNBody _ [contentsTgn]]; body: RefTGN _ NEW [RefTGNBody _ [machineDependent, CreateTGN[lc, referent]]]; RETURN[lc, CreateTGN[lc, body]]; }; CreateVarTGN: PUBLIC PROC [ lc: LocalContextNode, targetTgn: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: VarTGN _ NEW [VarTGNBody _ [targetTgn]]; RETURN[lc, CreateTGN[lc, body]]; }; CreateRelativeTGN: PUBLIC PROC [ lc: LocalContextNode, base, pointer: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: RelativeTGN _ NEW [RelativeTGNBody _ [base, pointer]]; RETURN[lc, CreateTGN[lc, body]]; }; <> <> <<>> CreateListTGN: PUBLIC PROC [ lc: LocalContextNode, readOnly: BOOLEAN, itemType: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: ListTGN _ NEW [ListTGNBody _ [readOnly, itemType, NIL]]; body.rest _ body; RETURN[lc, CreateTGN[lc, body]]; }; <> CreateEmptyEnumTypeTGN: PUBLIC PROC [ lc: LocalContextNode, machineDependent: BOOLEAN ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: EnumTGN _ NEW [EnumTGNBody _ [machineDependent, GetUniquePaint[lc].p, NIL, NIL]]; RETURN[lc, CreateTGN[lc, body]]; }; <<>> <> AppendElementToEnumTypeTGN: PUBLIC PROC [ lc: LocalContextNode, tgn: TypeGraphNodeNode, elementName: IdNode, rep: ExpPTreeNode ] RETURNS [ lcp: LocalContextNode ] ~ { body: EnumTGN _ NARROW[tgn.body]; cell: EnumElementCell _ NEW [EnumElementCellBody _ [elementName, rep, NIL]]; IF body.lastElement = NIL THEN body.firstElement _ cell ELSE body.lastElement.next _ cell; body.lastElement _ cell; RETURN[lc]; }; <> FieldNode: TYPE ~ REF FieldNodeBody; FieldNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.FieldNodeBody; FieldListNode: TYPE ~ REF FieldListNodeBody; FieldListNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.FieldListNodeBody; FrozenFieldListNode: TYPE ~ REF FrozenFieldListNodeBody; FrozenFieldListNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.FrozenFieldListNodeBody; CreateNamedField: PUBLIC PROC [ n: IdNode, pvn: PositionValNode, avn: AccessValNode, tgn: TypeGraphNodeNode, default: DefaultExpNode ] RETURNS [ f: FieldNode ] ~ { RETURN[NEW [FieldNodeBody _ [n, pvn, avn, tgn, default]]] }; CreateUnnamedField: PUBLIC PROC [ tgn: TypeGraphNodeNode, default: DefaultExpNode ] RETURNS [ f: FieldNode ] ~ { RETURN[NEW [FieldNodeBody _ [NIL, NIL, NIL, tgn, default]]] }; CreateEmptyFieldList: PUBLIC PROC RETURNS [ fl: FieldListNode ] ~ { RETURN[NEW [FieldListNodeBody _ [FALSE, 0, 0, NIL, NIL]]] }; AnyFieldList: PUBLIC PROC RETURNS [ fl: FieldListNode ] ~ { RETURN[NEW [FieldListNodeBody _ [TRUE, 0, 0, NIL, NIL]]] }; PrependCellToFieldList: PROC [ nFields: INT, cell: FieldListCell, fl: FieldListNode ] RETURNS [ flp: FieldListNode ] ~ { IF fl.any THEN ERROR; cell.next _ fl.firstCell; fl.firstCell _ cell; IF fl.lastCell = NIL THEN fl.lastCell _ cell; fl.nFields _ fl.nFields + nFields; fl.nCells _ fl.nCells + 1; RETURN[fl]; }; AppendCellToFieldList: PROC [ fl: FieldListNode, nFields: INT, cell: FieldListCell ] RETURNS [ flp: FieldListNode ] ~ { IF fl.any THEN ERROR; IF fl.lastCell = NIL THEN fl.firstCell _ cell ELSE fl.lastCell.next _ cell; fl.lastCell _ cell; fl.nFields _ fl.nFields + nFields; fl.nCells _ fl.nCells + 1; RETURN[fl]; }; PrependFieldToFieldList: PUBLIC PROC [ f: FieldNode, fl: FieldListNode ] RETURNS [ flp: FieldListNode ] ~ { cell: FieldListCell _ NEW [FieldListCellBody _ [f, NIL]]; RETURN[PrependCellToFieldList[1, cell, fl]]; }; AppendFieldToFieldList: PUBLIC PROC [ fl: FieldListNode, f: FieldNode ] RETURNS [ flp: FieldListNode ] ~ { cell: FieldListCell _ NEW [FieldListCellBody _ [f, NIL]]; RETURN[AppendCellToFieldList[fl, 1, cell]]; }; <> <> <> <<};>> <<>> AppendFFLToFieldList: PUBLIC PROC [ fl: FieldListNode, ffl: FrozenFieldListNode ] RETURNS [ flp: FieldListNode ] ~ { cell: FieldListCell _ NEW [FieldListCellBody _ [ffl, NIL]]; RETURN[AppendCellToFieldList[fl, ffl.nFields, cell]]; }; <<>> ConcatFieldLists: PUBLIC PROC [ fl1, fl2: FieldListNode ] RETURNS [ fl: FieldListNode ] ~ { IF fl1.any OR fl2.any THEN ERROR; IF fl1.firstCell = NIL THEN RETURN[fl2]; IF fl2.firstCell = NIL THEN RETURN[fl1]; fl1.lastCell.next _ fl2.firstCell; fl1.lastCell _ fl2.lastCell; fl1.nFields _ fl1.nFields + fl2.nFields; fl1.nCells _ fl1.nCells + fl2.nCells; RETURN[fl1]; }; FreezeFieldList: PUBLIC PROC [ lc: LocalContextNode, fl: FieldListNode ] RETURNS [ lcp: LocalContextNode, ffl: FrozenFieldListNode ] ~ { cell: FieldListCell _ fl.firstCell; ffl _ NEW [FrozenFieldListNodeBody[fl.nCells]]; ffl.any _ fl.any; ffl.nFields _ fl.nFields; ffl.next _ lc.fieldLists; lc.fieldLists _ ffl; FOR I: CARDINAL IN [0..CARDINAL[fl.nCells]) DO ffl[I] _ WITH cell.item SELECT FROM f: FieldNode => [field, f.name, f.pvn, f.avn, f.tgn, f.default, NIL], fflist: FrozenFieldListNode => [ffl, NIL, NIL, NIL, NIL, NIL, fflist], ENDCASE => ERROR; cell _ cell.next; ENDLOOP; FOR I: CARDINAL IN [0..ffl.nFields) DO SELECT ffl[I].case FROM field => IF IsVariantPartTGN[ffl[I].tgn] THEN { IF I = (CARDINAL[ffl.nFields]-1) THEN ffl.variant _ TRUE ELSE ERROR; -- variation allowed only in last field }; ffl => IF ffl[I].ffl.variant THEN { IF I = (CARDINAL[ffl.nFields]-1) THEN ffl.variant _ TRUE ELSE ERROR; -- variation allowed only in last field }; ENDCASE => ERROR; ENDLOOP; RETURN[lc, ffl]; }; <> UnionListNode: TYPE ~ REF UnionListNodeBody; UnionListNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.UnionListNodeBody; CreateVariantPartTGN: PUBLIC PROC [ lc: LocalContextNode, flavor: VariantFlavorNode, tagType: TypeGraphNodeNode, types: UnionListNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: VariantPartTGN _ NEW [VariantPartTGNBody _ [ flavor, tagType, FreezeUnionList[types]]]; RETURN[lc, CreateTGN[lc, body]]; }; IsVariantPartTGN: PROC [ tgn: TypeGraphNodeNode ] RETURNS [ BOOLEAN ] ~ { WITH tgn.body SELECT FROM vptgn: VariantPartTGN => RETURN[TRUE]; ENDCASE => RETURN[FALSE]; }; GetVariantPartUnionList: PROC [ tgn: TypeGraphNodeNode ] RETURNS [ FrozenUnionList ] ~ { WITH tgn.body SELECT FROM vptgn: VariantPartTGN => RETURN[vptgn.types]; ENDCASE => ERROR; }; CreateEmptyUnionList: PUBLIC PROC RETURNS [ UnionListNode ] ~ { RETURN[NEW [UnionListNodeBody _ [0, NIL, NIL]]]; }; <> AppendToUnionList: PUBLIC PROC [ ul: UnionListNode, id: IdNode, ffl: FrozenFieldListNode ] RETURNS [ ulnp: UnionListNode ] ~ { newCell: UnionListCell _ NEW [UnionListCellBody _ [id, ffl, NIL]]; IF ( ul.first = NIL ) THEN ul.first _ newCell ELSE ul.last.next _ newCell; ul.last _ newCell; ul.nCells _ ul.nCells+1; RETURN[ul]; }; <> FreezeUnionList: PROC[ ul: UnionListNode ] RETURNS [ FrozenUnionList ] ~ { ful: FrozenUnionList _ NEW [FrozenUnionListBody[ul.nCells]]; cell: UnionListCell _ ul.first; FOR i: CARDINAL IN [0..ful.nTypes) DO ful[i] _ [cell.id, cell.ffl]; cell _ cell.next; ENDLOOP; RETURN[ful] }; <> VariantFlavorNode: TYPE ~ REF VariantFlavorNodeBody; VariantFlavorNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.VariantFlavorNodeBody; OverlaidVariantFlavorConst: PUBLIC PROC RETURNS [ VariantFlavorNode ] ~ { RETURN[NEW [overlaid VariantFlavorNodeBody _ [overlaid[]]]] }; ComputedVariantFlavorConst: PUBLIC PROC RETURNS [ VariantFlavorNode ] ~ { RETURN[NEW [computed VariantFlavorNodeBody _ [computed[]]]] }; VanillaVariantFlavorVal: PUBLIC PROC [ id: IdNode, position: PositionValNode, access: AccessValNode ] RETURNS [ VariantFlavorNode ] ~ { RETURN[NEW [vanilla VariantFlavorNodeBody _ [vanilla[id, position, access]]]] }; <> SequenceTGN: TYPE ~ REF SequenceTGNBody; SequenceTGNBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.SequenceTGNBody; CreateSequenceTGN: PUBLIC PROC [ lc: LocalContextNode, packed: BOOLEAN, id: IdNode, position: PositionValNode, access: AccessValNode, tagType: TypeGraphNodeNode, type: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: SequenceTGN _ NEW [SequenceTGNBody _ [packed, id, position, access, tagType, type]]; RETURN[lc, CreateTGN[lc, body]]; }; <> CreateArrayTGN: PUBLIC PROC [ lc: LocalContextNode, packed: BOOLEAN, indexType: TypeGraphNodeNode, itemType: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: ArrayTGN _ NEW [ArrayTGNBody _ [packed, indexType, itemType]]; RETURN[lc, CreateTGN[lc, body]]; }; <> CreateDescriptorTGN: PUBLIC PROC [ lc: LocalContextNode, readonly: BOOLEAN, itemType: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: DescriptorTGN _ NEW [DescriptorTGNBody _ [readonly, itemType]]; RETURN[lc, CreateTGN[lc, body]]; }; <> CreateTransferTGN: PUBLIC PROC [ lc: LocalContextNode, safe: BOOLEAN, modeName: Rope.ROPE, arguments, results: FrozenFieldListNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { mode: TransferMode _ SELECT TRUE FROM Rope.Equal["proc", modeName] => proc, Rope.Equal["port", modeName] => port, Rope.Equal["signal", modeName] => signal, Rope.Equal["error", modeName] => error, Rope.Equal["process", modeName] => process, Rope.Equal["program", modeName] => program, ENDCASE => ERROR; body: TransferTGN _ NEW [TransferTGNBody_[safe, mode, arguments, results]]; RETURN[lc, CreateTGN[lc, body]]; }; <> CreateZoneTGN: PUBLIC PROC [ lc: LocalContextNode, uncounted: BOOLEAN ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: ZoneTGN _ NEW [ZoneTGNBody _ [uncounted]]; RETURN[lc, CreateTGN[lc, body]]; }; <> CreateLongTGN: PUBLIC PROC [ lc: LocalContextNode, underlyingType: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: LongTGN _ NEW [LongTGNBody _ [underlyingType]]; RETURN[lc, CreateTGN[lc, body]]; }; <> <> <<>> <> CreateEmptyInterfaceTGN: PUBLIC PROC [ lc: LocalContextNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: InterfaceTGN _ NEW [InterfaceTGNBody _ [FALSE, CreateEmptyVisibleNames[]]]; RETURN[lc, CreateTGN[lc, body]]; }; <<>> <> AddTGNToInterfaceTGN: PUBLIC PROC [lc: LocalContextNode, if: TypeGraphNodeNode, name: IdNode, access: AccessValNode, entryTgn: TypeGraphNodeNode] RETURNS [lcp: LocalContextNode] ~ { iftgn: InterfaceTGN _ NARROW[if.body]; IF entryTgn # NIL THEN RecordVisibleName[iftgn.typeNames, name, access, entryTgn]; <> RETURN[lc]; }; CreateInterfaceTGNFromInterface: PUBLIC PROC [lc: LocalContextNode, if: InterfaceValNode] RETURNS [lcp: LocalContextNode, ifTgn: TypeGraphNodeNode] ~ { AddOne: PROC [name: IdNode, access: AccessValNode, entryTGN: TypeGraphNodeNode] ~ { [] _ AddTGNToInterfaceTGN[lc, ifTgn, name, access, CreateLinkTGN[lc, entryTGN, if, name].ltgn]; }; ifTgn _ CreateEmptyInterfaceTGN[lc].tgn; GenInterfaceEntries[if, AddOne]; RETURN[lc, ifTgn]; }; <> <> <> <> <<[access, ratgn] _ LookupVisibleName[lc.lvtn, name];>> <> <> <> LookupTypeNameInInterfaceTGN: PUBLIC PROC [ lc: LocalContextNode, id: IdNode, if: TypeGraphNodeNode ] RETURNS [ tgn: TypeGraphNodeNode ] ~ { iftgn: InterfaceTGN _ NARROW[if.body]; refAnyTgn: REF ANY; access: AccessValNode; [access, refAnyTgn] _ LookupVisibleName[iftgn.typeNames, id]; IF access^ = public OR (access^ = private AND iftgn.sharedAccess) THEN RETURN[NARROW[refAnyTgn]]; ErrorSignal[]; }; GenPublicTypeNamesFromInterfaceTGN: PROC [ if: TypeGraphNodeNode, for: PROC [ IdNode, TypeGraphNodeNode ] ] ~ { iftgn: InterfaceTGN _ NARROW[if.body]; localFor: PROC [name: IdNode, access: AccessValNode, value: REF ANY] ~ BEGIN IF access^ = public OR (access^ = private AND iftgn.sharedAccess) THEN for[name, NARROW[value]] END; GenVisibleNames[iftgn.typeNames, localFor]; }; <<(following two operations correspond to entries in an OPEN clause)>> <<>> <<(OPEN name: interface)>> RenameInterface: PUBLIC PROC [lc: LocalContextNode, name: IdNode, interface: TypeGraphNodeNode] RETURNS [lcp: LocalContextNode] ~ { newTGN: TypeGraphNodeNode _ CreateLocallyVisibleTGN[lc, name, AccessValConst["private"]].tgn; WITH interface.body SELECT FROM itgn: InterfaceTGN => NULL; ENDCASE => ERROR; [] _ AddArcFromLVTGNToTGN[lc, newTGN, AccessValConst["private"], interface, DefaultExpVal["", NullExpPTree[]]]; RETURN[lc]; }; <<(OPEN interface)>> OpenInterface: PUBLIC PROC [ lc: LocalContextNode, interfaceTGN: TypeGraphNodeNode ] RETURNS [ lcp: LocalContextNode ] ~ { OpenOneInterfaceTypeName: PROC [ name: IdNode, tgn: TypeGraphNodeNode ] ~ { newTGN: TypeGraphNodeNode _ CreateLocallyVisibleTGN[lc, name, NEW[AccessValNodeBody_NotSureWhatItShouldBe]].tgn; [] _ AddArcFromLVTGNToTGN[lc, newTGN, NEW[AccessValNodeBody_NotSureWhatItShouldBe], tgn, DefaultExpVal["", NullExpPTree[]]]; }; GenPublicTypeNamesFromInterfaceTGN[ResolveNamedNodes[interfaceTGN], OpenOneInterfaceTypeName]; RETURN[lc]; }; <> <> <<(currently might be called with NIL tgn, when in a Using clause and refering to a entry point, rather than a type)>> CreateLinkTGN: PUBLIC PROC[lc: LocalContextNode, tgn: TypeGraphNodeNode, if: InterfaceValNode, itemName: IdNode] RETURNS[lcp: LocalContextNode, ltgn: TypeGraphNodeNode] = BEGIN IF tgn = NIL THEN RETURN[lc, NIL]; -- was a standin for an entry point RETURN[lc, CreateTGN[lc, NEW[LinkTGNBody_[tgn, if, itemName]]]]; END; <> <<(I will fill this in as needed later)>> FindFrameTGN: PUBLIC PROC [ lc: LocalContextNode, id: IdNode ] RETURNS [ tgn: TypeGraphNodeNode ] ~ { tgn _ FindLocallyVisibleTGN[lc, id]; WITH tgn.body SELECT FROM ftgn: FrameTGN => RETURN[tgn]; ENDCASE => ERROR; }; <> <<(we are either : 1) specializing a sequence or array of length 0, 2) discriminating a variant, 3) selecting an interface type.) There is one syntactic case in which we can't tell which until the data structures are completely built. ("foo[red]"), so we use this more general term for now.)>> <<(Dan Swinehart selected the word Specianated, if you can't figure out what this word means, try another field.)>> <<>> <<(underlying type must be a variant style record type, a sequence style record type, an array type with empty index domain, or an interface TGN.)>> <<(In the case of a def file TGN we do the appropriate look up, as this case can be distinguished during this construction pass.)>> <<>> <<(only one of expParameter and idParam will be non nil)>> <<>> <<(This one might be the selection of a type from an interface)>> CreateSpecianatedTGNUsingId: PUBLIC PROC [ lc: LocalContextNode, underlyingType: TypeGraphNodeNode, id: IdNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { WITH underlyingType.body SELECT FROM iftgn: InterfaceTGN => { RETURN[lc, LookupTypeNameInInterfaceTGN[lc, id, underlyingType].tgn]; <> }; ENDCASE => { body: SpecianatedTGN _ NEW [SpecianatedTGNBody _ [NIL, id, underlyingType]]; RETURN[lc, CreateTGN[lc, body]]; }; }; <<(this one can not be the selection of a type from an interface)>> CreateSpecianatedTGNUsingExp: PUBLIC PROC [ lc: LocalContextNode, underlyingType: TypeGraphNodeNode, parameter: ExpPTreeNode ] RETURNS [ lcp: LocalContextNode, tgn: TypeGraphNodeNode ] ~ { body: SpecianatedTGN _ NEW [SpecianatedTGNBody _ [parameter, NIL, underlyingType]]; RETURN[lc, CreateTGN[lc, body]]; }; <> OpaqueTGN: TYPE = REF OpaqueTGNBody; OpaqueTGNBody: PUBLIC TYPE = SaffronContextPrivateTypes.OpaqueTGNBody; CreateOpaqueTGN: PUBLIC PROC[lc: LocalContextNode, paint: PaintNode, optSize: ExpPTreeNode] RETURNS[lcp: LocalContextNode, tgn: TypeGraphNodeNode ] = BEGIN body: OpaqueTGN _ NEW[OpaqueTGNBody_[paint, optSize]]; RETURN[lc, CreateTGN[lc, body]]; END; <> PaintNode: TYPE ~ REF PaintNodeBody; PaintNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.PaintNodeBody; CreateUnpaintedPaint: PROC [ lc: LocalContextNode ] RETURNS [ PaintNode ] ~ { RETURN[NEW [PaintNodeBody _ [lc, 0]]] }; GetUnpaintedPaint: PUBLIC PROC [ lc: LocalContextNode ] RETURNS [ lcp: LocalContextNode, p: PaintNode ] ~ { RETURN[lc, lc.unpaintedPaint] }; <<>> GetUniquePaint: PUBLIC PROC [ lc: LocalContextNode ] RETURNS [ lcp: LocalContextNode, p: PaintNode ] ~ { lc.paintIndex _ lc.paintIndex + 1; RETURN[lc, NEW [PaintNodeBody _ [lc, lc.paintIndex]]]; }; <> CreateEmptyVisibleNames: PROC RETURNS [ vn: VisibleNames ] ~ { vn _ NEW [VisibleNamesBody _ [NIL]]; RETURN[vn]; }; RecordVisibleName: PROC [ vn: VisibleNames, name: IdNode, access: AccessValNode, value: REF ANY ] ~ { newCell: VNCell _ NEW [VNCellBody _ [name, access, value, vn.first]]; IF ( LookupVisibleName[vn, name].value # NIL ) THEN ErrorSignal[]; newCell _ NEW[VNCellBody _ [name, access, value, vn.first]]; vn.first _ newCell; }; LookupVisibleName: PROC [vn: VisibleNames, name: IdNode] RETURNS [access: AccessValNode, value: REF ANY] ~ { cell: VNCell _ vn.first; WHILE ( cell # NIL ) DO IF Rope.Equal[RopeFromId[cell.id], RopeFromId[name]] THEN RETURN[cell.access, cell.value]; cell _ cell.next; ENDLOOP; RETURN[NIL, NIL]; }; GenVisibleNames: PUBLIC PROC [vn: VisibleNames, for: PROC [name: IdNode, access: AccessValNode, value: REF ANY] ] ~ { cell: VNCell _ vn.first; WHILE ( cell # NIL ) DO for[cell.id, cell.access, cell.value]; cell _ cell.next; ENDLOOP; }; <> DefaultExpNode: TYPE ~ REF DefaultExpNodeBody; DefaultExpNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.DefaultExpNodeBody; DefaultExpVal: PUBLIC PROC [ case: Rope.ROPE, exp: ExpPTreeNode ] RETURNS [ DefaultExpNode ] ~ { RETURN[NEW [DefaultExpNodeBody _ [ SELECT TRUE FROM Rope.Equal[case, ""] => c1, Rope.Equal[case, "_"] => c2, Rope.Equal[case, "_e"] => c3, Rope.Equal[case, "_TRASH"] => c4, Rope.Equal[case, "_e|TRASH"] => c5, ENDCASE => ERROR, exp]]]; }; NullDefaultVal: PUBLIC PROC RETURNS [ DefaultExpNode ] ~ { RETURN[NIL]; }; <> PositionValNode: TYPE ~ REF PositionValNodeBody; PositionValNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.PositionValNodeBody; PositionValFun: PUBLIC PROC [ index: ExpPTreeNode, bounds: BoundsValNode ] RETURNS [ PositionValNode ] ~ { RETURN[NEW[PositionValNodeBody _ [index, bounds]]]; }; NullPosition: PUBLIC PROC RETURNS [ PositionValNode ] ~ { RETURN[NIL]; }; <> BoundsValNode: TYPE ~ REF BoundsValNodeBody; BoundsValNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.BoundsValNodeBody; BoundsValFun: PUBLIC PROC [ leftBracket: Rope.ROPE, first: ExpPTreeNode, last: ExpPTreeNode, rightBracket: Rope.ROPE ] RETURNS [ BoundsValNode ] ~ { bvn: BoundsValNode _ NEW [BoundsValNodeBody _ [open, first, last, open]]; bvn.left _ SELECT TRUE FROM Rope.Equal["[", leftBracket] => closed, Rope.Equal["(", leftBracket] => open, ENDCASE => ERROR; bvn.right _ SELECT TRUE FROM Rope.Equal["]", rightBracket] => closed, Rope.Equal[")", rightBracket] => open, ENDCASE => ERROR; RETURN[bvn]; }; NullBounds: PUBLIC PROC RETURNS [ BoundsValNode ] ~ { RETURN[NIL] }; <> AccessValNode: TYPE ~ REF AccessValNodeBody; AccessValNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.AccessValNodeBody; AccessValConst: PUBLIC PROC [ r: Rope.ROPE ] RETURNS [ AccessValNode ] ~ { SELECT TRUE FROM Rope.Equal[r, "empty"] => RETURN[NEW [AccessValNodeBody _ empty]]; Rope.Equal[r, "private"] => RETURN[NEW [AccessValNodeBody _ private]]; Rope.Equal[r, "public"] => RETURN[NEW [AccessValNodeBody _ public]]; ENDCASE => ErrorSignal[]; }; NullAccessVal: PUBLIC PROC [ ] RETURNS [ AccessValNode ] ~ { RETURN[NIL]; }; <> ExpPTreeNode: TYPE ~ REF ExpPTreeNodeBody; ExpPTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.ExpPTreeNodeBody; <<>> <> <> ExpPTreeVal: PUBLIC PROC [ node: ExpNode ] RETURNS [ ExpPTreeNode ] ~ { RETURN[NEW [ExpPTreeNodeBody _ [node]]]; }; NullExpPTree: PUBLIC PROC RETURNS [ ExpPTreeNode ] ~ { RETURN[NIL] }; <> ScopePTreeNode: TYPE ~ REF ScopePTreeNodeBody; ScopePTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.ScopePTreeNodeBody; <<>> <> ScopePTreeVal: PUBLIC PROC [ node: ScopeNode ] RETURNS [ ScopePTreeNode ] ~ { RETURN[NEW [ScopePTreeNodeBody _ [node]]] }; ScopeVal: PUBLIC PROC [ box: ScopePTreeNode ] RETURNS [ ScopeNode ] ~ { RETURN[box.node] }; <<>> <> ModulePPTreeNode: TYPE ~ REF ModulePPTreeNodeBody; ModulePPTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.ModulePPTreeNodeBody; ModulePPTreeVal: PUBLIC PROC [ node: ModulePNode ] RETURNS [ ModulePPTreeNode ] ~ {RETURN[NEW[ModulePPTreeNodeBody_[node]]]}; ModulePVal: PUBLIC PROC [ node: ModulePPTreeNode ] RETURNS [ ModulePNode ] ~ {RETURN[node.node]}; <> DefBodyPTreeNode: TYPE ~ REF DefBodyPTreeNodeBody; DefBodyPTreeNodeBody: PUBLIC TYPE ~ SaffronContextPrivateTypes.DefBodyPTreeNodeBody; DefBodyPTreeVal: PUBLIC PROC [ node: DefBodyNode ] RETURNS [ DefBodyPTreeNode ] ~ {RETURN[NEW[DefBodyPTreeNodeBody_[node]]]}; DefBodyVal: PUBLIC PROC [ node: DefBodyPTreeNode ] RETURNS [ DefBodyNode ] ~ {RETURN[node.node]}; <> NameSequenceNode: TYPE = REF NameSequenceNodeBody; NameSequenceNodeBody: PUBLIC TYPE = SaffronContextPrivateTypes.NameSequenceNodeBody; EmptyNameSequence: PUBLIC PROC RETURNS[NameSequenceNode] = {RETURN[NEW[NameSequenceNodeBody _ NIL]]}; InsertNameOnNameSequence: PUBLIC PROC[name: IdNode, ns: NameSequenceNode] RETURNS[NameSequenceNode] = {RETURN[NEW[NameSequenceNodeBody _ CONS[name, ns^]]]}; <> RopeNames: TYPE = REF RopeNamesBody; RopeNamesBody: TYPE = SaffronContextPrivateTypes.RopeNamesBody; RNCell: TYPE = REF RNCellBody; RNCellBody: TYPE = SaffronContextPrivateTypes.RNCellBody; CreateEmptyRopeNames: PROC RETURNS[rns: RopeNames] = BEGIN rns _ NEW[RopeNamesBody _ [NIL]]; RETURN[rns]; END; RecordRopeName: PROC[rns: RopeNames, name: Rope.ROPE, val: REF ANY] = BEGIN newCell: RNCell _ NEW[RNCellBody_[name, val, rns.first]]; IF (LookupRopeName[rns, name] # NIL) THEN ErrorSignal[]; rns.first _ newCell; END; LookupRopeName: PROC[rns: RopeNames, name: Rope.ROPE] RETURNS[REF ANY] = BEGIN cell: RNCell _ rns.first; WHILE cell # NIL DO IF Rope.Equal[cell.name, name] THEN RETURN[cell.value]; cell _ cell.next; ENDLOOP; RETURN[NIL]; END; GenRopeNames: PUBLIC PROC[rns: RopeNames, for: PROC[Rope.ROPE, REF ANY]] = BEGIN cell: RNCell _ rns.first; WHILE cell # NIL DO for[cell.name, cell.value]; cell _ cell.next; ENDLOOP; END; <> RopeFromId: PUBLIC PROC [ id: IdNode ] RETURNS [ Rope.ROPE ] ~ { RETURN[IF ( id # NIL ) THEN id.text ELSE ""]; }; RopeFromString: PUBLIC PROC [ string: StringNode ] RETURNS [ Rope.ROPE ] ~ { RETURN[IF ( string # NIL ) THEN string.text ELSE ""]; }; <> ErrorSignal: PUBLIC ERROR ~ CODE; <> True: PUBLIC PROC RETURNS [ BOOLEAN ] ~ { RETURN[TRUE] }; False: PUBLIC PROC RETURNS [ BOOLEAN ] ~ { RETURN[FALSE] }; BooleanConst: PUBLIC PROC [ r: Rope.ROPE ] RETURNS [ BOOLEAN ] ~ { SELECT TRUE FROM Rope.Equal[r, "True"] => RETURN[TRUE]; Rope.Equal[r, "False"] => RETURN[FALSE]; ENDCASE => ErrorSignal[]; }; Error: PUBLIC PROC [ r: Rope.ROPE ] RETURNS [ BOOLEAN ] ~ { ERROR }; NullId: PUBLIC PROC RETURNS [ IdNode ] ~ { RETURN[NIL] }; }.