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

* Patch from Mattias Gaertner: Record support, detect duplicate identifiers, bug fixes

Browse Source 
git-svn-id: trunk@34520 -
This commit is contained in:
michael 2016-09-13 08:01:37 +00:00
parent 97a4c7b9f7
commit a55c176bef
16 changed files with 1740 additions and 247 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -6627,6 +6627,7 @@ packages/pastojs/Makefile.fpc svneol=native#text/plain
packages/pastojs/fpmake.pp svneol=native#text/plain
packages/pastojs/src/fppas2js.pp svneol=native#text/plain
packages/pastojs/tests/tcconverter.pp svneol=native#text/plain
packages/pastojs/tests/tcmodules.pas svneol=native#text/plain
packages/pastojs/tests/testpas2js.lpi svneol=native#text/plain
packages/pastojs/tests/testpas2js.pp svneol=native#text/plain
packages/pastojs/todo.txt svneol=native#text/plain

2
packages/fcl-js/src/jstree.pp
View File

@ -120,7 +120,7 @@ Type
Constructor Create;
Destructor Destroy; override;
Property Params : TStrings Read FParams Write SetParams;
Property Body : TJSFunctionBody Read FBody Write FBody;
Property Body : TJSFunctionBody Read FBody Write FBody; // can be nil
Property Name : TJSString Read FName Write FName;
Property IsEmpty : Boolean Read FIsEmpty Write FIsEmpty;
end;

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

@ -474,15 +474,17 @@ begin
if Not (C or FD.IsEmpty) then
begin
Writeln('');
indent;
Indent;
end;
if Assigned(FD.Body) then
begin
FSkipBrackets:=True;
//writeln('TJSWriter.WriteFuncDef '+FD.Body.ClassName);
WriteJS(FD.Body);
If (Assigned(FD.Body.A))
and (not (FD.Body.A is TJSStatementList))
and (not (FD.Body.A is TJSSourceElements))
and (not (FD.Body.A is TJSEmptyBlockStatement))
then
if C then
Write('; ')
@ -493,7 +495,7 @@ begin
Write('}')
else
begin
undent;
Undent;
Write('}'); // do not writeln
end;
end;
@ -697,14 +699,20 @@ Var
LastEl: TJSElement;
begin
//write('TJSWriter.WriteStatementList '+BoolToStr(FSkipBrackets,true));
//if El.A<>nil then write(' El.A='+El.A.ClassName) else write(' El.A=nil');
//if El.B<>nil then write(' El.B='+El.B.ClassName) else write(' El.B=nil');
//writeln(' ');
C:=(woCompact in Options);
B:= Not FSkipBrackets;
if B then
begin
Write('{');
Indent;
if not C then writeln('');
end;
if Assigned(El.A) then
if Assigned(El.A) and (El.A.ClassType<>TJSEmptyBlockStatement) then
begin
WriteJS(El.A);
LastEl:=El.A;
@ -726,8 +734,8 @@ begin
end;
if B then
begin
Write('}');
if not C then writeln('');
Undent;
Write('}'); // do not writeln
end;
end;
@ -865,7 +873,10 @@ begin
begin
Write('do ');
if Assigned(El.Body) then
begin
FSkipBrackets:=false;
WriteJS(El.Body);
end;
Write(' while (');
If Assigned(El.Cond) then
WriteJS(EL.Cond);
@ -1052,7 +1063,8 @@ end;
procedure TJSWriter.WriteFunctionBody(El: TJSFunctionBody);
begin
if Assigned(El.A) then
//writeln('TJSWriter.WriteFunctionBody '+El.A.ClassName+' FSkipBrackets='+BoolToStr(FSkipBrackets,'true','false'));
if Assigned(El.A) and (not (El.A is TJSEmptyBlockStatement)) then
WriteJS(El.A);
end;

6
packages/fcl-js/tests/tcwriter.pp
View File

@ -1399,7 +1399,7 @@ Var
begin
// Writer.Options:=[woCompact,woUseUTF8];
S:=TJSStatementList.Create(0,0);
AssertWrite('Statement list','{'+sLineBreak+'}'+sLineBreak,S);
AssertWrite('Statement list','{'+sLineBreak+'}',S);
end;
Procedure TTestStatementWriter.TestStatementListEmptyCompact;
@ -1420,7 +1420,7 @@ begin
// Writer.Options:=[woCompact,woUseUTF8];
S:=TJSStatementList.Create(0,0);
S.A:=CreateAssignment(nil);
AssertWrite('Statement list','{'+sLineBreak+'a = b;'+sLineBreak+'}'+sLineBreak,S);
AssertWrite('Statement list','{'+sLineBreak+'a = b;'+sLineBreak+'}',S);
end;
Procedure TTestStatementWriter.TestStatementListOneStatementCompact;
@ -1444,7 +1444,7 @@ begin
S:=TJSStatementList.Create(0,0);
S.A:=CreateAssignment(nil);
S.B:=CreateAssignment(nil);
AssertWrite('Statement list','{'+sLineBreak+'a = b;'+sLineBreak+'a = b;'+sLineBreak+'}'+sLineBreak,S);
AssertWrite('Statement list','{'+sLineBreak+'a = b;'+sLineBreak+'a = b;'+sLineBreak+'}',S);
end;
Procedure TTestStatementWriter.TestStatementListTwoStatementsCompact;

5
packages/fcl-js/tests/testjs.lpr
View File

@ -3,7 +3,10 @@ program testjs;
{$mode objfpc}{$H+}
uses
cwstring,Classes, consoletestrunner, tcscanner, jsparser, jsscanner, jstree, jsbase,
{$IFDEF Unix}
cwstring,
{$ENDIF}
Classes, consoletestrunner, tcscanner, jsparser, jsscanner, jstree, jsbase,
tcparser, jswriter, tcwriter, jstoken;
var

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

