<> <> <> <> <> <> <> <<>> Include [SaffronAG, SaffronTreeDecls, SaffronBaseDecls, SaffronProgramGraphDecls]; <<>> <> SaffronMakeType1: Module = Begin <> for Top.modulep: AbstractProduction [ ModuleP ] let DoTop[tree, fileName, env, cs] _ MakeEnvironment [ModuleP, fileName, env, cs] ; <> for ModuleP.impl: AbstractProduction [ Directory, IdentList, Cedar, ProgHead, Checked, Block ] let MakeEnvironment [tree, fileName, env, cs] _ env2 where env2 _ AddCompiledImplementationFileToEnvironment [env1, fileName, contextTree, pg2] where pg2 _ AddMainProcedureGraphToProgramGraph[procGraph, pg1] where procGraph _ MakeProcedureGraph[programFragment] where _ Compile[Block, EmptyContextTree[contextRib], pg, cs] where pg _ CreateEmptyProgramGraph[] where contextRib _ FreezeLocalContext[lc4, moduleTGN] where _ CreateModuleTGN[lc3, ffl] where ffl _ FreezeFieldList[fl2] where _ AddTypeDeclarationToFieldList[IdentList, fl1, lc2, cs, access, access, implTGN, BogusTypeExpPTree[], NullDefaultVal[]] where access _ GetAccessVal[ProgHead, AccessValConst["private"]] where _ BuildImplementationTGN[ProgHead, lc1, cedar, cs] where cedar _ IsKeywordPresent[Cedar] where _ ProcessDirectoryClause [Directory, fl, lc, env, cs] where fl _ CreateEmptyFieldList[] where lc _ CreateEmptyContext [GetRootContextRib[cs], True[]] ; for ModuleP.def: AbstractProduction [ Directory, IdentList, Cedar, DefHead, DefBody ] let MakeEnvironment [tree, fileName, env, cs] _ env2 where env2 _ AddCompiledDefinitionsFileToEnvironment [env1, fileName, contextTree] where contextTree _ AddSubContextTree[EmptyContextTree[contextRib], childContextTree] where childContextTree _ MakeContextTree [DefBody, contextRib, True[], cs] where contextRib _ FreezeLocalContext[lc4, moduleTGN] where _ CreateModuleTGN[lc3, ffl] where ffl _ FreezeFieldList[fl2] where _ AddTypeDeclarationToFieldList[IdentList, fl1, lc2, cs, access, access, interfaceTGN, BogusTypeExpPTree[], NullDefaultVal[]] where access _ GetAccessVal[DefHead, AccessValConst["public"]] where _ BuildInterfaceTGN[DefHead, lc1, cedar, cs] where cedar _ IsKeywordPresent[Cedar] where _ ProcessDirectoryClause [Directory, fl, lc, env, cs] where fl _ CreateEmptyFieldList[] where lc _ CreateEmptyContext [GetRootContextRib[cs], True[]] ; <> for Directory.empty: AbstractProduction [ ] let ProcessDirectoryClause [tree, fl, localContext, env, cs] _ < FakeDamageFieldList [fl], FakeDamageContext [localContext], FakeDamageEnvironment [env] > ; for Directory.more: AbstractProduction [ Directory, IncludeItem ] let ProcessDirectoryClause [tree, fl, localContext, env, cs] _ where fl2 _ AppendFieldToFieldList[fl1, field] where _ ProcessDirectoryItem[IncludeItem, lc1, env1, cs] where _ ProcessDirectoryClause[Directory, fl, localContext, env, cs] ; <> for IncludeItem: AbstractProduction [Id.local, IdOrString, Id.moduleName, Using] let ProcessDirectoryItem[tree, lc, env, cs] _ where field _ CreateNamedTypeField[Id.local, position, access, tgn1, parseTree] where parseTree _ BogusTypeExpPTree[] where tgn1 _ RestrictNamedTGN[Using, tgn] where _ CreateNamedTGN[lc, Id.local, position, access, interface, default] where position _ NullPosition[] where access _ AccessValConst["public"] where interface _ LookupInterfaceInEnv[env1, fileName, Id.moduleName] where default _ NullDefaultVal[] where env1 _ if IsCompiledFileInEnv[env, fileName] then FakeDamageEnvironment[env] else ( MakeEnvironment [defFile, fileName, env, cs] where defFile _ ModulePVal [ReadDefFile [fileName]] ) where fileName _ RopeFromIdOrString[IdOrString] ; <> for Using.restricted: AbstractProduction [ IdList ] let RestrictNamedTGN [tree, namedTGN] _ AddIdsToRestrictionList [IdList, namedTGN] ; for Using.nothing: AbstractProduction [ ] let RestrictNamedTGN [tree, namedTGN] _ FakeDamageTypeGraphNode [namedTGN] ; for Using.unrestricted: AbstractProduction [ ] let RestrictNamedTGN [tree, namedTGN] _ AddAllIdsToRestrictionList [namedTGN] ; <> for DefHead: AbstractProduction [Locks, ModuleList, Shares, Access] let BuildInterfaceTGN[tree, lc, cedar, cs] _ CreateInterfaceTGN[lc, cedar, locks, imports, shares] where locks _ "I should be a locks foobar" where imports _ "I should be an imports list" where shares _ "I should be a shares list" ; <> for ProgHead: AbstractProduction [Safe, Class, Arguments, Locks, Interface, Access] let BuildImplementationTGN[tree, lc, cedar, cs] _ CreateImplementationTGN[lc2, cedar, transferType, locks, imports, exports, shares] where _ CreateTransferTGN[lc1, safe, "program", input, output] where safe _ IsKeywordPresent[Safe] where _ MakeArgumentLists[Arguments, lc, paintRecords, cs] where paintRecords _ True[] -- crock!! where locks _ "I should be a locks foobar" where imports _ "I should be an imports list" where exports _ "I should be an exports list" where shares _ "I should be a shares list" ; <> <> <> <> <> <> <> <> << HangContextsFromContextTree [DecList, thisScopeContextTree, newRib, paintRecords, cs]>> <> <> <<(note: Freeze will "process" the type graph, looking for cycles etc.)>> <> <> <<;>> End; SaffronMakeType2: Module = Begin <> for TypeExp.record: AbstractProduction [ MachineDependent, Monitored, RecList ] let MakeType[tree, localContext, paintRecords, cs] _ where _ CreateRecordTGN [ localContext2, paint, machineDependent, monitored, frozenFieldList] where frozenFieldList _ FreezeFieldList [fieldList] where _ MakeFieldList [RecList, localContext1, paintRecords, cs] where _ if paintRecords then GetUniquePaint [localContext] else GetUnpaintedPaint [localContext] where machineDependent _ IsKeywordPresent [MachineDependent] where monitored _ IsKeywordPresent [Monitored] ; for TypeExp.union: AbstractProduction [ Tag, VariantList ] let MakeType[tree, localContext, paintRecords, cs] _ CreateVariantPartTGN [localContext3, variantFlavor, tagTypeTgn1, unionList] where variantFlavor _ MakeVariantFlavor [Tag, cs] where _ if isStarTagType <> then MakeStarTagType [VariantList, localContext2] else where _ MakeTagType [Tag, localContext1, paintRecords, cs] where _ MakeUnionList [VariantList, localContext, paintRecords, cs] ; for TypeExp.sequence: AbstractProduction [ Packed, Tag, TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateSequenceTGN [localContext2, packed, GetSequenceTagInfo [Tag, cs], tagTypeTgn, tgn] where packed _ IsKeywordPresent [Packed] where x _ if isStarTagType then Error ["Sequence Tag must not be a star"] else True[] where _ MakeTagType [Tag, localContext1, paintRecords, cs] where _ MakeType [TypeExp, localContext, paintRecords, cs] ; for TypeExp.enum: AbstractProduction [ MachineDependent, ElementList ] let MakeType[tree, localContext, paintRecords, cs] _ MakeElementList [ElementList, localContext, machineDependent] where machineDependent _ IsKeywordPresent [MachineDependent] ; for TypeExp.ref: AbstractProduction [ ReadOnly, TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateRefTGN [localContext1, readOnly, referentTgn] where _ MakeType[TypeExp, localContext, paintRecords, cs] where readOnly _ IsKeywordPresent [ReadOnly] ; for TypeExp.refany: AbstractProduction [ ReadOnly ] let MakeType[tree, localContext, paintRecords, cs] _ CreateRefTGN [localContext1, readOnly, topTgn] where topTgn _ GetTop [cs] where localContext1 _ FakeDamageContext [localContext] where readOnly _ IsKeywordPresent [ReadOnly] ; for TypeExp.refunspecified: AbstractProduction [ ] let MakeType[tree, localContext, paintRecords, cs] _ CreateRefTGN [localContext1, readOnly, topTgn] where topTgn _ GetTop [cs] where localContext1 _ FakeDamageContext [localContext] where readOnly _ False [] ; for TypeExp.typeid: AbstractProduction [ TypeId ] let MakeType[tree, localContext, paintRecords, cs] _ MakeType [TypeId, localContext, paintRecords, cs] ; for TypeExp.subrange: AbstractProduction [ Subrange ] let MakeType[tree, localContext, paintRecords, cs] _ MakeType[Subrange, localContext, paintRecords, cs] ; for TypeExp.pointer: AbstractProduction [ Ordered, Base, PointerType ] let MakeType[tree, localContext, paintRecords, cs] _ CreatePointerTGN [localContext1, ordered, base, bounds, readOnly, tgn] where ordered _ IsKeywordPresent [Ordered] where base _ IsKeywordPresent [Base] where _ GetPointerTypeInfo [PointerType, localContext, paintRecords, cs] ; for TypeExp.var: AbstractProduction [ TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateVarTGN [localContext1, tgn] where _ MakeType [TypeExp, localContext, paintRecords, cs] ; for TypeExp.list: AbstractProduction [ ReadOnly, TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateListTGN [localContext1, readOnly, itemTgn] where _ MakeType [TypeExp, localContext, paintRecords, cs] where readOnly _ IsKeywordPresent [ReadOnly] ; for TypeExp.array: AbstractProduction [ Packed, OptType, TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateArrayTGN [localContext2, packed, indexTgn, itemTgn] where _ MakeType [TypeExp, localContext1, paintRecords, cs] where _ MakeType [OptType, localContext, paintRecords, cs] where packed _ IsKeywordPresent [Packed] ; for TypeExp.descriptor: AbstractProduction [ ReadOnly, TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateDescriptorTGN [localContext1, readOnly, tgn] where _ MakeType [TypeExp, localContext, paintRecords, cs] where readOnly _ IsKeywordPresent [ReadOnly] ; for TypeExp.transfer: AbstractProduction [ Safe, TransferMode, Arguments ] let MakeType[tree, localContext, paintRecords, cs] _ CreateTransferTGN [localContext1, safe, transferMode, fflInput, fflOutput] where _ MakeArgumentLists [Arguments, localContext, paintRecords, cs] where transferMode _ MakeTransferMode [TransferMode] where safe _ IsKeywordPresent [Safe] ; for TypeExp.relative: AbstractProduction [ TypeId, TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateRelativeTGN [localContext2, baseTgn, tgn] where _ MakeType [TypeExp, localContext1, paintRecords, cs] where _ LookupTypeId [TypeId, localContext] ; for TypeExp.zone: AbstractProduction [ Uncounted ] let MakeType[tree, localContext, paintRecords, cs] _ CreateZoneTGN [localContext, IsKeywordPresent [Uncounted]] ; for TypeExp.long: AbstractProduction [ TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateLongTGN [localContext1, tgn] where _ MakeType [TypeExp, localContext, paintRecords, cs] ; for TypeExp.frame: AbstractProduction [ Id ] let MakeType[tree, localContext, paintRecords, cs] _ where localContext1 _ FakeDamageContext [localContext] ; for TypeExp.painted: AbstractProduction [ TypeId, TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ where n _ GetBottom[cs] where c _ FakeDamageContext [localContext] where x _ Error [" Unimplemented Construct"] ; for TypeExp.typeapply: AbstractProduction [ TypeApply ] let MakeType[tree, localContext, paintRecords, cs] _ MakeType [TypeApply, localContext, paintRecords, cs] ; <> for TypeApply.one: AbstractProduction [ TypeId, Exp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateSpecianatedTGNUsingExp [localContext1, tgn, MakeUnparsedValue[Exp]] where _ LookupTypeId [TypeId, localContext] ; for TypeApply.morelengths: AbstractProduction [ TypeApply, Exp ] let MakeType[tree, localContext, paintRecords, cs] _ CreateSpecianatedTGNUsingExp [localContext1, tgn, MakeUnparsedValue[Exp]] where _ MakeType [TypeApply, localContext, paintRecords, cs] ; for TypeApply.moreids: AbstractProduction [ TypeApply, Id ] let MakeType[tree, localContext, paintRecords, cs] _ CreateSpecianatedTGNUsingId [localContext1, tgn, Id] where _ MakeType [TypeApply, localContext, paintRecords, cs] ; <> for TypeId.id: AbstractProduction [ Id ] let MakeType[tree, localContext, paintRecords, cs] _ CreateIdentifierTGN[localContext, Id] let LookupTypeId[tree, localContext] _ CreateIdentifierTGN[localContext, Id] < where localContext1 _ FakeDamageContext [localContext] where tgn _ LookupTypeName [ localContext, Id ]>> < where localContext1 _ FakeDamageContext [localContext] where tgn _ LookupTypeName [ localContext, Id ]>> ; for TypeId.qualifier: AbstractProduction [ TypeId, Id ] let MakeType[tree, localContext, paintRecords, cs] _ LookupTypeId [tree, localContext] let LookupTypeId[tree, localContext] _ CreateSpecianatedTGNUsingId [localContext1, tgn, Id] where _ LookupTypeId [TypeId, localContext] <> <> <> < _ LookupTypeId [TypeId, localContext]>> ; <> for OptType.absent: AbstractProduction [ ] let MakeType[tree, localContext, paintRecords, cs] _ where localContext1 _ FakeDamageContext [localContext] where tgn _ GetBottom [cs] ; for OptType.present: AbstractProduction [ TypeExp ] let MakeType[tree, localContext, paintRecords, cs] _ MakeType[TypeExp, localContext, paintRecords, cs] ; <> for Subrange.named: AbstractProduction [ TypeId, Interval ] let MakeType[tree, localContext, paintRecords, cs] _ CreateSubrangeTGN [localContext1, tgn, bounds] where _ LookupTypeId [TypeId, localContext] where bounds _ GetBoundsVal [Interval] ; for Subrange.unnamed: AbstractProduction [ Interval ] let MakeType[tree, localContext, paintRecords, cs] _ CreateSubrangeTGN [localContext, tgn, bounds] where tgn _ GetBottom [cs] where bounds _ GetBoundsVal [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], ")"] ; <> for Bounds: AbstractProduction [ Exp.lower, Exp.upper ] let GetLowerAndUpper [tree] _ ; <> for PointerType.unspecified: AbstractProduction [ OptInterval ] let GetPointerTypeInfo [tree, localContext, paintRecords, cs] _ where bounds _ GetBoundsVal [OptInterval] where readOnly _ False [] where tgn _ GetBottom[cs] where localContext1 _ FakeDamageContext [localContext] ; for PointerType.specified: AbstractProduction [ OptInterval, ReadOnly, TypeExp ] let GetPointerTypeInfo [tree, localContext, paintRecords, cs] _ where bounds _ GetBoundsVal [OptInterval] where readOnly _ IsKeywordPresent [ReadOnly] where _ MakeType [TypeExp, localContext, paintRecords, cs] ; <> for OptInterval.absent: AbstractProduction [ ] let GetBoundsVal [tree] _ NullBounds [] ; for OptInterval.present: AbstractProduction [ Interval ] let GetBoundsVal [tree] _ GetBoundsVal [Interval] ; <> 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" ; <> for Arguments: AbstractProduction [ ParameterList.input, ParameterList.output ] let MakeArgumentLists [tree, localContext, paintRecords, cs] _ where frozenOutputList _ FreezeFieldList[outputFieldList] where _ MakeFieldList [ParameterList.output, localContext1, paintRecords, cs] where frozenInputlist _ FreezeFieldList[inputFieldList] where _ MakeFieldList [ParameterList.output, localContext, paintRecords, cs] ; <> for Default.empty: AbstractProduction [ ] let GetDefaultExpVal [tree] _ DefaultExpVal ["", MakeDummy["Default.empty"]] ; for Default.gets: AbstractProduction [ ] let GetDefaultExpVal [tree] _ DefaultExpVal ["_", MakeDummy["Default.gets"]] ; for Default.getsexp: AbstractProduction [ Exp ] let GetDefaultExpVal [tree] _ DefaultExpVal ["_e", instance] where instance _ MakeDummy["Default.getsexp"] <> ; for Default.getstrash: AbstractProduction [ ] let GetDefaultExpVal [tree] _ DefaultExpVal ["_TRASH", MakeDummy["Default.getstrash"]] ; for Default.getsexportrash: AbstractProduction [ Exp ] let GetDefaultExpVal [tree] _ DefaultExpVal ["_e|TRASH", instance] where instance _ MakeDummy["Default.getsexportrash"] <> ; <> for Packed.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for Packed.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; <> for Monitored.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for Monitored.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; <> for MachineDependent.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for MachineDependent.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; <> for Ordered.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for Ordered.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; <> for Base.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for Base.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; <> for Cedar.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for Cedar.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; <> for Safe.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for Safe.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; for Safe.empty: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; <> <> for Uncounted.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for Uncounted.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; <> for ReadOnly.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for ReadOnly.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; <> for Inline.yes: AbstractProduction [ ] let IsKeywordPresent [tree] _ True [] ; for Inline.no: AbstractProduction [ ] let IsKeywordPresent [tree] _ False [] ; End. <<>>