paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-04-05 18:17:45 +02:00
Code Issues Packages Projects Releases Wiki Activity

missing patches from trunk

Browse Source
This commit is contained in:
mattias 2020-12-07 23:53:55 +00:00
parent 6330aa3fd6
commit 327e6aa0c9
19 changed files with 659 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
compiler/packages/fcl-passrc/src/pastree.pp
View File

@ -111,7 +111,8 @@ type
TPasMemberVisibility = (visDefault, visPrivate, visProtected, visPublic,
visPublished, visAutomated,
visStrictPrivate, visStrictProtected);
visStrictPrivate, visStrictProtected,
visRequired, visOptional);
TCallingConvention = (ccDefault,ccRegister,ccPascal,ccCDecl,ccStdCall,
ccOldFPCCall,ccSafeCall,ccSysCall,ccMWPascal,
@ -533,6 +534,7 @@ type
procedure ClearTypeReferences(aType: TPasElement); override;
public
DestType: TPasType;
SubType: TPasType;
Expr: TPasExpr;
end;
@ -1167,7 +1169,8 @@ type
otBitwiseAnd, otbitwiseXor,
otLogicalAnd, otLogicalNot, otLogicalXor,
otRightShift,
otEnumerator, otIn
otEnumerator, otIn,
otInitialize // Management operator
);
TOperatorTypes = set of TOperatorType;
@ -1700,7 +1703,7 @@ const
VisibilityNames: array[TPasMemberVisibility] of string = (
'default','private', 'protected', 'public', 'published', 'automated',
'strict private', 'strict protected');
'strict private', 'strict protected','required','optional');
ObjKindNames: array[TPasObjKind] of string = (
'object', 'class', 'interface',
@ -1749,13 +1752,13 @@ const
'>',':=','<>','<=','>=','**',
'><','Inc','Dec','mod','-','+','Or','div',
'shl','or','and','xor','and','not','xor',
'shr','enumerator','in');
'shr','enumerator','in','');
OperatorNames : Array[TOperatorType] of string
= ('','implicit','explicit','multiply','add','subtract','divide','lessthan','equal',
'greaterthan','assign','notequal','lessthanorequal','greaterthanorequal','power',
'symmetricaldifference','inc','dec','modulus','negative','positive','bitwiseor','intdivide',
'leftshift','logicalor','bitwiseand','bitwisexor','logicaland','logicalnot','logicalxor',
'rightshift','enumerator','in');
'rightshift','enumerator','in','initialize');
AssignKindNames : Array[TAssignKind] of string = (':=','+=','-=','*=','/=' );
@ -2834,7 +2837,9 @@ begin
Result := Result + ', ';
Result := Result + TPasArgument(ProcType.Args[i]).ArgType.Name;
end;
Result := Result + '): ' + TPasFunctionType(ProcType).ResultEl.ResultType.Name;
Result := Result + ')';
if (OperatorType<>otInitialize) and Assigned(TPasFunctionType(ProcType).ResultEl.ResultType) then
Result:=Result+': ' + TPasFunctionType(ProcType).ResultEl.ResultType.Name;
If WithPath then
begin
S:=Self.ParentPath;
@ -3302,6 +3307,7 @@ end;
destructor TPasAliasType.Destroy;
begin
ReleaseAndNil(TPasElement(SubType){$IFDEF CheckPasTreeRefCount},'TPasAliasType.SubType'{$ENDIF});
ReleaseAndNil(TPasElement(DestType){$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
ReleaseAndNil(TPasElement(Expr){$IFDEF CheckPasTreeRefCount},'TPasAliasType.Expr'{$ENDIF});
inherited Destroy;

8
compiler/packages/fcl-passrc/src/paswrite.pp
View File

@ -1408,11 +1408,11 @@ end;
procedure TPasWriter.WriteImplRaise(aRaise: TPasImplRaise);
begin
if assigned(aRaise.ExceptObject) then
if assigned(aRaise.ExceptObject) then
begin
Add('raise %s',[GetExpr(aRaise.ExceptObject)]);
if aRaise.ExceptAddr<>Nil then
Add(' at %s',[GetExpr(aRaise.ExceptAddr)]);
Add('raise %s',[GetExpr(aRaise.ExceptObject)]);
if aRaise.ExceptAddr<>Nil then
Add(' at %s',[GetExpr(aRaise.ExceptAddr)]);
end
else
Add('raise');

189
compiler/packages/fcl-passrc/src/pparser.pp
View File

@ -311,7 +311,7 @@ type
function CheckProcedureArgs(Parent: TPasElement;
Args: TFPList; // list of TPasArgument
ProcType: TProcType): boolean;
function CheckVisibility(S: String; var AVisibility: TPasMemberVisibility): Boolean;
function CheckVisibility(S: String; var AVisibility: TPasMemberVisibility; IsObjCProtocol : Boolean = False): Boolean;
procedure ParseExc(MsgNumber: integer; const Msg: String);
procedure ParseExc(MsgNumber: integer; const Fmt: String; Args : Array of {$ifdef pas2js}jsvalue{$else}const{$endif});
procedure ParseExcExpectedIdentifier;
@ -1192,29 +1192,40 @@ procedure TPasParser.ChangeToken(tk: TToken);
var
Cur, Last: PTokenRec;
IsLast: Boolean;
Procedure DoChange(tk1,tk2 : TToken);
begin
// change last token '>>' into two '>'
Cur:=@FTokenRing[FTokenRingCur];
Cur^.Token:=tk2;
Cur^.AsString:=TokenInfos[tk2];
Last:=@FTokenRing[FTokenRingEnd];
Last^.Token:=tk2;
Last^.AsString:=TokenInfos[tk2];
if Last^.Comments<>nil then
Last^.Comments.Clear;
Last^.SourcePos:=Cur^.SourcePos;
dec(Cur^.SourcePos.Column);
Last^.TokenPos:=Cur^.TokenPos;
inc(Last^.TokenPos.Column);
FTokenRingEnd:=(FTokenRingEnd+1) mod FTokenRingSize;
if FTokenRingStart=FTokenRingEnd then
FTokenRingStart:=(FTokenRingStart+1) mod FTokenRingSize;
FCurToken:=tk1;
FCurTokenString:=TokenInfos[tk1];
end;
begin
//writeln('TPasParser.ChangeToken FTokenBufferSize=',FTokenRingStart,' FTokenBufferIndex=',FTokenRingCur);
IsLast:=((FTokenRingCur+1) mod FTokenRingSize)=FTokenRingEnd;
if (CurToken=tkshr) and (tk=tkGreaterThan) and IsLast then
if (CurToken=tkGreaterEqualThan) and (tk=tkGreaterThan) and IsLast then
begin
// change last token '>>' into two '>'
Cur:=@FTokenRing[FTokenRingCur];
Cur^.Token:=tkGreaterThan;
Cur^.AsString:='>';
Last:=@FTokenRing[FTokenRingEnd];
Last^.Token:=tkGreaterThan;
Last^.AsString:='>';
if Last^.Comments<>nil then
Last^.Comments.Clear;
Last^.SourcePos:=Cur^.SourcePos;
dec(Cur^.SourcePos.Column);
Last^.TokenPos:=Cur^.TokenPos;
inc(Last^.TokenPos.Column);
FTokenRingEnd:=(FTokenRingEnd+1) mod FTokenRingSize;
if FTokenRingStart=FTokenRingEnd then
FTokenRingStart:=(FTokenRingStart+1) mod FTokenRingSize;
FCurToken:=tkGreaterThan;
FCurTokenString:='>';
DoChange(tkGreaterThan,tkEqual);
end
else if (CurToken=tkshr) and (tk=tkGreaterThan) and IsLast then
begin
DoChange(tkGreaterThan,tkGreaterThan);
end
else
CheckToken(tk);
@ -1748,12 +1759,20 @@ begin
end;
// read nested specialize arguments
ReadSpecializeArguments(ST,ST.Params);
// Important: resolve type reference AFTER args, because arg count is needed
ST.DestType:=ResolveTypeReference(GenName,ST,ST.Params.Count);
if CurToken<>tkGreaterThan then
ParseExcTokenError('[20190801113005]');
// ToDo: cascaded specialize A<B>.C<D>
// Check for cascaded specialize A<B>.C or A<B>.C<D>
NextToken;
if CurToken<>tkDot then
UnGetToken
else
begin
NextToken;
ST.SubType:=ParseSimpleType(ST,CurSourcePos,GenName,False);
end;
// Important: resolve type reference AFTER args, because arg count is needed
ST.DestType:=ResolveTypeReference(GenName,ST,ST.Params.Count);
Engine.FinishScope(stTypeDef,ST);
Result:=ST;
@ -1775,7 +1794,7 @@ begin
Try
// only allowed: ^dottedidentifer
// forbidden: ^^identifier, ^array of word, ^A<B>
ExpectIdentifier;
ExpectTokens([tkIdentifier,tkFile]);
Name:=CurTokenString;
repeat
NextToken;
@ -1787,7 +1806,14 @@ begin
else
break;
until false;
UngetToken;
if CurToken=tkLessThan then
begin
Repeat
NextToken; // We should do something with this.
Until CurToken=tkGreaterThan;
end
else
UngetToken;
Result.DestType:=ResolveTypeReference(Name,Result);
Engine.FinishScope(stTypeDef,Result);
ok:=true;
@ -3613,6 +3639,7 @@ begin
pt:=GetProcTypeFromToken(CurToken,True);
AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt, MustBeGeneric));
end;
tkAbsolute,
tkIdentifier:
begin
Scanner.UnSetTokenOption(toOperatorToken);
@ -4204,8 +4231,12 @@ begin
until CurToken<>tkComma;
Engine.FinishScope(stTypeDef,T);
until not (CurToken in [tkSemicolon,tkComma]);
if CurToken<>tkGreaterThan then
ParseExcExpectedAorB(TokenInfos[tkComma], TokenInfos[tkGreaterThan]);
if Not (CurToken in [tkGreaterThan,tkGreaterEqualThan]) then
ParseExcExpectedAorB(TokenInfos[tkComma], TokenInfos[tkGreaterThan])
else if CurToken=tkGreaterEqualThan then
begin
ChangeToken(tkGreaterThan);
end;
end;
{$warn 5043 on}
@ -4557,8 +4588,16 @@ begin
begin
Result:=True;
NextToken;
Location:=ReadDottedIdentifier(Parent,AbsoluteExpr,true);
UnGetToken;
if Curtoken=tkNumber then
begin
AbsoluteExpr:=CreatePrimitiveExpr(Parent,pekNumber,CurTokenString);
Location:=CurTokenString
end
else
begin
Location:=ReadDottedIdentifier(Parent,AbsoluteExpr,true);
UnGetToken;
end
end
else
UngetToken;
@ -4619,6 +4658,8 @@ begin
Result := Result + ' ' + CurTokenText;
LibName:=DoParseExpression(Parent);
end;
if CurToken=tkSemiColon then
exit;
if not CurTokenIsIdentifier('name') then
ParseExcSyntaxError;
NextToken;
@ -5318,13 +5359,17 @@ begin
begin
ResultEl.Name := CurTokenName;
ExpectToken(tkColon);
end
else
if (CurToken=tkColon) then
ResultEl.Name := 'Result'
else
ParseExc(nParserExpectedColonID,SParserExpectedColonID);
ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
end
else if not ((Parent is TPasOperator) and (TPasOperator(Parent).OperatorType=otInitialize)) then
// Initialize operator has no result
begin
if (CurToken=tkColon) then
ResultEl.Name := 'Result'
else
ParseExc(nParserExpectedColonID,SParserExpectedColonID);
ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
end;
end;
else
ResultEl:=Nil;
@ -5381,9 +5426,9 @@ begin
else
// remove legacy or basesysv on MorphOS syscalls
begin
if CurTokenIsIdentifier('legacy') or CurTokenIsIdentifier('BaseSysV') then
if CurTokenIsIdentifier('legacy') or CurTokenIsIdentifier('consoledevice')
or (Curtoken=tkIdentifier) and (Pos('base',LowerCase(CurtokenText))>0) then
NextToken;
NextToken; // remove offset
end;
end;
if IsProcType then
@ -6816,6 +6861,24 @@ var
Scanner.UnSetTokenOption(toOperatorToken);
end;
Function CheckSection : Boolean;
begin
// Advanced records can have empty sections.
{ Use Case:
Record
type
const
var
Case Integer of
end;
}
NextToken;
Result:=CurToken in [tkvar,tktype,tkConst,tkCase];
if Not Result then
UngetToken;
end;
Var
VariantName : String;
v : TPasMemberVisibility;
@ -6827,7 +6890,10 @@ Var
CurEl: TPasElement;
LastToken: TToken;
AllowVisibility: Boolean;
IsGeneric : Boolean;
begin
IsGeneric:=False;
AllowVisibility:=msAdvancedRecords in CurrentModeswitches;
if AllowVisibility then
v:=visPublic
@ -6844,6 +6910,8 @@ begin
DisableIsClass;
if Not AllowMethods then
ParseExc(nErrRecordTypesNotAllowed,SErrRecordTypesNotAllowed);
if CheckSection then
continue;
ExpectToken(tkIdentifier);
ParseMembersLocalTypes(ARec,v);
end;
@ -6852,6 +6920,8 @@ begin
DisableIsClass;
if Not AllowMethods then
ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed);
if CheckSection then
continue;
ExpectToken(tkIdentifier);
ParseMembersLocalConsts(ARec,v);
end;
@ -6859,6 +6929,8 @@ begin
begin
if Not AllowMethods then
ParseExc(nErrRecordVariablesNotAllowed,SErrRecordVariablesNotAllowed);
if CheckSection then
continue;
ExpectToken(tkIdentifier);
OldCount:=ARec.Members.Count;
ParseInlineVarDecl(ARec, ARec.Members, v, AEndToken=tkBraceClose);
@ -6907,7 +6979,7 @@ begin
if Not AllowMethods then
ParseExc(nErrRecordMethodsNotAllowed,SErrRecordMethodsNotAllowed);
ProcType:=GetProcTypeFromToken(CurToken,LastToken=tkclass);
Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,false,v);
Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,IsGeneric,v);
if Proc.Parent is TPasOverloadedProc then
TPasOverloadedProc(Proc.Parent).Overloads.Add(Proc)
else
@ -6916,9 +6988,21 @@ begin
end;
tkDestructor:
ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
tkabsolute,tkGeneric,tkSelf, // Counts as field name
tkGeneric, // Can count as field name
tkabsolute,
tkSelf, // Count as field name
tkIdentifier :
begin
if (Curtoken=tkGeneric) and AllowVisibility then
begin
NextToken;
if CurToken in [tkClass,tkOperator,tkFunction,tkProcedure] then
begin
IsGeneric:=True;
Continue;
end;
UnGetToken;
end;
If AllowVisibility and CheckVisibility(CurTokenString,v) then
begin
if not (v in [visPrivate,visPublic,visStrictPrivate]) then
@ -6972,6 +7056,8 @@ begin
break;
LastToken:=CurToken;
NextToken;
if not IsClass then
IsGeneric:=False;
end;
end;
@ -7005,18 +7091,20 @@ begin
end;
end;
Function IsVisibility(S : String; var AVisibility :TPasMemberVisibility) : Boolean;
Function IsVisibility(S : String; var AVisibility :TPasMemberVisibility; IsObjCProtocol : Boolean) : Boolean;
Const
VNames : array[TPasMemberVisibility] of string =
('', 'private', 'protected', 'public', 'published', 'automated', '', '');
('', 'private', 'protected', 'public', 'published', 'automated', '', '','required','optional');
VLast : Array[Boolean] of TPasMemberVisibility = (visAutomated,visOptional);
Var
V : TPasMemberVisibility;
begin
Result:=False;
S:=lowerCase(S);
For V :=Low(TPasMemberVisibility) to High(TPasMemberVisibility) do
For V :=Low(TPasMemberVisibility) to VLast[isObjCProtocol] do
begin
Result:=(VNames[V]<>'') and (S=VNames[V]);
if Result then
@ -7027,8 +7115,7 @@ begin
end;
end;
function TPasParser.CheckVisibility(S: String;
var AVisibility: TPasMemberVisibility): Boolean;
function TPasParser.CheckVisibility(S: String; var AVisibility: TPasMemberVisibility; IsObjCProtocol : Boolean = false): Boolean;
Var
B : Boolean;
@ -7041,7 +7128,7 @@ begin
NextToken;
s:=LowerCase(CurTokenString);
end;
Result:=isVisibility(S,AVisibility);
Result:=isVisibility(S,AVisibility,isObjCProtocol);
if Result then
begin
if (AVisibility=visPublished) and (msOmitRTTI in Scanner.CurrentModeSwitches) then
@ -7277,7 +7364,7 @@ begin
CurSection:=stVar;
end;
tkIdentifier:
if CheckVisibility(CurTokenString,CurVisibility) then
if CheckVisibility(CurTokenString,CurVisibility,(AType.ObjKind=okObjcProtocol)) then
CurSection:=stNone
else
begin
@ -7295,6 +7382,8 @@ begin
if not (AType.ObjKind in okWithFields) then
ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowedInX,[ObjKindNames[AType.ObjKind]]);
ParseClassFields(AType,CurVisibility,CurSection=stClassVar);
if Curtoken=tkEnd then // case Ta = Class x : String end;
UngetToken;
HaveClass:=False;
end;
stClassVar:
@ -7446,7 +7535,7 @@ begin
CheckToken(tkend);
NextToken;
AType.AncestorType := ParseTypeReference(AType,false,Expr);
if AType.ObjKind in [okClass,okObjCClass] then
if AType.ObjKind in [okClass,okObjCClass,okObjcProtocol] then
while CurToken=tkComma do
begin
NextToken;
@ -7482,7 +7571,7 @@ end;
function TPasParser.DoParseClassExternalHeader(AObjKind: TPasObjKind; out AExternalNameSpace, AExternalName: string): Boolean;
begin
Result:=False;
if ((aObjKind in [okObjcCategory,okObjcClass]) or
if ((aObjKind in [okObjcCategory,okObjcClass,okObjcProtocol]) or
((AObjKind in [okClass,okInterface]) and (msExternalClass in CurrentModeswitches)))
and CurTokenIsIdentifier('external') then
begin
@ -7494,7 +7583,7 @@ begin
AExternalNameSpace:=CurTokenString;
if (aObjKind in [okObjcCategory,okObjcClass]) then
begin
// Name is optional in objcclass/category
// Name is optional in objcclass/category/protocol
NextToken;
if CurToken=tkBraceOpen then
exit;

7
compiler/packages/fcl-passrc/src/pscanner.pp
View File

@ -1643,6 +1643,7 @@ begin
'$':
begin
FToken:=tkNumber;
inc(FTokenEnd);
{$ifdef UsePChar}
while FTokenEnd^ in HexDigits do inc(FTokenEnd);
{$else}
@ -3010,8 +3011,6 @@ Procedure TPascalScanner.PopStackItem;
var
IncludeStackItem: TIncludeStackItem;
aFileName : String;
begin
IncludeStackItem :=
TIncludeStackItem(FIncludeStack[FIncludeStack.Count - 1]);
@ -3798,8 +3797,8 @@ begin
SetMode(msMac,MacModeSwitches,false,bsMacPasMode);
'ISO':
SetMode(msIso,ISOModeSwitches,false,[],[],false);
'EXTENDED':
SetMode(msExtpas,ExtPasModeSwitches,false,[],[],false);
'EXTENDEDPASCAL':
SetMode(msExtpas,ExtPasModeSwitches,false);
'GPC':
SetMode(msGPC,GPCModeSwitches,false);
else

73
compiler/packages/fcl-passrc/tests/tcclasstype.pas
View File

@ -33,7 +33,7 @@ type
Procedure StartClass (AncestorName : String = 'TObject'; InterfaceList : String = ''; aClassType : TClassDeclType = cdtClass);
Procedure StartExternalClass (AParent : String; AExternalName,AExternalNameSpace : String );
Procedure StartClassHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject');
Procedure StartInterface (AParent : String = 'IInterface'; UUID : String = ''; Disp : Boolean = False; UseObjcClass : Boolean = False);
Procedure StartInterface (AParent : String = 'IInterface'; UUID : String = ''; Disp : Boolean = False; UseObjcClass : Boolean = False; UseExternal : Boolean = False);
Procedure StartRecordHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject');
Procedure StartVisibility(A : TPasMemberVisibility);
Procedure EndClass(AEnd : String = 'end');
@ -105,6 +105,7 @@ type
Procedure TestMethodWithDotFails;
Procedure TestMethodWithDotOK;
Procedure TestMethodFunctionWithDotOK;
Procedure TestNoSemicolon;
Procedure TestClassMethodSimple;
Procedure TestClassMethodSimpleComment;
Procedure TestConstructor;
@ -170,6 +171,10 @@ type
procedure TestClassHelperOneMethod;
procedure TestInterfaceEmpty;
procedure TestObjcProtocolEmpty;
procedure TestObjcProtocolEmptyExternal;
procedure TestObjcProtocolMultiParent;
procedure TestObjcProtocolOptional;
procedure TestObjcProtocolRequired;
procedure TestInterfaceDisp;
procedure TestInterfaceParentedEmpty;
procedure TestInterfaceOneMethod;
@ -320,7 +325,7 @@ begin
end;
procedure TTestClassType.StartInterface(AParent: String; UUID: String;
Disp: Boolean = False; UseObjcClass : Boolean = False);
Disp: Boolean = False; UseObjcClass : Boolean = False; UseExternal : Boolean = False);
Var
S : String;
begin
@ -328,7 +333,9 @@ begin
if UseObjCClass then
begin
FDecl.Add('{$modeswitch objectivec1}');
S:='TMyClass = objcprotocol'
S:='TMyClass = objcprotocol';
if UseExternal then
S:=S+' external name ''abc'' ';
end
else if Disp then
S:='TMyClass = DispInterface'
@ -971,6 +978,13 @@ begin
AssertNotNull('1 method resolution procedure',TPasMethodResolution(members[0]).ImplementationProc);
end;
procedure TTestClassType.TestNoSemicolon;
begin
StartClass;
fDecl.Add('Y : String');
ParseClass;
end;
procedure TTestClassType.TestClassMethodSimple;
begin
@ -1929,6 +1943,59 @@ begin
AssertNull('No UUID',TheClass.GUIDExpr);
end;
procedure TTestClassType.TestObjcProtocolEmptyExternal;
begin
StartInterface('','',False,True,true);
EndClass();
ParseClass;
AssertEquals('Is interface',okObjcProtocol,TheClass.ObjKind);
AssertTrue('Is objectivec',TheClass.IsObjCClass);
AssertEquals('No members',0,TheClass.Members.Count);
AssertNull('No UUID',TheClass.GUIDExpr);
end;
procedure TTestClassType.TestObjcProtocolMultiParent;
begin
StartInterface('A, B','',False,True,true);
FParent:='A';
EndClass();
ParseClass;
AssertEquals('Is interface',okObjcProtocol,TheClass.ObjKind);
AssertTrue('Is objectivec',TheClass.IsObjCClass);
AssertEquals('No members',0,TheClass.Members.Count);
AssertNull('No UUID',TheClass.GUIDExpr);
AssertEquals('Have 1 interface',1,TheClass.Interfaces.Count);
AssertNotNull('Correct class',TheClass.Interfaces[0]);
AssertEquals('Correct class',TPasUnresolvedTypeRef,TObject(TheClass.Interfaces[0]).ClassType);
AssertEquals('Interface name','B',TPasUnresolvedTypeRef(TheClass.Interfaces[0]).Name);
end;
procedure TTestClassType.TestObjcProtocolOptional;
begin
StartInterface('','',False,True);
FDecl.Add(' optional');
AddMember('Procedure DoSomething(A : Integer)');
EndClass();
ParseClass;
AssertEquals('Is interface',okObjcProtocol,TheClass.ObjKind);
AssertTrue('Is objectivec',TheClass.IsObjCClass);
AssertEquals('No members',1,TheClass.Members.Count);
AssertNull('No UUID',TheClass.GUIDExpr);
end;
procedure TTestClassType.TestObjcProtocolRequired;
begin
StartInterface('','',False,True);
FDecl.Add(' required');
AddMember('Procedure DoSomething(A : Integer)');
EndClass();
ParseClass;
AssertEquals('Is interface',okObjcProtocol,TheClass.ObjKind);
AssertTrue('Is objectivec',TheClass.IsObjCClass);
AssertEquals('No members',1,TheClass.Members.Count);
AssertNull('No UUID',TheClass.GUIDExpr);
end;
procedure TTestClassType.TestInterfaceDisp;
begin