@ -38,9 +38,12 @@
- case of
- try..finally..except, on, else, raise
- for loop
- spot duplicates
ToDo:
- spot duplicates
- records - TPasRecordType,
- variant - TPasVariant
- const TRecordValues
- check if types only refer types
- nested forward procs, nested must be resolved before proc body
- program/library/implementation forward procs
@ -49,9 +52,6 @@
- enums - TPasEnumType, TPasEnumValue
- propagate to parent scopes
- ranges TPasRangeType
- records - TPasRecordType,
- variant - TPasVariant
- const TRecordValues
- arrays TPasArrayType
- const TArrayValues
- pointer TPasPointerType
@ -102,6 +102,7 @@ const
nIncompatibleTypeArgNo = 3006;
nIncompatibleTypeArgNoVarParamMustMatchExactly = 3007;
nVariableIdentifierExpected = 3008;
nDuplicateIdentifier = 3009;
// resourcestring patterns of messages
resourcestring
@ -113,6 +114,7 @@ resourcestring
sIncompatibleTypeArgNo = 'Incompatible type arg no. %s: Got "%s", expected "%s"';
sIncompatibleTypeArgNoVarParamMustMatchExactly = 'Incompatible type arg no. %s: Got "%s", expected "%s". Var param must match exactly.';
sVariableIdentifierExpected = 'Variable identifier expected';
sDuplicateIdentifier = 'Duplicate identifier "%s" at %s';
type
TResolveBaseType = (
@ -388,6 +390,11 @@ type
TPasProcedureScope = Class(TPasIdentifierScope)
end;
{ TPasRecordScope }
TPasRecordScope = Class(TPasIdentifierScope)
end;
{ TPasExceptOnScope }
TPasExceptOnScope = Class(TPasIdentifierScope)
@ -427,6 +434,17 @@ type
property CurModule: TPasModule read FCurModule write SetCurModule;
end;
{ TPasSubRecordScope }
TPasSubRecordScope = Class(TPasSubScope)
public
RecordScope: TPasRecordScope;
function FindIdentifier(const Identifier: String): TPasIdentifier; override;
procedure IterateElements(const aName: string;
const OnIterateElement: TIterateScopeElement; Data: Pointer;
var Abort: boolean); override;
end;
TPasResolvedKind = (
rkNone,
rkIdentifier, // IdentEl is a type, var, const, property, proc, etc, built-in types have IdentEl=nil
@ -492,18 +510,23 @@ type
protected
procedure SetCurrentParser(AValue: TPasParser); override;
procedure CheckTopScope(ExpectedClass: TPasScopeClass);
function AddIdentifier(Scope: TPasIdentifierScope;
const aName: String; El: TPasElement;
const Kind: TPasIdentifierKind): TPasIdentifier; virtual;
procedure AddModule(El: TPasModule);
procedure AddSection(El: TPasSection);
procedure AddType(El: TPasType);
Procedure AddRecordType(El: TPasRecordType);
procedure AddVariable(El: TPasVariable);
procedure AddProcedure(El: TPasProcedure);
procedure AddArgument(El: TPasArgument);
procedure AddFunctionResult(El: TPasResultElement);
procedure AddExceptOn(El: TPasImplExceptOn);
procedure StartProcedureBody(El: TProcedureBody);
procedure FinishModule;
procedure FinishModule(CurModule: TPasModule);
procedure FinishUsesList;
procedure FinishTypeSection;
procedure FinishTypeDef(El: TPasType);
procedure FinishProcedure;
procedure FinishProcedureHeader;
procedure FinishExceptOnExpr;
@ -534,9 +557,10 @@ type
procedure IterateElements(const aName: string;
const OnIterateElement: TIterateScopeElement; Data: Pointer;
var Abort: boolean); virtual;
procedure FinishScope(ScopeType: TPasScopeType); override;
procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); override;
class procedure UnmangleSourceLineNumber(LineNumber: integer;
out Line, Column: integer);
class function GetElementSourcePosStr(El: TPasElement): string;
procedure Clear; virtual;
procedure AddObjFPCBuiltInIdentifiers(BaseTypes: TResolveBaseTypes = btAllStandardTypes);
function CreateReference(DeclEl, RefEl: TPasElement): TResolvedReference; virtual;
@ -810,6 +834,21 @@ begin
ResolvedType.ExprEl:=ExprEl;
end;
{ TPasSubRecordScope }
function TPasSubRecordScope.FindIdentifier(const Identifier: String
): TPasIdentifier;
begin
Result:=RecordScope.FindIdentifier(Identifier);
end;
procedure TPasSubRecordScope.IterateElements(const aName: string;
const OnIterateElement: TIterateScopeElement; Data: Pointer;
var Abort: boolean);
begin
RecordScope.IterateElements(aName, OnIterateElement, Data, Abort);
end;
{ TPasIdentifier }
procedure TPasIdentifier.SetElement(AValue: TPasElement);
@ -1135,12 +1174,26 @@ begin
RaiseInternalError('Expected TopScope='+ExpectedClass.ClassName+' but found '+TopScope.ClassName);
end;
procedure TPasResolver.FinishModule;
function TPasResolver.AddIdentifier(Scope: TPasIdentifierScope;
const aName: String; El: TPasElement; const Kind: TPasIdentifierKind
): TPasIdentifier;
var
Identifier, OlderIdentifier: TPasIdentifier;
begin
Identifier:=Scope.AddIdentifier(aName,El,Kind);
OlderIdentifier:=Identifier.NextSameIdentifier;
// check duplicate
if OlderIdentifier<>nil then
if (Identifier.Kind=pikSimple) or (OlderIdentifier.Kind=pikSimple) then
RaiseMsg(nDuplicateIdentifier,sDuplicateIdentifier,
[aName,GetElementSourcePosStr(OlderIdentifier.Element)],El);
Result:=Identifier;
end;
procedure TPasResolver.FinishModule(CurModule: TPasModule);
var
CurModuleClass: TClass;
CurModule: TPasModule;
begin
CurModule:=CurrentParser.CurModule;
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishModule START ',CurModule.Name);
{$ENDIF}
@ -1199,7 +1252,7 @@ begin
if (El.ClassType=TProgramSection) then
RaiseInternalError('used unit is a program: '+GetObjName(El));
Scope.AddIdentifier(El.Name,El,pikSimple);
AddIdentifier(Scope,El.Name,El,pikSimple);
// check used unit
PublicEl:=nil;
@ -1226,6 +1279,18 @@ begin
// ToDo: resolve pending forwards
end;
procedure TPasResolver.FinishTypeDef(El: TPasType);
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishTypeDef El=',GetObjName(El));
{$ENDIF}
if TopScope.Element=El then
begin
if TopScope.ClassType=TPasRecordScope then
PopScope;
end;
end;
procedure TPasResolver.FinishProcedure;
var
aProc: TPasProcedure;
@ -1244,6 +1309,7 @@ procedure TPasResolver.FinishProcedureHeader;
begin
CheckTopScope(TPasProcedureScope);
// ToDo: check class
// ToDo: check duplicate
end;
procedure TPasResolver.FinishExceptOnExpr;
@ -1260,7 +1326,7 @@ begin
Expr:=TPrimitiveExpr(El.VarExpr);
if Expr.Kind<>pekIdent then
RaiseNotYetImplemented(Expr);
TPasExceptOnScope(FTopScope).AddIdentifier(Expr.Value,Expr,pikSimple);
AddIdentifier(TPasExceptOnScope(FTopScope),Expr.Value,Expr,pikSimple);
end;
if El.TypeExpr<>nil then
ResolveExpr(El.TypeExpr);
@ -1287,6 +1353,8 @@ procedure TPasResolver.ResolveImplElement(El: TPasImplElement);
begin
//writeln('TPasResolver.ResolveImplElement ',GetObjName(El));
if El=nil then
else if El.ClassType=TPasImplBeginBlock then
ResolveImplBlock(TPasImplBeginBlock(El))
else if El.ClassType=TPasImplAssign then
begin
ResolveExpr(TPasImplAssign(El).left);
@ -1334,10 +1402,11 @@ begin
else if El.ClassType=TPasImplCommand then
begin
if TPasImplCommand(El).Command<>'' then
RaiseNotYetImplemented(El);
RaiseNotYetImplemented(El,'TPasResolver.ResolveImplElement');
end
else if El.ClassType=TPasImplAsmStatement then
else
RaiseNotYetImplemented(El);
RaiseNotYetImplemented(El,'TPasResolver.ResolveImplElement');
end;
procedure TPasResolver.ResolveImplCaseOf(CaseOf: TPasImplCaseOf);
@ -1423,6 +1492,7 @@ end;
procedure TPasResolver.ResolveBinaryExpr(El: TBinaryExpr);
begin
//writeln('TPasResolver.ResolveBinaryExpr left=',GetObjName(El.left),' right=',GetObjName(El.right),' opcode=',OpcodeStrings[El.OpCode]);
ResolveExpr(El.left);
if El.right=nil then exit;
case El.OpCode of
@ -1469,6 +1539,9 @@ var
DeclEl: TPasElement;
ModuleScope: TPasSubModuleScope;
aModule: TPasModule;
VarType: TPasType;
RecScope: TPasRecordScope;
SubScope: TPasSubRecordScope;
begin
//writeln('TPasResolver.ResolveSubIdent El.left=',GetObjName(El.left));
if El.left.ClassType=TPrimitiveExpr then
@ -1512,13 +1585,38 @@ begin
PushScope(ModuleScope);
ResolveExpr(El.right);
PopScope;
exit;
end
else if DeclEl.ClassType=TPasVariable then
begin
VarType:=TPasVariable(DeclEl).VarType;
if VarType.ClassType=TPasRecordType then
begin
RecScope:=TPasRecordType(VarType).CustomData as TPasRecordScope;
SubScope:=TPasSubRecordScope.Create;
SubScope.Owner:=Self;
SubScope.RecordScope:=RecScope;
PushScope(SubScope);
ResolveExpr(El.right);
PopScope;
exit;
end
else
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveSubIdent DeclEl=',GetObjName(DeclEl),' VarType=',GetObjName(VarType));
{$ENDIF}
end;
end;
end
else
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveSubIdent DeclEl=',GetObjName(DeclEl));
{$ENDIF}
end;
end
else
RaiseMsg(nIllegalQualifier,sIllegalQualifier,['.'],El);
end
else
RaiseMsg(nIllegalQualifier,sIllegalQualifier,['.'],El);
end;
RaiseMsg(nIllegalQualifier,sIllegalQualifier,['.'],El);
end;
procedure TPasResolver.ResolveParamsExpr(Params: TParamsExpr);
@ -1558,7 +1656,7 @@ begin
CreateReference(FindData.Found,Params.Value);
end
else
RaiseNotYetImplemented(Params,' with parameters');
RaiseNotYetImplemented(Params,'with parameters');
end;
procedure TPasResolver.AddModule(El: TPasModule);
@ -1615,7 +1713,21 @@ begin
{$ENDIF}
if not (TopScope is TPasIdentifierScope) then
RaiseInvalidScopeForElement(El);
TPasIdentifierScope(TopScope).AddIdentifier(El.Name,El,pikSimple);
AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
end;
procedure TPasResolver.AddRecordType(El: TPasRecordType);
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.AddRecordType ',GetObjName(El),' Parent=',GetObjName(El.Parent));
{$ENDIF}
if not (TopScope is TPasIdentifierScope) then
RaiseInvalidScopeForElement(El);
if El.Name<>'' then
AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
if El.Parent.ClassType<>TPasVariant then
PushScope(El,TPasRecordScope);
end;
procedure TPasResolver.AddVariable(El: TPasVariable);
@ -1626,7 +1738,7 @@ begin
{$ENDIF}
if not (TopScope is TPasIdentifierScope) then
RaiseInvalidScopeForElement(El);
TPasIdentifierScope(TopScope).AddIdentifier(El.Name,El,pikSimple);
AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
end;
procedure TPasResolver.AddProcedure(El: TPasProcedure);
@ -1636,7 +1748,7 @@ begin
{$ENDIF}
if not (TopScope is TPasIdentifierScope) then
RaiseInvalidScopeForElement(El);
TPasIdentifierScope(TopScope).AddIdentifier(El.Name,El,pikProc);
AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikProc);
PushScope(El,TPasProcedureScope);
end;
@ -1649,14 +1761,14 @@ begin
{$ENDIF}
if not (TopScope is TPasProcedureScope) then
RaiseInvalidScopeForElement(El);
TPasProcedureScope(TopScope).AddIdentifier(El.Name,El,pikSimple);
AddIdentifier(TPasProcedureScope(TopScope),El.Name,El,pikSimple);
end;
procedure TPasResolver.AddFunctionResult(El: TPasResultElement);
begin
if TopScope.ClassType<>TPasProcedureScope then
RaiseInvalidScopeForElement(El);
TPasProcedureScope(TopScope).AddIdentifier(ResolverResultVar,El,pikSimple);
AddIdentifier(TPasProcedureScope(TopScope),ResolverResultVar,El,pikSimple);
end;
procedure TPasResolver.AddExceptOn(El: TPasImplExceptOn);
@ -1727,7 +1839,7 @@ begin
writeln('TPasResolver.CreateElement ',AClass.ClassName,' Name=',AName,' Parent=',GetObjName(AParent),' (',ASrcPos.Row,',',ASrcPos.Column,')');
{$ENDIF}
if (AParent=nil) and (FRootElement<>nil)
and (not AClass.InheritsFrom(TPasUnresolvedTypeRef)) then
and (AClass<>TPasUnresolvedTypeRef) then
RaiseInternalError('TPasResolver.CreateElement more than one root element Class="'+AClass.ClassName+'" Root='+GetObjName(FRootElement));
if ASrcPos.FileName='' then
@ -1751,30 +1863,41 @@ begin
FRootElement:=Result;
// create scope
if AClass.InheritsFrom(TPasType) then
AddType(TPasType(El))
else if (AClass.ClassType=TPasVariable)
or (AClass.ClassType=TPasConst)
or (AClass.ClassType=TPasProperty) then
if (AClass=TPasVariable)
or (AClass=TPasConst)
or (AClass=TPasProperty) then
AddVariable(TPasVariable(El))
else if AClass.ClassType=TPasArgument then
else if AClass=TPasArgument then
AddArgument(TPasArgument(El))
else if AClass=TPasUnresolvedTypeRef then
else if (AClass=TPasAliasType)
or (AClass=TPasProcedureType)
or (AClass=TPasFunctionType) then
AddType(TPasType(El))
else if AClass=TPasRecordType then
AddRecordType(TPasRecordType(El))
else if AClass=TPasVariant then
else if AClass.InheritsFrom(TPasProcedure) then
AddProcedure(TPasProcedure(El))
else if AClass.ClassType=TPasResultElement then
else if AClass=TPasResultElement then
AddFunctionResult(TPasResultElement(El))
else if AClass.ClassType=TProcedureBody then
else if AClass=TProcedureBody then
StartProcedureBody(TProcedureBody(El))
else if AClass.InheritsFrom(TPasSection) then
else if AClass=TPasImplExceptOn then
AddExceptOn(TPasImplExceptOn(El))
else if AClass=TPasImplLabelMark then
else if AClass=TPasOverloadedProc then
else if (AClass=TInterfaceSection)
or (AClass=TImplementationSection)
or (AClass=TProgramSection)
or (AClass=TLibrarySection) then
AddSection(TPasSection(El))
else if AClass.InheritsFrom(TPasModule) then
else if (AClass=TPasModule)
or (AClass=TPasProgram)
or (AClass=TPasLibrary) then
AddModule(TPasModule(El))
else if AClass.InheritsFrom(TPasExpr) then
else if AClass.ClassType=TPasImplExceptOn then
AddExceptOn(TPasImplExceptOn(El))
else if AClass.InheritsFrom(TPasImplBlock) then
else if AClass.ClassType=TPasImplLabelMark then
else if AClass.ClassType=TPasOverloadedProc then
else
RaiseNotYetImplemented(El);
end;
@ -1818,13 +1941,13 @@ begin
end;
end;
procedure TPasResolver.FinishScope(ScopeType: TPasScopeType);
procedure TPasResolver.FinishScope(ScopeType: TPasScopeType; El: TPasElement);
begin
case ScopeType of
stModule: FinishModule;
stModule: FinishModule(El as TPasModule);
stUsesList: FinishUsesList;
stTypeSection: FinishTypeSection;
stTypeDef: ;
stTypeDef: FinishTypeDef(El as TPasType);
stProcedure: FinishProcedure;
stProcedureHeader: FinishProcedureHeader;
stExceptOnExpr: FinishExceptOnExpr;
@ -1846,6 +1969,18 @@ begin
end;
end;
class function TPasResolver.GetElementSourcePosStr(El: TPasElement): string;
var
Line, Column: integer;
begin
if El=nil then exit('nil');
UnmangleSourceLineNumber(El.SourceLinenumber,Line,Column);
Result:=El.SourceFilename+'('+IntToStr(Line);
if Column>0 then
Result:=Result+','+IntToStr(Column);
Result:=Result+')';
end;
destructor TPasResolver.Destroy;
begin
Clear;
@ -1876,7 +2011,7 @@ var
bt: TResolveBaseType;
begin
for bt in BaseTypes do
FDefaultScope.AddIdentifier(BaseTypeNames[bt],
AddIdentifier(FDefaultScope,BaseTypeNames[bt],
TPasUnresolvedSymbolRef.Create(BaseTypeNames[bt],nil),pikCustom);
end;
@ -1885,12 +2020,10 @@ function TPasResolver.CreateReference(DeclEl, RefEl: TPasElement
procedure RaiseAlreadySet;
var
aLine, aCol: integer;
FormerDeclEl: TPasElement;
begin
writeln('RaiseAlreadySet RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl));
UnmangleSourceLineNumber(RefEl.SourceLinenumber,aLine,aCol);
writeln(' RefEl at ',RefEl.SourceFilename,'(',aLine,',',aCol,')');
writeln(' RefEl at ',GetElementSourcePosStr(RefEl));
writeln(' RefEl.CustomData=',GetObjName(RefEl.CustomData));
if RefEl.CustomData is TResolvedReference then
begin
@ -1969,7 +2102,9 @@ begin
FScopes[FScopeCount]:=Scope;
inc(FScopeCount);
FTopScope:=Scope;
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.PushScope ScopeCount=',ScopeCount,' ',GetObjName(FTopScope),' IsDefault=',FDefaultScope=FTopScope);
{$ENDIF}
end;
procedure TPasResolver.SetLastMsg(MsgType: TMessageType; MsgNumber: integer;
@ -1997,8 +2132,13 @@ begin
end;
procedure TPasResolver.RaiseNotYetImplemented(El: TPasElement; Msg: string);
var
s: String;
begin
RaiseMsg(nNotYetImplemented,sNotYetImplemented+Msg,[GetObjName(El)],El);
s:=sNotYetImplemented;
if Msg<>'' then
s:=s+Msg;
RaiseMsg(nNotYetImplemented,s,[GetObjName(El)],El);
end;
procedure TPasResolver.RaiseInternalError(const Msg: string);

19
packages/fcl-passrc/src/pastree.pp
View File

@ -558,8 +558,7 @@ type
public
PackMode: TPackMode;
Members: TFPList; // array of TPasVariable elements
VariantName: string;
VariantType: TPasType;
VariantEl: TPasElement; // TPasVariable or TPasType
Variants: TFPList; // array of TPasVariant elements, may be nil!
Function IsPacked: Boolean;
Function IsBitPacked : Boolean;
@ -2173,8 +2172,8 @@ begin
TPasVariable(Members[i]).Release;
Members.Free;
if Assigned(VariantType) then
VariantType.Release;
if Assigned(VariantEl) then
VariantEl.Release;
if Assigned(Variants) then
begin
@ -3125,10 +3124,10 @@ begin
if Variants<>nil then
begin
temp:='case ';
if (VariantName<>'') then
temp:=Temp+variantName+' : ';
if (VariantType<>Nil) then
temp:=temp+VariantType.Name;
if (VariantEl is TPasVariable) then
temp:=Temp+VariantEl.Name+' : '+TPasVariable(VariantEl).VarType.Name
else if (VariantEl<>Nil) then
temp:=temp+VariantEl.Name;
S.Add(temp+' of');
T.Clear;
For I:=0 to Variants.Count-1 do
@ -3175,8 +3174,8 @@ begin
inherited ForEachCall(aMethodCall, Arg);
for i:=0 to Members.Count-1 do
TPasElement(Members[i]).ForEachCall(aMethodCall,Arg);
if VariantType<>nil then
VariantType.ForEachCall(aMethodCall,Arg);
if VariantEl<>nil then
VariantEl.ForEachCall(aMethodCall,Arg);
if Variants<>nil then
for i:=0 to Variants.Count-1 do
TPasElement(Variants[i]).ForEachCall(aMethodCall,Arg);

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

@ -176,7 +176,7 @@ type
function CreateFunctionType(const AName, AResultName: String; AParent: TPasElement;
UseParentAsResultParent: Boolean; const ASrcPos: TPasSourcePos): TPasFunctionType;
function FindElement(const AName: String): TPasElement; virtual; abstract;
procedure FinishScope(ScopeType: TPasScopeType); virtual;
procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); virtual;
function FindModule(const AName: String): TPasModule; virtual;
property Package: TPasPackage read FPackage;
property InterfaceOnly : Boolean Read FInterfaceOnly Write FInterFaceOnly;
@ -239,7 +239,6 @@ type
function GetVariableModifiers(Out VarMods : TVariableModifiers; Out Libname,ExportName : string): string;
function GetVariableValueAndLocation(Parent : TPasElement; Out Value : TPasExpr; Out Location: String): Boolean;
procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
procedure ParseAsmBlock(AsmBlock: TPasImplAsmStatement);
procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility);
procedure ParseClassLocalTypes(AType: TPasClassType; AVisibility: TPasMemberVisibility);
procedure ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibility: TPasMemberVisibility; Full: Boolean);
@ -251,6 +250,7 @@ type
Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Msg : String; SkipSourceInfo : Boolean = False);overload;
Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of const;SkipSourceInfo : Boolean = False);overload;
function GetProcTypeFromToken(tk: TToken; IsClass: Boolean=False ): TProcType;
procedure ParseAsmBlock(AsmBlock: TPasImplAsmStatement); virtual;
procedure ParseRecordFieldList(ARec: TPasRecordType; AEndToken: TToken; AllowMethods : Boolean);
procedure ParseRecordVariantParts(ARec: TPasRecordType; AEndToken: TToken);
function GetProcedureClass(ProcType : TProcType): TPTreeElement;
@ -658,9 +658,11 @@ begin
visDefault, ASrcPos));
end;
procedure TPasTreeContainer.FinishScope(ScopeType: TPasScopeType);
procedure TPasTreeContainer.FinishScope(ScopeType: TPasScopeType;
El: TPasElement);
begin
if ScopeType=stModule then ;
if El=nil then ;
end;
function TPasTreeContainer.FindModule(const AName: String): TPasModule;
@ -901,7 +903,7 @@ begin
if result and (pm in [pmPublic,pmForward]) then
begin
While (Parent<>Nil) and Not ((Parent is TPasClassType) or (Parent is TPasRecordType)) do
Parent:=Parent.Parent;
Parent:=Parent.Parent;
Result:=Not Assigned(Parent);
end;
end;
@ -1826,7 +1828,7 @@ begin
tkColon: // record field (a:xxx;b:yyy;c:zzz);
begin
n:=GetExprIdent(x);
x.Free;
x.Release;
r:=CreateRecordValues(AParent);
NextToken;
x:=DoParseConstValueExpression(AParent);
@ -1850,7 +1852,8 @@ begin
Result:=DoParseExpression(AParent,Result);
Exit;
end;
if CurToken<>tkBraceClose then ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
if CurToken<>tkBraceClose then
ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
NextToken;
end;
end;
@ -1984,7 +1987,7 @@ begin
If LogEvent(pleInterface) then
DoLog(mtInfo,nLogStartInterface,SLogStartInterface);
ParseInterface;
Engine.FinishScope(stModule);
Engine.FinishScope(stModule,Module);
finally
FCurModule:=nil;
end;
@ -2034,7 +2037,7 @@ begin
PP.ProgramSection := Section;
ParseOptionalUsesList(Section);
ParseDeclarations(Section);
Engine.FinishScope(stModule);
Engine.FinishScope(stModule,Module);
finally
FCurModule:=nil;
end;
@ -2063,7 +2066,7 @@ begin
PP.LibrarySection := Section;
ParseOptionalUsesList(Section);
ParseDeclarations(Section);
Engine.FinishScope(stModule);
Engine.FinishScope(stModule,Module);
finally
FCurModule:=nil;
end;
@ -2077,7 +2080,7 @@ begin
ParseUsesList(ASection)
else begin
CheckImplicitUsedUnits(ASection);
Engine.FinishScope(stUsesList);
Engine.FinishScope(stUsesList,ASection);
UngetToken;
end;
end;
@ -2201,7 +2204,7 @@ var
begin
if CurBlock=NewBlock then exit;
if CurBlock=declType then
Engine.FinishScope(stTypeDef);
Engine.FinishScope(stTypeSection,Declarations);
CurBlock:=NewBlock;
end;
@ -2540,7 +2543,7 @@ begin
ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon);
Until (CurToken=tkSemicolon);
Engine.FinishScope(stUsesList);
Engine.FinishScope(stUsesList,ASection);
end;
// Starts after the variable name
@ -2823,6 +2826,7 @@ begin
ok:=false;
try
D:=SaveComments; // This means we support only one comment per 'list'.
VarEl:=nil;
Repeat
// create the TPasVariable here, so that SourceLineNumber is correct
VarEl:=TPasVariable(CreateElement(TPasVariable,CurTokenString,Parent,AVisibility));
@ -2835,13 +2839,13 @@ begin
Until (CurToken=tkColon);
// read type
VarType := ParseComplexType(Parent);
VarType := ParseComplexType(VarEl);
for i := OldListCount to VarList.Count - 1 do
begin
VarEl:=TPasVariable(VarList[i]);
// Writeln(VarEl.Name, AVisibility);
VarEl.VarType := VarType;
VarType.Parent := VarEl;
//VarType.Parent := VarEl; // this is wrong for references types
if (i>=OldListCount) then
VarType.AddRef;
end;
@ -3231,6 +3235,7 @@ Var
CC : TCallingConvention;
PM : TProcedureModifier;
Done: Boolean;
ResultEl: TPasResultElement;
begin
// Element must be non-nil. Removed all checks for not-nil.
@ -3240,22 +3245,24 @@ begin
ptFunction,ptClassFunction:
begin
ExpectToken(tkColon);
TPasFunctionType(Element).ResultEl.ResultType := ParseType(Parent,Scanner.CurSourcePos);
ResultEl:=TPasFunctionType(Element).ResultEl;
ResultEl.ResultType := ParseType(ResultEl,Scanner.CurSourcePos);
end;
ptOperator,ptClassOperator:
begin
NextToken;
ResultEl:=TPasFunctionType(Element).ResultEl;
if (CurToken=tkIdentifier) then
begin
TPasFunctionType(Element).ResultEl.Name := CurTokenName;
ResultEl.Name := CurTokenName;
ExpectToken(tkColon);
end
else
if (CurToken=tkColon) then
TPasFunctionType(Element).ResultEl.Name := 'Result'
ResultEl.Name := 'Result'
else
ParseExc(nParserExpectedColonID,SParserExpectedColonID);
TPasFunctionType(Element).ResultEl.ResultType := ParseType(Parent,Scanner.CurSourcePos)
ResultEl.ResultType := ParseType(ResultEl,Scanner.CurSourcePos)
end;
end;
if OfObjectPossible then
@ -3343,7 +3350,7 @@ begin
ConsumeSemi;
if (ProcType in [ptOperator,ptClassOperator]) and (Parent is TPasOperator) then
TPasOperator(Parent).CorrectName;
Engine.FinishScope(stProcedureHeader);
Engine.FinishScope(stProcedureHeader,Element);
if (Parent is TPasProcedure)
and (not TPasProcedure(Parent).IsForward)
and (not TPasProcedure(Parent).IsExternal)
@ -3351,7 +3358,7 @@ begin
or (Parent.Parent is TProcedureBody))
then
ParseProcedureBody(Parent);
Engine.FinishScope(stProcedure);
Engine.FinishScope(stProcedure,Parent);
end;
// starts after the semicolon
@ -3527,13 +3534,45 @@ begin
end;
procedure TPasParser.ParseAsmBlock(AsmBlock : TPasImplAsmStatement);
begin
NextToken;
While CurToken<>tkEnd do
if po_asmwhole in Options then
begin
FTokenBufferIndex:=1;
FTokenBufferSize:=1;
FCommentsBuffer[0].Clear;
repeat
Scanner.ReadNonPascalTilEndToken(true);
case Scanner.CurToken of
tkLineEnding:
AsmBlock.Tokens.Add(Scanner.CurTokenString);
tkend:
begin
FTokenBuffer[0] := tkend;
FTokenStringBuffer[0] := Scanner.CurTokenString;
break;
end
else
begin
// missing end
FTokenBuffer[0] := tkEOF;
FTokenStringBuffer[0] := '';
end;
end;
until false;
FCurToken := FTokenBuffer[0];
FCurTokenString := FTokenStringBuffer[0];
FCurComments:=FCommentsBuffer[0];
CheckToken(tkend);
end
else
begin
AsmBlock.Tokens.Add(CurTokenText);
NextToken;
While CurToken<>tkEnd do
begin
// ToDo: allow @@end
AsmBlock.Tokens.Add(CurTokenText);
NextToken;
end;
end;
// NextToken; // Eat end.
// Do not consume end. Current token will normally be end;
@ -3563,7 +3602,7 @@ var
function CloseBlock: boolean; // true if parent reached
begin
if CurBlock.ClassType=TPasImplExceptOn then
Engine.FinishScope(stExceptOnStatement);
Engine.FinishScope(stExceptOnStatement,CurBlock);
CurBlock:=CurBlock.Parent as TPasImplBlock;
Result:=CurBlock=Parent;
end;
@ -3897,7 +3936,7 @@ begin
El:=TPasImplExceptOn(CreateElement(TPasImplExceptOn,'',CurBlock));
TPasImplExceptOn(El).VarExpr:=Left;
TPasImplExceptOn(El).TypeExpr:=Right;
Engine.FinishScope(stExceptOnExpr);
Engine.FinishScope(stExceptOnExpr,El);
CurBlock.AddElement(El);
CurBlock:=TPasImplExceptOn(El);
ExpectToken(tkDo);
@ -4184,14 +4223,14 @@ procedure TPasParser.ParseRecordFieldList(ARec: TPasRecordType;
AEndToken: TToken; AllowMethods: Boolean);
Var
VN : String;
VariantName : String;
v : TPasmemberVisibility;
Proc: TPasProcedure;
ProcType: TProcType;
Prop : TPasProperty;
Cons : TPasConst;
isClass : Boolean;
NamePos: TPasSourcePos;
begin
v:=visDefault;
isClass:=False;
@ -4256,16 +4295,20 @@ begin
begin
ARec.Variants:=TFPList.Create;
NextToken;
VN:=CurTokenString;
VariantName:=CurTokenString;
NamePos:=Scanner.CurSourcePos;
NextToken;
If CurToken=tkColon then
ARec.VariantName:=VN
begin
ARec.VariantEl:=TPasVariable(CreateElement(TPasVariable,VariantName,ARec,NamePos));
TPasVariable(ARec.VariantEl).VarType:=ParseType(ARec,Scanner.CurSourcePos);
end
else
begin
UnGetToken;
UnGetToken;
ARec.VariantEl:=ParseType(ARec,Scanner.CurSourcePos);
end;
ARec.VariantType:=ParseType(ARec,Scanner.CurSourcePos);
ExpectToken(tkOf);
ParseRecordVariantParts(ARec,AEndToken);
end;
@ -4293,6 +4336,7 @@ begin
Result.PackMode:=PackMode;
NextToken;
ParseRecordFieldList(Result,tkEnd,true);
Engine.FinishScope(stTypeDef,Result);
ok:=true;
finally
if not ok then

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

