paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-17 15:49:16 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@48022 -
This commit is contained in:
nickysn 2021-01-04 02:57:44 +00:00
commit 052d1bc38a
51 changed files with 2311 additions and 1679 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.gitattributes vendored
View File

@ -15229,6 +15229,10 @@ tests/test/tgenfunc20.pp svneol=native#text/pascal
tests/test/tgenfunc21.pp svneol=native#text/pascal
tests/test/tgenfunc22.pp svneol=native#text/pascal
tests/test/tgenfunc23.pp svneol=native#text/pascal
tests/test/tgenfunc24.pp svneol=native#text/pascal
tests/test/tgenfunc25.pp svneol=native#text/pascal
tests/test/tgenfunc26.pp svneol=native#text/pascal
tests/test/tgenfunc27.pp svneol=native#text/pascal
tests/test/tgenfunc3.pp svneol=native#text/pascal
tests/test/tgenfunc4.pp svneol=native#text/pascal
tests/test/tgenfunc5.pp svneol=native#text/pascal
@ -16745,6 +16749,8 @@ tests/webtbf/tw37476.pp svneol=native#text/pascal
tests/webtbf/tw37763.pp svneol=native#text/pascal
tests/webtbf/tw3790.pp svneol=native#text/plain
tests/webtbf/tw3812.pp svneol=native#text/plain
tests/webtbf/tw38289a.pp svneol=native#text/pascal
tests/webtbf/tw38289b.pp svneol=native#text/pascal
tests/webtbf/tw3930a.pp svneol=native#text/plain
tests/webtbf/tw3931b.pp svneol=native#text/plain
tests/webtbf/tw3969.pp svneol=native#text/plain
@ -18672,6 +18678,8 @@ tests/webtbs/tw38267a.pp svneol=native#text/pascal
tests/webtbs/tw38267b.pp svneol=native#text/pascal
tests/webtbs/tw3827.pp svneol=native#text/plain
tests/webtbs/tw3829.pp svneol=native#text/plain
tests/webtbs/tw38295.pp svneol=native#text/pascal
tests/webtbs/tw38299.pp svneol=native#text/pascal
tests/webtbs/tw3833.pp svneol=native#text/plain
tests/webtbs/tw3840.pp svneol=native#text/plain
tests/webtbs/tw3841.pp svneol=native#text/plain
@ -19338,6 +19346,7 @@ utils/fpdoc/Makefile.fpc.fpcmake svneol=native#text/plain
utils/fpdoc/README.txt svneol=native#text/plain
utils/fpdoc/css.inc svneol=native#text/plain
utils/fpdoc/dglobals.pp svneol=native#text/plain
utils/fpdoc/dw_basehtml.pp svneol=native#text/plain
utils/fpdoc/dw_basemd.pp svneol=native#text/plain
utils/fpdoc/dw_chm.pp svneol=native#text/plain
utils/fpdoc/dw_dxml.pp svneol=native#text/plain

3
compiler/dbgstabs.pas
View File

@ -480,6 +480,9 @@ implementation
begin
if tsym(p).typ = procsym then
begin
if (sp_generic_dummy in tsym(p).symoptions) and
(tprocsym(p).procdeflist.count=0) then
exit;
pd :=tprocdef(tprocsym(p).ProcdefList[0]);
if (po_virtualmethod in pd.procoptions) and
not is_objectpascal_helper(pd.struct) then

79
compiler/nadd.pas
View File

