SaffronMethods.ThreeC4 (July 16, 1987 4:02:51 pm PDT)
Copyright Ó 1987 by Xerox Corporation. All rights reserved.
Lucy Hederman August 20, 1987 3:49:01 pm PDT
Sturgis, July 21, 1987 3:16:17 pm PDT
Include [SaffronAG, SaffronTreeDecls, SaffronBaseDecls];
need DoTop to take MakeType of the TypeExp
SaffronMakeType: Module = Begin
Top
for Top.modulep: AbstractProduction [ ModuleP ]
let DoTop[tree, fileName, env] ← MakeEnvironment [ModuleP, fileName, env]
let Explore [tree, fileName, env] ← Explore [ModuleP, fileName, env]
;
ModuleP
for ModuleP.impl: AbstractProduction [ Directory, IdentList, Cedar, ProgHead, Checked, Block ]
NOTE : This isn't really doing much.. Also ignoring Cedar, ProgHead, Checked
let MakeEnvironment [tree, fileName, env] ← <env, interface>
where env ← AddInterfaceToEnvironment [CreateEmptyEnvironment [], "", interface]
where interface ← CreateInterfaceFromContextTree [ct, EmptyNameSequence[]]
where ct ← EmptyContextTree [ RootContextRib []]
let Explore [tree, fileName, env] ← <env, interface>
where env ← AddInterfaceToEnvironment [CreateEmptyEnvironment [], "", interface]
where interface ← CreateInterfaceFromContextTree [ct, EmptyNameSequence[]]
where ct ← EmptyContextTree [ RootContextRib []]
;
for ModuleP.def: AbstractProduction [ Directory, IdentList, Cedar, DefHead, DefBody ]
let MakeEnvironment [tree, fileName, env] ← <env2, interface>
where env2 ← AddInterfaceToEnvironment [env1, fileName, interface]
where interface ← CreateInterfaceFromContextTree [contextTree, nameSequence]
where contextTree ← MakeContextTree [DefBody, contextRib, paintRecords]
where contextRib ← FreezeLocalContext [localContext]
where paintRecords ← True []
where nameSequence ← MakeNameSequence [IdentList]
where <localContext, env1> ← ProcessDirectoryClause [Directory, rootContext, env]
where rootContext ← CreateEmptyContext [RootContextRib []]
let Explore [tree, fileName, env] ← <env2, interface>
where env2 ← AddInterfaceToEnvironment [env1, fileName, interface]
where interface ← CreateInterfaceFromContextTree [ct, EmptyNameSequence[]]
where ct ← EmptyContextTree [ RootContextRib []]
where env1 ← ExploreDirectoryClause [Directory, env]
;
NOTE : ignoring Cedar, DefHead
Directory
for Directory.empty: AbstractProduction [ ]
let ProcessDirectoryClause [tree, localContext, env] ←
<FakeDamageContext [localContext], FakeDamageEnvironment [env]>
let ExploreDirectoryClause [tree, env] ← FakeDamageEnvironment [env]
;
for Directory.more: AbstractProduction [ Directory, IncludeItem ]
let ProcessDirectoryClause [tree, localContext, env] ←
ProcessDirectoryClause [IncludeItem,
         ProcessDirectoryClause [Directory, localContext, env]]
let ExploreDirectoryClause [tree, env] ←
ExploreDirectoryClause [IncludeItem,
         ExploreDirectoryClause [Directory, env]]
;
IncludeItem
for IncludeItem.fromp: AbstractProduction [ Id, String, Using ]
let ProcessDirectoryClause [tree, localContext, env] ← <localContext3, env2>
where localContext3 ← AddArcFromLVTGNToTGN [localContext2, lvTgn,
           NullAccessVal[], interfaceTgn, NullDefaultVal []]
where <localContext2, lvTgn> ←
       CreateLocallyVisibleTGN [localContext1, Id, NullAccessVal[]]     
where <localContext1, interfaceTgn> ← MakeInterfaceTGN [Using, localContext, interface]
NOTE should check recorded module name against expected : Id
where <env2, interface> ←
if IsInterfaceInEnv [env, fileName]
then ( <env1, LookupInterfaceInEnv [env1, fileName]>
where env1 ← FakeDamageEnvironment [env] )
else ( MakeEnvironment [defFile, fileName, env]
where defFile ← ModulePVal [ReadDefFile [fileName]] )
where fileName ← RopeFromString [String]
let ExploreDirectoryClause [tree, env] ← env2
where <env2, interface> ←
if IsInterfaceInEnv [env, fileName]
then ( <env1, LookupInterfaceInEnv [env1, fileName]>
where env1 ← FakeDamageEnvironment [env] )
else ( Explore [defFile, fileName, env]
where defFile ← ModulePVal [ReadDefFile [fileName]] )
where fileName ← RopeFromString [String]
;
for IncludeItem.type: AbstractProduction [ Id, Using ]
let ProcessDirectoryClause [tree, localContext, env] ← <localContext3, env2>
where localContext3 ← AddArcFromLVTGNToTGN [localContext2, lvTgn,
           NullAccessVal[], interfaceTgn, NullDefaultVal []]
where <localContext2, lvTgn> ←
       CreateLocallyVisibleTGN [localContext1, Id, NullAccessVal[]]     
where <localContext1, interfaceTgn> ← MakeInterfaceTGN [Using, localContext, interface]
NOTE should check recorded module name against expected : Id
where <env2, interface> ←
if IsInterfaceInEnv [env, fileName]
then ( <env1, LookupInterfaceInEnv [env1, fileName]>
where env1 ← FakeDamageEnvironment [env] )
else ( MakeEnvironment [defFile, fileName, env]
where defFile ← ModulePVal [ReadDefFile [fileName]] )
where fileName ← RopeFromId [Id]
let ExploreDirectoryClause [tree, env] ← env2
where <env2, interface> ←
if IsInterfaceInEnv [env, fileName]
then ( <env1, LookupInterfaceInEnv [env1, fileName]>
where env1 ← FakeDamageEnvironment [env] )
else ( Explore [defFile, fileName, env]
where defFile ← ModulePVal [ReadDefFile [fileName]] )
where fileName ← RopeFromId [Id]
;
for IncludeItem.plain: AbstractProduction [ Id, Using ]
let ProcessDirectoryClause [tree, localContext, env] ← <localContext3, env2>
where localContext3 ← AddArcFromLVTGNToTGN [localContext2, lvTgn,
           NullAccessVal[], interfaceTgn, NullDefaultVal []]
where <localContext2, lvTgn> ←
       CreateLocallyVisibleTGN [localContext1, Id, NullAccessVal[]]     