@ -328,7 +328,8 @@ type
TPOption = (
po_delphi, // Delphi mode: forbid nested comments
po_cassignments, // allow C-operators += -= *= /=
po_resolvestandardtypes // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations
po_resolvestandardtypes, // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations
po_asmwhole // store whole text between asm..end in TPasImplAsmStatement.Tokens
);
TPOptions = set of TPOption;
@ -379,6 +380,7 @@ type
function GetCurColumn: Integer;
procedure SetOptions(AValue: TPOptions);
protected
function FetchLine: boolean;
procedure SetCurMsg(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of const);
Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Msg : String; SkipSourceInfo : Boolean = False);overload;
Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of const;SkipSourceInfo : Boolean = False);overload;
@ -400,6 +402,7 @@ type
destructor Destroy; override;
procedure OpenFile(const AFilename: string);
function FetchToken: TToken;
function ReadNonPascalTilEndToken(StopAtLineEnd: boolean): TToken;
Procedure AddDefine(S : String);
Procedure RemoveDefine(S : String);
function CurSourcePos: TPasSourcePos;
@ -1159,6 +1162,84 @@ begin
// Writeln(Result, '(',CurTokenString,')');
end;
function TPascalScanner.ReadNonPascalTilEndToken(StopAtLineEnd: boolean
): TToken;
var
StartPos: PChar;
Procedure Add;
var
AddLen: PtrInt;
OldLen: Integer;
begin
AddLen:=TokenStr-StartPos;
if AddLen=0 then exit;
OldLen:=length(FCurTokenString);
SetLength(FCurTokenString,OldLen+AddLen);
Move(StartPos^,PChar(PChar(FCurTokenString)+OldLen)^,AddLen);
StartPos:=TokenStr;
end;
begin
FCurTokenString := '';
if (TokenStr = nil) or (TokenStr^ = #0) then
if not FetchLine then
begin
Result := tkEOF;
FCurToken := Result;
exit;
end;
StartPos:=TokenStr;
repeat
case TokenStr[0] of
#0: // end of line
begin
Add;
if StopAtLineEnd then
begin
Result := tkLineEnding;
FCurToken := Result;
exit;
end;
if not FetchLine then
begin
Result := tkEOF;
FCurToken := Result;
exit;
end;
StartPos:=TokenStr;
end;
'0'..'9', 'A'..'Z', 'a'..'z','_':
begin
// number or identifier
if (TokenStr[0] in ['e','E'])
and (TokenStr[1] in ['n','N'])
and (TokenStr[2] in ['d','D'])
and not (TokenStr[3] in ['0'..'9', 'A'..'Z', 'a'..'z','_']) then
begin
// 'end' found
Add;
Result := tkend;
SetLength(FCurTokenString, 3);
Move(TokenStr^, FCurTokenString[1], 3);
inc(TokenStr,3);
FCurToken := Result;
exit;
end
else
begin
// skip identifier
while TokenStr[0] in ['0'..'9', 'A'..'Z', 'a'..'z','_'] do
inc(TokenStr);
end;
end;
else
inc(TokenStr);
end;
until false;
end;
procedure TPascalScanner.Error(MsgNumber: integer; const Msg: string);
begin
SetCurMsg(mtError,MsgNumber,Msg,[]);
@ -1335,25 +1416,6 @@ begin
end;
function TPascalScanner.DoFetchToken: TToken;
function FetchLine: Boolean;
begin
if CurSourceFile.IsEOF then
begin
FCurLine := '';
TokenStr := nil;
Result := false;
end else
begin
FCurLine := CurSourceFile.ReadLine;
TokenStr := PChar(CurLine);
Result := true;
Inc(FCurRow);
if LogEvent(sleLineNumber) and ((FCurRow Mod 100) = 0) then
DoLog(mtInfo,nLogLineNumber,SLogLineNumber,[FCurRow],True);
end;
end;
var
TokenStart, CurPos: PChar;
i: TToken;
@ -1935,6 +1997,24 @@ begin
FOptions:=AValue;
end;
function TPascalScanner.FetchLine: boolean;
begin
if CurSourceFile.IsEOF then
begin
FCurLine := '';
TokenStr := nil;
Result := false;
end else
begin
FCurLine := CurSourceFile.ReadLine;
TokenStr := PChar(CurLine);
Result := true;
Inc(FCurRow);
if LogEvent(sleLineNumber) and ((FCurRow Mod 100) = 0) then
DoLog(mtInfo,nLogLineNumber,SLogLineNumber,[FCurRow],True);
end;
end;
procedure TPascalScanner.SetCurMsg(MsgType: TMessageType; MsgNumber: integer;
const Fmt: String; Args: array of const);
begin

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

@ -64,7 +64,7 @@ Type
Private
FFirstStatement: TPasImplBlock;
FModules: TObjectList;// list of TTestEnginePasResolver
FPasResolver: TTestEnginePasResolver;
FResolverEngine: TTestEnginePasResolver;
function GetModuleCount: integer;
function GetModules(Index: integer): TTestEnginePasResolver;
function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
@ -109,7 +109,11 @@ Type
Procedure TestProcOverload;
Procedure TestProcOverloadRefs;
Procedure TestNestedProc;
property PasResolver: TTestEnginePasResolver read FPasResolver;
Procedure TestDuplicateVar;
Procedure TestRecord;
Procedure TestRecordVariant;
Procedure TestRecordVariantNested;
property ResolverEngine: TTestEnginePasResolver read FResolverEngine;
end;
function LinesToStr(Args: array of const): string;
@ -182,22 +186,22 @@ end;
procedure TTestResolver.TearDown;
begin
PasResolver.Clear;
ResolverEngine.Clear;
if FModules<>nil then
begin
FModules.OwnsObjects:=false;
FModules.Remove(PasResolver); // remove reference
FModules.Remove(ResolverEngine); // remove reference
FModules.OwnsObjects:=true;
FreeAndNil(FModules);// free all other modules
end;
inherited TearDown;
FPasResolver:=nil;
FResolverEngine:=nil;
end;
procedure TTestResolver.CreateEngine(var TheEngine: TPasTreeContainer);
begin
FPasResolver:=AddModule(MainFilename);
TheEngine:=PasResolver;
FResolverEngine:=AddModule(MainFilename);
TheEngine:=ResolverEngine;
end;
procedure TTestResolver.ParseProgram;
@ -232,7 +236,7 @@ begin
raise E;
end;
end;
TAssert.AssertSame('Has resolver',PasResolver,Parser.Engine);
TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine);
AssertEquals('Has program',TPasProgram,Module.ClassType);
AssertNotNull('Has program section',PasProgram.ProgramSection);
AssertNotNull('Has initialization section',PasProgram.InitializationSection);
@ -274,7 +278,7 @@ begin
raise E;
end;
end;
TAssert.AssertSame('Has resolver',PasResolver,Parser.Engine);
TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine);
AssertEquals('Has unit',TPasModule,Module.ClassType);
AssertNotNull('Has interface section',Module.InterfaceSection);
AssertNotNull('Has implementation section',Module.ImplementationSection);
@ -588,7 +592,7 @@ var
begin
Ref:=TResolvedReference(El.CustomData);
write(' Decl=',GetObjName(Ref.Declaration));
PasResolver.UnmangleSourceLineNumber(Ref.Declaration.SourceLinenumber,aLine,aCol);
ResolverEngine.UnmangleSourceLineNumber(Ref.Declaration.SourceLinenumber,aLine,aCol);
write(Ref.Declaration.SourceFilename,'(',aLine,',',aCol,')');
end
else
@ -636,7 +640,7 @@ var
if El.ClassType=TPasAliasType then
begin
DeclEl:=TPasAliasType(El).DestType;
PasResolver.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol);
ResolverEngine.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol);
if (aLabel^.Filename=DeclEl.SourceFilename)
and (aLabel^.LineNumber=LabelLine)
and (aLabel^.StartCol<=LabelCol)
@ -841,7 +845,7 @@ var
Data: PTestResolverReferenceData absolute FindData;
Line, Col: integer;
begin
PasResolver.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col);
ResolverEngine.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col);
//writeln('TTestResolver.OnFindReference ',GetObjName(El),' ',El.SourceFilename,' Line=',Line,',Col=',Col,' SearchFile=',Data^.Filename,',Line=',Data^.Line,',Col=',Data^.StartCol,'-',Data^.EndCol);
if (Data^.Filename=El.SourceFilename)
and (Data^.Line=Line)
@ -1417,6 +1421,87 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestDuplicateVar;
var
ok: Boolean;
begin
StartProgram(false);
Add('var a: longint;');
Add('var a: string;');
Add('begin');
ok:=false;
try
ParseModule;
except
on E: EPasResolve do
begin
AssertEquals('Expected duplicate identifier, but got msg number "'+E.Message+'"',
PasResolver.nDuplicateIdentifier,E.MsgNumber);
ok:=true;
end;
end;
AssertEquals('duplicate identifier spotted',true,ok);
end;
procedure TTestResolver.TestRecord;
begin
StartProgram(false);
Add('type');
Add(' {#TRec}TRec = record');
Add(' {#Size}Size: longint;');
Add(' end;');
Add('var');
Add(' {#r}{=TRec}r: TRec;');
Add('begin');
Add(' {@r}r.{@Size}Size:=3;');
ParseProgram;
end;
procedure TTestResolver.TestRecordVariant;
begin
StartProgram(false);
Add('type');
Add(' {#TRec}TRec = record');
Add(' {#Size}Size: longint;');
Add(' case {#vari}vari: longint of');
Add(' 0: ({#b}b: longint)');
Add(' end;');
Add('var');
Add(' {#r}{=TRec}r: TRec;');
Add('begin');
Add(' {@r}r.{@Size}Size:=3;');
Add(' {@r}r.{@vari}vari:=4;');
Add(' {@r}r.{@b}b:=5;');
ParseProgram;
end;
procedure TTestResolver.TestRecordVariantNested;
begin
StartProgram(false);
Add('type');
Add(' {#TRec}TRec = record');
Add(' {#Size}Size: longint;');
Add(' case {#vari}vari: longint of');
Add(' 0: ({#b}b: longint)');
Add(' 1: ({#c}c:');
Add(' record');
Add(' {#d}d: longint;');
Add(' case {#e}e: longint of');
Add(' 0: ({#f}f: longint)');
Add(' end)');
Add(' end;');
Add('var');
Add(' {#r}{=TRec}r: TRec;');
Add('begin');
Add(' {@r}r.{@Size}Size:=3;');
Add(' {@r}r.{@vari}vari:=4;');
Add(' {@r}r.{@b}b:=5;');
Add(' {@r}r.{@c}c.{@d}d:=6;');
Add(' {@r}r.{@c}c.{@e}e:=7;');
Add(' {@r}r.{@c}c.{@f}f:=8;');
ParseProgram;
end;
initialization
RegisterTests([TTestResolver]);