25
compiler/packages/fcl-passrc/tests/tcgenerics.pp
View File

@ -21,6 +21,7 @@ Type
Procedure TestProcTypeGenerics;
Procedure TestDeclarationDelphi;
Procedure TestDeclarationFPC;
Procedure TestDeclarationFPCNoSpaces;
Procedure TestMethodImplementation;
// generic constraints
@ -108,6 +109,9 @@ begin
Source.Add(' TSomeClass<T,T2> = Class(TObject)');
Source.Add(' b : T;');
Source.Add(' b2 : T2;');
Source.Add(' FItems: ^TArray<T>;');
Source.Add(' type');
Source.Add(' TDictionaryEnumerator = TDictionary<T, TEmptyRecord>.TKeyEnumerator;');
Source.Add(' end;');
ParseDeclarations;
AssertNotNull('have generic definition',Declarations.Classes);
@ -141,6 +145,27 @@ begin
AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent);
end;
procedure TTestGenerics.TestDeclarationFPCNoSpaces;
Var
T : TPasClassType;
begin
Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches;
Source.Add('Type');
Source.Add(' TSomeClass<T;T2>=Class(TObject)');
Source.Add(' b : T;');
Source.Add(' b2 : T2;');
Source.Add(' end;');
ParseDeclarations;
AssertNotNull('have generic definition',Declarations.Classes);
AssertEquals('have generic definition',1,Declarations.Classes.Count);
AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType);
T:=TPasClassType(Declarations.Classes[0]);
AssertNotNull('have generic templates',T.GenericTemplateTypes);
AssertEquals('2 template types',2,T.GenericTemplateTypes.Count);
AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent);
AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent);
end;
procedure TTestGenerics.TestMethodImplementation;
begin
With source do