where <localContext1, interfaceTgn> ← MakeInterfaceTGN [Using, localContext, interface]
NOTE should check recorded module name against expected : Id
where <env2, interface> ←
if IsInterfaceInEnv [env, fileName]
then ( <env1, LookupInterfaceInEnv [env1, fileName]>
where env1 ← FakeDamageEnvironment [env] )
else ( MakeEnvironment [defFile, fileName, env]
where defFile ← ModulePVal [ReadDefFile [fileName]] )
where fileName ← RopeFromId [Id]
let ExploreDirectoryClause [tree, env] ← env2
where <env2, interface> ←
if IsInterfaceInEnv [env, fileName]
then ( <env1, LookupInterfaceInEnv [env1, fileName]>
where env1 ← FakeDamageEnvironment [env] )
else ( Explore [defFile, fileName, env]
where defFile ← ModulePVal [ReadDefFile [fileName]] )
where fileName ← RopeFromId [Id]
;
for IncludeItem.typeandid: AbstractProduction [ Id.local, Id.global, Using ]
let ProcessDirectoryClause [tree, localContext, env] ← <localContext3, env2>
where localContext3 ← AddArcFromLVTGNToTGN [localContext2, lvTgn,
           NullAccessVal[], interfaceTgn, NullDefaultVal []]
where <localContext2, lvTgn> ←
      CreateLocallyVisibleTGN [localContext1, Id.local, NullAccessVal[]]     
where <localContext1, interfaceTgn> ← MakeInterfaceTGN [Using, localContext, interface]
NOTE should check recorded module name against expected : Id.global
where <env2, interface> ←
if IsInterfaceInEnv [env, fileName]
then ( <env1, LookupInterfaceInEnv [env1, fileName]>
where env1 ← FakeDamageEnvironment [env] )
else ( MakeEnvironment [defFile, fileName, env]
where defFile ← ModulePVal [ReadDefFile [fileName]] )
where fileName ← RopeFromId [Id.local]
let ExploreDirectoryClause [tree, env] ← env2
where <env2, interface> ←
if IsInterfaceInEnv [env, fileName]
then ( <env1, LookupInterfaceInEnv [env1, fileName]>
where env1 ← FakeDamageEnvironment [env] )
else ( Explore [defFile, fileName, env]
where defFile ← ModulePVal [ReadDefFile [fileName]] )
where fileName ← RopeFromId [Id.local]
;
Using
for Using.restricted: AbstractProduction [ IdList ]
let MakeInterfaceTGN [tree, localContext, interface] ←
<AddIdsToInterfaceTGN [IdList, localContext1, interfaceTGN, interface], interfaceTGN>
where <localContext1, interfaceTGN> ← CreateEmptyInterfaceTGN [localContext]
;
for Using.nothing: AbstractProduction [ ]
let MakeInterfaceTGN [tree, localContext, interface] ←
             CreateEmptyInterfaceTGN [localContext]
;
for Using.unrestricted: AbstractProduction [ ]
let MakeInterfaceTGN [tree, localContext, interface] ←
CreateInterfaceTGNFromInterface [localContext, interface]
;
DefBody
for DefBody: AbstractProduction [ BindList, DecList ]
let MakeContextTree [tree, contextRib, paintRecords] ←
Make the contextTree for the entire DefBody, nesting the DecList inside the bindlist's context.
MakeBindListContextTreeWithDefBody [BindList, defBodyPTree, contextRib, paintRecords]
where defBodyPTree ← DefBodyPTreeVal [tree]
let MakeContextTree1 [tree, rib, paintRecords] ←
Make the contextTree for the context nested within the BindList.
HangContextsFromContextTree [DecList, thisScopeContextTree, newRib, paintRecords]
where thisScopeContextTree ← EmptyContextTree [newRib]
where newRib ← FreezeLocalContext [thisScopeLocalContext]
(note: Freeze will "process" the type graph, looking for cycles etc.)
where thisScopeLocalContext ← UpdateLocalContext [DecList, localContext, paintRecords ]
where localContext ← CreateEmptyContext [rib]
;
TypeExp
for TypeExp.record: AbstractProduction [ MachineDependent, Monitored, RecList ]
let MakeType[tree, localContext, paintRecords] ← <localContext4, newTgn>
where <localContext4, newTgn> ←
CreateRecordTGN [ localContext3, paint, machineDependent, monitored, frozenFieldList]
where <localContext3, frozenFieldList> ← FreezeFieldList [localContext2, fieldList]
where <localContext2, fieldList> ← MakeFieldList [RecList, localContext1, paintRecords]
where <localContext1, paint> ←
if paintRecords then GetUniquePaint [localContext]
  else GetUnpaintedPaint [localContext]
where machineDependent ← GetBooleanVal [MachineDependent]
where monitored ← GetBooleanVal [Monitored]
;
for TypeExp.union: AbstractProduction [ Tag, VariantList ]
let MakeType[tree, localContext, paintRecords] ←
CreateVariantPartTGN [localContext3, variantFlavor, tagTypeTgn1, unionList]
where variantFlavor ← MakeVariantFlavor [Tag]
where <localContext3, tagTypeTgn1> ←
if isStarTagType
then Make up a Tag type by an enumeration of the VariantList types
then MakeStarTagType [VariantList, localContext2]
else <FakeDamageContext [localContext2], tagTypeTgn>
where <localContext2, tagTypeTgn, isStarTagType> ←
MakeTagType [Tag, localContext1, paintRecords]
where <localContext1, unionList> ←
MakeUnionList [VariantList, localContext, paintRecords]
;
for TypeExp.sequence: AbstractProduction [ Packed, Tag, TypeExp ]
let MakeType[tree, localContext, paintRecords] ←
CreateSequenceTGN [localContext2, packed, GetSequenceTagInfo [Tag], tagTypeTgn, tgn]
where packed ← GetBooleanVal [Packed]
where x ← if isStarTagType then Error ["Sequence Tag must not be a star"] else True[]
where <localContext2, tagTypeTgn, isStarTagType> ←
MakeTagType [Tag, localContext1, paintRecords]
where <localContext1, tgn> ← MakeType [TypeExp, localContext, paintRecords]
;
for TypeExp.enum: AbstractProduction [ MachineDependent, ElementList ]
let MakeType[tree, localContext, paintRecords] ← MakeElementList [ElementList, localContext, machineDependent]
where machineDependent ← GetBooleanVal [MachineDependent]
;
for TypeExp.ref: AbstractProduction [ ReadOnly, TypeExp ]
let MakeType[tree, localContext, paintRecords] ←
  CreateRefTGN [localContext1, readOnly, referentTgn]
where <localContext1, referentTgn> ← MakeType [TypeExp, localContext, paintRecords]
where readOnly ← GetBooleanVal [ReadOnly]
;
for TypeExp.refany: AbstractProduction [ ReadOnly ]
let MakeType[tree, localContext, paintRecords] ←
           CreateRefTGN [localContext1, readOnly, topTgn]
where topTgn ← FindTopTGN [localContext1]
where localContext1 ← FakeDamageContext [localContext]
where readOnly ← GetBooleanVal [ReadOnly]
;
for TypeExp.refunspecified: AbstractProduction [ ]
let MakeType[tree, localContext, paintRecords] ←
           CreateRefTGN [localContext1, readOnly, topTgn]
where topTgn ← FindTopTGN [localContext1]
where localContext1 ← FakeDamageContext [localContext]
where readOnly ← False []
;
for TypeExp.typeid: AbstractProduction [ TypeId ]
let MakeType[tree, localContext, paintRecords] ←
            MakeType [TypeId, localContext, paintRecords]
;
for TypeExp.subrange: AbstractProduction [ Subrange ]
let MakeType[tree, localContext, paintRecords] ←
            MakeType[Subrange, localContext, paintRecords]
