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