paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 07:09:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Mattias Gaertner:

Browse Source 
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 -
This commit is contained in:
michael 2017-02-04 11:26:59 +00:00
parent a9888eba70
commit 393b4caba2
11 changed files with 2907 additions and 772 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
packages/fcl-js/src/jswriter.pp
View File

@ -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);

519
packages/fcl-passrc/src/pasresolver.pp
View File

@ -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<x>
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

112
packages/fcl-passrc/src/pparser.pp
View File

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

18
packages/fcl-passrc/src/pscanner.pp
View File

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

27
packages/fcl-passrc/tests/tcclasstype.pas
View File

@ -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');

780
packages/fcl-passrc/tests/tcresolver.pas
View File

File diff suppressed because it is too large Load Diff

2
packages/fcl-passrc/tests/tcstatements.pas
View File

@ -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;']);

2
packages/fcl-passrc/tests/testpassrc.lpi
View File

@ -30,7 +30,7 @@
<RunParams>
<local>
<FormatVersion Value="1"/>
<CommandLineParams Value="--suite=TTestExpressions.TestUnaryDoubleDeref"/>
<CommandLineParams Value="--suite=TTestStatementParser.TestCaseElseNoSemicolon"/>
</local>
</RunParams>
<RequiredPackages Count="1">

1419
packages/pastojs/src/fppas2js.pp
View File

File diff suppressed because it is too large Load Diff

92
packages/pastojs/tests/tcconverter.pp
View File

@ -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);

678
packages/pastojs/tests/tcmodules.pas
View File

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