;
for TypeExp.pointer: AbstractProduction [ Ordered, Base, PointerType ]
let MakeType[tree, localContext, paintRecords] ←
     CreatePointerTGN [localContext1, ordered, base, bounds, readOnly, tgn]
where ordered ← GetBooleanVal [Ordered]
where base ← GetBooleanVal [Base]
where <localContext1, bounds, readOnly, tgn> ←
   GetPointerTypeInfo [PointerType, localContext, paintRecords]
;
for TypeExp.var: AbstractProduction [ TypeExp ]
let MakeType[tree, localContext, paintRecords] ← CreateVarTGN [localContext1, tgn]
where <localContext1, tgn> ← MakeType [TypeExp, localContext, paintRecords]
;
for TypeExp.list: AbstractProduction [ ReadOnly, TypeExp ]
let MakeType[tree, localContext, paintRecords] ←
  CreateListTGN [localContext1, readOnly, itemTgn]
where <localContext1, itemTgn> ← MakeType [TypeExp, localContext, paintRecords]
where readOnly ← GetBooleanVal [ReadOnly]
;
for TypeExp.array: AbstractProduction [ Packed, OptType, TypeExp ]
let MakeType[tree, localContext, paintRecords] ←
        CreateArrayTGN [localContext2, packed, indexTgn, itemTgn]
where <localContext2, itemTgn> ← MakeType [TypeExp, localContext1, paintRecords]
where <localContext1, indexTgn> ← MakeType [OptType, localContext, paintRecords]
where packed ← GetBooleanVal [Packed]
;
for TypeExp.descriptor: AbstractProduction [ ReadOnly, TypeExp ]
let MakeType[tree, localContext, paintRecords] ←
           CreateDescriptorTGN [localContext1, readOnly, tgn]
where <localContext1, tgn> ← MakeType [TypeExp, localContext, paintRecords]
where readOnly ← GetBooleanVal [ReadOnly]
;
for TypeExp.transfer: AbstractProduction [ Safe, TransferMode, Arguments ]
let MakeType[tree, localContext, paintRecords] ←
    CreateTransferTGN [localContext1, safe, transferMode, fflInput, fflOutput]
where <localContext1, fflInput, fflOutput> ←
       MakeArgumentLists [Arguments, localContext, paintRecords]
where transferMode ← MakeTransferMode [TransferMode]
where safe ← GetBooleanVal [Safe]
;
for TypeExp.relative: AbstractProduction [ TypeId, TypeExp ]
let MakeType[tree, localContext, paintRecords] ←
          CreateRelativeTGN [localContext2, baseTgn, tgn]
where <localContext2, tgn> ← MakeType [TypeExp, localContext1, paintRecords]
where <localContext1, baseTgn> ← LookupTypeId [TypeId, localContext]
;
for TypeExp.zone: AbstractProduction [ Uncounted ]
let MakeType[tree, localContext, paintRecords] ←
       CreateZoneTGN [localContext, GetBooleanVal [Uncounted]]
;
for TypeExp.long: AbstractProduction [ TypeExp ]
let MakeType[tree, localContext, paintRecords] ← CreateLongTGN [localContext1, tgn]
where <localContext1, tgn> ← MakeType [TypeExp, localContext, paintRecords]
;
for TypeExp.frame: AbstractProduction [ Id ]
let MakeType[tree, localContext, paintRecords] ←
           <localContext1, FindFrameTGN [localContext1, Id]>
where localContext1 ← FakeDamageContext [localContext]
;
for TypeExp.painted: AbstractProduction [ TypeId, TypeExp ]
let MakeType[tree, localContext, paintRecords] ← <c, n>
where n ← FindBottomTGN[c]
where c ← FakeDamageContext [localContext]
where x ← Error [" Unimplemented Construct"]
;
for TypeExp.typeapply: AbstractProduction [ TypeApply ]
let MakeType[tree, localContext, paintRecords] ←
         MakeType [TypeApply, localContext, paintRecords]
;
TypeApply
for TypeApply.one: AbstractProduction [ TypeId, Exp ]
let MakeType[tree, localContext, paintRecords] ←
CreateSpecianatedTGNUsingExp [localContext1, tgn, ExpPTreeVal [Exp]]
where <localContext1, tgn> ← LookupTypeId [TypeId, localContext]
;
for TypeApply.morelengths: AbstractProduction [ TypeApply, Exp ]
let MakeType[tree, localContext, paintRecords] ←
CreateSpecianatedTGNUsingExp [localContext1, tgn, ExpPTreeVal [Exp]]
where <localContext1, tgn> ← MakeType [TypeApply, localContext, paintRecords]
;
for TypeApply.moreids: AbstractProduction [ TypeApply, Id ]
let MakeType[tree, localContext, paintRecords] ←
CreateSpecianatedTGNUsingId [localContext1, tgn, Id]
where <localContext1, tgn> ← MakeType [TypeApply, localContext, paintRecords]
;
TypeId
for TypeId.id: AbstractProduction [ Id ]
let MakeType[tree, localContext, paintRecords] ← <localContext1, tgn>
where localContext1 ← FakeDamageContext [localContext]
where tgn ← FindLocallyVisibleTGN [ localContext, Id ]
let LookupTypeId [tree, localContext] ←<localContext1, tgn>
where localContext1 ← FakeDamageContext [localContext]
where tgn ← FindLocallyVisibleTGN [ localContext, Id ]
;
for TypeId.qualifier: AbstractProduction [ TypeId, Id ]
let MakeType[tree, localContext, paintRecords] ← LookupTypeId [tree, localContext]
let LookupTypeId [tree, localContext] ←
CreateSpecianatedTGNUsingId [localContext1, tgn, Id]
where <localContext1, tgn> ← LookupTypeId [TypeId, localContext]
;
OptType
for OptType.absent: AbstractProduction [ ]
let MakeType[tree, localContext, paintRecords] ← <localContext1, tgn>
where localContext1 ← FakeDamageContext [localContext]
where tgn ← FindBottomTGN [localContext]
;
for OptType.present: AbstractProduction [ TypeExp ]
let MakeType[tree, localContext, paintRecords] ←
            MakeType[TypeExp, localContext, paintRecords]