@ -536,12 +536,28 @@ implementation
function SwapLeftWithRightRight : tnode;
var
hp: tnode;
hp,hp2 : tnode;
begin
hp:=left;
left:=taddnode(right).right;
taddnode(right).right:=hp;
right:=right.simplify(false);
{ keep the order of val+const else string operations might cause an error }
hp:=taddnode(right).right;
taddnode(right).right:=taddnode(right).left;
taddnode(right).left:=left;
right.resultdef:=nil;
do_typecheckpass(right);
hp2:=right.simplify(forinline);
if assigned(hp2) then
right:=hp2;
if resultdef.typ<>pointerdef then
begin
{ ensure that the constant is not expanded to a larger type due to overflow,
but this is only useful if no pointer operation is done }
right:=ctypeconvnode.create_internal(right,resultdef);
do_typecheckpass(right);
end;
left:=right;
right:=hp;
result:=GetCopyAndTypeCheck;
end;
@ -1207,22 +1223,6 @@ implementation
exit;
end;
{ try to fold
op
/ \
op const1
/ \
val const2
while operating on strings
}
if (cs_opt_level2 in current_settings.optimizerswitches) and (nodetype=addn) and ((rt=stringconstn) or is_constcharnode(right)) and (left.nodetype=nodetype) and
(compare_defs(resultdef,left.resultdef,nothingn)=te_exact) and ((taddnode(left).right.nodetype=stringconstn) or is_constcharnode(taddnode(left).right)) then
begin
Result:=SwapRightWithLeftLeft;
exit;
end;
{ set constant evaluation }
if (right.nodetype=setconstn) and
not assigned(tsetconstnode(right).left) and
@ -1381,9 +1381,44 @@ implementation
exit;
end;
{ slow simplifications }
{ slow simplifications and/or more sophisticated transformations which might make debugging harder }
if cs_opt_level2 in current_settings.optimizerswitches then
begin
if nodetype=addn then
begin
{ try to fold
op
/ \
op const1
/ \
val const2
while operating on strings
}
if ((rt=stringconstn) or is_constcharnode(right)) and (left.nodetype=nodetype) and
(compare_defs(resultdef,left.resultdef,nothingn)=te_exact) and ((taddnode(left).right.nodetype=stringconstn) or is_constcharnode(taddnode(left).right)) then
begin
Result:=SwapRightWithLeftLeft;
exit;
end;
{ try to fold
op
/ \
const1 op
/ \
const2 val
while operating on strings
}
if ((lt=stringconstn) or is_constcharnode(left)) and (right.nodetype=nodetype) and
(compare_defs(resultdef,right.resultdef,nothingn)=te_exact) and ((taddnode(right).left.nodetype=stringconstn) or is_constcharnode(taddnode(right).left)) then
begin
Result:=SwapLeftWithRightRight;
exit;
end;
end;
{ the comparison is might be expensive and the nodes are usually only
equal if some previous optimizations were done so don't check
this simplification always

20
compiler/pdecsub.pas
View File

@ -1066,7 +1066,8 @@ implementation
end
else if (srsym.typ=typesym) and
(sp_generic_dummy in srsym.symoptions) and
(ttypesym(srsym).typedef.typ=undefineddef) then
(ttypesym(srsym).typedef.typ=undefineddef) and
not assigned(genericparams) then
begin
{ this is a generic dummy symbol that has not yet
been used; so we rename the dummy symbol and continue
@ -1162,13 +1163,26 @@ implementation
end;
if not assigned(dummysym) then
begin
dummysym:=ctypesym.create(orgspnongen,cundefineddef.create(true));
{ overloading generic routines with non-generic types is not
allowed, so we create a procsym as dummy }
dummysym:=cprocsym.create(orgspnongen);
if assigned(astruct) then
astruct.symtable.insert(dummysym)
else
symtablestack.top.insert(dummysym);
end;
end
else if (dummysym.typ<>procsym) and
(
{ show error only for the declaration, not also the implementation }
not assigned(astruct) or
(symtablestack.top.symtablelevel<>main_program_level)
) then
Message1(sym_e_duplicate_id,dummysym.realname);
if not (sp_generic_dummy in dummysym.symoptions) then
begin
include(dummysym.symoptions,sp_generic_dummy);
add_generic_dummysym(dummysym);
end;
{ start token recorder for the declaration }
pd.init_genericdecl;
current_scanner.startrecordtokens(pd.genericdecltokenbuf);

4
compiler/pexports.pas
View File

@ -149,7 +149,7 @@ implementation
else
begin
index:=0;
consume(_INTCONST);
message(type_e_ordinal_expr_expected);
end;
include(options,eo_index);
pt.free;
@ -166,7 +166,7 @@ implementation
else if is_constcharnode(pt) then
hpname:=chr(tordconstnode(pt).value.svalue and $ff)
else
consume(_CSTRING);
message(type_e_string_expr_expected);
include(options,eo_name);
pt.free;
DefString:=hpname+'='+InternalProcName;

56
compiler/pexpr.pas
View File

@ -1514,13 +1514,15 @@ implementation
begin
if srsym.typ=typesym then
spezdef:=ttypesym(srsym).typedef
else if tprocsym(srsym).procdeflist.count>0 then
spezdef:=tdef(tprocsym(srsym).procdeflist[0])
else
spezdef:=tdef(tprocsym(srsym).procdeflist[0]);
if (spezdef.typ=errordef) and (sp_generic_dummy in srsym.symoptions) then
spezdef:=nil;
if (not assigned(spezdef) or (spezdef.typ=errordef)) and (sp_generic_dummy in srsym.symoptions) then
symname:=srsym.RealName
else
symname:='';
spezdef:=generate_specialization_phase1(spezcontext,spezdef,symname);
spezdef:=generate_specialization_phase1(spezcontext,spezdef,symname,srsym.owner);
case spezdef.typ of
errordef:
begin
@ -2994,7 +2996,7 @@ implementation
begin
{$push}
{$warn 5036 off}
hdef:=generate_specialization_phase1(spezcontext,nil,nil,orgstoredpattern,dummypos);
hdef:=generate_specialization_phase1(spezcontext,nil,nil,orgstoredpattern,nil,dummypos);
{$pop}
if hdef=generrordef then
begin
@ -3048,12 +3050,20 @@ implementation
wasgenericdummy:=false;
if assigned(srsym) and
(sp_generic_dummy in srsym.symoptions) and
(srsym.typ=typesym) and
(srsym.typ in [procsym,typesym]) and
(
(
(m_delphi in current_settings.modeswitches) and
not (token in [_LT, _LSHARPBRACKET]) and
(
(
(srsym.typ=typesym) and
(ttypesym(srsym).typedef.typ=undefineddef)
) or (
(srsym.typ=procsym) and
(tprocsym(srsym).procdeflist.count=0)
)
)
)
or
(
@ -3306,8 +3316,14 @@ implementation
procsym :
begin
p1:=nil;
if (m_delphi in current_settings.modeswitches) and
(sp_generic_dummy in srsym.symoptions) and
(token in [_LT,_LSHARPBRACKET]) then
begin
p1:=cspecializenode.create(nil,getaddr,srsym)
end
{ check if it's a method/class method }
if is_member_read(srsym,srsymtable,p1,hdef) then
else if is_member_read(srsym,srsymtable,p1,hdef) then
begin
{ if we are accessing a owner procsym from the nested }
{ class we need to call it as a class member }
@ -3558,17 +3574,20 @@ implementation
(block_type=bt_body) and
(token in [_LT,_LSHARPBRACKET]) then
begin
if p1.nodetype=typen then
idstr:=ttypenode(p1).typesym.name
else
if (p1.nodetype=loadvmtaddrn) and
(tloadvmtaddrnode(p1).left.nodetype=typen) then
idstr:=ttypenode(tloadvmtaddrnode(p1).left).typesym.name
else
if (p1.nodetype=loadn) then
idstr:=tloadnode(p1).symtableentry.name
else
idstr:='';
case p1.nodetype of
typen:
idstr:=ttypenode(p1).typesym.name;
loadvmtaddrn:
if tloadvmtaddrnode(p1).left.nodetype=typen then
idstr:=ttypenode(tloadvmtaddrnode(p1).left).typesym.name;
loadn:
idstr:=tloadnode(p1).symtableentry.name;
calln:
idstr:=tcallnode(p1).symtableprocentry.name;
else
;
end;
{ if this is the case then the postfix handling is done in
sub_expr if necessary }
dopostfix:=not could_be_generic(idstr);
@ -4211,6 +4230,7 @@ implementation
typesym:
result:=ttypesym(sym).typedef;
procsym:
if not (sp_generic_dummy in sym.symoptions) or (tprocsym(sym).procdeflist.count>0) then
result:=tdef(tprocsym(sym).procdeflist[0]);
else
internalerror(2015092701);
@ -4230,6 +4250,8 @@ implementation
loadn:
if not searchsym_with_symoption(tloadnode(n).symtableentry.Name,srsym,srsymtable,sp_generic_dummy) then
srsym:=nil;
calln:
srsym:=tcallnode(n).symtableprocentry;
specializen:
srsym:=tspecializenode(n).sym;
{ TODO : handle const nodes }
@ -4264,7 +4286,7 @@ implementation
end;
if assigned(parseddef) and assigned(gensym) and assigned(p2) then
gendef:=generate_specialization_phase1(spezcontext,gendef,parseddef,gensym.realname,p2.fileinfo)
gendef:=generate_specialization_phase1(spezcontext,gendef,parseddef,gensym.realname,gensym.owner,p2.fileinfo)
else
gendef:=generate_specialization_phase1(spezcontext,gendef);
case gendef.typ of

33
compiler/pgenutil.pas
View File

@ -39,8 +39,8 @@ uses
procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string;parsedtype:tdef;symname:string;parsedpos:tfileposinfo);inline;
procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string);inline;
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef):tdef;inline;
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;symname:string):tdef;inline;
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef;
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;symname:string;symtable:tsymtable):tdef;inline;
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef;
function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;_prettyname:ansistring):tdef;
function check_generic_constraints(genericdef:tstoreddef;paramlist:tfpobjectlist;poslist:tfplist):boolean;
function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
@ -613,23 +613,23 @@ uses
{$push}
{$warn 5036 off}
begin
result:=generate_specialization_phase1(context,genericdef,nil,'',dummypos);
result:=generate_specialization_phase1(context,genericdef,nil,'',nil,dummypos);
end;
{$pop}
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;symname:string):tdef;
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;symname:string;symtable:tsymtable):tdef;
var
dummypos : tfileposinfo;
{$push}
{$warn 5036 off}
begin
result:=generate_specialization_phase1(context,genericdef,nil,symname,dummypos);
result:=generate_specialization_phase1(context,genericdef,nil,symname,symtable,dummypos);
end;
{$pop}
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef;
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef;
var
found,
err : boolean;
@ -637,6 +637,7 @@ uses
gencount : longint;
countstr,genname,ugenname : string;
tmpstack : tfpobjectlist;
symowner : tsymtable;
begin
context:=nil;
result:=nil;
@ -741,12 +742,17 @@ uses
context.genname:=genname;
if assigned(genericdef) and (genericdef.owner.symtabletype in [objectsymtable,recordsymtable]) then
begin
if genericdef.owner.symtabletype = objectsymtable then
found:=searchsym_in_class(tobjectdef(genericdef.owner.defowner),tobjectdef(genericdef.owner.defowner),ugenname,context.sym,context.symtable,[])
if assigned(genericdef) then
symowner:=genericdef.owner
else
found:=searchsym_in_record(tabstractrecorddef(genericdef.owner.defowner),ugenname,context.sym,context.symtable);
symowner:=symtable;
if assigned(symowner) and (symowner.symtabletype in [objectsymtable,recordsymtable]) then
begin
if symowner.symtabletype = objectsymtable then
found:=searchsym_in_class(tobjectdef(symowner.defowner),tobjectdef(symowner.defowner),ugenname,context.sym,context.symtable,[])
else
found:=searchsym_in_record(tabstractrecorddef(symowner.defowner),ugenname,context.sym,context.symtable);
if not found then
found:=searchsym(ugenname,context.sym,context.symtable);
end
@ -1350,7 +1356,7 @@ uses
context : tspecializationcontext;
genericdef : tstoreddef;
begin
genericdef:=tstoreddef(generate_specialization_phase1(context,tt,parsedtype,symname,parsedpos));
genericdef:=tstoreddef(generate_specialization_phase1(context,tt,parsedtype,symname,nil,parsedpos));
if genericdef<>generrordef then
genericdef:=tstoreddef(generate_specialization_phase2(context,genericdef,parse_class_parent,_prettyname));
tt:=genericdef;
@ -1790,8 +1796,7 @@ uses
if not searchsym_with_flags(sym.name,srsym,srsymtable,[ssf_no_addsymref]) then
srsym:=nil;
end
else if (sym.typ=procsym) and
(tprocsym(sym).procdeflist.count>0) then
else if sym.typ=procsym then
srsym:=sym
else
{ dummy symbol is already not so dummy anymore }

