[Indigo]<Casaba>7.0>Saffron1.0>SaffronMethods.ThreeC4!1

SaffronMethods.ThreeC4

Shoup, August 8, 1986 5:32:07 pm PDT

Bill Jackson (bj) April 27, 1987 10:09:58 pm PDT

Include [SaffronAG, SaffronTreeDecls, SaffronBaseDecls];

SaffronAddToNamedFieldList: Module = Begin

Ident

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

;

IdentList

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

Scope

for Top.scope: AbstractProduction [ Scope ]

let DoTop[tree] ←

let < contextTree, typeGraph > ←
NewScope[Scope, CreateRibContext[], CreateTypeGraph[]]

in True[]

;

End;

SaffronInsertDescriptor: Module = Begin

IdentList

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

Element ???

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

ElementList

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

RecList

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

PairItem

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 >

;

PairList

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

Subrange

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 >

;

TypeExp

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]

;

TypeId

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

Bound

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

Bounds

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

Interval

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

TypeItem

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 >

;

TypeList

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

Exp

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]

)

;

Initialization

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

Scope

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[]],

ignore nested contexts for now ...

nestedContexts ←
BuildEmptyContextTreeList[],

contextTree ←
BuildContextTree[newRibContext, nestedContexts]

in < contextTree, typeGraph3 >

;

End;

SaffronPreprocessDecls: Module = Begin

Declaration

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] >

;

DecList

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]

;

OptDecList

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

OptDecList

for OptDecList.absent: AbstractProduction [ ]