;
Subrange
for Subrange.named: AbstractProduction [ TypeId, Interval ]
let MakeType[tree, localContext, paintRecords] ←
CreateSubrangeTGN [localContext1, tgn, bounds]
where <localContext1, tgn> ← LookupTypeId [TypeId, localContext]
where bounds ← GetBoundsVal [Interval]
;
for Subrange.unnamed: AbstractProduction [ Interval ]
let MakeType[tree, localContext, paintRecords] ← CreateSubrangeTGN [localContext, tgn, bounds]
where tgn ← FindBottomTGN [localContext]
where bounds ← GetBoundsVal [Interval]
;
Interval
for Interval.cc: AbstractProduction [ Bounds ]
let GetBoundsVal [tree] ← BoundsValFun ["[", GetLowerAndUpper [Bounds], "]"]
;
for Interval.co: AbstractProduction [ Bounds ]
let GetBoundsVal [tree] ← BoundsValFun ["[", GetLowerAndUpper [Bounds], ")"]
;
for Interval.oc: AbstractProduction [ Bounds ]
let GetBoundsVal [tree] ← BoundsValFun ["(", GetLowerAndUpper [Bounds], "]"]
;
for Interval.oo: AbstractProduction [ Bounds ]
let GetBoundsVal [tree] ← BoundsValFun ["(", GetLowerAndUpper [Bounds], ")"]
;
Bounds
for Bounds: AbstractProduction [ Exp.lower, Exp.upper ]
let GetLowerAndUpper [tree] ← <ExpPTreeVal [Exp.lower], ExpPTreeVal [Exp.upper]>
;
PointerType
for PointerType.unspecified: AbstractProduction [ OptInterval ]
let GetPointerTypeInfo [tree, localContext, paintRecords] ← <localContext1, bounds, readOnly, tgn>
where bounds ← GetBoundsVal [OptInterval]
where readOnly ← False []
where tgn ← FindBottomTGN[localContext1]
where localContext1 ← FakeDamageContext [localContext]
;
for PointerType.specified: AbstractProduction [ OptInterval, ReadOnly, TypeExp ]
let GetPointerTypeInfo [tree, localContext, paintRecords] ← <localContext1, bounds, readOnly, tgn>
where bounds ← GetBoundsVal [OptInterval]
where readOnly ← GetBooleanVal [ReadOnly]
where <localContext1, tgn> ← MakeType [TypeExp, localContext, paintRecords]
;
OptInterval
for OptInterval.absent: AbstractProduction [ ]
let GetBoundsVal [tree] ← NullBounds []
;
for OptInterval.present: AbstractProduction [ Interval ]
let GetBoundsVal [tree] ← GetBoundsVal [Interval]
;
TransferMode
for TransferMode.proc: AbstractProduction [ ]
let MakeTransferMode [tree] ← "proc"
;
for TransferMode.port: AbstractProduction [ ]
let MakeTransferMode [tree] ← "port"
;
for TransferMode.signal: AbstractProduction [ ]
let MakeTransferMode [tree] ← "signal"
;
for TransferMode.error: AbstractProduction [ ]
let MakeTransferMode [tree] ← "error"
;
for TransferMode.process: AbstractProduction [ ]
let MakeTransferMode [tree] ← "process"
;
for TransferMode.program: AbstractProduction [ ]
let MakeTransferMode [tree] ← "program"
;
Arguments
for Arguments: AbstractProduction [ ParameterList.input, ParameterList.output ]
let MakeArgumentLists [tree, localContext, paintRecords] ← <localContext2, frozenInputlist, frozenOutputList>
where <localContext2, frozenOutputList> ←
FreezeFieldList [MakeFieldList [ParameterList.output, localContext1, paintRecords]]
where <localContext1, frozenInputlist> ←
FreezeFieldList [MakeFieldList [ParameterList.input, localContext, paintRecords]]
;
Default
for Default.empty: AbstractProduction [ ]
let GetDefaultExpVal [tree] ← DefaultExpVal ["", NullExpPTree []]
;
for Default.gets: AbstractProduction [ ]
let GetDefaultExpVal [tree] ← DefaultExpVal ["←", NullExpPTree []]
;
for Default.getsexp: AbstractProduction [ Exp ]
let GetDefaultExpVal [tree] ← DefaultExpVal ["𡤎", ExpPTreeVal [Exp]]
;
for Default.getstrash: AbstractProduction [ ]
let GetDefaultExpVal [tree] ← DefaultExpVal ["←TRASH", NullExpPTree []]
;
for Default.getsexportrash: AbstractProduction [ Exp ]
let GetDefaultExpVal [tree] ← DefaultExpVal ["𡤎|TRASH", ExpPTreeVal [Exp]]
;
Packed
for Packed.yes: AbstractProduction [ ]
let GetBooleanVal [tree] ← True []
;
for Packed.no: AbstractProduction [ ]
let GetBooleanVal [tree] ← False []
;
Monitored
for Monitored.yes: AbstractProduction [ ]
let GetBooleanVal [tree] ← True []
;
for Monitored.no: AbstractProduction [ ]
let GetBooleanVal [tree] ← False []
;
MachineDependent
for MachineDependent.yes: AbstractProduction [ ]
let GetBooleanVal [tree] ← True []
;
for MachineDependent.no: AbstractProduction [ ]
let GetBooleanVal [tree] ← False []
;
Ordered
for Ordered.yes: AbstractProduction [ ]
let GetBooleanVal [tree] ← True []
;
for Ordered.no: AbstractProduction [ ]
let GetBooleanVal [tree] ← False []
;
Base
for Base.yes: AbstractProduction [ ]
let GetBooleanVal [tree] ← True []
;
for Base.no: AbstractProduction [ ]
let GetBooleanVal [tree] ← False []
;
Safe
for Safe.yes: AbstractProduction [ ]
let GetBooleanVal [tree] ← True []
;
for Safe.no: AbstractProduction [ ]
let GetBooleanVal [tree] ← False []
;
for Safe.empty: AbstractProduction [ ]
let GetBooleanVal [tree] ← False []
;
ignoring safety default till we have flags.
Uncounted
for Uncounted.yes: AbstractProduction [ ]
let GetBooleanVal [tree] ← True []
;
for Uncounted.no: AbstractProduction [ ]
let GetBooleanVal [tree] ← False []
;
ReadOnly
for ReadOnly.yes: AbstractProduction [ ]
let GetBooleanVal [tree] ← True []
;
for ReadOnly.no: AbstractProduction [ ]
let GetBooleanVal [tree] ← False []
;
End;
SaffronMakeFieldList: Module = Begin
RecList
for RecList.empty:  AbstractProduction [ ]
let MakeFieldList [tree, localContext, paintRecords ] ←
< FakeDamageContext[localContext], CreateEmptyFieldList []>
;
for RecList.pairlist:  AbstractProduction [ PairList ]
let MakeFieldList [tree, localContext, paintRecords] ← <localContext1, fieldList>
where <localContext1, fieldList> ←
AddPairsToFieldList [PairList, localContext, newFieldList, paintRecords]
where newFieldList ← CreateEmptyFieldList []
;
for RecList.typelist: AbstractProduction [ TypeList ]
let MakeFieldList [tree, localContext, paintRecords] ← <localContext1, fieldList>
where <localContext1, fieldList> ← AddToFieldList [TypeList, localContext, newFieldList, paintRecords]
where newFieldList ← CreateEmptyFieldList []
;
ParameterList
for ParameterList.empty: AbstractProduction [ ]
let MakeFieldList [tree, localContext, paintRecords ] ←
 <FakeDamageContext[localContext], CreateEmptyFieldList []>
;
for ParameterList.any: AbstractProduction [ ]
let MakeFieldList [tree, localContext, paintRecords] ←
      <FakeDamageContext [localContext], AnyFieldList []>
