From 6ed7b60dc618fe906023d10a4c856b7f842b635b Mon Sep 17 00:00:00 2001 From: marco Date: Thu, 27 Apr 2017 16:40:51 +0000 Subject: [PATCH] --- Merging r34357 into '.': U packages/fcl-passrc/fpmake.pp A packages/fcl-passrc/tests/tcresolver.pas U packages/fcl-passrc/tests/testpassrc.lpi U packages/fcl-passrc/tests/tcbaseparser.pas U packages/fcl-passrc/tests/tcstatements.pas U packages/fcl-passrc/tests/tcscanner.pas U packages/fcl-passrc/tests/tcexprparser.pas U packages/fcl-passrc/tests/tctypeparser.pas U packages/fcl-passrc/tests/testpassrc.lpr U packages/fcl-passrc/tests/tconstparser.pas U packages/fcl-passrc/src/pparser.pp U packages/fcl-passrc/src/pastree.pp A packages/fcl-passrc/src/pasresolver.pp U packages/fcl-passrc/src/pscanner.pp U packages/pastojs/tests/tcconverter.pp U packages/pastojs/src/fppas2js.pp --- Recording mergeinfo for merge of r34357 into '.': U . --- Merging r34429 into '.': G packages/fcl-passrc/tests/tctypeparser.pas U packages/fcl-passrc/tests/tcresolver.pas G packages/fcl-passrc/tests/tcbaseparser.pas G packages/fcl-passrc/tests/tcstatements.pas G packages/fcl-passrc/src/pparser.pp G packages/fcl-passrc/src/pastree.pp U packages/fcl-passrc/src/pasresolver.pp G packages/fcl-passrc/src/pscanner.pp --- Recording mergeinfo for merge of r34429 into '.': G . # revisions: 34357,34429 git-svn-id: branches/fixes_3_0@35976 - --- .gitattributes | 2 + packages/fcl-passrc/fpmake.pp | 7 + packages/fcl-passrc/src/pasresolver.pp | 2395 ++++++++++++++++++++ packages/fcl-passrc/src/pastree.pp | 1018 +++++++-- packages/fcl-passrc/src/pparser.pp | 1021 +++++---- packages/fcl-passrc/src/pscanner.pp | 24 +- packages/fcl-passrc/tests/tcbaseparser.pas | 326 ++- packages/fcl-passrc/tests/tcexprparser.pas | 11 +- packages/fcl-passrc/tests/tconstparser.pas | 29 +- packages/fcl-passrc/tests/tcresolver.pas | 1424 ++++++++++++ packages/fcl-passrc/tests/tcscanner.pas | 3 - packages/fcl-passrc/tests/tcstatements.pas | 19 +- packages/fcl-passrc/tests/tctypeparser.pas | 11 +- packages/fcl-passrc/tests/testpassrc.lpi | 6 +- packages/fcl-passrc/tests/testpassrc.lpr | 2 +- packages/pastojs/src/fppas2js.pp | 694 ++++-- packages/pastojs/tests/tcconverter.pp | 20 +- 17 files changed, 6099 insertions(+), 913 deletions(-) create mode 100644 packages/fcl-passrc/src/pasresolver.pp create mode 100644 packages/fcl-passrc/tests/tcresolver.pas diff --git a/.gitattributes b/.gitattributes index 2ad5ebc858..56effdaa10 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2521,6 +2521,7 @@ packages/fcl-passrc/Makefile.fpc.fpcmake svneol=native#text/plain packages/fcl-passrc/examples/test_parser.pp svneol=native#text/plain packages/fcl-passrc/examples/testunit1.pp svneol=native#text/plain packages/fcl-passrc/fpmake.pp svneol=native#text/plain +packages/fcl-passrc/src/pasresolver.pp svneol=native#text/plain packages/fcl-passrc/src/passrcutil.pp svneol=native#text/plain packages/fcl-passrc/src/pastounittest.pp svneol=native#text/plain packages/fcl-passrc/src/pastree.pp svneol=native#text/plain @@ -2535,6 +2536,7 @@ packages/fcl-passrc/tests/tcmoduleparser.pas svneol=native#text/plain packages/fcl-passrc/tests/tconstparser.pas svneol=native#text/plain packages/fcl-passrc/tests/tcpassrcutil.pas svneol=native#text/plain packages/fcl-passrc/tests/tcprocfunc.pas svneol=native#text/plain +packages/fcl-passrc/tests/tcresolver.pas svneol=native#text/plain packages/fcl-passrc/tests/tcscanner.pas svneol=native#text/plain packages/fcl-passrc/tests/tcstatements.pas svneol=native#text/plain packages/fcl-passrc/tests/tctypeparser.pas svneol=native#text/plain diff --git a/packages/fcl-passrc/fpmake.pp b/packages/fcl-passrc/fpmake.pp index 045315259f..299e3e6ad9 100644 --- a/packages/fcl-passrc/fpmake.pp +++ b/packages/fcl-passrc/fpmake.pp @@ -39,6 +39,13 @@ begin AddUnit('pastree'); AddUnit('pscanner'); end; + T:=P.Targets.AddUnit('pasresolver.pp'); + with T.Dependencies do + begin + AddUnit('pastree'); + AddUnit('pscanner'); + AddUnit('pparser'); + end; T.ResourceStrings := True; T:=P.Targets.AddUnit('pastounittest.pp'); with T.Dependencies do diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp new file mode 100644 index 0000000000..d4585d552b --- /dev/null +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -0,0 +1,2395 @@ +{ + This file is part of the Free Component Library + + Pascal source parser + Copyright (c) 2000-2005 by + Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + ********************************************************************** + + Abstract: + Resolves references by setting TPasElement.CustomData as TResolvedReference. + Creates search scopes for elements with sub identifiers by setting + TPasElement.CustomData as TPasScope: unit, program, library, interface, + implementation, procs + + Works: + - built-in types as TPasUnresolvedSymbolRef: longint, int64, string, pointer, ... + - references in statements, error if not found + - interface and implementation types, vars, const + - params, local types, vars, const + - nested procedures + - search in used units + - unitname.identifier + - alias types, 'type a=b' + - type alias type 'type a=type b' + - choose the compatible overloaded procedure + - while do + - repeat until + - if then else + - binary operators + - case of + - try..finally..except, on, else, raise + - for loop + + ToDo: + - spot duplicates + - check if types only refer types + - nested forward procs, nested must be resolved before proc body + - program/library/implementation forward procs + - check if constant is longint or int64 + - built-in functions + - enums - TPasEnumType, TPasEnumValue + - propagate to parent scopes + - ranges TPasRangeType + - records - TPasRecordType, + - variant - TPasVariant + - const TRecordValues + - arrays TPasArrayType + - const TArrayValues + - pointer TPasPointerType + - untyped parameters + - sets - TPasSetType + - forwards of ^pointer and class of - must be queued and resolved at end of type section + - with - TPasImplWithDo + - classes - TPasClassType + - interfaces + - properties - TPasProperty + - read, write, index properties, implements, stored + - default property + - TPasResString + - TPasFileType + - generics, nested param lists + - visibility (private, protected, strict private, strict protected) + - check const expression types, e.g. bark on "const c:string=3;" + - dotted unitnames + - labels + - helpers + - generics + - many more: search for "ToDo:" + + Debug flags: -d + VerbosePasResolver +} +unit PasResolver; + +{$mode objfpc}{$H+} +{$inline on} + +interface + +uses + Classes, SysUtils, contnrs, PasTree, PParser, PScanner; + +const + ParserMaxEmbeddedColumn = 2048; + ParserMaxEmbeddedRow = $7fffffff div ParserMaxEmbeddedColumn; + +// message numbers +const + nIdentifierNotFound = 3001; + nNotYetImplemented = 3002; + nIllegalQualifier = 3003; + nSyntaxErrorExpectedButFound = 3004; + nWrongNumberOfParametersForCallTo = 3005; + nIncompatibleTypeArgNo = 3006; + nIncompatibleTypeArgNoVarParamMustMatchExactly = 3007; + nVariableIdentifierExpected = 3008; + +// resourcestring patterns of messages +resourcestring + sIdentifierNotFound = 'identifier not found "%s"'; + sNotYetImplemented = 'not yet implemented: %s'; + sIllegalQualifier = 'illegal qualifier "%s"'; + sSyntaxErrorExpectedButFound = 'Syntax error, "%s" expected but "%s" found'; + sWrongNumberOfParametersForCallTo = 'Wrong number of parameters specified for call to "%s"'; + sIncompatibleTypeArgNo = 'Incompatible type arg no. %s: Got "%s", expected "%s"'; + sIncompatibleTypeArgNoVarParamMustMatchExactly = 'Incompatible type arg no. %s: Got "%s", expected "%s". Var param must match exactly.'; + sVariableIdentifierExpected = 'Variable identifier expected'; + +type + TResolveBaseType = ( + btNone, // undefined + btContext, // a TPasType + btUntyped, // TPasArgument without ArgType + btChar, // char + btWideChar, // widechar + btString, // string + btAnsiString, // ansistring + btShortString, // shortstring + btWideString, // widestring + btUnicodeString,// unicodestring + btReal, // real platform, single or double + btSingle, // single 1.5E-45..3.4E38, digits 7-8, bytes 4 + btDouble, // double 5.0E-324..1.7E308, digits 15-16, bytes 8 + btExtended, // extended platform, double or 1.9E-4932..1.1E4932, digits 19-20, bytes 10 + btCExtended, // cextended + btComp, // comp -2E64+1..2E63-1, digits 19-20, bytes 8 + btCurrency, // currency ?, bytes 8 + btBoolean, // boolean + btByteBool, // bytebool true=not zero + btWordBool, // wordbool true=not zero + btLongBool, // longbool true=not zero + btQWordBool, // qwordbool true=not zero + btByte, // byte 0..255 + btShortInt, // shortint -128..127 + btWord, // word unsigned 2 bytes + btSmallInt, // smallint signed 2 bytes + btLongWord, // longword unsigned 4 bytes + btCardinal, // cardinal see longword + btLongint, // longint signed 4 bytes + btQWord, // qword 0..18446744073709551615, bytes 8 + btInt64, // int64 -9223372036854775808..9223372036854775807, bytes 8 + btPointer, // pointer + btFile, // file + btText, // text + btVariant, // variant + btNil, // nil = pointer, class, procedure, method, ... + btCompilerFunc// SUCC, PREC, LOW, HIGH, ORD, LENGTH, COPY + ); + TResolveBaseTypes = set of TResolveBaseType; +const + btAllNumbers = [btComp,btCurrency,btByte,btShortInt,btWord,btSmallInt, + btLongWord,btCardinal,btLongint,btQWord,btInt64]; + btAllStrings = [btChar,btWideChar,btString,btAnsiString,btShortString, + btWideString,btUnicodeString]; + btAllFloats = [btReal,btSingle,btDouble,btExtended,btCExtended]; + btAllBooleans = [btBoolean,btByteBool,btWordBool,btLongBool,btQWordBool]; + btAllStandardTypes = [ + btChar, + btWideChar, + btString, + btAnsiString, + btShortString, + btWideString, + btUnicodeString, + btReal, + btSingle, + btDouble, + btExtended, + btCExtended, + btComp, + btCurrency, + btBoolean, + btByteBool, + btWordBool, + btLongBool, + btQWordBool, + btByte, + btShortInt, + btWord, + btSmallInt, + btLongWord, + btCardinal, + btLongint, + btQWord, + btInt64, + btPointer, + btFile, + btText, + btVariant + ]; + + BaseTypeNames: array[TResolveBaseType] of shortstring =( + 'None', + 'Context', + 'Untyped', + 'Char', + 'WideChar', + 'String', + 'AnsiString', + 'ShortString', + 'WideString', + 'UnicodeString', + 'Real', + 'Single', + 'Double', + 'Extended', + 'CExtended', + 'Comp', + 'Currency', + 'Boolean', + 'ByteBool', + 'WordBool', + 'LongBool', + 'QWordBool', + 'Byte', + 'ShortInt', + 'Word', + 'SmallInt', + 'LongWord', + 'Cardinal', + 'Longint', + 'QWord', + 'Int64', + 'Pointer', + 'File', + 'Text', + 'Variant', + 'Nil', + 'CompilerFunc' + ); + +const + ResolverResultVar = 'Result'; + +type + + { EPasResolve } + + EPasResolve = class(Exception) + private + FPasElement: TPasElement; + procedure SetPasElement(AValue: TPasElement); + public + MsgNumber: integer; + Args: TMessageArgs; + destructor Destroy; override; + property PasElement: TPasElement read FPasElement write SetPasElement; + end; + + { TResolveData - base class for data stored in TPasElement.CustomData } + + TResolveData = Class + private + FElement: TPasElement; + procedure SetElement(AValue: TPasElement); + public + Owner: TObject; // e.g. a TPasResolver + Next: TResolveData; + CustomData: TObject; + constructor Create; virtual; + destructor Destroy; override; + property Element: TPasElement read FElement write SetElement; + end; + TResolveDataClass = class of TResolveData; + + { TResolvedReference - CustomData for normal references } + + TResolvedReference = Class(TResolveData) + private + FDeclaration: TPasElement; + procedure SetDeclaration(AValue: TPasElement); + public + destructor Destroy; override; + property Declaration: TPasElement read FDeclaration write SetDeclaration; + end; + + { TResolvedCustom - CustomData for compiler built-in identifiers like 'length' } + + TResolvedCustom = Class(TResolveData) + public + //pas2js creates descendants of this + end; + + TPasScope = class; + + TIterateScopeElement = procedure(El: TPasElement; Scope: TPasScope; + Data: Pointer; var Abort: boolean) of object; + + { TPasScope - CustomData for elements with sub identifiers } + + TPasScope = Class(TResolveData) + public + class function IsStoredInElement: boolean; virtual; + procedure IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); virtual; + procedure WriteIdentifiers(Prefix: string); virtual; + end; + TPasScopeClass = class of TPasScope; + + { TPasModuleScope } + + TPasModuleScope = class(TPasScope) + public + procedure IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); override; + end; + + TPasIdentifierKind = ( + pikNone, // not yet initialized + pikCustom, // built-in identifiers + pikSimple, // simple vars, consts, types, enums + pikProc // may need parameter list with round brackets + { + pikIndexedProperty, // may need parameter list with edged brackets + pikGeneric, // may need parameter list with angle brackets + pikDottedUses // namespace, needs dotted identifierss } + ); + TPasIdentifierKinds = set of TPasIdentifierKind; + + { TPasIdentifier } + + TPasIdentifier = Class(TObject) + private + FElement: TPasElement; + procedure SetElement(AValue: TPasElement); + public + Identifier: String; + NextSameIdentifier: TPasIdentifier; // next identifier with same name + Kind: TPasIdentifierKind; + destructor Destroy; override; + property Element: TPasElement read FElement write SetElement; + end; + + { TPasIdentifierScope - elements with a list of sub identifiers } + + TPasIdentifierScope = Class(TPasScope) + private + FItems: TFPHashList; + procedure InternalAdd(Item: TPasIdentifier); + procedure OnClearItem(Item, Dummy: pointer); + procedure OnWriteItem(Item, Dummy: pointer); + public + constructor Create; override; + destructor Destroy; override; + function FindIdentifier(const Identifier: String): TPasIdentifier; virtual; + function AddIdentifier(const Identifier: String; El: TPasElement; + const Kind: TPasIdentifierKind): TPasIdentifier; + function FindElement(const aName: string): TPasElement; + procedure IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); override; + procedure WriteIdentifiers(Prefix: string); override; + end; + + { TPasDefaultScope - root scope } + + TPasDefaultScope = class(TPasIdentifierScope) + public + class function IsStoredInElement: boolean; override; + end; + + { TPasSectionScope - e.g. interface, implementation, program, library } + + TPasSectionScope = Class(TPasIdentifierScope) + public + UsesList: TFPList; // list of TPasSectionScope + constructor Create; override; + destructor Destroy; override; + function FindIdentifierInSection(const Identifier: String): TPasIdentifier; + function FindIdentifier(const Identifier: String): TPasIdentifier; override; + procedure IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); override; + end; + + { TPasProcedureScope } + + TPasProcedureScope = Class(TPasIdentifierScope) + end; + + { TPasExceptOnScope } + + TPasExceptOnScope = Class(TPasIdentifierScope) + end; + + { TPasSubScope - base class for sub scopes } + + TPasSubScope = Class(TPasIdentifierScope) + public + class function IsStoredInElement: boolean; override; + end; + + { TPasIterateFilterData } + + TPasIterateFilterData = record + OnIterate: TIterateScopeElement; + Data: Pointer; + end; + PPasIterateFilterData = ^TPasIterateFilterData; + + { TPasSubModuleScope - scope for searching unitname. } + + TPasSubModuleScope = Class(TPasSubScope) + private + FCurModule: TPasModule; + procedure OnInternalIterate(El: TPasElement; Scope: TPasScope; + Data: Pointer; var Abort: boolean); + procedure SetCurModule(AValue: TPasModule); + public + InterfaceScope: TPasSectionScope; + ImplementationScope: TPasSectionScope; + destructor Destroy; override; + function FindIdentifier(const Identifier: String): TPasIdentifier; override; + procedure IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); override; + property CurModule: TPasModule read FCurModule write SetCurModule; + end; + + TPasResolvedKind = ( + rkNone, + rkIdentifier, // IdentEl is a type, var, const, property, proc, etc, built-in types have IdentEl=nil + // TypeEl is the resolved type + rkExpr, // ExprEl is a const, e.g. 3, 'pas', 1..2, [1,2+3] + rkArrayOf, // array of , IdentEl might be nil + rkPointer // @, pointer of TypeEl + ); + + TPasResolvedType = record + Kind: TPasResolvedKind; + BaseType: TResolveBaseType; + IdentEl: TPasElement; + TypeEl: TPasType; + ExprEl: TPasExpr; + end; + PPasResolvedType = ^TPasResolvedType; + + { TPasResolver } + + TPasResolver = Class(TPasTreeContainer) + private + FDefaultScope: TPasDefaultScope; + FLastElement: TPasElement; + FLastCreatedData: TResolveData; + FLastMsg: string; + FLastMsgArgs: TMessageArgs; + FLastMsgElement: TPasElement; + FLastMsgNumber: integer; + FLastMsgPattern: string; + FLastMsgType: TMessageType; + FScopes: array of TPasScope; // stack of scopes + FScopeCount: integer; + FStoreSrcColumns: boolean; + FRootElement: TPasElement; + FTopScope: TPasScope; + function GetScopes(Index: integer): TPasScope; inline; + protected + type + TFindFirstElementData = record + ErrorPosEl: TPasElement; + Found: TPasElement; + end; + PFindFirstElementData = ^TFindFirstElementData; + procedure OnFindFirstElement(El: TPasElement; Scope: TPasScope; + FindFirstElementData: Pointer; var Abort: boolean); virtual; + protected + type + TProcCompatibility = ( + pcIncompatible, + pcCompatible, // e.g. assign a longint to an int64 + pcExact + ); + TFindProcsData = record + Params: TParamsExpr; + Found: TPasProcedure; + Compatible: TProcCompatibility; + Count: integer; + end; + PFindProcsData = ^TFindProcsData; + procedure OnFindProc(El: TPasElement; Scope: TPasScope; + FindProcsData: Pointer; var Abort: boolean); virtual; + protected + procedure SetCurrentParser(AValue: TPasParser); override; + procedure CheckTopScope(ExpectedClass: TPasScopeClass); + procedure AddModule(El: TPasModule); + procedure AddSection(El: TPasSection); + procedure AddType(El: TPasType); + procedure AddVariable(El: TPasVariable); + procedure AddProcedure(El: TPasProcedure); + procedure AddArgument(El: TPasArgument); + procedure AddFunctionResult(El: TPasResultElement); + procedure AddExceptOn(El: TPasImplExceptOn); + procedure StartProcedureBody(El: TProcedureBody); + procedure FinishModule; + procedure FinishUsesList; + procedure FinishTypeSection; + procedure FinishProcedure; + procedure FinishProcedureHeader; + procedure FinishExceptOnExpr; + procedure FinishExceptOnStatement; + procedure ResolveImplBlock(Block: TPasImplBlock); + procedure ResolveImplElement(El: TPasImplElement); + procedure ResolveImplCaseOf(CaseOf: TPasImplCaseOf); + procedure ResolveImplLabelMark(Mark: TPasImplLabelMark); + procedure ResolveImplForLoop(Loop: TPasImplForLoop); + procedure ResolveExpr(El: TPasExpr); + procedure ResolveBinaryExpr(El: TBinaryExpr); + procedure ResolveSubIdent(El: TBinaryExpr); + procedure ResolveParamsExpr(Params: TParamsExpr); + procedure WriteScopes; + public + constructor Create; + destructor Destroy; override; + function CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; + overload; override; + function CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASrcPos: TPasSourcePos): TPasElement; + overload; override; + function FindElement(const AName: String): TPasElement; override; + function FindFirstElement(const AName: String; ErrorPosEl: TPasElement): TPasElement; + procedure IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); virtual; + procedure FinishScope(ScopeType: TPasScopeType); override; + class procedure UnmangleSourceLineNumber(LineNumber: integer; + out Line, Column: integer); + procedure Clear; virtual; + procedure AddObjFPCBuiltInIdentifiers(BaseTypes: TResolveBaseTypes = btAllStandardTypes); + function CreateReference(DeclEl, RefEl: TPasElement): TResolvedReference; virtual; + function CreateScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; virtual; + procedure PopScope; + procedure PushScope(Scope: TPasScope); overload; + function PushScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; inline; overload; + procedure SetLastMsg(MsgType: TMessageType; MsgNumber: integer; + Const Fmt : String; Args : Array of const; Element: TPasElement); + procedure RaiseMsg(MsgNumber: integer; const Fmt: String; + Args: Array of const; ErrorPosEl: TPasElement); + procedure RaiseNotYetImplemented(El: TPasElement; Msg: string = ''); virtual; + procedure RaiseInternalError(const Msg: string); + procedure RaiseInvalidScopeForElement(El: TPasElement; const Msg: string = ''); + procedure RaiseIdentifierNotFound(Identifier: string; El: TPasElement); + function CheckProcCompatibility(Proc: TPasProcedure; + Params: TParamsExpr; RaiseOnError: boolean): TProcCompatibility; + function CheckParamCompatibility(Expr: TPasExpr; Param: TPasArgument; + ParamNo: integer; RaiseOnError: boolean): TProcCompatibility; + procedure GetResolvedType(El: TPasElement; SkipTypeAlias: boolean; + out ResolvedType: TPasResolvedType); + public + property LastElement: TPasElement read FLastElement; + property StoreSrcColumns: boolean read FStoreSrcColumns write FStoreSrcColumns; { + If true Line and Column is mangled together in TPasElement.SourceLineNumber. + Use method UnmangleSourceLineNumber to extract. } + property Scopes[Index: integer]: TPasScope read GetScopes; + property ScopeCount: integer read FScopeCount; + property TopScope: TPasScope read FTopScope; + property RootElement: TPasElement read FRootElement; + property DefaultScope: TPasDefaultScope read FDefaultScope write FDefaultScope; + property LastMsg: string read FLastMsg write FLastMsg; + property LastMsgNumber: integer read FLastMsgNumber write FLastMsgNumber; + property LastMsgType: TMessageType read FLastMsgType write FLastMsgType; + property LastMsgPattern: string read FLastMsgPattern write FLastMsgPattern; + property LastMsgArgs: TMessageArgs read FLastMsgArgs write FLastMsgArgs; + property LastMsgElement: TPasElement read FLastMsgElement write FLastMsgElement; + end; + +function GetObjName(o: TObject): string; +function GetProcDesc(Proc: TPasProcedure): string; +function GetTypeDesc(aType: TPasType): string; +function GetTreeDesc(El: TPasElement; Indent: integer = 0): string; +function GetResolvedTypeDesc(const T: TPasResolvedType): string; +procedure SetResolvedType(out ResolvedType: TPasResolvedType; + Kind: TPasResolvedKind; BaseType: TResolveBaseType; IdentEl: TPasElement; + TypeEl: TPasType); overload; +procedure SetResolvedTypeExpr(out ResolvedType: TPasResolvedType; + BaseType: TResolveBaseType; ExprEl: TPasExpr); overload; + +implementation + +function GetObjName(o: TObject): string; +begin + if o=nil then + Result:='nil' + else if o is TPasElement then + Result:=TPasElement(o).Name+':'+o.ClassName + else + Result:=o.ClassName; +end; + +function GetProcDesc(Proc: TPasProcedure): string; +var + Args: TFPList; + i: Integer; + Arg: TPasArgument; +begin + if Proc=nil then exit('nil'); + Result:=Proc.Name+'('; + Args:=Proc.ProcType.Args; + for i:=0 to Args.Count-1 do + begin + if i>0 then Result:=Result+';'; + Arg:=TPasArgument(Args[i]); + if AccessNames[Arg.Access]<>'' then + Result:=Result+AccessNames[Arg.Access]+' '; + if Arg.ArgType=nil then + Result:=Result+'untyped' + else + Result:=Result+GetTypeDesc(Arg.ArgType); + end; + Result:=Result+')'; + if cCallingConventions[Proc.ProcType.CallingConvention]<>'' then + Result:=Result+';'+cCallingConventions[Proc.ProcType.CallingConvention]; +end; + +function GetTypeDesc(aType: TPasType): string; +begin + if aType=nil then exit('nil'); + if (aType.ClassType=TPasUnresolvedSymbolRef) + or (aType.ClassType=TPasUnresolvedTypeRef) then + Result:=aType.Name + else if aType.ClassType=TPasPointerType then + Result:='^'+GetTypeDesc(TPasPointerType(aType).DestType) + else if aType.ClassType=TPasAliasType then + Result:=GetTypeDesc(TPasAliasType(aType).DestType) + else if aType.ClassType=TPasTypeAliasType then + Result:='type '+GetTypeDesc(TPasTypeAliasType(aType).DestType) + else if aType.ClassType=TPasClassOfType then + Result:='class of '+TPasClassOfType(aType).DestType.Name + else if aType.ClassType=TPasArrayType then + Result:='array['+TPasArrayType(aType).IndexRange+'] of '+GetTypeDesc(TPasArrayType(aType).ElType) + else + Result:=aType.ElementTypeName; +end; + +function GetTreeDesc(El: TPasElement; Indent: integer): string; + + procedure LineBreak(SubIndent: integer); + begin + Inc(Indent,SubIndent); + Result:=Result+LineEnding+Space(Indent); + end; + +var + i, l: Integer; +begin + if El=nil then exit('nil'); + Result:=El.Name+':'+El.ClassName+'='; + if El is TPasExpr then + begin + if El.ClassType<>TBinaryExpr then + Result:=Result+OpcodeStrings[TPasExpr(El).OpCode]; + if El.ClassType=TUnaryExpr then + Result:=Result+GetTreeDesc(TUnaryExpr(El).Operand,Indent) + else if El.ClassType=TBinaryExpr then + Result:=Result+GetTreeDesc(TBinaryExpr(El).left,Indent) + +OpcodeStrings[TPasExpr(El).OpCode] + +GetTreeDesc(TBinaryExpr(El).right,Indent) + else if El.ClassType=TPrimitiveExpr then + Result:=Result+TPrimitiveExpr(El).Value + else if El.ClassType=TBoolConstExpr then + Result:=Result+BoolToStr(TBoolConstExpr(El).Value,'true','false') + else if El.ClassType=TNilExpr then + Result:=Result+'nil' + else if El.ClassType=TInheritedExpr then + Result:=Result+'inherited' + else if El.ClassType=TSelfExpr then + Result:=Result+'Self' + else if El.ClassType=TParamsExpr then + begin + LineBreak(2); + Result:=Result+GetTreeDesc(TParamsExpr(El).Value,Indent)+'('; + l:=length(TParamsExpr(El).Params); + if l>0 then + begin + inc(Indent,2); + for i:=0 to l-1 do + begin + LineBreak(0); + Result:=Result+GetTreeDesc(TParamsExpr(El).Params[i],Indent); + if i0 then + begin + inc(Indent,2); + for i:=0 to l-1 do + begin + LineBreak(0); + Result:=Result+TRecordValues(El).Fields[i].Name+':' + +GetTreeDesc(TRecordValues(El).Fields[i].ValueExp,Indent); + if i0 then + begin + inc(Indent,2); + for i:=0 to l-1 do + begin + LineBreak(0); + Result:=Result+GetTreeDesc(TArrayValues(El).Values[i],Indent); + if i0 then + begin + inc(Indent,2); + for i:=0 to l-1 do + begin + LineBreak(0); + Result:=Result+GetTreeDesc(TPasArgument(TPasProcedureType(El).Args[i]),Indent); + if i'' then + Result:=Result+'; '+cCallingConventions[TPasProcedureType(El).CallingConvention]; + end + else if El.ClassType=TPasResultElement then + Result:=Result+GetTreeDesc(TPasResultElement(El).ResultType,Indent) + else if El.ClassType=TPasArgument then + begin + if AccessNames[TPasArgument(El).Access]<>'' then + Result:=Result+AccessNames[TPasArgument(El).Access]+' '; + if TPasArgument(El).ArgType=nil then + Result:=Result+'untyped' + else + Result:=Result+GetTreeDesc(TPasArgument(El).ArgType,Indent); + end; +end; + +function GetResolvedTypeDesc(const T: TPasResolvedType): string; +begin + case T.Kind of + rkNone: Result:=''; + rkIdentifier: Result:=GetObjName(T.IdentEl)+':'+GetTypeDesc(T.TypeEl as TPasType)+'='+BaseTypeNames[T.BaseType]; + rkExpr: Result:=GetTreeDesc(T.ExprEl)+'='+BaseTypeNames[T.BaseType]; + rkArrayOf: Result:='array of '+GetTypeDesc(T.TypeEl as TPasType)+'='+BaseTypeNames[T.BaseType]; + rkPointer: Result:='^'+GetTypeDesc(T.TypeEl as TPasType)+'='+BaseTypeNames[T.BaseType]; + else Result:=''; + end; +end; + +procedure SetResolvedType(out ResolvedType: TPasResolvedType; + Kind: TPasResolvedKind; BaseType: TResolveBaseType; IdentEl: TPasElement; + TypeEl: TPasType); +begin + ResolvedType.Kind:=Kind; + ResolvedType.BaseType:=BaseType; + ResolvedType.IdentEl:=IdentEl; + ResolvedType.TypeEl:=TypeEl; + ResolvedType.ExprEl:=nil; +end; + +procedure SetResolvedTypeExpr(out ResolvedType: TPasResolvedType; + BaseType: TResolveBaseType; ExprEl: TPasExpr); +begin + ResolvedType.Kind:=rkExpr; + ResolvedType.BaseType:=BaseType; + ResolvedType.IdentEl:=nil; + ResolvedType.TypeEl:=nil; + ResolvedType.ExprEl:=ExprEl; +end; + +{ TPasIdentifier } + +procedure TPasIdentifier.SetElement(AValue: TPasElement); +begin + if FElement=AValue then Exit; + if Element<>nil then + Element.Release; + FElement:=AValue; + if Element<>nil then + Element.AddRef; +end; + +destructor TPasIdentifier.Destroy; +begin + Element:=nil; + inherited Destroy; +end; + +{ EPasResolve } + +procedure EPasResolve.SetPasElement(AValue: TPasElement); +begin + if FPasElement=AValue then Exit; + if PasElement<>nil then + PasElement.Release; + FPasElement:=AValue; + if PasElement<>nil then + PasElement.AddRef; +end; + +destructor EPasResolve.Destroy; +begin + PasElement:=nil; + inherited Destroy; +end; + +{ TResolvedReference } + +procedure TResolvedReference.SetDeclaration(AValue: TPasElement); +begin + if FDeclaration=AValue then Exit; + if Declaration<>nil then + Declaration.Release; + FDeclaration:=AValue; + if Declaration<>nil then + Declaration.AddRef; +end; + +destructor TResolvedReference.Destroy; +begin + Declaration:=nil; + inherited Destroy; +end; + +{ TPasSubScope } + +class function TPasSubScope.IsStoredInElement: boolean; +begin + Result:=false; +end; + +{ TPasSubModuleScope } + +procedure TPasSubModuleScope.OnInternalIterate(El: TPasElement; + Scope: TPasScope; Data: Pointer; var Abort: boolean); +var + FilterData: PPasIterateFilterData absolute Data; +begin + if El.ClassType=TPasModule then + exit; // skip used units + // call the original iterator + FilterData^.OnIterate(El,Scope,FilterData^.Data,Abort); +end; + +procedure TPasSubModuleScope.SetCurModule(AValue: TPasModule); +begin + if FCurModule=AValue then Exit; + if CurModule<>nil then + CurModule.Release; + FCurModule:=AValue; + if CurModule<>nil then + CurModule.AddRef; +end; + +destructor TPasSubModuleScope.Destroy; +begin + CurModule:=nil; + inherited Destroy; +end; + +function TPasSubModuleScope.FindIdentifier(const Identifier: String + ): TPasIdentifier; +begin + if ImplementationScope<>nil then + begin + Result:=ImplementationScope.FindIdentifierInSection(Identifier); + if (Result<>nil) and (Result.Element.ClassType<>TPasModule) then + exit; + end; + if InterfaceScope<>nil then + Result:=InterfaceScope.FindIdentifierInSection(Identifier) + else + Result:=nil; +end; + +procedure TPasSubModuleScope.IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); +var + FilterData: TPasIterateFilterData; +begin + FilterData.OnIterate:=OnIterateElement; + FilterData.Data:=Data; + if ImplementationScope<>nil then + begin + ImplementationScope.IterateElements(aName,@OnInternalIterate,@FilterData,Abort); + if Abort then exit; + end; + if InterfaceScope<>nil then + InterfaceScope.IterateElements(aName,@OnInternalIterate,@FilterData,Abort); +end; + +{ TPasSectionScope } + +constructor TPasSectionScope.Create; +begin + inherited Create; + UsesList:=TFPList.Create; +end; + +destructor TPasSectionScope.Destroy; +begin + FreeAndNil(UsesList); + inherited Destroy; +end; + +function TPasSectionScope.FindIdentifierInSection(const Identifier: String + ): TPasIdentifier; +begin + Result:=inherited FindIdentifier(Identifier); +end; + +function TPasSectionScope.FindIdentifier(const Identifier: String + ): TPasIdentifier; +var + i: Integer; + UsesScope: TPasIdentifierScope; +begin + Result:=inherited FindIdentifier(Identifier); + if Result<>nil then + exit; + for i:=0 to UsesList.Count-1 do + begin + UsesScope:=TPasIdentifierScope(UsesList[i]); + {$IFDEF VerbosePasResolver} + writeln('TPasSectionScope.FindIdentifier "',Identifier,'" in used unit ',GetObjName(UsesScope.Element)); + {$ENDIF} + Result:=UsesScope.FindIdentifier(Identifier); + if Result<>nil then exit; + end; +end; + +procedure TPasSectionScope.IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); +var + i: Integer; + UsesScope: TPasIdentifierScope; +begin + inherited IterateElements(aName, OnIterateElement, Data, Abort); + if Abort then exit; + for i:=0 to UsesList.Count-1 do + begin + UsesScope:=TPasIdentifierScope(UsesList[i]); + {$IFDEF VerbosePasResolver} + writeln('TPasSectionScope.IterateElements "',aName,'" in used unit ',GetObjName(UsesScope.Element)); + {$ENDIF} + UsesScope.IterateElements(aName,OnIterateElement,Data,Abort); + if Abort then exit; + end; +end; + +{ TPasModuleScope } + +procedure TPasModuleScope.IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); +begin + if CompareText(aName,Element.Name)<>0 then exit; + OnIterateElement(Element,Self,Data,Abort); +end; + +{ TPasDefaultScope } + +class function TPasDefaultScope.IsStoredInElement: boolean; +begin + Result:=false; +end; + +{ TResolveData } + +procedure TResolveData.SetElement(AValue: TPasElement); +begin + if FElement=AValue then Exit; + if Element<>nil then + Element.Release; + FElement:=AValue; + if Element<>nil then + Element.AddRef; +end; + +constructor TResolveData.Create; +begin + +end; + +destructor TResolveData.Destroy; +begin + Element:=nil; + inherited Destroy; +end; + +{ TPasScope } + +class function TPasScope.IsStoredInElement: boolean; +begin + Result:=true; +end; + +procedure TPasScope.IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); +begin + if aName='' then ; + if Data=nil then ; + if OnIterateElement=nil then ; + if Abort then ; +end; + +procedure TPasScope.WriteIdentifiers(Prefix: string); +begin + writeln(Prefix,'Element: ',GetObjName(Element)); +end; + +{ TPasResolver } + +// inline +function TPasResolver.PushScope(El: TPasElement; ScopeClass: TPasScopeClass + ): TPasScope; +begin + Result:=CreateScope(El,ScopeClass); + PushScope(Result); +end; + +// inline +function TPasResolver.GetScopes(Index: integer): TPasScope; +begin + Result:=FScopes[Index]; +end; + +procedure TPasResolver.OnFindFirstElement(El: TPasElement; Scope: TPasScope; + FindFirstElementData: Pointer; var Abort: boolean); +var + Data: PFindFirstElementData absolute FindFirstElementData; +begin + Data^.Found:=El; + Abort:=true; + if Scope=nil then ; +end; + +procedure TPasResolver.OnFindProc(El: TPasElement; Scope: TPasScope; + FindProcsData: Pointer; var Abort: boolean); +var + Data: PFindProcsData absolute FindProcsData; + Proc: TPasProcedure; + Compatible: TProcCompatibility; +begin + if not (El is TPasProcedure) then + begin + // identifier is not a proc + Abort:=true; + if Data^.Found=nil then + begin + // ToDo: use the ( as error position + RaiseMsg(nSyntaxErrorExpectedButFound,sSyntaxErrorExpectedButFound,[';','('], + Data^.Params.Value); + end + else + exit; + end; + // identifier is a proc + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.OnFindProc ',GetTreeDesc(El,2)); + {$ENDIF} + Proc:=TPasProcedure(El); + if Scope=nil then ; + Compatible:=CheckProcCompatibility(Proc,Data^.Params,false); + if (Data^.Found=nil) or (ord(Compatible)>ord(Data^.Compatible)) then + begin + Data^.Found:=Proc; + Data^.Compatible:=Compatible; + Data^.Count:=1; + end + else if Compatible=Data^.Compatible then + inc(Data^.Count); +end; + +procedure TPasResolver.SetCurrentParser(AValue: TPasParser); +begin + //writeln('TPasResolver.SetCurrentParser ',AValue<>nil); + if AValue=CurrentParser then exit; + Clear; + inherited SetCurrentParser(AValue); + if CurrentParser<>nil then + CurrentParser.Options:=CurrentParser.Options+[po_resolvestandardtypes]; +end; + +procedure TPasResolver.CheckTopScope(ExpectedClass: TPasScopeClass); +begin + if TopScope=nil then + RaiseInternalError('Expected TopScope='+ExpectedClass.ClassName+' but found nil'); + if TopScope.ClassType<>ExpectedClass then + RaiseInternalError('Expected TopScope='+ExpectedClass.ClassName+' but found '+TopScope.ClassName); +end; + +procedure TPasResolver.FinishModule; +var + CurModuleClass: TClass; + CurModule: TPasModule; +begin + CurModule:=CurrentParser.CurModule; + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishModule START ',CurModule.Name); + {$ENDIF} + CurModuleClass:=CurModule.ClassType; + if (CurModuleClass=TPasProgram) or (CurModuleClass=TPasLibrary) then + begin + // resolve begin..end block + ResolveImplBlock(CurModule.InitializationSection); + end + else if (CurModuleClass=TPasModule) then + begin + if CurModule.FinalizationSection<>nil then + // finalization section finished -> resolve + ResolveImplBlock(CurModule.FinalizationSection) + else if CurModule.InitializationSection<>nil then + // initialization section finished -> resolve + ResolveImplBlock(CurModule.InitializationSection) + else + begin + // ToDo: check if all forward procs are implemented + end; + end + else + RaiseInternalError(''); // unknown module + + // close all sections + while (TopScope<>nil) and (TopScope.ClassType=TPasSectionScope) do + PopScope; + CheckTopScope(TPasModuleScope); + PopScope; + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishModule END ',CurModule.Name); + {$ENDIF} +end; + +procedure TPasResolver.FinishUsesList; +var + Section: TPasSection; + i: Integer; + El, PublicEl: TPasElement; + Scope: TPasSectionScope; + UsesScope: TPasIdentifierScope; +begin + CheckTopScope(TPasSectionScope); + Scope:=TPasSectionScope(TopScope); + Section:=TPasSection(Scope.Element); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishUsesList Section=',Section.ClassName,' Section.UsesList.Count=',Section.UsesList.Count); + {$ENDIF} + for i:=0 to Section.UsesList.Count-1 do + begin + El:=TPasElement(Section.UsesList[i]); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishUsesList ',GetObjName(El)); + {$ENDIF} + if (El.ClassType=TProgramSection) then + RaiseInternalError('used unit is a program: '+GetObjName(El)); + + Scope.AddIdentifier(El.Name,El,pikSimple); + + // check used unit + PublicEl:=nil; + if (El.ClassType=TLibrarySection) then + PublicEl:=El + else if (El.ClassType=TPasModule) then + PublicEl:=TPasModule(El).InterfaceSection; + if PublicEl=nil then + RaiseInternalError('uses element has no interface section: '+GetObjName(El)); + if PublicEl.CustomData=nil then + RaiseInternalError('uses element has no resolver data: ' + +El.Name+'->'+GetObjName(PublicEl)); + if not (PublicEl.CustomData is TPasIdentifierScope) then + RaiseInternalError('uses element has invalid resolver data: ' + +El.Name+'->'+GetObjName(PublicEl)+'->'+PublicEl.CustomData.ClassName); + + UsesScope:=TPasIdentifierScope(PublicEl.CustomData); + Scope.UsesList.Add(UsesScope); + end; +end; + +procedure TPasResolver.FinishTypeSection; +begin + // ToDo: resolve pending forwards +end; + +procedure TPasResolver.FinishProcedure; +var + aProc: TPasProcedure; +begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.FinishProcedure START'); + {$ENDIF} + CheckTopScope(TPasProcedureScope); + aProc:=TPasProcedureScope(TopScope).Element as TPasProcedure; + if aProc.Body<>nil then + ResolveImplBlock(aProc.Body.Body); + PopScope; +end; + +procedure TPasResolver.FinishProcedureHeader; +begin + CheckTopScope(TPasProcedureScope); + // ToDo: check class +end; + +procedure TPasResolver.FinishExceptOnExpr; +var + El: TPasImplExceptOn; + Expr: TPrimitiveExpr; +begin + CheckTopScope(TPasExceptOnScope); + El:=TPasImplExceptOn(FTopScope.Element); + if El.VarExpr<>nil then + begin + if El.VarExpr.ClassType<>TPrimitiveExpr then + RaiseNotYetImplemented(El.VarExpr); + Expr:=TPrimitiveExpr(El.VarExpr); + if Expr.Kind<>pekIdent then + RaiseNotYetImplemented(Expr); + TPasExceptOnScope(FTopScope).AddIdentifier(Expr.Value,Expr,pikSimple); + end; + if El.TypeExpr<>nil then + ResolveExpr(El.TypeExpr); +end; + +procedure TPasResolver.FinishExceptOnStatement; +begin + //writeln('TPasResolver.FinishExceptOnStatement START'); + CheckTopScope(TPasExceptOnScope); + ResolveImplElement(TPasImplExceptOn(FTopScope.Element).Body); + PopScope; +end; + +procedure TPasResolver.ResolveImplBlock(Block: TPasImplBlock); +var + i: Integer; +begin + if Block=nil then exit; + for i:=0 to Block.Elements.Count-1 do + ResolveImplElement(TPasImplElement(Block.Elements[i])); +end; + +procedure TPasResolver.ResolveImplElement(El: TPasImplElement); +begin + //writeln('TPasResolver.ResolveImplElement ',GetObjName(El)); + if El=nil then + else if El.ClassType=TPasImplAssign then + begin + ResolveExpr(TPasImplAssign(El).left); + ResolveExpr(TPasImplAssign(El).right); + end + else if El.ClassType=TPasImplSimple then + ResolveExpr(TPasImplSimple(El).expr) + else if El.ClassType=TPasImplBlock then + ResolveImplBlock(TPasImplBlock(El)) + else if El.ClassType=TPasImplRepeatUntil then + begin + ResolveImplBlock(TPasImplBlock(El)); + ResolveExpr(TPasImplRepeatUntil(El).ConditionExpr); + end + else if El.ClassType=TPasImplIfElse then + begin + ResolveExpr(TPasImplIfElse(El).ConditionExpr); + ResolveImplElement(TPasImplIfElse(El).IfBranch); + ResolveImplElement(TPasImplIfElse(El).ElseBranch); + end + else if El.ClassType=TPasImplWhileDo then + begin + ResolveExpr(TPasImplWhileDo(El).ConditionExpr); + ResolveImplElement(TPasImplWhileDo(El).Body); + end + else if El.ClassType=TPasImplCaseOf then + ResolveImplCaseOf(TPasImplCaseOf(El)) + else if El.ClassType=TPasImplLabelMark then + ResolveImplLabelMark(TPasImplLabelMark(El)) + else if El.ClassType=TPasImplForLoop then + ResolveImplForLoop(TPasImplForLoop(El)) + else if El.ClassType=TPasImplTry then + begin + ResolveImplBlock(TPasImplTry(El)); + ResolveImplBlock(TPasImplTry(El).FinallyExcept); + ResolveImplBlock(TPasImplTry(El).ElseBranch); + end + else if El.ClassType=TPasImplExceptOn then + // handled in FinishExceptOnStatement + else if El.ClassType=TPasImplRaise then + begin + ResolveExpr(TPasImplRaise(El).ExceptObject); + ResolveExpr(TPasImplRaise(El).ExceptAddr); + end + else if El.ClassType=TPasImplCommand then + begin + if TPasImplCommand(El).Command<>'' then + RaiseNotYetImplemented(El); + end + else + RaiseNotYetImplemented(El); +end; + +procedure TPasResolver.ResolveImplCaseOf(CaseOf: TPasImplCaseOf); +var + i, j: Integer; + El: TPasElement; + Stat: TPasImplCaseStatement; +begin + ResolveExpr(CaseOf.CaseExpr); + for i:=0 to CaseOf.Elements.Count-1 do + begin + El:=TPasElement(CaseOf.Elements[i]); + if El.ClassType=TPasImplCaseStatement then + begin + Stat:=TPasImplCaseStatement(El); + for j:=0 to Stat.Expressions.Count-1 do + begin + //writeln('TPasResolver.ResolveImplCaseOf Stat.Expr[',j,']=',GetObjName(El)); + ResolveExpr(TPasExpr(Stat.Expressions[j])); + end; + ResolveImplElement(Stat.Body); + end + else if El.ClassType=TPasImplCaseElse then + ResolveImplBlock(TPasImplCaseElse(El)) + else + RaiseNotYetImplemented(El); + end; + // CaseOf.ElseBranch was already resolved via Elements +end; + +procedure TPasResolver.ResolveImplLabelMark(Mark: TPasImplLabelMark); +var + DeclEl: TPasElement; +begin + DeclEl:=FindFirstElement(Mark.LabelId,Mark); + // ToDo: check if DeclEl is a label and check duplicate + CreateReference(DeclEl,Mark); +end; + +procedure TPasResolver.ResolveImplForLoop(Loop: TPasImplForLoop); +begin + ResolveExpr(Loop.VariableName); + ResolveExpr(Loop.StartExpr); + ResolveExpr(Loop.EndExpr); + ResolveImplElement(Loop.Body); +end; + +procedure TPasResolver.ResolveExpr(El: TPasExpr); +var + Primitive: TPrimitiveExpr; + DeclEl: TPasElement; +begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResolveExpr ',GetObjName(El)); + {$ENDIF} + if El=nil then + else if El.ClassType=TPrimitiveExpr then + begin + Primitive:=TPrimitiveExpr(El); + case Primitive.Kind of + pekIdent: + begin + DeclEl:=FindFirstElement(Primitive.Value,El); + //writeln('TPasResolver.ResolveExpr Ref=',GetObjName(El)+' Decl='+GetObjName(DeclEl)); + CreateReference(DeclEl,El); + end; + pekNumber,pekString,pekNil,pekBoolConst: exit; + else + RaiseNotYetImplemented(El); + end; + end + else if El.ClassType=TUnaryExpr then + ResolveExpr(TUnaryExpr(El).Operand) + else if El.ClassType=TBinaryExpr then + ResolveBinaryExpr(TBinaryExpr(El)) + else if El.ClassType=TParamsExpr then + ResolveParamsExpr(TParamsExpr(El)) + else if El.ClassType=TBoolConstExpr then + else if El.ClassType=TNilExpr then + else + RaiseNotYetImplemented(El); +end; + +procedure TPasResolver.ResolveBinaryExpr(El: TBinaryExpr); +begin + ResolveExpr(El.left); + if El.right=nil then exit; + case El.OpCode of + eopNone, + eopAdd, + eopSubtract, + eopMultiply, + eopDivide, + eopDiv, + eopMod, + eopPower, + eopShr, + eopShl, + eopNot, + eopAnd, + eopOr, + eopXor, + eopEqual, + eopNotEqual, + eopLessThan, + eopGreaterThan, + eopLessthanEqual, + eopGreaterThanEqual, + eopIn, + eopIs, + eopAs, + eopSymmetricaldifference: + begin + // ToDo: check if left operand supports operator + ResolveExpr(El.right); + // ToDo: check if operator fits + end; + //eopAddress: ; + //eopDeref: ; + eopSubIdent: + ResolveSubIdent(El); + else + RaiseNotYetImplemented(El,OpcodeStrings[El.OpCode]); + end; +end; + +procedure TPasResolver.ResolveSubIdent(El: TBinaryExpr); +var + DeclEl: TPasElement; + ModuleScope: TPasSubModuleScope; + aModule: TPasModule; +begin + //writeln('TPasResolver.ResolveSubIdent El.left=',GetObjName(El.left)); + if El.left.ClassType=TPrimitiveExpr then + begin + //writeln('TPasResolver.ResolveSubIdent El.left.CustomData=',GetObjName(El.left.CustomData)); + if El.left.CustomData is TResolvedReference then + begin + DeclEl:=TResolvedReference(El.left.CustomData).Declaration; + //writeln('TPasResolver.ResolveSubIdent Decl=',GetObjName(DeclEl)); + if DeclEl is TPasModule then + begin + // e.g. unitname.identifier + // => search in interface and if this is our module in the implementation + aModule:=TPasModule(DeclEl); + ModuleScope:=TPasSubModuleScope.Create; + ModuleScope.Owner:=Self; + ModuleScope.CurModule:=aModule; + if aModule is TPasProgram then + begin // program + if TPasProgram(aModule).ProgramSection<>nil then + ModuleScope.InterfaceScope:= + TPasProgram(aModule).ProgramSection.CustomData as TPasSectionScope; + end + else if aModule is TPasLibrary then + begin // library + if TPasLibrary(aModule).LibrarySection<>nil then + ModuleScope.InterfaceScope:= + TPasLibrary(aModule).LibrarySection.CustomData as TPasSectionScope; + end + else + begin // unit + if aModule.InterfaceSection<>nil then + ModuleScope.InterfaceScope:= + aModule.InterfaceSection.CustomData as TPasSectionScope; + if (aModule=CurrentParser.CurModule) + and (aModule.ImplementationSection<>nil) + and (aModule.ImplementationSection.CustomData<>nil) + then + ModuleScope.ImplementationScope:=aModule.ImplementationSection.CustomData as TPasSectionScope; + end; + PushScope(ModuleScope); + ResolveExpr(El.right); + PopScope; + end; + end + else + RaiseMsg(nIllegalQualifier,sIllegalQualifier,['.'],El); + end + else + RaiseMsg(nIllegalQualifier,sIllegalQualifier,['.'],El); +end; + +procedure TPasResolver.ResolveParamsExpr(Params: TParamsExpr); +var + i: Integer; + ProcName: String; + FindData: TFindProcsData; + Abort: boolean; +begin + // first resolve params + for i:=0 to length(Params.Params)-1 do + ResolveExpr(Params.Params[i]); + // then search the best fitting proc + if Params.Value.ClassType=TPrimitiveExpr then + begin + ProcName:=TPrimitiveExpr(Params.Value).Value; + FindData:=Default(TFindProcsData); + FindData.Params:=Params; + Abort:=false; + IterateElements(ProcName,@OnFindProc,@FindData,Abort); + if FindData.Found=nil then + RaiseIdentifierNotFound(ProcName,Params.Value); + if FindData.Compatible=pcIncompatible then + begin + // found one proc, but it was incompatible => raise error + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ResolveParamsExpr found one proc, but it was incompatible => check again to raise error'); + {$ENDIF} + CheckProcCompatibility(FindData.Found,Params,true); + end; + if FindData.Count>1 then + begin + // ToDo: multiple overloads fit => search again and list the candidates + RaiseMsg(nIdentifierNotFound,sIdentifierNotFound,[],Params.Value); + end; + // found compatible proc + CreateReference(FindData.Found,Params.Value); + end + else + RaiseNotYetImplemented(Params,' with parameters'); +end; + +procedure TPasResolver.AddModule(El: TPasModule); +begin + if TopScope<>DefaultScope then + RaiseInvalidScopeForElement(El); + PushScope(El,TPasModuleScope); +end; + +procedure TPasResolver.AddSection(El: TPasSection); +// TInterfaceSection, TImplementationSection, TProgramSection, TLibrarySection +// Note: implementation scope is within the interface scope +var + CurModuleClass: TClass; +begin + CurModuleClass:=CurrentParser.CurModule.ClassType; + if (CurModuleClass=TPasProgram) or (CurModuleClass=TPasLibrary) then + begin + if El.ClassType=TInitializationSection then + ; // ToDo: check if all forward procs are implemented + end + else if CurModuleClass=TPasModule then + begin + if El.ClassType=TInitializationSection then + begin + // finished implementation + // ToDo: check if all forward procs are implemented + end + else if El.ClassType=TFinalizationSection then + begin + if CurrentParser.CurModule.InitializationSection<>nil then + begin + // resolve initialization section + ResolveImplBlock(CurrentParser.CurModule.InitializationSection); + end + else + begin + // finished implementation + // ToDo: check if all forward procs are implemented + end; + end; + end + else + RaiseInternalError(''); // unknown module + PushScope(El,TPasSectionScope); +end; + +procedure TPasResolver.AddType(El: TPasType); +begin + if (El.Name='') then exit; // sub type + if El is TPasUnresolvedTypeRef then exit; // built-in type + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.AddType El=',GetObjName(El),' El.Parent=',GetObjName(El.Parent)); + {$ENDIF} + if not (TopScope is TPasIdentifierScope) then + RaiseInvalidScopeForElement(El); + TPasIdentifierScope(TopScope).AddIdentifier(El.Name,El,pikSimple); +end; + +procedure TPasResolver.AddVariable(El: TPasVariable); +begin + if (El.Name='') then exit; // anonymous var + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.AddVariable ',GetObjName(El)); + {$ENDIF} + if not (TopScope is TPasIdentifierScope) then + RaiseInvalidScopeForElement(El); + TPasIdentifierScope(TopScope).AddIdentifier(El.Name,El,pikSimple); +end; + +procedure TPasResolver.AddProcedure(El: TPasProcedure); +begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.AddProcedure ',GetObjName(El)); + {$ENDIF} + if not (TopScope is TPasIdentifierScope) then + RaiseInvalidScopeForElement(El); + TPasIdentifierScope(TopScope).AddIdentifier(El.Name,El,pikProc); + PushScope(El,TPasProcedureScope); +end; + +procedure TPasResolver.AddArgument(El: TPasArgument); +begin + if (El.Name='') then + RaiseInternalError(GetObjName(El)); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.AddArgument ',GetObjName(El)); + {$ENDIF} + if not (TopScope is TPasProcedureScope) then + RaiseInvalidScopeForElement(El); + TPasProcedureScope(TopScope).AddIdentifier(El.Name,El,pikSimple); +end; + +procedure TPasResolver.AddFunctionResult(El: TPasResultElement); +begin + if TopScope.ClassType<>TPasProcedureScope then + RaiseInvalidScopeForElement(El); + TPasProcedureScope(TopScope).AddIdentifier(ResolverResultVar,El,pikSimple); +end; + +procedure TPasResolver.AddExceptOn(El: TPasImplExceptOn); +begin + PushScope(El,TPasExceptOnScope); +end; + +procedure TPasResolver.StartProcedureBody(El: TProcedureBody); +begin + if El=nil then ; + // ToDo: check if all nested forward procs are resolved + CheckTopScope(TPasProcedureScope); +end; + +procedure TPasResolver.WriteScopes; +var + i: Integer; + Scope: TPasScope; +begin + writeln('TPasResolver.WriteScopes ScopeCount=',ScopeCount); + for i:=ScopeCount-1 downto 0 do + begin + Scope:=Scopes[i]; + writeln(' ',i,'/',ScopeCount,' ',GetObjName(Scope)); + Scope.WriteIdentifiers(' '); + end; +end; + +constructor TPasResolver.Create; +begin + inherited Create; + FDefaultScope:=TPasDefaultScope.Create; + PushScope(FDefaultScope); +end; + +function TPasResolver.CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; +var + aScanner: TPascalScanner; + SrcPos: TPasSourcePos; +begin + // get source position for good error messages + aScanner:=CurrentParser.Scanner; + if (ASourceFilename='') or StoreSrcColumns then + begin + SrcPos.FileName:=aScanner.CurFilename; + SrcPos.Row:=aScanner.CurRow; + SrcPos.Column:=aScanner.CurColumn; + end + else + begin + SrcPos.FileName:=ASourceFilename; + SrcPos.Row:=ASourceLinenumber; + SrcPos.Column:=0; + end; + Result:=CreateElement(AClass,AName,AParent,AVisibility,SrcPos); +end; + +function TPasResolver.CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASrcPos: TPasSourcePos): TPasElement; +var + El: TPasElement; + SrcY: integer; +begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CreateElement ',AClass.ClassName,' Name=',AName,' Parent=',GetObjName(AParent),' (',ASrcPos.Row,',',ASrcPos.Column,')'); + {$ENDIF} + if (AParent=nil) and (FRootElement<>nil) + and (not AClass.InheritsFrom(TPasUnresolvedTypeRef)) then + RaiseInternalError('TPasResolver.CreateElement more than one root element Class="'+AClass.ClassName+'" Root='+GetObjName(FRootElement)); + + if ASrcPos.FileName='' then + RaiseInternalError('TPasResolver.CreateElement missing filename'); + SrcY:=ASrcPos.Row; + if StoreSrcColumns then + begin + if (ASrcPos.Columnnil then exit; + RaiseIdentifierNotFound(AName,ErrorPosEl); +end; + +procedure TPasResolver.IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); +var + i: Integer; + Scope: TPasScope; +begin + for i:=FScopeCount-1 downto 0 do + begin + Scope:=Scopes[i]; + Scope.IterateElements(AName,OnIterateElement,Data,Abort); + if Abort then + exit; + if Scope is TPasSubScope then break; + end; +end; + +procedure TPasResolver.FinishScope(ScopeType: TPasScopeType); +begin + case ScopeType of + stModule: FinishModule; + stUsesList: FinishUsesList; + stTypeSection: FinishTypeSection; + stTypeDef: ; + stProcedure: FinishProcedure; + stProcedureHeader: FinishProcedureHeader; + stExceptOnExpr: FinishExceptOnExpr; + stExceptOnStatement: FinishExceptOnStatement; + else + RaiseMsg(nNotYetImplemented,sNotYetImplemented+' FinishScope',[IntToStr(ord(ScopeType))],nil); + end; +end; + +class procedure TPasResolver.UnmangleSourceLineNumber(LineNumber: integer; out + Line, Column: integer); +begin + Line:=Linenumber; + Column:=0; + if Line<0 then begin + Line:=-Line; + Column:=Line mod ParserMaxEmbeddedColumn; + Line:=Line div ParserMaxEmbeddedColumn; + end; +end; + +destructor TPasResolver.Destroy; +begin + Clear; + PopScope; // free default scope + inherited Destroy; +end; + +procedure TPasResolver.Clear; +var + Data: TResolveData; +begin + // clear stack, keep DefaultScope + while (FScopeCount>0) and (FTopScope<>DefaultScope) do + PopScope; + // clear CustomData + while FLastCreatedData<>nil do + begin + Data:=FLastCreatedData; + Data.Element.CustomData:=nil; + FLastCreatedData:=Data.Next; + Data.Free; + end; +end; + +procedure TPasResolver.AddObjFPCBuiltInIdentifiers(BaseTypes: TResolveBaseTypes + ); +var + bt: TResolveBaseType; +begin + for bt in BaseTypes do + FDefaultScope.AddIdentifier(BaseTypeNames[bt], + TPasUnresolvedSymbolRef.Create(BaseTypeNames[bt],nil),pikCustom); +end; + +function TPasResolver.CreateReference(DeclEl, RefEl: TPasElement + ): TResolvedReference; + + procedure RaiseAlreadySet; + var + aLine, aCol: integer; + FormerDeclEl: TPasElement; + begin + writeln('RaiseAlreadySet RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl)); + UnmangleSourceLineNumber(RefEl.SourceLinenumber,aLine,aCol); + writeln(' RefEl at ',RefEl.SourceFilename,'(',aLine,',',aCol,')'); + writeln(' RefEl.CustomData=',GetObjName(RefEl.CustomData)); + if RefEl.CustomData is TResolvedReference then + begin + FormerDeclEl:=TResolvedReference(RefEl.CustomData).Declaration; + writeln(' TResolvedReference(RefEl.CustomData).Declaration=',GetObjName(FormerDeclEl), + ' IsSame=',FormerDeclEl=DeclEl); + end; + RaiseInternalError('TPasResolver.CreateReference customdata<>nil'); + end; + +begin + if RefEl.CustomData<>nil then + RaiseAlreadySet; + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CreateReference RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl)); + {$ENDIF} + Result:=TResolvedReference.Create; + Result.Element:=RefEl; + Result.Owner:=Self; + Result.Next:=FLastCreatedData; + Result.Declaration:=DeclEl; + FLastCreatedData:=Result; + RefEl.CustomData:=Result; +end; + +function TPasResolver.CreateScope(El: TPasElement; ScopeClass: TPasScopeClass + ): TPasScope; +begin + if El.CustomData<>nil then + raise EPasResolve.Create('TPasResolver.CreateScope customdata<>nil'); + + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CreateScope El=',GetObjName(El),' ScopeClass=',ScopeClass.ClassName); + {$ENDIF} + Result:=ScopeClass.Create; + Result.Element:=El; + Result.Owner:=Self; + Result.Next:=FLastCreatedData; + FLastCreatedData:=Result; + El.CustomData:=Result; +end; + +procedure TPasResolver.PopScope; +var + Scope: TPasScope; +begin + if FScopeCount=0 then + RaiseInternalError('PopScope'); + {$IFDEF VerbosePasResolver} + //writeln('TPasResolver.PopScope ',FScopeCount,' ',FTopScope<>nil,' IsDefault=',FTopScope=FDefaultScope); + writeln('TPasResolver.PopScope ',FTopScope.ClassName,' IsStoredInElement=',FTopScope.IsStoredInElement,' Element=',GetObjName(FTopScope.Element)); + {$ENDIF} + dec(FScopeCount); + if not FTopScope.IsStoredInElement then + begin + Scope:=FScopes[FScopeCount]; + if Scope.Element<>nil then + Scope.Element.CustomData:=nil; + if Scope=FDefaultScope then + FDefaultScope:=nil; + Scope.Free; + FScopes[FScopeCount]:=nil; + end; + if FScopeCount>0 then + FTopScope:=FScopes[FScopeCount-1] + else + FTopScope:=nil; +end; + +procedure TPasResolver.PushScope(Scope: TPasScope); +begin + if Scope=nil then + RaiseInternalError('TPasResolver.PushScope nil'); + if length(FScopes)=FScopeCount then + SetLength(FScopes,FScopeCount*2+10); + FScopes[FScopeCount]:=Scope; + inc(FScopeCount); + FTopScope:=Scope; + writeln('TPasResolver.PushScope ScopeCount=',ScopeCount,' ',GetObjName(FTopScope),' IsDefault=',FDefaultScope=FTopScope); +end; + +procedure TPasResolver.SetLastMsg(MsgType: TMessageType; MsgNumber: integer; + const Fmt: String; Args: array of const; Element: TPasElement); +begin + FLastMsgType := MsgType; + FLastMsgNumber := MsgNumber; + FLastMsgPattern := Fmt; + FLastMsg := Format(Fmt,Args); + FLastElement := Element; + CreateMsgArgs(FLastMsgArgs,Args); +end; + +procedure TPasResolver.RaiseMsg(MsgNumber: integer; const Fmt: String; + Args: array of const; ErrorPosEl: TPasElement); +var + E: EPasResolve; +begin + SetLastMsg(mtError,MsgNumber,Fmt,Args,ErrorPosEl); + E:=EPasResolve.Create(FLastMsg); + E.PasElement:=ErrorPosEl; + E.MsgNumber:=MsgNumber; + E.Args:=FLastMsgArgs; + raise E; +end; + +procedure TPasResolver.RaiseNotYetImplemented(El: TPasElement; Msg: string); +begin + RaiseMsg(nNotYetImplemented,sNotYetImplemented+Msg,[GetObjName(El)],El); +end; + +procedure TPasResolver.RaiseInternalError(const Msg: string); +begin + raise Exception.Create('Internal error: '+Msg); +end; + +procedure TPasResolver.RaiseInvalidScopeForElement(El: TPasElement; + const Msg: string); +var + i: Integer; + s: String; +begin + s:='invalid scope for "'+GetObjName(El)+'": '; + for i:=0 to ScopeCount-1 do + begin + if i>0 then s:=s+','; + s:=s+Scopes[i].ClassName; + end; + if Msg<>'' then + s:=s+': '+Msg; + RaiseInternalError(s); +end; + +procedure TPasResolver.RaiseIdentifierNotFound(Identifier: string; + El: TPasElement); +begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.RaiseIdentifierNotFound START "',Identifier,'"'); + WriteScopes; + {$ENDIF} + RaiseMsg(nIdentifierNotFound,sIdentifierNotFound,[Identifier],El); +end; + +function TPasResolver.CheckProcCompatibility(Proc: TPasProcedure; + Params: TParamsExpr; RaiseOnError: boolean): TProcCompatibility; +var + ProcArgs: TFPList; + i, ParamCnt: Integer; + Param: TPasExpr; + ParamCompatibility: TProcCompatibility; +begin + Result:=pcExact; + ProcArgs:=Proc.ProcType.Args; + // check args + ParamCnt:=length(Params.Params); + i:=0; + while i=ProcArgs.Count then + begin + // too many arguments + if RaiseOnError then + RaiseMsg(nWrongNumberOfParametersForCallTo, + sWrongNumberOfParametersForCallTo,[GetProcDesc(Proc)],Param); + exit(pcIncompatible); + end; + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CheckProcCompatibility ',i,'/',ParamCnt); + {$ENDIF} + ParamCompatibility:=CheckParamCompatibility(Param,TPasArgument(ProcArgs[i]),i+1,RaiseOnError); + if ParamCompatibility=pcIncompatible then + exit(pcIncompatible); + if ord(ParamCompatibility)rkIdentifier) then exit; + if ExprType.IdentEl=nil then exit; + if ExprType.IdentEl.ClassType=TPasVariable then exit(true); + if (ExprType.IdentEl.ClassType=TPasConst) + and (TPasConst(ExprType.IdentEl).VarType<>nil) then + exit(true); // typed const are writable + end; + +var + MustFitExactly: Boolean; +begin + Result:=pcIncompatible; + MustFitExactly:=Param.Access in [argVar, argOut]; + + GetResolvedType(Expr,not MustFitExactly,ExprType); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CheckParamCompatibility Expr=',GetTreeDesc(Expr,2),' ResolvedExpr=',GetResolvedTypeDesc(ExprType)); + {$ENDIF} + if ExprType.Kind=rkNone then + RaiseInternalError('GetResolvedType returned rkNone for '+GetTreeDesc(Expr)); + + if MustFitExactly then + begin + // Expr must be a variable + if not ExprCanBeVarParam then + begin + if RaiseOnError then + RaiseMsg(nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr); + exit; + end; + end; + + GetResolvedType(Param,not MustFitExactly,ParamType); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CheckParamCompatibility Param=',GetTreeDesc(Param,2),' ResolvedParam=',GetResolvedTypeDesc(ParamType)); + {$ENDIF} + if ExprType.Kind=rkNone then + RaiseInternalError('GetResolvedType returned rkNone for '+GetTreeDesc(Param)); + if (ParamType.TypeEl=nil) and (Param.ArgType<>nil) then + RaiseInternalError('GetResolvedType returned TypeEl=nil for '+GetTreeDesc(Param)); + + if MustFitExactly then + begin + if (ParamType.Kind=ExprType.Kind) + or (ParamType.BaseType=ExprType.BaseType) then + begin + if (ParamType.TypeEl<>nil) and (ParamType.TypeEl=ExprType.TypeEl) then + exit(pcExact); + end; + if RaiseOnError then + RaiseMsg(nIncompatibleTypeArgNoVarParamMustMatchExactly, + sIncompatibleTypeArgNoVarParamMustMatchExactly, + [ParamNo,GetTypeDesc(ExprType.TypeEl),GetTypeDesc(ParamType.TypeEl)], + Expr); + exit(pcIncompatible); + end; + + // check if the Expr can be converted to Param + case ParamType.Kind of + rkIdentifier, + rkExpr: + if ExprType.Kind in [rkExpr,rkIdentifier] then + begin + if ParamType.TypeEl=nil then + begin + // ToDo: untyped parameter + end + else if ParamType.BaseType=ExprType.BaseType then + begin + // ToDo: check btFile, btText + exit(pcExact); // same base type, maybe not same type name (e.g. longint and integer) + end + else if (ParamType.BaseType in btAllNumbers) + and (ExprType.BaseType in btAllNumbers) then + exit(pcCompatible) // ToDo: range check for Expr + else if (ParamType.BaseType in btAllBooleans) + and (ExprType.BaseType in btAllBooleans) then + exit(pcCompatible) + else if (ParamType.BaseType in btAllStrings) + and (ExprType.BaseType in btAllStrings) then + exit(pcCompatible) // ToDo: check Expr if Param=btChar/btWideChar + else if (ParamType.BaseType in btAllFloats) + and (ExprType.BaseType in btAllFloats) then + exit(pcCompatible) + else if ExprType.BaseType=btNil then + begin + if ParamType.BaseType=btPointer then + exit(pcExact); + // ToDo: allow classes and custom pointers + end + else + exit(pcIncompatible); + end; + //rkArrayOf: ; + //rkPointer: ; + else + end; + + RaiseNotYetImplemented(Expr,':TPasResolver.CheckParamCompatibility: Param='+GetResolvedTypeDesc(ParamType)+' '+GetResolvedTypeDesc(ExprType)); +end; + +procedure TPasResolver.GetResolvedType(El: TPasElement; SkipTypeAlias: boolean; out + ResolvedType: TPasResolvedType); +var + bt: TResolveBaseType; +begin + ResolvedType:=Default(TPasResolvedType); + if El=nil then + exit; + if El.ClassType=TPrimitiveExpr then + begin + case TPrimitiveExpr(El).Kind of + pekIdent: + begin + if El.CustomData is TResolvedReference then + GetResolvedType(TResolvedReference(El.CustomData).Declaration,SkipTypeAlias,ResolvedType) + else + RaiseNotYetImplemented(El,': cannot resolve this'); + end; + pekNumber: + // ToDo: check if btByte, btSmallInt, ... + SetResolvedTypeExpr(ResolvedType,btLongint,TPrimitiveExpr(El)); + pekString: + SetResolvedTypeExpr(ResolvedType,btString,TPrimitiveExpr(El)); + //pekSet: + pekNil: + SetResolvedTypeExpr(ResolvedType,btNil,TPrimitiveExpr(El)); + pekBoolConst: + SetResolvedTypeExpr(ResolvedType,btBoolean,TPrimitiveExpr(El)); + //pekRange: + //pekUnary: + //pekBinary: + //pekFuncParams: + //pekArrayParams: + //pekListOfExp: + //pekInherited: + //pekSelf: + else + RaiseNotYetImplemented(El,': cannot resolve this'); + end; + end + else if El.ClassType=TPasUnresolvedSymbolRef then + begin + // built-in type + for bt in TResolveBaseType do + if CompareText(BaseTypeNames[bt],El.Name)=0 then + begin + SetResolvedType(ResolvedType,rkIdentifier,bt,nil,TPasUnresolvedSymbolRef(El)); + break; + end; + end + else if El.ClassType=TPasAliasType then + // e.f. 'var a: b' -> resolve b + GetResolvedType(TPasTypeAliasType(El).DestType,true,ResolvedType) + else if (El.ClassType=TPasTypeAliasType) and SkipTypeAlias then + // e.g. 'type a = type b;' -> resolve b + GetResolvedType(TPasTypeAliasType(El).DestType,true,ResolvedType) + else if (El.ClassType=TPasVariable) or (El.ClassType=TPasConst) + or (El.ClassType=TPasProperty) then + begin + // e.g. 'var a:b' -> resolve b, use a as IdentEl + GetResolvedType(TPasVariable(El).VarType,SkipTypeAlias,ResolvedType); + ResolvedType.IdentEl:=El; + end + else if El.ClassType=TPasArgument then + begin + if TPasArgument(El).ArgType=nil then + // untyped parameter + SetResolvedType(ResolvedType,rkIdentifier,btUntyped,El,nil) + else + begin + // typed parameter -> use param as IdentEl, resolve type + GetResolvedType(TPasArgument(El).ArgType,SkipTypeAlias,ResolvedType); + ResolvedType.IdentEl:=El; + end; + end + else + RaiseNotYetImplemented(El,': cannot resolve this'); +end; + +{ TPasIdentifierScope } + +procedure TPasIdentifierScope.OnClearItem(Item, Dummy: pointer); +var + PasIdentifier: TPasIdentifier absolute Item; + Ident: TPasIdentifier; +begin + if Dummy=nil then ; + //writeln('TPasIdentifierScope.OnClearItem ',PasIdentifier.Identifier+':'+PasIdentifier.ClassName); + while PasIdentifier<>nil do + begin + Ident:=PasIdentifier; + PasIdentifier:=PasIdentifier.NextSameIdentifier; + Ident.Free; + end; +end; + +procedure TPasIdentifierScope.OnWriteItem(Item, Dummy: pointer); +var + PasIdentifier: TPasIdentifier absolute Item; + Prefix: String; +begin + Prefix:=AnsiString(Dummy); + while PasIdentifier<>nil do + begin + writeln(Prefix,'Identifier="',PasIdentifier.Identifier,'" Element=',GetObjName(PasIdentifier.Element)); + PasIdentifier:=PasIdentifier.NextSameIdentifier; + end; +end; + +procedure TPasIdentifierScope.InternalAdd(Item: TPasIdentifier); +var + Index: Integer; + OldItem: TPasIdentifier; + LoName: ShortString; +begin + LoName:=lowercase(Item.Identifier); + Index:=FItems.FindIndexOf(LoName); + //writeln(' Index=',Index); + if Index>=0 then + begin + // insert LIFO - last in, first out + OldItem:=TPasIdentifier(FItems.List^[Index].Data); + Item.NextSameIdentifier:=OldItem; + FItems.List^[Index].Data:=Item; + end + else + FItems.Add(LoName, Item); +end; + +constructor TPasIdentifierScope.Create; +begin + FItems:=TFPHashList.Create; +end; + +destructor TPasIdentifierScope.Destroy; +begin + FItems.ForEachCall(@OnClearItem,nil); + FItems.Clear; + FreeAndNil(FItems); + inherited Destroy; +end; + +function TPasIdentifierScope.FindIdentifier(const Identifier: String + ): TPasIdentifier; +var + LoName: ShortString; +begin + LoName:=lowercase(Identifier); + Result:=TPasIdentifier(FItems.Find(LoName)); +end; + +function TPasIdentifierScope.AddIdentifier(const Identifier: String; + El: TPasElement; const Kind: TPasIdentifierKind): TPasIdentifier; +var + Item: TPasIdentifier; +begin + //writeln('TPasIdentifierScope.AddIdentifier Identifier="',Identifier,'" El=',GetObjName(El)); + Item:=TPasIdentifier.Create; + Item.Identifier:=Identifier; + Item.Element:=El; + Item.Kind:=Kind; + + InternalAdd(Item); + //writeln('TPasIdentifierScope.AddIdentifier END'); + Result:=Item; +end; + +function TPasIdentifierScope.FindElement(const aName: string): TPasElement; +var + Item: TPasIdentifier; +begin + //writeln('TPasIdentifierScope.FindElement "',aName,'"'); + Item:=FindIdentifier(aName); + if Item=nil then + Result:=nil + else + Result:=Item.Element; + //writeln('TPasIdentifierScope.FindElement Found="',GetObjName(Result),'"'); +end; + +procedure TPasIdentifierScope.IterateElements(const aName: string; + const OnIterateElement: TIterateScopeElement; Data: Pointer; + var Abort: boolean); +var + Item: TPasIdentifier; +begin + Item:=FindIdentifier(aName); + while Item<>nil do + begin + // writeln('TPasIdentifierScope.IterateElements ',Item.Identifier,' ',GetObjName(Item.Element)); + OnIterateElement(Item.Element,Self,Data,Abort); + if Abort then exit; + Item:=Item.NextSameIdentifier; + end; +end; + +procedure TPasIdentifierScope.WriteIdentifiers(Prefix: string); +begin + inherited WriteIdentifiers(Prefix); + Prefix:=Prefix+' '; + FItems.ForEachCall(@OnWriteItem,Pointer(Prefix)); +end; + +end. + diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 5cfa02cde1..e928cc59c0 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -121,8 +121,11 @@ type Visibility: TPasMemberVisibility; public constructor Create(const AName: string; AParent: TPasElement); virtual; + destructor Destroy; override; procedure AddRef; procedure Release; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); virtual; function FullPath: string; function ParentPath: string; function FullName: string; virtual; // Name including parent's names @@ -159,14 +162,18 @@ type TPasExpr = class(TPasElement) Kind : TPasExprKind; OpCode : TExprOpCode; - constructor Create(AParent : TPasElement; AKind: TPasExprKind; AOpCode: TexprOpcode); virtual; overload; + constructor Create(AParent : TPasElement; AKind: TPasExprKind; AOpCode: TExprOpCode); virtual; overload; end; + { TUnaryExpr } + TUnaryExpr = class(TPasExpr) Operand : TPasExpr; constructor Create(AParent : TPasElement; AOperand: TPasExpr; AOpCode: TExprOpCode); overload; function GetDeclaration(full : Boolean) : string; override; destructor Destroy; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; end; { TBinaryExpr } @@ -178,6 +185,8 @@ type constructor CreateRange(AParent : TPasElement; xleft, xright: TPasExpr); overload; function GetDeclaration(full : Boolean) : string; override; destructor Destroy; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; end; TPrimitiveExpr = class(TPasExpr) @@ -214,16 +223,20 @@ type function GetDeclaration(full : Boolean) : string; override; end; + TPasExprArray = array of TPasExpr; + { TParamsExpr } TParamsExpr = class(TPasExpr) Value : TPasExpr; - Params : array of TPasExpr; + Params : TPasExprArray; {pekArray, pekFuncCall, pekSet} constructor Create(AParent : TPasElement; AKind: TPasExprKind); overload; function GetDeclaration(full : Boolean) : string; override; destructor Destroy; override; procedure AddParam(xp: TPasExpr); + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; end; { TRecordValues } @@ -239,16 +252,20 @@ type destructor Destroy; override; procedure AddField(const AName: AnsiString; Value: TPasExpr); function GetDeclaration(full : Boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; end; { TArrayValues } TArrayValues = class(TPasExpr) - Values : array of TPasExpr; + Values : TPasExprArray; constructor Create(AParent : TPasElement); overload; destructor Destroy; override; procedure AddValues(AValue: TPasExpr); function GetDeclaration(full : Boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; end; { TPasDeclarations } @@ -258,8 +275,12 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; function ElementTypeName: string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - Declarations, ResStrings, Types, Consts, Classes, + Declarations: TFPList; // list of TPasElement + // Declarations contains all the following: + ResStrings, Types, Consts, Classes, Functions, Variables, Properties, ExportSymbols: TFPList; end; @@ -270,6 +291,8 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; procedure AddUnitToUsesList(const AUnitName: string); + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public UsesList: TFPList; // TPasUnresolvedTypeRef or TPasModule elements end; @@ -300,6 +323,8 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public InterfaceSection: TInterfaceSection; ImplementationSection: TImplementationSection; @@ -309,18 +334,20 @@ type Filename : String; // the IN filename, only written when not empty. end; - { TPasProgram } - { TPasUnitModule } TPasUnitModule = Class(TPasModule) function ElementTypeName: string; override; end; + { TPasProgram } + TPasProgram = class(TPasModule) Public destructor Destroy; override; function ElementTypeName: string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; Public ProgramSection: TProgramSection; InputFile,OutPutFile : String; @@ -332,6 +359,8 @@ type Public destructor Destroy; override; function ElementTypeName: string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; Public LibrarySection: TLibrarySection; InputFile,OutPutFile : String; @@ -344,6 +373,8 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; function ElementTypeName: string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public Modules: TFPList; // List of TPasModule objects end; @@ -355,6 +386,8 @@ type Destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : Boolean) : string; Override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public Expr: TPasExpr; end; @@ -373,6 +406,8 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : Boolean): string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public DestType: TPasType; end; @@ -384,6 +419,8 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : Boolean): string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public DestType: TPasType; end; @@ -410,6 +447,8 @@ type public function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public RangeExpr : TBinaryExpr; Destructor Destroy; override; @@ -424,6 +463,8 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public IndexRange : string; PackMode : TPackMode; @@ -439,6 +480,8 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public ElType: TPasType; end; @@ -448,6 +491,8 @@ type TPasEnumValue = class(TPasElement) public function ElementTypeName: string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public Value: TPasExpr; Destructor Destroy; override; @@ -463,6 +508,8 @@ type function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; Procedure GetEnumNames(Names : TStrings); + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public Values: TFPList; // List of TPasEnumValue objects end; @@ -474,6 +521,8 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public EnumType: TPasType; end; @@ -487,8 +536,10 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - Values: TFPList; + Values: TFPList; // list of TPasElement Members: TPasRecordType; end; @@ -502,8 +553,10 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - PackMode : TPackMode; + PackMode: TPackMode; Members: TFPList; // array of TPasVariable elements VariantName: string; VariantType: TPasType; @@ -524,19 +577,20 @@ type constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; function ElementTypeName: string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - PackMode : TPackMode; + PackMode: TPackMode; ObjKind: TPasObjKind; AncestorType: TPasType; // TPasClassType or TPasUnresolvedTypeRef HelperForType: TPasType; // TPasClassType or TPasUnresolvedTypeRef - IsForward : Boolean; + IsForward: Boolean; IsShortDefinition: Boolean;//class(anchestor); without end GUIDExpr : TPasExpr; - Members: TFPList; // array of TPasElement objects - ClassVars: TFPList; // class vars + Members: TFPList; // list of TPasElement Modifiers: TStringList; - Interfaces : TFPList; - GenericTemplateTypes : TFPList; + Interfaces : TFPList; // list of TPasElement + GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType Function FindMember(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement; Function FindMemberInAncestors(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement; Function IsPacked : Boolean; @@ -554,6 +608,8 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public Access: TArgumentAccess; ArgType: TPasType; @@ -572,11 +628,13 @@ type function GetDeclaration(full : boolean) : string; override; procedure GetArguments(List : TStrings); function CreateArgument(const AName, AUnresolvedTypeName: string):TPasArgument; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public IsOfObject: Boolean; IsNested : Boolean; Args: TFPList; // List of TPasArgument objects - CallingConvention : TCallingConvention; + CallingConvention: TCallingConvention; end; { TPasResultElement } @@ -585,6 +643,8 @@ type public destructor Destroy; override; function ElementTypeName : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public ResultType: TPasType; end; @@ -597,6 +657,8 @@ type class function TypeName: string; override; function ElementTypeName: string; override; function GetDeclaration(Full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public ResultEl: TPasResultElement; end; @@ -627,9 +689,12 @@ type function ElementTypeName: string; override; end; - { TPasTypeRef } + { TPasTypeRef - not used by TPasParser } TPasTypeRef = class(TPasUnresolvedTypeRef) + public + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public RefType: TPasType; end; @@ -643,6 +708,8 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public VarType: TPasType; VarModifiers : TVariableModifiers; @@ -658,10 +725,12 @@ type TPasExportSymbol = class(TPasElement) public ExportName : TPasExpr; - Exportindex : TPasExpr; + ExportIndex : TPasExpr; Destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; end; { TPasConst } @@ -681,6 +750,8 @@ type destructor Destroy; override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public IndexExpr, DefaultExpr : TPasExpr; @@ -708,10 +779,14 @@ type destructor Destroy; override; function ElementTypeName: string; override; function TypeName: string; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public Overloads: TFPList; // List of TPasProcedure nodes end; + { TPasProcedure } + TProcedureModifier = (pmVirtual, pmDynamic, pmAbstract, pmOverride, pmExport, pmOverload, pmMessage, pmReintroduce, pmStatic,pmInline,pmAssembler,pmVarargs, pmPublic, @@ -734,6 +809,8 @@ type function TypeName: string; override; function GetDeclaration(full: Boolean): string; override; procedure GetModifiers(List: TStrings); + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public ProcType : TPasProcedureType; Body : TProcedureBody; @@ -760,7 +837,7 @@ type TPasFunction = class(TPasProcedure) private - function GetFT: TPasFunctionType; + function GetFT: TPasFunctionType; inline; public function ElementTypeName: string; override; function TypeName: string; override; @@ -862,8 +939,9 @@ Type public constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - Labels: TFPList; Body: TPasImplBlock; end; @@ -902,11 +980,11 @@ Type TPasImplElement = class(TPasElement) end; - { TPasImplCommand } + { TPasImplCommand - currently used as empty statement, e.g. if then else ; } TPasImplCommand = class(TPasImplElement) public - Command: string; + Command: string; // never set by TPasParser end; { TPasImplCommands - used by mkxmlrpc, not used by pparser } @@ -923,7 +1001,7 @@ Type TPasLabels = class(TPasImplElement) public - Labels : TStrings; + Labels: TStrings; constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; end; @@ -959,7 +1037,7 @@ Type function AddCaseOf(const Expression: TPasExpr): TPasImplCaseOf; function AddForLoop(AVar: TPasVariable; const AStartValue, AEndValue: TPasExpr): TPasImplForLoop; - function AddForLoop(const AVarName : String; AStartValue, AEndValue: TPasExpr; + function AddForLoop(AVarName : TPasExpr; AStartValue, AEndValue: TPasExpr; ADownTo: Boolean = false): TPasImplForLoop; function AddTry: TPasImplTry; function AddExceptOn(const VarName, TypeName: TPasExpr): TPasImplExceptOn; @@ -968,8 +1046,10 @@ Type function AddAssign(left, right: TPasExpr): TPasImplAssign; function AddSimple(exp: TPasExpr): TPasImplSimple; function CloseOnSemicolon: boolean; virtual; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - Elements: TFPList; // TPasImplElement objects + Elements: TFPList; // list of TPasImplElement and maybe one TPasImplCaseElse end; { TPasImplStatement } @@ -1012,6 +1092,8 @@ Type ConditionExpr : TPasExpr; destructor Destroy; override; Function Condition: string; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; end; { TPasImplIfElse } @@ -1021,8 +1103,10 @@ Type destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; function CloseOnSemicolon: boolean; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - ConditionExpr : TPasExpr; + ConditionExpr: TPasExpr; IfBranch: TPasImplElement; ElseBranch: TPasImplElement; // can be nil Function Condition: string; @@ -1034,6 +1118,8 @@ Type public destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public ConditionExpr : TPasExpr; Body: TPasImplElement; @@ -1048,15 +1134,17 @@ Type destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; procedure AddExpression(const Expression: TPasExpr); + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - Expressions: TFPList; + Expressions: TFPList; // list of TPasExpr Body: TPasImplElement; end; TPasImplCaseStatement = class; TPasImplCaseElse = class; - { TPasImplCaseOf } + { TPasImplCaseOf - Elements are TPasImplCaseStatement } TPasImplCaseOf = class(TPasImplBlock) public @@ -1064,9 +1152,11 @@ Type procedure AddElement(Element: TPasImplElement); override; function AddCase(const Expression: TPasExpr): TPasImplCaseStatement; function AddElse: TPasImplCaseElse; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public CaseExpr : TPasExpr; - ElseBranch: TPasImplCaseElse; + ElseBranch: TPasImplCaseElse; // this is also in Elements function Expression: string; end; @@ -1078,8 +1168,10 @@ Type destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; procedure AddExpression(const Expr: TPasExpr); + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - Expressions: TFPList; + Expressions: TFPList; // list of TPasExpr Body: TPasImplElement; end; @@ -1094,13 +1186,15 @@ Type public destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public - Variable: TPasVariable; + VariableName : TPasExpr; + LoopType : TLoopType; StartExpr : TPasExpr; EndExpr : TPasExpr; - VariableName : String; - LoopType : TLoopType; Body: TPasImplElement; + Variable: TPasVariable; // not used by TPasParser Function Down: boolean; // downto, backward compatibility Function StartValue : String; Function EndValue: string; @@ -1114,6 +1208,8 @@ Type right : TPasExpr; Kind : TAssignKind; Destructor Destroy; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; end; { TPasImplSimple } @@ -1122,6 +1218,8 @@ Type public expr : TPasExpr; Destructor Destroy; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; end; TPasImplTryHandler = class; @@ -1137,6 +1235,8 @@ Type function AddFinally: TPasImplTryFinally; function AddExcept: TPasImplTryExcept; function AddExceptElse: TPasImplTryExceptElse; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public FinallyExcept: TPasImplTryHandler; ElseBranch: TPasImplTryExceptElse; @@ -1166,6 +1266,8 @@ Type public destructor Destroy; override; procedure AddElement(Element: TPasImplElement); override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; public VarExpr,TypeExpr : TPasExpr; Body: TPasImplElement; @@ -1178,6 +1280,8 @@ Type TPasImplRaise = class(TPasImplStatement) public destructor Destroy; override; + procedure ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); override; Public ExceptObject, ExceptAddr : TPasExpr; @@ -1191,7 +1295,7 @@ Type TPasImplLabelMark = class(TPasImplElement) public - LabelId: AnsiString; + LabelId: AnsiString; end; const @@ -1205,9 +1309,25 @@ const ObjKindNames: array[TPasObjKind] of string = ( 'object', 'class', 'interface','class','class','class helper','record helper','type helper'); - - OpcodeStrings : Array[TExprOpCode] of string = - ('','+','-','*','/','div','mod','**', + + ExprKindNames : Array[TPasExprKind] of string = ( + 'Ident', + 'Number', + 'String', + 'Set', + 'Nil', + 'BoolConst', + 'Range', + 'Unary', + 'Binary', + 'FuncParams', + 'ArrayParams', + 'ListOfExp', + 'Inherited', + 'Self'); + + OpcodeStrings : Array[TExprOpCode] of string = ( + '','+','-','*','/','div','mod','**', 'shr','shl', 'not','and','or','xor', '=','<>', @@ -1243,10 +1363,29 @@ const 'static','inline','assembler','varargs', 'public', 'compilerproc','external','forward'); +procedure ReleaseAndNil(var El: TPasElement); overload; + implementation uses SysUtils; +procedure ReleaseAndNil(var El: TPasElement); +begin + if El=nil then exit; + El.Release; + El:=nil; +end; + +{ TPasTypeRef } + +procedure TPasTypeRef.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if RefType<>nil then + RefType.ForEachCall(aMethodCall,Arg); +end; + { TPasClassOperator } function TPasClassOperator.TypeName: string; @@ -1280,16 +1419,26 @@ end; destructor TPasImplRaise.Destroy; begin - FreeAndNil(ExceptObject); - FreeAndNil(ExceptAddr); + ReleaseAndNil(TPasElement(ExceptObject)); + ReleaseAndNil(TPasElement(ExceptAddr)); Inherited; end; +procedure TPasImplRaise.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ExceptObject<>nil then + ExceptObject.ForEachCall(aMethodCall,Arg); + if ExceptAddr<>nil then + ExceptAddr.ForEachCall(aMethodCall,Arg); +end; + { TPasImplRepeatUntil } destructor TPasImplRepeatUntil.Destroy; begin - FreeAndNil(ConditionExpr); + ReleaseAndNil(TPasElement(ConditionExpr)); inherited Destroy; end; @@ -1301,29 +1450,55 @@ begin Result:=''; end; +procedure TPasImplRepeatUntil.ForEachCall( + const aMethodCall: TListCallback; const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ConditionExpr<>nil then + ConditionExpr.ForEachCall(aMethodCall,Arg); +end; + { TPasImplSimple } destructor TPasImplSimple.Destroy; begin - FreeAndNil(Expr); + ReleaseAndNil(TPasElement(Expr)); inherited Destroy; end; +procedure TPasImplSimple.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if expr<>nil then + expr.ForEachCall(aMethodCall,Arg); +end; + { TPasImplAssign } destructor TPasImplAssign.Destroy; begin - FreeAndNil(Left); - FreeAndNil(Right); + ReleaseAndNil(TPasElement(Left)); + ReleaseAndNil(TPasElement(Right)); inherited Destroy; end; +procedure TPasImplAssign.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if left<>nil then + left.ForEachCall(aMethodCall,Arg); + if right<>nil then + right.ForEachCall(aMethodCall,Arg); +end; + { TPasExportSymbol } destructor TPasExportSymbol.Destroy; begin - FreeAndNil(ExportName); - FreeAndNil(ExportIndex); + ReleaseAndNil(TPasElement(ExportName)); + ReleaseAndNil(TPasElement(ExportIndex)); inherited Destroy; end; @@ -1341,6 +1516,16 @@ begin Result:=Result+' index '+ExportIndex.GetDeclaration(Full); end; +procedure TPasExportSymbol.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ExportName<>nil then + ExportName.ForEachCall(aMethodCall,Arg); + if ExportIndex<>nil then + ExportIndex.ForEachCall(aMethodCall,Arg); +end; + { TPasUnresolvedUnitRef } function TPasUnresolvedUnitRef.ElementTypeName: string; @@ -1352,7 +1537,7 @@ end; destructor TPasLibrary.Destroy; begin - FreeAndNil(LibrarySection); + ReleaseAndNil(TPasElement(LibrarySection)); inherited Destroy; end; @@ -1361,11 +1546,19 @@ begin Result:=inherited ElementTypeName; end; +procedure TPasLibrary.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + if LibrarySection<>nil then + LibrarySection.ForEachCall(aMethodCall,Arg); + inherited ForEachCall(aMethodCall, Arg); +end; + { TPasProgram } destructor TPasProgram.Destroy; begin - FreeAndNil(ProgramSection); + ReleaseAndNil(TPasElement(ProgramSection)); inherited Destroy; end; @@ -1374,6 +1567,14 @@ begin Result:=inherited ElementTypeName; end; +procedure TPasProgram.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + if ProgramSection<>nil then + ProgramSection.ForEachCall(aMethodCall,Arg); + inherited ForEachCall(aMethodCall, Arg); +end; + { TPasUnitModule } function TPasUnitModule.ElementTypeName: string; @@ -1393,7 +1594,7 @@ end; function TPasElement.ElementTypeName: string; begin Result := SPasTreeElement end; -Function TPasElement.HintsString: String; +function TPasElement.HintsString: String; Var H : TPasmemberHint; @@ -1410,8 +1611,30 @@ begin end; function TPasDeclarations.ElementTypeName: string; begin Result := SPasTreeSection end; + +procedure TPasDeclarations.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Declarations.Count-1 do + TPasElement(Declarations[i]).ForEachCall(aMethodCall,Arg); +end; + function TPasModule.ElementTypeName: string; begin Result := SPasTreeModule end; function TPasPackage.ElementTypeName: string; begin Result := SPasTreePackage end; + +procedure TPasPackage.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Modules.Count-1 do + TPasModule(Modules[i]).ForEachCall(aMethodCall,Arg); +end; + function TPasResString.ElementTypeName: string; begin Result := SPasTreeResString end; function TPasType.ElementTypeName: string; begin Result := SPasTreeType end; function TPasPointerType.ElementTypeName: string; begin Result := SPasTreePointerType end; @@ -1423,9 +1646,17 @@ function TPasArrayType.ElementTypeName: string; begin Result := SPasTreeArrayTyp function TPasFileType.ElementTypeName: string; begin Result := SPasTreeFileType end; function TPasEnumValue.ElementTypeName: string; begin Result := SPasTreeEnumValue end; +procedure TPasEnumValue.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if Value<>nil then + Value.ForEachCall(aMethodCall,Arg); +end; + destructor TPasEnumValue.Destroy; begin - FreeAndNil(Value); + ReleaseAndNil(TPasElement(Value)); inherited Destroy; end; @@ -1443,6 +1674,15 @@ function TPasRecordType.ElementTypeName: string; begin Result := SPasTreeRecordT function TPasArgument.ElementTypeName: string; begin Result := SPasTreeArgument end; function TPasProcedureType.ElementTypeName: string; begin Result := SPasTreeProcedureType end; function TPasResultElement.ElementTypeName: string; begin Result := SPasTreeResultElement end; + +procedure TPasResultElement.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ResultType<>nil then + ResultType.ForEachCall(aMethodCall,Arg); +end; + function TPasFunctionType.ElementTypeName: string; begin Result := SPasTreeFunctionType end; function TPasUnresolvedTypeRef.ElementTypeName: string; begin Result := SPasTreeUnresolvedTypeRef end; function TPasVariable.ElementTypeName: string; begin Result := SPasTreeVariable end; @@ -1558,76 +1798,6 @@ function TPasConstructorImpl.ElementTypeName: string; begin Result := SPasTreeCo function TPasDestructorImpl.ElementTypeName: string; begin Result := SPasTreeDestructorImpl end; function TPasStringType.ElementTypeName: string; begin Result:=SPasStringType;end; -function TPasClassType.ElementTypeName: string; -begin - case ObjKind of - okObject: Result := SPasTreeObjectType; - okClass: Result := SPasTreeClassType; - okInterface: Result := SPasTreeInterfaceType; - okGeneric : Result := SPasTreeGenericType; - okSpecialize : Result := SPasTreeSpecializedType; - okClassHelper : Result:=SPasClassHelperType; - okRecordHelper : Result:=SPasRecordHelperType; - end; -end; - -function TPasClassType.FindMember(MemberClass: TPTreeElement; const MemberName: String): TPasElement; - -Var - I : Integer; - -begin -// Writeln('Looking for ',MemberName,'(',MemberClass.ClassName,') in ',Name); - Result:=Nil; - I:=0; - While (Result=Nil) and (IMemberClass) or (CompareText(Result.Name,MemberName)<>0) then - Result:=Nil; - Inc(I); - end; -end; - -function TPasClassType.FindMemberInAncestors(MemberClass: TPTreeElement; - const MemberName: String): TPasElement; - - Function A (C : TPasClassType) : TPasClassType; - - begin - if C.AncestorType is TPasClassType then - result:=TPasClassType(C.AncestorType) - else - result:=Nil; - end; - -Var - C : TPasClassType; - -begin - Result:=Nil; - C:=A(Self); - While (Result=Nil) and (C<>Nil) do - begin - Result:=C.FindMember(MemberClass,MemberName); - C:=A(C); - end; -end; - -function TPasClassType.InterfaceGUID: string; -begin - If Assigned(GUIDExpr) then - Result:=GUIDExpr.GetDeclaration(True) - else - Result:='' -end; - -function TPasClassType.IsPacked: Boolean; -begin - Result:=PackMode<>pmNone; -end; - - { All other stuff: } @@ -1654,6 +1824,13 @@ begin FParent := AParent; end; +destructor TPasElement.Destroy; +begin + if FRefCount>0 then + raise Exception.Create(''); + inherited Destroy; +end; + procedure TPasElement.AddRef; begin Inc(FRefCount); @@ -1683,6 +1860,12 @@ begin {$ifdef debugrefcount} Writeln('Released : ',Cn); {$endif} end; +procedure TPasElement.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + aMethodCall(Self,Arg); +end; + function TPasElement.FullPath: string; var @@ -1810,9 +1993,9 @@ begin InterfaceSection.Release; if Assigned(ImplementationSection) then ImplementationSection.Release; - FreeAndNil(InitializationSection); - FreeAndNil(FinalizationSection); - inherited Destroy; + ReleaseAndNil(TPasElement(InitializationSection)); + ReleaseAndNil(TPasElement(FinalizationSection)); + inherited Destroy; end; @@ -1896,6 +2079,16 @@ begin end; end; +procedure TPasEnumType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Values.Count-1 do + TPasEnumValue(Values[i]).ForEachCall(aMethodCall,Arg); +end; + destructor TPasSetType.Destroy; begin @@ -1920,7 +2113,7 @@ Var begin For I:=0 to Values.Count-1 do - TObject(Values[i]).Free; + TPasElement(Values[i]).Release; Values.Free; if Assigned(Members) then Members.Release; @@ -1952,6 +2145,19 @@ begin end; end; +procedure TPasVariant.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Values.Count-1 do + TPasElement(Values[i]).ForEachCall(aMethodCall,Arg); + if Members<>nil then + Members.ForEachCall(aMethodCall,Arg); +end; + +{ TPasRecordType } constructor TPasRecordType.Create(const AName: string; AParent: TPasElement); begin @@ -1980,6 +2186,7 @@ begin inherited Destroy; end; +{ TPasClassType } constructor TPasClassType.Create(const AName: string; AParent: TPasElement); begin @@ -1988,10 +2195,8 @@ begin IsShortDefinition := False; Members := TFPList.Create; Modifiers := TStringList.Create; - ClassVars := TFPList.Create; Interfaces:= TFPList.Create; GenericTemplateTypes:=TFPList.Create; - end; destructor TPasClassType.Destroy; @@ -2007,9 +2212,8 @@ begin AncestorType.Release; if Assigned(HelperForType) then HelperForType.Release; - FreeAndNil(GUIDExpr); + ReleaseAndNil(TPasElement(GUIDExpr)); Modifiers.Free; - ClassVars.Free; Interfaces.Free; for i := 0 to GenericTemplateTypes.Count - 1 do TPasElement(GenericTemplateTypes[i]).Release; @@ -2017,15 +2221,107 @@ begin inherited Destroy; end; +function TPasClassType.ElementTypeName: string; +begin + case ObjKind of + okObject: Result := SPasTreeObjectType; + okClass: Result := SPasTreeClassType; + okInterface: Result := SPasTreeInterfaceType; + okGeneric : Result := SPasTreeGenericType; + okSpecialize : Result := SPasTreeSpecializedType; + okClassHelper : Result:=SPasClassHelperType; + okRecordHelper : Result:=SPasRecordHelperType; + end; +end; + +procedure TPasClassType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + + if AncestorType<>nil then + AncestorType.ForEachCall(aMethodCall,Arg); + for i:=0 to Interfaces.Count-1 do + TPasElement(Interfaces[i]).ForEachCall(aMethodCall,Arg); + if HelperForType<>nil then + HelperForType.ForEachCall(aMethodCall,Arg); + if GUIDExpr<>nil then + GUIDExpr.ForEachCall(aMethodCall,Arg); + for i:=0 to Members.Count-1 do + TPasElement(Members[i]).ForEachCall(aMethodCall,Arg); + for i:=0 to GenericTemplateTypes.Count-1 do + TPasElement(GenericTemplateTypes[i]).ForEachCall(aMethodCall,Arg); +end; + +function TPasClassType.FindMember(MemberClass: TPTreeElement; const MemberName: String): TPasElement; + +Var + I : Integer; + +begin +// Writeln('Looking for ',MemberName,'(',MemberClass.ClassName,') in ',Name); + Result:=Nil; + I:=0; + While (Result=Nil) and (IMemberClass) or (CompareText(Result.Name,MemberName)<>0) then + Result:=Nil; + Inc(I); + end; +end; + +function TPasClassType.FindMemberInAncestors(MemberClass: TPTreeElement; + const MemberName: String): TPasElement; + + Function A (C : TPasClassType) : TPasClassType; + + begin + if C.AncestorType is TPasClassType then + result:=TPasClassType(C.AncestorType) + else + result:=Nil; + end; + +Var + C : TPasClassType; + +begin + Result:=Nil; + C:=A(Self); + While (Result=Nil) and (C<>Nil) do + begin + Result:=C.FindMember(MemberClass,MemberName); + C:=A(C); + end; +end; + +function TPasClassType.InterfaceGUID: string; +begin + If Assigned(GUIDExpr) then + Result:=GUIDExpr.GetDeclaration(True) + else + Result:='' +end; + +function TPasClassType.IsPacked: Boolean; +begin + Result:=PackMode<>pmNone; +end; + + +{ TPasArgument } destructor TPasArgument.Destroy; begin - if Assigned(ArgType) then - ArgType.Release; - FreeAndNil(ValueExpr); + ReleaseAndNil(TPasElement(ArgType)); + ReleaseAndNil(TPasElement(ValueExpr)); inherited Destroy; end; +{ TPasProcedureType } constructor TPasProcedureType.Create(const AName: string; AParent: TPasElement); begin @@ -2056,6 +2352,17 @@ begin Result.ArgType := TPasUnresolvedTypeRef.Create(AUnresolvedTypeName, Result); end; +procedure TPasProcedureType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Args.Count-1 do + TPasElement(Args[i]).ForEachCall(aMethodCall,Arg); +end; + +{ TPasResultElement } destructor TPasResultElement.Destroy; begin @@ -2081,6 +2388,7 @@ end; constructor TPasUnresolvedTypeRef.Create(const AName: string; AParent: TPasElement); begin + if AParent=nil then ; inherited Create(AName, nil); end; @@ -2090,10 +2398,8 @@ begin // FreeAndNil(Expr); { Attention, in derived classes, VarType isn't necessarily set! (e.g. in Constants) } - if Assigned(VarType) then - VarType.Release; - if Assigned(Expr) then - Expr.Release; + ReleaseAndNil(TPasElement(VarType)); + ReleaseAndNil(TPasElement(Expr)); inherited Destroy; end; @@ -2111,8 +2417,8 @@ begin for i := 0 to Args.Count - 1 do TPasArgument(Args[i]).Release; Args.Free; - FreeAndNil(DefaultExpr); - FreeAndNil(IndexExpr); + ReleaseAndNil(TPasElement(DefaultExpr)); + ReleaseAndNil(TPasElement(IndexExpr)); inherited Destroy; end; @@ -2141,6 +2447,16 @@ begin SetLength(Result, 0); end; +procedure TPasOverloadedProc.ForEachCall( + const aMethodCall: TListCallback; const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Overloads.Count-1 do + TPasProcedure(Overloads[i]).ForEachCall(aMethodCall,Arg); +end; + function TPasProcedure.GetCallingConvention: TCallingConvention; begin Result:=ccDefault; @@ -2160,9 +2476,9 @@ begin ProcType.Release; if Assigned(Body) then Body.Release; - FreeAndNil(PublicName); - FreeAndNil(LibraryExpr); - FreeAndNil(LibrarySymbolName); + ReleaseAndNil(TPasElement(PublicName)); + ReleaseAndNil(TPasElement(LibraryExpr)); + ReleaseAndNil(TPasElement(LibrarySymbolName)); inherited Destroy; end; @@ -2226,11 +2542,9 @@ end; destructor TPasImplIfElse.Destroy; begin - FreeAndNil(ConditionExpr); - if Assigned(IfBranch) then - IfBranch.Release; - if Assigned(ElseBranch) then - ElseBranch.Release; + ReleaseAndNil(TPasElement(ConditionExpr)); + ReleaseAndNil(TPasElement(IfBranch)); + ReleaseAndNil(TPasElement(ElseBranch)); inherited Destroy; end; @@ -2256,6 +2570,18 @@ begin Result:=ElseBranch<>nil; end; +procedure TPasImplIfElse.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ConditionExpr<>nil then + ConditionExpr.ForEachCall(aMethodCall,Arg); + if IfBranch<>nil then + IfBranch.ForEachCall(aMethodCall,Arg); + if ElseBranch<>nil then + ElseBranch.ForEachCall(aMethodCall,Arg); +end; + function TPasImplIfElse.Condition: string; begin If Assigned(ConditionExpr) then @@ -2264,12 +2590,11 @@ end; destructor TPasImplForLoop.Destroy; begin - FreeAndNil(StartExpr); - FreeAndNil(EndExpr); - if Assigned(Variable) then - Variable.Release; - if Assigned(Body) then - Body.Release; + ReleaseAndNil(TPasElement(VariableName)); + ReleaseAndNil(TPasElement(StartExpr)); + ReleaseAndNil(TPasElement(EndExpr)); + ReleaseAndNil(TPasElement(Variable)); + ReleaseAndNil(TPasElement(Body)); inherited Destroy; end; @@ -2285,6 +2610,22 @@ begin raise Exception.Create('TPasImplForLoop.AddElement body already set - please report this bug'); end; +procedure TPasImplForLoop.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if VariableName<>nil then + VariableName.ForEachCall(aMethodCall,Arg); + if Variable<>nil then + Variable.ForEachCall(aMethodCall,Arg); + if StartExpr<>nil then + StartExpr.ForEachCall(aMethodCall,Arg); + if EndExpr<>nil then + EndExpr.ForEachCall(aMethodCall,Arg); + if Body<>nil then + Body.ForEachCall(aMethodCall,Arg); +end; + function TPasImplForLoop.Down: boolean; begin Result:=(LoopType=ltDown); @@ -2390,7 +2731,7 @@ begin AddElement(Result); end; -function TPasImplBlock.AddForLoop(const AVarName: String; AStartValue, +function TPasImplBlock.AddForLoop(AVarName: TPasExpr; AStartValue, AEndValue: TPasExpr; ADownTo: Boolean): TPasImplForLoop; begin Result := TPasImplForLoop.Create('', Self); @@ -2450,6 +2791,16 @@ begin Result:=false; end; +procedure TPasImplBlock.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Elements.Count-1 do + TPasElement(Elements[i]).ForEachCall(aMethodCall,Arg); +end; + { --------------------------------------------------------------------- @@ -2461,6 +2812,20 @@ begin Result := 'Unit ' + Name; end; +procedure TPasModule.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if InterfaceSection<>nil then + InterfaceSection.ForEachCall(aMethodCall,Arg); + if ImplementationSection<>nil then + ImplementationSection.ForEachCall(aMethodCall,Arg); + if InitializationSection<>nil then + InitializationSection.ForEachCall(aMethodCall,Arg); + if FinalizationSection<>nil then + FinalizationSection.ForEachCall(aMethodCall,Arg); +end; + { function TPas.GetDeclaration : string; begin @@ -2468,7 +2833,7 @@ begin end; } -function TPasResString.GetDeclaration (full : boolean) : string; +function TPasResString.GetDeclaration(full: Boolean): string; begin Result:=Expr.GetDeclaration(true); If Full Then @@ -2478,6 +2843,14 @@ begin end; end; +procedure TPasResString.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if Expr<>nil then + Expr.ForEachCall(aMethodCall,Arg); +end; + destructor TPasResString.Destroy; begin If Assigned(Expr) then @@ -2485,7 +2858,7 @@ begin inherited Destroy; end; -function TPasPointerType.GetDeclaration (full : boolean) : string; +function TPasPointerType.GetDeclaration(full: Boolean): string; begin Result:='^'+DestType.Name; If Full then @@ -2495,7 +2868,15 @@ begin end; end; -function TPasAliasType.GetDeclaration (full : boolean) : string; +procedure TPasPointerType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if DestType<>nil then + DestType.ForEachCall(aMethodCall,Arg); +end; + +function TPasAliasType.GetDeclaration(full: Boolean): string; begin Result:=DestType.Name; If Full then @@ -2505,6 +2886,14 @@ begin end; end; +procedure TPasAliasType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if DestType<>nil then + DestType.ForEachCall(aMethodCall,Arg); +end; + function TPasClassOfType.GetDeclaration (full : boolean) : string; begin Result:='Class of '+DestType.Name; @@ -2525,9 +2914,17 @@ begin end; end; +procedure TPasRangeType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if RangeExpr<>nil then + RangeExpr.ForEachCall(aMethodCall,Arg); +end; + destructor TPasRangeType.Destroy; begin - FreeAndNil(RangeExpr); + ReleaseAndNil(TPasElement(RangeExpr)); inherited Destroy; end; @@ -2560,6 +2957,14 @@ begin end; end; +procedure TPasArrayType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ElType<>nil then + ElType.ForEachCall(aMethodCall,Arg); +end; + function TPasArrayType.IsGenericArray: Boolean; begin Result:=elType is TPasGenericTemplateType; @@ -2582,6 +2987,14 @@ begin end; end; +procedure TPasFileType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ElType<>nil then + ElType.ForEachCall(aMethodCall,Arg); +end; + Function IndentStrings(S : TStrings; indent : Integer) : string; Var @@ -2663,6 +3076,14 @@ begin ProcessHints(False,Result); end; +procedure TPasSetType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if EnumType<>nil then + EnumType.ForEachCall(aMethodCall,Arg); +end; + procedure TPasRecordType.GetMembers(S: TStrings); Var @@ -2746,6 +3167,21 @@ begin end; end; +procedure TPasRecordType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Members.Count-1 do + TPasElement(Members[i]).ForEachCall(aMethodCall,Arg); + if VariantType<>nil then + VariantType.ForEachCall(aMethodCall,Arg); + if Variants<>nil then + for i:=0 to Variants.Count-1 do + TPasElement(Variants[i]).ForEachCall(aMethodCall,Arg); +end; + function TPasRecordType.IsPacked: Boolean; begin Result:=(PackMode <> pmNone); @@ -2817,7 +3253,7 @@ begin end; end; -function TPasFunctionType.GetDeclaration (full : boolean) : string; +function TPasFunctionType.GetDeclaration(Full: boolean): string; Var S : TStringList; @@ -2850,6 +3286,14 @@ begin end; end; +procedure TPasFunctionType.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ResultEl<>nil then + ResultEl.ForEachCall(aMethodCall,Arg); +end; + function TPasVariable.GetDeclaration (full : boolean) : string; Const @@ -2875,6 +3319,15 @@ begin end; end; +procedure TPasVariable.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if VarType<>nil then + VarType.ForEachCall(aMethodCall,Arg); + if Expr<>nil then + Expr.ForEachCall(aMethodCall,Arg); +end; function TPasVariable.Value: String; @@ -2924,6 +3377,20 @@ begin ProcessHints(True, Result); end; +procedure TPasProperty.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + if IndexExpr<>nil then + IndexExpr.ForEachCall(aMethodCall,Arg); + for i:=0 to Args.Count-1 do + TPasElement(Args[i]).ForEachCall(aMethodCall,Arg); + if DefaultExpr<>nil then + DefaultExpr.ForEachCall(aMethodCall,Arg); +end; + function TPasProperty.ResolvedType: TPasType; Function GC(P : TPasProperty) : TPasClassType; @@ -2974,7 +3441,7 @@ begin Result:=''; end; -Procedure TPasProcedure.GetModifiers(List : TStrings); +procedure TPasProcedure.GetModifiers(List: TStrings); Procedure DoAdd(B : Boolean; S : string); @@ -2994,33 +3461,49 @@ begin DoAdd(IsMessage,' Message'); end; -Procedure TPasProcedure.AddModifier(AModifier : TProcedureModifier); +procedure TPasProcedure.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if PublicName<>nil then + PublicName.ForEachCall(aMethodCall,Arg); + if ProcType<>nil then + ProcType.ForEachCall(aMethodCall,Arg); + if LibraryExpr<>nil then + LibraryExpr.ForEachCall(aMethodCall,Arg); + if LibrarySymbolName<>nil then + LibrarySymbolName.ForEachCall(aMethodCall,Arg); + if Body<>nil then + Body.ForEachCall(aMethodCall,Arg); +end; + +procedure TPasProcedure.AddModifier(AModifier: TProcedureModifier); begin Include(FModifiers,AModifier); end; -Function TPasProcedure.IsVirtual : Boolean; +function TPasProcedure.IsVirtual: Boolean; begin Result:=pmVirtual in FModifiers; end; -Function TPasProcedure.IsDynamic : Boolean; +function TPasProcedure.IsDynamic: Boolean; begin Result:=pmDynamic in FModifiers; end; -Function TPasProcedure.IsAbstract : Boolean; +function TPasProcedure.IsAbstract: Boolean; begin Result:=pmAbstract in FModifiers; end; -Function TPasProcedure.IsOverride : Boolean; +function TPasProcedure.IsOverride: Boolean; begin Result:=pmOverride in FModifiers; end; -Function TPasProcedure.IsExported : Boolean; +function TPasProcedure.IsExported: Boolean; begin Result:=pmExport in FModifiers; end; @@ -3030,22 +3513,22 @@ begin Result:=pmExternal in FModifiers; end; -Function TPasProcedure.IsOverload : Boolean; +function TPasProcedure.IsOverload: Boolean; begin Result:=pmOverload in FModifiers; end; -Function TPasProcedure.IsMessage: Boolean; +function TPasProcedure.IsMessage: Boolean; begin Result:=pmMessage in FModifiers; end; -Function TPasProcedure.IsReintroduced : Boolean; +function TPasProcedure.IsReintroduced: Boolean; begin Result:=pmReintroduce in FModifiers; end; -Function TPasProcedure.IsStatic : Boolean; +function TPasProcedure.IsStatic: Boolean; begin Result:=pmStatic in FModifiers; @@ -3056,7 +3539,7 @@ begin Result:=pmForward in FModifiers; end; -function TPasProcedure.GetDeclaration (full : boolean) : string; +function TPasProcedure.GetDeclaration(full: Boolean): string; Var S : TStringList; @@ -3196,6 +3679,16 @@ begin Result:=''; end; +procedure TPasArgument.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ArgType<>nil then + ArgType.ForEachCall(aMethodCall,Arg); + if ValueExpr<>nil then + ValueExpr.ForEachCall(aMethodCall,Arg); +end; + function TPasArgument.Value: String; begin If Assigned(ValueExpr) then @@ -3204,8 +3697,6 @@ begin Result:=''; end; - - { TPassTreeVisitor } procedure TPassTreeVisitor.Visit(obj: TPasElement); @@ -3237,29 +3728,44 @@ begin UsesList.Add(TPasUnresolvedTypeRef.Create(AUnitName, Self)); end; +procedure TPasSection.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to UsesList.Count-1 do + TPasElement(UsesList[i]).ForEachCall(aMethodCall,Arg); +end; + { TProcedureBody } constructor TProcedureBody.Create(const AName: string; AParent: TPasElement); begin inherited Create(AName, AParent); - Labels:=TFPList.Create; end; destructor TProcedureBody.Destroy; begin - FreeAndNil(Labels); if Assigned(Body) then Body.Release; inherited Destroy; end; +procedure TProcedureBody.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if Body<>nil then + Body.ForEachCall(aMethodCall,Arg); +end; + { TPasImplWhileDo } destructor TPasImplWhileDo.Destroy; begin - FreeAndNil(ConditionExpr); - if Assigned(Body) then - Body.Release; + ReleaseAndNil(TPasElement(ConditionExpr)); + ReleaseAndNil(TPasElement(Body)); inherited Destroy; end; @@ -3275,6 +3781,16 @@ begin raise Exception.Create('TPasImplWhileDo.AddElement body already set - please report this bug'); end; +procedure TPasImplWhileDo.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if ConditionExpr<>nil then + ConditionExpr.ForEachCall(aMethodCall,Arg); + if Body<>nil then + Body.ForEachCall(aMethodCall,Arg); +end; + function TPasImplWhileDo.Condition: string; begin If Assigned(ConditionExpr) then @@ -3285,9 +3801,8 @@ end; destructor TPasImplCaseOf.Destroy; begin - FreeAndNil(CaseExpr); - if Assigned(ElseBranch) then - ElseBranch.Release; + ReleaseAndNil(TPasElement(CaseExpr)); + ReleaseAndNil(TPasElement(ElseBranch)); inherited Destroy; end; @@ -3313,6 +3828,16 @@ begin AddElement(Result); end; +procedure TPasImplCaseOf.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if CaseExpr<>nil then + CaseExpr.ForEachCall(aMethodCall,Arg); + if ElseBranch<>nil then + ElseBranch.ForEachCall(aMethodCall,Arg); +end; + function TPasImplCaseOf.Expression: string; begin if Assigned(CaseExpr) then @@ -3337,10 +3862,9 @@ Var begin For I:=0 to Expressions.Count-1 do - TPasExpr(Expressions[i]).Free; + TPasExpr(Expressions[i]).Release; FreeAndNil(Expressions); - if Assigned(Body) then - Body.Release; + ReleaseAndNil(TPasElement(Body)); inherited Destroy; end; @@ -3359,6 +3883,18 @@ begin Expressions.Add(Expr); end; +procedure TPasImplCaseStatement.ForEachCall( + const aMethodCall: TListCallback; const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Expressions.Count-1 do + TPasElement(Expressions[i]).ForEachCall(aMethodCall,Arg); + if Body<>nil then + Body.ForEachCall(aMethodCall,Arg); +end; + { TPasImplWithDo } constructor TPasImplWithDo.Create(const AName: string; AParent: TPasElement); @@ -3374,7 +3910,7 @@ begin if Assigned(Body) then Body.Release; For I:=0 to Expressions.Count-1 do - TObject(Expressions[i]).Free; + TPasExpr(Expressions[i]).Release; FreeAndNil(Expressions); inherited Destroy; end; @@ -3394,6 +3930,18 @@ begin Expressions.Add(Expression); end; +procedure TPasImplWithDo.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to Expressions.Count-1 do + TPasElement(Expressions[i]).ForEachCall(aMethodCall,Arg); + if Body<>nil then + Body.ForEachCall(aMethodCall,Arg); +end; + { TPasImplTry } destructor TPasImplTry.Destroy; @@ -3423,14 +3971,23 @@ begin ElseBranch:=Result; end; +procedure TPasImplTry.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if FinallyExcept<>nil then + FinallyExcept.ForEachCall(aMethodCall,Arg); + if ElseBranch<>nil then + ElseBranch.ForEachCall(aMethodCall,Arg); +end; + { TPasImplExceptOn } destructor TPasImplExceptOn.Destroy; begin - FreeAndNil(VarExpr); - FreeAndNil(TypeExpr); - if Assigned(Body) then - Body.Release; + ReleaseAndNil(TPasElement(VarExpr)); + ReleaseAndNil(TPasElement(TypeExpr)); + ReleaseAndNil(TPasElement(Body)); inherited Destroy; end; @@ -3444,6 +4001,18 @@ begin end; end; +procedure TPasImplExceptOn.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if VarExpr<>nil then + VarExpr.ForEachCall(aMethodCall,Arg); + if TypeExpr<>nil then + TypeExpr.ForEachCall(aMethodCall,Arg); + if Body<>nil then + Body.ForEachCall(aMethodCall,Arg); +end; + function TPasImplExceptOn.VariableName: String; begin If assigned(VarExpr) then @@ -3510,7 +4079,7 @@ end; { TUnaryExpr } -Function TUnaryExpr.GetDeclaration(Full : Boolean):AnsiString; +function TUnaryExpr.GetDeclaration(full: Boolean): string; begin Result:=OpCodeStrings[Opcode]; @@ -3526,7 +4095,16 @@ end; destructor TUnaryExpr.Destroy; begin - Operand.Free; + if Assigned(Operand) then + Operand.Release; +end; + +procedure TUnaryExpr.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if Operand<>nil then + Operand.ForEachCall(aMethodCall,Arg); end; { TBinaryExpr } @@ -3594,14 +4172,26 @@ end; destructor TBinaryExpr.Destroy; begin - left.Free; - right.Free; + if Assigned(left) then left.Release; + left:=nil; + if Assigned(right) then right.Release; + right:=nil; inherited Destroy; end; +procedure TBinaryExpr.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + if left<>nil then + left.ForEachCall(aMethodCall,Arg); + if right<>nil then + right.ForEachCall(aMethodCall,Arg); +end; + { TParamsExpr } -Function TParamsExpr.GetDeclaration(Full: Boolean) : Ansistring; +function TParamsExpr.GetDeclaration(full: Boolean): string; Var I : Integer; @@ -3629,6 +4219,18 @@ begin Params[i]:=xp; end; +procedure TParamsExpr.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + if Value<>nil then + Value.ForEachCall(aMethodCall,Arg); + for i:=0 to Length(Params)-1 do + Params[i].ForEachCall(aMethodCall,Arg); +end; + constructor TParamsExpr.Create(AParent : TPasElement; AKind: TPasExprKind); begin inherited Create(AParent,AKind, eopNone) @@ -3638,14 +4240,14 @@ destructor TParamsExpr.Destroy; var i : Integer; begin - FreeAndNil(Value); - for i:=0 to length(Params)-1 do Params[i].Free; + ReleaseAndNil(TPasElement(Value)); + for i:=0 to length(Params)-1 do Params[i].Release; inherited Destroy; end; { TRecordValues } -Function TRecordValues.GetDeclaration(Full : Boolean):AnsiString; +function TRecordValues.GetDeclaration(full: Boolean): string; Var I : Integer; @@ -3660,6 +4262,18 @@ begin Result:='('+Result+')'; end; +procedure TRecordValues.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to length(Fields)-1 do + with Fields[i] do + if ValueExp<>nil then + ValueExp.ForEachCall(aMethodCall,Arg); +end; + constructor TRecordValues.Create(AParent : TPasElement); begin inherited Create(AParent,pekListOfExp, eopNone); @@ -3669,7 +4283,8 @@ destructor TRecordValues.Destroy; var i : Integer; begin - for i:=0 to length(Fields)-1 do Fields[i].ValueExp.Free; + for i:=0 to length(Fields)-1 do + Fields[i].ValueExp.Release; inherited Destroy; end; @@ -3706,7 +4321,7 @@ end; { TArrayValues } -Function TArrayValues.GetDeclaration(Full: Boolean):AnsiString; +function TArrayValues.GetDeclaration(full: Boolean): string; Var I : Integer; @@ -3722,6 +4337,16 @@ begin Result:='('+Result+')'; end; +procedure TArrayValues.ForEachCall(const aMethodCall: TListCallback; + const Arg: Pointer); +var + i: Integer; +begin + inherited ForEachCall(aMethodCall, Arg); + for i:=0 to length(Values)-1 do + Values[i].ForEachCall(aMethodCall,Arg); +end; + constructor TArrayValues.Create(AParent : TPasElement); begin inherited Create(AParent,pekListOfExp, eopNone) @@ -3731,7 +4356,8 @@ destructor TArrayValues.Destroy; var i : Integer; begin - for i:=0 to length(Values)-1 do Values[i].Free; + for i:=0 to length(Values)-1 do + Values[i].Release; inherited Destroy; end; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index c62b6320f1..0e4224eaa2 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -71,6 +71,8 @@ const nParserGenericArray1Element = 2044; nParserGenericClassOrArray = 2045; nParserDuplicateIdentifier = 2046; + nParserDefaultParameterRequiredFor = 2047; + nParserOnlyOneVariableCanBeInitialized = 2048; // resourcestring patterns of messages @@ -121,8 +123,26 @@ resourcestring SParserGenericArray1Element = 'Generic arrays can have only 1 template element'; SParserGenericClassOrArray = 'Generic can only be used with classes or arrays'; SParserDuplicateIdentifier = 'Duplicate identifier "%s"'; + SParserDefaultParameterRequiredFor = 'Default parameter required for "%s"'; + SParserOnlyOneVariableCanBeInitialized = 'Only one variable can be initialized'; type + TPasScopeType = ( + stModule, // e.g. unit, program, library + stUsesList, + stTypeSection, + stTypeDef, // e.g. the B in 'type A=B;' + //stConstDef, // e.g. the B in 'const A=B;' + stProcedure, // also method, procedure, constructor, destructor, ... + stProcedureHeader, + stExceptOnExpr, + stExceptOnStatement + //stDeclaration, // e.g. the A in 'type A=B;' + //stStatement, + //stAncestors // the list of ancestors and interfaces of a class + ); + TPasScopeTypes = set of TPasScopeType; + TPasParserLogHandler = Procedure (Sender : TObject; Const Msg : String) of object; TPParserLogEvent = (pleInterface,pleImplementation); TPParserLogEvents = set of TPParserLogEvent; @@ -140,6 +160,7 @@ type protected FPackage: TPasPackage; FInterfaceOnly : Boolean; + procedure SetCurrentParser(AValue: TPasParser); virtual; public function CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement; const ASourceFilename: String; @@ -148,18 +169,22 @@ type AParent: TPasElement; AVisibility: TPasMemberVisibility; const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;overload; virtual; abstract; + function CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASrcPos: TPasSourcePos): TPasElement; overload; + virtual; function CreateFunctionType(const AName, AResultName: String; AParent: TPasElement; - UseParentAsResultParent: Boolean; const ASourceFilename: String; - ASourceLinenumber: Integer): TPasFunctionType; + UseParentAsResultParent: Boolean; const ASrcPos: TPasSourcePos): TPasFunctionType; function FindElement(const AName: String): TPasElement; virtual; abstract; + procedure FinishScope(ScopeType: TPasScopeType); virtual; function FindModule(const AName: String): TPasModule; virtual; property Package: TPasPackage read FPackage; property InterfaceOnly : Boolean Read FInterfaceOnly Write FInterFaceOnly; - Property ScannerLogEvents : TPScannerLogEvents Read FScannerLogEvents Write FScannerLogEvents; - Property ParserLogEvents : TPParserLogEvents Read FPParserLogEvents Write FPParserLogEvents; - Property OnLog : TPasParserLogHandler Read FOnLog Write FOnLog; - Property CurrentParser : TPasParser Read FCurrentParser; - Property NeedComments : Boolean Read FNeedComments Write FNeedComments; + property ScannerLogEvents : TPScannerLogEvents Read FScannerLogEvents Write FScannerLogEvents; + property ParserLogEvents : TPParserLogEvents Read FPParserLogEvents Write FPParserLogEvents; + property OnLog : TPasParserLogHandler Read FOnLog Write FOnLog; + property CurrentParser : TPasParser Read FCurrentParser Write SetCurrentParser; + property NeedComments : Boolean Read FNeedComments Write FNeedComments; end; EParserError = class(Exception) @@ -233,7 +258,9 @@ type procedure ParseClassMembers(AType: TPasClassType); procedure ProcessMethod(AType: TPasClassType; IsClass : Boolean; AVisibility : TPasMemberVisibility); procedure ReadGenericArguments(List : TFPList;Parent : TPasElement); - function CheckProcedureArgs(Parent: TPasElement; Args: TFPList; Mandatory: Boolean): boolean; + function CheckProcedureArgs(Parent: TPasElement; + Args: TFPList; // list of TPasArgument + Mandatory: Boolean): boolean; function CheckVisibility(S: String; var AVisibility: TPasMemberVisibility): Boolean; procedure ParseExc(MsgNumber: integer; const Msg: String); procedure ParseExc(MsgNumber: integer; const Fmt: String; Args : Array of const); @@ -243,7 +270,9 @@ type function OpLevel(t: TToken): Integer; Function TokenToExprOp (AToken : TToken) : TExprOpCode; function CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement): TPasElement;overload; + function CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement; const ASrcPos: TPasSourcePos): TPasElement;overload; function CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility): TPasElement;overload; + function CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility; const ASrcPos: TPasSourcePos): TPasElement;overload; function CreatePrimitiveExpr(AParent: TPasElement; AKind: TPasExprKind; const AValue: String): TPrimitiveExpr; function CreateBoolConstExpr(AParent: TPasElement; AKind: TPasExprKind; const ABoolValue : Boolean): TBoolConstExpr; function CreateBinaryExpr(AParent : TPasElement; xleft, xright: TPasExpr; AOpCode: TExprOpCode): TBinaryExpr; @@ -265,8 +294,8 @@ type function ParseParams(AParent : TPasElement;paramskind: TPasExprKind): TParamsExpr; function ParseExpIdent(AParent : TPasElement): TPasExpr; procedure DoParseClassType(AType: TPasClassType); - function DoParseExpression(Aparent : TPaselement;InitExpr: TPasExpr=nil): TPasExpr; - function DoParseConstValueExpression(AParent : TPasElement): TPasExpr; + function DoParseExpression(AParent: TPaselement;InitExpr: TPasExpr=nil): TPasExpr; + function DoParseConstValueExpression(AParent: TPasElement): TPasExpr; function CheckPackMode: TPackMode; function CheckUseUnit(ASection: TPasSection; AUnitName : string): TPasElement; procedure CheckImplicitUsedUnits(ASection: TPasSection); @@ -293,21 +322,21 @@ type // Type declarations function ParseComplexType(Parent : TPasElement = Nil): TPasType; function ParseTypeDecl(Parent: TPasElement): TPasType; - function ParseType(Parent: TPasElement; Const TypeName : String = '';Full : Boolean = False): TPasType; - function ParseProcedureType(Parent: TPasElement; const TypeName: String; const PT: TProcType): TPasProcedureType; - function ParseStringType(Parent: TPasElement; const TypeName: String): TPasAliasType; - function ParseSimpleType(Parent: TPasElement; Const TypeName: String; IsFull : Boolean = False): TPasType; - function ParseAliasType(Parent: TPasElement; Const TypeName: String): TPasTypeAliasType; - function ParsePointerType(Parent: TPasElement; Const TypeName: String): TPasPointerType; - Function ParseArrayType(Parent : TPasElement; Const TypeName : String; PackMode : TPackMode) : TPasArrayType; - Function ParseFileType(Parent : TPasElement; Const TypeName : String) : TPasFileType; - Function ParseRecordDecl(Parent: TPasElement; Const TypeName : string; const Packmode : TPackMode = pmNone) : TPasRecordType; - function ParseEnumType(Parent: TPasElement; const TypeName: String): TPasEnumType; - function ParseSetType(Parent: TPasElement; const TypeName: String ): TPasSetType; + function ParseType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName : String = ''; Full : Boolean = False): TPasType; + function ParseProcedureType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; const PT: TProcType): TPasProcedureType; + function ParseStringType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasAliasType; + function ParseSimpleType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; IsFull : Boolean = False): TPasType; + function ParseAliasType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasTypeAliasType; + function ParsePointerType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasPointerType; + Function ParseArrayType(Parent : TPasElement; Const NamePos: TPasSourcePos; Const TypeName : String; PackMode : TPackMode) : TPasArrayType; + Function ParseFileType(Parent : TPasElement; Const NamePos: TPasSourcePos; Const TypeName : String) : TPasFileType; + Function ParseRecordDecl(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName : string; const Packmode : TPackMode = pmNone) : TPasRecordType; + function ParseEnumType(Parent: TPasElement; Const NamePos: TPasSourcePos; const TypeName: String): TPasEnumType; + function ParseSetType(Parent: TPasElement; Const NamePos: TPasSourcePos; const TypeName: String ): TPasSetType; function ParseSpecializeType(Parent: TPasElement; Const TypeName: String): TPasClassType; - Function ParseClassDecl(Parent: TPasElement; const AClassName: String; AObjKind: TPasObjKind; PackMode : TPackMode= pmNone): TPasType; + Function ParseClassDecl(Parent: TPasElement; Const AClassName: String; AObjKind: TPasObjKind; PackMode : TPackMode= pmNone): TPasType; Function ParseProperty(Parent : TPasElement; Const AName : String; AVisibility : TPasMemberVisibility) : TPasProperty; - function ParseRangeType(AParent: TPasElement; Const TypeName: String; Full : Boolean = True): TPasRangeType; + function ParseRangeType(AParent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; Full: Boolean = True): TPasRangeType; procedure ParseExportDecl(Parent: TPasElement; List: TFPList); // Constant declarations function ParseConstDecl(Parent: TPasElement): TPasConst; @@ -332,7 +361,9 @@ type procedure ParseProcBeginBlock(Parent: TProcedureBody); // Function/Procedure declaration function ParseProcedureOrFunctionDecl(Parent: TPasElement; ProcType: TProcType;AVisibility : TPasMemberVisibility = VisDefault): TPasProcedure; - procedure ParseArgList(Parent: TPasElement; Args: TFPList; EndToken: TToken); + procedure ParseArgList(Parent: TPasElement; + Args: TFPList; // list of TPasArgument + EndToken: TToken); procedure ParseProcedureOrFunctionHeader(Parent: TPasElement; Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean); procedure ParseProcedureBody(Parent: TPasElement); // Properties for external access @@ -586,6 +617,12 @@ end; TPasTreeContainer ---------------------------------------------------------------------} +procedure TPasTreeContainer.SetCurrentParser(AValue: TPasParser); +begin + if FCurrentParser=AValue then Exit; + FCurrentParser:=AValue; +end; + function TPasTreeContainer.CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement; const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; @@ -594,14 +631,22 @@ begin ASourceLinenumber); end; +function TPasTreeContainer.CreateElement(AClass: TPTreeElement; + const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASrcPos: TPasSourcePos): TPasElement; +begin + Result := CreateElement(AClass, AName, AParent, AVisibility, ASrcPos.FileName, + ASrcPos.Row); +end; + function TPasTreeContainer.CreateFunctionType(const AName, AResultName: String; AParent: TPasElement; UseParentAsResultParent: Boolean; - const ASourceFilename: String; ASourceLinenumber: Integer): TPasFunctionType; + const ASrcPos: TPasSourcePos): TPasFunctionType; var ResultParent: TPasElement; begin Result := TPasFunctionType(CreateElement(TPasFunctionType, AName, AParent, - ASourceFilename, ASourceLinenumber)); + visDefault, ASrcPos)); if UseParentAsResultParent then ResultParent := AParent @@ -610,7 +655,12 @@ begin TPasFunctionType(Result).ResultEl := TPasResultElement(CreateElement(TPasResultElement, AResultName, ResultParent, - ASourceFilename, ASourceLinenumber)); + visDefault, ASrcPos)); +end; + +procedure TPasTreeContainer.FinishScope(ScopeType: TPasScopeType); +begin + if ScopeType=stModule then ; end; function TPasTreeContainer.FindModule(const AName: String): TPasModule; @@ -677,7 +727,7 @@ begin FCommentsBuffer[1]:=TStringList.Create; if Assigned(FEngine) then begin - FEngine.FCurrentParser:=Self; + FEngine.CurrentParser:=Self; If FEngine.NeedComments then FScanner.SkipComments:=Not FEngine.NeedComments; end; @@ -687,11 +737,14 @@ end; destructor TPasParser.Destroy; begin + if Assigned(FEngine) then + begin + FEngine.CurrentParser:=Nil; + FEngine:=nil; + end; FreeAndNil(FImplicitUses); FreeAndNil(FCommentsBuffer[0]); FreeAndNil(FCommentsBuffer[1]); - if Assigned(FEngine) then - FEngine.FCurrentParser:=Nil; inherited Destroy; end; @@ -929,14 +982,16 @@ begin AName:=SimpleTypeCaseNames[I]; end; -function TPasParser.ParseStringType(Parent: TPasElement; const TypeName: String - ): TPasAliasType; +function TPasParser.ParseStringType(Parent: TPasElement; + const NamePos: TPasSourcePos; const TypeName: String): TPasAliasType; Var S : String; + ok: Boolean; begin - Result := TPasAliasType(CreateElement(TPasAliasType, TypeName, Parent)); + Result := TPasAliasType(CreateElement(TPasAliasType, TypeName, Parent, NamePos)); + ok:=false; try If (Result.Name='') then Result.Name:='string'; @@ -953,16 +1008,18 @@ begin end else UngetToken; - Result.DestType:=TPasStringType(CreateElement(TPasStringType,'string',Nil)); + Result.DestType:=TPasStringType(CreateElement(TPasStringType,'string',Parent)); TPasStringType(Result.DestType).LengthExpr:=S; - except - FreeAndNil(Result); - Raise; + ok:=true; + finally + if not ok then + Result.Release; end; end; function TPasParser.ParseSimpleType(Parent: TPasElement; - const TypeName: String; IsFull: Boolean): TPasType; + const NamePos: TPasSourcePos; const TypeName: String; IsFull: Boolean + ): TPasType; Type TSimpleTypeKind = (stkAlias,stkString,stkRange); @@ -986,8 +1043,13 @@ begin begin if (CurToken=tkSemicolon) or isCurTokenHint then // Type A = B; K:=stkAlias - else if (CurToken=tkSquaredBraceOpen) then // Type A = String[12]; - K:=stkString + else if (CurToken=tkSquaredBraceOpen) then + begin + if ((LowerCase(Name)='string') or (LowerCase(Name)='ansistring')) then // Type A = String[12]; + K:=stkString + else + ParseExcSyntaxError; + end else // Type A = A..B; K:=stkRange; UnGetToken; @@ -1001,32 +1063,32 @@ begin begin UnGetToken; K:=stkAlias; - if (LowerCase(Name)='string') then + if (not (po_resolvestandardtypes in Options)) and (LowerCase(Name)='string') then K:=stkString; end; Case K of stkString: begin - Result:=ParseStringType(Parent,TypeName); + Result:=ParseStringType(Parent,NamePos,TypeName); end; stkRange: begin UnGetToken; - Result:=ParseRangeType(Parent,TypeName,False); + Result:=ParseRangeType(Parent,NamePos,TypeName,False); end; stkAlias: begin Ref:=Nil; - SS:=isSimpleTypeToken(Name); + SS:=(not (po_resolvestandardtypes in FOptions)) and isSimpleTypeToken(Name); if not SS then Ref:=Engine.FindElement(Name); if (Ref=Nil) then - Ref:=TPasUnresolvedTypeRef(CreateElement(TPasUnresolvedTypeRef,Name,Nil)) + Ref:=TPasUnresolvedTypeRef(CreateElement(TPasUnresolvedTypeRef,Name,Parent)) else Ref.AddRef; if isFull then begin - Result := TPasAliasType(CreateElement(TPasAliasType, TypeName, Parent)); + Result := TPasAliasType(CreateElement(TPasAliasType, TypeName, Parent, NamePos)); TPasAliasType(Result).DestType:=Ref as TPasType; end else @@ -1036,39 +1098,49 @@ begin end; // On entry, we're on the TYPE token -function TPasParser.ParseAliasType(Parent: TPasElement; const TypeName: String - ): TPasTypeAliasType; +function TPasParser.ParseAliasType(Parent: TPasElement; + const NamePos: TPasSourcePos; const TypeName: String): TPasTypeAliasType; +var + ok: Boolean; begin - Result := TPasTypeAliasType(CreateElement(TPasTypeAliasType, TypeName, Parent)); + Result := TPasTypeAliasType(CreateElement(TPasTypeAliasType, TypeName, Parent, NamePos)); + ok:=false; try - Result.DestType := ParseType(Result,''); - except - FreeAndNil(Result); - raise; + Result.DestType := ParseType(Result,NamePos,''); + ok:=true; + finally + if not ok then + Result.Release; end; end; -function TPasParser.ParsePointerType(Parent: TPasElement; const TypeName: String - ): TPasPointerType; +function TPasParser.ParsePointerType(Parent: TPasElement; + const NamePos: TPasSourcePos; const TypeName: String): TPasPointerType; +var + ok: Boolean; begin - Result := TPasPointerType(CreateElement(TPasPointerType, TypeName, Parent)); + Result := TPasPointerType(CreateElement(TPasPointerType, TypeName, Parent, NamePos)); + ok:=false; Try - TPasPointerType(Result).DestType := ParseType(Result); - except - FreeAndNil(Result); - Raise; + TPasPointerType(Result).DestType := ParseType(Result,Scanner.CurSourcePos); + ok:=true; + finally + if not ok then + Result.Release; end; end; -function TPasParser.ParseEnumType(Parent: TPasElement; const TypeName: String - ): TPasEnumType; +function TPasParser.ParseEnumType(Parent: TPasElement; + const NamePos: TPasSourcePos; const TypeName: String): TPasEnumType; Var EnumValue: TPasEnumValue; + ok: Boolean; begin - Result := TPasEnumType(CreateElement(TPasEnumType, TypeName, Parent)); + Result := TPasEnumType(CreateElement(TPasEnumType, TypeName, Parent, NamePos)); + ok:=false; try while True do begin @@ -1092,28 +1164,34 @@ begin else if not (CurToken=tkComma) then ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket) end; - except - FreeAndNil(Result); - Raise; + ok:=true; + finally + if not ok then + Result.Release; end; end; -function TPasParser.ParseSetType(Parent: TPasElement; const TypeName: String - ): TPasSetType; +function TPasParser.ParseSetType(Parent: TPasElement; + const NamePos: TPasSourcePos; const TypeName: String): TPasSetType; +var + ok: Boolean; begin - Result := TPasSetType(CreateElement(TPasSetType, TypeName, Parent)); + Result := TPasSetType(CreateElement(TPasSetType, TypeName, Parent, NamePos)); + ok:=false; try ExpectToken(tkOf); - Result.EnumType := ParseType(Result,'',False); - except - Result.Free; - raise; + Result.EnumType := ParseType(Result,Scanner.CurSourcePos); + ok:=true; + finally + if not ok then + Result.Release; end; end; -function TPasParser.ParseType(Parent: TPasElement; const TypeName: String; - Full: Boolean): TPasType; +function TPasParser.ParseType(Parent: TPasElement; + const NamePos: TPasSourcePos; const TypeName: String; Full: Boolean + ): TPasType; Const // These types are allowed only when full type declarations @@ -1122,7 +1200,7 @@ Const NoHintTokens = [tkProcedure,tkFunction]; var PM : TPackMode; - CH : Boolean; // Check hint ? + CH , ok: Boolean; // Check hint ? begin Result := nil; Pm:=CheckPackMode; @@ -1134,6 +1212,7 @@ begin if (CurToken in FullTypeTokens) then ParseExc(nParserTypeNotAllowedHere,SParserTypeNotAllowedHere,[CurtokenText]); end; + ok:=false; Try case CurToken of // types only allowed when full @@ -1141,16 +1220,16 @@ begin tkInterface: Result := ParseClassDecl(Parent, TypeName, okInterface); tkSpecialize: Result:=ParseSpecializeType(Parent,TypeName); tkClass: Result := ParseClassDecl(Parent, TypeName, okClass, PM); - tkType: Result:=ParseAliasType(Parent,TypeName); + tkType: Result:=ParseAliasType(Parent,NamePos,TypeName); // Always allowed - tkIdentifier: Result:=ParseSimpleType(Parent,TypeName,Full); - tkCaret: Result:=ParsePointerType(Parent,TypeName); - tkFile: Result:=ParseFileType(Parent,TypeName); - tkArray: Result:=ParseArrayType(Parent,TypeName,pm); - tkBraceOpen: Result:=ParseEnumType(Parent,TypeName); - tkSet: Result:=ParseSetType(Parent,TypeName); - tkProcedure: Result:=ParseProcedureType(Parent,TypeName,ptProcedure); - tkFunction: Result:=ParseProcedureType(Parent,TypeName,ptFunction); + tkIdentifier: Result:=ParseSimpleType(Parent,NamePos,TypeName,Full); + tkCaret: Result:=ParsePointerType(Parent,NamePos,TypeName); + tkFile: Result:=ParseFileType(Parent,NamePos,TypeName); + tkArray: Result:=ParseArrayType(Parent,NamePos,TypeName,pm); + tkBraceOpen: Result:=ParseEnumType(Parent,NamePos,TypeName); + tkSet: Result:=ParseSetType(Parent,NamePos,TypeName); + tkProcedure: Result:=ParseProcedureType(Parent,NamePos,TypeName,ptProcedure); + tkFunction: Result:=ParseProcedureType(Parent,NamePos,TypeName,ptFunction); tkRecord: begin NextToken; @@ -1162,18 +1241,20 @@ begin else begin UnGetToken; - Result := ParseRecordDecl(Parent,TypeName,PM); + Result := ParseRecordDecl(Parent,NamePos,TypeName,PM); end; end; else UngetToken; - Result:=ParseRangeType(Parent,TypeName,Full); + Result:=ParseRangeType(Parent,NamePos,TypeName,Full); end; if CH then CheckHint(Result,True); - Except - FreeAndNil(Result); - Raise; + ok:=true; + finally + if not ok then + if Result<>nil then + Result.Release; end; end; @@ -1197,18 +1278,21 @@ begin end; else UngetToken; - Result := ParseType(Parent); + Result := ParseType(Parent,Scanner.CurSourcePos); end; end; -function TPasParser.ParseArrayType(Parent: TPasElement; const TypeName: String; - PackMode: TPackMode): TPasArrayType; +function TPasParser.ParseArrayType(Parent: TPasElement; + const NamePos: TPasSourcePos; const TypeName: String; PackMode: TPackMode + ): TPasArrayType; Var S : String; + ok: Boolean; begin - Result := TPasArrayType(CreateElement(TPasArrayType, TypeName, Parent)); + Result := TPasArrayType(CreateElement(TPasArrayType, TypeName, Parent, NamePos)); + ok:=false; try Result.PackMode:=PackMode; NextToken; @@ -1223,7 +1307,7 @@ begin until CurToken = tkSquaredBraceClose; Result.IndexRange:=S; ExpectToken(tkOf); - Result.ElType := ParseType(Result); + Result.ElType := ParseType(Result,Scanner.CurSourcePos); end; tkOf: begin @@ -1232,27 +1316,26 @@ begin else begin UngetToken; - Result.ElType := ParseType(Result); + Result.ElType := ParseType(Result,Scanner.CurSourcePos); end end else ParseExc(nParserArrayTypeSyntaxError,SParserArrayTypeSyntaxError); end; - except - FreeAndNil(Result); - Raise; + ok:=true; + finally + if not ok then + Result.Release; end; end; -function TPasParser.ParseFileType(Parent: TPasElement; const TypeName: String - ): TPasFileType; - - +function TPasParser.ParseFileType(Parent: TPasElement; + const NamePos: TPasSourcePos; const TypeName: String): TPasFileType; begin - Result:=TPasFileType(CreateElement(TPasFileType, TypeName, Parent)); + Result:=TPasFileType(CreateElement(TPasFileType, TypeName, Parent, NamePos)); NextToken; If CurToken=tkOf then - Result.ElType := ParseType(Result) + Result.ElType := ParseType(Result,Scanner.CurSourcePos) else ungettoken; end; @@ -1308,7 +1391,7 @@ begin NextToken; Result:=params; finally - if not Assigned(Result) then params.Free; + if not Assigned(Result) then params.Release; end; end; @@ -1347,7 +1430,7 @@ begin end; end; -function TPasParser.ParseExpIdent(AParent : TPasElement):TPasExpr; +function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr; var Last , Expr: TPasExpr; prm : TParamsExpr; @@ -1374,7 +1457,7 @@ begin b:=CreateBinaryExpr(AParent,Last, DoParseExpression(AParent), eopNone); if not Assigned(b.right) then begin - B.Free; + B.Release; Exit; // error end; Last:=b; @@ -1394,7 +1477,7 @@ begin b:=CreateBinaryExpr(AParent,Last, ParseExpIdent(AParent), TokenToExprOp(optk)); if not Assigned(b.right) then begin - B.Free; + B.Release; Exit; // error end; Last:=b; @@ -1437,7 +1520,7 @@ begin if CurToken=tkIdentifier then begin AddToBinaryExprChain(Result,Last, - CreatePrimitiveExpr(AParent,pekIdent, CurTokenText), eopSubIdent); + CreatePrimitiveExpr(AParent,pekIdent,CurTokenString), eopSubIdent); NextToken; end else @@ -1485,7 +1568,7 @@ begin ok:=true; finally if not ok then - FreeAndNil(Result); + Result.Release; end; end; @@ -1507,10 +1590,11 @@ begin end; end; -function TPasParser.DoParseExpression(Aparent : TPaselement;InitExpr: TPasExpr): TPasExpr; +function TPasParser.DoParseExpression(AParent : TPaselement;InitExpr: TPasExpr): TPasExpr; var expstack : TFPList; - opstack : TFPList; + opstack : array of TToken; + opstackTop: integer; pcount : Integer; x : TPasExpr; i : Integer; @@ -1536,19 +1620,22 @@ const procedure PushOper(token: TToken); inline; begin - opstack.Add( Pointer(PtrInt(token)) ); + inc(opstackTop); + if opstackTop=length(opstack) then + SetLength(opstack,length(opstack)*2+4); + opstack[opstackTop]:=token; end; function PeekOper: TToken; inline; begin - if opstack.Count>0 then Result:=TToken(PtrUInt(opstack[ opstack.Count-1])) - else Result:=tkEOF + if opstackTop>=0 then Result:=opstack[opstackTop] + else Result:=tkEOF; end; function PopOper: TToken; inline; begin Result:=PeekOper; - if Result<>tkEOF then opstack.Delete(opstack.Count-1); + if Result<>tkEOF then dec(opstackTop); end; procedure PopAndPushOperator; @@ -1563,7 +1650,7 @@ const xleft:=PopExp; if t=tkDotDot then begin - bin:=CreateBinaryExpr(Aparent,xleft,xright,eopNone); + bin:=CreateBinaryExpr(AParent,xleft,xright,eopNone); bin.Kind:=pekRange; end else @@ -1575,7 +1662,8 @@ begin //DumpCurToken('Entry',iaIndent); Result:=nil; expstack := TFPList.Create; - opstack := TFPList.Create; + SetLength(opstack,4); + opstackTop:=-1; try repeat NotBinary:=True; @@ -1608,7 +1696,7 @@ begin x:=DoParseExpression(AParent); if CurToken<>tkBraceClose then begin - x.free; + x.Release; Exit; end; NextToken; @@ -1654,7 +1742,7 @@ begin // Adjusting order of the operations NotBinary:=False; tempop:=PeekOper; - while (opstack.Count>0) and (OpLevel(tempop)>=OpLevel(CurToken)) do begin + while (opstackTop>=0) and (OpLevel(tempop)>=OpLevel(CurToken)) do begin PopAndPushOperator; tempop:=PeekOper; end; @@ -1666,7 +1754,7 @@ begin if not NotBinary then ParseExcExpectedIdentifier; - while opstack.Count>0 do PopAndPushOperator; + while opstackTop>=0 do PopAndPushOperator; // only 1 expression should be on the stack, at the end of the correct expression if expstack.Count=1 then Result:=TPasExpr(expstack[0]); @@ -1679,9 +1767,9 @@ begin if not Assigned(Result) then begin // expression error! for i:=0 to expstack.Count-1 do - TObject(expstack[i]).Free; + TPasExpr(expstack[i]).Release; end; - opstack.Free; + SetLength(opstack,0); expstack.Free; end; end; @@ -1828,7 +1916,7 @@ begin end; end; -// Return the parent of a function declaration. This is APArent, +// Return the parent of a function declaration. This is AParent, // except when AParent is a class, and the function is overloaded. // Then the parent is the overload object. function TPasParser.CheckIfOverloaded(AParent: TPasElement; const AName: String): TPasElement; @@ -1896,6 +1984,7 @@ begin If LogEvent(pleInterface) then DoLog(mtInfo,nLogStartInterface,SLogStartInterface); ParseInterface; + Engine.FinishScope(stModule); finally FCurModule:=nil; end; @@ -1945,6 +2034,7 @@ begin PP.ProgramSection := Section; ParseOptionalUsesList(Section); ParseDeclarations(Section); + Engine.FinishScope(stModule); finally FCurModule:=nil; end; @@ -1973,6 +2063,7 @@ begin PP.LibrarySection := Section; ParseOptionalUsesList(Section); ParseDeclarations(Section); + Engine.FinishScope(stModule); finally FCurModule:=nil; end; @@ -1986,6 +2077,7 @@ begin ParseUsesList(ASection) else begin CheckImplicitUsedUnits(ASection); + Engine.FinishScope(stUsesList); UngetToken; end; end; @@ -1998,7 +2090,7 @@ begin Section := TInterfaceSection(CreateElement(TInterfaceSection, '', CurModule)); CurModule.InterfaceSection := Section; ParseOptionalUsesList(Section); - ParseDeclarations(Section); + ParseDeclarations(Section); // this also parses the Implementation section end; // Starts after the "implementation" token @@ -2104,6 +2196,16 @@ end; procedure TPasParser.ParseDeclarations(Declarations: TPasDeclarations); var CurBlock: TDeclType; + + procedure SetBlock(NewBlock: TDeclType); + begin + if CurBlock=NewBlock then exit; + if CurBlock=declType then + Engine.FinishScope(stTypeDef); + CurBlock:=NewBlock; + end; + +var ConstEl: TPasConst; ResStrEl: TPasResString; TypeEl: TPasType; @@ -2116,6 +2218,7 @@ var PropEl : TPasProperty; TypeName: String; PT : TProcType; + NamePos: TPasSourcePos; begin CurBlock := declNone; @@ -2164,25 +2267,25 @@ begin else ParseExcSyntaxError; tkConst: - CurBlock := declConst; + SetBlock(declConst); tkexports: - CurBlock := declExports; + SetBlock(declExports); tkResourcestring: - CurBlock := declResourcestring; + SetBlock(declResourcestring); tkType: - CurBlock := declType; + SetBlock(declType); tkVar: - CurBlock := declVar; + SetBlock(declVar); tkThreadVar: - CurBlock := declThreadVar; + SetBlock(declThreadVar); tkProperty: - CurBlock := declProperty; + SetBlock(declProperty); tkProcedure, tkFunction, tkConstructor, tkDestructor,tkOperator: begin SaveComments; pt:=GetProcTypeFromToken(CurToken); AddProcOrFunction(Declarations, ParseProcedureOrFunctionDecl(Declarations, pt)); - CurBlock := declNone; + SetBlock(declNone); end; tkClass: begin @@ -2192,7 +2295,7 @@ begin begin pt:=GetProcTypeFromToken(CurToken,True); AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt)); - CurBlock := declNone; + SetBlock(declNone); end else ExpectToken(tkprocedure); @@ -2270,13 +2373,7 @@ begin begin List := TFPList.Create; try - try - ParseVarDecl(Declarations, List); - except - for i := 0 to List.Count - 1 do - TPasVariable(List[i]).Release; - raise; - end; + ParseVarDecl(Declarations, List); for i := 0 to List.Count - 1 do begin VarEl := TPasVariable(List[i]); @@ -2302,6 +2399,7 @@ begin if CurBlock <> declType then ParseExcSyntaxError; TypeName := ExpectIdentifier; + NamePos:=Scanner.CurSourcePos; List:=TFPList.Create; try ReadGenericArguments(List,Nil); @@ -2310,7 +2408,8 @@ begin Case CurToken of tkClass : begin - ClassEl := TPasClassType(Engine.CreateElement(TPasClassType,TypeName,Declarations, Scanner.CurFilename, Scanner.CurRow)); + ClassEl := TPasClassType(CreateElement(TPasClassType, + TypeName, Declarations, NamePos)); ClassEl.ObjKind:=okGeneric; For I:=0 to List.Count-1 do begin @@ -2327,7 +2426,7 @@ begin begin if List.Count<>1 then ParseExc(nParserGenericArray1Element,sParserGenericArray1Element); - ArrEl:=TPasArrayType(ParseArrayType(Declarations,TypeName,pmNone)); + ArrEl:=TPasArrayType(ParseArrayType(Declarations,NamePos,TypeName,pmNone)); CheckHint(ArrEl,True); ArrEl.ElType.Release; ArrEl.elType:=TPasGenericTemplateType(List[0]); @@ -2440,6 +2539,8 @@ begin if Not (CurToken in [tkComma,tkSemicolon]) then ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon); Until (CurToken=tkSemicolon); + + Engine.FinishScope(stUsesList); end; // Starts after the variable name @@ -2450,7 +2551,7 @@ begin try NextToken; if CurToken = tkColon then - Result.VarType := ParseType(Result) + Result.VarType := ParseType(Result,Scanner.CurSourcePos) else UngetToken; ExpectToken(tkEqual); @@ -2500,13 +2601,16 @@ end; // Starts after the type name function TPasParser.ParseRangeType(AParent: TPasElement; - const TypeName: String; Full: Boolean): TPasRangeType; + const NamePos: TPasSourcePos; const TypeName: String; Full: Boolean + ): TPasRangeType; Var PE : TPasExpr; + ok: Boolean; begin - Result := TPasRangeType(CreateElement(TPasRangeType, TypeName, AParent)); + Result := TPasRangeType(CreateElement(TPasRangeType, TypeName, AParent, NamePos)); + ok:=false; try if Full then begin @@ -2517,14 +2621,15 @@ begin PE:=DoParseExpression(Result,Nil); if not ((PE is TBinaryExpr) and (TBinaryExpr(PE).Kind=pekRange)) then begin - FreeAndNil(PE); + PE.Release; ParseExc(nRangeExpressionExpected,SRangeExpressionExpected); end; Result.RangeExpr:=PE as TBinaryExpr; UngetToken; - except - FreeAndNil(Result); - raise; + ok:=true; + finally + if not ok then + Result.Release; end; end; @@ -2557,32 +2662,42 @@ end; function TPasParser.ParseSpecializeType(Parent: TPasElement; const TypeName: String): TPasClassType; +var + ok: Boolean; begin - Result := TPasClassType(Engine.CreateElement(TPasClassType, TypeName, Parent, Scanner.CurFilename, Scanner.CurRow)); + Result := TPasClassType(CreateElement(TPasClassType, TypeName, Parent, + Scanner.CurSourcePos)); + ok:=false; try Result.ObjKind := okSpecialize; - Result.AncestorType := ParseType(Result); + Result.AncestorType := ParseType(Result,Scanner.CurSourcePos); Result.IsShortDefinition:=True; ReadGenericArguments(TPasClassType(Result).GenericTemplateTypes,Result); - except - FreeAndNil(Result); - Raise; + ok:=true; + finally + if not ok then + Result.Release; end; end; function TPasParser.ParseProcedureType(Parent: TPasElement; - const TypeName: String; const PT: TProcType): TPasProcedureType; + const NamePos: TPasSourcePos; const TypeName: String; const PT: TProcType + ): TPasProcedureType; +var + ok: Boolean; begin if PT in [ptFunction,ptClassFunction] then Result := CreateFunctionType(TypeName, 'Result', Parent, False) else - Result := TPasProcedureType(CreateElement(TPasProcedureType, TypeName, Parent)); + Result := TPasProcedureType(CreateElement(TPasProcedureType, TypeName, Parent, NamePos)); + ok:=false; try ParseProcedureOrFunctionHeader(Result, TPasProcedureType(Result), PT, True); - except - FreeAndNil(Result); - raise; + ok:=true; + finally + if not ok then + Result.Release; end; end; @@ -2590,10 +2705,12 @@ function TPasParser.ParseTypeDecl(Parent: TPasElement): TPasType; var TypeName: String; + NamePos: TPasSourcePos; begin TypeName := CurTokenString; + NamePos:=Scanner.CurSourcePos; ExpectToken(tkEqual); - Result:=ParseType(Parent,TypeName,True); + Result:=ParseType(Parent,NamePos,TypeName,True); end; function TPasParser.GetVariableValueAndLocation(Parent: TPasElement; out @@ -2689,64 +2806,85 @@ end; // Full means that a full variable declaration is being parsed. procedure TPasParser.ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibility: TPasMemberVisibility; Full : Boolean); +// on Exception the VarList is restored, no need to Release the new elements var - VarNames: TStringList; - i: Integer; + i, OldListCount: Integer; Value : TPasExpr; VarType: TPasType; VarEl: TPasVariable; H : TPasMemberHints; - varmods: TVariableModifiers; - D,Mods,Loc,alibname,aexpname : string; + VarMods: TVariableModifiers; + D,Mods,Loc,aLibName,aExpName : string; + ok: Boolean; begin - VarNames := TStringList.Create; + OldListCount:=VarList.Count; + ok:=false; try D:=SaveComments; // This means we support only one comment per 'list'. Repeat - VarNames.Add(CurTokenString); + // create the TPasVariable here, so that SourceLineNumber is correct + VarEl:=TPasVariable(CreateElement(TPasVariable,CurTokenString,Parent,AVisibility)); + VarList.Add(VarEl); NextToken; if Not (CurToken in [tkComma,tkColon]) then ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon); if CurToken=tkComma then ExpectIdentifier; Until (CurToken=tkColon); + + // read type VarType := ParseComplexType(Parent); + for i := OldListCount to VarList.Count - 1 do + begin + VarEl:=TPasVariable(VarList[i]); + // Writeln(VarEl.Name, AVisibility); + VarEl.VarType := VarType; + VarType.Parent := VarEl; + if (i>=OldListCount) then + VarType.AddRef; + end; + Value:=Nil; H:=CheckHint(Nil,False); If Full then GetVariableValueAndLocation(Parent,Value,Loc); + if (Value<>nil) and (VarList.Count>OldListCount+1) then + ParseExc(nParserOnlyOneVariableCanBeInitialized,SParserOnlyOneVariableCanBeInitialized); + TPasVariable(VarList[OldListCount]).Expr:=Value; + H:=H+CheckHint(Nil,Full); - if full then - Mods:=GetVariableModifiers(varmods,alibname,aexpname) + if Full then + Mods:=GetVariableModifiers(VarMods,aLibName,aExpName) else NextToken; SaveComments(D); - for i := 0 to VarNames.Count - 1 do + + // connect + for i := OldListCount to VarList.Count - 1 do begin - // Writeln(VarNames[i], AVisibility); - VarEl:=TPasVariable(CreateElement(TPasVariable,VarNames[i],Parent,AVisibility)); - VarEl.VarType := VarType; - VarType.Parent := VarEl; + VarEl:=TPasVariable(VarList[i]); + // Writeln(VarEl.Name, AVisibility); // Procedure declaration eats the hints. - if Assigned(VarType) and (VarType is TPasprocedureType) then + if Assigned(VarType) and (VarType is TPasProcedureType) then VarEl.Hints:=VarType.Hints else VarEl.Hints:=H; VarEl.Modifiers:=Mods; VarEl.VarModifiers:=VarMods; - if (i=0) then - VarEl.Expr:=Value; VarEl.AbsoluteLocation:=Loc; - VarEl.LibraryName:=alibName; - VarEl.ExportName:=aexpname; - if (i>0) then - VarType.AddRef; - VarList.Add(VarEl); + VarEl.LibraryName:=aLibName; + VarEl.ExportName:=aExpName; end; + ok:=true; finally - VarNames.Free; + if not ok then + begin + for i:=OldListCount to VarList.Count-1 do + TPasElement(VarList[i]).Release; + VarList.Count:=OldListCount; + end; end; end; @@ -2821,120 +2959,120 @@ end; procedure TPasParser.ParseVarDecl(Parent: TPasElement; List: TFPList); begin - ParseVarList(Parent,list,visDefault,True); + ParseVarList(Parent,List,visDefault,True); end; // Starts after the opening bracket token procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TFPList; EndToken: TToken); var - ArgNames: TStringList; - IsUntyped, ok: Boolean; + IsUntyped, ok, LastHadDefaultValue: Boolean; Name : String; Value : TPasExpr; - i: Integer; + i, OldArgCount: Integer; Arg: TPasArgument; Access: TArgumentAccess; ArgType: TPasType; begin - ArgNames := TStringList.Create; - try + LastHadDefaultValue := false; + while True do + begin + OldArgCount:=Args.Count; + Access := argDefault; + IsUntyped := False; + ArgType := nil; while True do begin - ArgNames.Clear; - Access := argDefault; - IsUntyped := False; - ArgType := nil; - while True do - begin - NextToken; - if CurToken = tkConst then - begin - Access := argConst; - Name := ExpectIdentifier; - end else if CurToken = tkConstRef then - begin - Access := argConstref; - Name := ExpectIdentifier; - end else if CurToken = tkVar then - begin - Access := ArgVar; - Name := ExpectIdentifier; - end else if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'OUT') then - begin - Access := ArgOut; - Name := ExpectIdentifier; - end else if CurToken = tkIdentifier then - Name := CurTokenString - else - ParseExc(nParserExpectedConstVarID,SParserExpectedConstVarID); - ArgNames.Add(Name); - NextToken; - if CurToken = tkColon then - break - else if ((CurToken = tkSemicolon) or (CurToken = tkBraceClose)) and - (Access <> argDefault) then - begin - // found an untyped const or var argument - UngetToken; - IsUntyped := True; - break - end - else if CurToken <> tkComma then - ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon); - end; - Value:=Nil; - if not IsUntyped then - begin - ArgType := ParseType(nil); - ok:=false; - try - NextToken; - if CurToken = tkEqual then - begin - if (ArgNames.Count>1) then - begin - FreeAndNil(ArgType); - ParseExc(nParserOnlyOneArgumentCanHaveDefault,SParserOnlyOneArgumentCanHaveDefault); - end; - NextToken; - Value := DoParseExpression(Parent,Nil); - // After this, we're on ), which must be unget. - end; - UngetToken; - ok:=true; - finally - if not ok then - FreeAndNil(ArgType); - end; - end; - - for i := 0 to ArgNames.Count - 1 do - begin - Arg := TPasArgument(CreateElement(TPasArgument, ArgNames[i], Parent)); - Arg.Access := Access; - Arg.ArgType := ArgType; - if Assigned(ArgType) then - begin - ArgType.Parent := Arg; - if (i > 0) then - ArgType.AddRef; - end; - Arg.ValueExpr := Value; - Value:=Nil; // Only the first gets a value. OK, since Var A,B : Integer = 1 is not allowed. - Args.Add(Arg); - end; - NextToken; - if (CurToken = tkIdentifier) and (LowerCase(CurTokenString) = 'location') then - begin - NextToken; // remove 'location' - NextToken; // remove register - end; - if CurToken = EndToken then - break; + if CurToken = tkConst then + begin + Access := argConst; + Name := ExpectIdentifier; + end else if CurToken = tkConstRef then + begin + Access := argConstref; + Name := ExpectIdentifier; + end else if CurToken = tkVar then + begin + Access := ArgVar; + Name := ExpectIdentifier; + end else if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'OUT') then + begin + Access := ArgOut; + Name := ExpectIdentifier; + end else if CurToken = tkIdentifier then + Name := CurTokenString + else + ParseExc(nParserExpectedConstVarID,SParserExpectedConstVarID); + Arg := TPasArgument(CreateElement(TPasArgument, Name, Parent)); + Args.Add(Arg); + NextToken; + if CurToken = tkColon then + break + else if ((CurToken = tkSemicolon) or (CurToken = tkBraceClose)) and + (Access <> argDefault) then + begin + // found an untyped const or var argument + UngetToken; + IsUntyped := True; + break + end + else if CurToken <> tkComma then + ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon); end; - finally - ArgNames.Free; + Value:=Nil; + if not IsUntyped then + begin + ArgType := ParseType(Parent,Scanner.CurSourcePos); + ok:=false; + try + NextToken; + if CurToken = tkEqual then + begin + if (Args.Count>OldArgCount+1) then + begin + ArgType.Release; + ArgType:=nil; + ParseExc(nParserOnlyOneArgumentCanHaveDefault,SParserOnlyOneArgumentCanHaveDefault); + end; + NextToken; + Value := DoParseExpression(Parent,Nil); + // After this, we're on ), which must be unget. + LastHadDefaultValue:=true; + end + else if LastHadDefaultValue then + ParseExc(nParserDefaultParameterRequiredFor, + SParserDefaultParameterRequiredFor,[TPasArgument(Args[OldArgCount]).Name]); + UngetToken; + ok:=true; + finally + if not ok then + ArgType.Release; + end; + end; + + for i := OldArgCount to Args.Count - 1 do + begin + Arg := TPasArgument(Args[i]); + Arg.Access := Access; + Arg.ArgType := ArgType; + if Assigned(ArgType) then + begin + ArgType.Parent := Arg; + if (i > OldArgCount) then + ArgType.AddRef; + end; + Arg.ValueExpr := Value; + Value:=Nil; // Only the first gets a value. OK, since Var A,B : Integer = 1 is not allowed. + end; + + NextToken; + if (CurToken = tkIdentifier) and (LowerCase(CurTokenString) = 'location') then + begin + NextToken; // remove 'location' + NextToken; // remove register + end; + if CurToken = EndToken then + break; end; end; @@ -3102,7 +3240,7 @@ begin ptFunction,ptClassFunction: begin ExpectToken(tkColon); - TPasFunctionType(Element).ResultEl.ResultType := ParseType(Parent) + TPasFunctionType(Element).ResultEl.ResultType := ParseType(Parent,Scanner.CurSourcePos); end; ptOperator,ptClassOperator: begin @@ -3117,7 +3255,7 @@ begin TPasFunctionType(Element).ResultEl.Name := 'Result' else ParseExc(nParserExpectedColonID,SParserExpectedColonID); - TPasFunctionType(Element).ResultEl.ResultType := ParseType(Parent) + TPasFunctionType(Element).ResultEl.ResultType := ParseType(Parent,Scanner.CurSourcePos) end; end; if OfObjectPossible then @@ -3205,6 +3343,7 @@ begin ConsumeSemi; if (ProcType in [ptOperator,ptClassOperator]) and (Parent is TPasOperator) then TPasOperator(Parent).CorrectName; + Engine.FinishScope(stProcedureHeader); if (Parent is TPasProcedure) and (not TPasProcedure(Parent).IsForward) and (not TPasProcedure(Parent).IsExternal) @@ -3212,6 +3351,7 @@ begin or (Parent.Parent is TProcedureBody)) then ParseProcedureBody(Parent); + Engine.FinishScope(stProcedure); end; // starts after the semicolon @@ -3265,11 +3405,12 @@ function TPasParser.ParseProperty(Parent: TPasElement; const AName: String; end; var - isArray : Boolean; + isArray , ok: Boolean; h : TPasMemberHint; begin Result:=TPasProperty(CreateElement(TPasProperty,AName,Parent,AVisibility)); + ok:=false; try NextToken; isArray:=CurToken=tkSquaredBraceOpen; @@ -3280,7 +3421,7 @@ begin end; if CurToken = tkColon then begin - Result.VarType := ParseType(Result); + Result.VarType := ParseType(Result,Scanner.CurSourcePos); NextToken; end; if CurTokenIsIdentifier('INDEX') then @@ -3352,9 +3493,10 @@ begin NextToken; end; UngetToken; - except - FreeAndNil(Result); - Raise; + ok:=true; + finally + if not ok then + Result.Release; end; end; @@ -3420,6 +3562,8 @@ var function CloseBlock: boolean; // true if parent reached begin + if CurBlock.ClassType=TPasImplExceptOn then + Engine.FinishScope(stExceptOnStatement); CurBlock:=CurBlock.Parent as TPasImplBlock; Result:=CurBlock=Parent; end; @@ -3441,14 +3585,13 @@ var end; var - VarName: String; SubBlock: TPasImplElement; CmdElem: TPasImplElement; - left: TPasExpr; - right: TPasExpr; - el : TPasImplElement; + left, right: TPasExpr; + El : TPasImplElement; ak : TAssignKind; lt : TLoopType; + ok: Boolean; begin NewImplElement:=nil; @@ -3460,30 +3603,30 @@ begin case CurToken of tkasm : begin - el:=TPasImplElement(CreateElement(TPasImplAsmStatement,'',CurBlock)); - ParseAsmBlock(TPasImplAsmStatement(el)); - CurBlock.AddElement(el); + El:=TPasImplElement(CreateElement(TPasImplAsmStatement,'',CurBlock)); + ParseAsmBlock(TPasImplAsmStatement(El)); + CurBlock.AddElement(El); NewImplElement:=El; end; tkbegin: begin - el:=TPasImplElement(CreateElement(TPasImplBeginBlock,'',CurBlock)); - CreateBlock(TPasImplBeginBlock(el)); + El:=TPasImplElement(CreateElement(TPasImplBeginBlock,'',CurBlock)); + CreateBlock(TPasImplBeginBlock(El)); end; tkrepeat: begin - el:=TPasImplRepeatUntil(CreateElement(TPasImplRepeatUntil,'',CurBlock)); - CreateBlock(TPasImplRepeatUntil(el)); + El:=TPasImplRepeatUntil(CreateElement(TPasImplRepeatUntil,'',CurBlock)); + CreateBlock(TPasImplRepeatUntil(El)); end; tkIf: begin NextToken; Left:=DoParseExpression(CurBlock); UNgettoken; - el:=TPasImplIfElse(CreateElement(TPasImplIfElse,'',CurBlock)); - TPasImplIfElse(el).ConditionExpr:=Left; + El:=TPasImplIfElse(CreateElement(TPasImplIfElse,'',CurBlock)); + TPasImplIfElse(El).ConditionExpr:=Left; //WriteLn(i,'IF Condition="',Condition,'" Token=',CurTokenText); - CreateBlock(TPasImplIfElse(el)); + CreateBlock(TPasImplIfElse(El)); ExpectToken(tkthen); end; tkelse: @@ -3491,8 +3634,8 @@ begin begin if TPasImplIfElse(CurBlock).IfBranch=nil then begin - el:=TPasImplCommand(CreateElement(TPasImplCommand,'', CurBlock)); - CurBlock.AddElement(el); + El:=TPasImplCommand(CreateElement(TPasImplCommand,'', CurBlock)); + CurBlock.AddElement(El); end; if TPasImplIfElse(CurBlock).ElseBranch<>nil then begin @@ -3518,9 +3661,9 @@ begin end else if (CurBlock is TPasImplTryExcept) then begin CloseBlock; - el:=TPasImplTryExceptElse(CreateElement(TPasImplTryExceptElse,'',CurBlock)); - TPasImplTry(CurBlock).ElseBranch:=TPasImplTryExceptElse(el); - CurBlock:=TPasImplTryExceptElse(el); + El:=TPasImplTryExceptElse(CreateElement(TPasImplTryExceptElse,'',CurBlock)); + TPasImplTry(CurBlock).ElseBranch:=TPasImplTryExceptElse(El); + CurBlock:=TPasImplTryExceptElse(El); end else ParseExcSyntaxError; tkwhile: @@ -3530,9 +3673,9 @@ begin left:=DoParseExpression(Parent); ungettoken; //WriteLn(i,'WHILE Condition="',Condition,'" Token=',CurTokenText); - el:=TPasImplWhileDo(CreateElement(TPasImplWhileDo,'',CurBlock)); - TPasImplWhileDo(el).ConditionExpr:=left; - CreateBlock(TPasImplWhileDo(el)); + El:=TPasImplWhileDo(CreateElement(TPasImplWhileDo,'',CurBlock)); + TPasImplWhileDo(El).ConditionExpr:=left; + CreateBlock(TPasImplWhileDo(El)); ExpectToken(tkdo); end; tkgoto: @@ -3545,20 +3688,39 @@ begin begin // for VarName := StartValue to EndValue do // for VarName in Expression do - ExpectIdentifier; - VarName:=CurTokenString; - NextToken; - Left:=Nil; - Right:=Nil; - if Not (CurToken in [tkAssign,tkIn]) then - ParseExc(nParserExpectedAssignIn,SParserExpectedAssignIn); - if (CurToken=tkAssign) then - lt:=ltNormal - else - lt:=ltin; - NextToken; - Left:=DoParseExpression(Parent); + El:=TPasImplForLoop(CreateElement(TPasImplForLoop,'',CurBlock)); + ok:=false; Try + ExpectIdentifier; + Left:=CreatePrimitiveExpr(El,pekIdent,CurTokenString); + Right:=Left; + TPasImplForLoop(El).VariableName:=Left; + repeat + NextToken; + case CurToken of + tkAssign: + begin + lt:=ltNormal; + break; + end; + tkin: + begin + lt:=ltIn; + break; + end; + tkDot: + begin + ExpectIdentifier; + AddToBinaryExprChain(Left,Right, + CreatePrimitiveExpr(El,pekIdent,CurTokenString), eopSubIdent); + TPasImplForLoop(El).VariableName:=Left; + end; + else + ParseExc(nParserExpectedAssignIn,SParserExpectedAssignIn); + end; + until false; + NextToken; + TPasImplForLoop(El).StartExpr:=DoParseExpression(El); if (Lt=ltNormal) then begin if Not (CurToken in [tkTo,tkDownTo]) then @@ -3566,21 +3728,17 @@ begin if CurToken=tkdownto then Lt:=ltDown; NextToken; - Right:=DoParseExpression(Parent); + TPasImplForLoop(El).EndExpr:=DoParseExpression(El); end; + TPasImplForLoop(El).LoopType:=lt; if (CurToken<>tkDo) then ParseExcTokenError(TokenInfos[tkDo]); - except - FreeAndNil(Left); - FreeAndNil(Right); - Raise; + ok:=true; + finally + if not ok then + El.Release; end; - el:=TPasImplForLoop(CreateElement(TPasImplForLoop,'',CurBlock)); - TPasImplForLoop(el).VariableName:=VarName; - TPasImplForLoop(el).StartExpr:=Left; - TPasImplForLoop(el).EndExpr:=Right; - TPasImplForLoop(el).LoopType:=lt; - CreateBlock(TPasImplForLoop(el)); + CreateBlock(TPasImplForLoop(El)); //WriteLn(i,'FOR "',VarName,'" := ',StartValue,' to ',EndValue,' Token=',CurTokenText); end; tkwith: @@ -3590,9 +3748,9 @@ begin NextToken; Left:=DoParseExpression(Parent); //writeln(i,'WITH Expr="',Expr,'" Token=',CurTokenText); - el:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock)); - TPasImplWithDo(el).AddExpression(Left); - CreateBlock(TPasImplWithDo(el)); + El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock)); + TPasImplWithDo(El).AddExpression(Left); + CreateBlock(TPasImplWithDo(El)); repeat if CurToken=tkdo then break; if CurToken<>tkComma then @@ -3610,9 +3768,9 @@ begin UngetToken; //writeln(i,'CASE OF Expr="',Expr,'" Token=',CurTokenText); ExpectToken(tkof); - el:=TPasImplCaseOf(CreateElement(TPasImplCaseOf,'',CurBlock)); - TPasImplCaseOf(el).CaseExpr:=Left; - CreateBlock(TPasImplCaseOf(el)); + El:=TPasImplCaseOf(CreateElement(TPasImplCaseOf,'',CurBlock)); + TPasImplCaseOf(El).CaseExpr:=Left; + CreateBlock(TPasImplCaseOf(El)); repeat NextToken; //writeln(i,'CASE OF Token=',CurTokenText); @@ -3626,9 +3784,9 @@ begin tkelse: begin // create case-else block - el:=TPasImplCaseElse(CreateElement(TPasImplCaseElse,'',CurBlock)); - TPasImplCaseOf(CurBlock).ElseBranch:=TPasImplCaseElse(el); - CreateBlock(TPasImplCaseElse(el)); + El:=TPasImplCaseElse(CreateElement(TPasImplCaseElse,'',CurBlock)); + TPasImplCaseOf(CurBlock).ElseBranch:=TPasImplCaseElse(El); + CreateBlock(TPasImplCaseElse(El)); break; end else @@ -3636,9 +3794,9 @@ begin if (curToken=tkIdentifier) and (LowerCase(CurtokenString)='otherwise') then begin // create case-else block - el:=TPasImplCaseElse(CreateElement(TPasImplCaseElse,'',CurBlock)); - TPasImplCaseOf(CurBlock).ElseBranch:=TPasImplCaseElse(el); - CreateBlock(TPasImplCaseElse(el)); + El:=TPasImplCaseElse(CreateElement(TPasImplCaseElse,'',CurBlock)); + TPasImplCaseOf(CurBlock).ElseBranch:=TPasImplCaseElse(El); + CreateBlock(TPasImplCaseElse(El)); break; end else @@ -3649,10 +3807,10 @@ begin TPasImplCaseStatement(CurBlock).Expressions.Add(Left) else begin - el:=TPasImplCaseStatement(CreateElement(TPasImplCaseStatement,'',CurBlock)); - TPasImplCaseStatement(el).AddExpression(Left); - CurBlock.AddElement(el); - CurBlock:=TPasImplCaseStatement(el); + El:=TPasImplCaseStatement(CreateElement(TPasImplCaseStatement,'',CurBlock)); + TPasImplCaseStatement(El).AddExpression(Left); + CurBlock.AddElement(El); + CurBlock:=TPasImplCaseStatement(El); end; //writeln(i,'CASE after value Token=',CurTokenText); if (CurToken=tkComma) then @@ -3681,8 +3839,8 @@ begin end; tktry: begin - el:=TPasImplTry(CreateElement(TPasImplTry,'',Curblock)); - CreateBlock(TPasImplTry(el)); + El:=TPasImplTry(CreateElement(TPasImplTry,'',CurBlock)); + CreateBlock(TPasImplTry(El)); end; tkfinally: begin @@ -3693,9 +3851,9 @@ begin end; if CurBlock is TPasImplTry then begin - el:=TPasImplTryFinally(CreateElement(TPasImplTryFinally,'',Curblock)); - TPasImplTry(CurBlock).FinallyExcept:=TPasImplTryFinally(el); - CurBlock:=TPasImplTryFinally(el); + El:=TPasImplTryFinally(CreateElement(TPasImplTryFinally,'',CurBlock)); + TPasImplTry(CurBlock).FinallyExcept:=TPasImplTryFinally(El); + CurBlock:=TPasImplTryFinally(El); end else ParseExcSyntaxError; end; @@ -3709,9 +3867,9 @@ begin if CurBlock is TPasImplTry then begin //writeln(i,'EXCEPT'); - el:=TPasImplTryExcept(CreateElement(TPasImplTryExcept,'',CurBlock)); - TPasImplTry(CurBlock).FinallyExcept:=TPasImplTryExcept(el); - CurBlock:=TPasImplTryExcept(el); + El:=TPasImplTryExcept(CreateElement(TPasImplTryExcept,'',CurBlock)); + TPasImplTry(CurBlock).FinallyExcept:=TPasImplTryExcept(El); + CurBlock:=TPasImplTryExcept(El); end else ParseExcSyntaxError; end; @@ -3736,29 +3894,30 @@ begin end; // else UngetToken; - el:=TPasImplExceptOn(CreateElement(TPasImplExceptOn,'',CurBlock)); - TPasImplExceptOn(el).VarExpr:=Left; - TPasImplExceptOn(el).TypeExpr:=Right; - CurBlock.AddElement(el); - CurBlock:=TPasImplExceptOn(el); + El:=TPasImplExceptOn(CreateElement(TPasImplExceptOn,'',CurBlock)); + TPasImplExceptOn(El).VarExpr:=Left; + TPasImplExceptOn(El).TypeExpr:=Right; + Engine.FinishScope(stExceptOnExpr); + CurBlock.AddElement(El); + CurBlock:=TPasImplExceptOn(El); ExpectToken(tkDo); end else ParseExcSyntaxError; end; tkraise: begin - el:=TPasImplRaise(CreateElement(TPasImplRaise,'',CurBlock)); - CreateBlock(TPasImplRaise(el)); + El:=TPasImplRaise(CreateElement(TPasImplRaise,'',CurBlock)); + CreateBlock(TPasImplRaise(El)); NextToken; If Curtoken=tkSemicolon then UnGetToken else begin - TPasImplRaise(el).ExceptObject:=DoParseExpression(el); + TPasImplRaise(El).ExceptObject:=DoParseExpression(El); if (CurToken=tkIdentifier) and (Uppercase(CurtokenString)='AT') then begin NextToken; - TPasImplRaise(el).ExceptAddr:=DoParseExpression(el); + TPasImplRaise(El).ExceptAddr:=DoParseExpression(El); end; if Curtoken in [tkSemicolon,tkEnd] then UngetToken @@ -3821,14 +3980,14 @@ begin Ak:=TokenToAssignKind(CurToken); NextToken; right:=DoParseExpression(Parent); // this may solve TPasImplWhileDo.AddElement BUG - el:=TPasImplAssign(CreateElement(TPasImplAssign,'',CurBlock)); - left.Parent:=el; - right.Parent:=el; - TPasImplAssign(el).left:=Left; - TPasImplAssign(el).right:=Right; - TPasImplAssign(el).Kind:=ak; - CurBlock.AddElement(el); - CmdElem:=TPasImplAssign(el); + El:=TPasImplAssign(CreateElement(TPasImplAssign,'',CurBlock)); + left.Parent:=El; + right.Parent:=El; + TPasImplAssign(El).left:=Left; + TPasImplAssign(El).right:=Right; + TPasImplAssign(El).Kind:=ak; + CurBlock.AddElement(El); + CmdElem:=TPasImplAssign(El); UngetToken; end; tkColon: @@ -3836,18 +3995,18 @@ begin if not (left is TPrimitiveExpr) then ParseExcTokenError(TokenInfos[tkSemicolon]); // label mark. todo: check mark identifier in the list of labels - el:=TPasImplLabelMark(CreateElement(TPasImplLabelMark,'', CurBlock)); - TPasImplLabelMark(el).LabelId:=TPrimitiveExpr(left).Value; - CurBlock.AddElement(el); - CmdElem:=TPasImplLabelMark(el); + El:=TPasImplLabelMark(CreateElement(TPasImplLabelMark,'', CurBlock)); + TPasImplLabelMark(El).LabelId:=TPrimitiveExpr(left).Value; + CurBlock.AddElement(El); + CmdElem:=TPasImplLabelMark(El); left.Free; end; else // simple statement (function call) - el:=TPasImplSimple(CreateElement(TPasImplSimple,'',CurBlock)); - TPasImplSimple(el).expr:=Left; - CurBlock.AddElement(el); - CmdElem:=TPasImplSimple(el); + El:=TPasImplSimple(CreateElement(TPasImplSimple,'',CurBlock)); + TPasImplSimple(El).expr:=Left; + CurBlock.AddElement(El); + CmdElem:=TPasImplSimple(El); UngetToken; end; @@ -3911,7 +4070,7 @@ var Name: String; PC : TPTreeElement; Ot : TOperatorType; - IsTokenBased : Boolean; + IsTokenBased , ok: Boolean; begin If (Not (ProcType in [ptOperator,ptClassOperator])) then @@ -3931,6 +4090,7 @@ begin PC:=GetProcedureClass(ProcType); Parent:=CheckIfOverLoaded(Parent,Name); Result:=TPasProcedure(CreateElement(PC,Name,Parent,AVisibility)); + ok:=false; try if Not (ProcType in [ptFunction, ptClassFunction, ptOperator, ptClassOperator]) then Result.ProcType := TPasProcedureType(CreateElement(TPasProcedureType, '', Result)) @@ -3964,9 +4124,10 @@ begin end; end; end; - except - FreeAndNil(Result); - Raise; + ok:=true; + finally + if not ok then + Result.Release; end; end; @@ -4070,7 +4231,7 @@ begin begin if Not AllowMethods then ParseExc(nErrRecordMethodsNotAllowed,SErrRecordMethodsNotAllowed); - ProcType:=GetProcTypeFromtoken(CurToken,isClass); + ProcType:=GetProcTypeFromToken(CurToken,isClass); Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,v); if Proc.Parent is TPasOverloadedProc then TPasOverloadedProc(Proc.Parent).Overloads.Add(Proc) @@ -4104,7 +4265,7 @@ begin UnGetToken; UnGetToken; end; - ARec.VariantType:=ParseType(ARec); + ARec.VariantType:=ParseType(ARec,Scanner.CurSourcePos); ExpectToken(tkOf); ParseRecordVariantParts(ARec,AEndToken); end; @@ -4120,18 +4281,23 @@ end; // Starts after the "record" token function TPasParser.ParseRecordDecl(Parent: TPasElement; - const TypeName: string; const Packmode: TPackMode): TPasRecordType; + const NamePos: TPasSourcePos; const TypeName: string; + const Packmode: TPackMode): TPasRecordType; +var + ok: Boolean; begin - Result := TPasRecordType(CreateElement(TPasRecordType, TypeName, Parent)); - try - Result.PackMode:=PackMode; - NextToken; - ParseRecordFieldList(Result,tkEnd,true); - except - FreeAndNil(Result); - Raise; - end; + Result := TPasRecordType(CreateElement(TPasRecordType, TypeName, Parent, NamePos)); + ok:=false; + try + Result.PackMode:=PackMode; + NextToken; + ParseRecordFieldList(Result,tkEnd,true); + ok:=true; + finally + if not ok then + Result.Release; + end; end; Function IsVisibility(S : String; var AVisibility :TPasMemberVisibility) : Boolean; @@ -4349,10 +4515,10 @@ begin end; end; // Parse ancestor list - Atype.IsForward:=(CurToken=tkSemiColon); + AType.IsForward:=(CurToken=tkSemiColon); if (CurToken=tkBraceOpen) then begin - AType.AncestorType := ParseType(AType); + AType.AncestorType := ParseType(AType,Scanner.CurSourcePos); while True do begin NextToken; @@ -4360,7 +4526,7 @@ begin break; UngetToken; ExpectToken(tkComma); - Element:=ParseType(AType); // search interface. + Element:=ParseType(AType,Scanner.CurSourcePos); // search interface. if assigned(element) then AType.Interfaces.add(element); end; @@ -4371,7 +4537,7 @@ begin begin if (CurToken<>tkFor) then ParseExcTokenError(TokenInfos[tkFor]); - AType.HelperForType:=ParseType(AType); + AType.HelperForType:=ParseType(AType,Scanner.CurSourcePos); NextToken; end; if (AType.IsShortDefinition or AType.IsForward) then @@ -4395,23 +4561,22 @@ function TPasParser.ParseClassDecl(Parent: TPasElement; ): TPasType; Var - SourcefileName : string; - SourceLineNumber : Integer; + SrcPos: TPasSourcePos; + ok: Boolean; begin // Save current parsing position to get it correct in all cases - SourceFilename := Scanner.CurFilename; - SourceLinenumber := Scanner.CurRow; + SrcPos := Scanner.CurSourcePos; NextToken; if (AObjKind = okClass) and (CurToken = tkOf) then begin - Result := TPasClassOfType(Engine.CreateElement(TPasClassOfType, AClassName, - Parent, SourceFilename, SourceLinenumber)); + Result := TPasClassOfType(CreateElement(TPasClassOfType, AClassName, + Parent, SrcPos)); ExpectIdentifier; UngetToken; // Only names are allowed as following type - TPasClassOfType(Result).DestType := ParseType(Result); + TPasClassOfType(Result).DestType := ParseType(Result,Scanner.CurSourcePos); exit; end; if (CurToken = tkHelper) then @@ -4422,31 +4587,45 @@ begin AObjKind:=okClassHelper; NextToken; end; - Result := TPasClassType(Engine.CreateElement(TPasClassType, AClassName, - Parent, SourceFilename, SourceLinenumber)); + Result := TPasClassType(CreateElement(TPasClassType, AClassName, + Parent, SrcPos)); + ok:=false; try TPasClassType(Result).ObjKind := AObjKind; TPasClassType(Result).PackMode:=PackMode; DoParseClassType(TPasClassType(Result)); - except - Result.Free; - raise; + ok:=true; + finally + if not ok then + Result.Release; end; end; function TPasParser.CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement): TPasElement; begin - Result := Engine.CreateElement(AClass, AName, AParent, - Scanner.CurFilename, Scanner.CurRow); + Result := Engine.CreateElement(AClass, AName, AParent, visDefault, Scanner.CurSourcePos); +end; + +function TPasParser.CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; const ASrcPos: TPasSourcePos): TPasElement; +begin + Result := Engine.CreateElement(AClass, AName, AParent, visDefault, ASrcPos); end; function TPasParser.CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility): TPasElement; begin Result := Engine.CreateElement(AClass, AName, AParent, AVisibility, - Scanner.CurFilename, Scanner.CurRow); + Scanner.CurSourcePos); +end; + +function TPasParser.CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASrcPos: TPasSourcePos): TPasElement; +begin + Result := Engine.CreateElement(AClass, AName, AParent, AVisibility, ASrcPos); end; function TPasParser.CreatePrimitiveExpr(AParent: TPasElement; @@ -4544,7 +4723,7 @@ function TPasParser.CreateFunctionType(const AName, AResultName: String; begin Result:=Engine.CreateFunctionType(AName,AResultName, AParent,UseParentAsResultParent, - Scanner.CurFilename,Scanner.CurRow); + Scanner.CurSourcePos); end; function TPasParser.CreateInheritedExpr(AParent: TPasElement): TInheritedExpr; diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index bf7b2c7c95..5d403fb2f9 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -317,6 +317,7 @@ type function FindSourceFile(const AName: string): TLineReader; override; function FindIncludeFile(const AName: string): TLineReader; override; Property OwnsStreams : Boolean Read FOwnsStreams write SetOwnsStreams; + Property Streams: TStringList read FStreams; end; EScannerError = class(Exception); @@ -324,9 +325,20 @@ type TPascalScannerPPSkipMode = (ppSkipNone, ppSkipIfBranch, ppSkipElseBranch, ppSkipAll); - TPOption = (po_delphi,po_cassignments); + TPOption = ( + po_delphi, // Delphi mode: forbid nested comments + po_cassignments, // allow C-operators += -= *= /= + po_resolvestandardtypes // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations + ); TPOptions = set of TPOption; +type + TPasSourcePos = Record + FileName: String; + Row, Column: Cardinal; + end; + +type { TPascalScanner } TPScannerLogHandler = Procedure (Sender : TObject; Const Msg : String) of object; @@ -390,6 +402,7 @@ type function FetchToken: TToken; Procedure AddDefine(S : String); Procedure RemoveDefine(S : String); + function CurSourcePos: TPasSourcePos; property FileResolver: TBaseFileResolver read FFileResolver; property CurSourceFile: TLineReader read FCurSourceFile; @@ -751,7 +764,7 @@ begin While (I=-1) and (J skip + CommentLvl:=1; + while true do + begin + inc(Src); + case Src^ of + #0: break; + '{': + if NestedComments then + inc(CommentLvl); + '}': + begin + dec(CommentLvl); + if CommentLvl=0 then + begin + inc(Src); + break; + end; + end; + end; + end; + end; + '/': // comment or real division + if (Src[1]='/') then + begin + // comment start -> read til line end + inc(Src); + while not (Src^ in [#0,#10,#13]) do + inc(Src); + end + else + break; + '(': // comment, bracket or compiler directive + if (Src[1]='*') then + begin + if (Src[2]='$') and (not SkipDirectives) then + // compiler directive + break + else + begin + // comment start -> read til comment end + inc(Src,2); + CommentLvl:=1; + while true do + begin + case Src^ of + #0: break; + '(': + if NestedComments and (Src[1]='*') then + inc(CommentLvl); + '*': + if (Src[1]=')') then + begin + dec(CommentLvl); + if CommentLvl=0 then + begin + inc(Src,2); + break; + end; + inc(Position); + end; + end; + inc(Src); + end; + end; + end else + // round bracket open + break; + else + break; + end; + end; + // read token + TokenStart:=Src; + c1:=Src^; + case c1 of + #0: + ; + 'A'..'Z','a'..'z','_': + begin + // identifier + inc(Src); + while Src^ in IdentChars do + inc(Src); + end; + '0'..'9': // number + begin + inc(Src); + // read numbers + while (Src^ in ['0'..'9']) do + inc(Src); + if (Src^='.') and (Src[1]<>'.') then + begin + // real type number + inc(Src); + while (Src^ in ['0'..'9']) do + inc(Src); + end; + if (Src^ in ['e','E']) then + begin + // read exponent + inc(Src); + if (Src^='-') then inc(Src); + while (Src^ in ['0'..'9']) do + inc(Src); + end; + end; + '''','#': // string constant + while true do + case Src^ of + #0: break; + '#': + begin + inc(Src); + while Src^ in ['0'..'9'] do + inc(Src); + end; + '''': + begin + inc(Src); + while not (Src^ in ['''',#0]) do + inc(Src); + if Src^='''' then + inc(Src); + end; + else + break; + end; + '$': // hex constant + begin + inc(Src); + while Src^ in HexNumberChars do + inc(Src); + end; + '&': // octal constant or keyword as identifier (e.g. &label) + begin + inc(Src); + if Src^ in ['0'..'7'] then + while Src^ in ['0'..'7'] do + inc(Src) + else + while Src^ in IdentChars do + inc(Src); + end; + '{': // compiler directive (it can't be a comment, because see above) + begin + CommentLvl:=1; + while true do + begin + inc(Src); + case Src^ of + #0: break; + '{': + if NestedComments then + inc(CommentLvl); + '}': + begin + dec(CommentLvl); + if CommentLvl=0 then + begin + inc(Src); + break; + end; + end; + end; + end; + end; + '(': // bracket or compiler directive + if (Src[1]='*') then + begin + // compiler directive -> read til comment end + inc(Src,2); + while (Src^<>#0) and ((Src^<>'*') or (Src[1]<>')')) do + inc(Src); + inc(Src,2); + end + else + // round bracket open + inc(Src); + #192..#255: + begin + // read UTF8 character + inc(Src); + if ((ord(c1) and %11100000) = %11000000) then + begin + // could be 2 byte character + if (ord(Src[0]) and %11000000) = %10000000 then + inc(Src); + end + else if ((ord(c1) and %11110000) = %11100000) then + begin + // could be 3 byte character + if ((ord(Src[0]) and %11000000) = %10000000) + and ((ord(Src[1]) and %11000000) = %10000000) then + inc(Src,2); + end + else if ((ord(c1) and %11111000) = %11110000) then + begin + // could be 4 byte character + if ((ord(Src[0]) and %11000000) = %10000000) + and ((ord(Src[1]) and %11000000) = %10000000) + and ((ord(Src[2]) and %11000000) = %10000000) then + inc(Src,3); + end; + end; + else + inc(Src); + case c1 of + '<': if Src^ in ['>','='] then inc(Src); + '.': if Src^='.' then inc(Src); + '@': + if Src^='@' then + begin + // @@ label + repeat + inc(Src); + until not (Src^ in IdentChars); + end + else + if (Src^='=') and (c1 in [':','+','-','/','*','<','>']) then + inc(Src); + end; + end; + Position:=Src; +end; + { TTestEngine } destructor TTestEngine.Destroy; @@ -158,7 +449,7 @@ begin FResolver:=TStreamResolver.Create; FResolver.OwnsStreams:=True; FScanner:=TPascalScanner.Create(FResolver); - FEngine:=TTestEngine.Create; + CreateEngine(FEngine); FParser:=TTestPasParser.Create(FScanner,FResolver,FEngine); FSource:=TStringList.Create; FModule:=Nil; @@ -178,7 +469,11 @@ begin FImplementation:=False; FEndSource:=False; FIsUnit:=False; - FreeAndNil(FModule); + if Assigned(FModule) then + begin + FModule.Release; + FModule:=nil; + end; FreeAndNil(FSource); FreeAndNil(FParseResult); FreeAndNil(FParser); @@ -206,11 +501,16 @@ begin Inherited; end; +procedure TTestParser.CreateEngine(var TheEngine: TPasTreeContainer); +begin + TheEngine:=TTestEngine.Create; +end; + procedure TTestParser.StartUnit(AUnitName: String); begin FIsUnit:=True; If (AUnitName='') then - AUnitName:='afile'; + AUnitName:=ExtractFileUnitName(MainFilename); Add('unit '+aUnitName+';'); Add(''); Add('interface'); @@ -228,7 +528,7 @@ begin begin AFileName:=AFileName+'('+AIn; if (AOut<>'') then - AFileName:=AFIleName+','+AOut; + AFileName:=AFileName+','+AOut; AFileName:=AFileName+')'; end; Add('program '+AFileName+';'); @@ -304,8 +604,8 @@ begin StartImplementation; EndSource; If (FFileName='') then - FFileName:='afile.pp'; - FResolver.AddStream(FFileName,TStringStream.Create(FSource.text)); + FFileName:=MainFilename; + FResolver.AddStream(FFileName,TStringStream.Create(FSource.Text)); FScanner.OpenFile(FFileName); Writeln('// Test : ',Self.TestName); Writeln(FSource.Text); @@ -345,6 +645,7 @@ end; function TTestParser.AssertExpression(const Msg: String; AExpr: TPasExpr; aKind: TPasExprKind; AClass: TClass): TPasExpr; begin + AssertNotNull(AExpr); AssertEquals(Msg+': Correct expression kind',aKind,AExpr.Kind); AssertEquals(Msg+': Correct expression class',AClass,AExpr.ClassType); Result:=AExpr; @@ -521,7 +822,14 @@ procedure TTestParser.AssertEquals(const Msg: String; AExpected, AActual: TOperatorType); begin AssertEquals(Msg,GetEnumName(TypeInfo(TOperatorType),Ord(AExpected)), - GetEnumName(TypeInfo(TOperatorType),Ord(AExpected))); + GetEnumName(TypeInfo(TOperatorType),Ord(AActual))); +end; + +procedure TTestParser.AssertSame(const Msg: String; AExpected, + AActual: TPasElement); +begin + if AExpected=AActual then exit; + AssertEquals(Msg,GetPasElementDesc(AExpected),GetPasElementDesc(AActual)); end; procedure TTestParser.HaveHint(AHint: TPasMemberHint; AHints: TPasMemberHints); diff --git a/packages/fcl-passrc/tests/tcexprparser.pas b/packages/fcl-passrc/tests/tcexprparser.pas index 1566c9be7f..2b55a7bf22 100644 --- a/packages/fcl-passrc/tests/tcexprparser.pas +++ b/packages/fcl-passrc/tests/tcexprparser.pas @@ -211,12 +211,14 @@ begin DeclareVar('record a : array[1..2] of integer; end ','b'); ParseExpression('b.a[1]'); P:=TParamsExpr(AssertExpression('Simple identifier',theExpr,pekArrayParams,TParamsExpr)); - B:=AssertExpression('Name of array',P.Value,pekBinary,TBInaryExpr) as TBInaryExpr; + B:=AssertExpression('Name of array',P.Value,pekBinary,TBInaryExpr) as TBinaryExpr; AssertEquals('name is Subident',eopSubIdent,B.Opcode); AssertExpression('Name of array',B.Left,pekIdent,'b'); AssertExpression('Name of array',B.Right,pekIdent,'a'); AssertEquals('One dimension',1,Length(p.params)); AssertExpression('Simple identifier',p.params[0],pekNumber,'1'); + TAssert.AssertSame('B.left.parent=B',B,B.left.Parent); + TAssert.AssertSame('B.right.parent=B',B,B.right.Parent); end; procedure TTestExpressions.TestArrayElement2Dims; @@ -291,6 +293,9 @@ begin B:=TBinaryExpr(AssertExpression('First element is range',P.Params[0],pekRange,TBinaryExpr)); AssertExpression('Left is 0',B.Left,pekNumber,'0'); AssertExpression('Right is 10',B.Right,pekNumber,'10'); + B:=TBinaryExpr(TheExpr); + TAssert.AssertSame('B.left.parent=B',B,B.left.Parent); + TAssert.AssertSame('B.right.parent=B',B,B.right.Parent); end; procedure TTestExpressions.TestBracketsTotal; @@ -868,7 +873,7 @@ Var I : Integer; begin - StartProgram('afile'); + StartProgram(ExtractFileUnitName(MainFilename)); if FVariables.Count=0 then DeclareVar('integer'); Add('Var'); @@ -913,6 +918,8 @@ begin ARight:=Result.Right; AssertNotNull('Have left',ALeft); AssertNotNull('Have right',ARight); + TAssert.AssertSame('Result.left.parent=B',Result,Result.left.Parent); + TAssert.AssertSame('Result.right.parent=B',Result,Result.right.Parent); end; function TTestExpressions.AssertUnaryExpr(const Msg: String; Op: TExprOpCode; diff --git a/packages/fcl-passrc/tests/tconstparser.pas b/packages/fcl-passrc/tests/tconstparser.pas index 7cfc12f7f0..70596c4b10 100644 --- a/packages/fcl-passrc/tests/tconstparser.pas +++ b/packages/fcl-passrc/tests/tconstparser.pas @@ -205,6 +205,8 @@ begin ParseConst('1 + 2'); CheckExprNameKindClass(pekBinary,TBinaryExpr); B:=TBinaryExpr(TheExpr); + TAssert.AssertSame('B.Left.Parent=B',B,B.left.Parent); + TAssert.AssertSame('B.right.Parent=B',B,B.right.Parent); AssertExpression('Left expression',B.Left,pekNumber,'1'); AssertExpression('Right expression',B.Right,pekNumber,'2'); end; @@ -547,24 +549,33 @@ begin end; procedure TTestResourcestringParser.DoTestSum; +var + B: TBinaryExpr; begin ParseResourcestring('''Something''+'' else'''); CheckExprNameKindClass(pekBinary,TBinaryExpr); - AssertEquals('Correct left',TPrimitiveExpr,TBinaryExpr(TheExpr).Left.ClassType); - AssertEquals('Correct right',TPrimitiveExpr,TBinaryExpr(TheExpr).Right.ClassType); - AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(TBinaryExpr(TheExpr).Left).Value); - AssertEquals('Correct right expression value',''' else''',TPrimitiveExpr(TBinaryExpr(TheExpr).Right).Value); + B:=TBinaryExpr(TheExpr); + TAssert.AssertSame('B.left.parent=B',B,B.left.Parent); + TAssert.AssertSame('B.right.parent=B',B,B.right.Parent); + AssertEquals('Correct left',TPrimitiveExpr,B.Left.ClassType); + AssertEquals('Correct right',TPrimitiveExpr,B.Right.ClassType); + AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(B.Left).Value); + AssertEquals('Correct right expression value',''' else''',TPrimitiveExpr(B.Right).Value); end; procedure TTestResourcestringParser.DoTestSum2; +var + B: TBinaryExpr; begin ParseResourcestring('''Something''+different'); CheckExprNameKindClass(pekBinary,TBinaryExpr); - AssertEquals('Correct left',TPrimitiveExpr,TBinaryExpr(TheExpr).Left.ClassType); - AssertEquals('Correct right',TPrimitiveExpr,TBinaryExpr(TheExpr).Right.ClassType); - AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(TBinaryExpr(TheExpr).Left).Value); - AssertEquals('Correct right expression value','different',TPrimitiveExpr(TBinaryExpr(TheExpr).Right).Value); - + B:=TBinaryExpr(TheExpr); + TAssert.AssertSame('B.left.parent=B',B,B.left.Parent); + TAssert.AssertSame('B.right.parent=B',B,B.right.Parent); + AssertEquals('Correct left',TPrimitiveExpr,B.Left.ClassType); + AssertEquals('Correct right',TPrimitiveExpr,B.Right.ClassType); + AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(B.Left).Value); + AssertEquals('Correct right expression value','different',TPrimitiveExpr(B.Right).Value); end; procedure TTestResourcestringParser.TestSimple; diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas new file mode 100644 index 0000000000..7b55cd589e --- /dev/null +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -0,0 +1,1424 @@ +{ + Examples: + ./testpassrc --suite=TTestResolver.TestEmpty +} +(* + CheckReferenceDirectives: + {#a} label "a", labels all elements at the following token + {@a} reference "a", search at next token for an element e with + TResolvedReference(e.CustomData).Declaration points to an element + labeled "a". + {=a} is "a", search at next token for a TPasAliasType t with t.DestType + points to an element labeled "a" +*) +unit tcresolver; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpcunit, PasTree, PScanner, PParser, PasResolver, + tcbaseparser, testregistry, contnrs; + +Type + TOnFindUnit = function(const aUnitName: String): TPasModule of object; + + { TTestEnginePasResolver } + + TTestEnginePasResolver = class(TPasResolver) + private + FFilename: string; + FModule: TPasModule; + FOnFindUnit: TOnFindUnit; + FParser: TPasParser; + FResolver: TStreamResolver; + FScanner: TPascalScanner; + FSource: string; + procedure SetModule(AValue: TPasModule); + public + constructor Create; + destructor Destroy; override; + function FindModule(const AName: String): TPasModule; override; + property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit; + property Filename: string read FFilename write FFilename; + property Resolver: TStreamResolver read FResolver write FResolver; + property Scanner: TPascalScanner read FScanner write FScanner; + property Parser: TPasParser read FParser write FParser; + property Source: string read FSource write FSource; + property Module: TPasModule read FModule write SetModule; + end; + + TTestResolverReferenceData = record + Filename: string; + Line: integer; + StartCol: integer; + EndCol: integer; + Found: TFPList; // list of TPasElement at this token + end; + PTestResolverReferenceData = ^TTestResolverReferenceData; + + { TTestResolver } + + TTestResolver = Class(TTestParser) + Private + FFirstStatement: TPasImplBlock; + FModules: TObjectList;// list of TTestEnginePasResolver + FPasResolver: TTestEnginePasResolver; + function GetModuleCount: integer; + function GetModules(Index: integer): TTestEnginePasResolver; + function OnPasResolverFindUnit(const aUnitName: String): TPasModule; + procedure OnFindReference(Element, FindData: pointer); + Protected + Procedure SetUp; override; + Procedure TearDown; override; + procedure CreateEngine(var TheEngine: TPasTreeContainer); override; + procedure ParseProgram; + procedure ParseUnit; + procedure CheckReferenceDirectives; + Public + function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; + function AddModule(aFilename: string): TTestEnginePasResolver; + function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver; + function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc, + ImplementationSrc: string): TTestEnginePasResolver; + procedure AddSystemUnit; + procedure StartProgram(NeedSystemUnit: boolean); + procedure StartUnit(NeedSystemUnit: boolean); + property Modules[Index: integer]: TTestEnginePasResolver read GetModules; + property ModuleCount: integer read GetModuleCount; + Published + Procedure TestEmpty; + Procedure TestAliasType; + Procedure TestAlias2Type; + Procedure TestAliasTypeRefs; + Procedure TestVarLongint; + Procedure TestVarInteger; + Procedure TestConstInteger; + Procedure TestPrgAssignment; + Procedure TestPrgProcVar; + Procedure TestUnitProcVar; + Procedure TestForLoop; + Procedure TestStatements; + Procedure TestCaseStatement; + Procedure TestTryStatement; + Procedure TestStatementsRefs; + Procedure TestUnitRef; + Procedure TestProcParam; + Procedure TestFunctionResult; + Procedure TestProcOverload; + Procedure TestProcOverloadRefs; + Procedure TestNestedProc; + property PasResolver: TTestEnginePasResolver read FPasResolver; + end; + +function LinesToStr(Args: array of const): string; + +implementation + +function LinesToStr(Args: array of const): string; +var + s: String; + i: Integer; +begin + s:=''; + for i:=Low(Args) to High(Args) do + case Args[i].VType of + vtChar: s += Args[i].VChar+LineEnding; + vtString: s += Args[i].VString^+LineEnding; + vtPChar: s += Args[i].VPChar+LineEnding; + vtWideChar: s += AnsiString(Args[i].VWideChar)+LineEnding; + vtPWideChar: s += AnsiString(Args[i].VPWideChar)+LineEnding; + vtAnsiString: s += AnsiString(Args[i].VAnsiString)+LineEnding; + vtWidestring: s += AnsiString(WideString(Args[i].VWideString))+LineEnding; + vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding; + end; + Result:=s; +end; + +{ TTestEnginePasResolver } + +procedure TTestEnginePasResolver.SetModule(AValue: TPasModule); +begin + if FModule=AValue then Exit; + if Module<>nil then + Module.Release; + FModule:=AValue; + if Module<>nil then + Module.AddRef; +end; + +constructor TTestEnginePasResolver.Create; +begin + inherited Create; + StoreSrcColumns:=true; +end; + +destructor TTestEnginePasResolver.Destroy; +begin + FreeAndNil(FResolver); + Module:=nil; + FreeAndNil(FParser); + FreeAndNil(FScanner); + FreeAndNil(FResolver); + inherited Destroy; +end; + +function TTestEnginePasResolver.FindModule(const AName: String): TPasModule; +begin + Result:=nil; + if Assigned(OnFindUnit) then + Result:=OnFindUnit(AName); +end; + +{ TTestResolver } + +procedure TTestResolver.SetUp; +begin + FModules:=TObjectList.Create(true); + inherited SetUp; + Parser.Options:=Parser.Options+[po_resolvestandardtypes]; +end; + +procedure TTestResolver.TearDown; +begin + PasResolver.Clear; + if FModules<>nil then + begin + FModules.OwnsObjects:=false; + FModules.Remove(PasResolver); // remove reference + FModules.OwnsObjects:=true; + FreeAndNil(FModules);// free all other modules + end; + inherited TearDown; + FPasResolver:=nil; +end; + +procedure TTestResolver.CreateEngine(var TheEngine: TPasTreeContainer); +begin + FPasResolver:=AddModule(MainFilename); + TheEngine:=PasResolver; +end; + +procedure TTestResolver.ParseProgram; +begin + FFirstStatement:=nil; + try + ParseModule; + except + on E: EParserError do + begin + writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message + +' File='+Scanner.CurFilename + +' LineNo='+IntToStr(Scanner.CurRow) + +' Col='+IntToStr(Scanner.CurColumn) + +' Line="'+Scanner.CurLine+'"' + ); + raise E; + end; + on E: EPasResolve do + begin + writeln('ERROR: TTestResolver.ParseProgram PasResolver: '+E.ClassName+':'+E.Message + +' File='+Scanner.CurFilename + +' LineNo='+IntToStr(Scanner.CurRow) + +' Col='+IntToStr(Scanner.CurColumn) + +' Line="'+Scanner.CurLine+'"' + ); + raise E; + end; + on E: Exception do + begin + writeln('ERROR: TTestResolver.ParseProgram Exception: '+E.ClassName+':'+E.Message); + raise E; + end; + end; + TAssert.AssertSame('Has resolver',PasResolver,Parser.Engine); + AssertEquals('Has program',TPasProgram,Module.ClassType); + AssertNotNull('Has program section',PasProgram.ProgramSection); + AssertNotNull('Has initialization section',PasProgram.InitializationSection); + if (PasProgram.InitializationSection.Elements.Count>0) then + if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then + FFirstStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]); + CheckReferenceDirectives; +end; + +procedure TTestResolver.ParseUnit; +begin + FFirstStatement:=nil; + try + ParseModule; + except + on E: EParserError do + begin + writeln('ERROR: TTestResolver.ParseUnit Parser: '+E.ClassName+':'+E.Message + +' File='+Scanner.CurFilename + +' LineNo='+IntToStr(Scanner.CurRow) + +' Col='+IntToStr(Scanner.CurColumn) + +' Line="'+Scanner.CurLine+'"' + ); + raise E; + end; + on E: EPasResolve do + begin + writeln('ERROR: TTestResolver.ParseUnit PasResolver: '+E.ClassName+':'+E.Message + +' File='+Scanner.CurFilename + +' LineNo='+IntToStr(Scanner.CurRow) + +' Col='+IntToStr(Scanner.CurColumn) + +' Line="'+Scanner.CurLine+'"' + ); + raise E; + end; + on E: Exception do + begin + writeln('ERROR: TTestResolver.ParseUnit Exception: '+E.ClassName+':'+E.Message); + raise E; + end; + end; + TAssert.AssertSame('Has resolver',PasResolver,Parser.Engine); + AssertEquals('Has unit',TPasModule,Module.ClassType); + AssertNotNull('Has interface section',Module.InterfaceSection); + AssertNotNull('Has implementation section',Module.ImplementationSection); + if (Module.InitializationSection<>nil) + and (Module.InitializationSection.Elements.Count>0) then + if TObject(Module.InitializationSection.Elements[0]) is TPasImplBlock then + FFirstStatement:=TPasImplBlock(Module.InitializationSection.Elements[0]); + CheckReferenceDirectives; +end; + +procedure TTestResolver.CheckReferenceDirectives; +type + TMarkerKind = ( + mkLabel, + mkResolverReference, + mkDirectReference + ); + PMarker = ^TMarker; + TMarker = record + Kind: TMarkerKind; + Filename: string; + LineNumber: integer; + StartCol, EndCol: integer; // token start, end column + Identifier: string; + Next: PMarker; + end; + +var + FirstMarker, LastMarker: PMarker; + Filename: string; + LineNumber: Integer; + SrcLine: String; + CommentStartP, CommentEndP: PChar; + FoundRefs: TTestResolverReferenceData; + + procedure GetSrc(Index: integer; out SrcLines: TStringList; out aFilename: string); + var + aStream: TStream; + begin + SrcLines:=TStringList.Create; + aStream:=Resolver.Streams.Objects[Index] as TStream; + aStream.Position:=0; + SrcLines.LoadFromStream(aStream); + aFilename:=Resolver.Streams[Index]; + end; + + procedure RaiseErrorAt(Msg: string; const aFilename: string; aLine, aCol: integer); + var + s, SrcFilename: String; + i, j: Integer; + SrcLines: TStringList; + begin + // write all source files + for i:=0 to Resolver.Streams.Count-1 do + begin + GetSrc(i,SrcLines,SrcFilename); + writeln('Testcode:-File="',SrcFilename,'"----------------------------------:'); + for j:=1 to SrcLines.Count do + writeln(Format('%:4d: ',[j]),SrcLines[j-1]); + SrcLines.Free; + end; + s:=Msg+' at '+aFilename+' line='+IntToStr(aLine)+', col='+IntToStr(aCol); + writeln('ERROR: TTestResolver.CheckReferenceDirectives: ',s); + raise Exception.Create('TTestResolver.CheckReferenceDirectives: '+s); + end; + + procedure RaiseErrorAt(Msg: string; aMarker: PMarker); + begin + RaiseErrorAt(Msg,aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol); + end; + + procedure RaiseError(Msg: string; p: PChar); + begin + RaiseErrorAt(Msg,Filename,LineNumber,p-PChar(SrcLine)+1); + end; + + procedure AddMarker(Marker: PMarker); + begin + if LastMarker<>nil then + LastMarker^.Next:=Marker + else + FirstMarker:=Marker; + LastMarker:=Marker; + end; + + function AddMarker(Kind: TMarkerKind; const aFilename: string; + aLine, aStartCol, aEndCol: integer; const Identifier: string): PMarker; + begin + New(Result); + Result^.Kind:=Kind; + Result^.Filename:=aFilename; + Result^.LineNumber:=aLine; + Result^.StartCol:=aStartCol; + Result^.EndCol:=aEndCol; + Result^.Identifier:=Identifier; + Result^.Next:=nil; + //writeln('AddMarker Line="',SrcLine,'" Identifier=',Identifier,' Col=',aStartCol,'-',aEndCol,' "',copy(SrcLine,aStartCol,aEndCol-aStartCol),'"'); + AddMarker(Result); + end; + + function AddMarkerForTokenBehindComment(Kind: TMarkerKind; + const Identifer: string): PMarker; + var + TokenStart, p: PChar; + begin + p:=CommentEndP; + ReadNextPascalToken(p,TokenStart,false,false); + Result:=AddMarker(Kind,Filename,LineNumber, + CommentEndP-PChar(SrcLine)+1,p-PChar(SrcLine)+1,Identifer); + end; + + function FindLabel(const Identifier: string): PMarker; + begin + Result:=FirstMarker; + while Result<>nil do + begin + if (Result^.Kind=mkLabel) + and (CompareText(Result^.Identifier,Identifier)=0) then + exit; + Result:=Result^.Next; + end; + end; + + function ReadIdentifier(var p: PChar): string; + var + StartP: PChar; + begin + if not (p^ in ['a'..'z','A'..'Z','_']) then + RaiseError('identifier expected',p); + StartP:=p; + inc(p); + while p^ in ['a'..'z','A'..'Z','_','0'..'9'] do inc(p); + SetLength(Result,p-StartP); + Move(StartP^,Result[1],length(Result)); + end; + + procedure AddLabel; + var + Identifier: String; + p: PChar; + begin + p:=CommentStartP+2; + Identifier:=ReadIdentifier(p); + //writeln('TTestResolver.CheckReferenceDirectives.AddLabel ',Identifier); + if FindLabel(Identifier)<>nil then + RaiseError('duplicate label "'+Identifier+'"',p); + AddMarkerForTokenBehindComment(mkLabel,Identifier); + end; + + procedure AddResolverReference; + var + Identifier: String; + p: PChar; + begin + p:=CommentStartP+2; + Identifier:=ReadIdentifier(p); + //writeln('TTestResolver.CheckReferenceDirectives.AddReference ',Identifier); + AddMarkerForTokenBehindComment(mkResolverReference,Identifier); + end; + + procedure AddDirectReference; + var + Identifier: String; + p: PChar; + begin + p:=CommentStartP+2; + Identifier:=ReadIdentifier(p); + //writeln('TTestResolver.CheckReferenceDirectives.AddPointer ',Identifier); + AddMarkerForTokenBehindComment(mkDirectReference,Identifier); + end; + + procedure ParseCode(SrcLines: TStringList; aFilename: string); + var + p: PChar; + IsDirective: Boolean; + begin + //writeln('TTestResolver.CheckReferenceDirectives.ParseCode File=',aFilename); + Filename:=aFilename; + // parse code, find all labels + LineNumber:=0; + while LineNumberSrcLines.Count then exit; + SrcLine:=SrcLines[LineNumber-1]; + //writeln('TTestResolver.CheckReferenceDirectives Comment Line=',SrcLine); + until SrcLine<>''; + p:=PChar(SrcLine); + continue; + end; + '}': + begin + inc(p); + break; + end; + end; + inc(p); + until false; + + CommentEndP:=p; + case CommentStartP[1] of + '#': AddLabel; + '@': AddResolverReference; + '=': AddDirectReference; + end; + p:=CommentEndP; + continue; + + end; + '/': + if p[1]='/' then + break; // rest of line is comment -> skip + end; + inc(p); + until false; + end; + end; + + function FindElementsAt(aFilename: string; aLine, aStartCol, aEndCol: integer): TFPList; + var + ok: Boolean; + begin + FoundRefs.Filename:=aFilename; + FoundRefs.Line:=aLine; + FoundRefs.StartCol:=aStartCol; + FoundRefs.EndCol:=aEndCol; + FoundRefs.Found:=TFPList.Create; + ok:=false; + try + Module.ForEachCall(@OnFindReference,@FoundRefs); + ok:=true; + finally + if not ok then + FreeAndNil(FoundRefs.Found); + end; + Result:=FoundRefs.Found; + FoundRefs.Found:=nil; + end; + + procedure CheckResolverReference(aMarker: PMarker); + // check if one element at {@a} has a TResolvedReference to an element labeled {#a} + var + aLabel: PMarker; + ReferenceElements, LabelElements: TFPList; + i, j, aLine, aCol: Integer; + El, LabelEl: TPasElement; + Ref: TResolvedReference; + begin + //writeln('CheckReference searching reference: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); + aLabel:=FindLabel(aMarker^.Identifier); + if aLabel=nil then + RaiseErrorAt('label "'+aMarker^.Identifier+'" not found',aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol); + + LabelElements:=nil; + ReferenceElements:=nil; + try + LabelElements:=FindElementsAt(aLabel^.Filename,aLabel^.LineNumber,aLabel^.StartCol,aLabel^.EndCol); + if LabelElements.Count=0 then + RaiseErrorAt('label "'+aLabel^.Identifier+'" has no elements',aLabel); + + ReferenceElements:=FindElementsAt(aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol,aMarker^.EndCol); + if ReferenceElements.Count=0 then + RaiseErrorAt('reference "'+aMarker^.Identifier+'" has no elements',aMarker); + + for i:=0 to ReferenceElements.Count-1 do + begin + El:=TPasElement(ReferenceElements[i]); + if El.CustomData is TResolvedReference then + begin + Ref:=TResolvedReference(El.CustomData); + for j:=0 to LabelElements.Count-1 do + begin + LabelEl:=TPasElement(LabelElements[j]); + if Ref.Declaration=LabelEl then + exit; // success + end; + end; + end; + + // failure write candidates + for i:=0 to ReferenceElements.Count-1 do + begin + El:=TPasElement(ReferenceElements[i]); + write('Reference candidate for "',aMarker^.Identifier,'" at reference ',aMarker^.Filename,'(',aMarker^.LineNumber,',',aMarker^.StartCol,'-',aMarker^.EndCol,')'); + write(' El=',GetObjName(El)); + if El.CustomData is TResolvedReference then + begin + Ref:=TResolvedReference(El.CustomData); + write(' Decl=',GetObjName(Ref.Declaration)); + PasResolver.UnmangleSourceLineNumber(Ref.Declaration.SourceLinenumber,aLine,aCol); + write(Ref.Declaration.SourceFilename,'(',aLine,',',aCol,')'); + end + else + write(' has no TResolvedReference'); + writeln; + end; + for i:=0 to LabelElements.Count-1 do + begin + El:=TPasElement(LabelElements[i]); + write('Label candidate for "',aLabel^.Identifier,'" at reference ',aLabel^.Filename,'(',aLabel^.LineNumber,',',aLabel^.StartCol,'-',aLabel^.EndCol,')'); + write(' El=',GetObjName(El)); + writeln; + end; + + RaiseErrorAt('wrong resolved reference "'+aMarker^.Identifier+'"',aMarker); + finally + LabelElements.Free; + ReferenceElements.Free; + end; + end; + + procedure CheckDirectReference(aMarker: PMarker); + // check if one element at {=a} is a TPasAliasType pointing to an element labeled {#a} + var + aLabel: PMarker; + ReferenceElements: TFPList; + i, LabelLine, LabelCol: Integer; + El: TPasElement; + DeclEl: TPasType; + begin + //writeln('CheckPointer searching pointer: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); + aLabel:=FindLabel(aMarker^.Identifier); + if aLabel=nil then + RaiseErrorAt('label "'+aMarker^.Identifier+'" not found',aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol); + + ReferenceElements:=nil; + try + ReferenceElements:=FindElementsAt(aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol,aMarker^.EndCol); + if ReferenceElements.Count=0 then + RaiseErrorAt('reference "'+aMarker^.Identifier+'" has no elements',aMarker); + + for i:=0 to ReferenceElements.Count-1 do + begin + El:=TPasElement(ReferenceElements[i]); + if El.ClassType=TPasAliasType then + begin + DeclEl:=TPasAliasType(El).DestType; + PasResolver.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol); + if (aLabel^.Filename=DeclEl.SourceFilename) + and (aLabel^.LineNumber=LabelLine) + and (aLabel^.StartCol<=LabelCol) + and (aLabel^.EndCol>=LabelCol) then + exit; // success + writeln('CheckDirectReference Decl at ',DeclEl.SourceFilename,'(',LabelLine,',',LabelCol,')'); + RaiseErrorAt('wrong direct reference "'+aMarker^.Identifier+'"',aMarker); + end; + end; + finally + end; + + end; + +var + aMarker: PMarker; + i: Integer; + SrcLines: TStringList; +begin + FirstMarker:=nil; + LastMarker:=nil; + FoundRefs:=Default(TTestResolverReferenceData); + try + // find all markers + for i:=0 to Resolver.Streams.Count-1 do + begin + GetSrc(i,SrcLines,Filename); + ParseCode(SrcLines,Filename); + SrcLines.Free; + end; + + // check references + aMarker:=FirstMarker; + while aMarker<>nil do + begin + case aMarker^.Kind of + mkResolverReference: CheckResolverReference(aMarker); + mkDirectReference: CheckDirectReference(aMarker); + end; + aMarker:=aMarker^.Next; + end; + + finally + while FirstMarker<>nil do + begin + aMarker:=FirstMarker; + FirstMarker:=FirstMarker^.Next; + Dispose(aMarker); + end; + end; +end; + +function TTestResolver.FindModuleWithFilename(aFilename: string + ): TTestEnginePasResolver; +var + i: Integer; +begin + for i:=0 to ModuleCount-1 do + if CompareText(Modules[i].Filename,aFilename)=0 then + exit(Modules[i]); + Result:=nil; +end; + +function TTestResolver.AddModule(aFilename: string): TTestEnginePasResolver; +begin + //writeln('TTestResolver.AddModule ',aFilename); + if FindModuleWithFilename(aFilename)<>nil then + raise Exception.Create('TTestResolver.AddModule: file "'+aFilename+'" already exists'); + Result:=TTestEnginePasResolver.Create; + Result.Filename:=aFilename; + Result.AddObjFPCBuiltInIdentifiers; + Result.OnFindUnit:=@OnPasResolverFindUnit; + FModules.Add(Result); +end; + +function TTestResolver.AddModuleWithSrc(aFilename, Src: string + ): TTestEnginePasResolver; +begin + Result:=AddModule(aFilename); + Result.Source:=Src; +end; + +function TTestResolver.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc, + ImplementationSrc: string): TTestEnginePasResolver; +var + Src: String; +begin + Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding; + Src+=LineEnding; + Src+='interface'+LineEnding; + Src+=LineEnding; + Src+=InterfaceSrc; + Src+='implementation'+LineEnding; + Src+=LineEnding; + Src+=ImplementationSrc; + Src+='end.'+LineEnding; + Result:=AddModuleWithSrc(aFilename,Src); +end; + +procedure TTestResolver.AddSystemUnit; +begin + AddModuleWithIntfImplSrc('system.pp', + // interface + LinesToStr([ + 'type', + ' integer=longint;', + ' sizeint=int64;', + //'const', + //' LineEnding = #10;', + //' DirectorySeparator = ''/'';', + //' DriveSeparator = '''';', + //' AllowDirectorySeparators : set of char = [''\'',''/''];', + //' AllowDriveSeparators : set of char = [];', + 'var', + ' ExitCode: Longint;', + //'Procedure Move(const source;var dest;count:SizeInt);', + '' + // implementation + ]),LinesToStr([ + // 'Procedure Move(const source;var dest;count:SizeInt);', + // 'begin', + // 'end;', + '' + ])); +end; + +procedure TTestResolver.StartProgram(NeedSystemUnit: boolean); +begin + if NeedSystemUnit then + AddSystemUnit + else + Parser.ImplicitUses.Clear; + Add('program '+ExtractFileUnitName(MainFilename)+';'); +end; + +procedure TTestResolver.StartUnit(NeedSystemUnit: boolean); +begin + if NeedSystemUnit then + AddSystemUnit + else + Parser.ImplicitUses.Clear; + Add('unit '+ExtractFileUnitName(MainFilename)+';'); +end; + +function TTestResolver.OnPasResolverFindUnit(const aUnitName: String + ): TPasModule; +var + i: Integer; + CurEngine: TTestEnginePasResolver; + CurUnitName: String; +begin + //writeln('TTestResolver.OnPasResolverFindUnit START Unit="',aUnitName,'"'); + Result:=nil; + for i:=0 to ModuleCount-1 do + begin + CurEngine:=Modules[i]; + CurUnitName:=ExtractFileUnitName(CurEngine.Filename); + //writeln('TTestResolver.OnPasResolverFindUnit Checking ',i,'/',ModuleCount,' ',CurEngine.Filename,' ',CurUnitName); + if CompareText(aUnitName,CurUnitName)=0 then + begin + Result:=CurEngine.Module; + if Result<>nil then exit; + //writeln('TTestResolver.OnPasResolverFindUnit PARSING unit "',CurEngine.Filename,'"'); + Resolver.FindSourceFile(aUnitName); + + CurEngine.Resolver:=TStreamResolver.Create; + CurEngine.Resolver.OwnsStreams:=True; + //writeln('TTestResolver.OnPasResolverFindUnit SOURCE=',CurEngine.Source); + CurEngine.Resolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source)); + CurEngine.Scanner:=TPascalScanner.Create(CurEngine.Resolver); + CurEngine.Parser:=TPasParser.Create(CurEngine.Scanner,CurEngine.Resolver,CurEngine); + if CompareText(CurUnitName,'System')=0 then + CurEngine.Parser.ImplicitUses.Clear; + CurEngine.Scanner.OpenFile(CurEngine.Filename); + try + CurEngine.Parser.NextToken; + CurEngine.Parser.ParseUnit(CurEngine.FModule); + except + on E: Exception do + begin + writeln('ERROR: TTestResolver.OnPasResolverFindUnit during parsing: '+E.ClassName+':'+E.Message + +' File='+CurEngine.Scanner.CurFilename + +' LineNo='+IntToStr(CurEngine.Scanner.CurRow) + +' Col='+IntToStr(CurEngine.Scanner.CurColumn) + +' Line="'+CurEngine.Scanner.CurLine+'"' + ); + raise E; + end; + end; + //writeln('TTestResolver.OnPasResolverFindUnit END ',CurUnitName); + Result:=CurEngine.Module; + exit; + end; + end; + writeln('TTestResolver.OnPasResolverFindUnit missing unit "',aUnitName,'"'); + raise Exception.Create('can''t find unit "'+aUnitName+'"'); +end; + +procedure TTestResolver.OnFindReference(Element, FindData: pointer); +var + El: TPasElement absolute Element; + Data: PTestResolverReferenceData absolute FindData; + Line, Col: integer; +begin + PasResolver.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col); + //writeln('TTestResolver.OnFindReference ',GetObjName(El),' ',El.SourceFilename,' Line=',Line,',Col=',Col,' SearchFile=',Data^.Filename,',Line=',Data^.Line,',Col=',Data^.StartCol,'-',Data^.EndCol); + if (Data^.Filename=El.SourceFilename) + and (Data^.Line=Line) + and (Data^.StartCol<=Col) + and (Data^.EndCol>=Col) + then + Data^.Found.Add(El); +end; + +function TTestResolver.GetModules(Index: integer): TTestEnginePasResolver; +begin + Result:=TTestEnginePasResolver(FModules[Index]); +end; + +function TTestResolver.GetModuleCount: integer; +begin + Result:=FModules.Count; +end; + +procedure TTestResolver.TestEmpty; +begin + StartProgram(false); + Add('begin'); + ParseProgram; + AssertEquals('No statements',0,PasProgram.InitializationSection.Elements.Count); +end; + +procedure TTestResolver.TestAliasType; +var + El: TPasElement; + T: TPasAliasType; +begin + StartProgram(false); + Add('type'); + Add(' tint=longint;'); + Add('begin'); + ParseProgram; + AssertEquals('1 declaration',1,PasProgram.ProgramSection.Declarations.Count); + El:=TPasElement(PasProgram.ProgramSection.Declarations[0]); + AssertEquals('Type',TPasAliasType,El.ClassType); + T:=TPasAliasType(El); + AssertEquals('Type tint','tint',T.Name); + AssertEquals('Type built-in',TPasUnresolvedSymbolRef,T.DestType.ClassType); + AssertEquals('longint type','longint',lowercase(T.DestType.Name)); +end; + +procedure TTestResolver.TestAlias2Type; +var + El: TPasElement; + T1, T2: TPasAliasType; + DestT1, DestT2: TPasType; +begin + StartProgram(false); + Add('type'); + Add(' tint1=longint;'); + Add(' tint2=tint1;'); + Add('begin'); + ParseProgram; + AssertEquals('2 declaration',2,PasProgram.ProgramSection.Declarations.Count); + + El:=TPasElement(PasProgram.ProgramSection.Declarations[0]); + AssertEquals('Type',TPasAliasType,El.ClassType); + T1:=TPasAliasType(El); + AssertEquals('Type tint1','tint1',T1.Name); + DestT1:=T1.DestType; + AssertEquals('built-in',TPasUnresolvedSymbolRef,DestT1.ClassType); + AssertEquals('built-in longint','longint',lowercase(DestT1.Name)); + + El:=TPasElement(PasProgram.ProgramSection.Declarations[1]); + AssertEquals('Type',TPasAliasType,El.ClassType); + T2:=TPasAliasType(El); + AssertEquals('Type tint2','tint2',T2.Name); + DestT2:=T2.DestType; + AssertEquals('points to alias type',TPasAliasType,DestT2.ClassType); + AssertEquals('points to tint1','tint1',DestT2.Name); +end; + +procedure TTestResolver.TestAliasTypeRefs; +begin + StartProgram(false); + Add('type'); + Add(' {#a}a=longint;'); + Add(' {#b}{=a}b=a;'); + Add('var'); + Add(' {=a}c: a;'); + Add(' {=b}d: b;'); + Add('begin'); + ParseProgram; +end; + +procedure TTestResolver.TestVarLongint; +var + El: TPasElement; + V1: TPasVariable; + DestT1: TPasType; +begin + StartProgram(false); + Add('var'); + Add(' v1:longint;'); + Add('begin'); + ParseProgram; + AssertEquals('1 declaration',1,PasProgram.ProgramSection.Declarations.Count); + + El:=TPasElement(PasProgram.ProgramSection.Declarations[0]); + AssertEquals('var',TPasVariable,El.ClassType); + V1:=TPasVariable(El); + AssertEquals('var v1','v1',V1.Name); + DestT1:=V1.VarType; + AssertEquals('built-in',TPasUnresolvedSymbolRef,DestT1.ClassType); + AssertEquals('built-in longint','longint',lowercase(DestT1.Name)); +end; + +procedure TTestResolver.TestVarInteger; +var + El: TPasElement; + V1: TPasVariable; + DestT1: TPasType; +begin + StartProgram(true); + Add('var'); + Add(' v1:integer;'); // defined in system.pp + Add('begin'); + ParseProgram; + AssertEquals('1 declaration',1,PasProgram.ProgramSection.Declarations.Count); + + El:=TPasElement(PasProgram.ProgramSection.Declarations[0]); + AssertEquals('var',TPasVariable,El.ClassType); + V1:=TPasVariable(El); + AssertEquals('var v1','v1',V1.Name); + DestT1:=V1.VarType; + AssertNotNull('v1 type',DestT1); + AssertEquals('built-in',TPasAliasType,DestT1.ClassType); + AssertEquals('built-in integer','integer',DestT1.Name); + AssertNull('v1 no expr',V1.Expr); +end; + +procedure TTestResolver.TestConstInteger; +var + El: TPasElement; + C1: TPasConst; + DestT1: TPasType; + ExprC1: TPrimitiveExpr; +begin + StartProgram(true); + Add('const'); + Add(' c1:integer=3;'); // defined in system.pp + Add('begin'); + ParseProgram; + AssertEquals('1 declaration',1,PasProgram.ProgramSection.Declarations.Count); + + El:=TPasElement(PasProgram.ProgramSection.Declarations[0]); + AssertEquals('const',TPasConst,El.ClassType); + C1:=TPasConst(El); + AssertEquals('const c1','c1',C1.Name); + DestT1:=C1.VarType; + AssertNotNull('c1 type',DestT1); + AssertEquals('built-in',TPasAliasType,DestT1.ClassType); + AssertEquals('built-in integer','integer',DestT1.Name); + ExprC1:=TPrimitiveExpr(C1.Expr); + AssertNotNull('c1 expr',ExprC1); + AssertEquals('c1 expr primitive',TPrimitiveExpr,ExprC1.ClassType); + AssertEquals('c1 expr value','3',ExprC1.Value); +end; + +procedure TTestResolver.TestPrgAssignment; +var + El: TPasElement; + V1: TPasVariable; + ImplAssign: TPasImplAssign; + Ref1: TPrimitiveExpr; + Resolver1: TResolvedReference; +begin + StartProgram(false); + Add('var'); + Add(' v1:longint;'); + Add('begin'); + Add(' v1:=3;'); + ParseProgram; + AssertEquals('1 declaration',1,PasProgram.ProgramSection.Declarations.Count); + + El:=TPasElement(PasProgram.ProgramSection.Declarations[0]); + AssertEquals('var',TPasVariable,El.ClassType); + V1:=TPasVariable(El); + AssertEquals('var v1','v1',V1.Name); + + AssertEquals('1 statement',1,PasProgram.InitializationSection.Elements.Count); + AssertEquals('Assignment statement',TPasImplAssign,FFirstStatement.ClassType); + ImplAssign:=FFirstStatement as TPasImplAssign; + AssertEquals('Normal assignment',akDefault,ImplAssign.Kind); + AssertExpression('Right side is constant',ImplAssign.Right,pekNumber,'3'); + AssertExpression('Left side is variable',ImplAssign.Left,pekIdent,'v1'); + AssertEquals('Left side is variable, primitive',TPrimitiveExpr,ImplAssign.Left.ClassType); + Ref1:=TPrimitiveExpr(ImplAssign.Left); + AssertNotNull('variable has customdata',Ref1.CustomData); + AssertEquals('variable has resolver',TResolvedReference,Ref1.CustomData.ClassType); + Resolver1:=TResolvedReference(Ref1.CustomData); + AssertSame('variable resolver element',Resolver1.Element,Ref1); + AssertSame('variable resolver declaration v1',Resolver1.Declaration,V1); +end; + +procedure TTestResolver.TestPrgProcVar; +begin + StartProgram(false); + Add('procedure Proc1;'); + Add('type'); + Add(' t1=longint;'); + Add('var'); + Add(' v1:t1;'); + Add('begin'); + Add('end;'); + Add('begin'); + ParseProgram; + AssertEquals('1 declaration',1,PasProgram.ProgramSection.Declarations.Count); +end; + +procedure TTestResolver.TestUnitProcVar; +var + El: TPasElement; + IntfProc1, ImplProc1: TPasProcedure; + IntfType1, ProcSubType1: TPasAliasType; + ImplVar1, ProcSubVar1: TPasVariable; + ImplVar1Type, ProcSubVar1Type: TPasType; +begin + StartUnit(false); + Add('interface'); + Add(''); + Add('type t1=string; // unit scope'); + Add('procedure Proc1;'); + Add(''); + Add('implementation'); + Add(''); + Add('procedure Proc1;'); + Add('type t1=longint; // local proc scope'); + Add('var v1:t1; // using local t1'); + Add('begin'); + Add('end;'); + Add('var v2:t1; // using interface t1'); + ParseUnit; + + // interface + AssertEquals('2 intf declarations',2,Module.InterfaceSection.Declarations.Count); + El:=TPasElement(Module.InterfaceSection.Declarations[0]); + AssertEquals('intf type',TPasAliasType,El.ClassType); + IntfType1:=TPasAliasType(El); + AssertEquals('intf type t1','t1',IntfType1.Name); + + El:=TPasElement(Module.InterfaceSection.Declarations[1]); + AssertEquals('intf proc',TPasProcedure,El.ClassType); + IntfProc1:=TPasProcedure(El); + AssertEquals('intf proc Proc1','Proc1',IntfProc1.Name); + + // implementation + AssertEquals('2 impl declarations',2,Module.ImplementationSection.Declarations.Count); + El:=TPasElement(Module.ImplementationSection.Declarations[0]); + AssertEquals('impl proc',TPasProcedure,El.ClassType); + ImplProc1:=TPasProcedure(El); + AssertEquals('impl proc Proc1','Proc1',ImplProc1.Name); + + El:=TPasElement(Module.ImplementationSection.Declarations[1]); + AssertEquals('impl var',TPasVariable,El.ClassType); + ImplVar1:=TPasVariable(El); + AssertEquals('impl var v2','v2',ImplVar1.Name); + ImplVar1Type:=TPasType(ImplVar1.VarType); + AssertSame('impl var type is intf t1',IntfType1,ImplVar1Type); + + // proc + AssertEquals('2 proc sub declarations',2,ImplProc1.Body.Declarations.Count); + + // proc sub type t1 + El:=TPasElement(ImplProc1.Body.Declarations[0]); + AssertEquals('proc sub type',TPasAliasType,El.ClassType); + ProcSubType1:=TPasAliasType(El); + AssertEquals('proc sub type t1','t1',ProcSubType1.Name); + + // proc sub var v1 + El:=TPasElement(ImplProc1.Body.Declarations[1]); + AssertEquals('proc sub var',TPasVariable,El.ClassType); + ProcSubVar1:=TPasVariable(El); + AssertEquals('proc sub var v1','v1',ProcSubVar1.Name); + ProcSubVar1Type:=TPasType(ProcSubVar1.VarType); + AssertSame('proc sub var type is proc sub t1',ProcSubType1,ProcSubVar1Type); +end; + +procedure TTestResolver.TestForLoop; +begin + StartProgram(false); + Add('var'); + Add(' {#v1}v1,{#v2}v2,{#v3}v3:longint;'); + Add('begin'); + Add(' for {@v1}v1:='); + Add(' {@v2}v2'); + Add(' to {@v3}v3 do ;'); + ParseProgram; +end; + +procedure TTestResolver.TestStatements; +begin + StartProgram(false); + Add('var'); + Add(' v1,v2,v3:longint;'); + Add('begin'); + Add(' v1:=1;'); + Add(' v2:=v1+v1*v1+v1 div v1;'); + Add(' v3:=-v1;'); + Add(' repeat'); + Add(' v1:=v1+1;'); + Add(' until v1>=5;'); + Add(' while v1>=0 do'); + Add(' v1:=v1-v2;'); + Add(' for v1:=v2 to v3 do v2:=v1;'); + Add(' if v1=5;'); + Add(' while {@v1}v1>=0 do'); + Add(' {@v1}v1'); + Add(' :={@v1}v1-{@v2}v2;'); + Add(' if {@v1}v1<{@v2}v2 then'); + Add(' {@v3}v3:={@v1}v1'); + Add(' else {@v3}v3:='); + Add(' {@v2}v2;'); + ParseProgram; + AssertEquals('3 declarations',3,PasProgram.ProgramSection.Declarations.Count); +end; + +procedure TTestResolver.TestUnitRef; +var + El, DeclEl, OtherUnit: TPasElement; + LocalVar: TPasVariable; + Assign1, Assign2, Assign3: TPasImplAssign; + Prim1, Prim2: TPrimitiveExpr; + BinExp: TBinaryExpr; +begin + StartUnit(true); + Add('interface'); + Add('var exitCOde: string;'); + Add('implementation'); + Add('initialization'); + Add(' ExitcodE:=''3'';'); + Add(' afile.eXitCode:=3;'); + Add(' System.exiTCode:=3;'); + ParseUnit; + + // interface + AssertEquals('1 intf declaration',1,Module.InterfaceSection.Declarations.Count); + El:=TPasElement(Module.InterfaceSection.Declarations[0]); + AssertEquals('local var',TPasVariable,El.ClassType); + LocalVar:=TPasVariable(El); + AssertEquals('local var exitcode','exitCOde',LocalVar.Name); + + // initialization + AssertEquals('3 initialization statements',3,Module.InitializationSection.Elements.Count); + + // check direct assignment to local var + El:=TPasElement(Module.InitializationSection.Elements[0]); + AssertEquals('direct assign',TPasImplAssign,El.ClassType); + Assign1:=TPasImplAssign(El); + AssertEquals('direct assign left',TPrimitiveExpr,Assign1.left.ClassType); + Prim1:=TPrimitiveExpr(Assign1.left); + AssertNotNull(Prim1.CustomData); + AssertEquals('direct assign left ref',TResolvedReference,Prim1.CustomData.ClassType); + DeclEl:=TResolvedReference(Prim1.CustomData).Declaration; + AssertSame('direct assign local var',LocalVar,DeclEl); + + // check indirect assignment to local var: "afile.eXitCode" + El:=TPasElement(Module.InitializationSection.Elements[1]); + AssertEquals('indirect assign',TPasImplAssign,El.ClassType); + Assign2:=TPasImplAssign(El); + AssertEquals('indirect assign left',TBinaryExpr,Assign2.left.ClassType); + BinExp:=TBinaryExpr(Assign2.left); + AssertEquals('indirect assign first token',TPrimitiveExpr,BinExp.left.ClassType); + Prim1:=TPrimitiveExpr(BinExp.left); + AssertEquals('indirect assign first token','afile',Prim1.Value); + AssertNotNull(Prim1.CustomData); + AssertEquals('indirect assign unit ref resolved',TResolvedReference,Prim1.CustomData.ClassType); + DeclEl:=TResolvedReference(Prim1.CustomData).Declaration; + AssertSame('indirect assign unit ref',Module,DeclEl); + + AssertEquals('indirect assign dot',eopSubIdent,BinExp.OpCode); + + AssertEquals('indirect assign second token',TPrimitiveExpr,BinExp.right.ClassType); + Prim2:=TPrimitiveExpr(BinExp.right); + AssertEquals('indirect assign second token','eXitCode',Prim2.Value); + AssertNotNull(Prim2.CustomData); + AssertEquals('indirect assign var ref resolved',TResolvedReference,Prim2.CustomData.ClassType); + AssertEquals('indirect assign left ref',TResolvedReference,Prim2.CustomData.ClassType); + DeclEl:=TResolvedReference(Prim2.CustomData).Declaration; + AssertSame('indirect assign local var',LocalVar,DeclEl); + + // check assignment to "system.ExitCode" + El:=TPasElement(Module.InitializationSection.Elements[2]); + AssertEquals('other unit assign',TPasImplAssign,El.ClassType); + Assign3:=TPasImplAssign(El); + AssertEquals('other unit assign left',TBinaryExpr,Assign3.left.ClassType); + BinExp:=TBinaryExpr(Assign3.left); + AssertEquals('othe unit assign first token',TPrimitiveExpr,BinExp.left.ClassType); + Prim1:=TPrimitiveExpr(BinExp.left); + AssertEquals('other unit assign first token','System',Prim1.Value); + AssertNotNull(Prim1.CustomData); + AssertEquals('other unit assign unit ref resolved',TResolvedReference,Prim1.CustomData.ClassType); + DeclEl:=TResolvedReference(Prim1.CustomData).Declaration; + OtherUnit:=DeclEl; + AssertEquals('other unit assign unit ref',TPasModule,DeclEl.ClassType); + AssertEquals('other unit assign unit ref system','system',lowercase(DeclEl.Name)); + + AssertEquals('other unit assign dot',eopSubIdent,BinExp.OpCode); + + AssertEquals('other unit assign second token',TPrimitiveExpr,BinExp.right.ClassType); + Prim2:=TPrimitiveExpr(BinExp.right); + AssertEquals('other unit assign second token','exiTCode',Prim2.Value); + AssertNotNull(Prim2.CustomData); + AssertEquals('other unit assign var ref resolved',TResolvedReference,Prim2.CustomData.ClassType); + AssertEquals('other unit assign left ref',TResolvedReference,Prim2.CustomData.ClassType); + DeclEl:=TResolvedReference(Prim2.CustomData).Declaration; + AssertEquals('other unit assign var',TPasVariable,DeclEl.ClassType); + AssertEquals('other unit assign var exitcode','exitcode',lowercase(DeclEl.Name)); + AssertSame('other unit assign var exitcode',OtherUnit,DeclEl.GetModule); +end; + +procedure TTestResolver.TestProcParam; +begin + StartProgram(false); + Add('procedure Proc1(a: longint);'); + Add('begin'); + Add(' a:=3;'); + Add('end;'); + Add('begin'); + ParseProgram; +end; + +procedure TTestResolver.TestFunctionResult; +begin + StartProgram(false); + Add('function Func1: longint;'); + Add('begin'); + Add(' Result:=3;'); + Add('end;'); + Add('begin'); + ParseProgram; +end; + +procedure TTestResolver.TestProcOverload; +var + El: TPasElement; +begin + StartProgram(false); + Add('function Func1(i: longint; j: longint = 0): longint; overload;'); + Add('begin'); + Add(' Result:=1;'); + Add('end;'); + Add('function Func1(s: string): longint; overload;'); + Add('begin'); + Add(' Result:=2;'); + Add('end;'); + Add('begin'); + Add(' Func1(3);'); + ParseProgram; + AssertEquals('1 declarations',1,PasProgram.ProgramSection.Declarations.Count); + + El:=TPasElement(PasProgram.ProgramSection.Declarations[0]); + AssertEquals('overloaded proc',TPasOverloadedProc,El.ClassType); + + AssertEquals('1 statement',1,PasProgram.InitializationSection.Elements.Count); +end; + +procedure TTestResolver.TestProcOverloadRefs; +begin + StartProgram(false); + Add('function {#A}Func1(i: longint; j: longint = 0): longint; overload;'); + Add('begin'); + Add(' Result:=1;'); + Add('end;'); + Add('function {#B}Func1(s: string): longint; overload;'); + Add('begin'); + Add(' Result:=2;'); + Add('end;'); + Add('begin'); + Add(' {@A}Func1(3);'); + ParseProgram; +end; + +procedure TTestResolver.TestNestedProc; +begin + StartProgram(false); + Add('function DoIt({#a1}a,{#d1}d: longint): longint;'); + Add('var'); + Add(' {#b1}b: longint;'); + Add(' {#c1}c: longint;'); + Add(' function {#Nesty1}Nesty({#a2}a: longint): longint; '); + Add(' var {#b2}b: longint;'); + Add(' begin'); + Add(' Result:={@a2}a'); + Add(' +{@b2}b'); + Add(' +{@c1}c'); + Add(' +{@d1}d;'); + Add(' end;'); + Add('begin'); + Add(' Result:={@a1}a'); + Add(' +{@b1}b'); + Add(' +{@c1}c;'); + Add('end;'); + Add('begin'); + ParseProgram; +end; + +initialization + RegisterTests([TTestResolver]); + +end. + diff --git a/packages/fcl-passrc/tests/tcscanner.pas b/packages/fcl-passrc/tests/tcscanner.pas index 33ff26e684..bcb2783fdd 100644 --- a/packages/fcl-passrc/tests/tcscanner.pas +++ b/packages/fcl-passrc/tests/tcscanner.pas @@ -1381,9 +1381,6 @@ begin AssertEQuals('Correct identifier', 'somethingweird',LastIdentifier); end; - - - initialization RegisterTests([TTestTokenFinder,TTestStreamLineReader,TTestScanner]); end. diff --git a/packages/fcl-passrc/tests/tcstatements.pas b/packages/fcl-passrc/tests/tcstatements.pas index 0e8fd4c0a8..abd14033dc 100644 --- a/packages/fcl-passrc/tests/tcstatements.pas +++ b/packages/fcl-passrc/tests/tcstatements.pas @@ -121,7 +121,7 @@ procedure TTestStatementParser.AddStatements(ASource: array of string); Var I :Integer; begin - StartProgram('afile'); + StartProgram(ExtractFileUnitName(MainFilename)); if FVariables.Count>0 then begin Add('Var'); @@ -369,9 +369,10 @@ begin S:=Statement as TPasImplSimple; AssertExpression('Doit call',S.Expr,pekBinary,TBinaryExpr); B:=S.Expr as TBinaryExpr; + TAssert.AssertSame('B.left.Parent=B',B,B.left.Parent); + TAssert.AssertSame('B.right.Parent=B',B,B.right.Parent); AssertExpression('Unit name',B.Left,pekIdent,'Unita'); AssertExpression('Doit call',B.Right,pekIdent,'Doit'); - end; procedure TTestStatementParser.TestCallQualified2; @@ -662,7 +663,7 @@ begin DeclareVar('integer'); TestStatement(['For a:=1 to 10 do',';']); F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop; - AssertEquals('Loop variable name','a',F.VariableName); + AssertExpression('Loop variable name',F.VariableName,pekIdent,'a'); AssertEquals('Loop type',ltNormal,F.Looptype); AssertEquals('Up loop',False,F.Down); AssertExpression('Start value',F.StartExpr,pekNumber,'1'); @@ -679,7 +680,7 @@ begin DeclareVar('integer'); TestStatement(['For a in SomeSet Do',';']); F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop; - AssertEquals('Loop variable name','a',F.VariableName); + AssertExpression('Loop variable name',F.VariableName,pekIdent,'a'); AssertEquals('Loop type',ltIn,F.Looptype); AssertEquals('In loop',False,F.Down); AssertExpression('Start value',F.StartExpr,pekIdent,'SomeSet'); @@ -696,7 +697,7 @@ begin DeclareVar('integer'); TestStatement(['For a:=1+1 to 5+5 do',';']); F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop; - AssertEquals('Loop variable name','a',F.VariableName); + AssertExpression('Loop variable name',F.VariableName,pekIdent,'a'); AssertEquals('Up loop',False,F.Down); AssertExpression('Start expression',F.StartExpr,pekBinary,TBinaryExpr); B:=F.StartExpr as TBinaryExpr; @@ -718,7 +719,7 @@ begin DeclareVar('integer'); TestStatement(['For a:=1 to 10 do','begin','end']); F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop; - AssertEquals('Loop variable name','a',F.VariableName); + AssertExpression('Loop variable name',F.VariableName,pekIdent,'a'); AssertEquals('Up loop',False,F.Down); AssertExpression('Start value',F.StartExpr,pekNumber,'1'); AssertExpression('End value',F.EndExpr,pekNumber,'10'); @@ -736,7 +737,7 @@ begin DeclareVar('integer'); TestStatement(['For a:=10 downto 1 do','begin','end']); F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop; - AssertEquals('Loop variable name','a',F.VariableName); + AssertExpression('Loop variable name',F.VariableName,pekIdent,'a'); AssertEquals('Down loop',True,F.Down); AssertExpression('Start value',F.StartExpr,pekNumber,'10'); AssertExpression('End value',F.EndExpr,pekNumber,'1'); @@ -754,14 +755,14 @@ begin DeclareVar('integer','b'); TestStatement(['For a:=1 to 10 do','For b:=11 to 20 do','begin','end']); F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop; - AssertEquals('Loop variable name','a',F.VariableName); + AssertExpression('Loop variable name',F.VariableName,pekIdent,'a'); AssertEquals('Up loop',False,F.Down); AssertExpression('Start value',F.StartExpr,pekNumber,'1'); AssertExpression('End value',F.EndExpr,pekNumber,'10'); AssertNotNull('Have while body',F.Body); AssertEquals('begin end block',TPasImplForLoop,F.Body.ClassType); F:=F.Body as TPasImplForLoop; - AssertEquals('Loop variable name','b',F.VariableName); + AssertExpression('Loop variable name',F.VariableName,pekIdent,'b'); AssertEquals('Up loop',False,F.Down); AssertExpression('Start value',F.StartExpr,pekNumber,'11'); AssertExpression('End value',F.EndExpr,pekNumber,'20'); diff --git a/packages/fcl-passrc/tests/tctypeparser.pas b/packages/fcl-passrc/tests/tctypeparser.pas index 6eb25787b4..f3248f7543 100644 --- a/packages/fcl-passrc/tests/tctypeparser.pas +++ b/packages/fcl-passrc/tests/tctypeparser.pas @@ -695,6 +695,8 @@ begin AssertNotNull('have right expr', B.Right); AssertEquals('argument right expr type', TPrimitiveExpr, B.right.ClassType); AssertEquals('argument right expr value', '2', TPrimitiveExpr(B.right).Value); + TAssert.AssertSame('B.left.parent=B',B,B.left.Parent); + TAssert.AssertSame('B.right.parent=B',B,B.right.Parent); end; procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultSet( @@ -1744,6 +1746,7 @@ procedure TTestRecordTypeParser.TestTwoFieldPrivateNoDelphi; Var EC : TClass; begin + EC:=nil; try TestFields(['private','x : integer'],'',False); Fail('Need po_Delphi for visibility specifier'); @@ -1759,16 +1762,22 @@ end; procedure TTestRecordTypeParser.TestTwoFieldProtected; Var B : Boolean; + EName: String; begin + B:=false; + EName:=''; try TestFields(['protected','x : integer'],'',False); Fail('Protected not allowed as record visibility specifier') except on E : Exception do + begin + EName:=E.ClassName; B:=E is EParserError; + end; end; If not B then - Fail('Wrong exception class.'); + Fail('Wrong exception class "'+EName+'".'); end; procedure TTestRecordTypeParser.TestTwoFieldPrivate; diff --git a/packages/fcl-passrc/tests/testpassrc.lpi b/packages/fcl-passrc/tests/testpassrc.lpi index c5e03a830f..9df63f87ff 100644 --- a/packages/fcl-passrc/tests/testpassrc.lpi +++ b/packages/fcl-passrc/tests/testpassrc.lpi @@ -38,7 +38,7 @@ - + @@ -87,6 +87,10 @@ + + + + diff --git a/packages/fcl-passrc/tests/testpassrc.lpr b/packages/fcl-passrc/tests/testpassrc.lpr index 0590042139..abed69205b 100644 --- a/packages/fcl-passrc/tests/testpassrc.lpr +++ b/packages/fcl-passrc/tests/testpassrc.lpr @@ -5,7 +5,7 @@ program testpassrc; uses Classes, consoletestrunner, tcscanner, tctypeparser, tcstatements, tcbaseparser, tcmoduleparser, tconstparser, tcvarparser, tcclasstype, - tcexprparser, tcprocfunc, tcpassrcutil; + tcexprparser, tcprocfunc, tcpassrcutil, tcresolver; type diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 38535c38c3..1d0e00acc4 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -11,7 +11,32 @@ but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - **********************************************************************} + ********************************************************************** + + Abstract: + Converts a TPasModule into + + Works: + - units, programs + - uses list + - interface vars + - implementation vars + - initialization section + - procs, params, local vars + - assign statements + - function results + + ToDos: + - many statements started, needs testing + - rename overloaded procs, append $0, $1, ... + - records + - arrays + - Optional: put implementation into $impl + - library + + Debug flags: -d + VerbosePas2JS +} unit fppas2js; {$mode objfpc}{$H+} @@ -19,45 +44,102 @@ unit fppas2js; interface uses - Classes, SysUtils, jsbase, jstree, pastree; + Classes, SysUtils, jsbase, jstree, pastree, PScanner, PasResolver; + +// message numbers +const + nPasElementNotSupported = 4001; + nIdentifierNotFound = 4002; + nUnaryOpcodeNotSupported = 4003; + nBinaryOpcodeNotSupported = 4004; + nInvalidNumber = 4005; + nInitializedArraysNotSupported = 4006; + nMemberExprMustBeIdentifier = 4007; +// resourcestring patterns of messages +resourcestring + sPasElementNotSupported = 'Pascal element not supported: %s'; + sIdentifierNotFound = 'identifier not found "%s"'; + sUnaryOpcodeNotSupported = 'Unary OpCode not yet supported "%s"'; + sBinaryOpcodeNotSupported = 'Binary OpCode not yet supported "%s"'; + sInvalidNumber = 'invalid number "%s"'; + sInitializedArraysNotSupported = 'Initialized array variables not yet supported'; + sMemberExprMustBeIdentifier = 'Member expression must be an identifier'; + Type - EPas2JS = Class(Exception); - { TPasToJSConverter } + { EPas2JS } + + EPas2JS = Class(Exception) + public + PasElement: TPasElement; + MsgNumber: integer; + Args: TMessageArgs; + end; + + { TConvertContext } TConvertContext = Class(TObject) public + Element: TPasElement; + Resolver: TPasResolver; + Parent: TConvertContext; + constructor Create(aParent: TConvertContext); + function GetRootModule: TPasModule; end; + { TRootContext } + + TRootContext = Class(TConvertContext) + end; + + { TInitializationContext } + + TInitializationContext = Class(TConvertContext) + end; + + { TProcContext } + + TProcContext = Class(TConvertContext) + end; + + { TProcBodyContext } + + TProcBodyContext = Class(TConvertContext) + // Element is TPasProcedure + end; + + { TPasToJSConverter } + TPasToJSConverter = Class(TObject) private - FCurrentContext: TJSElement; FMainFunction: TJSString; FNameSpace: TJSString; + FUseLowerCase: boolean; Procedure AddToSourceElements(Src: TJSSourceElements; El: TJSElement); Function CreateConstDecl(El: TPasConst; AContext: TConvertContext): TJSElement; Function CreateBuiltInIdentifierExpr(AName: string): TJSPrimaryExpressionIdent; - Function CreateIdentifierExpr(AName: string; El: TPasElement; AContext: TConvertContext): TJSPrimaryExpressionIdent; + Function CreateIdentifierExpr(AName: string; El: TPasElement): TJSPrimaryExpressionIdent; Function CreateTypeDecl(El: TPasType; AContext: TConvertContext): TJSElement; Function CreateVarDecl(El: TPasVariable; AContext: TConvertContext; TopLvl: boolean): TJSElement; - procedure SetCurrentContext(AValue: TJSElement); - procedure RaiseNotYetImplemented(El: TPasElement; AContext: TConvertContext); protected // helper functions Procedure DoError(Const Msg : String); Procedure DoError(Const Msg : String; Const Args : Array of Const); + Procedure DoError(MsgNumber: integer; const MsgPattern: string; Const Args : Array of Const; El: TPasElement); + procedure RaiseNotSupported(El: TPasElement; AContext: TConvertContext); + procedure RaiseIdentifierNotFound(Identifier: string; El: TPasElement); + procedure RaiseInconsistency; // Never create an element manually, always use the below function Function CreateElement(C: TJSElementClass; Src: TPasElement): TJSElement; virtual; Function GetExpressionValueType(El: TPasExpr; AContext: TConvertContext ): TJSType; virtual; Function GetPasIdentValueType(AName: String; AContext: TConvertContext): TJSType; virtual; - Function TransFormIdent(El: TJSPrimaryExpressionIdent; AContext : TConvertContext): TJSPrimaryExpressionIdent;virtual; - Function CreateJSContext(AContext : TConvertContext): TJSElement;virtual; - Function TransformVariableName(Const AName : String; AContext : TConvertContext) : String; - Function TransformVariableName(El : TPasElement; AContext : TConvertContext) : String; - Function TransformFunctionName(El : TPasElement; AContext : TConvertContext) : String; - Function GetExceptionObjectName(AContext : TConvertContext) : string; - Function ResolveType(El : TPasElement; AContext : TConvertContext) : TPasType; + Function TransFormIdent(El: TJSPrimaryExpressionIdent): TJSPrimaryExpressionIdent;virtual; + Function TransformVariableName(Const AName: String; AContext : TConvertContext): String; virtual; + Function TransformVariableName(El: TPasElement; AContext : TConvertContext) : String; virtual; + Function TransformFunctionName(El: TPasElement; AContext : TConvertContext) : String; virtual; + Function TransformModuleName(El: TPasModule; AContext : TConvertContext) : String; virtual; + Function GetExceptionObjectName(AContext: TConvertContext) : string; Function CreateCallStatement(const JSCallName: string; JSArgs: array of string): TJSCallExpression; Function CreateCallStatement(const FunNameEx: TJSElement; JSArgs: array of string): TJSCallExpression; Function CreateProcedureDeclaration(const El: TPasElement):TJSFunctionDeclarationStatement; @@ -89,6 +171,7 @@ Type Function ConvertTryFinallyStatement(El: TPasImplTryFinally; AContext: TConvertContext): TJSElement;virtual; Function ConvertExceptOn(El: TPasImplExceptOn; AContext: TConvertContext): TJSElement; Function ConvertTryExceptStatement(El: TPasImplTryExcept; AContext: TConvertContext): TJSElement; + Procedure CreateInitSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); // Expressions Function ConvertArrayValues(El: TArrayValues; AContext : TConvertContext): TJSElement;virtual; Function ConvertInheritedExpression(El: TInheritedExpr; AContext : TConvertContext): TJSElement;virtual; @@ -99,6 +182,7 @@ Type Function ConvertBinaryExpression(El: TBinaryExpr; AContext : TConvertContext): TJSElement;virtual; Function ConvertBoolConstExpression(El: TBoolConstExpr; AContext : TConvertContext): TJSElement;virtual; Function ConvertPrimitiveExpression(El: TPrimitiveExpr; AContext : TConvertContext): TJSElement;virtual; + Function ConvertIdentifierExpr(El: TPrimitiveExpr; AContext : TConvertContext): TJSElement;virtual; Function ConvertUnaryExpression(El: TUnaryExpr; AContext : TConvertContext ): TJSElement;virtual; Function ConvertCallExpression(El: TParamsExpr; AContext : TConvertContext ): TJSElement;virtual; Function TransFormStringLiteral(S : String) : String; @@ -117,20 +201,20 @@ Type Function ConvertPackage(El: TPasPackage; AContext : TConvertContext): TJSElement;virtual; Function ConvertArgument(El: TPasArgument; AContext : TConvertContext): TJSElement;virtual; Function ConvertProcedure(El: TPasProcedure; AContext : TConvertContext): TJSElement;virtual; - Function ConvertProcedureImpl(El: TPasProcedureImpl; AContext : TConvertContext): TJSElement;virtual; Function ConvertResString(El: TPasResString; AContext : TConvertContext): TJSElement;virtual; Function ConvertResultElement(El: TPasResultElement; AContext : TConvertContext): TJSElement;virtual; Function ConvertType(El: TPasElement; AContext : TConvertContext): TJSElement;virtual; Function ConvertVariable(El: TPasVariable; AContext : TConvertContext): TJSElement;virtual; Function ConvertElement(El : TPasElement; AContext : TConvertContext) : TJSElement; virtual; - function ConvertClassType(const El: TPasClassType;const AContext: TConvertContext): TJSElement; + function ConvertClassType(El: TPasClassType;AContext: TConvertContext): TJSElement; Function ConvertClassMember(El: TPasElement;AContext: TConvertContext): TJSElement; Function ConvertClassConstructor(El: TPasConstructor;AContext: TConvertContext): TJSElement; - Property CurrentContext : TJSElement Read FCurrentContext Write SetCurrentContext; Public - Function ConvertElement(El : TPasElement) : TJSElement; + constructor Create; + Function ConvertPasElement(El : TPasElement; Resolver: TPasResolver) : TJSElement; Property NameSpace : TJSString Read FNameSpace Write FNameSpace; Property MainFunction : TJSString Read FMainFunction Write FMainFunction; + Property UseLowerCase: boolean read FUseLowerCase write FUseLowerCase; end; EPasToJS = Class(Exception); @@ -140,10 +224,27 @@ var implementation -resourcestring - SErrUNknownExpressionClass = 'Unknown expression class: %s'; - SErrUnexpected = 'Unexpected class: %s'; - SerrInitalizedArray = 'Initialized array variables not yet supported'; +{ TConvertContext } + +constructor TConvertContext.Create(aParent: TConvertContext); +begin + Parent:=aParent; + if Parent<>nil then + Resolver:=Parent.Resolver; +end; + +function TConvertContext.GetRootModule: TPasModule; +var + aContext: TConvertContext; +begin + aContext:=Self; + while aContext.Parent<>nil do + aContext:=aContext.Parent; + if aContext.Element is TPasModule then + Result:=TPasModule(aContext.Element) + else + Result:=nil; +end; { TPasToJSConverter } @@ -215,7 +316,7 @@ begin RegModuleCall.Args:=ArgArray; // add parameter: unitname - ArgEx := TJSLiteral.Create(0,0,''); + ArgEx := TJSLiteral.Create(0,0); ModuleName:=El.Name; if El is TPasProgram then ModuleName:='program'; @@ -236,12 +337,12 @@ begin ArgArray.Elements.AddElement.Expr:=CreateUsesList(UsesList,AContext); // add parameter: function(){} - FunDecl:=TJSFunctionDeclarationStatement.Create(0,0,''); + FunDecl:=TJSFunctionDeclarationStatement.Create(0,0); ArgArray.Elements.AddElement.Expr:=FunDecl; FunDef:=TJSFuncDef.Create; FunDecl.AFunction:=FunDef; FunDef.Name:=''; - FunBody:=TJSFunctionBody.Create(0,0,''); + FunBody:=TJSFunctionBody.Create(0,0); FunDef.Body:=FunBody; Src:=TJSSourceElements(CreateElement(TJSSourceElements, El)); FunBody.A:=Src; @@ -249,33 +350,25 @@ begin if (El is TPasProgram) then begin // program if Assigned(TPasProgram(El).ProgramSection) then - AddToSourceElements(Src,ConvertElement(TPasProgram(El).ProgramSection,AContext)); - // add main section - if Assigned(El.InitializationSection) then - AddToSourceElements(Src,ConvertElement(El.InitializationSection,AContext)); + AddToSourceElements(Src,ConvertDeclarations(TPasProgram(El).ProgramSection,AContext)); + CreateInitSection(El,Src,AContext); end else if El is TPasLibrary then begin // library if Assigned(TPasLibrary(El).LibrarySection) then - AddToSourceElements(Src,ConvertElement(TPasLibrary(El).LibrarySection,AContext)); - // add initialization section - if Assigned(El.InitializationSection) then - AddToSourceElements(Src,ConvertElement(El.InitializationSection,AContext)); + AddToSourceElements(Src,ConvertDeclarations(TPasLibrary(El).LibrarySection,AContext)); + CreateInitSection(El,Src,AContext); end else begin // unit // add interface section if Assigned(El.InterfaceSection) then - AddToSourceElements(Src,ConvertElement(El.InterfaceSection,AContext)); + AddToSourceElements(Src,ConvertDeclarations(El.InterfaceSection,AContext)); // add implementation section if Assigned(El.ImplementationSection) then - AddToSourceElements(Src,ConvertElement(El.ImplementationSection,AContext)); - // add initialization section - if Assigned(El.InitializationSection) then - AddToSourceElements(Src,ConvertElement(El.InitializationSection,AContext)); - // finalization: not supported - if Assigned(El.FinalizationSection) then - raise Exception.Create('TPasToJSConverter.ConvertModule: finalization section is not supported'); + AddToSourceElements(Src,ConvertDeclarations(El.ImplementationSection,AContext)); + CreateInitSection(El,Src,AContext); + // add optional implementation uses list: [,, ...] if Assigned(El.ImplementationSection) then begin @@ -293,7 +386,7 @@ begin if Assigned(Src) then Result:=C.Create(Src.SourceLinenumber,1,Src.SourceFilename) else - Result:=C.Create(0,0,''); + Result:=C.Create(0,0); end; function TPasToJSConverter.ConvertUnaryExpression(El: TUnaryExpr; @@ -306,7 +399,7 @@ Var begin if AContext=nil then ; Result:=Nil; - E:=ConvertElement(El.Operand); + E:=ConvertElement(El.Operand,AContext); Case El.OpCode of eopAdd: begin @@ -319,8 +412,8 @@ begin U.A:=E; end; else - // ToDo: write Pascal source position - DoError('TPasToJSConverter.ConvertUnaryExpression: OpCode not yet supported: '+IntToStr(ord(El.OpCode))); + DoError(nUnaryOpcodeNotSupported,sUnaryOpcodeNotSupported, + [OpcodeStrings[El.OpCode]],El); end; Result:=U; end; @@ -329,8 +422,7 @@ function TPasToJSConverter.ConvertCallExpression(El: TParamsExpr; AContext: TConvertContext): TJSElement; begin if AContext=nil then ; - // ToDo: call function - Raise EPasToJS.CreateFmt(SErrUnexpected,[EL.ClassName]); + RaiseNotSupported(El,AContext); Result:=nil; end; @@ -446,37 +538,41 @@ Var ok: Boolean; begin Result:=Nil; - C:=BinClasses[EL.OpCode]; - A:=ConvertElement(EL.left,AContext); + + C:=BinClasses[El.OpCode]; + A:=ConvertElement(El.left,AContext); ok:=false; try - B:=ConvertElement(EL.right,AContext); + B:=ConvertElement(El.right,AContext); ok:=true; finally if not ok then FreeAndNil(A); end; if (C=Nil) then - Case EL.OpCode of - eopAs : begin - Result:=ConvertElement(El.Left,AContext); - end; + Case El.OpCode of + eopAs : + begin + // ToDo: add check + Result:=ConvertElement(El.left,AContext); + end; eopAnd, eopOr, eopXor : begin - if (GetExpressionValueType(EL.Left,AContext)=jstNumber) - or (GetExpressionValueType(EL.Right,AContext)=jstNumber) then - Case EL.OpCode of + if (GetExpressionValueType(El.left,AContext)=jstNumber) + or (GetExpressionValueType(El.right,AContext)=jstNumber) then + Case El.OpCode of eopAnd : C:=TJSBitwiseAndExpression; eopOr : C:=TJSBitwiseOrExpression; eopXor : C:=TJSBitwiseXOrExpression; end else - Case EL.OpCode of + Case El.OpCode of eopAnd : C:=TJSLogicalAndExpression; eopOr : C:=TJSLogicalOrExpression; - eopXOR : DoError('Logical XOR not supported yet'); + else + DoError(nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,['logical XOR'],El); end; end; eopSubIdent : @@ -487,8 +583,8 @@ begin TJSDotMemberExpression(Result).MExpr := A; TJSDotMemberExpression(Result).Name := TJSPrimaryExpressionIdent(B).Name; FreeAndNil(B); - end; - if (B is TJSCallExpression) then + end + else if (B is TJSCallExpression) then begin Result := B; funname := String(TJSPrimaryExpressionIdent(TJSCallExpression(B).Expr).Name); @@ -496,9 +592,9 @@ begin TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); TJSDotMemberExpression(TJSCallExpression(B).Expr).MExpr := A; TJSDotMemberExpression(TJSCallExpression(B).Expr).Name := TJSString(funname); - end; - if not ((B is TJSPrimaryExpressionIdent) or (B is TJSCallExpression)) then; - // DOError('Member expression must be an identifier'); + end + else + DoError(nMemberExprMustBeIdentifier,sMemberExprMustBeIdentifier,[],El); end else if (A is TJSPrimaryExpressionIdent) and @@ -525,41 +621,38 @@ begin end; end else - // ToDo: show source position - DoError('Unknown/Unsupported operand type for binary expression'); + DoError(nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,[OpcodeStrings[El.OpCode]],El); end; if (Result=Nil) and (C<>Nil) then begin - R:=TJSBinary(CreateElement(C,EL)); + R:=TJSBinary(CreateElement(C,El)); R.A:=A; R.B:=B; Result:=R; end; end; -function TPasToJSConverter.TransFormIdent(El: TJSPrimaryExpressionIdent; - AContext: TConvertContext): TJSPrimaryExpressionIdent; +function TPasToJSConverter.TransFormIdent(El: TJSPrimaryExpressionIdent + ): TJSPrimaryExpressionIdent; begin - if AContext=nil then ; - if CompareText(String(El.Name),DefaultJSExceptionObject)=0 then - El.Name:=TJSString(DefaultJSExceptionObject) - else - El.Name:=LowerCase(El.Name); + if UseLowerCase then + El.Name:=TJSString(lowercase(El.Name)); Result:=El; end; - -function TPasToJSConverter.CreateIdentifierExpr(AName: string; El: TPasElement; - AContext: TConvertContext): TJSPrimaryExpressionIdent; +function TPasToJSConverter.CreateIdentifierExpr(AName: string; El: TPasElement + ): TJSPrimaryExpressionIdent; Var I : TJSPrimaryExpressionIdent; begin I:=TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent,El)); + if UseLowerCase then + AName:=LowerCase(AName); I.Name:=TJSString(AName); - Result:=TransFormIdent(I,AContext); + Result:=TransFormIdent(I); end; function TPasToJSConverter.ConvertPrimitiveExpression(El: TPrimitiveExpr; @@ -584,17 +677,63 @@ begin L:=TJSLiteral(CreateElement(TJSLiteral,El)); Val(El.Value,Number,ConversionError); if ConversionError<>0 then - DoError('Invalid number: %s',[EL.Value]); + DoError(nInvalidNumber,sInvalidNumber,[El.Value],El); L.Value.AsNumber:=Number; Result:=L; end; pekIdent: begin - Result:=CreateIdentifierExpr(El.Value,El,AContext); + Result:=ConvertIdentifierExpr(El,AContext); end; + else + ; end; end; +function TPasToJSConverter.ConvertIdentifierExpr(El: TPrimitiveExpr; + AContext: TConvertContext): TJSElement; +var + Decl: TPasElement; + Name: String; + FoundModule: TPasModule; +begin + if AContext=nil then ; + if El.Kind<>pekIdent then + RaiseInconsistency; + if El.CustomData is TResolvedReference then + begin + Decl:=TResolvedReference(El.CustomData).Declaration; + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.ConvertIdentifierExpr ',GetObjName(El),' Decl=',GetObjName(Decl)); + {$ENDIF} + if Decl is TPasModule then + Name:='pas.'+TransformModuleName(TPasModule(Decl),AContext) + else if (Decl is TPasFunctionType) and (CompareText(ResolverResultVar,El.Value)=0) then + Name:=ResolverResultVar + else + begin + Name:=TransformVariableName(Decl,AContext); + writeln('TPasToJSConverter.ConvertIdentifierExpr Decl.Parent=',GetObjName(Decl.Parent)); + if Decl.Parent is TPasSection then + begin + FoundModule:=Decl.GetModule; + if FoundModule=nil then + RaiseInconsistency; + if AContext.GetRootModule=FoundModule then + Name:='this.'+Name + else + Name:='pas.'+TransformModuleName(FoundModule,AContext)+'.'+Name; + end; + end; + // ToDo: use TJSDotMemberExpression for dots + Result:=CreateIdentifierExpr(Name,El); + end + else if AContext.Resolver<>nil then + RaiseIdentifierNotFound(El.Value,El) + else + // simple mode + Result:=CreateIdentifierExpr(El.Value,El); +end; function TPasToJSConverter.ConvertBoolConstExpression(El: TBoolConstExpr; AContext: TConvertContext): TJSElement; @@ -630,7 +769,7 @@ var begin if AContext=nil then ; if El=nil then; - je := CreateIdentifierExpr('_super',El,AContext); + je := CreateIdentifierExpr('_super',El); Result := je; // ToDo: TInheritedExpr = class(TPasExpr) end; @@ -654,18 +793,18 @@ Var begin Result:=Nil; - Case EL.Kind of + Case El.Kind of pekFuncParams : begin C:=TJSCallExpression(CreateElement(TJSCallExpression,El)); try C.Expr:=ConvertElement(El.Value,AContext); - if (Length(EL.Params)>0) then + if (Length(El.Params)>0) then begin C.Args:=TJSArguments(CreateElement(TJSArguments,El)); - For I:=0 to Length(EL.Params)-1 do + For I:=0 to Length(El.Params)-1 do begin - E:=ConvertElement(EL.Params[i]); + E:=ConvertElement(El.Params[i],AContext); C.Args.Elements.AddElement.Expr:=E; end; end; @@ -677,12 +816,12 @@ begin end; pekArrayParams: begin - if Length(EL.Params)<>1 then + if Length(El.Params)<>1 then Raise EPasToJS.Create('Only 1-dimensional expressions allowed at this point'); B:=TJSBracketMemberExpression(CreateElement(TJSBracketMemberExpression,El)); B.MExpr:=ConvertElement(El.Value,AContext); Result:=B; - B.Name:=ConvertElement(EL.Params[0],AContext); + B.Name:=ConvertElement(El.Params[0],AContext); end end; end; @@ -753,7 +892,7 @@ begin else if (El is TRecordValues) then Result:=ConvertRecordValues(TRecordValues(El),AContext) else - DoError(SErrUNknownExpressionClass,[EL.ClassName]) + RaiseNotSupported(El,AContext); end; function TPasToJSConverter.CreateConstDecl(El: TPasConst; @@ -775,7 +914,9 @@ function TPasToJSConverter.CreateBuiltInIdentifierExpr(AName: string var Ident: TJSPrimaryExpressionIdent; begin - Ident:=TJSPrimaryExpressionIdent.Create(0,0,''); + Ident:=TJSPrimaryExpressionIdent.Create(0,0); + if UseLowerCase then + AName:=LowerCase(AName); Ident.Name:=TJSString(AName); Result:=Ident; end; @@ -828,6 +969,7 @@ Var P: TPasElement; IsTopLvl, IsProcBody, IsFunction: boolean; I : Integer; + SubContext: TConvertContext; Procedure AddFunctionResultInit; var @@ -847,8 +989,8 @@ Var Result:=SLFirst; AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); VarSt.A:=AssignSt; - AssignSt.LHS:=CreateBuiltInIdentifierExpr('result'); - AssignSt.Expr:=CreateValInit(ResultEl.ResultType,nil,El,AContext); + AssignSt.LHS:=CreateBuiltInIdentifierExpr(ResolverResultVar); + AssignSt.Expr:=CreateValInit(ResultEl.ResultType,nil,El,SubContext); end; Procedure AddFunctionResultReturn; @@ -856,7 +998,7 @@ Var RetSt: TJSReturnStatement; begin RetSt:=TJSReturnStatement(CreateElement(TJSReturnStatement,El)); - RetSt.Expr:=CreateBuiltInIdentifierExpr('result'); + RetSt.Expr:=CreateBuiltInIdentifierExpr(ResolverResultVar); AddToStatementList(SLFirst,SLLast,RetSt,El); end; @@ -869,56 +1011,63 @@ begin IsProcBody:=(El is TProcedureBody) and (TProcedureBody(El).Body<>nil); IsFunction:=IsProcBody and (El.Parent is TPasFunction); - if IsProcBody and IsFunction then - AddFunctionResultInit; + SubContext:=TProcContext.Create(aContext); + try + SubContext.Element:=El; - For I:=0 to El.Declarations.Count-1 do - begin - E:=Nil; - P:=TPasElement(El.Declarations[i]); - if P is TPasConst then - E:=CreateConstDecl(TPasConst(P),AContext) - else if P is TPasVariable then - E:=CreateVarDecl(TPasVariable(P),AContext,IsTopLvl) - else if P is TPasType then - E:=CreateTypeDecl(TPasType(P),AContext) - else if P is TPasProcedure then - E:=ConvertProcedure(TPasProcedure(P),AContext) - else - DoError('Unknown class: "%s" ',[P.ClassName]); - if (Pos('.', P.Name) > 0) then - AddProcedureToClass(TJSStatementList(Result), E, P as TPasProcedure) - else - AddToStatementList(SLFirst,SLLast,E,El); - Result:=SLFirst; - end; + if IsProcBody and IsFunction then + AddFunctionResultInit; - if IsProcBody then - begin - E:=ConvertElement(TProcedureBody(El).Body,AContext); - AddToStatementList(SLFirst,SLLast,E,El); - Result:=SLFirst; - end; + For I:=0 to El.Declarations.Count-1 do + begin + E:=Nil; + P:=TPasElement(El.Declarations[i]); + if P is TPasConst then + E:=CreateConstDecl(TPasConst(P),SubContext) + else if P is TPasVariable then + E:=CreateVarDecl(TPasVariable(P),SubContext,IsTopLvl) + else if P is TPasType then + E:=CreateTypeDecl(TPasType(P),SubContext) + else if P is TPasProcedure then + E:=ConvertProcedure(TPasProcedure(P),SubContext) + else + RaiseNotSupported(P as TPasElement,AContext); + if (Pos('.', P.Name) > 0) then + AddProcedureToClass(TJSStatementList(Result), E, P as TPasProcedure) + else + AddToStatementList(SLFirst,SLLast,E,El); + Result:=SLFirst; + end; - if IsProcBody and IsFunction then - AddFunctionResultReturn; + if IsProcBody then + begin + E:=ConvertElement(TProcedureBody(El).Body,SubContext); + AddToStatementList(SLFirst,SLLast,E,El); + Result:=SLFirst; + end; -{ - TPasDeclarations = class(TPasElement) - TPasSection = class(TPasDeclarations) - TInterfaceSection = class(TPasSection) - TImplementationSection = class(TPasSection) - TProgramSection = class(TImplementationSection) - TLibrarySection = class(TImplementationSection) - TProcedureBody = class(TPasDeclarations) -} + if IsProcBody and IsFunction then + AddFunctionResultReturn; + + { + TPasDeclarations = class(TPasElement) + TPasSection = class(TPasDeclarations) + TInterfaceSection = class(TPasSection) + TImplementationSection = class(TPasSection) + TProgramSection = class(TImplementationSection) + TLibrarySection = class(TImplementationSection) + TProcedureBody = class(TPasDeclarations) + } + finally + SubContext.Free; + end; end; function TPasToJSConverter.ConvertType(El: TPasElement; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; { ToDo: @@ -946,8 +1095,8 @@ TPasTypeRef = class(TPasUnresolvedTypeRef) } end; -function TPasToJSConverter.ConvertClassType(const El: TPasClassType; - const AContext: TConvertContext): TJSElement; +function TPasToJSConverter.ConvertClassType(El: TPasClassType; + AContext: TConvertContext): TJSElement; var call: TJSCallExpression; asi: TJSSimpleAssignStatement; @@ -967,7 +1116,7 @@ begin unary := TJSUnary(CreateElement(TJSUnary,El)); asi := TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); unary.A := asi; - asi.LHS := CreateIdentifierExpr(El.Name,El,AContext); + asi.LHS := CreateIdentifierExpr(El.Name,El); FS := TJSFunctionDeclarationStatement( CreateElement(TJSFunctionDeclarationStatement, El)); call := CreateCallStatement(FS, []); @@ -980,7 +1129,7 @@ begin if Assigned(El.AncestorType) then begin call.Args := TJSArguments(CreateElement(TJSArguments, El)); - call.Args.Elements.AddElement.Expr := CreateIdentifierExpr(El.AncestorType.Name,El,AContext); + call.Args.Elements.AddElement.Expr := CreateIdentifierExpr(El.AncestorType.Name,El); FD.Params.Add('_super'); unary2 := TJSUnary(CreateElement(TJSUnary, El)); call := CreateCallStatement('__extends', [jsName, '_super']); @@ -1005,7 +1154,7 @@ begin //add return statement ret := TJSReturnStatement(CreateElement(TJSReturnStatement, El)); TJSSourceElements(FD.Body.A).Statements.AddNode.Node := ret; - ret.Expr := CreateIdentifierExpr(El.Name,El,AContext); + ret.Expr := CreateIdentifierExpr(El.Name,El); Result := unary; end; @@ -1048,18 +1197,23 @@ begin fun1sourceele.Statements.AddNode.Node := ret; nmem := TJSNewMemberExpression.Create(0, 0, ''); ret.Expr := nmem; - nmem.MExpr := CreateIdentifierExpr(El.Parent.FullName,El.Parent,AContext); + nmem.MExpr := CreateIdentifierExpr(El.Parent.FullName,El.Parent); for n := 0 to El.ProcType.Args.Count - 1 do begin if n = 0 then nmem.Args := TJSArguments.Create(0, 0, ''); fs.AFunction.Params.Add(TPasArgument(El.ProcType.Args[n]).Name); Arg := TPasArgument(El.ProcType.Args[n]); - nmem.Args.Elements.AddElement.Expr := CreateIdentifierExpr(Arg.Name,Arg,AContext); + nmem.Args.Elements.AddElement.Expr := CreateIdentifierExpr(Arg.Name,Arg); end; Result := CreateUnary([El.Parent.FullName, TPasProcedure(El).Name], FS); end; +constructor TPasToJSConverter.Create; +begin + FUseLowerCase:=true; +end; + function TPasToJSConverter.ConvertProcedure(El: TPasProcedure; AContext: TConvertContext): TJSElement; @@ -1070,6 +1224,7 @@ Var IsTopLvl: Boolean; FunName: String; AssignSt: TJSSimpleAssignStatement; + SubContext: TConvertContext; begin Result:=nil; @@ -1097,7 +1252,14 @@ begin for n := 0 to El.ProcType.Args.Count - 1 do FD.Params.Add(TransformVariableName(TPasArgument(El.ProcType.Args[0]).Name,AContext)); FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,El.Body)); - FD.Body.A:=ConvertElement(El.Body,AContext); + + SubContext:=TProcBodyContext.Create(AContext); + try + SubContext.Element:=El; + FD.Body.A:=ConvertElement(El.Body,SubContext); + finally + SubContext.Free; + end; { TPasProcedureBase = class(TPasElement) TPasOverloadedProc = class(TPasProcedureBase) @@ -1111,28 +1273,6 @@ begin } end; -function TPasToJSConverter.ConvertProcedureImpl(El: TPasProcedureImpl; - AContext: TConvertContext): TJSElement; - -Var - FS : TJSFunctionDeclarationStatement; - FD : TJSFuncDef; - -begin - FS:=TJSFunctionDeclarationStatement(CreateElement(TJSFunctionDeclarationStatement,EL)); - Result:=FS; - FD:=TJSFuncDef.Create; - FD.Name:=TJSString(TransformFunctionName(El,AContext)); - FS.AFunction:=FD; - FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,EL.Body)); - FD.Body.A:=ConvertElement(El.Body,AContext); -{ - TPasProcedureImpl = class(TPasElement) - TPasConstructorImpl = class(TPasProcedureImpl) - TPasDestructorImpl = class(TPasProcedureImpl) -} -end; - function TPasToJSConverter.ConvertBeginEndStatement(El: TPasImplBeginBlock; AContext: TConvertContext): TJSElement; @@ -1228,7 +1368,7 @@ begin F:=Nil; B:=ConvertImplBlockElements(El,AContext); try - F:=ConvertElement(El.FinallyExcept); + F:=ConvertElement(El.FinallyExcept,AContext); IsFin:=El.FinallyExcept is TPasImplTryFinally; if IsFin then T:=TJSTryFinallyStatement(CreateElement(TJSTryFinallyStatement,El)) @@ -1266,6 +1406,25 @@ begin Result:=ConvertImplBlockElements(El,AContext); end; +procedure TPasToJSConverter.CreateInitSection(El: TPasModule; + Src: TJSSourceElements; AContext: TConvertContext); +var + SubContext: TInitializationContext; +begin + SubContext:=TInitializationContext.Create(AContext); + try + SubContext.Element:=El; + // add initialization section + if Assigned(El.InitializationSection) then + AddToSourceElements(Src,ConvertImplBlock(El.InitializationSection,SubContext)); + // finalization: not supported + if Assigned(El.FinalizationSection) then + raise Exception.Create('TPasToJSConverter.ConvertInitializationSection: finalization section is not supported'); + finally + SubContext.Free; + end; +end; + function TPasToJSConverter.ConvertImplBlock(El: TPasImplBlock; AContext: TConvertContext): TJSElement; @@ -1307,7 +1466,7 @@ function TPasToJSConverter.ConvertPackage(El: TPasPackage; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo TPasPackage = class(TPasElement) end; @@ -1316,7 +1475,7 @@ function TPasToJSConverter.ConvertResString(El: TPasResString; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo: TPasResString end; @@ -1325,7 +1484,7 @@ function TPasToJSConverter.ConvertArgument(El: TPasArgument; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo: TPasArgument end; @@ -1335,7 +1494,7 @@ function TPasToJSConverter.ConvertResultElement(El: TPasResultElement; begin // is this still needed? - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // TPasResultElement end; @@ -1356,7 +1515,7 @@ function TPasToJSConverter.ConvertConst(El: TPasConst; AContext: TConvertContext ): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo: TPasConst end; @@ -1365,7 +1524,7 @@ function TPasToJSConverter.ConvertProperty(El: TPasProperty; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo: TPasProperty = class(TPasVariable) end; @@ -1374,7 +1533,7 @@ function TPasToJSConverter.ConvertExportSymbol(El: TPasExportSymbol; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo: TPasExportSymbol end; @@ -1383,7 +1542,7 @@ function TPasToJSConverter.ConvertLabels(El: TPasLabels; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo: TPasLabels = class(TPasImplElement) end; @@ -1397,9 +1556,9 @@ Var begin if El.ExceptObject<>Nil then - E:=ConvertElement(El.ExceptObject) + E:=ConvertElement(El.ExceptObject,AContext) else - E:=CreateIdentifierExpr(GetExceptionObjectName(AContext),El,AContext); + E:=CreateIdentifierExpr(GetExceptionObjectName(AContext),El); T:=TJSThrowStatement(CreateElement(TJSThrowStatement,El)); T.A:=E; Result:=T; @@ -1415,10 +1574,10 @@ Var begin if AContext=nil then ; - LHS:=ConvertElement(El.left); + LHS:=ConvertElement(El.left,AContext); ok:=false; try - RHS:=ConvertElement(El.right); + RHS:=ConvertElement(El.right,AContext); ok:=true; finally if not ok then @@ -1434,7 +1593,7 @@ function TPasToJSConverter.ConvertCommand(El: TPasImplCommand; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo: TPasImplCommand = class(TPasImplElement) end; @@ -1454,13 +1613,13 @@ begin BElse:=Nil; ok:=false; try - C:=ConvertElement(El.ConditionExpr); + C:=ConvertElement(El.ConditionExpr,AContext); if Assigned(El.IfBranch) then - BThen:=ConvertElement(El.IfBranch) + BThen:=ConvertElement(El.IfBranch,AContext) else BThen:=TJSEmptyBlockStatement(CreateElement(TJSEmptyBlockStatement,El)); if Assigned(El.ElseBranch) then - BElse:=ConvertElement(El.ElseBranch); + BElse:=ConvertElement(El.ElseBranch,AContext); ok:=true; finally if not ok then @@ -1575,7 +1734,7 @@ begin L.B:=F; I:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El.StartExpr)); F.Init:=I; - I.LHS:=CreateIdentifierExpr(El.VariableName,El,AContext); + I.LHS:=CreateIdentifierExpr(El.VariableName,El); I.Expr:=ConvertElement(El.StartExpr,AContext); If El.Down then begin @@ -1589,10 +1748,10 @@ begin end; F.Incr:=U; F.Cond:=B; - U.A:=CreateIdentifierExpr(El.VariableName,El,AContext); - B.A:=CreateIdentifierExpr(El.VariableName,El,AContext); - B.B:=CreateIdentifierExpr(MV,El.EndExpr,AContext); - F.Body:=ConvertElement(El.Body); + U.A:=CreateIdentifierExpr(El.VariableName,El); + B.A:=CreateIdentifierExpr(El.VariableName,El); + B.B:=CreateIdentifierExpr(MV,El.EndExpr); + F.Body:=ConvertElement(El.Body,AContext); ok:=true; finally if not ok then @@ -1657,17 +1816,15 @@ function TPasToJSConverter.GetExceptionObjectName(AContext: TConvertContext begin if AContext=nil then ; Result:=DefaultJSExceptionObject; // use the same as the FPC RTL + if UseLowerCase then + Result:=lowercase(Result); end; -function TPasToJSConverter.ResolveType(El: TPasElement; - AContext: TConvertContext): TPasType; +procedure TPasToJSConverter.RaiseInconsistency; begin - if AContext=nil then ; - if EL is TPasType then - Result:=TPasType(El) // TPasUnresolvedTypeRef needs handling here - else - Result:=Nil; + raise Exception.Create('TPasToJSConverter.RaiseInconsistency: you found a bug'); end; + function TPasToJSConverter.CreateCallStatement(const JSCallName: string; JSArgs: array of string): TJSCallExpression; var @@ -1722,7 +1879,7 @@ var k: integer; begin if Length(Members) < 2 then - DoError('member expression with less than two members'); + DoError('internal error: member expression with less than two members'); LastMExpr := nil; for k:=High(Members) downto Low(Members)+1 do begin @@ -1846,14 +2003,14 @@ var anUnitName: String; ArgEx: TJSLiteral; begin - ArgArray:=TJSArrayLiteral.Create(0,0,''); + ArgArray:=TJSArrayLiteral.Create(0,0); if UsesList<>nil then for k:=0 to UsesList.Count-1 do begin El:=TPasElement(UsesList[k]); if not (El is TPasModule) then continue; anUnitName := TransformVariableName(TPasModule(El).Name,AContext); - ArgEx := TJSLiteral.Create(0,0,''); + ArgEx := TJSLiteral.Create(0,0); ArgEx.Value.AsString:=TJSString(anUnitName); ArgArray.Elements.AddElement.Expr := ArgEx; end; @@ -1924,14 +2081,14 @@ var T: TPasType; Lit: TJSLiteral; begin - T:=ResolveType(PasType,AContext); + T:=PasType; if (T is TPasArrayType) then begin Result:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,PasType)); If Assigned(Expr) then - Raise EPasToJS.Create(SerrInitalizedArray); + DoError(nInitializedArraysNotSupported,sInitializedArraysNotSupported,[],PasType); end - else If Assigned(Expr) then + else if Assigned(Expr) then Result:=ConvertElement(Expr,AContext) else begin @@ -1939,15 +2096,19 @@ begin Lit:=TJSLiteral(CreateElement(TJSLiteral,El)); Result:=Lit; if T is TPasAliasType then - T:=ResolveType(TPasAliasType(T).DestType,AContext); + T:=TPasAliasType(T).DestType; - if T is TPasPointerType then + if T=nil then + Lit.Value.IsUndefined:=true + else if T.ClassType=TPasPointerType then Lit.Value.IsNull:=true - else if T is TPasStringType then + else if T.ClassType=TPasStringType then Lit.Value.AsString:='' - else if T is TPasUnresolvedTypeRef then + else if T.ClassType=TPasUnresolvedSymbolRef then begin - if (CompareText(T.Name,'integer')=0) + if (CompareText(T.Name,'longint')=0) + or (CompareText(T.Name,'int64')=0) + or (CompareText(T.Name,'real')=0) or (CompareText(T.Name,'double')=0) then Lit.Value.AsNumber:=0.0 @@ -2003,15 +2164,15 @@ Var begin I:=TJSIfStatement(CreateElement(TJSIfStatement,El)); IO:=TJSRelationalExpressionInstanceOf(CreateElement(TJSRelationalExpressionInstanceOf,El)); - IO.A:=CreateIdentifierExpr(GetExceptionObjectName(AContext),El,AContext); - IO.B:=CreateIdentifierExpr(El.TypeName,El,AContext); + IO.A:=CreateIdentifierExpr(GetExceptionObjectName(AContext),El); + IO.B:=CreateIdentifierExpr(El.TypeName,El); I.Cond:=IO; L:=TJSStatementList(CreateElement(TJSStatementList,El.Body)); I.BTrue:=L; V:=TJSVarDeclaration(CreateElement(TJSVarDeclaration,El)); L.A:=V; V.Name:=TransformVariableName(El.VariableName,AContext); - V.Init:=CreateIdentifierExpr(GetExceptionObjectName(AContext),El,AContext); + V.Init:=CreateIdentifierExpr(GetExceptionObjectName(AContext),El); L.B:=TJSStatementList(CreateElement(TJSStatementList,El.Body)); L:=TJSStatementList(L.B); L.A:=ConvertElement(El.Body,AContext); @@ -2038,8 +2199,7 @@ begin else if (El is TPasImplForLoop) then Result:=ConvertForStatement(TPasImplForLoop(El),AContext) else - // ToDo: write source position - DoError('Unknown statement Class: %s',[El.ClassName]); + RaiseNotSupported(El,AContext); { TPasImplCaseStatement = class(TPasImplStatement) } @@ -2050,7 +2210,7 @@ function TPasToJSConverter.ConvertCommands(El: TPasImplCommands; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo: TPasImplCommands = class(TPasImplElement) end; @@ -2059,7 +2219,7 @@ function TPasToJSConverter.ConvertLabelMark(El: TPasImplLabelMark; AContext: TConvertContext): TJSElement; begin - RaiseNotYetImplemented(El,AContext); + RaiseNotSupported(El,AContext); Result:=Nil; // ToDo: TPasImplLabelMark = class(TPasImplLabelMark) then end; @@ -2071,39 +2231,37 @@ begin Result:=ConvertPackage(TPasPackage(El),AContext) else If (El is TPasModule) then Result:=ConvertModule(TPasModule(El),AContext) - else if (EL is TPasExpr) then + else if (El is TPasExpr) then Result:=ConvertExpression(TPasExpr(El),AContext) - else if (EL is TPasDeclarations) then + else if (El is TPasDeclarations) then Result:=ConvertDeclarations(TPasDeclarations(El),AContext) - else if (EL is TPasType) then + else if (El is TPasType) then Result:=ConvertType(TPasType(El),AContext) - else if (EL is TPasProcedure) then + else if (El is TPasProcedure) then Result:=ConvertProcedure(TPasProcedure(El),AContext) - else if (EL is TPasProcedureImpl) then - Result:=ConvertProcedureImpl(TPasProcedureImpl(El),AContext) - else if (EL is TPasImplBlock) then + else if (El is TPasImplBlock) then Result:=ConvertImplBlock(TPasImplBlock(El),AContext) - else if (EL is TPasResString) then + else if (El is TPasResString) then Result:=ConvertResString(TPasResString(El),AContext) - else if (EL is TPasArgument) then + else if (El is TPasArgument) then Result:=ConvertArgument(TPasArgument(El),AContext) - else if (EL is TPasResultElement) then + else if (El is TPasResultElement) then Result:=ConvertResultElement(TPasResultElement(El),AContext) - else if (EL is TPasConst) then + else if (El is TPasConst) then Result:=ConvertConst(TPasConst(El),AContext) - else if (EL is TPasProperty) then + else if (El is TPasProperty) then Result:=ConvertProperty(TPasProperty(El),AContext) - else if (EL is TPasVariable) then + else if (El is TPasVariable) then Result:=ConvertVariable(TPasVariable(El),AContext) - else if (EL is TPasExportSymbol) then + else if (El is TPasExportSymbol) then Result:=ConvertExportSymbol(TPasExportSymbol(El),AContext) - else if (EL is TPasLabels) then + else if (El is TPasLabels) then Result:=ConvertLabels(TPasLabels(El),AContext) - else if (EL is TPasImplCommand) then + else if (El is TPasImplCommand) then Result:=ConvertCommand(TPasImplCommand(El),AContext) - else if (EL is TPasImplCommands) then + else if (El is TPasImplCommands) then Result:=ConvertCommands(TPasImplCommands(El),AContext) - else if (EL is TPasImplLabelMark) then + else if (El is TPasImplLabelMark) then Result:=ConvertLabelMark(TPasImplLabelMark(El),AContext) else Result:=nil; @@ -2120,59 +2278,95 @@ begin Raise EPas2JS.CreateFmt(Msg,Args); end; -procedure TPasToJSConverter.SetCurrentContext(AValue: TJSElement); +procedure TPasToJSConverter.DoError(MsgNumber: integer; + const MsgPattern: string; const Args: array of const; El: TPasElement); +var + E: EPas2JS; begin - if FCurrentContext=AValue then Exit; - FCurrentContext:=AValue; + E:=EPas2JS.CreateFmt(MsgPattern,[El.ClassName]); + E.PasElement:=El; + E.MsgNumber:=MsgNumber; + CreateMsgArgs(E.Args,Args); + raise E; end; -procedure TPasToJSConverter.RaiseNotYetImplemented(El: TPasElement; +procedure TPasToJSConverter.RaiseNotSupported(El: TPasElement; AContext: TConvertContext); +var + E: EPas2JS; begin if AContext=nil then ; - raise EPas2JS.Create('conversion not yet implemented for "'+El.ClassName+'"'); + E:=EPas2JS.CreateFmt(sPasElementNotSupported,[GetObjName(El)]); + E.PasElement:=El; + E.MsgNumber:=nPasElementNotSupported; + SetLength(E.Args,1); + E.Args[0]:=El.ClassName; + raise E; end; -function TPasToJSConverter.CreateJSContext(AContext: TConvertContext - ): TJSElement; - +procedure TPasToJSConverter.RaiseIdentifierNotFound(Identifier: string; + El: TPasElement); +var + E: EPas2JS; begin - if AContext=nil then ; - Result:=TJSObjectLiteral.Create(0,0); + E:=EPas2JS.CreateFmt(sIdentifierNotFound,[Identifier]); + E.PasElement:=El; + E.MsgNumber:=nIdentifierNotFound; + SetLength(E.Args,1); + E.Args[0]:=Identifier; + raise E; end; function TPasToJSConverter.TransformVariableName(const AName: String; AContext: TConvertContext): String; begin if AContext=nil then ; - if CompareText(AName,DefaultJSExceptionObject)=0 then - Result:=DefaultJSExceptionObject + if UseLowerCase then + Result:=lowercase(AName) else - Result:=LowerCase(AName); + Result:=AName; end; function TPasToJSConverter.TransformVariableName(El: TPasElement; AContext: TConvertContext): String; begin if AContext=nil then ; - Result:=TransformVariableName(El.Name,AContext); - // Add to context. + Result:=El.Name; + if UseLowerCase then + Result:=lowercase(Result); end; function TPasToJSConverter.TransformFunctionName(El: TPasElement; AContext: TConvertContext): String; begin if AContext=nil then ; - if CompareText(El.Name,DefaultJSExceptionObject)=0 then - Result:=DefaultJSExceptionObject - else - Result:=LowerCase(El.Name); + Result:=El.Name; + if UseLowerCase then + Result:=lowercase(Result); end; -function TPasToJSConverter.ConvertElement(El: TPasElement): TJSElement; +function TPasToJSConverter.TransformModuleName(El: TPasModule; + AContext: TConvertContext): String; begin - // CurrentContext:=CreateJSContext(Nil); - Result:=ConvertElement(El,Nil); + if AContext=nil then ; + Result:=El.Name; + if UseLowerCase then + Result:=lowercase(Result); +end; + +function TPasToJSConverter.ConvertPasElement(El: TPasElement; + Resolver: TPasResolver): TJSElement; +var + aContext: TRootContext; +begin + aContext:=TRootContext.Create(nil); + try + aContext.Element:=El; + aContext.Resolver:=Resolver; + Result:=ConvertElement(El,aContext); + finally + FreeAndNil(aContext); + end; end; end. diff --git a/packages/pastojs/tests/tcconverter.pp b/packages/pastojs/tests/tcconverter.pp index 59aa81e562..7bab9ee0d0 100644 --- a/packages/pastojs/tests/tcconverter.pp +++ b/packages/pastojs/tests/tcconverter.pp @@ -63,6 +63,8 @@ type Class Function CreateCondition: TPasExpr; end; + { TTestTestConverter } + TTestTestConverter = class(TTestConverter) published procedure TestEmpty; @@ -584,7 +586,7 @@ begin AssertNull('No second statement',L.B); L:=AssertListStatement('try..except block is statement list',El.BCatch); AssertAssignStatement('Correct assignment in except..end block',L.A,'b','c'); - AssertEquals('Correct exception object name',DefaultJSExceptionObject,El.Ident); + AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),El.Ident); AssertNull('No second statement',L.B); end; @@ -621,18 +623,18 @@ begin O.Body:=CreateAssignStatement('b','c'); // Convert El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement)); - AssertEquals('Correct exception object name',DefaultJSExceptionObject,EL.Ident); + AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),EL.Ident); L:=AssertListStatement('try..except block is statement list',El.BCatch); AssertNull('No second statement',L.B); I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,L.A)); Ic:=TJSRelationalExpressionInstanceOf(AssertElement('If condition is InstanceOf expression',TJSRelationalExpressionInstanceOf,I.Cond)); - Assertidentifier('InstanceOf left is exception object',Ic.A,DefaultJSExceptionObject); + Assertidentifier('InstanceOf left is exception object',Ic.A,lowercase(DefaultJSExceptionObject)); // Lowercased exception - May need checking Assertidentifier('InstanceOf right is original exception type',Ic.B,'exception'); L:=AssertListStatement('On block is always a list',i.btrue); V:=TJSVarDeclaration(AssertElement('First statement in list is a var declaration',TJSVarDeclaration,L.A)); AssertEquals('Variable name is identifier in On A : Ex do','e',V.Name); - Assertidentifier('Variable init is exception object',v.init,DefaultJSExceptionObject); + Assertidentifier('Variable init is exception object',v.init,lowercase(DefaultJSExceptionObject)); L:=AssertListStatement('Second statement is again list',L.B); AssertAssignStatement('Original assignment in second statement',L.A,'b','c'); end; @@ -669,20 +671,20 @@ begin O.Body:=TPasImplRaise.Create('',Nil); // Convert El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement)); - AssertEquals('Correct exception object name',DefaultJSExceptionObject,EL.Ident); + AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),EL.Ident); L:=AssertListStatement('try..except block is statement list',El.BCatch); AssertNull('No second statement',L.B); I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,L.A)); Ic:=TJSRelationalExpressionInstanceOf(AssertElement('If condition is InstanceOf expression',TJSRelationalExpressionInstanceOf,I.Cond)); - Assertidentifier('InstanceOf left is exception object',Ic.A,DefaultJSExceptionObject); + Assertidentifier('InstanceOf left is exception object',Ic.A,lowercase(DefaultJSExceptionObject)); // Lowercased exception - May need checking L:=AssertListStatement('On block is always a list',i.btrue); V:=TJSVarDeclaration(AssertElement('First statement in list is a var declaration',TJSVarDeclaration,L.A)); AssertEquals('Variable name is identifier in On A : Ex do','e',V.Name); - Assertidentifier('Variable init is exception object',v.init,DefaultJSExceptionObject); + Assertidentifier('Variable init is exception object',v.init,lowercase(DefaultJSExceptionObject)); L:=AssertListStatement('Second statement is again list',L.B); R:=TJSThrowStatement(AssertElement('On block is throw statement',TJSThrowStatement,L.A)); - Assertidentifier('R expression is original exception ',R.A,DefaultJSExceptionObject); + Assertidentifier('R expression is original exception ',R.A,lowercase(DefaultJSExceptionObject)); end; Procedure TTestStatementConverter.TestVariableStatement; @@ -1206,7 +1208,7 @@ Function TTestConverter.Convert(AElement: TPasElement; AClass: TJSElementClass ): TJSElement; begin FSource:=AElement; - Result:=FConverter.ConvertElement(AElement); + Result:=FConverter.ConvertPasElement(AElement,nil); FRes:=Result; if (AClass<>Nil) then begin