DIRECTORY AMBridge, AMMiniModel, AMTypes, Atom, FS, Basics, BasicTime, BitTwiddling, IO, EnumTypes, NumTypes, Rope, RoseTranslateTypes, RoseTypes, SignalTypeRegistration, SwitchNumConvert, SwitchTypes, VFonts;

EnumTypesImpl: CEDAR PROGRAM
IMPORTS AMBridge, AMMiniModel, AMTypes, Atom, FS, Basics, BasicTime, IO, NumTypes, Rope, RoseTranslateTypes, SignalTypeRegistration, SwitchNumConvert, SwitchTypes, VFonts
EXPORTS EnumTypes =

BEGIN

ROPE: TYPE = Rope.ROPE;

Ptr: TYPE = RoseTypes.Ptr;
NodeType: TYPE = RoseTypes.NodeType;
NodeTypeRep: TYPE = RoseTypes.NodeTypeRep;
Format: TYPE = RoseTypes.Format;
Node: TYPE = RoseTypes.Node;
NodeTest: TYPE = RoseTypes.NodeTest;

ETData: TYPE = REF ETDataRep;
ETDataRep: TYPE = RECORD [
fileSinceEpoch: LONG CARDINAL,
interface, type: ROPE,
amType: AMTypes.Type,
initialValue, bits: CARDINAL
];

enumTypeProcs: RoseTypes.NodeProcs _ NEW [RoseTypes.NodeProcsRep _ [
UserDescription: EnumTypeUserDescription,
ListFormats: EnumTypeListFormats,
GetFormat: EnumTypeGetFormat,
MesaForSelf: EnumTypeMesaForSelf,
SelectorOffset: EnumTypeSelectorOffset,
SubType: EnumTypeSubType,
Bits: EnumTypeBits,
MesaRepresentation: EnumTypeMesaRepresentation,
MesaRepAux: EnumTypeMesaRepAux,
Equivalent: EnumTypeEquivalent,
SwitchEquivalent: EnumTypeSwitchEquivalent,
Transduce: SwitchNumConvert.Transduce
]];

ConstructEnumType: PROC [parms: REF ANY --UNION [BindingList, Args]--] RETURNS [type: NodeType] --RoseTranslateTypes.NodeTypeConstructor-- =
BEGIN
name: RoseTranslateTypes.Quoted _ NARROW[RoseTranslateTypes.GetParm[n: 1, name: "name", parms: parms]];
type _ EnumType[name.rope];
END;

EnumType: PUBLIC PROC [etName: ROPE] RETURNS [nt: NodeType] =
BEGIN
interface, type: ROPE;
atom: ATOM;
md: ETData;
fileTime: BasicTime.GMT;
fileSinceEpoch: LONG CARDINAL;
fileExists: BOOLEAN _ TRUE;
periodPos: INT;
iType, enumType: AMTypes.Type;
iv: AMTypes.TV;
nComponents, fieldIndex: NAT;
maxValue, initialValue: CARDINAL _ 0;
bits: CARDINAL _ 0;
powBits: INT;

atom _ Atom.MakeAtom[etName];
nt _ NARROW[Atom.GetProp[atom: atom, prop: $enumTypeRoseImpl]];
periodPos _ etName.Find["."];
WHILE periodPos<0 DO
etName _ Rope.Concat["Dragon.", etName];
periodPos _ etName.Find["."];
ENDLOOP;
interface _ etName.Substr[0, periodPos];
type _ etName.Substr[periodPos+1, etName.Length[]-(periodPos+1)];
IF interface.Length=0 OR type.Length=0 THEN ERROR RoseTranslateTypes.TypeConstructionError["EnumType arg not of form \"Interface.Type\""];

fileTime _ FS.FileInfo[interface.Concat[".bcd"]
! FS.Error => {fileExists _ FALSE; CONTINUE}].created;

IF NOT fileExists THEN ERROR RoseTranslateTypes.TypeConstructionError[IO.PutFR["File %g.bcd doesn't exist", IO.rope[interface]]];
fileSinceEpoch _ BasicTime.Period[from: BasicTime.earliestGMT, to: fileTime];
IF nt # NIL THEN
BEGIN
et: ETData _ NARROW[nt.typeData];
IF fileSinceEpoch = et.fileSinceEpoch THEN RETURN; -- it's still good
END;