;
for ParameterList.pairlist: AbstractProduction [ PairList ]
let MakeFieldList [tree, localContext, paintRecords] ← <localContext1, fieldList>
where <localContext1, fieldList> ←
AddPairsToFieldList [PairList, localContext, newFieldList, paintRecords]
where newFieldList ← CreateEmptyFieldList []
;
for ParameterList.typelist: AbstractProduction [ TypeList ]
let MakeFieldList [tree, localContext, paintRecords] ← <localContext1, fieldList>
where <localContext1, fieldList> ← AddToFieldList [TypeList, localContext, newFieldList, paintRecords]
where newFieldList ← CreateEmptyFieldList []
;
VariantList
for VariantList.one: AbstractProduction [ VariantItem ]
let MakeUnionList [tree, localContext, paintRecords] ←
AddVariantsToUnionList [VariantItem, localContext, newUnionList, paintRecords]
where newUnionList ← CreateEmptyUnionList []
let AddVariantsToUnionList [tree, localContext, unionList, paintRecords] ←
AddVariantsToUnionList [VariantItem, localContext, unionList, paintRecords]
let MakeStarTagType [tree, localContext] ← <localContext2, tgn>
where localContext2 ←
AddVariantNamesToEnumTypeTGN [VariantItem, localContext1, tgn]
where <localContext1, tgn> ← CreateEmptyEnumTypeTGN [localContext, False []]
let AddVariantNamesToEnumTypeTGN [tree, localContext, tgn] ←
AddVariantNamesToEnumTypeTGN [VariantItem, localContext, tgn]
;
for VariantList.more: AbstractProduction [ VariantList, VariantItem ]
let MakeUnionList [tree, localContext, paintRecords] ←
AddVariantsToUnionList [VariantItem, localContext1, unionList, paintRecords]
where <localContext1, unionList> ←
AddVariantsToUnionList [VariantList, localContext, newUnionList, paintRecords]
where newUnionList ← CreateEmptyUnionList []
let AddVariantsToUnionList [tree, localContext, unionList, paintRecords] ←
AddVariantsToUnionList [VariantItem, localContext1, unionList1, paintRecords]
where <localContext1, unionList1> ←
AddVariantsToUnionList [VariantList, localContext, unionList, paintRecords]
let MakeStarTagType [tree, localContext] ← <localContext3, tgn>
where localContext3 ←
AddVariantNamesToEnumTypeTGN [VariantItem, localContext2, tgn]
where localContext2 ←
AddVariantNamesToEnumTypeTGN [VariantList, localContext1, tgn]
where <localContext1, tgn> ← CreateEmptyEnumTypeTGN [localContext, False []]
let AddVariantNamesToEnumTypeTGN [tree, localContext, tgn] ←
AddVariantNamesToEnumTypeTGN [VariantItem, localContext1, tgn]
where localContext1 ←
AddVariantNamesToEnumTypeTGN [VariantList, localContext, tgn]
;
VariantItem
for VariantItem: AbstractProduction [ IdList, RecList ]
let AddVariantsToUnionList [tree, localContext, unionList, paintRecords] ← < localContext2, AddNamesToUnionList [IdList, ffl, unionList]>
where <localContext2, ffl> ← FreezeFieldList [localContext1, fieldList]
where <localContext1, fieldList> ← MakeFieldList [RecList, localContext, paintRecords ]
let AddVariantNamesToEnumTypeTGN [tree, localContext, tgn] ←
AddVariantNamesToEnumTypeTGN [IdList, localContext, tgn]
;
IdList
for IdList.one: AbstractProduction [ Id ]
let AddNamesToUnionList [tree, ffl, unionList] ← AppendToUnionList [unionList, Id, ffl]
let AddVariantNamesToEnumTypeTGN [tree, localContext, tgn] ←
AppendElementToEnumTypeTGN [localContext, tgn, Id, NullExpPTree[]]
let AddIdsToInterfaceTGN [tree, localContext, interfaceTGN, interface] ←
AddTGNToInterfaceTGN [localContext1, interfaceTGN, Id, accessVal, linkTgn]
where <localContext1, linkTgn> ← CreateLinkTGN [localContext, entryTgn, interface, Id]
entryTgn is NIL if the Id is for an entry point rather than a type.
Until we know about entry points we can't handle this correctly
where <accessVal, entryTgn> ← LookupInterfaceEntry [interface, Id]
;
for IdList.more: AbstractProduction [ Id, IdList ]
let AddNamesToUnionList [tree, ffl, unionList] ←
AddNamesToUnionList [IdList, ffl, unionList1]
where unionList1 ← AppendToUnionList [unionList, Id, ffl]
let AddVariantNamesToEnumTypeTGN [tree, localContext, tgn] ←
AddVariantNamesToEnumTypeTGN [IdList, localContext1, tgn]
where localContext1 ← AppendElementToEnumTypeTGN [localContext, tgn, Id, NullExpPTree[]]
let AddIdsToInterfaceTGN [tree, localContext, interfaceTGN, interface] ←
  AddIdsToInterfaceTGN [IdList, localContext2, interfaceTGN, interface]