10
compiler/symtable.pas
View File

@ -3374,6 +3374,8 @@ implementation
exit;
end;
end;
if (tprocsym(sym).procdeflist.count=0) and (sp_generic_dummy in tprocsym(sym).symoptions) then
result:=is_visible_for_object(sym.owner,sym.visibility,contextobjdef);
end
else
result:=is_visible_for_object(sym.owner,sym.visibility,contextobjdef);
@ -4254,6 +4256,14 @@ implementation
result:=true;
exit;
end;
if (sp_generic_dummy in tprocsym(srsym).symoptions) and
(tprocsym(srsym).procdeflist.count=0) and
is_visible_for_object(srsym.owner,srsym.visibility,contextclassh) then
begin
srsymtable:=srsym.owner;
result:=true;
exit;
end;
end;
typesym,
fieldvarsym,

4
compiler/x86/nx86inl.pas
View File

@ -1223,7 +1223,9 @@ implementation
{ only one memory operand is allowed }
gotmem:=false;
memop:=0;
for i:=1 to 3 do
{ in case parameters come on the FPU stack, we have to pop them in reverse order as we
called secondpass }
for i:=3 downto 1 do
begin
if not(paraarray[i].location.loc in [LOC_MMREGISTER,LOC_CMMREGISTER]) then
begin

2
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -208,6 +208,7 @@ const
nClassTypesAreNotRelatedXY = 3142;
nDirectiveXNotAllowedHere = 3143;
nAwaitWithoutPromise = 3144;
nSymbolCannotExportedFromALibrary = 3145;
// using same IDs as FPC
nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@ -363,6 +364,7 @@ resourcestring
sClassTypesAreNotRelatedXY = 'Class types "%s" and "%s" are not related';
sDirectiveXNotAllowedHere = 'Directive "%s" not allowed here';
sAwaitWithoutPromise = 'Await without promise';
sSymbolCannotExportedFromALibrary = 'The symbol cannot be exported from a library';
type
{ TResolveData - base class for data stored in TPasElement.CustomData }

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