14
compiler/packages/fcl-passrc/tests/tconstparser.pas
View File

@ -43,6 +43,7 @@ Type
Procedure TestSimpleIdentifierConst;
Procedure TestSimpleSetConst;
Procedure TestSimpleExprConst;
Procedure TestSimpleAbsoluteConst;
Procedure TestSimpleIntConstDeprecatedMsg;
Procedure TestSimpleIntConstDeprecated;
Procedure TestSimpleFloatConstDeprecated;
@ -255,6 +256,19 @@ begin
DoTestSimpleExprConst;
end;
procedure TTestConstParser.TestSimpleAbsoluteConst;
// Found in xi.pp
begin
Add('Const');
Add(' Absolute = 1;');
ParseDeclarations;
AssertEquals('One constant definition',1,Declarations.Consts.Count);
AssertEquals('First declaration is constant definition.',TPasConst,TObject(Declarations.Consts[0]).ClassType);
end;
procedure TTestConstParser.TestSimpleIntConstDeprecatedMsg;
begin
Hint:='deprecated ''this is old''' ;

108
compiler/packages/fcl-passrc/tests/tcprocfunc.pas
View File

@ -122,6 +122,10 @@ type
procedure TestCallingConventionSysV_ABI_CDec;
procedure TestCallingConventionSysV_ABI_Default;
procedure TestCallingConventionVectorCall;
procedure TestCallingConventionSysCall;
procedure TestCallingConventionSysCallExecbase;
procedure TestCallingConventionSysCallUtilitybase;
procedure TestCallingConventionSysCallConsoleDevice;
Procedure TestProcedurePublic;
Procedure TestProcedurePublicIdent;
Procedure TestFunctionPublic;
@ -174,6 +178,7 @@ type
Procedure TestProcedureCdeclExternalName;
Procedure TestFunctionCdeclExternalName;
Procedure TestFunctionAlias;
Procedure TestOperatorNamedResult;
Procedure TestOperatorTokens;
procedure TestOperatorNames;
Procedure TestAssignOperatorAfterObject;
@ -812,6 +817,30 @@ begin
AssertProc([],[],ccVectorCall,0);
end;
procedure TTestProcedureFunction.TestCallingConventionSysCall;
begin
ParseProcedure('; syscall abc');
AssertProc([],[],ccSysCall,0);
end;
procedure TTestProcedureFunction.TestCallingConventionSysCallExecbase;
begin
ParseProcedure('; syscall _execBase 123');
AssertProc([],[],ccSysCall,0);
end;
procedure TTestProcedureFunction.TestCallingConventionSysCallUtilitybase;
begin
ParseProcedure('; syscall _utilityBase 123');
AssertProc([],[],ccSysCall,0);
end;
procedure TTestProcedureFunction.TestCallingConventionSysCallConsoleDevice;
begin
ParseProcedure('; syscall ConsoleDevice 123');
AssertProc([],[],ccSysCall,0);
end;
procedure TTestProcedureFunction.TestCallingConventionHardFloat;
begin
ParseProcedure('; HardFloat');
@ -1005,14 +1034,14 @@ procedure TTestProcedureFunction.TestProcedureFar;
begin
AddDeclaration('procedure A; far;');
ParseProcedure;
AssertProc([pmfar],[],ccDefault,0);
AssertProc([pmfar],[ptmfar],ccDefault,0);
end;
procedure TTestProcedureFunction.TestFunctionFar;
begin
AddDeclaration('function A : integer; far;');
ParseFunction;
AssertFunc([pmfar],[],ccDefault,0);
AssertFunc([pmfar],[ptmfar],ccDefault,0);
end;
procedure TTestProcedureFunction.TestProcedureCdeclForward;
@ -1284,6 +1313,13 @@ begin
AssertEquals('Alias name','''myalias''',Func.AliasName);
end;
procedure TTestProcedureFunction.TestOperatorNamedResult;
begin
AddDeclaration('operator = (a,b : T) z : Integer;');
ParseOperator;
AssertEquals('Correct operator type',otEqual,FOperator.OperatorType);
end;
procedure TTestProcedureFunction.TestProcedureAlias;
begin
AddDeclaration('Procedure A; Alias : ''myalias''');
@ -1300,23 +1336,25 @@ Var
begin
For t:=otMul to High(TOperatorType) do
begin
if OperatorTokens[t]='' then continue;
// No way to distinguish between logical/bitwise or/and/Xor
if not (t in [otBitwiseOr,otBitwiseAnd,otBitwiseXor]) then
begin
S:=GetEnumName(TypeInfo(TOperatorType),Ord(T));
ResetParser;
if t in UnaryOperators then
AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorTokens[t]]))
else
AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorTokens[t]]));
ParseOperator;
AssertEquals(S+': Token based ',Not (T in [otInc,otDec,otEnumerator]),FOperator.TokenBased);
AssertEquals(S+': Correct operator type',T,FOperator.OperatorType);
if t in UnaryOperators then
AssertEquals(S+': Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name)
else
AssertEquals(S+': Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name);
end;
if t in [otBitWiseOr,otBitwiseAnd,otbitwiseXor] then continue;
S:=GetEnumName(TypeInfo(TOperatorType),Ord(T));
ResetParser;
if t in UnaryOperators then
AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorTokens[t]]))
else
AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorTokens[t]]));
ParseOperator;
AssertEquals(S+': Token based ',Not (T in [otInc,otDec,otEnumerator]),FOperator.TokenBased);
AssertEquals(S+': Correct operator type',T,FOperator.OperatorType);
if t in UnaryOperators then
AssertEquals(S+': Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name)
else
AssertEquals(S+': Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name);
end;
end;
procedure TTestProcedureFunction.TestOperatorNames;
@ -1327,21 +1365,25 @@ Var
begin
For t:=Succ(otUnknown) to High(TOperatorType) do
begin
S:=GetEnumName(TypeInfo(TOperatorType),Ord(T));
ResetParser;
if t in UnaryOperators then
AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorNames[t]]))
else
AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorNames[t]]));
ParseOperator;
AssertEquals(S+': Token based',t in [otIn],FOperator.TokenBased);
AssertEquals(S+': Correct operator type',T,FOperator.OperatorType);
if t in UnaryOperators then
AssertEquals('Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name)
else
AssertEquals('Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name);
end;
begin
if OperatorNames[t]='' then continue;
// otInitialize has no result
if t=otInitialize then continue;
writeln('TTestProcedureFunction.TestOperatorTokens ',t);
S:=GetEnumName(TypeInfo(TOperatorType),Ord(T));
ResetParser;
if t in UnaryOperators then
AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorNames[t]]))
else
AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorNames[t]]));
ParseOperator;
AssertEquals(S+': Token based',t in [otIn],FOperator.TokenBased);
AssertEquals(S+': Correct operator type',T,FOperator.OperatorType);
if t in UnaryOperators then
AssertEquals('Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name)
else
AssertEquals('Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name);
end;
end;
procedure TTestProcedureFunction.TestAssignOperatorAfterObject;

93
compiler/packages/fcl-passrc/tests/tctypeparser.pas
View File

@ -50,6 +50,7 @@ type
Procedure DoTestClassOf(Const AHint : string);
Published
Procedure TestAliasType;
procedure TestAbsoluteAliasType;
Procedure TestCrossUnitAliasType;
Procedure TestAliasTypeDeprecated;
Procedure TestAliasTypePlatform;
@ -168,6 +169,7 @@ type
Procedure TestTypeHelperWithParent;
procedure TestPointerReference;
Procedure TestPointerKeyWord;
Procedure TestPointerFile;
end;
{ TTestRecordTypeParser }
@ -361,9 +363,13 @@ type
Procedure TestAdvRec_ProcOverrideFail;
Procedure TestAdvRec_ProcMessageFail;
Procedure TestAdvRec_DestructorFail;
Procedure TestAdvRec_CaseInVar;
Procedure TestAdvRec_EmptySections;
Procedure TestAdvRecordInFunction;
Procedure TestAdvRecordInAnonFunction;
Procedure TestAdvRecordClassOperator;
Procedure TestAdvRecordInitOperator;
Procedure TestAdvRecordGenericFunction;
end;
{ TTestProcedureTypeParser }
@ -2610,6 +2616,29 @@ begin
ParseRecordFail(SParserNoConstructorAllowed,nParserNoConstructorAllowed);
end;
procedure TTestRecordTypeParser.TestAdvRec_CaseInVar;
// Found in System.UITypes.pas
begin
StartRecord(true);
AddMember('var');
AddMember('Case Integer of');
AddMember(' 1 : (x: integer);');
AddMember(' 2 : (y,z: integer)');
ParseRecord;
end;
procedure TTestRecordTypeParser.TestAdvRec_EmptySections;
begin
StartRecord(true);
AddMember('const');
AddMember('type');
AddMember('var');
AddMember(' x: integer;');
ParseRecord;
end;
procedure TTestRecordTypeParser.TestAdvRecordInFunction;
// Src from bug report 36179
@ -2688,6 +2717,51 @@ begin
ParseModule; // We're just interested in that it parses.
end;
procedure TTestRecordTypeParser.TestAdvRecordInitOperator;
// Source from bug id 36180
Const
SRC =
'{$mode objfpc}'+sLineBreak+
'{$modeswitch advancedrecords}'+sLineBreak+
'program afile;'+sLineBreak+
'type'+sLineBreak+
' TMyRecord = record'+sLineBreak+
' class operator initialize (var self: TMyRecord);'+sLineBreak+
' end;'+sLineBreak+
'class operator TMyRecord.initialize (a, b: TMyRecord);'+sLineBreak+
'begin'+sLineBreak+
' result := (@a = @b);'+sLineBreak+
'end;'+sLineBreak+
'begin'+sLineBreak+
'end.';
begin
Source.Text:=Src;
ParseModule; // We're just interested in that it parses.
end;
procedure TTestRecordTypeParser.TestAdvRecordGenericFunction;
Const
SRC =
'{$mode objfpc}'+sLineBreak+
'{$modeswitch advancedrecords}'+sLineBreak+
'program afile;'+sLineBreak+
'type'+sLineBreak+
' TMyRecord = record'+sLineBreak+
' generic class procedure doit<T> (a: T);'+sLineBreak+
' end;'+sLineBreak+
'generic class procedure TMyRecord.DoIt<T>(a: T);'+sLineBreak+
'begin'+sLineBreak+
'end;'+sLineBreak+
'begin'+sLineBreak+
'end.';
begin
Source.Text:=Src;
ParseModule; // We're just interested in that it parses.
end;
{ TBaseTestTypeParser }
Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;
@ -2893,11 +2967,21 @@ begin
end;
procedure TTestTypeParser.TestAliasType;
begin
DoTestAliasType('othertype','');
AssertEquals('Unresolved type name ','othertype',TPasUnresolvedTypeRef(TPasAliasType(TheType).DestType).name);
end;
procedure TTestTypeParser.TestAbsoluteAliasType;
begin
Add('Type');
Add(' Absolute = Integer;');
ParseDeclarations;
AssertEquals('First declaration is type definition.',TPasAliasType,TPasElement(Declarations.Types[0]).ClassType);
AssertEquals('First declaration has correct name.','Absolute',TPasElement(Declarations.Types[0]).Name);
end;
procedure TTestTypeParser.TestCrossUnitAliasType;
begin
DoTestAliasType('otherunit.othertype','');
@ -3674,6 +3758,15 @@ begin
AssertEquals('object definition count',1,Declarations.Classes.Count);
end;
procedure TTestTypeParser.TestPointerFile;
begin
Add('type');
Add(' pfile = ^file;');
ParseDeclarations;
AssertEquals('object definition count',1,Declarations.Types.Count);
end;
initialization
RegisterTests([TTestTypeParser,TTestRecordTypeParser,TTestProcedureTypeParser]);

36
compiler/packages/fcl-passrc/tests/tcvarparser.pas
View File

@ -26,6 +26,7 @@ Type
Procedure TearDown; override;
Published
Procedure TestSimpleVar;
Procedure TestSimpleVarAbsoluteName;
Procedure TestSimpleVarHelperName;
procedure TestSimpleVarHelperType;
Procedure TestSimpleVarDeprecated;
@ -34,6 +35,7 @@ Type
procedure TestSimpleVarInitializedDeprecated;
procedure TestSimpleVarInitializedPlatform;
Procedure TestSimpleVarAbsolute;
Procedure TestSimpleVarAbsoluteAddress;
Procedure TestSimpleVarAbsoluteDot;
Procedure TestSimpleVarAbsolute2Dots;
Procedure TestVarProcedure;
@ -51,6 +53,7 @@ Type
Procedure TestVarExternalLib;
Procedure TestVarExternalLibName;
procedure TestVarExternalNoSemiColon;
procedure TestVarExternalLibNoName;
Procedure TestVarCVar;
Procedure TestVarCVarExternal;
Procedure TestVarPublic;
@ -129,6 +132,21 @@ begin
AssertVariableType('b');
end;
procedure TTestVarParser.TestSimpleVarAbsoluteName;
Var
R : TPasVariable;
begin
Add('Var');
Add(' Absolute : integer;');
// Writeln(source.text);
ParseDeclarations;
AssertEquals('One variable definition',1,Declarations.Variables.Count);
AssertEquals('First declaration is type definition.',TPasVariable,TObject(Declarations.Variables[0]).ClassType);
R:=TPasVariable(Declarations.Variables[0]);
AssertEquals('First declaration has correct name.','Absolute',R.Name);
end;
procedure TTestVarParser.TestSimpleVarHelperName;
Var
@ -194,6 +212,13 @@ begin
AssertExpression('correct absolute location',TheVar.AbsoluteExpr,pekIdent,'v');
end;
procedure TTestVarParser.TestSimpleVarAbsoluteAddress;
begin
ParseVar('q absolute $123','');
AssertVariableType('q');
AssertExpression('correct absolute location',TheVar.AbsoluteExpr,pekNumber,'$123');
end;
procedure TTestVarParser.TestSimpleVarAbsoluteDot;
var
B: TBinaryExpr;
@ -339,6 +364,17 @@ begin
AssertNotNull('Library symbol',TheVar.ExportName);
end;
procedure TTestVarParser.TestVarExternalLibNoName;
begin
// Found in e.g.apache headers
ParseVar('integer; external ''mylib''','');
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
AssertNotNull('Library name',TheVar.LibraryName);
end;
procedure TTestVarParser.TestVarExternalLibName;
begin
ParseVar('integer; external ''mylib'' name ''de''','');

10
compiler/packages/fcl-passrc/tests/testpassrc.lpi
View File

@ -4,7 +4,9 @@
<Version Value="12"/>
<General>
<Flags>
<SaveOnlyProjectUnits Value="True"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
<SaveJumpHistory Value="False"/>
<SaveFoldState Value="False"/>
<CompatibilityMode Value="True"/>
@ -40,7 +42,7 @@
<PackageName Value="FCL"/>
</Item1>
</RequiredPackages>
<Units Count="15">
<Units Count="16">
<Unit0>
<Filename Value="testpassrc.lpr"/>
<IsPartOfProject Value="True"/>
@ -101,6 +103,10 @@
<Filename Value="tcuseanalyzer.pas"/>
<IsPartOfProject Value="True"/>
</Unit14>
<Unit15>
<Filename Value="tcresolvegenerics.pas"/>
<IsPartOfProject Value="True"/>
</Unit15>
</Units>
</ProjectOptions>
<CompilerOptions>

57
compiler/packages/pastojs/src/fppas2js.pp
View File

@ -4575,19 +4575,24 @@ var
ClassScope: TPas2JSClassScope;
ptm: TProcTypeModifier;
TypeEl, ElTypeEl, HelperForType: TPasType;
FuncType: TPasFunctionType;
begin
inherited FinishProcedureType(El);
if El is TPasFunctionType then
begin
TypeEl:=ResolveAliasType(TPasFunctionType(El).ResultEl.ResultType);
if TypeEl.ClassType=TPasPointerType then
FuncType:=TPasFunctionType(El);
if FuncType.ResultEl<>nil then
begin
ElTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType);
if ElTypeEl.ClassType=TPasRecordType then
// ^record
else
RaiseMsg(20180423110824,nNotSupportedX,sNotSupportedX,['pointer'],El);
TypeEl:=ResolveAliasType(FuncType.ResultEl.ResultType);
if TypeEl.ClassType=TPasPointerType then
begin
ElTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType);
if ElTypeEl.ClassType=TPasRecordType then
// ^record
else
RaiseMsg(20180423110824,nNotSupportedX,sNotSupportedX,['pointer'],El);
end;
end;
end;
@ -6278,10 +6283,12 @@ begin
AddBaseType(Pas2JSBuiltInNames[pbitnUIntDouble],btUIntDouble);
if btIntDouble in TheBaseTypes then
AddBaseType(Pas2JSBuiltInNames[pbitnIntDouble],btIntDouble);
FJSBuiltInProcs[pbpDebugger]:=AddBuiltInProc('Debugger','procedure Debugger',
FJSBuiltInProcs[pbpDebugger]:=AddBuiltInProc(Pas2jsBuiltInProcNames[pbpDebugger],
'procedure Debugger',
@BI_Debugger_OnGetCallCompatibility,nil,
nil,nil,bfCustom,[bipfCanBeStatement]);
FJSBuiltInProcs[pbpAWait]:=AddBuiltInProc('AWait','function await(const Expr: T): T',
FJSBuiltInProcs[pbpAWait]:=AddBuiltInProc(Pas2jsBuiltInProcNames[pbpAWait],
'function await(const Expr: T): T',
@BI_AWait_OnGetCallCompatibility,@BI_AWait_OnGetCallResult,
@BI_AWait_OnEval,@BI_AWait_OnFinishParamsExpr,bfCustom,[bipfCanBeStatement]);
end;
@ -6485,6 +6492,7 @@ end;
function TPas2JSResolver.FindLocalBuiltInSymbol(El: TPasElement): TPasElement;
var
Data: TObject;
pbp: TPas2jsBuiltInProc;
begin
Result:=inherited FindLocalBuiltInSymbol(El);
if Result<>nil then exit;
@ -6493,10 +6501,9 @@ begin
Result:=JSBaseTypes[TResElDataPas2JSBaseType(Data).JSBaseType]
else if (Data.ClassType=TResElDataBuiltInProc)
and (TResElDataBuiltInProc(Data).BuiltIn=bfCustom) then
case El.Name of
'Debugger': Result:=FJSBuiltInProcs[pbpDebugger].Element;
'AWait': Result:=FJSBuiltInProcs[pbpAWait].Element;
end;
for pbp in TPas2jsBuiltInProc do
if El.Name=Pas2jsBuiltInProcNames[pbp] then
Result:=FJSBuiltInProcs[pbp].Element;
end;
function TPas2JSResolver.ExtractPasStringLiteral(El: TPasElement;
@ -12451,9 +12458,9 @@ begin
end;
end;
end
else if to_bt=btChar then
else if to_bt in [btChar,btWideChar] then
begin
if from_bt=btChar then
if from_bt in [btChar,btWideChar] then
begin
// char to char
Result:=ConvertExpression(Param,AContext);
@ -13214,7 +13221,7 @@ begin
bt:=ParamResolved.BaseType;
if bt=btRange then
bt:=ParamResolved.SubType;
if bt=btChar then
if bt in [btChar,btWideChar] then
begin
if Param is TParamsExpr then
begin
@ -15023,22 +15030,26 @@ Var
Proc: TPasProcedure;
FunType: TPasFunctionType;
VarSt: TJSVariableStatement;
SrcEl: TPasElement;
Scope: TPas2JSProcedureScope;
ImplScope: TPas2JSProcedureScope;
begin
Proc:=El.Parent as TPasProcedure;
FunType:=Proc.ProcType as TPasFunctionType;
ResultEl:=FunType.ResultEl;
Scope:=Proc.CustomData as TPas2JSProcedureScope;
if Scope.ResultVarName<>'' then
ResultVarName:=Scope.ResultVarName
ImplScope:=Proc.CustomData as TPas2JSProcedureScope;
if (ResultEl=nil) or (ResultEl.ResultType=nil) then
begin
Proc:=ImplScope.DeclarationProc;
FunType:=Proc.ProcType as TPasFunctionType;
ResultEl:=FunType.ResultEl;
end;
if ImplScope.ResultVarName<>'' then
ResultVarName:=ImplScope.ResultVarName
else
ResultVarName:=ResolverResultVar;
// add 'var result=initvalue'
SrcEl:=ResultEl;
VarSt:=CreateVarStatement(ResultVarName,
CreateValInit(ResultEl.ResultType,nil,SrcEl,aContext),ResultEl);
CreateValInit(ResultEl.ResultType,nil,ResultEl,aContext),ResultEl);
Add(VarSt,ResultEl);
Result:=SLFirst;
end;

6
compiler/packages/pastojs/src/pas2jscompiler.pp
View File

@ -44,9 +44,9 @@ uses
const
VersionMajor = 2;
VersionMinor = 0;
VersionRelease = 0;
VersionExtra = 'RC5';
VersionMinor = 1;
VersionRelease = 1;
VersionExtra = '';
DefaultConfigFile = 'pas2js.cfg';
//------------------------------------------------------------------------------

51
compiler/packages/pastojs/src/pas2jsfilecache.pp
View File

@ -259,7 +259,7 @@ type
function FindUnitJSFileName(const aUnitFilename: string): String; override;
function FindUnitFileName(const aUnitname, InFilename, ModuleDir: string; out IsForeign: boolean): String; override;
function FindResourceFileName(const aFilename, ModuleDir: string): String; override;
function FindIncludeFileName(const aFilename, ModuleDir: string): String; override;
function FindIncludeFileName(const aFilename, SrcDir, ModuleDir: string; Mode: TModeSwitch): String; override;
function AddIncludePaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
function AddUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
function AddSrcUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
@ -1832,25 +1832,52 @@ begin
UsePointDirectory, AlwaysRequireSharedBaseFolder, RelPath);
end;
function TPas2jsFilesCache.FindIncludeFileName(const aFilename,
ModuleDir: string): String;
function TPas2jsFilesCache.FindIncludeFileName(const aFilename, SrcDir,
ModuleDir: string; Mode: TModeSwitch): String;
function SearchCasedInIncPath(const Filename: string): string;
var
SearchedDir: array of string;
function SearchDir(Dir: string): boolean;
var
i: Integer;
CurFile: String;
begin
Dir:=IncludeTrailingPathDelimiter(Dir);
for i:=0 to length(SearchedDir)-1 do
if SearchedDir[i]=Dir then exit;
CurFile:=Dir+Filename;
//writeln('SearchDir aFilename=',aFilename,' SrcDir=',SrcDir,' ModDir=',ModuleDir,' Mode=',Mode,' CurFile=',CurFile);
Result:=SearchLowUpCase(CurFile);
if Result then
SearchCasedInIncPath:=CurFile
else begin
i:=length(SearchedDir);
SetLength(SearchedDir,i+1);
SearchedDir[i]:=Dir;
end;
end;
var
i: Integer;
begin
// file name is relative
// first search in the same directory as the unit
SearchedDir:=nil;
// first search in the same directory as the include file
if not (Mode in [msDelphi,msDelphiUnicode])
and (SrcDir<>'') then
if SearchDir(SrcDir) then exit;
// then search in the same directory as the unit
if ModuleDir<>'' then
begin
Result:=IncludeTrailingPathDelimiter(ModuleDir)+Filename;
if SearchLowUpCase(Result) then exit;
end;
if SearchDir(ModuleDir) then exit;
// then search in include path
for i:=0 to IncludePaths.Count-1 do begin
Result:=IncludeTrailingPathDelimiter(IncludePaths[i])+Filename;
if SearchLowUpCase(Result) then exit;
end;
for i:=0 to IncludePaths.Count-1 do
if SearchDir(IncludePaths[i]) then exit;
Result:='';
end;

47
compiler/packages/pastojs/src/pas2jsfiler.pp
View File

@ -1005,6 +1005,7 @@ type
FElementRefsArray: TPCUFilerElementRefArray; // TPCUFilerElementRef by Id
FJSON: TJSONObject;
FPendingIdentifierScopes: TObjectList; // list of TPCUReaderPendingIdentifierScope
FPendingForwardProcs: TFPList; // list of TPasElement waiting for implementation of methods
procedure Set_Variable_VarType(RefEl: TPasElement; Data: TObject);
procedure Set_AliasType_DestType(RefEl: TPasElement; Data: TObject);
procedure Set_PointerType_DestType(RefEl: TPasElement; Data: TObject);
@ -6217,6 +6218,7 @@ var
BuiltInProc: TResElDataBuiltInProc;
bp: TResolverBuiltInProc;
pbt: TPas2jsBaseType;
pbp: TPas2jsBuiltInProc;
begin
if not ReadArray(Obj,BuiltInNodeName,Arr,ErrorEl) then exit;
for i:=0 to Arr.Count-1 do
@ -6275,6 +6277,21 @@ begin
end;
end;
end;
if not Found then
begin
for pbp in TPas2jsBuiltInProc do
begin
BuiltInProc:=Resolver.JSBuiltInProcs[pbp];
if BuiltInProc=nil then continue;
El:=BuiltInProc.Element;
if (CompareText(El.Name,aName)=0) then
begin
Found:=true;
AddElReference(Id,ErrorEl,El);
break;
end;
end;
end;
if not Found then
RaiseMsg(20180216231551,ErrorEl,aName);
end;
@ -7034,6 +7051,8 @@ procedure TPCUReader.ReadSection(Obj: TJSONObject; Section: TPasSection;
// Note: can be called twice for each section if there are pending used interfaces
var
Scope: TPas2JSSectionScope;
i: Integer;
El: TPasElement;
begin
{$IFDEF VerbosePCUFiler}
writeln('TPCUReader.ReadSection ',GetObjName(Section));
@ -7068,10 +7087,19 @@ begin
end;
Scope.Finished:=true;
if Section is TInterfaceSection then
if Section.ClassType=TInterfaceSection then
begin
ResolvePending(false);
Resolver.NotifyPendingUsedInterfaces;
end
else if Section.ClassType=TImplementationSection then
begin
for i:=0 to FPendingForwardProcs.Count-1 do
begin
El:=TPasElement(FPendingForwardProcs[i]);
Resolver.CheckPendingForwardProcs(El);
end;
FPendingForwardProcs.Clear;
end;
end;
@ -8657,7 +8685,7 @@ begin
Resolver.PopScope;
end;
ReadRecordScope(Obj,Scope,aContext);
Resolver.FinishSpecializedClassOrRecIntf(Scope);
Resolver.FinishGenericClassOrRecIntf(Scope);
Resolver.FinishSpecializations(Scope);
ReadSpecializations(Obj,El);
@ -9028,8 +9056,9 @@ begin
finally
Resolver.PopScope;
end;
Resolver.FinishSpecializedClassOrRecIntf(Scope);
Resolver.FinishSpecializations(Scope);
Resolver.FinishGenericClassOrRecIntf(Scope);
if (El.GenericTemplateTypes<>nil) and (El.GenericTemplateTypes.Count>0) then
FPendingForwardProcs.Add(El);
ReadSpecializations(Obj,El);
end;
end;
@ -9563,7 +9592,7 @@ var
DefProcMods: TProcedureModifiers;
t: TProcedureMessageType;
s: string;
Found: Boolean;
Found, HasBody: Boolean;
Scope: TPas2JSProcedureScope;
DeclProcId: integer;
Ref: TPCUFilerElementRef;
@ -9587,6 +9616,7 @@ begin
ReadPasElement(Obj,El,aContext);
HasBody:=Obj.Find('Body')<>nil;
if ReadInteger(Obj,'DeclarationProc',DeclProcId,El) then
begin
// ImplProc
@ -9598,7 +9628,7 @@ begin
DeclProc:=TPasProcedure(Ref.Element);
Scope.DeclarationProc:=DeclProc; // no AddRef
El.ProcType:=TPasProcedureType(CreateElement(TPasProcedureTypeClass(DeclProc.ProcType.ClassType),'',DeclProc));
El.ProcType:=TPasProcedureType(CreateElement(TPasProcedureTypeClass(DeclProc.ProcType.ClassType),'',El));
El.Modifiers:=ReadProcedureModifiers(Obj,El,'PMods',DeclProc.Modifiers*PCUProcedureModifiersImplProc);
end
else
@ -9644,7 +9674,7 @@ begin
if (Scope<>nil) and (Obj.Find('ImplProc')=nil) then
ReadProcScopeReferences(Obj,Scope);
if Obj.Find('Body')<>nil then
if HasBody then
ReadProcedureBody(Obj,El,aContext);
end;
@ -9931,12 +9961,14 @@ begin
inherited Create;
FInitialFlags:=TPCUInitialFlags.Create;
FPendingIdentifierScopes:=TObjectList.Create(true);
FPendingForwardProcs:=TFPList.Create;
end;
destructor TPCUReader.Destroy;
begin
FreeAndNil(FJSON);
inherited Destroy;
FreeAndNil(FPendingForwardProcs);
FreeAndNil(FPendingIdentifierScopes);
FreeAndNil(FInitialFlags);
end;
@ -9952,6 +9984,7 @@ begin
FPendingIdentifierScopes.Clear;
while FPendingSpecialize<>nil do
DeletePendingSpecialize(FPendingSpecialize);
FPendingForwardProcs.Clear;
inherited Clear;
FInitialFlags.Clear;

6
compiler/packages/pastojs/src/pas2jsfs.pp
View File

@ -98,7 +98,7 @@ Type
Public
// Public Abstract. Must be overridden
function FindResourceFileName(const aFilename, ModuleDir: string): String; virtual; abstract;
function FindIncludeFileName(const aFilename, ModuleDir: string): String; virtual; abstract;
function FindIncludeFileName(const aFilename, SrcDir, ModuleDir: string; Mode: TModeSwitch): String; virtual; abstract;
function LoadFile(Filename: string; Binary: boolean = false): TPas2jsFile; virtual; abstract;
Function FileExists(Const aFileName: String): Boolean; virtual; abstract;
function FindUnitJSFileName(const aUnitFilename: string): String; virtual; abstract;
@ -421,7 +421,7 @@ var
Filename: String;
begin
Result:=nil;
Filename:=FS.FindIncludeFileName(aFilename,BaseDirectory);
Filename:=FS.FindIncludeFileName(aFilename,BaseDirectory,ModuleDirectory,Mode);
if Filename='' then exit;
try
Result:=FindSourceFile(Filename);
@ -444,7 +444,7 @@ end;
function TPas2jsFSResolver.FindIncludeFileName(const aFilename: string): String;
begin
Result:=FS.FindIncludeFileName(aFilename,BaseDirectory);
Result:=FS.FindIncludeFileName(aFilename,BaseDirectory,ModuleDirectory,Mode);
end;

12
compiler/packages/pastojs/tests/tcmodules.pas
View File

@ -233,7 +233,7 @@ type
Published
Procedure TestReservedWords;
// program/units
// program, units, includes
Procedure TestEmptyProgram;
Procedure TestEmptyProgramUseStrict;
Procedure TestEmptyUnit;
@ -294,7 +294,7 @@ type
Procedure TestBaseType_RawByteStringFail;
Procedure TestTypeShortstring_Fail;
Procedure TestCharSet_Custom;
Procedure TestWideChar_VarArg;
Procedure TestWideChar;
Procedure TestForCharDo;
Procedure TestForCharInDo;
@ -7927,7 +7927,7 @@ begin
'']));
end;
procedure TTestModule.TestWideChar_VarArg;
procedure TTestModule.TestWideChar;
begin
StartProgram(false);
Add([
@ -7940,9 +7940,12 @@ begin
'var',
' c: char;',
' wc: widechar;',
' w: word;',
'begin',
' Fly(wc);',
' Run(c);',
' wc:=WideChar(w);',
' w:=ord(wc);',
'']);
ConvertProgram;
CheckSource('TestWideChar_VarArg',
@ -7953,6 +7956,7 @@ begin
'};',
'this.c = "";',
'this.wc = "";',
'this.w = 0;',
'']),
LinesToStr([ // this.$main
'$mod.Fly({',
@ -7973,6 +7977,8 @@ begin
' this.p.c = v;',
' }',
'});',
'$mod.wc = String.fromCharCode($mod.w);',
'$mod.w = $mod.wc.charCodeAt();',
'',
'']));
end;