where localContext2 ←
AddTGNToInterfaceTGN [localContext1, interfaceTGN, Id, accessVal, linkTgn]
where <localContext1, linkTgn> ← CreateLinkTGN [localContext, entryTgn, interface, Id]
where <accessVal, entryTgn> ← LookupInterfaceEntry [interface, Id]
verify that entryTgn is as intended
;
Tag
for Tag.ident: AbstractProduction [ Ident, Access, TagType ]
let MakeVariantFlavor [tree] ←
VanillaVariantFlavorVal [GetIdentInfo [Ident], GetAccessVal [Access]]
let MakeTagType [tree, localContext, paintRecords] ←
MakeTagType [TagType, localContext, paintRecords]
let GetSequenceTagInfo [tree] ← <GetIdentInfo [Ident], GetAccessVal [Access]>
;
for Tag.computed: AbstractProduction [ TagType ]
let MakeVariantFlavor [tree] ← ComputedVariantFlavorConst []
let MakeTagType [tree, localContext, paintRecords] ←
MakeTagType [TagType, localContext, paintRecords]
let GetSequenceTagInfo [tree] ← <NullId [], NullPosition [], AccessValConst ["empty"]>
;
for Tag.overlaid: AbstractProduction [ TagType ]
let MakeVariantFlavor [tree] ← OverlaidVariantFlavorConst []
let MakeTagType [tree, localContext, paintRecords] ←
MakeTagType [TagType, localContext, paintRecords]
let GetSequenceTagInfo [tree] ← <NullId [], NullPosition [], AccessValConst ["empty"]>
where x ← Error ["Sequences can't be overlaid"]
;
TagType
for TagType.star: AbstractProduction [ ]
let MakeTagType [tree, localContext, paintRecords] ←
<localContext1, FindBottomTGN [localContext1], True []>
where localContext1 ← FakeDamageContext [localContext]
;
for TagType.typeexp: AbstractProduction [ TypeExp ]
let MakeTagType [tree, localContext, paintRecords] ←
<MakeType [TypeExp, localContext, paintRecords], False []>
;
End;
SaffronAddToFieldList: Module = Begin
TypeList
for TypeList.many: AbstractProduction [ TypeList.head, TypeList.tail ]
let AddToFieldList [tree, localContext, fieldList, paintRecords] ←
AddToFieldList [ TypeList.tail, localContext1, fieldList1, paintRecords]
where <localContext1, fieldList1> ←
AddToFieldList [ TypeList.head, localContext, fieldList, paintRecords]
;
for TypeList.one: AbstractProduction [ TypeItem ]
let AddToFieldList [tree, localContext, fieldList, paintRecords] ←
AddToFieldList [ TypeItem, localContext, fieldList, paintRecords]
;
TypeItem
for TypeItem: AbstractProduction [ TypeExp, Default ]
let AddToFieldList [tree, localContext, fieldList, paintRecords] ← <localContext1, fieldList1>
where fieldList1 ← AppendFieldToFieldList [ fieldList, field]
where field ← CreateUnnamedField [tgn, defaultExp]
where <localContext1, tgn> ← MakeType [TypeExp, localContext, paintRecords]
where defaultExp ← GetDefaultExpVal [Default]
End;
SaffronAddPairsToFieldList: Module = Begin
PairList
for PairList.many: AbstractProduction [ PairList.head, PairList.tail ]
let AddPairsToFieldList [tree, localContext, fieldList, paintRecords] ←
AddPairsToFieldList [ PairList.tail, localContext1, fieldList1, paintRecords]
where <localContext1, fieldList1> ←
AddPairsToFieldList [PairList.head, localContext, fieldList, paintRecords]
;
for PairList.one: AbstractProduction [ PairItem ]
let AddPairsToFieldList [tree, localContext, fieldList, paintRecords] ←
AddPairsToFieldList [PairItem, localContext, fieldList, paintRecords]
;
PairItem
for PairItem: AbstractProduction [ IdentList, Access, TypeExp, Default ]
let AddPairsToFieldList [tree, localContext, fieldList, paintRecords] ←
< localContext1, AddNamesToFieldList [IdentList, accessVal, tgn, defaultExp, fieldList] >
where <localContext1, tgn> ← MakeType [TypeExp, localContext, paintRecords]
where accessVal ← GetAccessVal [Access]
where defaultExp ← GetDefaultExpVal [Default]
;
Access
for Access.empty:  AbstractProduction [ ]
let GetAccessVal [tree] ← AccessValConst ["empty"]
;
for Access.public:  AbstractProduction [ ]
let GetAccessVal [tree] ← AccessValConst ["public"]
;
for Access.private: AbstractProduction [ ]
let GetAccessVal [tree] ← AccessValConst ["private"]
;
End;
SaffronAddNamesToFieldList: Module = Begin
IdentList
for IdentList.many: AbstractProduction [ IdentList.head, IdentList.tail ]
let AddNamesToFieldList [tree, accessVal, tgn, defaultExp, fieldList] ←
AddNamesToFieldList [IdentList.tail, accessVal, tgn, defaultExp, fieldList1]
where fieldList1 ← AddNamesToFieldList [IdentList.head, accessVal, tgn, defaultExp, fieldList]
let PutNewNamesInLocalContext1[tree, localContext, accessVal]←
PutNewNamesInLocalContext1[IdentList.tail, localContext1, accessVal]
where localContext1 ←
PutNewNamesInLocalContext1[IdentList.head, localContext, accessVal]
let RecAddArcsfromLVTGNtoTGN[tree, localContext, accessVal, tgn, defaultExp]←
RecAddArcsfromLVTGNtoTGN[IdentList.tail, localContext1, accessVal, tgn, defaultExp]
where localContext1 ← RecAddArcsfromLVTGNtoTGN[IdentList.head, localContext, accessVal, tgn, defaultExp]
let MakeNameSequence [tree] ← AddNamesToSequence [IdentList.head, nameSequence1]
where nameSequence1 ← AddNamesToSequence [IdentList.tail, nameSequence]
where nameSequence ← EmptyNameSequence []
let AddNamesToSequence [tree, nameSequence] ←
  AddNamesToSequence [IdentList.head, nameSequence1]
where nameSequence1 ← AddNamesToSequence [IdentList.tail, nameSequence]
;
for IdentList.one: AbstractProduction [ Ident ]
let AddNamesToFieldList [tree, accessVal, tgn, defaultExp, fieldList] ←
AddNamesToFieldList [Ident, accessVal, tgn, defaultExp, fieldList]
let PutNewNamesInLocalContext1[tree, localContext, accessVal] ←
PutNewNamesInLocalContext1[Ident, localContext, accessVal]
let RecAddArcsfromLVTGNtoTGN[tree, localContext, accessVal, tgn, defaultExp] ←
RecAddArcsfromLVTGNtoTGN[Ident, localContext, accessVal, tgn, defaultExp]
let MakeNameSequence [tree] ← AddNamesToSequence [Ident, nameSequence]
where nameSequence ← EmptyNameSequence []
let AddNamesToSequence [tree, nameSequence] ←
  AddNamesToSequence [Ident, nameSequence]
;
Ident
for Ident.id: AbstractProduction [ Id ]
let AddNamesToFieldList [tree, accessVal, tgn, defaultExp, fieldList] ←
AppendFieldToFieldList [fieldList, field]
where field ← CreateNamedField [Id, NullPosition [], accessVal, tgn, defaultExp]
let PutNewNamesInLocalContext1[tree, localContext, accessVal] ← localContext1
where <localContext1, tgn> ← CreateLocallyVisibleTGN [localContext, Id, accessVal ]
let RecAddArcsfromLVTGNtoTGN[tree, localContext, accessVal, tgn, defaultExp] ←
AddArcFromLVTGNToTGN [localContext, lvtgn, accessVal, tgn, defaultExp]
where lvtgn ← FindLocallyVisibleTGN [localContext, Id]
let GetIdentInfo [tree] ← <Id, NullPosition []>
let AddNamesToSequence [tree, nameSequence] ←
  InsertNameOnNameSequence [Id, nameSequence]
;
for Ident.idposition: AbstractProduction [ Id, Position ]
let AddNamesToFieldList [tree, accessVal, tgn, defaultExp, fieldList] ←
AppendFieldToFieldList [fieldList, field]
where field ← CreateNamedField [Id, GetPositionVal [Position], accessVal, tgn, defaultExp]
let PutNewNamesInLocalContext1[tree, localContext, accessVal] ← localContext1
where <localContext1, tgn> ← CreateLocallyVisibleTGN [localContext, Id, accessVal ]
let RecAddArcsfromLVTGNtoTGN[tree, localContext, accessVal, tgn, defaultExp] ←
AddArcFromLVTGNToTGN [localContext, lvtgn, accessVal, tgn, defaultExp]
where lvtgn ← FindLocallyVisibleTGN [localContext, Id]
let GetIdentInfo [tree] ← <Id, GetPositionVal [Position]>
let AddNamesToSequence [tree, nameSequence] ←
  InsertNameOnNameSequence [Id, nameSequence]