56
packages/fcl-passrc/tests/tctypeparser.pas
View File

@ -1191,13 +1191,12 @@ begin
if HaveVariant then
begin
AssertNotNull('Have variants',TheRecord.Variants);
AssertNotNull('Have variant type',TheRecord.VariantType);
AssertNotNull('Have variant type',TheRecord.VariantEl);
end
else
begin
AssertNull('No variants',TheRecord.Variants);
AssertNull('No variant type',TheRecord.VariantType);
AssertEquals('No variant name','',TheRecord.VariantName);
AssertNull('No variant element',TheRecord.VariantEl);
end;
if AddComment then
AssertComment;
@ -1205,13 +1204,22 @@ end;
procedure TTestRecordTypeParser.AssertVariantSelector(AName,AType : string);
var
V: TPasVariable;
begin
if (AType='') then
AType:='Integer';
AssertEquals('Have variant selector storage name',AName,TheRecord.VariantName);
AssertNotNull('Have variant selector type',TheRecord.VariantType);
AssertEquals('Have variant selector type',TPasUnresolvedTypeRef,TheRecord.VariantType.ClassType);
AssertEquals('Have variant selector type name',AType,TheRecord.VariantType.Name);
AssertNotNull('Have variant element',TheRecord.VariantEl);
if AName<>'' then
begin
AssertEquals('Have variant variable',TPasVariable,TheRecord.VariantEl.ClassType);
V:=TPasVariable(TheRecord.VariantEl);
AssertEquals('Have variant variable name',AName,V.Name);
AssertNotNull('Have variant var type',V.VarType);
AssertEquals('Have variant selector type',TPasUnresolvedTypeRef,V.VarType.ClassType);
AssertEquals('Have variant selector type name',lowercase(AType),lowercase(V.VarType.Name));
end else begin
AssertEquals('Have variant selector type',TPasUnresolvedTypeRef,TheRecord.VariantEl.ClassType);
AssertEquals('Have variant selector type name',lowercase(AType),lowercase(TheRecord.VariantEl.Name));
end;
end;
procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints);
@ -1316,7 +1324,7 @@ procedure TTestRecordTypeParser.DoTestVariantNoStorage(const AHint: string);
begin
TestFields(['x : integer;','case integer of','0 : (y : integer;)'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertVariant1([]);
end;
@ -1325,7 +1333,7 @@ procedure TTestRecordTypeParser.DoTestDeprecatedVariantNoStorage(
begin
TestFields(['x : integer;','case integer of','0 : (y : integer deprecated;)'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertVariant1([hDeprecated]);
end;
@ -1334,7 +1342,7 @@ procedure TTestRecordTypeParser.DoTestDeprecatedVariantStorage(
begin
TestFields(['x : integer;','case s : integer of','0 : (y : integer deprecated;)'],AHint,True);
AssertField1([]);
AssertVariantSelector('s','');
AssertVariantSelector('s','integer');
AssertVariant1([hDeprecated]);
end;
@ -1342,7 +1350,7 @@ procedure TTestRecordTypeParser.DoTestVariantStorage(const AHint: string);
begin
TestFields(['x : integer;','case s : integer of','0 : (y : integer;)'],AHint,True);
AssertField1([]);
AssertVariantSelector('s','');
AssertVariantSelector('s','integer');
AssertVariant1([]);
end;
@ -1350,7 +1358,7 @@ procedure TTestRecordTypeParser.DoTestTwoVariantsNoStorage(const AHint: string);
begin
TestFields(['x : integer;','case integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertVariant1([]);
AssertVariant2([]);
end;
@ -1359,7 +1367,7 @@ procedure TTestRecordTypeParser.DoTestTwoVariantsStorage(const AHint: string);
begin
TestFields(['x : integer;','case s : integer of','0 : (y : integer;);','1 : (z : integer;)'],AHint,True);
AssertField1([]);
AssertVariantSelector('s','');
AssertVariantSelector('s','integer');
AssertVariant1([]);
AssertVariant2([]);
end;
@ -1369,7 +1377,7 @@ procedure TTestRecordTypeParser.DoTestTwoVariantsFirstDeprecatedStorage(
begin
TestFields(['x : integer;','case s : integer of','0 : (y : integer deprecated;);','1 : (z : integer;)'],AHint,True);
AssertField1([]);
AssertVariantSelector('s','');
AssertVariantSelector('s','integer');
AssertVariant1([hdeprecated]);
AssertVariant2([]);
end;
@ -1379,7 +1387,7 @@ procedure TTestRecordTypeParser.DoTestTwoVariantsSecondDeprecatedStorage(
begin
TestFields(['x : integer;','case s : integer of','0 : (y : integer ;);','1 : (z : integer deprecated;)'],AHint,True);
AssertField1([]);
AssertVariantSelector('s','');
AssertVariantSelector('s','integer');
AssertVariant1([]);
AssertVariant2([hdeprecated]);
end;
@ -1388,7 +1396,7 @@ procedure TTestRecordTypeParser.DoTestVariantTwoLabels(const AHint: string);
begin
TestFields(['x : integer;','case integer of','0,1 : (y : integer)'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertVariant1([],['0','1']);
end;
@ -1396,7 +1404,7 @@ procedure TTestRecordTypeParser.DoTestTwoVariantsTwoLabels(const AHint: string);
begin
TestFields(['x : integer;','case integer of','0,1 : (y : integer);','2,3 : (z : integer);'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertVariant1([],['0','1']);
AssertVariant2([],['2','3']);
end;
@ -1405,7 +1413,7 @@ procedure TTestRecordTypeParser.DoTestVariantNestedRecord(const AHint: string);
begin
TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;','end)'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertRecordVariant(0,[],['0']);
end;
@ -1413,7 +1421,7 @@ procedure TTestRecordTypeParser.DoTestVariantNestedVariant(const AHint: string);
begin
TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer);',' 2 : ( j : byte)', 'end)'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertRecordVariant(0,[],['0']);
AssertRecordVariantVariant(0,'i','Integer',[],['1']);
AssertRecordVariantVariant(1,'j','Byte',[],['2'])
@ -1424,7 +1432,7 @@ procedure TTestRecordTypeParser.DoTestVariantNestedVariantFirstDeprecated(
begin
TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer deprecated);',' 2 : ( j : byte)', 'end)'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertRecordVariant(0,[],['0']);
AssertRecordVariantVariant(0,'i','Integer',[hDeprecated],['1']);
AssertRecordVariantVariant(1,'j','Byte',[],['2'])
@ -1435,7 +1443,7 @@ procedure TTestRecordTypeParser.DoTestVariantNestedVariantSecondDeprecated(
begin
TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer );',' 2 : ( j : byte deprecated)', 'end)'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertRecordVariant(0,[],['0']);
AssertRecordVariantVariant(0,'i','Integer',[],['1']);
AssertRecordVariantVariant(1,'j','Byte',[hDeprecated],['2'])
@ -1446,7 +1454,7 @@ procedure TTestRecordTypeParser.DoTestVariantNestedVariantBothDeprecated(const A
begin
TestFields(['x : integer;','case integer of','0 : ( y : record',' z : integer;',' case byte of ',' 1 : (i : integer deprecated );',' 2 : ( j : byte deprecated)', 'end)'],AHint,True);
AssertField1([]);
AssertVariantSelector('','');
AssertVariantSelector('','integer');
AssertRecordVariant(0,[],['0']);
AssertRecordVariantVariant(0,'i','Integer',[hdeprecated],['1']);
AssertRecordVariantVariant(1,'j','Byte',[hDeprecated],['2'])

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

@ -12,9 +12,9 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************
}(*
Abstract:
Converts a TPasModule into
Converts TPasElements into TJSElements.
Works:
- units, programs
@ -25,20 +25,56 @@
- procs, params, local vars
- assign statements
- function results
- record types and vars
- for loop
- repeat..until
- while..do
- try..finally
- asm..end
ToDos:
- many statements started, needs testing
- unit interface function
- optional: use $impl
- append to for-loop: if($loopend>i)i--;
- rename overloaded procs, append $0, $1, ...
- records
- rename js identifiers: apply, bind, call, prototyp, ...
- bug: try adds empty line
- bug: finally adds unnecessary {}
- record const
- copy record
- asm..end as whole body
- arrays
- access JavaScript from Pascal
- classes
- passing by reference
- procedure modifier external
- Optional: put implementation into $impl
- 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:
implements, interface, let, package,
private, protected, public, static, yield,
class, enum, export, extends, import, super,
__extends, _super
array, Array, null, prototype, delete, for, break, if
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
- use UTF8 string literals
- dotted unit names
Debug flags: -d<x>
VerbosePas2JS
}
*)
unit fppas2js;
{$mode objfpc}{$H+}
@ -68,7 +104,7 @@ resourcestring
sMemberExprMustBeIdentifier = 'Member expression must be an identifier';
const
LoopEndVar = '$loopend';
LoopEndVarName = '$loopend';
Type
@ -102,9 +138,9 @@ Type
TInitializationContext = Class(TConvertContext)
end;
{ TProcContext }
{ TDeclContext }
TProcContext = Class(TConvertContext)
TDeclContext = Class(TConvertContext)
end;
{ TProcBodyContext }
@ -131,7 +167,7 @@ Type
Procedure DoError(Const Msg : String);
Procedure DoError(Const Msg : String; Const Args : Array of Const);
Procedure DoError(MsgNumber: integer; const MsgPattern: string; Const Args : Array of Const; El: TPasElement);
procedure RaiseNotSupported(El: TPasElement; AContext: TConvertContext);
procedure RaiseNotSupported(El: TPasElement; AContext: TConvertContext; const Msg: string = '');
procedure RaiseIdentifierNotFound(Identifier: string; El: TPasElement);
procedure RaiseInconsistency;
// Never create an element manually, always use the below function
@ -157,6 +193,8 @@ Type
Add: TJSElement; Src: TPasElement);
Function CreateValInit(PasType: TPasType; Expr: TPasElement; El: TPasElement; AContext: TConvertContext): TJSElement;virtual;
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;
// Statements
Function ConvertImplBlockElements(El: TPasImplBlock; AContext: TConvertContext): TJSElement;virtual;
Function ConvertBeginEndStatement(El: TPasImplBeginBlock; AContext: TConvertContext): TJSElement;virtual;
@ -175,6 +213,7 @@ Type
Function ConvertTryFinallyStatement(El: TPasImplTryFinally; AContext: TConvertContext): TJSElement;virtual;
Function ConvertExceptOn(El: TPasImplExceptOn; AContext: TConvertContext): TJSElement;
Function ConvertTryExceptStatement(El: TPasImplTryExcept; AContext: TConvertContext): TJSElement;
Function ConvertAsmStatement(El: TPasImplAsmStatement; AContext: TConvertContext): TJSElement;
Procedure CreateInitSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext);
// Expressions
Function ConvertArrayValues(El: TArrayValues; AContext : TConvertContext): TJSElement;virtual;
@ -210,9 +249,10 @@ Type
Function ConvertType(El: TPasElement; AContext : TConvertContext): TJSElement;virtual;
Function ConvertVariable(El: TPasVariable; AContext : TConvertContext): TJSElement;virtual;
Function ConvertElement(El : TPasElement; AContext : TConvertContext) : TJSElement; virtual;
function ConvertClassType(El: TPasClassType;AContext: TConvertContext): TJSElement;
Function ConvertClassMember(El: TPasElement;AContext: TConvertContext): TJSElement;
Function ConvertClassConstructor(El: TPasConstructor;AContext: TConvertContext): TJSElement;
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;
Function ConvertPasElement(El : TPasElement; Resolver: TPasResolver) : TJSElement;
@ -335,9 +375,7 @@ begin
UsesSection:=TPasLibrary(El).LibrarySection
else
UsesSection:=El.InterfaceSection;
UsesList:=nil;
if UsesSection<>nil then
UsesList:=UsesSection.UsesList;
UsesList:=UsesSection.UsesList;
ArgArray.Elements.AddElement.Expr:=CreateUsesList(UsesList,AContext);
// add parameter: function(){}
@ -426,7 +464,7 @@ function TPasToJSConverter.ConvertCallExpression(El: TParamsExpr;
AContext: TConvertContext): TJSElement;
begin
if AContext=nil then ;
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertCallExpression');
Result:=nil;
end;
@ -717,7 +755,9 @@ begin
else
begin
Name:=TransformVariableName(Decl,AContext);
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.ConvertIdentifierExpr Decl.Parent=',GetObjName(Decl.Parent));
{$ENDIF}
if Decl.Parent is TPasSection then
begin
FoundModule:=Decl.GetModule;
@ -896,7 +936,7 @@ begin
else if (El is TRecordValues) then
Result:=ConvertRecordValues(TRecordValues(El),AContext)
else
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertExpression');
end;
function TPasToJSConverter.CreateConstDecl(El: TPasConst;
@ -931,8 +971,10 @@ function TPasToJSConverter.CreateTypeDecl(El: TPasType;
begin
Result:=Nil;
if (El is TPasClassType) then
Result := ConvertClassType(TPasClassType(El), AContext);
// ToDo: Need to do something for classes and records.
Result := ConvertClassType(TPasClassType(El), AContext)
else if El is TPasRecordType then
Result := ConvertRecordType(TPasRecordType(El), AContext);
// other types don't need a constructor function
end;
function TPasToJSConverter.CreateVarDecl(El: TPasVariable;
@ -1015,7 +1057,7 @@ begin
IsProcBody:=(El is TProcedureBody) and (TProcedureBody(El).Body<>nil);
IsFunction:=IsProcBody and (El.Parent is TPasFunction);
SubContext:=TProcContext.Create(aContext);
SubContext:=TDeclContext.Create(aContext);
try
SubContext.Element:=El;
@ -1035,7 +1077,7 @@ begin
else if P is TPasProcedure then
E:=ConvertProcedure(TPasProcedure(P),SubContext)
else
RaiseNotSupported(P as TPasElement,AContext);
RaiseNotSupported(P as TPasElement,AContext,'ConvertDeclarations');
if (Pos('.', P.Name) > 0) then
AddProcedureToClass(TJSStatementList(Result), E, P as TPasProcedure)
else
@ -1071,7 +1113,7 @@ function TPasToJSConverter.ConvertType(El: TPasElement;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertType');
Result:=Nil;
{
ToDo:
@ -1254,7 +1296,7 @@ begin
FD.Name:=TJSString(FunName);
FS.AFunction:=FD;
for n := 0 to El.ProcType.Args.Count - 1 do
FD.Params.Add(TransformVariableName(TPasArgument(El.ProcType.Args[0]).Name,AContext));
FD.Params.Add(TransformVariableName(TPasArgument(El.ProcType.Args[n]).Name,AContext));
FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,El.Body));
SubContext:=TProcBodyContext.Create(AContext);
@ -1288,33 +1330,27 @@ function TPasToJSConverter.ConvertImplBlockElements(El: TPasImplBlock;
AContext: TConvertContext): TJSElement;
var
B : TJSElement;
S,S2 : TJSStatementList;
First, Last: TJSStatementList;
I : Integer;
PasImpl: TPasImplElement;
JSImpl : TJSElement;
begin
if Not (Assigned(El.Elements) and (El.Elements.Count>0)) then
Result:=TJSEmptyBlockStatement(CreateElement(TJSEmptyBlockStatement,El))
else
begin
S:=TJSStatementList(CreateElement(TJSStatementList,TPasImplElement(El)));
Result:=S;
First:=nil;
Result:=First;
Last:=First;
//writeln('TPasToJSConverter.ConvertImplBlockElements START El.Elements.Count=',El.Elements.Count);
For I:=0 to El.Elements.Count-1 do
begin
B:=ConvertElement(TPasImplElement(El.Elements[i]),AContext);
if not Assigned(S.A) then
S.A:=B
else
begin
if Assigned(S.B) then
begin
S2:=TJSStatementList(CreateElement(TJSStatementList,TPasImplElement(El.Elements[i])));
S2.A:=S.B;
S.B:=S2;
S:=S2;
end;
S.B:=B;
end;
PasImpl:=TPasImplElement(El.Elements[i]);
JSImpl:=ConvertElement(PasImpl,AContext);
//writeln('TPasToJSConverter.ConvertImplBlockElements ',i,' ',JSImpl.ClassName);
AddToStatementList(First,Last,JSImpl,PasImpl);
Result:=First;
end;
end;
end;
@ -1345,8 +1381,11 @@ begin
AssignSt.Expr:=FDS;
FD:=TJSFuncDef.Create;
FDS.AFunction:=FD;
FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,El));
FD.Body.A:=ConvertImplBlockElements(El,AContext);
if El.Elements.Count>0 then
begin
FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,El));
FD.Body.A:=ConvertImplBlockElements(El,AContext);
end;
ok:=true;
finally
if not ok then FreeAndNil(Result);
@ -1366,11 +1405,12 @@ function TPasToJSConverter.ConvertTryStatement(El: TPasImplTry;
Var
B,F : TJSElement;
T : TJSTryStatement;
IsFin : Boolean;
IsFin , ok: Boolean;
begin
F:=Nil;
B:=ConvertImplBlockElements(El,AContext);
ok:=false;
try
F:=ConvertElement(El.FinallyExcept,AContext);
IsFin:=El.FinallyExcept is TPasImplTryFinally;
@ -1381,10 +1421,13 @@ begin
T:=TJSTryCatchStatement(CreateElement(TJSTryCatchStatement,El));
T.Ident:=TJSString(GetExceptionObjectName(AContext));
end;
except
FreeAndNil(B);
FreeAndNil(F);
Raise;
ok:=true;
finally
if not ok then
begin
B.Free;
F.Free;
end;
end;
if IsFin then
T.BFinally:=F
@ -1397,7 +1440,6 @@ end;
function TPasToJSConverter.ConvertTryFinallyStatement(El: TPasImplTryFinally;
AContext: TConvertContext): TJSElement;
begin
Result:=ConvertImplBlockElements(El,AContext);
end;
@ -1405,11 +1447,27 @@ end;
function TPasToJSConverter.ConvertTryExceptStatement(El: TPasImplTryExcept;
AContext: TConvertContext): TJSElement;
begin
Result:=ConvertImplBlockElements(El,AContext);
end;
function TPasToJSConverter.ConvertAsmStatement(El: TPasImplAsmStatement;
AContext: TConvertContext): TJSElement;
var
pex: TJSPrimaryExpressionIdent;
s: String;
begin
if AContext=nil then ;
s:=El.Tokens.Text;
if s='' then
Result:=TJSEmptyStatement(CreateElement(TJSEmptyStatement,El))
else begin
pex:=TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent,El));
pex.Name := TJSString(s);
Result:=pex;
end;
end;
procedure TPasToJSConverter.CreateInitSection(El: TPasModule;
Src: TJSSourceElements; AContext: TConvertContext);
var
@ -1434,9 +1492,9 @@ function TPasToJSConverter.ConvertImplBlock(El: TPasImplBlock;
begin
Result:=Nil;
if (EL is TPasImplStatement) then
if (El is TPasImplStatement) then
Result:=ConvertStatement(TPasImplStatement(El),AContext)
else if (EL is TPasImplIfElse) then
else if (El is TPasImplIfElse) then
Result:=ConvertIfStatement(TPasImplIfElse(El),AContext)
else if (El is TPasImplRepeatUntil) then
Result:=ConvertRepeatStatement(TPasImplRepeatUntil(El),AContext)
@ -1470,7 +1528,7 @@ function TPasToJSConverter.ConvertPackage(El: TPasPackage;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertPackage');
Result:=Nil;
// ToDo TPasPackage = class(TPasElement)
end;
@ -1479,7 +1537,7 @@ function TPasToJSConverter.ConvertResString(El: TPasResString;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertResString');
Result:=Nil;
// ToDo: TPasResString
end;
@ -1488,7 +1546,8 @@ function TPasToJSConverter.ConvertArgument(El: TPasArgument;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
// is this still needed?
RaiseNotSupported(El,AContext,'ConvertArgument');
Result:=Nil;
// ToDo: TPasArgument
end;
@ -1519,7 +1578,8 @@ function TPasToJSConverter.ConvertConst(El: TPasConst; AContext: TConvertContext
): TJSElement;
begin
RaiseNotSupported(El,AContext);
// is this still needed?
RaiseNotSupported(El,AContext,'ConvertConst');
Result:=Nil;
// ToDo: TPasConst
end;
@ -1528,7 +1588,7 @@ function TPasToJSConverter.ConvertProperty(El: TPasProperty;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertProperty');
Result:=Nil;
// ToDo: TPasProperty = class(TPasVariable)
end;
@ -1537,7 +1597,7 @@ function TPasToJSConverter.ConvertExportSymbol(El: TPasExportSymbol;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertExportSymbol');
Result:=Nil;
// ToDo: TPasExportSymbol
end;
@ -1546,7 +1606,7 @@ function TPasToJSConverter.ConvertLabels(El: TPasLabels;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertLabels');
Result:=Nil;
// ToDo: TPasLabels = class(TPasImplElement)
end;
@ -1597,7 +1657,7 @@ function TPasToJSConverter.ConvertCommand(El: TPasImplCommand;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertCommand');
Result:=Nil;
// ToDo: TPasImplCommand = class(TPasImplElement)
end;
@ -1749,7 +1809,7 @@ begin
VarStat:=TJSVariableStatement(CreateElement(TJSVariableStatement,El));
VarDecl:=TJSVarDeclaration(CreateElement(TJSVarDeclaration,El));
VarStat.A:=VarDecl;
VarDecl.Name:=LoopEndVar;
VarDecl.Name:=LoopEndVarName;
VarDecl.Init:=ConvertElement(El.EndExpr,AContext);
ForSt.Init:=VarStat;
// add "LoopVar<=$loopend"
@ -1758,7 +1818,7 @@ begin
else
BinExp:=TJSRelationalExpressionLE(CreateElement(TJSRelationalExpressionLE,El.EndExpr));
BinExp.A:=ConvertElement(El.VariableName,AContext);
BinExp.B:=CreateIdentifierExpr(LoopEndVar,El.EndExpr);
BinExp.B:=CreateIdentifierExpr(LoopEndVarName,El.EndExpr);
ForSt.Cond:=BinExp;
// add "LoopVar++"
If El.Down then
@ -2059,36 +2119,41 @@ begin
else
begin
// merge lists (append)
if Last.B<>nil then
raise Exception.Create('internal error: TPasToJSConverter.ConvertDeclarations.AddToStatementList add list');
Last.B:=Add;
while Last.B is TJSStatementList do
Last:=TJSStatementList(Last.B);
if Last.B<>nil then
begin
// add a nil to the end of chain
SL2:=TJSStatementList(CreateElement(TJSStatementList,Src));
SL2.A:=Last.B;
Last.B:=SL2;
Last:=SL2;
// Last.B is now nil
end;
Last.B:=Add;
while Last.B is TJSStatementList do
Last:=TJSStatementList(Last.B);
end;
end
else
begin
if Last=nil then
begin
// start list
Last:=TJSStatementList(CreateElement(TJSStatementList,Src));
First:=Last;
Last.A:=Add;
end
else if Last.B=nil then
// second element
Last.B:=Add
else
begin
if Last.B<>nil then
raise Exception.Create('internal error: TPasToJSConverter.ConvertDeclarations.AddToStatementList add element');
// add to chain
SL2:=TJSStatementList(CreateElement(TJSStatementList,Src));
SL2.A:=Last.B;
Last.B:=SL2;
Last:=SL2;
Last.B:=Add;
end;
Last.A:=Add;
end;
end;
@ -2105,6 +2170,8 @@ begin
If Assigned(Expr) then
DoError(nInitializedArraysNotSupported,sInitializedArraysNotSupported,[],PasType);
end
else if T is TPasRecordType then
Result:=CreateRecordInit(TPasRecordType(T),Expr,El,AContext)
else if Assigned(Expr) then
Result:=ConvertElement(Expr,AContext)
else
@ -2156,6 +2223,42 @@ begin
Result:=CreateValInit(El.VarType,El.Expr,El,AContext);
end;
function TPasToJSConverter.CreateRecordInit(aRecord: TPasRecordType;
Expr: TPasElement; El: TPasElement; AContext: TConvertContext): TJSElement;
var
NewMemE: TJSNewMemberExpression;
begin
if Expr<>nil then
RaiseNotSupported(Expr,AContext,'CreateRecordInit Expr<>nil');
NewMemE:=TJSNewMemberExpression(CreateElement(TJSNewMemberExpression,El));
Result:=NewMemE;
NewMemE.MExpr:=CreateTypeRef(aRecord,AContext);
end;
function TPasToJSConverter.CreateTypeRef(El: TPasType; AContext: TConvertContext
): TJSElement;
var
FoundModule: TPasModule;
Name: String;
begin
Name:=TransformVariableName(El.Name,AContext);
{ $IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateTypeRef El="',GetObjName(El),'" El.Parent=',GetObjName(El.Parent));
{ $ENDIF}
if El.Parent is TPasSection then
begin
FoundModule:=El.GetModule;
if FoundModule=nil then
RaiseInconsistency;
if AContext.GetRootModule=FoundModule then
Name:='this.'+Name
else
Name:='pas.'+TransformModuleName(FoundModule,AContext)+'.'+Name;
end;
// ToDo: use TJSDotMemberExpression for dots
Result:=CreateIdentifierExpr(Name,El);
end;
function TPasToJSConverter.CreateProcedureDeclaration(const El: TPasElement):
TJSFunctionDeclarationStatement;
var
@ -2169,6 +2272,7 @@ begin
FS.AFunction := FD;
Result := FS;
end;
function TPasToJSConverter.ConvertExceptOn(El: TPasImplExceptOn;
AContext: TConvertContext): TJSElement;
@ -2215,8 +2319,10 @@ begin
Result:=ConvertExceptOn(TPasImplExceptOn(El),AContext)
else if (El is TPasImplForLoop) then
Result:=ConvertForStatement(TPasImplForLoop(El),AContext)
else if (El is TPasImplAsmStatement) then
Result:=ConvertAsmStatement(TPasImplAsmStatement(El),AContext)
else
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertStatement');
{
TPasImplCaseStatement = class(TPasImplStatement)
}
@ -2227,7 +2333,7 @@ function TPasToJSConverter.ConvertCommands(El: TPasImplCommands;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertCommands');
Result:=Nil;
// ToDo: TPasImplCommands = class(TPasImplElement)
end;
@ -2236,7 +2342,7 @@ function TPasToJSConverter.ConvertLabelMark(El: TPasImplLabelMark;
AContext: TConvertContext): TJSElement;
begin
RaiseNotSupported(El,AContext);
RaiseNotSupported(El,AContext,'ConvertLabelMark');
Result:=Nil;
// ToDo: TPasImplLabelMark = class(TPasImplLabelMark) then
end;
@ -2284,6 +2390,57 @@ begin
Result:=nil;
end;
function TPasToJSConverter.ConvertRecordType(El: TPasRecordType;
AContext: TConvertContext): TJSElement;
(*
type
TMyRecord = record
i: longint;
s: string;
d: double;
end;
this.TMyRecord=function() {
i=0;
s="";
d=0.0;
};
*)
var
AssignSt: TJSSimpleAssignStatement;
ok: Boolean;
i: Integer;
PasVar: TPasVariable;
FDS: TJSFunctionDeclarationStatement;
FD: TJSFuncDef;
JSVar: TJSElement;
First, Last: TJSStatementList;
begin
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
Result:=AssignSt;
ok:=false;
try
AssignSt.LHS:=CreateMemberExpression(['this',TransformVariableName(El.Name,AContext)]);
FDS:=TJSFunctionDeclarationStatement(CreateElement(TJSFunctionDeclarationStatement,El));
AssignSt.Expr:=FDS;
FD:=TJSFuncDef.Create;
FDS.AFunction:=FD;
FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,El));
First:=nil;
Last:=nil;
for i:=0 to El.Members.Count-1 do
begin
PasVar:=TPasVariable(El.Members[i]);
JSVar:=ConvertVariable(PasVar,AContext);
AddToStatementList(First,Last,JSVar,PasVar);
FD.Body.A:=First;
end;
ok:=true;
finally
if not ok then FreeAndNil(Result);
end;
end;
procedure TPasToJSConverter.DoError(const Msg: String);
begin
Raise EPas2JS.Create(Msg);
@ -2308,12 +2465,14 @@ begin
end;
procedure TPasToJSConverter.RaiseNotSupported(El: TPasElement;
AContext: TConvertContext);
AContext: TConvertContext; const Msg: string);
var
E: EPas2JS;
begin
if AContext=nil then ;
E:=EPas2JS.CreateFmt(sPasElementNotSupported,[GetObjName(El)]);
if Msg<>'' then
E.Message:=E.Message+': '+Msg;
E.PasElement:=El;
E.MsgNumber:=nPasElementNotSupported;
SetLength(E.Args,1);

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

@ -333,8 +333,13 @@ begin
AssertEquals('Correct condition class',TJSUnaryNotExpression,E.Cond.ClassType);
AssertIdentifier('Conditional expression',TJSUnaryNotExpression(E.Cond).A,'a');
L:=AssertListStatement('Multiple statements',E.Body);
// writeln('TTestStatementConverter.TestRepeatUntilStatementTwo L.A=',L.A.ClassName);
// writeln(' L.B=',L.B.ClassName);
// writeln(' L.B.A=',TJSStatementList(L.B).A.ClassName);
// writeln(' L.B.B=',TJSStatementList(L.B).B.ClassName);
AssertAssignStatement('First List statement is assignment',L.A,'b','c');
AssertAssignStatement('Second List statement is assignment',L.b,'d','e');
AssertAssignStatement('Second List statement is assignment',L.B,'d','e');
end;
Procedure TTestStatementConverter.TestRepeatUntilStatementThree;
@ -394,15 +399,15 @@ begin
E:=TJSForStatement(AssertElement('Second in list is "for" statement',TJSForStatement,L.B));
// "var $loopend=100"
VS:=TJSVariableStatement(AssertElement('var '+LoopEndVar,TJSVariableStatement,E.Init));
VD:=TJSVarDeclaration(AssertElement('var '+LoopEndVar,TJSVarDeclaration,VS.A));
AssertEquals('Correct name for '+LoopEndVar,LoopEndVar,VD.Name);
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<=$loopend
C:=TJSRelationalExpressionLE(AssertElement('Condition is <= expression',TJSRelationalExpressionLE,E.Cond));
AssertIdentifier('Cond LHS is loop variable',C.A,'i');
AssertIdentifier('Cond RHS is '+LoopEndVar,C.B,LoopEndVar);
AssertIdentifier('Cond RHS is '+LoopEndVarName,C.B,LoopEndVarName);
// i++
I:=TJSUnaryPostPlusPlusExpression(AssertElement('Increment is ++ statement',TJSUnaryPostPlusPlusExpression,E.Incr));
@ -444,15 +449,15 @@ begin
E:=TJSForStatement(AssertElement('Second in list is "for" statement',TJSForStatement,L.B));
// "var $loopend=1"
VS:=TJSVariableStatement(AssertElement('var '+LoopEndVar,TJSVariableStatement,E.Init));
VD:=TJSVarDeclaration(AssertElement('var '+LoopEndVar,TJSVarDeclaration,VS.A));
AssertEquals('Correct name for '+LoopEndVar,LoopEndVar,VD.Name);
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>=$loopend
C:=TJSRelationalExpressionGE(AssertElement('Condition is >= expression',TJSRelationalExpressionGE,E.Cond));
AssertIdentifier('Cond LHS is loop variable',C.A,'i');
AssertIdentifier('Cond RHS is '+LoopEndVar,C.B,LoopEndVar);
AssertIdentifier('Cond RHS is '+LoopEndVarName,C.B,LoopEndVarName);
// i--
I:=TJSUnaryPostMinusMinusExpression(AssertElement('Increment is -- statement',TJSUnaryPostMinusMinusExpression,E.Incr));
@ -1333,7 +1338,7 @@ Class Procedure TTestConverter.AssertAssignStatement(Const Msg : String; El : TJ
begin
AssertNotNull(Msg+': have statement',EL);
If not (El is TJSSimpleAssignStatement) then
Fail(Msg+': statement is not assign statement but is'+El.ClassName);
Fail(Msg+': statement is not assign statement but is '+El.ClassName);
AssertIdentifier(Msg+': left hand side ('+LHS+')',TJSAssignStatement(EL).LHS,LHS);
AssertIdentifier(Msg+': left hand side ('+LHS+')',TJSAssignStatement(EL).Expr,RHS);
end;

952
packages/pastojs/tests/tcmodules.pas Normal file
View File

@ -0,0 +1,952 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2014 by Michael Van Canneyt
Unit tests for Pascal-to-Javascript converter class.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************
Examples:
./testpas2js --suite=TTestModuleConverter.TestEmptyProgram
}
unit tcmodules;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testregistry, contnrs, fppas2js,
pastree, PScanner, PasResolver, PParser, jstree, jswriter, jsbase;
const
po_pas2js = [po_asmwhole,po_resolvestandardtypes];
type
{ TTestPasParser }
TTestPasParser = Class(TPasParser)
end;
TOnFindUnit = function(const aUnitName: String): TPasModule of object;
{ TTestEnginePasResolver }
TTestEnginePasResolver = class(TPasResolver)
private
FFilename: string;
FModule: TPasModule;
FOnFindUnit: TOnFindUnit;
FParser: TTestPasParser;
FResolver: TStreamResolver;
FScanner: TPascalScanner;
FSource: string;
procedure SetModule(AValue: TPasModule);
public
constructor Create;
destructor Destroy; override;
function FindModule(const AName: String): TPasModule; override;
property OnFindUnit: TOnFindUnit read FOnFindUnit write FOnFindUnit;
property Filename: string read FFilename write FFilename;
property Resolver: TStreamResolver read FResolver write FResolver;
property Scanner: TPascalScanner read FScanner write FScanner;
property Parser: TTestPasParser read FParser write FParser;
property Source: string read FSource write FSource;
property Module: TPasModule read FModule write SetModule;
end;
{ TTestModule }
TTestModule = Class(TTestCase)
private
FConverter: TPasToJSConverter;
FEngine: TTestEnginePasResolver;
FFilename: string;
FFileResolver: TStreamResolver;
FJSInitBody: TJSFunctionBody;
FJSInterfaceUses: TJSArrayLiteral;
FJSModule: TJSSourceElements;
FJSModuleSrc: TJSSourceElements;
FJSSource: TStringList;
FModule: TPasModule;
FJSModuleCallArgs: TJSArguments;
FModules: TObjectList;// list of TTestEnginePasResolver
FParser: TTestPasParser;
FPasProgram: TPasProgram;
FJSRegModuleCall: TJSCallExpression;
FScanner: TPascalScanner;
FSource: TStringList;
FFirstPasStatement: TPasImplBlock;
function GetModuleCount: integer;
function GetModules(Index: integer): TTestEnginePasResolver;
function OnPasResolverFindUnit(const aUnitName: String): TPasModule;
protected
procedure SetUp; override;
procedure TearDown; override;
Procedure Add(Line: string);
Procedure StartParsing;
Procedure ParseModule;
procedure ParseProgram;
protected
function FindModuleWithFilename(aFilename: string): TTestEnginePasResolver;
function AddModule(aFilename: string): TTestEnginePasResolver;
function AddModuleWithSrc(aFilename, Src: string): TTestEnginePasResolver;
function AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
ImplementationSrc: string): TTestEnginePasResolver;
procedure AddSystemUnit;
procedure StartProgram(NeedSystemUnit: boolean);
Procedure ConvertProgram;
procedure CheckDottedIdentifier(Msg: string; El: TJSElement; DottedName: string);
function GetDottedIdentifier(El: TJSElement): string;
procedure CheckSource(Msg,Statements, InitStatements: string);
procedure CheckDiff(Msg, Expected, Actual: string);
property PasProgram: TPasProgram Read FPasProgram;
property Modules[Index: integer]: TTestEnginePasResolver read GetModules;
property ModuleCount: integer read GetModuleCount;
property Engine: TTestEnginePasResolver read FEngine;
property Filename: string read FFilename;
Property Module: TPasModule Read FModule;
property FirstPasStatement: TPasImplBlock read FFirstPasStatement;
property Converter: TPasToJSConverter read FConverter;
property JSSource: TStringList read FJSSource;
property JSModule: TJSSourceElements read FJSModule;
property JSRegModuleCall: TJSCallExpression read FJSRegModuleCall;
property JSModuleCallArgs: TJSArguments read FJSModuleCallArgs;
property JSInterfaceUses: TJSArrayLiteral read FJSInterfaceUses;
property JSModuleSrc: TJSSourceElements read FJSModuleSrc;
property JSInitBody: TJSFunctionBody read FJSInitBody;
public
property Source: TStringList read FSource;
property FileResolver: TStreamResolver read FFileResolver;
property Scanner: TPascalScanner read FScanner;
property Parser: TTestPasParser read FParser;
Published
Procedure TestEmptyProgram;
Procedure TestVarInt;
Procedure TestEmptyProc;
Procedure TestProcTwoArgs;
Procedure TestFunctionInt;
Procedure TestFunctionString;
Procedure TestVarRecord;
Procedure TestForLoop;
Procedure TestForLoopInFunction;
Procedure TestRepeatUntil;
Procedure TestAsmBlock;
Procedure TestTryFinally;
end;
function LinesToStr(Args: array of const): string;
function ExtractFileUnitName(aFilename: string): string;
function JSToStr(El: TJSElement): string;
implementation
function LinesToStr(Args: array of const): string;
var
s: String;
i: Integer;
begin
s:='';
for i:=Low(Args) to High(Args) do
case Args[i].VType of
vtChar: s += Args[i].VChar+LineEnding;
vtString: s += Args[i].VString^+LineEnding;
vtPChar: s += Args[i].VPChar+LineEnding;
vtWideChar: s += AnsiString(Args[i].VWideChar)+LineEnding;
vtPWideChar: s += AnsiString(Args[i].VPWideChar)+LineEnding;
vtAnsiString: s += AnsiString(Args[i].VAnsiString)+LineEnding;
vtWidestring: s += AnsiString(WideString(Args[i].VWideString))+LineEnding;
vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding;
end;
Result:=s;
end;
function ExtractFileUnitName(aFilename: string): string;
var
p: Integer;
begin
Result:=ExtractFileName(aFilename);
if Result='' then exit;
for p:=length(Result) downto 1 do
case Result[p] of
'/','\': exit;
'.':
begin
Delete(Result,p,length(Result));
exit;
end;
end;
end;
function JSToStr(El: TJSElement): string;
var
aWriter: TBufferWriter;
aJSWriter: TJSWriter;
begin
aWriter:=TBufferWriter.Create(1000);
try
aJSWriter:=TJSWriter.Create(aWriter);
aJSWriter.IndentSize:=2;
aJSWriter.WriteJS(El);
Result:=aWriter.AsAnsistring;
finally
aWriter.Free;
end;
end;
{ TTestEnginePasResolver }
procedure TTestEnginePasResolver.SetModule(AValue: TPasModule);
begin
if FModule=AValue then Exit;
if Module<>nil then
Module.Release;
FModule:=AValue;
if Module<>nil then
Module.AddRef;
end;
constructor TTestEnginePasResolver.Create;
begin
inherited Create;
StoreSrcColumns:=true;
end;
destructor TTestEnginePasResolver.Destroy;
begin
FreeAndNil(FResolver);
Module:=nil;
FreeAndNil(FParser);
FreeAndNil(FScanner);
FreeAndNil(FResolver);
inherited Destroy;
end;
function TTestEnginePasResolver.FindModule(const AName: String): TPasModule;
begin
Result:=nil;
if Assigned(OnFindUnit) then
Result:=OnFindUnit(AName);
end;
{ TTestModule }
function TTestModule.GetModuleCount: integer;
begin
Result:=FModules.Count;
end;
function TTestModule.GetModules(Index: integer
): TTestEnginePasResolver;
begin
Result:=TTestEnginePasResolver(FModules[Index]);
end;
function TTestModule.OnPasResolverFindUnit(const aUnitName: String
): TPasModule;
var
i: Integer;
CurEngine: TTestEnginePasResolver;
CurUnitName: String;
begin
//writeln('TTestModule.OnPasResolverFindUnit START Unit="',aUnitName,'"');
Result:=nil;
for i:=0 to ModuleCount-1 do
begin
CurEngine:=Modules[i];
CurUnitName:=ExtractFileUnitName(CurEngine.Filename);
//writeln('TTestModule.OnPasResolverFindUnit Checking ',i,'/',ModuleCount,' ',CurEngine.Filename,' ',CurUnitName);
if CompareText(aUnitName,CurUnitName)=0 then
begin
Result:=CurEngine.Module;
if Result<>nil then exit;
//writeln('TTestModule.OnPasResolverFindUnit PARSING unit "',CurEngine.Filename,'"');
FileResolver.FindSourceFile(aUnitName);
CurEngine.Resolver:=TStreamResolver.Create;
CurEngine.Resolver.OwnsStreams:=True;
//writeln('TTestResolver.OnPasResolverFindUnit SOURCE=',CurEngine.Source);
CurEngine.Resolver.AddStream(CurEngine.FileName,TStringStream.Create(CurEngine.Source));
CurEngine.Scanner:=TPascalScanner.Create(CurEngine.Resolver);
CurEngine.Parser:=TTestPasParser.Create(CurEngine.Scanner,CurEngine.Resolver,CurEngine);
CurEngine.Parser.Options:=CurEngine.Parser.Options+po_pas2js;
if CompareText(CurUnitName,'System')=0 then
CurEngine.Parser.ImplicitUses.Clear;
CurEngine.Scanner.OpenFile(CurEngine.Filename);
try
CurEngine.Parser.NextToken;
CurEngine.Parser.ParseUnit(CurEngine.FModule);
except
on E: Exception do
begin
writeln('ERROR: TTestModule.OnPasResolverFindUnit during parsing: '+E.ClassName+':'+E.Message
+' File='+CurEngine.Scanner.CurFilename
+' LineNo='+IntToStr(CurEngine.Scanner.CurRow)
+' Col='+IntToStr(CurEngine.Scanner.CurColumn)
+' Line="'+CurEngine.Scanner.CurLine+'"'
);
raise E;
end;
end;
//writeln('TTestModule.OnPasResolverFindUnit END ',CurUnitName);
Result:=CurEngine.Module;
exit;
end;
end;
writeln('TTestModule.OnPasResolverFindUnit missing unit "',aUnitName,'"');
raise Exception.Create('can''t find unit "'+aUnitName+'"');
end;
procedure TTestModule.SetUp;
begin
inherited SetUp;
FSource:=TStringList.Create;
FModules:=TObjectList.Create(true);
FFilename:='test1.pp';
FFileResolver:=TStreamResolver.Create;
FFileResolver.OwnsStreams:=True;
FScanner:=TPascalScanner.Create(FFileResolver);
FEngine:=AddModule(Filename);
FParser:=TTestPasParser.Create(FScanner,FFileResolver,FEngine);
Parser.Options:=Parser.Options+po_pas2js;
FModule:=Nil;
FConverter:=TPasToJSConverter.Create;
end;
procedure TTestModule.TearDown;
begin
FJSModule:=nil;
FJSRegModuleCall:=nil;
FJSModuleCallArgs:=nil;
FJSInterfaceUses:=nil;
FJSModuleSrc:=nil;
FJSInitBody:=nil;
FreeAndNil(FJSSource);
FreeAndNil(FJSModule);
FreeAndNil(FConverter);
Engine.Clear;
if Assigned(FModule) then
begin
FModule.Release;
FModule:=nil;
end;
FreeAndNil(FSource);
FreeAndNil(FParser);
FreeAndNil(FScanner);
FreeAndNil(FFileResolver);
if FModules<>nil then
begin
FreeAndNil(FModules);
FEngine:=nil;
end;
inherited TearDown;
end;
procedure TTestModule.Add(Line: string);
begin
Source.Add(Line);
end;
procedure TTestModule.StartParsing;
begin
FileResolver.AddStream(FileName,TStringStream.Create(Source.Text));
Scanner.OpenFile(FileName);
Writeln('// Test : ',Self.TestName);
Writeln(Source.Text);
end;
procedure TTestModule.ParseModule;
begin
StartParsing;
Parser.ParseMain(FModule);
AssertNotNull('Module resulted in Module',FModule);
AssertEquals('modulename',ChangeFileExt(FFileName,''),Module.Name);
end;
procedure TTestModule.ParseProgram;
begin
FFirstPasStatement:=nil;
try
ParseModule;
except
on E: EParserError do
begin
writeln('ERROR: TTestModule.ParseProgram Parser: '+E.ClassName+':'+E.Message
+' File='+Scanner.CurFilename
+' LineNo='+IntToStr(Scanner.CurRow)
+' Col='+IntToStr(Scanner.CurColumn)
+' Line="'+Scanner.CurLine+'"'
);
raise E;
end;
on E: EPasResolve do
begin
writeln('ERROR: TTestModule.ParseProgram PasResolver: '+E.ClassName+':'+E.Message
+' File='+Scanner.CurFilename
+' LineNo='+IntToStr(Scanner.CurRow)
+' Col='+IntToStr(Scanner.CurColumn)
+' Line="'+Scanner.CurLine+'"'
);
raise E;
end;
on E: Exception do
begin
writeln('ERROR: TTestModule.ParseProgram Exception: '+E.ClassName+':'+E.Message);
raise E;
end;
end;
TAssert.AssertSame('Has resolver',Engine,Parser.Engine);
AssertEquals('Has program',TPasProgram,Module.ClassType);
FPasProgram:=TPasProgram(Module);
AssertNotNull('Has program section',PasProgram.ProgramSection);
AssertNotNull('Has initialization section',PasProgram.InitializationSection);
if (PasProgram.InitializationSection.Elements.Count>0) then
if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then
FFirstPasStatement:=TPasImplBlock(PasProgram.InitializationSection.Elements[0]);
end;
function TTestModule.FindModuleWithFilename(aFilename: string
): TTestEnginePasResolver;
var
i: Integer;
begin
for i:=0 to ModuleCount-1 do
if CompareText(Modules[i].Filename,aFilename)=0 then
exit(Modules[i]);
Result:=nil;
end;
function TTestModule.AddModule(aFilename: string
): TTestEnginePasResolver;
begin
//writeln('TTestModuleConverter.AddModule ',aFilename);
if FindModuleWithFilename(aFilename)<>nil then
raise Exception.Create('TTestModuleConverter.AddModule: file "'+aFilename+'" already exists');
Result:=TTestEnginePasResolver.Create;
Result.Filename:=aFilename;
Result.AddObjFPCBuiltInIdentifiers([btChar,btString,btLongint,btInt64,btBoolean,btDouble]);
Result.OnFindUnit:=@OnPasResolverFindUnit;
FModules.Add(Result);
end;
function TTestModule.AddModuleWithSrc(aFilename, Src: string
): TTestEnginePasResolver;
begin
Result:=AddModule(aFilename);
Result.Source:=Src;
end;
function TTestModule.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc,
ImplementationSrc: string): TTestEnginePasResolver;
var
Src: String;
begin
Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding;
Src+=LineEnding;
Src+='interface'+LineEnding;
Src+=LineEnding;
Src+=InterfaceSrc;
Src+='implementation'+LineEnding;
Src+=LineEnding;
Src+=ImplementationSrc;
Src+='end.'+LineEnding;
Result:=AddModuleWithSrc(aFilename,Src);
end;
procedure TTestModule.AddSystemUnit;
begin
AddModuleWithIntfImplSrc('system.pp',
// interface
LinesToStr([
'type',
' integer=longint;',
'var',
' ExitCode: Longint;',
''
// implementation
]),LinesToStr([
''
]));
end;
procedure TTestModule.StartProgram(NeedSystemUnit: boolean);
begin
if NeedSystemUnit then
AddSystemUnit
else
Parser.ImplicitUses.Clear;
Add('program test1;');
Add('');
end;
procedure TTestModule.ConvertProgram;
var
ModuleNameExpr: TJSLiteral;
FunDecl, InitFunction: TJSFunctionDeclarationStatement;
FunDef: TJSFuncDef;
InitAssign: TJSSimpleAssignStatement;
FunBody: TJSFunctionBody;
begin
FJSSource:=TStringList.Create;
Add('end.');
ParseProgram;
FJSModule:=FConverter.ConvertPasElement(Module,nil) as TJSSourceElements;
FJSSource.Text:=JSToStr(JSModule);
writeln('TTestModule.ConvertProgram JS:');
write(FJSSource.Text);
// rtl.module(...
AssertEquals('jsmodule has one statement - the call',1,JSModule.Statements.Count);
AssertNotNull('register module call',JSModule.Statements.Nodes[0].Node);
AssertEquals('register module call',TJSCallExpression,JSModule.Statements.Nodes[0].Node.ClassType);
FJSRegModuleCall:=JSModule.Statements.Nodes[0].Node as TJSCallExpression;
AssertNotNull('register module rtl.module expr',JSRegModuleCall.Expr);
AssertNotNull('register module rtl.module args',JSRegModuleCall.Args);
AssertEquals('rtl.module args',TJSArguments,JSRegModuleCall.Args.ClassType);
FJSModuleCallArgs:=JSRegModuleCall.Args as TJSArguments;
AssertEquals('rtl.module args.count',3,JSModuleCallArgs.Elements.Count);
// parameter 'unitname'
AssertNotNull('module name param',JSModuleCallArgs.Elements.Elements[0].Expr);
ModuleNameExpr:=JSModuleCallArgs.Elements.Elements[0].Expr as TJSLiteral;
AssertEquals('module name param is string',ord(jstString),ord(ModuleNameExpr.Value.ValueType));
AssertEquals('module name','program',String(ModuleNameExpr.Value.AsString));
// main uses section
AssertNotNull('interface uses section',JSModuleCallArgs.Elements.Elements[1].Expr);
AssertEquals('interface uses section type',TJSArrayLiteral,JSModuleCallArgs.Elements.Elements[1].Expr.ClassType);
FJSInterfaceUses:=JSModuleCallArgs.Elements.Elements[1].Expr as TJSArrayLiteral;
// function()
AssertNotNull('module function',JSModuleCallArgs.Elements.Elements[2].Expr);
AssertEquals('module function type',TJSFunctionDeclarationStatement,JSModuleCallArgs.Elements.Elements[2].Expr.ClassType);
FunDecl:=JSModuleCallArgs.Elements.Elements[2].Expr as TJSFunctionDeclarationStatement;
AssertNotNull('module function def',FunDecl.AFunction);
FunDef:=FunDecl.AFunction as TJSFuncDef;
AssertEquals('module function name','',String(FunDef.Name));
AssertNotNull('module function body',FunDef.Body);
FunBody:=FunDef.Body as TJSFunctionBody;
FJSModuleSrc:=FunBody.A as TJSSourceElements;
// init this.$main - the last statement
AssertEquals('this.$main function 1',true,JSModuleSrc.Statements.Count>0);
InitAssign:=JSModuleSrc.Statements.Nodes[JSModuleSrc.Statements.Count-1].Node as TJSSimpleAssignStatement;
CheckDottedIdentifier('init function',InitAssign.LHS,'this.$main');
InitFunction:=InitAssign.Expr as TJSFunctionDeclarationStatement;
FJSInitBody:=InitFunction.AFunction.Body as TJSFunctionBody;
end;
procedure TTestModule.CheckDottedIdentifier(Msg: string; El: TJSElement;
DottedName: string);
begin
if DottedName='' then
begin
AssertNull(Msg,El);
end
else
begin
AssertNotNull(Msg,El);
AssertEquals(Msg,DottedName,GetDottedIdentifier(EL));
end;
end;
function TTestModule.GetDottedIdentifier(El: TJSElement): string;
begin
if El=nil then
Result:=''
else if El is TJSPrimaryExpressionIdent then
Result:=String(TJSPrimaryExpressionIdent(El).Name)
else if El is TJSDotMemberExpression then
Result:=GetDottedIdentifier(TJSDotMemberExpression(El).MExpr)+'.'+String(TJSDotMemberExpression(El).Name)
else
AssertEquals('GetDottedIdentifier',TJSPrimaryExpressionIdent,El.ClassType);
end;
procedure TTestModule.CheckSource(Msg, Statements, InitStatements: string);
var
ActualSrc, ExpectedSrc: String;
begin
ActualSrc:=JSToStr(JSModuleSrc);
ExpectedSrc:=Statements+LineEnding
+'this.$main = function () {'+LineEnding
+InitStatements
+'};'+LineEnding;
CheckDiff(Msg,ExpectedSrc,ActualSrc);
end;
procedure TTestModule.CheckDiff(Msg, Expected, Actual: string);
// search diff, ignore changes in spaces
const
SpaceChars = [#9,#10,#13,' '];
var
ExpectedP, ActualP: PChar;
function FindLineEnd(p: PChar): PChar;
begin
Result:=p;
while not (Result^ in [#0,#10,#13]) do inc(Result);
end;
function FindLineStart(p, MinP: PChar): PChar;
begin
while (p>MinP) and not (p[-1] in [#10,#13]) do dec(p);
Result:=p;
end;
procedure DiffFound;
var
ActLineStartP, ActLineEndP, p, StartPos: PChar;
ExpLine, ActLine: String;
i: Integer;
begin
writeln('Diff found "',Msg,'". Lines:');
// write correct lines
p:=PChar(Expected);
repeat
StartPos:=p;
while not (p^ in [#0,#10,#13]) do inc(p);
ExpLine:=copy(Expected,StartPos-PChar(Expected)+1,p-StartPos);
if p^ in [#10,#13] then begin
if (p[1] in [#10,#13]) and (p^<>p[1]) then
inc(p,2)
else
inc(p);
end;
if p<=ExpectedP then begin
writeln('= ',ExpLine);
end else begin
// diff line
// write actual line
ActLineStartP:=FindLineStart(ActualP,PChar(Actual));
ActLineEndP:=FindLineEnd(ActualP);
ActLine:=copy(Actual,ActLineStartP-PChar(Actual)+1,ActLineEndP-ActLineStartP);
writeln('- ',ActLine);
// write expected line
writeln('+ ',ExpLine);
// write empty line with pointer ^
for i:=1 to 2+ExpectedP-StartPos do write(' ');
writeln('^');
AssertEquals(Msg,ExpLine,ActLine);
break;
end;
until p^=#0;
raise Exception.Create('diff found, but lines are the same, internal error');
end;
var
IsSpaceNeeded: Boolean;
LastChar: Char;
begin
if Expected='' then Expected:=' ';
if Actual='' then Actual:=' ';
ExpectedP:=PChar(Expected);
ActualP:=PChar(Actual);
repeat
//writeln('TTestModule.CheckDiff Exp="',ExpectedP^,'" Act="',ActualP^,'"');
case ExpectedP^ of
#0:
begin
// check that rest of Actual has only spaces
while ActualP^ in SpaceChars do inc(ActualP);
if ActualP^<>#0 then
DiffFound;
exit;
end;
' ',#9,#10,#13:
begin
// skip space in Expected
IsSpaceNeeded:=false;
if ExpectedP>PChar(Expected) then
LastChar:=ExpectedP[-1]
else
LastChar:=#0;
while ExpectedP^ in SpaceChars do inc(ExpectedP);
if (LastChar in ['a'..'z','A'..'Z','0'..'9','_','$'])
and (ExpectedP^ in ['a'..'z','A'..'Z','0'..'9','_','$']) then
IsSpaceNeeded:=true;
if IsSpaceNeeded and (not (ActualP^ in SpaceChars)) then
DiffFound;
while ActualP^ in SpaceChars do inc(ActualP);
end;
else
while ActualP^ in SpaceChars do inc(ActualP);
if ExpectedP^<>ActualP^ then
DiffFound;
inc(ExpectedP);
inc(ActualP);
end;
until false;
end;
procedure TTestModule.TestEmptyProgram;
begin
StartProgram(false);
Add('begin');
ConvertProgram;
CheckSource('Empty program','','');
end;
procedure TTestModule.TestVarInt;
begin
StartProgram(false);
Add('var i: longint;');
Add('begin');
ConvertProgram;
CheckSource('TestVarInt','this.i=0;','');
end;
procedure TTestModule.TestEmptyProc;
begin
StartProgram(false);
Add('procedure Test;');
Add('begin');
Add('end;');
Add('begin');
ConvertProgram;
CheckSource('TestEmptyProc',
LinesToStr([ // statements
'this.test = function () {',
'};'
]),
LinesToStr([ // this.$main
''
]));
end;
procedure TTestModule.TestProcTwoArgs;
begin
StartProgram(false);
Add('procedure Test(a,b: longint);');
Add('begin');
Add('end;');
Add('begin');
ConvertProgram;
CheckSource('TestProcTwoArgs',
LinesToStr([ // statements
'this.test = function (a,b) {',
'};'
]),
LinesToStr([ // this.$main
''
]));
end;
procedure TTestModule.TestFunctionInt;
begin
StartProgram(false);
Add('function Test(a: longint): longint;');
Add('begin');
Add(' Result:=2*a');
Add('end;');
Add('begin');
ConvertProgram;
CheckSource('TestProcTwoArgs',
LinesToStr([ // statements
'this.test = function (a) {',
' var result = 0;',
' result = (2*a);',
' return result;',
'};'
]),
LinesToStr([ // this.$main
''
]));
end;
procedure TTestModule.TestFunctionString;
begin
StartProgram(false);
Add('function Test(a: string): string;');
Add('begin');
Add(' Result:=a+a');
Add('end;');
Add('begin');
ConvertProgram;
CheckSource('TestProcTwoArgs',
LinesToStr([ // statements
'this.test = function (a) {',
' var result = "";',
' result = (a+a);',
' return result;',
'};'
]),
LinesToStr([ // this.$main
''
]));
end;
procedure TTestModule.TestVarRecord;
begin
StartProgram(false);
Add('type');
Add(' TRecA = record');
Add(' B: longint;');
Add(' end;');
Add('var r: TRecA;');
Add('begin');
Add(' r.B:=123');
ConvertProgram;
CheckSource('TestVarRecord',
LinesToStr([ // statements
'this.treca = function () {',
' b = 0;',
'};',
'this.r = new this.treca();'
]),
LinesToStr([ // this.$main
'this.r.b = 123;'
]));
end;
procedure TTestModule.TestForLoop;
begin
StartProgram(false);
Add('var');
Add(' i, j, n: longint;');
Add('begin');
Add(' j:=0;');
Add(' n:=3;');
Add(' for i:=1 to n do');
Add(' begin');
Add(' j:=j+i;');
Add(' end;');
ConvertProgram;
CheckSource('TestVarRecord',
LinesToStr([ // statements
'this.i = 0;',
'this.j = 0;',
'this.n = 0;'
]),
LinesToStr([ // this.$main
' this.j = 0;',
' this.n = 3;',
' this.i = 1;',
' for (var $loopend = this.n; (this.i <= $loopend); this.i++) {',
' this.j = (this.j + this.i);',
' };'
]));
end;
procedure TTestModule.TestForLoopInFunction;
begin
StartProgram(false);
Add('function SumNumbers(n: longint): longint;');
Add('var');
Add(' i, j: longint;');
Add('begin');
Add(' j:=0;');
Add(' for i:=1 to n do');
Add(' begin');
Add(' j:=j+i;');
Add(' end;');
Add('end;');
Add('begin');
Add(' SumNumbers(3);');
ConvertProgram;
CheckSource('TestVarRecord',
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++) {',
' j = (j + i);',
' };',
' return result;',
'};'
]),
LinesToStr([ // this.$main
' this.sumnumbers(3);'
]));
end;
procedure TTestModule.TestRepeatUntil;
begin
StartProgram(false);
Add('var');
Add(' i, j, n: longint;');
Add('begin');
Add(' n:=3;');
Add(' j:=0;');
Add(' i:=0;');
Add(' repeat');
Add(' i:=i+1;');
Add(' j:=j+i;');
Add(' until i>=n');
ConvertProgram;
CheckSource('TestVarRecord',
LinesToStr([ // statements
'this.i = 0;',
'this.j = 0;',
'this.n = 0;'
]),
LinesToStr([ // this.$main
' this.n = 3;',
' this.j = 0;',
' this.i = 0;',
' do{',
' this.i = (this.i + 1);',
' this.j = (this.j + this.i);',
' }while(!(this.i>=this.n));'
]));
end;
procedure TTestModule.TestAsmBlock;
begin
StartProgram(false);
Add('var');
Add(' i: longint;');
Add('begin');
Add(' i:=1;');
Add(' asm');
Add(' if (i==1) {');
Add(' i=2;');
Add(' }');
Add(' if (i==2){ i=3; }');
Add(' end;');
Add(' i:=4;');
ConvertProgram;
CheckSource('TestAsm',
LinesToStr([ // statements
'this.i = 0;'
]),
LinesToStr([ // this.$main
' this.i = 1;',
'if (i==1) {',
'i=2;',
'}',
'if (i==2){ i=3; }',
';',
'this.i = 4;'
]));
end;
procedure TTestModule.TestTryFinally;
begin
StartProgram(false);
Add('var i: longint;');
Add('begin');
Add(' try');
Add(' i:=0; i:=2 div i;');
Add(' finally');
Add(' i:=3');
Add(' end;');
ConvertProgram;
end;
Initialization
RegisterTests([TTestModule]);
end.

2
packages/pastojs/tests/testpas2js.pp
View File

@ -17,7 +17,7 @@ program testpas2js;
{$mode objfpc}{$H+}
uses
Classes, consoletestrunner, tcconverter, fppas2js;
Classes, consoletestrunner, tcconverter, tcmodules;
type

15
utils/fpdoc/dw_html.pp
View File

@ -1938,6 +1938,8 @@ var
TREl, TDEl: TDOMElement;
CurVariant: TPasVariant;
isExtended : Boolean;
VariantEl: TPasElement;
VariantType: TPasType;
begin
if not (Element.Parent is TPasVariant) then
@ -1972,18 +1974,21 @@ begin
AppendSym(CodeEl, ';');
end;
if Assigned(Element.VariantType) then
if Assigned(Element.VariantEl) then
begin
TREl := CreateTR(TableEl);
CodeEl := CreateCode(CreatePara(CreateTD_vtop(TREl)));
AppendNbSp(CodeEl, NestingLevel * 2 + 2);
AppendKw(CodeEl, 'case ');
if TPasRecordType(Element).VariantName <> '' then
VariantEl:=TPasRecordType(Element).VariantEl;
if VariantEl is TPasVariable then
begin
AppendText(CodeEl, TPasRecordType(Element).VariantName);
AppendText(CodeEl, TPasVariable(VariantEl).Name);
AppendSym(CodeEl, ': ');
end;
CodeEl := AppendType(CodeEl, TableEl, TPasRecordType(Element).VariantType, True);
VariantType:=TPasVariable(VariantEl).VarType;
end else
VariantType:=VariantEl as TPasType;
CodeEl := AppendType(CodeEl, TableEl, VariantType, True);
AppendKw(CodeEl, ' of');
for i := 0 to TPasRecordType(Element).Variants.Count - 1 do
begin