1
compiler/packages/pastojs/tests/tcprecompile.pas
View File

@ -130,7 +130,6 @@ begin
Params.AddStrings(SharedParams);
if SecondRunParams<>nil then
Params.AddStrings(SecondRunParams);
writeln('BBB1 TCustomTestCLI_Precompile.CheckPrecompile ',Params.Text);
Compile([MainFile,'-FU'+UnitOutputDir],ExpExitCode);
if ExpExitCode=0 then
begin

52
compiler/packages/pastojs/tests/tcunitsearch.pas
View File

@ -143,7 +143,11 @@ type
procedure TestUS_Program_FU;
procedure TestUS_Program_FU_o;
procedure TestUS_Program_FE_o;
// include files
procedure TestUS_IncludeSameDir;
Procedure TestUS_Include_NestedDelphi;
Procedure TestUS_Include_NestedObjFPC;
// uses 'in' modifier
procedure TestUS_UsesInFile;
@ -729,6 +733,54 @@ begin
Compile(['test1.pas','-Fusub','-FElib','-ofoo.js']);
end;
procedure TTestCLI_UnitSearch.TestUS_Include_NestedDelphi;
begin
AddUnit('system.pp',[''],['']);
AddFile('sub/inc1.inc',[
'type number = longint;',
'{$I sub/deep/inc2.inc}',
'']);
AddFile('sub/deep/inc2.inc',[
'type numero = number;',
'{$I sub/inc3.inc}',
'']);
AddFile('sub/inc3.inc',[
'type nummer = numero;',
'']);
AddFile('test1.pas',[
'{$mode delphi}',
'{$i sub/inc1.inc}',
'var',
' n: nummer;',
'begin',
'end.']);
Compile(['test1.pas','-Jc']);
end;
procedure TTestCLI_UnitSearch.TestUS_Include_NestedObjFPC;
begin
AddUnit('system.pp',[''],['']);
AddFile('sub/inc1.inc',[
'type number = longint;',
'{$I deep/inc2.inc}',
'']);
AddFile('sub/deep/inc2.inc',[
'type numero = number;',
'{$I ../inc3.inc}',
'']);
AddFile('sub/inc3.inc',[
'type nummer = numero;',
'']);
AddFile('test1.pas',[
'{$mode objfpc}',
'{$i sub/inc1.inc}',
'var',
' n: nummer;',
'begin',
'end.']);
Compile(['test1.pas','-Jc']);
end;
procedure TTestCLI_UnitSearch.TestUS_UsesInFile;
begin
AddUnit('system.pp',[''],['']);