where x ← Error ["Is Position field valid in a ModuleName list"]
;
Position
for Position: AbstractProduction [ Exp, OptBits ]
let GetPositionVal [tree] ← PositionValFun [ExpPTreeVal [Exp], boundsVal]
where boundsVal ← GetBoundsVal [OptBits]
;
OptBits
for OptBits.absent: AbstractProduction [ ]
let GetBoundsVal [tree] ← NullBounds []
;
for OptBits.present: AbstractProduction [ Bounds ]
let GetBoundsVal [tree] ← BoundsValFun ["[", GetLowerAndUpper [Bounds], "]"]
;
End;
SaffronMakeElementList: Module = Begin
ElementList
for ElementList.empty: AbstractProduction [ ]
let MakeElementList [tree, localContext, machineDependent] ← CreateEmptyEnumTypeTGN [localContext, machineDependent]
;
for ElementList.more: AbstractProduction [ ElementList, Element ]
let MakeElementList [tree, localContext, machineDependent] ← <localContext1, tgn>
where localContext1 ←
AppendElementToEnumTypeTGN [localContext2, tgn, elementName, rep]
where <localContext2, tgn> ← MakeElementList [ElementList, localContext, machineDependent]
where <elementName, rep> ← ElementInfo [Element]
End;
SaffronElementName: Module = Begin
Element
for Element.id: AbstractProduction [ Id ]
let ElementInfo [tree] ← <Id, NullExpPTree[]>
;
for Element.idwithrep: AbstractProduction [ Id, Exp ]
let ElementInfo [tree] ← <Id, ExpPTreeVal [Exp]>
;
for Element.anonymousrep: AbstractProduction [ Exp ]
let ElementInfo [tree] ← <NullId [], ExpPTreeVal [Exp]>
;
Exp
for Exp.id: AbstractProduction [ Id ]
let IdVal [tree] ← Id
;
for Exp.sum: AbstractProduction [ Exp.left, AddOp, Exp.right ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.unarysum: AbstractProduction [ AddOp, Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.product: AbstractProduction [ Exp.left, MultOp, Exp.right ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.or: AbstractProduction [ Exp.left, Exp.right ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.and: AbstractProduction [ Exp.left, Exp.right ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.not: AbstractProduction [ Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.relation: AbstractProduction [ Exp, Relation ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.ifthenelse: AbstractProduction [ Exp.cond, Exp.thenpart, Exp.elsepart ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.select: AbstractProduction [ SelectHead, SelectExpList, Exp.default ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.assign: AbstractProduction [ Exp.lhs, Exp.rhs ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.multiassign: AbstractProduction [ ExpList, Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.num: AbstractProduction [ Num ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.string: AbstractProduction [ String ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.flnum: AbstractProduction [ Flnum ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.char: AbstractProduction [ Char ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.atom: AbstractProduction [ Atom ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.narrow: AbstractProduction [ Exp, OptType, Catch ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.loophole: AbstractProduction [ Exp, OptType ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.apply: AbstractProduction [ Exp.rator, Exp.rand, Catch ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.qualifier: AbstractProduction [ Exp, Qualifier ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.explist: AbstractProduction [ ExpList ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.prefixop: AbstractProduction [ PrefixOp, OrderList ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.val: AbstractProduction [ OrderList ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.all: AbstractProduction [ OrderList ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.new: AbstractProduction [ New, TypeExp, Initialization, Catch ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.cons: AbstractProduction [ Cons, ExpList, Catch ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.listcons: AbstractProduction [ ListCons, ExpList ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.nil: AbstractProduction [ ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.typeop: AbstractProduction [ TypeOp, TypeExp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.size: AbstractProduction [ TypeExp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.size2: AbstractProduction [ TypeExp, Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.bits: AbstractProduction [ TypeExp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.bits2: AbstractProduction [ TypeExp, Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.bytes: AbstractProduction [ TypeExp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.bytes2: AbstractProduction [ TypeExp, Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.units: AbstractProduction [ TypeExp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.units2: AbstractProduction [ TypeExp, Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.words: AbstractProduction [ TypeExp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.words2: AbstractProduction [ TypeExp, Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.istype: AbstractProduction [ Exp, TypeExp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.address: AbstractProduction [ Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.descriptor: AbstractProduction [ DescList ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.error: AbstractProduction [ ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
for Exp.transfer: AbstractProduction [ TransferOp, Exp ]
let IdVal [tree] ← NullId [] where x ← Error ["Expected an Id"];
End;
SaffronScope: Module = Begin
Scope
Look carefully at this. The syntax does not match the nesting semantics.
for Scope: AbstractProduction [ BindList, Catch, OptDecList, StatementList ]
let MakeContextTree [tree, rib, paintRecords] ←
Make the contextTree for the entire scope, nesting everything else inside the bindlist's context.
MakeBindListContextTreeWithScope [BindList, scopePTree, rib, paintRecords]
where scopePTree ← ScopePTreeVal [tree]
let MakeContextTree1 [tree, rib, paintRecords] ←
Make the contextTree for the context nested within the BindList.
HangContextsFromContextTree [StatementList, decListContextTree, newRib, paintRecords]
where decListContextTree ← HangContextsFromContextTree [OptDecList, thisScopeContextTree, newRib, paintRecords]
where thisScopeContextTree ← EmptyContextTree [newRib]
(process statements here? this will probably require a nested context for newly constructed types, but they can never be circular)
where newRib ← FreezeLocalContext [thisScopeLocalContext]
(note: Freeze will "process" the type graph, looking for cycles etc.)
where thisScopeLocalContext ← UpdateLocalContext [OptDecList, localContext, paintRecords ]
where localContext ← CreateEmptyContext [rib]
;
ignoring Catch in Scope
BindList
for BindList.empty: AbstractProduction [ ]
let MakeBindListContextTreeWithDefBody [tree, defBodyPTree, rib, paintRecords] ←
MakeContextTree1 [defBody, rib, paintRecords]
where defBody ← DefBodyVal [defBodyPTree]
avoids making an unnecessary context tree node
let MakeBindListContextTreeWithScope [tree, scopePTree, rib, paintRecords] ←
MakeContextTree1 [scope, rib, paintRecords]
where scope ← ScopeVal [scopePTree]
avoids making an unnecessary context tree node
let UpdateLocalContext [tree, localContext, paintRecords] ←
FakeDamageContext [localContext]
;
for BindList.more: AbstractProduction [ BindList, BindItem ]
Semantically the scope creates a subcontext (contextTree2) of the Bindlist.
Rib2 is the rib corresponding to the context of Bindlist.
let MakeBindListContextTreeWithDefBody [tree, defBodyPTree, rib, paintRecords] ←
 AddSubContextTree [EmptyContextTree [rib2], contextTree2]
where contextTree2 ← MakeContextTree1[defBody, rib2, paintRecords]
where defBody ← DefBodyVal [defBodyPTree]
where rib2 ← FreezeLocalContext [bindListsLocalContext]
where bindListsLocalContext ← UpdateLocalContext [tree, localContext, paintRecords]
where localContext ← CreateEmptyContext [rib]
let MakeBindListContextTreeWithScope [tree, scopePTree, rib, paintRecords] ←
 AddSubContextTree [EmptyContextTree [rib2], contextTree2]
where contextTree2 ← MakeContextTree1[scope, rib2, paintRecords]
where scope ← ScopeVal [scopePTree]
where rib2 ← FreezeLocalContext [bindListsLocalContext]
where bindListsLocalContext ← UpdateLocalContext [tree, localContext, paintRecords]
where localContext ← CreateEmptyContext [rib]
let UpdateLocalContext [tree, localContext, paintRecords] ←
UpdateLocalContext [BindItem, localContext1, paintRecords]
where localContext1 ← UpdateLocalContext [BindList, localContext, paintRecords]
;
BindItem
for BindItem.named: AbstractProduction [ Id, Exp ]
let UpdateLocalContext [tree, localContext, paintRecords] ←
RenameInterface [localContext, Id, interfaceTgn]
where interfaceTgn ← FindLocallyVisibleTGN [localContext, IdVal [Exp]]
;
for BindItem.unnamed: AbstractProduction [ Exp ]
let UpdateLocalContext [tree, localContext, paintRecords] ←
OpenInterface [localContext, interfaceTgn]
where interfaceTgn ← FindLocallyVisibleTGN [localContext, IdVal [Exp]]
;
OptDecList
for OptDecList.absent: AbstractProduction [ ]
let UpdateLocalContext [tree, localContext, paintRecords] ←
FakeDamageContext [localContext]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree];
for OptDecList.present: AbstractProduction [ DecList ]
let UpdateLocalContext [tree, localContext, paintRecords] ←
FillInLocalContext [DecList, localContext1, paintRecords]
where localContext1 ← PutNewNamesInLocalContext [DecList, localContext]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
HangContextsFromContextTree [DecList, contextTree, rib, paintRecords]
;
DecList
for DecList.many: AbstractProduction [ DecList.head, DecList.tail ]
let UpdateLocalContext [tree, localContext, paintRecords] ←
FillInLocalContext [tree, localContext1, paintRecords]
where localContext1 ← PutNewNamesInLocalContext [tree, localContext]
let PutNewNamesInLocalContext [tree, localContext] ←
PutNewNamesInLocalContext [DecList.tail, localContext1]
where localContext1 ← PutNewNamesInLocalContext [DecList.head, localContext]
let FillInLocalContext [tree, localContext, paintRecords] ←
FillInLocalContext [DecList.tail, localContext1, paintRecords]
where localContext1 ← FillInLocalContext [DecList.head, localContext, paintRecords]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
HangContextsFromContextTree [DecList.tail, contextTree1, rib, paintRecords]
where contextTree1 ← HangContextsFromContextTree [DecList.head, contextTree, rib, paintRecords]
;
for DecList.one: AbstractProduction [ Declaration ]
let UpdateLocalContext [tree, localContext, paintRecords] ←
FillInLocalContext [tree, localContext1, paintRecords]
where localContext1 ← PutNewNamesInLocalContext [tree, localContext]
let PutNewNamesInLocalContext[tree, localContext] ←
PutNewNamesInLocalContext[Declaration, localContext]
let FillInLocalContext[tree, localContext, paintRecords] ←
FillInLocalContext[Declaration, localContext, paintRecords]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
HangContextsFromContextTree [Declaration, contextTree, rib, paintRecords]
;
Declaration
for Declaration.opaquetype: AbstractProduction [ IdentList, Access, OptSize ]
let PutNewNamesInLocalContext[tree, localContext] ←
PutNewNamesInLocalContext1[IdentList, localContext, GetAccessVal[Access]]
let FillInLocalContext[tree, localContext, paintRecords] ←
RecAddArcsfromLVTGNtoTGN [IdentList, localContext2, NullAccessVal [], tgn, NullDefaultVal []]
where <localContext2, tgn> ← CreateOpaqueTGN [localContext1, paint, sizeExp]
where <localContext1, paint> ← GetUniquePaint [localContext]
where sizeExp ← GetExpVal [OptSize]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
ignoring optsize
for Declaration.type: AbstractProduction [ IdentList, Access.id, Access.type, TypeExp, Default ]
let PutNewNamesInLocalContext[tree, localContext] ←
PutNewNamesInLocalContext1[IdentList, localContext, GetAccessVal[Access.id]]
let FillInLocalContext[tree, localContext, paintRecords] ←
RecAddArcsfromLVTGNtoTGN [IdentList, localContext1, GetAccessVal[Access.type], tgn, defaultExp]
where <localContext1, tgn> ← MakeType [TypeExp, localContext, paintRecords]
where defaultExp ← GetDefaultExpVal [Default]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Declaration.value: AbstractProduction [ IdentList, Access, Entry, ReadOnly, TypeExp, Initialization ]
let PutNewNamesInLocalContext[tree, localContext] ← FakeDamageContext [localContext]
let FillInLocalContext[tree, localContext, paintRecords] ←
FakeDamageContext [localContext]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
ignoring value declarations
OptSize
for OptSize.absent: AbstractProduction [ ]
let GetExpVal [tree] ← NullExpPTree []
;
for OptSize.present: AbstractProduction [ Exp ]
let GetExpVal [tree] ← ExpPTreeVal [Exp]
;
StatementList
for StatementList.empty: AbstractProduction [ ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for StatementList.more: AbstractProduction [ StatementList, Statement ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
HangContextsFromContextTree [Statement, contextTree1, rib, paintRecords]
where contextTree1 ←
HangContextsFromContextTree [StatementList, contextTree, rib, paintRecords]
;
Statement
for Statement.ifthen: AbstractProduction [ Exp, Statement ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
HangContextsFromContextTree [Statement, contextTree, rib, paintRecords]
;
can exp change context tree ?
for Statement.ifthenelse: AbstractProduction [ Exp, Statement.thenpart, Statement.elsepart ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
HangContextsFromContextTree [Statement.elsepart, contextTree1, rib, paintRecords]
where contextTree1 ←
HangContextsFromContextTree [Statement.thenpart, contextTree, rib, paintRecords]
;
for Statement.select: AbstractProduction [ SelectHead, SelectStmtList, OptStatement ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.exp: AbstractProduction [ Exp ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
can exp change context tree ?
for Statement.assign: AbstractProduction [ Exp.lhs, Exp.rhs ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.multiassign: AbstractProduction [ ExpList, Exp ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.block: AbstractProduction [ Checked, Block ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
HangContextsFromContextTree [Block, contextTree, rib, paintRecords]
;
ignoring Checked on a block statement
for Statement.loopcontrol: AbstractProduction [ ForClause, DoTest, Scope, DoExit ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.exit: AbstractProduction [ ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.loop: AbstractProduction [ ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.goto: AbstractProduction [ Id ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.return: AbstractProduction [ OptArgs ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.transfer: AbstractProduction [ Transfer, Exp ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.free: AbstractProduction [ Free, Exp, Catch ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.wait: AbstractProduction [ Exp ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.error: AbstractProduction [ ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.stop: AbstractProduction [ ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.null: AbstractProduction [ ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.resume: AbstractProduction [ OptArgs ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.reject: AbstractProduction [ ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.continue: AbstractProduction [ ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.retry: AbstractProduction [ ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.getstate: AbstractProduction [ Exp ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
for Statement.setstate: AbstractProduction [ Exp ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
FakeDamageContextTree [contextTree]
;
Block
for Block: AbstractProduction [ Scope, ExitList ]
let HangContextsFromContextTree [tree, contextTree, rib, paintRecords] ←
AddSubContextTree[contextTree, subContextTree]
where subContextTree ← MakeContextTree [Scope, rib, paintRecords]
;
ignoring ExitList
End.
eof...