diff --git a/.gitattributes b/.gitattributes index 9fd65d2522..85678fb59d 100644 --- a/.gitattributes +++ b/.gitattributes @@ -13449,6 +13449,7 @@ tests/test/cg/cdecl/taoc3.pp svneol=native#text/plain tests/test/cg/cdecl/taoc4.pp svneol=native#text/plain tests/test/cg/cdecl/taoc5.pp svneol=native#text/plain tests/test/cg/cdecl/taoc6.pp svneol=native#text/plain +tests/test/cg/cpudefs.inc svneol=native#text/plain tests/test/cg/obj/aix/powerpc/cpptcl1.o -text tests/test/cg/obj/aix/powerpc/cpptcl2.o -text tests/test/cg/obj/aix/powerpc/ctest.o -text @@ -13821,7 +13822,6 @@ tests/test/cg/tcalcst5.pp svneol=native#text/plain tests/test/cg/tcalcst6.pp svneol=native#text/plain tests/test/cg/tcalcst7.pp svneol=native#text/plain tests/test/cg/tcalcst8.pp svneol=native#text/plain -tests/test/cg/tcaldefs.inc svneol=native#text/plain tests/test/cg/tcalext.pp svneol=native#text/plain tests/test/cg/tcalext3.pp svneol=native#text/plain tests/test/cg/tcalext4.pp svneol=native#text/plain @@ -18484,6 +18484,7 @@ tests/webtbs/tw37554.pp svneol=native#text/pascal tests/webtbs/tw3758.pp svneol=native#text/plain tests/webtbs/tw3764.pp svneol=native#text/plain tests/webtbs/tw3765.pp svneol=native#text/plain +tests/webtbs/tw37650.pp svneol=native#text/pascal tests/webtbs/tw3768.pp svneol=native#text/plain tests/webtbs/tw3774.pp svneol=native#text/plain tests/webtbs/tw3777.pp svneol=native#text/plain diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 9b0757b2d0..852889a35d 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -114,7 +114,12 @@ implementation end else begin - if (tordconstnode(p).value<=0) then + { the node is a generic param while parsing a generic def + so disable the range checking for the string } + if parse_generic and + (nf_generic_para in p.flags) then + tordconstnode(p).value:=255; + if tordconstnode(p).value<=0 then begin Message(parser_e_invalid_string_size); tordconstnode(p).value:=255; diff --git a/compiler/xtensa/cpupara.pas b/compiler/xtensa/cpupara.pas index 846ebe6243..4730c3bbac 100644 --- a/compiler/xtensa/cpupara.pas +++ b/compiler/xtensa/cpupara.pas @@ -49,7 +49,7 @@ unit cpupara; paras : tparalist; var curintreg : tsuperregister; var cur_stack_offset : aword; varargsparas : boolean) : longint; function create_paraloc1_info_intern(p: tabstractprocdef; side: tcallercallee; paradef: tdef; var loc: TCGPara; varspez: tvarspez; varoptions: tvaroptions; - var curintreg: tsuperregister; var cur_stack_offset: aword; varargsparas: boolean): longint; + var curintreg: tsuperregister; var cur_stack_offset: aword; varargsparas, funcret: boolean): longint; end; implementation @@ -153,10 +153,7 @@ unit cpupara; recorddef : result:=(varspez = vs_const); arraydef: - result:=((varspez = vs_const) and (tarraydef(def).highrange>=tarraydef(def).lowrange)) or - is_open_array(def) or - is_array_of_const(def) or - is_array_constructor(def); + result:=true; objectdef : result:=is_object(def) and (varspez = vs_const); variantdef, @@ -252,7 +249,7 @@ unit cpupara; else if (result.def.size>4) and (result.def.size<=16) then begin init_values(p,side,curintreg,cur_stack_offset); - create_paraloc1_info_intern(p,side,result.def,result,vs_value,[],curintreg,cur_stack_offset,false); + create_paraloc1_info_intern(p,side,result.def,result,vs_value,[],curintreg,cur_stack_offset,false,true); { check if everything is ok } if result.location^.loc=LOC_INVALID then @@ -320,7 +317,7 @@ unit cpupara; function tcpuparamanager.create_paraloc1_info_intern(p : tabstractprocdef; side: tcallercallee; paradef:tdef;var loc : TCGPara;varspez : tvarspez;varoptions : tvaroptions; - var curintreg: tsuperregister; var cur_stack_offset: aword; varargsparas: boolean):longint; + var curintreg: tsuperregister; var cur_stack_offset: aword; varargsparas, funcret: boolean):longint; var paralen: aint; locdef, @@ -349,19 +346,21 @@ unit cpupara; exit; end; - if push_addr_param(varspez,paradef,p.proccalloption) then + if not is_special_array(paradef) then + paralen:=paradef.size + else + paralen:=tcgsize2size[def_cgsize(paradef)]; + + if (not(funcret) and push_addr_param(varspez,paradef,p.proccalloption)) or + (funcret and (paralen>24)) then begin paradef:=cpointerdef.getreusable_no_free(paradef); locpara:=LOC_REGISTER; - paracgsize := OS_ADDR; - paralen := tcgsize2size[OS_ADDR]; + paracgsize:=OS_ADDR; + paralen:=tcgsize2size[OS_ADDR]; end else begin - if not is_special_array(paradef) then - paralen := paradef.size - else - paralen := tcgsize2size[def_cgsize(paradef)]; if (paradef.typ in [objectdef,arraydef,recorddef,setdef,stringdef]) and not is_special_array(paradef) and (varspez in [vs_value,vs_const]) then @@ -369,10 +368,10 @@ unit cpupara; else begin paracgsize:=def_cgsize(paradef); - if (paracgsize=OS_NO) then + if paracgsize=OS_NO then begin paracgsize:=OS_ADDR; - paralen := tcgsize2size[OS_ADDR]; + paralen:=tcgsize2size[OS_ADDR]; paradef:=voidpointertype; end; end; @@ -481,7 +480,7 @@ unit cpupara; result:=0; for i:=0 to paras.count-1 do result:=create_paraloc1_info_intern(p,side,tparavarsym(paras[i]).vardef,tparavarsym(paras[i]).paraloc[side],tparavarsym(paras[i]).varspez, - tparavarsym(paras[i]).varoptions,curintreg,cur_stack_offset,false); + tparavarsym(paras[i]).varoptions,curintreg,cur_stack_offset,false,false); end; diff --git a/packages/chm/src/chmls.lpr b/packages/chm/src/chmls.lpr index 955c350162..c1ac4f5a88 100644 --- a/packages/chm/src/chmls.lpr +++ b/packages/chm/src/chmls.lpr @@ -482,7 +482,7 @@ begin s:=r.readstringsentry(cnt); end; - +var dx : dword; begin setlength(s,4); for i:=1 to 4 do @@ -529,7 +529,8 @@ begin Writeln('Unknown. Often 1. Also 0, 3. :',leton(m.readdword)); cnt2:=m.ReadDWordLE; Writeln('Number of files in the [MERGE FILES] list :',cnt2); - Writeln('Unknown. Often 0. :',leton(m.readdword),'(Non-zero mostly in files with some files in the merge files list)'); + dx:=leton(m.readdword); + Writeln('Unknown. Often 0. :',dx,' =$',inttohex(dx,8),'(Non-zero mostly in files with some files in the merge files list)'); if cnt2>0 then for i:=0 to cnt2-1 do begin @@ -805,7 +806,7 @@ begin writeln(' Non zero if there are ALinks : ',m.readdwordLE ); ts.dwlowdatetime:=m.readdwordLE; ts.dwhighdatetime:=m.readdwordLE; - writeln(' Timestamp : ',ts.dwhighdatetime,':', ts.dwlowdatetime ); + writeln(' Timestamp : ',ts.dwhighdatetime,':', ts.dwlowdatetime, ' = $',inttohex(ts.dwhighdatetime,8),': $', inttohex(ts.dwlowdatetime,8)); writeln(' 0/1 except in dsmsdn.chi has 1 : ',m.readdwordLE ); writeln(' 0 (unknown) : ',m.readdwordLE ); end; @@ -831,6 +832,7 @@ begin writeln(' x size is larger than 16'); m.position:=m.position+chsz-16; end; +var dx : dword; begin symbolname:='helpid'; @@ -878,7 +880,8 @@ begin 8 : printentry8(m,chunksize); 9 : Writeln('(9) CHM compiler version :',printnulterminated(chunksize)); 10: begin - writeln('(10) Timestamp (32-bit?) :',m.readdwordle); + dx:=m.readdwordle; + writeln('(10) Timestamp (32-bit?) :',dx,' , = $',inttohex(dx,8)); m.position:=m.position+chunksize-4; end; 11: Writeln('(11) DWord when Binary TOC is on :',m.readdwordle, '(= entry in #urltbl has same first dword'); diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index 2f67fc40d7..85995de067 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -1027,27 +1027,27 @@ var begin if o=nil then Result:='nil' - else if o is TPasArrayType then + else if (o is TPasArrayType) and (TPasArrayType(o).Name='') then begin - if TPasArrayType(o).ElType = nil then - Result:='array of const' - else - Result:=Format('TArray<%s>', [TPasArrayType(o).ElType.Name]); - end - else if o is TPasElement then - begin - Result:=TPasElement(o).Name; - if o is TPasGenericType then - begin - GenType:=TPasGenericType(o); - if (GenType.GenericTemplateTypes<>nil) - and (GenType.GenericTemplateTypes.Count>0) then - Result:=Result+GetGenericParamCommas(GenType.GenericTemplateTypes.Count); - end; - Result:=Result+':'+o.ClassName; - end + if TPasArrayType(o).ElType = nil then + Result:='array of const' else - Result:=o.ClassName; + Result:=Format('TArray<%s>', [TPasArrayType(o).ElType.Name]); + end + else if o is TPasElement then + begin + Result:=TPasElement(o).Name; + if o is TPasGenericType then + begin + GenType:=TPasGenericType(o); + if (GenType.GenericTemplateTypes<>nil) + and (GenType.GenericTemplateTypes.Count>0) then + Result:=Result+GetGenericParamCommas(GenType.GenericTemplateTypes.Count); + end; + Result:=Result+':'+o.ClassName; + end + else + Result:=o.ClassName; end; function GetObjPath(o: TObject): string; diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index b32eee10b2..fbce70bd06 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -986,12 +986,14 @@ type TPasArrayScope = Class(TPasGenericScope) public end; + TPasArrayScopeClass = class of TPasArrayScope; { TPasProcTypeScope } TPasProcTypeScope = Class(TPasGenericScope) public end; + TPasProcTypeScopeClass = class of TPasProcTypeScope; { TPasClassOrRecordScope } @@ -1510,10 +1512,12 @@ type FOptions: TPasResolverOptions; FPendingForwardProcs: TFPList; // list of TPasElement needed to check for forward procs FRootElement: TPasModule; + FScopeClass_Array: TPasArrayScopeClass; FScopeClass_Class: TPasClassScopeClass; FScopeClass_InitialFinalization: TPasInitialFinalizationScopeClass; FScopeClass_Module: TPasModuleScopeClass; FScopeClass_Proc: TPasProcedureScopeClass; + FScopeClass_ProcType: TPasProcTypeScopeClass; FScopeClass_Record: TPasRecordScopeClass; FScopeClass_Section: TPasSectionScopeClass; FScopeClass_WithExpr: TPasWithExprScopeClass; @@ -2424,10 +2428,12 @@ type property ScopeCount: integer read FScopeCount; property TopScope: TPasScope read FTopScope; property DefaultScope: TPasDefaultScope read FDefaultScope write FDefaultScope; + property ScopeClass_Array: TPasArrayScopeClass read FScopeClass_Array write FScopeClass_Array; property ScopeClass_Class: TPasClassScopeClass read FScopeClass_Class write FScopeClass_Class; property ScopeClass_InitialFinalization: TPasInitialFinalizationScopeClass read FScopeClass_InitialFinalization write FScopeClass_InitialFinalization; property ScopeClass_Module: TPasModuleScopeClass read FScopeClass_Module write FScopeClass_Module; property ScopeClass_Procedure: TPasProcedureScopeClass read FScopeClass_Proc write FScopeClass_Proc; + property ScopeClass_ProcType: TPasProcTypeScopeClass read FScopeClass_ProcType write FScopeClass_ProcType; property ScopeClass_Record: TPasRecordScopeClass read FScopeClass_Record write FScopeClass_Record; property ScopeClass_Section: TPasSectionScopeClass read FScopeClass_Section write FScopeClass_Section; property ScopeClass_WithExpr: TPasWithExprScopeClass read FScopeClass_WithExpr write FScopeClass_WithExpr; @@ -11910,7 +11916,7 @@ begin if TypeParams<>nil then begin - Scope:=TPasArrayScope(PushScope(El,TPasArrayScope)); + Scope:=TPasArrayScope(PushScope(El,ScopeClass_Array)); AddGenericTemplateIdentifiers(TypeParams,Scope); end; end else if TypeParams<>nil then @@ -12239,7 +12245,7 @@ begin if TypeParams<>nil then begin - Scope:=TPasProcTypeScope(PushScope(El,TPasProcTypeScope)); + Scope:=TPasProcTypeScope(PushScope(El,ScopeClass_ProcType)); AddGenericTemplateIdentifiers(TypeParams,Scope); end; end else if TypeParams<>nil then @@ -17664,7 +17670,7 @@ var begin if GenEl.GenericTemplateTypes<>nil then begin - GenScope:=TPasGenericScope(PushScope(SpecEl,TPasProcTypeScope)); + GenScope:=TPasGenericScope(PushScope(SpecEl,ScopeClass_ProcType)); if SpecializedItem<>nil then begin // specialized procedure type @@ -18148,7 +18154,7 @@ begin SpecEl.PackMode:=GenEl.PackMode; if GenEl.GenericTemplateTypes<>nil then begin - GenScope:=TPasGenericScope(PushScope(SpecEl,TPasArrayScope)); + GenScope:=TPasGenericScope(PushScope(SpecEl,ScopeClass_Array)); if SpecializedItem<>nil then begin // specialized generic array @@ -20525,10 +20531,12 @@ begin cInterfaceToTGUID:=cTypeConversion+1; cInterfaceToString:=cTypeConversion+2; + FScopeClass_Array:=TPasArrayScope; FScopeClass_Class:=TPasClassScope; FScopeClass_InitialFinalization:=TPasInitialFinalizationScope; FScopeClass_Module:=TPasModuleScope; FScopeClass_Proc:=TPasProcedureScope; + FScopeClass_ProcType:=TPasProcTypeScope; FScopeClass_Record:=TPasRecordScope; FScopeClass_Section:=TPasSectionScope; FScopeClass_WithExpr:=TPasWithExprScope; diff --git a/packages/openssl/src/openssl.pas b/packages/openssl/src/openssl.pas index 1b23606217..d561dca67a 100644 --- a/packages/openssl/src/openssl.pas +++ b/packages/openssl/src/openssl.pas @@ -1152,7 +1152,7 @@ var function EvpPkeyAssign(pkey: PEVP_PKEY; _type: cInt; key: Prsa): cInt; function EvpGetDigestByName(Name: String): PEVP_MD; procedure EVPcleanup; - function SSLeayversion(t: cInt): string; deprecated 'For 1.1+ use OpenSSL_version'; + function SSLeayversion(t: cInt): string; deprecated 'For 1.1+ use OpenSSLGetVersion'; procedure ErrErrorString(e: cInt; var buf: string; len: cInt); function ErrGetError: cInt; procedure ErrClearError; @@ -1243,7 +1243,7 @@ var // Crypto Functions - function SSLeay_version(t: cint): PChar; + function SSLeay_version(t: cint): PChar; deprecated 'For 1.1+ use OpenSSLGetVersion'; // EVP Functions - evp.h function EVP_des_ede3_cbc : PEVP_CIPHER; @@ -1551,7 +1551,6 @@ end; type // libssl.dll - TOpenSSLversion = function (arg : cint) : pchar; cdecl; TSslGetError = function(s: PSSL; ret_code: cInt):cInt; cdecl; TSslLibraryInit = function:cInt; cdecl; TOPENSSL_INIT_new = function : POPENSSL_INIT_SETTINGS; cdecl; @@ -1631,6 +1630,7 @@ type TEvpPkeyAssign = function(pkey: PEVP_PKEY; _type: cInt; key: Prsa): cInt; cdecl; TEvpGetDigestByName = function(Name: PChar): PEVP_MD; cdecl; TEVPcleanup = procedure; cdecl; + TOpenSSLversion = function (arg : cint) : pchar; cdecl; TSSLeayversion = function(t: cInt): PChar; cdecl; TErrErrorString = procedure(e: cInt; buf: PChar; len: cInt); cdecl; TErrGetError = function: cInt; cdecl; @@ -1716,7 +1716,6 @@ type // Crypto Functions - TSSLeay_version = function(t: cint): PChar; cdecl; TCRYPTOcleanupAllExData = procedure; cdecl; TOPENSSLaddallalgorithms = procedure; cdecl; @@ -1789,7 +1788,6 @@ type var // libssl.dll - _OpenSSLVersion : TOpenSSLversion = Nil; _SslGetError: TSslGetError = nil; _SslLibraryInit: TSslLibraryInit = nil; _OPENSSL_init_ssl : TOPENSSL_init_ssl = Nil; @@ -1868,6 +1866,7 @@ var _EvpPkeyAssign: TEvpPkeyAssign = nil; _EvpGetDigestByName: TEvpGetDigestByName = nil; _EVPcleanup: TEVPcleanup = nil; + _OpenSSLVersion : TOpenSSLversion = Nil; _SSLeayversion: TSSLeayversion = nil; _ErrErrorString: TErrErrorString = nil; _ErrGetError: TErrGetError = nil; @@ -1971,7 +1970,6 @@ var // Crypto Functions - _SSLeay_version: TSSLeay_version = nil; _CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil; _OPENSSLaddallalgorithms: TOPENSSLaddallalgorithms = nil; @@ -3350,8 +3348,8 @@ end; function SSLeay_version(t: cint): PChar; begin - if InitSSLInterface and Assigned(_SSLeay_version) then - Result := _SSLeay_version(t) + if InitSSLInterface and Assigned(_SSLeayversion) then + Result := _SSLeayversion(t) else Result := nil; end; @@ -4858,7 +4856,6 @@ end; Procedure LoadSSLEntryPoints; begin - _OpenSSLVersion := GetProcAddr(SSLLibHandle, 'OpenSSL_version'); _SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error'); _SslLibraryInit := GetProcAddr(SSLLibHandle, 'SSL_library_init'); _OPENSSL_init_ssl := GetProcAddr(SSLLibHandle, 'OPENSSL_init_ssl'); @@ -4950,9 +4947,10 @@ begin _EvpPkeyAssign := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_assign'); _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup'); _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname'); + _OpenSSLVersion := GetProcAddr(SSLUtilHandle, 'OpenSSL_version'); _SSLeayversion := GetProcAddr(SSLUtilHandle, 'SSLeay_version'); if @_SSLeayversion=Nil then - _SSLeayversion := GetProcAddr(SSLUtilHandle, 'OpenSSL_version'); + _SSLeayversion := _OpenSSLVersion; _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n'); _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error'); _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error'); @@ -5090,8 +5088,6 @@ begin _BIO_s_file := GetProcAddr(SSLUtilHandle, 'BIO_s_file'); _BIO_new_file := GetProcAddr(SSLUtilHandle, 'BIO_new_file'); _BIO_new_mem_buf := GetProcAddr(SSLUtilHandle, 'BIO_new_mem_buf'); - // Crypto Functions - _SSLeay_version := GetProcAddr(SSLUtilHandle, 'SSLeay_version'); // PKCS7 _PKCS7_ISSUER_AND_SERIAL_new:=GetProcAddr(SSLUtilHandle,'PKCS7_ISSUER_AND_SERIAL_new'); _PKCS7_ISSUER_AND_SERIAL_free:=GetProcAddr(SSLUtilHandle,'PKCS7_ISSUER_AND_SERIAL_free'); @@ -5217,7 +5213,6 @@ end; Procedure ClearSSLEntryPoints; begin - _OpenSSLVersion := Nil; _SslGetError := nil; _SslLibraryInit := nil; _OPENSSL_init_ssl:=Nil; @@ -5396,6 +5391,7 @@ end; Procedure ClearUtilEntryPoints; begin + _OpenSSLVersion := Nil; _SSLeayversion := nil; _ERR_load_crypto_strings := nil; _OPENSSL_init_crypto:=Nil; @@ -5564,10 +5560,6 @@ begin _BIO_s_file := nil; _BIO_new_file := nil; _BIO_new_mem_buf := nil; - - // Crypto Functions - - _SSLeay_version := nil; end; procedure locking_callback(mode, ltype: integer; lfile: PChar; line: integer); cdecl; diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index b2ceb5b773..2ea60a053d 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -1166,6 +1166,7 @@ type TPas2JSClassScope = class(TPasClassScope) public + LongName: string; NewInstanceFunction: TPasClassFunction; GUID: string; ElevatedLocals: TPas2jsElevatedLocals; @@ -1183,6 +1184,7 @@ type TPas2JSRecordScope = class(TPasRecordScope) public + LongName: string; MemberOverloadsRenamed: boolean; end; @@ -1191,6 +1193,7 @@ type TPas2JSProcedureScope = class(TPasProcedureScope) public OverloadName: string; + LongName: string; ResultVarName: string; // valid in implementation ProcScope, empty means use ResolverResultVar BodyOverloadsRenamed: boolean; BodyJS: string; // Option coStoreProcJS: stored in ImplScope @@ -1200,6 +1203,20 @@ type destructor Destroy; override; end; + { TPas2JSArrayScope } + + TPas2JSArrayScope = Class(TPasArrayScope) + public + LongName: string; + end; + + { TPas2JSProcTypeScope } + + TPas2JSProcTypeScope = Class(TPasProcTypeScope) + public + LongName: string; + end; + { TPas2JSWithExprScope } TPas2JSWithExprScope = class(TPasWithExprScope) @@ -1495,9 +1512,12 @@ type function GenerateGUID(El: TPasClassType): string; virtual; protected // generic/specialize + procedure SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem); + override; procedure SpecializeGenericImpl(SpecializedItem: TPRSpecializedItem); override; function SpecializeNeedsDelay(SpecializedItem: TPRSpecializedItem): TPasElement; virtual; + function CreateLongName(SpecializedItem: TPRSpecializedItem): string; virtual; protected const cJSValueConversion = 2*cTypeConversion; @@ -4955,6 +4975,49 @@ begin Result:=Result+'}'; end; +procedure TPas2JSResolver.SpecializeGenericIntf( + SpecializedItem: TPRSpecializedItem); +{$IFDEF EnableLongNames} +var + El: TPasElement; + C: TClass; + RecScope: TPas2JSRecordScope; + ClassScope: TPas2JSClassScope; + ArrayScope: TPas2JSArrayScope; + ProcTypeScope: TPas2JSProcTypeScope; + LongName: String; +{$ENDIF} +begin + {$IFDEF EnableLongNames} + El:=SpecializedItem.SpecializedEl; + C:=El.ClassType; + LongName:=CreateLongName(SpecializedItem); + if C=TPasRecordType then + begin + RecScope:=TPas2JSRecordScope(El.CustomData); + RecScope.LongName:=LongName; + end + else if C=TPasClassType then + begin + ClassScope:=TPas2JSClassScope(El.CustomData); + ClassScope.LongName:=LongName; + end + else if C=TPasArrayType then + begin + ArrayScope:=TPas2JSArrayScope(El.CustomData); + ArrayScope.LongName:=LongName; + end + else if (C=TPasProcedureType) or (C=TPasFunctionType) then + begin + ProcTypeScope:=TPas2JSProcTypeScope(El.CustomData); + ProcTypeScope.LongName:=LongName; + end + else + RaiseNotYetImplemented(20200904132908,El); + {$ENDIF} + inherited SpecializeGenericIntf(SpecializedItem); +end; + procedure TPas2JSResolver.SpecializeGenericImpl( SpecializedItem: TPRSpecializedItem); var @@ -5037,6 +5100,24 @@ begin end; end; +function TPas2JSResolver.CreateLongName(SpecializedItem: TPRSpecializedItem + ): string; +var + GenEl: TPasElement; + i: Integer; + Param: TPasType; +begin + GenEl:=SpecializedItem.GenericEl; + Result:=GenEl.Name+'<'; + for i:=0 to length(SpecializedItem.Params)-1 do + begin + Param:=ResolveAliasType(SpecializedItem.Params[i],false); + // ToDo move to resolver + if Param=nil then ; + end; + Result:=Result+'>'; +end; + function TPas2JSResolver.AddJSBaseType(const aName: string; Typ: TPas2jsBaseType ): TResElDataPas2JSBaseType; var @@ -5827,6 +5908,8 @@ begin ScopeClass_Module:=TPas2JSModuleScope; ScopeClass_Procedure:=TPas2JSProcedureScope; ScopeClass_Record:=TPas2JSRecordScope; + ScopeClass_Array:=TPas2JSArrayScope; + ScopeClass_ProcType:=TPas2JSProcTypeScope; ScopeClass_Section:=TPas2JSSectionScope; ScopeClass_WithExpr:=TPas2JSWithExprScope; for bt in [pbtJSValue] do @@ -14791,6 +14874,8 @@ begin end; // add class members: types and class vars + if SpecializeNeedsDelay then + DelayFuncContext:=CreateDelayedInitFunction(El,Src,FuncContext,DelaySrc); if El.ObjKind in ([okClass]+okAllHelpers) then begin For i:=0 to El.Members.Count-1 do @@ -14828,11 +14913,7 @@ begin if NewEl<>nil then begin if SpecializeNeedsDelay and not (P is TPasProcedure) then - begin - if DelayFuncContext=nil then - DelayFuncContext:=CreateDelayedInitFunction(El,Src,FuncContext,DelaySrc); - AddToSourceElements(DelaySrc,NewEl); - end + AddToSourceElements(DelaySrc,NewEl) else AddToSourceElements(Src,NewEl); end; @@ -14900,11 +14981,7 @@ begin AddClassMessageIds(El,Src,FuncContext,pbivnMessageStr); // add RTTI init function if SpecializeNeedsDelay then - begin - if DelayFuncContext=nil then - DelayFuncContext:=CreateDelayedInitFunction(El,Src,FuncContext,DelaySrc); - AddClassRTTI(El,DelaySrc,DelayFuncContext); - end + AddClassRTTI(El,DelaySrc,DelayFuncContext) else AddClassRTTI(El,Src,FuncContext); end; @@ -15400,7 +15477,7 @@ var Obj: TJSObjectLiteral; Prop: TJSObjectLiteralElement; aResolver: TPas2JSResolver; - Scope: TPasProcTypeScope; + Scope: TPas2JSProcTypeScope; SpecializeNeedsDelay: Boolean; FuncSt: TJSFunctionDeclarationStatement; AssignSt: TJSSimpleAssignStatement; @@ -15420,7 +15497,7 @@ begin if El.Parent is TProcedureBody then RaiseNotSupported(El,AContext,20181231112029); - Scope:=El.CustomData as TPasProcTypeScope; + Scope:=El.CustomData as TPas2JSProcTypeScope; SpecializeNeedsDelay:=(Scope<>nil) and (aResolver.SpecializeNeedsDelay(Scope.SpecializedFromItem)<>nil); @@ -15532,7 +15609,7 @@ var var aResolver: TPas2JSResolver; - Scope: TPasArrayScope; + Scope: TPas2JSArrayScope; SpecializeNeedsDelay: Boolean; AssignSt: TJSSimpleAssignStatement; CallName, ArrName: String; @@ -15566,7 +15643,7 @@ begin writeln('TPasToJSConverter.ConvertArrayType ',GetObjName(El)); {$ENDIF} - Scope:=El.CustomData as TPasArrayScope; + Scope:=El.CustomData as TPas2JSArrayScope; SpecializeNeedsDelay:=(Scope<>nil) and (aResolver.SpecializeNeedsDelay(Scope.SpecializedFromItem)<>nil); @@ -16750,6 +16827,7 @@ begin if (C=TPasRecordType) or (C=TPasClassType) then begin + if (C=TPasClassType) and TPasClassType(El).IsExternal then exit; // pas.unitname.recordtype.$initSpec(); Path:=CreateReferencePath(El,AContext,rpkPathAndName)+'.'+GetBIName(pbifnClassInitSpecialize); Call:=CreateCallExpression(El); @@ -24998,6 +25076,8 @@ begin Vars:=TFPList.Create; Methods:=TFPList.Create; IsComplex:=false; + if SpecializeNeedsDelay then + DelayFuncContext:=CreateDelayedInitFunction(El,Src,FuncContext,DelaySrc); for i:=0 to El.Members.Count-1 do begin P:=TPasElement(El.Members[i]); @@ -25072,11 +25152,7 @@ begin if NewEl<>nil then begin if SpecializeNeedsDelay and not (P is TPasProcedure) then - begin - if DelayFuncContext=nil then - DelayFuncContext:=CreateDelayedInitFunction(El,Src,FuncContext,DelaySrc); - AddToSourceElements(DelaySrc,NewEl); - end + AddToSourceElements(DelaySrc,NewEl) else AddToSourceElements(Src,NewEl); end; @@ -25103,11 +25179,7 @@ begin if (aResolver<>nil) and HasTypeInfo(El,FuncContext) then begin if SpecializeNeedsDelay then - begin - if DelayFuncContext=nil then - DelayFuncContext:=CreateDelayedInitFunction(El,Src,FuncContext,DelaySrc); - CreateRecordRTTI(El,DelaySrc,DelayFuncContext); - end + CreateRecordRTTI(El,DelaySrc,DelayFuncContext) else CreateRecordRTTI(El,Src,FuncContext); end; diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas index b6a08e81e3..6186b5ecba 100644 --- a/packages/pastojs/tests/tcgenerics.pas +++ b/packages/pastojs/tests/tcgenerics.pas @@ -47,6 +47,7 @@ type procedure TestGen_ExtClass_GenJSValueAssign; procedure TestGen_ExtClass_AliasMemberType; Procedure TestGen_ExtClass_RTTI; + procedure TestGen_ExtClass_UnitImplRec; // class interfaces procedure TestGen_ClassInterface_Corba; @@ -79,6 +80,8 @@ type procedure TestGen_ArrayOfUnitImplRec; // generic procedure type + procedure TestGen_ProcType_ProcLocal; + procedure TestGen_ProcType_ProcLocal_RTTI; procedure TestGen_ProcType_ParamUnitImpl; end; @@ -1324,6 +1327,70 @@ begin ''])); end; +procedure TTestGenerics.TestGen_ExtClass_UnitImplRec; +begin + WithTypeInfo:=true; + StartProgram(true,[supTObject]); + AddModuleWithIntfImplSrc('UnitA.pas', + LinesToStr([ + '{$mode objfpc}', + '{$modeswitch externalclass}', + 'type', + ' generic TAnt = class external name ''SET''', + ' x: T;', + ' end;', + '']), + LinesToStr([ + 'type', + ' TBird = record', + ' b: word;', + ' end;', + 'var', + ' f: specialize TAnt;', + 'begin', + ' f.x.b:=f.x.b+10;', + ''])); + Add([ + 'uses UnitA;', + 'begin', + 'end.']); + ConvertProgram; + CheckUnit('UnitA.pas', + LinesToStr([ // statements + 'rtl.module("UnitA", ["system"], function () {', + ' var $mod = this;', + ' var $impl = $mod.$impl;', + ' $mod.$rtti.$ExtClass("TAnt$G1", {', + ' jsclass: "SET"', + ' });', + ' $mod.$init = function () {', + ' $impl.f.x.b = $impl.f.x.b + 10;', + ' };', + '}, null, function () {', + ' var $mod = this;', + ' var $impl = $mod.$impl;', + ' rtl.recNewT($impl, "TBird", function () {', + ' this.b = 0;', + ' this.$eq = function (b) {', + ' return this.b === b.b;', + ' };', + ' this.$assign = function (s) {', + ' this.b = s.b;', + ' return this;', + ' };', + ' var $r = $mod.$rtti.$Record("TBird", {});', + ' $r.addField("b", rtl.word);', + ' });', + ' $impl.f = null;', + '});'])); + CheckSource('TestGen_Class_ClassVarRecord_UnitImpl', + LinesToStr([ // statements + //'pas.UnitA.TAnt$G1.$initSpec();', + '']), + LinesToStr([ // $mod.$main + ''])); +end; + procedure TTestGenerics.TestGen_ClassInterface_Corba; begin StartProgram(false); @@ -2044,6 +2111,61 @@ begin ''])); end; +procedure TTestGenerics.TestGen_ProcType_ProcLocal; +begin + StartProgram(false); + Add([ + 'procedure Fly(w: word);', + 'begin', + 'end;', + 'procedure Run(w: word);', + 'type generic TProc = procedure(a: T);', + 'var p: specialize TProc;', + 'begin', + ' p:=@Fly;', + ' p(w);', + 'end;', + 'begin', + 'end.']); + ConvertProgram; + CheckSource('TestGen_ProcType_ProcLocal', + LinesToStr([ // statements + 'this.Fly = function (w) {', + '};', + 'this.Run = function (w) {', + ' var p = null;', + ' p = $mod.Fly;', + ' p(w);', + '};', + '']), + LinesToStr([ // $mod.$main + ''])); +end; + +procedure TTestGenerics.TestGen_ProcType_ProcLocal_RTTI; +begin + WithTypeInfo:=true; + StartProgram(false); + Add([ + 'procedure Fly(w: word);', + 'begin', + 'end;', + 'procedure Run(w: word);', + 'type generic TProc = procedure(a: T);', + 'var', + ' p: specialize TProc;', + ' t: Pointer;', + 'begin', + ' p:=@Fly;', + ' p(w);', + ' t:=typeinfo(p);', + 'end;', + 'begin', + 'end.']); + SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished); + ConvertProgram; +end; + procedure TTestGenerics.TestGen_ProcType_ParamUnitImpl; begin WithTypeInfo:=true; diff --git a/packages/winunits-base/src/richedit.pp b/packages/winunits-base/src/richedit.pp index 0093109659..8454ecf168 100644 --- a/packages/winunits-base/src/richedit.pp +++ b/packages/winunits-base/src/richedit.pp @@ -692,7 +692,7 @@ Const COMPCOLOR = _compcolor; TCOMPCOLOR = _compcolor; - EDITSTREAMCALLBACK = function (dwCookie:PDWORD; pbBuff:LPBYTE; cb:LONG; var pcb:LONG):DWORD; + EDITSTREAMCALLBACK = function (dwCookie:DWORD_PTR; pbBuff:LPBYTE; cb:LONG; var pcb:LONG):DWORD; _editstream = record dwCookie : DWORD_PTR; diff --git a/rtl/objpas/math.pp b/rtl/objpas/math.pp index 38f73b207c..f87c811e0a 100644 --- a/rtl/objpas/math.pp +++ b/rtl/objpas/math.pp @@ -56,10 +56,6 @@ interface sysutils; {$IFDEF FPDOC_MATH} -{$DEFINE FPC_HAS_TYPE_SINGLE} -{$DEFINE FPC_HAS_TYPE_DOUBLE} -{$DEFINE FPC_HAS_TYPE_EXTENDED} -{$DEFINE FPC_HAS_TYPE_COMP} Type Float = MaxFloatType; @@ -158,6 +154,17 @@ Const NegInfinity = -1.0/0.0; {$pop} + +{$IFDEF FPDOC_MATH} + +// This must be after the above defines. + +{$DEFINE FPC_HAS_TYPE_SINGLE} +{$DEFINE FPC_HAS_TYPE_DOUBLE} +{$DEFINE FPC_HAS_TYPE_EXTENDED} +{$DEFINE FPC_HAS_TYPE_COMP} +{$ENDIF} + { Min/max determination } function MinIntValue(const Data: array of Integer): Integer; function MaxIntValue(const Data: array of Integer): Integer; diff --git a/rtl/win/sysutils.pp b/rtl/win/sysutils.pp index fd7abcc58d..ec36bb4caa 100644 --- a/rtl/win/sysutils.pp +++ b/rtl/win/sysutils.pp @@ -476,16 +476,19 @@ begin end; end; - Handle := FindFirstFileExW(PUnicodeChar(SymLinkRec.TargetName), FindExInfoDefaults , @SymLinkRec.FindData, - FindExSearchNameMatch, Nil, 0); - if Handle <> INVALID_HANDLE_VALUE then begin - Windows.FindClose(Handle); - SymLinkRec.Attr := SymLinkRec.FindData.dwFileAttributes; - SymLinkRec.Size := QWord(SymLinkRec.FindData.nFileSizeHigh) shl 32 + QWord(SymLinkRec.FindData.nFileSizeLow); - end else if RaiseErrorOnMissing then - raise EDirectoryNotFoundException.Create(SysErrorMessage(GetLastOSError)) - else - SymLinkRec.TargetName := ''; + if SymLinkRec.TargetName <> '' then begin + Handle := FindFirstFileExW(PUnicodeChar(SymLinkRec.TargetName), FindExInfoDefaults , @SymLinkRec.FindData, + FindExSearchNameMatch, Nil, 0); + if Handle <> INVALID_HANDLE_VALUE then begin + Windows.FindClose(Handle); + SymLinkRec.Attr := SymLinkRec.FindData.dwFileAttributes; + SymLinkRec.Size := QWord(SymLinkRec.FindData.nFileSizeHigh) shl 32 + QWord(SymLinkRec.FindData.nFileSizeLow); + end else if RaiseErrorOnMissing then + raise EDirectoryNotFoundException.Create(SysErrorMessage(GetLastOSError)) + else + SymLinkRec.TargetName := ''; + end else + SetLastError(ERROR_REPARSE_TAG_INVALID); end else SetLastError(ERROR_REPARSE_TAG_INVALID); finally diff --git a/tests/test/cg/tcaldefs.inc b/tests/test/cg/cpudefs.inc similarity index 100% rename from tests/test/cg/tcaldefs.inc rename to tests/test/cg/cpudefs.inc diff --git a/tests/webtbs/tw37650.pp b/tests/webtbs/tw37650.pp new file mode 100644 index 0000000000..b769c0ed9e --- /dev/null +++ b/tests/webtbs/tw37650.pp @@ -0,0 +1,22 @@ +{ %NORUN } + +program tw37650; + +{$mode objfpc} + +type + generic TMyClass = class + type TKey = String[U]; + end; + +generic procedure Test; +type + TKey = String[U]; +begin +end; + +type + TMyClass12 = specialize TMyClass<12>; +begin + specialize Test<12>; +end.