iType _ AMMiniModel.AcquireIRType[defsName: interface];
nComponents _ AMTypes.NComponents[iType];
fieldIndex _ AMTypes.NameToIndex[iType, type];
IF NOT fieldIndex IN [1 .. nComponents] THEN ERROR RoseTranslateTypes.TypeConstructionError["fieldIndex NOT IN [1 .. nComponents] --- shouldn't ever happen"];
enumType _ AMTypes.UnderType[AMTypes.TVToType[AMTypes.IndexToDefaultInitialValue[iType, fieldIndex]]];
IF AMTypes.TypeClass[enumType] # enumerated THEN ERROR RoseTranslateTypes.TypeConstructionError[IO.PutFR["TYPE %g.%g isn't enumerated", IO.rope[interface], IO.rope[type]]];
TRUSTED {maxValue _ AMBridge.TVToLC[AMTypes.Last[enumType]]};
powBits _ 2;
FOR bits _ 1, bits+1 DO
IF maxValue<powBits THEN EXIT;
powBits _ 2*powBits;
ENDLOOP;
iv _ AMTypes.DefaultInitialValue[enumType];
IF iv = NIL THEN iv _ AMTypes.First[enumType];
TRUSTED {initialValue _ AMBridge.TVToLC[iv]};

md _ NEW [ETDataRep _ [
fileSinceEpoch: fileSinceEpoch,
interface: interface,
type: type,
amType: enumType,
initialValue: initialValue,
bits: bits]];

nt _ NEW [NodeTypeRep _ [
procs: enumTypeProcs,
typeData: md,
structure: array[bits, NARROW[NumTypes.boolType]] ]];
Atom.PutProp[atom: atom, prop: $enumTypeRoseImpl, val: nt];
END;

