From 393b4caba2dfc80ee43826c905bb63dae19fb1ab Mon Sep 17 00:00:00 2001 From: michael Date: Sat, 4 Feb 2017 11:26:59 +0000 Subject: [PATCH] * Patch from Mattias Gaertner: jswriter: more compact try..catch pasresolver: - mark function calls without () - "with type do ;" - constructor call store TPasType - mark if a constructor call creates a new instance or is a normal call - same for destructor - fixed checking assign operator types - more tests fppas2js: - convert implicit calls in Pascal to explicit calls in JS - built in procedure "exit" and "exit(value)" - if loopvar is used afterwards append if($loopend>i)i--; - classes - declare using createClass, needs rtl magic - constructor - destructor - vars - ancestor - virtual, override, abstract - "is" operator - "as" operator - call inherited "inherited;", "inherited funcname;" - dynamic arrays - init as "arr = []" - SetLength(arr,newlength) - length(arr) - try..except, on .. do, raise - insert default values in calls git-svn-id: trunk@35383 - --- packages/fcl-js/src/jswriter.pp | 30 +- packages/fcl-passrc/src/pasresolver.pp | 519 ++++--- packages/fcl-passrc/src/pparser.pp | 112 +- packages/fcl-passrc/src/pscanner.pp | 18 +- packages/fcl-passrc/tests/tcclasstype.pas | 27 +- packages/fcl-passrc/tests/tcresolver.pas | 780 ++++++++--- packages/fcl-passrc/tests/tcstatements.pas | 2 - packages/fcl-passrc/tests/testpassrc.lpi | 2 +- packages/pastojs/src/fppas2js.pp | 1419 ++++++++++++++++---- packages/pastojs/tests/tcconverter.pp | 92 +- packages/pastojs/tests/tcmodules.pas | 678 +++++++++- 11 files changed, 2907 insertions(+), 772 deletions(-) diff --git a/packages/fcl-js/src/jswriter.pp b/packages/fcl-js/src/jswriter.pp index 947427ad3b..c3ff91dc8f 100644 --- a/packages/fcl-js/src/jswriter.pp +++ b/packages/fcl-js/src/jswriter.pp @@ -1051,39 +1051,27 @@ begin Indent; WriteJS(El.Block); Undent; - If C then - Write('} ') - else - begin - Writeln('}'); - end; + Write('}'); If (El is TJSTryCatchFinallyStatement) or (El is TJSTryCatchStatement) then begin - Write('catch ('+El.Ident); + Write(' catch'); + if El.Ident<>'' then Write(' ('+El.Ident+')'); If C then - Write(') {') + Write(' {') else - Writeln(') {'); + Writeln(' {'); + FSkipBrackets:=True; Indent; WriteJS(El.BCatch); Undent; - If C then - if (El is TJSTryCatchFinallyStatement) then - Write('} ') - else - Write('}') - else - begin - Writeln(''); - Writeln('}'); - end; + Write('}'); end; If (El is TJSTryCatchFinallyStatement) or (El is TJSTryFinallyStatement) then begin If C then - Write('finally {') + Write(' finally {') else - Writeln('finally {'); + Writeln(' finally {'); Indent; FSkipBrackets:=True; WriteJS(El.BFinally); diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 997fc5b2d6..be3a52f098 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -57,7 +57,8 @@ - defaultexpr - is and as operator - nil - - constructor result type + - constructor result type, rrfNewInstance + - destructor call type: rrfFreeInstance - type cast - class of - class method, property, var, const @@ -93,8 +94,10 @@ - built-in functions high, low for range type and arrays - procedure type - method type + - function without params: mark if call or address, rrfImplicitCallWithoutParams ToDo: + - overloads - char constant #0, #10, #13, UTF-8 char - const TArrayValues - classes - TPasClassType @@ -102,6 +105,7 @@ - nested types - check if constant is longint or int64 - for..in..do + - class forward and pointer type must check type section before other scopes - pointer TPasPointerType - records - TPasRecordType, - variant - TPasVariant @@ -127,6 +131,20 @@ Debug flags: -d VerbosePasResolver + + Notes: + Functions and function types without parameters: + property P read f; // use function f, not its result + f. // implicit resolve f once if param less function or function type + f[] // implicit resolve f once if a param less function or function type + @f; use function f, not its result + @p.f; @ operator applies to f, not p + @f(); @ operator applies to result of f + f(); use f's result + FuncVar:=Func; if mode=objfpc: incompatible + if mode=delphi: implicit addr of function f, not yet implemented + if f=g then : can implicit resolve each side once, at the moment: always implicit + p(f), f as var parameter: always implicit, thus incompatible } unit PasResolver; @@ -429,11 +447,11 @@ type procedure SetElement(AValue: TPasElement); public Owner: TObject; // e.g. a TPasResolver - Next: TResolveData; - CustomData: TObject; + Next: TResolveData; // TPasResolver uses this for its memory chain + CustomData: TObject; // not used by TPasResolver, free for your extension constructor Create; virtual; destructor Destroy; override; - property Element: TPasElement read FElement write SetElement; + property Element: TPasElement read FElement write SetElement;// Element.CustomData=Self end; TResolveDataClass = class of TResolveData; @@ -621,6 +639,7 @@ type NeedTmpVar: boolean; Expr: TPasExpr; Scope: TPasScope; + OnlyTypeMembers: boolean; class function IsStoredInElement: boolean; override; class function FreeOnPop: boolean; override; procedure IterateElements(const aName: string; StartScope: TPasScope; @@ -709,12 +728,19 @@ type end; TResolvedReferenceFlag = ( - rrfCallWithoutParams, // a TPrimitiveExpr is a call without params - rrfNewInstance, // constructor call (without it call a constructor as normal method) + rrfDotScope, // found reference via a dot scope (TPasDotIdentifierScope) + rrfImplicitCallWithoutParams, // a TPrimitiveExpr is an implicit call without params + rrfNewInstance, // constructor call (without it call constructor as normal method) + rrfFreeInstance, // destructor call (without it call destructor as normal method) rrfVMT // use VMT for call ); TResolvedReferenceFlags = set of TResolvedReferenceFlag; + { TResolvedRefContext } + + TResolvedRefContext = Class + end; + { TResolvedReference - CustomData for normal references } TResolvedReference = Class(TResolveData) @@ -722,12 +748,20 @@ type FDeclaration: TPasElement; procedure SetDeclaration(AValue: TPasElement); public - WithExprScope: TPasWithExprScope; Flags: TResolvedReferenceFlags; + Context: TResolvedRefContext; + WithExprScope: TPasWithExprScope;// if set, this reference used a With-block expression. destructor Destroy; override; property Declaration: TPasElement read FDeclaration write SetDeclaration; end; + { TResolvedRefCtxConstructor } + + TResolvedRefCtxConstructor = Class(TResolvedRefContext) + public + Typ: TPasType; // e.g. TPasClassType + end; + TPasResolverResultFlag = ( rrfReadable, rrfWritable @@ -782,10 +816,13 @@ type GetCallResult: TOnGetCallResult; end; + { TPRFindData } + TPRFindData = record ErrorPosEl: TPasElement; Found: TPasElement; - ElScope, StartScope: TPasScope; + ElScope: TPasScope; // Where Found was found + StartScope: TPasScope; // where the searched started end; PPRFindData = ^TPRFindData; @@ -931,6 +968,7 @@ type procedure ConvertRangeToFirstValue(var ResolvedEl: TPasResolverResult); function IsCharLiteral(const Value: string): boolean; virtual; protected + // built-in functions function OnGetCallCompatibility_Length(Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; procedure OnGetCallResult_Length(Proc: TResElDataBuiltInProc; @@ -1051,6 +1089,8 @@ type function CheckProcArgCompatibility(Arg1, Arg2: TPasArgument): boolean; function CheckCanBeLHS(const ResolvedEl: TPasResolverResult; ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean; + function CheckAssignCompatibility(const LHS, RHS: TPasElement; + RaiseOnIncompatible: boolean = true): integer; function CheckAssignCompatibility(const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer; function CheckEqualCompatibility(const LHS, RHS: TPasResolverResult; @@ -1065,6 +1105,8 @@ type function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType; function ResolveAliasType(aType: TPasType): TPasType; function ExprIsAddrTarget(El: TPasExpr): boolean; + function GetLastExprIdentifier(El: TPasExpr): TPasExpr; + function GetReference_NewInstanceClass(Ref: TResolvedReference): TPasClassType; public property BaseType[bt: TResolverBaseType]: TPasUnresolvedSymbolRef read GetBaseType; property BaseTypeStringIndex: TResolverBaseType read FBaseTypeStringIndex write FBaseTypeStringIndex; @@ -1662,6 +1704,7 @@ end; destructor TResolvedReference.Destroy; begin Declaration:=nil; + FreeAndNil(Context); inherited Destroy; end; @@ -2591,16 +2634,10 @@ begin end; procedure TPasResolver.FinishConstDef(El: TPasConst); -var - TypeResolved, ExprResolved: TPasResolverResult; begin ResolveExpr(El.Expr); if El.VarType<>nil then - begin - ComputeElement(El,TypeResolved,[]); - ComputeElement(El.Expr,ExprResolved,[rcReturnFuncResult]); - CheckAssignCompatibility(TypeResolved,ExprResolved,El.Expr,true) - end; + CheckAssignCompatibility(El,El.Expr,true); end; procedure TPasResolver.FinishProcedure; @@ -2779,6 +2816,7 @@ begin Proc.ProcType.IsOfObject:=true; ProcScope:=TopScope as TPasProcedureScope; ClassScope:=Scopes[ScopeCount-2] as TPasClassScope; + ProcScope.ClassScope:=ClassScope; FindData:=Default(TFindOverloadProcData); FindData.Proc:=Proc; FindData.Args:=Proc.ProcType.Args; @@ -2971,15 +3009,9 @@ begin end; procedure TPasResolver.FinishVariable(El: TPasVariable); -var - TypeResolved, ExprResolved: TPasResolverResult; begin if El.Expr<>nil then - begin - ComputeElement(El,TypeResolved,[]); - ComputeElement(El.Expr,ExprResolved,[rcReturnFuncResult]); - CheckAssignCompatibility(TypeResolved,ExprResolved,El.Expr,true); - end; + CheckAssignCompatibility(El,El.Expr,true); end; procedure TPasResolver.FinishPropertyOfClass(PropEl: TPasProperty); @@ -3288,15 +3320,9 @@ begin end; procedure TPasResolver.FinishArgument(El: TPasArgument); -var - TypeResolved, ExprResolved: TPasResolverResult; begin if (El.ArgType<>nil) and (El.ValueExpr<>nil) then - begin - ComputeElement(El,TypeResolved,[]); - ComputeElement(El.ValueExpr,ExprResolved,[rcReturnFuncResult]); - CheckAssignCompatibility(TypeResolved,ExprResolved,El.ValueExpr,true); - end; + CheckAssignCompatibility(El,El.ValueExpr,true); end; procedure TPasResolver.FinishAncestors(aClass: TPasClassType); @@ -3536,6 +3562,8 @@ var WithScope: TPasWithScope; WithExprScope: TPasWithExprScope; ExprScope: TPasScope; + OnlyTypeMembers: Boolean; + ClassEl: TPasClassType; begin OldScopeCount:=ScopeCount; WithScope:=TPasWithScope(CreateScope(El,TPasWithScope)); @@ -3555,10 +3583,28 @@ begin RaiseMsg(nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, [BaseTypeNames[ExprResolved.BaseType]],ErrorEl); + OnlyTypeMembers:=false; if TypeEl.ClassType=TPasRecordType then - ExprScope:=TPasRecordType(TypeEl).CustomData as TPasRecordScope + begin + ExprScope:=TPasRecordType(TypeEl).CustomData as TPasRecordScope; + if ExprResolved.IdentEl is TPasType then + // e.g. with TPoint do PointInCircle + OnlyTypeMembers:=true; + end else if TypeEl.ClassType=TPasClassType then - ExprScope:=TPasClassType(TypeEl).CustomData as TPasClassScope + begin + ExprScope:=TPasClassType(TypeEl).CustomData as TPasClassScope; + if ExprResolved.IdentEl is TPasType then + // e.g. with TFPMemoryImage do FindHandlerFromExtension() + OnlyTypeMembers:=true; + end + else if TypeEl.ClassType=TPasClassOfType then + begin + // e.g. with ImageClass do FindHandlerFromExtension() + ClassEl:=ResolveAliasType(TPasClassOfType(TypeEl).DestType) as TPasClassType; + ExprScope:=ClassEl.CustomData as TPasClassScope; + OnlyTypeMembers:=true; + end else RaiseMsg(nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, [TypeEl.ElementTypeName],ErrorEl); @@ -3568,6 +3614,7 @@ begin WithExprScope.Expr:=Expr; WithExprScope.Scope:=ExprScope; WithExprScope.NeedTmpVar:=not (ExprResolved.IdentEl is TPasType); + WithExprScope.OnlyTypeMembers:=OnlyTypeMembers; WithScope.ExpressionScopes.Add(WithExprScope); PushScope(WithExprScope); end; @@ -3582,6 +3629,7 @@ end; procedure TPasResolver.ResolveImplAssign(El: TPasImplAssign); var LeftResolved, RightResolved: TPasResolverResult; + Flags: TPasResolverComputeFlags; begin ResolveExpr(El.left); ResolveExpr(El.right); @@ -3592,13 +3640,11 @@ begin ComputeElement(El.left,LeftResolved,[rcSkipTypeAlias]); CheckCanBeLHS(LeftResolved,true,El.left); // compute RHS - ComputeElement(El.right,RightResolved,[rcSkipTypeAlias]); - - if RightResolved.BaseType=btProc then - begin - // ToDo: Delphi also uses left side to decide whether use function reference or function result - ComputeProcWithoutParams(RightResolved,El.right); - end; + Flags:=[rcSkipTypeAlias,rcReturnFuncResult]; + //writeln('TPasResolver.ResolveImplAssign Left=',GetResolverResultDesc(LeftResolved),' rcReturnFuncResult=',rcReturnFuncResult in Flags); + // ToDo: Delphi also uses left side to decide whether use function reference or function result + ComputeElement(El.right,RightResolved,Flags); + //writeln('TPasResolver.ResolveImplAssign Right=',GetResolverResultDesc(RightResolved)); case El.Kind of akDefault: @@ -3661,17 +3707,21 @@ procedure TPasResolver.ResolveImplRaise(El: TPasImplRaise); var ResolvedEl: TPasResolverResult; begin - ResolveExpr(El.ExceptObject); - ResolveExpr(El.ExceptAddr); - ComputeElement(El.ExceptObject,ResolvedEl,[rcSkipTypeAlias,rcReturnFuncResult]); - if (ResolvedEl.IdentEl=nil) then - RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, - ['variable',ResolvedEl.TypeEl.ElementTypeName],El.ExceptObject); - if (ResolvedEl.IdentEl.ClassType<>TPasVariable) - and (ResolvedEl.IdentEl.ClassType<>TPasArgument) then - RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, - ['variable',ResolvedEl.IdentEl.ElementTypeName],El.ExceptObject); - CheckIsClass(El.ExceptObject,ResolvedEl); + if El.ExceptObject<>nil then + begin + ResolveExpr(El.ExceptObject); + ComputeElement(El.ExceptObject,ResolvedEl,[rcSkipTypeAlias,rcReturnFuncResult]); + if (ResolvedEl.IdentEl=nil) then + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, + ['variable',ResolvedEl.TypeEl.ElementTypeName],El.ExceptObject); + if (ResolvedEl.IdentEl.ClassType<>TPasVariable) + and (ResolvedEl.IdentEl.ClassType<>TPasArgument) then + RaiseMsg(nXExpectedButYFound,sXExpectedButYFound, + ['variable',ResolvedEl.IdentEl.ElementTypeName],El.ExceptObject); + CheckIsClass(El.ExceptObject,ResolvedEl); + end; + if El.ExceptAddr<>nil then + ResolveExpr(El.ExceptAddr); end; procedure TPasResolver.ResolveExpr(El: TPasExpr); @@ -3730,6 +3780,8 @@ var BuiltInProc: TResElDataBuiltInProc; begin DeclEl:=FindElementWithoutParams(aName,FindData,El,false); + Ref:=CreateReference(DeclEl,El,@FindData); + CheckFoundElement(FindData,Ref); if DeclEl is TPasProcedure then begin // identifier is a proc and args brackets are missing @@ -3755,8 +3807,6 @@ begin BuiltInProc.GetCallCompatibility(BuiltInProc,El,true); end; end; - Ref:=CreateReference(DeclEl,El,@FindData); - CheckFoundElement(FindData,Ref); end; procedure TPasResolver.ResolveInherited(El: TInheritedExpr); @@ -3766,14 +3816,17 @@ var DeclProc, AncestorProc: TPasProcedure; begin {$IFDEF VerbosePasResolver} - writeln('TPasResolver.ResolveInheritedDefault El.Parent=',GetTreeDesc(El.Parent)); + writeln('TPasResolver.ResolveInherited El.Parent=',GetTreeDesc(El.Parent)); {$ENDIF} if (El.Parent.ClassType=TBinaryExpr) and (TBinaryExpr(El.Parent).OpCode=eopNone) then begin + // e.g. 'inherited Proc;' ResolveInheritedCall(TBinaryExpr(El.Parent)); exit; end; + + // 'inherited;' without expression CheckTopScope(TPasProcedureScope); ProcScope:=TPasProcedureScope(TopScope); if ProcScope.ClassScope=nil then @@ -3782,11 +3835,11 @@ begin AncestorScope:=ProcScope.ClassScope.AncestorScope; if AncestorScope=nil then begin - // 'inherited;' without ancestor is ignored + // 'inherited;' without ancestor class is silently ignored exit; end; - // search in ancestor + // search ancestor in element, i.e. 'inherited' expression DeclProc:=ProcScope.DeclarationProc; DeclProcScope:=DeclProc.CustomData as TPasProcedureScope; AncestorProc:=DeclProcScope.OverriddenProc; @@ -3799,7 +3852,7 @@ begin end else begin - // 'inherited;' without ancestor is ignored + // 'inherited;' without ancestor method is silently ignored exit; end; end; @@ -3942,6 +3995,7 @@ begin end else if LeftResolved.TypeEl=nil then begin + // illegal qualifier, see below end else if LeftResolved.TypeEl.ClassType=TPasClassType then begin @@ -4631,17 +4685,12 @@ begin exit; end; - ComputeElement(Bin.left,LeftResolved,Flags); - ComputeElement(Bin.right,RightResolved,Flags); + ComputeElement(Bin.left,LeftResolved,Flags+[rcReturnFuncResult]); + ComputeElement(Bin.right,RightResolved,Flags+[rcReturnFuncResult]); // ToDo: check operator overloading //writeln('TPasResolver.ComputeBinaryExpr ',OpcodeStrings[Bin.OpCode],' Left=',GetResolverResultDesc(LeftResolved),' Right=',GetResolverResultDesc(RightResolved)); - if LeftResolved.BaseType=btProc then - ComputeProcWithoutParams(LeftResolved,Bin.left); - if RightResolved.BaseType=btProc then - ComputeProcWithoutParams(RightResolved,Bin.right); - if Bin.OpCode in [eopEqual,eopNotEqual] then begin if CheckEqualCompatibility(LeftResolved,RightResolved,Bin,true)=cIncompatible then @@ -5112,10 +5161,12 @@ var Proc: TPasProcedure; aClass: TPasClassType; ResolvedTypeEl: TPasResolverResult; + Ref: TResolvedReference; begin if Params.Value.CustomData is TResolvedReference then begin - DeclEl:=TResolvedReference(Params.Value.CustomData).Declaration; + Ref:=TResolvedReference(Params.Value.CustomData); + DeclEl:=Ref.Declaration; if DeclEl.ClassType=TPasUnresolvedSymbolRef then begin if DeclEl.CustomData.ClassType=TResElDataBuiltInProc then @@ -5130,7 +5181,7 @@ begin end else if DeclEl.CustomData.ClassType=TResElDataBaseType then begin - // type case to base type + // type cast to base type SetResolverValueExpr(ResolvedEl, TResElDataBaseType(DeclEl.CustomData).BaseType, TPasUnresolvedSymbolRef(DeclEl),Params.Params[0],[rrfReadable]); @@ -5140,6 +5191,7 @@ begin end else begin + // normal identifier (not built-in) ComputeElement(DeclEl,ResolvedEl,Flags-[rcReturnFuncResult]); if ResolvedEl.BaseType=btProc then begin @@ -5151,10 +5203,11 @@ begin if Proc is TPasFunction then // function call => return result ComputeElement(TPasFunction(Proc).FuncType.ResultEl,ResolvedEl,Flags-[rcReturnFuncResult]) - else if Proc.ClassType=TPasConstructor then + else if (Proc.ClassType=TPasConstructor) + and (rrfNewInstance in Ref.Flags) then begin - // constructor call -> return value of type class - aClass:=Proc.Parent as TPasClassType; + // new instance call -> return value of type class + aClass:=GetReference_NewInstanceClass(Ref); SetResolverValueExpr(ResolvedEl,btContext,aClass,Params.Value,[rrfReadable]); end else @@ -5208,9 +5261,8 @@ procedure TPasResolver.ComputeProcWithoutParams( var aClass: TPasClassType; Proc: TPasProcedure; + Ref: TResolvedReference; begin - if ExprIsAddrTarget(Expr) then exit; - if ResolvedEl.IdentEl=nil then RaiseNotYetImplemented(20160928183455,Expr,GetResolverResultDesc(ResolvedEl)); if not (ResolvedEl.IdentEl is TPasProcedure) then @@ -5221,13 +5273,22 @@ begin RaiseMsg(nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo, [GetProcDesc(Proc.ProcType)],Expr); + Expr:=GetLastExprIdentifier(Expr); + if ExprIsAddrTarget(Expr) then exit; + + Ref:=nil; if Expr.CustomData is TResolvedReference then - Include(TResolvedReference(Expr.CustomData).Flags,rrfCallWithoutParams); + begin + Ref:=TResolvedReference(Expr.CustomData); + Include(Ref.Flags,rrfImplicitCallWithoutParams); + end; if (ResolvedEl.IdentEl is TPasFunction) then ComputeElement(TPasFunction(ResolvedEl.IdentEl).FuncType.ResultEl,ResolvedEl,[]) - else if ResolvedEl.IdentEl.ClassType=TPasConstructor then + else if (ResolvedEl.IdentEl.ClassType=TPasConstructor) + and (Ref<>nil) and (rrfNewInstance in Ref.Flags) then begin - aClass:=Proc.Parent as TPasClassType; + // new instance call -> return value of type class + aClass:=GetReference_NewInstanceClass(Ref); SetResolverValueExpr(ResolvedEl,btContext,aClass,Expr,[rrfReadable]); end else @@ -5998,6 +6059,8 @@ var Data: TPRFindData; begin Result:=FindElementWithoutParams(AName,Data,ErrorPosEl,NoProcsWithArgs); + if Data.Found=nil then exit; // forward type: class-of or ^ + CheckFoundElement(Data,nil); if (Data.StartScope<>nil) and (Data.StartScope.ClassType=TPasWithExprScope) and TPasWithExprScope(Data.StartScope).NeedTmpVar then RaiseInternalError(20160923111727); // caller forgot to handle "With", use the other FindElementWithoutParams instead @@ -6035,8 +6098,6 @@ begin // proc needs parameters RaiseMsg(nWrongNumberOfParametersForCallTo, sWrongNumberOfParametersForCallTo,[GetProcDesc(TPasProcedure(Result).ProcType)],ErrorPosEl); - - CheckFoundElement(Data,nil); end; procedure TPasResolver.IterateElements(const aName: string; @@ -6064,12 +6125,29 @@ var Proc: TPasProcedure; Context: TPasElement; FoundContext: TPasClassType; + StartScope: TPasScope; + OnlyTypeMembers: Boolean; + TypeEl: TPasType; begin - //writeln('TPasResolver.CheckFoundElOnStartScope StartScope=',FindData.StartScope.ClassName,' ',FindData.StartScope is TPasDotIdentifierScope,' ',(FindData.StartScope is TPasDotIdentifierScope) - // and TPasDotIdentifierScope(FindData.StartScope).OnlyTypeMembers, + StartScope:=FindData.StartScope; + OnlyTypeMembers:=false; + if (StartScope is TPasDotIdentifierScope) then + begin + OnlyTypeMembers:=TPasDotIdentifierScope(StartScope).OnlyTypeMembers; + Include(Ref.Flags,rrfDotScope); + end + else if StartScope.ClassType=TPasWithExprScope then + begin + OnlyTypeMembers:=TPasWithExprScope(StartScope).OnlyTypeMembers; + Include(Ref.Flags,rrfDotScope); + end; + + //writeln('TPasResolver.CheckFoundElOnStartScope StartScope=',StartScope.ClassName, + // ' ',StartScope is TPasDotIdentifierScope, + // ' ',(StartScope is TPasDotIdentifierScope) + // and TPasDotIdentifierScope(StartScope).OnlyTypeMembers, // ' FindData.Found=',GetObjName(FindData.Found)); - if (FindData.StartScope is TPasDotIdentifierScope) - and TPasDotIdentifierScope(FindData.StartScope).OnlyTypeMembers then + if OnlyTypeMembers then begin //writeln('TPasResolver.CheckFoundElOnStartScope ',GetObjName(FindData.Found),' ',(FindData.Found is TPasVariable) // and (vmClass in TPasVariable(FindData.Found).VarModifiers)); @@ -6096,8 +6174,8 @@ begin Proc:=TPasProcedure(FindData.Found); if Proc.IsVirtual or Proc.IsOverride then begin - if (FindData.StartScope.ClassType=TPasDotClassScope) - and TPasDotClassScope(FindData.StartScope).InheritedExpr then + if (StartScope.ClassType=TPasDotClassScope) + and TPasDotClassScope(StartScope).InheritedExpr then begin // call directly if Proc.IsAbstract then @@ -6106,16 +6184,69 @@ begin end else begin - // call via method table + // call via virtual method table if Ref<>nil then Ref.Flags:=Ref.Flags+[rrfVMT]; end; end; - if (FindData.Found.ClassType=TPasConstructor) - and (FindData.StartScope.ClassType=TPasDotClassScope) - and TPasDotClassScope(FindData.StartScope).OnlyTypeMembers + + // constructor: NewInstance or normal call + // it is a NewInstance iff the scope is a class, e.g. TObject.Create + if (Proc.ClassType=TPasConstructor) + and OnlyTypeMembers and (Ref<>nil) then + begin Ref.Flags:=Ref.Flags+[rrfNewInstance]; + // store the class in Ref.Context + if Ref.Context<>nil then + RaiseInternalError(20170131141936); + Ref.Context:=TResolvedRefCtxConstructor.Create; + if StartScope is TPasDotClassScope then + TypeEl:=TPasDotClassScope(StartScope).ClassScope.Element as TPasType + else if (StartScope is TPasWithExprScope) and (TPasWithExprScope(StartScope).Scope is TPasClassScope) then + TypeEl:=TPasClassScope(TPasWithExprScope(StartScope).Scope).Element as TPasType + else + RaiseInternalError(20170131150855,GetObjName(StartScope)); + TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl; + end; + {$IFDEF VerbosePasResolver} + if (Proc.ClassType=TPasConstructor) then + begin + write('TPasResolver.CheckFoundElement ',GetObjName(Proc)); + if Ref=nil then + write(' no ref!') + else + begin + write(' rrfNewInstance=',rrfNewInstance in Ref.Flags, + ' StartScope=',GetObjName(StartScope), + ' OnlyTypeMembers=',OnlyTypeMembers); + end; + writeln; + end; + {$ENDIF} + + // destructor: FreeInstance or normal call + // it is a normal call if 'inherited' + if (Proc.ClassType=TPasDestructor) and (Ref<>nil) then + if ((StartScope.ClassType<>TPasDotClassScope) + or (not TPasDotClassScope(StartScope).InheritedExpr)) then + Ref.Flags:=Ref.Flags+[rrfFreeInstance]; + {$IFDEF VerbosePasResolver} + if (Proc.ClassType=TPasDestructor) then + begin + write('TPasResolver.CheckFoundElement ',GetObjName(Proc)); + if Ref=nil then + write(' no ref!') + else + begin + write(' rrfFreeInstance=',rrfFreeInstance in Ref.Flags, + ' StartScope=',GetObjName(StartScope)); + if StartScope.ClassType=TPasDotClassScope then + write(' InheritedExpr=',TPasDotClassScope(StartScope).InheritedExpr); + end; + writeln; + end; + {$ENDIF} end; // check class visibility @@ -6886,6 +7017,16 @@ begin RaiseMsg(nVariableIdentifierExpected,sVariableIdentifierExpected,[],ErrorEl); end; +function TPasResolver.CheckAssignCompatibility(const LHS, RHS: TPasElement; + RaiseOnIncompatible: boolean): integer; +var + LeftResolved, RightResolved: TPasResolverResult; +begin + ComputeElement(LHS,LeftResolved,[]); + ComputeElement(RHS,RightResolved,[rcReturnFuncResult]); + Result:=CheckAssignCompatibility(LeftResolved,RightResolved,RHS,RaiseOnIncompatible); +end; + function TPasResolver.CheckAssignCompatibility(const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean ): integer; @@ -6894,7 +7035,7 @@ var begin // check if the RHS can be converted to LHS {$IFDEF VerbosePasResolver} - writeln('TPasResolver.CheckAssignCompatibility '); + writeln('TPasResolver.CheckAssignCompatibility START LHS='+GetResolverResultDesc(LHS)+' RHS='+GetResolverResultDesc(RHS)); {$ENDIF} if LHS.TypeEl=nil then begin @@ -6966,7 +7107,7 @@ begin end; end; {$IFDEF VerbosePasResolver} - writeln('TPasResolver.CheckAssignCompatibility LHS='+GetResolverResultDesc(LHS)+' RHS='+GetResolverResultDesc(RHS)); + writeln('TPasResolver.CheckAssignCompatibility incompatible LHS='+GetResolverResultDesc(LHS)+' RHS='+GetResolverResultDesc(RHS)); {$ENDIF} if not RaiseOnIncompatible then exit(cIncompatible); @@ -7194,8 +7335,6 @@ begin MustFitExactly:=Param.Access in [argVar, argOut]; ComputeElement(Expr,ExprResolved,ComputeFlags); - if ExprResolved.BaseType=btProc then - ComputeProcWithoutParams(ExprResolved,Expr); {$IFDEF VerbosePasResolver} writeln('TPasResolver.CheckParamCompatibility Expr=',GetTreeDesc(Expr,2),' ResolvedExpr=',GetResolverResultDesc(ExprResolved)); @@ -7213,7 +7352,9 @@ begin RaiseMsg(nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr); exit; end; - end; + end + else if ExprResolved.BaseType=btProc then + ComputeProcWithoutParams(ExprResolved,Expr); ComputeElement(Param,ParamResolved,ComputeFlags); {$IFDEF VerbosePasResolver} @@ -7269,7 +7410,7 @@ begin exit(cExact); {$IFDEF VerbosePasResolver} - //writeln('TPasResolver.CheckCustomTypeCompatibility SrcTypeEl=',GetObjName(RTypeEl),' DstTypeEl=',GetObjName(LTypeEl)); + writeln('TPasResolver.CheckCustomTypeCompatibility LTypeEl=',GetObjName(LTypeEl),' RTypeEl=',GetObjName(RTypeEl)); {$ENDIF} if LTypeEl.ClassType=TPasClassType then begin @@ -7591,6 +7732,8 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out var DeclEl: TPasElement; aClass: TPasClassType; + Ref: TResolvedReference; + Proc: TPasProcedure; begin ResolvedEl:=Default(TPasResolverResult); {$IFDEF VerbosePasResolver} @@ -7605,20 +7748,30 @@ begin begin if not (El.CustomData is TResolvedReference) then RaiseNotYetImplemented(20160922163658,El,'Value="'+TPrimitiveExpr(El).Value+'" CustomData='+GetObjName(El.CustomData)+' '+GetElementSourcePosStr(El)); - ComputeElement(TResolvedReference(El.CustomData).Declaration,ResolvedEl,Flags-[rcReturnFuncResult]); + Ref:=TResolvedReference(El.CustomData); + ComputeElement(Ref.Declaration,ResolvedEl,Flags-[rcReturnFuncResult]); + //writeln('TPasResolver.ComputeElement TPrimitiveExpr "',TPrimitiveExpr(El).Value,'" ',GetResolverResultDesc(ResolvedEl),' rcReturnFuncResult=',rcReturnFuncResult in Flags); if (ResolvedEl.BaseType=btProc) and (rcReturnFuncResult in Flags) then begin + // a proc and implicit call without params is allowed -> check if possible if rcConstant in Flags then RaiseConstantExprExp(El); - Include(TResolvedReference(El.CustomData).Flags,rrfCallWithoutParams); - if ResolvedEl.IdentEl is TPasFunction then - // function => return result - ComputeElement(TPasFunction(ResolvedEl.IdentEl).FuncType.ResultEl,ResolvedEl,Flags-[rcReturnFuncResult]) - else if ResolvedEl.IdentEl.ClassType=TPasConstructor then + Proc:=ResolvedEl.IdentEl as TPasProcedure; + if (Proc.ProcType.Args.Count=0) + or (TPasArgument(Proc.ProcType.Args[0]).ValueExpr<>nil) then begin - // constructor -> return value of type class - aClass:=ResolvedEl.IdentEl.Parent as TPasClassType; - SetResolverValueExpr(ResolvedEl,btContext,aClass,TPrimitiveExpr(El),[rrfReadable]); + // parameter less proc -> implicit call + Include(Ref.Flags,rrfImplicitCallWithoutParams); + if ResolvedEl.IdentEl is TPasFunction then + // function => return result + ComputeElement(TPasFunction(ResolvedEl.IdentEl).FuncType.ResultEl,ResolvedEl,Flags-[rcReturnFuncResult]) + else if (ResolvedEl.IdentEl.ClassType=TPasConstructor) + and (rrfNewInstance in Ref.Flags) then + begin + // new instance constructor -> return value of type class + aClass:=GetReference_NewInstanceClass(Ref); + SetResolverValueExpr(ResolvedEl,btContext,aClass,TPrimitiveExpr(El),[rrfReadable]); + end; end; end; end; @@ -7657,8 +7810,72 @@ begin else RaiseNotYetImplemented(20160926194756,El); end + else if El.ClassType=TSelfExpr then + begin + if rcConstant in Flags then + RaiseConstantExprExp(El); + ComputeElement(TResolvedReference(El.CustomData).Declaration,ResolvedEl,Flags); + end + else if El.ClassType=TBoolConstExpr then + SetResolverValueExpr(ResolvedEl,btBoolean,FBaseTypes[btBoolean],TBoolConstExpr(El),[rrfReadable]) else if El.ClassType=TBinaryExpr then ComputeBinaryExpr(TBinaryExpr(El),ResolvedEl,Flags) + else if El.ClassType=TUnaryExpr then + begin + if TUnaryExpr(El).OpCode=eopAddress then + ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags-[rcReturnFuncResult]) + else + ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags); + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.ComputeElement Unary Kind=',TUnaryExpr(El).Kind,' OpCode=',TUnaryExpr(El).OpCode,' OperandResolved=',GetResolverResultDesc(ResolvedEl),' ',GetElementSourcePosStr(El)); + {$ENDIF} + case TUnaryExpr(El).OpCode of + eopAdd, eopSubtract: + if ResolvedEl.BaseType in (btAllInteger+btAllFloats) then + exit + else + RaiseMsg(nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); + eopNot: + if ResolvedEl.BaseType in (btAllInteger+btAllBooleans) then + exit + else + RaiseMsg(nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); + eopAddress: + if (ResolvedEl.BaseType=btProc) and (ResolvedEl.IdentEl is TPasProcedure) then + begin + SetResolverValueExpr(ResolvedEl,btContext,ResolvedEl.TypeEl,TUnaryExpr(El).Operand,[rrfReadable]); + exit; + end + else + RaiseMsg(nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); + end; + RaiseNotYetImplemented(20160926142426,El); + end + else if El.ClassType=TParamsExpr then + case TParamsExpr(El).Kind of + pekArrayParams: + ComputeArrayParams(TParamsExpr(El),ResolvedEl,Flags); + pekFuncParams: + ComputeFuncParams(TParamsExpr(El),ResolvedEl,Flags); + pekSet: + ComputeSetParams(TParamsExpr(El),ResolvedEl,Flags); + else + RaiseNotYetImplemented(20161010184559,El); + end + else if El.ClassType=TInheritedExpr then + begin + // writeln('TPasResolver.ComputeElement TInheritedExpr El.CustomData=',GetObjName(El.CustomData)); + if El.CustomData is TResolvedReference then + begin + // "inherited;" + DeclEl:=TResolvedReference(El.CustomData).Declaration as TPasProcedure; + SetResolverIdentifier(ResolvedEl,btProc,DeclEl, + TPasProcedure(DeclEl).ProcType,[]); + end + else + // no ancestor proc + SetResolverIdentifier(ResolvedEl,btBuiltInProc,nil,nil,[]); + end else if El.ClassType=TPasAliasType then begin // e.g. 'type a = b' -> compute b @@ -7767,37 +7984,6 @@ begin ResolvedEl.IdentEl:=El; ResolvedEl.Flags:=[]; end - else if El.ClassType=TUnaryExpr then - begin - if TUnaryExpr(El).OpCode=eopAddress then - ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags-[rcReturnFuncResult]) - else - ComputeElement(TUnaryExpr(El).Operand,ResolvedEl,Flags); - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.ComputeElement Unary Kind=',TUnaryExpr(El).Kind,' OpCode=',TUnaryExpr(El).OpCode,' OperandResolved=',GetResolverResultDesc(ResolvedEl),' ',GetElementSourcePosStr(El)); - {$ENDIF} - case TUnaryExpr(El).OpCode of - eopAdd, eopSubtract: - if ResolvedEl.BaseType in (btAllInteger+btAllFloats) then - exit - else - RaiseMsg(nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); - eopNot: - if ResolvedEl.BaseType in (btAllInteger+btAllBooleans) then - exit - else - RaiseMsg(nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); - eopAddress: - if (ResolvedEl.BaseType=btProc) and (ResolvedEl.IdentEl is TPasProcedure) then - begin - SetResolverValueExpr(ResolvedEl,btContext,ResolvedEl.TypeEl,TUnaryExpr(El).Operand,[rrfReadable]); - exit; - end - else - RaiseMsg(nIllegalQualifier,sIllegalQualifier,[OpcodeStrings[TUnaryExpr(El).OpCode]],El); - end; - RaiseNotYetImplemented(20160926142426,El); - end else if El.ClassType=TPasResultElement then begin if rcConstant in Flags then @@ -7810,47 +7996,17 @@ begin SetResolverIdentifier(ResolvedEl,btModule,El,nil,[]) else if El.ClassType=TNilExpr then SetResolverValueExpr(ResolvedEl,btNil,FBaseTypes[btNil],TNilExpr(El),[rrfReadable]) - else if El.ClassType=TSelfExpr then - begin - if rcConstant in Flags then - RaiseConstantExprExp(El); - ComputeElement(TResolvedReference(El.CustomData).Declaration,ResolvedEl,Flags); - end - else if El.ClassType=TBoolConstExpr then - SetResolverValueExpr(ResolvedEl,btBoolean,FBaseTypes[btBoolean],TBoolConstExpr(El),[rrfReadable]) - else if El.ClassType=TParamsExpr then - case TParamsExpr(El).Kind of - pekArrayParams: - ComputeArrayParams(TParamsExpr(El),ResolvedEl,Flags); - pekFuncParams: - ComputeFuncParams(TParamsExpr(El),ResolvedEl,Flags); - pekSet: - ComputeSetParams(TParamsExpr(El),ResolvedEl,Flags); - else - RaiseNotYetImplemented(20161010184559,El); - end else if El is TPasProcedure then begin SetResolverIdentifier(ResolvedEl,btProc,El,TPasProcedure(El).ProcType,[]); if El is TPasFunction then Include(ResolvedEl.Flags,rrfReadable); + // Note: the readability of TPasConstructor depends on the context end else if El is TPasProcedureType then SetResolverIdentifier(ResolvedEl,btContext,El,TPasProcedureType(El),[]) else if El.ClassType=TPasArrayType then SetResolverIdentifier(ResolvedEl,btContext,El,TPasArrayType(El),[]) - else if El.ClassType=TInheritedExpr then - begin - if El.CustomData is TResolvedReference then - begin - DeclEl:=TResolvedReference(El.CustomData).Declaration as TPasProcedure; - SetResolverIdentifier(ResolvedEl,btProc,DeclEl, - TPasProcedure(DeclEl).ProcType,[]); - end - else - // no ancestor proc - SetResolverIdentifier(ResolvedEl,btBuiltInProc,nil,nil,[]); - end else RaiseNotYetImplemented(20160922163705,El); end; @@ -7896,18 +8052,19 @@ begin end; function TPasResolver.ExprIsAddrTarget(El: TPasExpr): boolean; -// returns true if El is the last element of an @ operator expression -// e.g. the OnClick in '@p().o[].OnClick' -// or '@s[]' +{ returns true if El is + a) the last element of an @ operator expression + e.g. '@p().o[].El' or '@El[]' + b) an accessor function, e.g. property P read El; +} var Parent: TPasElement; + Prop: TPasProperty; begin Result:=false; if El=nil then exit; - if (El.ClassType=TParamsExpr) or (El.ClassType=TPrimitiveExpr) - or (El.ClassType=TSelfExpr) then - // these are possible endings of a @ expression - else + if not ((El.ClassType=TParamsExpr) or (El.ClassType=TPrimitiveExpr) + or (El.ClassType=TSelfExpr)) then exit; repeat Parent:=El.Parent; @@ -7924,12 +8081,36 @@ begin begin if TParamsExpr(Parent).Value<>El then exit; end - else + else if Parent.ClassType=TPasProperty then + begin + Prop:=TPasProperty(Parent); + Result:=(Prop.ReadAccessor=El) or (Prop.WriteAccessor=El) or (Prop.StoredAccessor=El); + exit; + end + else exit; El:=TPasExpr(Parent); until false; end; +function TPasResolver.GetLastExprIdentifier(El: TPasExpr): TPasExpr; +begin + Result:=El; + while Result<>nil do + begin + if Result is TParamsExpr then + Result:=TParamsExpr(Result).Value + else if Result is TBinaryExpr then + Result:=TBinaryExpr(Result).right; + end; +end; + +function TPasResolver.GetReference_NewInstanceClass(Ref: TResolvedReference + ): TPasClassType; +begin + Result:=(Ref.Context as TResolvedRefCtxConstructor).Typ as TPasClassType; +end; + function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType, ResolvedDestType: TPasResolverResult; ErrorEl: TPasElement): integer; // finds distance between classes SrcType and DestType diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 530ab3d328..100caaaeb8 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -283,6 +283,9 @@ type Element: TPasExpr; AOpCode: TExprOpCode); procedure AddParamsToBinaryExprChain(var ChainFirst, ChainLast: TPasExpr; Params: TParamsExpr); + {$IFDEF VerbosePasParser} + procedure WriteBinaryExprChain(Prefix: string; First, Last: TPasExpr); + {$ENDIF} function CreateUnaryExpr(AParent : TPasElement; AOperand: TPasExpr; AOpCode: TExprOpCode): TUnaryExpr; function CreateArrayValues(AParent : TPasElement): TArrayValues; function CreateFunctionType(const AName, AResultName: String; AParent: TPasElement; @@ -2701,7 +2704,12 @@ begin NextToken; if CurToken = tkColon then begin - Result.VarType := ParseType(Result,Scanner.CurSourcePos); + Scanner.ForceCaret:=True; + try + Result.VarType := ParseType(Result,Scanner.CurSourcePos); + finally + Scanner.ForceCaret:=False; + end; { if Result.VarType is TPasRangeType then Ungettoken; // Range type stops on token after last range token} end @@ -2870,7 +2878,12 @@ begin TypeName := CurTokenString; NamePos:=Scanner.CurSourcePos; ExpectToken(tkEqual); - Result:=ParseType(Parent,NamePos,TypeName,True); + Scanner.ForceCaret:=True; + try + Result:=ParseType(Parent,NamePos,TypeName,True); + finally + Scanner.ForceCaret:=False; + end; end; function TPasParser.GetVariableValueAndLocation(Parent: TPasElement; out @@ -2994,9 +3007,13 @@ begin if CurToken=tkComma then ExpectIdentifier; Until (CurToken=tkColon); - + Scanner.ForceCaret:=False; + try + VarType := ParseComplexType(VarEl); + finally + Scanner.ForceCaret:=False; + end; // read type - VarType := ParseComplexType(VarEl); for i := OldListCount to VarList.Count - 1 do begin VarEl:=TPasVariable(VarList[i]); @@ -3254,16 +3271,10 @@ function TPasParser.CheckProcedureArgs(Parent: TPasElement; Args: TFPList; begin NextToken; - Result:=(Curtoken=tkbraceOpen); - if not Result then - begin - if Mandatory then - ParseExc(nParserExpectedLBracketColon,SParserExpectedLBracketColon) - else - UngetToken; - end - else + case CurToken of + tkBraceOpen: begin + Result:=true; NextToken; if (CurToken<>tkBraceClose) then begin @@ -3271,6 +3282,17 @@ begin ParseArgList(Parent, Args, tkBraceClose); end; end; + tkSemicolon,tkColon,tkof,tkis,tkIdentifier: + begin + Result:=false; + if Mandatory then + ParseExc(nParserExpectedLBracketColon,SParserExpectedLBracketColon) + else + UngetToken; + end + else + ParseExcTokenError(';'); + end; end; procedure TPasParser.HandleProcedureModifier(Parent: TPasElement; pm: TProcedureModifier); @@ -5039,7 +5061,7 @@ begin // chain not yet full => inconsistency RaiseInternal; Last.right:=CreateBinaryExpr(Last,Last.right,Element,AOpCode); - ChainLast:=Last; + ChainLast:=Last.right; end else begin @@ -5085,6 +5107,68 @@ begin end; end; +{$IFDEF VerbosePasParser} +procedure TPasParser.WriteBinaryExprChain(Prefix: string; First, Last: TPasExpr + ); +var + i: Integer; +begin + if First=nil then + begin + write(Prefix,'First=nil'); + if Last=nil then + writeln('=Last') + else + begin + writeln(', ERROR Last=',Last.ClassName); + ParseExcSyntaxError; + end; + end + else if Last=nil then + begin + writeln(Prefix,'ERROR Last=nil First=',First.ClassName); + ParseExcSyntaxError; + end + else if First is TBinaryExpr then + begin + i:=0; + while First is TBinaryExpr do + begin + writeln(Prefix,Space(i*2),'bin.left=',TBinaryExpr(First).left.ClassName); + if First=Last then break; + First:=TBinaryExpr(First).right; + inc(i); + end; + if First<>Last then + begin + writeln(Prefix,Space(i*2),'ERROR Last is not last in chain'); + ParseExcSyntaxError; + end; + if not (Last is TBinaryExpr) then + begin + writeln(Prefix,Space(i*2),'ERROR Last is not TBinaryExpr: ',Last.ClassName); + ParseExcSyntaxError; + end; + if TBinaryExpr(Last).right=nil then + begin + writeln(Prefix,Space(i*2),'ERROR Last.right=nil'); + ParseExcSyntaxError; + end; + writeln(Prefix,Space(i*2),'last.right=',TBinaryExpr(Last).right.ClassName); + end + else if First=Last then + writeln(Prefix,'First=Last=',First.ClassName) + else + begin + write(Prefix,'ERROR First=',First.ClassName); + if Last<>nil then + writeln(' Last=',Last.ClassName) + else + writeln(' Last=nil'); + end; +end; +{$ENDIF} + function TPasParser.CreateUnaryExpr(AParent: TPasElement; AOperand: TPasExpr; AOpCode: TExprOpCode): TUnaryExpr; begin diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index 5da2272f98..18f77f004a 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -403,6 +403,7 @@ type TPascalScanner = class private FCurrentModeSwitches: TModeSwitches; + FForceCaret: Boolean; FLastMsg: string; FLastMsgArgs: TMessageArgs; FLastMsgNumber: integer; @@ -420,6 +421,7 @@ type FOptions: TPOptions; FLogEvents: TPScannerLogEvents; FOnLog: TPScannerLogHandler; + FPreviousToken: TToken; FSkipComments: Boolean; FSkipWhiteSpace: Boolean; TokenStr: PChar; @@ -484,6 +486,7 @@ type property CurToken: TToken read FCurToken; property CurTokenString: string read FCurTokenString; + Property PreviousToken : TToken Read FPreviousToken; property Defines: TStrings read FDefines; property Macros: TStrings read FMacros; @@ -497,6 +500,7 @@ type property LastMsgPattern: string read FLastMsgPattern write FLastMsgPattern; property LastMsgArgs: TMessageArgs read FLastMsgArgs write FLastMsgArgs; Property CurrentModeSwitches : TModeSwitches Read FCurrentModeSwitches Write FCurrentModeSwitches; + Property ForceCaret : Boolean Read FForceCaret Write FForceCaret; end; const @@ -1262,6 +1266,7 @@ function TPascalScanner.FetchToken: TToken; var IncludeStackItem: TIncludeStackItem; begin + FPreviousToken:=FCurToken; while true do begin Result := DoFetchToken; @@ -1403,9 +1408,14 @@ begin OldLength:=0; FCurTokenString := ''; - while TokenStr[0] in ['#', ''''] do + while TokenStr[0] in ['^','#', ''''] do begin case TokenStr[0] of + '^' : + begin + TokenStart := TokenStr; + Inc(TokenStr); + end; '#': begin TokenStart := TokenStr; @@ -2173,8 +2183,14 @@ begin end; '^': begin + if ForceCaret or + (PreviousToken in [tkIdentifier,tkNil,tkOperator,tkBraceClose,tkSquaredBraceClose,tkCARET]) then + begin Inc(TokenStr); Result := tkCaret; + end + else + Result:=DoFetchTextToken; end; '\': begin diff --git a/packages/fcl-passrc/tests/tcclasstype.pas b/packages/fcl-passrc/tests/tcclasstype.pas index b4f332eedf..5d94233b0f 100644 --- a/packages/fcl-passrc/tests/tcclasstype.pas +++ b/packages/fcl-passrc/tests/tcclasstype.pas @@ -37,6 +37,7 @@ type Procedure EndClass(AEnd : String = 'end'); Procedure AddMember(S : String); Procedure ParseClass; + Procedure ParseClassFail(Msg: string; MsgNumber: integer); Procedure DoParseClass(FromSpecial : Boolean = False); procedure SetUp; override; procedure TearDown; override; @@ -92,6 +93,7 @@ type procedure TestHintFieldUninmplemented; Procedure TestMethodSimple; Procedure TestMethodSimpleComment; + Procedure TestMethodWithDotFails; Procedure TestClassMethodSimple; Procedure TestClassMethodSimpleComment; Procedure TestConstructor; @@ -329,6 +331,23 @@ begin DoParseClass(False); end; +procedure TTestClassType.ParseClassFail(Msg: string; MsgNumber: integer); +var + ok: Boolean; +begin + ok:=false; + try + ParseClass; + except + on E: EParserError do + begin + AssertEquals('Expected {'+Msg+'}, but got msg {'+Parser.LastMsg+'}',MsgNumber,Parser.LastMsgNumber); + ok:=true; + end; + end; + AssertEquals('Missing parser error {'+Msg+'} ('+IntToStr(MsgNumber)+')',true,ok); +end; + procedure TTestClassType.DoParseClass(FromSpecial: Boolean); begin EndClass; @@ -363,7 +382,6 @@ begin AssertNull('No helperfortype if not helper',TheClass.HelperForType); if TheClass.Members.Count>0 then FMember1:=TObject(TheClass.Members[0]) as TPaselement; - end; procedure TTestClassType.SetUp; @@ -409,6 +427,7 @@ procedure TTestClassType.AssertProperty(P: TPasProperty; AVisibility: TPasMemberVisibility; AName, ARead, AWrite, AStored, AImplements: String; AArgCount: Integer; ADefault, ANodefault: Boolean); begin + AssertEquals('Property Name',AName,P.Name); AssertEquals(P.Name+': Visibility',AVisibility,P.Visibility); Assertequals(P.Name+': No args',AArgCount,P.Args.Count); Assertequals(P.Name+': Read accessor',ARead,P.ReadAccessorName); @@ -768,6 +787,12 @@ begin AssertEquals('Comment','c'+sLineBreak,Method1.DocComment); end; +procedure TTestClassType.TestMethodWithDotFails; +begin + AddMember('Procedure DoSomething.Stupid'); + ParseClassFail('Expected ";"',nParserExpectTokenError); +end; + procedure TTestClassType.TestClassMethodSimple; begin AddMember('Class Procedure DoSomething'); diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 77a61de9ec..ecbc180e0e 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -21,7 +21,29 @@ uses Classes, SysUtils, fpcunit, PasTree, PScanner, PParser, PasResolver, tcbaseparser, testregistry, contnrs; -Type +type + TSrcMarkerKind = ( + mkLabel, + mkResolverReference, + mkDirectReference + ); + PSrcMarker = ^TSrcMarker; + TSrcMarker = record + Kind: TSrcMarkerKind; + Filename: string; + Row: integer; + StartCol, EndCol: integer; // token start, end column + Identifier: string; + Next: PSrcMarker; + end; + +const + SrcMarker: array[TSrcMarkerKind] of char = ( + '#', // mkLabel + '@', // mkResolverReference + '=' // mkDirectReference + ); +type TOnFindUnit = function(const aUnitName: String): TPasModule of object; { TTestEnginePasResolver } @@ -51,7 +73,7 @@ Type TTestResolverReferenceData = record Filename: string; - Line: integer; + Row: integer; StartCol: integer; EndCol: integer; Found: TFPList; // list of TPasElement at this token @@ -75,7 +97,9 @@ Type function OnPasResolverFindUnit(const aUnitName: String): TPasModule; procedure OnFindReference(El: TPasElement; FindData: pointer); procedure OnCheckElementParent(El: TPasElement; arg: pointer); + procedure FreeSrcMarkers; Protected + FirstSrcMarker, LastSrcMarker: PSrcMarker; Procedure SetUp; override; Procedure TearDown; override; procedure CreateEngine(var TheEngine: TPasTreeContainer); override; @@ -84,6 +108,14 @@ Type procedure CheckReferenceDirectives; procedure CheckResolverException(Msg: string; MsgNumber: integer); procedure CheckParserException(Msg: string; MsgNumber: integer); + procedure GetSrc(Index: integer; out SrcLines: TStringList; out aFilename: string); + function FindElementsAt(aFilename: string; aLine, aStartCol, aEndCol: integer): TFPList;// list of TPasElement + function FindElementsAt(aMarker: PSrcMarker; ErrorOnNoElements: boolean = true): TFPList;// list of TPasElement + function FindSrcLabel(const Identifier: string): PSrcMarker; + function FindElementsAtSrcLabel(const Identifier: string; ErrorOnNoElements: boolean = true): TFPList;// list of TPasElement + procedure WriteSources(const aFilename: string; aRow, aCol: integer); + procedure RaiseErrorAtSrc(Msg: string; const aFilename: string; aRow, aCol: integer); + procedure RaiseErrorAtSrcMarker(Msg: string; aMarker: PSrcMarker); Public function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver; function AddModule(aFilename: string): TTestEnginePasResolver; @@ -208,19 +240,19 @@ Type Procedure TestClassTripleInheritance; Procedure TestClassForward; Procedure TestClassForwardNotResolved; - Procedure TestClassMethod; - Procedure TestClassMethodUnresolved; - Procedure TestClassMethodAbstract; - Procedure TestClassMethodAbstractWithoutVirtual; - Procedure TestClassMethodAbstractHasBody; - Procedure TestClassMethodUnresolvedWithAncestor; - Procedure TestClassProcFuncMismatch; - Procedure TestClassMethodOverload; - Procedure TestClassMethodInvalidOverload; - Procedure TestClassOverride; - Procedure TestClassOverride2; - Procedure TestClassMethodScope; - Procedure TestClassIdentifierSelf; + Procedure TestClass_Method; + Procedure TestClass_MethodUnresolved; + Procedure TestClass_MethodAbstract; + Procedure TestClass_MethodAbstractWithoutVirtualFail; + Procedure TestClass_MethodAbstractHasBodyFail; + Procedure TestClass_MethodUnresolvedWithAncestor; + Procedure TestClass_ProcFuncMismatch; + Procedure TestClass_MethodOverload; + Procedure TestClass_MethodInvalidOverload; + Procedure TestClass_MethodOverride; + Procedure TestClass_MethodOverride2; + Procedure TestClass_MethodScope; + Procedure TestClass_IdentifierSelf; Procedure TestClassCallInherited; Procedure TestClassCallInheritedNoParamsAbstractFail; Procedure TestClassCallInheritedWithParamsAbstractFail; @@ -228,11 +260,11 @@ Type Procedure TestClassAssignNil; Procedure TestClassAssign; Procedure TestClassNilAsParam; - Procedure TestClassOperator_Is_As; - Procedure TestClassOperatorIsOnNonDescendantFail; - Procedure TestClassOperatorIsOnNonTypeFail; - Procedure TestClassOperatorAsOnNonDescendantFail; - Procedure TestClassOperatorAsOnNonTypeFail; + Procedure TestClass_Operators_Is_As; + Procedure TestClass_OperatorIsOnNonDescendantFail; + Procedure TestClass_OperatorIsOnNonTypeFail; + Procedure TestClass_OperatorAsOnNonDescendantFail; + Procedure TestClass_OperatorAsOnNonTypeFail; Procedure TestClassAsFuncResult; Procedure TestClassTypeCast; Procedure TestClassTypeCastUnrelatedFail; @@ -247,6 +279,12 @@ Type Procedure TestClass_ProtectedInDescendant; Procedure TestClass_StrictPrivateInMainBeginFail; Procedure TestClass_StrictProtectedInMainBeginFail; + Procedure TestClass_Constructor_NewInstance; + Procedure TestClass_Constructor_InstanceCallResultFail; + Procedure TestClass_Destructor_FreeInstance; + Procedure TestClass_ConDestructor_CallInherited; + Procedure TestClass_Constructor_Inherited; + Procedure TestClass_SubObject; // class of Procedure TestClassOf; @@ -377,6 +415,8 @@ end; procedure TTestResolver.SetUp; begin + FirstSrcMarker:=nil; + LastSrcMarker:=nil; FModules:=TObjectList.Create(true); inherited SetUp; Parser.Options:=Parser.Options+[po_resolvestandardtypes]; @@ -384,6 +424,7 @@ end; procedure TTestResolver.TearDown; begin + FreeSrcMarkers; ResolverEngine.Clear; if FModules<>nil then begin @@ -403,6 +444,9 @@ begin end; procedure TTestResolver.ParseProgram; +var + aFilename: String; + aRow, aCol: Integer; begin FFirstStatement:=nil; try @@ -410,24 +454,29 @@ begin except on E: EParserError do begin + aFilename:=Scanner.CurFilename; + aRow:=Scanner.CurRow; + aCol:=Scanner.CurColumn; + WriteSources(aFilename,aRow,aCol); writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message +' Scanner at' - +' File='+Scanner.CurFilename - +' Row='+IntToStr(Scanner.CurRow) - +' Col='+IntToStr(Scanner.CurColumn) - +' Line="'+Scanner.CurLine+'"' - ); + +' at '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')' + +' Line="'+Scanner.CurLine+'"'); raise E; end; on E: EPasResolve do begin + aFilename:=Scanner.CurFilename; + aRow:=Scanner.CurRow; + aCol:=Scanner.CurColumn; + if E.PasElement<>nil then + begin + aFilename:=E.PasElement.SourceFilename; + ResolverEngine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,aRow,aCol); + end; + WriteSources(aFilename,aRow,aCol); writeln('ERROR: TTestResolver.ParseProgram PasResolver: '+E.ClassName+':'+E.Message - +' Scanner at' - +' File='+Scanner.CurFilename - +' Row='+IntToStr(Scanner.CurRow) - +' Col='+IntToStr(Scanner.CurColumn) - +' Line="'+Scanner.CurLine+'"' - ); + +' at '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')'); raise E; end; on E: Exception do @@ -490,87 +539,33 @@ begin 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); + RaiseErrorAtSrc(Msg,Filename,LineNumber,p-PChar(SrcLine)+1); end; - procedure AddMarker(Marker: PMarker); + procedure AddMarker(Marker: PSrcMarker); begin - if LastMarker<>nil then - LastMarker^.Next:=Marker + if LastSrcMarker<>nil then + LastSrcMarker^.Next:=Marker else - FirstMarker:=Marker; - LastMarker:=Marker; + FirstSrcMarker:=Marker; + LastSrcMarker:=Marker; end; - function AddMarker(Kind: TMarkerKind; const aFilename: string; - aLine, aStartCol, aEndCol: integer; const Identifier: string): PMarker; + function AddMarker(Kind: TSrcMarkerKind; const aFilename: string; + aLine, aStartCol, aEndCol: integer; const Identifier: string): PSrcMarker; begin New(Result); Result^.Kind:=Kind; Result^.Filename:=aFilename; - Result^.LineNumber:=aLine; + Result^.Row:=aLine; Result^.StartCol:=aStartCol; Result^.EndCol:=aEndCol; Result^.Identifier:=Identifier; @@ -579,8 +574,8 @@ var AddMarker(Result); end; - function AddMarkerForTokenBehindComment(Kind: TMarkerKind; - const Identifer: string): PMarker; + function AddMarkerForTokenBehindComment(Kind: TSrcMarkerKind; + const Identifer: string): PSrcMarker; var TokenStart, p: PChar; begin @@ -590,18 +585,6 @@ var 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; @@ -623,7 +606,7 @@ var p:=CommentStartP+2; Identifier:=ReadIdentifier(p); //writeln('TTestResolver.CheckReferenceDirectives.AddLabel ',Identifier); - if FindLabel(Identifier)<>nil then + if FindSrcLabel(Identifier)<>nil then RaiseError('duplicate label "'+Identifier+'"',p); AddMarkerForTokenBehindComment(mkLabel,Identifier); end; @@ -721,50 +704,24 @@ var 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); + procedure CheckResolverReference(aMarker: PSrcMarker); // check if one element at {@a} has a TResolvedReference to an element labeled {#a} var - aLabel: PMarker; + aLabel: PSrcMarker; ReferenceElements, LabelElements: TFPList; i, j, aLine, aCol: Integer; El, Ref, LabelEl: TPasElement; begin - //writeln('CheckResolverReference searching reference: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); - aLabel:=FindLabel(aMarker^.Identifier); + //writeln('CheckResolverReference searching reference: ',aMarker^.Filename,' Line=',aMarker^.Row,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); + aLabel:=FindSrcLabel(aMarker^.Identifier); if aLabel=nil then - RaiseErrorAt('label "'+aMarker^.Identifier+'" not found',aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol); + RaiseErrorAtSrc('label "'+aMarker^.Identifier+'" not found',aMarker^.Filename,aMarker^.Row,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); + LabelElements:=FindElementsAt(aLabel); + ReferenceElements:=FindElementsAt(aMarker); for i:=0 to ReferenceElements.Count-1 do begin @@ -787,7 +744,7 @@ var 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('Reference candidate for "',aMarker^.Identifier,'" at reference ',aMarker^.Filename,'(',aMarker^.Row,',',aMarker^.StartCol,'-',aMarker^.EndCol,')'); write(' El=',GetObjName(El)); Ref:=nil; if El.CustomData is TResolvedReference then @@ -807,54 +764,49 @@ var 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('Label candidate for "',aLabel^.Identifier,'" at reference ',aLabel^.Filename,'(',aLabel^.Row,',',aLabel^.StartCol,'-',aLabel^.EndCol,')'); write(' El=',GetObjName(El)); writeln; end; - RaiseErrorAt('wrong resolved reference "'+aMarker^.Identifier+'"',aMarker); + RaiseErrorAtSrcMarker('wrong resolved reference "'+aMarker^.Identifier+'"',aMarker); finally LabelElements.Free; ReferenceElements.Free; end; end; - procedure CheckDirectReference(aMarker: PMarker); + procedure CheckDirectReference(aMarker: PSrcMarker); // check if one element at {=a} is a TPasAliasType pointing to an element labeled {#a} var - aLabel: PMarker; + aLabel: PSrcMarker; ReferenceElements, LabelElements: TFPList; i, LabelLine, LabelCol, j: Integer; El, LabelEl: TPasElement; DeclEl, TypeEl: TPasType; begin - writeln('CheckDirectReference searching pointer: ',aMarker^.Filename,' Line=',aMarker^.LineNumber,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); - aLabel:=FindLabel(aMarker^.Identifier); + //writeln('CheckDirectReference searching pointer: ',aMarker^.Filename,' Line=',aMarker^.Row,' Col=',aMarker^.StartCol,'-',aMarker^.EndCol,' Label="',aMarker^.Identifier,'"'); + aLabel:=FindSrcLabel(aMarker^.Identifier); if aLabel=nil then - RaiseErrorAt('label "'+aMarker^.Identifier+'" not found',aMarker); + RaiseErrorAtSrcMarker('label "'+aMarker^.Identifier+'" not found',aMarker); LabelElements:=nil; ReferenceElements:=nil; try - writeln('CheckDirectReference finding elements at label ...'); - LabelElements:=FindElementsAt(aLabel^.Filename,aLabel^.LineNumber,aLabel^.StartCol,aLabel^.EndCol); - if LabelElements.Count=0 then - RaiseErrorAt('label "'+aLabel^.Identifier+'" has no elements',aLabel); - - writeln('CheckDirectReference finding elements at reference ...'); - ReferenceElements:=FindElementsAt(aMarker^.Filename,aMarker^.LineNumber,aMarker^.StartCol,aMarker^.EndCol); - if ReferenceElements.Count=0 then - RaiseErrorAt('reference "'+aMarker^.Identifier+'" has no elements',aMarker); + //writeln('CheckDirectReference finding elements at label ...'); + LabelElements:=FindElementsAt(aLabel); + //writeln('CheckDirectReference finding elements at reference ...'); + ReferenceElements:=FindElementsAt(aMarker); for i:=0 to ReferenceElements.Count-1 do begin El:=TPasElement(ReferenceElements[i]); - writeln('CheckDirectReference ',i,'/',ReferenceElements.Count,' ',GetTreeDesc(El,2)); + //writeln('CheckDirectReference ',i,'/',ReferenceElements.Count,' ',GetTreeDesc(El,2)); if El.ClassType=TPasVariable then begin if TPasVariable(El).VarType=nil then begin - writeln('CheckDirectReference Var without Type: ',GetObjName(El),' El.Parent=',GetObjName(El.Parent)); + //writeln('CheckDirectReference Var without Type: ',GetObjName(El),' El.Parent=',GetObjName(El.Parent)); AssertNotNull('TPasVariable(El='+El.Name+').VarType',TPasVariable(El).VarType); end; TypeEl:=TPasVariable(El).VarType; @@ -870,7 +822,7 @@ var DeclEl:=TPasAliasType(El).DestType; ResolverEngine.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol); if (aLabel^.Filename=DeclEl.SourceFilename) - and (aLabel^.LineNumber=LabelLine) + and (aLabel^.Row=LabelLine) and (aLabel^.StartCol<=LabelCol) and (aLabel^.EndCol>=LabelCol) then exit; // success @@ -899,7 +851,7 @@ var El:=TPasElement(ReferenceElements[i]); writeln(' Reference ',GetObjName(El),' at ',ResolverEngine.GetElementSourcePosStr(El)); end; - RaiseErrorAt('wrong direct reference "'+aMarker^.Identifier+'"',aMarker); + RaiseErrorAtSrcMarker('wrong direct reference "'+aMarker^.Identifier+'"',aMarker); finally LabelElements.Free; ReferenceElements.Free; @@ -907,45 +859,32 @@ var end; var - aMarker: PMarker; + aMarker: PSrcMarker; i: Integer; SrcLines: TStringList; begin Module.ForEachCall(@OnCheckElementParent,nil); - FirstMarker:=nil; - LastMarker:=nil; - FoundRefs:=Default(TTestResolverReferenceData); - try - //writeln('TTestResolver.CheckReferenceDirectives find all markers'); - // find all markers - for i:=0 to Resolver.Streams.Count-1 do - begin - GetSrc(i,SrcLines,Filename); - ParseCode(SrcLines,Filename); - SrcLines.Free; - end; + //writeln('TTestResolver.CheckReferenceDirectives find all markers'); + // find all markers + for i:=0 to Resolver.Streams.Count-1 do + begin + GetSrc(i,SrcLines,Filename); + ParseCode(SrcLines,Filename); + SrcLines.Free; + end; - //writeln('TTestResolver.CheckReferenceDirectives check references'); - // check references - aMarker:=FirstMarker; - while aMarker<>nil do - begin - case aMarker^.Kind of - mkResolverReference: CheckResolverReference(aMarker); - mkDirectReference: CheckDirectReference(aMarker); - end; - aMarker:=aMarker^.Next; - end; - writeln('TTestResolver.CheckReferenceDirectives COMPLETE'); - - finally - while FirstMarker<>nil do - begin - aMarker:=FirstMarker; - FirstMarker:=FirstMarker^.Next; - Dispose(aMarker); - end; - end; + //writeln('TTestResolver.CheckReferenceDirectives check references'); + // check references + aMarker:=FirstSrcMarker; + while aMarker<>nil do + begin + case aMarker^.Kind of + mkResolverReference: CheckResolverReference(aMarker); + mkDirectReference: CheckDirectReference(aMarker); + end; + aMarker:=aMarker^.Next; + end; + //writeln('TTestResolver.CheckReferenceDirectives COMPLETE'); end; procedure TTestResolver.CheckResolverException(Msg: string; MsgNumber: integer); @@ -984,6 +923,116 @@ begin AssertEquals('Missing parser error '+Msg+' ('+IntToStr(MsgNumber)+')',true,ok); end; +procedure TTestResolver.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; + +function TTestResolver.FindElementsAt(aFilename: string; aLine, aStartCol, + aEndCol: integer): TFPList; +var + ok: Boolean; + FoundRefs: TTestResolverReferenceData; +begin + FoundRefs:=Default(TTestResolverReferenceData); + FoundRefs.Filename:=aFilename; + FoundRefs.Row:=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; + +function TTestResolver.FindElementsAt(aMarker: PSrcMarker; + ErrorOnNoElements: boolean): TFPList; +begin + Result:=FindElementsAt(aMarker^.Filename,aMarker^.Row,aMarker^.StartCol,aMarker^.EndCol); + if ErrorOnNoElements and ((Result=nil) or (Result.Count=0)) then + RaiseErrorAtSrcMarker('marker '+SrcMarker[aMarker^.Kind]+aMarker^.Identifier+' has no elements',aMarker); +end; + +function TTestResolver.FindSrcLabel(const Identifier: string): PSrcMarker; +begin + Result:=FirstSrcMarker; + while Result<>nil do + begin + if (Result^.Kind=mkLabel) + and (CompareText(Result^.Identifier,Identifier)=0) then + exit; + Result:=Result^.Next; + end; +end; + +function TTestResolver.FindElementsAtSrcLabel(const Identifier: string; + ErrorOnNoElements: boolean): TFPList; +var + SrcLabel: PSrcMarker; +begin + SrcLabel:=FindSrcLabel(Identifier); + if SrcLabel=nil then + Fail('missing label "'+Identifier+'"'); + Result:=FindElementsAt(SrcLabel,ErrorOnNoElements); +end; + +procedure TTestResolver.WriteSources(const aFilename: string; aRow, + aCol: integer); +var + IsSrc: Boolean; + i, j: Integer; + SrcLines: TStringList; + SrcFilename, Line: string; +begin + for i:=0 to Resolver.Streams.Count-1 do + begin + GetSrc(i,SrcLines,SrcFilename); + IsSrc:=ExtractFilename(aFilename)=ExtractFileName(aFilename); + writeln('Testcode:-File="',SrcFilename,'"----------------------------------:'); + for j:=1 to SrcLines.Count do + begin + Line:=SrcLines[j-1]; + if IsSrc and (j=aRow) then + begin + write('*'); + Line:=LeftStr(Line,aCol-1)+'|'+copy(Line,aCol,length(Line)); + end; + writeln(Format('%:4d: ',[j]),Line); + end; + SrcLines.Free; + end; +end; + +procedure TTestResolver.RaiseErrorAtSrc(Msg: string; const aFilename: string; + aRow, aCol: integer); +var + s: String; +begin + WriteSources(aFilename,aRow,aCol); + s:='[TTestResolver.RaiseErrorAtSrc] '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+') Error: '+Msg; + writeln('ERROR: ',s); + raise EAssertionFailedError.Create(s); +end; + +procedure TTestResolver.RaiseErrorAtSrcMarker(Msg: string; aMarker: PSrcMarker); +begin + RaiseErrorAtSrc(Msg,aMarker^.Filename,aMarker^.Row,aMarker^.StartCol); +end; + function TTestResolver.FindModuleWithFilename(aFilename: string ): TTestEnginePasResolver; var @@ -999,7 +1048,7 @@ 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'); + raise EAssertionFailedError.Create('TTestResolver.AddModule: file "'+aFilename+'" already exists'); Result:=TTestEnginePasResolver.Create; Result.Filename:=aFilename; Result.AddObjFPCBuiltInIdentifiers; @@ -1140,7 +1189,7 @@ begin end; end; writeln('TTestResolver.OnPasResolverFindUnit missing unit "',aUnitName,'"'); - raise Exception.Create('can''t find unit "'+aUnitName+'"'); + raise EAssertionFailedError.Create('can''t find unit "'+aUnitName+'"'); end; procedure TTestResolver.OnFindReference(El: TPasElement; FindData: pointer); @@ -1149,9 +1198,9 @@ var Line, Col: integer; begin ResolverEngine.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col); - //writeln('TTestResolver.OnFindReference ',El.SourceFilename,' Line=',Line,',Col=',Col,' ',GetObjName(El),' SearchFile=',Data^.Filename,',Line=',Data^.Line,',Col=',Data^.StartCol,'-',Data^.EndCol); + //writeln('TTestResolver.OnFindReference ',El.SourceFilename,' Line=',Line,',Col=',Col,' ',GetObjName(El),' SearchFile=',Data^.Filename,',Line=',Data^.Row,',Col=',Data^.StartCol,'-',Data^.EndCol); if (Data^.Filename=El.SourceFilename) - and (Data^.Line=Line) + and (Data^.Row=Line) and (Data^.StartCol<=Col) and (Data^.EndCol>=Col) then @@ -1170,7 +1219,7 @@ var s:='TTestResolver.OnCheckElementParent El='+GetTreeDesc(El)+' '+ ResolverEngine.GetElementSourcePosStr(El)+' '+Msg; writeln('ERROR: ',s); - raise Exception.Create(s); + raise EAssertionFailedError.Create(s); end; begin @@ -1234,6 +1283,19 @@ begin end; end; +procedure TTestResolver.FreeSrcMarkers; +var + aMarker, Last: PSrcMarker; +begin + aMarker:=FirstSrcMarker; + while aMarker<>nil do + begin + Last:=aMarker; + aMarker:=aMarker^.Next; + Dispose(Last); + end; +end; + function TTestResolver.GetModules(Index: integer): TTestEnginePasResolver; begin Result:=TTestEnginePasResolver(FModules[Index]); @@ -2120,12 +2182,13 @@ begin Add(' {@v1}v1:={@e1}e;'); Add(' except'); Add(' {@v1}v1:={@e1}e;'); + Add(' raise;'); Add(' end'); Add(' try'); Add(' {@v1}v1:={@e1}e;'); Add(' except'); Add(' on {#e2}{=Exec}E: Exception do'); - Add(' if {@e2}e=nil then ;'); + Add(' if {@e2}e=nil then raise;'); Add(' on {#e3}{=Exec}E: Exception do'); Add(' raise {@e3}e;'); Add(' else'); @@ -2971,7 +3034,7 @@ begin AssertEquals('Forward class not resolved raises correct error',nForwardTypeNotResolved,ErrorNo); end; -procedure TTestResolver.TestClassMethod; +procedure TTestResolver.TestClass_Method; begin StartProgram(false); Add('type'); @@ -2990,7 +3053,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestClassMethodUnresolved; +procedure TTestResolver.TestClass_MethodUnresolved; begin StartProgram(false); Add('type'); @@ -3003,7 +3066,7 @@ begin CheckResolverException('forward proc not resolved',PasResolver.nForwardProcNotResolved); end; -procedure TTestResolver.TestClassMethodAbstract; +procedure TTestResolver.TestClass_MethodAbstract; begin StartProgram(false); Add('type'); @@ -3014,7 +3077,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestClassMethodAbstractWithoutVirtual; +procedure TTestResolver.TestClass_MethodAbstractWithoutVirtualFail; begin StartProgram(false); Add('type'); @@ -3025,7 +3088,7 @@ begin CheckResolverException('abstract without virtual',PasResolver.nInvalidProcModifiers); end; -procedure TTestResolver.TestClassMethodAbstractHasBody; +procedure TTestResolver.TestClass_MethodAbstractHasBodyFail; begin StartProgram(false); Add('type'); @@ -3040,7 +3103,7 @@ begin PasResolver.nAbstractMethodsMustNotHaveImplementation); end; -procedure TTestResolver.TestClassMethodUnresolvedWithAncestor; +procedure TTestResolver.TestClass_MethodUnresolvedWithAncestor; begin StartProgram(false); Add('type'); @@ -3054,7 +3117,7 @@ begin CheckResolverException('forward proc not resolved',PasResolver.nForwardProcNotResolved); end; -procedure TTestResolver.TestClassProcFuncMismatch; +procedure TTestResolver.TestClass_ProcFuncMismatch; begin StartProgram(false); Add('type'); @@ -3068,7 +3131,7 @@ begin CheckResolverException('procedure expected, but function found',PasResolver.nXExpectedButYFound); end; -procedure TTestResolver.TestClassMethodOverload; +procedure TTestResolver.TestClass_MethodOverload; begin StartProgram(false); Add('type'); @@ -3090,7 +3153,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestClassMethodInvalidOverload; +procedure TTestResolver.TestClass_MethodInvalidOverload; begin StartProgram(false); Add('type'); @@ -3108,7 +3171,7 @@ begin CheckResolverException('Duplicate identifier',PasResolver.nDuplicateIdentifier); end; -procedure TTestResolver.TestClassOverride; +procedure TTestResolver.TestClass_MethodOverride; begin StartProgram(false); Add('type'); @@ -3128,7 +3191,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestClassOverride2; +procedure TTestResolver.TestClass_MethodOverride2; begin StartProgram(false); Add('type'); @@ -3154,7 +3217,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestClassMethodScope; +procedure TTestResolver.TestClass_MethodScope; begin StartProgram(false); Add('type'); @@ -3172,7 +3235,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestClassIdentifierSelf; +procedure TTestResolver.TestClass_IdentifierSelf; begin StartProgram(false); Add('type'); @@ -3204,10 +3267,11 @@ begin Add(' {#A}TClassA = class'); Add(' procedure {#A_ProcA}ProcA(i: longint); override;'); Add(' procedure {#A_ProcB}ProcB(j: longint); override;'); + Add(' procedure {#A_ProcC}ProcC; virtual;'); Add(' end;'); Add('procedure TObject.ProcA(i: longint);'); Add('begin'); - Add(' inherited; // ignore and do not raise error'); + Add(' inherited; // ignore, do not raise error'); Add('end;'); Add('procedure TObject.ProcB(j: longint);'); Add('begin'); @@ -3223,6 +3287,10 @@ begin Add('procedure TClassA.ProcB(j: longint);'); Add('begin'); Add('end;'); + Add('procedure TClassA.ProcC;'); + Add('begin'); + Add(' inherited; // ignore, do not raise error'); + Add('end;'); Add('begin'); ParseProgram; end; @@ -3363,7 +3431,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestClassOperator_Is_As; +procedure TTestResolver.TestClass_Operators_Is_As; begin StartProgram(false); Add('type'); @@ -3383,7 +3451,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestClassOperatorIsOnNonDescendantFail; +procedure TTestResolver.TestClass_OperatorIsOnNonDescendantFail; begin StartProgram(false); Add('type'); @@ -3399,7 +3467,7 @@ begin CheckResolverException('types are not related',PasResolver.nTypesAreNotRelated); end; -procedure TTestResolver.TestClassOperatorIsOnNonTypeFail; +procedure TTestResolver.TestClass_OperatorIsOnNonTypeFail; begin StartProgram(false); Add('type'); @@ -3416,7 +3484,7 @@ begin PasResolver.nXExpectedButYFound); end; -procedure TTestResolver.TestClassOperatorAsOnNonDescendantFail; +procedure TTestResolver.TestClass_OperatorAsOnNonDescendantFail; begin StartProgram(false); Add('type'); @@ -3432,7 +3500,7 @@ begin CheckResolverException('types are not related',PasResolver.nTypesAreNotRelated); end; -procedure TTestResolver.TestClassOperatorAsOnNonTypeFail; +procedure TTestResolver.TestClass_OperatorAsOnNonTypeFail; begin StartProgram(false); Add('type'); @@ -3512,9 +3580,12 @@ begin Add(' {@v}v:=TClassA({@o}o);'); Add(' {@v}v:=TClassA(TObject({@o}o));'); Add(' {@v}v:=TClassA({@v}v);'); + Add(' {@v}v:=v as TClassA;'); + Add(' {@v}v:=o as TClassA;'); Add(' ProcA({@v}v);'); Add(' ProcA(TClassA({@o}o));'); Add(' if TClassA({@o}o).id=3 then ;'); + Add(' if (o as TClassA).id=3 then ;'); ParseProgram; end; @@ -3768,6 +3839,269 @@ begin PasResolver.nCantAccessPrivateMember); end; +procedure TTestResolver.TestClass_Constructor_NewInstance; +var + aMarker: PSrcMarker; + Elements: TFPList; + i: Integer; + El: TPasElement; + Ref: TResolvedReference; + ActualNewInstance, ActualImplicitCallWithoutParams: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' constructor Create;'); + Add(' end;'); + Add('constructor TObject.Create;'); + Add('begin'); + Add(' {#a}Create; // normal call'); + Add(' TObject.{#b}Create; // new object'); + Add('end;'); + Add('var'); + Add(' o: TObject;'); + Add('begin'); + Add(' TObject.{#c}Create; // new object'); + Add(' o:=TObject.{#d}Create; // new object'); + Add(' o.{#e}Create; // normal call'); + ParseProgram; + aMarker:=FirstSrcMarker; + while aMarker<>nil do + begin + //writeln('TTestResolver.TestClass_Constructor_NewInstance ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol); + Elements:=FindElementsAt(aMarker); + try + ActualNewInstance:=false; + ActualImplicitCallWithoutParams:=false; + for i:=0 to Elements.Count-1 do + begin + El:=TPasElement(Elements[i]); + //writeln('TTestResolver.TestClass_Constructor_NewInstance ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData)); + if not (El.CustomData is TResolvedReference) then continue; + Ref:=TResolvedReference(El.CustomData); + if not (Ref.Declaration is TPasProcedure) then continue; + //writeln('TTestResolver.TestClass_Constructor_NewInstance ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags); + if (Ref.Declaration is TPasConstructor) then + ActualNewInstance:=rrfNewInstance in Ref.Flags; + ActualImplicitCallWithoutParams:=rrfImplicitCallWithoutParams in Ref.Flags; + break; + end; + if not ActualImplicitCallWithoutParams then + RaiseErrorAtSrcMarker('expected implicit call at "#'+aMarker^.Identifier+', but got function ref"',aMarker); + case aMarker^.Identifier of + 'a','e':// should be normal call + if ActualNewInstance then + RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker); + else // should be newinstance + if not ActualNewInstance then + RaiseErrorAtSrcMarker('expected newinstance at "#'+aMarker^.Identifier+', but got normal call"',aMarker); + end; + finally + Elements.Free; + end; + aMarker:=aMarker^.Next; + end; +end; + +procedure TTestResolver.TestClass_Constructor_InstanceCallResultFail; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' constructor Create;'); + Add(' end;'); + Add('constructor TObject.Create;'); + Add('begin'); + Add('end;'); + Add('var'); + Add(' o: TObject;'); + Add('begin'); + Add(' o:=o.Create; // normal call has no result -> fail'); + CheckResolverException('Incompatible types: got "Procedure/Function" expected "TObject"', + PasResolver.nIncompatibleTypesGotExpected); +end; + +procedure TTestResolver.TestClass_Destructor_FreeInstance; +var + aMarker: PSrcMarker; + Elements: TFPList; + i: Integer; + El: TPasElement; + Ref: TResolvedReference; + ActualFreeInstance, ActualImplicitCallWithoutParams: Boolean; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' destructor Destroy; virtual;'); + Add(' end;'); + Add(' TChild = class(TObject)'); + Add(' destructor DestroyOther;'); + Add(' end;'); + Add('destructor TObject.Destroy;'); + Add('begin'); + Add('end;'); + Add('destructor TChild.DestroyOther;'); + Add('begin'); + Add(' {#a}Destroy; // free instance'); + Add(' inherited {#b}Destroy; // normal call'); + Add('end;'); + Add('var'); + Add(' c: TChild;'); + Add('begin'); + Add(' c.{#c}Destroy; // free instance'); + Add(' c.{#d}DestroyOther; // free instance'); + ParseProgram; + aMarker:=FirstSrcMarker; + while aMarker<>nil do + begin + //writeln('TTestResolver.TestClass_Destructor_FreeInstance ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol); + Elements:=FindElementsAt(aMarker); + try + ActualFreeInstance:=false; + ActualImplicitCallWithoutParams:=false; + for i:=0 to Elements.Count-1 do + begin + El:=TPasElement(Elements[i]); + //writeln('TTestResolver.TestClass_Destructor_FreeInstance ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData)); + if not (El.CustomData is TResolvedReference) then continue; + Ref:=TResolvedReference(El.CustomData); + if not (Ref.Declaration is TPasProcedure) then continue; + //writeln('TTestResolver.TestClass_Destructor_FreeInstance ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags); + if (Ref.Declaration is TPasDestructor) then + ActualFreeInstance:=rrfFreeInstance in Ref.Flags; + ActualImplicitCallWithoutParams:=rrfImplicitCallWithoutParams in Ref.Flags; + break; + end; + if not ActualImplicitCallWithoutParams then + RaiseErrorAtSrcMarker('expected implicit call at "#'+aMarker^.Identifier+', but got function ref"',aMarker); + case aMarker^.Identifier of + 'b':// should be normal call + if ActualFreeInstance then + RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got freeinstance"',aMarker); + else // should be freeinstance + if not ActualFreeInstance then + RaiseErrorAtSrcMarker('expected freeinstance at "#'+aMarker^.Identifier+', but got normal call"',aMarker); + end; + finally + Elements.Free; + end; + aMarker:=aMarker^.Next; + end; +end; + +procedure TTestResolver.TestClass_ConDestructor_CallInherited; +var + aMarker: PSrcMarker; + Elements: TFPList; + i: Integer; + El: TPasElement; + Ref: TResolvedReference; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' constructor Create;'); + Add(' destructor Destroy; virtual;'); + Add(' end;'); + Add(' TChild = class(TObject)'); + Add(' constructor Create;'); + Add(' destructor Destroy; override;'); + Add(' end;'); + Add('constructor TObject.Create;'); + Add('begin'); + Add('end;'); + Add('destructor TObject.Destroy;'); + Add('begin'); + Add('end;'); + Add('constructor TChild.Create;'); + Add('begin'); + Add(' {#c}inherited; // normal call'); + Add('end;'); + Add('destructor TChild.Destroy;'); + Add('begin'); + Add(' {#d}inherited; // normal call'); + Add('end;'); + Add('begin'); + ParseProgram; + aMarker:=FirstSrcMarker; + while aMarker<>nil do + begin + writeln('TTestResolver.TestClass_ConDestructor_Inherited ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol); + Elements:=FindElementsAt(aMarker); + try + for i:=0 to Elements.Count-1 do + begin + El:=TPasElement(Elements[i]); + writeln('TTestResolver.TestClass_ConDestructor_Inherited ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData)); + if not (El.CustomData is TResolvedReference) then continue; + Ref:=TResolvedReference(El.CustomData); + if not (Ref.Declaration is TPasProcedure) then continue; + writeln('TTestResolver.TestClass_ConDestructor_Inherited ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags); + if rrfNewInstance in Ref.Flags then + RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker); + if rrfFreeInstance in Ref.Flags then + RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got freeinstance"',aMarker); + break; + end; + finally + Elements.Free; + end; + aMarker:=aMarker^.Next; + end; +end; + +procedure TTestResolver.TestClass_Constructor_Inherited; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' constructor Create;'); + Add(' destructor Destroy;'); + Add(' procedure DoIt;'); + Add(' end;'); + Add(' {#TClassA}TClassA = class'); + Add(' Sub: TObject;'); + Add(' end;'); + Add('constructor TObject.Create; begin end;'); + Add('destructor TObject.Destroy; begin end;'); + Add('procedure TObject.DoIt; begin end;'); + Add('var a: TClassA;'); + Add('begin'); + Add(' a:=TClassA.Create;'); + Add(' a.DoIt;'); + Add(' a.Destroy;'); + Add(' if TClassA.Create.Sub=nil then ;'); + Add(' with TClassA.Create do Sub:=nil;'); + Add(' with TClassA do a:=Create;'); + Add(' with TClassA do Create.Sub:=nil;'); + ParseProgram; +end; + +procedure TTestResolver.TestClass_SubObject; +begin + StartProgram(false); + Add('type'); + Add(' {#TOBJ}TObject = class'); + Add(' {#Sub}Sub: TObject;'); + Add(' procedure DoIt(p: longint);'); + Add(' function GetIt(p: longint): TObject;'); + Add(' end;'); + Add('procedure TObject.DoIt(p: longint); begin end;'); + Add('function TObject.GetIt(p: longint): TObject; begin end;'); + Add('var o: TObject;'); + Add('begin'); + Add(' o.Sub:=nil;'); + Add(' o.Sub.Sub:=nil;'); + Add(' if o.Sub=nil then ;'); + Add(' if o.Sub=o.Sub.Sub then ;'); + Add(' o.Sub.DoIt(3);'); + Add(' o.Sub.GetIt(4);'); + Add(' o.Sub.GetIt(5).DoIt(6);'); + Add(' o.Sub.GetIt(7).Sub.DoIt(8);'); + ParseProgram; +end; + procedure TTestResolver.TestClassOf; begin StartProgram(false); @@ -4735,7 +5069,7 @@ begin Add(' f: TFunctionInt;'); Add(' ff: TFunctionIntFunc;'); Add('begin'); - Add(' i:=GetNumber;'); + Add(' i:=GetNumber; // omit ()'); Add(' i:=GetNumber();'); Add(' i:=GetNumberFunc()();'); Add(' i:=GetNumberFuncFunc()()();'); diff --git a/packages/fcl-passrc/tests/tcstatements.pas b/packages/fcl-passrc/tests/tcstatements.pas index ebab1f2ebd..e23a71dcb4 100644 --- a/packages/fcl-passrc/tests/tcstatements.pas +++ b/packages/fcl-passrc/tests/tcstatements.pas @@ -1211,8 +1211,6 @@ procedure TTestStatementParser.TestCaseElseNoSemicolon; Var C : TPasImplCaseOf; S : TPasImplCaseStatement; - B : TPasImplbeginBlock; - begin DeclareVar('integer'); TestStatement(['case a of','1 : dosomething;','2 : dosomethingmore','else','a:=1;','end;']); diff --git a/packages/fcl-passrc/tests/testpassrc.lpi b/packages/fcl-passrc/tests/testpassrc.lpi index fb506d1474..90c1df5466 100644 --- a/packages/fcl-passrc/tests/testpassrc.lpi +++ b/packages/fcl-passrc/tests/testpassrc.lpi @@ -30,7 +30,7 @@ - + diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 126e504005..44e9b16573 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -28,36 +28,68 @@ - function results - record types and vars - for loop + - if loopvar is used afterwards append if($loopend>i)i--; - repeat..until - while..do - try..finally + - try..except + - raise - asm..end - type alias - inc/dec to += -= - case-of - use $impl for implementation declarations, can be disabled + - classes + - declare using createClass + - constructor + - destructor + - vars + - ancestor + - virtual, override, abstract + - "is" operator + - "as" operator + - call inherited "inherited;", "inherited funcname;" + - arrays + - init as "arr = []" + - SetLength(arr,newlength,defaultvalue) + - length(arr) + - access element: arr[index] ToDos: - arrays + - array of record: setlength + - multi dimensional [index1,index2] -> [index1][index2] + - static array: non 0 start index + - static array: length + - array of static array: setlength + - array[char] + - low(), high() + - constant + - open arrays - classes + + overloads, reintroduce + + reintroduced variables + + property + + class of + - proc default values - pass by reference - create unique id for local const - - append to for-loop: if($loopend>i)i--; - rename overloaded procs, append $0, $1, ... - - rename js identifiers: apply, bind, call, prototyp, ... + - rename name conflicts with js identifiers: apply, bind, call, prototyp, ... + - assembler proc modifier: asm..end as whole body + - enums, sets. + var s = {}; + s["red"] = true; s["green"] = true; s["red"] = true; + Object.keys(s).length === 2; + s["red"] === true; + for (var key in s) // arbitrary order + if (s.hasOwnProperty(key)) + console.log(s[key]); + - with-do - record const - copy record - - asm..end as whole body - procedure modifier external - library - - enums, sets. For small sets use an integer, for big sets use - var s = {}; - s["red"] = true; s["green"] = true; s["red"] = true; - Object.keys(s).length === 2; - s["red"] === true; - for (var key in s) // arbitrary order - if (s.hasOwnProperty(key)) - console.log(s[key]); - Fix file names on converter errors (relative instead of full) - 'use strict' to allow javascript compilers optimize better - Avoid nameclashes with the following identifiers: @@ -69,7 +101,7 @@ do, while, constructor, each, in, function, continue, default, arguments, switch, try, catch, throw, var, let, with, return, getPrototypeOf, new, instanceof, Math, Object, anonymous, true, false, null, NaN, undefined, - String, Number, static, this, case, default + String, Number, static, this, case, default, throw, isPrototypeOf - use UTF8 string literals - dotted unit names @@ -105,7 +137,15 @@ resourcestring sMemberExprMustBeIdentifier = 'Member expression must be an identifier'; const - LoopEndVarName = '$loopend'; + DefaultRTLVarName = 'rtl'; + DefaultImplementationVarName = '$impl'; + DefaultLoopEndVarName = '$loopend'; + DefaultCreateClassFuncName = 'createClass'; // rtl.createClass + DefaultNewClassInstanceFuncName = '$create'; + DefaultFreeClassInstanceFuncName = '$destroy'; + DefaultSetArrayLengthFuncName = 'setArrayLength'; // rtl.setArrayLength + DefaultLengthFuncName = 'length'; // rtl.length + DefaultAsFuncName = 'as'; // rtl.as Type @@ -119,7 +159,12 @@ Type Id: int64; end; - TCtxJSElementKind = (cjkRoot, cjkObject, cjkFunction, cjkArray); + TCtxJSElementKind = ( + cjkRoot, + cjkObject, + cjkFunction, + cjkArray, + cjkDot); { TConvertContext } @@ -134,6 +179,7 @@ Type TmpVarCount: integer; constructor Create(PasEl: TPasElement; JSEl: TJSElement; aParent: TConvertContext); virtual; function GetRootModule: TPasModule; + function GetThis: TPasElement; function CreateTmpIdentifier(const Prefix: string): string; end; @@ -148,6 +194,7 @@ Type TFunctionContext = Class(TConvertContext) public + This: TPasElement; constructor Create(PasEl: TPasElement; JSEl: TJSElement; aParent: TConvertContext); override; end; @@ -165,14 +212,35 @@ Type constructor Create(PasEl: TPasElement; JSEl: TJSElement; aParent: TConvertContext); override; end; + { TDotContext } + + TDotContext = Class(TConvertContext) + public + constructor Create(PasEl: TPasElement; JSEl: TJSElement; aParent: TConvertContext); override; + end; + + TRefPathKind = ( + rpkPath, // e.g. "TObject" + rpkPathWithDot, // e.g. "TObject." + rpkPathAndName // e.g. "TObject.ClassName" + ); + { TPasToJSConverter } TPasToJSConverter = Class(TObject) private + FAsFuncName: TJSString; FMainFunction: TJSString; FUseLowerCase: boolean; FImplementationName: TJSString; FUseSwitchStatement: boolean; + FRTLVarName: TJSString; + FLoopEndVarName: TJSString; + FNewClassInstanceFuncName: TJSString; + FFreeClassInstanceFuncName: TJSString; + FCreateClassFuncName: TJSString; + FSetArrayLengthFuncName: TJSString; + FLengthFuncName: TJSString; Procedure AddToSourceElements(Src: TJSSourceElements; El: TJSElement); Function CreateBuiltInIdentifierExpr(AName: string): TJSPrimaryExpressionIdent; Function CreateIdentifierExpr(AName: string; El: TPasElement): TJSPrimaryExpressionIdent; @@ -182,6 +250,28 @@ Type Function CreateVarDecl(El: TPasVariable; AContext: TConvertContext): TJSElement; Function CreateConstDecl(El: TPasConst; AContext: TConvertContext): TJSElement; Function CreateSwitchStatement(El: TPasImplCaseOf; AContext: TConvertContext): TJSElement; + Function GetFunctionDefinitionInUnary(const fd: TJSFunctionDeclarationStatement;const funname: TJSString; inunary: boolean): TJSFunctionDeclarationStatement; + Function GetFunctionUnaryName(var je: TJSElement;out fundec: TJSFunctionDeclarationStatement): TJSString; + Procedure AddProcedureToClass(sl: TJSStatementList; E: TJSElement;const P: TPasProcedure); + Function ConvertClassConstructor(El: TPasConstructor; AContext: TConvertContext): TJSElement; virtual; + private + type + TForLoopFindData = record + ForLoop: TPasImplForLoop; + LoopVar: TPasElement; + FoundLoop: boolean; + LoopVarWrite: boolean; // true if first acces of LoopVar after loop is a write + LoopVarRead: boolean; // true if first acces of LoopVar after loop is a read + end; + PForLoopFindData = ^TForLoopFindData; + procedure ForLoop_OnProcBodyElement(El: TPasElement; arg: pointer); + private + type + TTryExceptFindData = record + HasRaiseWithoutObject: boolean; + end; + PTryExceptFindData = ^TTryExceptFindData; + procedure TryExcept_OnElement(El: TPasElement; arg: pointer); protected // Error functions Procedure DoError(Id: int64; Const Msg : String); @@ -193,23 +283,24 @@ Type // Search Function GetExpressionValueType(El: TPasExpr; AContext: TConvertContext ): TJSType; virtual; Function GetPasIdentValueType(AName: String; AContext: TConvertContext): TJSType; virtual; - Function GetFunctionDefinitionInUnary(const fd: TJSFunctionDeclarationStatement;const funname: TJSString; inunary: boolean): TJSFunctionDeclarationStatement; - Function GetFunctionUnaryName(var je: TJSElement;out fundec: TJSFunctionDeclarationStatement): TJSString; // Name mangling 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; // Never create an element manually, always use the below functions Function CreateElement(C: TJSElementClass; Src: TPasElement): TJSElement; virtual; + {$IFDEF EnableOldClass} Function CreateCallStatement(const JSCallName: string; JSArgs: array of string): TJSCallExpression; Function CreateCallStatement(const FunNameEx: TJSElement; JSArgs: array of string): TJSCallExpression; + {$ENDIF} + Function CreateNewFreeInstanceExpr(Ref: TResolvedReference; AContext : TConvertContext): TJSCallExpression; virtual; Function CreateProcedureDeclaration(const El: TPasElement):TJSFunctionDeclarationStatement; + Procedure CreateProcedureCall(var Call: TJSCallExpression; Args: TParamsExpr; TargetProc: TPasProcedure; AContext: TConvertContext); virtual; + Procedure CreateProcedureCallArgs(Elements: TJSArrayLiteralElements; Args: TParamsExpr; TargetProc: TPasProcedure; AContext: TConvertContext); virtual; Function CreateUnary(Members: array of string; E: TJSElement): TJSUnary; Function CreateMemberExpression(Members: array of string): TJSDotMemberExpression; - Procedure AddProcedureToClass(sl: TJSStatementList; E: TJSElement;const P: TPasProcedure); Function CreateUsesList(UsesList: TFPList; AContext : TConvertContext): TJSArrayLiteral; Procedure AddToStatementList(var First, Last: TJSStatementList; Add: TJSElement; Src: TPasElement); @@ -217,10 +308,13 @@ Type Function CreateVarInit(El: TPasVariable; AContext: TConvertContext): TJSElement;virtual; Function CreateRecordInit(aRecord: TPasRecordType; Expr: TPasElement; El: TPasElement; AContext: TConvertContext): TJSElement;virtual; Function CreateTypeRef(El: TPasType; AContext : TConvertContext): TJSElement;virtual; - Function CreateReferencePath(El: TPasElement; AContext : TConvertContext): string;virtual; + Function CreateReferencePath(El: TPasElement; AContext : TConvertContext; + Kind: TRefPathKind; Full: boolean = false): string; virtual; + Procedure CreateImplementationSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); + Procedure CreateInitSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); // Statements - Function ConvertImplBlockElements(El: TPasImplBlock; AContext: TConvertContext): TJSElement;virtual; - Function ConvertBeginEndStatement(El: TPasImplBeginBlock; AContext: TConvertContext): TJSElement;virtual; + Function ConvertImplBlockElements(El: TPasImplBlock; AContext: TConvertContext): TJSElement; virtual; + Function ConvertBeginEndStatement(El: TPasImplBeginBlock; AContext: TConvertContext): TJSElement; virtual; Function ConvertStatement(El: TPasImplStatement; AContext: TConvertContext ): TJSElement;virtual; Function ConvertAssignStatement(El: TPasImplAssign; AContext: TConvertContext): TJSElement; virtual; Function ConvertRaiseStatement(El: TPasImplRaise; AContext: TConvertContext ): TJSElement; virtual; @@ -231,60 +325,68 @@ Type Function ConvertFinalizationSection(El: TFinalizationSection; AContext: TConvertContext): TJSElement;virtual; Function ConvertInitializationSection(El: TInitializationSection; AContext: TConvertContext): TJSElement;virtual; Function ConvertSimpleStatement(El: TPasImplSimple; AContext: TConvertContext): TJSElement;virtual; - Function ConvertTryStatement(El: TPasImplTry; AContext: TConvertContext ): TJSElement;virtual; Function ConvertWithStatement(El: TPasImplWithDo; AContext: TConvertContext): TJSElement;virtual; + Function ConvertTryStatement(El: TPasImplTry; AContext: TConvertContext ): TJSElement;virtual; Function ConvertTryFinallyStatement(El: TPasImplTryFinally; AContext: TConvertContext): TJSElement;virtual; - Function ConvertExceptOn(El: TPasImplExceptOn; AContext: TConvertContext): TJSElement; Function ConvertTryExceptStatement(El: TPasImplTryExcept; AContext: TConvertContext): TJSElement; + Function ConvertExceptOn(El: TPasImplExceptOn; AContext: TConvertContext): TJSElement; Function ConvertCaseOfStatement(El: TPasImplCaseOf; AContext: TConvertContext): TJSElement; Function ConvertAsmStatement(El: TPasImplAsmStatement; AContext: TConvertContext): TJSElement; - Procedure CreateImplementationSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); - 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; - Function ConvertNilExpr(El: TNilExpr; AContext : TConvertContext): TJSElement;virtual; - Function ConvertParamsExpression(El: TParamsExpr; AContext : TConvertContext): TJSElement;virtual; - Function ConvertBuiltInIncDec(El: TParamsExpr; AContext : TConvertContext): TJSElement;virtual; - Function ConvertRecordValues(El: TRecordValues; AContext : TConvertContext): TJSElement;virtual; - Function ConvertSelfExpression(El: TSelfExpr; AContext : TConvertContext): TJSElement;virtual; - 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 ConvertArrayValues(El: TArrayValues; AContext: TConvertContext): TJSElement;virtual; + Function ConvertInheritedExpression(El: TInheritedExpr; AContext: TConvertContext): TJSElement;virtual; + Function ConvertNilExpr(El: TNilExpr; AContext: TConvertContext): TJSElement;virtual; + Function ConvertParamsExpression(El: TParamsExpr; AContext: TConvertContext): TJSElement;virtual; + Function ConvertBuiltInLength(El: TParamsExpr; AContext: TConvertContext): TJSElement;virtual; + Function ConvertBuiltInSetLength(El: TParamsExpr; AContext: TConvertContext): TJSElement;virtual; + Function ConvertBuiltInExit(El: TPasExpr; AContext: TConvertContext): TJSElement;virtual; + Function ConvertBuiltInIncDec(El: TParamsExpr; AContext: TConvertContext): TJSElement;virtual; + Function ConvertRecordValues(El: TRecordValues; AContext: TConvertContext): TJSElement;virtual; + Function ConvertSelfExpression(El: TSelfExpr; AContext: TConvertContext): TJSElement;virtual; + 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 ConvertUnaryExpression(El: TUnaryExpr; AContext: TConvertContext ): TJSElement;virtual; + Function ConvertCallExpression(El: TParamsExpr; AContext: TConvertContext ): TJSElement;virtual; Function TransFormStringLiteral(S : String) : String; // Convert declarations - Function ConvertElement(El : TPasElement; AContext : TConvertContext) : TJSElement; virtual; - Function ConvertProperty(El: TPasProperty; AContext : TConvertContext ): TJSElement;virtual; - Function ConvertCommand(El: TPasImplCommand; AContext : TConvertContext): TJSElement;virtual; - Function ConvertCommands(El: TPasImplCommands; AContext : TConvertContext): TJSElement;virtual; - Function ConvertConst(El: TPasConst; AContext : TConvertContext): TJSElement;virtual; - Function ConvertDeclarations(El: TPasDeclarations; AContext : TConvertContext): TJSElement;virtual; - Function ConvertExportSymbol(El: TPasExportSymbol; AContext : TConvertContext): TJSElement;virtual; - Function ConvertExpression(El: TPasExpr; AContext : TConvertContext): TJSElement;virtual; - Function ConvertImplBlock(El: TPasImplBlock; AContext : TConvertContext ): TJSElement;virtual; - Function ConvertLabelMark(El: TPasImplLabelMark; AContext : TConvertContext): TJSElement;virtual; - Function ConvertLabels(El: TPasLabels; AContext : TConvertContext): TJSElement;virtual; - Function ConvertModule(El: TPasModule; AContext : TConvertContext): TJSElement;virtual; - 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 ConvertResString(El: TPasResString; AContext : TConvertContext): TJSElement;virtual; - Function ConvertType(El: TPasElement; AContext : TConvertContext): TJSElement;virtual; - Function ConvertVariable(El: TPasVariable; AContext : TConvertContext): TJSElement;virtual; - function ConvertRecordType(El: TPasRecordType; AContext: TConvertContext): TJSElement; virtual; - function ConvertClassType(El: TPasClassType; AContext: TConvertContext): TJSElement; virtual; + Function ConvertElement(El : TPasElement; AContext: TConvertContext) : TJSElement; virtual; + Function ConvertProperty(El: TPasProperty; AContext: TConvertContext ): TJSElement;virtual; + Function ConvertCommand(El: TPasImplCommand; AContext: TConvertContext): TJSElement;virtual; + Function ConvertCommands(El: TPasImplCommands; AContext: TConvertContext): TJSElement;virtual; + Function ConvertConst(El: TPasConst; AContext: TConvertContext): TJSElement;virtual; + Function ConvertDeclarations(El: TPasDeclarations; AContext: TConvertContext): TJSElement;virtual; + Function ConvertExportSymbol(El: TPasExportSymbol; AContext: TConvertContext): TJSElement;virtual; + Function ConvertExpression(El: TPasExpr; AContext: TConvertContext): TJSElement;virtual; + Function ConvertImplBlock(El: TPasImplBlock; AContext: TConvertContext ): TJSElement;virtual; + Function ConvertLabelMark(El: TPasImplLabelMark; AContext: TConvertContext): TJSElement;virtual; + Function ConvertLabels(El: TPasLabels; AContext: TConvertContext): TJSElement;virtual; + Function ConvertModule(El: TPasModule; AContext: TConvertContext): TJSElement;virtual; + 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 ConvertResString(El: TPasResString; AContext: TConvertContext): TJSElement;virtual; + Function ConvertType(El: TPasElement; AContext: TConvertContext): TJSElement;virtual; + Function ConvertVariable(El: TPasVariable; AContext: TConvertContext): TJSElement;virtual; + Function ConvertRecordType(El: TPasRecordType; AContext: TConvertContext): TJSElement; virtual; + Function ConvertClassType(El: TPasClassType; AContext: TConvertContext): TJSElement; virtual; Function ConvertClassMember(El: TPasElement; AContext: TConvertContext): TJSElement; virtual; - Function ConvertClassConstructor(El: TPasConstructor; AContext: TConvertContext): TJSElement; virtual; Public - constructor Create; + Constructor Create; Function ConvertPasElement(El : TPasElement; Resolver: TPasResolver) : TJSElement; Property MainFunction: TJSString Read FMainFunction Write FMainFunction; Property ImplementationName: TJSString read FImplementationName write FImplementationName;// empty to not use, default '$impl' - Property UseLowerCase: boolean read FUseLowerCase write FUseLowerCase; + Property UseLowerCase: boolean read FUseLowerCase write FUseLowerCase default true; Property UseSwitchStatement: boolean read FUseSwitchStatement write FUseSwitchStatement;// default false, because slower than "if" in many engines + Property RTLVarName: TJSString read FRTLVarName write FRTLVarName; + Property CreateClassFuncName: TJSString read FCreateClassFuncName write FCreateClassFuncName; + Property NewClassInstanceFuncName: TJSString read FNewClassInstanceFuncName write FNewClassInstanceFuncName; + Property FreeClassInstanceFuncName: TJSString read FFreeClassInstanceFuncName write FFreeClassInstanceFuncName; + Property SetArrayLengthFuncName: TJSString read FSetArrayLengthFuncName write FSetArrayLengthFuncName; + Property LengthFuncName: TJSString read FLengthFuncName write FLengthFuncName; + Property LoopEndVarName: TJSString read FLoopEndVarName write FLoopEndVarName; + Property AsFuncName: TJSString read FAsFuncName write FAsFuncName; end; EPasToJS = Class(Exception); @@ -294,6 +396,15 @@ var implementation +{ TDotContext } + +constructor TDotContext.Create(PasEl: TPasElement; JSEl: TJSElement; + aParent: TConvertContext); +begin + inherited Create(PasEl, JSEl, aParent); + Kind:=cjkDot; +end; + { TInterfaceContext } constructor TInterfaceContext.Create(PasEl: TPasElement; JSEl: TJSElement; @@ -355,6 +466,19 @@ begin Result:=nil; end; +function TConvertContext.GetThis: TPasElement; +var + ctx: TConvertContext; +begin + Result:=nil; + ctx:=Self; + repeat + if ctx is TFunctionContext then + exit(TFunctionContext(ctx).This); + ctx:=ctx.Parent; + until ctx=nil; +end; + function TConvertContext.CreateTmpIdentifier(const Prefix: string): string; begin inc(TmpVarCount); @@ -429,7 +553,7 @@ begin // create 'rtl.module(...)' RegModuleCall:=TJSCallExpression(CreateElement(TJSCallExpression,El)); AddToSourceElements(OuterSrc,RegModuleCall); - RegModuleCall.Expr:=CreateMemberExpression(['rtl','module']); + RegModuleCall.Expr:=CreateMemberExpression([String(RTLVarName),'module']); ArgArray := TJSArguments.Create(0, 0, ''); RegModuleCall.Args:=ArgArray; @@ -465,17 +589,18 @@ begin IntfContext:=TInterfaceContext.Create(El,Src,AContext); try + IntfContext.This:=El; if (El is TPasProgram) then begin // program if Assigned(TPasProgram(El).ProgramSection) then AddToSourceElements(Src,ConvertDeclarations(TPasProgram(El).ProgramSection,IntfContext)); - CreateInitSection(El,Src,AContext); + CreateInitSection(El,Src,IntfContext); end else if El is TPasLibrary then begin // library if Assigned(TPasLibrary(El).LibrarySection) then AddToSourceElements(Src,ConvertDeclarations(TPasLibrary(El).LibrarySection,IntfContext)); - CreateInitSection(El,Src,AContext); + CreateInitSection(El,Src,IntfContext); end else begin // unit @@ -523,6 +648,55 @@ begin Result:=C.Create(0,0); end; +function TPasToJSConverter.CreateNewFreeInstanceExpr(Ref: TResolvedReference; + AContext: TConvertContext): TJSCallExpression; +// create "$create("funcname");" +var + ok: Boolean; + C: TJSCallExpression; + Proc: TPasProcedure; + ProcScope: TPasProcedureScope; + ClassScope: TPasClassScope; + aClass: TPasElement; + ArgEx: TJSLiteral; + ArgElems: TJSArrayLiteralElements; +begin + Result:=nil; + //writeln('TPasToJSConverter.CreateNewInstanceStatement Ref.Declaration=',GetObjName(Ref.Declaration)); + Proc:=Ref.Declaration as TPasProcedure; + if Proc.Name='' then + RaiseInconsistency(20170125191914); + //writeln('TPasToJSConverter.CreateNewInstanceStatement Proc.Name=',Proc.Name); + ProcScope:=Proc.CustomData as TPasProcedureScope; + //writeln('TPasToJSConverter.CreateNewInstanceStatement ProcScope.Element=',GetObjName(ProcScope.Element),' ProcScope.ClassScope=',GetObjName(ProcScope.ClassScope),' ProcScope.DeclarationProc=',GetObjName(ProcScope.DeclarationProc),' ProcScope.ImplProc=',GetObjName(ProcScope.ImplProc),' ProcScope.CustomData=',GetObjName(ProcScope.CustomData)); + ClassScope:=ProcScope.ClassScope; + aClass:=ClassScope.Element; + if aClass.Name='' then + RaiseInconsistency(20170125191923); + //writeln('TPasToJSConverter.CreateNewInstanceStatement aClass.Name=',aClass.Name); + C:=TJSCallExpression(CreateElement(TJSCallExpression,Ref.Element)); + ok:=false; + try + // add "$create()" + C.Expr:=TJSPrimaryExpressionIdent.Create(0,0); + if rrfNewInstance in Ref.Flags then + TJSPrimaryExpressionIdent(C.Expr).Name:=NewClassInstanceFuncName + else + TJSPrimaryExpressionIdent(C.Expr).Name:=FreeClassInstanceFuncName; + C.Args:=TJSArguments(CreateElement(TJSArguments,Ref.Element)); + ArgElems:=C.Args.Elements; + // parameter: "funcname" + ArgEx := TJSLiteral.Create(0,0); + ArgEx.Value.AsString:=TJSString(TransformVariableName(Proc.Name,AContext)); + ArgElems.AddElement.Expr:=ArgEx; + ok:=true; + finally + if not ok then + C.Free; + end; + Result:=C; +end; + function TPasToJSConverter.ConvertUnaryExpression(El: TUnaryExpr; AContext: TConvertContext): TJSElement; @@ -542,7 +716,7 @@ begin end; eopSubtract: begin - U:=TJSUnaryPlusExpression(CreateElement(TJSUnaryMinusExpression,El)); + U:=TJSUnaryMinusExpression(CreateElement(TJSUnaryMinusExpression,El)); U.A:=E; end; else @@ -630,8 +804,71 @@ end; function TPasToJSConverter.ConvertBinaryExpression(El: TBinaryExpr; AContext: TConvertContext): TJSElement; -Type - TJSBinaryClass = Class of TJSBinary; + function CreateDotExpression: TJSElement; + // connect El.left and El.right with a dot. + var + Dot: TJSDotMemberExpression; + DotContext: TDotContext; + BParent, A, B: TJSElement; + ok: Boolean; + begin + Result:=nil; + // convert left side and create a dot-context for the right side + A:=ConvertElement(El.left,AContext); + if A=nil then + RaiseInconsistency(20170201140821); + DotContext:=TDotContext.Create(El,A,AContext); + ok:=false; + try + B:=ConvertElement(El.right,DotContext); + if A=nil then + RaiseInconsistency(20170201140827); + // create a TJSDotMemberExpression of A and the left-most identifier of B + // A becomes the new left-most element of B. + Result:=B; + BParent:=nil; + repeat + if (B is TJSCallExpression) then + begin + BParent:=B; + B:=TJSCallExpression(B).Expr; + end + else if (B is TJSDotMemberExpression) then + begin + BParent:=B; + B:=TJSDotMemberExpression(B).MExpr; + end + else if (B is TJSPrimaryExpressionIdent) then + begin + // left-most identifier found + // -> replace it + Dot := TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); + Dot.MExpr := A; + Dot.Name := TJSPrimaryExpressionIdent(B).Name; + if Result=B then + Result:=Dot + else if BParent is TJSDotMemberExpression then + TJSDotMemberExpression(BParent).MExpr:=Dot + else if BParent is TJSCallExpression then + TJSCallExpression(BParent).Expr:=Dot + else + DoError(20170129141307,''); + FreeAndNil(B); + break; + end + else + DoError(20161024191240,nMemberExprMustBeIdentifier,sMemberExprMustBeIdentifier,[],El); + until false; + ok:=true; + finally + DotContext.Free; + if not ok then + begin + FreeAndNil(A); + FreeAndNil(Result); + end; + end; + end; Const BinClasses : Array [TExprOpCode] of TJSBinaryClass = ( @@ -667,12 +904,31 @@ Const Var R : TJSBinary; C : TJSBinaryClass; - A,B : TJSElement; - funname: string; + A,B: TJSElement; ok: Boolean; + DotExpr: TJSDotMemberExpression; + Call: TJSCallExpression; + {$IFDEF EnableOldClass} + funname: string; + {$ENDIF} + begin Result:=Nil; + case El.OpCode of + eopSubIdent: + begin + Result:=CreateDotExpression; + exit; + end; + eopNone: + if El.left is TInheritedExpr then + begin + Result:=ConvertInheritedExpression(TInheritedExpr(El.left),AContext); + exit; + end; + end; + C:=BinClasses[El.OpCode]; A:=ConvertElement(El.left,AContext); ok:=false; @@ -687,8 +943,14 @@ begin Case El.OpCode of eopAs : begin - // ToDo: add check - Result:=ConvertElement(El.left,AContext); + // convert "A as B" to "rtl.as(A,B)" + Call:=TJSCallExpression(CreateElement(TJSCallExpression,El)); + Call.Args:=TJSArguments(CreateElement(TJSArguments,El)); + Call.Expr:=CreateBuiltInIdentifierExpr(String(RTLVarName)+'.'+String(AsFuncName)); + Call.Args.Elements.AddElement.Expr:=A; + Call.Args.Elements.AddElement.Expr:=B; + Result:=Call; + exit; end; eopAnd, eopOr, @@ -709,60 +971,55 @@ begin DoError(20161024191234,nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,['logical XOR'],El); end; end; - eopSubIdent : - begin - if (B is TJSPrimaryExpressionIdent) then - begin - Result := TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); - TJSDotMemberExpression(Result).MExpr := A; - TJSDotMemberExpression(Result).Name := TJSPrimaryExpressionIdent(B).Name; - FreeAndNil(B); - end - else if (B is TJSCallExpression) then - begin - Result := B; - funname := String(TJSPrimaryExpressionIdent(TJSCallExpression(B).Expr).Name); - TJSCallExpression(B).Expr := - TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); - TJSDotMemberExpression(TJSCallExpression(B).Expr).MExpr := A; - TJSDotMemberExpression(TJSCallExpression(B).Expr).Name := TJSString(funname); - end - else - DoError(20161024191240,nMemberExprMustBeIdentifier,sMemberExprMustBeIdentifier,[],El); - end - else - if (A is TJSPrimaryExpressionIdent) and + {$IFDEF EnableOldClass} + else if (A is TJSPrimaryExpressionIdent) and (TJSPrimaryExpressionIdent(A).Name = '_super') then begin - Result := B; - funname := String(TJSPrimaryExpressionIdent(TJSCallExpression(b).Expr).Name); - TJSCallExpression(b).Args.Elements.AddElement.Expr := - CreateBuiltInIdentifierExpr('self'); - if TJSCallExpression(b).Args.Elements.Count > 1 then - TJSCallExpression(b).Args.Elements.Exchange( - 0, TJSCallExpression(b).Args.Elements.Count - 1); - if CompareText(funname, 'Create') = 0 then + Result := B; + funname := String(TJSPrimaryExpressionIdent(TJSCallExpression(b).Expr).Name); + TJSCallExpression(b).Args.Elements.AddElement.Expr := + CreateBuiltInIdentifierExpr('self'); + if TJSCallExpression(b).Args.Elements.Count > 1 then + TJSCallExpression(b).Args.Elements.Exchange( + 0, TJSCallExpression(b).Args.Elements.Count - 1); + if CompareText(funname, 'Create') = 0 then begin - TJSCallExpression(B).Expr := - TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); - TJSDotMemberExpression(TJSCallExpression(b).Expr).MExpr := A; - TJSDotMemberExpression(TJSCallExpression(b).Expr).Name := TJSString(funname); + TJSCallExpression(B).Expr := + TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); + TJSDotMemberExpression(TJSCallExpression(b).Expr).MExpr := A; + TJSDotMemberExpression(TJSCallExpression(b).Expr).Name := TJSString(funname); end - else + else begin - TJSCallExpression(B).Expr := - CreateMemberExpression(['_super', 'prototype', funname, 'call']); + TJSCallExpression(B).Expr := + CreateMemberExpression(['_super', 'prototype', funname, 'call']); end; end - else - DoError(20161024191244,nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,[OpcodeStrings[El.OpCode]],El); + {$ENDIF} + else + DoError(20161024191244,nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,[OpcodeStrings[El.OpCode]],El); end; if (Result=Nil) and (C<>Nil) then begin - R:=TJSBinary(CreateElement(C,El)); - R.A:=A; - R.B:=B; - Result:=R; + if (El.OpCode=eopIs) and (AContext.Resolver<>nil) then + begin + // convert "A is B" to "B.isPrototypeOf(A)" + Call:=TJSCallExpression(CreateElement(TJSCallExpression,El)); + Result:=Call; + Call.Args:=TJSArguments(CreateElement(TJSArguments,El)); + Call.Args.Elements.AddElement.Expr:=A; + DotExpr:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,El)); + DotExpr.MExpr:=B; + DotExpr.Name:='isPrototypeOf'; + Call.Expr:=DotExpr; + end + else + begin + R:=TJSBinary(CreateElement(C,El)); + R.A:=A; + R.B:=B; + Result:=R; + end; end; end; @@ -814,8 +1071,14 @@ Var ConversionError : Integer; i: Int64; S: String; + Ref: TResolvedReference; + BuiltInProc: TResElDataBuiltInProc; begin + {$IFDEF VerbosePas2JS} + str(El.Kind,S); + writeln('TPasToJSConverter.ConvertPrimitiveExpression El=',GetObjName(El),' Context=',GetObjName(AContext),' El.Kind=',S); + {$ENDIF} Result:=Nil; case El.Kind of pekString: @@ -863,6 +1126,30 @@ begin end; pekIdent: begin + if El.CustomData is TResolvedReference then + begin + Ref:=TResolvedReference(El.CustomData); + if [rrfNewInstance,rrfFreeInstance]*Ref.Flags<>[] then + begin + // call constructor, destructor + Result:=CreateNewFreeInstanceExpr(Ref,AContext); + exit; + end; + //writeln('TPasToJSConverter.ConvertPrimitiveExpression pekIdent TResolvedReference ',GetObjName(Ref.Declaration),' ',GetObjName(Ref.Declaration.CustomData)); + if Ref.Declaration.CustomData is TResElDataBuiltInProc then + begin + BuiltInProc:=TResElDataBuiltInProc(Ref.Declaration.CustomData); + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.ConvertPrimitiveExpression ',Ref.Declaration.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn]); + {$ENDIF} + case BuiltInProc.BuiltIn of + bfExit: Result:=ConvertBuiltInExit(El,AContext); + else + RaiseNotSupported(El,AContext,20161130164955,'built in proc '+ResolverBuiltInProcNames[BuiltInProc.BuiltIn]); + end; + if Result<>nil then exit; + end; + end; Result:=ConvertIdentifierExpr(El,AContext); end; else @@ -875,15 +1162,19 @@ function TPasToJSConverter.ConvertIdentifierExpr(El: TPrimitiveExpr; var Decl: TPasElement; Name: String; + Ref: TResolvedReference; + Call: TJSCallExpression; + Proc: TPasProcedure; begin if AContext=nil then ; if El.Kind<>pekIdent then RaiseInconsistency(20161024191255); if El.CustomData is TResolvedReference then begin - Decl:=TResolvedReference(El.CustomData).Declaration; + Ref:=TResolvedReference(El.CustomData); + Decl:=Ref.Declaration; {$IFDEF VerbosePas2JS} - writeln('TPasToJSConverter.ConvertIdentifierExpr ',GetObjName(El),' Decl=',GetObjName(Decl)); + writeln('TPasToJSConverter.ConvertIdentifierExpr ',GetObjName(El),' Decl=',GetObjName(Decl),' Decl.Parent=',GetObjName(Decl.Parent)); {$ENDIF} if Decl is TPasModule then Name:='pas.'+TransformModuleName(TPasModule(Decl),AContext) @@ -891,14 +1182,23 @@ begin Name:=ResolverResultVar else begin - Name:=TransformVariableName(Decl,AContext); - {$IFDEF VerbosePas2JS} - writeln('TPasToJSConverter.ConvertIdentifierExpr Decl.Parent=',GetObjName(Decl.Parent)); - {$ENDIF} - Name:=CreateReferencePath(Decl,AContext)+Name; + Name:=CreateReferencePath(Decl,AContext,rpkPathAndName); end; - // ToDo: use TJSDotMemberExpression for dots Result:=CreateIdentifierExpr(Name,El); + if (rrfImplicitCallWithoutParams in Ref.Flags) then + begin + // create a call with default parameters + Call:=nil; + try + Proc:=Ref.Declaration as TPasProcedure; + CreateProcedureCall(Call,nil,Proc,AContext); + Call.Expr:=Result; + Result:=Call; + finally + if Result<>Call then + Call.Free; + end; + end; end else if AContext.Resolver<>nil then RaiseIdentifierNotFound(El.Value,El,20161024191306) @@ -936,14 +1236,118 @@ end; function TPasToJSConverter.ConvertInheritedExpression(El: TInheritedExpr; AContext: TConvertContext): TJSElement; + + function CreateAncestorCall(ParentEl: TPasElement; Apply: boolean; + AncestorProc: TPasProcedure; ParamsExpr: TParamsExpr): TJSElement; + var + FunName: String; + Call: TJSCallExpression; + begin + Result:=nil; + FunName:=CreateReferencePath(AncestorProc,AContext,rpkPathAndName,true); + if Apply then + // create "ancestor.funcname.apply(this,arguments)" + FunName:=FunName+'.apply' + else + // create "ancestor.funcname.call(this,param1,param2,...)" + FunName:=FunName+'.call'; + Call:=nil; + try + Call:=TJSCallExpression(CreateElement(TJSCallExpression,ParentEl)); + Call.Args:=TJSArguments(CreateElement(TJSArguments,ParentEl)); + Call.Expr:=CreateIdentifierExpr(FunName,ParentEl); + Call.Args.Elements.AddElement.Expr:=CreateBuiltInIdentifierExpr('this'); + if Apply then + Call.Args.Elements.AddElement.Expr:=CreateBuiltInIdentifierExpr('arguments') + else + CreateProcedureCall(Call,ParamsExpr,AncestorProc,AContext); + Result:=Call; + finally + if Result=nil then + Call.Free; + end; + end; + var - je: TJSPrimaryExpressionIdent; + Right: TPasExpr; + Ref: TResolvedReference; + PrimExpr: TPrimitiveExpr; + AncestorProc: TPasProcedure; + ParamsExpr: TParamsExpr; begin + Result:=nil; + {$IFDEF EnableOldClass} if AContext=nil then ; - if El=nil then; - je := CreateIdentifierExpr('_super',El); - Result := je; - // ToDo: TInheritedExpr = class(TPasExpr) + Result := CreateIdentifierExpr('_super',El); + {$ELSE} + if (El.Parent is TBinaryExpr) and (TBinaryExpr(El.Parent).OpCode=eopNone) + and (TBinaryExpr(El.Parent).left=El) then + begin + // "inherited " + AncestorProc:=nil; + ParamsExpr:=nil; + Right:=TBinaryExpr(El.Parent).right; + if Right.ClassType=TPrimitiveExpr then + begin + PrimExpr:=TPrimitiveExpr(Right); + Ref:=PrimExpr.CustomData as TResolvedReference; + if rrfImplicitCallWithoutParams in Ref.Flags then + begin + // inherited + // -> create "AncestorProc.call(this,defaultargs)" + AncestorProc:=Ref.Declaration as TPasProcedure; + end + else + begin + // inherited + // all variables have unique names -> simply access it + Result:=ConvertPrimitiveExpression(PrimExpr,AContext); + exit; + end; + end + else if Right.ClassType=TParamsExpr then + begin + ParamsExpr:=TParamsExpr(Right); + if ParamsExpr.Kind=pekFuncParams then + begin + if ParamsExpr.Value is TPrimitiveExpr then + begin + // inherited (args) + // -> create "AncestorProc.call(this,args,defaultargs)" + PrimExpr:=TPrimitiveExpr(ParamsExpr.Value); + Ref:=PrimExpr.CustomData as TResolvedReference; + AncestorProc:=Ref.Declaration as TPasProcedure; + end; + end + else + begin + // inherited [] + // all variables have unique names -> simply access it + Result:=ConvertElement(Right,AContext); + exit; + end; + end; + if AncestorProc=nil then + begin + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.ConvertInheritedExpression Right=',GetObjName(Right)); + {$ENDIF} + RaiseNotSupported(El,AContext,20170201190824); + end; + //writeln('TPasToJSConverter.ConvertInheritedExpression Func=',GetObjName(FuncContext.PasElement)); + Result:=CreateAncestorCall(Right,false,AncestorProc,ParamsExpr); + end + else + begin + // "inherited;" + if El.CustomData=nil then + exit; // "inherited;" when there is no AncestorProc proc -> silently ignore + // create "AncestorProc.apply(this,arguments)" + Ref:=TResolvedReference(El.CustomData); + AncestorProc:=Ref.Declaration as TPasProcedure; + Result:=CreateAncestorCall(El,true,AncestorProc,nil); + end; + {$ENDIF} end; function TPasToJSConverter.ConvertSelfExpression(El: TSelfExpr; @@ -959,19 +1363,21 @@ function TPasToJSConverter.ConvertParamsExpression(El: TParamsExpr; Var b: TJSBracketMemberExpression; - C : TJSCallExpression; - I : Integer; + Call : TJSCallExpression; E : TJSElement; ok: Boolean; Ref: TResolvedReference; BuiltInProc: TResElDataBuiltInProc; - + Elements: TJSArrayLiteralElements; + TargetProc: TPasProcedure; begin Result:=Nil; Case El.Kind of pekFuncParams : begin //writeln('TPasToJSConverter.ConvertParamsExpression START pekFuncParams ',GetObjName(El.CustomData),' ',GetObjName(El.Value.CustomData)); + Call:=nil; + TargetProc:=nil; if El.Value.CustomData is TResolvedReference then begin Ref:=TResolvedReference(El.Value.CustomData); @@ -983,29 +1389,47 @@ begin writeln('TPasToJSConverter.ConvertParamsExpression ',Ref.Declaration.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn]); {$ENDIF} case BuiltInProc.BuiltIn of + bfLength: Result:=ConvertBuiltInLength(El,AContext); + bfSetLength: Result:=ConvertBuiltInSetLength(El,AContext); + bfExit: Result:=ConvertBuiltInExit(El,AContext); bfInc,bfDec: Result:=ConvertBuiltInIncDec(El,AContext); + else + RaiseNotSupported(El,AContext,20161130164955,'built in proc '+ResolverBuiltInProcNames[BuiltInProc.BuiltIn]); end; if Result<>nil then exit; - end; + end + else if Ref.Declaration is TPasProcedure then + TargetProc:=TPasProcedure(Ref.Declaration); + if [rrfNewInstance,rrfFreeInstance]*Ref.Flags<>[] then + // call constructor, destructor + Call:=CreateNewFreeInstanceExpr(Ref,AContext); end; - C:=TJSCallExpression(CreateElement(TJSCallExpression,El)); + if Call=nil then + Call:=TJSCallExpression(CreateElement(TJSCallExpression,El)); ok:=false; try - C.Expr:=ConvertElement(El.Value,AContext); - if (Length(El.Params)>0) then + if Call.Expr=nil then + Call.Expr:=ConvertElement(El.Value,AContext); + if Call.Args=nil then begin - C.Args:=TJSArguments(CreateElement(TJSArguments,El)); - For I:=0 to Length(El.Params)-1 do - begin - E:=ConvertElement(El.Params[i],AContext); - C.Args.Elements.AddElement.Expr:=E; - end; + // append () + Call.Args:=TJSArguments(CreateElement(TJSArguments,El)); + Elements:=Call.Args.Elements; + end + else + begin + // insert array parameter [], e.g. this.TObject.$create("create",[]) + Elements:=Call.Args.Elements; + E:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,El)); + Elements.AddElement.Expr:=E; + Elements:=TJSArrayLiteral(E).Elements; end; + CreateProcedureCallArgs(Elements,El,TargetProc,AContext); ok:=true; finally - if not ok then FreeAndNil(C); + if not ok then FreeAndNil(Call); end; - Result:=C; + Result:=Call; end; pekArrayParams: begin @@ -1019,6 +1443,100 @@ begin end; end; +function TPasToJSConverter.ConvertBuiltInLength(El: TParamsExpr; + AContext: TConvertContext): TJSElement; +// length(array) -> rtl.length(array) +var + Call: TJSCallExpression; + Arg: TJSElement; +begin + Result:=nil; + Call:=TJSCallExpression(CreateElement(TJSCallExpression,El)); + try + // rtl.length() + Call.Expr:=CreateMemberExpression([String(RTLVarName),String(LengthFuncName)]); + Call.Args:=TJSArguments(CreateElement(TJSArguments,El)); + // pass param + Arg:=ConvertElement(El.Params[0],AContext); + Call.Args.Elements.AddElement.Expr:=Arg; + Result:=Call; + finally + if Result=nil then + Call.Free; + end; +end; + +function TPasToJSConverter.ConvertBuiltInSetLength(El: TParamsExpr; + AContext: TConvertContext): TJSElement; +// SetLength(array,newlength) +// -> rtl.setArrayLength(array,newlength,initvalue) +var + Param0: TPasExpr; + ResolvedParam0: TPasResolverResult; + ArrayType: TPasArrayType; + Call: TJSCallExpression; + ValInit: TJSElement; +begin + Result:=nil; + Param0:=El.Params[0]; + AContext.Resolver.ComputeElement(Param0,ResolvedParam0,[rcSkipTypeAlias,rcReturnFuncResult]); + {$IFDEF VerbosePasResolver} + writeln('TPasToJSConverter.ConvertBuiltInSetLength ',GetResolverResultDesc(ResolvedParam0)); + {$ENDIF} + if ResolvedParam0.TypeEl is TPasArrayType then + begin + ArrayType:=TPasArrayType(ResolvedParam0.TypeEl); + {$IFDEF VerbosePasResolver} + writeln('TPasToJSConverter.ConvertBuiltInSetLength array'); + {$ENDIF} + Call:=TJSCallExpression(CreateElement(TJSCallExpression,El)); + try + // rtl.setArrayLength() + Call.Expr:=CreateMemberExpression([String(RTLVarName),String(SetArrayLengthFuncName)]); + Call.Args:=TJSArguments(CreateElement(TJSArguments,El)); + // 1st param: array + Call.Args.Elements.AddElement.Expr:=ConvertElement(Param0,AContext); + // 2nd param: newlength + Call.Args.Elements.AddElement.Expr:=ConvertElement(El.Params[1],AContext); + // 3rd param: default value + ValInit:=CreateValInit(ArrayType.ElType,nil,Param0,AContext); + Call.Args.Elements.AddElement.Expr:=ValInit; + Result:=Call; + finally + if Result=nil then + Call.Free; + end; + exit; + end; + RaiseNotSupported(El,AContext,20170130141026); +end; + +function TPasToJSConverter.ConvertBuiltInExit(El: TPasExpr; + AContext: TConvertContext): TJSElement; +// convert "exit;" -> in a function: "return result;" in a procedure: "return;" +// convert "exit(param);" -> "return param;" +var + ProcEl: TPasElement; +begin + Result:=TJSReturnStatement(CreateElement(TJSReturnStatement,El)); + if (El is TParamsExpr) and (length(TParamsExpr(El).Params)>0) then + begin + // with parameter. convert "exit(param);" -> "return param;" + TJSReturnStatement(Result).Expr:=ConvertExpression(TParamsExpr(El).Params[0],AContext); + end + else + begin + // without parameter. + ProcEl:=El.Parent; + while not (ProcEl is TPasProcedure) do ProcEl:=ProcEl.Parent; + if ProcEl is TPasFunction then + // in a function, "return result;" + TJSReturnStatement(Result).Expr:=CreateBuiltInIdentifierExpr(ResolverResultVar) + else + ; // in a procedure, "return;" which means "return undefined;" + end; +end; + function TPasToJSConverter.ConvertBuiltInIncDec(El: TParamsExpr; AContext: TConvertContext): TJSElement; // convert inc(a,b) to a+=b @@ -1038,7 +1556,9 @@ begin L:=TJSLiteral(CreateElement(TJSLiteral,El)); L.Value.AsNumber:=1; AssignSt.Expr:=L; - end else begin + end + else + begin AssignSt.Expr:=ConvertExpression(El.Params[1],AContext); end; end; @@ -1087,6 +1607,9 @@ function TPasToJSConverter.ConvertExpression(El: TPasExpr; AContext: TConvertContext): TJSElement; begin + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.ConvertExpression El=',GetObjName(El),' Context=',GetObjName(AContext)); + {$ENDIF} Result:=Nil; if (El.ClassType=TUnaryExpr) then Result:=ConvertUnaryExpression(TUnaryExpr(El),AContext) @@ -1127,7 +1650,7 @@ function TPasToJSConverter.CreateTypeDecl(El: TPasType; begin Result:=Nil; - if (El is TPasClassType) then + if El is TPasClassType then Result := ConvertClassType(TPasClassType(El), AContext) else if El is TPasRecordType then Result := ConvertRecordType(TPasRecordType(El), AContext); @@ -1377,16 +1900,11 @@ begin if PasProc.IsForward then continue; // JavaScript does not need the forward ProcScope:=TPasProcedureScope(PasProc.CustomData); if (ProcScope.DeclarationProc<>nil) - and (PasProc.Parent.ClassType=TImplementationSection) then + and (not ProcScope.DeclarationProc.IsForward) then continue; // this proc was already converted in interface or class if ProcScope.ImplProc<>nil then P:=ProcScope.ImplProc; E:=ConvertProcedure(TPasProcedure(P),aContext); - if (Pos('.', P.Name) > 0) then - begin - AddProcedureToClass(TJSStatementList(Result), E, P as TPasProcedure); - continue; - end; end else RaiseNotSupported(P as TPasElement,AContext,20161024191434); @@ -1435,6 +1953,7 @@ TPasTypeRef = class(TPasUnresolvedTypeRef) } end; +{$IFDEF EnableOldClass} function TPasToJSConverter.ConvertClassType(El: TPasClassType; AContext: TConvertContext): TJSElement; var @@ -1506,24 +2025,120 @@ begin ret.Expr := CreateIdentifierExpr(El.Name,El); Result := unary; end; +{$ELSE} +function TPasToJSConverter.ConvertClassType(El: TPasClassType; + AContext: TConvertContext): TJSElement; +(* + type + TMyClass = class(Ancestor) + i: longint; + end; + + rtl.createClass(this,"TMyClass",Ancestor,function(){ + this.i = 0; + }); +*) +var + aCall: TJSCallExpression; + FunDecl: TJSFunctionDeclarationStatement; + FunDef: TJSFuncDef; + FunBody: TJSFunctionBody; + Src: TJSSourceElements; + ArgEx: TJSLiteral; + ok: Boolean; + FuncContext: TFunctionContext; + I: Integer; + NewEl: TJSElement; + P: TPasElement; + Scope: TPasClassScope; + Ancestor: TPasType; + +begin + if El.IsForward then + exit(nil); + + if El.CustomData is TPasClassScope then + Scope:=TPasClassScope(El.CustomData) + else + Scope:=nil; + + // create call 'rtl.createClass(' + aCall:=TJSCallExpression(CreateElement(TJSCallExpression,El)); + ok:=false; + try + aCall.Expr:=CreateMemberExpression([String(RTLVarName),String(CreateClassFuncName)]); + aCall.Args:=TJSArguments(CreateElement(TJSArguments,El)); + + // add parameter owner. 'this' for top level class. + aCall.Args.Elements.AddElement.Expr:=CreateBuiltInIdentifierExpr('this'); + + // add parameter string constant '"classname"' + ArgEx := TJSLiteral(CreateElement(TJSLiteral,El)); + ArgEx.Value.AsString:=TJSString(TransformVariableName(El.Name,AContext)); + aCall.Args.Elements.AddElement.Expr:=ArgEx; + + // add parameter ancestor. + if (Scope<>nil) and (Scope.AncestorScope<>nil) then + Ancestor:=Scope.AncestorScope.Element as TPasType + else + Ancestor:=El.AncestorType; + if Ancestor<>nil then + aCall.Args.Elements.AddElement.Expr:= + CreateIdentifierExpr(CreateReferencePath(Ancestor,AContext,rpkPathAndName),El) + else + aCall.Args.Elements.AddElement.Expr:=CreateBuiltInIdentifierExpr('null'); + + // add parameter init function 'function(){...}' + FunDecl:=TJSFunctionDeclarationStatement.Create(0,0); + aCall.Args.Elements.AddElement.Expr:=FunDecl; + FunDef:=TJSFuncDef.Create; + FunDecl.AFunction:=FunDef; + FunDef.Name:=''; + FunBody:=TJSFunctionBody.Create(0,0); + FunDef.Body:=FunBody; + Src:=TJSSourceElements(CreateElement(TJSSourceElements, El)); + FunBody.A:=Src; + + // add members + FuncContext:=TFunctionContext.Create(El,Src,AContext); + try + FuncContext.IsSingleton:=true; + FuncContext.This:=El; + For I:=0 to El.Members.Count-1 do + begin + P:=TPasElement(El.Members[i]); + writeln('TPasToJSConverter.ConvertClassType El[',i,']=',GetObjName(P)); + NewEl:=ConvertClassMember(P,FuncContext); + AddToSourceElements(Src,NewEl); + end; + finally + FuncContext.Free; + end; + + ok:=true; + finally + if not ok then + aCall.Free; + end; + + Result:=aCall; +end; +{$ENDIF} function TPasToJSConverter.ConvertClassMember(El: TPasElement; AContext: TConvertContext): TJSElement; -var - FS: TJSFunctionDeclarationStatement; begin Result := nil; - if (El is TPasProcedure) and (not (El is TPasConstructor)) then - begin - FS := CreateProcedureDeclaration(El); - Result := CreateUnary([El.Parent.FullName, 'prototype', TPasProcedure(El).Name], FS); - end; - if (El is TPasConstructor)then - begin - Result:=ConvertClassConstructor(TPasClassConstructor(El),AContext); - end; - if (El is TPasProperty) then - ConvertProperty(TPasProperty(El), AContext); + if El.ClassType=TPasConst then + Result:=CreateConstDecl(TPasConst(El),aContext) + else if El.ClassType=TPasVariable then + Result:=CreateVarDecl(TPasVariable(El),aContext) + else if El is TPasType then + Result:=CreateTypeDecl(TPasType(El),aContext) + else if El is TPasProcedure then + Result:=ConvertProcedure(TPasProcedure(El),aContext) + else + RaiseNotSupported(El,AContext,20161221233338); end; function TPasToJSConverter.ConvertClassConstructor(El: TPasConstructor; @@ -1558,10 +2173,48 @@ begin Result := CreateUnary([El.Parent.FullName, TPasProcedure(El).Name], FS); end; +procedure TPasToJSConverter.ForLoop_OnProcBodyElement(El: TPasElement; + arg: pointer); +// Called by ConvertForStatement on each element of the current proc body +// Check each element that lies behind the loop if it is reads the LoopVar +var + Data: PForLoopFindData absolute arg; +begin + if El.HasParent(Data^.ForLoop) then + Data^.FoundLoop:=true + else if Data^.FoundLoop and (not Data^.LoopVarWrite) and (not Data^.LoopVarRead) then + begin + // El comes after loop and LoopVar was not yet accessed + if (El.CustomData is TResolvedReference) + and (TResolvedReference(El.CustomData).Declaration=Data^.LoopVar) then + begin + // El refers the LoopVar + // ToDo: check write only access + Data^.LoopVarRead:=true; + end; + end; +end; + +procedure TPasToJSConverter.TryExcept_OnElement(El: TPasElement; arg: pointer); +var + Data: PTryExceptFindData absolute arg; +begin + if (El is TPasImplRaise) and (TPasImplRaise(El).ExceptObject=nil) then + Data^.HasRaiseWithoutObject:=true; +end; + constructor TPasToJSConverter.Create; begin FUseLowerCase:=true; - FImplementationName:='$impl'; + FImplementationName:=DefaultImplementationVarName; + FRTLVarName:=DefaultRTLVarName; + FCreateClassFuncName:=DefaultCreateClassFuncName; + FNewClassInstanceFuncName:=DefaultNewClassInstanceFuncName; + FFreeClassInstanceFuncName:=DefaultFreeClassInstanceFuncName; + FSetArrayLengthFuncName:=DefaultSetArrayLengthFuncName; + FLengthFuncName:=DefaultLengthFuncName; + FLoopEndVarName:=DefaultLoopEndVarName; + FAsFuncName:=DefaultAsFuncName; end; function TPasToJSConverter.ConvertProcedure(El: TPasProcedure; @@ -1571,23 +2224,28 @@ Var FS : TJSFunctionDeclarationStatement; FD : TJSFuncDef; n:Integer; - IsTopLvl: Boolean; FunName: String; AssignSt: TJSSimpleAssignStatement; FuncContext: TFunctionContext; + ProcScope: TPasProcedureScope; begin Result:=nil; - IsTopLvl:=AContext.IsSingleton; + + if El.IsAbstract then exit; {$IFDEF VerbosePas2JS} writeln('TPasToJSConverter.ConvertProcedure "',El.Name,'" ',El.Parent.ClassName); {$ENDIF} - FunName:=TransformFunctionName(El,AContext); + ProcScope:=TPasProcedureScope(El.CustomData); + if ProcScope.DeclarationProc<>nil then + FunName:=TransformVariableName(ProcScope.DeclarationProc,AContext) + else + FunName:=TransformVariableName(El,AContext); AssignSt:=nil; - if IsTopLvl then + if AContext.IsSingleton then begin AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); Result:=AssignSt; @@ -1605,12 +2263,20 @@ begin FS.AFunction:=FD; for n := 0 to El.ProcType.Args.Count - 1 do FD.Params.Add(TransformVariableName(TPasArgument(El.ProcType.Args[n]).Name,AContext)); - FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,El.Body)); + + // body -> use implementation proc + if ProcScope.ImplProc<>nil then + El:=ProcScope.ImplProc; if El.Body<>nil then begin + FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,El.Body)); FuncContext:=TFunctionContext.Create(El,FD.Body,AContext); try + if ProcScope.ClassScope<>nil then + FuncContext.This:=ProcScope.ClassScope.Element + else + FuncContext.This:=AContext.GetThis; FD.Body.A:=ConvertDeclarations(El.Body,FuncContext); finally FuncContext.Free; @@ -1658,6 +2324,8 @@ begin begin PasImpl:=TPasImplElement(El.Elements[i]); JSImpl:=ConvertElement(PasImpl,AContext); + if JSImpl=nil then + continue; // e.g. "inherited;" when there is no ancestor proc //writeln('TPasToJSConverter.ConvertImplBlockElements ',i,' ',JSImpl.ClassName); AddToStatementList(First,Last,JSImpl,PasImpl); Result:=First; @@ -1699,6 +2367,7 @@ begin begin FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,El)); FuncContext:=TFunctionContext.Create(El,FD.Body,AContext); + FuncContext.This:=AContext.GetThis; FD.Body.A:=ConvertImplBlockElements(El,FuncContext); end; ok:=true; @@ -1723,6 +2392,19 @@ Var T : TJSTryStatement; IsFin , ok: Boolean; + function NeedExceptObject: boolean; + var + Data: TTryExceptFindData; + begin + Result:=false; + if El.FinallyExcept.Elements.Count=0 then exit; + if TPasElement(El.FinallyExcept.Elements[0]) is TPasImplExceptOn then + exit(true); + Data:=Default(TTryExceptFindData); + El.FinallyExcept.ForEachCall(@TryExcept_OnElement,@Data); + Result:=Data.HasRaiseWithoutObject; + end; + begin F:=Nil; B:=ConvertImplBlockElements(El,AContext); @@ -1735,7 +2417,8 @@ begin else begin T:=TJSTryCatchStatement(CreateElement(TJSTryCatchStatement,El)); - T.Ident:=TJSString(GetExceptionObjectName(AContext)); + if NeedExceptObject then + T.Ident:=TJSString(GetExceptionObjectName(AContext)); end; ok:=true; finally @@ -2240,70 +2923,140 @@ end; function TPasToJSConverter.ConvertForStatement(El: TPasImplForLoop; AContext: TConvertContext): TJSElement; // Creates the following code: -// LoopVar=; -// for(var $loopend=; LoopVar<=$loopend; LoopVar++){} +// var $loopend=; +// for(LoopVar=; LoopVar<=$loopend; LoopVar++){} +// if(LoopVar>$loopend)LoopVar--; // this line is only added if LoopVar is read later // // The StartExpr must be executed exactly once at beginning. // The EndExpr must be executed exactly once at beginning. -// The $loopend variable is local to the FOR block. It's only used within -// the for header, so the name can be the same in other for loops. // LoopVar can be a varname or programname.varname Var ForSt : TJSForStatement; - List : TJSStatementList; + List, ListEnd: TJSStatementList; SimpleAss : TJSSimpleAssignStatement; VarDecl : TJSVarDeclaration; - Incr : TJSUNaryExpression; + Incr, Decr : TJSUNaryExpression; BinExp : TJSBinaryExpression; - ok: Boolean; VarStat: TJSVariableStatement; + IfSt: TJSIfStatement; + GTExpr: TJSRelationalExpression; + CurLoopEndVarName: String; + FuncContext: TConvertContext; + + function NeedDecrAfterLoop: boolean; + var + ResolvedVar: TPasResolverResult; + aParent: TPasElement; + ProcBody: TProcedureBody; + FindData: TForLoopFindData; + begin + Result:=true; + if AContext.Resolver=nil then exit(false); + AContext.Resolver.ComputeElement(El.VariableName,ResolvedVar,[]); + if ResolvedVar.IdentEl=nil then + exit; + if ResolvedVar.IdentEl.Parent is TProcedureBody then + begin + // loopvar is a local var + ProcBody:=TProcedureBody(ResolvedVar.IdentEl.Parent); + aParent:=El; + while true do + begin + aParent:=aParent.Parent; + if aParent=nil then exit; + if aParent is TProcedureBody then + begin + if aParent<>ProcBody then exit; + break; + end; + end; + // loopvar is a local var of the same function as where the loop is + // -> check if it is read after the loop + FindData:=Default(TForLoopFindData); + FindData.ForLoop:=El; + FindData.LoopVar:=ResolvedVar.IdentEl; + ProcBody.Body.ForEachCall(@ForLoop_OnProcBodyElement,@FindData); + if not FindData.LoopVarRead then + exit(false); + end; + end; begin Result:=Nil; BinExp:=Nil; + // get function context + FuncContext:=AContext; + while (FuncContext.Parent<>nil) and (not (FuncContext is TFunctionContext)) do + FuncContext:=FuncContext.Parent; + // create unique loopend var name + CurLoopEndVarName:=FuncContext.CreateTmpIdentifier(String(LoopEndVarName)); + // loopvar:= // for (statementlist... List:=TJSStatementList(CreateElement(TJSStatementList,El)); - Result:=List; - ok:=false; + ListEnd:=List; try - // add "LoopVar:=;" - SimpleAss:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El.StartExpr)); - SimpleAss.LHS:=ConvertElement(El.VariableName,AContext); - SimpleAss.Expr:=ConvertElement(El.StartExpr,AContext); - List.A:=SimpleAss; + // add "var $loopend=" + VarStat:=TJSVariableStatement(CreateElement(TJSVariableStatement,El)); + List.A:=VarStat; + VarDecl:=TJSVarDeclaration(CreateElement(TJSVarDeclaration,El)); + VarStat.A:=VarDecl; + VarDecl.Name:=CurLoopEndVarName; + VarDecl.Init:=ConvertElement(El.EndExpr,AContext); // add "for()" ForSt:=TJSForStatement(CreateElement(TJSForStatement,El)); List.B:=ForSt; - // add "var $loopend=" - VarStat:=TJSVariableStatement(CreateElement(TJSVariableStatement,El)); - VarDecl:=TJSVarDeclaration(CreateElement(TJSVarDeclaration,El)); - VarStat.A:=VarDecl; - VarDecl.Name:=LoopEndVarName; - VarDecl.Init:=ConvertElement(El.EndExpr,AContext); - ForSt.Init:=VarStat; + // add "LoopVar=;" + SimpleAss:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El.StartExpr)); + ForSt.Init:=SimpleAss; + SimpleAss.LHS:=ConvertElement(El.VariableName,AContext); + SimpleAss.Expr:=ConvertElement(El.StartExpr,AContext); // add "LoopVar<=$loopend" - If El.Down then + if El.Down then BinExp:=TJSRelationalExpressionGE(CreateElement(TJSRelationalExpressionGE,El.EndExpr)) else BinExp:=TJSRelationalExpressionLE(CreateElement(TJSRelationalExpressionLE,El.EndExpr)); - BinExp.A:=ConvertElement(El.VariableName,AContext); - BinExp.B:=CreateIdentifierExpr(LoopEndVarName,El.EndExpr); ForSt.Cond:=BinExp; + BinExp.A:=ConvertElement(El.VariableName,AContext); + BinExp.B:=CreateIdentifierExpr(CurLoopEndVarName,El.EndExpr); // add "LoopVar++" - If El.Down then + if El.Down then Incr:=TJSUnaryPostMinusMinusExpression(CreateElement(TJSUnaryPostMinusMinusExpression,El)) else Incr:=TJSUnaryPostPlusPlusExpression(CreateElement(TJSUnaryPostPlusPlusExpression,El)); - Incr.A:=ConvertElement(El.VariableName,AContext); ForSt.Incr:=Incr; + Incr.A:=ConvertElement(El.VariableName,AContext); // add body - ForSt.Body:=ConvertElement(El.Body,AContext); - ok:=true; + if El.Body<>nil then + ForSt.Body:=ConvertElement(El.Body,AContext); + + if NeedDecrAfterLoop then + begin + // add "if(LoopVar>$loopend)LoopVar--;" + // add "if()" + IfSt:=TJSIfStatement(CreateElement(TJSIfStatement,El)); + AddToStatementList(List,ListEnd,IfSt,El); + // add "LoopVar>$loopend" + if El.Down then + GTExpr:=TJSRelationalExpressionLT(CreateElement(TJSRelationalExpressionLT,El)) + else + GTExpr:=TJSRelationalExpressionGT(CreateElement(TJSRelationalExpressionGT,El)); + IfSt.Cond:=GTExpr; + GTExpr.A:=ConvertElement(El.VariableName,AContext); + GTExpr.B:=CreateIdentifierExpr(CurLoopEndVarName,El.EndExpr); + // add "LoopVar--" + if El.Down then + Decr:=TJSUnaryPostPlusPlusExpression(CreateElement(TJSUnaryPostPlusPlusExpression,El)) + else + Decr:=TJSUnaryPostMinusMinusExpression(CreateElement(TJSUnaryPostMinusMinusExpression,El)); + IfSt.BTrue:=Decr; + Decr.A:=ConvertElement(El.VariableName,AContext); + end; + Result:=List; finally - if not ok then - FreeAndNil(Result); + if Result=nil then + List.Free; end; end; @@ -2315,6 +3068,8 @@ Var begin E:=ConvertElement(EL.Expr,AContext); + if E=nil then + exit(nil); // e.g. "inherited;" without ancestor proc Result:=TJSExpressionStatement(CreateElement(TJSExpressionStatement,El)); TJSExpressionStatement(Result).A:=E; end; @@ -2373,6 +3128,7 @@ begin raise Exception.Create('TPasToJSConverter.RaiseInconsistency['+IntToStr(Id)+']: you found a bug'); end; +{$IFDEF EnableOldClass} function TPasToJSConverter.CreateCallStatement(const JSCallName: string; JSArgs: array of string): TJSCallExpression; var @@ -2405,6 +3161,7 @@ begin end; Result := Call; end; +{$ENDIF} function TPasToJSConverter.CreateUnary(Members: array of string; E: TJSElement): TJSUnary; var @@ -2652,21 +3409,20 @@ begin // always init with a default value to create a typed variable (faster and more readable) Lit:=TJSLiteral(CreateElement(TJSLiteral,El)); Result:=Lit; - if T is TPasAliasType then - T:=TPasAliasType(T).DestType; - if T=nil then Lit.Value.IsUndefined:=true - else if T.ClassType=TPasPointerType then + else if (T.ClassType=TPasPointerType) or (T.ClassType=TPasClassType) then Lit.Value.IsNull:=true else if T.ClassType=TPasStringType then Lit.Value.AsString:='' else if T.ClassType=TPasUnresolvedSymbolRef then begin + // ToDo: check resolver type if (CompareText(T.Name,'longint')=0) or (CompareText(T.Name,'int64')=0) or (CompareText(T.Name,'real')=0) or (CompareText(T.Name,'double')=0) + or (CompareText(T.Name,'single')=0) then Lit.Value.AsNumber:=0.0 else if (CompareText(T.Name,'boolean')=0) @@ -2713,35 +3469,122 @@ function TPasToJSConverter.CreateTypeRef(El: TPasType; AContext: TConvertContext var Name: String; begin - Name:=TransformVariableName(El.Name,AContext); {$IFDEF VerbosePas2JS} writeln('TPasToJSConverter.CreateTypeRef El="',GetObjName(El),'" El.Parent=',GetObjName(El.Parent)); {$ENDIF} - Name:=CreateReferencePath(El,AContext)+Name; + Name:=CreateReferencePath(El,AContext,rpkPathAndName); Result:=CreateIdentifierExpr(Name,El); end; function TPasToJSConverter.CreateReferencePath(El: TPasElement; - AContext: TConvertContext): string; + AContext: TConvertContext; Kind: TRefPathKind; Full: boolean): string; +{ Notes: + - local var, even higher lvl does not need a reference path + - 'this: + - in interface function (even nested) 'this' is the interface, + - in implementation function (even nested) 'this' is the implementation, + - in initialization 'this' is interface + - in method body 'this' is the instance + - in class method body 'this' is the class + otherwise use absolute path +} + + function IsLocalVar: boolean; + begin + Result:=false; + if El.ClassType=TPasArgument then + exit(true); + if El.ClassType=TPasResultElement then + exit(true); + if El.Parent.ClassType=TPasImplExceptOn then + exit(true); + if not (El.Parent is TProcedureBody) then exit; + // ToDo: local const are stored in interface + if El is TPasConst then + RaiseNotSupported(El,AContext,20170201164310); + Result:=true; + end; + + procedure Prepend(var aPath: string; Prefix: string); + begin + if aPath<>'' then + aPath:='.'+aPath; + aPath:=Prefix+aPath; + end; + var FoundModule: TPasModule; + This, ParentEl: TPasElement; begin Result:=''; - if El.Parent is TPasSection then + if El.Parent=nil then + RaiseNotSupported(El,AContext,20170201172141); + + writeln('IsLocalVar AAA1 ',GetObjName(El),' ',GetObjName(El.Parent)); + if not (AContext is TDotContext) then begin - FoundModule:=El.GetModule; - if FoundModule=nil then - RaiseInconsistency(20161024192755); - if AContext.GetRootModule=FoundModule then + // check if El is local var + if IsLocalVar then begin - if (ImplementationName<>'') and (El.Parent.ClassType=TImplementationSection) then - Result:=String(ImplementationName)+'.' - else - Result:='this.'; + // El is local var -> does not need path end else - Result:='pas.'+TransformModuleName(FoundModule,AContext)+'.'; + begin + This:=AContext.GetThis; + // need full path + ParentEl:=El.Parent; + while ParentEl<>nil do + begin + if ParentEl.ClassType=TImplementationSection then + begin + // element is in an implementation section + if ParentEl=This then + Prepend(Result,'this') + else + begin + FoundModule:=El.GetModule; + if FoundModule=nil then + RaiseInconsistency(20161024192755); + if AContext.GetRootModule=FoundModule then + // in same unit -> use '$impl' + Prepend(Result,String(ImplementationName)) + else + // in other unit -> use pas.unitname.$impl + Prepend(Result,'pas.'+TransformModuleName(FoundModule,AContext)+'.'+String(ImplementationName)); + end; + break; + end + else if ParentEl is TPasModule then + begin + // element is in an unit interface or program/library section + if ParentEl=This then + Prepend(Result,'this') + else + Prepend(Result,'pas.'+TransformModuleName(TPasModule(ParentEl),AContext)); + break; + end + else if (ParentEl.ClassType=TPasClassType) + or (ParentEl.ClassType=TPasRecordType) then + begin + // element is a class or record + if Full then + Prepend(Result,ParentEl.Name) + else + begin + // Pascal and JS have similar scoping rules, so we cna use 'this'. + // Special cases are handled elsewhere. + Result:='this'; + break; + end; + end; + ParentEl:=ParentEl.Parent; + end; + end; + if (Result<>'') and (Kind in [rpkPathWithDot,rpkPathAndName]) then + Result:=Result+'.'; end; + if Kind=rpkPathAndName then + Result:=Result+TransformVariableName(El,AContext); end; function TPasToJSConverter.CreateProcedureDeclaration(const El: TPasElement @@ -2758,31 +3601,114 @@ begin Result := FS; end; +procedure TPasToJSConverter.CreateProcedureCall(var Call: TJSCallExpression; + Args: TParamsExpr; TargetProc: TPasProcedure; AContext: TConvertContext); +// create a call, adding call by reference and default values +begin + if Call=nil then + Call:=TJSCallExpression(CreateElement(TJSCallExpression,Args)); + if Call.Args=nil then + Call.Args:=TJSArguments(CreateElement(TJSArguments,Args)); + CreateProcedureCallArgs(Call.Args.Elements,Args,TargetProc,AContext); +end; + +procedure TPasToJSConverter.CreateProcedureCallArgs( + Elements: TJSArrayLiteralElements; Args: TParamsExpr; + TargetProc: TPasProcedure; AContext: TConvertContext); +// Add call arguments. Handle call by reference and default values +var + ArgContext: TConvertContext; + i: Integer; + Arg: TJSElement; + TargetArgs: TFPList; + TargetArg: TPasArgument; +begin + // get context + ArgContext:=AContext; + while ArgContext is TDotContext do + ArgContext:=ArgContext.Parent; + i:=0; + // add params + if Args<>nil then + while inil then + begin + TargetArgs:=TargetProc.ProcType.Args; + while inil then + begin + // add "var E=exceptObject;" + L:=TJSStatementList(CreateElement(TJSStatementList,El.Body)); + IfSt.BTrue:=L; + V:=TJSVariableStatement(CreateElement(TJSVariableStatement,El)); + L.A:=V; + VarDecl:=TJSVarDeclaration(CreateElement(TJSVarDeclaration,El)); + V.A:=VarDecl; + VarDecl.Name:=TransformVariableName(El.VariableName,AContext); + VarDecl.Init:=CreateIdentifierExpr(GetExceptionObjectName(AContext),El); + // add statements + L.B:=ConvertElement(El.Body,AContext); + end + else + // add statements + IfSt.BTrue:=ConvertElement(El.Body,AContext); + + Result:=IfSt; + finally + if Result=nil then + IfSt.Free; + end; end; function TPasToJSConverter.ConvertStatement(El: TPasImplStatement; @@ -2843,6 +3769,9 @@ function TPasToJSConverter.ConvertElement(El: TPasElement; var C: TClass; begin + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.ConvertElement El=',GetObjName(El),' Context=',GetObjName(AContext)); + {$ENDIF} if El=nil then begin Result:=nil; @@ -2944,6 +3873,7 @@ begin // add variables FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,El)); FuncContext:=TFunctionContext.Create(El,FD.Body,AContext); + FuncContext.This:=El; FuncContext.IsSingleton:=true; First:=nil; Last:=nil; @@ -3030,7 +3960,7 @@ function TPasToJSConverter.TransformVariableName(const AName: String; begin if AContext=nil then ; if UseLowerCase then - Result:=lowercase(AName) + Result:=LowerCase(AName) else Result:=AName; end; @@ -3044,20 +3974,14 @@ begin Result:=lowercase(Result); end; -function TPasToJSConverter.TransformFunctionName(El: TPasElement; - AContext: TConvertContext): String; -begin - if AContext=nil then ; - Result:=El.Name; - if UseLowerCase then - Result:=lowercase(Result); -end; - function TPasToJSConverter.TransformModuleName(El: TPasModule; AContext: TConvertContext): String; begin if AContext=nil then ; - Result:=El.Name; + if El is TPasProgram then + Result:='program' + else + Result:=El.Name; if UseLowerCase then Result:=lowercase(Result); end; @@ -3078,4 +4002,3 @@ end; end. - diff --git a/packages/pastojs/tests/tcconverter.pp b/packages/pastojs/tests/tcconverter.pp index 2dfc6eb266..521264b046 100644 --- a/packages/pastojs/tests/tcconverter.pp +++ b/packages/pastojs/tests/tcconverter.pp @@ -108,7 +108,6 @@ type Procedure TestMemberExpressionArrayTwoDim; Procedure TestVariable; Procedure TestArrayVariable; - procedure TestClassDecleration; end; { TTestStatementConverter } @@ -374,6 +373,7 @@ Var I : TJSUnaryPostPlusPlusExpression; C : TJSRelationalExpressionLE; VS: TJSVariableStatement; + LoopEndVar: String; begin // For I:=1 to 100 do a:=b; @@ -385,24 +385,27 @@ begin F.Body:=CreateAssignStatement(); L:=TJSStatementList(Convert(F,TJSStatementList)); // Should be a list of two statements: - // i:=1; - // for(var $loopend=100; i<=$loopend; i++){ a:=b; } - A:=TJSSimpleAssignStatement(AssertElement('First in list is Init statement',TJSSimpleAssignStatement,L.A)); - AssertIdentifier('Init statement LHS is loop variable',A.LHS,'i'); - AssertLiteral('Init statement RHS is start value',A.Expr,1); + // var $loopend1=100; + // for(i=1; i<=$loopend1; i++){ a:=b; } + + // "var $loopend1=100" + LoopEndVar:=DefaultLoopEndVarName+'1'; + VS:=TJSVariableStatement(AssertElement('First in list is var '+LoopEndVar,TJSVariableStatement,L.A)); + VD:=TJSVarDeclaration(AssertElement('var '+LoopEndVar,TJSVarDeclaration,VS.A)); + AssertEquals('Correct name for '+LoopEndVar,LoopEndVar,VD.Name); + AssertLiteral('Correct end value',VD.Init,100); E:=TJSForStatement(AssertElement('Second in list is "for" statement',TJSForStatement,L.B)); - // "var $loopend=100" - VS:=TJSVariableStatement(AssertElement('var '+LoopEndVarName,TJSVariableStatement,E.Init)); - VD:=TJSVarDeclaration(AssertElement('var '+LoopEndVarName,TJSVarDeclaration,VS.A)); - AssertEquals('Correct name for '+LoopEndVarName,LoopEndVarName,VD.Name); - AssertLiteral('Correct end value',VD.Init,100); + // i:=1 + A:=TJSSimpleAssignStatement(AssertElement('Init statement',TJSSimpleAssignStatement,E.Init)); + AssertIdentifier('Init statement LHS is loop variable',A.LHS,'i'); + AssertLiteral('Init statement RHS is start value',A.Expr,1); - // i<=$loopend + // i<=$loopend1 C:=TJSRelationalExpressionLE(AssertElement('Condition is <= expression',TJSRelationalExpressionLE,E.Cond)); AssertIdentifier('Cond LHS is loop variable',C.A,'i'); - AssertIdentifier('Cond RHS is '+LoopEndVarName,C.B,LoopEndVarName); + AssertIdentifier('Cond RHS is '+LoopEndVar,C.B,LoopEndVar); // i++ I:=TJSUnaryPostPlusPlusExpression(AssertElement('Increment is ++ statement',TJSUnaryPostPlusPlusExpression,E.Incr)); @@ -422,6 +425,7 @@ Var I : TJSUnaryPostMinusMinusExpression; C : TJSRelationalExpressionGE; VS: TJSVariableStatement; + LoopEndVar: String; begin // For I:=100 downto 1 do a:=b; @@ -435,24 +439,27 @@ begin L:=TJSStatementList(Convert(F,TJSStatementList)); // Should be a list of two statements: - // i:=100; - // for(var $loopend=1; i>=$loopend; i--){ a:=b; } - A:=TJSSimpleAssignStatement(AssertElement('First in list is Init statement',TJSSimpleAssignStatement,L.A)); - AssertIdentifier('Init statement LHS is loop variable',A.LHS,'i'); - AssertLiteral('Init statement RHS is start value',A.Expr,100); + // var $loopend1=1; + // for(i=100; i>=$loopend1; i--){ a:=b; } + + // "var $loopend1=1" + LoopEndVar:=DefaultLoopEndVarName+'1'; + VS:=TJSVariableStatement(AssertElement('var '+LoopEndVar,TJSVariableStatement,L.A)); + VD:=TJSVarDeclaration(AssertElement('var '+LoopEndVar,TJSVarDeclaration,VS.A)); + AssertEquals('Correct name for '+LoopEndVar,LoopEndVar,VD.Name); + AssertLiteral('Correct end value',VD.Init,1); E:=TJSForStatement(AssertElement('Second in list is "for" statement',TJSForStatement,L.B)); - // "var $loopend=1" - VS:=TJSVariableStatement(AssertElement('var '+LoopEndVarName,TJSVariableStatement,E.Init)); - VD:=TJSVarDeclaration(AssertElement('var '+LoopEndVarName,TJSVarDeclaration,VS.A)); - AssertEquals('Correct name for '+LoopEndVarName,LoopEndVarName,VD.Name); - AssertLiteral('Correct end value',VD.Init,1); + // i=100; + A:=TJSSimpleAssignStatement(AssertElement('First in list is Init statement',TJSSimpleAssignStatement,E.Init)); + AssertIdentifier('Init statement LHS is loop variable',A.LHS,'i'); + AssertLiteral('Init statement RHS is start value',A.Expr,100); - // i>=$loopend + // i>=$loopend1 C:=TJSRelationalExpressionGE(AssertElement('Condition is >= expression',TJSRelationalExpressionGE,E.Cond)); AssertIdentifier('Cond LHS is loop variable',C.A,'i'); - AssertIdentifier('Cond RHS is '+LoopEndVarName,C.B,LoopEndVarName); + AssertIdentifier('Cond RHS is '+LoopEndVar,C.B,LoopEndVar); // i-- I:=TJSUnaryPostMinusMinusExpression(AssertElement('Increment is -- statement',TJSUnaryPostMinusMinusExpression,E.Incr)); @@ -596,7 +603,7 @@ Procedure TTestStatementConverter.TestTryExceptStatement; Var T : TPasImplTry; F : TPasImplTryExcept; - El : TJSTryFinallyStatement; + El : TJSTryCatchStatement; L : TJSStatementList; begin @@ -605,7 +612,7 @@ begin T.AddElement(CreateAssignStatement('a','b')); F:=T.AddExcept; F.AddElement(CreateAssignStatement('b','c')); - El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement)); + El:=TJSTryCatchStatement(Convert(T,TJSTryCatchStatement)); L:=AssertListStatement('try..except block is statement list',El.Block); AssertAssignStatement('Correct assignment in try..except block',L.A,'a','b'); AssertNull('No second statement',L.B); @@ -621,7 +628,7 @@ Var T : TPasImplTry; F : TPasImplTryExcept; O : TPasImplExceptOn; - El : TJSTryFinallyStatement; + El : TJSTryCatchStatement; L : TJSStatementList; I : TJSIfStatement; IC : TJSRelationalExpressionInstanceOf; @@ -647,7 +654,7 @@ begin O:=F.AddExceptOn('E','Exception'); O.Body:=CreateAssignStatement('b','c'); // Convert - El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement)); + El:=TJSTryCatchStatement(Convert(T,TJSTryCatchStatement)); AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident)); L:=AssertListStatement('try..except block is statement list',El.BCatch); AssertNull('No second statement',L.B); @@ -669,7 +676,7 @@ Var T : TPasImplTry; F : TPasImplTryExcept; O : TPasImplExceptOn; - El : TJSTryFinallyStatement; + El : TJSTryCatchStatement; L : TJSStatementList; I : TJSIfStatement; IC : TJSRelationalExpressionInstanceOf; @@ -695,7 +702,7 @@ begin O:=F.AddExceptOn('E','Exception'); O.Body:=TPasImplRaise.Create('',Nil); // Convert - El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement)); + El:=TJSTryCatchStatement(Convert(T,TJSTryCatchStatement)); AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident)); L:=AssertListStatement('try..except block is statement list',El.BCatch); AssertNull('No second statement',L.B); @@ -756,6 +763,7 @@ begin AssertNotNull('Convert returned a result',E); if not (E is TJSUnary) then Fail('Do not have unary class, but: '+E.ClassName); + AssertEquals('TTestExpressionConverter.TestUnaryExpression: wrong class',AClass.ClassName,E.ClassName); Result:=TJSUnary(E); end; @@ -1186,27 +1194,7 @@ begin A:=TJSArrayLiteral(AssertElement('Init is array literal',TJSArrayLiteral,VD.Init)); AssertEquals('No elements',0,A.Elements.Count); end; -procedure TTestExpressionConverter.TestClassDecleration; -var - C: TPasClassType; - Decl: TPasDeclarations; - Sl: TJSStatementList; - Uni: TJSUnary; - Asi: TJSSimpleAssignStatement; - pex: TJSPrimaryExpressionIdent; - Call: TJSCallExpression; -begin - Decl:=TPasDeclarations.Create('',Nil); - C:=TPasClassType.Create('myclass',Nil); - Decl.Declarations.Add(c); - Sl:=TJSStatementList(Convert(Decl,TJSStatementList)); - Uni:=TJSUnary(AssertElement('Sl.A is TJSUnary',TJSUnary,Sl.A)); - Asi:=TJSSimpleAssignStatement(AssertElement('Sl.A is TJSUnary',TJSSimpleAssignStatement,Uni.A)); - pex:=TJSPrimaryExpressionIdent(AssertElement('Asi.LHS is TJSPrimaryExpressionIdent',TJSPrimaryExpressionIdent,Asi.LHS)); - AssertEquals('Correct name','myclass',String(pex.Name)); - Call:=TJSCallExpression(AssertElement('Asi.Expr is TJSCallExpression',TJSCallExpression,Asi.Expr)); - if Call=nil then ; -end; + procedure TTestTestConverter.TestEmpty; begin AssertNotNull('Have converter',Converter); diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index c496cf74c9..b6b44a6138 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -112,6 +112,7 @@ type function GetDottedIdentifier(El: TJSElement): string; procedure CheckSource(Msg,Statements, InitStatements: string); procedure CheckDiff(Msg, Expected, Actual: string); + procedure WriteSource(aFilename: string; Row: integer = 0; Col: integer = 0); property PasProgram: TPasProgram Read FPasProgram; property Modules[Index: integer]: TTestEnginePasResolver read GetModules; property ModuleCount: integer read GetModuleCount; @@ -154,6 +155,7 @@ type Procedure TestProcedureWithoutParams; Procedure TestPrgProcVar; Procedure TestProcTwoArgs; + Procedure TestProc_DefaultValue; Procedure TestUnitProcVar; Procedure TestFunctionResult; // ToDo: overloads @@ -163,11 +165,12 @@ type Procedure TestAssignFunctionResult; Procedure TestFunctionResultInCondition; Procedure TestExit; + // ToDo: Procedure TestBreak; + // ToDo: Procedure TestContinue; + // ToDo: TestString; SetLength,Length,[],char // ToDo: pass by reference - // ToDo: procedure type - // ToDo: enums // statements @@ -179,30 +182,43 @@ type Procedure TestVarRecord; Procedure TestForLoop; Procedure TestForLoopInFunction; + Procedure TestForLoop_ReadVarAfter; + Procedure TestForLoop_Nested; Procedure TestRepeatUntil; Procedure TestAsmBlock; Procedure TestTryFinally; - // ToDo: try..except + Procedure TestTryExcept; Procedure TestCaseOf; Procedure TestCaseOf_UseSwitch; Procedure TestCaseOfNoElse; Procedure TestCaseOfNoElse_UseSwitch; Procedure TestCaseOfRange; + // arrays + Procedure TestArray; + // classes - // ToDo: var - // ToDo: inheritance - // ToDo: constructor + Procedure TestClass_TObjectDefaultConstructor; + Procedure TestClass_TObjectConstructorWithParams; + Procedure TestClass_Var; + Procedure TestClass_Method; + Procedure TestClass_Inheritance; + Procedure TestClass_AbstractMethod; + Procedure TestClass_CallInherited_NoParams; + Procedure TestClass_CallInherited_WithParams; + // ToDo: Procedure TestClass_CallInheritedConstructor; + // ToDo: overload // ToDo: second constructor // ToDo: call another constructor within a constructor - // ToDo: newinstance - // ToDo: BeforeDestruction - // ToDo: AfterConstruction + // ToDo: call class.classmethod + // ToDo: call instance.classmethod + // ToDo: property // ToDo: event // ToDo: class of + // ToDo: call classof.classmethod - // ToDo: arrays + // ToDo: procedure type end; function LinesToStr(Args: array of const): string; @@ -428,6 +444,8 @@ begin end; procedure TTestModule.ParseModule; +var + Row, Col: integer; begin FFirstPasStatement:=nil; try @@ -436,22 +454,20 @@ begin except on E: EParserError do begin + WriteSource(E.Filename,E.Row,E.Column); writeln('ERROR: TTestModule.ParseModule Parser: '+E.ClassName+':'+E.Message - +' File='+Scanner.CurFilename - +' LineNo='+IntToStr(Scanner.CurRow) - +' Col='+IntToStr(Scanner.CurColumn) + +' '+E.Filename+'('+IntToStr(E.Row)+','+IntToStr(E.Column)+')' +' Line="'+Scanner.CurLine+'"' ); raise E; end; on E: EPasResolve do begin + Engine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,Row,Col); + WriteSource(E.PasElement.SourceFilename,Row,Col); writeln('ERROR: TTestModule.ParseModule PasResolver: '+E.ClassName+':'+E.Message - +' File='+Scanner.CurFilename - +' LineNo='+IntToStr(Scanner.CurRow) - +' Col='+IntToStr(Scanner.CurColumn) - +' Line="'+Scanner.CurLine+'"' - ); + +' '+E.PasElement.SourceFilename + +'('+IntToStr(Row)+','+IntToStr(Col)+')'); raise E; end; on E: Exception do @@ -582,7 +598,7 @@ var FunBody: TJSFunctionBody; InitName: String; begin - FJSModule:=FConverter.ConvertPasElement(Module,nil) as TJSSourceElements; + FJSModule:=FConverter.ConvertPasElement(Module,Engine) as TJSSourceElements; FJSSource:=TStringList.Create; FJSSource.Text:=JSToStr(JSModule); writeln('TTestModule.ConvertModule JS:'); @@ -809,6 +825,34 @@ begin until false; end; +procedure TTestModule.WriteSource(aFilename: string; Row: integer; Col: integer + ); +var + LR: TLineReader; + CurRow: Integer; + Line: String; +begin + LR:=FileResolver.FindSourceFile(aFilename); + writeln('Testcode:-File="',aFilename,'"----------------------------------:'); + if LR=nil then + writeln('Error: file not loaded: "',aFilename,'"') + else + begin + CurRow:=0; + while not LR.IsEOF do + begin + inc(CurRow); + Line:=LR.ReadLine; + if (Row=CurRow) then + begin + write('*'); + Line:=LeftStr(Line,Col-1)+'|'+copy(Line,Col,length(Line)); + end; + writeln(Format('%:4d: ',[CurRow]),Line); + end; + end; +end; + procedure TTestModule.TestEmptyProgram; begin StartProgram(false); @@ -1347,7 +1391,7 @@ begin Add('end;'); Add('begin'); ConvertProgram; - CheckSource('TestUnitImplVar', + CheckSource('TestExit', LinesToStr([ // statements 'this.proca = function () {', ' return;', @@ -1379,7 +1423,7 @@ begin Add(' v2:longint = 3;'); Add(' v3:string = ''abc'';'); ConvertUnit; - CheckSource('TestUnitImplVar', + CheckSource('TestUnitImplVars', LinesToStr([ // statements 'var $impl = {', '};', @@ -1401,7 +1445,7 @@ begin Add(' v2:longint = 4;'); Add(' v3:string = ''abc'';'); ConvertUnit; - CheckSource('TestUnitImplVar', + CheckSource('TestUnitImplConsts', LinesToStr([ // statements 'var $impl = {', '};', @@ -1426,7 +1470,7 @@ begin Add('initialization'); Add(' r.i:=3;'); ConvertUnit; - CheckSource('TestUnitImplVar', + CheckSource('TestUnitImplRecord', LinesToStr([ // statements 'var $impl = {', '};', @@ -1458,6 +1502,49 @@ begin ])); end; +procedure TTestModule.TestProc_DefaultValue; +begin + StartProgram(false); + Add('procedure p1(i: longint = 1);'); + Add('begin'); + Add('end;'); + Add('procedure p2(i: longint = 1; c: char = ''a'');'); + Add('begin'); + Add('end;'); + Add('procedure p3(d: double = 1.0; b: boolean = false; s: string = ''abc'');'); + Add('begin'); + Add('end;'); + Add('begin'); + Add(' p1;'); + Add(' p1();'); + Add(' p1(11);'); + Add(' p2;'); + Add(' p2();'); + Add(' p2(12);'); + Add(' p2(13,''b'');'); + Add(' p3();'); + ConvertProgram; + CheckSource('TestProc_DefaultValue', + LinesToStr([ // statements + 'this.p1 = function (i) {', + '};', + 'this.p2 = function (i,c) {', + '};', + 'this.p3 = function (d,b,s) {', + '};' + ]), + LinesToStr([ // this.$main + ' this.p1(1);', + ' this.p1(1);', + ' this.p1(11);', + ' this.p2(1,"a");', + ' this.p2(1,"a");', + ' this.p2(12,"a");', + ' this.p2(13,"b");', + ' this.p3(1.0,false,"abc");' + ])); +end; + procedure TTestModule.TestFunctionInt; begin StartProgram(false); @@ -1467,7 +1554,7 @@ begin Add('end;'); Add('begin'); ConvertProgram; - CheckSource('TestProcTwoArgs', + CheckSource('TestFunctionInt', LinesToStr([ // statements 'this.test = function (a) {', ' var result = 0;', @@ -1489,7 +1576,7 @@ begin Add('end;'); Add('begin'); ConvertProgram; - CheckSource('TestProcTwoArgs', + CheckSource('TestFunctionString', LinesToStr([ // statements 'this.test = function (a) {', ' var result = "";', @@ -1538,7 +1625,7 @@ begin Add(' j:=j+i;'); Add(' end;'); ConvertProgram; - CheckSource('TestVarRecord', + CheckSource('TestForLoop', LinesToStr([ // statements 'this.i = 0;', 'this.j = 0;', @@ -1547,10 +1634,11 @@ begin LinesToStr([ // this.$main ' this.j = 0;', ' this.n = 3;', - ' this.i = 1;', - ' for (var $loopend = this.n; (this.i <= $loopend); this.i++) {', + ' var $loopend1 = this.n;', + ' for (this.i = 1; (this.i <= $loopend1); this.i++) {', ' this.j = (this.j + this.i);', - ' };' + ' };', + ' if ((this.i > $loopend1)) this.i--;' ])); end; @@ -1570,15 +1658,15 @@ begin Add('begin'); Add(' SumNumbers(3);'); ConvertProgram; - CheckSource('TestVarRecord', + CheckSource('TestForLoopInFunction', LinesToStr([ // statements 'this.sumnumbers = function (n) {', ' var result = 0;', ' var i = 0;', ' var j = 0;', ' j = 0;', - ' i = 1;', - ' for (var $loopend = n; (i <= $loopend); i++) {', + ' var $loopend1 = n;', + ' for (i = 1; (i <= $loopend1); i++) {', ' j = (j + i);', ' };', ' return result;', @@ -1589,6 +1677,69 @@ begin ])); end; +procedure TTestModule.TestForLoop_ReadVarAfter; +begin + StartProgram(false); + Add('var'); + Add(' i: longint;'); + Add('begin'); + Add(' for i:=1 to 2 do ;'); + Add(' if i=3 then ;'); + ConvertProgram; + CheckSource('TestForLoop', + LinesToStr([ // statements + 'this.i = 0;' + ]), + LinesToStr([ // this.$main + ' var $loopend1 = 2;', + ' for (this.i = 1; (this.i <= $loopend1); this.i++);', + ' if((this.i>$loopend1))this.i--;', + ' if ((this.i==3)){} ;' + ])); +end; + +procedure TTestModule.TestForLoop_Nested; +begin + StartProgram(false); + Add('function SumNumbers(n: longint): longint;'); + Add('var'); + Add(' i, j, k: longint;'); + Add('begin'); + Add(' k:=0;'); + Add(' for i:=1 to n do'); + Add(' begin'); + Add(' for j:=1 to i do'); + Add(' begin'); + Add(' k:=k+i;'); + Add(' end;'); + Add(' end;'); + Add('end;'); + Add('begin'); + Add(' SumNumbers(3);'); + ConvertProgram; + CheckSource('TestForLoopInFunction', + LinesToStr([ // statements + 'this.sumnumbers = function (n) {', + ' var result = 0;', + ' var i = 0;', + ' var j = 0;', + ' var k = 0;', + ' k = 0;', + ' var $loopend1 = n;', + ' for (i = 1; (i <= $loopend1); i++) {', + ' var $loopend2 = i;', + ' for (j = 1; (j <= $loopend2); j++) {', + ' k = (k + i);', + ' };', + ' };', + ' return result;', + '};' + ]), + LinesToStr([ // this.$main + ' this.sumnumbers(3);' + ])); +end; + procedure TTestModule.TestRepeatUntil; begin StartProgram(false); @@ -1603,7 +1754,7 @@ begin Add(' j:=j+i;'); Add(' until i>=n'); ConvertProgram; - CheckSource('TestVarRecord', + CheckSource('TestRepeatUntil', LinesToStr([ // statements 'this.i = 0;', 'this.j = 0;', @@ -1635,7 +1786,7 @@ begin Add(' end;'); Add(' i:=4;'); ConvertProgram; - CheckSource('TestAsm', + CheckSource('TestAsmBlock', LinesToStr([ // statements 'this.i = 0;' ]), @@ -1661,7 +1812,7 @@ begin Add(' i:=3'); Add(' end;'); ConvertProgram; - CheckSource('TestVarRecord', + CheckSource('TestTryFinally', LinesToStr([ // statements 'this.i = 0;' ]), @@ -1675,6 +1826,69 @@ begin ])); end; +procedure TTestModule.TestTryExcept; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class end;'); + Add(' Exception = class Msg: string; end;'); + Add(' EInvalidCast = class(Exception) end;'); + Add('var i: longint;'); + Add('begin'); + Add(' try'); + Add(' i:=1;'); + Add(' except'); + Add(' i:=2'); + Add(' end;'); + Add(' try'); + Add(' i:=3;'); + Add(' except'); + Add(' raise;'); + Add(' end;'); + Add(' try'); + Add(' i:=4;'); + Add(' except'); + Add(' on EInvalidCast do'); + Add(' raise;'); + Add(' on E: Exception do'); + Add(' if E.msg='''' then'); + Add(' raise E;'); + Add(' end;'); + ConvertProgram; + CheckSource('TestTryExcept', + LinesToStr([ // statements + 'rtl.createClass(this, "tobject", null, function () {', + '});', + 'rtl.createClass(this, "exception", this.tobject, function () {', + ' this.msg = "";', + '});', + 'rtl.createClass(this, "einvalidcast", this.exception, function () {', + '});', + 'this.i = 0;' + ]), + LinesToStr([ // this.$main + 'try {', + ' this.i = 1;', + '} catch {', + ' this.i = 2;', + '};', + 'try {', + ' this.i = 3;', + '} catch (exceptobject) {', + ' throw exceptobject;', + '};', + 'try {', + ' this.i = 4;', + '} catch (exceptobject) {', + ' if (this.einvalidcast.isPrototypeOf(exceptobject)) throw exceptobject;', + ' if (this.exception.isPrototypeOf(exceptobject)) {', + ' var e = exceptobject;', + ' if ((e.msg == "")) throw e;', + ' };', + '};' + ])); +end; + procedure TTestModule.TestCaseOf; begin StartProgram(false); @@ -1687,7 +1901,7 @@ begin Add(' i:=4'); Add(' end;'); ConvertProgram; - CheckSource('TestVarRecord', + CheckSource('TestCaseOf', LinesToStr([ // statements 'this.i = 0;' ]), @@ -1712,7 +1926,7 @@ begin Add(' i:=4'); Add(' end;'); ConvertProgram; - CheckSource('TestVarRecord', + CheckSource('TestCaseOf_UseSwitch', LinesToStr([ // statements 'this.i = 0;' ]), @@ -1738,7 +1952,7 @@ begin Add(' 1: begin i:=2; i:=3; end;'); Add(' end;'); ConvertProgram; - CheckSource('TestVarRecord', + CheckSource('TestCaseOfNoElse', LinesToStr([ // statements 'this.i = 0;' ]), @@ -1761,7 +1975,7 @@ begin Add(' 1: begin i:=2; i:=3; end;'); Add(' end;'); ConvertProgram; - CheckSource('TestVarRecord', + CheckSource('TestCaseOfNoElse_UseSwitch', LinesToStr([ // statements 'this.i = 0;' ]), @@ -1787,7 +2001,7 @@ begin Add(' else ;'); Add(' end;'); ConvertProgram; - CheckSource('TestVarRecord', + CheckSource('TestCaseOfRange', LinesToStr([ // statements 'this.i = 0;' ]), @@ -1798,6 +2012,390 @@ begin ])); end; +procedure TTestModule.TestClass_TObjectDefaultConstructor; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' public'); + Add(' constructor Create;'); + Add(' destructor Destroy;'); + Add(' end;'); + Add('constructor TObject.Create;'); + Add('begin end;'); + Add('destructor TObject.Destroy;'); + Add('begin end;'); + Add('var o: TObject;'); + Add('begin'); + Add(' o:=TObject.Create;'); + Add(' o.Destroy;'); + ConvertProgram; + CheckSource('TestClass_TObjectDefaultConstructor', + LinesToStr([ // statements + 'rtl.createClass(this,"tobject",null,function(){', + ' this.create = function(){', + ' };', + ' this.destroy = function(){', + ' };', + '});', + 'this.o = null;' + ]), + LinesToStr([ // this.$main + 'this.o = this.tobject.$create("create");', + 'this.o.$destroy("destroy");' + ])); +end; + +procedure TTestModule.TestClass_TObjectConstructorWithParams; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' public'); + Add(' constructor Create(p: longint);'); + Add(' end;'); + Add('constructor TObject.Create(p: longint);'); + Add('begin end;'); + Add('var o: TObject;'); + Add('begin'); + Add(' o:=TObject.Create(3);'); + ConvertProgram; + CheckSource('TestClass_TObjectConstructorWithParams', + LinesToStr([ // statements + 'rtl.createClass(this,"tobject",null,function(){', + ' this.create = function(p){', + ' };', + '});', + 'this.o = null;' + ]), + LinesToStr([ // this.$main + 'this.o = this.tobject.$create("create",[3]);' + ])); +end; + +procedure TTestModule.TestClass_Var; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' public'); + Add(' i: longint;'); + Add(' constructor Create(p: longint);'); + Add(' end;'); + Add('constructor TObject.Create(p: longint);'); + Add('begin'); + Add(' i:=p+3'); + Add('end;'); + Add('var o: TObject;'); + Add('begin'); + Add(' o:=TObject.Create(4);'); + Add(' o.i:=o.i+5;'); + ConvertProgram; + CheckSource('TestClass_Var', + LinesToStr([ // statements + 'rtl.createClass(this,"tobject",null,function(){', + ' this.i = 0;', + ' this.create = function(p){', + ' this.i = (p+3);', + ' };', + '});', + 'this.o = null;' + ]), + LinesToStr([ // this.$main + 'this.o = this.tobject.$create("create",[4]);', + 'this.o.i = (this.o.i + 5);' + ])); +end; + +procedure TTestModule.TestClass_Method; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' public'); + Add(' i: longint;'); + Add(' Sub: TObject;'); + Add(' constructor Create;'); + Add(' function GetIt(p: longint): TObject;'); + Add(' end;'); + Add('constructor TObject.Create; begin end;'); + Add('function TObject.GetIt(p: longint): TObject;'); + Add('begin'); + Add(' Self.i:=p+3;'); + Add(' Result:=Self.Sub;'); + Add('end;'); + Add('var o: TObject;'); + Add('begin'); + Add(' o:=TObject.Create;'); + Add(' o.GetIt(4);'); + Add(' o.Sub.Sub:=nil;'); + Add(' o.Sub.GetIt(5);'); + Add(' o.Sub.GetIt(6).Sub:=nil;'); + Add(' o.Sub.GetIt(7).GetIt(8);'); + Add(' o.Sub.GetIt(9).Sub.GetIt(10);'); + ConvertProgram; + CheckSource('TestClass_Method', + LinesToStr([ // statements + 'rtl.createClass(this,"tobject",null,function(){', + ' this.i = 0;', + ' this.sub = null;', + ' this.create = function(){', + ' };', + ' this.getit = function(p){', + ' var result = null;', + ' this.i = (p + 3);', + ' result = this.sub;', + ' return result;', + ' };', + '});', + 'this.o = null;' + ]), + LinesToStr([ // this.$main + 'this.o = this.tobject.$create("create");', + 'this.o.getit(4);', + 'this.o.sub.sub=null;', + 'this.o.sub.getit(5);', + 'this.o.sub.getit(6).sub=null;', + 'this.o.sub.getit(7).getit(8);', + 'this.o.sub.getit(9).sub.getit(10);' + ])); +end; + +procedure TTestModule.TestClass_Inheritance; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' public'); + Add(' constructor Create;'); + Add(' end;'); + Add(' TClassA = class'); + Add(' end;'); + Add(' TClassB = class(TObject)'); + Add(' procedure ProcB;'); + Add(' end;'); + Add('constructor TObject.Create; begin end;'); + Add('procedure TClassB.ProcB; begin end;'); + Add('var'); + Add(' o: TObject;'); + Add(' a: TClassA;'); + Add(' b: TClassB;'); + Add('begin'); + Add(' o:=TObject.Create;'); + Add(' a:=TClassA.Create;'); + Add(' b:=TClassB.Create;'); + Add(' if o is TClassA then ;'); + Add(' b:=o as TClassB;'); + Add(' (o as TClassB).ProcB;'); + ConvertProgram; + CheckSource('TestClass_Inheritance', + LinesToStr([ // statements + 'rtl.createClass(this,"tobject",null,function(){', + ' this.create = function () {', + ' };', + '});', + 'rtl.createClass(this,"tclassa",this.tobject,function(){', + '});', + 'rtl.createClass(this,"tclassb",this.tobject,function(){', + ' this.procb = function () {', + ' };', + '});', + 'this.o = null;', + 'this.a = null;', + 'this.b = null;' + ]), + LinesToStr([ // this.$main + 'this.o = this.tobject.$create("create");', + 'this.a = this.tclassa.$create("create");', + 'this.b = this.tclassb.$create("create");', + 'if (this.tclassa.isPrototypeOf(this.o)) {', + '};', + 'this.b = rtl.as(this.o, this.tclassb);', + 'rtl.as(this.o, this.tclassb).procb();' + ])); +end; + +procedure TTestModule.TestClass_AbstractMethod; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' public'); + Add(' procedure DoIt; virtual; abstract;'); + Add(' end;'); + Add('begin'); + ConvertProgram; + CheckSource('TestClass_AbstractMethod', + LinesToStr([ // statements + 'rtl.createClass(this,"tobject",null,function(){', + '});' + ]), + LinesToStr([ // this.$main + '' + ])); +end; + +procedure TTestModule.TestClass_CallInherited_NoParams; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure DoAbstract; virtual; abstract;'); + Add(' procedure DoVirtual; virtual;'); + Add(' procedure DoIt;'); + Add(' end;'); + Add(' TA = class'); + Add(' procedure DoAbstract; override;'); + Add(' procedure DoVirtual; override;'); + Add(' procedure DoSome;'); + Add(' end;'); + Add('procedure TObject.DoVirtual;'); + Add('begin'); + Add(' inherited; // call non existing ancestor -> ignore silently'); + Add('end;'); + Add('procedure TObject.DoIt;'); + Add('begin'); + Add('end;'); + Add('procedure TA.DoAbstract;'); + Add('begin'); + Add(' inherited DoVirtual; // call TObject.DoVirtual'); + Add('end;'); + Add('procedure TA.DoVirtual;'); + Add('begin'); + Add(' inherited; // call TObject.DoVirtual'); + Add(' inherited DoVirtual; // call TObject.DoVirtual'); + Add(' inherited DoVirtual(); // call TObject.DoVirtual'); + Add(' DoIt;'); + Add(' DoIt();'); + Add('end;'); + Add('procedure TA.DoSome;'); + Add('begin'); + Add(' inherited; // call non existing ancestor method -> silently ignore'); + Add('end;'); + Add('begin'); + ConvertProgram; + CheckSource('TestClass_CallInherited_NoParams', + LinesToStr([ // statements + 'rtl.createClass(this,"tobject",null,function(){', + ' this.dovirtual = function () {', + ' };', + ' this.doit = function () {', + ' };', + '});', + 'rtl.createClass(this, "ta", this.tobject, function () {', + ' this.doabstract = function () {', + ' pas.program.tobject.dovirtual.call(this);', + ' };', + ' this.dovirtual = function () {', + ' pas.program.tobject.dovirtual.apply(this, arguments);', + ' pas.program.tobject.dovirtual.call(this);', + ' pas.program.tobject.dovirtual.call(this);', + ' this.doit();', + ' this.doit();', + ' };', + ' this.dosome = function () {', + ' };', + '});' + ]), + LinesToStr([ // this.$main + '' + ])); +end; + +procedure TTestModule.TestClass_CallInherited_WithParams; +begin + StartProgram(false); + Add('type'); + Add(' TObject = class'); + Add(' procedure DoAbstract(a: longint; b: longint = 0); virtual; abstract;'); + Add(' procedure DoVirtual(a: longint; b: longint = 0); virtual;'); + Add(' procedure DoIt(a: longint; b: longint = 0);'); + Add(' procedure DoIt2(a: longint = 1; b: longint = 2);'); + Add(' end;'); + Add(' TA = class'); + Add(' procedure DoAbstract(a: longint; b: longint = 0); override;'); + Add(' procedure DoVirtual(a: longint; b: longint = 0); override;'); + Add(' end;'); + Add('procedure TObject.DoVirtual(a: longint; b: longint = 0);'); + Add('begin'); + Add('end;'); + Add('procedure TObject.DoIt(a: longint; b: longint = 0);'); + Add('begin'); + Add('end;'); + Add('procedure TObject.DoIt2(a: longint; b: longint = 0);'); + Add('begin'); + Add('end;'); + Add('procedure TA.DoAbstract(a: longint; b: longint = 0);'); + Add('begin'); + Add(' inherited DoVirtual(a,b); // call TObject.DoVirtual(a,b)'); + Add(' inherited DoVirtual(a); // call TObject.DoVirtual(a,0)'); + Add('end;'); + Add('procedure TA.DoVirtual(a: longint; b: longint = 0);'); + Add('begin'); + Add(' inherited; // call TObject.DoVirtual(a,b)'); + Add(' inherited DoVirtual(a,b); // call TObject.DoVirtual(a,b)'); + Add(' inherited DoVirtual(a); // call TObject.DoVirtual(a,0)'); + Add(' DoIt(a,b);'); + Add(' DoIt(a);'); + Add(' DoIt2(a);'); + Add(' DoIt2;'); + Add('end;'); + Add('begin'); + ConvertProgram; + CheckSource('TestClass_CallInherited_WithParams', + LinesToStr([ // statements + 'rtl.createClass(this,"tobject",null,function(){', + ' this.dovirtual = function (a,b) {', + ' };', + ' this.doit = function (a,b) {', + ' };', + ' this.doit2 = function (a,b) {', + ' };', + '});', + 'rtl.createClass(this, "ta", this.tobject, function () {', + ' this.doabstract = function (a,b) {', + ' pas.program.tobject.dovirtual.call(this,a,b);', + ' pas.program.tobject.dovirtual.call(this,a,0);', + ' };', + ' this.dovirtual = function (a,b) {', + ' pas.program.tobject.dovirtual.apply(this, arguments);', + ' pas.program.tobject.dovirtual.call(this,a,b);', + ' pas.program.tobject.dovirtual.call(this,a,0);', + ' this.doit(a,b);', + ' this.doit(a,0);', + ' this.doit2(a,2);', + ' this.doit2(1,2);', + ' };', + '});' + ]), + LinesToStr([ // this.$main + '' + ])); +end; + +procedure TTestModule.TestArray; +begin + StartProgram(false); + Add('type'); + Add(' TArrayInt = array of longint;'); + Add('var'); + Add(' a: TArrayInt;'); + Add('begin'); + Add(' SetLength(a,3);'); + Add(' a[0]:=4;'); + Add(' a[1]:=length(a)+a[0];'); + ConvertProgram; + CheckSource('TestArray', + LinesToStr([ // statements + 'this.a = [];' + ]), + LinesToStr([ // this.$main + 'rtl.setArrayLength(this.a,3,0);', + 'this.a[0]=4;', + 'this.a[1]=(rtl.length(this.a)+this.a[0]);' + ])); +end; + Initialization RegisterTests([TTestModule]); end.