unit uPSCompiler; {$I PascalScript.inc} interface uses {$IFNDEF DELPHI3UP}{$IFNDEF PS_NOINTERFACES}{$IFNDEF LINUX}Windows, Ole2,{$ENDIF} {$ENDIF}{$ENDIF}SysUtils, uPSUtils; type {$IFNDEF PS_NOINTERFACES} TPSInterface = class; {$ENDIF} TPSParameterMode = (pmIn, pmOut, pmInOut); TPSPascalCompiler = class; TPSType = class; TPSValue = class; TPSParameters = class; TPSSubOptType = (tMainBegin, tProcBegin, tSubBegin, tOneLiner, tifOneliner, tRepeat, tTry, tTryEnd {$IFDEF PS_USESSUPPORT},tUnitInit, tUnitFinish {$ENDIF}); //nvds {TPSExternalClass is used when external classes need to be called} TPSCompileTimeClass = class; TPSAttributes = class; TPSAttribute = class; EPSCompilerException = class(Exception) end; TPSParameterDecl = class(TObject) private FName: tbtString; FOrgName: tbtString; FMode: TPSParameterMode; FType: TPSType; {$IFDEF PS_USESSUPPORT} FDeclareUnit: tbtString; {$ENDIF} FDeclarePos: Cardinal; FDeclareRow: Cardinal; FDeclareCol: Cardinal; procedure SetName(const s: tbtString); public property Name: tbtString read FName; property OrgName: tbtString read FOrgName write SetName; property aType: TPSType read FType write FType; property Mode: TPSParameterMode read FMode write FMode; {$IFDEF PS_USESSUPPORT} property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; {$ENDIF} property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; end; TPSParametersDecl = class(TObject) private FParams: TPSList; FResult: TPSType; function GetParam(I: Longint): TPSParameterDecl; function GetParamCount: Longint; public property Params[I: Longint]: TPSParameterDecl read GetParam; property ParamCount: Longint read GetParamCount; function AddParam: TPSParameterDecl; procedure DeleteParam(I: Longint); property Result : TPSType read FResult write FResult; procedure Assign(Params: TPSParametersDecl); function Same(d: TPSParametersDecl): boolean; constructor Create; destructor Destroy; override; end; TPSRegProc = class(TObject) private FNameHash: Longint; FName: tbtString; FDecl: TPSParametersDecl; FExportName: Boolean; FImportDecl: tbtString; FOrgName: tbtString; procedure SetName(const Value: tbtString); public property OrgName: tbtString read FOrgName write FOrgName; property Name: tbtString read FName write SetName; property NameHash: Longint read FNameHash; property Decl: TPSParametersDecl read FDecl; property ExportName: Boolean read FExportName write FExportName; property ImportDecl: tbtString read FImportDecl write FImportDecl; constructor Create; destructor Destroy; override; end; PIFPSRegProc = TPSRegProc; PIfRVariant = ^TIfRVariant; TIfRVariant = record FType: TPSType; case Byte of 1: (tu8: TbtU8); 2: (tS8: TbtS8); 3: (tu16: TbtU16); 4: (ts16: TbtS16); 5: (tu32: TbtU32); 6: (ts32: TbtS32); 7: (tsingle: TbtSingle); 8: (tdouble: TbtDouble); 9: (textended: TbtExtended); 11: (tcurrency: tbtCurrency); 10: (tstring: Pointer); {$IFNDEF PS_NOINT64} 17: (ts64: Tbts64); {$ENDIF} 19: (tchar: tbtChar); {$IFNDEF PS_NOWIDESTRING} 18: (twidestring: Pointer); 20: (twidechar: tbtwidechar); {$ENDIF} 21: (ttype: TPSType); 22: (tunistring: Pointer); end; TPSRecordFieldTypeDef = class(TObject) private FFieldOrgName: tbtString; FFieldName: tbtString; FFieldNameHash: Longint; FType: TPSType; procedure SetFieldOrgName(const Value: tbtString); public property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName; property FieldName: tbtString read FFieldName; property FieldNameHash: Longint read FFieldNameHash; property aType: TPSType read FType write FType; end; PIFPSRecordFieldTypeDef = TPSRecordFieldTypeDef; TPSType = class(TObject) private FNameHash: Longint; FName: tbtString; FBaseType: TPSBaseType; {$IFDEF PS_USESSUPPORT} FDeclareUnit: tbtString; {$ENDIF} FDeclarePos: Cardinal; FDeclareRow: Cardinal; FDeclareCol: Cardinal; FUsed: Boolean; FExportName: Boolean; FOriginalName: tbtString; FAttributes: TPSAttributes; FFinalTypeNo: cardinal; procedure SetName(const Value: tbtString); public constructor Create; destructor Destroy; override; property Attributes: TPSAttributes read FAttributes; property FinalTypeNo: cardinal read FFinalTypeNo; property OriginalName: tbtString read FOriginalName write FOriginalName; property Name: tbtString read FName write SetName; property NameHash: Longint read FNameHash; property BaseType: TPSBaseType read FBaseType write FBaseType; {$IFDEF PS_USESSUPPORT} property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; {$ENDIF} property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; property Used: Boolean read FUsed; property ExportName: Boolean read FExportName write FExportName; procedure Use; end; PIFPSType = TPSType; TPSVariantType = class(TPSType) private public function GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString; Params: TPSParameters): Cardinal; virtual; function GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType; virtual; function GetDynInvokeParamType(Owner: TPSPascalCompiler): TPSType; virtual; function GetDynIvokeResulType(Owner: TPSPascalCompiler): TPSType; virtual; end; TPSRecordType = class(TPSType) private FRecordSubVals: TPSList; public constructor Create; destructor Destroy; override; function RecValCount: Longint; function RecVal(I: Longint): PIFPSRecordFieldTypeDef; function AddRecVal: PIFPSRecordFieldTypeDef; end; TPSClassType = class(TPSType) private FCL: TPSCompiletimeClass; public property Cl: TPSCompileTimeClass read FCL write FCL; end; TPSExternalClass = class; TPSUndefinedClassType = class(TPSType) private FExtClass: TPSExternalClass; public property ExtClass: TPSExternalClass read FExtClass write FExtClass; end; {$IFNDEF PS_NOINTERFACES} TPSInterfaceType = class(TPSType) private FIntf: TPSInterface; public property Intf: TPSInterface read FIntf write FIntf; end; {$ENDIF} TPSProceduralType = class(TPSType) private FProcDef: TPSParametersDecl; public property ProcDef: TPSParametersDecl read FProcDef; constructor Create; destructor Destroy; override; end; TPSArrayType = class(TPSType) private FArrayTypeNo: TPSType; public property ArrayTypeNo: TPSType read FArrayTypeNo write FArrayTypeNo; end; TPSStaticArrayType = class(TPSArrayType) private FStartOffset: Longint; FLength: Cardinal; public property StartOffset: Longint read FStartOffset write FStartOffset; property Length: Cardinal read FLength write FLength; end; TPSSetType = class(TPSType) private FSetType: TPSType; function GetByteSize: Longint; function GetBitSize: Longint; public property SetType: TPSType read FSetType write FSetType; property ByteSize: Longint read GetByteSize; property BitSize: Longint read GetBitSize; end; TPSTypeLink = class(TPSType) private FLinkTypeNo: TPSType; public property LinkTypeNo: TPSType read FLinkTypeNo write FLinkTypeNo; end; TPSEnumType = class(TPSType) private FHighValue: Cardinal; public property HighValue: Cardinal read FHighValue write FHighValue; end; TPSProcedure = class(TObject) private FAttributes: TPSAttributes; public property Attributes: TPSAttributes read FAttributes; constructor Create; destructor Destroy; override; end; TPSAttributeType = class; TPSAttributeTypeField = class(TObject) private FOwner: TPSAttributeType; FFieldOrgName: tbtString; FFieldName: tbtString; FFieldNameHash: Longint; FFieldType: TPSType; FHidden: Boolean; procedure SetFieldOrgName(const Value: tbtString); public constructor Create(AOwner: TPSAttributeType); property Owner: TPSAttributeType read FOwner; property FieldOrgName: tbtString read FFieldOrgName write SetFieldOrgName; property FieldName: tbtString read FFieldName; property FieldNameHash: Longint read FFieldNameHash; property FieldType: TPSType read FFieldType write FFieldType; property Hidden: Boolean read FHidden write FHidden; end; TPSApplyAttributeToType = function (Sender: TPSPascalCompiler; aType: TPSType; Attr: TPSAttribute): Boolean; TPSApplyAttributeToProc = function (Sender: TPSPascalCompiler; aProc: TPSProcedure; Attr: TPSAttribute): Boolean; { An attribute type } TPSAttributeType = class(TPSType) private FFields: TPSList; FName: tbtString; FOrgname: tbtString; FNameHash: Longint; FAAProc: TPSApplyAttributeToProc; FAAType: TPSApplyAttributeToType; function GetField(I: Longint): TPSAttributeTypeField; function GetFieldCount: Longint; procedure SetName(const s: tbtString); public property OnApplyAttributeToType: TPSApplyAttributeToType read FAAType write FAAType; property OnApplyAttributeToProc: TPSApplyAttributeToProc read FAAProc write FAAProc; property Fields[i: Longint]: TPSAttributeTypeField read GetField; property FieldCount: Longint read GetFieldCount; procedure DeleteField(I: Longint); function AddField: TPSAttributeTypeField; property Name: tbtString read FName; property OrgName: tbtString read FOrgName write SetName; property NameHash: Longint read FNameHash; constructor Create; destructor Destroy; override; end; TPSAttribute = class(TObject) private FAttribType: TPSAttributeType; FValues: TPSList; function GetValueCount: Longint; function GetValue(I: Longint): PIfRVariant; public constructor Create(AttribType: TPSAttributeType); procedure Assign(Item: TPSAttribute); property AType: TPSAttributeType read FAttribType; property Count: Longint read GetValueCount; property Values[i: Longint]: PIfRVariant read GetValue; default; procedure DeleteValue(i: Longint); function AddValue(v: PIFRVariant): Longint; destructor Destroy; override; end; TPSAttributes = class(TObject) private FItems: TPSList; function GetCount: Longint; function GetItem(I: Longint): TPSAttribute; public procedure Assign(attr: TPSAttributes; Move: Boolean); property Count: Longint read GetCount; property Items[i: Longint]: TPSAttribute read GetItem; default; procedure Delete(i: Longint); function Add(AttribType: TPSAttributeType): TPSAttribute; function FindAttribute(const Name: tbtString): TPSAttribute; constructor Create; destructor Destroy; override; end; TPSProcVar = class(TObject) private FNameHash: Longint; FName: tbtString; FOrgName: tbtString; FType: TPSType; FUsed: Boolean; {$IFDEF PS_USESSUPPORT} FDeclareUnit: tbtString; {$ENDIF} FDeclarePos, FDeclareRow, FDeclareCol: Cardinal; procedure SetName(const Value: tbtString); public property OrgName: tbtString read FOrgName write FOrgname; property NameHash: Longint read FNameHash; property Name: tbtString read FName write SetName; property AType: TPSType read FType write FType; property Used: Boolean read FUsed; {$IFDEF PS_USESSUPPORT} property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; {$ENDIF} property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; procedure Use; end; PIFPSProcVar = TPSProcVar; TPSExternalProcedure = class(TPSProcedure) private FRegProc: TPSRegProc; public property RegProc: TPSRegProc read FRegProc write FRegProc; end; TPSInternalProcedure = class(TPSProcedure) private FForwarded: Boolean; FData: tbtString; FNameHash: Longint; FName: tbtString; FDecl: TPSParametersDecl; FProcVars: TPSList; FUsed: Boolean; FOutputDeclPosition: Cardinal; FResultUsed: Boolean; FLabels: TIfStringList; FGotos: TIfStringList; FDeclareRow: Cardinal; {$IFDEF PS_USESSUPPORT} FDeclareUnit: tbtString; {$ENDIF} FDeclarePos: Cardinal; FDeclareCol: Cardinal; FOriginalName: tbtString; procedure SetName(const Value: tbtString); public constructor Create; destructor Destroy; override; {Attributes} property Forwarded: Boolean read FForwarded write FForwarded; property Data: tbtString read FData write FData; property Decl: TPSParametersDecl read FDecl; property OriginalName: tbtString read FOriginalName write FOriginalName; property Name: tbtString read FName write SetName; property NameHash: Longint read FNameHash; property ProcVars: TPSList read FProcVars; property Used: Boolean read FUsed; {$IFDEF PS_USESSUPPORT} property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; {$ENDIF} property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; property OutputDeclPosition: Cardinal read FOutputDeclPosition write FOutputDeclPosition; property ResultUsed: Boolean read FResultUsed; property Labels: TIfStringList read FLabels; property Gotos: TIfStringList read FGotos; procedure Use; procedure ResultUse; end; TPSVar = class(TObject) private FNameHash: Longint; FOrgName: tbtString; FName: tbtString; FType: TPSType; FUsed: Boolean; FExportName: tbtString; FDeclareRow: Cardinal; {$IFDEF PS_USESSUPPORT} FDeclareUnit: tbtString; {$ENDIF} FDeclarePos: Cardinal; FDeclareCol: Cardinal; FSaveAsPointer: Boolean; procedure SetName(const Value: tbtString); public property SaveAsPointer: Boolean read FSaveAsPointer write FSaveAsPointer; property ExportName: tbtString read FExportName write FExportName; property Used: Boolean read FUsed; property aType: TPSType read FType write FType; property OrgName: tbtString read FOrgName write FOrgName; property Name: tbtString read FName write SetName; property NameHash: Longint read FNameHash; {$IFDEF PS_USESSUPPORT} property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; {$ENDIF} property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; procedure Use; end; PIFPSVar = TPSVar; TPSConstant = class(TObject) private FOrgName: tbtString; FNameHash: Longint; FName: tbtString; FDeclareRow: Cardinal; {$IFDEF PS_USESSUPPORT} FDeclareUnit: tbtString; {$ENDIF} FDeclarePos: Cardinal; FDeclareCol: Cardinal; FValue: PIfRVariant; procedure SetName(const Value: tbtString); public property OrgName: tbtString read FOrgName write FOrgName; property Name: tbtString read FName write SetName; property NameHash: Longint read FNameHash; property Value: PIfRVariant read FValue write FValue; {$IFDEF PS_USESSUPPORT} property DeclareUnit: tbtString read FDeclareUnit write FDeclareUnit; {$ENDIF} property DeclarePos: Cardinal read FDeclarePos write FDeclarePos; property DeclareRow: Cardinal read FDeclareRow write FDeclareRow; property DeclareCol: Cardinal read FDeclareCol write FDeclareCol; procedure SetSet(const val); procedure SetInt(const Val: Longint); procedure SetUInt(const Val: Cardinal); {$IFNDEF PS_NOINT64} procedure SetInt64(const Val: Int64); {$ENDIF} procedure SetString(const Val: tbtString); procedure SetChar(c: tbtChar); {$IFNDEF PS_NOWIDESTRING} procedure SetWideChar(const val: WideChar); procedure SetWideString(const val: tbtwidestring); procedure SetUnicodeString(const val: tbtunicodestring); {$ENDIF} procedure SetExtended(const Val: Extended); destructor Destroy; override; end; PIFPSConstant = TPSConstant; TPSPascalCompilerErrorType = ( ecUnknownIdentifier, ecIdentifierExpected, ecCommentError, ecStringError, ecCharError, ecSyntaxError, ecUnexpectedEndOfFile, ecSemicolonExpected, ecBeginExpected, ecPeriodExpected, ecDuplicateIdentifier, ecColonExpected, ecUnknownType, ecCloseRoundExpected, ecTypeMismatch, ecInternalError, ecAssignmentExpected, ecThenExpected, ecDoExpected, ecNoResult, ecOpenRoundExpected, ecCommaExpected, ecToExpected, ecIsExpected, ecOfExpected, ecCloseBlockExpected, ecVariableExpected, ecStringExpected, ecEndExpected, ecUnSetLabel, ecNotInLoop, ecInvalidJump, ecOpenBlockExpected, ecWriteOnlyProperty, ecReadOnlyProperty, ecClassTypeExpected, ecCustomError, ecDivideByZero, ecMathError, ecUnsatisfiedForward, ecForwardParameterMismatch, ecInvalidnumberOfParameters {$IFDEF PS_USESSUPPORT} , ecNotAllowed, ecUnitNotFoundOrContainsErrors, ecCrossReference {$ENDIF} ); TPSPascalCompilerHintType = ( ehVariableNotUsed, ehFunctionNotUsed, ehCustomHint ); TPSPascalCompilerWarningType = ( ewCalculationAlwaysEvaluatesTo, ewIsNotNeeded, ewAbstractClass, ewCustomWarning ); TPSPascalCompilerMessage = class(TObject) protected FRow: Cardinal; FCol: Cardinal; FModuleName: tbtString; FParam: tbtString; FPosition: Cardinal; procedure SetParserPos(Parser: TPSPascalParser); public property ModuleName: tbtString read FModuleName write FModuleName; property Param: tbtString read FParam write FParam; property Pos: Cardinal read FPosition write FPosition; property Row: Cardinal read FRow write FRow; property Col: Cardinal read FCol write FCol; function ErrorType: tbtString; virtual; abstract; procedure SetCustomPos(Pos, Row, Col: Cardinal); function MessageToString: tbtString; virtual; function ShortMessageToString: tbtString; virtual; abstract; end; TPSPascalCompilerError = class(TPSPascalCompilerMessage) protected FError: TPSPascalCompilerErrorType; public property Error: TPSPascalCompilerErrorType read FError; function ErrorType: tbtString; override; function ShortMessageToString: tbtString; override; end; TPSPascalCompilerHint = class(TPSPascalCompilerMessage) protected FHint: TPSPascalCompilerHintType; public property Hint: TPSPascalCompilerHintType read FHint; function ErrorType: tbtString; override; function ShortMessageToString: tbtString; override; end; TPSPascalCompilerWarning = class(TPSPascalCompilerMessage) protected FWarning: TPSPascalCompilerWarningType; public property Warning: TPSPascalCompilerWarningType read FWarning; function ErrorType: tbtString; override; function ShortMessageToString: tbtString; override; end; TPSDuplicCheck = set of (dcTypes, dcProcs, dcVars, dcConsts); TPSBlockInfo = class(TObject) private FOwner: TPSBlockInfo; FWithList: TPSList; FProcNo: Cardinal; FProc: TPSInternalProcedure; FSubType: TPSSubOptType; public property WithList: TPSList read FWithList; property ProcNo: Cardinal read FProcNo write FProcNo; property Proc: TPSInternalProcedure read FProc write FProc; property SubType: TPSSubOptType read FSubType write FSubType; procedure Clear; constructor Create(Owner: TPSBlockInfo); destructor Destroy; override; end; TPSBinOperatorType = (otAdd, otSub, otMul, otDiv, otMod, otShl, otShr, otAnd, otOr, otXor, otAs, otIntDiv, otGreaterEqual, otLessEqual, otGreater, otLess, otEqual, otNotEqual, otIs, otIn); TPSUnOperatorType = (otNot, otMinus, otCast); TPSOnUseVariable = procedure (Sender: TPSPascalCompiler; VarType: TPSVariableType; VarNo: Longint; ProcNo, Position: Cardinal; const PropData: tbtString); TPSOnUses = function(Sender: TPSPascalCompiler; const Name: tbtString): Boolean; TPSOnExportCheck = function(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; const ProcDecl: tbtString): Boolean; {$IFNDEF PS_USESSUPPORT} TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; Position: Cardinal): Boolean; {$ELSE} TPSOnWriteLineEvent = function (Sender: TPSPascalCompiler; FileName: tbtString; Position: Cardinal): Boolean; {$ENDIF} TPSOnExternalProc = function (Sender: TPSPascalCompiler; Decl: TPSParametersDecl; const Name, FExternal: tbtString): TPSRegProc; TPSOnTranslateLineInfoProc = procedure (Sender: TPSPascalCompiler; var Pos, Row, Col: Cardinal; var Name: tbtString); TPSOnNotify = function (Sender: TPSPascalCompiler): Boolean; TPSOnFunction = procedure(name: tbtString; Pos, Row, Col: Integer) of object; TPSPascalCompiler = class protected FAnyString: TPSType; FUnitName: tbtString; FID: Pointer; FOnExportCheck: TPSOnExportCheck; FDefaultBoolType: TPSType; FRegProcs: TPSList; FConstants: TPSList; FProcs: TPSList; FTypes: TPSList; FAttributeTypes: TPSList; FVars: TPSList; FOutput: tbtString; FParser: TPSPascalParser; FParserHadError: Boolean; FMessages: TPSList; FOnUses: TPSOnUses; FUtf8Decode: Boolean; FIsUnit: Boolean; FAllowNoBegin: Boolean; FAllowNoEnd: Boolean; FAllowUnit: Boolean; FBooleanShortCircuit: Boolean; FDebugOutput: tbtString; FOnExternalProc: TPSOnExternalProc; FOnUseVariable: TPSOnUseVariable; FOnBeforeOutput: TPSOnNotify; FOnBeforeCleanup: TPSOnNotify; FOnWriteLine: TPSOnWriteLineEvent; FContinueOffsets, FBreakOffsets: TPSList; FOnTranslateLineInfo: TPSOnTranslateLineInfoProc; FAutoFreeList: TPSList; FClasses: TPSList; FOnFunctionStart: TPSOnFunction; FOnFunctionEnd: TPSOnFunction; FWithCount: Integer; FTryCount: Integer; FExceptFinallyCount: Integer; {$IFDEF PS_USESSUPPORT} FUnitInits : TPSList; //nvds FUnitFinits: TPSList; //nvds FUses : TPSStringList; fUnits : TPSUnitList; fUnit : TPSUnit; fModule : tbtString; {$ENDIF} fInCompile : Integer; {$IFNDEF PS_NOINTERFACES} FInterfaces: TPSList; {$ENDIF} FCurrUsedTypeNo: Cardinal; FGlobalBlock: TPSBlockInfo; function IsBoolean(aType: TPSType): Boolean; {$IFNDEF PS_NOWIDESTRING} function GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring; function GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring; {$ENDIF} function PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean; function FindBaseType(BaseType: TPSBaseType): TPSType; function IsIntBoolType(aType: TPSType): Boolean; function GetTypeCopyLink(p: TPSType): TPSType; function at2ut(p: TPSType): TPSType; procedure UseProc(procdecl: TPSParametersDecl); function GetMsgCount: Longint; function GetMsg(l: Longint): TPSPascalCompilerMessage; function MakeExportDecl(decl: TPSParametersDecl): tbtString; procedure DefineStandardTypes; procedure DefineStandardProcedures; function ReadReal(const s: tbtString): PIfRVariant; function ReadString: PIfRVariant; function ReadInteger(const s: tbtString): PIfRVariant; function ReadAttributes(Dest: TPSAttributes): Boolean; function ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant; function ApplyAttribsToFunction(func: TPSProcedure): boolean; function ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean; function ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean; function IsVarInCompatible(ft1, ft2: TPSType): Boolean; function GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType; function DoVarBlock(proc: TPSInternalProcedure): Boolean; function DoTypeBlock(FParser: TPSPascalParser): Boolean; function ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType; function ProcessLabel(Proc: TPSInternalProcedure): Boolean; function ProcessSub(BlockInfo: TPSBlockInfo): Boolean; function ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean; procedure WriteDebugData(const s: tbtString); procedure Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure); procedure Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure); procedure Debug_WriteLine(BlockInfo: TPSBlockInfo); function IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean; function IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean; {$IFDEF PS_USESSUPPORT} function IsInLocalUnitList(s: tbtString): Boolean; {$ENDIF} function NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure; function AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal; function AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal; function CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean; procedure ParserError(Parser: TObject; Kind: TPSParserErrorKind); function ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType; function VarIsDuplicate(Proc: TPSInternalProcedure; const VarNames, s: tbtString): Boolean; function IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean; procedure CheckForUnusedVars(Func: TPSInternalProcedure); function ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean; public function GetConstant(const Name: tbtString): TPSConstant; function UseExternalProc(const Name: tbtString): TPSParametersDecl; function FindProc(const aName: tbtString): Cardinal; function GetTypeCount: Longint; function GetType(I: Longint): TPSType; function GetVarCount: Longint; function GetVar(I: Longint): TPSVar; function GetProcCount: Longint; function GetProc(I: Longint): TPSProcedure; function GetConstCount: Longint; function GetConst(I: Longint): TPSConstant; function GetRegProcCount: Longint; function GetRegProc(I: Longint): TPSRegProc; function AddAttributeType: TPSAttributeType; function FindAttributeType(const Name: tbtString): TPSAttributeType; procedure AddToFreeList(Obj: TObject); property ID: Pointer read FID write FID; function MakeError(const Module: tbtString; E: TPSPascalCompilerErrorType; const Param: tbtString): TPSPascalCompilerMessage; function MakeWarning(const Module: tbtString; E: TPSPascalCompilerWarningType; const Param: tbtString): TPSPascalCompilerMessage; function MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType; const Param: tbtString): TPSPascalCompilerMessage; {$IFNDEF PS_NOINTERFACES} function AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface; function FindInterface(const Name: tbtString): TPSInterface; {$ENDIF} function AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass; function AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass; function FindClass(const aClass: tbtString): TPSCompileTimeClass; function AddFunction(const Header: tbtString): TPSRegProc; function AddDelphiFunction(const Decl: tbtString): TPSRegProc; function AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType; function AddTypeS(const Name, Decl: tbtString): TPSType; function AddTypeCopy(const Name: tbtString; TypeNo: TPSType): TPSType; function AddTypeCopyN(const Name, FType: tbtString): TPSType; function AddConstant(const Name: tbtString; FType: TPSType): TPSConstant; function AddConstantN(const Name, FType: tbtString): TPSConstant; function AddVariable(const Name: tbtString; FType: TPSType): TPSVar; function AddVariableN(const Name, FType: tbtString): TPSVar; function AddUsedVariable(const Name: tbtString; FType: TPSType): TPSVar; function AddUsedVariableN(const Name, FType: tbtString): TPSVar; function AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar; function AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar; function FindType(const Name: tbtString): TPSType; function MakeDecl(decl: TPSParametersDecl): tbtString; function Compile(const s: tbtString): Boolean; function GetOutput(var s: tbtString): Boolean; function GetDebugOutput(var s: tbtString): Boolean; procedure Clear; constructor Create; destructor Destroy; override; property MsgCount: Longint read GetMsgCount; property Msg[l: Longint]: TPSPascalCompilerMessage read GetMsg; property OnTranslateLineInfo: TPSOnTranslateLineInfoProc read FOnTranslateLineInfo write FOnTranslateLineInfo; property OnUses: TPSOnUses read FOnUses write FOnUses; property OnExportCheck: TPSOnExportCheck read FOnExportCheck write FOnExportCheck; property OnWriteLine: TPSOnWriteLineEvent read FOnWriteLine write FOnWriteLine; property OnExternalProc: TPSOnExternalProc read FOnExternalProc write FOnExternalProc; property OnUseVariable: TPSOnUseVariable read FOnUseVariable write FOnUseVariable; property OnBeforeOutput: TPSOnNotify read FOnBeforeOutput write FOnBeforeOutput; property OnBeforeCleanup: TPSOnNotify read FOnBeforeCleanup write FOnBeforeCleanup; property OnFunctionStart: TPSOnFunction read FOnFunctionStart write FOnFunctionStart; property OnFunctionEnd: TPSOnFunction read FOnFunctionEnd write FOnFunctionEnd; property IsUnit: Boolean read FIsUnit; property AllowNoBegin: Boolean read FAllowNoBegin write FAllowNoBegin; property AllowUnit: Boolean read FAllowUnit write FAllowUnit; property AllowNoEnd: Boolean read FAllowNoEnd write FAllowNoEnd; property BooleanShortCircuit: Boolean read FBooleanShortCircuit write FBooleanShortCircuit; property UTF8Decode: Boolean read FUtf8Decode write FUtf8Decode; property UnitName: tbtString read FUnitName; end; TIFPSPascalCompiler = TPSPascalCompiler; TPSValue = class(TObject) private FPos, FRow, FCol: Cardinal; public property Pos: Cardinal read FPos write FPos; property Row: Cardinal read FRow write FRow; property Col: Cardinal read FCol write FCol; procedure SetParserPos(P: TPSPascalParser); end; TPSParameter = class(TObject) private FValue: TPSValue; FTempVar: TPSValue; FParamMode: TPSParameterMode; FExpectedType: TPSType; public property Val: TPSValue read FValue write FValue; property ExpectedType: TPSType read FExpectedType write FExpectedType; property TempVar: TPSValue read FTempVar write FTempVar; property ParamMode: TPSParameterMode read FParamMode write FParamMode; destructor Destroy; override; end; TPSParameters = class(TObject) private FItems: TPSList; function GetCount: Cardinal; function GetItem(I: Longint): TPSParameter; public constructor Create; destructor Destroy; override; property Count: Cardinal read GetCount; property Item[I: Longint]: TPSParameter read GetItem; default; procedure Delete(I: Cardinal); function Add: TPSParameter; end; TPSSubItem = class(TObject) private FType: TPSType; public property aType: TPSType read FType write FType; end; TPSSubNumber = class(TPSSubItem) private FSubNo: Cardinal; public property SubNo: Cardinal read FSubNo write FSubNo; end; TPSSubValue = class(TPSSubItem) private FSubNo: TPSValue; public property SubNo: TPSValue read FSubNo write FSubNo; destructor Destroy; override; end; TPSValueVar = class(TPSValue) private FRecItems: TPSList; function GetRecCount: Cardinal; function GetRecItem(I: Cardinal): TPSSubItem; public constructor Create; destructor Destroy; override; function RecAdd(Val: TPSSubItem): Cardinal; procedure RecDelete(I: Cardinal); property RecItem[I: Cardinal]: TPSSubItem read GetRecItem; property RecCount: Cardinal read GetRecCount; end; TPSValueGlobalVar = class(TPSValueVar) private FAddress: Cardinal; public property GlobalVarNo: Cardinal read FAddress write FAddress; end; TPSValueLocalVar = class(TPSValueVar) private FLocalVarNo: Longint; public property LocalVarNo: Longint read FLocalVarNo write FLocalVarNo; end; TPSValueParamVar = class(TPSValueVar) private FParamNo: Longint; public property ParamNo: Longint read FParamNo write FParamNo; end; TPSValueAllocatedStackVar = class(TPSValueLocalVar) private FProc: TPSInternalProcedure; public property Proc: TPSInternalProcedure read FProc write FProc; destructor Destroy; override; end; TPSValueData = class(TPSValue) private FData: PIfRVariant; public property Data: PIfRVariant read FData write FData; destructor Destroy; override; end; TPSValueReplace = class(TPSValue) private FPreWriteAllocated: Boolean; FFreeOldValue: Boolean; FFreeNewValue: Boolean; FOldValue: TPSValue; FNewValue: TPSValue; FReplaceTimes: Longint; public property OldValue: TPSValue read FOldValue write FOldValue; property NewValue: TPSValue read FNewValue write FNewValue; {Should it free the old value when destroyed?} property FreeOldValue: Boolean read FFreeOldValue write FFreeOldValue; property FreeNewValue: Boolean read FFreeNewValue write FFreeNewValue; property PreWriteAllocated: Boolean read FPreWriteAllocated write FPreWriteAllocated; property ReplaceTimes: Longint read FReplaceTimes write FReplaceTimes; constructor Create; destructor Destroy; override; end; TPSUnValueOp = class(TPSValue) private FVal1: TPSValue; FOperator: TPSUnOperatorType; FType: TPSType; public property Val1: TPSValue read FVal1 write FVal1; {The operator} property Operator: TPSUnOperatorType read FOperator write FOperator; property aType: TPSType read FType write FType; destructor Destroy; override; end; TPSBinValueOp = class(TPSValue) private FVal1, FVal2: TPSValue; FOperator: TPSBinOperatorType; FType: TPSType; public property Val1: TPSValue read FVal1 write FVal1; property Val2: TPSValue read FVal2 write FVal2; {The operator for this value} property Operator: TPSBinOperatorType read FOperator write FOperator; property aType: TPSType read FType write FType; destructor Destroy; override; end; TPSValueNil = class(TPSValue) end; TPSValueProcPtr = class(TPSValue) private FProcNo: Cardinal; public property ProcPtr: Cardinal read FProcNo write FProcNo; end; TPSValueProc = class(TPSValue) private FSelfPtr: TPSValue; FParameters: TPSParameters; FResultType: TPSType; public property ResultType: TPSType read FResultType write FResultType; property SelfPtr: TPSValue read FSelfPtr write FSelfPtr; property Parameters: TPSParameters read FParameters write FParameters; destructor Destroy; override; end; TPSValueProcNo = class(TPSValueProc) private FProcNo: Cardinal; public property ProcNo: Cardinal read FProcNo write FProcNo; end; TPSValueProcVal = class(TPSValueProc) private FProcNo: TPSValue; public property ProcNo: TPSValue read FProcNo write FProcNo; destructor Destroy; override; end; TPSValueArray = class(TPSValue) private FItems: TPSList; function GetCount: Cardinal; function GetItem(I: Cardinal): TPSValue; public function Add(Item: TPSValue): Cardinal; procedure Delete(I: Cardinal); property Item[I: Cardinal]: TPSValue read GetItem; property Count: Cardinal read GetCount; constructor Create; destructor Destroy; override; end; TPSDelphiClassItem = class; TPSPropType = (iptRW, iptR, iptW); TPSCompileTimeClass = class private FInheritsFrom: TPSCompileTimeClass; FClass: TClass; FClassName: tbtString; FClassNameHash: Longint; FClassItems: TPSList; FDefaultProperty: Cardinal; FIsAbstract: Boolean; FCastProc, FNilProc: Cardinal; FType: TPSType; FOwner: TPSPascalCompiler; function GetCount: Longint; function GetItem(i: Longint): TPSDelphiClassItem; public property aType: TPSType read FType; property Items[i: Longint]: TPSDelphiClassItem read GetItem; property Count: Longint read GetCount; property IsAbstract: Boolean read FIsAbstract write FIsAbstract; property ClassInheritsFrom: TPSCompileTimeClass read FInheritsFrom write FInheritsFrom; function RegisterMethod(const Decl: tbtString): Boolean; procedure RegisterProperty(const PropertyName, PropertyType: tbtString; PropAC: TPSPropType); procedure RegisterPublishedProperties; function RegisterPublishedProperty(const Name: tbtString): Boolean; procedure SetDefaultPropery(const Name: tbtString); constructor Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType); class function CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass; destructor Destroy; override; function IsCompatibleWith(aType: TPSType): Boolean; function SetNil(var ProcNo: Cardinal): Boolean; function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; function Property_Find(const Name: tbtString; var Index: IPointer): Boolean; function Property_Get(Index: IPointer; var ProcNo: Cardinal): Boolean; function Property_Set(Index: IPointer; var ProcNo: Cardinal): Boolean; function Property_GetHeader(Index: IPointer; Dest: TPSParametersDecl): Boolean; function Func_Find(const Name: tbtString; var Index: IPointer): Boolean; function Func_Call(Index: IPointer; var ProcNo: Cardinal): Boolean; function ClassFunc_Find(const Name: tbtString; var Index: IPointer): Boolean; function ClassFunc_Call(Index: IPointer; var ProcNo: Cardinal): Boolean; end; TPSDelphiClassItem = class(TObject) private FOwner: TPSCompileTimeClass; FOrgName: tbtString; FName: tbtString; FNameHash: Longint; FDecl: TPSParametersDecl; procedure SetName(const s: tbtString); public constructor Create(Owner: TPSCompileTimeClass); destructor Destroy; override; property Decl: TPSParametersDecl read FDecl; property Name: tbtString read FName; property OrgName: tbtString read FOrgName write SetName; property NameHash: Longint read FNameHash; property Owner: TPSCompileTimeClass read FOwner; end; TPSDelphiClassItemMethod = class(TPSDelphiClassItem) private FMethodNo: Cardinal; public property MethodNo: Cardinal read FMethodNo write FMethodNo; end; TPSDelphiClassItemProperty = class(TPSDelphiClassItem) private FReadProcNo: Cardinal; FWriteProcNo: Cardinal; FAccessType: TPSPropType; public property AccessType: TPSPropType read FAccessType write FAccessType; property ReadProcNo: Cardinal read FReadProcNo write FReadProcNo; property WriteProcNo: Cardinal read FWriteProcNo write FWriteProcNo; end; TPSDelphiClassItemConstructor = class(TPSDelphiClassItemMethod) end; {$IFNDEF PS_NOINTERFACES} TPSInterface = class(TObject) private FOwner: TPSPascalCompiler; FType: TPSType; FInheritedFrom: TPSInterface; FGuid: TGuid; FCastProc, FNilProc: Cardinal; FItems: TPSList; FName: tbtString; FNameHash: Longint; procedure SetInheritedFrom(p: TPSInterface); public constructor Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType); destructor Destroy; override; property aType: TPSType read FType; property InheritedFrom: TPSInterface read FInheritedFrom write SetInheritedFrom; property Guid: TGuid read FGuid write FGuid; property Name: tbtString read FName write FName; property NameHash: Longint read FNameHash; function RegisterMethod(const Declaration: tbtString; const cc: TPSCallingConvention): Boolean; function RegisterMethodEx(const Declaration: tbtString; const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean; procedure RegisterDummyMethod; function IsCompatibleWith(aType: TPSType): Boolean; function SetNil(var ProcNo: Cardinal): Boolean; function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; function Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; end; TPSInterfaceMethod = class(TObject) private FName: tbtString; FDecl: TPSParametersDecl; FNameHash: Longint; FCC: TPSCallingConvention; FScriptProcNo: Cardinal; FOrgName: tbtString; FOwner: TPSInterface; FOffsetCache: Cardinal; function GetAbsoluteProcOffset: Cardinal; public property AbsoluteProcOffset: Cardinal read GetAbsoluteProcOffset; property ScriptProcNo: Cardinal read FScriptProcNo; property OrgName: tbtString read FOrgName; property Name: tbtString read FName; property NameHash: Longint read FNameHash; property Decl: TPSParametersDecl read FDecl; property CC: TPSCallingConvention read FCC; constructor Create(Owner: TPSInterface); destructor Destroy; override; end; {$ENDIF} TPSExternalClass = class(TObject) protected SE: TPSPascalCompiler; FTypeNo: TPSType; public function SelfType: TPSType; virtual; constructor Create(Se: TPSPascalCompiler; TypeNo: TPSType); function ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual; function ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual; function Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; virtual; function Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; virtual; function IsCompatibleWith(Cl: TPSExternalClass): Boolean; virtual; function SetNil(var ProcNo: Cardinal): Boolean; virtual; function CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; virtual; function CompareClass(OtherTypeNo: TPSType; var ProcNo: Cardinal): Boolean; virtual; end; function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean; procedure SetVarExportName(P: TPSVar; const ExpName: tbtString); function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean; const {Invalid value, this is returned by most functions of pascal script that return a cardinal, when they fail} InvalidVal = Cardinal(-1); type TIFPSCompileTimeClass = TPSCompileTimeClass; TIFPSInternalProcedure = TPSInternalProcedure; TIFPSPascalCompilerError = TPSPascalCompilerError; TPMFuncType = (mftProc , mftConstructor ); function PS_mi2s(i: Cardinal): tbtString; function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean; function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean; function DeclToBits(const Decl: TPSParametersDecl): tbtString; function NewVariant(FType: TPSType): PIfRVariant; procedure DisposeVariant(p: PIfRVariant); implementation uses Classes, typInfo; {$IFDEF DELPHI3UP} resourceString {$ELSE} const {$ENDIF} RPS_OnUseEventOnly = 'This function can only be called from within the OnUses event'; RPS_UnableToRegisterFunction = 'Unable to register function %s'; RPS_UnableToRegisterConst = 'Unable to register constant %s'; RPS_InvalidTypeForVar = 'Invalid type for variable %s'; RPS_InvalidType = 'Invalid Type'; RPS_UnableToRegisterType = 'Unable to register type %s'; RPS_UnknownInterface = 'Unknown interface: %s'; RPS_ConstantValueMismatch = 'Constant Value Type Mismatch'; RPS_ConstantValueNotAssigned = 'Constant Value is not assigned'; RPS_Error = 'Error'; RPS_UnknownIdentifier = 'Unknown identifier ''%s'''; RPS_IdentifierExpected = 'Identifier expected'; RPS_CommentError = 'Comment error'; RPS_StringError = 'String error'; RPS_CharError = 'Char error'; RPS_SyntaxError = 'Syntax error'; RPS_EOF = 'Unexpected end of file'; RPS_SemiColonExpected = 'Semicolon ('';'') expected'; RPS_BeginExpected = '''BEGIN'' expected'; RPS_PeriodExpected = 'period (''.'') expected'; RPS_DuplicateIdent = 'Duplicate identifier ''%s'''; RPS_ColonExpected = 'colon ('':'') expected'; RPS_UnknownType = 'Unknown type ''%s'''; RPS_CloseRoundExpected = 'Closing parenthesis expected'; RPS_TypeMismatch = 'Type mismatch'; RPS_InternalError = 'Internal error (%s)'; RPS_AssignmentExpected = 'Assignment expected'; RPS_ThenExpected = '''THEN'' expected'; RPS_DoExpected = '''DO'' expected'; RPS_NoResult = 'No result'; RPS_OpenRoundExpected = 'opening parenthesis (''('')expected'; RPS_CommaExpected = 'comma ('','') expected'; RPS_ToExpected = '''TO'' expected'; RPS_IsExpected = 'is (''='') expected'; RPS_OfExpected = '''OF'' expected'; RPS_CloseBlockExpected = 'Closing square bracket ('']'') expected'; RPS_VariableExpected = 'Variable Expected'; RPS_StringExpected = 'String Expected'; RPS_EndExpected = '''END'' expected'; RPS_UnSetLabel = 'Label ''%s'' not set'; RPS_NotInLoop = 'Not in a loop'; RPS_InvalidJump = 'Invalid jump'; RPS_OpenBlockExpected = 'Opening square brackets (''['') expected'; RPS_WriteOnlyProperty = 'Write-only property'; RPS_ReadOnlyProperty = 'Read-only property'; RPS_ClassTypeExpected = 'Class type expected'; RPS_DivideByZero = 'Divide by Zero'; RPS_MathError = 'Math Error'; RPS_UnsatisfiedForward = 'Unsatisfied Forward %s'; RPS_ForwardParameterMismatch = 'Forward Parameter Mismatch'; RPS_InvalidNumberOfParameter = 'Invalid number of parameters'; RPS_UnknownError = 'Unknown error'; {$IFDEF PS_USESSUPPORT} RPS_NotAllowed = '%s is not allowed at this position'; RPS_UnitNotFound = 'Unit ''%s'' not found or contains errors'; RPS_CrossReference = 'Cross-Reference error of ''%s'''; {$ENDIF} RPS_Hint = 'Hint'; RPS_VariableNotUsed = 'Variable ''%s'' never used'; RPS_FunctionNotUsed = 'Function ''%s'' never used'; RPS_UnknownHint = 'Unknown hint'; RPS_Warning = 'Warning'; RPS_CalculationAlwaysEvaluatesTo = 'Calculation always evaluates to %s'; RPS_IsNotNeeded = '%s is not needed'; RPS_AbstractClass = 'Abstract Class Construction'; RPS_UnknownWarning = 'Unknown warning'; {$IFDEF DEBUG } RPS_UnableToRegister = 'Unable to register %s'; {$ENDIF} RPS_NotArrayProperty = 'Not an array property'; RPS_NotProperty = 'Not a property'; RPS_UnknownProperty = 'Unknown Property'; function DeclToBits(const Decl: TPSParametersDecl): tbtString; var i: longint; begin Result := ''; if Decl.Result = nil then begin Result := Result + #0; end else Result := Result + #1; for i := 0 to Decl.ParamCount -1 do begin if Decl.Params[i].Mode <> pmIn then Result := Result + #1 else Result := Result + #0; end; end; procedure BlockWriteByte(BlockInfo: TPSBlockInfo; b: Byte); begin BlockInfo.Proc.Data := BlockInfo.Proc.Data + tbtChar(b); end; procedure BlockWriteData(BlockInfo: TPSBlockInfo; const Data; Len: Longint); begin SetLength(BlockInfo.Proc.FData, Length(BlockInfo.Proc.FData) + Len); Move(Data, BlockInfo.Proc.FData[Length(BlockInfo.Proc.FData) - Len + 1], Len); end; procedure BlockWriteLong(BlockInfo: TPSBlockInfo; l: Cardinal); begin BlockWriteData(BlockInfo, l, 4); end; procedure BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant); var du8: tbtu8; du16: tbtu16; begin BlockWriteLong(BlockInfo, p^.FType.FinalTypeNo); case p.FType.BaseType of btType: BlockWriteData(BlockInfo, p^.ttype.FinalTypeno, 4); {$IFNDEF PS_NOWIDESTRING} btWideString: begin BlockWriteLong(BlockInfo, Length(tbtWideString(p^.twidestring))); BlockWriteData(BlockInfo, tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring))); end; btUnicodeString: begin BlockWriteLong(BlockInfo, Length(tbtUnicodeString(p^.twidestring))); BlockWriteData(BlockInfo, tbtUnicodeString(p^.twidestring)[1], 2*Length(tbtUnicodeString(p^.twidestring))); end; btWideChar: BlockWriteData(BlockInfo, p^.twidechar, 2); {$ENDIF} btSingle: BlockWriteData(BlockInfo, p^.tsingle, sizeof(tbtSingle)); btDouble: BlockWriteData(BlockInfo, p^.tdouble, sizeof(tbtDouble)); btExtended: BlockWriteData(BlockInfo, p^.textended, sizeof(tbtExtended)); btCurrency: BlockWriteData(BlockInfo, p^.tcurrency, sizeof(tbtCurrency)); btChar: BlockWriteData(BlockInfo, p^.tchar, 1); btSet: begin BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); end; btString: begin BlockWriteLong(BlockInfo, Length(tbtString(p^.tstring))); BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); end; btenum: begin if TPSEnumType(p^.FType).HighValue <=256 then begin du8 := tbtu8(p^.tu32); BlockWriteData(BlockInfo, du8, 1) end else if TPSEnumType(p^.FType).HighValue <=65536 then begin du16 := tbtu16(p^.tu32); BlockWriteData(BlockInfo, du16, 2) end; end; bts8,btu8: BlockWriteData(BlockInfo, p^.tu8, 1); bts16,btu16: BlockWriteData(BlockInfo, p^.tu16, 2); bts32,btu32: BlockWriteData(BlockInfo, p^.tu32, 4); {$IFNDEF PS_NOINT64} bts64: BlockWriteData(BlockInfo, p^.ts64, 8); {$ENDIF} btProcPtr: BlockWriteData(BlockInfo, p^.tu32, 4); {$IFDEF DEBUG} {$IFNDEF FPC} else asm int 3; end; {$ENDIF} {$ENDIF} end; end; function ExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; Types: array of TPSBaseType; Modes: array of TPSParameterMode): Boolean; var i: Longint; ttype: TPSType; begin if High(Types) <> High(Modes)+1 then begin Result := False; exit; end; if High(Types) <> Proc.Decl.ParamCount then begin Result := False; exit; end; TType := Proc.Decl.Result; if TType = nil then begin if Types[0] <> btReturnAddress then begin Result := False; exit; end; end else begin if TType.BaseType <> Types[0] then begin Result := False; exit; end; end; for i := 0 to High(Modes) do begin TType := Proc.Decl.Params[i].aType; if Modes[i] <> Proc.Decl.Params[i].Mode then begin Result := False; exit; end; if TType.BaseType <> Types[i+1] then begin Result := False; exit; end; end; Result := True; end; procedure SetVarExportName(P: TPSVar; const ExpName: tbtString); begin if p <> nil then p.exportname := ExpName; end; function FindAndAddType(Owner: TPSPascalCompiler; const Name, Decl: tbtString): TPSType; var tt: TPSType; begin Result := Owner.FindType(Name); if Result = nil then begin tt := Owner.AddTypeS(Name, Decl); tt.ExportName := True; Result := tt; end; end; function ParseMethod(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType): Boolean; begin Result := ParseMethodEx(Owner, FClassName, Decl, OrgName, DestDecl, Func, nil); end; function ParseMethodEx(Owner: TPSPascalCompiler; const FClassName: tbtString; Decl: tbtString; var OrgName: tbtString; DestDecl: TPSParametersDecl; var Func: TPMFuncType; CustomParser: TPSPascalParser): Boolean; var Parser: TPSPascalParser; FuncType: Byte; VNames: tbtString; modifier: TPSParameterMode; VCType: TPSType; ERow, EPos, ECol: Integer; begin if CustomParser = nil then begin Parser := TPSPascalParser.Create; Parser.SetText(Decl); end else Parser := CustomParser; if Parser.CurrTokenId = CSTII_Function then FuncType:= 0 else if Parser.CurrTokenId = CSTII_Procedure then FuncType := 1 else if (Parser.CurrTokenId = CSTII_Constructor) and (FClassName <> '') then FuncType := 2 else begin if Parser <> CustomParser then Parser.Free; Result := False; exit; end; Parser.Next; if Parser.CurrTokenId <> CSTI_Identifier then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecIdentifierExpected, ''); Result := False; exit; end; {if} OrgName := Parser.OriginalToken; Parser.Next; if Parser.CurrTokenId = CSTI_OpenRound then begin Parser.Next; if Parser.CurrTokenId <> CSTI_CloseRound then begin while True do begin if Parser.CurrTokenId = CSTII_Const then begin modifier := pmIn; Parser.Next; end else if Parser.CurrTokenId = CSTII_Var then begin modifier := pmInOut; Parser.Next; end else if Parser.CurrTokenId = CSTII_Out then begin modifier := pmOut; Parser.Next; end else modifier := pmIn; if Parser.CurrTokenId <> CSTI_Identifier then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecIdentifierExpected, ''); Result := False; exit; end; EPos:=Parser.CurrTokenPos; ERow:=Parser.Row; ECol:=Parser.Col; VNames := Parser.OriginalToken + '|'; Parser.Next; while Parser.CurrTokenId = CSTI_Comma do begin Parser.Next; if Parser.CurrTokenId <> CSTI_Identifier then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecIdentifierExpected, ''); Result := False; exit; end; VNames := VNames + Parser.OriginalToken + '|'; Parser.Next; end; if Parser.CurrTokenId <> CSTI_Colon then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecColonExpected, ''); Result := False; exit; end; Parser.Next; if Parser.CurrTokenID = CSTII_Array then begin Parser.nExt; if Parser.CurrTokenId <> CSTII_Of then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecOfExpected, ''); Result := False; exit; end; Parser.Next; if Parser.CurrTokenId = CSTII_Const then begin VCType := FindAndAddType(Owner, '!OPENARRAYOFCONST', 'array of ___Pointer') end else begin VCType := Owner.GetTypeCopyLink(Owner.FindType(Parser.GetToken)); if VCType = nil then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecUnknownType, Parser.GetToken); Result := False; exit; end; case VCType.BaseType of btU8: VCType := FindAndAddType(Owner, '!OPENARRAYOFU8', 'array of byte'); btS8: VCType := FindAndAddType(Owner, '!OPENARRAYOFS8', 'array of ShortInt'); btU16: VCType := FindAndAddType(Owner, '!OPENARRAYOFU16', 'array of SmallInt'); btS16: VCType := FindAndAddType(Owner, '!OPENARRAYOFS16', 'array of Word'); btU32: VCType := FindAndAddType(Owner, '!OPENARRAYOFU32', 'array of Cardinal'); btS32: VCType := FindAndAddType(Owner, '!OPENARRAYOFS32', 'array of Longint'); btSingle: VCType := FindAndAddType(Owner, '!OPENARRAYOFSINGLE', 'array of Single'); btDouble: VCType := FindAndAddType(Owner, '!OPENARRAYOFDOUBLE', 'array of Double'); btExtended: VCType := FindAndAddType(Owner, '!OPENARRAYOFEXTENDED', 'array of Extended'); btString: VCType := FindAndAddType(Owner, '!OPENARRAYOFSTRING', 'array of String'); btPChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFPCHAR', {$IFDEF PS_PANSICHAR}'array of PAnsiChar'{$ELSE}'array of PChar'{$ENDIF}); btNotificationVariant, btVariant: VCType := FindAndAddType(Owner, '!OPENARRAYOFVARIANT', 'array of variant'); {$IFNDEF PS_NOINT64}btS64: VCType := FindAndAddType(Owner, '!OPENARRAYOFS64', 'array of Int64');{$ENDIF} btChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFCHAR', 'array of Char'); {$IFNDEF PS_NOWIDESTRING} btWideString: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDESTRING', 'array of WideString'); btUnicodeString: VCType := FindAndAddType(Owner, '!OPENARRAYOFUNICODESTRING', 'array of UnicodeString'); btWideChar: VCType := FindAndAddType(Owner, '!OPENARRAYOFWIDECHAR', 'array of WideChar'); {$ENDIF} btClass: VCType := FindAndAddType(Owner, '!OPENARRAYOFTOBJECT', 'array of TObject'); btRecord: VCType := FindAndAddType(Owner, '!OPENARRAYOFRECORD_'+FastUpperCase(Parser.OriginalToken), 'array of ' +FastUpperCase(Parser.OriginalToken)); else begin if Parser <> CustomParser then Parser.Free; Result := False; exit; end; end; end; end else if Parser.CurrTokenID = CSTII_Const then VCType := nil // any type else begin VCType := Owner.FindType(Parser.GetToken); if VCType = nil then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecUnknownType, Parser.GetToken); Result := False; exit; end; end; while Pos(tbtchar('|'), VNames) > 0 do begin with DestDecl.AddParam do begin {$IFDEF PS_USESSUPPORT} DeclareUnit:=Owner.fModule; {$ENDIF} DeclarePos := EPos; DeclareRow := ERow; DeclareCol := ECol; Mode := modifier; OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1); aType := VCType; end; Delete(VNames, 1, Pos(tbtchar('|'), VNames)); end; Parser.Next; if Parser.CurrTokenId = CSTI_CloseRound then break; if Parser.CurrTokenId <> CSTI_Semicolon then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecSemiColonExpected, ''); Result := False; exit; end; Parser.Next; end; {while} end; {if} Parser.Next; end; {if} if FuncType = 0 then begin if Parser.CurrTokenId <> CSTI_Colon then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecColonExpected, ''); Result := False; exit; end; Parser.Next; VCType := Owner.FindType(Parser.GetToken); if VCType = nil then begin if Parser <> CustomParser then Parser.Free else Owner.MakeError('', ecUnknownType, Parser.GetToken); Result := False; exit; end; Parser.Next; end else if FuncType = 2 then {constructor} begin VCType := Owner.FindType(FClassName) end else VCType := nil; DestDecl.Result := VCType; if Parser <> CustomParser then Parser.Free; if FuncType = 2 then Func := mftConstructor else Func := mftProc; Result := True; end; function TPSPascalCompiler.FindProc(const aName: tbtString): Cardinal; var l, h: Longint; x: TPSProcedure; xr: TPSRegProc; name: tbtString; begin name := FastUpperCase(aName); h := MakeHash(Name); if FProcs = nil then begin result := InvalidVal; Exit; end; for l := FProcs.Count - 1 downto 0 do begin x := FProcs.Data^[l]; if x.ClassType = TPSInternalProcedure then begin if (TPSInternalProcedure(x).NameHash = h) and (TPSInternalProcedure(x).Name = Name) then begin Result := l; exit; end; end else begin if (TPSExternalProcedure(x).RegProc.NameHash = h) and (TPSExternalProcedure(x).RegProc.Name = Name) {$IFDEF PS_USESSUPPORT} and (IsInLocalUnitList(TPSInternalProcedure(x).DeclareUnit)){$ENDIF} then begin Result := l; exit; end; end; end; for l := FRegProcs.Count - 1 downto 0 do begin xr := FRegProcs[l]; if (xr.NameHash = h) and (xr.Name = Name) then begin x := TPSExternalProcedure.Create; TPSExternalProcedure(x).RegProc := xr; FProcs.Add(x); Result := FProcs.Count - 1; exit; end; end; Result := InvalidVal; end; {findfunc} function TPSPascalCompiler.UseExternalProc(const Name: tbtString): TPSParametersDecl; var ProcNo: cardinal; proc: TPSProcedure; begin ProcNo := FindProc(FastUppercase(Name)); if ProcNo = InvalidVal then Result := nil else begin proc := TPSProcedure(FProcs[ProcNo]); if Proc is TPSExternalProcedure then begin Result := TPSExternalProcedure(Proc).RegProc.Decl; end else result := nil; end; end; function TPSPascalCompiler.FindBaseType(BaseType: TPSBaseType): TPSType; var l: Longint; x: TPSType; begin for l := 0 to FTypes.Count -1 do begin X := FTypes[l]; if (x.BaseType = BaseType) and (x.ClassType = TPSType) then begin Result := at2ut(x); exit; end; end; X := TPSType.Create; x.Name := ''; x.BaseType := BaseType; {$IFDEF PS_USESSUPPORT} x.DeclareUnit:=fModule; {$ENDIF} x.DeclarePos := InvalidVal; x.DeclareCol := 0; x.DeclareRow := 0; FTypes.Add(x); Result := at2ut(x); end; function TPSPascalCompiler.MakeDecl(decl: TPSParametersDecl): tbtString; var i: Longint; begin if Decl.Result = nil then result := '0' else result := Decl.Result.Name; for i := 0 to decl.ParamCount -1 do begin if decl.GetParam(i).Mode = pmIn then Result := Result + ' @' else Result := Result + ' !'; Result := Result + decl.GetParam(i).aType.Name; end; end; { TPSPascalCompiler } const BtTypeCopy = 255; type TFuncType = (ftProc, ftFunc); function PS_mi2s(i: Cardinal): tbtString; begin SetLength(Result, 4); Cardinal((@Result[1])^) := i; end; function TPSPascalCompiler.AddType(const Name: tbtString; const BaseType: TPSBaseType): TPSType; begin if FProcs = nil then begin raise EPSCompilerException.Create(RPS_OnUseEventOnly); end; case BaseType of btProcPtr: Result := TPSProceduralType.Create; BtTypeCopy: Result := TPSTypeLink.Create; btRecord: Result := TPSRecordType.Create; btArray: Result := TPSArrayType.Create; btStaticArray: Result := TPSStaticArrayType.Create; btEnum: Result := TPSEnumType.Create; btClass: Result := TPSClassType.Create; btExtClass: REsult := TPSUndefinedClassType.Create; btNotificationVariant, btVariant: Result := TPSVariantType.Create; {$IFNDEF PS_NOINTERFACES} btInterface: Result := TPSInterfaceType.Create; {$ENDIF} else Result := TPSType.Create; end; Result.Name := FastUppercase(Name); Result.OriginalName := Name; Result.BaseType := BaseType; {$IFDEF PS_USESSUPPORT} Result.DeclareUnit:=fModule; {$ENDIF} Result.DeclarePos := InvalidVal; Result.DeclareCol := 0; Result.DeclareRow := 0; FTypes.Add(Result); end; function TPSPascalCompiler.AddFunction(const Header: tbtString): TPSRegProc; var Parser: TPSPascalParser; i: Integer; IsFunction: Boolean; VNames, Name: tbtString; Decl: TPSParametersDecl; modifier: TPSParameterMode; VCType: TPSType; x: TPSRegProc; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Parser := TPSPascalParser.Create; Parser.SetText(Header); Decl := TPSParametersDecl.Create; x := nil; try if Parser.CurrTokenId = CSTII_Function then IsFunction := True else if Parser.CurrTokenId = CSTII_Procedure then IsFunction := False else Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']); Parser.Next; if Parser.CurrTokenId <> CSTI_Identifier then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, ['']); Name := Parser.OriginalToken; Parser.Next; if Parser.CurrTokenId = CSTI_OpenRound then begin Parser.Next; if Parser.CurrTokenId <> CSTI_CloseRound then begin while True do begin if Parser.CurrTokenId = CSTII_Out then begin Modifier := pmOut; Parser.Next; end else if Parser.CurrTokenId = CSTII_Const then begin Modifier := pmIn; Parser.Next; end else if Parser.CurrTokenId = CSTII_Var then begin modifier := pmInOut; Parser.Next; end else modifier := pmIn; if Parser.CurrTokenId <> CSTI_Identifier then raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); VNames := Parser.OriginalToken + '|'; Parser.Next; while Parser.CurrTokenId = CSTI_Comma do begin Parser.Next; if Parser.CurrTokenId <> CSTI_Identifier then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); VNames := VNames + Parser.OriginalToken + '|'; Parser.Next; end; if Parser.CurrTokenId <> CSTI_Colon then begin Parser.Free; Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); end; Parser.Next; VCType := FindType(Parser.GetToken); if VCType = nil then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); while Pos(tbtchar('|'), VNames) > 0 do begin with Decl.AddParam do begin Mode := modifier; OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1); aType := VCType; end; Delete(VNames, 1, Pos(tbtchar('|'), VNames)); end; Parser.Next; if Parser.CurrTokenId = CSTI_CloseRound then break; if Parser.CurrTokenId <> CSTI_Semicolon then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); Parser.Next; end; {while} end; {if} Parser.Next; end; {if} if IsFunction then begin if Parser.CurrTokenId <> CSTI_Colon then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); Parser.Next; VCType := FindType(Parser.GetToken); if VCType = nil then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Name]); end else VCType := nil; Decl.Result := VCType; X := TPSRegProc.Create; x.OrgName := Name; x.Name := FastUpperCase(Name); x.ExportName := True; x.Decl.Assign(decl); if Decl.Result = nil then begin x.ImportDecl := x.ImportDecl + #0; end else x.ImportDecl := x.ImportDecl + #1; for i := 0 to Decl.ParamCount -1 do begin if Decl.Params[i].Mode <> pmIn then x.ImportDecl := x.ImportDecl + #1 else x.ImportDecl := x.ImportDecl + #0; end; FRegProcs.Add(x); finally Decl.Free; Parser.Free; end; Result := x; end; function TPSPascalCompiler.MakeHint(const Module: tbtString; E: TPSPascalCompilerHintType; const Param: tbtString): TPSPascalCompilerMessage; var n: TPSPascalCompilerHint; begin N := TPSPascalCompilerHint.Create; n.FHint := e; n.SetParserPos(FParser); n.FModuleName := Module; n.FParam := Param; FMessages.Add(n); Result := n; end; function TPSPascalCompiler.MakeError(const Module: tbtString; E: TPSPascalCompilerErrorType; const Param: tbtString): TPSPascalCompilerMessage; var n: TPSPascalCompilerError; begin N := TPSPascalCompilerError.Create; n.FError := e; n.SetParserPos(FParser); {$IFNDEF PS_USESSUPPORT} n.FModuleName := Module; {$ELSE} if Module <> '' then n.FModuleName := Module else n.FModuleName := fModule; {$ENDIF} n.FParam := Param; FMessages.Add(n); Result := n; end; function TPSPascalCompiler.MakeWarning(const Module: tbtString; E: TPSPascalCompilerWarningType; const Param: tbtString): TPSPascalCompilerMessage; var n: TPSPascalCompilerWarning; begin N := TPSPascalCompilerWarning.Create; n.FWarning := e; n.SetParserPos(FParser); n.FModuleName := Module; n.FParam := Param; FMessages.Add(n); Result := n; end; procedure TPSPascalCompiler.Clear; var l: Longint; begin FDebugOutput := ''; FOutput := ''; for l := 0 to FMessages.Count - 1 do TPSPascalCompilerMessage(FMessages[l]).Free; FMessages.Clear; for L := FAutoFreeList.Count -1 downto 0 do begin TObject(FAutoFreeList[l]).Free; end; FAutoFreeList.Clear; end; procedure CopyVariantContents(Src, Dest: PIfRVariant); begin case src.FType.BaseType of btu8, bts8: dest^.tu8 := src^.tu8; btu16, bts16: dest^.tu16 := src^.tu16; btenum, btu32, bts32: dest^.tu32 := src^.tu32; btsingle: Dest^.tsingle := src^.tsingle; btdouble: Dest^.tdouble := src^.tdouble; btextended: Dest^.textended := src^.textended; btCurrency: Dest^.tcurrency := Src^.tcurrency; btchar: Dest^.tchar := src^.tchar; {$IFNDEF PS_NOINT64}bts64: dest^.ts64 := src^.ts64;{$ENDIF} btset, btstring: tbtstring(dest^.tstring) := tbtstring(src^.tstring); {$IFNDEF PS_NOWIDESTRING} btunicodestring: tbtunicodestring(dest^.tunistring) := tbtunicodestring(src^.tunistring); btwidestring: tbtwidestring(dest^.twidestring) := tbtwidestring(src^.twidestring); btwidechar: Dest^.tchar := src^.tchar; {$ENDIF} end; end; function DuplicateVariant(Src: PIfRVariant): PIfRVariant; begin New(Result); FillChar(Result^, SizeOf(TIfRVariant), 0); CopyVariantContents(Src, Result); end; procedure InitializeVariant(Vari: PIfRVariant; FType: TPSType); begin FillChar(vari^, SizeOf(TIfRVariant), 0); if FType.BaseType = btSet then begin SetLength(tbtstring(vari^.tstring), TPSSetType(FType).ByteSize); fillchar(tbtstring(vari^.tstring)[1], length(tbtstring(vari^.tstring)), 0); end; vari^.FType := FType; end; function NewVariant(FType: TPSType): PIfRVariant; begin New(Result); InitializeVariant(Result, FType); end; procedure FinalizeA(var s: tbtString); overload; begin s := ''; end; procedure FinalizeW(var s: tbtwidestring); overload; begin s := ''; end; procedure FinalizeU(var s: tbtunicodestring); overload; begin s := ''; end; procedure FinalizeVariant(var p: TIfRVariant); begin if (p.FType.BaseType = btString) or (p.FType.basetype = btSet) then finalizeA(tbtstring(p.tstring)) {$IFNDEF PS_NOWIDESTRING} else if p.FType.BaseType = btWideString then finalizeW(tbtWideString(p.twidestring)) // tbtwidestring else if p.FType.BaseType = btUnicodeString then finalizeU(tbtUnicodeString(p.tunistring)); // tbtwidestring {$ENDIF} end; procedure DisposeVariant(p: PIfRVariant); begin if p <> nil then begin FinalizeVariant(p^); Dispose(p); end; end; function TPSPascalCompiler.GetTypeCopyLink(p: TPSType): TPSType; begin if p = nil then Result := nil else if p.BaseType = BtTypeCopy then begin Result := TPSTypeLink(p).LinkTypeNo; end else Result := p; end; function IsIntType(b: TPSBaseType): Boolean; begin case b of btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True; else Result := False; end; end; function IsRealType(b: TPSBaseType): Boolean; begin case b of btSingle, btDouble, btCurrency, btExtended: Result := True; else Result := False; end; end; function IsIntRealType(b: TPSBaseType): Boolean; begin case b of btSingle, btDouble, btCurrency, btExtended, btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True; else Result := False; end; end; function DiffRec(p1, p2: TPSSubItem): Boolean; begin if p1.ClassType = p2.ClassType then begin if P1.ClassType = TPSSubNumber then Result := TPSSubNumber(p1).SubNo <> TPSSubNumber(p2).SubNo else if P1.ClassType = TPSSubValue then Result := TPSSubValue(p1).SubNo <> TPSSubValue(p2).SubNo else Result := False; end else Result := True; end; function SameReg(x1, x2: TPSValue): Boolean; var I: Longint; begin if (x1.ClassType = x2.ClassType) and (X1 is TPSValueVar) then begin if ((x1.ClassType = TPSValueGlobalVar) and (TPSValueGlobalVar(x1).GlobalVarNo = TPSValueGlobalVar(x2).GlobalVarNo)) or ((x1.ClassType = TPSValueLocalVar) and (TPSValueLocalVar(x1).LocalVarNo = TPSValueLocalVar(x2).LocalVarNo)) or ((x1.ClassType = TPSValueParamVar) and (TPSValueParamVar(x1).ParamNo = TPSValueParamVar(x2).ParamNo)) or ((x1.ClassType = TPSValueAllocatedStackVar) and (TPSValueAllocatedStackVar(x1).LocalVarNo = TPSValueAllocatedStackVar(x2).LocalVarNo)) then begin if TPSValueVar(x1).GetRecCount <> TPSValueVar(x2).GetRecCount then begin Result := False; exit; end; for i := 0 to TPSValueVar(x1).GetRecCount -1 do begin if DiffRec(TPSValueVar(x1).RecItem[i], TPSValueVar(x2).RecItem[i]) then begin Result := False; exit; end; end; Result := True; end else Result := False; end else Result := False; end; function GetUInt(Src: PIfRVariant; var s: Boolean): Cardinal; begin case Src.FType.BaseType of btU8: Result := Src^.tu8; btS8: Result := Src^.ts8; btU16: Result := Src^.tu16; btS16: Result := Src^.ts16; btU32: Result := Src^.tu32; btS32: Result := Src^.ts32; {$IFNDEF PS_NOINT64} bts64: Result := src^.ts64; {$ENDIF} btChar: Result := ord(Src^.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := ord(tbtwidechar(src^.twidechar)); {$ENDIF} btEnum: Result := src^.tu32; else begin s := False; Result := 0; end; end; end; function GetInt(Src: PIfRVariant; var s: Boolean): Longint; begin case Src.FType.BaseType of btU8: Result := Src^.tu8; btS8: Result := Src^.ts8; btU16: Result := Src^.tu16; btS16: Result := Src^.ts16; btU32: Result := Src^.tu32; btS32: Result := Src^.ts32; {$IFNDEF PS_NOINT64} bts64: Result := src^.ts64; {$ENDIF} btChar: Result := ord(Src^.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := ord(tbtwidechar(src^.twidechar)); {$ENDIF} btEnum: Result := src^.tu32; else begin s := False; Result := 0; end; end; end; {$IFNDEF PS_NOINT64} function GetInt64(Src: PIfRVariant; var s: Boolean): Int64; begin case Src.FType.BaseType of btU8: Result := Src^.tu8; btS8: Result := Src^.ts8; btU16: Result := Src^.tu16; btS16: Result := Src^.ts16; btU32: Result := Src^.tu32; btS32: Result := Src^.ts32; bts64: Result := src^.ts64; btChar: Result := ord(Src^.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := ord(tbtwidechar(src^.twidechar)); {$ENDIF} btEnum: Result := src^.tu32; else begin s := False; Result := 0; end; end; end; {$ENDIF} function GetReal(Src: PIfRVariant; var s: Boolean): Extended; begin case Src.FType.BaseType of btU8: Result := Src^.tu8; btS8: Result := Src^.ts8; btU16: Result := Src^.tu16; btS16: Result := Src^.ts16; btU32: Result := Src^.tu32; btS32: Result := Src^.ts32; {$IFNDEF PS_NOINT64} bts64: Result := src^.ts64; {$ENDIF} btChar: Result := ord(Src^.tchar); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := ord(tbtwidechar(src^.twidechar)); {$ENDIF} btSingle: Result := Src^.tsingle; btDouble: Result := Src^.tdouble; btCurrency: Result := SRc^.tcurrency; btExtended: Result := Src^.textended; else begin s := False; Result := 0; end; end; end; function GetString(Src: PIfRVariant; var s: Boolean): tbtString; begin case Src.FType.BaseType of btChar: Result := Src^.tchar; btString: Result := tbtstring(src^.tstring); {$IFNDEF PS_NOWIDESTRING} btWideChar: Result := tbtstring(src^.twidechar); btWideString: Result := tbtstring(tbtWideString(src^.twidestring)); btUnicodeString: Result := tbtstring(tbtUnicodeString(src^.tunistring)); {$ENDIF} else begin s := False; Result := ''; end; end; end; {$IFNDEF PS_NOWIDESTRING} function TPSPascalCompiler.GetWideString(Src: PIfRVariant; var s: Boolean): tbtwidestring; begin case Src.FType.BaseType of btChar: Result := tbtWidestring(Src^.tchar); btString: Result := tbtWidestring(tbtstring(src^.tstring)); btWideChar: Result := src^.twidechar; btWideString: Result := tbtWideString(src^.twidestring); btUnicodeString: result := tbtUnicodeString(src^.tunistring); else begin s := False; Result := ''; end; end; end; function TPSPascalCompiler.GetUnicodeString(Src: PIfRVariant; var s: Boolean): tbtunicodestring; begin case Src.FType.BaseType of btChar: Result := tbtWidestring(Src^.tchar); btString: Result := tbtWidestring(tbtstring(src^.tstring)); btWideChar: Result := src^.twidechar; btWideString: Result := tbtWideString(src^.twidestring); btUnicodeString: result := tbtUnicodeString(src^.tunistring); else begin s := False; Result := ''; end; end; end; {$ENDIF} function ab(b: Longint): Longint; begin ab := Longint(b = 0); end; procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer); var i: Longint; begin for i := ByteSize -1 downto 0 do Dest^[i] := Dest^[i] or Src^[i]; end; procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer); var i: Longint; begin for i := ByteSize -1 downto 0 do Dest^[i] := Dest^[i] and not Src^[i]; end; procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer); var i: Longint; begin for i := ByteSize -1 downto 0 do Dest^[i] := Dest^[i] and Src^[i]; end; procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean); var i: Integer; begin for i := ByteSize -1 downto 0 do begin if not (Src^[i] and Dest^[i] = Dest^[i]) then begin Val := False; exit; end; end; Val := True; end; procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean); var i: Longint; begin for i := ByteSize -1 downto 0 do begin if Dest^[i] <> Src^[i] then begin Val := False; exit; end; end; val := True; end; procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean); begin Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0; end; procedure Set_MakeMember(Item: Longint; Src: PByteArray); begin Src^[Item shr 3] := Src^[Item shr 3] or (1 shl (Item and 7)); end; procedure ConvertToBoolean(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; b: Boolean); begin FinalizeVariant(var1^); if FUseUsedTypes then Var1^.FType := se.at2ut(se.FDefaultBoolType) else Var1^.FType := Se.FDefaultBoolType; var1^.tu32 := Ord(b); end; procedure ConvertToString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtString); var atype: TPSType; begin FinalizeVariant(var1^); atype := se.FindBaseType(btString); if FUseUsedTypes then InitializeVariant(var1, se.at2ut(atype)) else InitializeVariant(var1, atype); tbtstring(var1^.tstring) := s; end; {$IFNDEF PS_NOWIDESTRING} procedure ConvertToUnicodeString(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIFRVariant; const s: tbtunicodestring); var atype: TPSType; begin FinalizeVariant(var1^); atype := se.FindBaseType(btUnicodeString); if FUseUsedTypes then InitializeVariant(var1, se.at2ut(atype)) else InitializeVariant(var1, atype); tbtunicodestring(var1^.tunistring) := s; end; {$ENDIF} procedure ConvertToFloat(SE: TPSPascalCompiler; FUseUsedTypes: Boolean; var1: PIfRVariant; NewType: TPSType); var vartemp: PIfRVariant; b: Boolean; begin New(vartemp); b := false; if FUseUsedTypes then NewType := se.at2ut(NewType); InitializeVariant(vartemp, var1.FType); CopyVariantContents(var1, vartemp); FinalizeVariant(var1^); InitializeVariant(var1, newtype); case var1.ftype.basetype of btSingle: begin if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then var1^.tsingle := GetUInt(vartemp, b) else var1^.tsingle := GetInt(vartemp, b) end; btDouble: begin if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then var1^.tdouble := GetUInt(vartemp, b) else var1^.tdouble := GetInt(vartemp, b) end; btExtended: begin if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then var1^.textended:= GetUInt(vartemp, b) else var1^.textended:= GetInt(vartemp, b) end; btCurrency: begin if (vartemp.ftype.BaseType = btu8) or (vartemp.ftype.BaseType = btu16) or (vartemp.ftype.BaseType = btu32) then var1^.tcurrency:= GetUInt(vartemp, b) else var1^.tcurrency:= GetInt(vartemp, b) end; end; DisposeVariant(vartemp); end; function TPSPascalCompiler.IsCompatibleType(p1, p2: TPSType; Cast: Boolean): Boolean; begin if ((p1.BaseType = btProcPtr) and (p2 = p1)) or (p1.BaseType = btPointer) or (p2.BaseType = btPointer) or ((p1.BaseType = btNotificationVariant) or (p1.BaseType = btVariant)) or ((p2.BaseType = btNotificationVariant) or (p2.BaseType = btVariant)) or (IsIntType(p1.BaseType) and IsIntType(p2.BaseType)) or (IsRealType(p1.BaseType) and IsIntRealType(p2.BaseType)) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and ((p2.BaseType = btString) or (p2.BaseType = btPchar))) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btChar)) or (((p1.BaseType = btArray) or (p1.BaseType = btStaticArray)) and ( (p2.BaseType = btArray) or (p2.BaseType = btStaticArray)) and IsCompatibleType(TPSArrayType(p1).ArrayTypeNo, TPSArrayType(p2).ArrayTypeNo, False)) or ((p1.BaseType = btChar) and (p2.BaseType = btChar)) or ((p1.BaseType = btSet) and (p2.BaseType = btSet)) or {$IFNDEF PS_NOWIDESTRING} ((p1.BaseType = btWideChar) and (p2.BaseType = btChar)) or ((p1.BaseType = btWideChar) and (p2.BaseType = btWideChar)) or ((p1.BaseType = btWidestring) and (p2.BaseType = btChar)) or ((p1.BaseType = btWidestring) and (p2.BaseType = btWideChar)) or ((p1.BaseType = btWidestring) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or ((p1.BaseType = btWidestring) and ((p2.BaseType = btWidestring))) or ((p1.BaseType = btUnicodeString) and (p2.BaseType = btChar)) or ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWideChar)) or ((p1.BaseType = btUnicodeString) and ((p2.BaseType = btString) or (p2.BaseType = btPchar) or (p2.BaseType = btUnicodeString))) or ((p1.BaseType = btUnicodeString) and (p2.BaseType = btWidestring)) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWideString)or (p2.BaseType = btUnicodeString)) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btWidechar)) or (((p1.basetype = btPchar) or (p1.BaseType = btString)) and (p2.BaseType = btchar)) or {$ENDIF} ((p1.BaseType = btRecord) and (p2.BaseType = btrecord) and (not IsVarInCompatible(p1, p2))) or ((p1.BaseType = btEnum) and (p2.BaseType = btEnum)) or (Cast and IsIntType(P1.BaseType) and (p2.baseType = btEnum)) or (Cast and (p1.baseType = btEnum) and IsIntType(P2.BaseType)) then Result := True // nx change start - allow casting class -> integer and vice versa else if p1.BaseType = btclass then Result := TPSClassType(p1).cl.IsCompatibleWith(p2) or (p2.BaseType in [btU32, btS32]) else if (p1.BaseType in [btU32, btS32]) then Result := (p2.BaseType = btClass) // nx change end {$IFNDEF PS_NOINTERFACES} else if p1.BaseType = btInterface then Result := TPSInterfaceType(p1).Intf.IsCompatibleWith(p2) {$ENDIF} else if ((p1.BaseType = btExtClass) and (p2.BaseType = btExtClass)) then begin Result := TPSUndefinedClassType(p1).ExtClass.IsCompatibleWith(TPSUndefinedClassType(p2).ExtClass); end else Result := False; end; function TPSPascalCompiler.PreCalc(FUseUsedTypes: Boolean; Var1Mod: Byte; var1: PIFRVariant; Var2Mod: Byte; Var2: PIfRVariant; Cmd: TPSBinOperatorType; Pos, Row, Col: Cardinal): Boolean; { var1=dest, var2=src } var b: Boolean; begin Result := True; try if (IsRealType(var2.FType.BaseType) and IsIntType(var1.FType.BaseType)) then ConvertToFloat(Self, FUseUsedTypes, var1, var2^.FType); case Cmd of otAdd: begin { + } case var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 + GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 + GetInt(Var2, Result); btU16: var1^.tu16 := var1^.tu16 + GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 + Getint(Var2, Result); btEnum, btU32: var1^.tu32 := var1^.tu32 + GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 + Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 + GetInt64(Var2, Result); {$ENDIF} btSingle: var1^.tsingle := var1^.tsingle + GetReal( Var2, Result); btDouble: var1^.tdouble := var1^.tdouble + GetReal( Var2, Result); btExtended: var1^.textended := var1^.textended + GetReal( Var2, Result); btCurrency: var1^.tcurrency := var1^.tcurrency + GetReal( Var2, Result); btSet: begin if (var1.FType = var2.FType) then begin Set_Union(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize); end else Result := False; end; btChar: begin ConvertToString(Self, FUseUsedTypes, var1, getstring(Var1, b)+getstring(Var2, b)); end; btString: tbtstring(var1^.tstring) := tbtstring(var1^.tstring) + GetString(Var2, Result); {$IFNDEF PS_NOWIDESTRING} btwideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result); btUnicodeString: tbtunicodestring(var1^.tunistring) := tbtunicodestring(var1^.tunistring) + GetUnicodeString(Var2, Result); btWidechar: begin ConvertToUnicodeString(Self, FUseUsedTypes, var1, GetUnicodeString(Var1, b)+GetUnicodeString(Var2, b)); end; {$ENDIF} else Result := False; end; end; otSub: begin { - } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 - GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 - Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 - GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 - Getint(Var2, Result); btEnum, btU32: var1^.tu32 := var1^.tu32 - GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 - Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 - GetInt64(Var2, Result); {$ENDIF} btSingle: var1^.tsingle := var1^.tsingle - GetReal( Var2, Result); btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result); btExtended: var1^.textended := var1^.textended - GetReal(Var2, Result); btCurrency: var1^.tcurrency := var1^.tcurrency - GetReal( Var2, Result); btSet: begin if (var1.FType = var2.FType) then begin Set_Diff(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize); end else Result := False; end; else Result := False; end; end; otMul: begin { * } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 * GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 * Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 * GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 * Getint(Var2, Result); btU32: var1^.tu32 := var1^.tu32 * GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 * Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 * GetInt64(Var2, Result); {$ENDIF} btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result); btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result); btExtended: var1^.textended := var1^.textended * GetReal( Var2, Result); btCurrency: var1^.tcurrency := var1^.tcurrency * GetReal( Var2, Result); btSet: begin if (var1.FType = var2.FType) then begin Set_Intersect(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize); end else Result := False; end; else Result := False; end; end; {$IFDEF PS_DELPHIDIV} otDiv: begin { / } if IsIntType(var1.FType.BaseType) then ConvertToFloat(self, FUseUsedTypes, var1, Self.FindType('EXTENDED')); case Var1.FType.BaseType of btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result); btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result); btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result); btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result); else Result := False; end; end; otIntDiv: begin { / } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result); btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF} else Result := False; end; end; {$ELSE} otDiv, otIntDiv: begin { / } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 div GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 div Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 div GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 div Getint(Var2, Result); btU32: var1^.tu32 := var1^.tu32 div GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 div Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 div GetInt64(Var2, Result); {$ENDIF} btSingle: var1^.tsingle := var1^.tsingle / GetReal( Var2, Result); btDouble: var1^.tdouble := var1^.tdouble / GetReal( Var2, Result); btExtended: var1^.textended := var1^.textended / GetReal( Var2, Result); btCurrency: var1^.tcurrency := var1^.tcurrency / GetReal( Var2, Result); else Result := False; end; end; {$ENDIF} otMod: begin { MOD } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 mod GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 mod Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 mod GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 mod Getint(Var2, Result); btU32: var1^.tu32 := var1^.tu32 mod GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 mod Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 mod GetInt64(Var2, Result); {$ENDIF} else Result := False; end; end; otshl: begin { SHL } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 shl GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 shl Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 shl GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 shl Getint(Var2, Result); btU32: var1^.tu32 := var1^.tu32 shl GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 shl Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shl GetInt64(Var2, Result); {$ENDIF} else Result := False; end; end; otshr: begin { SHR } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 shr GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 shr Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 shr GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 shr Getint(Var2, Result); btU32: var1^.tu32 := var1^.tu32 shr GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 shr Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 shr GetInt64( Var2, Result); {$ENDIF} else Result := False; end; end; otAnd: begin { AND } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 and GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 and Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 and GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 and Getint(Var2, Result); btU32: var1^.tu32 := var1^.tu32 and GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 and Getint(Var2, Result); btEnum: var1^.ts32 := var1^.ts32 and Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 and GetInt64(Var2, Result); {$ENDIF} else Result := False; end; end; otor: begin { OR } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 or GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 or Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 or GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 or Getint(Var2, Result); btU32: var1^.tu32 := var1^.tu32 or GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 or Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 or GetInt64(Var2, Result); {$ENDIF} btEnum: var1^.ts32 := var1^.ts32 or Getint(Var2, Result); else Result := False; end; end; otxor: begin { XOR } case Var1.FType.BaseType of btU8: var1^.tu8 := var1^.tu8 xor GetUint(Var2, Result); btS8: var1^.ts8 := var1^.ts8 xor Getint(Var2, Result); btU16: var1^.tu16 := var1^.tu16 xor GetUint(Var2, Result); btS16: var1^.ts16 := var1^.ts16 xor Getint(Var2, Result); btU32: var1^.tu32 := var1^.tu32 xor GetUint(Var2, Result); btS32: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: var1^.ts64 := var1^.ts64 xor GetInt64(Var2, Result); {$ENDIF} btEnum: var1^.ts32 := var1^.ts32 xor Getint(Var2, Result); else Result := False; end; end; otGreaterEqual: begin { >= } case Var1.FType.BaseType of btU8: b := var1^.tu8 >= GetUint(Var2, Result); btS8: b := var1^.ts8 >= Getint(Var2, Result); btU16: b := var1^.tu16 >= GetUint(Var2, Result); btS16: b := var1^.ts16 >= Getint(Var2, Result); btU32: b := var1^.tu32 >= GetUint(Var2, Result); btS32: b := var1^.ts32 >= Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 >= GetInt64(Var2, Result); {$ENDIF} btSingle: b := var1^.tsingle >= GetReal( Var2, Result); btDouble: b := var1^.tdouble >= GetReal( Var2, Result); btExtended: b := var1^.textended >= GetReal( Var2, Result); btCurrency: b := var1^.tcurrency >= GetReal( Var2, Result); btSet: begin if (var1.FType = var2.FType) then begin Set_Subset(var2.tstring, var1.tstring, TPSSetType(var1.FType).ByteSize, b); end else Result := False; end; else Result := False; end; ConvertToBoolean(Self, FUseUsedTypes, Var1, b); end; otLessEqual: begin { <= } case Var1.FType.BaseType of btU8: b := var1^.tu8 <= GetUint(Var2, Result); btS8: b := var1^.ts8 <= Getint(Var2, Result); btU16: b := var1^.tu16 <= GetUint(Var2, Result); btS16: b := var1^.ts16 <= Getint(Var2, Result); btU32: b := var1^.tu32 <= GetUint(Var2, Result); btS32: b := var1^.ts32 <= Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <= GetInt64(Var2, Result); {$ENDIF} btSingle: b := var1^.tsingle <= GetReal( Var2, Result); btDouble: b := var1^.tdouble <= GetReal( Var2, Result); btExtended: b := var1^.textended <= GetReal( Var2, Result); btCurrency: b := var1^.tcurrency <= GetReal( Var2, Result); btSet: begin if (var1.FType = var2.FType) then begin Set_Subset(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b); end else Result := False; end; else Result := False; end; ConvertToBoolean(Self, FUseUsedTypes, Var1, b); end; otGreater: begin { > } case Var1.FType.BaseType of btU8: b := var1^.tu8 > GetUint(Var2, Result); btS8: b := var1^.ts8 > Getint(Var2, Result); btU16: b := var1^.tu16 > GetUint(Var2, Result); btS16: b := var1^.ts16 > Getint(Var2, Result); btU32: b := var1^.tu32 > GetUint(Var2, Result); btS32: b := var1^.ts32 > Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 > GetInt64(Var2, Result); {$ENDIF} btSingle: b := var1^.tsingle > GetReal( Var2, Result); btDouble: b := var1^.tdouble > GetReal( Var2, Result); btExtended: b := var1^.textended > GetReal( Var2, Result); btCurrency: b := var1^.tcurrency > GetReal( Var2, Result); else Result := False; end; ConvertToBoolean(Self, FUseUsedTypes, Var1, b); end; otLess: begin { < } case Var1.FType.BaseType of btU8: b := var1^.tu8 < GetUint(Var2, Result); btS8: b := var1^.ts8 < Getint(Var2, Result); btU16: b := var1^.tu16 < GetUint(Var2, Result); btS16: b := var1^.ts16 < Getint(Var2, Result); btU32: b := var1^.tu32 < GetUint(Var2, Result); btS32: b := var1^.ts32 < Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 < GetInt64(Var2, Result); {$ENDIF} btSingle: b := var1^.tsingle < GetReal( Var2, Result); btDouble: b := var1^.tdouble < GetReal( Var2, Result); btExtended: b := var1^.textended < GetReal( Var2, Result); btCurrency: b := var1^.tcurrency < GetReal( Var2, Result); else Result := False; end; ConvertToBoolean(Self, FUseUsedTypes, Var1, b); end; otNotEqual: begin { <> } case Var1.FType.BaseType of btU8: b := var1^.tu8 <> GetUint(Var2, Result); btS8: b := var1^.ts8 <> Getint(Var2, Result); btU16: b := var1^.tu16 <> GetUint(Var2, Result); btS16: b := var1^.ts16 <> Getint(Var2, Result); btU32: b := var1^.tu32 <> GetUint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 <> GetInt64(Var2, Result); {$ENDIF} btS32: b := var1^.ts32 <> Getint(Var2, Result); btSingle: b := var1^.tsingle <> GetReal( Var2, Result); btDouble: b := var1^.tdouble <> GetReal( Var2, Result); btExtended: b := var1^.textended <> GetReal( Var2, Result); btCurrency: b := var1^.tcurrency <> GetReal( Var2, Result); btEnum: b := var1^.ts32 <> Getint(Var2, Result); btString: b := tbtstring(var1^.tstring) <> GetString(var2, Result); btChar: b := var1^.tchar <> GetString(var2, Result); {$IFNDEF PS_NOWIDESTRING} btWideString: b := tbtWideString(var1^.twidestring) <> GetWideString(var2, Result); btUnicodeString: b := tbtUnicodeString(var1^.tunistring) <> GetUnicodeString(var2, Result); btWideChar: b := var1^.twidechar <> GetUnicodeString(var2, Result); {$ENDIF} btSet: begin if (var1.FType = var2.FType) then begin Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).GetByteSize, b); b := not b; end else Result := False; end; else Result := False; end; ConvertToBoolean(Self, FUseUsedTypes, Var1, b); end; otEqual: begin { = } case Var1.FType.BaseType of btU8: b := var1^.tu8 = GetUint(Var2, Result); btS8: b := var1^.ts8 = Getint(Var2, Result); btU16: b := var1^.tu16 = GetUint(Var2, Result); btS16: b := var1^.ts16 = Getint(Var2, Result); btU32: b := var1^.tu32 = GetUint(Var2, Result); btS32: b := var1^.ts32 = Getint(Var2, Result); {$IFNDEF PS_NOINT64}btS64: b := var1^.ts64 = GetInt64(Var2, Result); {$ENDIF} btSingle: b := var1^.tsingle = GetReal( Var2, Result); btDouble: b := var1^.tdouble = GetReal( Var2, Result); btExtended: b := var1^.textended = GetReal( Var2, Result); btCurrency: b := var1^.tcurrency = GetReal( Var2, Result); btEnum: b := var1^.ts32 = Getint(Var2, Result); btString: b := tbtstring(var1^.tstring) = GetString(var2, Result); btChar: b := var1^.tchar = GetString(var2, Result); {$IFNDEF PS_NOWIDESTRING} btWideString: b := tbtWideString(var1^.twidestring) = GetWideString(var2, Result); btUnicodeString: b := tbtUnicodeString(var1^.twidestring) = GetUnicodeString(var2, Result); btWideChar: b := var1^.twidechar = GetUnicodeString(var2, Result); {$ENDIF} btSet: begin if (var1.FType = var2.FType) then begin Set_Equal(var1.tstring, var2.tstring, TPSSetType(var1.FType).ByteSize, b); end else Result := False; end; else Result := False; end; ConvertToBoolean(Self, FUseUsedTypes, Var1, b); end; otIn: begin if (var2.Ftype.BaseType = btset) and (TPSSetType(var2).SetType = Var1.FType) then begin Set_membership(GetUint(var1, result), var2.tstring, b); end else Result := False; end; else Result := False; end; except on E: EDivByZero do begin Result := False; MakeError('', ecDivideByZero, ''); Exit; end; on E: EZeroDivide do begin Result := False; MakeError('', ecDivideByZero, ''); Exit; end; on E: EMathError do begin Result := False; MakeError('', ecMathError, tbtstring(e.Message)); Exit; end; on E: Exception do begin Result := False; MakeError('', ecInternalError, tbtstring(E.Message)); Exit; end; end; if not Result then begin with MakeError('', ecTypeMismatch, '') do begin FPosition := Pos; FRow := Row; FCol := Col; end; end; end; function TPSPascalCompiler.IsDuplicate(const s: tbtString; const check: TPSDuplicCheck): Boolean; var h, l: Longint; x: TPSProcedure; begin h := MakeHash(s); if (s = 'RESULT') then begin Result := True; exit; end; if dcTypes in Check then for l := FTypes.Count - 1 downto 0 do begin if (TPSType(FTypes.Data[l]).NameHash = h) and (TPSType(FTypes.Data[l]).Name = s) then begin Result := True; exit; end; end; if dcProcs in Check then for l := FProcs.Count - 1 downto 0 do begin x := FProcs.Data[l]; if x.ClassType = TPSInternalProcedure then begin if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then begin Result := True; exit; end; end else begin if (TPSExternalProcedure(x).RegProc.NameHash = h) and (TPSExternalProcedure(x).RegProc.Name = s) then begin Result := True; exit; end; end; end; if dcVars in Check then for l := FVars.Count - 1 downto 0 do begin if (TPSVar(FVars.Data[l]).NameHash = h) and (TPSVar(FVars.Data[l]).Name = s) then begin Result := True; exit; end; end; if dcConsts in Check then for l := FConstants.Count -1 downto 0 do begin if (TPSConstant(FConstants.Data[l]).NameHash = h) and (TPSConstant(FConstants.Data[l]).Name = s) then begin Result := TRue; exit; end; end; Result := False; end; procedure ClearRecSubVals(RecSubVals: TPSList); var I: Longint; begin for I := 0 to RecSubVals.Count - 1 do TPSRecordFieldTypeDef(RecSubVals[I]).Free; RecSubVals.Free; end; function TPSPascalCompiler.ReadTypeAddProcedure(const Name: tbtString; FParser: TPSPascalParser): TPSType; var IsFunction: Boolean; VNames: tbtString; modifier: TPSParameterMode; Decl: TPSParametersDecl; VCType: TPSType; begin if FParser.CurrTokenId = CSTII_Function then IsFunction := True else IsFunction := False; Decl := TPSParametersDecl.Create; try FParser.Next; if FParser.CurrTokenId = CSTI_OpenRound then begin FParser.Next; if FParser.CurrTokenId <> CSTI_CloseRound then begin while True do begin if FParser.CurrTokenId = CSTII_Const then begin Modifier := pmIn; FParser.Next; end else if FParser.CurrTokenId = CSTII_Out then begin Modifier := pmOut; FParser.Next; end else if FParser.CurrTokenId = CSTII_Var then begin modifier := pmInOut; FParser.Next; end else modifier := pmIn; if FParser.CurrTokenId <> CSTI_Identifier then begin Result := nil; if FParser = Self.FParser then MakeError('', ecIdentifierExpected, ''); exit; end; VNames := FParser.OriginalToken + '|'; FParser.Next; while FParser.CurrTokenId = CSTI_Comma do begin FParser.Next; if FParser.CurrTokenId <> CSTI_Identifier then begin Result := nil; if FParser = Self.FParser then MakeError('', ecIdentifierExpected, ''); exit; end; VNames := VNames + FParser.GetToken + '|'; FParser.Next; end; if FParser.CurrTokenId <> CSTI_Colon then begin Result := nil; if FParser = Self.FParser then MakeError('', ecColonExpected, ''); exit; end; FParser.Next; if FParser.CurrTokenId <> CSTI_Identifier then begin Result := nil; if FParser = self.FParser then MakeError('', ecIdentifierExpected, ''); exit; end; VCType := FindType(FParser.GetToken); if VCType = nil then begin if FParser = self.FParser then MakeError('', ecUnknownIdentifier, FParser.OriginalToken); Result := nil; exit; end; while Pos(tbtchar('|'), VNames) > 0 do begin with Decl.AddParam do begin Mode := modifier; OrgName := copy(VNames, 1, Pos(tbtchar('|'), VNames) - 1); FType := VCType; end; Delete(VNames, 1, Pos(tbtchar('|'), VNames)); end; FParser.Next; if FParser.CurrTokenId = CSTI_CloseRound then break; if FParser.CurrTokenId <> CSTI_Semicolon then begin if FParser = Self.FParser then MakeError('', ecSemicolonExpected, ''); Result := nil; exit; end; FParser.Next; end; {while} end; {if} FParser.Next; end; {if} if IsFunction then begin if FParser.CurrTokenId <> CSTI_Colon then begin if FParser = Self.FParser then MakeError('', ecColonExpected, ''); Result := nil; exit; end; FParser.Next; if FParser.CurrTokenId <> CSTI_Identifier then begin Result := nil; if FParser = Self.FParser then MakeError('', ecIdentifierExpected, ''); exit; end; VCType := self.FindType(FParser.GetToken); if VCType = nil then begin if FParser = self.FParser then MakeError('', ecUnknownIdentifier, FParser.OriginalToken); Result := nil; exit; end; FParser.Next; end else VCType := nil; Decl.Result := VcType; VCType := TPSProceduralType.Create; VCType.Name := FastUppercase(Name); VCType.OriginalName := Name; VCType.BaseType := btProcPtr; {$IFDEF PS_USESSUPPORT} VCType.DeclareUnit:=fModule; {$ENDIF} VCType.DeclarePos := FParser.CurrTokenPos; VCType.DeclareRow := FParser.Row; VCType.DeclareCol := FParser.Col; TPSProceduralType(VCType).ProcDef.Assign(Decl); FTypes.Add(VCType); Result := VCType; finally Decl.Free; end; end; {ReadTypeAddProcedure} function TPSPascalCompiler.ReadType(const Name: tbtString; FParser: TPSPascalParser): TPSType; // InvalidVal = Invalid var TypeNo: TPSType; h, l: Longint; FieldName,fieldorgname,s: tbtString; RecSubVals: TPSList; FArrayStart, FArrayLength: Longint; rvv: PIFPSRecordFieldTypeDef; p, p2: TPSType; tempf: PIfRVariant; {$IFNDEF PS_NOINTERFACES} InheritedFrom: tbtString; Guid: TGUID; Intf: TPSInterface; {$ENDIF} begin if (FParser.CurrTokenID = CSTII_Function) or (FParser.CurrTokenID = CSTII_Procedure) then begin Result := ReadTypeAddProcedure(Name, FParser); Exit; end else if FParser.CurrTokenId = CSTII_Set then begin FParser.Next; if FParser.CurrTokenId <> CSTII_Of then begin MakeError('', ecOfExpected, ''); Result := nil; Exit; end; FParser.Next; if FParser.CurrTokenID <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); Result := nil; exit; end; TypeNo := FindType(FParser.GetToken); if TypeNo = nil then begin MakeError('', ecUnknownIdentifier, ''); Result := nil; exit; end; if (TypeNo.BaseType = btEnum) or (TypeNo.BaseType = btChar) or (TypeNo.BaseType = btU8) then begin FParser.Next; p2 := TPSSetType.Create; p2.Name := FastUppercase(Name); p2.OriginalName := Name; p2.BaseType := btSet; {$IFDEF PS_USESSUPPORT} p2.DeclareUnit:=fModule; {$ENDIF} p2.DeclarePos := FParser.CurrTokenPos; p2.DeclareRow := FParser.Row; p2.DeclareCol := FParser.Col; TPSSetType(p2).SetType := TypeNo; FTypes.Add(p2); Result := p2; end else begin MakeError('', ecTypeMismatch, ''); Result := nil; end; exit; end else if FParser.CurrTokenId = CSTI_OpenRound then begin FParser.Next; L := 0; P2 := TPSEnumType.Create; P2.Name := FastUppercase(Name); p2.OriginalName := Name; p2.BaseType := btEnum; {$IFDEF PS_USESSUPPORT} p2.DeclareUnit:=fModule; {$ENDIF} p2.DeclarePos := FParser.CurrTokenPos; p2.DeclareRow := FParser.Row; p2.DeclareCol := FParser.Col; FTypes.Add(p2); repeat if FParser.CurrTokenId <> CSTI_Identifier then begin if FParser = Self.FParser then MakeError('', ecIdentifierExpected, ''); Result := nil; exit; end; s := FParser.OriginalToken; if IsDuplicate(FastUppercase(s), [dcTypes]) then begin if FParser = Self.FParser then MakeError('', ecDuplicateIdentifier, s); Result := nil; Exit; end; with AddConstant(s, p2) do begin FValue.tu32 := L; {$IFDEF PS_USESSUPPORT} DeclareUnit:=fModule; {$ENDIF} DeclarePos:=FParser.CurrTokenPos; DeclareRow:=FParser.Row; DeclareCol:=FParser.Col; end; Inc(L); FParser.Next; if FParser.CurrTokenId = CSTI_CloseRound then Break else if FParser.CurrTokenId <> CSTI_Comma then begin if FParser = Self.FParser then MakeError('', ecCloseRoundExpected, ''); Result := nil; Exit; end; FParser.Next; until False; FParser.Next; TPSEnumType(p2).HighValue := L-1; Result := p2; exit; end else if FParser.CurrTokenId = CSTII_Array then begin FParser.Next; if FParser.CurrTokenID = CSTI_OpenBlock then begin FParser.Next; tempf := ReadConstant(FParser, CSTI_TwoDots); if tempf = nil then begin Result := nil; exit; end; case tempf.FType.BaseType of btU8: FArrayStart := tempf.tu8; btS8: FArrayStart := tempf.ts8; btU16: FArrayStart := tempf.tu16; btS16: FArrayStart := tempf.ts16; btU32: FArrayStart := tempf.tu32; btS32: FArrayStart := tempf.ts32; {$IFNDEF PS_NOINT64} bts64: FArrayStart := tempf.ts64; {$ENDIF} else begin DisposeVariant(tempf); MakeError('', ecTypeMismatch, ''); Result := nil; exit; end; end; DisposeVariant(tempf); if FParser.CurrTokenID <> CSTI_TwoDots then begin MakeError('', ecPeriodExpected, ''); Result := nil; exit; end; FParser.Next; tempf := ReadConstant(FParser, CSTI_CloseBlock); if tempf = nil then begin Result := nil; exit; end; case tempf.FType.BaseType of btU8: FArrayLength := tempf.tu8; btS8: FArrayLength := tempf.ts8; btU16: FArrayLength := tempf.tu16; btS16: FArrayLength := tempf.ts16; btU32: FArrayLength := tempf.tu32; btS32: FArrayLength := tempf.ts32; {$IFNDEF PS_NOINT64} bts64: FArrayLength := tempf.ts64; {$ENDIF} else DisposeVariant(tempf); MakeError('', ecTypeMismatch, ''); Result := nil; exit; end; DisposeVariant(tempf); FArrayLength := FArrayLength - FArrayStart + 1; if (FArrayLength < 0) or (FArrayLength > MaxInt div 4) then begin MakeError('', ecTypeMismatch, ''); Result := nil; exit; end; if FParser.CurrTokenID <> CSTI_CloseBlock then begin MakeError('', ecCloseBlockExpected, ''); Result := nil; exit; end; FParser.Next; end else begin FArrayStart := 0; FArrayLength := -1; end; if FParser.CurrTokenId <> CSTII_Of then begin if FParser = Self.FParser then MakeError('', ecOfExpected, ''); Result := nil; exit; end; FParser.Next; TypeNo := ReadType('', FParser); if TypeNo = nil then begin if FParser = Self.FParser then MakeError('', ecUnknownIdentifier, ''); Result := nil; exit; end; if (Name = '') and (FArrayLength = -1) then begin if TypeNo.Used then begin for h := 0 to FTypes.Count -1 do begin p := FTypes[H]; if (p.BaseType = btArray) and (TPSArrayType(p).ArrayTypeNo = TypeNo) and (Copy(p.Name, 1, 1) <> '!') then begin Result := p; exit; end; end; end; end; if FArrayLength <> -1 then begin p := TPSStaticArrayType.Create; TPSStaticArrayType(p).StartOffset := FArrayStart; TPSStaticArrayType(p).Length := FArrayLength; p.BaseType := btStaticArray; end else begin p := TPSArrayType.Create; p.BaseType := btArray; end; p.Name := FastUppercase(Name); p.OriginalName := Name; {$IFDEF PS_USESSUPPORT} p.DeclareUnit:=fModule; {$ENDIF} p.DeclarePos := FParser.CurrTokenPos; p.DeclareRow := FParser.Row; p.DeclareCol := FParser.Col; TPSArrayType(p).ArrayTypeNo := TypeNo; FTypes.Add(p); Result := p; Exit; end else if FParser.CurrTokenId = CSTII_Record then begin FParser.Next; RecSubVals := TPSList.Create; repeat repeat if FParser.CurrTokenId <> CSTI_Identifier then begin ClearRecSubVals(RecSubVals); if FParser = Self.FParser then MakeError('', ecIdentifierExpected, ''); Result := nil; exit; end; FieldName := FParser.GetToken; s := S+FParser.OriginalToken+'|'; FParser.Next; h := MakeHash(FieldName); for l := 0 to RecSubVals.Count - 1 do begin if (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldNameHash = h) and (PIFPSRecordFieldTypeDef(RecSubVals[l]).FieldName = FieldName) then begin if FParser = Self.FParser then MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); ClearRecSubVals(RecSubVals); Result := nil; exit; end; end; if FParser.CurrTokenID = CSTI_Colon then Break else if FParser.CurrTokenID <> CSTI_Comma then begin if FParser = Self.FParser then MakeError('', ecColonExpected, ''); ClearRecSubVals(RecSubVals); Result := nil; exit; end; FParser.Next; until False; FParser.Next; p := ReadType('', FParser); if p = nil then begin ClearRecSubVals(RecSubVals); Result := nil; exit; end; p := GetTypeCopyLink(p); if FParser.CurrTokenId <> CSTI_Semicolon then begin ClearRecSubVals(RecSubVals); if FParser = Self.FParser then MakeError('', ecSemicolonExpected, ''); Result := nil; exit; end; {if} FParser.Next; while Pos(tbtchar('|'), s) > 0 do begin fieldorgname := copy(s, 1, Pos(tbtchar('|'), s)-1); Delete(s, 1, length(FieldOrgName)+1); rvv := TPSRecordFieldTypeDef.Create; rvv.FieldOrgName := fieldorgname; rvv.FType := p; RecSubVals.Add(rvv); end; until FParser.CurrTokenId = CSTII_End; FParser.Next; // skip CSTII_End P := TPSRecordType.Create; p.Name := FastUppercase(Name); p.OriginalName := Name; p.BaseType := btRecord; {$IFDEF PS_USESSUPPORT} p.DeclareUnit:=fModule; {$ENDIF} p.DeclarePos := FParser.CurrTokenPos; p.DeclareRow := FParser.Row; p.DeclareCol := FParser.Col; for l := 0 to RecSubVals.Count -1 do begin rvv := RecSubVals[l]; with TPSRecordType(p).AddRecVal do begin FieldOrgName := rvv.FieldOrgName; FType := rvv.FType; end; rvv.Free; end; RecSubVals.Free; FTypes.Add(p); Result := p; Exit; {$IFNDEF PS_NOINTERFACES} end else if FParser.CurrTokenId = CSTII_Interface then begin FParser.Next; if FParser.CurrTokenId <> CSTI_OpenRound then begin MakeError('', ecOpenRoundExpected, ''); Result := nil; Exit; end; FParser.Next; if FParser.CurrTokenID <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); Result := nil; exit; end; InheritedFrom := FParser.GetToken; TypeNo := FindType(InheritedFrom); if TypeNo = nil then begin MakeError('', ecUnknownType, FParser.GetToken); Result := nil; exit; end; if TypeNo.BaseType <> btInterface then begin MakeError('', ecTypeMismatch, ''); Result := nil; Exit; end; FParser.Next; if FParser.CurrTokenId <> CSTI_CloseRound then begin MakeError('', ecCloseRoundExpected, ''); Result := nil; Exit; end; {$IFNDEF PS_NOINTERFACEGUIDBRACKETS} FParser.Next; if FParser.CurrTokenId <> CSTI_OpenBlock then begin MakeError('', ecOpenBlockExpected, ''); Result := nil; Exit; end; {$ENDIF} FParser.Next; if FParser.CurrTokenId <> CSTI_String then begin MakeError('', ecStringExpected, ''); Result := nil; Exit; end; s := FParser.GetToken; try Guid := StringToGuid(String(Copy(s, 2, Length(s)-2))); except on e: Exception do begin MakeError('', ecCustomError, tbtstring(e.Message)); Result := nil; Exit; end; end; {$IFNDEF PS_NOINTERFACEGUIDBRACKETS} FParser.Next; if FParser.CurrTokenId <> CSTI_CloseBlock then begin MakeError('', ecCloseBlockExpected, ''); Result := nil; Exit; end; {$ENDIF} Intf := AddInterface(FindInterface(InheritedFrom), Guid, Name); FParser.Next; repeat if not Intf.RegisterMethodEx('', cdStdCall, FParser) then begin MakeError('', ecCustomError, 'Invalid method'); Result := nil; Exit; end; FParser.Next; until FParser.CurrTokenId = CSTII_End; FParser.Next; // skip CSTII_End Result := Intf.FType; Exit; {$ENDIF} end else if FParser.CurrTokenId = CSTI_Identifier then begin s := FParser.GetToken; h := MakeHash(s); Typeno := nil; for l := 0 to FTypes.Count - 1 do begin p2 := FTypes[l]; if (p2.NameHash = h) and (p2.Name = s) then begin FParser.Next; Typeno := GetTypeCopyLink(p2); Break; end; end; if Typeno = nil then begin Result := nil; if FParser = Self.FParser then MakeError('', ecUnknownType, FParser.OriginalToken); exit; end; if Name <> '' then begin p := TPSTypeLink.Create; p.Name := FastUppercase(Name); p.OriginalName := Name; p.BaseType := BtTypeCopy; {$IFDEF PS_USESSUPPORT} p.DeclareUnit:=fModule; {$ENDIF} p.DeclarePos := FParser.CurrTokenPos; p.DeclareRow := FParser.Row; p.DeclareCol := FParser.Col; TPSTypeLink(p).LinkTypeNo := TypeNo; FTypes.Add(p); Result := p; Exit; end else begin Result := TypeNo; exit; end; end; Result := nil; if FParser = Self.FParser then MakeError('', ecIdentifierExpected, ''); Exit; end; function TPSPascalCompiler.VarIsDuplicate(Proc: TPSInternalProcedure; const Varnames, s: tbtString): Boolean; var h, l: Longint; x: TPSProcedure; v: tbtString; begin h := MakeHash(s); if (s = 'RESULT') then begin Result := True; exit; end; for l := FProcs.Count - 1 downto 0 do begin x := FProcs.Data[l]; if x.ClassType = TPSInternalProcedure then begin if (h = TPSInternalProcedure(x).NameHash) and (s = TPSInternalProcedure(x).Name) then begin Result := True; exit; end; end else begin if (TPSExternalProcedure(x).RegProc.NameHash = h) and (TPSExternalProcedure(x).RegProc.Name = s) then begin Result := True; exit; end; end; end; if proc <> nil then begin for l := proc.ProcVars.Count - 1 downto 0 do begin if (PIFPSProcVar(proc.ProcVars.Data[l]).NameHash = h) and (PIFPSProcVar(proc.ProcVars.Data[l]).Name = s) then begin Result := True; exit; end; end; for l := Proc.FDecl.ParamCount -1 downto 0 do begin if (Proc.FDecl.Params[l].Name = s) then begin Result := True; exit; end; end; end else begin for l := FVars.Count - 1 downto 0 do begin if (TPSVar(FVars.Data[l]).NameHash = h) and (TPSVar(FVars.Data[l]).Name = s) then begin Result := True; exit; end; end; end; v := VarNames; while Pos(tbtchar('|'), v) > 0 do begin if FastUppercase(copy(v, 1, Pos(tbtchar('|'), v) - 1)) = s then begin Result := True; exit; end; Delete(v, 1, Pos(tbtchar('|'), v)); end; for l := FConstants.Count -1 downto 0 do begin if (TPSConstant(FConstants.Data[l]).NameHash = h) and (TPSConstant(FConstants.Data[l]).Name = s) then begin Result := True; exit; end; end; Result := False; end; function TPSPascalCompiler.DoVarBlock(proc: TPSInternalProcedure): Boolean; var VarName, s: tbtString; VarType: TPSType; VarNo: Cardinal; v: TPSVar; vp: PIFPSProcVar; EPos, ERow, ECol: Integer; begin Result := False; FParser.Next; // skip CSTII_Var if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); exit; end; repeat VarNAme := ''; if VarIsDuplicate(proc, VarName, FParser.GetToken) then begin MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); exit; end; VarName := FParser.OriginalToken + '|'; Varno := 0; if @FOnUseVariable <> nil then begin if Proc <> nil then FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '') else FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '') end; EPos:=FParser.CurrTokenPos; ERow:=FParser.Row; ECol:=FParser.Col; FParser.Next; while FParser.CurrTokenId = CSTI_Comma do begin FParser.Next; if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); end; if VarIsDuplicate(proc, VarName, FParser.GetToken) then begin MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); exit; end; VarName := VarName + FParser.OriginalToken + '|'; Inc(varno); if @FOnUseVariable <> nil then begin if Proc <> nil then FOnUseVariable(Self, ivtVariable, Proc.ProcVars.Count + VarNo, FProcs.Count -1, FParser.CurrTokenPos, '') else FOnUseVariable(Self, ivtGlobal, FVars.Count + VarNo, InvalidVal, FParser.CurrTokenPos, '') end; FParser.Next; end; if FParser.CurrTokenId <> CSTI_Colon then begin MakeError('', ecColonExpected, ''); exit; end; FParser.Next; VarType := at2ut(ReadType('', FParser)); if VarType = nil then begin exit; end; while Pos(tbtchar('|'), VarName) > 0 do begin s := copy(VarName, 1, Pos(tbtchar('|'), VarName) - 1); Delete(VarName, 1, Pos(tbtchar('|'), VarName)); if proc = nil then begin v := TPSVar.Create; v.OrgName := s; v.Name := FastUppercase(s); {$IFDEF PS_USESSUPPORT} v.DeclareUnit:=fModule; {$ENDIF} v.DeclarePos := EPos; v.DeclareRow := ERow; v.DeclareCol := ECol; v.FType := VarType; FVars.Add(v); end else begin vp := TPSProcVar.Create; vp.OrgName := s; vp.Name := FastUppercase(s); vp.aType := VarType; {$IFDEF PS_USESSUPPORT} vp.DeclareUnit:=fModule; {$ENDIF} vp.DeclarePos := EPos; vp.DeclareRow := ERow; vp.DeclareCol := ECol; proc.ProcVars.Add(vp); end; end; if FParser.CurrTokenId <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); exit; end; FParser.Next; until FParser.CurrTokenId <> CSTI_Identifier; Result := True; end; function TPSPascalCompiler.NewProc(const OriginalName, Name: tbtString): TPSInternalProcedure; begin Result := TPSInternalProcedure.Create; Result.OriginalName := OriginalName; Result.Name := Name; {$IFDEF PS_USESSUPPORT} Result.DeclareUnit:=fModule; {$ENDIF} Result.DeclarePos := FParser.CurrTokenPos; Result.DeclareRow := FParser.Row; Result.DeclareCol := FParser.Col; FProcs.Add(Result); end; function TPSPascalCompiler.IsProcDuplicLabel(Proc: TPSInternalProcedure; const s: tbtString): Boolean; var i: Longint; h: Longint; u: tbtString; begin h := MakeHash(s); if s = 'RESULT' then Result := True else if Proc.Name = s then Result := True else if IsDuplicate(s, [dcVars, dcConsts, dcProcs]) then Result := True else begin for i := 0 to Proc.Decl.ParamCount -1 do begin if Proc.Decl.Params[i].Name = s then begin Result := True; exit; end; end; for i := 0 to Proc.ProcVars.Count -1 do begin if (PIFPSProcVar(Proc.ProcVars[I]).NameHash = h) and (PIFPSProcVar(Proc.ProcVars[I]).Name = s) then begin Result := True; exit; end; end; for i := 0 to Proc.FLabels.Count -1 do begin u := Proc.FLabels[I]; delete(u, 1, 4); if Longint((@u[1])^) = h then begin delete(u, 1, 4); if u = s then begin Result := True; exit; end; end; end; Result := False; end; end; function TPSPascalCompiler.ProcessLabel(Proc: TPSInternalProcedure): Boolean; var CurrLabel: tbtString; begin FParser.Next; while true do begin if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); Result := False; exit; end; CurrLabel := FParser.GetToken; if IsProcDuplicLabel(Proc, CurrLabel) then begin MakeError('', ecDuplicateIdentifier, CurrLabel); Result := False; exit; end; FParser.Next; Proc.FLabels.Add(#$FF#$FF#$FF#$FF+PS_mi2s(MakeHash(CurrLabel))+CurrLabel); if FParser.CurrTokenId = CSTI_Semicolon then begin FParser.Next; Break; end; if FParser.CurrTokenId <> CSTI_Comma then begin MakeError('', ecCommaExpected, ''); Result := False; exit; end; FParser.Next; end; Result := True; end; procedure TPSPascalCompiler.Debug_SavePosition(ProcNo: Cardinal; Proc: TPSInternalProcedure); var Row, Col, Pos: Cardinal; s: tbtString; begin Row := FParser.Row; Col := FParser.Col; Pos := FParser.CurrTokenPos; {$IFNDEF PS_USESSUPPORT} s := ''; {$ELSE} s := fModule; {$ENDIF} if @FOnTranslateLineInfo <> nil then FOnTranslateLineInfo(Self, Pos, Row, Col, S); {$IFDEF FPC} WriteDebugData(#4 + s + #1); WriteDebugData(Ps_mi2s(ProcNo)); WriteDebugData(Ps_mi2s(Length(Proc.Data))); WriteDebugData(Ps_mi2s(Pos)); WriteDebugData(Ps_mi2s(Row)); WriteDebugData(Ps_mi2s(Col)); {$ELSE} WriteDebugData(#4 + s + #1 + PS_mi2s(ProcNo) + PS_mi2s(Length(Proc.Data)) + PS_mi2s(Pos) + PS_mi2s(Row)+ PS_mi2s(Col)); {$ENDIF} end; procedure TPSPascalCompiler.Debug_WriteParams(ProcNo: Cardinal; Proc: TPSInternalProcedure); var I: Longint; s: tbtString; begin s := #2 + PS_mi2s(ProcNo); if Proc.Decl.Result <> nil then begin s := s + 'Result' + #1; end; for i := 0 to Proc.Decl.ParamCount -1 do s := s + Proc.Decl.Params[i].OrgName + #1; s := s + #0#3 + PS_mi2s(ProcNo); for I := 0 to Proc.ProcVars.Count - 1 do begin s := s + PIFPSProcVar(Proc.ProcVars[I]).OrgName + #1; end; s := s + #0; WriteDebugData(s); end; procedure TPSPascalCompiler.CheckForUnusedVars(Func: TPSInternalProcedure); var i: Integer; p: PIFPSProcVar; begin for i := 0 to Func.ProcVars.Count -1 do begin p := Func.ProcVars[I]; if not p.Used then begin with MakeHint({$IFDEF PS_USESSUPPORT}p.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, p.Name) do begin FRow := p.DeclareRow; FCol := p.DeclareCol; FPosition := p.DeclarePos; end; end; end; if (not Func.ResultUsed) and (Func.Decl.Result <> nil) then begin with MakeHint({$IFDEF PS_USESSUPPORT}Func.DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, 'Result') do begin FRow := Func.DeclareRow; FCol := Func.DeclareCol; FPosition := Func.DeclarePos; end; end; end; function TPSPascalCompiler.ProcIsDuplic(Decl: TPSParametersDecl; const FunctionName, FunctionParamNames: tbtString; const s: tbtString; Func: TPSInternalProcedure): Boolean; var i: Longint; u: tbtString; begin if s = 'RESULT' then Result := True else if FunctionName = s then Result := True else begin for i := 0 to Decl.ParamCount -1 do begin if Decl.Params[i].Name = s then begin Result := True; exit; end; GRFW(u); end; u := FunctionParamNames; while Pos(tbtchar('|'), u) > 0 do begin if copy(u, 1, Pos(tbtchar('|'), u) - 1) = s then begin Result := True; exit; end; Delete(u, 1, Pos(tbtchar('|'), u)); end; if Func = nil then begin result := False; exit; end; for i := 0 to Func.ProcVars.Count -1 do begin if s = PIFPSProcVar(Func.ProcVars[I]).Name then begin Result := True; exit; end; end; for i := 0 to Func.FLabels.Count -1 do begin u := Func.FLabels[I]; delete(u, 1, 4); if u = s then begin Result := True; exit; end; end; Result := False; end; end; procedure WriteProcVars(Func:TPSInternalProcedure; t: TPSList); var l: Longint; v: PIFPSProcVar; begin for l := 0 to t.Count - 1 do begin v := t[l]; Func.Data := Func.Data + chr(cm_pt)+ PS_mi2s(v.AType.FinalTypeNo); end; end; function TPSPascalCompiler.ApplyAttribsToFunction(func: TPSProcedure): boolean; var i: Longint; begin for i := 0 to Func.Attributes.Count -1 do begin if @Func.Attributes.Items[i].AType.OnApplyAttributeToProc <> nil then begin if not Func.Attributes.Items[i].AType.OnApplyAttributeToProc(Self, Func, Func.Attributes.Items[i]) then begin Result := false; exit; end; end; end; result := true; end; function TPSPascalCompiler.ProcessFunction(AlwaysForward: Boolean; Att: TPSAttributes): Boolean; var FunctionType: TFuncType; OriginalName, FunctionName: tbtString; FunctionParamNames: tbtString; FunctionTempType: TPSType; ParamNo: Cardinal; FunctionDecl: TPSParametersDecl; modifier: TPSParameterMode; Func: TPSInternalProcedure; F2: TPSProcedure; EPos, ECol, ERow: Cardinal; E2Pos, E2Col, E2Row: Cardinal; pp: TPSRegProc; pp2: TPSExternalProcedure; FuncNo, I: Longint; Block: TPSBlockInfo; begin if att = nil then begin Att := TPSAttributes.Create; if not ReadAttributes(Att) then begin att.free; Result := false; exit; end; end; if FParser.CurrTokenId = CSTII_Procedure then FunctionType := ftProc else FunctionType := ftFunc; Func := nil; EPos := FParser.CurrTokenPos; ERow := FParser.Row; ECol := FParser.Col; FParser.Next; Result := False; if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); att.free; exit; end; if assigned(FOnFunctionStart) then {$IFDEF PS_USESSUPPORT} FOnFunctionStart(fModule + '.' + FParser.OriginalToken, EPos, ERow, ECol); {$ELSE} FOnFunctionStart(FParser.OriginalToken, EPos, ERow, ECol); {$ENDIF} EPos := FParser.CurrTokenPos; ERow := FParser.Row; ECol := FParser.Col; OriginalName := FParser.OriginalToken; FunctionName := FParser.GetToken; FuncNo := -1; for i := 0 to FProcs.Count -1 do begin f2 := FProcs[I]; if (f2.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(f2).Name = FunctionName) and (TPSInternalProcedure(f2).Forwarded) then begin Func := FProcs[I]; FuncNo := i; Break; end; end; if (Func = nil) and IsDuplicate(FunctionName, [dcTypes, dcProcs, dcVars, dcConsts]) then begin att.free; MakeError('', ecDuplicateIdentifier, FunctionName); exit; end; FParser.Next; FunctionDecl := TPSParametersDecl.Create; try if FParser.CurrTokenId = CSTI_OpenRound then begin FParser.Next; if FParser.CurrTokenId = CSTI_CloseRound then begin FParser.Next; end else begin if FunctionType = ftFunc then ParamNo := 1 else ParamNo := 0; while True do begin if FParser.CurrTokenId = CSTII_Const then begin modifier := pmIn; FParser.Next; end else if FParser.CurrTokenId = CSTII_Out then begin modifier := pmOut; FParser.Next; end else if FParser.CurrTokenId = CSTII_Var then begin modifier := pmInOut; FParser.Next; end else modifier := pmIn; if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); exit; end; E2Pos := FParser.CurrTokenPos; E2Row := FParser.Row; E2Col := FParser.Col; FunctionParamNames := ''; if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then begin MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); exit; end; FunctionParamNames := FParser.OriginalToken + '|'; if @FOnUseVariable <> nil then begin FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, ''); end; inc(ParamNo); FParser.Next; while FParser.CurrTokenId = CSTI_Comma do begin FParser.Next; if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); exit; end; if ProcIsDuplic(FunctionDecl, FunctionName, FunctionParamNames, FParser.GetToken, Func) then begin MakeError('', ecDuplicateIdentifier, ''); exit; end; if @FOnUseVariable <> nil then begin FOnUseVariable(Self, ivtParam, ParamNo, FProcs.Count, FParser.CurrTokenPos, ''); end; inc(ParamNo); FunctionParamNames := FunctionParamNames + FParser.OriginalToken + '|'; FParser.Next; end; if FParser.CurrTokenId <> CSTI_Colon then begin MakeError('', ecColonExpected, ''); exit; end; FParser.Next; FunctionTempType := at2ut(ReadType('', FParser)); if FunctionTempType = nil then begin exit; end; while Pos(tbtchar('|'), FunctionParamNames) > 0 do begin with FunctionDecl.AddParam do begin OrgName := copy(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames) - 1); Mode := modifier; aType := FunctionTempType; {$IFDEF PS_USESSUPPORT} DeclareUnit:=fModule; {$ENDIF} DeclarePos:=E2Pos; DeclareRow:=E2Row; DeclareCol:=E2Col; end; Delete(FunctionParamNames, 1, Pos(tbtchar('|'), FunctionParamNames)); end; if FParser.CurrTokenId = CSTI_CloseRound then break; if FParser.CurrTokenId <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); exit; end; FParser.Next; end; FParser.Next; end; end; if FunctionType = ftFunc then begin if FParser.CurrTokenId <> CSTI_Colon then begin MakeError('', ecColonExpected, ''); exit; end; FParser.Next; FunctionTempType := at2ut(ReadType('', FParser)); if FunctionTempType = nil then exit; FunctionDecl.Result := FunctionTempType; end; if FParser.CurrTokenId <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); exit; end; FParser.Next; if (Func = nil) and (FParser.CurrTokenID = CSTII_External) then begin FParser.Next; if FParser.CurrTokenID <> CSTI_String then begin MakeError('', ecStringExpected, ''); exit; end; FunctionParamNames := FParser.GetToken; FunctionParamNames := copy(FunctionParamNames, 2, length(FunctionParamNames) - 2); FParser.Next; if FParser.CurrTokenID <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); exit; end; FParser.Next; if @FOnExternalProc = nil then begin MakeError('', ecSemicolonExpected, ''); exit; end; pp := FOnExternalProc(Self, FunctionDecl, OriginalName, FunctionParamNames); if pp = nil then begin MakeError('', ecCustomError, ''); exit; end; pp2 := TPSExternalProcedure.Create; pp2.Attributes.Assign(att, true); pp2.RegProc := pp; FProcs.Add(pp2); FRegProcs.Add(pp); Result := ApplyAttribsToFunction(pp2); Exit; end else if (FParser.CurrTokenID = CSTII_Forward) or AlwaysForward then begin if Func <> nil then begin MakeError('', ecBeginExpected, ''); exit; end; if not AlwaysForward then begin FParser.Next; if FParser.CurrTokenID <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); Exit; end; FParser.Next; end; Func := NewProc(OriginalName, FunctionName); Func.Attributes.Assign(Att, True); Func.Forwarded := True; {$IFDEF PS_USESSUPPORT} Func.FDeclareUnit := fModule; {$ENDIF} Func.FDeclarePos := EPos; Func.FDeclareRow := ERow; Func.FDeclarePos := ECol; Func.Decl.Assign(FunctionDecl); Result := ApplyAttribsToFunction(Func); exit; end; if (Func = nil) then begin Func := NewProc(OriginalName, FunctionName); Func.Attributes.Assign(att, True); Func.Decl.Assign(FunctionDecl); {$IFDEF PS_USESSUPPORT} Func.FDeclareUnit := fModule; {$ENDIF} Func.FDeclarePos := EPos; Func.FDeclareRow := ERow; Func.FDeclareCol := ECol; FuncNo := FProcs.Count -1; if not ApplyAttribsToFunction(Func) then begin result := false; exit; end; end else begin if not FunctionDecl.Same(Func.Decl) then begin MakeError('', ecForwardParameterMismatch, ''); Result := false; exit; end; Func.Forwarded := False; end; if FParser.CurrTokenID = CSTII_Export then begin FParser.Next; if FParser.CurrTokenID <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); exit; end; FParser.Next; end; while FParser.CurrTokenId <> CSTII_Begin do begin if FParser.CurrTokenId = CSTII_Var then begin if not DoVarBlock(Func) then exit; end else if FParser.CurrTokenId = CSTII_Label then begin if not ProcessLabel(Func) then Exit; end else begin MakeError('', ecBeginExpected, ''); exit; end; end; Debug_WriteParams(FuncNo, Func); WriteProcVars(Func, Func.ProcVars); Block := TPSBlockInfo.Create(FGlobalBlock); Block.SubType := tProcBegin; Block.ProcNo := FuncNo; Block.Proc := Func; if not ProcessSub(Block) then begin Block.Free; exit; end; Block.Free; CheckForUnusedVars(Func); Result := ProcessLabelForwards(Func); if assigned(FOnFunctionEnd) then {$IFDEF PS_USESSUPPORT} OnFunctionEnd(fModule + '.' + OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col); {$ELSE} OnFunctionEnd(OriginalName, FParser.CurrTokenPos, FParser.Row, FParser.Col); {$ENDIF} finally FunctionDecl.Free; att.Free; end; end; function GetParamType(BlockInfo: TPSBlockInfo; I: Longint): TPSType; begin if BlockInfo.Proc.Decl.Result <> nil then dec(i); if i = -1 then Result := BlockInfo.Proc.Decl.Result else begin Result := BlockInfo.Proc.Decl.Params[i].aType; end; end; function TPSPascalCompiler.GetTypeNo(BlockInfo: TPSBlockInfo; p: TPSValue): TPSType; begin if p.ClassType = TPSUnValueOp then Result := TPSUnValueOp(p).aType else if p.ClassType = TPSBinValueOp then Result := TPSBinValueOp(p).aType else if p.ClassType = TPSValueArray then Result := at2ut(FindType('TVariantArray')) else if p.ClassType = TPSValueData then Result := TPSValueData(p).Data.FType else if p is TPSValueProc then Result := TPSValueProc(p).ResultType else if (p is TPSValueVar) and (TPSValueVar(p).RecCount > 0) then Result := TPSValueVar(p).RecItem[TPSValueVar(p).RecCount - 1].aType else if p.ClassType = TPSValueGlobalVar then Result := TPSVar(FVars[TPSValueGlobalVar(p).GlobalVarNo]).FType else if p.ClassType = TPSValueParamVar then Result := GetParamType(BlockInfo, TPSValueParamVar(p).ParamNo) else if p is TPSValueLocalVar then Result := TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueLocalVar(p).LocalVarNo]).AType else if p.classtype = TPSValueReplace then Result := GetTypeNo(BlockInfo, TPSValueReplace(p).NewValue) else Result := nil; end; function TPSPascalCompiler.IsVarInCompatible(ft1, ft2: TPSType): Boolean; begin ft1 := GetTypeCopyLink(ft1); ft2 := GetTypeCopyLink(ft2); Result := (ft1 <> ft2) and (ft2 <> nil); end; function TPSPascalCompiler.ValidateParameters(BlockInfo: TPSBlockInfo; Params: TPSParameters; ParamTypes: TPSParametersDecl): boolean; var i, c: Longint; pType: TPSType; begin UseProc(ParamTypes); c := 0; for i := 0 to ParamTypes.ParamCount -1 do begin while (c < Longint(Params.Count)) and (Params[c].Val = nil) do Inc(c); if c >= Longint(Params.Count) then begin MakeError('', ecInvalidnumberOfParameters, ''); Result := False; exit; end; Params[c].ExpectedType := ParamTypes.Params[i].aType; Params[c].ParamMode := ParamTypes.Params[i].Mode; if ParamTypes.Params[i].Mode <> pmIn then begin if not (Params[c].Val is TPSValueVar) then begin with MakeError('', ecVariableExpected, '') do begin Row := Params[c].Val.Row; Col := Params[c].Val.Col; Pos := Params[c].Val.Pos; end; result := false; exit; end; PType := Params[c].ExpectedType; if (PType = nil) or ((PType.BaseType = btArray) and (TPSArrayType(PType).ArrayTypeNo = nil) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray)) or (PType = FAnyString) then begin Params[c].ExpectedType := GetTypeNo(BlockInfo, Params[c].Val); if PType <> nil then if (Params[c].ExpectedType = nil) or not (Params[c].ExpectedType.BaseType in [btString, btWideString, btUnicodeString, btChar, btWideChar]) then begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; if Params[c].ExpectedType.BaseType = btChar then Params[c].ExpectedType := FindBaseType(btString) else if Params[c].ExpectedType.BaseType = btWideChar then Params[c].ExpectedType := FindBaseType(btUnicodeString); end else if (PType.BaseType = btArray) and (GetTypeNo(BlockInfo, Params[c].Val).BaseType = btArray) then begin if TPSArrayType(GetTypeNo(BlockInfo, Params[c].Val)).ArrayTypeNo <> TPSArrayType(PType).ArrayTypeNo then begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; end else if IsVarInCompatible(PType, GetTypeNo(BlockInfo, Params[c].Val)) then begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; end; Inc(c); end; for i := c to Params.Count -1 do begin if Params[i].Val <> nil then begin MakeError('', ecInvalidnumberOfParameters, ''); Result := False; exit; end; end; Result := true; end; function TPSPascalCompiler.DoTypeBlock(FParser: TPSPascalParser): Boolean; var VOrg,VName: tbtString; Attr: TPSAttributes; FType: TPSType; i: Longint; begin Result := False; FParser.Next; repeat Attr := TPSAttributes.Create; if not ReadAttributes(Attr) then begin Attr.Free; exit; end; if (FParser.CurrTokenID = CSTII_Procedure) or (FParser.CurrTokenID = CSTII_Function) then begin Result := ProcessFunction(false, Attr); exit; end; if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); Attr.Free; exit; end; VName := FParser.GetToken; VOrg := FParser.OriginalToken; if IsDuplicate(VName, [dcTypes, dcProcs, dcVars]) then begin MakeError('', ecDuplicateIdentifier, FParser.OriginalToken); Attr.Free; exit; end; FParser.Next; if FParser.CurrTokenId <> CSTI_Equal then begin MakeError('', ecIsExpected, ''); Attr.Free; exit; end; FParser.Next; FType := ReadType(VOrg, FParser); if Ftype = nil then begin Attr.Free; Exit; end; FType.Attributes.Assign(Attr, True); for i := 0 to FType.Attributes.Count -1 do begin if @FType.Attributes[i].FAttribType.FAAType <> nil then FType.Attributes[i].FAttribType.FAAType(Self, FType, Attr[i]); end; Attr.Free; if FParser.CurrTokenID <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); Exit; end; FParser.Next; until (FParser.CurrTokenId <> CSTI_Identifier) and (FParser.CurrTokenID <> CSTI_OpenBlock); Result := True; end; procedure TPSPascalCompiler.Debug_WriteLine(BlockInfo: TPSBlockInfo); var b: Boolean; begin if @FOnWriteLine <> nil then begin {$IFNDEF PS_USESSUPPORT} b := FOnWriteLine(Self, FParser.CurrTokenPos); {$ELSE} b := FOnWriteLine(Self, FModule, FParser.CurrTokenPos); {$ENDIF} end else b := true; if b then Debug_SavePosition(BlockInfo.ProcNo, BlockInfo.Proc); end; function TPSPascalCompiler.ReadReal(const s: tbtString): PIfRVariant; var C: Integer; begin New(Result); InitializeVariant(Result, FindBaseType(btExtended)); Val(string(s), Result^.textended, C); end; function TPSPascalCompiler.ReadString: PIfRVariant; {$IFNDEF PS_NOWIDESTRING}var wchar: Boolean;{$ENDIF} function ParseString({$IFNDEF PS_NOWIDESTRING}var res: tbtunicodestring{$ELSE}var res: tbtString{$ENDIF}): Boolean; var temp3: {$IFNDEF PS_NOWIDESTRING}tbtunicodestring{$ELSE}tbtString{$ENDIF}; function ChrToStr(s: tbtString): {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF}; var w: Longint; begin Delete(s, 1, 1); {First char : #} w := StrToInt(s); Result := {$IFNDEF PS_NOWIDESTRING}widechar{$ELSE}tbtchar{$ENDIF}(w); {$IFNDEF PS_NOWIDESTRING}if w > $FF then wchar := true;{$ENDIF} end; function PString(s: tbtString): tbtString; var i: Longint; begin s := copy(s, 2, Length(s) - 2); i := length(s); while i > 0 do begin if (i < length(s)) and (s[i] = #39) and (s[i + 1] = #39) then begin Delete(s, i, 1); dec(i); end; dec(i); end; PString := s; end; var lastwasstring: Boolean; begin temp3 := ''; while (FParser.CurrTokenId = CSTI_String) or (FParser.CurrTokenId = CSTI_Char) do begin lastwasstring := FParser.CurrTokenId = CSTI_String; if FParser.CurrTokenId = CSTI_String then begin if UTF8Decode then begin temp3 := temp3 + {$IFNDEF PS_NOWIDESTRING}{$IFDEF DELPHI6UP}System.{$IFDEF DELPHI2009UP}UTF8ToWidestring{$ELSE}UTF8Decode{$ENDIF}{$ENDIF}{$ENDIF}(PString(FParser.GetToken)); {$IFNDEF PS_NOWIDESTRING}wchar:=true;{$ENDIF} end else temp3 := temp3 + tbtUnicodestring(PString(FParser.GetToken)); FParser.Next; if FParser.CurrTokenId = CSTI_String then temp3 := temp3 + #39; end {if} else begin temp3 := temp3 + ChrToStr(FParser.GetToken); FParser.Next; end; {else if} if lastwasstring and (FParser.CurrTokenId = CSTI_String) then begin MakeError('', ecSyntaxError, ''); result := false; exit; end; end; {while} res := temp3; result := true; end; var {$IFNDEF PS_NOWIDESTRING} w: tbtunicodestring; {$ENDIF} s: tbtString; begin {$IFNDEF PS_NOWIDESTRING}wchar:=false;{$ENDIF} if not ParseString({$IFDEF PS_NOWIDESTRING} s {$ELSE} w {$ENDIF}) then begin result := nil; exit; end; {$IFNDEF PS_NOWIDESTRING} if wchar then begin New(Result); if Length(w) = 1 then begin InitializeVariant(Result, at2ut(FindBaseType(btwidechar))); Result^.twidechar := w[1]; end else begin InitializeVariant(Result, at2ut(FindBaseType(btUnicodeString))); tbtunicodestring(Result^.tunistring) := w; end; end else begin s := tbtstring(w); {$ENDIF} New(Result); if Length(s) = 1 then begin InitializeVariant(Result, at2ut(FindBaseType(btchar))); Result^.tchar := s[1]; end else begin InitializeVariant(Result, at2ut(FindBaseType(btstring))); tbtstring(Result^.tstring) := s; end; {$IFNDEF PS_NOWIDESTRING} end; {$ENDIF} end; function TPSPascalCompiler.ReadInteger(const s: tbtString): PIfRVariant; var R: {$IFNDEF PS_NOINT64}Int64;{$ELSE}Longint;{$ENDIF} begin New(Result); {$IFNDEF PS_NOINT64} r := StrToInt64Def(string(s), 0); if (r >= Low(Integer)) and (r <= High(Integer)) then begin InitializeVariant(Result, at2ut(FindBaseType(bts32))); Result^.ts32 := r; end else if (r <= $FFFFFFFF) then begin InitializeVariant(Result, at2ut(FindBaseType(btu32))); Result^.tu32 := r; end else begin InitializeVariant(Result, at2ut(FindBaseType(bts64))); Result^.ts64 := r; end; {$ELSE} r := StrToIntDef(s, 0); InitializeVariant(Result, at2ut(FindBaseType(bts32))); Result^.ts32 := r; {$ENDIF} end; function TPSPascalCompiler.ProcessSub(BlockInfo: TPSBlockInfo): Boolean; function AllocStackReg2(MType: TPSType): TPSValue; var x: TPSProcVar; begin {$IFDEF DEBUG} if (mtype = nil) or (not mtype.Used) then asm int 3; end; {$ENDIF} x := TPSProcVar.Create; {$IFDEF PS_USESSUPPORT} x.DeclareUnit:=fModule; {$ENDIF} x.DeclarePos := FParser.CurrTokenPos; x.DeclareRow := FParser.Row; x.DeclareCol := FParser.Col; x.Name := ''; x.AType := MType; x.Use; BlockInfo.Proc.ProcVars.Add(x); Result := TPSValueAllocatedStackVar.Create; Result.SetParserPos(FParser); TPSValueAllocatedStackVar(Result).Proc := BlockInfo.Proc; with TPSValueAllocatedStackVar(Result) do begin LocalVarNo := proc.ProcVars.Count -1; end; end; function AllocStackReg(MType: TPSType): TPSValue; begin Result := AllocStackReg2(MType); BlockWriteByte(BlockInfo, Cm_Pt); BlockWriteLong(BlockInfo, MType.FinalTypeNo); end; function AllocPointer(MDestType: TPSType): TPSValue; begin Result := AllocStackReg(at2ut(FindBaseType(btPointer))); TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(Result).LocalVarNo]).AType := MDestType; end; function WriteCalculation(InData, OutReg: TPSValue): Boolean; forward; function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean; forward; function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean; forward; procedure AfterWriteOutRec(var x: TPSValue); forward; function CheckCompatType(V1, v2: TPSValue): Boolean; var p1, P2: TPSType; begin p1 := GetTypeNo(BlockInfo, V1); P2 := GetTypeNo(BlockInfo, v2); if (p1 = nil) or (p2 = nil) then begin if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.BaseType = btProcPtr)) and (v2.ClassType = TPSValueNil)) or ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.BaseType = btProcPtr)) and (v1.ClassType = TPSValueNil)) then begin Result := True; exit; end else if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSClassType)) and (v2.ClassType = TPSValueNil)) or ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSClassType)) and (v1.ClassType = TPSValueNil)) then begin Result := True; exit; end else if ((p1 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p1.ClassType = TPSInterfaceType) or {$ENDIF}(p1.ClassType = TPSUndefinedClassType)) and (v2.ClassType = TPSValueNil)) or ((p2 <> nil) and ({$IFNDEF PS_NOINTERFACES}(p2.ClassType = TPSInterfaceType) or {$ENDIF}(p2.ClassType = TPSUndefinedClassType)) and (v1.ClassType = TPSValueNil)) then begin Result := True; exit; end else if (v1.ClassType = TPSValueProcPtr) and (p2 <> nil) and (p2.BaseType = btProcPtr) then begin Result := CheckCompatProc(p2, TPSValueProcPtr(v1).ProcPtr); exit; end else if (v2.ClassType = TPSValueProcPtr) and (p1 <> nil) and (p1.BaseType = btProcPtr) then begin Result := CheckCompatProc(p1, TPSValueProcPtr(v2).ProcPtr); exit; end; Result := False; end else if (p1 <> nil) and (p1.BaseType = btSet) and (v2 is TPSValueArray) then begin Result := True; end else Result := IsCompatibleType(p1, p2, False); end; function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean; forward; function ProcessFunction2(ProcNo: Cardinal; Par: TPSParameters; ResultReg: TPSValue): Boolean; var Temp: TPSValueProcNo; i: Integer; begin Temp := TPSValueProcNo.Create; Temp.Parameters := Par; Temp.ProcNo := ProcNo; if TObject(FProcs[ProcNo]).ClassType = TPSInternalProcedure then Temp.ResultType := TPSInternalProcedure(FProcs[ProcNo]).Decl.Result else Temp.ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result; if (Temp.ResultType <> nil) and (Temp.ResultType = FAnyString) then begin // workaround to make the result type match for i := 0 to Par.Count -1 do begin if Par[i].ExpectedType.BaseType in [btString, btWideString] then Temp.ResultType := Par[i].ExpectedType; end; end; Result := _ProcessFunction(Temp, ResultReg); Temp.Parameters := nil; Temp.Free; end; function MakeNil(NilPos, NilRow, nilCol: Cardinal;ivar: TPSValue): Boolean; var Procno: Cardinal; PF: TPSType; Par: TPSParameters; begin Pf := GetTypeNo(BlockInfo, IVar); if not (Ivar is TPSValueVar) then begin with MakeError('', ecTypeMismatch, '') do begin FPosition := nilPos; FRow := NilRow; FCol := nilCol; end; Result := False; exit; end; if (pf.BaseType = btProcPtr) then begin Result := True; end else if (pf.BaseType = btString) or (pf.BaseType = btPChar) then begin if not PreWriteOutRec(iVar, nil) then begin Result := false; exit; end; BlockWriteByte(BlockInfo, CM_A); WriteOutRec(ivar, False); BlockWriteByte(BlockInfo, 1); BlockWriteLong(BlockInfo, GetTypeNo(BlockInfo, IVar).FinalTypeNo); BlockWriteLong(BlockInfo, 0); //empty tbtString AfterWriteOutRec(ivar); Result := True; end else if (pf.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pf.BaseType = btInterface){$ENDIF} then begin {$IFNDEF PS_NOINTERFACES} if (pf.BaseType = btClass) then begin {$ENDIF} if not TPSClassType(pf).Cl.SetNil(ProcNo) then begin with MakeError('', ecTypeMismatch, '') do begin FPosition := nilPos; FRow := NilRow; FCol := nilCol; end; Result := False; exit; end; {$IFNDEF PS_NOINTERFACES} end else begin if not TPSInterfaceType(pf).Intf.SetNil(ProcNo) then begin with MakeError('', ecTypeMismatch, '') do begin FPosition := nilPos; FRow := NilRow; FCol := nilCol; end; Result := False; exit; end; end; {$ENDIF} Par := TPSParameters.Create; with par.Add do begin Val := IVar; ExpectedType := GetTypeNo(BlockInfo, ivar); {$IFDEF DEBUG} if not ExpectedType.Used then asm int 3; end; {$ENDIF} ParamMode := pmInOut; end; Result := ProcessFunction2(ProcNo, Par, nil); Par[0].Val := nil; // don't free IVAR Par.Free; end else if pf.BaseType = btExtClass then begin if not TPSUndefinedClassType(pf).ExtClass.SetNil(ProcNo) then begin with MakeError('', ecTypeMismatch, '') do begin FPosition := nilPos; FRow := NilRow; FCol := nilCol; end; Result := False; exit; end; Par := TPSParameters.Create; with par.Add do begin Val := IVar; ExpectedType := GetTypeNo(BlockInfo, ivar); ParamMode := pmInOut; end; Result := ProcessFunction2(ProcNo, Par, nil); Par[0].Val := nil; // don't free IVAR Par.Free; end else begin with MakeError('', ecTypeMismatch, '') do begin FPosition := nilPos; FRow := NilRow; FCol := nilCol; end; Result := False; end; end; function DoBinCalc(BVal: TPSBinValueOp; Output: TPSValue): Boolean; var tmpp, tmpc: TPSValue; jend, jover: Cardinal; procno: Cardinal; begin if BVal.Operator >= otGreaterEqual then begin if BVal.FVal1.ClassType = TPSValueNil then begin tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal2)); if not MakeNil(BVal.FVal1.Pos, BVal.FVal1.Row, BVal.FVal1.Col, tmpp) then begin tmpp.Free; Result := False; exit; end; tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin OldValue := BVal.FVal1; NewValue := tmpp; end; BVal.FVal1 := tmpc; end; if BVal.FVal2.ClassType = TPSValueNil then begin tmpp := AllocStackReg(GetTypeNo(BlockInfo, BVal.FVal1)); if not MakeNil(BVal.FVal2.Pos, BVal.FVal2.Row, BVal.FVal2.Col, tmpp) then begin tmpp.Free;; Result := False; exit; end; tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin OldValue := BVal.FVal2; NewValue := tmpp; end; BVal.FVal2 := tmpc; end; if GetTypeNo(BlockInfo, BVal.FVal1).BaseType = btExtClass then begin if not TPSUndefinedClassType(GetTypeNo(BlockInfo, BVal.FVal1)).ExtClass.CompareClass(GetTypeNo(BlockInfo, Bval.FVal2), ProcNo) then begin Result := False; exit; end; tmpp := TPSValueProcNo.Create; with TPSValueProcNo(tmpp) do begin ResultType := at2ut(FDefaultBoolType); Parameters := TPSParameters.Create; ProcNo := procno; Pos := BVal.Pos; Col := BVal.Col; Row := BVal.Row; with parameters.Add do begin Val := BVal.FVal1; ExpectedType := GetTypeNo(BlockInfo, Val); end; with parameters.Add do begin Val := BVal.FVal2; ExpectedType := GetTypeNo(BlockInfo, Val); end; end; if Bval.Operator = otNotEqual then begin tmpc := TPSUnValueOp.Create; TPSUnValueOp(tmpc).Operator := otNot; TPSUnValueOp(tmpc).Val1 := tmpp; TPSUnValueOp(tmpc).aType := GetTypeNo(BlockInfo, tmpp); end else tmpc := tmpp; Result := WriteCalculation(tmpc, Output); with TPSValueProcNo(tmpp) do begin Parameters[0].Val := nil; Parameters[1].Val := nil; end; tmpc.Free; if BVal.Val1.ClassType = TPSValueReplace then begin tmpp := TPSValueReplace(BVal.Val1).OldValue; BVal.Val1.Free; BVal.Val1 := tmpp; end; if BVal.Val2.ClassType = TPSValueReplace then begin tmpp := TPSValueReplace(BVal.Val2).OldValue; BVal.Val2.Free; BVal.Val2 := tmpp; end; exit; end; if not (PreWriteOutRec(Output, nil) and PreWriteOutRec(BVal.FVal1, GetTypeNo(BlockInfo, BVal.FVal2)) and PreWriteOutRec(BVal.FVal2, GetTypeNo(BlockInfo, BVal.FVal1))) then begin Result := False; exit; end; BlockWriteByte(BlockInfo, CM_CO); case BVal.Operator of otGreaterEqual: BlockWriteByte(BlockInfo, 0); otLessEqual: BlockWriteByte(BlockInfo, 1); otGreater: BlockWriteByte(BlockInfo, 2); otLess: BlockWriteByte(BlockInfo, 3); otEqual: BlockWriteByte(BlockInfo, 5); otNotEqual: BlockWriteByte(BlockInfo, 4); otIn: BlockWriteByte(BlockInfo, 6); otIs: BlockWriteByte(BlockInfo, 7); end; if not (WriteOutRec(Output, False) and writeOutRec(BVal.FVal1, True) and writeOutRec(BVal.FVal2, True)) then begin Result := False; exit; end; AfterWriteOutrec(BVal.FVal1); AfterWriteOutrec(BVal.FVal2); AfterWriteOutrec(Output); if BVal.Val1.ClassType = TPSValueReplace then begin tmpp := TPSValueReplace(BVal.Val1).OldValue; BVal.Val1.Free; BVal.Val1 := tmpp; end; if BVal.Val2.ClassType = TPSValueReplace then begin tmpp := TPSValueReplace(BVal.Val2).OldValue; BVal.Val2.Free; BVal.Val2 := tmpp; end; end else begin if (BVal.aType <> nil) and (BVal.aType <> GetTypeNo(BlockInfo, Output)) then begin tmpp := AllocStackReg(BVal.aType); PreWriteOutrec(tmpp, nil); DoBinCalc(BVal, tmpp); afterwriteoutrec(tmpp); result := WriteCalculation(tmpp, output); tmpp.Free; exit; end; if not PreWriteOutRec(Output, nil) then begin Result := False; exit; end; if not SameReg(Output, BVal.Val1) then begin if not WriteCalculation(BVal.FVal1, Output) then begin Result := False; exit; end; end; if (FBooleanShortCircuit) and (IsBoolean(BVal.aType)) then begin if BVal.Operator = otAnd then begin BlockWriteByte(BlockInfo, Cm_CNG); jover := Length(BlockInfo.Proc.FData); BlockWriteLong(BlockInfo, 0); WriteOutRec(Output, True); jend := Length(BlockInfo.Proc.FData); end else if BVal.Operator = otOr then begin BlockWriteByte(BlockInfo, Cm_CG); jover := Length(BlockInfo.Proc.FData); BlockWriteLong(BlockInfo, 0); WriteOutRec(Output, True); jend := Length(BlockInfo.Proc.FData); end else begin jover := 0; jend := 0; end; end else begin jover := 0; jend := 0; end; if not PreWriteOutrec(BVal.FVal2, GetTypeNo(BlockInfo, Output)) then begin Result := False; exit; end; BlockWriteByte(BlockInfo, Cm_CA); if BVAL.Operator = otIntDiv then BlockWriteByte(BlockInfo, Ord(otDiv)) else BlockWriteByte(BlockInfo, Ord(BVal.Operator)); if not (WriteOutRec(Output, False) and WriteOutRec(BVal.FVal2, True)) then begin Result := False; exit; end; AfterWriteOutRec(BVal.FVal2); if FBooleanShortCircuit and (IsBoolean(BVal.aType)) and (JOver <> JEnd) then begin {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Cardinal((@BlockInfo.Proc.FData[jover+1])^)) := Cardinal(Length(BlockInfo.Proc.FData)) - jend; {$else} Cardinal((@BlockInfo.Proc.FData[jover+1])^) := Cardinal(Length(BlockInfo.Proc.FData)) - jend; {$endif} end; AfterWriteOutRec(Output); end; Result := True; end; function DoUnCalc(Val: TPSUnValueOp; Output: TPSValue): Boolean; var Tmp: TPSValue; begin if not PreWriteOutRec(Output, nil) then begin Result := False; exit; end; case Val.Operator of otNot: begin if not SameReg(Val.FVal1, Output) then begin if not WriteCalculation(Val.FVal1, Output) then begin Result := False; exit; end; end; if IsBoolean(GetTypeNo(BlockInfo, Val)) then BlockWriteByte(BlockInfo, cm_bn) else BlockWriteByte(BlockInfo, cm_in); if not WriteOutRec(Output, True) then begin Result := False; exit; end; end; otMinus: begin if not SameReg(Val.FVal1, Output) then begin if not WriteCalculation(Val.FVal1, Output) then begin Result := False; exit; end; end; BlockWriteByte(BlockInfo, cm_vm); if not WriteOutRec(Output, True) then begin Result := False; exit; end; end; otCast: begin if ((Val.aType.BaseType = btChar) and (Val.aType.BaseType <> btU8)) {$IFNDEF PS_NOWIDESTRING}or ((Val.aType.BaseType = btWideChar) and (Val.aType.BaseType <> btU16)){$ENDIF} then begin Tmp := AllocStackReg(Val.aType); end else Tmp := Output; if not (PreWriteOutRec(Val.FVal1, GetTypeNo(BlockInfo, Tmp)) and PreWriteOutRec(Tmp, GetTypeNo(BlockInfo, Tmp))) then begin Result := False; if tmp <> Output then Tmp.Free; exit; end; BlockWriteByte(BlockInfo, CM_A); if not (WriteOutRec(Tmp, False) and WriteOutRec(Val.FVal1, True)) then begin Result := false; if tmp <> Output then Tmp.Free; exit; end; AfterWriteOutRec(val.Fval1); if Tmp <> Output then begin if not WriteCalculation(Tmp, Output) then begin Result := false; Tmp.Free; exit; end; end; AfterWriteOutRec(Tmp); if Tmp <> Output then Tmp.Free; end; {else donothing} end; AfterWriteOutRec(Output); Result := True; end; function GetAddress(Val: TPSValue): Cardinal; begin if Val.ClassType = TPSValueGlobalVar then Result := TPSValueGlobalVar(val).GlobalVarNo else if Val.ClassType = TPSValueLocalVar then Result := PSAddrStackStart + TPSValueLocalVar(val).LocalVarNo + 1 else if Val.ClassType = TPSValueParamVar then Result := PSAddrStackStart - TPSValueParamVar(val).ParamNo -1 else if Val.ClassType = TPSValueAllocatedStackVar then Result := PSAddrStackStart + TPSValueAllocatedStackVar(val).LocalVarNo + 1 else Result := InvalidVal; end; function PreWriteOutRec(var X: TPSValue; FArrType: TPSType): Boolean; var rr: TPSSubItem; tmpp, tmpc: TPSValue; i: Longint; function MakeSet(SetType: TPSSetType; arr: TPSValueArray): Boolean; var c, i: Longint; dataval: TPSValueData; mType: TPSType; begin Result := True; dataval := TPSValueData.Create; dataval.Data := NewVariant(FarrType); for i := 0 to arr.count -1 do begin mType := GetTypeNo(BlockInfo, arr.Item[i]); if mType <> SetType.SetType then begin with MakeError('', ecTypeMismatch, '') do begin FCol := arr.item[i].Col; FRow := arr.item[i].Row; FPosition := arr.item[i].Pos; end; DataVal.Free; Result := False; exit; end; if arr.Item[i] is TPSValueData then begin c := GetInt(TPSValueData(arr.Item[i]).Data, Result); if not Result then begin dataval.Free; exit; end; Set_MakeMember(c, dataval.Data.tstring); end else begin DataVal.Free; MakeError('', ecTypeMismatch, ''); Result := False; exit; end; end; tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin OldValue := x; NewValue := dataval; PreWriteAllocated := True; end; x := tmpc; end; begin Result := True; if x.ClassType = TPSValueReplace then begin if TPSValueReplace(x).PreWriteAllocated then begin inc(TPSValueReplace(x).FReplaceTimes); end; end else if x.ClassType = TPSValueProcPtr then begin if FArrType = nil then begin MakeError('', ecTypeMismatch, ''); Result := False; Exit; end; tmpp := TPSValueData.Create; TPSValueData(tmpp).Data := NewVariant(FArrType); TPSValueData(tmpp).Data.tu32 := TPSValueProcPtr(x).ProcPtr; tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin PreWriteAllocated := True; OldValue := x; NewValue := tmpp; end; x := tmpc; end else if x.ClassType = TPSValueNil then begin if FArrType = nil then begin MakeError('', ecTypeMismatch, ''); Result := False; Exit; end; tmpp := AllocStackReg(FArrType); if not MakeNil(x.Pos, x.Row, x.Col, tmpp) then begin tmpp.Free; Result := False; exit; end; tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin PreWriteAllocated := True; OldValue := x; NewValue := tmpp; end; x := tmpc; end else if x.ClassType = TPSValueArray then begin if FArrType = nil then begin MakeError('', ecTypeMismatch, ''); Result := False; Exit; end; if TPSType(FArrType).BaseType = btSet then begin Result := MakeSet(TPSSetType(FArrType), TPSValueArray(x)); exit; end; if TPSType(FarrType).BaseType = btVariant then FArrType := FindAndAddType(self, '', 'array of variant'); if TPSType(FarrType).BaseType <> btArray then FArrType := FindAndAddType(self, '', 'array of variant'); tmpp := AllocStackReg(FArrType); tmpc := AllocStackReg(FindBaseType(bts32)); BlockWriteByte(BlockInfo, CM_A); WriteOutrec(tmpc, False); BlockWriteByte(BlockInfo, 1); BlockWriteLong(BlockInfo, FindBaseType(bts32).FinalTypeNo); BlockWriteLong(BlockInfo, TPSValueArray(x).Count); BlockWriteByte(BlockInfo, CM_PV); WriteOutrec(tmpp, False); BlockWriteByte(BlockInfo, CM_C); BlockWriteLong(BlockInfo, FindProc('SETARRAYLENGTH')); BlockWriteByte(BlockInfo, CM_PO); tmpc.Free; rr := TPSSubNumber.Create; rr.aType := TPSArrayType(FArrType).ArrayTypeNo; TPSValueVar(tmpp).RecAdd(rr); for i := 0 to TPSValueArray(x).Count -1 do begin TPSSubNumber(rr).SubNo := i; tmpc := TPSValueArray(x).Item[i]; if not PreWriteOutRec(tmpc, GetTypeNo(BlockInfo, tmpc)) then begin tmpp.Free; Result := false; exit; end; if TPSArrayType(FArrType).ArrayTypeNo.BaseType = btPointer then BlockWriteByte(BlockInfo, cm_spc) else BlockWriteByte(BlockInfo, cm_a); if not (WriteOutrec(tmpp, False) and WriteOutRec(tmpc, True)) then begin Tmpp.Free; Result := false; exit; end; AfterWriteOutRec(tmpc); end; TPSValueVar(tmpp).RecDelete(0); tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin PreWriteAllocated := True; OldValue := x; NewValue := tmpp; end; x := tmpc; end else if (x.ClassType = TPSUnValueOp) then begin tmpp := AllocStackReg(GetTypeNo(BlockInfo, x)); if not DoUnCalc(TPSUnValueOp(x), tmpp) then begin Result := False; exit; end; tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin PreWriteAllocated := True; OldValue := x; NewValue := tmpp; end; x := tmpc; end else if (x.ClassType = TPSBinValueOp) then begin tmpp := AllocStackReg(GetTypeNo(BlockInfo, x)); if not DoBinCalc(TPSBinValueOp(x), tmpp) then begin tmpp.Free; Result := False; exit; end; tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin PreWriteAllocated := True; OldValue := x; NewValue := tmpp; end; x := tmpc; end else if x is TPSValueProc then begin tmpp := AllocStackReg(TPSValueProc(x).ResultType); if not WriteCalculation(x, tmpp) then begin tmpp.Free; Result := False; exit; end; tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin PreWriteAllocated := True; OldValue := x; NewValue := tmpp; end; x := tmpc; end else if (x is TPSValueVar) and (TPSValueVar(x).RecCount <> 0) then begin if TPSValueVar(x).RecCount = 1 then begin rr := TPSValueVar(x).RecItem[0]; if rr.ClassType <> TPSSubValue then exit; // there is no need pre-calculate anything if (TPSSubValue(rr).SubNo is TPSValueVar) and (TPSValueVar(TPSSubValue(rr).SubNo).RecCount = 0) then exit; end; //if tmpp := AllocPointer(GetTypeNo(BlockInfo, x)); BlockWriteByte(BlockInfo, cm_sp); WriteOutRec(tmpp, True); BlockWriteByte(BlockInfo, 0); BlockWriteLong(BlockInfo, GetAddress(x)); for i := 0 to TPSValueVar(x).RecCount - 1 do begin rr := TPSValueVar(x).RecItem[I]; if rr.ClassType = TPSSubNumber then begin BlockWriteByte(BlockInfo, cm_sp); WriteOutRec(tmpp, false); BlockWriteByte(BlockInfo, 2); BlockWriteLong(BlockInfo, GetAddress(tmpp)); BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo); end else begin // if rr.classtype = TPSSubValue then begin tmpc := AllocStackReg(FindBaseType(btU32)); if not WriteCalculation(TPSSubValue(rr).SubNo, tmpc) then begin tmpc.Free; tmpp.Free; Result := False; exit; end; //if BlockWriteByte(BlockInfo, cm_sp); WriteOutRec(tmpp, false); BlockWriteByte(BlockInfo, 3); BlockWriteLong(BlockInfo, GetAddress(tmpp)); BlockWriteLong(BlockInfo, GetAddress(tmpc)); tmpc.Free; end; end; // for tmpc := TPSValueReplace.Create; with TPSValueReplace(tmpc) do begin OldValue := x; NewValue := tmpp; PreWriteAllocated := True; end; x := tmpc; end; end; procedure AfterWriteOutRec(var x: TPSValue); var tmp: TPSValue; begin if (x.ClassType = TPSValueReplace) and (TPSValueReplace(x).PreWriteAllocated) then begin Dec(TPSValueReplace(x).FReplaceTimes); if TPSValueReplace(x).ReplaceTimes = 0 then begin tmp := TPSValueReplace(x).OldValue; x.Free; x := tmp; end; end; end; //afterwriteoutrec function WriteOutRec(x: TPSValue; AllowData: Boolean): Boolean; var rr: TPSSubItem; begin Result := True; if x.ClassType = TPSValueReplace then Result := WriteOutRec(TPSValueReplace(x).NewValue, AllowData) else if x is TPSValueVar then begin if TPSValueVar(x).RecCount = 0 then begin BlockWriteByte(BlockInfo, 0); BlockWriteLong(BlockInfo, GetAddress(x)); end else begin rr := TPSValueVar(x).RecItem[0]; if rr.ClassType = TPSSubNumber then begin BlockWriteByte(BlockInfo, 2); BlockWriteLong(BlockInfo, GetAddress(x)); BlockWriteLong(BlockInfo, TPSSubNumber(rr).SubNo); end else begin BlockWriteByte(BlockInfo, 3); BlockWriteLong(BlockInfo, GetAddress(x)); BlockWriteLong(BlockInfo, GetAddress(TPSSubValue(rr).SubNo)); end; end; end else if x.ClassType = TPSValueData then begin if AllowData then begin BlockWriteByte(BlockInfo, 1); BlockWriteVariant(BlockInfo, TPSValueData(x).Data) end else begin Result := False; exit; end; end else Result := False; end; function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean; forward; {$IFNDEF PS_NOIDISPATCH} function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue; forward; {$ENDIF} function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue; forward; function ReadVarParameters(ProcNoVar: TPSValue): TPSValue; forward; function calc(endOn: TPSPasToken): TPSValue; forward; procedure CheckNotificationVariant(var Val: TPSValue); var aType: TPSType; Call: TPSValueProcNo; tmp: TPSValue; begin if not (Val is TPSValueGlobalVar) then exit; aType := GetTypeNo(BlockInfo, Val); if (AType = nil) or (AType.BaseType <> btNotificationVariant) then exit; if FParser.CurrTokenId = CSTI_Assignment then begin Call := TPSValueProcNo.Create; Call.ResultType := nil; Call.SetParserPos(FParser); Call.ProcNo := FindProc('!NOTIFICATIONVARIANTSET');; Call.SetParserPos(FParser); Call.Parameters := TPSParameters.Create; Tmp := TPSValueData.Create; TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString))); tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName; with call.Parameters.Add do begin Val := tmp; ExpectedType := TPSValueData(tmp).Data.FType; end; FParser.Next; tmp := Calc(CSTI_SemiColon); if tmp = nil then begin Val.Free; Val := nil; exit; end; with Call.Parameters.Add do begin Val := tmp; ExpectedType := at2ut(FindBaseType(btVariant)); end; Val.Free; Val := Call; end else begin Call := TPSValueProcNo.Create; Call.ResultType := AT2UT(FindBaseType(btVariant)); Call.SetParserPos(FParser); Call.ProcNo := FindProc('!NOTIFICATIONVARIANTGET'); Call.SetParserPos(FParser); Call.Parameters := TPSParameters.Create; Tmp := TPSValueData.Create; TPSVAlueData(tmp).Data := NewVariant(at2ut(FindBaseType(btString))); tbtString(TPSValueData(tmp).Data.tstring) := TPSVar(FVars[TPSValueGlobalVar(Val).GlobalVarNo]).OrgName; with call.Parameters.Add do begin Val := tmp; ExpectedType := TPSValueData(tmp).Data.FType; end; Val.Free; Val := Call; end; end; procedure CheckProcCall(var x: TPSValue); var aType: TPSType; begin if FParser.CurrTokenId in [CSTI_Dereference, CSTI_OpenRound] then begin aType := GetTypeNo(BlockInfo, x); if (aType = nil) or (aType.BaseType <> btProcPtr) then begin MakeError('', ecTypeMismatch, ''); x.Free; x := nil; Exit; end; if FParser.CurrTokenId = CSTI_Dereference then FParser.Next; x := ReadVarParameters(x); end; end; procedure CheckFurther(var x: TPSValue; ImplicitPeriod: Boolean); var t: Cardinal; rr: TPSSubItem; L: Longint; u: TPSType; Param: TPSParameter; tmp, tmpn: TPSValue; tmp3: TPSValueProcNo; tmp2: Boolean; function FindSubR(const n: tbtString; FType: TPSType): Cardinal; var h, I: Longint; rvv: PIFPSRecordFieldTypeDef; begin h := MakeHash(n); for I := 0 to TPSRecordType(FType).RecValCount - 1 do begin rvv := TPSRecordType(FType).RecVal(I); if (rvv.FieldNameHash = h) and (rvv.FieldName = n) then begin Result := I; exit; end; end; Result := InvalidVal; end; begin (* if not (x is TPSValueVar) then Exit;*) u := GetTypeNo(BlockInfo, x); if u = nil then exit; while True do begin if (u.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (u.BaseType = btInterface){$ENDIF} {$IFNDEF PS_NOIDISPATCH}or ((u.BaseType = btVariant) or (u.BaseType = btNotificationVariant)){$ENDIF} or (u.BaseType = btExtClass) then exit; if FParser.CurrTokenId = CSTI_OpenBlock then begin if (u.BaseType = btString) {$IFNDEF PS_NOWIDESTRING} or (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) {$ENDIF} then begin FParser.Next; tmp := Calc(CSTI_CloseBlock); if tmp = nil then begin x.Free; x := nil; exit; end; if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then begin MakeError('', ecTypeMismatch, ''); tmp.Free; x.Free; x := nil; exit; end; FParser.Next; if FParser.CurrTokenId = CSTI_Assignment then begin if not (x is TPSValueVar) then begin MakeError('', ecVariableExpected, ''); tmp.Free; x.Free; x := nil; exit; end; {$IFNDEF PS_NOWIDESTRING} if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then l := FindProc('WSTRSET') else {$ENDIF} l := FindProc('STRSET'); if l = -1 then begin MakeError('', ecUnknownIdentifier, 'StrSet'); tmp.Free; x.Free; x := nil; exit; end; tmp3 := TPSValueProcNo.Create; tmp3.ResultType := nil; tmp3.SetParserPos(FParser); tmp3.ProcNo := L; tmp3.SetParserPos(FParser); tmp3.Parameters := TPSParameters.Create; param := tmp3.Parameters.Add; with tmp3.Parameters.Add do begin Val := tmp; ExpectedType := GetTypeNo(BlockInfo, tmp); {$IFDEF DEBUG} if not ExpectedType.Used then asm int 3; end; {$ENDIF} end; with tmp3.Parameters.Add do begin Val := x; ExpectedType := GetTypeNo(BlockInfo, x); {$IFDEF DEBUG} if not ExpectedType.Used then asm int 3; end; {$ENDIF} ParamMode := pmInOut; end; x := tmp3; FParser.Next; tmp := Calc(CSTI_SemiColon); if tmp = nil then begin x.Free; x := nil; exit; end; if (GetTypeNo(BlockInfo, Tmp).BaseType <> btChar) {$IFNDEF PS_NOWIDESTRING} and (GetTypeno(BlockInfo, Tmp).BaseType <> btWideChar) {$ENDIF} then begin x.Free; x := nil; Tmp.Free; MakeError('', ecTypeMismatch, ''); exit; end; param.Val := tmp; Param.ExpectedType := GetTypeNo(BlockInfo, tmp); {$IFDEF DEBUG} if not Param.ExpectedType.Used then asm int 3; end; {$ENDIF} end else begin {$IFNDEF PS_NOWIDESTRING} if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then l := FindProc('WSTRGET') else {$ENDIF} l := FindProc('STRGET'); if l = -1 then begin MakeError('', ecUnknownIdentifier, 'StrGet'); tmp.Free; x.Free; x := nil; exit; end; tmp3 := TPSValueProcNo.Create; {$IFNDEF PS_NOWIDESTRING} if (u.BaseType = btWideString) or (u.BaseType = btUnicodeString) then tmp3.ResultType := FindBaseType(btWideChar) else {$ENDIF} tmp3.ResultType := FindBaseType(btChar); tmp3.ProcNo := L; tmp3.SetParserPos(FParser); tmp3.Parameters := TPSParameters.Create; with tmp3.Parameters.Add do begin Val := x; ExpectedType := GetTypeNo(BlockInfo, x); {$IFDEF DEBUG} if not ExpectedType.Used then asm int 3; end; {$ENDIF} if x is TPSValueVar then ParamMode := pmInOut else parammode := pmIn; end; with tmp3.Parameters.Add do begin Val := tmp; ExpectedType := GetTypeNo(BlockInfo, tmp); {$IFDEF DEBUG} if not ExpectedType.Used then asm int 3; end; {$ENDIF} end; x := tmp3; end; Break; end else if ((u.BaseType = btArray) or (u.BaseType = btStaticArray)) and (x is TPSValueVar) then begin FParser.Next; tmp := calc(CSTI_CloseBlock); if tmp = nil then begin x.Free; x := nil; exit; end; if not IsIntType(GetTypeNo(BlockInfo, tmp).BaseType) then begin MakeError('', ecTypeMismatch, ''); tmp.Free; x.Free; x := nil; exit; end; if (tmp.ClassType = TPSValueData) then begin rr := TPSSubNumber.Create; TPSValueVar(x).RecAdd(rr); if (u.BaseType = btStaticArray) then TPSSubNumber(rr).SubNo := Cardinal(GetInt(TPSValueData(tmp).Data, tmp2) - TPSStaticArrayType(u).StartOffset) else TPSSubNumber(rr).SubNo := GetUInt(TPSValueData(tmp).Data, tmp2); tmp.Free; rr.aType := TPSArrayType(u).ArrayTypeNo; u := rr.aType; end else begin if (u.BaseType = btStaticArray) then begin tmpn := TPSBinValueOp.Create; TPSBinValueOp(tmpn).Operator := otSub; TPSBinValueOp(tmpn).Val1 := tmp; tmp := TPSValueData.Create; TPSValueData(tmp).Data := NewVariant(FindBaseType(btS32)); TPSValueData(tmp).Data.ts32 := TPSStaticArrayType(u).StartOffset; TPSBinValueOp(tmpn).Val2 := tmp; TPSBinValueOp(tmpn).aType := FindBaseType(btS32); tmp := tmpn; end; rr := TPSSubValue.Create; TPSValueVar(x).recAdd(rr); TPSSubValue(rr).SubNo := tmp; rr.aType := TPSArrayType(u).ArrayTypeNo; u := rr.aType; end; if FParser.CurrTokenId <> CSTI_CloseBlock then begin MakeError('', ecCloseBlockExpected, ''); x.Free; x := nil; exit; end; Fparser.Next; end else begin MakeError('', ecSemicolonExpected, ''); x.Free; x := nil; exit; end; end else if (FParser.CurrTokenId = CSTI_Period) or (ImplicitPeriod) then begin if not ImplicitPeriod then FParser.Next; if u.BaseType = btRecord then begin t := FindSubR(FParser.GetToken, u); if t = InvalidVal then begin if ImplicitPeriod then exit; MakeError('', ecUnknownIdentifier, FParser.GetToken); x.Free; x := nil; exit; end; if (x is TPSValueProcNo) then begin ImplicitPeriod := False; FParser.Next; tmp := AllocStackReg(u); WriteCalculation(x,tmp); TPSVar(BlockInfo.Proc.FProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use; rr := TPSSubNumber.Create; TPSValueVar(tmp).RecAdd(rr); TPSSubNumber(rr).SubNo := t; rr.aType := TPSRecordType(u).RecVal(t).FType; u := rr.aType; tmpn := TPSValueReplace.Create; with TPSValueReplace(tmpn) do begin FreeOldValue := true; FreeNewValue := true; OldValue := tmp; NewValue := AllocStackReg(u); PreWriteAllocated := true; end; if not WriteCalculation(tmp,TPSValueReplace(tmpn).NewValue) then begin {MakeError('',ecInternalError,'');} x.Free; x := nil; exit; end; x.Free; x := tmpn; end else begin if not (x is TPSValueVar) then begin MakeError('', ecVariableExpected, FParser.GetToken); x.Free; x := nil; exit; end; ImplicitPeriod := False; FParser.Next; rr := TPSSubNumber.Create; TPSValueVar(x).RecAdd(rr); TPSSubNumber(rr).SubNo := t; rr.aType := TPSRecordType(u).RecVal(t).FType; u := rr.aType; end; end else begin x.Free; MakeError('', ecSemicolonExpected, ''); x := nil; exit; end; end else break; end; end; procedure CheckClassArrayProperty(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal); var Tempp: TPSValue; aType: TPSClassType; procno: Cardinal; Idx: IPointer; Decl: TPSParametersDecl; begin if p = nil then exit; if (GetTypeNo(BlockInfo, p) = nil) or (GetTypeNo(BlockInfo, p).BaseType <> btClass) then exit; aType := TPSClassType(GetTypeNo(BlockInfo, p)); if FParser.CurrTokenID = CSTI_OpenBlock then begin if not TPSClassType(aType).Cl.Property_Find('', Idx) then begin MakeError('', ecPeriodExpected, ''); p.Free; p := nil; exit; end; if VarNo <> InvalidVal then begin if @FOnUseVariable <> nil then FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, FParser.CurrTokenPos, '[Default]'); end; Decl := TPSParametersDecl.Create; TPSClassType(aType).Cl.Property_GetHeader(Idx, Decl); tempp := p; P := TPSValueProcNo.Create; with TPSValueProcNo(P) do begin Parameters := TPSParameters.Create; Parameters.Add; end; if not (ReadParameters(True, TPSValueProc(P).Parameters) and ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then begin tempp.Free; Decl.Free; p.Free; p := nil; exit; end; with TPSValueProcNo(p).Parameters[0] do begin Val := tempp; ExpectedType := GetTypeNo(BlockInfo, tempp); end; if FParser.CurrTokenId = CSTI_Assignment then begin FParser.Next; TempP := Calc(CSTI_SemiColon); if TempP = nil then begin Decl.Free; P.Free; p := nil; exit; end; with TPSValueProc(p).Parameters.Add do begin Val := Tempp; ExpectedType := at2ut(Decl.Result); end; if not TPSClassType(aType).Cl.Property_Set(Idx, procno) then begin Decl.Free; MakeError('', ecReadOnlyProperty, ''); p.Free; p := nil; exit; end; TPSValueProcNo(p).ProcNo := procno; TPSValueProcNo(p).ResultType := nil; end else begin if not TPSClassType(aType).Cl.Property_Get(Idx, procno) then begin Decl.Free; MakeError('', ecWriteOnlyProperty, ''); p.Free; p := nil; exit; end; TPSValueProcNo(p).ProcNo := procno; TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[procno]).RegProc.Decl.Result; end; // if FParser.CurrTokenId = CSTI_Assign Decl.Free; end; end; procedure CheckExtClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean); var Temp, Idx: Cardinal; FType: TPSType; s: tbtString; begin FType := GetTypeNo(BlockInfo, p); if FType = nil then Exit; if FType.BaseType <> btExtClass then Exit; while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do begin if not ImplicitPeriod then FParser.Next; if FParser.CurrTokenID <> CSTI_Identifier then begin if ImplicitPeriod then exit; MakeError('', ecIdentifierExpected, ''); p.Free; P := nil; Exit; end; s := FParser.GetToken; if TPSUndefinedClassType(FType).ExtClass.Func_Find(s, Idx) then begin FParser.Next; TPSUndefinedClassType(FType).ExtClass.Func_Call(Idx, Temp); P := ReadProcParameters(Temp, P); if p = nil then begin Exit; end; end else begin if ImplicitPeriod then exit; MakeError('', ecUnknownIdentifier, s); p.Free; P := nil; Exit; end; ImplicitPeriod := False; FType := GetTypeNo(BlockInfo, p); if (FType = nil) or (FType.BaseType <> btExtClass) then Exit; end; {while} end; procedure CheckClass(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean); var Procno: Cardinal; Idx: IPointer; FType: TPSType; TempP: TPSValue; Decl: TPSParametersDecl; s: tbtString; pinfo, pinfonew: tbtString; ppos: Cardinal; begin FType := GetTypeNo(BlockInfo, p); if FType = nil then exit; pinfo := ''; if (FType.BaseType <> btClass) then Exit; while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod) do begin if not ImplicitPeriod then FParser.Next; if FParser.CurrTokenID <> CSTI_Identifier then begin if ImplicitPeriod then exit; MakeError('', ecIdentifierExpected, ''); p.Free; P := nil; Exit; end; s := FParser.GetToken; if TPSClassType(FType).Cl.Func_Find(s, Idx) then begin FParser.Next; VarNo := InvalidVal; TPSClassType(FType).cl.Func_Call(Idx, Procno); P := ReadProcParameters(Procno, P); if p = nil then begin Exit; end; end else if TPSClassType(FType).cl.Property_Find(s, Idx) then begin ppos := FParser.CurrTokenPos; pinfonew := FParser.OriginalToken; FParser.Next; if VarNo <> InvalidVal then begin if pinfo = '' then pinfo := pinfonew else pinfo := pinfo + '.' + pinfonew; if @FOnUseVariable <> nil then FOnUseVariable(Self, VarType, VarNo, BlockInfo.ProcNo, ppos, pinfo); end; Decl := TPSParametersDecl.Create; TPSClassType(FType).cl.Property_GetHeader(Idx, Decl); TempP := P; p := TPSValueProcNo.Create; with TPSValueProcNo(p) do begin Parameters := TPSParameters.Create; Parameters.Add; Pos := FParser.CurrTokenPos; row := FParser.Row; Col := FParser.Col; end; if Decl.ParamCount <> 0 then begin if not (ReadParameters(True, TPSValueProc(P).Parameters) and ValidateParameters(BlockInfo, TPSValueProc(P).Parameters, Decl)) then begin Tempp.Free; Decl.Free; p.Free; P := nil; exit; end; end; // if with TPSValueProcNo(p).Parameters[0] do begin Val := TempP; ExpectedType := at2ut(GetTypeNo(BlockInfo, TempP)); end; if FParser.CurrTokenId = CSTI_Assignment then begin FParser.Next; TempP := Calc(CSTI_SemiColon); if TempP = nil then begin Decl.Free; P.Free; p := nil; exit; end; with TPSValueProc(p).Parameters.Add do begin Val := Tempp; ExpectedType := at2ut(Decl.Result); {$IFDEF DEBUG} if not ExpectedType.Used then asm int 3; end; {$ENDIF} end; if not TPSClassType(FType).cl.Property_Set(Idx, Procno) then begin MakeError('', ecReadOnlyProperty, ''); Decl.Free; p.Free; p := nil; exit; end; TPSValueProcNo(p).ProcNo := Procno; TPSValueProcNo(p).ResultType := nil; Decl.Free; Exit; end else begin if not TPSClassType(FType).cl.Property_Get(Idx, Procno) then begin MakeError('', ecWriteOnlyProperty, ''); Decl.Free; p.Free; p := nil; exit; end; TPSValueProcNo(p).ProcNo := ProcNo; TPSValueProcNo(p).ResultType := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl.Result; end; // if FParser.CurrTokenId = CSTI_Assign Decl.Free; end else begin if ImplicitPeriod then exit; MakeError('', ecUnknownIdentifier, s); p.Free; P := nil; Exit; end; ImplicitPeriod := False; FType := GetTypeNo(BlockInfo, p); if (FType = nil) or (FType.BaseType <> btClass) then Exit; end; {while} end; {$IFNDEF PS_NOIDISPATCH} procedure CheckIntf(var P: TPSValue; const VarType: TPSVariableType; VarNo: Cardinal; ImplicitPeriod: Boolean); var Procno, Idx: Cardinal; FType: TPSType; s: tbtString; CheckArrayProperty,HasArrayProperty:boolean; begin FType := GetTypeNo(BlockInfo, p); if FType = nil then exit; if (FType.BaseType <> btInterface) and (Ftype.BaseType <> BtVariant) and (FType.BaseType = btNotificationVariant) then Exit; CheckArrayProperty:=(FParser.CurrTokenID=CSTI_OpenBlock)and (Ftype.BaseType = BtVariant); while (FParser.CurrTokenID = CSTI_Period) or (ImplicitPeriod)or (CheckArrayProperty) do begin HasArrayProperty:=CheckArrayProperty; if CheckArrayProperty then begin CheckArrayProperty:=false; end else begin if not ImplicitPeriod then FParser.Next; end; if FParser.CurrTokenID <> CSTI_Identifier then begin if ImplicitPeriod then exit; if not HasArrayProperty then begin MakeError('', ecIdentifierExpected, ''); p.Free; P := nil; Exit; end; end; if (FType.BaseType = btVariant) or (FType.BaseType = btNotificationVariant) then begin if HasArrayProperty then begin s:=''; end else begin s := FParser.OriginalToken; FParser.Next; end; ImplicitPeriod := False; FType := GetTypeNo(BlockInfo, p); p := ReadIDispatchParameters(s, TPSVariantType(FType), p); if (FType = nil) or (FType.BaseType <> btInterface) then Exit; end else begin s := FParser.GetToken; if (FType is TPSInterfaceType) and (TPSInterfaceType(FType).Intf.Func_Find(s, Idx)) then begin FParser.Next; TPSInterfaceType(FType).Intf.Func_Call(Idx, Procno); P := ReadProcParameters(Procno, P); if p = nil then begin Exit; end; end else begin if ImplicitPeriod then exit; MakeError('', ecUnknownIdentifier, s); p.Free; P := nil; Exit; end; ImplicitPeriod := False; FType := GetTypeNo(BlockInfo, p); if (FType = nil) or ((FType.BaseType <> btInterface) and (Ftype.BaseType <> btVariant) and (Ftype.BaseType <> btNotificationVariant)) then Exit; end; end; {while} end; {$ENDIF} function ExtCheckClassType(FType: TPSType; const ParserPos: Cardinal): TPSValue; var FType2: TPSType; ProcNo, Idx: Cardinal; Temp, ResV: TPSValue; begin if FParser.CurrTokenID = CSTI_OpenRound then begin FParser.Next; Temp := Calc(CSTI_CloseRound); if Temp = nil then begin Result := nil; exit; end; if FParser.CurrTokenID <> CSTI_CloseRound then begin temp.Free; MakeError('', ecCloseRoundExpected, ''); Result := nil; exit; end; FType2 := GetTypeNo(BlockInfo, Temp); if (FType.basetype = BtClass) and (ftype2.BaseType = btClass) and (ftype <> ftype2) then begin if not TPSUndefinedClassType(FType2).ExtClass.CastToType(AT2UT(FType), ProcNo) then begin temp.Free; MakeError('', ecTypeMismatch, ''); Result := nil; exit; end; Result := TPSValueProcNo.Create; TPSValueProcNo(Result).Parameters := TPSParameters.Create; TPSValueProcNo(Result).ResultType := at2ut(FType); TPSValueProcNo(Result).ProcNo := ProcNo; with TPSValueProcNo(Result).Parameters.Add do begin Val := Temp; ExpectedType := GetTypeNo(BlockInfo, temp); end; with TPSValueProcNo(Result).Parameters.Add do begin ExpectedType := at2ut(FindBaseType(btu32)); Val := TPSValueData.Create; with TPSValueData(val) do begin SetParserPos(FParser); Data := NewVariant(ExpectedType); Data.tu32 := at2ut(FType).FinalTypeNo; end; end; FParser.Next; Exit; end; if not IsCompatibleType(FType, FType2, True) then begin temp.Free; MakeError('', ecTypeMismatch, ''); Result := nil; exit; end; FParser.Next; Result := TPSUnValueOp.Create; with TPSUnValueOp(Result) do begin Operator := otCast; Val1 := Temp; SetParserPos(FParser); aType := AT2UT(FType); end; exit; end; if FParser.CurrTokenId <> CSTI_Period then begin Result := nil; MakeError('', ecPeriodExpected, ''); Exit; end; if FType.BaseType <> btExtClass then begin Result := nil; MakeError('', ecClassTypeExpected, ''); Exit; end; FParser.Next; if not TPSUndefinedClassType(FType).ExtClass.ClassFunc_Find(FParser.GetToken, Idx) then begin Result := nil; MakeError('', ecUnknownIdentifier, FParser.OriginalToken); Exit; end; FParser.Next; TPSUndefinedClassType(FType).ExtClass.ClassFunc_Call(Idx, ProcNo); Temp := TPSValueData.Create; with TPSValueData(Temp) do begin Data := NewVariant(at2ut(FindBaseType(btu32))); Data.tu32 := at2ut(FType).FinalTypeNo; end; ResV := ReadProcParameters(ProcNo, Temp); if ResV <> nil then begin TPSValueProc(Resv).ResultType := at2ut(FType); Result := Resv; end else begin Result := nil; end; end; function CheckClassType(TypeNo: TPSType; const ParserPos: Cardinal): TPSValue; var FType2: TPSType; ProcNo: Cardinal; Idx: IPointer; Temp, ResV: TPSValue; dta: PIfRVariant; begin if typeno.BaseType = btExtClass then begin Result := ExtCheckClassType(TypeNo, PArserPos); exit; end; if FParser.CurrTokenID = CSTI_OpenRound then begin FParser.Next; Temp := Calc(CSTI_CloseRound); if Temp = nil then begin Result := nil; exit; end; if FParser.CurrTokenID <> CSTI_CloseRound then begin temp.Free; MakeError('', ecCloseRoundExpected, ''); Result := nil; exit; end; FType2 := GetTypeNo(BlockInfo, Temp); if ((typeno.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (TypeNo.basetype = btInterface){$ENDIF}) and ((ftype2.BaseType = btClass){$IFNDEF PS_NOINTERFACES} or (ftype2.BaseType = btInterface){$ENDIF}) and (TypeNo <> ftype2) then begin {$IFNDEF PS_NOINTERFACES} if FType2.basetype = btClass then begin {$ENDIF} if not TPSClassType(FType2).Cl.CastToType(AT2UT(TypeNo), ProcNo) then begin temp.Free; MakeError('', ecTypeMismatch, ''); Result := nil; exit; end; {$IFNDEF PS_NOINTERFACES} end else begin if not TPSInterfaceType(FType2).Intf.CastToType(AT2UT(TypeNo), ProcNo) then begin temp.Free; MakeError('', ecTypeMismatch, ''); Result := nil; exit; end; end; {$ENDIF} Result := TPSValueProcNo.Create; TPSValueProcNo(Result).Parameters := TPSParameters.Create; TPSValueProcNo(Result).ResultType := at2ut(TypeNo); TPSValueProcNo(Result).ProcNo := ProcNo; with TPSValueProcNo(Result).Parameters.Add do begin Val := Temp; ExpectedType := GetTypeNo(BlockInfo, temp); {$IFDEF DEBUG} if not ExpectedType.Used then asm int 3; end; {$ENDIF} end; with TPSValueProcNo(Result).Parameters.Add do begin ExpectedType := at2ut(FindBaseType(btu32)); {$IFDEF DEBUG} if not ExpectedType.Used then asm int 3; end; {$ENDIF} Val := TPSValueData.Create; with TPSValueData(val) do begin SetParserPos(FParser); Data := NewVariant(ExpectedType); Data.tu32 := at2ut(TypeNo).FinalTypeNo; end; end; FParser.Next; Exit; end; if not IsCompatibleType(TypeNo, FType2, True) then begin temp.Free; MakeError('', ecTypeMismatch, ''); Result := nil; exit; end; FParser.Next; Result := TPSUnValueOp.Create; with TPSUnValueOp(Result) do begin Operator := otCast; Val1 := Temp; SetParserPos(FParser); aType := AT2UT(TypeNo); end; exit; end else if FParser.CurrTokenId <> CSTI_Period then begin Result := TPSValueData.Create; Result.SetParserPos(FParser); New(dta); TPSValueData(Result).Data := dta; InitializeVariant(dta, at2ut(FindBaseType(btType))); dta.ttype := at2ut(TypeNo); Exit; end; if TypeNo.BaseType <> btClass then begin Result := nil; MakeError('', ecClassTypeExpected, ''); Exit; end; FParser.Next; if not TPSClassType(TypeNo).Cl.ClassFunc_Find(FParser.GetToken, Idx) then begin Result := nil; MakeError('', ecUnknownIdentifier, FParser.OriginalToken); Exit; end; FParser.Next; TPSClassType(TypeNo).Cl.ClassFunc_Call(Idx, ProcNo); Temp := TPSValueData.Create; with TPSValueData(Temp) do begin Data := NewVariant(at2ut(FindBaseType(btu32))); Data.tu32 := at2ut(TypeNo).FinalTypeNo; end; ResV := ReadProcParameters(ProcNo, Temp); if ResV <> nil then begin TPSValueProc(Resv).ResultType := at2ut(TypeNo); Result := Resv; end else begin Result := nil; end; end; function GetIdentifier(const FType: Byte): TPSValue; { FType: 0 = Anything 1 = Only variables 2 = Not constants } var vt: TPSVariableType; vno: Cardinal; TWith, Temp: TPSValue; l, h: Longint; s, u: tbtString; t: TPSConstant; Temp1: TPSType; temp2: CArdinal; bi: TPSBlockInfo; lOldRecCount: Integer; begin s := FParser.GetToken; if FType <> 1 then begin bi := BlockInfo; while bi <> nil do begin for l := bi.WithList.Count -1 downto 0 do begin TWith := TPSValueAllocatedStackVar.Create; TPSValueAllocatedStackVar(TWith).LocalVarNo := TPSValueAllocatedStackVar(TPSValueReplace(bi.WithList[l]).NewValue).LocalVarNo; Temp := TWith; VNo := TPSValueAllocatedStackVar(Temp).LocalVarNo; lOldRecCount := TPSValueVar(TWith).GetRecCount; vt := ivtVariable; if Temp = TWith then CheckFurther(TWith, True); if Temp = TWith then CheckClass(TWith, vt, vno, True); if Temp = TWith then CheckExtClass(TWith, vt, vno, True); if (Temp <> TWith) or (Cardinal(lOldRecCount) <> TPSValueVar(TWith).GetRecCount) then begin repeat Temp := TWith; if TWith <> nil then CheckFurther(TWith, False); if TWith <> nil then CheckClass(TWith, vt, vno, False); if TWith <> nil then CheckExtClass(TWith, vt, vno, False); {$IFNDEF PS_NOIDISPATCH}if TWith <> nil then CheckIntf(TWith, vt, vno, False);{$ENDIF} if TWith <> nil then CheckProcCall(TWith); if TWith <> nil then CheckClassArrayProperty(TWith, vt, vno); vno := InvalidVal; until (TWith = nil) or (Temp = TWith); Result := TWith; Exit; end; TWith.Free; end; bi := bi.FOwner; end; end; if s = 'RESULT' then begin if BlockInfo.proc.Decl.Result = nil then begin Result := nil; MakeError('', ecUnknownIdentifier, FParser.OriginalToken); end else begin BlockInfo.Proc.ResultUse; Result := TPSValueParamVar.Create; with TPSValueParamVar(Result) do begin SetParserPos(FParser); ParamNo := 0; end; vno := 0; vt := ivtParam; if @FOnUseVariable <> nil then FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, ''); FParser.Next; repeat Temp := Result; if Result <> nil then CheckFurther(Result, False); if Result <> nil then CheckClass(Result, vt, vno, False); if Result <> nil then CheckExtClass(Result, vt, vno, False); {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} if Result <> nil then CheckProcCall(Result); if Result <> nil then CheckClassArrayProperty(Result, vt, vno); vno := InvalidVal; until (Result = nil) or (Temp = Result); end; exit; end; if BlockInfo.Proc.Decl.Result = nil then l := 0 else l := 1; for h := 0 to BlockInfo.proc.Decl.ParamCount -1 do begin if BlockInfo.proc.Decl.Params[h].Name = s then begin Result := TPSValueParamVar.Create; with TPSValueParamVar(Result) do begin SetParserPos(FParser); ParamNo := l; end; vt := ivtParam; vno := L; if @FOnUseVariable <> nil then FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, ''); FParser.Next; repeat Temp := Result; if Result <> nil then CheckFurther(Result, False); if Result <> nil then CheckClass(Result, vt, vno, False); if Result <> nil then CheckExtClass(Result, vt, vno, False); {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} if Result <> nil then CheckProcCall(Result); if Result <> nil then CheckClassArrayProperty(Result, vt, vno); vno := InvalidVal; until (Result = nil) or (Temp = Result); exit; end; Inc(l); GRFW(u); end; h := MakeHash(s); for l := 0 to BlockInfo.Proc.ProcVars.Count - 1 do begin if (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).NameHash = h) and (PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Name = s) then begin PIFPSProcVar(BlockInfo.Proc.ProcVars[l]).Use; vno := l; vt := ivtVariable; if @FOnUseVariable <> nil then FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, ''); Result := TPSValueLocalVar.Create; with TPSValueLocalVar(Result) do begin LocalVarNo := l; SetParserPos(FParser); end; FParser.Next; repeat Temp := Result; if Result <> nil then CheckFurther(Result, False); if Result <> nil then CheckClass(Result, vt, vno, False); if Result <> nil then CheckExtClass(Result, vt, vno, False); {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} if Result <> nil then CheckProcCall(Result); if Result <> nil then CheckClassArrayProperty(Result, vt, vno); vno := InvalidVal; until (Result = nil) or (Temp = Result); exit; end; end; for l := 0 to FVars.Count - 1 do begin if (TPSVar(FVars[l]).NameHash = h) and (TPSVar(FVars[l]).Name = s) {$IFDEF PS_USESSUPPORT} and (IsInLocalUnitList(TPSVar(FVars[l]).FDeclareUnit)){$ENDIF} then begin TPSVar(FVars[l]).Use; Result := TPSValueGlobalVar.Create; with TPSValueGlobalVar(Result) do begin SetParserPos(FParser); GlobalVarNo := l; end; vt := ivtGlobal; vno := l; if @FOnUseVariable <> nil then FOnUseVariable(Self, vt, vno, BlockInfo.ProcNo, FParser.CurrTokenPos, ''); FParser.Next; repeat Temp := Result; if Result <> nil then CheckNotificationVariant(Result); if Result <> nil then CheckFurther(Result, False); if Result <> nil then CheckClass(Result, vt, vno, False); if Result <> nil then CheckExtClass(Result, vt, vno, False); {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} if Result <> nil then CheckProcCall(Result); if Result <> nil then CheckClassArrayProperty(Result, vt, vno); vno := InvalidVal; until (Result = nil) or (Temp = Result); exit; end; end; Temp1 := FindType(FParser.GetToken); if Temp1 <> nil then begin l := FParser.CurrTokenPos; if FType = 1 then begin Result := nil; MakeError('', ecVariableExpected, FParser.OriginalToken); exit; end; vt := ivtGlobal; vno := InvalidVal; FParser.Next; Result := CheckClassType(Temp1, l); repeat Temp := Result; if Result <> nil then CheckFurther(Result, False); if Result <> nil then CheckClass(Result, vt, vno, False); if Result <> nil then CheckExtClass(Result, vt, vno, False); {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} if Result <> nil then CheckProcCall(Result); if Result <> nil then CheckClassArrayProperty(Result, vt, vno); vno := InvalidVal; until (Result = nil) or (Temp = Result); exit; end; Temp2 := FindProc(FParser.GetToken); if Temp2 <> InvalidVal then begin if FType = 1 then begin Result := nil; MakeError('', ecVariableExpected, FParser.OriginalToken); exit; end; FParser.Next; Result := ReadProcParameters(Temp2, nil); if Result = nil then exit; Result.SetParserPos(FParser); vt := ivtGlobal; vno := InvalidVal; repeat Temp := Result; if Result <> nil then CheckFurther(Result, False); if Result <> nil then CheckClass(Result, vt, vno, False); if Result <> nil then CheckExtClass(Result, vt, vno, False); {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} if Result <> nil then CheckProcCall(Result); if Result <> nil then CheckClassArrayProperty(Result, vt, vno); vno := InvalidVal; until (Result = nil) or (Temp = Result); exit; end; for l := 0 to FConstants.Count -1 do begin t := TPSConstant(FConstants[l]); if (t.NameHash = h) and (t.Name = s) {$IFDEF PS_USESSUPPORT} and (IsInLocalUnitList(t.FDeclareUnit)) {$ENDIF} then begin if FType <> 0 then begin Result := nil; MakeError('', ecVariableExpected, FParser.OriginalToken); exit; end; fparser.next; Result := TPSValueData.Create; with TPSValueData(Result) do begin SetParserPos(FParser); Data := NewVariant(at2ut(t.Value.FType)); CopyVariantContents(t.Value, Data); end; vt := ivtGlobal; vno := InvalidVal; repeat Temp := Result; if Result <> nil then CheckFurther(Result, False); if Result <> nil then CheckClass(Result, vt, vno, False); if Result <> nil then CheckExtClass(Result, vt, vno, False); {$IFNDEF PS_NOIDISPATCH}if Result <> nil then CheckIntf(Result, vt, vno, False);{$ENDIF} if Result <> nil then CheckProcCall(Result); if Result <> nil then CheckClassArrayProperty(Result, vt, vno); vno := InvalidVal; until (Result = nil) or (Temp = Result); exit; end; end; Result := nil; MakeError('', ecUnknownIdentifier, FParser.OriginalToken); end; function calc(endOn: TPSPasToken): TPSValue; function TryEvalConst(var P: TPSValue): Boolean; forward; function ReadExpression: TPSValue; forward; function ReadTerm: TPSValue; forward; function ReadFactor: TPSValue; var NewVar: TPSValue; NewVarU: TPSUnValueOp; Proc: TPSProcedure; function ReadArray: Boolean; var tmp: TPSValue; begin FParser.Next; NewVar := TPSValueArray.Create; NewVar.SetParserPos(FParser); if FParser.CurrTokenID <> CSTI_CloseBlock then begin while True do begin tmp := nil; Tmp := ReadExpression(); if Tmp = nil then begin Result := False; NewVar.Free; exit; end; if not TryEvalConst(tmp) then begin tmp.Free; NewVar.Free; Result := False; exit; end; TPSValueArray(NewVar).Add(tmp); if FParser.CurrTokenID = CSTI_CloseBlock then Break; if FParser.CurrTokenID <> CSTI_Comma then begin MakeError('', ecCloseBlockExpected, ''); NewVar.Free; Result := False; exit; end; FParser.Next; end; end; FParser.Next; Result := True; end; function CallAssigned(P: TPSValue): TPSValue; var temp: TPSValueProcNo; begin temp := TPSValueProcNo.Create; temp.ProcNo := FindProc('!ASSIGNED'); temp.ResultType := at2ut(FDefaultBoolType); temp.Parameters := TPSParameters.Create; with Temp.Parameters.Add do begin Val := p; ExpectedType := GetTypeNo(BlockInfo, p); {$IFDEF DEBUG} if not ExpectedType.Used then asm int 3; end; {$ENDIF} FParamMode := pmIn; end; Result := Temp; end; function CallSucc(P: TPSValue): TPSValue; var temp: TPSBinValueOp; begin temp := TPSBinValueOp.Create; temp.SetParserPos(FParser); temp.FOperator := otAdd; temp.FVal2 := TPSValueData.Create; TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32)); TPSValueData(Temp.FVal2).Data.ts32 := 1; temp.FVal1 := p; Temp.FType := GetTypeNo(BlockInfo, P); result := temp; end; function CallPred(P: TPSValue): TPSValue; var temp: TPSBinValueOp; begin temp := TPSBinValueOp.Create; temp.SetParserPos(FParser); temp.FOperator := otSub; temp.FVal2 := TPSValueData.Create; TPSValueData(Temp.FVal2).Data := NewVariant(FindBaseType(bts32)); TPSValueData(Temp.FVal2).Data.ts32 := 1; temp.FVal1 := p; Temp.FType := GetTypeNo(BlockInfo, P); result := temp; end; begin case fParser.CurrTokenID of CSTI_OpenBlock: begin if not ReadArray then begin Result := nil; exit; end; end; CSTII_Not: begin FParser.Next; NewVar := ReadFactor; if NewVar = nil then begin Result := nil; exit; end; NewVarU := TPSUnValueOp.Create; NewVarU.SetParserPos(FParser); NewVarU.aType := GetTypeNo(BlockInfo, NewVar); NewVarU.Operator := otNot; NewVarU.Val1 := NewVar; NewVar := NewVarU; end; CSTI_Plus: begin FParser.Next; NewVar := ReadTerm; if NewVar = nil then begin Result := nil; exit; end; end; CSTI_Minus: begin FParser.Next; NewVar := ReadTerm; if NewVar = nil then begin Result := nil; exit; end; NewVarU := TPSUnValueOp.Create; NewVarU.SetParserPos(FParser); NewVarU.aType := GetTypeNo(BlockInfo, NewVar); NewVarU.Operator := otMinus; NewVarU.Val1 := NewVar; NewVar := NewVarU; end; CSTII_Nil: begin FParser.Next; NewVar := TPSValueNil.Create; NewVar.SetParserPos(FParser); end; CSTI_AddressOf: begin FParser.Next; if FParser.CurrTokenID <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); Result := nil; exit; end; NewVar := TPSValueProcPtr.Create; NewVar.SetParserPos(FParser); TPSValueProcPtr(NewVar).ProcPtr := FindProc(FParser.GetToken); if TPSValueProcPtr(NewVar).ProcPtr = InvalidVal then begin MakeError('', ecUnknownIdentifier, FParser.OriginalToken); NewVar.Free; Result := nil; exit; end; Proc := FProcs[TPSValueProcPtr(NewVar).ProcPtr]; if Proc.ClassType <> TPSInternalProcedure then begin MakeError('', ecUnknownIdentifier, FParser.OriginalToken); NewVar.Free; Result := nil; exit; end; FParser.Next; end; CSTI_OpenRound: begin FParser.Next; NewVar := ReadExpression(); if NewVar = nil then begin Result := nil; exit; end; if FParser.CurrTokenId <> CSTI_CloseRound then begin NewVar.Free; Result := nil; MakeError('', ecCloseRoundExpected, ''); exit; end; FParser.Next; end; CSTI_Char, CSTI_String: begin NewVar := TPSValueData.Create; NewVar.SetParserPos(FParser); TPSValueData(NewVar).Data := ReadString; if TPSValueData(NewVar).Data = nil then begin NewVar.Free; Result := nil; exit; end; end; CSTI_HexInt, CSTI_Integer: begin NewVar := TPSValueData.Create; NewVar.SetParserPos(FParser); TPSValueData(NewVar).Data := ReadInteger(FParser.GetToken); FParser.Next; end; CSTI_Real: begin NewVar := TPSValueData.Create; NewVar.SetParserPos(FParser); TPSValueData(NewVar).Data := ReadReal(FParser.GetToken); FParser.Next; end; CSTII_Ord: begin FParser.Next; if fParser.Currtokenid <> CSTI_OpenRound then begin Result := nil; MakeError('', ecOpenRoundExpected, ''); exit; end; FParser.Next; NewVar := ReadExpression(); if NewVar = nil then begin Result := nil; exit; end; if FParser.CurrTokenId <> CSTI_CloseRound then begin NewVar.Free; Result := nil; MakeError('', ecCloseRoundExpected, ''); exit; end; if not ((GetTypeNo(BlockInfo, NewVar).BaseType = btChar) or {$IFNDEF PS_NOWIDESTRING} (GetTypeNo(BlockInfo, NewVar).BaseType = btWideChar) or{$ENDIF} (GetTypeNo(BlockInfo, NewVar).BaseType = btEnum) or (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType))) then begin NewVar.Free; Result := nil; MakeError('', ecTypeMismatch, ''); exit; end; NewVarU := TPSUnValueOp.Create; NewVarU.SetParserPos(FParser); NewVarU.Operator := otCast; NewVarU.FType := at2ut(FindBaseType(btu32)); NewVarU.Val1 := NewVar; NewVar := NewVarU; FParser.Next; end; CSTII_Chr: begin FParser.Next; if fParser.Currtokenid <> CSTI_OpenRound then begin Result := nil; MakeError('', ecOpenRoundExpected, ''); exit; end; FParser.Next; NewVar := ReadExpression(); if NewVar = nil then begin Result := nil; exit; end; if FParser.CurrTokenId <> CSTI_CloseRound then begin NewVar.Free; Result := nil; MakeError('', ecCloseRoundExpected, ''); exit; end; if not (IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType)) then begin NewVar.Free; Result := nil; MakeError('', ecTypeMismatch, ''); exit; end; NewVarU := TPSUnValueOp.Create; NewVarU.SetParserPos(FParser); NewVarU.Operator := otCast; NewVarU.FType := at2ut(FindBaseType(btChar)); NewVarU.Val1 := NewVar; NewVar := NewVarU; FParser.Next; end; CSTI_Identifier: begin if FParser.GetToken = 'SUCC' then begin FParser.Next; if FParser.CurrTokenID <> CSTI_OpenRound then begin Result := nil; MakeError('', ecOpenRoundExpected, ''); exit; end; FParser.Next; NewVar := ReadExpression; if NewVar = nil then begin result := nil; exit; end; if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then begin NewVar.Free; Result := nil; MakeError('', ecTypeMismatch, ''); exit; end; if FParser.CurrTokenID <> CSTI_CloseRound then begin NewVar.Free; Result := nil; MakeError('', eccloseRoundExpected, ''); exit; end; NewVar := CallSucc(NewVar); FParser.Next; end else if FParser.GetToken = 'PRED' then begin FParser.Next; if FParser.CurrTokenID <> CSTI_OpenRound then begin Result := nil; MakeError('', ecOpenRoundExpected, ''); exit; end; FParser.Next; NewVar := ReadExpression; if NewVar = nil then begin result := nil; exit; end; if (GetTypeNo(BlockInfo, NewVar) = nil) or (not IsIntType(GetTypeNo(BlockInfo, NewVar).BaseType) and (GetTypeNo(BlockInfo, NewVar).BaseType <> btEnum)) then begin NewVar.Free; Result := nil; MakeError('', ecTypeMismatch, ''); exit; end; if FParser.CurrTokenID <> CSTI_CloseRound then begin NewVar.Free; Result := nil; MakeError('', eccloseRoundExpected, ''); exit; end; NewVar := CallPred(NewVar); FParser.Next; end else if FParser.GetToken = 'ASSIGNED' then begin FParser.Next; if FParser.CurrTokenID <> CSTI_OpenRound then begin Result := nil; MakeError('', ecOpenRoundExpected, ''); exit; end; FParser.Next; NewVar := GetIdentifier(0); if NewVar = nil then begin result := nil; exit; end; if (GetTypeNo(BlockInfo, NewVar) = nil) or ((GetTypeNo(BlockInfo, NewVar).BaseType <> btClass) and (GetTypeNo(BlockInfo, NewVar).BaseType <> btPChar) and (GetTypeNo(BlockInfo, NewVar).BaseType <> btString)) then begin NewVar.Free; Result := nil; MakeError('', ecTypeMismatch, ''); exit; end; if FParser.CurrTokenID <> CSTI_CloseRound then begin NewVar.Free; Result := nil; MakeError('', eccloseRoundExpected, ''); exit; end; NewVar := CallAssigned(NewVar); FParser.Next; end else begin NewVar := GetIdentifier(0); if NewVar = nil then begin Result := nil; exit; end; end; end; else begin MakeError('', ecSyntaxError, ''); Result := nil; exit; end; end; {case} Result := NewVar; end; // ReadFactor function GetResultType(p1, P2: TPSValue; Cmd: TPSBinOperatorType): TPSType; var pp, t1, t2: PIFPSType; begin t1 := GetTypeNo(BlockInfo, p1); t2 := GetTypeNo(BlockInfo, P2); if (t1 = nil) or (t2 = nil) then begin if ((p1.ClassType = TPSValueNil) or (p2.ClassType = TPSValueNil)) and ((t1 <> nil) or (t2 <> nil)) then begin if p1.ClassType = TPSValueNil then pp := t2 else pp := t1; if (pp.BaseType = btPchar) or (pp.BaseType = btString) or (pp.BaseType = btClass) {$IFNDEF PS_NOINTERFACES}or (pp.BaseType =btInterface){$ENDIF} or (pp.BaseType = btProcPtr) then Result := AT2UT(FDefaultBoolType) else Result := nil; exit; end; Result := nil; exit; end; case Cmd of otAdd: {plus} begin if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or (t2.BaseType = btString) or {$IFNDEF PS_NOWIDESTRING} (t2.BaseType = btwideString) or (t2.BaseType = btUnicodestring) or (t2.BaseType = btwidechar) or {$ENDIF} (t2.BaseType = btPchar) or (t2.BaseType = btChar) or (isIntRealType(t2.BaseType))) then Result := t1 else if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or (t1.BaseType = btString) or {$IFNDEF PS_NOWIDESTRING} (t1.BaseType = btUnicodestring) or (t1.BaseType = btwideString) or (t1.BaseType = btwidechar) or {$ENDIF} (t1.BaseType = btPchar) or (t1.BaseType = btChar) or (isIntRealType(t1.BaseType))) then Result := t2 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then Result := t1 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then Result := t1 else if IsIntRealType(t1.BaseType) and IsIntRealType(t2.BaseType) then begin if IsRealType(t1.BaseType) then Result := t1 else Result := t2; end else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then Result := t1 else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then Result := t2 else if ((t1.BaseType = btPchar) or(t1.BaseType = btString) or (t1.BaseType = btChar)) and ((t2.BaseType = btPchar) or(t2.BaseType = btString) or (t2.BaseType = btChar)) then Result := at2ut(FindBaseType(btString)) {$IFNDEF PS_NOWIDESTRING} else if ((t1.BaseType = btString) or (t1.BaseType = btChar) or (t1.BaseType = btPchar)or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodeString)) and ((t2.BaseType = btString) or (t2.BaseType = btChar) or (t2.BaseType = btPchar) or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodeString)) then Result := at2ut(FindBaseType(btWideString)) {$ENDIF} else Result := nil; end; otSub, otMul, otIntDiv, otDiv: { - * / } begin if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or (isIntRealType(t2.BaseType))) then Result := t1 else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otSub) or (cmd = otMul)) then Result := t1 else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then Result := t1 else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') and ((cmd = otSub) or (cmd = otMul)) then Result := t2 else if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or (isIntRealType(t1.BaseType))) then Result := t2 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then begin Result := t1; {$IFDEF PS_DELPHIDIV} if Cmd = otDiv then result := FindBaseType(btExtended); {$ENDIF} end else if IsIntRealType(t1.BaseType) and IsIntRealType(t2.BaseType) then begin if IsRealType(t1.BaseType) then Result := t1 else Result := t2; {$IFDEF PS_DELPHIDIV} if Cmd = otIntDiv then //intdiv only works result := nil; {$ENDIF} end else Result := nil; end; otAnd, otOr, otXor: {and,or,xor} begin if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or (isIntType(t2.BaseType))) then Result := t1 else if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or (isIntType(t1.BaseType))) then Result := t2 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then Result := t1 else if (IsBoolean(t1)) and ((t2 = t1) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant))) then begin Result := t1; if ((p1.ClassType = TPSValueData) or (p2.ClassType = TPSValueData)) then begin if cmd = otAnd then {and} begin if p1.ClassType = TPSValueData then begin if (TPSValueData(p1).FData^.tu8 <> 0) then begin with MakeWarning('', ewIsNotNeeded, '"True and"') do begin FRow := p1.Row; FCol := p1.Col; FPosition := p1.Pos; end; end else begin with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do begin FRow := p1.Row; FCol := p1.Col; FPosition := p1.Pos; end; end; end else begin if (TPSValueData(p2).Data.tu8 <> 0) then begin with MakeWarning('', ewIsNotNeeded, '"and True"') do begin FRow := p1.Row; FCol := p1.Col; FPosition := p1.Pos; end; end else begin with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'False') do begin FRow := p1.Row; FCol := p1.Col; FPosition := p1.Pos; end; end; end; end else if cmd = otOr then {or} begin if p1.ClassType = TPSValueData then begin if (TPSValueData(p1).Data.tu8 <> 0) then begin with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do begin FRow := p1.Row; FCol := p1.Col; FPosition := p1.Pos; end; end else begin with MakeWarning('', ewIsNotNeeded, '"False or"') do begin FRow := p1.Row; FCol := p1.Col; FPosition := p1.Pos; end; end end else begin if (TPSValueData(p2).Data.tu8 <> 0) then begin with MakeWarning('', ewCalculationAlwaysEvaluatesTo, 'True') do begin FRow := p1.Row; FCol := p1.Col; FPosition := p1.Pos; end; end else begin with MakeWarning('', ewIsNotNeeded, '"or False"') do begin FRow := p1.Row; FCol := p1.Col; FPosition := p1.Pos; end; end end; end; end; end else Result := nil; end; otMod, otShl, otShr: {mod,shl,shr} begin if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or (isIntType(t2.BaseType))) then Result := t1 else if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or (isIntType(t1.BaseType))) then Result := t2 else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then Result := t1 else Result := nil; end; otGreater, otLess, otGreaterEqual, otLessEqual: { >=, <=, >, <} begin if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or (t2.BaseType = btString) or (t2.BaseType = btPchar) or (t2.BaseType = btChar) or (isIntRealType(t2.BaseType))) then Result := FDefaultBoolType else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) and ((cmd = otGreaterEqual) or (cmd = otLessEqual)) then Result := FDefaultBoolType else if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or (t1.BaseType = btString) or (t1.BaseType = btPchar) or (t1.BaseType = btChar) or (isIntRealType(t1.BaseType))) then Result := FDefaultBoolType else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then Result := FDefaultBoolType else if IsIntRealType(t1.BaseType) and IsIntRealType(t2.BaseType) then Result := FDefaultBoolType else if ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then Result := FDefaultBoolType else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then Result := FDefaultBoolType else Result := nil; end; otEqual, otNotEqual: {=, <>} begin if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) and ( ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) or (t2.BaseType = btString) or (t2.BaseType = btPchar) or (t2.BaseType = btChar) or (isIntRealType(t2.BaseType))) then Result := FDefaultBoolType else if ((t1.BaseType = btSet) and (t2.BaseType = btSet)) and (t1 = t2) then Result := FDefaultBoolType else if ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) and ( ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or (t1.BaseType = btString) or (t1.BaseType = btPchar) or (t1.BaseType = btChar) or (isIntRealType(t1.BaseType))) then Result := FDefaultBoolType else if IsIntType(t1.BaseType) and IsIntType(t2.BaseType) then Result := FDefaultBoolType else if IsIntRealType(t1.BaseType) and IsIntRealType(t2.BaseType) then Result := FDefaultBoolType else if ((t1.BaseType = btString) or (t1.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t1.BaseType = btWideString) or (t1.BaseType = btWideChar) or (t1.BaseType = btUnicodestring){$ENDIF}) and ((t2.BaseType = btString) or (t2.BaseType = btChar) {$IFNDEF PS_NOWIDESTRING} or (t2.BaseType = btWideString) or (t2.BaseType = btWideChar) or (t2.BaseType = btUnicodestring){$ENDIF}) then Result := FDefaultBoolType else if (t1.basetype = btSet) and (t2.Name = 'TVARIANTARRAY') then Result := FDefaultBoolType else if (t2.basetype = btSet) and (t1.Name = 'TVARIANTARRAY') then Result := FDefaultBoolType else if (t1.BaseType = btEnum) and (t1 = t2) then Result := FDefaultBoolType else if (t1.BaseType = btClass) and (t2.BaseType = btClass) then Result := FDefaultBoolType else if (t1 = t2) then Result := FDefaultBoolType else if ((t1.BaseType = btVariant) or (t1.BaseType = btNotificationVariant)) or ((t2.BaseType = btVariant) or (t2.BaseType = btNotificationVariant)) then Result := FDefaultBoolType else Result := nil; end; otIn: begin if (t2.Name = 'TVARIANTARRAY') then Result := FDefaultBoolType else if (t2.BaseType = btSet) and (TPSSetType(t2).SetType = t1) then Result := FDefaultBoolType else Result := nil; end; otIs: begin if t2.BaseType = btType then begin Result := FDefaultBoolType end else Result := nil; end; otAs: begin if t2.BaseType = btType then begin Result := at2ut(TPSValueData(p2).Data.ttype); end else Result := nil; end; else Result := nil; end; end; function ReadTerm: TPSValue; var F1, F2: TPSValue; fType: TPSType; F: TPSBinValueOp; Token: TPSPasToken; Op: TPSBinOperatorType; begin F1 := ReadFactor; if F1 = nil then begin Result := nil; exit; end; while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr, CSTII_As] do begin Token := FParser.CurrTokenID; FParser.Next; F2 := ReadFactor; if f2 = nil then begin f1.Free; Result := nil; exit; end; case Token of CSTI_Multiply: Op := otMul; CSTI_Divide: Op := otDiv; CSTII_div: Op := otIntDiv; CSTII_mod: Op := otMod; CSTII_and: Op := otAnd; CSTII_shl: Op := otShl; CSTII_shr: Op := otShr; CSTII_As: Op := otAs; else Op := otAdd; end; if (Op = otAs) and (f2 is TPSValueData) and (TPSValueData(f2).Data.FType.BaseType = btType) then begin fType := TPSValueData(f2).Data.ttype; f2.Free; f2 := TPSUnValueOp.Create; TPSUnValueOp(F2).Val1 := f1; TPSUnValueOp(F2).SetParserPos(FParser); TPSUnValueOp(f2).FType := fType; TPSUnValueOp(f2).Operator := otCast; f1 := f2; end else begin F := TPSBinValueOp.Create; f.Val1 := F1; f.Val2 := F2; f.Operator := Op; f.aType := GetResultType(F1, F2, Op); if f.aType = nil then begin MakeError('', ecTypeMismatch, ''); f.Free; Result := nil; exit; end; f1 := f; end; end; Result := F1; end; // ReadTerm function ReadSimpleExpression: TPSValue; var F1, F2: TPSValue; F: TPSBinValueOp; Token: TPSPasToken; Op: TPSBinOperatorType; begin F1 := ReadTerm; if F1 = nil then begin Result := nil; exit; end; while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do begin Token := FParser.CurrTokenID; FParser.Next; F2 := ReadTerm; if f2 = nil then begin f1.Free; Result := nil; exit; end; case Token of CSTI_Plus: Op := otAdd; CSTI_Minus: Op := otSub; CSTII_or: Op := otOr; CSTII_xor: Op := otXor; else Op := otAdd; end; F := TPSBinValueOp.Create; f.Val1 := F1; f.Val2 := F2; f.Operator := Op; f.aType := GetResultType(F1, F2, Op); if f.aType = nil then begin MakeError('', ecTypeMismatch, ''); f.Free; Result := nil; exit; end; f1 := f; end; Result := F1; end; // ReadSimpleExpression function ReadExpression: TPSValue; var F1, F2: TPSValue; F: TPSBinValueOp; Token: TPSPasToken; Op: TPSBinOperatorType; begin F1 := ReadSimpleExpression; if F1 = nil then begin Result := nil; exit; end; while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual, CSTII_in, CSTII_is] do begin Token := FParser.CurrTokenID; FParser.Next; F2 := ReadSimpleExpression; if f2 = nil then begin f1.Free; Result := nil; exit; end; case Token of CSTI_GreaterEqual: Op := otGreaterEqual; CSTI_LessEqual: Op := otLessEqual; CSTI_Greater: Op := otGreater; CSTI_Less: Op := otLess; CSTI_Equal: Op := otEqual; CSTI_NotEqual: Op := otNotEqual; CSTII_in: Op := otIn; CSTII_is: Op := otIs; else Op := otAdd; end; F := TPSBinValueOp.Create; f.Val1 := F1; f.Val2 := F2; f.Operator := Op; f.aType := GetResultType(F1, F2, Op); if f.aType = nil then begin MakeError('', ecTypeMismatch, ''); f.Free; Result := nil; exit; end; f1 := f; end; Result := F1; end; // ReadExpression function TryEvalConst(var P: TPSValue): Boolean; var preplace: TPSValue; begin if p is TPSBinValueOp then begin if not (TryEvalConst(TPSBinValueOp(p).FVal1) and TryEvalConst(TPSBinValueOp(p).FVal2)) then begin Result := False; exit; end; if (TPSBinValueOp(p).FVal1.ClassType = TPSValueData) and (TPSBinValueOp(p).FVal2.ClassType = TPSValueData) then begin if not PreCalc(True, 0, TPSValueData(TPSBinValueOp(p).Val1).Data, 0, TPSValueData(TPSBinValueOp(p).Val2).Data, TPSBinValueOp(p).Operator, p.Pos, p.Row, p.Col) then begin Result := False; exit; end; preplace := TPSValueData.Create; preplace.Pos := p.Pos; preplace.Row := p.Row; preplace.Col := p.Col; TPSValueData(preplace).Data := TPSValueData(TPSBinValueOp(p).Val1).Data; TPSValueData(TPSBinValueOp(p).Val1).Data := nil; p.Free; p := preplace; end; end else if p is TPSUnValueOp then begin if not TryEvalConst(TPSUnValueOp(p).FVal1) then begin Result := False; exit; end; if TPSUnValueOp(p).FVal1.ClassType = TPSValueData then begin // case TPSUnValueOp(p).Operator of otNot: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of btEnum: begin if IsBoolean(TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType) then begin TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := (not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8) and 1; end else begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; end; btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32; bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8; bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16; bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32; {$IFNDEF PS_NOINT64} bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := not TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; {$ENDIF} else begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; end; preplace := TPSUnValueOp(p).Val1; TPSUnValueOp(p).Val1 := nil; p.Free; p := preplace; end; otMinus: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data^.FType.BaseType of btU8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; btU16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; btU32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu32; bts8: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts8; bts16: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts16; bts32: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts32; {$IFNDEF PS_NOINT64} bts64: TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64 := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; {$ENDIF} btSingle: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tsingle; btDouble: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tdouble; btExtended: TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.textended; btCurrency: TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency := -TPSValueData(TPSUnValueOp(p).FVal1).Data^.tcurrency; else begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; end; preplace := TPSUnValueOp(p).Val1; TPSUnValueOp(p).Val1 := nil; p.Free; p := preplace; end; otCast: begin preplace := TPSValueData.Create; TPSValueData(preplace).Data := NewVariant(TPSUnValueOp(p).FType); case TPSUnValueOp(p).FType.BaseType of btU8: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of btchar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.tu8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} btU8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; btS8: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; btU16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; btS16: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; btU32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; btS32: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; {$IFNDEF PS_NOINT64} btS64: TPSValueData(preplace).Data.tu8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; {$ENDIF} else begin MakeError('', ecTypeMismatch, ''); preplace.Free; Result := False; exit; end; end; end; btS8: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of btchar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.ts8 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} btU8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; btS8: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; btU16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; btS16: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; btU32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; btS32: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; {$IFNDEF PS_NOINT64} btS64: TPSValueData(preplace).Data.ts8 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; {$ENDIF} else begin MakeError('', ecTypeMismatch, ''); preplace.Free; Result := False; exit; end; end; end; btU16: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of btchar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.tu16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} btU8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; btS8: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; btS16: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; btU32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; btS32: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; {$IFNDEF PS_NOINT64} btS64: TPSValueData(preplace).Data.tu16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; {$ENDIF} else begin MakeError('', ecTypeMismatch, ''); preplace.Free; Result := False; exit; end; end; end; bts16: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of btchar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.ts16 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} btU8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; btS8: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; btU16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; btS16: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; btU32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; btS32: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; {$IFNDEF PS_NOINT64} btS64: TPSValueData(preplace).Data.ts16 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; {$ENDIF} else begin MakeError('', ecTypeMismatch, ''); preplace.Free; Result := False; exit; end; end; end; btU32: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of btchar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.tu32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} btU8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; btS8: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; btU16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; btS16: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; btU32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; btS32: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; {$IFNDEF PS_NOINT64} btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; {$ENDIF} else begin MakeError('', ecTypeMismatch, ''); preplace.Free; Result := False; exit; end; end; end; btS32: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of btchar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.ts32 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} btU8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; btS8: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; btU16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; btS16: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; btU32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; btS32: TPSValueData(preplace).Data.ts32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; {$IFNDEF PS_NOINT64} btS64: TPSValueData(preplace).Data.tu32 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; {$ENDIF} else begin MakeError('', ecTypeMismatch, ''); preplace.Free; Result := False; exit; end; end; end; {$IFNDEF PS_NOINT64} btS64: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of btchar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar); {$IFNDEF PS_NOWIDESTRING} btwidechar: TPSValueData(preplace).Data.ts64 := ord(TPSValueData(TPSUnValueOp(p).FVal1).Data^.twidechar); {$ENDIF} btU8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8; btS8: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8; btU16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16; btS16: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16; btU32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32; btS32: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32; btS64: TPSValueData(preplace).Data.ts64 := TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64; else begin MakeError('', ecTypeMismatch, ''); preplace.Free; Result := False; exit; end; end; end; {$ENDIF} btChar: begin case TPSValueData(TPSUnValueOp(p).FVal1).Data.Ftype.basetype of btchar: TPSValueData(preplace).Data.tchar := TPSValueData(TPSUnValueOp(p).FVal1).Data^.tchar; btU8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu8); btS8: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS8); btU16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tu16); btS16: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS16); btU32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tU32); btS32: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.tS32); {$IFNDEF PS_NOINT64} btS64: TPSValueData(preplace).Data.tchar := tbtchar(TPSValueData(TPSUnValueOp(p).FVal1).Data^.ts64); {$ENDIF} else begin MakeError('', ecTypeMismatch, ''); Result := False; preplace.Free; exit; end; end; end; else begin MakeError('', ecTypeMismatch, ''); Result := False; preplace.Free; exit; end; end; p.Free; p := preplace; end; else begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; end; // case end; // if end; Result := True; end; var Temp, Val: TPSValue; vt: TPSVariableType; begin Val := ReadExpression; if Val = nil then begin Result := nil; exit; end; vt := ivtGlobal; repeat Temp := Val; if Val <> nil then CheckFurther(Val, False); if Val <> nil then CheckClass(Val, vt, InvalidVal, False); if Val <> nil then CheckExtClass(Val, vt, InvalidVal, False); {$IFNDEF PS_NOIDISPATCH}if Val <> nil then CheckIntf(Val, vt, InvalidVal, False);{$ENDIF} if Val <> nil then CheckProcCall(Val); if Val<> nil then CheckClassArrayProperty(Val, vt, InvalidVal); until (Val = nil) or (Temp = Val); if not TryEvalConst(Val) then begin Val.Free; Result := nil; exit; end; Result := Val; end; function ReadParameters(IsProperty: Boolean; Dest: TPSParameters): Boolean; var sr,cr: TPSPasToken; begin if IsProperty then begin sr := CSTI_OpenBlock; cr := CSTI_CloseBlock; end else begin sr := CSTI_OpenRound; cr := CSTI_CloseRound; end; if FParser.CurrTokenId = sr then begin FParser.Next; if FParser.CurrTokenId = cr then begin FParser.Next; Result := True; exit; end; end else begin result := True; exit; end; repeat with Dest.Add do begin Val := calc(CSTI_CloseRound); if Val = nil then begin result := false; exit; end; end; if FParser.CurrTokenId = cr then begin FParser.Next; Break; end; if FParser.CurrTokenId <> CSTI_Comma then begin MakeError('', ecCommaExpected, ''); Result := false; exit; end; {if} FParser.Next; until False; Result := true; end; function ReadProcParameters(ProcNo: Cardinal; FSelf: TPSValue): TPSValue; var Decl: TPSParametersDecl; begin if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then Decl := TPSInternalProcedure(FProcs[ProcNo]).Decl else Decl := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl; UseProc(Decl); Result := TPSValueProcNo.Create; TPSValueProcNo(Result).ProcNo := ProcNo; TPSValueProcNo(Result).ResultType := Decl.Result; with TPSValueProcNo(Result) do begin SetParserPos(FParser); Parameters := TPSParameters.Create; if FSelf <> nil then begin Parameters.Add; end; end; if not ReadParameters(False, TPSValueProc(Result).Parameters) then begin FSelf.Free; Result.Free; Result := nil; exit; end; if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then begin FSelf.Free; Result.Free; Result := nil; exit; end; if FSelf <> nil then begin with TPSValueProcNo(Result).Parameters[0] do begin Val := FSelf; ExpectedType := GetTypeNo(BlockInfo, FSelf); end; end; end; {$IFNDEF PS_NOIDISPATCH} function ReadIDispatchParameters(const ProcName: tbtString; aVariantType: TPSVariantType; FSelf: TPSValue): TPSValue; var Par: TPSParameters; PropSet: Boolean; i: Longint; Temp: TPSValue; begin Par := TPSParameters.Create; try if not ReadParameters(FParser.CurrTokenID = CSTI_OpenBlock, Par) then begin FSelf.Free; Result := nil; exit; end; if FParser.CurrTokenID = CSTI_Assignment then begin FParser.Next; PropSet := True; Temp := calc(CSTI_SemiColon); if temp = nil then begin FSelf.Free; Result := nil; exit; end; with par.Add do begin FValue := Temp; end; end else begin PropSet := False; end; Result := TPSValueProcNo.Create; TPSValueProcNo(Result).ResultType := aVariantType; with TPSValueProcNo(Result) do begin SetParserPos(FParser); Parameters := TPSParameters.Create; if FSelf <> nil then begin with Parameters.Add do begin Val := FSelf; ExpectedType := aVariantType.GetDynIvokeSelfType(Self); end; with Parameters.Add do begin Val := TPSValueData.Create; TPSValueData(Val).Data := NewVariant(FDefaultBoolType); TPSValueData(Val).Data.tu8 := Ord(PropSet); ExpectedType := FDefaultBoolType; end; with Parameters.Add do begin Val := TPSValueData.Create; TPSValueData(Val).Data := NewVariant(FindBaseType(btString)); tbtString(TPSValueData(Val).data.tString) := Procname; ExpectedType := FindBaseType(btString); end; with Parameters.Add do begin val := TPSValueArray.Create; ExpectedType := aVariantType.GetDynInvokeParamType(Self); temp := Val; end; for i := 0 to Par.Count -1 do begin TPSValueArray(Temp).Add(par.Item[i].Val); par.Item[i].val := nil; end; end; end; TPSValueProcNo(Result).ProcNo := aVariantType.GetDynInvokeProcNo(Self, ProcName, TPSValueProcNo(Result).Parameters); finally Par.Free; end; end; {$ENDIF} function ReadVarParameters(ProcNoVar: TPSValue): TPSValue; var Decl: TPSParametersDecl; begin Decl := TPSProceduralType(GetTypeNo(BlockInfo, ProcnoVar)).ProcDef; UseProc(Decl); Result := TPSValueProcVal.Create; with TPSValueProcVal(Result) do begin ResultType := Decl.Result; ProcNo := ProcNoVar; Parameters := TPSParameters.Create; end; if not ReadParameters(False, TPSValueProc(Result).Parameters) then begin Result.Free; Result := nil; exit; end; if not ValidateParameters(BlockInfo, TPSValueProc(Result).Parameters, Decl) then begin Result.Free; Result := nil; exit; end; end; function WriteCalculation(InData, OutReg: TPSValue): Boolean; function CheckOutreg(Where, Outreg: TPSValue; aRoot: Boolean): Boolean; var i: Longint; begin Result := False; if Outreg is TPSValueReplace then Outreg:=TPSValueReplace(Outreg).OldValue; if Where is TPSValueVar then begin if TPSValueVar(Where).GetRecCount > 0 then result := true; if SAmeReg(Where, OutReg) and not aRoot then result := true; end else if Where.ClassType = TPSUnValueOp then begin if CheckOutReg(TPSUnValueOp(Where).Val1, OutReg, aRoot) then Result := True; end else if Where.ClassType = TPSBinValueOp then begin if CheckOutreg(TPSBinValueOp(Where).Val1, OutReg, aRoot) or CheckOutreg(TPSBinValueOp(Where).Val2, OutReg, False) then Result := True; end else if Where is TPSValueVar then begin if SameReg(Where, OutReg) then Result := True; end else if Where is TPSValueProc then begin for i := 0 to TPSValueProc(Where).Parameters.Count -1 do begin if Checkoutreg(TPSValueProc(Where).Parameters[i].Val, Outreg, false) then begin Result := True; break; end; end; end; end; begin if not CheckCompatType(Outreg, InData) then begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; if SameReg(OutReg, InData) then begin Result := True; exit; end; if InData is TPSValueProc then begin Result := _ProcessFunction(TPSValueProc(indata), OutReg) end else begin if not PreWriteOutRec(OutReg, nil) then begin Result := False; exit; end; if (not CheckOutReg(InData, OutReg, true)) and (InData is TPSBinValueOp) or (InData is TPSUnValueOp) then begin if InData is TPSBinValueOp then begin if not DoBinCalc(TPSBinValueOp(InData), OutReg) then begin AfterWriteOutRec(OutReg); Result := False; exit; end; end else begin if not DoUnCalc(TPSUnValueOp(InData), OutReg) then begin AfterWriteOutRec(OutReg); Result := False; exit; end; end; end else if (InData is TPSBinValueOp) and (not CheckOutReg(TPSBinValueOp(InData).Val2, OutReg, false)) then begin if not DoBinCalc(TPSBinValueOp(InData), OutReg) then begin AfterWriteOutRec(OutReg); Result := False; exit; end; end else begin if not PreWriteOutRec(InData, GetTypeNo(BlockInfo, OutReg)) then begin Result := False; exit; end; BlockWriteByte(BlockInfo, CM_A); if not (WriteOutRec(OutReg, False) and WriteOutRec(InData, True)) then begin Result := False; exit; end; AfterWriteOutRec(InData); end; AfterWriteOutRec(OutReg); Result := True; end; end; {WriteCalculation} function _ProcessFunction(ProcCall: TPSValueProc; ResultRegister: TPSValue): Boolean; var res: TPSType; tmp: TPSParameter; lTv: TPSValue; resreg: TPSValue; l: Longint; function Cleanup: Boolean; var i: Longint; begin for i := 0 to ProcCall.Parameters.Count -1 do begin if ProcCall.Parameters[i].TempVar <> nil then ProcCall.Parameters[i].TempVar.Free; ProcCall.Parameters[i].TempVar := nil; end; if ProcCall is TPSValueProcVal then AfterWriteOutRec(TPSValueProcVal(ProcCall).fProcNo); if ResReg <> nil then AfterWriteOutRec(resreg); if ResReg <> nil then begin if ResReg <> ResultRegister then begin if ResultRegister <> nil then begin if not WriteCalculation(ResReg, ResultRegister) then begin Result := False; resreg.Free; exit; end; end; resreg.Free; end; end; Result := True; end; begin Res := ProcCall.ResultType; if ProcCall.ResultType = FAnyString then begin for l := ProcCall.Parameters.Count - 1 downto 0 do begin Tmp := ProcCall.Parameters[l]; if (Tmp.ParamMode <> pmOut) and (Tmp.ExpectedType = FAnyString) then begin Res := GetTypeNo(BlockInfo, tmp.Val); Break; end; end; end; Result := False; if (res = nil) and (ResultRegister <> nil) then begin MakeError('', ecNoResult, ''); exit; end else if (res <> nil) then begin if (ResultRegister = nil) or (Res <> GetTypeNo(BlockInfo, ResultRegister)) then begin resreg := AllocStackReg(res); end else resreg := ResultRegister; end else resreg := nil; if ResReg <> nil then begin if not PreWriteOutRec(resreg, nil) then begin Cleanup; exit; end; end; if Proccall is TPSValueProcVal then begin if not PreWriteOutRec(TPSValueProcVal(ProcCall).fProcNo, nil) then begin Cleanup; exit; end; end; for l := ProcCall.Parameters.Count - 1 downto 0 do begin Tmp := ProcCall.Parameters[l]; if (Tmp.ParamMode <> pmIn) then begin if IsVarInCompatible(GetTypeNo(BlockInfo, tmp.Val), tmp.ExpectedType) then begin with MakeError('', ecTypeMismatch, '') do begin pos := tmp.Val.Pos; row := tmp.Val.row; col := tmp.Val.col; end; Cleanup; exit; end; if Copy(tmp.ExpectedType.Name, 1, 10) = '!OPENARRAY' then begin tmp.TempVar := AllocPointer(tmp.ExpectedType); lTv := AllocStackReg(tmp.ExpectedType); if not PreWriteOutRec(Tmp.FValue, nil) then begin cleanup; exit; end; BlockWriteByte(BlockInfo, CM_A); WriteOutRec(lTv, False); WriteOutRec(Tmp.FValue, False); AfterWriteOutRec(Tmp.FValue); BlockWriteByte(BlockInfo, cm_sp); WriteOutRec(tmp.TempVar, False); WriteOutRec(lTv, False); lTv.Free; // BlockWriteByte(BlockInfo, CM_PO); // pop the temp var end else begin tmp.TempVar := AllocPointer(GetTypeNo(BlockInfo, Tmp.FValue)); if not PreWriteOutRec(Tmp.FValue, nil) then begin cleanup; exit; end; BlockWriteByte(BlockInfo, cm_sp); WriteOutRec(tmp.TempVar, False); WriteOutRec(Tmp.FValue, False); AfterWriteOutRec(Tmp.FValue); end; end else begin if (Tmp.ExpectedType = nil) or (Tmp.ExpectedType = FAnyString) then Tmp.ExpectedType := GetTypeNo(BlockInfo, tmp.Val); if Tmp.ExpectedType.BaseType = btPChar then begin Tmp.TempVar := AllocStackReg(at2ut(FindBaseType(btstring))) end else begin Tmp.TempVar := AllocStackReg(Tmp.ExpectedType); end; if not WriteCalculation(Tmp.Val, Tmp.TempVar) then begin Cleanup; exit; end; end; end; {for} if res <> nil then begin BlockWriteByte(BlockInfo, CM_PV); if not WriteOutRec(resreg, False) then begin Cleanup; MakeError('', ecInternalError, '00015'); exit; end; end; if ProcCall is TPSValueProcVal then begin BlockWriteByte(BlockInfo, Cm_cv); WriteOutRec(TPSValueProcVal(ProcCall).ProcNo, True); end else begin BlockWriteByte(BlockInfo, CM_C); BlockWriteLong(BlockInfo, TPSValueProcNo(ProcCall).ProcNo); end; if res <> nil then BlockWriteByte(BlockInfo, CM_PO); if not Cleanup then begin Result := False; exit; end; Result := True; end; {ProcessVarFunction} function HasInvalidJumps(StartPos, EndPos: Cardinal): Boolean; var I, J: Longint; Ok: LongBool; FLabelsInBlock: TIfStringList; s: tbtString; begin FLabelsInBlock := TIfStringList.Create; for i := 0 to BlockInfo.Proc.FLabels.Count -1 do begin s := BlockInfo.Proc.FLabels[I]; if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then begin Delete(s, 1, 8); FLabelsInBlock.Add(s); end; end; for i := 0 to BlockInfo.Proc.FGotos.Count -1 do begin s := BlockInfo.Proc.FGotos[I]; if (Cardinal((@s[1])^) >= StartPos) and (Cardinal((@s[1])^) <= EndPos) then begin Delete(s, 1, 4); s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)]; Delete(s,1,8); OK := False; for J := 0 to FLabelsInBlock.Count -1 do begin if FLabelsInBlock[J] = s then begin Ok := True; Break; end; end; if not Ok then begin MakeError('', ecInvalidJump, ''); Result := True; FLabelsInBlock.Free; exit; end; end else begin Delete(s, 1, 4); s := BlockInfo.Proc.FLabels[Cardinal((@s[1])^)]; Delete(s,1,8); OK := True; for J := 0 to FLabelsInBlock.Count -1 do begin if FLabelsInBlock[J] = s then begin Ok := False; Break; end; end; if not Ok then begin MakeError('', ecInvalidJump, ''); Result := True; FLabelsInBlock.Free; exit; end; end; end; FLabelsInBlock.Free; Result := False; end; function ProcessFor: Boolean; { Process a for x := y to z do } var VariableVar: TPSValue; TempBool, InitVal, finVal: TPSValue; Block: TPSBlockInfo; Backwards: Boolean; FPos, NPos, EPos, RPos: Longint; OldCO, OldBO: TPSList; I: Longint; iOldWithCount: Integer; iOldTryCount: Integer; iOldExFnlCount: Integer; lType: TPSType; begin Debug_WriteLine(BlockInfo); Result := False; FParser.Next; if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); exit; end; VariableVar := GetIdentifier(1); if VariableVar = nil then exit; lType := GetTypeNo(BlockInfo, VariableVar); if lType = nil then begin MakeError('', ecTypeMismatch, ''); VariableVar.Free; exit; end; case lType.BaseType of btU8, btS8, btU16, btS16, btU32, btS32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btVariant: ; else begin MakeError('', ecTypeMismatch, ''); VariableVar.Free; exit; end; end; if FParser.CurrTokenId <> CSTI_Assignment then begin MakeError('', ecAssignmentExpected, ''); VariableVar.Free; exit; end; FParser.Next; InitVal := calc(CSTII_DownTo); if InitVal = nil then begin VariableVar.Free; exit; end; if FParser.CurrTokenId = CSTII_To then Backwards := False else if FParser.CurrTokenId = CSTII_DownTo then Backwards := True else begin MakeError('', ecToExpected, ''); VariableVar.Free; InitVal.Free; exit; end; FParser.Next; finVal := calc(CSTII_do); if finVal = nil then begin VariableVar.Free; InitVal.Free; exit; end; lType := GetTypeNo(BlockInfo, finVal); if lType = nil then begin MakeError('', ecTypeMismatch, ''); VariableVar.Free; InitVal.Free; exit; end; case lType.BaseType of btVariant, btU8, btS8, btU16, btS16, btU32, {$IFNDEF PS_NOINT64} btS64, {$ENDIF} btS32: ; else begin MakeError('', ecTypeMismatch, ''); VariableVar.Free; InitVal.Free; exit; end; end; if FParser.CurrTokenId <> CSTII_do then begin MakeError('', ecDoExpected, ''); finVal.Free; InitVal.Free; VariableVar.Free; exit; end; FParser.Next; if not WriteCalculation(InitVal, VariableVar) then begin VariableVar.Free; InitVal.Free; finVal.Free; exit; end; InitVal.Free; TempBool := AllocStackReg(at2ut(FDefaultBoolType)); NPos := Length(BlockInfo.Proc.Data); if not (PreWriteOutRec(VariableVar, nil) and PreWriteOutRec(finVal, nil)) then begin TempBool.Free; VariableVar.Free; finVal.Free; exit; end; BlockWriteByte(BlockInfo, CM_CO); if Backwards then begin BlockWriteByte(BlockInfo, 0); { >= } end else begin BlockWriteByte(BlockInfo, 1); { <= } end; if not (WriteOutRec(TempBool, False) and WriteOutRec(VariableVar, True) and WriteOutRec(finVal, True)) then begin TempBool.Free; VariableVar.Free; finVal.Free; exit; end; AfterWriteOutRec(finVal); AfterWriteOutRec(VariableVar); finVal.Free; BlockWriteByte(BlockInfo, Cm_CNG); EPos := Length(BlockInfo.Proc.Data); BlockWriteLong(BlockInfo, $12345678); WriteOutRec(TempBool, False); RPos := Length(BlockInfo.Proc.Data); OldCO := FContinueOffsets; FContinueOffsets := TPSList.Create; OldBO := FBreakOffsets; FBreakOffsets := TPSList.Create; Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tOneLiner; iOldWithCount := FWithCount; FWithCount := 0; iOldTryCount := FTryCount; FTryCount := 0; iOldExFnlCount := FExceptFinallyCount; FExceptFinallyCount := 0; if not ProcessSub(Block) then begin Block.Free; TempBool.Free; VariableVar.Free; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; exit; end; Block.Free; FPos := Length(BlockInfo.Proc.Data); if not PreWriteOutRec(VariableVar, nil) then begin TempBool.Free; VariableVar.Free; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; exit; end; if Backwards then BlockWriteByte(BlockInfo, cm_dec) else BlockWriteByte(BlockInfo, cm_inc); if not WriteOutRec(VariableVar, False) then begin TempBool.Free; VariableVar.Free; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; exit; end; AfterWriteOutRec(VariableVar); BlockWriteByte(BlockInfo, Cm_G); BlockWriteLong(BlockInfo, Longint(NPos - Length(BlockInfo.Proc.Data) - 4)); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos + 1])^)) := Length(BlockInfo.Proc.Data) - RPos; {$else} Longint((@BlockInfo.Proc.Data[EPos + 1])^) := Length(BlockInfo.Proc.Data) - RPos; {$endif} for i := 0 to FBreakOffsets.Count -1 do begin EPos := IPointer(FBreakOffsets[I]); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos); {$else} Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos); {$endif} end; for i := 0 to FContinueOffsets.Count -1 do begin EPos := IPointer(FContinueOffsets[I]); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(FPos) - Longint(EPos); {$else} Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(FPos) - Longint(EPos); {$endif} end; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; TempBool.Free; VariableVar.Free; if HasInvalidJumps(RPos, Length(BlockInfo.Proc.Data)) then begin Result := False; exit; end; Result := True; end; {ProcessFor} function ProcessWhile: Boolean; var vin, vout: TPSValue; SPos, EPos: Cardinal; OldCo, OldBO: TPSList; I: Longint; Block: TPSBlockInfo; iOldWithCount: Integer; iOldTryCount: Integer; iOldExFnlCount: Integer; begin Result := False; Debug_WriteLine(BlockInfo); FParser.Next; vout := calc(CSTII_do); if vout = nil then exit; if FParser.CurrTokenId <> CSTII_do then begin vout.Free; MakeError('', ecDoExpected, ''); exit; end; vin := AllocStackReg(at2ut(FDefaultBoolType)); SPos := Length(BlockInfo.Proc.Data); // start position OldCo := FContinueOffsets; FContinueOffsets := TPSList.Create; OldBO := FBreakOffsets; FBreakOffsets := TPSList.Create; if not WriteCalculation(vout, vin) then begin vout.Free; vin.Free; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; exit; end; vout.Free; FParser.Next; // skip DO BlockWriteByte(BlockInfo, Cm_CNG); // only goto if expression is false BlockWriteLong(BlockInfo, $12345678); EPos := Length(BlockInfo.Proc.Data); if not WriteOutRec(vin, False) then begin MakeError('', ecInternalError, '00017'); vin.Free; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; exit; end; Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tOneLiner; iOldWithCount := FWithCount; FWithCount := 0; iOldTryCount := FTryCount; FTryCount := 0; iOldExFnlCount := FExceptFinallyCount; FExceptFinallyCount := 0; if not ProcessSub(Block) then begin Block.Free; vin.Free; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; exit; end; Block.Free; Debug_WriteLine(BlockInfo); BlockWriteByte(BlockInfo, Cm_G); BlockWriteLong(BlockInfo, Longint(SPos) - Length(BlockInfo.Proc.Data) - 4); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5; {$else} Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos) - 5; {$endif} for i := 0 to FBreakOffsets.Count -1 do begin EPos := Cardinal(FBreakOffsets[I]); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos); {$else} Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos); {$endif} end; for i := 0 to FContinueOffsets.Count -1 do begin EPos := Cardinal(FContinueOffsets[I]); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) - Longint(EPos); {$else} Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Longint(EPos); {$endif} end; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; vin.Free; if HasInvalidJumps(EPos, Length(BlockInfo.Proc.Data)) then begin Result := False; exit; end; Result := True; end; function ProcessRepeat: Boolean; var vin, vout: TPSValue; CPos, SPos, EPos: Cardinal; I: Longint; OldCo, OldBO: TPSList; Block: TPSBlockInfo; iOldWithCount: Integer; iOldTryCount: Integer; iOldExFnlCount: Integer; begin Result := False; Debug_WriteLine(BlockInfo); FParser.Next; OldCo := FContinueOffsets; FContinueOffsets := TPSList.Create; OldBO := FBreakOffsets; FBreakOffsets := TPSList.Create; vin := AllocStackReg(at2ut(FDefaultBoolType)); SPos := Length(BlockInfo.Proc.Data); Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tRepeat; iOldWithCount := FWithCount; FWithCount := 0; iOldTryCount := FTryCount; FTryCount := 0; iOldExFnlCount := FExceptFinallyCount; FExceptFinallyCount := 0; if not ProcessSub(Block) then begin Block.Free; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; vin.Free; exit; end; Block.Free; FParser.Next; //cstii_until vout := calc(CSTI_Semicolon); if vout = nil then begin FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; vin.Free; exit; end; CPos := Length(BlockInfo.Proc.Data); if not WriteCalculation(vout, vin) then begin vout.Free; vin.Free; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; exit; end; vout.Free; BlockWriteByte(BlockInfo, Cm_CNG); BlockWriteLong(BlockInfo, $12345678); EPos := Length(BlockInfo. Proc.Data); if not WriteOutRec(vin, False) then begin MakeError('', ecInternalError, '00016'); vin.Free; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; exit; end; {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(SPos) - Length(BlockInfo.Proc.Data); {$else} Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(SPos) - Length(BlockInfo.Proc.Data); {$endif} for i := 0 to FBreakOffsets.Count -1 do begin EPos := Cardinal(FBreakOffsets[I]); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo. Proc.Data) - Longint(EPos); {$else} Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo. Proc.Data) - Longint(EPos); {$endif} end; for i := 0 to FContinueOffsets.Count -1 do begin EPos := Cardinal(FContinueOffsets[I]); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Longint(CPos) - Longint(EPos); {$else} Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Longint(CPos) - Longint(EPos); {$endif} end; FBreakOffsets.Free; FContinueOffsets.Free; FContinueOffsets := OldCO; FBreakOffsets := OldBo; FWithCount := iOldWithCount; FTryCount := iOldTryCount; FExceptFinallyCount := iOldExFnlCount; vin.Free; if HasInvalidJumps(SPos, Length(BlockInfo. Proc.Data)) then begin Result := False; exit; end; Result := True; end; {ProcessRepeat} function ProcessIf: Boolean; var vout, vin: TPSValue; SPos, EPos: Cardinal; Block: TPSBlockInfo; begin Result := False; Debug_WriteLine(BlockInfo); FParser.Next; vout := calc(CSTII_Then); if vout = nil then exit; if FParser.CurrTokenId <> CSTII_Then then begin vout.Free; MakeError('', ecThenExpected, ''); exit; end; vin := AllocStackReg(at2ut(FDefaultBoolType)); if not WriteCalculation(vout, vin) then begin vout.Free; vin.Free; exit; end; vout.Free; BlockWriteByte(BlockInfo, cm_sf); if not WriteOutRec(vin, False) then begin MakeError('', ecInternalError, '00018'); vin.Free; exit; end; BlockWriteByte(BlockInfo, 1); vin.Free; BlockWriteByte(BlockInfo, cm_fg); BlockWriteLong(BlockInfo, $12345678); SPos := Length(BlockInfo.Proc.Data); FParser.Next; // skip then Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tifOneliner; if not ProcessSub(Block) then begin Block.Free; exit; end; Block.Free; if FParser.CurrTokenId = CSTII_Else then begin BlockWriteByte(BlockInfo, Cm_G); BlockWriteLong(BlockInfo, $12345678); EPos := Length(BlockInfo.Proc.Data); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos); {$else} Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos); {$endif} FParser.Next; Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tOneLiner; if not ProcessSub(Block) then begin Block.Free; exit; end; Block.Free; {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[EPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(EPos); {$else} Longint((@BlockInfo.Proc.Data[EPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(EPos); {$endif} end else begin {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Longint((@BlockInfo.Proc.Data[SPos - 3])^)) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5; {$else} Longint((@BlockInfo.Proc.Data[SPos - 3])^) := Length(BlockInfo.Proc.Data) - Longint(SPos) + 5 - 5; {$endif} end; Result := True; end; {ProcessIf} function _ProcessLabel: Longint; {0 = failed; 1 = successful; 2 = no label} var I, H: Longint; s: tbtString; begin h := MakeHash(FParser.GetToken); for i := 0 to BlockInfo.Proc.FLabels.Count -1 do begin s := BlockInfo.Proc.FLabels[I]; delete(s, 1, 4); if Longint((@s[1])^) = h then begin delete(s, 1, 4); if s = FParser.GetToken then begin s := BlockInfo.Proc.FLabels[I]; Cardinal((@s[1])^) := Length(BlockInfo.Proc.Data); BlockInfo.Proc.FLabels[i] := s; FParser.Next; if fParser.CurrTokenId = CSTI_Colon then begin Result := 1; FParser.Next; exit; end else begin MakeError('', ecColonExpected, ''); Result := 0; Exit; end; end; end; end; result := 2; end; function ProcessIdentifier: Boolean; var vin, vout: TPSValue; begin Result := False; Debug_WriteLine(BlockInfo); vin := Calc(CSTI_Assignment);//GetIdentifier(2); if vin <> nil then begin if vin is TPSValueVar then begin // assignment needed if FParser.CurrTokenId <> CSTI_Assignment then begin MakeError('', ecAssignmentExpected, ''); vin.Free; exit; end; FParser.Next; vout := calc(CSTI_Semicolon); if vout = nil then begin vin.Free; exit; end; if not WriteCalculation(vout, vin) then begin vin.Free; vout.Free; exit; end; vin.Free; vout.Free; end else if vin is TPSValueProc then begin Result := _ProcessFunction(TPSValueProc(vin), nil); vin.Free; Exit; end else begin MakeError('', ecInternalError, '20'); vin.Free; REsult := False; exit; end; end else begin Result := False; exit; end; Result := True; end; {ProcessIdentifier} function ProcessCase: Boolean; var V1, V2, TempRec, Val, CalcItem: TPSValue; p: TPSBinValueOp; SPos, CurrP: Cardinal; I: Longint; EndReloc: TPSList; Block: TPSBlockInfo; function NewRec(val: TPSValue): TPSValueReplace; begin Result := TPSValueReplace.Create; Result.SetParserPos(FParser); Result.FNewValue := Val; Result.FreeNewValue := False; end; function Combine(v1, v2: TPSValue; Op: TPSBinOperatorType): TPSValue; begin if V1 = nil then begin Result := v2; end else if v2 = nil then begin Result := V1; end else begin Result := TPSBinValueOp.Create; TPSBinValueOp(Result).FType := FDefaultBoolType; TPSBinValueOp(Result).Operator := Op; Result.SetParserPos(FParser); TPSBinValueOp(Result).FVal1 := V1; TPSBinValueOp(Result).FVal2 := V2; end; end; begin Debug_WriteLine(BlockInfo); FParser.Next; Val := calc(CSTII_of); if Val = nil then begin ProcessCase := False; exit; end; {if} if FParser.CurrTokenId <> CSTII_Of then begin MakeError('', ecOfExpected, ''); val.Free; ProcessCase := False; exit; end; {if} FParser.Next; TempRec := AllocStackReg(GetTypeNo(BlockInfo, Val)); if not WriteCalculation(Val, TempRec) then begin TempRec.Free; val.Free; ProcessCase := False; exit; end; {if} val.Free; EndReloc := TPSList.Create; CalcItem := AllocStackReg(at2ut(FDefaultBoolType)); SPos := Length(BlockInfo.Proc.Data); repeat V1 := nil; while true do begin Val := calc(CSTI_Colon); if (Val = nil) then begin V1.Free; CalcItem.Free; TempRec.Free; EndReloc.Free; ProcessCase := False; exit; end; {if} if fParser.CurrTokenID = CSTI_TwoDots then begin FParser.Next; V2 := Calc(CSTI_colon); if V2 = nil then begin V1.Free; CalcItem.Free; TempRec.Free; EndReloc.Free; ProcessCase := False; Val.Free; exit; end; p := TPSBinValueOp.Create; p.SetParserPos(FParser); p.Operator := otGreaterEqual; p.aType := at2ut(FDefaultBoolType); p.Val2 := Val; p.Val1 := NewRec(TempRec); Val := p; p := TPSBinValueOp.Create; p.SetParserPos(FParser); p.Operator := otLessEqual; p.aType := at2ut(FDefaultBoolType); p.Val2 := V2; p.Val1 := NewRec(TempRec); P := TPSBinValueOp(Combine(Val,P, otAnd)); end else begin p := TPSBinValueOp.Create; p.SetParserPos(FParser); p.Operator := otEqual; p.aType := at2ut(FDefaultBoolType); p.Val1 := Val; p.Val2 := NewRec(TempRec); end; V1 := Combine(V1, P, otOr); if FParser.CurrTokenId = CSTI_Colon then Break; if FParser.CurrTokenID <> CSTI_Comma then begin MakeError('', ecColonExpected, ''); V1.Free; CalcItem.Free; TempRec.Free; EndReloc.Free; ProcessCase := False; exit; end; FParser.Next; end; FParser.Next; if not WriteCalculation(V1, CalcItem) then begin CalcItem.Free; v1.Free; EndReloc.Free; ProcessCase := False; exit; end; v1.Free; BlockWriteByte(BlockInfo, Cm_CNG); BlockWriteLong(BlockInfo, $12345678); CurrP := Length(BlockInfo.Proc.Data); WriteOutRec(CalcItem, False); Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tifOneliner; if not ProcessSub(Block) then begin Block.Free; CalcItem.Free; TempRec.Free; EndReloc.Free; ProcessCase := False; exit; end; Block.Free; BlockWriteByte(BlockInfo, Cm_G); BlockWriteLong(BlockInfo, $12345678); EndReloc.Add(Pointer(Length(BlockInfo.Proc.Data))); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5; {$else} Cardinal((@BlockInfo.Proc.Data[CurrP - 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - CurrP - 5; {$endif} if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next; if FParser.CurrTokenID = CSTII_Else then begin FParser.Next; Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tOneliner; if not ProcessSub(Block) then begin Block.Free; CalcItem.Free; TempRec.Free; EndReloc.Free; ProcessCase := False; exit; end; Block.Free; if FParser.CurrTokenID = CSTI_Semicolon then FParser.Next; if FParser.CurrtokenId <> CSTII_End then begin MakeError('', ecEndExpected, ''); CalcItem.Free; TempRec.Free; EndReloc.Free; ProcessCase := False; exit; end; end; until FParser.CurrTokenID = CSTII_End; FParser.Next; for i := 0 to EndReloc.Count -1 do begin {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^)) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]); {$else} Cardinal((@BlockInfo.Proc.Data[Cardinal(EndReloc[I])- 3])^) := Cardinal(Length(BlockInfo.Proc.Data)) - Cardinal(EndReloc[I]); {$endif} end; CalcItem.Free; TempRec.Free; EndReloc.Free; if FContinueOffsets <> nil then begin for i := 0 to FContinueOffsets.Count -1 do begin if Cardinal(FContinueOffsets[i]) >= SPos then begin {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^)) := Cm_P2G; {$else} Byte((@BlockInfo.Proc.Data[Longint(FContinueOffsets[i]) - 4])^) := Cm_P2G; {$endif} end; end; end; if FBreakOffsets <> nil then begin for i := 0 to FBreakOffsets.Count -1 do begin if Cardinal(FBreakOffsets[i]) >= SPos then begin {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} unaligned(Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^)) := Cm_P2G; {$else} Byte((@BlockInfo.Proc.Data[Longint(FBreakOffsets[i]) - 4])^) := Cm_P2G; {$endif} end; end; end; if HasInvalidJumps(SPos, Length(BlockInfo.Proc.Data)) then begin Result := False; exit; end; Result := True; end; {ProcessCase} function ProcessGoto: Boolean; var I, H: Longint; s: tbtString; begin Debug_WriteLine(BlockInfo); FParser.Next; h := MakeHash(FParser.GetToken); for i := 0 to BlockInfo.Proc.FLabels.Count -1 do begin s := BlockInfo.Proc.FLabels[I]; delete(s, 1, 4); if Longint((@s[1])^) = h then begin delete(s, 1, 4); if s = FParser.GetToken then begin FParser.Next; BlockWriteByte(BlockInfo, Cm_G); BlockWriteLong(BlockInfo, $12345678); BlockInfo.Proc.FGotos.Add(PS_mi2s(length(BlockInfo.Proc.Data))+PS_mi2s(i)); Result := True; exit; end; end; end; MakeError('', ecUnknownIdentifier, FParser.OriginalToken); Result := False; end; {ProcessGoto} function ProcessWith: Boolean; var Block: TPSBlockInfo; aVar, aReplace: TPSValue; aType: TPSType; iStartOffset: Integer; tmp: TPSValue; begin Debug_WriteLine(BlockInfo); Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tOneLiner; FParser.Next; repeat aVar := GetIdentifier(0); if aVar = nil then begin block.Free; Result := False; exit; end; AType := GetTypeNo(BlockInfo, aVar); if (AType = nil) or ((aType.BaseType <> btRecord) and (aType.BaseType <> btClass)) then begin MakeError('', ecClassTypeExpected, ''); Block.Free; Result := False; exit; end; aReplace := TPSValueReplace.Create; aReplace.SetParserPos(FParser); TPSValueReplace(aReplace).FreeOldValue := True; TPSValueReplace(aReplace).FreeNewValue := True; TPSValueReplace(aReplace).OldValue := aVar; //if aVar.InheritsFrom(TPSVar) then TPSVar(aVar).Use; tmp := AllocPointer(GetTypeNo(BlockInfo, aVar)); TPSProcVar(BlockInfo.Proc.ProcVars[TPSValueAllocatedStackVar(tmp).LocalVarNo]).Use; PreWriteOutRec(tmp,GetTypeNo(BlockInfo, tmp)); PreWriteOutRec(aVar,GetTypeNo(BlockInfo, aVar)); BlockWriteByte(BlockInfo, cm_sp); WriteOutRec(tmp, false); WriteOutRec(aVar, false); TPSValueReplace(aReplace).NewValue := tmp; Block.WithList.Add(aReplace); if FParser.CurrTokenID = CSTII_do then begin FParser.Next; Break; end else if FParser.CurrTokenId <> CSTI_Comma then begin MakeError('', ecDoExpected, ''); Block.Free; Result := False; exit; end; FParser.Next; until False; inc(FWithCount); iStartOffset := Length(Block.Proc.Data); if not (ProcessSub(Block) and (not HasInvalidJumps(iStartOffset,Length(BlockInfo.Proc.Data) + 1)) ) then begin dec(FWithCount); Block.Free; Result := False; exit; end; dec(FWithCount); AfterWriteOutRec(aVar); AfterWriteOutRec(tmp); Block.Free; Result := True; end; function ProcessTry: Boolean; var FStartOffset: Cardinal; iBlockStartOffset: Integer; Block: TPSBlockInfo; begin FParser.Next; BlockWriteByte(BlockInfo, cm_puexh); FStartOffset := Length(BlockInfo.Proc.Data) + 1; BlockWriteLong(BlockInfo, InvalidVal); BlockWriteLong(BlockInfo, InvalidVal); BlockWriteLong(BlockInfo, InvalidVal); BlockWriteLong(BlockInfo, InvalidVal); Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tTry; inc(FTryCount); if ProcessSub(Block) and (not HasInvalidJumps(FStartOffset,Length(BlockInfo.Proc.Data) + 1)) then begin dec(FTryCount); Block.Free; BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 0); if FParser.CurrTokenID = CSTII_Except then begin FParser.Next; Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; iBlockStartOffset := Length(BlockInfo.Proc.Data) ; Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tTryEnd; inc(FExceptFinallyCount); if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then begin dec(FExceptFinallyCount); Block.Free; BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 2); if FParser.CurrTokenId = CSTII_Finally then begin Cardinal((@BlockInfo.Proc.Data[FStartOffset + 8])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; iBlockStartOffset := Length(BlockInfo.Proc.Data) ; Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tTryEnd; FParser.Next; inc(FExceptFinallyCount); if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then begin dec(FExceptFinallyCount); Block.Free; if FParser.CurrTokenId = CSTII_End then begin BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 3); end else begin MakeError('', ecEndExpected, ''); Result := False; exit; end; end else begin Block.Free; Result := False; dec(FExceptFinallyCount); exit; end; end else if FParser.CurrTokenID <> CSTII_End then begin MakeError('', ecEndExpected, ''); Result := False; exit; end; FParser.Next; end else begin Block.Free; Result := False; dec(FExceptFinallyCount); exit; end; end else if FParser.CurrTokenId = CSTII_Finally then begin FParser.Next; Cardinal((@BlockInfo.Proc.Data[FStartOffset])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; iBlockStartOffset := Length(BlockInfo.Proc.Data) ; Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tTryEnd; inc(FExceptFinallyCount); if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then begin dec(FExceptFinallyCount); Block.Free; BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 1); if FParser.CurrTokenId = CSTII_Except then begin Cardinal((@BlockInfo.Proc.Data[FStartOffset + 4])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; iBlockStartOffset := Length(BlockInfo.Proc.Data) ; FParser.Next; Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tTryEnd; inc(FExceptFinallyCount); if ProcessSub(Block) and (not HasInvalidJumps(iBlockStartOffset,Length(BlockInfo.Proc.Data) + 1)) then begin dec(FExceptFinallyCount); Block.Free; if FParser.CurrTokenId = CSTII_End then begin BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 2); end else begin MakeError('', ecEndExpected, ''); Result := False; exit; end; end else begin Block.Free; Result := False; dec(FExceptFinallyCount); exit; end; end else if FParser.CurrTokenID <> CSTII_End then begin MakeError('', ecEndExpected, ''); Result := False; exit; end; FParser.Next; end else begin Block.Free; Result := False; dec(FExceptFinallyCount); exit; end; end; end else begin Block.Free; Result := False; dec(FTryCount); exit; end; Cardinal((@BlockInfo.Proc.Data[FStartOffset + 12])^) := Cardinal(Length(BlockInfo.Proc.Data)) - FStartOffset - 15; Result := True; end; {ProcessTry} var i: Integer; Block: TPSBlockInfo; begin ProcessSub := False; if (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType= tMainBegin) or {$IFDEF PS_USESSUPPORT} (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType= tUnitFinish) or // NvdS {$endif} (BlockInfo.SubType= tSubBegin) then begin FParser.Next; // skip CSTII_Begin end; while True do begin case FParser.CurrTokenId of CSTII_Goto: begin if not ProcessGoto then Exit; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTII_With: begin if not ProcessWith then Exit; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTII_Try: begin if not ProcessTry then Exit; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTII_Finally, CSTII_Except: begin if (BlockInfo.SubType = tTry) or (BlockInfo.SubType = tTryEnd) then Break else begin MakeError('', ecEndExpected, ''); Exit; end; end; CSTII_Begin: begin Block := TPSBlockInfo.Create(BlockInfo); Block.SubType := tSubBegin; if not ProcessSub(Block) then begin Block.Free; Exit; end; Block.Free; FParser.Next; // skip END if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTI_Semicolon: begin if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break else FParser.Next; end; CSTII_until: begin Debug_WriteLine(BlockInfo); if BlockInfo.SubType = tRepeat then begin break; end else begin MakeError('', ecIdentifierExpected, ''); exit; end; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTII_Else: begin if BlockInfo.SubType = tifOneliner then break else begin MakeError('', ecIdentifierExpected, ''); exit; end; end; CSTII_repeat: begin if not ProcessRepeat then exit; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTII_For: begin if not ProcessFor then exit; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTII_While: begin if not ProcessWhile then exit; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTII_Exit: begin Debug_WriteLine(BlockInfo); BlockWriteByte(BlockInfo, Cm_R); FParser.Next; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTII_Case: begin if not ProcessCase then exit; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTII_If: begin if not ProcessIf then exit; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; CSTI_OpenRound, CSTI_Identifier: begin case _ProcessLabel of 0: Exit; 1: ; else begin if FParser.GetToken = 'BREAK' then begin if FBreakOffsets = nil then begin MakeError('', ecNotInLoop, ''); exit; end; for i := 0 to FExceptFinallyCount - 1 do begin BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 1); end; for i := 0 to FTryCount - 1 do begin BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 0); BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 1); end; for i := 0 to FWithCount - 1 do BlockWriteByte(BlockInfo,cm_po); BlockWriteByte(BlockInfo, Cm_G); BlockWriteLong(BlockInfo, $12345678); FBreakOffsets.Add(Pointer(Length(BlockInfo.Proc.Data))); FParser.Next; if (BlockInfo.SubType= tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end else if FParser.GetToken = 'CONTINUE' then begin if FBreakOffsets = nil then begin MakeError('', ecNotInLoop, ''); exit; end; for i := 0 to FExceptFinallyCount - 1 do begin BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 1); end; for i := 0 to FTryCount - 1 do begin BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 0); BlockWriteByte(BlockInfo, cm_poexh); BlockWriteByte(BlockInfo, 1); end; for i := 0 to FWithCount - 1 do BlockWriteByte(BlockInfo,cm_po); BlockWriteByte(BlockInfo, Cm_G); BlockWriteLong(BlockInfo, $12345678); FContinueOffsets.Add(Pointer(Length(BlockInfo.Proc.Data))); FParser.Next; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end else if not ProcessIdentifier then exit; if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; end; {case} if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then break; end; {$IFDEF PS_USESSUPPORT} CSTII_Finalization: //NvdS begin // if (BlockInfo.SubType = tUnitInit) then // begin // break; // end // else // begin // MakeError('', ecIdentifierExpected, ''); // exit; // end; // end; //nvds {$endif} CSTII_End: begin if (BlockInfo.SubType = tTryEnd) or (BlockInfo.SubType = tMainBegin) or (BlockInfo.SubType = tSubBegin) or (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = tProcBegin) or (BlockInfo.SubType = TOneLiner) {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds begin break; end else begin MakeError('', ecIdentifierExpected, ''); exit; end; end; CSTI_EOF: begin MakeError('', ecUnexpectedEndOfFile, ''); exit; end; else begin MakeError('', ecIdentifierExpected, ''); exit; end; end; end; if (BlockInfo.SubType = tMainBegin) or (BlockInfo.SubType = tProcBegin) {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish) {$endif} then //nvds begin Debug_WriteLine(BlockInfo); BlockWriteByte(BlockInfo, Cm_R); {$IFDEF PS_USESSUPPORT} if FParser.CurrTokenId = CSTII_End then //nvds begin {$endif} FParser.Next; // skip end if ((BlockInfo.SubType = tMainBegin) {$IFDEF PS_USESSUPPORT} or (BlockInfo.SubType = tUnitInit) or (BlockInfo.SubType = tUnitFinish){$endif}) //nvds and (FParser.CurrTokenId <> CSTI_Period) then begin MakeError('', ecPeriodExpected, ''); exit; end; if (BlockInfo.SubType = tProcBegin) and (FParser.CurrTokenId <> CSTI_Semicolon) then begin MakeError('', ecSemicolonExpected, ''); exit; end; FParser.Next; {$IFDEF PS_USESSUPPORT} end; //nvds {$endif} end else if (BlockInfo.SubType = tifOneliner) or (BlockInfo.SubType = TOneLiner) then begin if (FParser.CurrTokenID <> CSTII_Else) and (FParser.CurrTokenID <> CSTII_End) then if FParser.CurrTokenID <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); exit; end; end; ProcessSub := True; end; procedure TPSPascalCompiler.UseProc(procdecl: TPSParametersDecl); var i: Longint; begin if procdecl.Result <> nil then procdecl.Result := at2ut(procdecl.Result); for i := 0 to procdecl.ParamCount -1 do begin procdecl.Params[i].aType := at2ut(procdecl.Params[i].aType); end; end; function TPSPascalCompiler.at2ut(p: TPSType): TPSType; var i: Longint; begin p := GetTypeCopyLink(p); if p = nil then begin Result := nil; exit; end; if not p.Used then begin p.Use; case p.BaseType of btStaticArray, btArray: TPSArrayType(p).ArrayTypeNo := at2ut(TPSArrayType(p).ArrayTypeNo); btRecord: begin for i := 0 to TPSRecordType(p).RecValCount -1 do begin TPSRecordType(p).RecVal(i).aType := at2ut(TPSRecordType(p).RecVal(i).aType); end; end; btSet: TPSSetType(p).SetType := at2ut(TPSSetType(p).SetType); btProcPtr: begin UseProc(TPSProceduralType(p).ProcDef); end; end; p.FFinalTypeNo := FCurrUsedTypeNo; inc(FCurrUsedTypeNo); end; Result := p; end; function TPSPascalCompiler.ProcessLabelForwards(Proc: TPSInternalProcedure): Boolean; var i: Longint; s, s2: tbtString; begin for i := 0 to Proc.FLabels.Count -1 do begin s := Proc.FLabels[I]; if Longint((@s[1])^) = -1 then begin delete(s, 1, 8); MakeError('', ecUnSetLabel, s); Result := False; exit; end; end; for i := Proc.FGotos.Count -1 downto 0 do begin s := Proc.FGotos[I]; s2 := Proc.FLabels[Cardinal((@s[5])^)]; Cardinal((@Proc.Data[Cardinal((@s[1])^)-3])^) := Cardinal((@s2[1])^) - Cardinal((@s[1])^) ; end; Result := True; end; type TCompilerState = (csStart, csProgram, csUnit, csUses, csInterface, csInterfaceUses, csImplementation); function TPSPascalCompiler.Compile(const s: tbtString): Boolean; var Position: TCompilerState; i: Longint; {$IFDEF PS_USESSUPPORT} OldFileName: tbtString; OldParser : TPSPascalParser; OldIsUnit : Boolean; OldUnit : TPSUnit; {$ENDIF} procedure Cleanup; var I: Longint; PT: TPSType; begin {$IFDEF PS_USESSUPPORT} if fInCompile>1 then begin dec(fInCompile); exit; end; {$ENDIF} if @FOnBeforeCleanup <> nil then FOnBeforeCleanup(Self); // no reason it actually read the result of this call FGlobalBlock.Free; FGlobalBlock := nil; for I := 0 to FRegProcs.Count - 1 do TObject(FRegProcs[I]).Free; FRegProcs.Free; for i := 0 to FConstants.Count -1 do begin TPSConstant(FConstants[I]).Free; end; Fconstants.Free; for I := 0 to FVars.Count - 1 do begin TPSVar(FVars[I]).Free; end; FVars.Free; FVars := nil; for I := 0 to FProcs.Count - 1 do TPSProcedure(FProcs[I]).Free; FProcs.Free; FProcs := nil; for I := 0 to FTypes.Count - 1 do begin PT := FTypes[I]; pt.Free; end; FTypes.Free; {$IFNDEF PS_NOINTERFACES} for i := FInterfaces.Count -1 downto 0 do TPSInterface(FInterfaces[i]).Free; FInterfaces.Free; {$ENDIF} for i := FClasses.Count -1 downto 0 do begin TPSCompileTimeClass(FClasses[I]).Free; end; FClasses.Free; for i := FAttributeTypes.Count -1 downto 0 do begin TPSAttributeType(FAttributeTypes[i]).Free; end; FAttributeTypes.Free; FAttributeTypes := nil; {$IFDEF PS_USESSUPPORT} for I := 0 to FUnitInits.Count - 1 do //nvds begin //nvds TPSBlockInfo(FUnitInits[I]).free; //nvds end; //nvds FUnitInits.Free; //nvds FUnitInits := nil; // for I := 0 to FUnitFinits.Count - 1 do //nvds begin //nvds TPSBlockInfo(FUnitFinits[I]).free; //nvds end; //nvds FUnitFinits.Free; // FUnitFinits := nil; // FreeAndNil(fUnits); FreeAndNil(FUses); fInCompile:=0; {$ENDIF} end; function MakeOutput: Boolean; procedure WriteByte(b: Byte); begin FOutput := FOutput + tbtChar(b); end; procedure WriteData(const Data; Len: Longint); var l: Longint; begin if Len < 0 then Len := 0; l := Length(FOutput); SetLength(FOutput, l + Len); Move(Data, FOutput[l + 1], Len); end; procedure WriteLong(l: Cardinal); begin WriteData(l, 4); end; procedure WriteVariant(p: PIfRVariant); begin WriteLong(p^.FType.FinalTypeNo); case p.FType.BaseType of btType: WriteLong(p^.ttype.FinalTypeNo); {$IFNDEF PS_NOWIDESTRING} btWideString: begin WriteLong(Length(tbtWideString(p^.twidestring))); WriteData(tbtwidestring(p^.twidestring)[1], 2*Length(tbtWideString(p^.twidestring))); end; btUnicodeString: begin WriteLong(Length(tbtUnicodestring(p^.twidestring))); WriteData(tbtUnicodestring(p^.twidestring)[1], 2*Length(tbtUnicodestring(p^.twidestring))); end; btWideChar: WriteData(p^.twidechar, 2); {$ENDIF} btSingle: WriteData(p^.tsingle, sizeof(tbtSingle)); btDouble: WriteData(p^.tsingle, sizeof(tbtDouble)); btExtended: WriteData(p^.tsingle, sizeof(tbtExtended)); btCurrency: WriteData(p^.tsingle, sizeof(tbtCurrency)); btChar: WriteData(p^.tchar, 1); btSet: begin WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); end; btString: begin WriteLong(Length(tbtString(p^.tstring))); WriteData(tbtString(p^.tstring)[1], Length(tbtString(p^.tstring))); end; btenum: begin if TPSEnumType(p^.FType).HighValue <=256 then WriteData( p^.tu32, 1) else if TPSEnumType(p^.FType).HighValue <=65536 then WriteData(p^.tu32, 2) else WriteData(p^.tu32, 4); end; bts8,btu8: WriteData(p^.tu8, 1); bts16,btu16: WriteData(p^.tu16, 2); bts32,btu32: WriteData(p^.tu32, 4); {$IFNDEF PS_NOINT64} bts64: WriteData(p^.ts64, 8); {$ENDIF} btProcPtr: WriteData(p^.tu32, 4); {$IFDEF DEBUG} else asm int 3; end; {$ENDIF} end; end; procedure WriteAttributes(attr: TPSAttributes); var i, j: Longint; begin WriteLong(attr.Count); for i := 0 to Attr.Count -1 do begin j := Length(attr[i].FAttribType.Name); WriteLong(j); WriteData(Attr[i].FAttribType.Name[1], j); WriteLong(Attr[i].Count); for j := 0 to Attr[i].Count -1 do begin WriteVariant(Attr[i][j]); end; end; end; procedure WriteTypes; var l, n: Longint; bt: TPSBaseType; x: TPSType; s: tbtString; FExportName: tbtString; Items: TPSList; procedure WriteTypeNo(TypeNo: Cardinal); begin WriteData(TypeNo, 4); end; begin Items := TPSList.Create; try for l := 0 to FCurrUsedTypeNo -1 do Items.Add(nil); for l := 0 to FTypes.Count -1 do begin x := FTypes[l]; if x.Used then Items[x.FinalTypeNo] := x; end; for l := 0 to Items.Count - 1 do begin x := Items[l]; if x.FExportName then FExportName := x.Name else FExportName := ''; if (x.BaseType = btExtClass) and (x is TPSUndefinedClassType) then begin x := GetTypeCopyLink(TPSUndefinedClassType(x).ExtClass.SelfType); end; bt := x.BaseType; if (x.BaseType = btType) or (x.BaseType = btNotificationVariant) then begin bt := btU32; end else if (x.BaseType = btEnum) then begin if TPSEnumType(x).HighValue <= 256 then bt := btU8 else if TPSEnumType(x).HighValue <= 65536 then bt := btU16 else bt := btU32; end; if FExportName <> '' then begin WriteByte(bt + 128); end else WriteByte(bt); {$IFNDEF PS_NOINTERFACES} if x.BaseType = btInterface then begin WriteData(TPSInterfaceType(x).Intf.Guid, Sizeof(TGuid)); end else {$ENDIF} if x.BaseType = btClass then begin WriteLong(Length(TPSClassType(X).Cl.FClassName)); WriteData(TPSClassType(X).Cl.FClassName[1], Length(TPSClassType(X).Cl.FClassName)); end else if (x.BaseType = btProcPtr) then begin s := DeclToBits(TPSProceduralType(x).ProcDef); WriteLong(Length(s)); WriteData(s[1], Length(s)); end else if (x.BaseType = btSet) then begin WriteLong(TPSSetType(x).BitSize); end else if (x.BaseType = btArray) or (x.basetype = btStaticArray) then begin WriteLong(TPSArrayType(x).ArrayTypeNo.FinalTypeNo); if (x.baseType = btstaticarray) then begin WriteLong(TPSStaticArrayType(x).Length); WriteLong(TPSStaticArrayType(x).StartOffset); //<-additional StartOffset end; end else if x.BaseType = btRecord then begin n := TPSRecordType(x).RecValCount; WriteData( n, 4); for n := 0 to TPSRecordType(x).RecValCount - 1 do WriteTypeNo(TPSRecordType(x).RecVal(n).FType.FinalTypeNo); end; if FExportName <> '' then begin WriteLong(Length(FExportName)); WriteData(FExportName[1], length(FExportName)); end; WriteAttributes(x.Attributes); end; finally Items.Free; end; end; procedure WriteVars; var l,j : Longint; x: TPSVar; begin for l := 0 to FVars.Count - 1 do begin x := FVars[l]; if x.SaveAsPointer then begin for j := FTypes.count -1 downto 0 do begin if TPSType(FTypes[j]).BaseType = btPointer then begin WriteLong(TPSType(FTypes[j]).FinalTypeNo); break; end; end; end else WriteLong(x.FType.FinalTypeNo); if x.exportname <> '' then begin WriteByte( 1); WriteLong(Length(X.ExportName)); WriteData( X.ExportName[1], length(X.ExportName)); end else WriteByte( 0); end; end; procedure WriteProcs; var l: Longint; xp: TPSProcedure; xo: TPSInternalProcedure; xe: TPSExternalProcedure; s: tbtString; att: Byte; begin for l := 0 to FProcs.Count - 1 do begin xp := FProcs[l]; if xp.Attributes.Count <> 0 then att := 4 else att := 0; if xp.ClassType = TPSInternalProcedure then begin xo := TPSInternalProcedure(xp); xo.OutputDeclPosition := Length(FOutput); WriteByte(att or 2); // exported WriteLong(0); // offset is unknown at this time WriteLong(0); // length is also unknown at this time WriteLong(Length(xo.Name)); WriteData( xo.Name[1], length(xo.Name)); s := MakeExportDecl(xo.Decl); WriteLong(Length(s)); WriteData( s[1], length(S)); end else begin xe := TPSExternalProcedure(xp); if xe.RegProc.ImportDecl <> '' then begin WriteByte( att or 3); // imported if xe.RegProc.FExportName then begin WriteByte(Length(xe.RegProc.Name)); WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF); end else begin WriteByte(0); end; WriteLong(Length(xe.RegProc.ImportDecl)); WriteData(xe.RegProc.ImportDecl[1], Length(xe.RegProc.ImportDecl)); end else begin WriteByte(att or 1); // imported WriteByte(Length(xe.RegProc.Name)); WriteData(xe.RegProc.Name[1], Length(xe.RegProc.Name) and $FF); end; end; if xp.Attributes.Count <> 0 then WriteAttributes(xp.Attributes); end; end; procedure WriteProcs2; var l: Longint; L2: Cardinal; x: TPSProcedure; begin for l := 0 to FProcs.Count - 1 do begin x := FProcs[l]; if x.ClassType = TPSInternalProcedure then begin if TPSInternalProcedure(x).Data = '' then TPSInternalProcedure(x).Data := Chr(Cm_R); L2 := Length(FOutput); Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 2], 4); // write position WriteData(TPSInternalProcedure(x).Data[1], Length(TPSInternalProcedure(x).Data)); L2 := Cardinal(Length(FOutput)) - L2; Move(L2, FOutput[TPSInternalProcedure(x).OutputDeclPosition + 6], 4); // write length end; end; end; {$IFDEF PS_USESSUPPORT} function FindMainProc: Cardinal; var l: Longint; Proc : TPSInternalProcedure; ProcData : tbtString; Calls : Integer; procedure WriteProc(const aData: Longint); var l: Longint; begin ProcData := ProcData + Chr(cm_c); l := Length(ProcData); SetLength(ProcData, l + 4); Move(aData, ProcData[l + 1], 4); inc(Calls); end; begin ProcData := ''; Calls := 1; for l := 0 to FUnitInits.Count-1 do if (FUnitInits[l] <> nil) and (TPSBlockInfo(FUnitInits[l]).Proc.Data<>'') then WriteProc(TPSBlockInfo(FUnitInits[l]).FProcNo); WriteProc(FGlobalBlock.FProcNo); for l := FUnitFinits.Count-1 downto 0 do if (FUnitFinits[l] <> nil) and (TPSBlockInfo(FUnitFinits[l]).Proc.Data<>'') then WriteProc(TPSBlockInfo(FUnitFinits[l]).FProcNo); if Calls = 1 then begin Result := FGlobalBlock.FProcNo; end else begin Proc := NewProc('Master proc', '!MASTERPROC'); Result := FindProc('!MASTERPROC'); Proc.data := Procdata + Chr(cm_R); end; end; {$ELSE} function FindMainProc: Cardinal; var l: Longint; begin for l := 0 to FProcs.Count - 1 do begin if (TPSProcedure(FProcs[l]).ClassType = TPSInternalProcedure) and (TPSInternalProcedure(FProcs[l]).Name = PSMainProcName) then begin Result := l; exit; end; end; Result := InvalidVal; end; {$ENDIF} procedure CreateDebugData; var I: Longint; p: TPSProcedure; pv: TPSVar; s: tbtString; begin s := #0; for I := 0 to FProcs.Count - 1 do begin p := FProcs[I]; if p.ClassType = TPSInternalProcedure then begin if TPSInternalProcedure(p).Name = PSMainProcName then s := s + #1 else s := s + TPSInternalProcedure(p).OriginalName + #1; end else begin s := s+ TPSExternalProcedure(p).RegProc.OrgName + #1; end; end; s := s + #0#1; for I := 0 to FVars.Count - 1 do begin pv := FVars[I]; s := s + pv.OrgName + #1; end; s := s + #0; WriteDebugData(s); end; var //nvds MainProc : Cardinal; //nvds begin if @FOnBeforeOutput <> nil then begin if not FOnBeforeOutput(Self) then begin Result := false; exit; end; end; MainProc := FindMainProc; //NvdS (need it here becose FindMainProc can create a New proc. CreateDebugData; WriteLong(PSValidHeader); WriteLong(PSCurrentBuildNo); WriteLong(FCurrUsedTypeNo); WriteLong(FProcs.Count); WriteLong(FVars.Count); WriteLong(MainProc); //nvds WriteLong(0); WriteTypes; WriteProcs; WriteVars; WriteProcs2; Result := true; end; function CheckExports: Boolean; var i: Longint; p: TPSProcedure; begin if @FOnExportCheck = nil then begin result := true; exit; end; for i := 0 to FProcs.Count -1 do begin p := FProcs[I]; if p.ClassType = TPSInternalProcedure then begin if not FOnExportCheck(Self, TPSInternalProcedure(p), MakeDecl(TPSInternalProcedure(p).Decl)) then begin Result := false; exit; end; end; end; Result := True; end; function DoConstBlock: Boolean; var COrgName: tbtString; CTemp, CValue: PIFRVariant; Cp: TPSConstant; TokenPos, TokenRow, TokenCol: Integer; begin FParser.Next; repeat if FParser.CurrTokenID <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); Result := False; Exit; end; TokenPos := FParser.CurrTokenPos; TokenRow := FParser.Row; TokenCol := FParser.Col; COrgName := FParser.OriginalToken; if IsDuplicate(FastUpperCase(COrgName), [dcVars, dcProcs, dcConsts]) then begin MakeError('', ecDuplicateIdentifier, COrgName); Result := False; exit; end; FParser.Next; if FParser.CurrTokenID <> CSTI_Equal then begin MakeError('', ecIsExpected, ''); Result := False; Exit; end; FParser.Next; CValue := ReadConstant(FParser, CSTI_SemiColon); if CValue = nil then begin Result := False; Exit; end; if FParser.CurrTokenID <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); Result := False; exit; end; cp := TPSConstant.Create; cp.Orgname := COrgName; cp.Name := FastUpperCase(COrgName); {$IFDEF PS_USESSUPPORT} cp.DeclareUnit:=fModule; {$ENDIF} cp.DeclarePos := TokenPos; cp.DeclareRow := TokenRow; cp.DeclareCol := TokenCol; New(CTemp); InitializeVariant(CTemp, CValue.FType); CopyVariantContents(cvalue, CTemp); cp.Value := CTemp; FConstants.Add(cp); DisposeVariant(CValue); FParser.Next; until FParser.CurrTokenId <> CSTI_Identifier; Result := True; end; function ProcessUses: Boolean; var {$IFNDEF PS_USESSUPPORT} FUses: TIfStringList; {$ENDIF} I: Longint; s: tbtString; {$IFDEF PS_USESSUPPORT} Parse: Boolean; ParseUnit: tbtString; ParserPos: TPSPascalParser; {$ENDIF} begin FParser.Next; {$IFNDEF PS_USESSUPPORT} FUses := TIfStringList.Create; FUses.Add('SYSTEM'); {$ENDIF} repeat if FParser.CurrTokenID <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); {$IFNDEF PS_USESSUPPORT} FUses.Free; {$ENDIF} Result := False; exit; end; s := FParser.GetToken; {$IFDEF PS_USESSUPPORT} Parse:=true; {$ENDIF} for i := 0 to FUses.Count -1 do begin if FUses[I] = s then begin {$IFNDEF PS_USESSUPPORT} MakeError('', ecDuplicateIdentifier, s); FUses.Free; Result := False; exit; {$ELSE} Parse:=false; {$ENDIF} end; end; {$IFDEF PS_USESSUPPORT} if fUnits.GetUnit(S).HasUses(fModule) then begin MakeError('', ecCrossReference, s); Result := False; exit; end; fUnit.AddUses(S); if Parse then begin {$ENDIF} FUses.Add(s); if @FOnUses <> nil then begin try {$IFDEF PS_USESSUPPORT} OldFileName:=fModule; fModule:=FParser.OriginalToken; ParseUnit:=FParser.OriginalToken; ParserPos:=FParser; {$ENDIF} if not OnUses(Self, FParser.GetToken) then begin {$IFNDEF PS_USESSUPPORT} FUses.Free; {$ELSE} FParser:=ParserPos; fModule:=OldFileName; MakeError(OldFileName, ecUnitNotFoundOrContainsErrors, ParseUnit); {$ENDIF} Result := False; exit; end; {$IFDEF PS_USESSUPPORT} fModule:=OldFileName; {$ENDIF} except on e: Exception do begin MakeError('', ecCustomError, tbtstring(e.Message)); {$IFNDEF PS_USESSUPPORT} FUses.Free; {$ENDIF} Result := False; exit; end; end; end; {$IFDEF PS_USESSUPPORT} end; {$ENDIF} FParser.Next; if FParser.CurrTokenID = CSTI_Semicolon then break else if FParser.CurrTokenId <> CSTI_Comma then begin MakeError('', ecSemicolonExpected, ''); Result := False; {$IFNDEF PS_USESSUPPORT} FUses.Free; {$ENDIF} exit; end; FParser.Next; until False; {$IFNDEF PS_USESSUPPORT} FUses.Free; {$ENDIF} FParser.next; Result := True; end; var Proc: TPSProcedure; {$IFDEF PS_USESSUPPORT} Block : TPSBlockInfo; //nvds {$ENDIF} begin Result := False; FWithCount := -1; {$IFDEF PS_USESSUPPORT} if fInCompile=0 then begin {$ENDIF} FUnitName := ''; FCurrUsedTypeNo := 0; FIsUnit := False; Clear; FParserHadError := False; FParser.SetText(s); FAttributeTypes := TPSList.Create; FProcs := TPSList.Create; FConstants := TPSList.Create; FVars := TPSList.Create; FTypes := TPSList.Create; FRegProcs := TPSList.Create; FClasses := TPSList.Create; {$IFDEF PS_USESSUPPORT} FUnitInits := TPSList.Create; //nvds FUnitFinits:= TPSList.Create; //nvds FUses:=TIFStringList.Create; FUnits:=TPSUnitList.Create; {$ENDIF} {$IFNDEF PS_NOINTERFACES} FInterfaces := TPSList.Create;{$ENDIF} FGlobalBlock := TPSBlockInfo.Create(nil); FGlobalBlock.SubType := tMainBegin; FGlobalBlock.Proc := NewProc(PSMainProcNameOrg, PSMainProcName); FGlobalBlock.ProcNo := FindProc(PSMainProcName); {$IFDEF PS_USESSUPPORT} OldFileName:=fModule; fModule:='System'; FUses.Add('SYSTEM'); {$ENDIF} {$IFNDEF PS_NOSTANDARDTYPES} DefineStandardTypes; DefineStandardProcedures; {$ENDIF} if @FOnUses <> nil then begin try if not OnUses(Self, 'SYSTEM') then begin Cleanup; exit; end; except on e: Exception do begin MakeError('', ecCustomError, tbtstring(e.Message)); Cleanup; exit; end; end; end; {$IFDEF PS_USESSUPPORT} fModule:=OldFileName; OldParser:=nil; OldUnit:=nil; OldIsUnit:=false; // defaults end else begin OldParser:=FParser; OldIsUnit:=FIsUnit; OldUnit:=fUnit; FParser:=TPSPascalParser.Create; FParser.SetText(s); end; fUnit:=fUnits.GetUnit(fModule); inc(fInCompile); {$ENDIF} Position := csStart; repeat if FParser.CurrTokenId = CSTI_EOF then begin if FParserHadError then begin Cleanup; exit; end; if FAllowNoEnd then Break else begin MakeError('', ecUnexpectedEndOfFile, ''); Cleanup; exit; end; end; if (FParser.CurrTokenId = CSTII_Program) and (Position = csStart) then begin {$IFDEF PS_USESSUPPORT} if fInCompile>1 then begin MakeError('', ecNotAllowed, 'program'); Cleanup; exit; end; {$ENDIF} Position := csProgram; FParser.Next; if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); Cleanup; exit; end; FParser.Next; if FParser.CurrTokenId <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); Cleanup; exit; end; FParser.Next; end else if (Fparser.CurrTokenID = CSTII_Implementation) and ((Position = csinterface) or (position = csInterfaceUses)) then begin Position := csImplementation; FParser.Next; end else if (Fparser.CurrTokenID = CSTII_Interface) and (Position = csUnit) then begin Position := csInterface; FParser.Next; end else if (FParser.CurrTokenId = CSTII_Unit) and (Position = csStart) and (FAllowUnit) then begin Position := csUnit; FIsUnit := True; FParser.Next; if FParser.CurrTokenId <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); Cleanup; exit; end; if fInCompile = 1 then FUnitName := FParser.OriginalToken; FParser.Next; if FParser.CurrTokenId <> CSTI_Semicolon then begin MakeError('', ecSemicolonExpected, ''); Cleanup; exit; end; FParser.Next; end else if (FParser.CurrTokenID = CSTII_Uses) and ((Position < csuses) or (Position = csInterface)) then begin if (Position = csInterface) or (Position =csInterfaceUses) then Position := csInterfaceUses else Position := csUses; if not ProcessUses then begin Cleanup; exit; end; end else if (FParser.CurrTokenId = CSTII_Procedure) or (FParser.CurrTokenId = CSTII_Function) or (FParser.CurrTokenID = CSTI_OpenBlock) then begin if (Position = csInterface) or (position = csInterfaceUses) then begin if not ProcessFunction(True, nil) then begin Cleanup; exit; end; end else begin Position := csUses; if not ProcessFunction(False, nil) then begin Cleanup; exit; end; end; end else if (FParser.CurrTokenId = CSTII_Label) then begin if (Position = csInterface) or (Position =csInterfaceUses) then Position := csInterfaceUses else Position := csUses; if not ProcessLabel(FGlobalBlock.Proc) then begin Cleanup; exit; end; end else if (FParser.CurrTokenId = CSTII_Var) then begin if (Position = csInterface) or (Position =csInterfaceUses) then Position := csInterfaceUses else Position := csUses; if not DoVarBlock(nil) then begin Cleanup; exit; end; end else if (FParser.CurrTokenId = CSTII_Const) then begin if (Position = csInterface) or (Position =csInterfaceUses) then Position := csInterfaceUses else Position := csUses; if not DoConstBlock then begin Cleanup; exit; end; end else if (FParser.CurrTokenId = CSTII_Type) then begin if (Position = csInterface) or (Position =csInterfaceUses) then Position := csInterfaceUses else Position := csUses; if not DoTypeBlock(FParser) then begin Cleanup; exit; end; end else if (FParser.CurrTokenId = CSTII_Begin) {$IFDEF PS_USESSUPPORT} or ((FParser.CurrTokenID = CSTII_initialization) and FIsUnit) {$ENDIF} then //nvds begin {$IFDEF PS_USESSUPPORT} if FIsUnit then begin Block := TPSBlockInfo.Create(nil); //nvds Block.SubType := tUnitInit; //nvds Block.Proc := NewProc(PSMainProcNameOrg+'_'+fModule, FastUpperCase(PSMainProcName+'_'+fModule)); //nvds Block.ProcNo := FindProc(PSMainProcName+'_'+fModule); //nvds Block.Proc.DeclareUnit:= fModule; Block.Proc.DeclarePos := FParser.CurrTokenPos; Block.Proc.DeclareRow := FParser.Row; Block.Proc.DeclareCol := FParser.Col; Block.Proc.Use; FUnitInits.Add(Block); if ProcessSub(Block) then begin if (Fparser.CurrTokenId = CSTI_EOF) THEN break; end else begin Cleanup; exit; end; end else begin FGlobalBlock.Proc.DeclareUnit:= fModule; {$ENDIF} FGlobalBlock.Proc.DeclarePos := FParser.CurrTokenPos; FGlobalBlock.Proc.DeclareRow := FParser.Row; FGlobalBlock.Proc.DeclareCol := FParser.Col; if ProcessSub(FGlobalBlock) then begin break; end else begin Cleanup; exit; end; {$IFDEF PS_USESSUPPORT} end; {$ENDIF} end {$IFDEF PS_USESSUPPORT} else if ((FParser.CurrTokenID = CSTII_finalization) and FIsUnit) then //NvdS begin Block := TPSBlockInfo.Create(nil); Block.SubType := tUnitFinish; Block.Proc := NewProc('!Finish_'+fModule, '!FINISH_'+FastUppercase(fModule)); Block.ProcNo := FindProc('!FINISH_'+FastUppercase(fModule)); Block.Proc.DeclareUnit:= fModule; Block.Proc.DeclarePos := FParser.CurrTokenPos; Block.Proc.DeclareRow := FParser.Row; Block.Proc.DeclareCol := FParser.Col; Block.Proc.use; FUnitFinits.Add(Block); if ProcessSub(Block) then begin break; end else begin Cleanup; Result := False; //Cleanup; exit; end; end {$endif} else if (Fparser.CurrTokenId = CSTII_End) and (FAllowNoBegin or FIsUnit) then begin FParser.Next; if FParser.CurrTokenID <> CSTI_Period then begin MakeError('', ecPeriodExpected, ''); Cleanup; exit; end; break; end else begin MakeError('', ecBeginExpected, ''); Cleanup; exit; end; until False; {$IFDEF PS_USESSUPPORT} dec(fInCompile); if fInCompile=0 then begin {$ENDIF} if not ProcessLabelForwards(FGlobalBlock.Proc) then begin Cleanup; exit; end; // NVDS: Do we need to check here also do a ProcessLabelForwards() for each Initialisation/finalization block? for i := 0 to FProcs.Count -1 do begin Proc := FProcs[I]; if (Proc.ClassType = TPSInternalProcedure) and (TPSInternalProcedure(Proc).Forwarded) then begin with MakeError('', ecUnsatisfiedForward, TPSInternalProcedure(Proc).Name) do begin FPosition := TPSInternalProcedure(Proc).DeclarePos; FRow := TPSInternalProcedure(Proc).DeclareRow; FCol := TPSInternalProcedure(Proc).DeclareCol; end; Cleanup; Exit; end; end; if not CheckExports then begin Cleanup; exit; end; for i := 0 to FVars.Count -1 do begin if not TPSVar(FVars[I]).Used then begin with MakeHint({$IFDEF PS_USESSUPPORT}TPSVar(FVars[I]).DeclareUnit{$ELSE}''{$ENDIF}, ehVariableNotUsed, TPSVar(FVars[I]).Name) do begin FPosition := TPSVar(FVars[I]).DeclarePos; FRow := TPSVar(FVars[I]).DeclareRow; FCol := TPSVar(FVars[I]).DeclareCol; end; end; end; Result := MakeOutput; Cleanup; {$IFDEF PS_USESSUPPORT} end else begin fParser.Free; fParser:=OldParser; fIsUnit:=OldIsUnit; fUnit:=OldUnit; result:=true; end; {$ENDIF} end; constructor TPSPascalCompiler.Create; begin inherited Create; FParser := TPSPascalParser.Create; FParser.OnParserError := ParserError; FAutoFreeList := TPSList.Create; FOutput := ''; {$IFDEF PS_USESSUPPORT} FAllowUnit := true; {$ENDIF} FMessages := TPSList.Create; end; destructor TPSPascalCompiler.Destroy; begin Clear; FAutoFreeList.Free; FMessages.Free; FParser.Free; inherited Destroy; end; function TPSPascalCompiler.GetOutput(var s: tbtString): Boolean; begin if Length(FOutput) <> 0 then begin s := FOutput; Result := True; end else Result := False; end; function TPSPascalCompiler.GetMsg(l: Longint): TPSPascalCompilerMessage; begin Result := FMessages[l]; end; function TPSPascalCompiler.GetMsgCount: Longint; begin Result := FMessages.Count; end; procedure TPSPascalCompiler.DefineStandardTypes; var i: Longint; begin AddType('Byte', btU8); FDefaultBoolType := AddTypeS('Boolean', '(False, True)'); FDefaultBoolType.ExportName := True; with TPSEnumType(AddType('LongBool', btEnum)) do begin HighValue := 2147483647; // make sure it's gonna be a 4 byte var end; with TPSEnumType(AddType('WordBool', btEnum)) do begin HighValue := 65535; // make sure it's gonna be a 2 byte var end; with TPSEnumType(AddType('ByteBool', btEnum)) do begin HighValue := 255; // make sure it's gonna be a 1 byte var end; //following 2 IFDEFs should actually be UNICODE IFDEFs... AddType({$IFDEF PS_PANSICHAR}'AnsiChar'{$ELSE}'Char'{$ENDIF}, btChar); {$IFDEF PS_PANSICHAR} AddType('Char', btWideChar); {$ENDIF} {$IFNDEF PS_NOWIDESTRING} AddType('WideChar', btWideChar); AddType('WideString', btWideString); AddType('UnicodeString', btUnicodeString); {$ENDIF} AddType('AnsiString', btString); {$IFDEF DELPHI2009UP} AddType('String', btUnicodeString); ADdType('NativeString', btUnicodeString); {$ELSE} AddType('String', btString); AddType('NativeString', btString); {$ENDIF} FAnyString := AddType('AnyString', btString); AddType('ShortInt', btS8); AddType('Word', btU16); AddType('SmallInt', btS16); AddType('LongInt', btS32); at2ut(AddType('___Pointer', btPointer)); AddType('LongWord', btU32); AddTypeCopyN('Integer', 'LONGINT'); AddTypeCopyN('Cardinal', 'LONGWORD'); AddType('tbtString', btString); {$IFNDEF PS_NOINT64} AddType('Int64', btS64); {$ENDIF} AddType('Single', btSingle); AddType('Double', btDouble); AddType('Extended', btExtended); AddType('Currency', btCurrency); AddType({$IFDEF PS_PANSICHAR}'PAnsiChar'{$ELSE}'PChar'{$ENDIF}, btPChar); AddType('Variant', btVariant); AddType('!NotificationVariant', btNotificationVariant); for i := FTypes.Count -1 downto 0 do AT2UT(FTypes[i]); TPSArrayType(AddType('TVariantArray', btArray)).ArrayTypeNo := FindType('VARIANT'); with AddFunction('function Assigned(I: Longint): Boolean;') do begin Name := '!ASSIGNED'; end; with AddFunction('procedure _T(Name: tbtString; v: Variant);') do begin Name := '!NOTIFICATIONVARIANTSET'; end; with AddFunction('function _T(Name: tbtString): Variant;') do begin Name := '!NOTIFICATIONVARIANTGET'; end; end; function TPSPascalCompiler.FindType(const Name: tbtString): TPSType; var i, n: Longint; RName: tbtString; begin if FProcs = nil then begin Result := nil; exit;end; RName := Fastuppercase(Name); n := makehash(rname); for i := FTypes.Count - 1 downto 0 do begin Result := FTypes.Data[I]; if (Result.NameHash = n) and (Result.name = rname) then begin Result := GetTypeCopyLink(Result); exit; end; end; result := nil; end; function TPSPascalCompiler.AddConstant(const Name: tbtString; FType: TPSType): TPSConstant; var pc: TPSConstant; val: PIfRVariant; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); FType := GetTypeCopyLink(FType); if FType = nil then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterConst, [name]); pc := TPSConstant.Create; pc.OrgName := name; pc.Name := FastUppercase(name); pc.DeclarePos:=InvalidVal; {$IFDEF PS_USESSUPPORT} pc.DeclareUnit:=fModule; {$ENDIF} New(Val); InitializeVariant(Val, FType); pc.Value := Val; FConstants.Add(pc); result := pc; end; function TPSPascalCompiler.ReadAttributes(Dest: TPSAttributes): Boolean; var Att: TPSAttributeType; at: TPSAttribute; varp: PIfRVariant; h, i: Longint; s: tbtString; begin if FParser.CurrTokenID <> CSTI_OpenBlock then begin Result := true; exit; end; FParser.Next; if FParser.CurrTokenID <> CSTI_Identifier then begin MakeError('', ecIdentifierExpected, ''); Result := False; exit; end; s := FParser.GetToken; h := MakeHash(s); att := nil; for i := FAttributeTypes.count -1 downto 0 do begin att := FAttributeTypes[i]; if (att.FNameHash = h) and (att.FName = s) then Break; att := nil; end; if att = nil then begin MakeError('', ecUnknownIdentifier, ''); Result := False; exit; end; FParser.Next; i := 0; at := Dest.Add(att); while att.Fields[i].Hidden do begin at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType))); inc(i); end; if FParser.CurrTokenId <> CSTI_OpenRound then begin MakeError('', ecOpenRoundExpected, ''); Result := False; exit; end; FParser.Next; if i < Att.FieldCount then begin while i < att.FieldCount do begin varp := ReadConstant(FParser, CSTI_CloseRound); if varp = nil then begin Result := False; exit; end; at.AddValue(varp); if not IsCompatibleType(varp.FType, Att.Fields[i].FieldType, False) then begin MakeError('', ecTypeMismatch, ''); Result := False; exit; end; Inc(i); while (i < Att.FieldCount) and (att.Fields[i].Hidden) do begin at.AddValue(NewVariant(at2ut(att.Fields[i].FieldType))); inc(i); end; if i >= Att.FieldCount then begin break; end else begin if FParser.CurrTokenID <> CSTI_Comma then begin MakeError('', ecCommaExpected, ''); Result := False; exit; end; end; FParser.Next; end; end; if FParser.CurrTokenID <> CSTI_CloseRound then begin MakeError('', ecCloseRoundExpected, ''); Result := False; exit; end; FParser.Next; if FParser.CurrTokenID <> CSTI_CloseBlock then begin MakeError('', ecCloseBlockExpected, ''); Result := False; exit; end; FParser.Next; Result := True; end; type TConstOperation = class(TObject) private FDeclPosition, FDeclRow, FDeclCol: Cardinal; public property DeclPosition: Cardinal read FDeclPosition write FDeclPosition; property DeclRow: Cardinal read FDeclRow write FDeclRow; property DeclCol: Cardinal read FDeclCol write FDeclCol; procedure SetPos(Parser: TPSPascalParser); end; TUnConstOperation = class(TConstOperation) private FOpType: TPSUnOperatorType; FVal1: TConstOperation; public property OpType: TPSUnOperatorType read FOpType write FOpType; property Val1: TConstOperation read FVal1 write FVal1; destructor Destroy; override; end; TBinConstOperation = class(TConstOperation) private FOpType: TPSBinOperatorType; FVal2: TConstOperation; FVal1: TConstOperation; public property OpType: TPSBinOperatorType read FOpType write FOpType; property Val1: TConstOperation read FVal1 write FVal1; property Val2: TConstOperation read FVal2 write FVal2; destructor Destroy; override; end; TConstData = class(TConstOperation) private FData: PIfRVariant; public property Data: PIfRVariant read FData write FData; destructor Destroy; override; end; function TPSPascalCompiler.IsBoolean(aType: TPSType): Boolean; begin Result := (AType = FDefaultBoolType) or (AType.Name = 'LONGBOOL') or (AType.Name = 'WORDBOOL') or (AType.Name = 'BYTEBOOL'); end; function TPSPascalCompiler.ReadConstant(FParser: TPSPascalParser; StopOn: TPSPasToken): PIfRVariant; function ReadExpression: TConstOperation; forward; function ReadTerm: TConstOperation; forward; function ReadFactor: TConstOperation; var NewVar: TConstOperation; NewVarU: TUnConstOperation; function GetConstantIdentifier: PIfRVariant; var s: tbtString; sh: Longint; i: Longint; p: TPSConstant; begin s := FParser.GetToken; sh := MakeHash(s); for i := FConstants.Count -1 downto 0 do begin p := FConstants[I]; if (p.NameHash = sh) and (p.Name = s) then begin New(Result); InitializeVariant(Result, p.Value.FType); CopyVariantContents(P.Value, Result); FParser.Next; exit; end; end; MakeError('', ecUnknownIdentifier, ''); Result := nil; end; begin case fParser.CurrTokenID of CSTII_Not: begin FParser.Next; NewVar := ReadFactor; if NewVar = nil then begin Result := nil; exit; end; NewVarU := TUnConstOperation.Create; NewVarU.OpType := otNot; NewVarU.Val1 := NewVar; NewVar := NewVarU; end; CSTI_Minus: begin FParser.Next; NewVar := ReadTerm; if NewVar = nil then begin Result := nil; exit; end; NewVarU := TUnConstOperation.Create; NewVarU.OpType := otMinus; NewVarU.Val1 := NewVar; NewVar := NewVarU; end; CSTI_OpenRound: begin FParser.Next; NewVar := ReadExpression; if NewVar = nil then begin Result := nil; exit; end; if FParser.CurrTokenId <> CSTI_CloseRound then begin NewVar.Free; Result := nil; MakeError('', ecCloseRoundExpected, ''); exit; end; FParser.Next; end; CSTI_Char, CSTI_String: begin NewVar := TConstData.Create; NewVar.SetPos(FParser); TConstData(NewVar).Data := ReadString; end; CSTI_HexInt, CSTI_Integer: begin NewVar := TConstData.Create; NewVar.SetPos(FParser); TConstData(NewVar).Data := ReadInteger(FParser.GetToken); FParser.Next; end; CSTI_Real: begin NewVar := TConstData.Create; NewVar.SetPos(FParser); TConstData(NewVar).Data := ReadReal(FParser.GetToken); FParser.Next; end; CSTI_Identifier: begin NewVar := TConstData.Create; NewVar.SetPos(FParser); TConstData(NewVar).Data := GetConstantIdentifier; if TConstData(NewVar).Data = nil then begin NewVar.Free; Result := nil; exit; end end; else begin MakeError('', ecSyntaxError, ''); Result := nil; exit; end; end; {case} Result := NewVar; end; // ReadFactor function ReadTerm: TConstOperation; var F1, F2: TConstOperation; F: TBinConstOperation; Token: TPSPasToken; Op: TPSBinOperatorType; begin F1 := ReadFactor; if F1 = nil then begin Result := nil; exit; end; while FParser.CurrTokenID in [CSTI_Multiply, CSTI_Divide, CSTII_Div, CSTII_Mod, CSTII_And, CSTII_Shl, CSTII_Shr] do begin Token := FParser.CurrTokenID; FParser.Next; F2 := ReadFactor; if f2 = nil then begin f1.Free; Result := nil; exit; end; case Token of CSTI_Multiply: Op := otMul; CSTI_Divide: Op := otDiv; CSTII_Div: Op := otIntDiv; CSTII_mod: Op := otMod; CSTII_and: Op := otAnd; CSTII_shl: Op := otShl; CSTII_shr: Op := otShr; else Op := otAdd; end; F := TBinConstOperation.Create; f.Val1 := F1; f.Val2 := F2; f.OpType := Op; f1 := f; end; Result := F1; end; // ReadTerm function ReadSimpleExpression: TConstOperation; var F1, F2: TConstOperation; F: TBinConstOperation; Token: TPSPasToken; Op: TPSBinOperatorType; begin F1 := ReadTerm; if F1 = nil then begin Result := nil; exit; end; while FParser.CurrTokenID in [CSTI_Plus, CSTI_Minus, CSTII_Or, CSTII_Xor] do begin Token := FParser.CurrTokenID; FParser.Next; F2 := ReadTerm; if f2 = nil then begin f1.Free; Result := nil; exit; end; case Token of CSTI_Plus: Op := otAdd; CSTI_Minus: Op := otSub; CSTII_or: Op := otOr; CSTII_xor: Op := otXor; else Op := otAdd; end; F := TBinConstOperation.Create; f.Val1 := F1; f.Val2 := F2; f.OpType := Op; f1 := f; end; Result := F1; end; // ReadSimpleExpression function ReadExpression: TConstOperation; var F1, F2: TConstOperation; F: TBinConstOperation; Token: TPSPasToken; Op: TPSBinOperatorType; begin F1 := ReadSimpleExpression; if F1 = nil then begin Result := nil; exit; end; while FParser.CurrTokenID in [ CSTI_GreaterEqual, CSTI_LessEqual, CSTI_Greater, CSTI_Less, CSTI_Equal, CSTI_NotEqual] do begin Token := FParser.CurrTokenID; FParser.Next; F2 := ReadSimpleExpression; if f2 = nil then begin f1.Free; Result := nil; exit; end; case Token of CSTI_GreaterEqual: Op := otGreaterEqual; CSTI_LessEqual: Op := otLessEqual; CSTI_Greater: Op := otGreater; CSTI_Less: Op := otLess; CSTI_Equal: Op := otEqual; CSTI_NotEqual: Op := otNotEqual; else Op := otAdd; end; F := TBinConstOperation.Create; f.Val1 := F1; f.Val2 := F2; f.OpType := Op; f1 := f; end; Result := F1; end; // ReadExpression function EvalConst(P: TConstOperation): PIfRVariant; var p1, p2: PIfRVariant; begin if p is TBinConstOperation then begin p1 := EvalConst(TBinConstOperation(p).Val1); if p1 = nil then begin Result := nil; exit; end; p2 := EvalConst(TBinConstOperation(p).Val2); if p2 = nil then begin DisposeVariant(p1); Result := nil; exit; end; if not PreCalc(False, 0, p1, 0, p2, TBinConstOperation(p).OpType, p.DeclPosition, p.DeclRow, p.DeclCol) then begin DisposeVariant(p1); DisposeVariant(p2); // MakeError('', ecTypeMismatch, ''); result := nil; exit; end; DisposeVariant(p2); Result := p1; end else if p is TUnConstOperation then begin with TUnConstOperation(P) do begin p1 := EvalConst(Val1); case OpType of otNot: case p1.FType.BaseType of btU8: p1.tu8 := not p1.tu8; btU16: p1.tu16 := not p1.tu16; btU32: p1.tu32 := not p1.tu32; bts8: p1.ts8 := not p1.ts8; bts16: p1.ts16 := not p1.ts16; bts32: p1.ts32 := not p1.ts32; {$IFNDEF PS_NOINT64} bts64: p1.ts64 := not p1.ts64; {$ENDIF} else begin MakeError('', ecTypeMismatch, ''); DisposeVariant(p1); Result := nil; exit; end; end; otMinus: case p1.FType.BaseType of btU8: p1.tu8 := -p1.tu8; btU16: p1.tu16 := -p1.tu16; btU32: p1.tu32 := -p1.tu32; bts8: p1.ts8 := -p1.ts8; bts16: p1.ts16 := -p1.ts16; bts32: p1.ts32 := -p1.ts32; {$IFNDEF PS_NOINT64} bts64: p1.ts64 := -p1.ts64; {$ENDIF} btDouble: p1.tdouble := - p1.tDouble; btSingle: p1.tsingle := - p1.tsingle; btCurrency: p1.tcurrency := - p1.tcurrency; btExtended: p1.textended := - p1.textended; else begin MakeError('', ecTypeMismatch, ''); DisposeVariant(p1); Result := nil; exit; end; end; else begin DisposeVariant(p1); Result := nil; exit; end; end; end; Result := p1; end else begin if ((p as TConstData).Data.FType.BaseType = btString) and (length(tbtstring((p as TConstData).Data.tstring)) =1) then begin New(p1); InitializeVariant(p1, FindBaseType(btChar)); p1.tchar := tbtstring((p as TConstData).Data.tstring)[1]; Result := p1; end else begin New(p1); InitializeVariant(p1, (p as TConstData).Data.FType); CopyVariantContents((p as TConstData).Data, p1); Result := p1; end; end; end; var Val: TConstOperation; begin Val := ReadExpression; if val = nil then begin Result := nil; exit; end; Result := EvalConst(Val); Val.Free; end; procedure TPSPascalCompiler.WriteDebugData(const s: tbtString); begin FDebugOutput := FDebugOutput + s; end; function TPSPascalCompiler.GetDebugOutput(var s: tbtString): Boolean; begin if Length(FDebugOutput) <> 0 then begin s := FDebugOutput; Result := True; end else Result := False; end; function TPSPascalCompiler.AddUsedFunction(var Proc: TPSInternalProcedure): Cardinal; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Proc := TPSInternalProcedure.Create; FProcs.Add(Proc); Result := FProcs.Count - 1; end; {$IFNDEF PS_NOINTERFACES} const IUnknown_Guid: TGuid = (D1: 0; d2: 0; d3: 0; d4: ($c0,00,00,00,00,00,00,$46)); IDispatch_Guid: Tguid = (D1: $20400; D2: $0; D3: $0; D4:($C0, $0, $0, $0, $0, $0, $0, $46)); {$ENDIF} procedure TPSPascalCompiler.DefineStandardProcedures; var p: TPSRegProc; begin {$IFNDEF PS_NOINT64} AddFunction('function IntToStr(i: Int64): String;'); {$ELSE} AddFunction('function IntTostr(i: Integer): String;'); {$ENDIF} AddFunction('function StrToInt(s: String): Longint;'); AddFunction('function StrToIntDef(s: String; def: Longint): Longint;'); AddFunction('function Copy(s: AnyString; iFrom, iCount: Longint): AnyString;'); AddFunction('function Pos(SubStr, S: AnyString): Longint;'); AddFunction('procedure Delete(var s: AnyString; ifrom, icount: Longint);'); AddFunction('procedure Insert(s: AnyString; var s2: AnyString; iPos: Longint);'); p := AddFunction('function GetArrayLength: integer;'); with P.Decl.AddParam do begin OrgName := 'arr'; Mode := pmInOut; end; p := AddFunction('procedure SetArrayLength;'); with P.Decl.AddParam do begin OrgName := 'arr'; Mode := pmInOut; end; with P.Decl.AddParam do begin OrgName := 'count'; aType := FindBaseType(btS32); end; AddFunction('Function StrGet(var S : String; I : Integer) : Char;'); AddFunction('Function StrGet2(S : String; I : Integer) : Char;'); AddFunction('procedure StrSet(c : Char; I : Integer; var s : String);'); {$IFNDEF PS_NOWIDESTRING} AddFunction('Function WStrGet(var S : AnyString; I : Integer) : WideChar;'); AddFunction('procedure WStrSet(c : AnyString; I : Integer; var s : AnyString);'); {$ENDIF} AddFunction('Function AnsiUppercase(s : String) : String;'); AddFunction('Function AnsiLowercase(s : String) : String;'); AddFunction('Function Uppercase(s : AnyString) : AnyString;'); AddFunction('Function Lowercase(s : AnyString) : AnyString;'); AddFunction('Function Trim(s : AnyString) : AnyString;'); AddFunction('function Length: Integer;').Decl.AddParam.OrgName:='s'; with AddFunction('procedure SetLength;').Decl do begin with AddParam do begin OrgName:='s'; Mode:=pmInOut; end; with AddParam do begin OrgName:='NewLength'; aType:=FindBaseType(btS32); //Integer end; end; {$IFNDEF PS_NOINT64} AddFunction('function Low: Int64;').Decl.AddParam.OrgName:='x'; AddFunction('function High: Int64;').Decl.AddParam.OrgName:='x'; {$ELSE} AddFunction('function Low: Integer;').Decl.AddParam.OrgName:='x'; AddFunction('function High: Integer;').Decl.AddParam.OrgName:='x'; {$ENDIF} with AddFunction('procedure Dec;').Decl do begin with AddParam do begin OrgName:='x'; Mode:=pmInOut; end; end; with AddFunction('procedure Inc;').Decl do begin with AddParam do begin OrgName:='x'; Mode:=pmInOut; end; end; AddFunction('Function Sin(e : Extended) : Extended;'); AddFunction('Function Cos(e : Extended) : Extended;'); AddFunction('Function Sqrt(e : Extended) : Extended;'); AddFunction('Function Round(e : Extended) : Longint;'); AddFunction('Function Trunc(e : Extended) : Longint;'); AddFunction('Function Int(e : Extended) : Extended;'); AddFunction('Function Pi : Extended;'); AddFunction('Function Abs(e : Extended) : Extended;'); AddFunction('function StrToFloat(s: String): Extended;'); AddFunction('Function FloatToStr(e : Extended) : String;'); AddFunction('Function Padl(s : AnyString;I : longInt) : AnyString;'); AddFunction('Function Padr(s : AnyString;I : longInt) : AnyString;'); AddFunction('Function Padz(s : AnyString;I : longInt) : AnyString;'); AddFunction('Function Replicate(c : char;I : longInt) : String;'); AddFunction('Function StringOfChar(c : char;I : longInt) : String;'); AddTypeS('TVarType', 'Word'); AddConstantN('varEmpty', 'Word').Value.tu16 := varempty; AddConstantN('varNull', 'Word').Value.tu16 := varnull; AddConstantN('varSmallInt', 'Word').Value.tu16 := varsmallint; AddConstantN('varInteger', 'Word').Value.tu16 := varinteger; AddConstantN('varSingle', 'Word').Value.tu16 := varsingle; AddConstantN('varDouble', 'Word').Value.tu16 := vardouble; AddConstantN('varCurrency', 'Word').Value.tu16 := varcurrency; AddConstantN('varDate', 'Word').Value.tu16 := vardate; AddConstantN('varOleStr', 'Word').Value.tu16 := varolestr; AddConstantN('varDispatch', 'Word').Value.tu16 := vardispatch; AddConstantN('varError', 'Word').Value.tu16 := varerror; AddConstantN('varBoolean', 'Word').Value.tu16 := varboolean; AddConstantN('varVariant', 'Word').Value.tu16 := varvariant; AddConstantN('varUnknown', 'Word').Value.tu16 := varunknown; {$IFDEF DELPHI6UP} AddConstantN('varShortInt', 'Word').Value.tu16 := varshortint; AddConstantN('varByte', 'Word').Value.tu16 := varbyte; AddConstantN('varWord', 'Word').Value.tu16 := varword; AddConstantN('varLongWord', 'Word').Value.tu16 := varlongword; AddConstantN('varInt64', 'Word').Value.tu16 := varint64; {$ENDIF} {$IFDEF DELPHI5UP} AddConstantN('varStrArg', 'Word').Value.tu16 := varstrarg; AddConstantN('varAny', 'Word').Value.tu16 := varany; {$ENDIF} AddConstantN('varString', 'Word').Value.tu16 := varstring; AddConstantN('varTypeMask', 'Word').Value.tu16 := vartypemask; AddConstantN('varArray', 'Word').Value.tu16 := vararray; AddConstantN('varByRef', 'Word').Value.tu16 := varByRef; {$IFDEF UNICODE} AddConstantN('varUString', 'Word').Value.tu16 := varUString; {$ENDIF} AddDelphiFunction('function Unassigned: Variant;'); AddDelphiFunction('function VarIsEmpty(const V: Variant): Boolean;'); AddDelphiFunction('function Null: Variant;'); AddDelphiFunction('function VarIsNull(const V: Variant): Boolean;'); AddDelphiFunction('function VarType(const V: Variant): TVarType;'); addTypeS('TIFException', '(ErNoError, erCannotImport, erInvalidType, ErInternalError, '+ 'erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc, erOutOfGlobalVarsRange, '+ 'erOutOfProcRange, ErOutOfRange, erOutOfStackRange, ErTypeMismatch, erUnexpectedEof, '+ 'erVersionError, ErDivideByZero, ErMathError,erCouldNotCallProc, erOutofRecordRange, '+ 'erOutOfMemory, erException, erNullPointerException, erNullVariantError, erInterfaceNotSupported, erCustomError)'); AddFunction('procedure RaiseLastException;'); AddFunction('procedure RaiseException(Ex: TIFException; Param: String);'); AddFunction('function ExceptionType: TIFException;'); AddFunction('function ExceptionParam: String;'); AddFunction('function ExceptionProc: Cardinal;'); AddFunction('function ExceptionPos: Cardinal;'); AddFunction('function ExceptionToString(er: TIFException; Param: String): String;'); {$IFNDEF PS_NOINT64} AddFunction('function StrToInt64(s: String): int64;'); AddFunction('function Int64ToStr(i: Int64): String;'); {$ENDIF} with AddFunction('function SizeOf: Longint;').Decl.AddParam do begin OrgName := 'Data'; end; {$IFNDEF PS_NOINTERFACES} with AddInterface(nil, IUnknown_Guid, 'IUnknown') do begin RegisterDummyMethod; // Query Interface RegisterDummyMethod; // _AddRef RegisterDummyMethod; // _Release end; with AddInterface(nil, IUnknown_Guid, 'IInterface') do begin RegisterDummyMethod; // Query Interface RegisterDummyMethod; // _AddRef RegisterDummyMethod; // _Release end; {$IFNDEF PS_NOIDISPATCH} with AddInterface(FindInterface('IUnknown'), IDispatch_Guid, 'IDispatch') do begin RegisterDummyMethod; // GetTypeCount RegisterDummyMethod; // GetTypeInfo RegisterDummyMethod; // GetIdsOfName RegisterDummyMethod; // Invoke end; with TPSInterfaceType(FindType('IDispatch')) do begin ExportName := True; end; AddDelphiFunction('function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: String; Par: array of variant): variant;'); {$ENDIF} {$ENDIF} end; function TPSPascalCompiler.GetTypeCount: Longint; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := FTypes.Count; end; function TPSPascalCompiler.GetType(I: Longint): TPSType; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := FTypes[I]; end; function TPSPascalCompiler.GetVarCount: Longint; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := FVars.Count; end; function TPSPascalCompiler.GetVar(I: Longint): TPSVar; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := FVars[i]; end; function TPSPascalCompiler.GetProcCount: Longint; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := FProcs.Count; end; function TPSPascalCompiler.GetProc(I: Longint): TPSProcedure; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := FProcs[i]; end; function TPSPascalCompiler.AddUsedFunction2(var Proc: TPSExternalProcedure): Cardinal; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Proc := TPSExternalProcedure.Create; FProcs.Add(Proc); Result := FProcs.Count -1; end; function TPSPascalCompiler.AddVariable(const Name: tbtString; FType: TPSType): TPSVar; var P: TPSVar; s:tbtString; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); if FType = nil then raise EPSCompilerException.CreateFmt(RPS_InvalidTypeForVar, [Name]); s := Fastuppercase(Name); if IsDuplicate(s,[dcVars]) then raise EPSCompilerException.CreateFmt(RPS_DuplicateIdent, [Name]); p := TPSVar.Create; p.OrgName := Name; p.Name := s; p.FType := AT2UT(FType); p.exportname := p.Name; FVars.Add(p); Result := P; end; function TPSPascalCompiler.AddAttributeType: TPSAttributeType; begin if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly); Result := TPSAttributeType.Create; FAttributeTypes.Add(Result); end; function TPSPascalCompiler.FindAttributeType(const Name: tbtString): TPSAttributeType; var h, i: Integer; n: tbtString; begin if FAttributeTypes = nil then Raise Exception.Create(RPS_OnUseEventOnly); n := FastUpperCase(Name); h := MakeHash(n); for i := FAttributeTypes.Count -1 downto 0 do begin result := TPSAttributeType(FAttributeTypes[i]); if (Result.NameHash = h) and (Result.Name = n) then exit; end; result := nil; end; function TPSPascalCompiler.GetConstCount: Longint; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); result := FConstants.Count; end; function TPSPascalCompiler.GetConst(I: Longint): TPSConstant; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := TPSConstant(FConstants[i]); end; function TPSPascalCompiler.GetRegProcCount: Longint; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := FRegProcs.Count; end; function TPSPascalCompiler.GetRegProc(I: Longint): TPSRegProc; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := TPSRegProc(FRegProcs[i]); end; procedure TPSPascalCompiler.AddToFreeList(Obj: TObject); begin FAutoFreeList.Add(Obj); end; function TPSPascalCompiler.AddConstantN(const Name, FType: tbtString): TPSConstant; begin Result := AddConstant(Name, FindType(FType)); end; function TPSPascalCompiler.AddTypeCopy(const Name: tbtString; TypeNo: TPSType): TPSType; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); TypeNo := GetTypeCopyLink(TypeNo); if Typeno = nil then raise EPSCompilerException.Create(RPS_InvalidType); Result := AddType(Name, BtTypeCopy); TPSTypeLink(Result).LinkTypeNo := TypeNo; end; function TPSPascalCompiler.AddTypeCopyN(const Name, FType: tbtString): TPSType; begin Result := AddTypeCopy(Name, FindType(FType)); end; function TPSPascalCompiler.AddUsedVariable(const Name: tbtString; FType: TPSType): TPSVar; begin Result := AddVariable(Name, FType); if Result <> nil then Result.Use; end; function TPSPascalCompiler.AddUsedVariableN(const Name, FType: tbtString): TPSVar; begin Result := AddVariable(Name, FindType(FType)); if Result <> nil then Result.Use; end; function TPSPascalCompiler.AddVariableN(const Name, FType: tbtString): TPSVar; begin Result := AddVariable(Name, FindType(FType)); end; function TPSPascalCompiler.AddUsedPtrVariable(const Name: tbtString; FType: TPSType): TPSVar; begin Result := AddVariable(Name, FType); if Result <> nil then begin result.SaveAsPointer := True; Result.Use; end; end; function TPSPascalCompiler.AddUsedPtrVariableN(const Name, FType: tbtString): TPSVar; begin Result := AddVariable(Name, FindType(FType)); if Result <> nil then begin result.SaveAsPointer := True; Result.Use; end; end; function TPSPascalCompiler.AddTypeS(const Name, Decl: tbtString): TPSType; var Parser: TPSPascalParser; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Parser := TPSPascalParser.Create; Parser.SetText(Decl); Result := ReadType(Name, Parser); if Result<>nil then begin Result.DeclarePos:=InvalidVal; {$IFDEF PS_USESSUPPORT} Result.DeclareUnit:=fModule; {$ENDIF} Result.DeclareRow:=0; Result.DeclareCol:=0; end; Parser.Free; if result = nil then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterType, [name]); end; function TPSPascalCompiler.CheckCompatProc(P: TPSType; ProcNo: Cardinal): Boolean; var i: Longint; s1, s2: TPSParametersDecl; begin if p.BaseType <> btProcPtr then begin Result := False; Exit; end; S1 := TPSProceduralType(p).ProcDef; if TPSProcedure(FProcs[ProcNo]).ClassType = TPSInternalProcedure then s2 := TPSInternalProcedure(FProcs[ProcNo]).Decl else s2 := TPSExternalProcedure(FProcs[ProcNo]).RegProc.Decl; if (s1.Result <> s2.Result) or (s1.ParamCount <> s2.ParamCount) then begin Result := False; Exit; end; for i := 0 to s1.ParamCount -1 do begin if (s1.Params[i].Mode <> s2.Params[i].Mode) or (s1.Params[i].aType <> s2.Params[i].aType) then begin Result := False; Exit; end; end; Result := True; end; function TPSPascalCompiler.MakeExportDecl(decl: TPSParametersDecl): tbtString; var i: Longint; begin if Decl.Result = nil then result := '-1' else result := IntToStr(Decl.Result.FinalTypeNo); for i := 0 to decl.ParamCount -1 do begin if decl.GetParam(i).Mode = pmIn then Result := Result + ' @' else Result := Result + ' !'; Result := Result + inttostr(decl.GetParam(i).aType.FinalTypeNo); end; end; function TPSPascalCompiler.IsIntBoolType(aType: TPSType): Boolean; begin if Isboolean(aType) then begin Result := True; exit;end; case aType.BaseType of btU8, btS8, btU16, btS16, btU32, btS32{$IFNDEF PS_NOINT64}, btS64{$ENDIF}: Result := True; else Result := False; end; end; procedure TPSPascalCompiler.ParserError(Parser: TObject; Kind: TPSParserErrorKind); begin FParserHadError := True; case Kind of ICOMMENTERROR: MakeError('', ecCommentError, ''); ISTRINGERROR: MakeError('', ecStringError, ''); ICHARERROR: MakeError('', ecCharError, ''); else MakeError('', ecSyntaxError, ''); end; end; function TPSPascalCompiler.AddDelphiFunction(const Decl: tbtString): TPSRegProc; var p: TPSRegProc; pDecl: TPSParametersDecl; DOrgName: tbtString; FT: TPMFuncType; i: Longint; begin pDecl := TPSParametersDecl.Create; p := nil; try if not ParseMethod(Self, '', Decl, DOrgName, pDecl, FT) then Raise EPSCompilerException.CreateFmt(RPS_UnableToRegisterFunction, [Decl]); p := TPSRegProc.Create; P.Name := FastUppercase(DOrgName); p.OrgName := DOrgName; p.ExportName := True; p.Decl.Assign(pDecl); FRegProcs.Add(p); if pDecl.Result = nil then begin p.ImportDecl := p.ImportDecl + #0; end else p.ImportDecl := p.ImportDecl + #1; for i := 0 to pDecl.ParamCount -1 do begin if pDecl.Params[i].Mode <> pmIn then p.ImportDecl := p.ImportDecl + #1 else p.ImportDecl := p.ImportDecl + #0; end; finally pDecl.Free; end; Result := p; end; {$IFNDEF PS_NOINTERFACES} function TPSPascalCompiler.AddInterface(InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString): TPSInterface; var f: TPSType; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); f := FindType(Name); if (f <> nil) and (f is TPSInterfaceType) then begin result := TPSInterfaceType(f).Intf; Result.Guid := Guid; Result.InheritedFrom := InheritedFrom; exit; end; f := AddType(Name, btInterface); Result := TPSInterface.Create(Self, InheritedFrom, GUID, FastUppercase(Name), f); FInterfaces.Add(Result); TPSInterfaceType(f).Intf := Result; end; function TPSPascalCompiler.FindInterface(const Name: tbtString): TPSInterface; var n: tbtString; i, nh: Longint; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); n := FastUpperCase(Name); nh := MakeHash(n); for i := FInterfaces.Count -1 downto 0 do begin Result := FInterfaces[i]; if (Result.NameHash = nh) and (Result.Name = N) then exit; end; raise EPSCompilerException.CreateFmt(RPS_UnknownInterface, [Name]); end; {$ENDIF} function TPSPascalCompiler.AddClass(InheritsFrom: TPSCompileTimeClass; aClass: TClass): TPSCompileTimeClass; var f: TPSType; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := FindClass(tbtstring(aClass.ClassName)); if Result <> nil then exit; f := AddType(tbtstring(aClass.ClassName), btClass); Result := TPSCompileTimeClass.CreateC(aClass, Self, f); Result.FInheritsFrom := InheritsFrom; FClasses.Add(Result); TPSClassType(f).Cl := Result; f.ExportName := True; end; function TPSPascalCompiler.AddClassN(InheritsFrom: TPSCompileTimeClass; const aClass: tbtString): TPSCompileTimeClass; var f: TPSType; begin if FProcs = nil then raise EPSCompilerException.Create(RPS_OnUseEventOnly); Result := FindClass(aClass); if Result <> nil then begin if InheritsFrom <> nil then Result.FInheritsFrom := InheritsFrom; exit; end; f := AddType(aClass, btClass); Result := TPSCompileTimeClass.Create(FastUppercase(aClass), Self, f); TPSClassType(f).Cl := Result; Result.FInheritsFrom := InheritsFrom; FClasses.Add(Result); TPSClassType(f).Cl := Result; f.ExportName := True; end; function TPSPascalCompiler.FindClass(const aClass: tbtString): TPSCompileTimeClass; var i: Longint; Cl: tbtString; H: Longint; x: TPSCompileTimeClass; begin cl := FastUpperCase(aClass); H := MakeHash(Cl); for i :=0 to FClasses.Count -1 do begin x := FClasses[I]; if (X.FClassNameHash = H) and (X.FClassName = Cl) then begin Result := X; Exit; end; end; Result := nil; end; { } function TransDoubleToStr(D: Double): tbtString; begin SetLength(Result, SizeOf(Double)); Double((@Result[1])^) := D; end; function TransSingleToStr(D: Single): tbtString; begin SetLength(Result, SizeOf(Single)); Single((@Result[1])^) := D; end; function TransExtendedToStr(D: Extended): tbtString; begin SetLength(Result, SizeOf(Extended)); Extended((@Result[1])^) := D; end; function TransLongintToStr(D: Longint): tbtString; begin SetLength(Result, SizeOf(Longint)); Longint((@Result[1])^) := D; end; function TransCardinalToStr(D: Cardinal): tbtString; begin SetLength(Result, SizeOf(Cardinal)); Cardinal((@Result[1])^) := D; end; function TransWordToStr(D: Word): tbtString; begin SetLength(Result, SizeOf(Word)); Word((@Result[1])^) := D; end; function TransSmallIntToStr(D: SmallInt): tbtString; begin SetLength(Result, SizeOf(SmallInt)); SmallInt((@Result[1])^) := D; end; function TransByteToStr(D: Byte): tbtString; begin SetLength(Result, SizeOf(Byte)); Byte((@Result[1])^) := D; end; function TransShortIntToStr(D: ShortInt): tbtString; begin SetLength(Result, SizeOf(ShortInt)); ShortInt((@Result[1])^) := D; end; function TPSPascalCompiler.GetConstant(const Name: tbtString): TPSConstant; var h, i: Longint; n: tbtString; begin n := FastUppercase(name); h := MakeHash(n); for i := 0 to FConstants.Count -1 do begin result := TPSConstant(FConstants[i]); if (Result.NameHash = h) and (Result.Name = n) then exit; end; result := nil; end; {$IFDEF PS_USESSUPPORT} function TPSPascalCompiler.IsInLocalUnitList(s: tbtstring): Boolean; begin s:=FastUpperCase(s); if (s=FastUpperCase(fModule)) or (s='SYSTEM') then begin result:=true; exit; end; result:=fUnit.HasUses(S); end; {$ENDIF} { TPSType } constructor TPSType.Create; begin inherited Create; FAttributes := TPSAttributes.Create; FFinalTypeNo := InvalidVal; end; destructor TPSType.Destroy; begin FAttributes.Free; inherited Destroy; end; procedure TPSType.SetName(const Value: tbtString); begin FName := Value; FNameHash := MakeHash(Value); end; procedure TPSType.Use; begin FUsed := True; end; { TPSRecordType } function TPSRecordType.AddRecVal: PIFPSRecordFieldTypeDef; begin Result := TPSRecordFieldTypeDef.Create; FRecordSubVals.Add(Result); end; constructor TPSRecordType.Create; begin inherited Create; FRecordSubVals := TPSList.Create; end; destructor TPSRecordType.Destroy; var i: Longint; begin for i := FRecordSubVals.Count -1 downto 0 do TPSRecordFieldTypeDef(FRecordSubVals[I]).Free; FRecordSubVals.Free; inherited Destroy; end; function TPSRecordType.RecVal(I: Longint): PIFPSRecordFieldTypeDef; begin Result := FRecordSubVals[I] end; function TPSRecordType.RecValCount: Longint; begin Result := FRecordSubVals.Count; end; { TPSRegProc } constructor TPSRegProc.Create; begin inherited Create; FDecl := TPSParametersDecl.Create; end; destructor TPSRegProc.Destroy; begin FDecl.Free; inherited Destroy; end; procedure TPSRegProc.SetName(const Value: tbtString); begin FName := Value; FNameHash := MakeHash(FName); end; { TPSRecordFieldTypeDef } procedure TPSRecordFieldTypeDef.SetFieldOrgName(const Value: tbtString); begin FFieldOrgName := Value; FFieldName := FastUppercase(Value); FFieldNameHash := MakeHash(FFieldName); end; { TPSProcVar } procedure TPSProcVar.SetName(const Value: tbtString); begin FName := Value; FNameHash := MakeHash(FName); end; procedure TPSProcVar.Use; begin FUsed := True; end; { TPSInternalProcedure } constructor TPSInternalProcedure.Create; begin inherited Create; FProcVars := TPSList.Create; FLabels := TIfStringList.Create; FGotos := TIfStringList.Create; FDecl := TPSParametersDecl.Create; end; destructor TPSInternalProcedure.Destroy; var i: Longint; begin FDecl.Free; for i := FProcVars.Count -1 downto 0 do TPSProcVar(FProcVars[I]).Free; FProcVars.Free; FGotos.Free; FLabels.Free; inherited Destroy; end; procedure TPSInternalProcedure.ResultUse; begin FResultUsed := True; end; procedure TPSInternalProcedure.SetName(const Value: tbtString); begin FName := Value; FNameHash := MakeHash(FName); end; procedure TPSInternalProcedure.Use; begin FUsed := True; end; { TPSProcedure } constructor TPSProcedure.Create; begin inherited Create; FAttributes := TPSAttributes.Create; end; destructor TPSProcedure.Destroy; begin FAttributes.Free; inherited Destroy; end; { TPSVar } procedure TPSVar.SetName(const Value: tbtString); begin FName := Value; FNameHash := MakeHash(Value); end; procedure TPSVar.Use; begin FUsed := True; end; { TPSConstant } destructor TPSConstant.Destroy; begin DisposeVariant(Value); inherited Destroy; end; procedure TPSConstant.SetChar(c: tbtChar); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btChar: FValue.tchar := c; btString: tbtString(FValue.tstring) := c; {$IFNDEF PS_NOWIDESTRING} btWideString: tbtwidestring(FValue.twidestring) := tbtWidestring(c); btUnicodeString: tbtUnicodestring(FValue.twidestring) := tbtUnicodestring(c); {$ENDIF} else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; procedure TPSConstant.SetExtended(const Val: Extended); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btSingle: FValue.tsingle := Val; btDouble: FValue.tdouble := Val; btExtended: FValue.textended := Val; btCurrency: FValue.tcurrency := Val; else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; procedure TPSConstant.SetInt(const Val: Longint); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btEnum: FValue.tu32 := Val; btU32, btS32: FValue.ts32 := Val; btU16, btS16: FValue.ts16 := Val; btU8, btS8: FValue.ts8 := Val; btSingle: FValue.tsingle := Val; btDouble: FValue.tdouble := Val; btExtended: FValue.textended := Val; btCurrency: FValue.tcurrency := Val; {$IFNDEF PS_NOINT64} bts64: FValue.ts64 := Val; {$ENDIF} else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; {$IFNDEF PS_NOINT64} procedure TPSConstant.SetInt64(const Val: Int64); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btEnum: FValue.tu32 := Val; btU32, btS32: FValue.ts32 := Val; btU16, btS16: FValue.ts16 := Val; btU8, btS8: FValue.ts8 := Val; btSingle: FValue.tsingle := Val; btDouble: FValue.tdouble := Val; btExtended: FValue.textended := Val; btCurrency: FValue.tcurrency := Val; bts64: FValue.ts64 := Val; else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; {$ENDIF} procedure TPSConstant.SetName(const Value: tbtString); begin FName := Value; FNameHash := MakeHash(Value); end; procedure TPSConstant.SetSet(const val); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btSet: begin if length(tbtstring(FValue.tstring)) <> TPSSetType(FValue.FType).ByteSize then SetLength(tbtstring(FValue.tstring), TPSSetType(FValue.FType).ByteSize); Move(Val, FValue.tstring^, TPSSetType(FValue.FType).ByteSize); end; else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; procedure TPSConstant.SetString(const Val: tbtString); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btChar: FValue.tchar := (Val+#0)[1]; btWideChar: FValue.twidechar := WideChar((Val+#0)[1]); btString: tbtString(FValue.tstring) := val; {$IFNDEF PS_NOWIDESTRING} btWideString: tbtwidestring(FValue.twidestring) := tbtwidestring(val); btUnicodeString: tbtunicodestring(FValue.tunistring) := tbtunicodestring(val); {$ENDIF} else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; procedure TPSConstant.SetUInt(const Val: Cardinal); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btEnum: FValue.tu32 := Val; btU32, btS32: FValue.tu32 := Val; btU16, btS16: FValue.tu16 := Val; btU8, btS8: FValue.tu8 := Val; btSingle: FValue.tsingle := Val; btDouble: FValue.tdouble := Val; btExtended: FValue.textended := Val; btCurrency: FValue.tcurrency := Val; {$IFNDEF PS_NOINT64} bts64: FValue.ts64 := Val; {$ENDIF} else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; {$IFNDEF PS_NOWIDESTRING} procedure TPSConstant.SetWideChar(const val: WideChar); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btString: tbtString(FValue.tstring) := tbtstring(val); btWideChar: FValue.twidechar := val; btWideString: tbtwidestring(FValue.twidestring) := val; btUnicodeString: tbtUnicodestring(FValue.tUniString) := val; else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; procedure TPSConstant.SetWideString(const val: tbtwidestring); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btString: tbtString(FValue.tstring) := tbtstring(val); btWideString: tbtwidestring(FValue.twidestring) := val; btUnicodeString: tbtunicodestring(FValue.tunistring) := val; else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; procedure TPSConstant.SetUnicodeString(const val: tbtunicodestring); begin if (FValue <> nil) then begin case FValue.FType.BaseType of btString: tbtString(FValue.tstring) := tbtstring(val); btWideString: tbtwidestring(FValue.twidestring) := val; btUnicodeString: tbtunicodestring(FValue.tunistring) := val; else raise EPSCompilerException.Create(RPS_ConstantValueMismatch); end; end else raise EPSCompilerException.Create(RPS_ConstantValueNotAssigned) end; {$ENDIF} { TPSPascalCompilerError } function TPSPascalCompilerError.ErrorType: tbtString; begin Result := tbtstring(RPS_Error); end; function TPSPascalCompilerError.ShortMessageToString: tbtString; begin case Error of ecUnknownIdentifier: Result := tbtstring(Format (RPS_UnknownIdentifier, [Param])); ecIdentifierExpected: Result := tbtstring(RPS_IdentifierExpected); ecCommentError: Result := tbtstring(RPS_CommentError); ecStringError: Result := tbtstring(RPS_StringError); ecCharError: Result := tbtstring(RPS_CharError); ecSyntaxError: Result := tbtstring(RPS_SyntaxError); ecUnexpectedEndOfFile: Result := tbtstring(RPS_EOF); ecSemicolonExpected: Result := tbtstring(RPS_SemiColonExpected); ecBeginExpected: Result := tbtstring(RPS_BeginExpected); ecPeriodExpected: Result := tbtstring(RPS_PeriodExpected); ecDuplicateIdentifier: Result := tbtstring(Format (RPS_DuplicateIdent, [Param])); ecColonExpected: Result := tbtstring(RPS_ColonExpected); ecUnknownType: Result := tbtstring(Format (RPS_UnknownType, [Param])); ecCloseRoundExpected: Result := tbtstring(RPS_CloseRoundExpected); ecTypeMismatch: Result := tbtstring(RPS_TypeMismatch); ecInternalError: Result := tbtstring(Format (RPS_InternalError, [Param])); ecAssignmentExpected: Result := tbtstring(RPS_AssignmentExpected); ecThenExpected: Result := tbtstring(RPS_ThenExpected); ecDoExpected: Result := tbtstring(RPS_DoExpected); ecNoResult: Result := tbtstring(RPS_NoResult); ecOpenRoundExpected: Result := tbtstring(RPS_OpenRoundExpected); ecCommaExpected: Result := tbtstring(RPS_CommaExpected); ecToExpected: Result := tbtstring(RPS_ToExpected); ecIsExpected: Result := tbtstring(RPS_IsExpected); ecOfExpected: Result := tbtstring(RPS_OfExpected); ecCloseBlockExpected: Result := tbtstring(RPS_CloseBlockExpected); ecVariableExpected: Result := tbtstring(RPS_VariableExpected); ecStringExpected: result := tbtstring(RPS_StringExpected); ecEndExpected: Result := tbtstring(RPS_EndExpected); ecUnSetLabel: Result := tbtstring(Format (RPS_UnSetLabel, [Param])); ecNotInLoop: Result := tbtstring(RPS_NotInLoop); ecInvalidJump: Result := tbtstring(RPS_InvalidJump); ecOpenBlockExpected: Result := tbtstring(RPS_OpenBlockExpected); ecWriteOnlyProperty: Result := tbtstring(RPS_WriteOnlyProperty); ecReadOnlyProperty: Result := tbtstring(RPS_ReadOnlyProperty); ecClassTypeExpected: Result := tbtstring(RPS_ClassTypeExpected); ecCustomError: Result := Param; ecDivideByZero: Result := tbtstring(RPS_DivideByZero); ecMathError: Result := tbtstring(RPS_MathError); ecUnsatisfiedForward: Result := tbtstring(Format (RPS_UnsatisfiedForward, [Param])); ecForwardParameterMismatch: Result := tbtstring(RPS_ForwardParameterMismatch); ecInvalidnumberOfParameters: Result := tbtstring(RPS_InvalidNumberOfParameter); {$IFDEF PS_USESSUPPORT} ecNotAllowed : Result:=tbtstring(Format(RPS_NotAllowed,[Param])); ecUnitNotFoundOrContainsErrors: Result:=tbtstring(Format(RPS_UnitNotFound,[Param])); ecCrossReference: Result:=Format(RPS_CrossReference,[Param]); {$ENDIF} else Result := tbtstring(RPS_UnknownError); end; Result := Result; end; { TPSPascalCompilerHint } function TPSPascalCompilerHint.ErrorType: tbtString; begin Result := tbtstring(RPS_Hint); end; function TPSPascalCompilerHint.ShortMessageToString: tbtString; begin case Hint of ehVariableNotUsed: Result := tbtstring(Format (RPS_VariableNotUsed, [Param])); ehFunctionNotUsed: Result := tbtstring(Format (RPS_FunctionNotUsed, [Param])); ehCustomHint: Result := Param; else Result := tbtstring(RPS_UnknownHint); end; end; { TPSPascalCompilerWarning } function TPSPascalCompilerWarning.ErrorType: tbtString; begin Result := tbtstring(RPS_Warning); end; function TPSPascalCompilerWarning.ShortMessageToString: tbtString; begin case Warning of ewCustomWarning: Result := Param; ewCalculationAlwaysEvaluatesTo: Result := tbtstring(Format (RPS_CalculationAlwaysEvaluatesTo, [Param])); ewIsNotNeeded: Result := tbtstring(Format (RPS_IsNotNeeded, [Param])); ewAbstractClass: Result := tbtstring(RPS_AbstractClass); else Result := tbtstring(RPS_UnknownWarning); end; end; { TPSPascalCompilerMessage } function TPSPascalCompilerMessage.MessageToString: tbtString; begin Result := '['+ErrorType+'] '+FModuleName+'('+IntToStr(FRow)+':'+IntToStr(FCol)+'): '+ShortMessageToString; end; procedure TPSPascalCompilerMessage.SetParserPos(Parser: TPSPascalParser); begin FPosition := Parser.CurrTokenPos; FRow := Parser.Row; FCol := Parser.Col; end; procedure TPSPascalCompilerMessage.SetCustomPos(Pos, Row, Col: Cardinal); begin FPosition := Pos; FRow := Row; FCol := Col; end; { TUnConstOperation } destructor TUnConstOperation.Destroy; begin FVal1.Free; inherited Destroy; end; { TBinConstOperation } destructor TBinConstOperation.Destroy; begin FVal1.Free; FVal2.Free; inherited Destroy; end; { TConstData } destructor TConstData.Destroy; begin DisposeVariant(FData); inherited Destroy; end; { TConstOperation } procedure TConstOperation.SetPos(Parser: TPSPascalParser); begin FDeclPosition := Parser.CurrTokenPos; FDeclRow := Parser.Row; FDeclCol := Parser.Col; end; { TPSValue } procedure TPSValue.SetParserPos(P: TPSPascalParser); begin FPos := P.CurrTokenPos; FRow := P.Row; FCol := P.Col; end; { TPSValueData } destructor TPSValueData.Destroy; begin DisposeVariant(FData); inherited Destroy; end; { TPSValueReplace } constructor TPSValueReplace.Create; begin FFreeNewValue := True; FReplaceTimes := 1; end; destructor TPSValueReplace.Destroy; begin if FFreeOldValue then FOldValue.Free; if FFreeNewValue then FNewValue.Free; inherited Destroy; end; { TPSUnValueOp } destructor TPSUnValueOp.Destroy; begin FVal1.Free; inherited Destroy; end; { TPSBinValueOp } destructor TPSBinValueOp.Destroy; begin FVal1.Free; FVal2.Free; inherited Destroy; end; { TPSSubValue } destructor TPSSubValue.Destroy; begin FSubNo.Free; inherited Destroy; end; { TPSValueVar } constructor TPSValueVar.Create; begin inherited Create; FRecItems := TPSList.Create; end; destructor TPSValueVar.Destroy; var i: Longint; begin for i := 0 to FRecItems.Count -1 do begin TPSSubItem(FRecItems[I]).Free; end; FRecItems.Free; inherited Destroy; end; function TPSValueVar.GetRecCount: Cardinal; begin Result := FRecItems.Count; end; function TPSValueVar.GetRecItem(I: Cardinal): TPSSubItem; begin Result := FRecItems[I]; end; function TPSValueVar.RecAdd(Val: TPSSubItem): Cardinal; begin Result := FRecItems.Add(Val); end; procedure TPSValueVar.RecDelete(I: Cardinal); var rr :TPSSubItem; begin rr := FRecItems[i]; FRecItems.Delete(I); rr.Free; end; { TPSValueProc } destructor TPSValueProc.Destroy; begin FSelfPtr.Free; FParameters.Free; end; { TPSParameter } destructor TPSParameter.Destroy; begin FTempVar.Free; FValue.Free; inherited Destroy; end; { TPSParameters } function TPSParameters.Add: TPSParameter; begin Result := TPSParameter.Create; FItems.Add(Result); end; constructor TPSParameters.Create; begin inherited Create; FItems := TPSList.Create; end; procedure TPSParameters.Delete(I: Cardinal); var p: TPSParameter; begin p := FItems[I]; FItems.Delete(i); p.Free; end; destructor TPSParameters.Destroy; var i: Longint; begin for i := FItems.Count -1 downto 0 do begin TPSParameter(FItems[I]).Free; end; FItems.Free; inherited Destroy; end; function TPSParameters.GetCount: Cardinal; begin Result := FItems.Count; end; function TPSParameters.GetItem(I: Longint): TPSParameter; begin Result := FItems[I]; end; { TPSValueArray } function TPSValueArray.Add(Item: TPSValue): Cardinal; begin Result := FItems.Add(Item); end; constructor TPSValueArray.Create; begin inherited Create; FItems := TPSList.Create; end; procedure TPSValueArray.Delete(I: Cardinal); begin FItems.Delete(i); end; destructor TPSValueArray.Destroy; var i: Longint; begin for i := FItems.Count -1 downto 0 do TPSValue(FItems[I]).Free; FItems.Free; inherited Destroy; end; function TPSValueArray.GetCount: Cardinal; begin Result := FItems.Count; end; function TPSValueArray.GetItem(I: Cardinal): TPSValue; begin Result := FItems[I]; end; { TPSValueAllocatedStackVar } destructor TPSValueAllocatedStackVar.Destroy; var pv: TPSProcVar; begin {$IFDEF DEBUG} if Cardinal(LocalVarNo +1) <> proc.ProcVars.Count then begin Abort; exit; end; {$ENDIF} if Proc <> nil then begin pv := Proc.ProcVars[Proc.ProcVars.Count -1]; Proc.ProcVars.Delete(Proc.ProcVars.Count -1); pv.Free; Proc.Data := Proc.Data + tbtChar(CM_PO); end; inherited Destroy; end; function AddImportedClassVariable(Sender: TPSPascalCompiler; const VarName, VarType: tbtString): Boolean; var P: TPSVar; begin P := Sender.AddVariableN(VarName, VarType); if p = nil then begin Result := False; Exit; end; SetVarExportName(P, FastUppercase(VarName)); p.Use; Result := True; end; {'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params For property write functions there is an '@' after the funcname. } const ProcHDR = 'procedure a;'; { TPSCompileTimeClass } function TPSCompileTimeClass.CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; var P: TPSExternalProcedure; begin if (IntoType <> nil) and (IntoType.BaseType <> btClass) and (IntoType.BaseType <> btInterface) then begin Result := False; exit; end; if FCastProc <> InvalidVal then begin Procno := FCastProc; Result := True; exit; end; ProcNo := FOwner. AddUsedFunction2(P); P.RegProc := FOwner.AddFunction(ProcHDR); P.RegProc.Name := ''; with P.RegProc.Decl.AddParam do begin OrgName := 'Org'; aType := Self.FType; end; with P.RegProc.Decl.AddParam do begin OrgName := 'TypeNo'; aType := FOwner.at2ut(FOwner.FindBaseType(btU32)); end; P.RegProc.Decl.Result := IntoType; P.RegProc.ImportDecl := 'class:+'; FCastProc := ProcNo; Result := True; end; function TPSCompileTimeClass.ClassFunc_Call(Index: IPointer; var ProcNo: Cardinal): Boolean; var C: TPSDelphiClassItemConstructor; P: TPSExternalProcedure; s: tbtString; i: Longint; begin if FIsAbstract then FOwner.MakeWarning('', ewAbstractClass, ''); C := Pointer(Index); if c.MethodNo = InvalidVal then begin ProcNo := FOwner.AddUsedFunction2(P); P.RegProc := FOwner.AddFunction(ProcHDR); P.RegProc.Name := ''; P.RegProc.Decl.Assign(c.Decl); s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0); if c.Decl.Result = nil then s := s + #0 else s := s + #1; for i := 0 to C.Decl.ParamCount -1 do begin if c.Decl.Params[i].Mode <> pmIn then s := s + #1 else s := s + #0; end; P.RegProc.ImportDecl := s; C.MethodNo := ProcNo; end else begin ProcNo := c.MethodNo; end; Result := True; end; function TPSCompileTimeClass.ClassFunc_Find(const Name: tbtString; var Index: IPointer): Boolean; var H: Longint; I: Longint; CurrClass: TPSCompileTimeClass; C: TPSDelphiClassItem; begin H := MakeHash(Name); CurrClass := Self; while CurrClass <> nil do begin for i := CurrClass.FClassItems.Count -1 downto 0 do begin C := CurrClass.FClassItems[I]; if (c is TPSDelphiClassItemConstructor) and (C.NameHash = H) and (C.Name = Name) then begin Index := Cardinal(C); Result := True; exit; end; end; CurrClass := CurrClass.FInheritsFrom; end; Result := False; end; class function TPSCompileTimeClass.CreateC(FClass: TClass; aOwner: TPSPascalCompiler; aType: TPSType): TPSCompileTimeClass; begin Result := TPSCompileTimeClass.Create(FastUpperCase(tbtstring(FClass.ClassName)), aOwner, aType); Result.FClass := FClass; end; constructor TPSCompileTimeClass.Create(ClassName: tbtString; aOwner: TPSPascalCompiler; aType: TPSType); begin inherited Create; FType := aType; FCastProc := InvalidVal; FNilProc := InvalidVal; FDefaultProperty := InvalidVal; FClassName := Classname; FClassNameHash := MakeHash(FClassName); FClassItems := TPSList.Create; FOwner := aOwner; end; destructor TPSCompileTimeClass.Destroy; var I: Longint; begin for i := FClassItems.Count -1 downto 0 do TPSDelphiClassItem(FClassItems[I]).Free; FClassItems.Free; inherited Destroy; end; function TPSCompileTimeClass.Func_Call(Index: IPointer; var ProcNo: Cardinal): Boolean; var C: TPSDelphiClassItemMethod; P: TPSExternalProcedure; i: Longint; s: tbtString; begin C := Pointer(Index); if c.MethodNo = InvalidVal then begin ProcNo := FOwner.AddUsedFunction2(P); P.RegProc := FOwner.AddFunction(ProcHDR); P.RegProc.Name := ''; p.RegProc.Decl.Assign(c.Decl); s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+ chr(0); if c.Decl.Result = nil then s := s + #0 else s := s + #1; for i := 0 to c.Decl.ParamCount -1 do begin if c.Decl.Params[i].Mode <> pmIn then s := s + #1 else s := s + #0; end; P.RegProc.ImportDecl := s; C.MethodNo := ProcNo; end else begin ProcNo := c.MethodNo; end; Result := True; end; function TPSCompileTimeClass.Func_Find(const Name: tbtString; var Index: IPointer): Boolean; var H: Longint; I: Longint; CurrClass: TPSCompileTimeClass; C: TPSDelphiClassItem; begin H := MakeHash(Name); CurrClass := Self; while CurrClass <> nil do begin for i := CurrClass.FClassItems.Count -1 downto 0 do begin C := CurrClass.FClassItems[I]; if (c is TPSDelphiClassItemMethod) and (C.NameHash = H) and (C.Name = Name) then begin Index := Cardinal(C); Result := True; exit; end; end; CurrClass := CurrClass.FInheritsFrom; end; Result := False; end; function TPSCompileTimeClass.GetCount: Longint; begin Result := FClassItems.Count; end; function TPSCompileTimeClass.GetItem(i: Longint): TPSDelphiClassItem; begin Result := FClassItems[i]; end; function TPSCompileTimeClass.IsCompatibleWith(aType: TPSType): Boolean; var Temp: TPSCompileTimeClass; begin if (atype.BaseType <> btClass) then begin Result := False; exit; end; temp := TPSClassType(aType).Cl; while Temp <> nil do begin if Temp = Self then begin Result := True; exit; end; Temp := Temp.FInheritsFrom; end; Result := False; end; function TPSCompileTimeClass.Property_Find(const Name: tbtString; var Index: IPointer): Boolean; var H: Longint; I: Longint; CurrClass: TPSCompileTimeClass; C: TPSDelphiClassItem; begin if Name = '' then begin CurrClass := Self; while CurrClass <> nil do begin if CurrClass.FDefaultProperty <> InvalidVal then begin Index := Cardinal(CurrClass.FClassItems[Currclass.FDefaultProperty]); result := True; exit; end; CurrClass := CurrClass.FInheritsFrom; end; Result := False; exit; end; H := MakeHash(Name); CurrClass := Self; while CurrClass <> nil do begin for i := CurrClass.FClassItems.Count -1 downto 0 do begin C := CurrClass.FClassItems[I]; if (c is TPSDelphiClassItemProperty) and (C.NameHash = H) and (C.Name = Name) then begin Index := Cardinal(C); Result := True; exit; end; end; CurrClass := CurrClass.FInheritsFrom; end; Result := False; end; function TPSCompileTimeClass.Property_Get(Index: IPointer; var ProcNo: Cardinal): Boolean; var C: TPSDelphiClassItemProperty; P: TPSExternalProcedure; s: tbtString; begin C := Pointer(Index); if c.AccessType = iptW then begin Result := False; exit; end; if c.ReadProcNo = InvalidVal then begin ProcNo := FOwner.AddUsedFunction2(P); P.RegProc := FOwner.AddFunction(ProcHDR); P.RegProc.Name := ''; P.RegProc.Decl.Result := C.Decl.Result; s := 'class:' + C.Owner.FClassName + '|' + C.Name + '|'+#0#0#0#0; Longint((@(s[length(s)-3]))^) := c.Decl.ParamCount +1; P.RegProc.ImportDecl := s; C.ReadProcNo := ProcNo; end else begin ProcNo := c.ReadProcNo; end; Result := True; end; function TPSCompileTimeClass.Property_GetHeader(Index: IPointer; Dest: TPSParametersDecl): Boolean; var c: TPSDelphiClassItemProperty; begin C := Pointer(Index); FOwner.UseProc(c.Decl); Dest.Assign(c.Decl); Result := True; end; function TPSCompileTimeClass.Property_Set(Index: IPointer; var ProcNo: Cardinal): Boolean; var C: TPSDelphiClassItemProperty; P: TPSExternalProcedure; s: tbtString; begin C := Pointer(Index); if c.AccessType = iptR then begin Result := False; exit; end; if c.WriteProcNo = InvalidVal then begin ProcNo := FOwner.AddUsedFunction2(P); P.RegProc := FOwner.AddFunction(ProcHDR); P.RegProc.Name := ''; s := 'class:' + C.Owner.FClassName + '|' + C.Name + '@|'#0#0#0#0; Longint((@(s[length(s)-3]))^) := C.Decl.ParamCount+1; P.RegProc.ImportDecl := s; C.WriteProcNo := ProcNo; end else begin ProcNo := c.WriteProcNo; end; Result := True; end; function TPSCompileTimeClass.RegisterMethod(const Decl: tbtString): Boolean; var DOrgName: tbtString; DDecl: TPSParametersDecl; FT: TPMFuncType; p: TPSDelphiClassItemMethod; begin DDecl := TPSParametersDecl.Create; try if not ParseMethod(FOwner, FClassName, Decl, DOrgName, DDecl, FT) then begin Result := False; {$IFDEF DEBUG} raise EPSCompilerException.CreateFmt(RPS_UnableToRegister, [Decl]); {$ENDIF} exit; end; if ft = mftConstructor then p := TPSDelphiClassItemConstructor.Create(Self) else p := TPSDelphiClassItemMethod.Create(self); p.OrgName := DOrgName; p.Decl.Assign(DDecl); p.MethodNo := InvalidVal; FClassItems.Add(p); Result := True; finally DDecl.Free; end; end; procedure TPSCompileTimeClass.RegisterProperty(const PropertyName, PropertyType: tbtString; PropAC: TPSPropType); var FType: TPSType; Param: TPSParameterDecl; p: TPSDelphiClassItemProperty; PT: tbtString; begin pt := PropertyType; p := TPSDelphiClassItemProperty.Create(Self); p.AccessType := PropAC; p.ReadProcNo := InvalidVal; p.WriteProcNo := InvalidVal; p.OrgName := PropertyName; repeat FType := FOwner.FindType(FastUpperCase(grfw(pt))); if FType = nil then begin p.Free; Exit; end; if p.Decl.Result = nil then p.Decl.Result := FType else begin param := p.Decl.AddParam; Param.OrgName := 'param'+IntToStr(p.Decl.ParamCount); Param.aType := FType; end; until pt = ''; FClassItems.Add(p); end; procedure TPSCompileTimeClass.RegisterPublishedProperties; var p: PPropList; i, Count: Longint; a: TPSPropType; begin if (Fclass = nil) or (Fclass.ClassInfo = nil) then exit; Count := GetTypeData(fclass.ClassInfo)^.PropCount; GetMem(p, Count * SizeOf(Pointer)); GetPropInfos(fclass.ClassInfo, p); for i := Count -1 downto 0 do begin if p^[i]^.PropType^.Kind in [tkLString, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod{$IFNDEF PS_NOWIDESTRING}, tkWString{$ENDIF}] then begin if (p^[i]^.GetProc <> nil) then begin if p^[i]^.SetProc = nil then a := iptr else a := iptrw; end else begin a := iptW; if p^[i]^.SetProc = nil then continue; end; RegisterProperty(p^[i]^.Name, p^[i]^.PropType^.Name, a); end; end; FreeMem(p); end; function TPSCompileTimeClass.RegisterPublishedProperty(const Name: tbtString): Boolean; var p: PPropInfo; a: TPSPropType; begin if (Fclass = nil) or (Fclass.ClassInfo = nil) then begin Result := False; exit; end; p := GetPropInfo(fclass.ClassInfo, string(Name)); if p = nil then begin Result := False; exit; end; if (p^.GetProc <> nil) then begin if p^.SetProc = nil then a := iptr else a := iptrw; end else begin a := iptW; if p^.SetProc = nil then begin result := False; exit; end; end; RegisterProperty(p^.Name, p^.PropType^.Name, a); Result := True; end; procedure TPSCompileTimeClass.SetDefaultPropery(const Name: tbtString); var i,h: Longint; p: TPSDelphiClassItem; s: tbtString; begin s := FastUppercase(name); h := MakeHash(s); for i := FClassItems.Count -1 downto 0 do begin p := FClassItems[i]; if (p.NameHash = h) and (p.Name = s) then begin if p is TPSDelphiClassItemProperty then begin if p.Decl.ParamCount = 0 then Raise EPSCompilerException.Create(RPS_NotArrayProperty); FDefaultProperty := I; exit; end else Raise EPSCompilerException.Create(RPS_NotProperty); end; end; raise EPSCompilerException.Create(RPS_UnknownProperty); end; function TPSCompileTimeClass.SetNil(var ProcNo: Cardinal): Boolean; var P: TPSExternalProcedure; begin if FNilProc <> InvalidVal then begin Procno := FNilProc; Result := True; exit; end; ProcNo := FOwner.AddUsedFunction2(P); P.RegProc := FOwner.AddFunction(ProcHDR); P.RegProc.Name := ''; with P.RegProc.Decl.AddParam do begin OrgName := 'VarNo'; aType := FOwner.at2ut(FType); end; P.RegProc.ImportDecl := 'class:-'; FNilProc := Procno; Result := True; end; { TPSSetType } function TPSSetType.GetBitSize: Longint; begin case SetType.BaseType of btEnum: begin Result := TPSEnumType(setType).HighValue+1; end; btChar, btU8: Result := 256; else Result := 0; end; end; function TPSSetType.GetByteSize: Longint; var r: Longint; begin r := BitSize; if r mod 8 <> 0 then inc(r, 7); Result := r div 8; end; { TPSBlockInfo } procedure TPSBlockInfo.Clear; var i: Longint; begin for i := WithList.Count -1 downto 0 do begin TPSValue(WithList[i]).Free; WithList.Delete(i); end; end; constructor TPSBlockInfo.Create(Owner: TPSBlockInfo); begin inherited Create; FOwner := Owner; FWithList := TPSList.Create; if FOwner <> nil then begin FProcNo := FOwner.ProcNo; FProc := FOwner.Proc; end; end; destructor TPSBlockInfo.Destroy; begin Clear; FWithList.Free; inherited Destroy; end; { TPSAttributeTypeField } procedure TPSAttributeTypeField.SetFieldOrgName(const Value: tbtString); begin FFieldOrgName := Value; FFieldName := FastUpperCase(Value); FFieldNameHash := MakeHash(FFieldName); end; constructor TPSAttributeTypeField.Create(AOwner: TPSAttributeType); begin inherited Create; FOwner := AOwner; end; { TPSAttributeType } function TPSAttributeType.GetField(I: Longint): TPSAttributeTypeField; begin Result := TPSAttributeTypeField(FFields[i]); end; function TPSAttributeType.GetFieldCount: Longint; begin Result := FFields.Count; end; procedure TPSAttributeType.SetName(const s: tbtString); begin FOrgname := s; FName := FastUppercase(s); FNameHash := MakeHash(FName); end; constructor TPSAttributeType.Create; begin inherited Create; FFields := TPSList.Create; end; destructor TPSAttributeType.Destroy; var i: Longint; begin for i := FFields.Count -1 downto 0 do begin TPSAttributeTypeField(FFields[i]).Free; end; FFields.Free; inherited Destroy; end; function TPSAttributeType.AddField: TPSAttributeTypeField; begin Result := TPSAttributeTypeField.Create(self); FFields.Add(Result); end; procedure TPSAttributeType.DeleteField(I: Longint); var Fld: TPSAttributeTypeField; begin Fld := FFields[i]; FFields.Delete(i); Fld.Free; end; { TPSAttribute } function TPSAttribute.GetValueCount: Longint; begin Result := FValues.Count; end; function TPSAttribute.GetValue(I: Longint): PIfRVariant; begin Result := FValues[i]; end; constructor TPSAttribute.Create(AttribType: TPSAttributeType); begin inherited Create; FValues := TPSList.Create; FAttribType := AttribType; end; procedure TPSAttribute.DeleteValue(i: Longint); var Val: PIfRVariant; begin Val := FValues[i]; FValues.Delete(i); DisposeVariant(Val); end; function TPSAttribute.AddValue(v: PIFRVariant): Longint; begin Result := FValues.Add(v); end; destructor TPSAttribute.Destroy; var i: Longint; begin for i := FValues.Count -1 downto 0 do begin DisposeVariant(FValues[i]); end; FValues.Free; inherited Destroy; end; procedure TPSAttribute.Assign(Item: TPSAttribute); var i: Longint; p: PIfRVariant; begin for i := FValues.Count -1 downto 0 do begin DisposeVariant(FValues[i]); end; FValues.Clear; FAttribType := Item.FAttribType; for i := 0 to Item.FValues.Count -1 do begin p := DuplicateVariant(Item.FValues[i]); FValues.Add(p); end; end; { TPSAttributes } function TPSAttributes.GetCount: Longint; begin Result := FItems.Count; end; function TPSAttributes.GetItem(I: Longint): TPSAttribute; begin Result := TPSAttribute(FItems[i]); end; procedure TPSAttributes.Delete(i: Longint); var item: TPSAttribute; begin item := TPSAttribute(FItems[i]); FItems.Delete(i); Item.Free; end; function TPSAttributes.Add(AttribType: TPSAttributeType): TPSAttribute; begin Result := TPSAttribute.Create(AttribType); FItems.Add(Result); end; constructor TPSAttributes.Create; begin inherited Create; FItems := TPSList.Create; end; destructor TPSAttributes.Destroy; var i: Longint; begin for i := FItems.Count -1 downto 0 do begin TPSAttribute(FItems[i]).Free; end; FItems.Free; inherited Destroy; end; procedure TPSAttributes.Assign(attr: TPSAttributes; Move: Boolean); var newitem, item: TPSAttribute; i: Longint; begin for i := ATtr.FItems.Count -1 downto 0 do begin Item := Attr.Fitems[i]; if Move then begin FItems.Add(Item); Attr.FItems.Delete(i); end else begin newitem := TPSAttribute.Create(Item.FAttribType ); newitem.Assign(item); FItems.Add(NewItem); end; end; end; function TPSAttributes.FindAttribute( const Name: tbtString): TPSAttribute; var h, i: Longint; begin h := MakeHash(name); for i := FItems.Count -1 downto 0 do begin Result := FItems[i]; if (Result.FAttribType.NameHash = h) and (Result.FAttribType.Name = Name) then exit; end; result := nil; end; { TPSParameterDecl } procedure TPSParameterDecl.SetName(const s: tbtString); begin FOrgName := s; FName := FastUppercase(s); end; { TPSParametersDecl } procedure TPSParametersDecl.Assign(Params: TPSParametersDecl); var i: Longint; np, orgp: TPSParameterDecl; begin for i := FParams.Count -1 downto 0 do begin TPSParameterDecl(Fparams[i]).Free; end; FParams.Clear; FResult := Params.Result; for i := 0 to Params.FParams.count -1 do begin orgp := Params.FParams[i]; np := AddParam; np.OrgName := orgp.OrgName; np.Mode := orgp.Mode; np.aType := orgp.aType; np.DeclarePos:=orgp.DeclarePos; np.DeclareRow:=orgp.DeclareRow; np.DeclareCol:=orgp.DeclareCol; end; end; function TPSParametersDecl.GetParam(I: Longint): TPSParameterDecl; begin Result := FParams[i]; end; function TPSParametersDecl.GetParamCount: Longint; begin Result := FParams.Count; end; function TPSParametersDecl.AddParam: TPSParameterDecl; begin Result := TPSParameterDecl.Create; FParams.Add(Result); end; procedure TPSParametersDecl.DeleteParam(I: Longint); var param: TPSParameterDecl; begin param := FParams[i]; FParams.Delete(i); Param.Free; end; constructor TPSParametersDecl.Create; begin inherited Create; FParams := TPSList.Create; end; destructor TPSParametersDecl.Destroy; var i: Longint; begin for i := FParams.Count -1 downto 0 do begin TPSParameterDecl(Fparams[i]).Free; end; FParams.Free; inherited Destroy; end; function TPSParametersDecl.Same(d: TPSParametersDecl): boolean; var i: Longint; begin if (d = nil) or (d.ParamCount <> ParamCount) or (d.Result <> Self.Result) then Result := False else begin for i := 0 to d.ParamCount -1 do begin if (d.Params[i].Mode <> Params[i].Mode) or (d.Params[i].aType <> Params[i].aType) then begin Result := False; exit; end; end; Result := True; end; end; { TPSProceduralType } constructor TPSProceduralType.Create; begin inherited Create; FProcDef := TPSParametersDecl.Create; end; destructor TPSProceduralType.Destroy; begin FProcDef.Free; inherited Destroy; end; { TPSDelphiClassItem } procedure TPSDelphiClassItem.SetName(const s: tbtString); begin FOrgName := s; FName := FastUpperCase(s); FNameHash := MakeHash(FName); end; constructor TPSDelphiClassItem.Create(Owner: TPSCompileTimeClass); begin inherited Create; FOwner := Owner; FDecl := TPSParametersDecl.Create; end; destructor TPSDelphiClassItem.Destroy; begin FDecl.Free; inherited Destroy; end; {$IFNDEF PS_NOINTERFACES} { TPSInterface } function TPSInterface.CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; var P: TPSExternalProcedure; begin if (IntoType <> nil) and (IntoType.BaseType <> btInterface) then begin Result := False; exit; end; if FCastProc <> InvalidVal then begin ProcNo := FCastProc; Result := True; exit; end; ProcNo := FOwner.AddUsedFunction2(P); P.RegProc := FOwner.AddFunction(ProcHDR); P.RegProc.Name := ''; with P.RegProc.Decl.AddParam do begin OrgName := 'Org'; aType := Self.FType; end; with P.RegProc.Decl.AddParam do begin OrgName := 'TypeNo'; aType := FOwner.at2ut(FOwner.FindBaseType(btU32)); end; P.RegProc.Decl.Result := FOwner.at2ut(IntoType); P.RegProc.ImportDecl := 'class:+'; FCastProc := ProcNo; Result := True; end; constructor TPSInterface.Create(Owner: TPSPascalCompiler; InheritedFrom: TPSInterface; Guid: TGuid; const Name: tbtString; aType: TPSType); begin inherited Create; FCastProc := InvalidVal; FNilProc := InvalidVal; FType := aType; FOWner := Owner; FGuid := GUID; Self.InheritedFrom := InheritedFrom; FItems := TPSList.Create; FName := Name; FNameHash := MakeHash(Name); end; procedure TPSInterface.SetInheritedFrom(p: TPSInterface); begin FInheritedFrom := p; end; destructor TPSInterface.Destroy; var i: Longint; begin for i := FItems.Count -1 downto 0 do begin TPSInterfaceMethod(FItems[i]).Free; end; FItems.Free; inherited Destroy; end; function TPSInterface.Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; var c: TPSInterfaceMethod; P: TPSExternalProcedure; s: tbtString; i: Longint; begin c := TPSInterfaceMethod(Index); if c.FScriptProcNo <> InvalidVal then begin Procno := c.FScriptProcNo; Result := True; exit; end; ProcNo := FOwner.AddUsedFunction2(P); P.RegProc := FOwner.AddFunction(ProcHDR); P.RegProc.Name := ''; FOwner.UseProc(C.Decl); P.RegProc.Decl.Assign(c.Decl); s := tbtstring('intf:.') + PS_mi2s(c.AbsoluteProcOffset) + tbtchar(ord(c.CC)); if c.Decl.Result = nil then s := s + #0 else s := s + #1; for i := 0 to C.Decl.ParamCount -1 do begin if c.Decl.Params[i].Mode <> pmIn then s := s + #1 else s := s + #0; end; P.RegProc.ImportDecl := s; C.FScriptProcNo := ProcNo; Result := True; end; function TPSInterface.Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; var H: Longint; I: Longint; CurrClass: TPSInterface; C: TPSInterfaceMethod; begin H := MakeHash(Name); CurrClass := Self; while CurrClass <> nil do begin for i := CurrClass.FItems.Count -1 downto 0 do begin C := CurrClass.FItems[I]; if (C.NameHash = H) and (C.Name = Name) then begin Index := Cardinal(c); Result := True; exit; end; end; CurrClass := CurrClass.FInheritedFrom; end; Result := False; end; function TPSInterface.IsCompatibleWith(aType: TPSType): Boolean; var Temp: TPSInterface; begin if (atype.BaseType = btClass) then // just support it, we'll see what happens begin Result := true; exit; end; if atype.BaseType <> btInterface then begin Result := False; exit; end; temp := TPSInterfaceType(atype).FIntf; while Temp <> nil do begin if Temp = Self then begin Result := True; exit; end; Temp := Temp.FInheritedFrom; end; Result := False; end; procedure TPSInterface.RegisterDummyMethod; begin FItems.Add(TPSInterfaceMethod.Create(self)); end; function TPSInterface.RegisterMethod(const Declaration: tbtString; const cc: TPSCallingConvention): Boolean; begin Result := RegisterMethodEx(Declaration, cc, nil); end; function TPSInterface.RegisterMethodEx(const Declaration: tbtString; const cc: TPSCallingConvention; const CustomParser: TPSPascalParser): Boolean; var M: TPSInterfaceMethod; DOrgName: tbtString; Func: TPMFuncType; begin M := TPSInterfaceMethod.Create(Self); if not ParseMethodEx(FOwner, '', Declaration, DOrgname, m.Decl, Func, CustomParser) then begin FItems.Add(m); // in any case, add a dummy item Result := False; exit; end; m.FName := FastUppercase(DOrgName); m.FOrgName := DOrgName; m.FNameHash := MakeHash(m.FName); m.FCC := CC; m.FScriptProcNo := InvalidVal; FItems.Add(M); Result := True; end; function TPSInterface.SetNil(var ProcNo: Cardinal): Boolean; var P: TPSExternalProcedure; begin if FNilProc <> InvalidVal then begin Procno := FNilProc; Result := True; exit; end; ProcNo := FOwner.AddUsedFunction2(P); P.RegProc := FOwner.AddFunction(ProcHDR); P.RegProc.Name := ''; with p.RegProc.Decl.AddParam do begin Mode := pmInOut; OrgName := 'VarNo'; aType := FOwner.at2ut(Self.FType); end; P.RegProc.ImportDecl := 'class:-'; FNilProc := Procno; Result := True; end; { TPSInterfaceMethod } constructor TPSInterfaceMethod.Create(Owner: TPSInterface); begin inherited Create; FDecl := TPSParametersDecl.Create; FOwner := Owner; FOffsetCache := InvalidVal; end; function TPSInterfaceMethod.GetAbsoluteProcOffset: Cardinal; var ps: TPSInterface; begin if FOffsetCache = InvalidVal then begin FOffsetCache := FOwner.FItems.IndexOf(Self); ps := FOwner.FInheritedFrom; while ps <> nil do begin FOffsetCache := FOffsetCache + ps.FItems.Count; ps := ps.FInheritedFrom; end; end; result := FOffsetCache; end; destructor TPSInterfaceMethod.Destroy; begin FDecl.Free; inherited Destroy; end; {$ENDIF} { TPSVariantType } function TPSVariantType.GetDynInvokeParamType(Owner: TPSPascalCompiler) : TPSType; begin Result := Owner.at2ut(FindAndAddType(owner, '!OPENARRAYOFVARIANT', 'array of variant')); end; function TPSVariantType.GetDynInvokeProcNo(Owner: TPSPascalCompiler; const Name: tbtString; Params: TPSParameters): Cardinal; begin Result := Owner.FindProc('IDISPATCHINVOKE'); end; function TPSVariantType.GetDynIvokeResulType( Owner: TPSPascalCompiler): TPSType; begin Result := Owner.FindType('VARIANT'); end; function TPSVariantType.GetDynIvokeSelfType(Owner: TPSPascalCompiler): TPSType; begin Result := Owner.at2ut(Owner.FindType('IDISPATCH')); end; { TPSExternalClass } function TPSExternalClass.SetNil(var ProcNo: Cardinal): Boolean; begin Result := False; end; constructor TPSExternalClass.Create(Se: TIFPSPascalCompiler; TypeNo: TPSType); begin inherited Create; Self.SE := se; Self.FTypeNo := TypeNo; end; function TPSExternalClass.Func_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; begin Result := False; end; function TPSExternalClass.Func_Find(const Name: tbtString; var Index: Cardinal): Boolean; begin Result := False; end; function TPSExternalClass.IsCompatibleWith( Cl: TPSExternalClass): Boolean; begin Result := False; end; function TPSExternalClass.SelfType: TPSType; begin Result := nil; end; function TPSExternalClass.CastToType(IntoType: TPSType; var ProcNo: Cardinal): Boolean; begin Result := False; end; function TPSExternalClass.CompareClass(OtherTypeNo: TPSType; var ProcNo: Cardinal): Boolean; begin Result := false; end; function TPSExternalClass.ClassFunc_Find(const Name: tbtString; var Index: Cardinal): Boolean; begin result := false; end; function TPSExternalClass.ClassFunc_Call(Index: Cardinal; var ProcNo: Cardinal): Boolean; begin result := false; end; { TPSValueProcVal } destructor TPSValueProcVal.Destroy; begin FProcNo.Free; inherited; end; { Internal error counter: 00020 (increase and then use) } end.