Enumerated: PUBLIC PROC [nt: NodeType] RETURNS [b: BOOL] =
{b _ nt.typeData # NIL AND ISTYPE[nt.typeData, ETData]};

EnumTypeUserDescription: PROC [nt: NodeType] RETURNS [ud: ROPE] =
{md: ETData _ NARROW[nt.typeData];
ud _ Rope.Cat["EnumType[\"", md.interface.Cat[".", md.type], "\"]"]};

EnumTypeListFormats: PROC [NodeType] RETURNS [rl: RoseTypes.RopeList] =
{rl _ LIST["et"]};

EnumTypeGetFormat: PROC [nt: NodeType, r: ROPE] RETURNS [Format] =
{RETURN [IF r.Equal["init"] THEN initFormat ELSE enumTypeFormat]};

EnumTypeMesaForSelf: PROC [nt: NodeType] RETURNS [m: RoseTypes.Mesa] =
{md: ETData _ NARROW[nt.typeData];
m _ [
mesa: Rope.Cat["EnumTypes.EnumType[\"", md.interface.Cat[".", md.type], "\"]"],
imports: LIST["EnumTypes"]]};

EnumTypeSelectorOffset: PROC [nt: NodeType, s: RoseTypes.Selector] RETURNS [o: NAT] = {
o _ WITH s SELECT FROM
number => index,
whole => 0,
range => IF up THEN first ELSE (first + 1 - count),
ENDCASE => ERROR;
};

EnumTypeSubType: PROC [nt: NodeType, s: RoseTypes.Selector] RETURNS [snt: NodeType] = {
snt _ WITH s SELECT FROM
whole => nt,
number => NumTypes.boolType,
range => NumTypes.NumType[count],
ENDCASE => ERROR;
};

EnumTypeBits: PROC [nt: NodeType] RETURNS [container, data, leftPad: INT] =
{md: ETData _ NARROW[nt.typeData]; container _ data _ md.bits; leftPad _ 0};

EnumTypeMesaRepresentation: PROC [nt: NodeType] RETURNS [m: RoseTypes.Mesa] =
{md: ETData _ NARROW[nt.typeData]; m _ [md.type]};

EnumTypeMesaRepAux: PROC [nt: NodeType] RETURNS [m: RoseTypes.Mesa] = {
md: ETData _ NARROW[nt.typeData];
m _ [
mesa: md.type.Cat[": TYPE = ", md.interface, ".", md.type],
directory: LIST[md.interface]]};

EnumTypeEquivalent: PROC [self, other: NodeType] RETURNS [eqv: BOOL] = {
md: ETData _ NARROW[self.typeData];
eqv _ SELECT TRUE FROM
NumTypes.Numeric[other] => md.bits = Length[other],
Enumerated[other] => md.bits = Length[other],
ENDCASE => FALSE;
};

Length: PROC [nt: NodeType] RETURNS [len: INT] = {
len _ WITH nt SELECT FROM
ant: RoseTypes.AtomNodeType => 1,
ant: RoseTypes.ArrayNodeType => ant.length,
ENDCASE => ERROR;
};

EnumTypeSwitchEquivalent: PROC [self: NodeType] RETURNS [other: NodeType] = {
md: ETData _ NARROW[self.typeData];
other _ SwitchTypes.Bundle[md.bits];
};

enumTypeFormat: RoseTypes.Format _ NEW [RoseTypes.FormatRep _ [
FormatValue: EnumTypeFormatValue,
ParseValue: EnumTypeParseValue,
FormatTest: EnumTypeFormatTest,
ParseTest: EnumTypeParseTest,
MaxWidth: EnumTypeMaxWidth,
formatData: NIL,
key: "et"]];

initFormat: RoseTypes.Format _ NEW [RoseTypes.FormatRep _ [
ParseValue: EnumTypeParseInitValue,
key: "init"]];

bpw: NAT = Basics.bitsPerWord;

Pointer: TYPE = RECORD [
p: LONG POINTER TO CARDINAL,
leftPad: [0 .. bpw)];

EnumTypeFormatValue: PROC [node: Node, format: Format, where: Ptr] RETURNS [rope: ROPE] =
BEGIN
md: ETData _ NARROW[node.type.typeData];
p: Pointer _ ToPointer[where];
index: CARDINAL _ Read[p, md.bits];
tv: AMTypes.TV _ AMTypes.New[md.amType];
TRUSTED {AMBridge.SetTVFromLC[tv, index]};
rope _ AMTypes.TVToName[tv];
END;

ToPointer: PROC [ptr: Ptr] RETURNS [p: Pointer] = TRUSTED {
p _ [
p: LOOPHOLE[ptr.word],
leftPad: ptr.bit];
};

Read: PROC [p: Pointer, bits: NAT] RETURNS [card: CARDINAL] = TRUSTED {
IF p.leftPad + bits > bpw THEN ERROR;
card _ Basics.BITSHIFT[p.p^, INTEGER[bits + p.leftPad] - bpw];
card _ Basics.BITAND[card, BitTwiddling.oneLessThanTwoToThe[bits]];
};

Write: PROC [p: Pointer, bits: NAT, card: CARDINAL] = TRUSTED {
shift: INTEGER _ bpw - (bits + p.leftPad);
mask: CARDINAL _ BitTwiddling.oneLessThanTwoToThe[bits];
IF p.leftPad + bits > bpw THEN ERROR;
IF card > mask THEN ERROR;
card _ Basics.BITSHIFT[card, shift];
mask _ Basics.BITSHIFT[mask, shift];
p.p^ _ Basics.BITOR[card, Basics.BITAND[p.p^, Basics.BITNOT[mask]]];
};

EnumTypeParseValue: PROC [node: Node, format: Format, where: Ptr, from: IO.STREAM] RETURNS [success: BOOLEAN] =
BEGIN
md: ETData _ NARROW[node.type.typeData];
p: Pointer _ ToPointer[where];
i: CARDINAL;
rope: ROPE _ from.GetTokenRope[].token;
[i, success] _ Lookup[md, rope];
IF success THEN Write[p, md.bits, i];
END;

EnumTypeParseInitValue: PROC [node: Node, format: Format, where: Ptr, from: IO.STREAM] RETURNS [success: BOOLEAN] =
BEGIN
md: ETData _ NARROW[node.type.typeData];
p: Pointer _ ToPointer[where];
rope: ROPE _ from.GetTokenRope[].token;
IF NOT (rope.Equal["initial"] OR rope.Equal["steady"]) THEN ERROR;
Write[p, md.bits, md.initialValue];
END;

Lookup: PROC [md: ETData, rope: ROPE] RETURNS [index: CARDINAL, success: BOOLEAN] =
BEGIN
FOR tv: AMTypes.TV _ AMTypes.First[md.amType], AMTypes.Next[tv] WHILE tv#NIL DO
BEGIN
IF Rope.Equal[rope, AMTypes.TVToName[tv
! AMTypes.Error => IF reason=badIndex THEN GOTO NoName ELSE REJECT]] THEN
TRUSTED BEGIN
value: CARDINAL = AMBridge.TVToLC[tv];
RETURN[value, TRUE];
END;
EXITS NoName => NULL;
END;
ENDLOOP;
success _ FALSE; index _ 0;
END;

EnumTypeMaxWidth: PROC [nodeType: NodeType, format: Format, font: VFonts.Font] RETURNS [INT] =
BEGIN
md: ETData _ NARROW[nodeType.typeData];
mw: INT _ VFonts.StringWidth["??"];
FOR tv: AMTypes.TV _ AMTypes.First[md.amType], AMTypes.Next[tv] WHILE tv#NIL DO
mw _ MAX[mw, VFonts.StringWidth[AMTypes.TVToName[tv
! AMTypes.Error => IF reason=badIndex THEN CONTINUE ELSE REJECT], font]];
ENDLOOP;
RETURN [mw];
END;

EnumTypeParseTest: PROC [nodeType: NodeType, format: Format, from: IO.STREAM] RETURNS [success: BOOLEAN, test: NodeTest] =
BEGIN
md: ETData _ NARROW[nodeType.typeData];
i: CARDINAL;
rope: ROPE _ from.GetTokenRope[].token;
[i, success] _ Lookup[md, rope];
test.data _ IF success THEN NEW [CARDINAL _ i] ELSE NIL;
test.proc _ TestEnumType;
END;

EnumTypeFormatTest: PROC [nodeType: NodeType, format: Format, test: NodeTest] RETURNS [rope: ROPE] =
BEGIN
md: ETData _ NARROW[nodeType.typeData];
rc: REF CARDINAL _ NARROW[test.data];
IF rc # NIL THEN
BEGIN ENABLE AMTypes.Error => IF reason=badIndex THEN GOTO NoName ELSE REJECT;
RETURN[AMTypes.TVToName[AMTypes.Value[md.amType, rc^+1]]];
EXITS NoName => NULL;
END;
RETURN["??"];
END;

TestEnumType: PROC [where: Ptr, testData: REF ANY, nodeType: NodeType] RETURNS [passes: BOOLEAN] --RoseTypes.NodeTestProc-- =
BEGIN
rc: REF CARDINAL _ NARROW[testData];
md: ETData _ NARROW[nodeType.typeData];
p: Pointer _ ToPointer[where];
index: CARDINAL _ Read[p, md.bits];
passes _ rc^ = index;
END;

SignalTypeRegistration.RegisterNodeTypeConstructor["EnumType", ConstructEnumType];

END.
ˆEnumTypesImpl.Mesa
Last Edited by: Spreitzer, May 6, 1985 2:39:39 pm PDT
Last Edited by: McCreight, March 8, 1984 7:02:23 pm PST
Κκ–

"cedar" style˜Icode™K™5K™7K˜KšΟk	œ'œ#œz˜Ρ
K˜šΠbx
œœ
˜Kšœ'œœc˜ͺ
Kšœ˜—K˜Kš
˜K˜Kšœœœ
˜K˜Kšœœ˜Kšœ
œ˜$Kšœ
œ˜*Kšœœ˜ Kšœœ˜Kšœ
œ˜$K˜Kšœœœ˜šœœœ˜Kšœœ
œ
˜Kšœœ
˜Kš
œ˜Kšœ˜K˜—K˜šœ%œ˜DKš
œ)˜)Kš
œ!˜!Kš
œ˜Kš
œ!˜!Kš
œ'˜'Kš
œ˜Kš
œ˜Kš
œ/˜/Kš
œ˜Kš
œ˜Kš
œ+˜+Kš
œ%˜%Kš
œ˜—K˜šΟnœœ	œ
œ
Οcœœ *œ˜Œ
Kš
˜Kšœ"œ?˜gK˜Kšœ
˜—K˜š
Ÿœœ
œ
œœ˜=Kš
˜Kšœœ
˜Kšœœ
˜K˜Kšœœ
˜Kšœœ
œ
˜Kšœœœ
˜Kšœœ
˜Kš
œ˜Kšœœ
˜Kšœœ
˜Kšœœ˜%Kšœœ˜Kšœ	œ
˜
K˜Kš
œ˜Kšœœ4˜?K˜šœ
˜Kš
œ(˜(Kš
œ˜Kšœ
˜—Kš
œ(˜(Kš
œA˜AKšœœœ
œY˜Š
K˜Kš	œœ%œœœ˜fK˜Kšœ
œœ
œ*œ$œ˜
Kš
œM˜Mšœœ
˜Kš
˜Kšœ
œ˜!Kšœ$œ
œ ˜EKšœ
˜—K˜Kš
œ7˜7Kš
œ)˜)Kš
œ.˜.Kš
œ
œœœ
œl˜ž
Kš
œf˜fKšœ*œ
œ*œ&œœ˜¬
Kšœ6˜=Kš
œ˜šœ˜Kšœœ
œ
˜Kš
œ˜Kšœ
˜—Kš
œ+˜+Kšœœ
œ˜.Kšœ&˜-K˜šœœ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ
˜
—K˜šœœ˜Kš
œ˜K˜
Kšœœ˜5—Kš
œ;˜;Kšœ
˜—K˜š
Ÿ
œœ
œœœ˜:Kšœœ
œ
œ˜8—K˜šŸœœœœ˜AKšœœ˜"Kš
œE˜E—K˜šŸœœœ˜GKšœœ˜—K˜šŸœœœœ˜BKš	œ
œœœœ˜B—K˜šŸœœœ˜FKšœœ˜"š
œ˜Kš
œO˜OKšœ	œ˜——K˜šŸœœ'œœ˜Wšœœœ
˜K˜K˜Kšœ	œœœ˜3Kšœœ
˜—K˜—K˜šŸœœ'œ˜Wšœœœ
˜K˜K˜K˜!Kšœœ
˜—K˜—K˜šŸœœœœ˜KKšœœ8˜L—K˜šŸœœœ˜MKšœœ˜2—K˜šŸœœœ˜GKšœ
œ˜!š
œ˜Kš
œ;˜;Kšœœ˜ ——K˜šŸœœœœ˜HKšœ
œ˜#šœœ
œ
˜Kš
œ3˜3K˜-Kšœœ
˜—Kš
œ˜—K˜šŸœœœœ˜2šœœœ
˜K˜!K˜+Kšœœ
˜—K˜—K˜šŸœœœ˜MKšœ
œ˜#K˜$K˜—K˜šœ#œ˜?Kš
œ!˜!Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kšœœ
˜Kš
œ˜—K˜šœœ˜;Kš
œ#˜#Kš
œ˜—K˜Kšœœ˜K˜šœ	œœ˜Kš	œœ
œ
œ
œ
˜K˜—K˜šŸœœ*œœ˜YKš
˜Kšœ
œ˜(K˜Kšœœ˜#K˜(Kšœ#˜*Kš
œ˜Kšœ
˜—K˜šŸ	œœœœ˜;˜Kšœœ˜K˜—K˜—K˜šŸœœœœœœ˜GKšœœ
œ
˜%Kšœœœ˜>Kšœœ/˜CK˜—K˜š
Ÿœœœœœ˜?Kšœœ˜*Kšœœ*˜8Kšœœ
œ
˜%Kšœ
œ
œ
˜Kšœœ˜$Kšœœ˜$Kšœœœœ	˜DK˜—K˜šŸœœ0œ
œœœ˜oKš
˜Kšœ
œ˜(K˜Kšœœ
˜Kšœœ˜'K˜ Kšœ	œ˜%Kšœ
˜—K˜šŸœœ0œ
œœœ˜sKš
˜Kšœ
œ˜(K˜Kšœœ˜'Kš
œ
œœœ
œ
˜BKš
œ#˜#Kšœ
˜—K˜šŸœœœœ	œœ˜SKš
˜š	œ
œ.œœ
˜OKš
˜š
œ9œœ
œœ
œ˜qKšœ
˜
Kšœœ˜&Kšœœ˜Kšœ
˜—Kšœœ
˜Kšœ
˜Kšœ
˜—Kšœ
œ˜Kšœ
˜—K˜šŸœœ9œœ˜^Kš
˜Kšœ
œ˜'Kšœœ˜#š	œ
œ.œœ
˜Ošœœ+˜3Kšœœœ
œ
œ
œ
˜I—Kšœ
˜—Kšœ˜Kšœ
˜—K˜šŸœœ,œ
œœœ˜zKš
˜Kšœ
œ˜'Kšœœ
˜Kšœœ˜'K˜ Kš
œœ	œ
œœœ
œ
˜8K˜Kšœ
˜—K˜šŸœœ6œœ˜dKš
˜Kšœ
œ˜'Kšœœ
œœ˜%šœœ
˜Kšœ
œœœ
œœ
œ
˜NKšœ4˜:Kšœœ
˜Kšœ
˜—Kšœ˜
Kšœ
˜—K˜šŸœœœ
œœ
œ œ˜}Kš
˜Kšœœ
œœ˜$Kšœ
œ˜'K˜Kšœœ˜#Kš
œ˜Kšœ
˜—K˜Kš
œR˜RK˜Kšœ
˜—…—)6„