@ -1612,6 +1612,7 @@ type
procedure AddClassType(El: TPasClassType; TypeParams: TFPList); virtual;
procedure AddVariable(El: TPasVariable); virtual;
procedure AddResourceString(El: TPasResString); virtual;
procedure AddExportSymbol(El: TPasExportSymbol); virtual;
procedure AddEnumType(El: TPasEnumType); virtual;
procedure AddEnumValue(El: TPasEnumValue); virtual;
procedure AddProperty(El: TPasProperty); virtual;
@ -9139,7 +9140,7 @@ end;
procedure TPasResolver.FinishExportSymbol(El: TPasExportSymbol);
procedure CheckExpExpr(Expr: TPasExpr; Kinds: TREVKinds; const Expected: string);
procedure CheckConstExpr(Expr: TPasExpr; Kinds: TREVKinds; const Expected: string);
var
Value: TResEvalValue;
ResolvedEl: TPasResolverResult;
@ -9157,9 +9158,40 @@ procedure TPasResolver.FinishExportSymbol(El: TPasExportSymbol);
RaiseXExpectedButYFound(20210101194628,Expected,GetTypeDescription(ResolvedEl),Expr);
end;
var
Expr: TPasExpr;
DeclEl: TPasElement;
FindData: TPRFindData;
Ref: TResolvedReference;
ResolvedEl: TPasResolverResult;
begin
CheckExpExpr(El.ExportIndex,[revkInt,revkUInt],'integer');
CheckExpExpr(El.ExportName,[revkString,revkUnicodeString],'string');
Expr:=El.NameExpr;
if Expr<>nil then
begin
ResolveExpr(Expr,rraRead);
//ResolveGlobalSymbol(Expr);
ComputeElement(Expr,ResolvedEl,[rcConstant]);
DeclEl:=ResolvedEl.IdentEl;
if DeclEl=nil then
RaiseMsg(20210103012907,nXExpectedButYFound,sXExpectedButYFound,['symbol',GetTypeDescription(ResolvedEl)],Expr);
if not (DeclEl.Parent is TPasSection) then
RaiseMsg(20210103012908,nXExpectedButYFound,sXExpectedButYFound,['global symbol',GetElementTypeName(DeclEl)],Expr);
end
else
begin
FindFirstEl(El.Name,FindData,El);
DeclEl:=FindData.Found;
if DeclEl=nil then
RaiseMsg(20210103002747,nIdentifierNotFound,sIdentifierNotFound,[El.Name],El);
if not (DeclEl.Parent is TPasSection) then
RaiseMsg(20210103003244,nXExpectedButYFound,sXExpectedButYFound,['global symbol',GetObjPath(DeclEl)],El);
Ref:=CreateReference(DeclEl,El,rraRead,@FindData);
CheckFoundElement(FindData,Ref);
end;
// check index and name
CheckConstExpr(El.ExportIndex,[revkInt,revkUInt],'integer');
CheckConstExpr(El.ExportName,[revkString,revkUnicodeString],'string');
end;
procedure TPasResolver.FinishProcParamAccess(ProcType: TPasProcedureType;
@ -10276,7 +10308,7 @@ begin
if ProcNeedsParams(Proc.ProcType) and not ExprIsAddrTarget(El) then
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveNameExpr ',GetObjName(El));
writeln('TPasResolver.ResolveNameExpr ',GetObjPath(El));
{$ENDIF}
RaiseMsg(20170216152138,nWrongNumberOfParametersForCallTo,
sWrongNumberOfParametersForCallTo,[Proc.Name],El);
@ -12205,6 +12237,14 @@ begin
AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple);
end;
procedure TPasResolver.AddExportSymbol(El: TPasExportSymbol);
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.AddExportSymbol ',GetObjName(El));
{$ENDIF}
// Note: export symbol is not added to scope
end;
procedure TPasResolver.AddEnumType(El: TPasEnumType);
var
CanonicalSet: TPasSetType;
@ -17452,6 +17492,8 @@ begin
AddProcedureType(TPasProcedureType(SpecEl),nil);
SpecializeProcedureType(TPasProcedureType(GenEl),TPasProcedureType(SpecEl),nil);
end
else if C=TPasExportSymbol then
RaiseMsg(20210101234958,nSymbolCannotExportedFromALibrary,sSymbolCannotExportedFromALibrary,[],GenEl)
else
RaiseNotYetImplemented(20190728151215,GenEl);
end;
@ -20866,6 +20908,7 @@ begin
// resolved when finished
else if AClass=TPasAttributes then
else if AClass=TPasExportSymbol then
AddExportSymbol(TPasExportSymbol(El))
else if AClass=TPasUnresolvedUnitRef then
RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El)
else
@ -28209,10 +28252,12 @@ function TPasResolver.ExprIsAddrTarget(El: TPasExpr): boolean;
e.g. '@p().o[].El' or '@El[]'
b) mode delphi: the last element of a right side of an assignment
c) an accessor function, e.g. property P read El;
d) an export
}
var
Parent: TPasElement;
Prop: TPasProperty;
C: TClass;
begin
Result:=false;
if El=nil then exit;
@ -28221,31 +28266,34 @@ begin
repeat
Parent:=El.Parent;
//writeln('TPasResolver.ExprIsAddrTarget El=',GetObjName(El),' Parent=',GetObjName(Parent));
if Parent.ClassType=TUnaryExpr then
C:=Parent.ClassType;
if C=TUnaryExpr then
begin
if TUnaryExpr(Parent).OpCode=eopAddress then exit(true);
end
else if Parent.ClassType=TBinaryExpr then
else if C=TBinaryExpr then
begin
if TBinaryExpr(Parent).right<>El then exit;
if TBinaryExpr(Parent).OpCode<>eopSubIdent then exit;
end
else if Parent.ClassType=TParamsExpr then
else if C=TParamsExpr then
begin
if TParamsExpr(Parent).Value<>El then exit;
end
else if Parent.ClassType=TPasProperty then
else if C=TPasProperty then
begin
Prop:=TPasProperty(Parent);
Result:=(Prop.ReadAccessor=El) or (Prop.WriteAccessor=El) or (Prop.StoredAccessor=El);
exit;
end
else if Parent.ClassType=TPasImplAssign then
else if C=TPasImplAssign then
begin
if TPasImplAssign(Parent).right<>El then exit;
if (msDelphi in CurrentParser.CurrentModeswitches) then exit(true);
exit;
end
else if C=TPasExportSymbol then
exit(true)
else
exit;
El:=TPasExpr(Parent);

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

@ -975,6 +975,7 @@ type
TPasExportSymbol = class(TPasElement)
public
NameExpr: TPasExpr; // only if name is not a simple identifier
ExportName : TPasExpr;
ExportIndex : TPasExpr;
Destructor Destroy; override;
@ -2601,6 +2602,7 @@ end;
destructor TPasExportSymbol.Destroy;
begin
ReleaseAndNil(TPasElement(NameExpr){$IFDEF CheckPasTreeRefCount},'TPasExportSymbol.NameExpr'{$ENDIF});
ReleaseAndNil(TPasElement(ExportName){$IFDEF CheckPasTreeRefCount},'TPasExportSymbol.ExportName'{$ENDIF});
ReleaseAndNil(TPasElement(ExportIndex){$IFDEF CheckPasTreeRefCount},'TPasExportSymbol.ExportIndex'{$ENDIF});
inherited Destroy;
@ -2624,6 +2626,7 @@ procedure TPasExportSymbol.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,NameExpr,false);
ForEachChildCall(aMethodCall,Arg,ExportName,false);
ForEachChildCall(aMethodCall,Arg,ExportIndex,false);
end;

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

