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