unit Myc.Ast.Types; interface uses System.SysUtils, System.Generics.Collections, System.Generics.Defaults, Myc.Data.Scalar, Myc.Data.Keyword; type // Forward declarations IStaticType = interface; ITupleType = interface; IVectorType = interface; IMatrixType = interface; ISeriesType = interface; IMethodType = interface; IRecordType = interface; IGenericRecordType = interface; TStaticTypeKind = ( stUnknown, stVoid, stOrdinal, stFloat, stBoolean, stDateTime, stText, stKeyword, stMethod, stSeries, stRecord, stRecordSeries, stGenericRecord, // New N-dimensional types stTuple, stVector, stMatrix ); TStaticTypeKindHelper = record helper for TStaticTypeKind public function ToString: string; end; IMethodSignature = interface {$region 'private'} function GetParamTypes: TArray; function GetReturnType: IStaticType; {$endregion} property ParamTypes: TArray read GetParamTypes; property ReturnType: IStaticType read GetReturnType; function GetHashCode: Integer; end; IGenericRecordDefinition = IKeywordMapping; TGenericRecordRegistry = TKeywordMappingRegistry; IScalarRecordDefinition = Myc.Data.Scalar.IScalarRecordDefinition; // Base Interface IStaticType = interface {$region 'private'} function GetKind: TStaticTypeKind; function GetIsOptional: Boolean; function GetIsScalarPure: Boolean; {$endregion} property Kind: TStaticTypeKind read GetKind; property IsOptional: Boolean read GetIsOptional; property IsScalarPure: Boolean read GetIsScalarPure; function IsEqual(const Other: IStaticType): Boolean; function IsStructurallyEqual(const Other: IStaticType): Boolean; function ToString: string; function GetHashCode: Integer; // Hard casts to specialized interfaces function AsTuple: ITupleType; function AsVector: IVectorType; function AsMatrix: IMatrixType; function AsSeries: ISeriesType; function AsMethod: IMethodType; function AsRecord: IRecordType; function AsGenericRecord: IGenericRecordType; end; // --- Specialized Interfaces --- ITupleType = interface(IStaticType) {$region 'private'} function GetElements: TArray; function GetCount: Integer; {$endregion} property Elements: TArray read GetElements; property Count: Integer read GetCount; end; IVectorType = interface(IStaticType) {$region 'private'} function GetElementType: IStaticType; function GetCount: Integer; {$endregion} property ElementType: IStaticType read GetElementType; property Count: Integer read GetCount; end; IMatrixType = interface(IStaticType) {$region 'private'} function GetElementType: IStaticType; function GetDimensions: TArray; {$endregion} property ElementType: IStaticType read GetElementType; property Dimensions: TArray read GetDimensions; end; ISeriesType = interface(IStaticType) {$region 'private'} function GetElementType: IStaticType; {$endregion} property ElementType: IStaticType read GetElementType; end; IMethodType = interface(IStaticType) {$region 'private'} function GetSignatures: TArray; {$endregion} property Signatures: TArray read GetSignatures; end; IRecordType = interface(IStaticType) {$region 'private'} function GetDefinition: IScalarRecordDefinition; {$endregion} property Definition: IScalarRecordDefinition read GetDefinition; end; IGenericRecordType = interface(IStaticType) {$region 'private'} function GetGenericDefinition: IGenericRecordDefinition; {$endregion} property GenericDefinition: IGenericRecordDefinition read GetGenericDefinition; end; // --- Factory --- TTypes = record private class var FUnknown: IStaticType; class var FVoid: IStaticType; class var FOrdinal: IStaticType; class var FFloat: IStaticType; class var FBoolean: IStaticType; class var FDateTime: IStaticType; class var FText: IStaticType; class var FKeyword: IStaticType; class var FOrdinalOpt: IStaticType; class var FFloatOpt: IStaticType; class var FBooleanOpt: IStaticType; class var FDateTimeOpt: IStaticType; class var FTextOpt: IStaticType; class var FKeywordOpt: IStaticType; class var FSeriesCache: TDictionary; class var FRecordCache: TDictionary; class var FRecordSeriesCache: TDictionary; class var FGenericRecordCache: TDictionary; class var FMethodCache: TDictionary, IStaticType>; class var FOptionalCache: TDictionary; class constructor Create; class destructor Destroy; public class property Unknown: IStaticType read FUnknown; class property Void: IStaticType read FVoid; class property Ordinal: IStaticType read FOrdinal; class property Float: IStaticType read FFloat; class property Boolean: IStaticType read FBoolean; class property DateTime: IStaticType read FDateTime; class property Text: IStaticType read FText; class property Keyword: IStaticType read FKeyword; class property OrdinalOpt: IStaticType read FOrdinalOpt; class property FloatOpt: IStaticType read FFloatOpt; class property BooleanOpt: IStaticType read FBooleanOpt; class property DateTimeOpt: IStaticType read FDateTimeOpt; class property TextOpt: IStaticType read FTextOpt; class property KeywordOpt: IStaticType read FKeywordOpt; class function CreateSeries(const AElementType: IStaticType): IStaticType; static; class function CreateMethod(const AParamTypes: TArray; const AReturnType: IStaticType): IStaticType; static; class function CreateMethodSet(const ASignatures: TArray): IStaticType; static; class function CreateRecord(const ADef: IScalarRecordDefinition): IStaticType; static; class function CreateRecordSeries(const ADef: IScalarRecordDefinition): IStaticType; static; class function CreateGenericRecord(const ADef: IGenericRecordDefinition): IStaticType; static; class function CreateTuple(const AElements: TArray): ITupleType; static; class function CreateVector(const AElementType: IStaticType; ACount: Integer): IVectorType; static; class function CreateMatrix(const AElementType: IStaticType; const ADimensions: TArray): IMatrixType; static; class function MakeOptional(const AType: IStaticType): IStaticType; static; class function Unwrap(const AType: IStaticType): IStaticType; static; class function FromScalarKind(AKind: TScalar.TKind): IStaticType; static; end; TTypeRules = record public class function Promote(const A, B: IStaticType): IStaticType; static; class function CanAssign(const Target, Source: IStaticType): Boolean; static; class function ResolveBinaryOp(Op: TScalar.TBinaryOp; const Left, Right: IStaticType): IStaticType; static; class function ResolveUnaryOp(Op: TScalar.TUnaryOp; const Right: IStaticType): IStaticType; static; end; TMethodSignature = class(TInterfacedObject, IMethodSignature) private FParamTypes: TArray; FReturnType: IStaticType; function GetParamTypes: TArray; function GetReturnType: IStaticType; public constructor Create(const AParamTypes: TArray; const AReturnType: IStaticType); function GetHashCode: Integer; override; end; implementation uses System.Hash; { TStaticTypeKindHelper } function TStaticTypeKindHelper.ToString: string; begin case Self of stUnknown: Result := 'Unknown'; stVoid: Result := 'Void'; stOrdinal: Result := 'Ordinal'; stFloat: Result := 'Float'; stBoolean: Result := 'Boolean'; stDateTime: Result := 'DateTime'; stText: Result := 'Text'; stKeyword: Result := 'Keyword'; stMethod: Result := 'Method'; stSeries: Result := 'Series'; stRecord: Result := 'Record'; stRecordSeries: Result := 'RecordSeries'; stGenericRecord: Result := 'GenericRecord'; stTuple: Result := 'Tuple'; stVector: Result := 'Vector'; stMatrix: Result := 'Matrix'; else Result := 'ErrorType'; end; end; // --- Abstract Base Implementation --- type TAbstractStaticType = class(TInterfacedObject, IStaticType) protected function GetKind: TStaticTypeKind; virtual; abstract; function GetIsOptional: Boolean; virtual; function GetIsScalarPure: Boolean; virtual; function IsEqual(const Other: IStaticType): Boolean; virtual; function IsStructurallyEqual(const Other: IStaticType): Boolean; virtual; function GetHashCode: Integer; override; abstract; function ToString: string; override; function AsTuple: ITupleType; virtual; function AsVector: IVectorType; virtual; function AsMatrix: IMatrixType; virtual; function AsSeries: ISeriesType; virtual; function AsMethod: IMethodType; virtual; function AsRecord: IRecordType; virtual; function AsGenericRecord: IGenericRecordType; virtual; end; function TAbstractStaticType.GetIsOptional: Boolean; begin Result := False; end; function TAbstractStaticType.GetIsScalarPure: Boolean; begin Result := False; end; function TAbstractStaticType.IsStructurallyEqual(const Other: IStaticType): Boolean; begin if not Assigned(Other) then exit(False); Result := (GetKind = TTypes.Unwrap(Other).Kind); end; function TAbstractStaticType.IsEqual(const Other: IStaticType): Boolean; begin if not Assigned(Other) then exit(False); if GetIsOptional <> Other.IsOptional then exit(False); Result := IsStructurallyEqual(Other); end; function TAbstractStaticType.ToString: string; begin Result := GetKind.ToString; end; // Cast Defaults function TAbstractStaticType.AsTuple: ITupleType; begin raise EInvalidCast.Create('Type is not a Tuple.'); end; function TAbstractStaticType.AsVector: IVectorType; begin raise EInvalidCast.Create('Type is not a Vector.'); end; function TAbstractStaticType.AsMatrix: IMatrixType; begin raise EInvalidCast.Create('Type is not a Matrix.'); end; function TAbstractStaticType.AsSeries: ISeriesType; begin raise EInvalidCast.Create('Type is not a Series.'); end; function TAbstractStaticType.AsMethod: IMethodType; begin raise EInvalidCast.Create('Type is not a Method.'); end; function TAbstractStaticType.AsRecord: IRecordType; begin raise EInvalidCast.Create('Type is not a Record.'); end; function TAbstractStaticType.AsGenericRecord: IGenericRecordType; begin raise EInvalidCast.Create('Type is not a Generic Record.'); end; // --- Optional Type Decorator --- type TOptionalType = class(TInterfacedObject, IStaticType) private FInner: IStaticType; public constructor Create(const AInner: IStaticType); function GetKind: TStaticTypeKind; function GetIsOptional: Boolean; function GetIsScalarPure: Boolean; function IsStructurallyEqual(const Other: IStaticType): Boolean; function IsEqual(const Other: IStaticType): Boolean; function GetHashCode: Integer; override; function ToString: string; override; function AsTuple: ITupleType; function AsVector: IVectorType; function AsMatrix: IMatrixType; function AsSeries: ISeriesType; function AsMethod: IMethodType; function AsRecord: IRecordType; function AsGenericRecord: IGenericRecordType; end; constructor TOptionalType.Create(const AInner: IStaticType); begin inherited Create; FInner := AInner; end; function TOptionalType.GetKind: TStaticTypeKind; begin Result := FInner.Kind; end; function TOptionalType.GetIsOptional: Boolean; begin Result := True; end; function TOptionalType.GetIsScalarPure: Boolean; begin Result := False; end; function TOptionalType.IsStructurallyEqual(const Other: IStaticType): Boolean; begin Result := FInner.IsStructurallyEqual(TTypes.Unwrap(Other)); end; function TOptionalType.IsEqual(const Other: IStaticType): Boolean; begin if not Assigned(Other) then exit(False); if not Other.IsOptional then exit(False); Result := IsStructurallyEqual(Other); end; function TOptionalType.GetHashCode: Integer; var h: Integer; optionalMarker: Integer; begin h := FInner.GetHashCode; optionalMarker := $11111111; Result := THashBobJenkins.GetHashValue(optionalMarker, SizeOf(Integer), h); end; function TOptionalType.ToString: string; begin Result := FInner.ToString + '?'; end; // Delegation function TOptionalType.AsTuple: ITupleType; begin Result := FInner.AsTuple; end; function TOptionalType.AsVector: IVectorType; begin Result := FInner.AsVector; end; function TOptionalType.AsMatrix: IMatrixType; begin Result := FInner.AsMatrix; end; function TOptionalType.AsSeries: ISeriesType; begin Result := FInner.AsSeries; end; function TOptionalType.AsMethod: IMethodType; begin Result := FInner.AsMethod; end; function TOptionalType.AsRecord: IRecordType; begin Result := FInner.AsRecord; end; function TOptionalType.AsGenericRecord: IGenericRecordType; begin Result := FInner.AsGenericRecord; end; // --- Simple (Flyweight) Type Implementations --- type TSimpleStaticType = class(TAbstractStaticType) private FKind: TStaticTypeKind; public constructor Create(AKind: TStaticTypeKind); function GetKind: TStaticTypeKind; override; function GetIsScalarPure: Boolean; override; function GetHashCode: Integer; override; end; constructor TSimpleStaticType.Create(AKind: TStaticTypeKind); begin inherited Create; FKind := AKind; end; function TSimpleStaticType.GetKind: TStaticTypeKind; begin Result := FKind; end; function TSimpleStaticType.GetIsScalarPure: Boolean; begin Result := FKind in [stOrdinal, stFloat, stBoolean, stDateTime, stKeyword]; end; function TSimpleStaticType.GetHashCode: Integer; begin Result := THashBobJenkins.GetHashValue(FKind, SizeOf(TStaticTypeKind), 0); end; // --- Complex Type Implementations --- type TSeriesType = class(TAbstractStaticType, ISeriesType) private FElementType: IStaticType; public constructor Create(AElementType: IStaticType); function GetKind: TStaticTypeKind; override; function GetElementType: IStaticType; function IsStructurallyEqual(const Other: IStaticType): Boolean; override; function GetHashCode: Integer; override; function ToString: string; override; function AsSeries: ISeriesType; override; end; constructor TSeriesType.Create(AElementType: IStaticType); begin inherited Create; FElementType := AElementType; end; function TSeriesType.GetKind: TStaticTypeKind; begin Result := stSeries; end; function TSeriesType.GetElementType: IStaticType; begin Result := FElementType; end; function TSeriesType.AsSeries: ISeriesType; begin Result := Self; end; function TSeriesType.IsStructurallyEqual(const Other: IStaticType): Boolean; begin var uOther := TTypes.Unwrap(Other); if uOther.Kind <> stSeries then exit(False); Result := FElementType.IsEqual(uOther.AsSeries.ElementType); end; function TSeriesType.GetHashCode: Integer; var h: Integer; begin h := Ord(stSeries); Result := THashBobJenkins.GetHashValue(h, SizeOf(TStaticTypeKind), 0); if Assigned(FElementType) then begin h := FElementType.GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); end; end; function TSeriesType.ToString: string; begin Result := inherited + '<' + FElementType.ToString + '>'; end; // --- Tuple --- type TTupleType = class(TAbstractStaticType, ITupleType) private FElements: TArray; public constructor Create(const AElements: TArray); function GetKind: TStaticTypeKind; override; function GetIsScalarPure: Boolean; override; function GetElements: TArray; function GetCount: Integer; function IsStructurallyEqual(const Other: IStaticType): Boolean; override; function GetHashCode: Integer; override; function ToString: string; override; function AsTuple: ITupleType; override; end; constructor TTupleType.Create(const AElements: TArray); begin inherited Create; FElements := AElements; end; function TTupleType.GetKind: TStaticTypeKind; begin Result := stTuple; end; function TTupleType.GetIsScalarPure: Boolean; begin for var elem in FElements do if not elem.IsScalarPure then exit(False); Result := True; end; function TTupleType.GetElements: TArray; begin Result := FElements; end; function TTupleType.GetCount: Integer; begin Result := Length(FElements); end; function TTupleType.AsTuple: ITupleType; begin Result := Self; end; function TTupleType.IsStructurallyEqual(const Other: IStaticType): Boolean; var otherTuple: ITupleType; i: Integer; begin var uOther := TTypes.Unwrap(Other); if uOther.Kind <> stTuple then exit(False); otherTuple := uOther.AsTuple; if Length(FElements) <> otherTuple.Count then exit(False); for i := 0 to High(FElements) do if not FElements[i].IsEqual(otherTuple.Elements[i]) then exit(False); Result := True; end; function TTupleType.GetHashCode: Integer; var h, i: Integer; begin h := Ord(stTuple); Result := THashBobJenkins.GetHashValue(h, SizeOf(TStaticTypeKind), 0); for i := 0 to High(FElements) do begin h := FElements[i].GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); end; end; function TTupleType.ToString: string; var sb: TStringBuilder; i: Integer; begin sb := TStringBuilder.Create; try sb.Append('['); for i := 0 to High(FElements) do begin sb.Append(FElements[i].ToString); if i < High(FElements) then sb.Append(', '); end; sb.Append(']'); Result := sb.ToString; finally sb.Free; end; end; // --- Vector --- type TVectorType = class(TAbstractStaticType, IVectorType) private FElementType: IStaticType; FCount: Integer; public constructor Create(const AElementType: IStaticType; ACount: Integer); function GetKind: TStaticTypeKind; override; function GetIsScalarPure: Boolean; override; function GetElementType: IStaticType; function GetCount: Integer; function IsStructurallyEqual(const Other: IStaticType): Boolean; override; function GetHashCode: Integer; override; function ToString: string; override; function AsVector: IVectorType; override; end; constructor TVectorType.Create(const AElementType: IStaticType; ACount: Integer); begin inherited Create; FElementType := AElementType; FCount := ACount; end; function TVectorType.GetKind: TStaticTypeKind; begin Result := stVector; end; function TVectorType.GetIsScalarPure: Boolean; begin Result := FElementType.IsScalarPure; end; function TVectorType.GetElementType: IStaticType; begin Result := FElementType; end; function TVectorType.GetCount: Integer; begin Result := FCount; end; function TVectorType.AsVector: IVectorType; begin Result := Self; end; function TVectorType.IsStructurallyEqual(const Other: IStaticType): Boolean; var otherVec: IVectorType; begin var uOther := TTypes.Unwrap(Other); if uOther.Kind <> stVector then exit(False); otherVec := uOther.AsVector; Result := (FCount = otherVec.Count) and (FElementType.IsEqual(otherVec.ElementType)); end; function TVectorType.GetHashCode: Integer; var h: Integer; begin h := Ord(stVector); Result := THashBobJenkins.GetHashValue(h, SizeOf(TStaticTypeKind), 0); h := FElementType.GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); Result := THashBobJenkins.GetHashValue(FCount, SizeOf(Integer), Result); end; function TVectorType.ToString: string; begin Result := inherited + Format('[%s; %d]', [FElementType.ToString, FCount]); end; // --- Matrix --- type TMatrixType = class(TAbstractStaticType, IMatrixType) private FElementType: IStaticType; FDimensions: TArray; public constructor Create(const AElementType: IStaticType; const ADimensions: TArray); function GetKind: TStaticTypeKind; override; function GetIsScalarPure: Boolean; override; function GetElementType: IStaticType; function GetDimensions: TArray; function IsStructurallyEqual(const Other: IStaticType): Boolean; override; function GetHashCode: Integer; override; function ToString: string; override; function AsMatrix: IMatrixType; override; end; constructor TMatrixType.Create(const AElementType: IStaticType; const ADimensions: TArray); begin inherited Create; FElementType := AElementType; FDimensions := ADimensions; end; function TMatrixType.GetKind: TStaticTypeKind; begin Result := stMatrix; end; function TMatrixType.GetIsScalarPure: Boolean; begin Result := FElementType.IsScalarPure; end; function TMatrixType.GetElementType: IStaticType; begin Result := FElementType; end; function TMatrixType.GetDimensions: TArray; begin Result := FDimensions; end; function TMatrixType.AsMatrix: IMatrixType; begin Result := Self; end; function TMatrixType.IsStructurallyEqual(const Other: IStaticType): Boolean; var otherMat: IMatrixType; i: Integer; dims: TArray; begin var uOther := TTypes.Unwrap(Other); if uOther.Kind <> stMatrix then exit(False); otherMat := uOther.AsMatrix; if not FElementType.IsEqual(otherMat.ElementType) then exit(False); dims := otherMat.Dimensions; if Length(FDimensions) <> Length(dims) then exit(False); for i := 0 to High(FDimensions) do if FDimensions[i] <> dims[i] then exit(False); Result := True; end; function TMatrixType.GetHashCode: Integer; var h, i: Integer; begin h := Ord(stMatrix); Result := THashBobJenkins.GetHashValue(h, SizeOf(TStaticTypeKind), 0); h := FElementType.GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); for i := 0 to High(FDimensions) do Result := THashBobJenkins.GetHashValue(FDimensions[i], SizeOf(Integer), Result); end; function TMatrixType.ToString: string; var sb: TStringBuilder; i: Integer; begin sb := TStringBuilder.Create; try sb.Append('['); sb.Append(FElementType.ToString); sb.Append('; '); for i := 0 to High(FDimensions) do begin sb.Append(FDimensions[i]); if i < High(FDimensions) then sb.Append('x'); end; sb.Append(']'); Result := inherited + sb.ToString; finally sb.Free; end; end; // --- Method Type --- type TMethodType = class(TAbstractStaticType, IMethodType) private FSignatures: TArray; function SignatureToString(const Sig: IMethodSignature): string; public constructor Create(const ASignatures: TArray); function GetKind: TStaticTypeKind; override; function GetSignatures: TArray; function IsStructurallyEqual(const Other: IStaticType): Boolean; override; function GetHashCode: Integer; override; function ToString: string; override; function AsMethod: IMethodType; override; end; constructor TMethodType.Create(const ASignatures: TArray); begin inherited Create; Assert(Length(ASignatures) > 0, 'Cannot create a method type with zero signatures'); FSignatures := ASignatures; end; function TMethodType.GetKind: TStaticTypeKind; begin Result := stMethod; end; function TMethodType.GetSignatures: TArray; begin Result := FSignatures; end; function TMethodType.AsMethod: IMethodType; begin Result := Self; end; function TMethodType.SignatureToString(const Sig: IMethodSignature): string; var i: Integer; paramStr: string; begin paramStr := ''; for i := 0 to High(Sig.ParamTypes) do begin paramStr := paramStr + Sig.ParamTypes[i].ToString; if i < High(Sig.ParamTypes) then paramStr := paramStr + ', '; end; Result := Format('Method(%s): %s', [paramStr, Sig.ReturnType.ToString]); end; function TMethodType.IsStructurallyEqual(const Other: IStaticType): Boolean; var otherMeth: IMethodType; i, j: Integer; s1, s2: IMethodSignature; begin var uOther := TTypes.Unwrap(Other); if uOther.Kind <> stMethod then exit(False); otherMeth := uOther.AsMethod; if Length(FSignatures) <> Length(otherMeth.Signatures) then exit(False); for i := 0 to High(FSignatures) do begin s1 := FSignatures[i]; s2 := otherMeth.Signatures[i]; if not s1.ReturnType.IsEqual(s2.ReturnType) then exit(False); if Length(s1.ParamTypes) <> Length(s2.ParamTypes) then exit(False); for j := 0 to High(s1.ParamTypes) do if not s1.ParamTypes[j].IsEqual(s2.ParamTypes[j]) then exit(False); end; Result := True; end; function TMethodType.GetHashCode: Integer; var h: Integer; sig: IMethodSignature; begin h := Ord(stMethod); Result := THashBobJenkins.GetHashValue(h, SizeOf(TStaticTypeKind), 0); for sig in FSignatures do begin if Assigned(sig) then begin h := sig.GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); end; end; end; function TMethodType.ToString: string; var sb: TStringBuilder; sig: IMethodSignature; begin if Length(FSignatures) = 1 then begin Result := SignatureToString(FSignatures[0]); end else begin sb := TStringBuilder.Create; try sb.Append('Method{'); for sig in FSignatures do begin sb.Append('('); sb.Append(SignatureToString(sig)); sb.Append('), '); end; sb.Remove(sb.Length - 2, 2); sb.Append('}'); Result := sb.ToString; finally sb.Free; end; end; end; // --- Record Type --- type TRecordType = class(TAbstractStaticType, IRecordType) private FKind: TStaticTypeKind; FDefinition: IScalarRecordDefinition; public constructor Create(AKind: TStaticTypeKind; ADef: IScalarRecordDefinition); function GetKind: TStaticTypeKind; override; function GetDefinition: IScalarRecordDefinition; function GetHashCode: Integer; override; function AsRecord: IRecordType; override; function IsStructurallyEqual(const Other: IStaticType): Boolean; override; function ToString: string; override; end; constructor TRecordType.Create(AKind: TStaticTypeKind; ADef: IScalarRecordDefinition); begin inherited Create; Assert(AKind in [stRecord, stRecordSeries]); FKind := AKind; FDefinition := ADef; end; function TRecordType.GetKind: TStaticTypeKind; begin Result := FKind; end; function TRecordType.GetDefinition: IScalarRecordDefinition; begin Result := FDefinition; end; function TRecordType.AsRecord: IRecordType; begin Result := Self; end; function TRecordType.IsStructurallyEqual(const Other: IStaticType): Boolean; var i: Integer; begin var uOther := TTypes.Unwrap(Other); if uOther.Kind <> FKind then exit(False); var otherDef := uOther.AsRecord.Definition; if (not Assigned(Self.FDefinition)) or (not Assigned(otherDef)) then exit(False); if Self.FDefinition.Count <> otherDef.Count then exit(False); for i := 0 to Self.FDefinition.Count - 1 do begin if (Self.FDefinition.Keywords[i] <> otherDef.Keywords[i]) or (Self.FDefinition[i] <> otherDef[i]) then exit(False); end; Result := True; end; function TRecordType.GetHashCode: Integer; var i, h: Integer; begin Result := THashBobJenkins.GetHashValue(FKind, SizeOf(TStaticTypeKind), 0); if Assigned(FDefinition) then begin for i := 0 to FDefinition.Count - 1 do begin h := FDefinition.Keywords[i].Idx; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); h := Ord(FDefinition[i]); Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); end; end; end; function TRecordType.ToString: string; var i: Integer; begin Result := GetKind.ToString + '{'; if Assigned(FDefinition) then begin for i := 0 to FDefinition.Count - 1 do begin Result := Result + FDefinition.Keywords[i].Name + ': ' + FDefinition[i].ToString; if i < FDefinition.Count - 1 then Result := Result + ', '; end; end; Result := Result + '}'; end; // --- Generic Record Type --- type TGenericRecordType = class(TAbstractStaticType, IGenericRecordType) private FDefinition: IGenericRecordDefinition; public constructor Create(const ADef: IGenericRecordDefinition); function GetKind: TStaticTypeKind; override; function GetGenericDefinition: IGenericRecordDefinition; function GetHashCode: Integer; override; function AsGenericRecord: IGenericRecordType; override; function IsStructurallyEqual(const Other: IStaticType): Boolean; override; function ToString: string; override; end; constructor TGenericRecordType.Create(const ADef: IGenericRecordDefinition); begin inherited Create; FDefinition := ADef; end; function TGenericRecordType.GetKind: TStaticTypeKind; begin Result := stGenericRecord; end; function TGenericRecordType.GetGenericDefinition: IGenericRecordDefinition; begin Result := FDefinition; end; function TGenericRecordType.AsGenericRecord: IGenericRecordType; begin Result := Self; end; function TGenericRecordType.IsStructurallyEqual(const Other: IStaticType): Boolean; var i: Integer; begin var uOther := TTypes.Unwrap(Other); if uOther.Kind <> stGenericRecord then exit(False); var otherDef := uOther.AsGenericRecord.GenericDefinition; if (not Assigned(Self.FDefinition)) or (not Assigned(otherDef)) then exit(False); if Self.FDefinition.Count <> otherDef.Count then exit(False); for i := 0 to Self.FDefinition.Count - 1 do begin if (Self.FDefinition.Keywords[i] <> otherDef.Keywords[i]) or (not Self.FDefinition[i].IsEqual(otherDef[i])) then exit(False); end; Result := True; end; function TGenericRecordType.GetHashCode: Integer; var i, h: Integer; begin h := Ord(stGenericRecord); Result := THashBobJenkins.GetHashValue(h, SizeOf(TStaticTypeKind), 0); if Assigned(FDefinition) then begin for i := 0 to FDefinition.Count - 1 do begin h := FDefinition.Keywords[i].Idx; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); var val := FDefinition[i]; if Assigned(val) then begin h := val.GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); end; end; end; end; function TGenericRecordType.ToString: string; var i: Integer; begin Result := GetKind.ToString + '{'; if Assigned(FDefinition) then begin for i := 0 to FDefinition.Count - 1 do begin Result := Result + FDefinition.Keywords[i].Name + ': ' + FDefinition[i].ToString; if i < FDefinition.Count - 1 then Result := Result + ', '; end; end; Result := Result + '}'; end; // --- TMethodSigArrayComparer --- type TMethodSigArrayComparer = class(TEqualityComparer>) public function Equals(const Left, Right: TArray): Boolean; override; function GetHashCode(const Value: TArray): Integer; override; end; function TMethodSigArrayComparer.Equals(const Left, Right: TArray): Boolean; var i, j: Integer; begin if Length(Left) <> Length(Right) then exit(False); for i := 0 to High(Left) do begin if not Left[i].ReturnType.IsEqual(Right[i].ReturnType) then exit(False); var pLeft := Left[i].ParamTypes; var pRight := Right[i].ParamTypes; if Length(pLeft) <> Length(pRight) then exit(False); for j := 0 to High(pLeft) do if not pLeft[j].IsEqual(pRight[j]) then exit(False); end; Result := True; end; function TMethodSigArrayComparer.GetHashCode(const Value: TArray): Integer; var sig: IMethodSignature; p: IStaticType; h: Integer; begin Result := 0; for sig in Value do begin if Assigned(sig.ReturnType) then begin h := sig.ReturnType.GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); end; for p in sig.ParamTypes do begin h := p.GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); end; end; end; { TMethodSignature } constructor TMethodSignature.Create(const AParamTypes: TArray; const AReturnType: IStaticType); begin inherited Create; FParamTypes := AParamTypes; FReturnType := AReturnType; end; function TMethodSignature.GetParamTypes: TArray; begin Result := FParamTypes; end; function TMethodSignature.GetReturnType: IStaticType; begin Result := FReturnType; end; function TMethodSignature.GetHashCode: Integer; var i, h: Integer; begin Result := 0; if Assigned(FReturnType) then begin h := FReturnType.GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); end; for i := 0 to High(FParamTypes) do begin if Assigned(FParamTypes[i]) then begin h := FParamTypes[i].GetHashCode; Result := THashBobJenkins.GetHashValue(h, SizeOf(Integer), Result); end; end; end; { TTypes Factory } class constructor TTypes.Create; begin FUnknown := TSimpleStaticType.Create(stUnknown); FVoid := TSimpleStaticType.Create(stVoid); FOrdinal := TSimpleStaticType.Create(stOrdinal); FFloat := TSimpleStaticType.Create(stFloat); FBoolean := TSimpleStaticType.Create(stBoolean); FDateTime := TSimpleStaticType.Create(stDateTime); FText := TSimpleStaticType.Create(stText); FKeyword := TSimpleStaticType.Create(stKeyword); FOrdinalOpt := TOptionalType.Create(FOrdinal); FFloatOpt := TOptionalType.Create(FFloat); FBooleanOpt := TOptionalType.Create(FBoolean); FDateTimeOpt := TOptionalType.Create(FDateTime); FTextOpt := TOptionalType.Create(FText); FKeywordOpt := TOptionalType.Create(FKeyword); FSeriesCache := TDictionary.Create; FRecordCache := TDictionary.Create; FRecordSeriesCache := TDictionary.Create; FGenericRecordCache := TDictionary.Create; FMethodCache := TDictionary, IStaticType>.Create(TMethodSigArrayComparer.Create); FOptionalCache := TDictionary.Create; end; class destructor TTypes.Destroy; begin FSeriesCache.Free; FRecordCache.Free; FRecordSeriesCache.Free; FGenericRecordCache.Free; FMethodCache.Free; FOptionalCache.Free; end; class function TTypes.CreateSeries(const AElementType: IStaticType): IStaticType; begin if not Assigned(AElementType) then exit(FUnknown); TMonitor.Enter(FSeriesCache); try if not FSeriesCache.TryGetValue(AElementType, Result) then begin Result := TSeriesType.Create(AElementType); FSeriesCache.Add(AElementType, Result); end; finally TMonitor.Exit(FSeriesCache); end; end; class function TTypes.CreateRecord(const ADef: IScalarRecordDefinition): IStaticType; begin TMonitor.Enter(FRecordCache); try if not FRecordCache.TryGetValue(ADef, Result) then begin Result := TRecordType.Create(stRecord, ADef); FRecordCache.Add(ADef, Result); end; finally TMonitor.Exit(FRecordCache); end; end; class function TTypes.CreateRecordSeries(const ADef: IScalarRecordDefinition): IStaticType; begin TMonitor.Enter(FRecordSeriesCache); try if not FRecordSeriesCache.TryGetValue(ADef, Result) then begin Result := TRecordType.Create(stRecordSeries, ADef); FRecordSeriesCache.Add(ADef, Result); end; finally TMonitor.Exit(FRecordSeriesCache); end; end; class function TTypes.CreateGenericRecord(const ADef: IGenericRecordDefinition): IStaticType; begin TMonitor.Enter(FGenericRecordCache); try if not FGenericRecordCache.TryGetValue(ADef, Result) then begin Result := TGenericRecordType.Create(ADef); FGenericRecordCache.Add(ADef, Result); end; finally TMonitor.Exit(FGenericRecordCache); end; end; class function TTypes.CreateMethod(const AParamTypes: TArray; const AReturnType: IStaticType): IStaticType; begin Result := CreateMethodSet([TMethodSignature.Create(AParamTypes, AReturnType)]); end; class function TTypes.CreateMethodSet(const ASignatures: TArray): IStaticType; begin if Length(ASignatures) = 0 then exit(FUnknown); TMonitor.Enter(FMethodCache); try if not FMethodCache.TryGetValue(ASignatures, Result) then begin Result := TMethodType.Create(ASignatures); FMethodCache.Add(ASignatures, Result); end; finally TMonitor.Exit(FMethodCache); end; end; class function TTypes.MakeOptional(const AType: IStaticType): IStaticType; begin if (not Assigned(AType)) or (AType.Kind = stUnknown) or (AType.Kind = stVoid) then exit(AType); if AType.IsOptional then exit(AType); // Fast path flyweights if Pointer(AType) = Pointer(FOrdinal) then exit(FOrdinalOpt); if Pointer(AType) = Pointer(FFloat) then exit(FFloatOpt); if Pointer(AType) = Pointer(FBoolean) then exit(FBooleanOpt); if Pointer(AType) = Pointer(FDateTime) then exit(FDateTimeOpt); if Pointer(AType) = Pointer(FText) then exit(FTextOpt); if Pointer(AType) = Pointer(FKeyword) then exit(FKeywordOpt); TMonitor.Enter(FOptionalCache); try if not FOptionalCache.TryGetValue(AType, Result) then begin Result := TOptionalType.Create(AType); FOptionalCache.Add(AType, Result); end; finally TMonitor.Exit(FOptionalCache); end; end; class function TTypes.Unwrap(const AType: IStaticType): IStaticType; begin if (Assigned(AType)) and (AType is TOptionalType) then Result := (AType as TOptionalType).FInner else Result := AType; end; class function TTypes.FromScalarKind(AKind: TScalar.TKind): IStaticType; begin case AKind of TScalar.TKind.Ordinal: Result := FOrdinal; TScalar.TKind.Float: Result := FFloat; TScalar.TKind.Keyword: Result := FKeyword; TScalar.TKind.Boolean: Result := FBoolean; TScalar.TKind.DateTime: Result := FDateTime; else Result := nil; end; end; // --- New Factories --- class function TTypes.CreateTuple(const AElements: TArray): ITupleType; begin Result := TTupleType.Create(AElements); end; class function TTypes.CreateVector(const AElementType: IStaticType; ACount: Integer): IVectorType; begin Result := TVectorType.Create(AElementType, ACount); end; class function TTypes.CreateMatrix(const AElementType: IStaticType; const ADimensions: TArray): IMatrixType; begin Result := TMatrixType.Create(AElementType, ADimensions); end; { TTypeRules } class function TTypeRules.CanAssign(const Target, Source: IStaticType): Boolean; begin if (not Assigned(Target)) or (not Assigned(Source)) then exit(False); if (Target.Kind = stUnknown) or (Source.Kind = stUnknown) then exit(True); if Source.IsOptional and (not Target.IsOptional) then exit(False); var uTarget := TTypes.Unwrap(Target); var uSource := TTypes.Unwrap(Source); if uTarget.IsStructurallyEqual(uSource) then exit(True); // Auto-Promotion rules if (uTarget.Kind = stFloat) and (uSource.Kind = stOrdinal) then exit(True); if (uTarget.Kind = stOrdinal) and (uSource.Kind = stBoolean) then exit(True); if (uTarget.Kind = stFloat) and (uSource.Kind = stDateTime) then exit(True); if (uTarget.Kind = stVoid) and (uSource.Kind = stMethod) then exit(True); if (uTarget.Kind = stOrdinal) and (uSource.Kind = stKeyword) then exit(True); Result := False; end; class function TTypeRules.Promote(const A, B: IStaticType): IStaticType; begin if A.Kind = stUnknown then exit(B); if B.Kind = stUnknown then exit(A); if (A.Kind = stVoid) and (B.Kind <> stVoid) then exit(TTypes.MakeOptional(B)); if (B.Kind = stVoid) and (A.Kind <> stVoid) then exit(TTypes.MakeOptional(A)); if (A.Kind = stVoid) and (B.Kind = stVoid) then exit(TTypes.Void); var uA := TTypes.Unwrap(A); var uB := TTypes.Unwrap(B); var common: IStaticType := nil; if uA.IsStructurallyEqual(uB) then common := uA else if (uA.Kind = stFloat) and (uB.Kind = stFloat) then common := TTypes.Float else if (uA.Kind = stFloat) and (uB.Kind = stOrdinal) then common := TTypes.Float else if (uA.Kind = stOrdinal) and (uB.Kind = stFloat) then common := TTypes.Float else if (uA.Kind = stOrdinal) and (uB.Kind = stOrdinal) then common := TTypes.Ordinal; if common = nil then exit(nil); if A.IsOptional or B.IsOptional then Result := TTypes.MakeOptional(common) else Result := common; end; class function TTypeRules.ResolveBinaryOp(Op: TScalar.TBinaryOp; const Left, Right: IStaticType): IStaticType; begin if Left.IsOptional or Right.IsOptional then exit(nil); var promotedType := Promote(Left, Right); if not Assigned(promotedType) then exit(nil); if promotedType.Kind = stUnknown then exit(TTypes.Unknown); var promotedKind := promotedType.Kind; case Op of TScalar.TBinaryOp.Add, TScalar.TBinaryOp.Subtract, TScalar.TBinaryOp.Multiply: begin if not (promotedKind in [stOrdinal, stFloat, stDateTime]) then exit(nil); Result := promotedType; end; TScalar.TBinaryOp.Divide: begin if not (promotedKind in [stOrdinal, stFloat, stDateTime]) then exit(nil); Result := TTypes.Float; end; TScalar.TBinaryOp.Equal, TScalar.TBinaryOp.NotEqual: begin if not (promotedKind in [stOrdinal, stFloat, stKeyword, stBoolean, stDateTime]) then exit(nil); Result := TTypes.Boolean; end; TScalar.TBinaryOp.Less, TScalar.TBinaryOp.Greater, TScalar.TBinaryOp.LessOrEqual, TScalar.TBinaryOp.GreaterOrEqual: begin if not (promotedKind in [stOrdinal, stFloat, stDateTime]) then exit(nil); Result := TTypes.Boolean; end; else Result := nil; end; end; class function TTypeRules.ResolveUnaryOp(Op: TScalar.TUnaryOp; const Right: IStaticType): IStaticType; begin if Right.IsOptional then exit(nil); var rightKind := Right.Kind; if rightKind = stUnknown then exit(TTypes.Unknown); case Op of TScalar.TUnaryOp.Negate: begin if not (rightKind in [stOrdinal, stFloat]) then exit(nil); Result := Right; end; TScalar.TUnaryOp.Not: begin if not (rightKind in [stOrdinal, stBoolean]) then exit(nil); Result := TTypes.Boolean; end; else Result := nil; end; end; end.