diff --git a/compiler/packages/fcl-passrc/src/pastree.pp b/compiler/packages/fcl-passrc/src/pastree.pp index 2c7ec5a..bb72237 100644 --- a/compiler/packages/fcl-passrc/src/pastree.pp +++ b/compiler/packages/fcl-passrc/src/pastree.pp @@ -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; diff --git a/compiler/packages/fcl-passrc/src/paswrite.pp b/compiler/packages/fcl-passrc/src/paswrite.pp index f93ad3e..72e5325 100644 --- a/compiler/packages/fcl-passrc/src/paswrite.pp +++ b/compiler/packages/fcl-passrc/src/paswrite.pp @@ -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'); diff --git a/compiler/packages/fcl-passrc/src/pparser.pp b/compiler/packages/fcl-passrc/src/pparser.pp index b7a5ca0..2fe4fcc 100644 --- a/compiler/packages/fcl-passrc/src/pparser.pp +++ b/compiler/packages/fcl-passrc/src/pparser.pp @@ -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.C + + // Check for cascaded specialize A.C or A.C + 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 - 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; diff --git a/compiler/packages/fcl-passrc/src/pscanner.pp b/compiler/packages/fcl-passrc/src/pscanner.pp index 71c50b4..a25357f 100644 --- a/compiler/packages/fcl-passrc/src/pscanner.pp +++ b/compiler/packages/fcl-passrc/src/pscanner.pp @@ -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 diff --git a/compiler/packages/fcl-passrc/tests/tcclasstype.pas b/compiler/packages/fcl-passrc/tests/tcclasstype.pas index 30b54b8..ea045d6 100644 --- a/compiler/packages/fcl-passrc/tests/tcclasstype.pas +++ b/compiler/packages/fcl-passrc/tests/tcclasstype.pas @@ -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 diff --git a/compiler/packages/fcl-passrc/tests/tcgenerics.pp b/compiler/packages/fcl-passrc/tests/tcgenerics.pp index 02414f3..95c3436 100644 --- a/compiler/packages/fcl-passrc/tests/tcgenerics.pp +++ b/compiler/packages/fcl-passrc/tests/tcgenerics.pp @@ -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 = Class(TObject)'); Source.Add(' b : T;'); Source.Add(' b2 : T2;'); + Source.Add(' FItems: ^TArray;'); + Source.Add(' type'); + Source.Add(' TDictionaryEnumerator = TDictionary.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=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 diff --git a/compiler/packages/fcl-passrc/tests/tconstparser.pas b/compiler/packages/fcl-passrc/tests/tconstparser.pas index efe5d21..8162cb6 100644 --- a/compiler/packages/fcl-passrc/tests/tconstparser.pas +++ b/compiler/packages/fcl-passrc/tests/tconstparser.pas @@ -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''' ; diff --git a/compiler/packages/fcl-passrc/tests/tcprocfunc.pas b/compiler/packages/fcl-passrc/tests/tcprocfunc.pas index 2687fd7..8f63c7f 100644 --- a/compiler/packages/fcl-passrc/tests/tcprocfunc.pas +++ b/compiler/packages/fcl-passrc/tests/tcprocfunc.pas @@ -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; diff --git a/compiler/packages/fcl-passrc/tests/tctypeparser.pas b/compiler/packages/fcl-passrc/tests/tctypeparser.pas index 1818e85..2ce8d7c 100644 --- a/compiler/packages/fcl-passrc/tests/tctypeparser.pas +++ b/compiler/packages/fcl-passrc/tests/tctypeparser.pas @@ -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 (a: T);'+sLineBreak+ + ' end;'+sLineBreak+ + 'generic class procedure TMyRecord.DoIt(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]); diff --git a/compiler/packages/fcl-passrc/tests/tcvarparser.pas b/compiler/packages/fcl-passrc/tests/tcvarparser.pas index 13becc7..b6092b3 100644 --- a/compiler/packages/fcl-passrc/tests/tcvarparser.pas +++ b/compiler/packages/fcl-passrc/tests/tcvarparser.pas @@ -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''',''); diff --git a/compiler/packages/fcl-passrc/tests/testpassrc.lpi b/compiler/packages/fcl-passrc/tests/testpassrc.lpi index 73eb1cd..4e7860a 100644 --- a/compiler/packages/fcl-passrc/tests/testpassrc.lpi +++ b/compiler/packages/fcl-passrc/tests/testpassrc.lpi @@ -4,7 +4,9 @@ - + + + @@ -40,7 +42,7 @@ - + @@ -101,6 +103,10 @@ + + + + diff --git a/compiler/packages/pastojs/src/fppas2js.pp b/compiler/packages/pastojs/src/fppas2js.pp index 0d0bf80..ab02906 100644 --- a/compiler/packages/pastojs/src/fppas2js.pp +++ b/compiler/packages/pastojs/src/fppas2js.pp @@ -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; diff --git a/compiler/packages/pastojs/src/pas2jscompiler.pp b/compiler/packages/pastojs/src/pas2jscompiler.pp index b831b29..6824c86 100644 --- a/compiler/packages/pastojs/src/pas2jscompiler.pp +++ b/compiler/packages/pastojs/src/pas2jscompiler.pp @@ -44,9 +44,9 @@ uses const VersionMajor = 2; - VersionMinor = 0; - VersionRelease = 0; - VersionExtra = 'RC5'; + VersionMinor = 1; + VersionRelease = 1; + VersionExtra = ''; DefaultConfigFile = 'pas2js.cfg'; //------------------------------------------------------------------------------ diff --git a/compiler/packages/pastojs/src/pas2jsfilecache.pp b/compiler/packages/pastojs/src/pas2jsfilecache.pp index fee9d38..8ea388c 100644 --- a/compiler/packages/pastojs/src/pas2jsfilecache.pp +++ b/compiler/packages/pastojs/src/pas2jsfilecache.pp @@ -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; diff --git a/compiler/packages/pastojs/src/pas2jsfiler.pp b/compiler/packages/pastojs/src/pas2jsfiler.pp index c69a7e3..dae0698 100644 --- a/compiler/packages/pastojs/src/pas2jsfiler.pp +++ b/compiler/packages/pastojs/src/pas2jsfiler.pp @@ -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; diff --git a/compiler/packages/pastojs/src/pas2jsfs.pp b/compiler/packages/pastojs/src/pas2jsfs.pp index 2dd9146..587589c 100644 --- a/compiler/packages/pastojs/src/pas2jsfs.pp +++ b/compiler/packages/pastojs/src/pas2jsfs.pp @@ -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; diff --git a/compiler/packages/pastojs/tests/tcmodules.pas b/compiler/packages/pastojs/tests/tcmodules.pas index fb2df96..5cc3bb2 100644 --- a/compiler/packages/pastojs/tests/tcmodules.pas +++ b/compiler/packages/pastojs/tests/tcmodules.pas @@ -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; diff --git a/compiler/packages/pastojs/tests/tcprecompile.pas b/compiler/packages/pastojs/tests/tcprecompile.pas index d81af82..01c3027 100644 --- a/compiler/packages/pastojs/tests/tcprecompile.pas +++ b/compiler/packages/pastojs/tests/tcprecompile.pas @@ -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 diff --git a/compiler/packages/pastojs/tests/tcunitsearch.pas b/compiler/packages/pastojs/tests/tcunitsearch.pas index 5d2e855..66b1813 100644 --- a/compiler/packages/pastojs/tests/tcunitsearch.pas +++ b/compiler/packages/pastojs/tests/tcunitsearch.pas @@ -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',[''],['']);