@ -4341,13 +4341,25 @@ end;
procedure TPasParser.ParseExportDecl(Parent: TPasElement; List: TFPList);
Var
E : TPasExportSymbol;
aName: String;
NameExpr: TPasExpr;
begin
try
Repeat
if List.Count<>0 then
if List.Count>0 then
ExpectIdentifier;
E:=TPasExportSymbol(CreateElement(TPasExportSymbol,CurtokenString,Parent));
aName:=ReadDottedIdentifier(Parent,NameExpr,true);
E:=TPasExportSymbol(CreateElement(TPasExportSymbol,aName,Parent));
if NameExpr.Kind=pekIdent then
// simple identifier -> no need to store NameExpr
NameExpr.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}
else
begin
E.NameExpr:=NameExpr;
NameExpr.Parent:=E;
end;
NameExpr:=nil;
List.Add(E);
NextToken;
if CurTokenIsIdentifier('INDEX') then
begin
NextToken;
@ -4362,6 +4374,10 @@ begin
ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon);
Engine.FinishScope(stDeclaration,E);
until (CurToken=tkSemicolon);
finally
if NameExpr<>nil then
NameExpr.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}
end;
end;
function TPasParser.ParseProcedureType(Parent: TPasElement;

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

@ -986,6 +986,7 @@ type
Procedure TestLibrary_ExportFunc_IndexStringFail;
Procedure TestLibrary_ExportVar; // ToDo
Procedure TestLibrary_Initialization_Finalization;
Procedure TestLibrary_ExportFuncOverloadFail; // ToDo
// ToDo Procedure TestLibrary_UnitExports;
end;
@ -18833,6 +18834,25 @@ begin
ParseLibrary;
end;
procedure TTestResolver.TestLibrary_ExportFuncOverloadFail;
begin
exit;
StartLibrary(false);
Add([
'procedure Run(w: word); overload;',
'begin',
'end;',
'procedure Run(d: double); overload;',
'begin',
'end;',
'exports',
' Run,',
' afile.run;',
'begin']);
CheckResolverException('The symbol cannot be exported from a library',123);
end;
initialization
RegisterTests([TTestResolver]);

2
packages/pastojs/src/pas2jsfiler.pp
View File

@ -4430,6 +4430,7 @@ procedure TPCUWriter.WriteExportSymbol(Obj: TJSONObject; El: TPasExportSymbol;
aContext: TPCUWriterContext);
begin
WritePasElement(Obj,El,aContext);
WriteExpr(Obj,El,'NameExpr',El.NameExpr,aContext);
WriteExpr(Obj,El,'ExportName',El.ExportName,aContext);
WriteExpr(Obj,El,'ExportIndex',El.ExportIndex,aContext);
end;
@ -9256,6 +9257,7 @@ procedure TPCUReader.ReadExportSymbol(Obj: TJSONObject; El: TPasExportSymbol;
aContext: TPCUReaderContext);
begin
ReadPasElement(Obj,El,aContext);
El.NameExpr:=ReadExpr(Obj,El,'NameExpr',aContext);
El.ExportName:=ReadExpr(Obj,El,'ExportName',aContext);
El.ExportIndex:=ReadExpr(Obj,El,'ExportIndex',aContext);
end;

1
packages/pastojs/tests/tcfiler.pas
View File

@ -1935,6 +1935,7 @@ end;
procedure TCustomTestPrecompile.CheckRestoredExportSymbol(const Path: string;
Orig, Rest: TPasExportSymbol; Flags: TPCCheckFlags);
begin
CheckRestoredElement(Path+'.NameExpr',Orig.NameExpr,Rest.NameExpr,Flags);
CheckRestoredElement(Path+'.ExportName',Orig.ExportName,Rest.ExportName,Flags);
CheckRestoredElement(Path+'.ExportIndex',Orig.ExportIndex,Rest.ExportIndex,Flags);
end;

14
packages/rtl-objpas/src/inc/nullable.pp
View File

@ -1,3 +1,17 @@
{
This file is part of the Free Pascal run time library.
Copyright (C) 2020 Michael Van Canneyt
member of the Free Pascal development team.
Nullable generic type.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
unit nullable;
{$mode objfpc}

2
rtl/aarch64/mathu.inc
View File

@ -51,7 +51,7 @@ function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
rm2bits: array[TFPURoundingMode] of byte = (0,2,1,3);
begin
softfloat_rounding_mode:=RoundMode;
SetRoundMode:=RoundMode;
SetRoundMode:=GetRoundMode;
setfpcr((getfpcr and $ff3fffff) or (rm2bits[RoundMode] shl 22));
end;

3
rtl/arm/mathu.inc
View File

@ -62,9 +62,10 @@ function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
var
c: dword;
begin
softfloat_rounding_mode:=RoundMode;
Reslut:=GetRoundMode;
c:=Ord(RoundMode) shl 16;
c:=_controlfp(c, _MCW_RC);
Result:=TFPURoundingMode((c shr 16) and 3);
end;
function GetPrecisionMode: TFPUPrecisionMode;

1
rtl/i386/mathu.inc
View File

@ -147,6 +147,7 @@ function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
var
CtlWord: Word;
begin
softfloat_rounding_mode:=RoundMode;
CtlWord := Get8087CW;
Set8087CW((CtlWord and $F3FF) or (Ord(RoundMode) shl 10));
if has_sse_support then

1
rtl/i8086/mathu.inc
View File

@ -155,6 +155,7 @@ function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
var
CtlWord: Word;
begin
softfloat_rounding_mode:=RoundMode;
CtlWord := Get8087CW;
Set8087CW((CtlWord and $F3FF) or (Ord(RoundMode) shl 10));
{ if has_sse_support then

2
rtl/m68k/mathu.inc
View File

@ -137,10 +137,10 @@ const
var
FPCR: DWord;
begin
Result:=GetRoundMode;
FPCR:=GetFPCR and not FPU68K_ROUND_MASK;
SetFPCR(FPCR or FPCToFPURoundingMode[RoundMode]);
softfloat_rounding_mode:=RoundMode;
Result:=RoundMode;
end;
function GetPrecisionMode: TFPUPrecisionMode;

1
rtl/mips/mathu.inc
View File

@ -62,6 +62,7 @@ function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
begin
fsr:=get_fsr;
result:=fsr2roundmode[fsr and fpu_rounding_mask];
softfloat_rounding_mode:=RoundMode;
set_fsr((fsr and not fpu_rounding_mask) or roundmode2fsr[RoundMode]);
end;

2
rtl/powerpc/mathu.inc
View File

@ -101,12 +101,12 @@ begin
mode := FP_RND_RM;
end;
end;
result := GetRoundMode;
{$ifndef aix}
setFPSCR((getFPSCR and (not RoundModeMask)) or mode);
{$else not aix}
fp_swap_rnd(mode);
{$endif not aix}
result := RoundMode;
end;

2
rtl/powerpc64/mathu.inc
View File

@ -109,12 +109,12 @@ begin
mode := FP_RND_RM;
end;
end;
result := GetRoundMode;
{$ifndef aix}
setFPSCR((getFPSCR and (not RoundModeMask)) or mode);
{$else not aix}
fp_swap_rnd(mode);
{$endif not aix}
result := RoundMode;
end;

2
rtl/riscv64/mathu.inc
View File

@ -50,7 +50,7 @@ function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
rm2bits : array[TFPURoundingMode] of byte = (0,2,3,1);
begin
softfloat_rounding_mode:=RoundMode;
SetRoundMode:=RoundMode;
SetRoundMode:=GetRoundMode;
setrm(rm2bits[RoundMode]);
end;

1
rtl/sparc/mathu.inc
View File

@ -32,6 +32,7 @@ function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
cw: dword;
begin
cw:=get_fsr;
softfloat_rounding_mode:=RoundMode;
result:=TFPURoundingMode(cw shr 30);
set_fsr((cw and $3fffffff) or (rm2bits[RoundMode] shl 30));
end;

1
rtl/sparc64/mathu.inc
View File

@ -31,6 +31,7 @@ function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
cw: dword;
begin
cw:=get_fsr;
softfloat_rounding_mode:=RoundMode;
result:=TFPURoundingMode(cw shr 30);
set_fsr((cw and $3fffffff) or (rm2bits[RoundMode] shl 30));
end;

8
rtl/win/syswin.inc
View File

@ -609,6 +609,14 @@ procedure Win32Ansi2UnicodeMove(source:pchar;cp : TSystemCodePage;var dest:Unico
dwFlags:=MB_PRECOMPOSED;
end;
destlen:=MultiByteToWideChar(cp, dwFlags, source, len, nil, 0);
{ destlen=0 means that Windows cannot convert, so call the default
handler. This is similiar to what unix does and is a good fallback
if rawbyte strings are passed }
if destlen=0 then
begin
DefaultAnsi2UnicodeMove(source,DefaultSystemCodePage,dest,len);
exit;
end;
// this will null-terminate
setlength(dest, destlen);
if destlen>0 then

1
rtl/x86_64/mathu.inc
View File

@ -201,6 +201,7 @@ var
begin
CtlWord:=Get8087CW;
SSECSR:=GetMXCSR;
softfloat_rounding_mode:=RoundMode;
Set8087CW((CtlWord and $F3FF) or (Ord(RoundMode) shl 10));
SetMXCSR((SSECSR and $ffff9fff) or (dword(RoundMode) shl 13));
{$ifdef FPC_HAS_TYPE_EXTENDED}

1
rtl/xtensa/mathu.inc
View File

@ -20,6 +20,7 @@ function GetRoundMode: TFPURoundingMode;
function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
begin
SetRoundMode:=softfloat_rounding_mode;
softfloat_rounding_mode:=RoundMode;
end;

25
tests/test/tgenfunc24.pp Normal file
View File

@ -0,0 +1,25 @@
{ %FAIL }
program tgenfunc24;
{$mode delphi}
type
TTest = class
public type
Test = class
end;
public
procedure Test<T>;
end;
procedure TTest.Test<T>;
begin
end;
begin
end.

24
tests/test/tgenfunc25.pp Normal file
View File

@ -0,0 +1,24 @@
{ %FAIL }
program tgenfunc25;
{$mode delphi}
type
TTest = class
public
procedure Test<T>;
public type
Test = class
end;
end;
procedure TTest.Test<T>;
begin
end;
begin
end.

24
tests/test/tgenfunc26.pp Normal file
View File

@ -0,0 +1,24 @@
{ %FAIL }
unit tgenfunc26;
{$mode objfpc}{$H+}
interface
generic procedure Test<T>;
type
Test = record
end;
implementation
generic procedure Test<T>;
begin
end;
end.

24
tests/test/tgenfunc27.pp Normal file
View File

@ -0,0 +1,24 @@
{ %FAIL }
unit tgenfunc27;
{$mode objfpc}{$H+}
interface
type
Test = record
end;
generic procedure Test<T>;
implementation
generic procedure Test<T>;
begin
end;
end.

156
tests/test/units/math/trndcurr.pp
View File

@ -1,13 +1,34 @@
uses
Math;
const
failure_count : longint = 0;
first_error : longint = 0;
{$ifndef SKIP_CURRENCY_TEST}
procedure testround(const c, expected: currency; error: longint);
begin
if round(c)<>expected then
begin
writeln('round(',c,') = ',round(c),' instead of ', expected);
halt(error);
inc(failure_count);
if first_error=0 then
first_error:=error;
end;
end;
{$endif}
{$ifndef SKIP_SINGLE_TEST}
procedure testroundsingle(const c, expected: single; error: longint);
begin
if round(c)<>expected then
begin
writeln('round(',c,') = ',round(c),' instead of ', expected);
inc(failure_count);
if first_error=0 then
first_error:=error;
end;
end;
@ -16,6 +37,13 @@ end;
begin
{$ifndef SKIP_CURRENCY_TEST}
if GetRoundMode <> rmNearest then
begin
writeln('Starting rounding mode is not rmNearest');
inc(failure_count);
if first_error=0 then
first_error:=200;
end;
writeln('Rounding mode: rmNearest (even)');
testround(0.5,0.0,1);
testround(1.5,2.0,2);
@ -31,7 +59,15 @@ begin
testround(-1.4,-1.0,154);
writeln('Rounding mode: rmUp');
SetRoundMode(rmUp);
if SetRoundMode(rmUp)<>rmNearest then
writeln('Warning: previous mode was not rmNearest');
if GetRoundMode <> rmUp then
begin
writeln('Failed to set rounding mode to rmUp');
inc(failure_count);
if first_error=0 then
first_error:=201;
end;
testround(0.5,1.0,5);
testround(1.5,2.0,6);
testround(-0.5,0.0,7);
@ -46,7 +82,15 @@ begin
testround(-1.4,-1.0,158);
writeln('Rounding mode: rmDown');
SetRoundMode(rmDown);
if SetRoundMode(rmDown)<>rmUp then
writeln('Warning: previous mode was not rmUp');
if GetRoundMode <> rmDown then
begin
writeln('Failed to set rounding mode to rmDown');
inc(failure_count);
if first_error=0 then
first_error:=202;
end;
testround(0.5,0.0,9);
testround(1.5,1.0,10);
testround(-0.5,-1.0,11);
@ -61,7 +105,15 @@ begin
testround(-1.4,-2.0,162);
writeln('Rounding mode: rmTruncate');
SetRoundMode(rmTruncate);
if SetRoundMode(rmTruncate)<>rmDown then
writeln('Warning: previous mode was not rmDown');
if GetRoundMode <> rmTruncate then
begin
writeln('Failed to set rounding mode to rmTruncate');
inc(failure_count);
if first_error=0 then
first_error:=203;
end;
testround(0.5,0.0,13);
testround(1.5,1.0,14);
testround(-0.5,0.0,15);
@ -75,4 +127,100 @@ begin
testround(-0.4,0.0,165);
testround(-1.4,-1.0,166);
{$endif}
{$ifndef SKIP_SINGLE_TEST}
SetRoundMode(rmNearest);
if GetRoundMode <> rmNearest then
begin
writeln('Starting rounding mode is not rmNearest');
inc(failure_count);
if first_error=0 then
first_error:=200;
end;
writeln('Rounding mode: rmNearest (even)');
testroundsingle(0.5,0.0,1);
testroundsingle(1.5,2.0,2);
testroundsingle(-0.5,0.0,3);
testroundsingle(-1.5,-2.0,4);
testroundsingle(0.6,1.0,101);
testroundsingle(1.6,2.0,102);
testroundsingle(-0.6,-1.0,103);
testroundsingle(-1.6,-2.0,104);
testroundsingle(0.4,0.0,151);
testroundsingle(1.4,1.0,152);
testroundsingle(-0.4,-0.0,153);
testroundsingle(-1.4,-1.0,154);
writeln('Rounding mode: rmUp');
if SetRoundMode(rmUp)<>rmNearest then
writeln('Warning: previous mode was not rmNearest');
if GetRoundMode <> rmUp then
begin
writeln('Failed to set rounding mode to rmUp');
inc(failure_count);
if first_error=0 then
first_error:=201;
end;
testroundsingle(0.5,1.0,5);
testroundsingle(1.5,2.0,6);
testroundsingle(-0.5,0.0,7);
testroundsingle(-1.5,-1.0,8);
testroundsingle(0.6,1.0,105);
testroundsingle(1.6,2.0,106);
testroundsingle(-0.6,0.0,107);
testroundsingle(-1.6,-1.0,108);
testroundsingle(0.4,1.0,155);
testroundsingle(1.4,2.0,156);
testroundsingle(-0.4,0.0,157);
testroundsingle(-1.4,-1.0,158);
writeln('Rounding mode: rmDown');
if SetRoundMode(rmDown)<>rmUp then
writeln('Warning: previous mode was not rmUp');
if GetRoundMode <> rmDown then
begin
writeln('Failed to set rounding mode to rmDown');
inc(failure_count);
if first_error=0 then
first_error:=202;
end;
testroundsingle(0.5,0.0,9);
testroundsingle(1.5,1.0,10);
testroundsingle(-0.5,-1.0,11);
testroundsingle(-1.5,-2.0,12);
testroundsingle(0.6,0.0,109);
testroundsingle(1.6,1.0,110);
testroundsingle(-0.6,-1.0,111);
testroundsingle(-1.6,-2.0,112);
testroundsingle(0.4,0.0,159);
testroundsingle(1.4,1.0,160);
testroundsingle(-0.4,-1.0,161);
testroundsingle(-1.4,-2.0,162);
writeln('Rounding mode: rmTruncate');
if SetRoundMode(rmTruncate)<>rmDown then
writeln('Warning: previous mode was not rmDown');
if GetRoundMode <> rmTruncate then
begin
writeln('Failed to set rounding mode to rmTruncate');
inc(failure_count);
if first_error=0 then
first_error:=203;
end;
testroundsingle(0.5,0.0,13);
testroundsingle(1.5,1.0,14);
testroundsingle(-0.5,0.0,15);
testroundsingle(-1.5,-1.0,16);
testroundsingle(0.6,0.0,113);
testroundsingle(1.6,1.0,114);
testroundsingle(-0.6,0.0,115);
testroundsingle(-1.6,-1.0,116);
testroundsingle(0.4,0.0,163);
testroundsingle(1.4,1.0,164);
testroundsingle(-0.4,0.0,165);
testroundsingle(-1.4,-1.0,166);
{$endif}
if failure_count=0 then
writeln('SetRoundMode test finished OK')
else
halt(first_error);
end.

8
tests/webtbf/tw38289a.pp Normal file
View File

@ -0,0 +1,8 @@
{ %FAIL }
library tw38289a;
procedure Test; begin end;
exports
Test index 3 'abc';
//------------^^^
end.

8
tests/webtbf/tw38289b.pp Normal file
View File

@ -0,0 +1,8 @@
{ %FAIL }
library tw38289b;
procedure Test; begin end;
exports
Test index 'abc' 3;
//------------^^^
end.

31
tests/webtbs/tw38267b.pp
View File

@ -1,6 +1,6 @@
{ %opt=-O3 -Sg }
{$mode objfpc} {$longstrings+}
label start1, end1, start2, end2, start3, end3;
label start1, end1, start2, end2, start3, end3, start4, end4;
var
s: string;
@ -88,5 +88,34 @@ end3:
if PtrUint(CodePointer(@end3) - CodePointer(@start3))>300 then
halt(3);
writeln;
writeln('31 literals concatenated with 1 dynamic string, they could fold but didn''t at all:');
start4:
s := 'Once like a Great House' + (LineEnding +
('founded on sand,' + (LineEnding +
('Stood our Temple' + (LineEnding +
('whose pillars on troubles were based.' + (LineEnding +
('Now mischievous spirits, bound,' + (LineEnding +
('in dim corners stand,' + (LineEnding +
('Rotted columns, but' + (LineEnding +
('with iron-bound bands embraced' + (LineEnding +
('Cracked, crumbling marble,' + (LineEnding +
('tempered on every hand,' + (LineEnding +
('By strong steel' + (LineEnding +
('forged in fire and faith.' + (LineEnding +
('Shackled, these wayward servants' + (LineEnding +
('serve the land,' + (LineEnding +
('The Temple secured' + (LineEnding +
('by the Builder’s grace.' +
Copy('', 1, 0)))))))))))))))))))))))))))))));
end4:
writeln(Copy(s, 1, 0), PtrUint(CodePointer(@end4) - CodePointer(@start4)), ' b of code');
{ more than 100 bytes of code might point out that the constants are not folded,
example x86_64-linux: not folded: 1384 bytes; folded: 108 bytes
}
if PtrUint(CodePointer(@end4) - CodePointer(@start4))>300 then
halt(4);
writeln('ok');
end.

19
tests/webtbs/tw38295.pp Normal file
View File

@ -0,0 +1,19 @@
{ %cpu=i386 }
{ %opt=-CfAVX -CpCOREAVX2 -OoFASTMATH }
uses
cpu;
var
a, b: uint32; // or (u)int64; int32 works
r: single; // or double, or even extended
begin
if FMASupport then
begin
a := 1;
b := 3;
r := a + b / 10;
writeln(r:0:3);
if r>2.0 then
halt(1);
writeln('ok');
end;
end.

15
tests/webtbs/tw38299.pp Normal file
View File

@ -0,0 +1,15 @@
{ %opt=-O2 -Fcutf8 }
program bug;
const
cAnsiLineFeed = AnsiChar(#10);
cAnsiCarriageReturn = AnsiChar(#13);
var
test: RawByteString;
begin
test := '123';
test := test + UTF8Encode('456') + '789' + cAnsiCarriageReturn + cAnsiLineFeed;
writeln(test);
if test<>'123456789'#13#10 then
halt(1);
writeln('ok');
end.

12
utils/fpdoc/dglobals.pp
View File

@ -151,6 +151,18 @@ resourcestring
SCHMUsageMakeSearch = 'Automatically generate a Search Index from filenames that match *.htm*';
SCHMUsageChmTitle= 'Title of the chm. Defaults to the value from --package';
// MarkDown usage
SMDUsageFooter = 'Append markdown (@filename reads from file) as footer to every markdown page';
SMDUsageHeader = 'Prepend markdown (@filename reads from file) as header to every markdown page';
SMDIndexColcount = 'Use N columns in the identifier index pages';
SMDImageUrl = 'Prefix image URLs with url';
SMDTheme = 'Use name as theme name';
SMDNavigation = 'Use scheme for navigation tree, here scheme is one of:';
SMDNavSubtree = ' UnitSubTree : put all units in a sub tree of a Units node';
SMDNavTree = ' UnitTree : put every units as a node on the same level as packages node';
SXMLUsageSource = 'Include source file and line info in generated XML';
// Linear usage

1060
utils/fpdoc/dw_basehtml.pp Normal file
View File

File diff suppressed because it is too large Load Diff

27
utils/fpdoc/dw_basemd.pp
View File

@ -1,3 +1,16 @@
{
FPDoc - Free Pascal Documentation Tool
Copyright (C) 2021 by Michael Van Canneyt
* Basic Markdown output generator. No assumptions about document/documentation structure
See the file COPYING, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
unit dw_basemd;
{$mode objfpc}{$H+}
@ -32,7 +45,6 @@ Type
FFileRendering: TRender;
FIndentSize: Byte;
FKeywordRendering: TRender;
FModule: TPasModule;
FPrefix : string;
FMetadata,
FMarkDown: TStrings;
@ -486,7 +498,7 @@ end;
procedure TBaseMarkdownWriter.DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString);
Var
D,FN : String;
aLink,D,FN : String;
L : integer;
begin
// Determine URL for image.
@ -498,15 +510,16 @@ begin
If (L>0) and (D[L]<>'/') then
D:=D+'/';
FN:=UTF8Decode(D + BaseImageURL) + AFileName;
FN:=D + BaseImageURL+ Utf8Encode(AFileName);
EnsureEmptyLine;
AppendToLine('!['+aCaption+']('+FN+')',False);
aLink:='!['+UTF8Encode(aCaption)+']('+FN+')';
AppendToLine(aLink,False);
end;
procedure TBaseMarkdownWriter.DescrWriteFileEl(const AText: DOMString);
begin
AppendRendered(aText,FileRendering);
AppendRendered(UTF8Encode(aText),FileRendering);
end;
procedure TBaseMarkdownWriter.DescrWriteKeywordEl(const AText: DOMString);
@ -516,7 +529,7 @@ end;
procedure TBaseMarkdownWriter.DescrWriteVarEl(const AText: DOMString);
begin
AppendRendered(aText,VarRendering);
AppendRendered(UTF8Encode(aText),VarRendering);
end;
procedure TBaseMarkdownWriter.DescrBeginLink(const AId: DOMString);
@ -556,7 +569,7 @@ end;
procedure TBaseMarkdownWriter.DescrBeginURL(const AURL: DOMString);
begin
FLink:=aURL;
FLink:=UTF8Encode(aURL);
AppendToLine('[');
end;

21
utils/fpdoc/dw_chm.pp
View File

@ -2,7 +2,7 @@ unit dw_chm;
interface
uses Classes, DOM, DOM_HTML,
uses Classes, DOM,
dGlobals, PasTree, dwriter, dw_html, chmwriter, chmtypes, chmsitemap;
type
@ -63,7 +63,7 @@ type
implementation
uses SysUtils, HTMWrite;
uses SysUtils, HTMWrite, dw_basehtml;
{ TCHmFileNameAllocator }
@ -152,11 +152,18 @@ end;
procedure TFpDocChmWriter.FileAdded ( AStream: TStream;
const AEntry: TFileEntryRec ) ;
var FTsave : boolean;
begin
// Exclude Full text index for files starting from the dot
if Pos('.', AEntry.Name) <> 1 then
inherited FileAdded(AStream, AEntry)
else
begin
FTsave:=FullTextSearch;
FullTextSearch:=False;
inherited FileAdded(AStream, AEntry);
FullTextSearch:=FTsave;
end;
end;
{ TCHMHTMLWriter }
@ -179,12 +186,12 @@ begin
DoLog('Note: --index-page not assigned. Using default "index.html"');
end;
if FCSSFile <> '' then
if CSSFile <> '' then
begin
if not FileExists(FCSSFile) Then
Raise Exception.CreateFmt('Can''t find CSS file "%S"',[FCSSFILE]);
if not FileExists(CSSFile) Then
Raise Exception.CreateFmt('Can''t find CSS file "%S"',[CSSFILE]);
TempStream := TMemoryStream.Create;
TempStream.LoadFromFile(FCSSFile);
TempStream.LoadFromFile(CSSFile);
TempStream.Position := 0;
FChm.AddStreamToArchive('fpdoc.css', '/', TempStream, True);
TempStream.Free;

1468
utils/fpdoc/dw_html.pp
View File

File diff suppressed because it is too large Load Diff

19
utils/fpdoc/dw_markdown.pp
View File

@ -1,9 +1,8 @@
{
FPDoc - Free Pascal Documentation Tool
Copyright (C) 2000 - 2005 by
Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org
Copyright (C) 2021 by Michael Van Canneyt
* HTML/XHTML output generator
* Markdown generator, multi-file
See the file COPYING, included in this distribution,
for details about the copyright.
@ -1909,13 +1908,19 @@ end;
class procedure TMarkdownWriter.Usage(List: TStrings);
begin
List.add('--header=file');
List.Add(SHTMLUsageHeader);
List.Add(SMDUsageHeader);
List.add('--footer=file');
List.Add(SHTMLUsageFooter);
List.Add(SMDUsageFooter);
List.Add('--index-colcount=N');
List.Add(SHTMLIndexColcount);
List.Add(SMDIndexColcount);
List.Add('--image-url=url');
List.Add(SHTMLImageUrl);
List.Add(SMDImageUrl);
List.Add('--theme=name');
List.Add(SMDTheme);
List.Add('--navigation=scheme');
List.Add(SMDNavigation);
List.Add(SMDNavSubtree);
List.Add(SMDNavTree);
end;
class procedure TMarkdownWriter.SplitImport(var AFilename, ALinkPrefix: String);

19
utils/fpdoc/dwriter.pp
View File

@ -186,10 +186,12 @@ type
procedure DescrEndTableRow; virtual; abstract;
procedure DescrBeginTableCell; virtual; abstract;
procedure DescrEndTableCell; virtual; abstract;
Property CurrentContext : TPasElement Read FContext ;
public
Constructor Create(APackage: TPasPackage; AEngine: TFPDocEngine); virtual;
destructor Destroy; override;
procedure AddModuleIdentifiers(AModule: TPasModule; L: TStrings);
property Engine : TFPDocEngine read FEngine;
Property Package : TPasPackage read FPackage;
Property Topics : TList Read FTopics;
@ -526,6 +528,7 @@ begin
and (AModule.InterfaceSection.Classes.Count>0);
end;
procedure TMultiFileDocWriter.AddPages(AElement: TPasElement; ASubpageIndex: Integer;
AList: TFPList);
var
@ -1028,6 +1031,22 @@ begin
Inherited;
end;
procedure TFPDocWriter.AddModuleIdentifiers(AModule : TPasModule; L : TStrings);
begin
if assigned(AModule.InterfaceSection) Then
begin
AddElementsFromList(L,AModule.InterfaceSection.Consts);
AddElementsFromList(L,AModule.InterfaceSection.Types);
AddElementsFromList(L,AModule.InterfaceSection.Functions);
AddElementsFromList(L,AModule.InterfaceSection.Classes);
AddElementsFromList(L,AModule.InterfaceSection.Variables);
AddElementsFromList(L,AModule.InterfaceSection.ResStrings);
end;
end;
function TFPDocWriter.InterpretOption(const Cmd, Arg: String): Boolean;
begin
Result:=False;

6
utils/fpdoc/fpdoc.lpi
View File

@ -46,7 +46,7 @@
<PackageName Value="FCL"/>
</Item1>
</RequiredPackages>
<Units Count="19">
<Units Count="20">
<Unit0>
<Filename Value="fpdoc.pp"/>
<IsPartOfProject Value="True"/>
@ -130,6 +130,10 @@
<Filename Value="dw_basemd.pp"/>
<IsPartOfProject Value="True"/>
</Unit18>
<Unit19>
<Filename Value="dw_basehtml.pp"/>
<IsPartOfProject Value="True"/>
</Unit19>
</Units>
</ProjectOptions>
<CompilerOptions>

2
utils/fpdoc/fpdoc.pp
View File

@ -37,7 +37,7 @@ uses
dw_man, // Man page writer
dw_linrtf, // linear RTF writer
dw_txt, // TXT writer
fpdocproj, mkfpdoc, dw_basemd;
fpdocproj, mkfpdoc, dw_basemd, dw_basehtml;
Type

2
utils/fpdoc/fpdocclasstree.pp
View File

@ -5,7 +5,7 @@ unit fpdocclasstree;
interface
uses
Classes, SysUtils, dGlobals, pastree, contnrs, DOM ,XMLWrite;
Classes, SysUtils, dGlobals, pastree, contnrs{$IFDEF TREE_TEST}, DOM ,XMLWrite{$ENDIF};
Type