<> <> <> <> Include [SaffronAG, SaffronTreeDecls, SaffronBaseDecls]; SaffronAddToNamedFieldList: Module = Begin <> for Ident.id: AbstractProduction [ id ] let AddToNamedFieldList[tree, typeIndex, namedFieldList] _ let fieldDescriptor _ BuildFieldDescriptor[typeIndex], < namedFieldList1, ok > _ AddNamedField[namedFieldList, id, fieldDescriptor], assert _ Assert[ok, "multiply defined field name", BotchAction.quit] in namedFieldList1 ; <> for IdentList.many: AbstractProduction [ IdentList.head, IdentList.tail ] let AddToNamedFieldList[tree, typeIndex, namedFieldList] _ let namedFieldList1 _ AddToNamedFieldList[IdentList.head, typeIndex, namedFieldList], namedFieldList2 _ AddToNamedFieldList[IdentList.tail, typeIndex, namedFieldList1] in namedFieldList2 ; for IdentList.one: AbstractProduction [ Ident ] let AddToNamedFieldList[tree, typeIndex, namedFieldList] _ AddToNamedFieldList[Ident, typeIndex, namedFieldList] ; End; SaffronDoTop: Module = Begin <> for Top.scope: AbstractProduction [ Scope ] let DoTop[tree] _ let < contextTree, typeGraph > _ NewScope[Scope, CreateRibContext[], CreateTypeGraph[]] in True[] ; End; SaffronInsertDescriptor: Module = Begin <> for Ident.id: AbstractProduction [ id ] let InsertDescriptor[tree, descriptor, localContext] _ let < localContext1, ok > _ InsertContext[localContext, id, descriptor], assert _ Assert[ok, "multiply defined identifier", BotchAction.quit] in localContext1 ; for IdentList.many: AbstractProduction [ IdentList.head, IdentList.tail ] let InsertDescriptor[tree, descriptor, localContext] _ let localContext1 _ InsertDescriptor[IdentList.head, descriptor, localContext], localContext2 _ InsertDescriptor[IdentList.tail, descriptor, localContext1] in localContext2 ; for IdentList.one: AbstractProduction [ Ident ] let InsertDescriptor[tree, descriptor, localContext] _ InsertDescriptor[Ident, descriptor, localContext] ; End; SaffronInsertElement: Module = Begin <> for Element.id: AbstractProduction [ id ] let InsertElement[tree, eltList] _ let < eltList1, ok > _ EltListInsert[eltList, id], assert _ Assert[ok, "multiply defined identifier", BotchAction.quit] in eltList1 ; End; SaffronMakeEltList: Module = Begin <> for ElementList.empty: AbstractProduction [ ] let MakeEltList[tree] _ BuildEmptyEltList[] ; for ElementList.more: AbstractProduction [ ElementList, Element ] let MakeEltList[tree] _ let eltList _ MakeEltList[ElementList] in InsertElement[Element, eltList] ; End; SaffronMakeFieldList: Module = Begin <> for RecList.empty: AbstractProduction [ ] let MakeFieldList[tree, localContext, ribContext, typeGraph] _ < BuildNullFieldList[], XLocalContext[localContext], XTypeGraph[typeGraph] > ; for RecList.pairlist: AbstractProduction [ PairList ] let MakeFieldList[tree, localContext, ribContext, typeGraph] _ let < namedFieldList, localContext1, typeGraph1 > _ MakeNamedFieldList[PairList, CreateNamedFieldList[], localContext, ribContext, typeGraph] in < BuildNamedFieldList[namedFieldList], localContext1, typeGraph1 > ; for RecList.typelist: AbstractProduction [ TypeList ] let MakeFieldList[tree, localContext, ribContext, typeGraph] _ let < unnamedFieldList, localContext1, typeGraph1 > _ MakeUnnamedFieldList[TypeList, CreateUnnamedFieldList[], localContext, ribContext, typeGraph] in < BuildUnnamedFieldList[unnamedFieldList], localContext1, typeGraph1 > ; End; SaffronMakeNamedFieldList: Module = Begin <> for PairItem: AbstractProduction [ IdentList, Access, TypeExp, Default ] let MakeNamedFieldList[tree, namedFieldList, localContext, ribContext, typeGraph] _ let < typeIndex, localContext1, typeGraph1 > _ MakeType[TypeExp, localContext, ribContext, typeGraph, UndefinedTypeIndex[]], namedFieldList1 _ AddToNamedFieldList[IdentList, typeIndex, namedFieldList] in < namedFieldList1, localContext1, typeGraph1 > ; <> for PairList.many: AbstractProduction [ PairList.head, PairList.tail ] let MakeNamedFieldList[tree, namedFieldList, localContext, ribContext, typeGraph] _ let < namedFieldList1, localContext1, typeGraph1 > _ MakeNamedFieldList[PairList.head, namedFieldList, localContext, ribContext, typeGraph], < namedFieldList2, localContext2, typeGraph2 > _ MakeNamedFieldList[PairList.tail, namedFieldList1, localContext1, ribContext, typeGraph1] in < namedFieldList2, localContext2, typeGraph2 > ; for PairList.one: AbstractProduction [ PairItem ] let MakeNamedFieldList[tree, namedFieldList, localContext, ribContext, typeGraph] _ MakeNamedFieldList[PairItem, namedFieldList, localContext, ribContext, typeGraph] ; End; SaffronMakeType: Module = Begin <> for Subrange.named: AbstractProduction [ TypeId, Interval ] let MakeType[tree, localContext, ribContext, typeGraph, optTypeIndex] _ let < typeIndex, localContext1, typeGraph1 > _ MakeType[TypeId, localContext, ribContext, typeGraph, UndefinedTypeIndex[]], < typeNode, bounds, localContext2, typeGraph2 > _ MakeTypeInterval[Interval, typeIndex, localContext1, ribContext, typeGraph1], newTypeNode _ BuildSubrangeType[typeNode, bounds], < typeGraph3, resultTypeIndex > _ AddOrSetType[typeGraph2, newTypeNode, optTypeIndex] in < resultTypeIndex, localContext2, typeGraph3 > ; <> for TypeExp.enum: AbstractProduction [ MachineDependent, ElementList ] let MakeType[tree, localContext, ribContext, typeGraph, optTypeIndex] _ let eltList _ MakeEltList[ElementList], < typeGraph1, paint > _ NewPaint[typeGraph], typeNode _ BuildEnumType[paint, eltList], < typeGraph2, typeIndex > _ AddOrSetType[typeGraph1, typeNode, optTypeIndex] in < typeIndex, XLocalContext[localContext], typeGraph2 > ; for TypeExp.record: AbstractProduction [ MachineDependent, Monitored, RecList ] let MakeType[tree, localContext, ribContext, typeGraph, optTypeIndex] _ let < fieldList, localContext1, typeGraph1 > _ MakeFieldList[RecList, localContext, ribContext, typeGraph], typeNode _ BuildRecordType[fieldList], < typeGraph2, typeIndex > _ AddOrSetType[typeGraph1, typeNode, optTypeIndex] in < typeIndex, localContext1, typeGraph2 > ; for TypeExp.ref: AbstractProduction [ ReadOnly, TypeExp ] let MakeType[tree, localContext, ribContext, typeGraph, optTypeIndex] _ let < referentTypeIndex, localContext1, typeGraph1 > _ MakeType[TypeExp, localContext, ribContext, typeGraph, UndefinedTypeIndex[]], typeNode _ BuildRefType[referentTypeIndex], < typeGraph2, typeIndex > _ AddOrSetType[typeGraph1, typeNode, optTypeIndex] in < typeIndex, localContext1, typeGraph2 > ; for TypeExp.subrange: AbstractProduction [ Subrange ] let MakeType[tree, localContext, ribContext, typeGraph, optTypeIndex] _ MakeType[Subrange, localContext, ribContext, typeGraph, optTypeIndex] ; for TypeExp.typeid: AbstractProduction [ TypeId ] let MakeType[tree, localContext, ribContext, typeGraph, optTypeIndex] _ MakeType[TypeId, localContext, ribContext, typeGraph, optTypeIndex] ; <> for TypeId.id: AbstractProduction [ id ] let MakeType[tree, localContext, ribContext, typeGraph, optTypeIndex] _ let descriptor _ Lookup[ribContext, localContext, id], assert1 _ Assert[Not[IsUndefinedDescriptor[descriptor]], "undeclared id", BotchAction.quit], assert2 _ Assert[IsTypeDescriptor[descriptor], "type id expected", BotchAction.quit], typeIndex _ GetType[descriptor] in ( if IsUndefinedTypeIndex[optTypeIndex] then < typeIndex, XLocalContext[localContext], XTypeGraph[typeGraph] > else ( let < typeNode, localContext1, typeGraph1 > _ FetchType[typeGraph, typeIndex, localContext, ribContext], typeGraph2 _ SetType[typeGraph1, typeNode, optTypeIndex] in < XTypeIndex[optTypeIndex], localContext1, typeGraph2 > ) ) ; End; SaffronMakeTypeBound: Module = Begin <> for Bound: AbstractProduction [ Exp ] let MakeTypeBound[tree, typeIndex, localContext, ribContext, typeGraph] _ let < value, localContext1, typeGraph1 > _ MakeValue[Exp, localContext, ribContext, typeGraph, typeIndex], boundTypeIndex _ ValueGetType[value], < boundTypeNode, localContext2, typeGraph2 > _ FetchType[typeGraph1, boundTypeIndex, localContext1, ribContext], assert _ Assert[IsEnumType[boundTypeNode], "type mismatch", BotchAction.quit], < typeNode, localContext3, typeGraph3 > _ FetchType[typeGraph2, typeIndex, localContext2, ribContext], assert1 _ Assert[PaintEqual[GetPaint[typeNode], GetPaint[boundTypeNode]], "type mismatch", BotchAction.quit], assert2 _ Assert[IsSimpleValue[value], "not a compile-time constant", BotchAction.quit] in < ValueGetOrdinal[value], localContext3, typeGraph3 > ; End; SaffronMakeTypeBounds: Module = Begin <> for Bounds: AbstractProduction [ Bound.lower, Bound.upper ] let MakeTypeBounds[tree, leftClosed, rightClosed, typeIndex, localContext, ribContext, typeGraph] _ let < typeNode, localContext1, typeGraph1 > _ FetchType[typeGraph, typeIndex, localContext, ribContext], assert _ Assert[IsEnumType[typeNode], "only subranges of enums are allowed", BotchAction.quit], < lowerOrdinal, localContext2, typeGraph2 > _ MakeTypeBound[Bound.lower, typeIndex, localContext1, ribContext, typeGraph1], < upperOrdinal, localContext3, typeGraph3 > _ MakeTypeBound[Bound.upper, typeIndex, localContext2, ribContext, typeGraph2], bounds _ BuildTypeBounds[lowerOrdinal, upperOrdinal, leftClosed, rightClosed] in < typeNode, bounds, localContext3, typeGraph3 > ; End; SaffronMakeTypeInterval: Module = Begin <> for Interval.cc: AbstractProduction [ Bounds ] let MakeTypeInterval[tree, typeIndex, localContext, ribContext, typeGraph] _ MakeTypeBounds[Bounds, True[], True[], typeIndex, localContext, ribContext, typeGraph] ; for Interval.co: AbstractProduction [ Bounds ] let MakeTypeInterval[tree, typeIndex, localContext, ribContext, typeGraph] _ MakeTypeBounds[Bounds, True[], False[], typeIndex, localContext, ribContext, typeGraph] ; for Interval.oc: AbstractProduction [ Bounds ] let MakeTypeInterval[tree, typeIndex, localContext, ribContext, typeGraph] _ MakeTypeBounds[Bounds, False[], True[], typeIndex, localContext, ribContext, typeGraph] ; for Interval.oo: AbstractProduction [ Bounds ] let MakeTypeInterval[tree, typeIndex, localContext, ribContext, typeGraph] _ MakeTypeBounds[Bounds, False[], False[], typeIndex, localContext, ribContext, typeGraph] ; End; SaffronMakeUnnamedFieldList: Module = Begin <> for TypeItem: AbstractProduction [ TypeExp, Default ] let MakeUnnamedFieldList[tree, unnamedFieldList, localContext, ribContext, typeGraph] _ let < typeIndex, localContext1, typeGraph1 > _ MakeType[TypeExp, localContext, ribContext, typeGraph, UndefinedTypeIndex[]], fieldDescriptor _ BuildFieldDescriptor[typeIndex], unnamedFieldList1 _ AddUnnamedField[unnamedFieldList, fieldDescriptor] in < unnamedFieldList1, localContext1, typeGraph1 > ; <> for TypeList.many: AbstractProduction [ TypeList.head, TypeList.tail ] let MakeUnnamedFieldList[tree, unnamedFieldList, localContext, ribContext, typeGraph] _ let < unnamedFieldList1, localContext1, typeGraph1 > _ MakeUnnamedFieldList[TypeList.head, unnamedFieldList, localContext, ribContext, typeGraph] in MakeUnnamedFieldList[TypeList.tail, unnamedFieldList1, localContext1, ribContext, typeGraph1] ; for TypeList.one: AbstractProduction [ TypeItem ] let MakeUnnamedFieldList[tree, unnamedFieldList, localContext, ribContext, typeGraph] _ MakeUnnamedFieldList[TypeItem, unnamedFieldList, localContext, ribContext, typeGraph] ; End; SaffronMakeValue: Module = Begin <> for Exp.id: AbstractProduction [ id ] let MakeValue[tree, localContext, ribContext, typeGraph, typeIndex] _ let < typeNode, localContext1, typeGraph1 > _ FetchType[typeGraph, typeIndex, localContext, ribContext], descriptor _ ( if IsEnumType[typeNode] then ( let eltList _ EnumTypeEltList[typeNode], ordinalValue _ EltListLookup[eltList, id] in ( if IsUndefinedOrdinalValue[ordinalValue] then Lookup[ribContext, localContext1, id] else BuildValueDescriptor[BuildSimpleValue[typeIndex, ordinalValue]] ) ) else Lookup[ribContext, localContext1, id] ), assert2 _ Assert[Not[IsUndefinedDescriptor[descriptor]], "undefined identifier", BotchAction.quit], assert3 _ Assert[Not[IsInaccessibleDescriptor[descriptor]], "circularly defined value", BotchAction.quit], assert4 _ Assert[Not[IsTypeDescriptor[descriptor]], "type identifier not allowed", BotchAction.quit] in ( if IsSuspendedDescriptor[descriptor] then ( let < localContext2, typeGraph2 > _ ProcessOneDecl[NarrowToDeclaration[DescriptorGetDecl[descriptor]], UndefinedTypeIndex[], localContext1, ribContext, typeGraph1] in MakeValue[tree, localContext2, ribContext, typeGraph2, typeIndex] ) else < GetValue[descriptor], XLocalContext[localContext1], XTypeGraph[typeGraph1] > -- IsValueDescriptor[descriptor] ) ; <> for Initialization.assignment: AbstractProduction [ InitialValue ] let MakeValue[tree, localContext, ribContext, typeGraph, typeIndex] _ < BuildVarValue[typeIndex], XLocalContext[localContext], XTypeGraph[typeGraph] > ; for Initialization.binding: AbstractProduction [ InitialValue ] let MakeValue[tree, localContext, ribContext, typeGraph, typeIndex] _ MakeValue[InitialValue, localContext, ribContext, typeGraph, typeIndex] ; for Initialization.empty: AbstractProduction [ ] let MakeValue[tree, localContext, ribContext, typeGraph, typeIndex] _ < BuildVarValue[typeIndex], XLocalContext[localContext], XTypeGraph[typeGraph] > ; for InitialValue.exp: AbstractProduction [ Exp ] let MakeValue[tree, localContext, ribContext, typeGraph, typeIndex] _ MakeValue[Exp, localContext, ribContext, typeGraph, typeIndex] ; End; SaffronNewScope: Module = Begin <> for Scope: AbstractProduction [ BindList, Catch, OptDecList, StatementList ] let NewScope[tree, ribContext, typeGraph] _ let localContext _ CreateLocalContext[], < localContext1, typeGraph1 > _ PreprocessDecls[OptDecList, localContext, typeGraph], < localContext2, typeGraph2 > _ ProcessDecls[OptDecList, localContext1, ribContext, typeGraph1], < localContext3, typeGraph3 > _ FetchAllSizes[typeGraph2, localContext2, ribContext], newRibContext _ ExtendRibContext[ribContext, localContext3], junk _ PrintLocalContext[localContext3, Output[]], junk1 _ PrintTypeGraph[typeGraph3, Output[]], <> nestedContexts _ BuildEmptyContextTreeList[], contextTree _ BuildContextTree[newRibContext, nestedContexts] in < contextTree, typeGraph3 > ; End; SaffronPreprocessDecls: Module = Begin <> for Declaration.opaquetype: AbstractProduction [ IdentList, Access, OptSize ] let PreprocessDecls[tree, localContext, typeGraph] _ let typeNode _ BuildSuspendedType[tree], < typeGraph1, typeIndex > _ AddType[typeGraph, typeNode], descriptor _ BuildTypeDescriptor[typeIndex], localContext1 _ InsertDescriptor[IdentList, descriptor, localContext] in < localContext1, typeGraph1 > ; for Declaration.type: AbstractProduction [ IdentList, Access.id, Access.type, TypeExp, Default] let PreprocessDecls[tree, localContext, typeGraph] _ let typeNode _ BuildSuspendedType[tree], < typeGraph1, typeIndex > _ AddType[typeGraph, typeNode], descriptor _ BuildTypeDescriptor[typeIndex], localContext1 _ InsertDescriptor[IdentList, descriptor, localContext] in < localContext1, typeGraph1 > ; for Declaration.value: AbstractProduction [ IdentList, Access, Entry, ReadOnly, TypeExp, Initialization ] let PreprocessDecls[tree, localContext, typeGraph] _ let descriptor _ BuildSuspendedDescriptor[tree], localContext1 _ InsertDescriptor[IdentList, descriptor, localContext] in < localContext1, XTypeGraph[typeGraph] > ; <> for DecList.many: AbstractProduction [ DecList.head, DecList.tail ] let PreprocessDecls[tree, localContext, typeGraph] _ let < localContext1, typeGraph1 > _ PreprocessDecls[DecList.head, localContext, typeGraph], < localContext2, typeGraph2 > _ PreprocessDecls[DecList.tail, localContext1, typeGraph1] in < localContext2, typeGraph2 > ; for DecList.one: AbstractProduction [ Declaration ] let PreprocessDecls[tree, localContext, typeGraph] _ PreprocessDecls[Declaration, localContext, typeGraph] ; <> for OptDecList.absent: AbstractProduction [ ] let PreprocessDecls[tree, localContext, typeGraph] _ < XLocalContext[localContext], XTypeGraph[typeGraph] > ; for OptDecList.present: AbstractProduction [ DecList ] let PreprocessDecls[tree, localContext, typeGraph] _ PreprocessDecls[DecList, localContext, typeGraph] ; End; SaffronProcessDecls: Module = Begin <> for OptDecList.absent: AbstractProduction [ ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ < XLocalContext[localContext], XTypeGraph[typeGraph] > ; for OptDecList.present: AbstractProduction [ DecList ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ ProcessDecls[DecList, localContext, ribContext, typeGraph] ; <> for DecList.many: AbstractProduction [ DecList.head, DecList.tail ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ let < localContext1, typeGraph1 > _ ProcessDecls[DecList.head, localContext, ribContext, typeGraph], < localContext2, typeGraph2 > _ ProcessDecls[DecList.tail, localContext1, ribContext, typeGraph1] in < localContext2, typeGraph2 > ; for DecList.one: AbstractProduction [ Declaration ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ ProcessDecls[Declaration, localContext, ribContext, typeGraph] ; <> for Declaration.opaquetype: AbstractProduction [ IdentList, Access, OptSize ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ ProcessDecls[IdentList, localContext, ribContext, typeGraph] ; for Declaration.type: AbstractProduction [ IdentList, Access.id, Access.type, TypeExp, Default ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ ProcessDecls[IdentList, localContext, ribContext, typeGraph] ; for Declaration.value: AbstractProduction [ IdentList, Access, Entry, ReadOnly, TypeExp, Initialization ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ ProcessDecls[IdentList, localContext, ribContext, typeGraph] ; <> for IdentList.many: AbstractProduction [ IdentList.head, IdentList.tail ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ let < localContext1, typeGraph1 > _ ProcessDecls[IdentList.head, localContext, ribContext, typeGraph], < localContext2, typeGraph2 > _ ProcessDecls[IdentList.tail, localContext1, ribContext, typeGraph1] in < localContext2, typeGraph2 > ; for IdentList.one: AbstractProduction [ Ident ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ ProcessDecls[Ident, localContext, ribContext, typeGraph] ; <> for Ident.id: AbstractProduction [ id ] let ProcessDecls[tree, localContext, ribContext, typeGraph] _ let descriptor _ LocalLookup[localContext, id], assert _ Assert[Not[IsUndefinedDescriptor[descriptor]], "undefined descriptor", BotchAction.debug], assert1 _ Assert[Not[IsInaccessibleDescriptor[descriptor]], "inaccessible descriptor", BotchAction.debug] in ( if IsSuspendedDescriptor[descriptor] then ProcessOneDecl[NarrowToDeclaration[DescriptorGetDecl[descriptor]], UndefinedTypeIndex[], localContext, ribContext, typeGraph] else if IsValueDescriptor[descriptor] then < XLocalContext[localContext], XTypeGraph[typeGraph] > else ( <> let typeIndex _ GetType[descriptor], typeNode _ RawFetchType[typeGraph, typeIndex] in ( if IsSuspendedType[typeNode] then ProcessOneDecl[NarrowToDeclaration[GetTypeDecl[typeNode]], typeIndex, localContext, ribContext, typeGraph] else < XLocalContext[localContext], XTypeGraph[typeGraph] > ) ) ) ; End; SaffronProcessOneDecl: Module = Begin <> for Declaration.type: AbstractProduction [ IdentList, Access.id, Access.type, TypeExp, Default ] let ProcessOneDecl[tree, typeIndex, localContext, ribContext, typeGraph] _ let tempTypeNode _ BuildInaccessibleType[], typeGraph1 _ SetType[typeGraph, tempTypeNode, typeIndex], < newTypeIndex, localContext1, typeGraph2 > _ MakeType[TypeExp, localContext, ribContext, typeGraph1, typeIndex] in < localContext1, typeGraph2 > ; for Declaration.value: AbstractProduction [ IdentList, Access, Entry, ReadOnly, TypeExp, Initialization ] let ProcessOneDecl[tree, dummyTypeIndex, localContext, ribContext, typeGraph] _ let newDescriptor _ BuildInaccessibleDescriptor[], localContext1 _ ReplaceDescriptor[IdentList, newDescriptor, localContext], < typeIndex, localContext2, typeGraph1 > _ MakeType[TypeExp, localContext1, ribContext, typeGraph, UndefinedTypeIndex[]], < value, localContext3, typeGraph2 > _ MakeValue[Initialization, localContext2, ribContext, typeGraph1, typeIndex], finalDescriptor _ BuildValueDescriptor[value], localContext4 _ ReplaceDescriptor[IdentList, finalDescriptor, localContext3] in < localContext4, typeGraph2 > ; End; SaffronReplaceDescriptor: Module = Begin <> for Ident.id: AbstractProduction [ id ] let ReplaceDescriptor[tree, descriptor, localContext] _ let < localContext1, ok > _ ReplaceContext[localContext, id, descriptor], assert _ Assert[ok, "undefined identifier", BotchAction.debug] in localContext1 ; for IdentList.many: AbstractProduction [ IdentList.head , IdentList.tail ] let ReplaceDescriptor[tree, descriptor, localContext] _ let localContext1 _ ReplaceDescriptor[IdentList.head, descriptor, localContext], localContext2 _ ReplaceDescriptor[IdentList.tail, descriptor, localContext1] in localContext2 ; for IdentList.one: AbstractProduction [ Ident ] let ReplaceDescriptor[tree, descriptor, localContext] _ ReplaceDescriptor[Ident, descriptor, localContext] ; End. <> <<>>