From 3109005791794f433437c6d452e72f1bffbd4a4a Mon Sep 17 00:00:00 2001 From: florian Date: Sat, 2 Jan 2021 22:18:38 +0000 Subject: [PATCH 01/24] + fold also (string const+(string const+string var)) * string tree folding code moved into level 2 opt. block git-svn-id: trunk@47986 - --- compiler/nadd.pas | 85 +++++++++++++++++++++++++++++----------- tests/webtbs/tw38267b.pp | 31 ++++++++++++++- 2 files changed, 92 insertions(+), 24 deletions(-) diff --git a/compiler/nadd.pas b/compiler/nadd.pas index 62689f4fe4..4b279b31ed 100644 --- a/compiler/nadd.pas +++ b/compiler/nadd.pas @@ -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,23 +1223,7 @@ 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 } + { set constant evaluation } if (right.nodetype=setconstn) and not assigned(tsetconstnode(right).left) and (left.nodetype=setconstn) and @@ -1381,9 +1381,48 @@ implementation exit; end; - { slow simplifications } + if cs_opt_level1 in current_settings.optimizerswitches then + begin + end; + + { 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 diff --git a/tests/webtbs/tw38267b.pp b/tests/webtbs/tw38267b.pp index 4dd0449d81..df7ee09010 100644 --- a/tests/webtbs/tw38267b.pp +++ b/tests/webtbs/tw38267b.pp @@ -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. From d854d18bd9730ffbe4340dd8a1dc9c2c1efd65b8 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 2 Jan 2021 23:23:08 +0000 Subject: [PATCH 02/24] * instead of blindly consuming whatever comes next trigger an explicit error if the parsed expression does not match for "INDEX ordexpr" or "NAME strexpr" + added tests git-svn-id: trunk@47995 - --- .gitattributes | 2 ++ compiler/pexports.pas | 4 ++-- tests/webtbf/tw38289a.pp | 8 ++++++++ tests/webtbf/tw38289b.pp | 8 ++++++++ 4 files changed, 20 insertions(+), 2 deletions(-) create mode 100644 tests/webtbf/tw38289a.pp create mode 100644 tests/webtbf/tw38289b.pp diff --git a/.gitattributes b/.gitattributes index 6ada342ede..8e18770f9b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -16697,6 +16697,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 diff --git a/compiler/pexports.pas b/compiler/pexports.pas index dfd37bbf3b..8770410872 100644 --- a/compiler/pexports.pas +++ b/compiler/pexports.pas @@ -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; diff --git a/tests/webtbf/tw38289a.pp b/tests/webtbf/tw38289a.pp new file mode 100644 index 0000000000..9e89a8a9df --- /dev/null +++ b/tests/webtbf/tw38289a.pp @@ -0,0 +1,8 @@ +{ %FAIL } + +library tw38289a; +procedure Test; begin end; +exports + Test index 3 'abc'; + //------------^^^ +end. diff --git a/tests/webtbf/tw38289b.pp b/tests/webtbf/tw38289b.pp new file mode 100644 index 0000000000..5229c86a3a --- /dev/null +++ b/tests/webtbf/tw38289b.pp @@ -0,0 +1,8 @@ +{ %FAIL } + +library tw38289b; +procedure Test; begin end; +exports + Test index 'abc' 3; + //------------^^^ +end. From 9179f9d43b5ebc1ba356a7d0ad12a13a2ac52b3f Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 2 Jan 2021 23:23:12 +0000 Subject: [PATCH 03/24] * always add a generic dummy if it is a procsym git-svn-id: trunk@47996 - --- compiler/pgenutil.pas | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas index 56567d6cff..726c2cda28 100644 --- a/compiler/pgenutil.pas +++ b/compiler/pgenutil.pas @@ -1790,8 +1790,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 } From 43ba5b69d2b86a6b00908c0c1664cd893db22f9d Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 2 Jan 2021 23:23:16 +0000 Subject: [PATCH 04/24] * ensure that the dummy symbol is registered if it's added due to a routine git-svn-id: trunk@47997 - --- compiler/pdecsub.pas | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index c2ebfb2bc2..3f7998b21d 100644 --- a/compiler/pdecsub.pas +++ b/compiler/pdecsub.pas @@ -1168,7 +1168,11 @@ implementation else symtablestack.top.insert(dummysym); end; - include(dummysym.symoptions,sp_generic_dummy); + 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); From f42b39a7b5c586378c5baef31567ee53cc427715 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 2 Jan 2021 23:23:20 +0000 Subject: [PATCH 05/24] * use a case statement instead of nested if-then statements git-svn-id: trunk@47998 - --- compiler/pexpr.pas | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 1558e38263..47801234a3 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -3558,17 +3558,18 @@ 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 + 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; else - if (p1.nodetype=loadn) then - idstr:=tloadnode(p1).symtableentry.name - else - idstr:=''; + ; + end; { if this is the case then the postfix handling is done in sub_expr if necessary } dopostfix:=not could_be_generic(idstr); From a65d778f73ae920d4eeec28438c254ad9ee0f8cb Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 2 Jan 2021 23:23:24 +0000 Subject: [PATCH 06/24] * also handle call nodes when determining the generic symbol for inline specializations git-svn-id: trunk@47999 - --- compiler/pexpr.pas | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 47801234a3..d0776c43fe 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -3567,6 +3567,8 @@ implementation idstr:=ttypenode(tloadvmtaddrnode(p1).left).typesym.name; loadn: idstr:=tloadnode(p1).symtableentry.name; + calln: + idstr:=tcallnode(p1).symtableprocentry.name; else ; end; @@ -4231,6 +4233,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 } From e4eed4e25994349c28dec79ab566831565bec643 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 2 Jan 2021 23:23:29 +0000 Subject: [PATCH 07/24] * when only a symbol name is provided to generate_specialization_phase1 allow a symbol table to be provided as well git-svn-id: trunk@48000 - --- compiler/pexpr.pas | 6 +++--- compiler/pgenutil.pas | 28 +++++++++++++++++----------- 2 files changed, 20 insertions(+), 14 deletions(-) diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index d0776c43fe..8df8d235d8 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -1520,7 +1520,7 @@ implementation 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 +2994,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 @@ -4269,7 +4269,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 diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas index 726c2cda28..a4de4abf13 100644 --- a/compiler/pgenutil.pas +++ b/compiler/pgenutil.pas @@ -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 + if assigned(genericdef) then + symowner:=genericdef.owner + else + symowner:=symtable; + + if assigned(symowner) and (symowner.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 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(genericdef.owner.defowner),ugenname,context.sym,context.symtable); + 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; From 7343e9c4a273b789577856915e0edf6613fa4b41 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 2 Jan 2021 23:23:34 +0000 Subject: [PATCH 08/24] * correctly handle the case should the generic dummy symbol be a procsym instead of a typesym git-svn-id: trunk@48001 - --- compiler/pexpr.pas | 29 +++++++++++++++++++++++------ compiler/symtable.pas | 10 ++++++++++ 2 files changed, 33 insertions(+), 6 deletions(-) diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 8df8d235d8..a36bef1900 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -1514,9 +1514,11 @@ 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:=''; @@ -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 - (ttypesym(srsym).typedef.typ=undefineddef) + ( + ( + (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 } @@ -4214,7 +4230,8 @@ implementation typesym: result:=ttypesym(sym).typedef; procsym: - result:=tdef(tprocsym(sym).procdeflist[0]); + if not (sp_generic_dummy in sym.symoptions) or (tprocsym(sym).procdeflist.count>0) then + result:=tdef(tprocsym(sym).procdeflist[0]); else internalerror(2015092701); end; diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 731b5028e5..8117af72f7 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -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, From c96029ebd57c852dd3f006cf8769d9fd5473a605 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sat, 2 Jan 2021 23:23:39 +0000 Subject: [PATCH 09/24] * Delphi does not allow a generic method to be overloaded by a non generic type of the same name (unlike for generic types and non generic routines); this is probably done to simplify the implementation of implicit specializations of generic methods so we do this as well. For this we change the dummy symbol for generic routines from a typesym to a procsym + added tests Note: what Delphi /does/ allow however is to overload a generic routine with a generic type... go figure. :/ We currently don't allow that git-svn-id: trunk@48002 - --- .gitattributes | 4 ++++ compiler/pdecsub.pas | 16 +++++++++++++--- tests/test/tgenfunc24.pp | 25 +++++++++++++++++++++++++ tests/test/tgenfunc25.pp | 24 ++++++++++++++++++++++++ tests/test/tgenfunc26.pp | 24 ++++++++++++++++++++++++ tests/test/tgenfunc27.pp | 24 ++++++++++++++++++++++++ 6 files changed, 114 insertions(+), 3 deletions(-) create mode 100644 tests/test/tgenfunc24.pp create mode 100644 tests/test/tgenfunc25.pp create mode 100644 tests/test/tgenfunc26.pp create mode 100644 tests/test/tgenfunc27.pp diff --git a/.gitattributes b/.gitattributes index 8e18770f9b..12ae660c5b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -15181,6 +15181,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 diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index 3f7998b21d..baf558743b 100644 --- a/compiler/pdecsub.pas +++ b/compiler/pdecsub.pas @@ -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,12 +1163,21 @@ 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); diff --git a/tests/test/tgenfunc24.pp b/tests/test/tgenfunc24.pp new file mode 100644 index 0000000000..ca592be8d5 --- /dev/null +++ b/tests/test/tgenfunc24.pp @@ -0,0 +1,25 @@ +{ %FAIL } + +program tgenfunc24; + +{$mode delphi} + +type + TTest = class + public type + Test = class + end; + + public + procedure Test; + end; + +procedure TTest.Test; +begin + +end; + +begin + +end. + diff --git a/tests/test/tgenfunc25.pp b/tests/test/tgenfunc25.pp new file mode 100644 index 0000000000..3728c37807 --- /dev/null +++ b/tests/test/tgenfunc25.pp @@ -0,0 +1,24 @@ +{ %FAIL } + +program tgenfunc25; + +{$mode delphi} + +type + TTest = class + public + procedure Test; + public type + Test = class + end; + end; + +procedure TTest.Test; +begin + +end; + +begin + +end. + diff --git a/tests/test/tgenfunc26.pp b/tests/test/tgenfunc26.pp new file mode 100644 index 0000000000..f0f34b9b13 --- /dev/null +++ b/tests/test/tgenfunc26.pp @@ -0,0 +1,24 @@ +{ %FAIL } + +unit tgenfunc26; + +{$mode objfpc}{$H+} + +interface + +generic procedure Test; + +type + Test = record + + end; + +implementation + +generic procedure Test; +begin + +end; + +end. + diff --git a/tests/test/tgenfunc27.pp b/tests/test/tgenfunc27.pp new file mode 100644 index 0000000000..ea18a34fea --- /dev/null +++ b/tests/test/tgenfunc27.pp @@ -0,0 +1,24 @@ +{ %FAIL } + +unit tgenfunc27; + +{$mode objfpc}{$H+} + +interface + +type + Test = record + + end; + +generic procedure Test; + +implementation + +generic procedure Test; +begin + +end; + +end. + From e911431ed44dfbe86cf44a0b5251571f0184ba72 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sun, 3 Jan 2021 01:04:26 +0000 Subject: [PATCH 10/24] fcl-passrc: parser: export unit.symbol, resolver: started library export git-svn-id: trunk@48003 - --- packages/fcl-passrc/src/pasresolveeval.pas | 2 + packages/fcl-passrc/src/pasresolver.pp | 66 +++++++++++++++++++--- packages/fcl-passrc/src/pastree.pp | 3 + packages/fcl-passrc/src/pparser.pp | 56 +++++++++++------- packages/fcl-passrc/tests/tcresolver.pas | 20 +++++++ 5 files changed, 118 insertions(+), 29 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index a2d654cb21..c570595277 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -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 } diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 77630339f3..9fe78b10ff 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -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); diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 819fe25907..709090d435 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -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; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 467a7fa721..1e8a23c240 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -4341,27 +4341,43 @@ end; procedure TPasParser.ParseExportDecl(Parent: TPasElement; List: TFPList); Var E : TPasExportSymbol; + aName: String; + NameExpr: TPasExpr; begin - Repeat - if List.Count<>0 then - ExpectIdentifier; - E:=TPasExportSymbol(CreateElement(TPasExportSymbol,CurtokenString,Parent)); - List.Add(E); - NextToken; - if CurTokenIsIdentifier('INDEX') then - begin - NextToken; - E.Exportindex:=DoParseExpression(E,Nil) - end - else if CurTokenIsIdentifier('NAME') then - begin - NextToken; - E.ExportName:=DoParseExpression(E,Nil) - end; - if not (CurToken in [tkComma,tkSemicolon]) then - ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon); - Engine.FinishScope(stDeclaration,E); - until (CurToken=tkSemicolon); + try + Repeat + if List.Count>0 then + ExpectIdentifier; + 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); + if CurTokenIsIdentifier('INDEX') then + begin + NextToken; + E.Exportindex:=DoParseExpression(E,Nil) + end + else if CurTokenIsIdentifier('NAME') then + begin + NextToken; + E.ExportName:=DoParseExpression(E,Nil) + end; + if not (CurToken in [tkComma,tkSemicolon]) then + 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; diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index c1000b6150..587d86c3bf 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -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]); From 9825d3b552bf219121ac50cccf8dedb4399cd535 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sun, 3 Jan 2021 01:06:04 +0000 Subject: [PATCH 11/24] pastojs: filer export nameexpr git-svn-id: trunk@48004 - --- packages/pastojs/src/pas2jsfiler.pp | 2 ++ packages/pastojs/tests/tcfiler.pas | 1 + 2 files changed, 3 insertions(+) diff --git a/packages/pastojs/src/pas2jsfiler.pp b/packages/pastojs/src/pas2jsfiler.pp index 362cfb987e..3767d01d2c 100644 --- a/packages/pastojs/src/pas2jsfiler.pp +++ b/packages/pastojs/src/pas2jsfiler.pp @@ -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; diff --git a/packages/pastojs/tests/tcfiler.pas b/packages/pastojs/tests/tcfiler.pas index d66ca39bbc..e08cbfc904 100644 --- a/packages/pastojs/tests/tcfiler.pas +++ b/packages/pastojs/tests/tcfiler.pas @@ -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; From 1afca037c69906e6da5f5a3361082afc693997cd Mon Sep 17 00:00:00 2001 From: michael Date: Sun, 3 Jan 2021 08:37:52 +0000 Subject: [PATCH 12/24] * Help for markdown git-svn-id: trunk@48005 - --- utils/fpdoc/dglobals.pp | 14 +++++++++++++- utils/fpdoc/dw_markdown.pp | 14 ++++++++++---- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/utils/fpdoc/dglobals.pp b/utils/fpdoc/dglobals.pp index f44619eed2..31f8e4e743 100644 --- a/utils/fpdoc/dglobals.pp +++ b/utils/fpdoc/dglobals.pp @@ -139,7 +139,7 @@ resourcestring SHTMLIndexColcount = 'Use N columns in the identifier index pages'; SHTMLImageUrl = 'Prefix image URLs with url'; SHTMLDisableMenuBrackets = 'Disable ''['' and '']'' characters around menu items at the top of the page. Useful for custom css'; - + // CHM usage SCHMUsageTOC = 'Use [File] as the table of contents. Usually a .hhc file.'; SCHMUsageIndex = 'Use [File] as the index. Usually a .hhk 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 diff --git a/utils/fpdoc/dw_markdown.pp b/utils/fpdoc/dw_markdown.pp index 8b82e710dd..93fd04e91f 100644 --- a/utils/fpdoc/dw_markdown.pp +++ b/utils/fpdoc/dw_markdown.pp @@ -1909,13 +1909,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); From 4a274cd63a079098b0e65582247a4e8b1207c810 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sun, 3 Jan 2021 12:11:40 +0000 Subject: [PATCH 13/24] + add a copyright/license header for the nullable unit git-svn-id: trunk@48006 - --- packages/rtl-objpas/src/inc/nullable.pp | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/packages/rtl-objpas/src/inc/nullable.pp b/packages/rtl-objpas/src/inc/nullable.pp index c66e7d914c..1968ab04ce 100644 --- a/packages/rtl-objpas/src/inc/nullable.pp +++ b/packages/rtl-objpas/src/inc/nullable.pp @@ -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} From b8578f804f48a7e7fc45a176f4556cf729dab2db Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sun, 3 Jan 2021 12:11:44 +0000 Subject: [PATCH 14/24] * fix compilation on targets that use Stabs debug information: ignore generic dummy symbols with no procdefs for generating stabs data git-svn-id: trunk@48007 - --- compiler/dbgstabs.pas | 3 +++ 1 file changed, 3 insertions(+) diff --git a/compiler/dbgstabs.pas b/compiler/dbgstabs.pas index 2d8b986e8c..ef8a575475 100644 --- a/compiler/dbgstabs.pas +++ b/compiler/dbgstabs.pas @@ -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 From 7be3d2f80ce7a98a905d86f22b52b1b7240f3bea Mon Sep 17 00:00:00 2001 From: michael Date: Sun, 3 Jan 2021 14:08:02 +0000 Subject: [PATCH 15/24] * get rid of some warnings git-svn-id: trunk@48009 - --- utils/fpdoc/fpdocclasstree.pp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/utils/fpdoc/fpdocclasstree.pp b/utils/fpdoc/fpdocclasstree.pp index 91084de79f..ca25b2b75e 100644 --- a/utils/fpdoc/fpdocclasstree.pp +++ b/utils/fpdoc/fpdocclasstree.pp @@ -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 From 7ee4954b0b14278ddb80ab8f63cf25e4ece27bdf Mon Sep 17 00:00:00 2001 From: michael Date: Sun, 3 Jan 2021 14:08:48 +0000 Subject: [PATCH 16/24] * Refactor HTML engine so it can more easily be extended git-svn-id: trunk@48010 - --- utils/fpdoc/dglobals.pp | 4 +- utils/fpdoc/dw_basemd.pp | 27 +- utils/fpdoc/dw_chm.pp | 12 +- utils/fpdoc/dw_html.pp | 2070 +++++++++--------------------------- utils/fpdoc/dw_markdown.pp | 5 +- utils/fpdoc/dwriter.pp | 19 + utils/fpdoc/fpdoc.lpi | 6 +- utils/fpdoc/fpdoc.pp | 2 +- 8 files changed, 573 insertions(+), 1572 deletions(-) diff --git a/utils/fpdoc/dglobals.pp b/utils/fpdoc/dglobals.pp index 31f8e4e743..a1ce8bb899 100644 --- a/utils/fpdoc/dglobals.pp +++ b/utils/fpdoc/dglobals.pp @@ -158,8 +158,8 @@ resourcestring 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'; + 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'; diff --git a/utils/fpdoc/dw_basemd.pp b/utils/fpdoc/dw_basemd.pp index 0b365a9e56..46de0ee314 100644 --- a/utils/fpdoc/dw_basemd.pp +++ b/utils/fpdoc/dw_basemd.pp @@ -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; diff --git a/utils/fpdoc/dw_chm.pp b/utils/fpdoc/dw_chm.pp index 632665f1ac..f8c2a9fe90 100644 --- a/utils/fpdoc/dw_chm.pp +++ b/utils/fpdoc/dw_chm.pp @@ -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 } @@ -179,12 +179,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; diff --git a/utils/fpdoc/dw_html.pp b/utils/fpdoc/dw_html.pp index 5d28ffd354..5b43b06c1f 100644 --- a/utils/fpdoc/dw_html.pp +++ b/utils/fpdoc/dw_html.pp @@ -19,168 +19,76 @@ unit dw_html; {$WARN 5024 off : Parameter "$1" not used} interface -uses Classes, DOM, DOM_HTML, dGlobals, PasTree, dWriter; +uses Classes, DOM, DOM_HTML, dGlobals, PasTree, dWriter, dw_basehtml; type { THTMLWriter } - THTMLWriter = class(TMultiFileDocWriter) + THTMLWriter = class(TBaseHTMLWriter) private - FImageFileList: TStrings; + FHeadElement: TDomElement; FOnTest: TNotifyEvent; + FCSSFile: String; FCharSet : String; + FHeaderHTML, + FNavigatorHTML, + FFooterHTML: TStringStream; + FTitleElement: TDOMElement; + FIncludeDateInFooter : Boolean; + FUseMenuBrackets: Boolean; + FDateFormat: String; + FIndexColCount : Integer; + FSearchPage : String; procedure CreateMinusImage; procedure CreatePlusImage; procedure SetOnTest(const AValue: TNotifyEvent); protected - FCSSFile: String; - - Doc: THTMLDocument; - HeadElement, - BodyElement, TitleElement: TDOMElement; - - - OutputNodeStack: TList; - CurOutputNode: TDOMNode; - InsideHeadRow, DoPasHighlighting: Boolean; - HighlighterFlags: Byte; - HeaderHTML, - NavigatorHTML, - FooterHTML: TStringStream; - FIDF : Boolean; - FDateFormat: String; - FIndexColCount : Integer; - FSearchPage : String; - FBaseImageURL : String; - FUseMenuBrackets: Boolean; - - procedure AppendFragment(aParentNode: TDOMElement; aStream: TStream); function CreateAllocator : TFileAllocator; override; procedure WriteDocPage(const aFileName: String; aElement: TPasElement; aSubPageIndex: Integer); override; procedure CreateCSSFile; virtual; - // Helper functions for creating DOM elements - function CreateEl(Parent: TDOMNode; const AName: DOMString): THTMLElement; - function CreatePara(Parent: TDOMNode): THTMLElement; - function CreateH1(Parent: TDOMNode): THTMLElement; - function CreateH2(Parent: TDOMNode): THTMLElement; - function CreateH3(Parent: TDOMNode): THTMLElement; - function CreateTable(Parent: TDOMNode; const AClass: DOMString = ''): THTMLElement; - function CreateContentTable(Parent: TDOMNode): THTMLElement; - function CreateTR(Parent: TDOMNode): THTMLElement; - function CreateTD(Parent: TDOMNode): THTMLElement; - function CreateTD_vtop(Parent: TDOMNode): THTMLElement; - function CreateLink(Parent: TDOMNode; const AHRef: String): THTMLElement; - function CreateLink(Parent: TDOMNode; const AHRef: DOMString): THTMLElement; - function CreateAnchor(Parent: TDOMNode; const AName: DOMString): THTMLElement; - function CreateCode(Parent: TDOMNode): THTMLElement; - function CreateWarning(Parent: TDOMNode): THTMLElement; - - // Description node conversion - Procedure DescrEmitNotesHeader(AContext : TPasElement); override; - Procedure DescrEmitNotesFooter(AContext : TPasElement); override; - procedure PushOutputNode(ANode: TDOMNode); - procedure PopOutputNode; - procedure DescrWriteText(const AText: DOMString); override; - procedure DescrBeginBold; override; - procedure DescrEndBold; override; - procedure DescrBeginItalic; override; - procedure DescrEndItalic; override; - procedure DescrBeginEmph; override; - procedure DescrEndEmph; override; - procedure DescrBeginUnderline; override; - procedure DescrEndUnderline; override; - procedure DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); override; - procedure DescrWriteFileEl(const AText: DOMString); override; - procedure DescrWriteKeywordEl(const AText: DOMString); override; - procedure DescrWriteVarEl(const AText: DOMString); override; - procedure DescrBeginLink(const AId: DOMString); override; - procedure DescrEndLink; override; - procedure DescrBeginURL(const AURL: DOMString); override; - procedure DescrEndURL; override; - procedure DescrWriteLinebreak; override; - procedure DescrBeginParagraph; override; - procedure DescrEndParagraph; override; - procedure DescrBeginCode(HasBorder: Boolean; const AHighlighterName: String); override; - procedure DescrWriteCodeLine(const ALine: String); override; - procedure DescrEndCode; override; - procedure DescrBeginOrderedList; override; - procedure DescrEndOrderedList; override; - procedure DescrBeginUnorderedList; override; - procedure DescrEndUnorderedList; override; - procedure DescrBeginDefinitionList; override; - procedure DescrEndDefinitionList; override; - procedure DescrBeginListItem; override; - procedure DescrEndListItem; override; - procedure DescrBeginDefinitionTerm; override; - procedure DescrEndDefinitionTerm; override; - procedure DescrBeginDefinitionEntry; override; - procedure DescrEndDefinitionEntry; override; - procedure DescrBeginSectionTitle; override; - procedure DescrBeginSectionBody; override; - procedure DescrEndSection; override; - procedure DescrBeginRemark; override; - procedure DescrEndRemark; override; - procedure DescrBeginTable(ColCount: Integer; HasBorder: Boolean); override; - procedure DescrEndTable; override; - procedure DescrBeginTableCaption; override; - procedure DescrEndTableCaption; override; - procedure DescrBeginTableHeadRow; override; - procedure DescrEndTableHeadRow; override; - procedure DescrBeginTableRow; override; - procedure DescrEndTableRow; override; - procedure DescrBeginTableCell; override; - procedure DescrEndTableCell; override; - - procedure AppendText(Parent: TDOMNode; const AText: String); - procedure AppendText(Parent: TDOMNode; const AText: DOMString); - procedure AppendNbSp(Parent: TDOMNode; ACount: Integer); - procedure AppendSym(Parent: TDOMNode; const AText: DOMString); - procedure AppendKw(Parent: TDOMNode; const AText: String); - procedure AppendKw(Parent: TDOMNode; const AText: DOMString); - function AppendPasSHFragment(Parent: TDOMNode; const AText: String; - AShFlags: Byte): Byte; - Procedure AppendShortDescr(AContext : TPasElement;Parent: TDOMNode; DocNode : TDocNode); - procedure AppendShortDescr(Parent: TDOMNode; Element: TPasElement); - procedure AppendShortDescrCell(Parent: TDOMNode; Element: TPasElement); - procedure AppendDescr(AContext: TPasElement; Parent: TDOMNode; - DescrNode: TDOMElement; AutoInsertBlock: Boolean); - procedure AppendDescrSection(AContext: TPasElement; Parent: TDOMNode; DescrNode: TDOMElement; const ATitle: String); - procedure AppendDescrSection(AContext: TPasElement; Parent: TDOMNode; DescrNode: TDOMElement; const ATitle: DOMString); - function AppendHyperlink(Parent: TDOMNode; Element: TPasElement): TDOMElement; + procedure AppendTitle(const AText: String; Hints : TPasMemberHints = []); virtual; + procedure AppendTitle(const AText: DOMString; Hints : TPasMemberHints = []); virtual; function AppendType(CodeEl, TableEl: TDOMElement; Element: TPasType; Expanded: Boolean; - NestingLevel: Integer = 0): TDOMElement; - function AppendProcType(CodeEl, TableEl: TDOMElement; - Element: TPasProcedureType; Indent: Integer): TDOMElement; - procedure AppendProcExt(CodeEl: TDOMElement; Element: TPasProcedure); - procedure AppendProcDecl(CodeEl, TableEl: TDOMElement; Element: TPasProcedureBase); - procedure AppendProcArgsSection(Parent: TDOMNode; Element: TPasProcedureType; SkipResult : Boolean = False); - function AppendRecordType(CodeEl, TableEl: TDOMElement; Element: TPasRecordType; NestingLevel: Integer): TDOMElement; - procedure CreateMemberDeclarations(AParent: TPasElement; Members: TFPList; TableEl: TDOmelement; AddEnd: Boolean); + NestingLevel: Integer = 0): TDOMElement; virtual; + function AppendProcType(CodeEl, TableEl: TDOMElement; Element: TPasProcedureType; Indent: Integer): TDOMElement; virtual; + procedure AppendProcExt(CodeEl: TDOMElement; Element: TPasProcedure); virtual; + procedure AppendProcDecl(CodeEl, TableEl: TDOMElement; Element: TPasProcedureBase); virtual; + procedure AppendProcArgsSection(Parent: TDOMNode; Element: TPasProcedureType; SkipResult : Boolean = False); virtual; + function AppendRecordType(CodeEl, TableEl: TDOMElement; Element: TPasRecordType; NestingLevel: Integer): TDOMElement; virtual; + procedure CreateMemberDeclarations(AParent: TPasElement; Members: TFPList; TableEl: TDOmelement; AddEnd: Boolean); virtual; - procedure AppendTitle(const AText: String; Hints : TPasMemberHints = []); - procedure AppendTitle(const AText: DOMString; Hints : TPasMemberHints = []); - procedure AppendMenuBar(ASubpageIndex: Integer); - procedure AppendTopicMenuBar(Topic : TTopicElement); - procedure AppendSourceRef(AElement: TPasElement); - procedure FinishElementPage(AElement: TPasElement); - Procedure AppendSeeAlsoSection(AElement : TPasElement;DocNode : TDocNode); - Procedure AppendExampleSection(AElement : TPasElement;DocNode : TDocNode); - procedure AppendFooter; - procedure CreateIndexPage(L : TStringList); - procedure CreateModuleIndexPage(AModule: TPasModule); + procedure AppendMenuBar(ASubpageIndex: Integer);virtual; + procedure AppendTopicMenuBar(Topic : TTopicElement);virtual; + procedure FinishElementPage(AElement: TPasElement);virtual; + procedure AppendFooter;virtual; + + + procedure AppendClassMemberListLink(aClass: TPasClassType; ParaEl: TDomElement; AListSubpageIndex: Integer; const AText: DOMString);virtual; + procedure CreateClassMainPage(aClass: TPasClassType);virtual; + procedure CreateClassInheritanceSubpage(aClass: TPasClassType; AFilter: TMemberFilter);virtual; + procedure CreateClassSortedSubpage(AClass: TPasClassType; AFilter: TMemberFilter);virtual; + + procedure CreateIndexPage(L : TStringList); virtual; + procedure CreateModuleIndexPage(AModule: TPasModule); virtual; + // Package procedure CreatePageBody(AElement: TPasElement; ASubpageIndex: Integer); virtual; - procedure CreatePackagePageBody; + procedure CreatePackagePageBody;virtual; procedure CreatePackageIndex; procedure CreatePackageClassHierarchy; procedure CreateClassHierarchyPage(AddUnit : Boolean); - procedure AddModuleIdentifiers(AModule : TPasModule; L : TStrings); + // Topic Procedure CreateTopicPageBody(AElement : TTopicElement); + // Module + procedure CreateModuleMainPage(aModule: TPasModule);virtual; + procedure CreateModuleSimpleSubpage(aModule: TPasModule; ASubpageIndex: Integer; const ATitle: DOMString; AList: TFPList);virtual; + procedure CreateModuleResStringsPage(aModule: TPasModule);virtual; procedure CreateModulePageBody(AModule: TPasModule; ASubpageIndex: Integer); + // Identifiers procedure CreateConstPageBody(AConst: TPasConst); procedure CreateTypePageBody(AType: TPasType); procedure CreateClassPageBody(AClass: TPasClassType; ASubpageIndex: Integer); @@ -189,36 +97,35 @@ type procedure CreateProcPageBody(AProc: TPasProcedureBase); Procedure CreateTopicLinks(Node : TDocNode; PasElement : TPasElement); procedure AppendTypeDecl(AType: TPasType; TableEl, CodeEl: TDomElement); + Property HeaderHTML : TStringStream Read FHeaderHTML; + Property NavigatorHTML : TStringStream read FNavigatorHTML; + Property FooterHTML : TStringStream read FFooterHTML; + Property CSSFile : String Read FCSSFile; + Property HeadElement : TDomElement Read FHeadElement; + Property TitleElement: TDOMElement Read FTitleElement; public // Creating all module hierarchy classes is here !!!! constructor Create(APackage: TPasPackage; AEngine: TFPDocEngine); override; - destructor Destroy; override; - - // Single-page generation - function CreateHTMLPage(AElement: TPasElement; ASubpageIndex: Integer): TXMLDocument; - function CreateXHTMLPage(AElement: TPasElement; ASubpageIndex: Integer): TXMLDocument; - - // Start producing html complete package documentation - procedure WriteXHTMLPages; - - Function InterPretOption(Const Cmd,Arg : String) : boolean; override; - Procedure WriteDoc; override; + // Overrides Class Function FileNameExtension : String; override; class procedure Usage(List: TStrings); override; Class procedure SplitImport(var AFilename, ALinkPrefix: String); override; - Property SearchPage: String Read FSearchPage Write FSearchPage; - Property IncludeDateInFooter : Boolean Read FIDF Write FIDF; + Function InterPretOption(Const Cmd,Arg : String) : boolean; override; + Procedure WriteDoc; override; + + // Single-page generation + function CreateHTMLPage(AElement: TPasElement; ASubpageIndex: Integer): TXMLDocument; virtual; + + Property SearchPage: String Read FSearchPage Write FSearchPage; + Property IncludeDateInFooter : Boolean Read FIncludeDateInFooter Write FIncludeDateInFooter; Property DateFormat : String Read FDateFormat Write FDateFormat; property OnTest: TNotifyEvent read FOnTest write SetOnTest; Property CharSet : String Read FCharSet Write FCharSet; Property IndexColCount : Integer Read FIndexColCount write FIndexColCount; - Property BaseImageURL : String Read FBaseImageURL Write FBaseImageURL; Property UseMenuBrackets : Boolean Read FUseMenuBrackets write FUseMenuBrackets; - Property ImageFileList : TStrings Read FImageFileList; end; -Function FixHTMLpath(S : String) : STring; implementation @@ -228,47 +135,27 @@ uses SysUtils, XMLRead, HTMWrite, sh_pas, fpdocclasstree; {$i plusimage.inc} {$i minusimage.inc} -Function FixHTMLpath(S : String) : STring; - -begin - Result:=StringReplace(S,'\','/',[rfReplaceAll]); -end; - constructor THTMLWriter.Create(APackage: TPasPackage; AEngine: TFPDocEngine); - -var - i: Integer; - L : TObjectList; - H : Boolean; - begin inherited Create(APackage, AEngine); // should default to true since this is the old behavior UseMenuBrackets:=True; IndexColCount:=3; Charset:='iso-8859-1'; - OutputNodeStack := TList.Create; - FImageFileList := TStringList.Create; AllocatePages; end; -destructor THTMLWriter.Destroy; -begin - OutputNodeStack.Free; - FImageFileList.Free; - inherited Destroy; -end; - function THTMLWriter.CreateHTMLPage(AElement: TPasElement; ASubpageIndex: Integer): TXMLDocument; var HTMLEl: THTMLHtmlElement; HeadEl: THTMLHeadElement; + BodyElement : THTMLElement; El: TDOMElement; begin - Doc := THTMLDocument.Create; - Result := Doc; + Result := THTMLDocument.Create; + SetHTMLDocument(THTMLDocument(Result)); Doc.AppendChild(Doc.Impl.CreateDocumentType( 'HTML', '-//W3C//DTD HTML 4.01 Transitional//EN', 'http://www.w3.org/TR/html4/loose.dtd')); @@ -277,18 +164,19 @@ begin Doc.AppendChild(HTMLEl); HeadEl := Doc.CreateHeadElement; - HeadElement:=HeadEl; + FHeadElement:=HeadEl; HTMLEl.AppendChild(HeadEl); El := Doc.CreateElement('meta'); HeadEl.AppendChild(El); El['http-equiv'] := 'Content-Type'; El['content'] := 'text/html; charset=utf-8'; - TitleElement := Doc.CreateElement('title'); + FTitleElement := Doc.CreateElement('title'); HeadEl.AppendChild(TitleElement); El := Doc.CreateElement('link'); BodyElement := Doc.CreateElement('body'); + ContentElement:=BodyElement; HTMLEl.AppendChild(BodyElement); CreatePageBody(AElement, ASubpageIndex); @@ -301,23 +189,18 @@ begin El['href'] := UTF8Decode(FixHtmlPath(UTF8Encode(Allocator.GetCSSFilename(AElement)))); end; -function THTMLWriter.CreateXHTMLPage(AElement: TPasElement; - ASubpageIndex: Integer): TXMLDocument; -begin - Result := nil; -end; - procedure THTMLWriter.WriteDocPage(const aFileName: String; aElement: TPasElement; aSubPageIndex: Integer); Var PageDoc: TXMLDocument; - + FN : String; begin PageDoc := CreateHTMLPage(aElement, aSubpageIndex); try - //writeln('Element: ',Element.PathName, ' FileName: ', Filename); - WriteHTMLFile(PageDoc, aFilename); + FN:=GetFileBaseDir(Engine.Output)+aFilename; + //writeln('Element: ',Element.PathName, ' FileName: ', FN); + WriteHTMLFile(PageDoc, FN); except on E: Exception do DoLog(SErrCouldNotCreateFile, [aFileName, e.Message]); @@ -367,7 +250,6 @@ begin end; end; - procedure THTMLWriter.CreateCSSFile; Var @@ -397,783 +279,9 @@ begin end; end; -procedure THTMLWriter.WriteXHTMLPages; -begin -end; - -{procedure THTMLWriter.CreateDoc(const ATitle: DOMString; - AElement: TPasElement; const AFilename: String); -var - El: TDOMElement; - DocInfo: TDocInfo; - CSSName: String; - -begin - Doc := TXHTMLDocument.Create; - with TXHTMLDocument(Doc) do - begin - Encoding := 'ISO8859-1'; - CSSName := 'fpdoc.css'; - if Assigned(Module) then - CSSName := '../' + CSSName; -$IFNDEF ver1_0 - StylesheetType := 'text/css'; - StylesheetHRef := CSSName; -$ENDIF - CreateRoot(xhtmlStrict); - with RequestHeadElement do - begin - AppendText(RequestTitleElement, ATitle); - El := CreateElement('link'); - AppendChild(El); - El['rel'] := 'stylesheet'; - El['type'] := 'text/css'; - El['href'] := FixHtmlPath(CSSName); - end; - Self.BodyElement := RequestBodyElement('en'); - end; - - if Length(AFilename) > 0 then - begin - DocInfo := TDocInfo.Create; - DocInfos.Add(DocInfo); - DocInfo.Element := AElement; - DocInfo.Filename := AFilename; - end; -end; -} - - - -function THTMLWriter.CreateEl(Parent: TDOMNode; - const AName: DOMString): THTMLElement; -begin - Result := Doc.CreateElement(AName); - Parent.AppendChild(Result); -end; - -function THTMLWriter.CreatePara(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(Parent, 'p'); -end; - -function THTMLWriter.CreateH1(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(Parent, 'h1'); -end; - -function THTMLWriter.CreateH2(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(Parent, 'h2'); -end; - -function THTMLWriter.CreateH3(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(Parent, 'h3'); -end; - -function THTMLWriter.CreateTable(Parent: TDOMNode; const AClass: DOMString = ''): THTMLElement; -begin - Result := CreateEl(Parent, 'table'); - Result['cellspacing'] := '0'; - Result['cellpadding'] := '0'; - if AClass <> '' then - Result['class'] := AClass; -end; - -function THTMLWriter.CreateContentTable(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(Parent, 'table'); -end; - -function THTMLWriter.CreateTR(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(Parent, 'tr'); -end; - -function THTMLWriter.CreateTD(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(Parent, 'td'); -end; - -function THTMLWriter.CreateTD_vtop(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(Parent, 'td'); - Result['valign'] := 'top'; -end; - -function THTMLWriter.CreateLink(Parent: TDOMNode; const AHRef: String): THTMLElement; -begin - Result := CreateEl(Parent, 'a'); - Result['href'] := UTF8Decode(FixHtmlPath(AHRef)); -end; - -function THTMLWriter.CreateLink(Parent: TDOMNode; - const AHRef: DOMString): THTMLElement; -begin - Result:=CreateLink(Parent,UTF8Encode(aHREf)); -end; - -function THTMLWriter.CreateAnchor(Parent: TDOMNode; - const AName: DOMString): THTMLElement; -begin - Result := CreateEl(Parent, 'a'); - Result['name'] := AName; -end; - -function THTMLWriter.CreateCode(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(CreateEl(Parent, 'tt'), 'span'); - Result['class'] := 'code'; -end; - -function THTMLWriter.CreateWarning(Parent: TDOMNode): THTMLElement; -begin - Result := CreateEl(Parent, 'span'); - Result['class'] := 'warning'; -end; - -procedure THTMLWriter.DescrEmitNotesHeader(AContext: TPasElement); -begin - AppendText(CreateH2(BodyElement), SDocNotes); - PushOutputNode(BodyElement); -end; - -procedure THTMLWriter.DescrEmitNotesFooter(AContext: TPasElement); -begin - PopOutPutNode; -end; - -procedure THTMLWriter.PushOutputNode(ANode: TDOMNode); -begin - OutputNodeStack.Add(CurOutputNode); - CurOutputNode := ANode; -end; - -procedure THTMLWriter.PopOutputNode; -begin - CurOutputNode := TDOMNode(OutputNodeStack[OutputNodeStack.Count - 1]); - OutputNodeStack.Delete(OutputNodeStack.Count - 1); -end; - -procedure THTMLWriter.DescrWriteText(const AText: DOMString); -begin - AppendText(CurOutputNode, AText); -end; - -procedure THTMLWriter.DescrBeginBold; -begin - PushOutputNode(CreateEl(CurOutputNode, 'b')); -end; - -procedure THTMLWriter.DescrEndBold; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginItalic; -begin - PushOutputNode(CreateEl(CurOutputNode, 'i')); -end; - -procedure THTMLWriter.DescrEndItalic; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginEmph; -begin - PushOutputNode(CreateEl(CurOutputNode, 'em')); -end; - -procedure THTMLWriter.DescrEndEmph; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginUnderline; -begin - PushOutputNode(CreateEl(CurOutputNode, 'u')); -end; - -procedure THTMLWriter.DescrEndUnderline; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); - -Var - Pel,Cel: TDOMNode; - El :TDomElement; - D : String; - L : Integer; - -begin - // Determine parent node. - If (ACaption='') then - Pel:=CurOutputNode - else - begin - Cel:=CreateTable(CurOutputNode, 'imagetable'); - Pel:=CreateTD(CreateTR(Cel)); - Cel:=CreateTD(CreateTR(Cel)); - El := CreateEl(Cel, 'span'); - El['class'] := 'imagecaption'; - Cel := El; - If (ALinkName<>'') then - Cel:=CreateAnchor(Cel,ALinkName); - AppendText(Cel,ACaption); - end; - - // Determine URL for image. - If (Module=Nil) then - D:=Allocator.GetRelativePathToTop(Package) - else - D:=Allocator.GetRelativePathToTop(Module); - L:=Length(D); - If (L>0) and (D[L]<>'/') then - D:=D+'/'; - - // Create image node. - El:=CreateEl(Pel,'img'); - EL['src']:=UTF8Decode(D + BaseImageURL) + AFileName; - El['alt']:=ACaption; - - //cache image filename, so it can be used later (CHM) - FImageFileList.Add(UTF8Encode(UTF8Decode(BaseImageURL) + AFileName)); -end; - -procedure THTMLWriter.DescrWriteFileEl(const AText: DOMString); -var - NewEl: TDOMElement; -begin - NewEl := CreateEl(CurOutputNode, 'span'); - NewEl['class'] := 'file'; - AppendText(NewEl, AText); -end; - -procedure THTMLWriter.DescrWriteKeywordEl(const AText: DOMString); -var - NewEl: TDOMElement; -begin - NewEl := CreateEl(CurOutputNode, 'span'); - NewEl['class'] := 'kw'; - AppendText(NewEl, AText); -end; - -procedure THTMLWriter.DescrWriteVarEl(const AText: DOMString); -begin - AppendText(CreateEl(CurOutputNode, 'var'), AText); -end; - -procedure THTMLWriter.DescrBeginLink(const AId: DOMString); -var - a,s,n : String; - -begin - a:=UTF8Encode(AId); - s := UTF8Encode(ResolveLinkID(a)); - if Length(s) = 0 then - begin - if assigned(module) then - s:=module.name - else - s:='?'; - if a='' then a:=''; - if Assigned(CurrentContext) then - N:=CurrentContext.Name - else - N:='?'; - DoLog(SErrUnknownLinkID, [s,n,a]); - PushOutputNode(CreateEl(CurOutputNode, 'b')); - end else - PushOutputNode(CreateLink(CurOutputNode, s)); -end; - -procedure THTMLWriter.DescrEndLink; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginURL(const AURL: DOMString); -begin - PushOutputNode(CreateLink(CurOutputNode, AURL)); -end; - -procedure THTMLWriter.DescrEndURL; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrWriteLinebreak; -begin - CreateEl(CurOutputNode, 'br'); -end; - -procedure THTMLWriter.DescrBeginParagraph; -begin - PushOutputNode(CreatePara(CurOutputNode)); -end; - -procedure THTMLWriter.DescrEndParagraph; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginCode(HasBorder: Boolean; const AHighlighterName: String); -begin - DoPasHighlighting := (AHighlighterName = '') or (AHighlighterName = 'Pascal'); - HighlighterFlags := 0; - PushOutputNode(CreateEl(CurOutputNode, 'pre')); -end; - -procedure THTMLWriter.DescrWriteCodeLine(const ALine: String); -begin - if DoPasHighlighting then - begin - HighlighterFlags := AppendPasSHFragment(CurOutputNode, ALine, - HighlighterFlags); - AppendText(CurOutputNode, #10); - end else - AppendText(CurOutputNode, ALine + #10); -end; - -procedure THTMLWriter.DescrEndCode; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginOrderedList; -begin - PushOutputNode(CreateEl(CurOutputNode, 'ol')); -end; - -procedure THTMLWriter.DescrEndOrderedList; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginUnorderedList; -begin - PushOutputNode(CreateEl(CurOutputNode, 'ul')); -end; - -procedure THTMLWriter.DescrEndUnorderedList; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginDefinitionList; -begin - PushOutputNode(CreateEl(CurOutputNode, 'dl')); -end; - -procedure THTMLWriter.DescrEndDefinitionList; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginListItem; -begin - PushOutputNode(CreateEl(CurOutputNode, 'li')); -end; - -procedure THTMLWriter.DescrEndListItem; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginDefinitionTerm; -begin - PushOutputNode(CreateEl(CurOutputNode, 'dt')); -end; - -procedure THTMLWriter.DescrEndDefinitionTerm; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginDefinitionEntry; -begin - PushOutputNode(CreateEl(CurOutputNode, 'dd')); -end; - -procedure THTMLWriter.DescrEndDefinitionEntry; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginSectionTitle; -begin - PushOutputNode(CreateEl(CurOutputNode, 'h3')); -end; - -procedure THTMLWriter.DescrBeginSectionBody; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrEndSection; -begin -end; - -procedure THTMLWriter.DescrBeginRemark; -var - NewEl, TDEl: TDOMElement; -begin - NewEl := CreateEl(CurOutputNode, 'table'); - NewEl['width'] := '100%'; - NewEl['border'] := '0'; - NewEl['CellSpacing'] := '0'; - NewEl['class'] := 'remark'; - NewEl := CreateTR(NewEl); - TDEl := CreateTD(NewEl); - TDEl['valign'] := 'top'; - TDEl['class'] := 'pre'; - AppendText(CreateEl(TDEl, 'b'), SDocRemark); - PushOutputNode(CreateTD(NewEl)); -end; - -procedure THTMLWriter.DescrEndRemark; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginTable(ColCount: Integer; HasBorder: Boolean); -var - Table: TDOMElement; -begin - Table := CreateEl(CurOutputNode, 'table'); - Table['border'] := UTF8Decode(IntToStr(Ord(HasBorder))); - PushOutputNode(Table); -end; - -procedure THTMLWriter.DescrEndTable; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginTableCaption; -begin - PushOutputNode(CreateEl(CurOutputNode, 'caption')); -end; - -procedure THTMLWriter.DescrEndTableCaption; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginTableHeadRow; -begin - PushOutputNode(CreateTr(CurOutputNode)); - InsideHeadRow := True; -end; - -procedure THTMLWriter.DescrEndTableHeadRow; -begin - InsideHeadRow := False; - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginTableRow; -begin - PushOutputNode(CreateTR(CurOutputNode)); -end; - -procedure THTMLWriter.DescrEndTableRow; -begin - PopOutputNode; -end; - -procedure THTMLWriter.DescrBeginTableCell; -begin - if InsideHeadRow then - PushOutputNode(CreateEl(CurOutputNode, 'th')) - else - PushOutputNode(CreateTD(CurOutputNode)); -end; - -procedure THTMLWriter.DescrEndTableCell; -begin - PopOutputNode; -end; - -procedure THTMLWriter.AppendText(Parent: TDOMNode; const AText: String); -begin - AppendText(Parent,UTF8Decode(aText)); -end; - - -procedure THTMLWriter.AppendText(Parent: TDOMNode; const AText: DOMString); -begin - Parent.AppendChild(Doc.CreateTextNode(AText)); -end; - -procedure THTMLWriter.AppendNbSp(Parent: TDOMNode; ACount: Integer); -begin - while ACount > 0 do - begin - Parent.AppendChild(Doc.CreateEntityReference('nbsp')); - Dec(ACount); - end; -end; - -procedure THTMLWriter.AppendSym(Parent: TDOMNode; const AText: DOMString); -var - El: TDOMElement; -begin - El := CreateEl(Parent, 'span'); - El['class'] := 'sym'; - AppendText(El, AText); -end; - -procedure THTMLWriter.AppendKw(Parent: TDOMNode; const AText: String); -begin - AppendKW(Parent,UTF8Decode(aText)); -end; - -procedure THTMLWriter.AppendKw(Parent: TDOMNode; const AText: DOMString); -var - El: TDOMElement; -begin - El := CreateEl(Parent, 'span'); - El['class'] := 'kw'; - AppendText(El, AText); -end; - -function THTMLWriter.AppendPasSHFragment(Parent: TDOMNode; - const AText: String; AShFlags: Byte): Byte; - - -var - Line, Last, p: PChar; - El: TDOMElement; - - Procedure MaybeOutput; - - Var - CurParent: TDomNode; - - begin - If (Last<>Nil) then - begin - If (el<>Nil) then - CurParent:=El - else - CurParent:=Parent; - AppendText(CurParent,Last); - El:=Nil; - Last:=Nil; - end; - end; - - Function NewEl(Const ElType,Attr,AttrVal : DOMString) : TDomElement; - - begin - Result:=CreateEl(Parent,ElType); - Result[Attr]:=AttrVal; - end; - - Function NewSpan(Const AttrVal : DOMString) : TDomElement; - - begin - Result:=CreateEl(Parent,'span'); - Result['class']:=AttrVal; - end; - -begin - GetMem(Line, Length(AText) * 3 + 4); - Try - DoPascalHighlighting(AShFlags, PChar(AText), Line); - Result := AShFlags; - Last := Nil; - p := Line; - el:=nil; - while p[0] <> #0 do - begin - if p[0] = LF_ESCAPE then - begin - p[0] := #0; - MaybeOutput; - case Ord(p[1]) of - shDefault: El:=Nil; - shInvalid: El:=newel('font','color','red'); - shSymbol : El:=newspan('sym'); - shKeyword: El:=newspan('kw'); - shComment: El:=newspan('cmt'); - shDirective: El:=newspan('dir'); - shNumbers: El:=newspan('num'); - shCharacters: El:=newspan('chr'); - shStrings: El:=newspan('str'); - shAssembler: El:=newspan('asm'); - end; - Inc(P); - end - else If (Last=Nil) then - Last:=P; - Inc(p); - end; - MaybeOutput; - Finally - FreeMem(Line); - end; -end; - -procedure THTMLWriter.AppendShortDescr ( AContext: TPasElement; - Parent: TDOMNode; DocNode: TDocNode ) ; - -Var - N : TDocNode; - -begin - if Assigned(DocNode) then - begin - If (DocNode.Link<>'') then - begin - N:=Engine.FindLinkedNode(DocNode); - If (N<>Nil) then - DocNode:=N; - end; - If Assigned(DocNode.ShortDescr) then - begin - PushOutputNode(Parent); - try - if not ConvertShort(AContext,TDomElement(DocNode.ShortDescr)) then - Warning(AContext, SErrInvalidShortDescr) - finally - PopOutputNode; - end; - end; - end; -end; - -procedure THTMLWriter.AppendShortDescr(Parent: TDOMNode; Element: TPasElement); - -begin - AppendShortDescr(Element,Parent,Engine.FindDocNode(Element)); -end; - -procedure THTMLWriter.AppendShortDescrCell(Parent: TDOMNode; - Element: TPasElement); - -var - ParaEl: TDOMElement; - -begin - if Assigned(Engine.FindShortDescr(Element)) then - begin - AppendNbSp(CreatePara(CreateTD(Parent)), 2); - ParaEl := CreatePara(CreateTD(Parent)); - ParaEl['class'] := 'cmt'; - AppendShortDescr(ParaEl, Element); - end; -end; - -procedure THTMLWriter.AppendDescr(AContext: TPasElement; Parent: TDOMNode; - DescrNode: TDOMElement; AutoInsertBlock: Boolean); -begin - if Assigned(DescrNode) then - begin - PushOutputNode(Parent); - try - ConvertDescr(AContext, DescrNode, AutoInsertBlock); - finally - PopOutputNode; - end; - end; -end; - -procedure THTMLWriter.AppendDescrSection(AContext: TPasElement; Parent: TDOMNode; DescrNode: TDOMElement; const ATitle: String); -begin - AppendDescrSection(aContext,Parent,DescrNode,UTF8Decode(aTitle)); -end; - -procedure THTMLWriter.AppendDescrSection(AContext: TPasElement; - Parent: TDOMNode; DescrNode: TDOMElement; const ATitle: DOMString); -begin - if not IsDescrNodeEmpty(DescrNode) then - begin - If (ATitle<>'') then // Can be empty for topic. - AppendText(CreateH2(Parent), ATitle); - AppendDescr(AContext, Parent, DescrNode, True); - end; -end; - - - -function THTMLWriter.AppendHyperlink(Parent: TDOMNode; - Element: TPasElement): TDOMElement; -var - s: DOMString; - UnitList: TFPList; - i: Integer; - ThisPackage: TLinkNode; -begin - if Assigned(Element) then - begin - if Element.InheritsFrom(TPasUnresolvedTypeRef) then - begin - s := ResolveLinkID(Element.Name); - if Length(s) = 0 then - begin - { Try all packages } - ThisPackage := Engine.RootLinkNode.FirstChild; - while Assigned(ThisPackage) do - begin - s := ResolveLinkID(ThisPackage.Name + '.' + Element.Name); - if Length(s) > 0 then - break; - ThisPackage := ThisPackage.NextSibling; - end; - if Length(s) = 0 then - begin - { Okay, then we have to try all imported units of the current module } - UnitList := Module.InterfaceSection.UsesList; - for i := UnitList.Count - 1 downto 0 do - begin - { Try all packages } - ThisPackage := Engine.RootLinkNode.FirstChild; - while Assigned(ThisPackage) do - begin - s := ResolveLinkID(ThisPackage.Name + '.' + - TPasType(UnitList[i]).Name + '.' + Element.Name); - if Length(s) > 0 then - break; - ThisPackage := ThisPackage.NextSibling; - end; - if length(s)=0 then - s := ResolveLinkID('#rtl.System.' + Element.Name); - if Length(s) > 0 then - break; - end; - end; - end; - end else if Element is TPasEnumValue then - s := ResolveLinkID(Element.Parent.PathName) - else - s := ResolveLinkID(Element.PathName); - - if Length(s) > 0 then - begin - Result := CreateLink(Parent, s); - AppendText(Result, Element.Name); - end else - begin - Result := nil; - AppendText(Parent, Element.Name); // unresolved items - end; - end else - begin - Result := nil; - AppendText(CreateWarning(Parent), ''); - end; -end; - { Returns the new CodeEl, which will be the old CodeEl in most cases } -function THTMLWriter.AppendType(CodeEl, TableEl: TDOMElement; - Element: TPasType; Expanded: Boolean; NestingLevel: Integer): TDOMElement; +function THTMLWriter.AppendType(CodeEl, TableEl: TDOMElement; Element: TPasType; Expanded: Boolean; NestingLevel: Integer): TDOMElement; Var S : String; @@ -1504,17 +612,6 @@ begin Result := CodeEl; end; -procedure THTMLWriter.AppendTitle(const AText: DOMString; Hints : TPasMemberHints = []); - -Var - T : UnicodeString; -begin - T:=AText; - if (Hints<>[]) then - T:=T+' ('+UTF8Decode(Engine.HintsToStr(Hints))+')'; - AppendText(TitleElement, AText); - AppendText(CreateH1(BodyElement), T); -end; procedure THTMLWriter.AppendTopicMenuBar(Topic : TTopicElement); @@ -1531,7 +628,7 @@ var end; begin - TableEl := CreateEl(BodyElement, 'table'); + TableEl := CreateEl(ContentElement, 'table'); TableEl['cellpadding'] := '4'; TableEl['cellspacing'] := '0'; TableEl['border'] := '0'; @@ -1567,15 +664,6 @@ begin end; end; -procedure THTMLWriter.AppendFragment(aParentNode : TDOMElement; aStream : TStream); - -begin - if (aStream<>Nil) then - begin - aStream.Position:=0; - ReadXMLFragment(aParentNode,aStream); - end; -end; function THTMLWriter.CreateAllocator: TFileAllocator; begin @@ -1618,7 +706,7 @@ var begin - TableEl := CreateEl(BodyElement, 'table'); + TableEl := CreateEl(ContentElement, 'table'); TableEl['cellpadding'] := '4'; TableEl['cellspacing'] := '0'; TableEl['border'] := '0'; @@ -1703,139 +791,9 @@ begin AppendHyperlink(ParaEl, Package); AppendText(ParaEl, ']'); end; - AppendFragment(BodyElement,HeaderHTML); + AppendFragment(ContentElement,HeaderHTML); end; -procedure THTMLWriter.AppendSourceRef(AElement: TPasElement); -begin - AppendText(CreatePara(BodyElement), Format(SDocSourcePosition, - [ExtractFileName(AElement.SourceFilename), AElement.SourceLinenumber])); -end; - -procedure THTMLWriter.AppendSeeAlsoSection ( AElement: TPasElement; - DocNode: TDocNode ) ; - -var - Node: TDOMNode; - TableEl, El, TREl, ParaEl, NewEl, DescrEl: TDOMElement; - l,s,n: DOMString; - IsFirstSeeAlso : Boolean; - -begin - if Not (Assigned(DocNode) and Assigned(DocNode.SeeAlso)) then - Exit; - IsFirstSeeAlso := True; - Node:=DocNode.SeeAlso.FirstChild; - While Assigned(Node) do - begin - if (Node.NodeType=ELEMENT_NODE) and (Node.NodeName='link') then - begin - if IsFirstSeeAlso then - begin - IsFirstSeeAlso := False; - AppendText(CreateH2(BodyElement), SDocSeeAlso); - TableEl := CreateTable(BodyElement); - end; - El:=TDOMElement(Node); - TREl:=CreateTR(TableEl); - ParaEl:=CreatePara(CreateTD_vtop(TREl)); - l:=El['id']; - s:= ResolveLinkID(UTF8ENcode(l)); - if Length(s)=0 then - begin - if assigned(module) then - s:=UTF8Decode(module.name) - else - s:='?'; - if l='' then l:=''; - if Assigned(AElement) then - N:=UTF8Decode(AElement.Name) - else - N:='?'; - DoLog(SErrUnknownLinkID, [s,N,l]); - NewEl := CreateEl(ParaEl,'b') - end - else - NewEl := CreateLink(ParaEl,s); - if Not IsDescrNodeEmpty(El) then - begin - PushOutputNode(NewEl); - Try - ConvertBaseShortList(AElement, El, True) - Finally - PopOutputNode; - end; - end - else - AppendText(NewEl,El['id']); - l:=El['id']; - DescrEl := Engine.FindShortDescr(AElement.GetModule,UTF8Encode(L)); - if Assigned(DescrEl) then - begin - AppendNbSp(CreatePara(CreateTD(TREl)), 2); - ParaEl := CreatePara(CreateTD(TREl)); - ParaEl['class'] := 'cmt'; - PushOutputNode(ParaEl); - try - ConvertShort(AElement, DescrEl); - finally - PopOutputNode; - end; - end; - end; // Link node - Node := Node.NextSibling; - end; // While -end; - -procedure THTMLWriter.AppendExampleSection ( AElement: TPasElement; - DocNode: TDocNode ) ; - -var - Node: TDOMNode; -// TableEl, El, TREl, TDEl, ParaEl, NewEl, DescrEl: TDOMElement; - fn,s: String; - f: Text; - -begin - if not (Assigned(DocNode) and Assigned(DocNode.FirstExample)) then - Exit; - Node := DocNode.FirstExample; - while Assigned(Node) do - begin - if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'example') then - begin - fn:=Engine.GetExampleFilename(TDOMElement(Node)); - If (fn<>'') then - begin - AppendText(CreateH2(BodyElement), SDocExample); - try - Assign(f, FN); - Reset(f); - try - PushOutputNode(BodyElement); - DescrBeginCode(False, UTF8Encode(TDOMElement(Node)['highlighter'])); - while not EOF(f) do - begin - ReadLn(f, s); - DescrWriteCodeLine(s); - end; - DescrEndCode; - PopOutputNode; - finally - Close(f); - end; - except - on e: Exception do - begin - e.Message := '[example] ' + e.Message; - raise; - end; - end; - end; - end; - Node := Node.NextSibling; - end; -end; procedure THTMLWriter.AppendFooter; @@ -1844,11 +802,11 @@ Var F : TDomElement; begin if Assigned(FooterHTML) then - AppendFragment(BodyElement, FooterHTML) + AppendFragment(ContentElement, FooterHTML) else if IncludeDateInFooter then begin - CreateEl(BodyElement, 'hr'); - F:=CreateEl(BodyElement,'span'); + CreateEl(ContentElement, 'hr'); + F:=CreateEl(ContentElement,'span'); F['class']:='footer'; If (FDateFormat='') then S:=DateToStr(Date) @@ -1865,43 +823,44 @@ var begin DocNode := Engine.FindDocNode(AElement); - If Assigned(DocNode) then - begin - // Description - if Assigned(DocNode.Descr) then - AppendDescrSection(AElement, BodyElement, DocNode.Descr, UTF8Encode(SDocDescription)); + If Not Assigned(DocNode) then + exit; - // Append "Errors" section - if Assigned(DocNode.ErrorsDoc) then - AppendDescrSection(AElement, BodyElement, DocNode.ErrorsDoc, UTF8Encode(SDocErrors)); + // Description + if Assigned(DocNode.Descr) then + AppendDescrSection(AElement, ContentElement, DocNode.Descr, UTF8Encode(SDocDescription)); - // Append Version info - if Assigned(DocNode.Version) then - AppendDescrSection(AElement, BodyElement, DocNode.Version, UTF8Encode(SDocVersion)); + // Append "Errors" section + if Assigned(DocNode.ErrorsDoc) then + AppendDescrSection(AElement, ContentElement, DocNode.ErrorsDoc, UTF8Encode(SDocErrors)); - // Append "See also" section - AppendSeeAlsoSection(AElement,DocNode); + // Append Version info + if Assigned(DocNode.Version) then + AppendDescrSection(AElement, ContentElement, DocNode.Version, UTF8Encode(SDocVersion)); - // Append examples, if present - AppendExampleSection(AElement,DocNode); - // Append notes, if present - ConvertNotes(AElement,DocNode.Notes); - end; + // Append "See also" section + AppendSeeAlsoSection(AElement,DocNode); + + // Append examples, if present + AppendExampleSection(AElement,DocNode); + // Append notes, if present + ConvertNotes(AElement,DocNode.Notes); end; procedure THTMLWriter.CreateTopicPageBody(AElement: TTopicElement); var DocNode: TDocNode; + begin AppendTopicMenuBar(AElement); DocNode:=AElement.TopicNode; if Assigned(DocNode) then // should always be true, but we're being careful. begin AppendShortDescr(AElement,TitleElement, DocNode); - AppendShortDescr(AElement,CreateH2(BodyElement), DocNode); + AppendShortDescr(AElement,CreateH2(ContentElement), DocNode); if Assigned(DocNode.Descr) then - AppendDescrSection(AElement, BodyElement, DocNode.Descr, ''); + AppendDescrSection(AElement, ContentElement, DocNode.Descr, ''); AppendSeeAlsoSection(AElement,DocNode); CreateTopicLinks(DocNode,AElement); AppendExampleSection(AElement,DocNode); @@ -1910,6 +869,7 @@ begin end; procedure THTMLWriter.CreateClassHierarchyPage(AddUnit : Boolean); + type TypeEN = (NPackage, NModule, NName); @@ -1995,7 +955,7 @@ type end; begin - PushOutputNode(BodyElement); + PushOutputNode(ContentElement); try PushClassList; AppendClass(TreeClass.RootNode); @@ -2030,11 +990,12 @@ begin CreateClassHierarchyPage(True); end; -procedure THTMLWriter.CreatePageBody(AElement: TPasElement; - ASubpageIndex: Integer); +procedure THTMLWriter.CreatePageBody(AElement: TPasElement; ASubpageIndex: Integer); + var i: Integer; Element: TPasElement; + begin CurDirectory := Allocator.GetFilename(AElement, ASubpageIndex); i := Length(CurDirectory); @@ -2121,7 +1082,7 @@ begin end; Try // Create a quick jump table to all available letters. - TableEl := CreateTable(BodyElement); + TableEl := CreateTable(ContentElement); TableEl['border']:='1'; TableEl['width']:='50%'; TREl := CreateTR(TableEl); @@ -2140,10 +1101,10 @@ begin CL:=Lists[C]; If CL<>Nil then begin - El:=CreateH2(BodyElement); + El:=CreateH2(ContentElement); AppendText(El,UTF8Decode(C)); CreateAnchor(El,UTF8Decode('SECTION'+C)); - TableEl := CreateTable(BodyElement); + TableEl := CreateTable(ContentElement); TableEl['Width']:='80%'; // Determine number of rows needed Rows:=(CL.Count div IndexColCount); @@ -2173,22 +1134,6 @@ begin end; end; - -procedure THTMLWriter.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; - - procedure THTMLWriter.CreatePackageIndex; Var @@ -2219,6 +1164,7 @@ begin end; procedure THTMLWriter.CreatePackagePageBody; + var DocNode: TDocNode; TableEl, TREl: TDOMElement; @@ -2229,10 +1175,10 @@ var begin AppendMenuBar(0); AppendTitle(UTF8Encode(Format(SDocPackageTitle, [Copy(Package.Name, 2, 256)]))); - AppendShortDescr(CreatePara(BodyElement), Package); + AppendShortDescr(CreatePara(ContentElement), Package); - AppendText(CreateH2(BodyElement), UTF8Encode(SDocUnits)); - TableEl := CreateTable(BodyElement); + AppendText(CreateH2(ContentElement), UTF8Encode(SDocUnits)); + TableEl := CreateTable(ContentElement); L:=TStringList.Create; Try L.Sorted:=True; @@ -2255,13 +1201,12 @@ begin if Assigned(DocNode) then begin if Assigned(DocNode.Descr) then - AppendDescrSection(nil, BodyElement, DocNode.Descr, UTF8Decode(SDocDescription)); + AppendDescrSection(nil, ContentElement, DocNode.Descr, UTF8Decode(SDocDescription)); CreateTopicLinks(DocNode,Package); end; end; -procedure THTMLWriter.CreateTopicLinks ( Node: TDocNode; - PasElement: TPasElement ) ; +procedure THTMLWriter.CreateTopicLinks (Node: TDocNode; PasElement: TPasElement) ; var DocNode: TDocNode; @@ -2279,8 +1224,8 @@ begin if first then begin First:=False; - AppendText(CreateH2(BodyElement), UTF8Decode(SDocRelatedTopics)); - TableEl := CreateTable(BodyElement); + AppendText(CreateH2(ContentElement), UTF8Decode(SDocRelatedTopics)); + TableEl := CreateTable(ContentElement); end; TREl := CreateTR(TableEl); ThisTopic:=FindTopicElement(DocNode); @@ -2309,133 +1254,137 @@ begin end; end; +procedure THTMLWriter.CreateModuleMainPage(aModule : TPasModule); + +var + TableEl, TREl, TDEl, CodeEl: TDOMElement; + i: Integer; + UnitRef: TPasType; + DocNode: TDocNode; + +begin + AppendMenuBar(0); + AppendTitle(UTF8Decode(Format(SDocUnitTitle, [AModule.Name])),AModule.Hints); + AppendShortDescr(CreatePara(ContentElement), AModule); + + if AModule.InterfaceSection.UsesList.Count > 0 then + begin + TableEl := CreateTable(ContentElement); + AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'uses'); + for i := 0 to AModule.InterfaceSection.UsesList.Count - 1 do + begin + UnitRef := TPasType(AModule.InterfaceSection.UsesList[i]); + DocNode := Engine.FindDocNode(UnitRef); + if Assigned(DocNode) and DocNode.IsSkipped then + continue; + TREl := CreateTR(TableEl); + TDEl := CreateTD_vtop(TREl); + CodeEl := CreateCode(CreatePara(TDEl)); + AppendNbSp(CodeEl, 2); + AppendHyperlink(CodeEl, UnitRef); + if i < AModule.InterfaceSection.UsesList.Count - 1 then + AppendSym(CodeEl, ',') + else + AppendSym(CodeEl, ';'); + AppendText(CodeEl, ' '); // Space for descriptions + AppendShortDescrCell(TREl, UnitRef); + end; + end; + + DocNode := Engine.FindDocNode(AModule); + if Assigned(DocNode) then + begin + if Assigned(DocNode.Descr) then + AppendDescrSection(AModule, ContentElement, DocNode.Descr, UTF8Decode(SDocOverview)); + ConvertNotes(AModule,DocNode.Notes); + CreateTopicLinks(DocNode,AModule); + end; +end; + + +procedure THTMLWriter.CreateModuleSimpleSubpage(aModule: TPasModule; ASubpageIndex: Integer; const ATitle: DOMString; AList: TFPList); + +var + TableEl, TREl, CodeEl: TDOMElement; + i, j: Integer; + Decl: TPasElement; + SortedList: TFPList; + DocNode: TDocNode; + S : String; + +begin + AppendMenuBar(ASubpageIndex); + S:=UTF8Encode(ATitle); + AppendTitle(UTF8Decode(Format(SDocUnitTitle + ': %s', [AModule.Name, S]))); + SortedList := TFPList.Create; + try + for i := 0 to AList.Count - 1 do + begin + Decl := TPasElement(AList[i]); + DocNode := Engine.FindDocNode(Decl); + if (not Assigned(DocNode)) or (not DocNode.IsSkipped) then + begin + j := 0; + while (j < SortedList.Count) and (CompareText( + TPasElement(SortedList[j]).PathName, Decl.PathName) < 0) do + Inc(j); + SortedList.Insert(j, Decl); + end; + end; + + TableEl := CreateTable(ContentElement); + for i := 0 to SortedList.Count - 1 do + begin + Decl := TPasElement(SortedList[i]); + TREl := CreateTR(TableEl); + CodeEl := CreateCode(CreatePara(CreateTD_vtop(TREl))); + AppendHyperlink(CodeEl, Decl); + AppendShortDescrCell(TREl, Decl); + end; + finally + SortedList.Free; + end; +end; + +procedure THTMLWriter.CreateModuleResStringsPage(aModule : TPasModule); +var + ParaEl: TDOMElement; + i: Integer; + Decl: TPasResString; +begin + AppendMenuBar(ResstrSubindex); + AppendTitle(UTF8Decode(Format(SDocUnitTitle + ': %s', [AModule.Name, SDocResStrings]))); + for i := 0 to AModule.InterfaceSection.ResStrings.Count - 1 do + begin + Decl := TPasResString(AModule.InterfaceSection.ResStrings[i]); + CreateEl(ContentElement, 'a')['name'] := UTF8Decode(LowerCase(Decl.Name)); + ParaEl := CreatePara(ContentElement); + AppendText(CreateCode(ParaEl), UTF8Decode(Decl.Name)); + CreateEl(ParaEl, 'br'); + AppendText(ParaEl, UTF8Decode(Decl.Expr.getDeclaration(true))); + end; +end; + + procedure THTMLWriter.CreateModulePageBody(AModule: TPasModule; ASubpageIndex: Integer); - procedure CreateMainPage; - var - TableEl, TREl, TDEl, CodeEl: TDOMElement; - i: Integer; - UnitRef: TPasType; - DocNode: TDocNode; - begin - AppendMenuBar(0); - AppendTitle(UTF8Decode(Format(SDocUnitTitle, [AModule.Name])),AModule.Hints); - AppendShortDescr(CreatePara(BodyElement), AModule); - - if AModule.InterfaceSection.UsesList.Count > 0 then - begin - TableEl := CreateTable(BodyElement); - AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'uses'); - for i := 0 to AModule.InterfaceSection.UsesList.Count - 1 do - begin - UnitRef := TPasType(AModule.InterfaceSection.UsesList[i]); - DocNode := Engine.FindDocNode(UnitRef); - if Assigned(DocNode) and DocNode.IsSkipped then - continue; - TREl := CreateTR(TableEl); - TDEl := CreateTD_vtop(TREl); - CodeEl := CreateCode(CreatePara(TDEl)); - AppendNbSp(CodeEl, 2); - AppendHyperlink(CodeEl, UnitRef); - if i < AModule.InterfaceSection.UsesList.Count - 1 then - AppendSym(CodeEl, ',') - else - AppendSym(CodeEl, ';'); - AppendText(CodeEl, ' '); // Space for descriptions - AppendShortDescrCell(TREl, UnitRef); - end; - end; - - DocNode := Engine.FindDocNode(AModule); - if Assigned(DocNode) then - begin - if Assigned(DocNode.Descr) then - AppendDescrSection(AModule, BodyElement, DocNode.Descr, UTF8Decode(SDocOverview)); - ConvertNotes(AModule,DocNode.Notes); - CreateTopicLinks(DocNode,AModule); - end; - end; - - procedure CreateSimpleSubpage(const ATitle: DOMString; AList: TFPList); - var - TableEl, TREl, CodeEl: TDOMElement; - i, j: Integer; - Decl: TPasElement; - SortedList: TFPList; - DocNode: TDocNode; - S : String; - - begin - AppendMenuBar(ASubpageIndex); - S:=UTF8Encode(ATitle); - AppendTitle(UTF8Decode(Format(SDocUnitTitle + ': %s', [AModule.Name, S]))); - SortedList := TFPList.Create; - try - for i := 0 to AList.Count - 1 do - begin - Decl := TPasElement(AList[i]); - DocNode := Engine.FindDocNode(Decl); - if (not Assigned(DocNode)) or (not DocNode.IsSkipped) then - begin - j := 0; - while (j < SortedList.Count) and (CompareText( - TPasElement(SortedList[j]).PathName, Decl.PathName) < 0) do - Inc(j); - SortedList.Insert(j, Decl); - end; - end; - - TableEl := CreateTable(BodyElement); - for i := 0 to SortedList.Count - 1 do - begin - Decl := TPasElement(SortedList[i]); - TREl := CreateTR(TableEl); - CodeEl := CreateCode(CreatePara(CreateTD_vtop(TREl))); - AppendHyperlink(CodeEl, Decl); - AppendShortDescrCell(TREl, Decl); - end; - finally - SortedList.Free; - end; - end; - - procedure CreateResStringsPage; - var - ParaEl: TDOMElement; - i: Integer; - Decl: TPasResString; - begin - AppendMenuBar(ResstrSubindex); - AppendTitle(UTF8Decode(Format(SDocUnitTitle + ': %s', [AModule.Name, SDocResStrings]))); - for i := 0 to AModule.InterfaceSection.ResStrings.Count - 1 do - begin - Decl := TPasResString(AModule.InterfaceSection.ResStrings[i]); - CreateEl(BodyElement, 'a')['name'] := UTF8Decode(LowerCase(Decl.Name)); - ParaEl := CreatePara(BodyElement); - AppendText(CreateCode(ParaEl), UTF8Decode(Decl.Name)); - CreateEl(ParaEl, 'br'); - AppendText(ParaEl, UTF8Decode(Decl.Expr.getDeclaration(true))); - end; - end; - - begin case ASubpageIndex of 0: - CreateMainPage; + CreateModuleMainPage(aModule); ResstrSubindex: - CreateResStringsPage; + CreateModuleResStringsPage(aModule); ConstsSubindex: - CreateSimpleSubpage(UTF8Decode(SDocConstants), AModule.InterfaceSection.Consts); + CreateModuleSimpleSubpage(aModule, ConstsSubindex,UTF8Decode(SDocConstants), AModule.InterfaceSection.Consts); TypesSubindex: - CreateSimpleSubpage(UTF8Decode(SDocTypes), AModule.InterfaceSection.Types); + CreateModuleSimpleSubpage(aModule, TypesSubindex,UTF8Decode(SDocTypes), AModule.InterfaceSection.Types); ClassesSubindex: - CreateSimpleSubpage(UTF8Decode(SDocClasses), AModule.InterfaceSection.Classes); + CreateModuleSimpleSubpage(aModule, ClassesSubindex,UTF8Decode(SDocClasses), AModule.InterfaceSection.Classes); ProcsSubindex: - CreateSimpleSubpage(UTF8Decode(SDocProceduresAndFunctions), AModule.InterfaceSection.Functions); + CreateModuleSimpleSubpage(aModule, ProcsSubindex, UTF8Decode(SDocProceduresAndFunctions), AModule.InterfaceSection.Functions); VarsSubindex: - CreateSimpleSubpage(UTF8Decode(SDocVariables), AModule.InterfaceSection.Variables); + CreateModuleSimpleSubpage(aModule, VarsSubindex,UTF8Decode(SDocVariables), AModule.InterfaceSection.Variables); IndexSubIndex: CreateModuleIndexPage(AModule); end; @@ -2447,11 +1396,11 @@ var begin AppendMenuBar(-1); AppendTitle(UTF8Decode(AConst.Name),AConst.Hints); - AppendShortDescr(CreatePara(BodyElement), AConst); - AppendText(CreateH2(BodyElement), UTF8Decode(SDocDeclaration)); - AppendSourceRef(AConst); + AppendShortDescr(CreatePara(ContentElement), AConst); + AppendText(CreateH2(ContentElement), UTF8Decode(SDocDeclaration)); + AppendSourceRef(ContentElement,AConst); - TableEl := CreateTable(BodyElement); + TableEl := CreateTable(ContentElement); CodeEl := CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))); AppendKw(CodeEl, 'const'); @@ -2524,7 +1473,7 @@ begin if AType.InheritsFrom(TPasProcedureType) then begin AppendSym(AppendType(CodeEl, TableEl, TPasType(AType), True), ';'); - AppendProcArgsSection(BodyElement, TPasProcedureType(AType)); + AppendProcArgsSection(ContentElement, TPasProcedureType(AType)); end else // Record if AType.ClassType = TPasRecordType then @@ -2579,11 +1528,11 @@ var begin AppendMenuBar(-1); AppendTitle(UTF8Decode(AType.Name),AType.Hints); - AppendShortDescr(CreatePara(BodyElement), AType); - AppendText(CreateH2(BodyElement), UTF8Decode(SDocDeclaration)); - AppendSourceRef(AType); + AppendShortDescr(CreatePara(ContentElement), AType); + AppendText(CreateH2(ContentElement), UTF8Decode(SDocDeclaration)); + AppendSourceRef(ContentElement,AType); - TableEl := CreateTable(BodyElement); + TableEl := CreateTable(ContentElement); TREl := CreateTR(TableEl); TDEl := CreateTD(TREl); CodeEl := CreateCode(CreatePara(TDEl)); @@ -2753,35 +1702,46 @@ begin AppendTitle(UTF8Decode(aText),Hints); end; -procedure THTMLWriter.CreateClassPageBody(AClass: TPasClassType; - ASubpageIndex: Integer); -var - ParaEl: TDOMElement; +procedure THTMLWriter.AppendTitle(const AText: DOMString; Hints : TPasMemberHints = []); - procedure AppendMemberListLink(AListSubpageIndex: Integer; - const AText: DOMString); - var - LinkEl: TDOMElement; - begin - if FUseMenuBrackets then - AppendText(ParaEl, '['); - LinkEl := CreateEl(ParaEl, 'a'); - LinkEl['href'] :=UTF8Decode(FixHtmlPath(ResolveLinkWithinPackage(AClass, AListSubpageIndex))); - LinkEl['onClick'] := 'window.open(''' + LinkEl['href'] + ''', ''list'', ' + - '''dependent=yes,resizable=yes,scrollbars=yes,height=400,width=300''); return false;'; - AppendText(LinkEl, AText); - AppendText(ParaEl, ' ('); - LinkEl := CreateEl(ParaEl, 'a'); - LinkEl['href'] :=UTF8Decode(FixHtmlPath(ResolveLinkWithinPackage(AClass, AListSubpageIndex + 1))); - LinkEl['onClick'] := 'window.open(''' + LinkEl['href'] + ''', ''list'', ' + - '''dependent=yes,resizable=yes,scrollbars=yes,height=400,width=300''); return false;'; - AppendText(LinkEl, UTF8Decode(SDocByName)); - AppendText(ParaEl, ')'); - if FUseMenuBrackets then - AppendText(ParaEl, '] ') - else - AppendText(ParaEl, ' '); - end; +Var + T : UnicodeString; +begin + T:=AText; + if (Hints<>[]) then + T:=T+' ('+UTF8Decode(Engine.HintsToStr(Hints))+')'; + AppendText(TitleElement, AText); + AppendText(CreateH1(ContentElement), T); +end; + + +procedure THTMLWriter.AppendClassMemberListLink(aClass : TPasClassType; ParaEl : TDomElement; AListSubpageIndex: Integer; const AText: DOMString); + +var + LinkEl: TDOMElement; +begin + if FUseMenuBrackets then + AppendText(ParaEl, '['); + LinkEl := CreateEl(ParaEl, 'a'); + LinkEl['href'] :=UTF8Decode(FixHtmlPath(ResolveLinkWithinPackage(AClass, AListSubpageIndex))); + LinkEl['onClick'] := 'window.open(''' + LinkEl['href'] + ''', ''list'', ' + + '''dependent=yes,resizable=yes,scrollbars=yes,height=400,width=300''); return false;'; + AppendText(LinkEl, AText); + AppendText(ParaEl, ' ('); + LinkEl := CreateEl(ParaEl, 'a'); + LinkEl['href'] :=UTF8Decode(FixHtmlPath(ResolveLinkWithinPackage(AClass, AListSubpageIndex + 1))); + LinkEl['onClick'] := 'window.open(''' + LinkEl['href'] + ''', ''list'', ' + + '''dependent=yes,resizable=yes,scrollbars=yes,height=400,width=300''); return false;'; + AppendText(LinkEl, UTF8Decode(SDocByName)); + AppendText(ParaEl, ')'); + if FUseMenuBrackets then + AppendText(ParaEl, '] ') + else + AppendText(ParaEl, ' '); +end; + + +procedure THTMLWriter.CreateClassMainPage(aClass : TPasClassType); procedure AppendGenericTypes(CodeEl : TDomElement; AList : TFPList; isSpecialize : Boolean); @@ -2799,264 +1759,268 @@ var AppendSym(CodeEl, '>'); end; - procedure CreateMainPage; - var - TableEl, TREl, TDEl, CodeEl: TDOMElement; - i: Integer; - ThisInterface, - ThisClass: TPasClassType; - ThisTreeNode: TPasElementNode; + +var + ParaEl,TableEl, TREl, TDEl, CodeEl: TDOMElement; + i: Integer; + ThisInterface, + ThisClass: TPasClassType; + ThisTreeNode: TPasElementNode; +begin + //WriteLn('@ClassPageBody.CreateMainPage Class=', AClass.Name); + AppendMenuBar(-1); + AppendTitle(UTF8Decode(AClass.Name),AClass.Hints); + + ParaEl := CreatePara(ContentElement); + AppendClassMemberListLink(aClass,ParaEl,PropertiesByInheritanceSubindex, UTF8Decode(SDocProperties)); + AppendClassMemberListLink(aClass,ParaEl,MethodsByInheritanceSubindex, UTF8Decode(SDocMethods)); + AppendClassMemberListLink(aClass,ParaEl,EventsByInheritanceSubindex, UTF8Decode(SDocEvents)); + + AppendShortDescr(CreatePara(ContentElement), AClass); + AppendText(CreateH2(ContentElement), UTF8Decode(SDocDeclaration)); + AppendSourceRef(ContentElement,AClass); + + TableEl := CreateTable(ContentElement); + + TREl := CreateTR(TableEl); + TDEl := CreateTD(TREl); + CodeEl := CreateCode(CreatePara(TDEl)); + AppendKw(CodeEl, 'type'); + if AClass.GenericTemplateTypes.Count>0 then + AppendKw(CodeEl, ' generic '); + AppendText(CodeEl, ' ' + UTF8Decode(AClass.Name) + ' '); + if AClass.GenericTemplateTypes.Count>0 then + AppendGenericTypes(CodeEl,AClass.GenericTemplateTypes,false); + AppendSym(CodeEl, '='); + AppendText(CodeEl, ' '); + AppendKw(CodeEl, UTF8Decode(ObjKindNames[AClass.ObjKind])); + + if Assigned(AClass.AncestorType) then begin - //WriteLn('@ClassPageBody.CreateMainPage Class=', AClass.Name); - AppendMenuBar(-1); - AppendTitle(UTF8Decode(AClass.Name),AClass.Hints); + AppendSym(CodeEl, '('); + AppendHyperlink(CodeEl, AClass.AncestorType); + if AClass.Interfaces.count>0 Then + begin + for i:=0 to AClass.interfaces.count-1 do + begin + AppendSym(CodeEl, ', '); + AppendHyperlink(CodeEl,TPasClassType(AClass.Interfaces[i])); + end; + end; + AppendSym(CodeEl, ')'); + end; + CreateMemberDeclarations(AClass, AClass.Members,TableEl, not AClass.IsShortDefinition); - ParaEl := CreatePara(BodyElement); - AppendMemberListLink(PropertiesByInheritanceSubindex, UTF8Decode(SDocProperties)); - AppendMemberListLink(MethodsByInheritanceSubindex, UTF8Decode(SDocMethods)); - AppendMemberListLink(EventsByInheritanceSubindex, UTF8Decode(SDocEvents)); + AppendText(CreateH2(ContentElement), UTF8Decode(SDocInheritance)); + TableEl := CreateTable(ContentElement); - AppendShortDescr(CreatePara(BodyElement), AClass); - AppendText(CreateH2(BodyElement), UTF8Decode(SDocDeclaration)); - AppendSourceRef(AClass); + // Now we are using only TreeClass for show inheritance - TableEl := CreateTable(BodyElement); + ThisClass := AClass; ThisTreeNode := Nil; + if AClass.ObjKind = okInterface then + ThisTreeNode := TreeInterface.GetPasElNode(AClass) + else + ThisTreeNode := TreeClass.GetPasElNode(AClass); + while True do + begin + TREl := CreateTR(TableEl); + TDEl := CreateTD_vtop(TREl); + TDEl['align'] := 'center'; + CodeEl := CreateCode(CreatePara(TDEl)); + // Show class item + if Assigned(ThisClass) Then + AppendHyperlink(CodeEl, ThisClass); + //else + // AppendHyperlink(CodeEl, ThisTreeNode); + // Show links to class interfaces + if Assigned(ThisClass) and (ThisClass.Interfaces.count>0) then + begin + for i:=0 to ThisClass.interfaces.count-1 do + begin + ThisInterface:=TPasClassType(ThisClass.Interfaces[i]); + AppendText(CodeEl,','); + AppendHyperlink(CodeEl, ThisInterface); + end; + end; + // short class description + if Assigned(ThisClass) then + AppendShortDescrCell(TREl, ThisClass); + + if Assigned(ThisTreeNode) then + if Assigned(ThisTreeNode.ParentNode) then + begin + TDEl := CreateTD(CreateTR(TableEl)); + TDEl['align'] := 'center'; + AppendText(TDEl, '|'); + ThisClass := ThisTreeNode.ParentNode.Element; + ThisTreeNode := ThisTreeNode.ParentNode; + end + else + begin + ThisClass := nil; + ThisTreeNode:= nil; + break; + end + else + break; + end; + FinishElementPage(AClass); +end; + +procedure THTMLWriter.CreateClassInheritanceSubpage(aClass : TPasClassType; AFilter: TMemberFilter); + +var + ThisClass: TPasClassType; + i: Integer; + Member: TPasElement; + TableEl, TREl, TDEl, ParaEl, LinkEl: TDOMElement; +begin + TableEl := CreateTable(ContentElement); + ThisClass := AClass; + while True do + begin TREl := CreateTR(TableEl); TDEl := CreateTD(TREl); - CodeEl := CreateCode(CreatePara(TDEl)); - AppendKw(CodeEl, 'type'); - if AClass.GenericTemplateTypes.Count>0 then - AppendKw(CodeEl, ' generic '); - AppendText(CodeEl, ' ' + UTF8Decode(AClass.Name) + ' '); - if AClass.GenericTemplateTypes.Count>0 then - AppendGenericTypes(CodeEl,AClass.GenericTemplateTypes,false); - AppendSym(CodeEl, '='); - AppendText(CodeEl, ' '); - AppendKw(CodeEl, UTF8Decode(ObjKindNames[AClass.ObjKind])); - - if Assigned(AClass.AncestorType) then - begin - AppendSym(CodeEl, '('); - AppendHyperlink(CodeEl, AClass.AncestorType); - if AClass.Interfaces.count>0 Then - begin - for i:=0 to AClass.interfaces.count-1 do - begin - AppendSym(CodeEl, ', '); - AppendHyperlink(CodeEl,TPasClassType(AClass.Interfaces[i])); - end; - end; - AppendSym(CodeEl, ')'); - end; - CreateMemberDeclarations(AClass, AClass.Members,TableEl, not AClass.IsShortDefinition); - - AppendText(CreateH2(BodyElement), UTF8Decode(SDocInheritance)); - TableEl := CreateTable(BodyElement); - - // Now we are using only TreeClass for show inheritance - - ThisClass := AClass; ThisTreeNode := Nil; - if AClass.ObjKind = okInterface then - ThisTreeNode := TreeInterface.GetPasElNode(AClass) - else - ThisTreeNode := TreeClass.GetPasElNode(AClass); - while True do + TDEl['colspan'] := '3'; + CreateTD(TREl); + LinkEl := AppendHyperlink(CreateEl(CreateCode(CreatePara(TDEl)), 'b'), ThisClass); + if Assigned(LinkEl) then + LinkEl['onClick'] := 'opener.location.href = ''' + LinkEl['href'] + + '''; return false;'; + for i := 0 to ThisClass.Members.Count - 1 do begin + Member := TPasElement(ThisClass.Members[i]); + if Not (Engine.ShowElement(Member) and AFilter(Member)) then + continue; TREl := CreateTR(TableEl); - TDEl := CreateTD_vtop(TREl); - TDEl['align'] := 'center'; - CodeEl := CreateCode(CreatePara(TDEl)); + ParaEl := CreatePara(CreateTD(TREl)); + case Member.Visibility of + visPrivate: + AppendText(ParaEl, 'pv'); + visProtected: + AppendText(ParaEl, 'pt'); + visPublished: + AppendText(ParaEl, 'pl'); + else + end; + AppendNbSp(ParaEl, 1); - // Show class item - if Assigned(ThisClass) Then - AppendHyperlink(CodeEl, ThisClass); - //else - // AppendHyperlink(CodeEl, ThisTreeNode); - // Show links to class interfaces - if Assigned(ThisClass) and (ThisClass.Interfaces.count>0) then - begin - for i:=0 to ThisClass.interfaces.count-1 do - begin - ThisInterface:=TPasClassType(ThisClass.Interfaces[i]); - AppendText(CodeEl,','); - AppendHyperlink(CodeEl, ThisInterface); - end; - end; - // short class description - if Assigned(ThisClass) then - AppendShortDescrCell(TREl, ThisClass); + ParaEl := CreateTD(TREl); + if (Member.ClassType = TPasProperty) and + (Length(TPasProperty(Member).WriteAccessorName) = 0) then + begin + AppendText(ParaEl, 'ro'); + AppendNbSp(ParaEl, 1); + end; - if Assigned(ThisTreeNode) then - if Assigned(ThisTreeNode.ParentNode) then - begin - TDEl := CreateTD(CreateTR(TableEl)); - TDEl['align'] := 'center'; - AppendText(TDEl, '|'); - ThisClass := ThisTreeNode.ParentNode.Element; - ThisTreeNode := ThisTreeNode.ParentNode; - end - else - begin - ThisClass := nil; - ThisTreeNode:= nil; - break; - end - else - break; - end; - FinishElementPage(AClass); - end; - - procedure CreateInheritanceSubpage(AFilter: TMemberFilter); - var - ThisClass: TPasClassType; - i: Integer; - Member: TPasElement; - TableEl, TREl, TDEl, ParaEl, LinkEl: TDOMElement; - begin - TableEl := CreateTable(BodyElement); - ThisClass := AClass; - while True do - begin - TREl := CreateTR(TableEl); - TDEl := CreateTD(TREl); - TDEl['colspan'] := '3'; - CreateTD(TREl); - LinkEl := AppendHyperlink(CreateEl(CreateCode(CreatePara(TDEl)), 'b'), ThisClass); + LinkEl := AppendHyperlink(CreatePara(CreateTD(TREl)), Member); if Assigned(LinkEl) then LinkEl['onClick'] := 'opener.location.href = ''' + LinkEl['href'] + '''; return false;'; + end; + if (not Assigned(ThisClass.AncestorType)) or + (not (ThisClass.AncestorType.ClassType.inheritsfrom(TPasClassType))) then + break; + ThisClass := TPasClassType(ThisClass.AncestorType); + AppendNbSp(CreatePara(CreateTD(CreateTR(TableEl))), 1); + end; +end; + +procedure THTMLWriter.CreateClassSortedSubpage(AClass: TPasClassType; AFilter: TMemberFilter); +var + List: TFPList; + ThisClass: TPasClassType; + i, j: Integer; + Member: TPasElement; + ParaEl, TableEl, TREl, TDEl, LinkEl: TDOMElement; + +begin + List := TFPList.Create; + try + ThisClass := AClass; + while True do + begin for i := 0 to ThisClass.Members.Count - 1 do begin Member := TPasElement(ThisClass.Members[i]); - if Not (Engine.ShowElement(Member) and AFilter(Member)) then - continue; - TREl := CreateTR(TableEl); - ParaEl := CreatePara(CreateTD(TREl)); - case Member.Visibility of - visPrivate: - AppendText(ParaEl, 'pv'); - visProtected: - AppendText(ParaEl, 'pt'); - visPublished: - AppendText(ParaEl, 'pl'); - else - end; - AppendNbSp(ParaEl, 1); - - ParaEl := CreateTD(TREl); - if (Member.ClassType = TPasProperty) and - (Length(TPasProperty(Member).WriteAccessorName) = 0) then + if Engine.ShowElement(Member) and AFilter(Member) then begin - AppendText(ParaEl, 'ro'); - AppendNbSp(ParaEl, 1); + j := 0; + while (j < List.Count) and + (CompareText(TPasElement(List[j]).Name, Member.Name) < 0) do + Inc(j); + List.Insert(j, Member); end; - - LinkEl := AppendHyperlink(CreatePara(CreateTD(TREl)), Member); - if Assigned(LinkEl) then - LinkEl['onClick'] := 'opener.location.href = ''' + LinkEl['href'] + - '''; return false;'; end; if (not Assigned(ThisClass.AncestorType)) or (not (ThisClass.AncestorType.ClassType.inheritsfrom(TPasClassType))) then break; ThisClass := TPasClassType(ThisClass.AncestorType); - AppendNbSp(CreatePara(CreateTD(CreateTR(TableEl))), 1); end; - end; - procedure CreateSortedSubpage(AFilter: TMemberFilter); - var - List: TFPList; - ThisClass: TPasClassType; - i, j: Integer; - Member: TPasElement; - TableEl, TREl, TDEl, ParaEl, LinkEl: TDOMElement; - begin - List := TFPList.Create; - try - ThisClass := AClass; - while True do - begin - for i := 0 to ThisClass.Members.Count - 1 do - begin - Member := TPasElement(ThisClass.Members[i]); - if Engine.ShowElement(Member) and AFilter(Member) then - begin - j := 0; - while (j < List.Count) and - (CompareText(TPasElement(List[j]).Name, Member.Name) < 0) do - Inc(j); - List.Insert(j, Member); - end; - end; - if (not Assigned(ThisClass.AncestorType)) or - (not (ThisClass.AncestorType.ClassType.inheritsfrom(TPasClassType))) then - break; - ThisClass := TPasClassType(ThisClass.AncestorType); + TableEl := CreateTable(ContentElement); + for i := 0 to List.Count - 1 do + begin + Member := TPasElement(List[i]); + TREl := CreateTR(TableEl); + ParaEl := CreatePara(CreateTD(TREl)); + case Member.Visibility of + visPrivate: + AppendText(ParaEl, 'pv'); + visProtected: + AppendText(ParaEl, 'pt'); + visPublished: + AppendText(ParaEl, 'pl'); + else end; + AppendNbSp(ParaEl, 1); - TableEl := CreateTable(BodyElement); - for i := 0 to List.Count - 1 do + ParaEl := CreatePara(CreateTD(TREl)); + if (Member.ClassType = TPasProperty) and + (Length(TPasProperty(Member).WriteAccessorName) = 0) then begin - Member := TPasElement(List[i]); - TREl := CreateTR(TableEl); - ParaEl := CreatePara(CreateTD(TREl)); - case Member.Visibility of - visPrivate: - AppendText(ParaEl, 'pv'); - visProtected: - AppendText(ParaEl, 'pt'); - visPublished: - AppendText(ParaEl, 'pl'); - else - end; + AppendText(ParaEl, 'ro'); AppendNbSp(ParaEl, 1); - - ParaEl := CreatePara(CreateTD(TREl)); - if (Member.ClassType = TPasProperty) and - (Length(TPasProperty(Member).WriteAccessorName) = 0) then - begin - AppendText(ParaEl, 'ro'); - AppendNbSp(ParaEl, 1); - end; - - TDEl := CreateTD(TREl); - TDEl['nowrap'] := 'nowrap'; - ParaEl := CreatePara(TDEl); - LinkEl := AppendHyperlink(ParaEl, Member); - if Assigned(LinkEl) then - LinkEl['onClick'] := 'opener.location.href = ''' + LinkEl['href'] + - '''; return false;'; - AppendText(ParaEl, ' ('); - LinkEl := AppendHyperlink(ParaEl, Member.Parent); - if Assigned(LinkEl) then - LinkEl['onClick'] := 'opener.location.href = ''' + LinkEl['href'] + - '''; return false;'; - AppendText(ParaEl, ')'); end; - finally - List.Free; + + TDEl := CreateTD(TREl); + TDEl['nowrap'] := 'nowrap'; + ParaEl := CreatePara(TDEl); + LinkEl := AppendHyperlink(ParaEl, Member); + if Assigned(LinkEl) then + LinkEl['onClick'] := 'opener.location.href = ''' + LinkEl['href'] + + '''; return false;'; + AppendText(ParaEl, ' ('); + LinkEl := AppendHyperlink(ParaEl, Member.Parent); + if Assigned(LinkEl) then + LinkEl['onClick'] := 'opener.location.href = ''' + LinkEl['href'] + + '''; return false;'; + AppendText(ParaEl, ')'); end; + finally + List.Free; end; +end; + +procedure THTMLWriter.CreateClassPageBody(AClass: TPasClassType; ASubpageIndex: Integer); begin case ASubpageIndex of 0: - CreateMainPage; + CreateClassMainPage(aClass); PropertiesByInheritanceSubindex: - CreateInheritanceSubpage(@PropertyFilter); + CreateClassInheritanceSubpage(aClass,@PropertyFilter); PropertiesByNameSubindex: - CreateSortedSubpage(@PropertyFilter); + CreateClassSortedSubpage(aClass,@PropertyFilter); MethodsByInheritanceSubindex: - CreateInheritanceSubpage(@MethodFilter); + CreateClassInheritanceSubpage(aClass,@MethodFilter); MethodsByNameSubindex: - CreateSortedSubpage(@MethodFilter); + CreateClassSortedSubpage(aClass,@MethodFilter); EventsByInheritanceSubindex: - CreateInheritanceSubpage(@EventFilter); + CreateClassInheritanceSubpage(aClass,@EventFilter); EventsByNameSubindex: - CreateSortedSubpage(@EventFilter); + CreateClassSortedSubpage(aClass,@EventFilter); end; end; @@ -3200,11 +2164,11 @@ var begin AppendMenuBar(-1); AppendTitle(UTF8Decode(AElement.FullName),AElement.Hints); - AppendShortDescr(CreatePara(BodyElement), AElement); - AppendText(CreateH2(BodyElement), SDocDeclaration); - AppendSourceRef(AElement); + AppendShortDescr(CreatePara(ContentElement), AElement); + AppendText(CreateH2(ContentElement), SDocDeclaration); + AppendSourceRef(ContentElement,AElement); - TableEl := CreateTable(BodyElement); + TableEl := CreateTable(ContentElement); TREl := CreateTR(TableEl); CodeEl := CreateCode(CreatePara(CreateTD(TREl))); AppendText(CodeEl, ' '); // !!!: Workaround for current HTML writer @@ -3227,7 +2191,7 @@ begin else if AElement is TPasType then CreateTypePage(TPasType(AElement)) else - AppendText(CreateWarning(BodyElement), '<' + AElement.ClassName + '>'); + AppendText(CreateWarning(ContentElement), '<' + AElement.ClassName + '>'); FinishElementPage(AElement); end; @@ -3238,11 +2202,11 @@ var begin AppendMenuBar(-1); AppendTitle(AVar.FullName,AVar.Hints); - AppendShortDescr(CreatePara(BodyElement), AVar); - AppendText(CreateH2(BodyElement), SDocDeclaration); - AppendSourceRef(AVar); + AppendShortDescr(CreatePara(ContentElement), AVar); + AppendText(CreateH2(ContentElement), SDocDeclaration); + AppendSourceRef(ContentElement,AVar); - TableEl := CreateTable(BodyElement); + TableEl := CreateTable(ContentElement); TREl := CreateTR(TableEl); TDEl := CreateTD(TREl); CodeEl := CreateCode(CreatePara(TDEl)); @@ -3264,16 +2228,18 @@ begin end; procedure THTMLWriter.CreateProcPageBody(AProc: TPasProcedureBase); + var TableEl, TREl, TDEl, CodeEl: TDOMElement; + begin AppendMenuBar(-1); AppendTitle(UTF8Decode(AProc.Name),AProc.Hints); - AppendShortDescr(CreatePara(BodyElement), AProc); - AppendText(CreateH2(BodyElement), SDocDeclaration); - AppendSourceRef(AProc); + AppendShortDescr(CreatePara(ContentElement), AProc); + AppendText(CreateH2(ContentElement), SDocDeclaration); + AppendSourceRef(ContentElement,AProc); - TableEl := CreateTable(BodyElement); + TableEl := CreateTable(ContentElement); TREl := CreateTR(TableEl); TDEl := CreateTD(TREl); CodeEl := CreateCode(CreatePara(TDEl)); @@ -3310,22 +2276,22 @@ begin if Cmd = '--html-search' then SearchPage := Arg else if Cmd = '--footer' then - FooterHTML := ReadFile(Arg) + FFooterHTML := ReadFile(Arg) else if Cmd = '--header' then - HeaderHTML := ReadFile(Arg) + FHeaderHTML := ReadFile(Arg) else if Cmd = '--navigator' then - NavigatorHTML := ReadFile(Arg) + FNavigatorHTML := ReadFile(Arg) else if Cmd = '--charset' then CharSet := Arg else if Cmd = '--index-colcount' then IndexColCount := StrToIntDef(Arg,IndexColCount) else if Cmd = '--image-url' then - FBaseImageURL := Arg + BaseImageURL := Arg else if Cmd = '--css-file' then FCSSFile := arg else if Cmd = '--footer-date' then begin - FIDF:=True; + FIncludeDateInFooter:=True; FDateFormat:=Arg; end else if Cmd = '--disable-menu-brackets' then diff --git a/utils/fpdoc/dw_markdown.pp b/utils/fpdoc/dw_markdown.pp index 93fd04e91f..85cc29ba17 100644 --- a/utils/fpdoc/dw_markdown.pp +++ b/utils/fpdoc/dw_markdown.pp @@ -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. diff --git a/utils/fpdoc/dwriter.pp b/utils/fpdoc/dwriter.pp index ddd7d09539..3d1e2103a9 100644 --- a/utils/fpdoc/dwriter.pp +++ b/utils/fpdoc/dwriter.pp @@ -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; diff --git a/utils/fpdoc/fpdoc.lpi b/utils/fpdoc/fpdoc.lpi index c0fa9a2262..b9c99b0c3f 100644 --- a/utils/fpdoc/fpdoc.lpi +++ b/utils/fpdoc/fpdoc.lpi @@ -46,7 +46,7 @@ - + @@ -130,6 +130,10 @@ + + + + diff --git a/utils/fpdoc/fpdoc.pp b/utils/fpdoc/fpdoc.pp index 0efc47add7..5e789409e1 100644 --- a/utils/fpdoc/fpdoc.pp +++ b/utils/fpdoc/fpdoc.pp @@ -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 From 12adb47d65e06d4d730cbb860c711bb668a94367 Mon Sep 17 00:00:00 2001 From: florian Date: Sun, 3 Jan 2021 15:03:27 +0000 Subject: [PATCH 17/24] * clean up git-svn-id: trunk@48011 - --- compiler/nadd.pas | 4 ---- 1 file changed, 4 deletions(-) diff --git a/compiler/nadd.pas b/compiler/nadd.pas index 4b279b31ed..b7ba6594fc 100644 --- a/compiler/nadd.pas +++ b/compiler/nadd.pas @@ -1381,10 +1381,6 @@ implementation exit; end; - if cs_opt_level1 in current_settings.optimizerswitches then - begin - end; - { slow simplifications and/or more sophisticated transformations which might make debugging harder } if cs_opt_level2 in current_settings.optimizerswitches then begin From 1332915a102f8e7866820466706c371988d8d453 Mon Sep 17 00:00:00 2001 From: marco Date: Sun, 3 Jan 2021 15:21:43 +0000 Subject: [PATCH 18/24] * still add files that start with ., just not to FTS git-svn-id: trunk@48013 - --- utils/fpdoc/dw_chm.pp | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/utils/fpdoc/dw_chm.pp b/utils/fpdoc/dw_chm.pp index f8c2a9fe90..e37076e24b 100644 --- a/utils/fpdoc/dw_chm.pp +++ b/utils/fpdoc/dw_chm.pp @@ -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); - + inherited FileAdded(AStream, AEntry) + else + begin + FTsave:=FullTextSearch; + FullTextSearch:=False; + inherited FileAdded(AStream, AEntry); + FullTextSearch:=FTsave; + end; end; { TCHMHTMLWriter } From 743e7c1c1b262e4759249841f36d12241bd5a252 Mon Sep 17 00:00:00 2001 From: michael Date: Sun, 3 Jan 2021 15:30:41 +0000 Subject: [PATCH 19/24] * Forgot to commit git-svn-id: trunk@48014 - --- .gitattributes | 1 + utils/fpdoc/dw_basehtml.pp | 1060 ++++++++++++++++++++++++++++++++++++ 2 files changed, 1061 insertions(+) create mode 100644 utils/fpdoc/dw_basehtml.pp diff --git a/.gitattributes b/.gitattributes index 12ae660c5b..bcf35c1610 100644 --- a/.gitattributes +++ b/.gitattributes @@ -19296,6 +19296,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 diff --git a/utils/fpdoc/dw_basehtml.pp b/utils/fpdoc/dw_basehtml.pp new file mode 100644 index 0000000000..c0a82aae25 --- /dev/null +++ b/utils/fpdoc/dw_basehtml.pp @@ -0,0 +1,1060 @@ +{ + FPDoc - Free Pascal Documentation Tool + Copyright (C) 2021 by Michael Van Canneyt + + * Basic HTML 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_basehtml; + +{$mode objfpc}{$H+} + +interface + +uses Classes, DOM, DOM_HTML, dGlobals, PasTree, dWriter; + + +type + + { THTMLWriter } + + { TBaseHTMLWriter } + + TBaseHTMLWriter = class(TMultiFileDocWriter) + Private + FImageFileList: TStrings; + FContentElement : THTMLELement; + FInsideHeadRow: Boolean; + FOutputNodeStack: TFPList; + FBaseImageURL : String; + FDoc: THTMLDocument; + FCurOutputNode: TDOMNode; + FDoPasHighlighting : Boolean; + FHighlighterFlags: Byte; + Protected + + Procedure SetContentElement(aElement : THTMLELement); virtual; + // Description node conversion + Procedure DescrEmitNotesHeader(AContext : TPasElement); override; + Procedure DescrEmitNotesFooter(AContext : TPasElement); override; + procedure DescrWriteText(const AText: DOMString); override; + procedure DescrBeginBold; override; + procedure DescrEndBold; override; + procedure DescrBeginItalic; override; + procedure DescrEndItalic; override; + procedure DescrBeginEmph; override; + procedure DescrEndEmph; override; + procedure DescrBeginUnderline; override; + procedure DescrEndUnderline; override; + procedure DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); override; + procedure DescrWriteFileEl(const AText: DOMString); override; + procedure DescrWriteKeywordEl(const AText: DOMString); override; + procedure DescrWriteVarEl(const AText: DOMString); override; + procedure DescrBeginLink(const AId: DOMString); override; + procedure DescrEndLink; override; + procedure DescrBeginURL(const AURL: DOMString); override; + procedure DescrEndURL; override; + procedure DescrWriteLinebreak; override; + procedure DescrBeginParagraph; override; + procedure DescrEndParagraph; override; + procedure DescrBeginCode(HasBorder: Boolean; const AHighlighterName: String); override; + procedure DescrWriteCodeLine(const ALine: String); override; + procedure DescrEndCode; override; + procedure DescrBeginOrderedList; override; + procedure DescrEndOrderedList; override; + procedure DescrBeginUnorderedList; override; + procedure DescrEndUnorderedList; override; + procedure DescrBeginDefinitionList; override; + procedure DescrEndDefinitionList; override; + procedure DescrBeginListItem; override; + procedure DescrEndListItem; override; + procedure DescrBeginDefinitionTerm; override; + procedure DescrEndDefinitionTerm; override; + procedure DescrBeginDefinitionEntry; override; + procedure DescrEndDefinitionEntry; override; + procedure DescrBeginSectionTitle; override; + procedure DescrBeginSectionBody; override; + procedure DescrEndSection; override; + procedure DescrBeginRemark; override; + procedure DescrEndRemark; override; + procedure DescrBeginTable(ColCount: Integer; HasBorder: Boolean); override; + procedure DescrEndTable; override; + procedure DescrBeginTableCaption; override; + procedure DescrEndTableCaption; override; + procedure DescrBeginTableHeadRow; override; + procedure DescrEndTableHeadRow; override; + procedure DescrBeginTableRow; override; + procedure DescrEndTableRow; override; + procedure DescrBeginTableCell; override; + procedure DescrEndTableCell; override; + + // Basic HTML handling + Procedure SetHTMLDocument(aDoc : THTMLDocument); + procedure PushOutputNode(ANode: TDOMNode); + procedure PopOutputNode; + procedure AppendText(Parent: TDOMNode; const AText: String); + procedure AppendText(Parent: TDOMNode; const AText: DOMString); + procedure AppendNbSp(Parent: TDOMNode; ACount: Integer); + procedure AppendSym(Parent: TDOMNode; const AText: DOMString); + procedure AppendKw(Parent: TDOMNode; const AText: String); + procedure AppendKw(Parent: TDOMNode; const AText: DOMString); + function AppendPasSHFragment(Parent: TDOMNode; const AText: String; AShFlags: Byte): Byte; + procedure AppendFragment(aParentNode: TDOMElement; aStream: TStream); + // FPDoc specifics + procedure AppendSourceRef(aParent: TDOMElement; AElement: TPasElement); + Procedure AppendSeeAlsoSection(AElement: TPasElement; DocNode: TDocNode); virtual; + Procedure AppendExampleSection(AElement : TPasElement;DocNode : TDocNode); virtual; + Procedure AppendShortDescr(Parent: TDOMNode; Element: TPasElement); + procedure AppendShortDescr(AContext: TPasElement; Parent: TDOMNode; DocNode: TDocNode); + procedure AppendShortDescrCell(Parent: TDOMNode; Element: TPasElement); + procedure AppendDescr(AContext: TPasElement; Parent: TDOMNode; DescrNode: TDOMElement; AutoInsertBlock: Boolean); + procedure AppendDescrSection(AContext: TPasElement; Parent: TDOMNode; DescrNode: TDOMElement; const ATitle: DOMString); + procedure AppendDescrSection(AContext: TPasElement; Parent: TDOMNode; DescrNode: TDOMElement; const ATitle: String); + function AppendHyperlink(Parent: TDOMNode; Element: TPasElement): TDOMElement; + + // Helper functions for creating DOM elements + + function CreateEl(Parent: TDOMNode; const AName: DOMString): THTMLElement; + function CreatePara(Parent: TDOMNode): THTMLElement; + function CreateH1(Parent: TDOMNode): THTMLElement; + function CreateH2(Parent: TDOMNode): THTMLElement; + function CreateH3(Parent: TDOMNode): THTMLElement; + function CreateTable(Parent: TDOMNode; const AClass: DOMString = ''): THTMLElement; + function CreateContentTable(Parent: TDOMNode): THTMLElement; + function CreateTR(Parent: TDOMNode): THTMLElement; + function CreateTD(Parent: TDOMNode): THTMLElement; + function CreateTD_vtop(Parent: TDOMNode): THTMLElement; + function CreateLink(Parent: TDOMNode; const AHRef: String): THTMLElement; + function CreateLink(Parent: TDOMNode; const AHRef: DOMString): THTMLElement; + function CreateAnchor(Parent: TDOMNode; const AName: DOMString): THTMLElement; + function CreateCode(Parent: TDOMNode): THTMLElement; + function CreateWarning(Parent: TDOMNode): THTMLElement; + + + // Some info + Property ContentElement : THTMLELement Read FContentElement Write SetContentElement; + Property OutputNodeStack: TFPList Read FOutputNodeStack; + Property CurOutputNode : TDomNode Read FCurOutputNode; + Property ImageFileList : TStrings Read FImageFileList; + Property Doc: THTMLDocument Read FDoc; + Property InsideHeadRow: Boolean Read FInsideHeadRow; + Property DoPasHighlighting : Boolean Read FDoPasHighlighting; + Property HighlighterFlags : Byte read FHighlighterFlags; + + Public + constructor Create(APackage: TPasPackage; AEngine: TFPDocEngine); override; + Destructor Destroy; override; + Property BaseImageURL : String Read FBaseImageURL Write FBaseImageURL; + end; + +Function FixHTMLpath(S : String) : STring; + +implementation + +uses xmlread, sysutils, sh_pas; + +Function FixHTMLpath(S : String) : STring; + +begin + Result:=StringReplace(S,'\','/',[rfReplaceAll]); +end; + +constructor TBaseHTMLWriter.Create(APackage: TPasPackage; AEngine: TFPDocEngine); + +begin + Inherited; + FOutputNodeStack := TFPList.Create; + FImageFileList:=TStringList.Create; +end; + +destructor TBaseHTMLWriter.Destroy; +begin + FreeAndNil(FOutputNodeStack); + FreeAndNil(FImageFileList); + inherited Destroy; +end; + +Procedure TBaseHTMLWriter.SetContentElement(aElement : THTMLELement); + +begin + FContentElement:=aElement; +end; + +function TBaseHTMLWriter.CreateEl(Parent: TDOMNode; + const AName: DOMString): THTMLElement; +begin + Result := Doc.CreateElement(AName); + Parent.AppendChild(Result); +end; + +function TBaseHTMLWriter.CreatePara(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(Parent, 'p'); +end; + +function TBaseHTMLWriter.CreateH1(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(Parent, 'h1'); +end; + +function TBaseHTMLWriter.CreateH2(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(Parent, 'h2'); +end; + +function TBaseHTMLWriter.CreateH3(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(Parent, 'h3'); +end; + +function TBaseHTMLWriter.CreateTable(Parent: TDOMNode; const AClass: DOMString = ''): THTMLElement; +begin + Result := CreateEl(Parent, 'table'); + Result['cellspacing'] := '0'; + Result['cellpadding'] := '0'; + if AClass <> '' then + Result['class'] := AClass; +end; + +function TBaseHTMLWriter.CreateContentTable(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(Parent, 'table'); +end; + +function TBaseHTMLWriter.CreateTR(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(Parent, 'tr'); +end; + +function TBaseHTMLWriter.CreateTD(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(Parent, 'td'); +end; + +function TBaseHTMLWriter.CreateTD_vtop(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(Parent, 'td'); + Result['valign'] := 'top'; +end; + +function TBaseHTMLWriter.CreateLink(Parent: TDOMNode; const AHRef: String): THTMLElement; +begin + Result := CreateEl(Parent, 'a'); + Result['href'] := UTF8Decode(FixHtmlPath(AHRef)); +end; + +function TBaseHTMLWriter.CreateLink(Parent: TDOMNode; + const AHRef: DOMString): THTMLElement; +begin + Result:=CreateLink(Parent,UTF8Encode(aHREf)); +end; + +function TBaseHTMLWriter.CreateAnchor(Parent: TDOMNode; + const AName: DOMString): THTMLElement; +begin + Result := CreateEl(Parent, 'a'); + Result['name'] := AName; +end; + +function TBaseHTMLWriter.CreateCode(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(CreateEl(Parent, 'tt'), 'span'); + Result['class'] := 'code'; +end; + +function TBaseHTMLWriter.CreateWarning(Parent: TDOMNode): THTMLElement; +begin + Result := CreateEl(Parent, 'span'); + Result['class'] := 'warning'; +end; + +procedure TBaseHTMLWriter.DescrEmitNotesHeader(AContext: TPasElement); +begin + AppendText(CreateH2(ContentElement), SDocNotes); + PushOutputNode(ContentElement); +end; + +procedure TBaseHTMLWriter.DescrEmitNotesFooter(AContext: TPasElement); +begin + PopOutPutNode; +end; + +procedure TBaseHTMLWriter.PushOutputNode(ANode: TDOMNode); +begin + OutputNodeStack.Add(CurOutputNode); + FCurOutputNode := ANode; +end; + +procedure TBaseHTMLWriter.PopOutputNode; +begin + FCurOutputNode := TDOMNode(OutputNodeStack[OutputNodeStack.Count - 1]); + OutputNodeStack.Delete(OutputNodeStack.Count - 1); +end; + +procedure TBaseHTMLWriter.DescrWriteText(const AText: DOMString); +begin + AppendText(CurOutputNode, AText); +end; + +procedure TBaseHTMLWriter.DescrBeginBold; +begin + PushOutputNode(CreateEl(CurOutputNode, 'b')); +end; + +procedure TBaseHTMLWriter.DescrEndBold; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginItalic; +begin + PushOutputNode(CreateEl(CurOutputNode, 'i')); +end; + +procedure TBaseHTMLWriter.DescrEndItalic; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginEmph; +begin + PushOutputNode(CreateEl(CurOutputNode, 'em')); +end; + +procedure TBaseHTMLWriter.DescrEndEmph; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginUnderline; +begin + PushOutputNode(CreateEl(CurOutputNode, 'u')); +end; + +procedure TBaseHTMLWriter.DescrEndUnderline; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrWriteImageEl(const AFileName, ACaption, ALinkName : DOMString); + +Var + Pel,Cel: TDOMNode; + El :TDomElement; + D : String; + L : Integer; + +begin + // Determine parent node. + If (ACaption='') then + Pel:=CurOutputNode + else + begin + Cel:=CreateTable(CurOutputNode, 'imagetable'); + Pel:=CreateTD(CreateTR(Cel)); + Cel:=CreateTD(CreateTR(Cel)); + El := CreateEl(Cel, 'span'); + El['class'] := 'imagecaption'; + Cel := El; + If (ALinkName<>'') then + Cel:=CreateAnchor(Cel,ALinkName); + AppendText(Cel,ACaption); + end; + + // Determine URL for image. + If (Module=Nil) then + D:=Allocator.GetRelativePathToTop(Package) + else + D:=Allocator.GetRelativePathToTop(Module); + L:=Length(D); + If (L>0) and (D[L]<>'/') then + D:=D+'/'; + + // Create image node. + El:=CreateEl(Pel,'img'); + EL['src']:=UTF8Decode(D + BaseImageURL) + AFileName; + El['alt']:=ACaption; + + //cache image filename, so it can be used later (CHM) + ImageFileList.Add(UTF8Encode(UTF8Decode(BaseImageURL) + AFileName)); +end; + +procedure TBaseHTMLWriter.DescrWriteFileEl(const AText: DOMString); +var + NewEl: TDOMElement; +begin + NewEl := CreateEl(CurOutputNode, 'span'); + NewEl['class'] := 'file'; + AppendText(NewEl, AText); +end; + +procedure TBaseHTMLWriter.DescrWriteKeywordEl(const AText: DOMString); +var + NewEl: TDOMElement; +begin + NewEl := CreateEl(CurOutputNode, 'span'); + NewEl['class'] := 'kw'; + AppendText(NewEl, AText); +end; + +procedure TBaseHTMLWriter.DescrWriteVarEl(const AText: DOMString); +begin + AppendText(CreateEl(CurOutputNode, 'var'), AText); +end; + +procedure TBaseHTMLWriter.DescrBeginLink(const AId: DOMString); +var + a,s,n : String; + +begin + a:=UTF8Encode(AId); + s := UTF8Encode(ResolveLinkID(a)); + if Length(s) = 0 then + begin + if assigned(module) then + s:=module.name + else + s:='?'; + if a='' then a:=''; + if Assigned(CurrentContext) then + N:=CurrentContext.Name + else + N:='?'; + DoLog(SErrUnknownLinkID, [s,n,a]); + PushOutputNode(CreateEl(CurOutputNode, 'b')); + end else + PushOutputNode(CreateLink(CurOutputNode, s)); +end; + +procedure TBaseHTMLWriter.DescrEndLink; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginURL(const AURL: DOMString); +begin + PushOutputNode(CreateLink(CurOutputNode, AURL)); +end; + +procedure TBaseHTMLWriter.DescrEndURL; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrWriteLinebreak; +begin + CreateEl(CurOutputNode, 'br'); +end; + +procedure TBaseHTMLWriter.DescrBeginParagraph; +begin + PushOutputNode(CreatePara(CurOutputNode)); +end; + +procedure TBaseHTMLWriter.DescrEndParagraph; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginCode(HasBorder: Boolean; const AHighlighterName: String); +begin + FDoPasHighlighting := (AHighlighterName = '') or (AHighlighterName = 'Pascal'); + FHighlighterFlags := 0; + PushOutputNode(CreateEl(CurOutputNode, 'pre')); +end; + +procedure TBaseHTMLWriter.DescrWriteCodeLine(const ALine: String); +begin + if DoPasHighlighting then + begin + FHighlighterFlags := AppendPasSHFragment(CurOutputNode, ALine,FHighlighterFlags); + AppendText(CurOutputNode, #10); + end else + AppendText(CurOutputNode, ALine + #10); +end; + +procedure TBaseHTMLWriter.DescrEndCode; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginOrderedList; +begin + PushOutputNode(CreateEl(CurOutputNode, 'ol')); +end; + +procedure TBaseHTMLWriter.DescrEndOrderedList; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginUnorderedList; +begin + PushOutputNode(CreateEl(CurOutputNode, 'ul')); +end; + +procedure TBaseHTMLWriter.DescrEndUnorderedList; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginDefinitionList; +begin + PushOutputNode(CreateEl(CurOutputNode, 'dl')); +end; + +procedure TBaseHTMLWriter.DescrEndDefinitionList; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginListItem; +begin + PushOutputNode(CreateEl(CurOutputNode, 'li')); +end; + +procedure TBaseHTMLWriter.DescrEndListItem; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginDefinitionTerm; +begin + PushOutputNode(CreateEl(CurOutputNode, 'dt')); +end; + +procedure TBaseHTMLWriter.DescrEndDefinitionTerm; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginDefinitionEntry; +begin + PushOutputNode(CreateEl(CurOutputNode, 'dd')); +end; + +procedure TBaseHTMLWriter.DescrEndDefinitionEntry; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginSectionTitle; +begin + PushOutputNode(CreateEl(CurOutputNode, 'h3')); +end; + +procedure TBaseHTMLWriter.DescrBeginSectionBody; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrEndSection; +begin +end; + +procedure TBaseHTMLWriter.DescrBeginRemark; +var + NewEl, TDEl: TDOMElement; +begin + NewEl := CreateEl(CurOutputNode, 'table'); + NewEl['width'] := '100%'; + NewEl['border'] := '0'; + NewEl['CellSpacing'] := '0'; + NewEl['class'] := 'remark'; + NewEl := CreateTR(NewEl); + TDEl := CreateTD(NewEl); + TDEl['valign'] := 'top'; + TDEl['class'] := 'pre'; + AppendText(CreateEl(TDEl, 'b'), SDocRemark); + PushOutputNode(CreateTD(NewEl)); +end; + +procedure TBaseHTMLWriter.DescrEndRemark; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginTable(ColCount: Integer; HasBorder: Boolean); +var + Table: TDOMElement; +begin + Table := CreateEl(CurOutputNode, 'table'); + Table['border'] := UTF8Decode(IntToStr(Ord(HasBorder))); + PushOutputNode(Table); +end; + +procedure TBaseHTMLWriter.DescrEndTable; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginTableCaption; +begin + PushOutputNode(CreateEl(CurOutputNode, 'caption')); +end; + +procedure TBaseHTMLWriter.DescrEndTableCaption; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginTableHeadRow; +begin + PushOutputNode(CreateTr(CurOutputNode)); + FInsideHeadRow := True; +end; + +procedure TBaseHTMLWriter.DescrEndTableHeadRow; +begin + FInsideHeadRow := False; + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginTableRow; +begin + PushOutputNode(CreateTR(CurOutputNode)); +end; + +procedure TBaseHTMLWriter.DescrEndTableRow; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.DescrBeginTableCell; +begin + if InsideHeadRow then + PushOutputNode(CreateEl(CurOutputNode, 'th')) + else + PushOutputNode(CreateTD(CurOutputNode)); +end; + +procedure TBaseHTMLWriter.DescrEndTableCell; +begin + PopOutputNode; +end; + +procedure TBaseHTMLWriter.SetHTMLDocument(aDoc: THTMLDocument); +begin + FDoc:=aDoc; + FOutputNodeStack.Clear; + FCurOutputNode:=Nil; +end; + +procedure TBaseHTMLWriter.AppendText(Parent: TDOMNode; const AText: String); +begin + AppendText(Parent,UTF8Decode(aText)); +end; + + +procedure TBaseHTMLWriter.AppendText(Parent: TDOMNode; const AText: DOMString); +begin + Parent.AppendChild(Doc.CreateTextNode(AText)); +end; + +procedure TBaseHTMLWriter.AppendNbSp(Parent: TDOMNode; ACount: Integer); +begin + while ACount > 0 do + begin + Parent.AppendChild(Doc.CreateEntityReference('nbsp')); + Dec(ACount); + end; +end; + +procedure TBaseHTMLWriter.AppendSym(Parent: TDOMNode; const AText: DOMString); +var + El: TDOMElement; +begin + El := CreateEl(Parent, 'span'); + El['class'] := 'sym'; + AppendText(El, AText); +end; + +procedure TBaseHTMLWriter.AppendKw(Parent: TDOMNode; const AText: String); +begin + AppendKW(Parent,UTF8Decode(aText)); +end; + +procedure TBaseHTMLWriter.AppendKw(Parent: TDOMNode; const AText: DOMString); +var + El: TDOMElement; +begin + El := CreateEl(Parent, 'span'); + El['class'] := 'kw'; + AppendText(El, AText); +end; + +function TBaseHTMLWriter.AppendPasSHFragment(Parent: TDOMNode; + const AText: String; AShFlags: Byte): Byte; + + +var + Line, Last, p: PChar; + El: TDOMElement; + + Procedure MaybeOutput; + + Var + CurParent: TDomNode; + + begin + If (Last<>Nil) then + begin + If (el<>Nil) then + CurParent:=El + else + CurParent:=Parent; + AppendText(CurParent,Last); + El:=Nil; + Last:=Nil; + end; + end; + + Function NewEl(Const ElType,Attr,AttrVal : DOMString) : TDomElement; + + begin + Result:=CreateEl(Parent,ElType); + Result[Attr]:=AttrVal; + end; + + Function NewSpan(Const AttrVal : DOMString) : TDomElement; + + begin + Result:=CreateEl(Parent,'span'); + Result['class']:=AttrVal; + end; + +begin + GetMem(Line, Length(AText) * 3 + 4); + Try + DoPascalHighlighting(AShFlags, PChar(AText), Line); + Result := AShFlags; + Last := Nil; + p := Line; + el:=nil; + while p[0] <> #0 do + begin + if p[0] = LF_ESCAPE then + begin + p[0] := #0; + MaybeOutput; + case Ord(p[1]) of + shDefault: El:=Nil; + shInvalid: El:=newel('font','color','red'); + shSymbol : El:=newspan('sym'); + shKeyword: El:=newspan('kw'); + shComment: El:=newspan('cmt'); + shDirective: El:=newspan('dir'); + shNumbers: El:=newspan('num'); + shCharacters: El:=newspan('chr'); + shStrings: El:=newspan('str'); + shAssembler: El:=newspan('asm'); + end; + Inc(P); + end + else If (Last=Nil) then + Last:=P; + Inc(p); + end; + MaybeOutput; + Finally + FreeMem(Line); + end; +end; + + +procedure TBaseHTMLWriter.AppendSeeAlsoSection ( AElement: TPasElement; + DocNode: TDocNode ) ; + +var + Node: TDOMNode; + TableEl, El, TREl, ParaEl, NewEl, DescrEl: TDOMElement; + l,s,n: DOMString; + IsFirstSeeAlso : Boolean; + +begin + if Not (Assigned(DocNode) and Assigned(DocNode.SeeAlso)) then + Exit; + IsFirstSeeAlso := True; + Node:=DocNode.SeeAlso.FirstChild; + While Assigned(Node) do + begin + if (Node.NodeType=ELEMENT_NODE) and (Node.NodeName='link') then + begin + if IsFirstSeeAlso then + begin + IsFirstSeeAlso := False; + AppendText(CreateH2(ContentElement), SDocSeeAlso); + TableEl := CreateTable(ContentElement); + end; + El:=TDOMElement(Node); + TREl:=CreateTR(TableEl); + ParaEl:=CreatePara(CreateTD_vtop(TREl)); + l:=El['id']; + s:= ResolveLinkID(UTF8ENcode(l)); + if Length(s)=0 then + begin + if assigned(module) then + s:=UTF8Decode(module.name) + else + s:='?'; + if l='' then l:=''; + if Assigned(AElement) then + N:=UTF8Decode(AElement.Name) + else + N:='?'; + DoLog(SErrUnknownLinkID, [s,N,l]); + NewEl := CreateEl(ParaEl,'b') + end + else + NewEl := CreateLink(ParaEl,s); + if Not IsDescrNodeEmpty(El) then + begin + PushOutputNode(NewEl); + Try + ConvertBaseShortList(AElement, El, True) + Finally + PopOutputNode; + end; + end + else + AppendText(NewEl,El['id']); + l:=El['id']; + DescrEl := Engine.FindShortDescr(AElement.GetModule,UTF8Encode(L)); + if Assigned(DescrEl) then + begin + AppendNbSp(CreatePara(CreateTD(TREl)), 2); + ParaEl := CreatePara(CreateTD(TREl)); + ParaEl['class'] := 'cmt'; + PushOutputNode(ParaEl); + try + ConvertShort(AElement, DescrEl); + finally + PopOutputNode; + end; + end; + end; // Link node + Node := Node.NextSibling; + end; // While +end; + +procedure TBaseHTMLWriter.AppendExampleSection ( AElement: TPasElement; DocNode: TDocNode ) ; + +var + Node: TDOMNode; + fn,s: String; + f: Text; + +begin + if not (Assigned(DocNode) and Assigned(DocNode.FirstExample)) then + Exit; + Node := DocNode.FirstExample; + while Assigned(Node) do + begin + if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'example') then + begin + fn:=Engine.GetExampleFilename(TDOMElement(Node)); + If (fn<>'') then + begin + AppendText(CreateH2(ContentElement), SDocExample); + try + Assign(f, FN); + Reset(f); + try + PushOutputNode(ContentElement); + DescrBeginCode(False, UTF8Encode(TDOMElement(Node)['highlighter'])); + while not EOF(f) do + begin + ReadLn(f, s); + DescrWriteCodeLine(s); + end; + DescrEndCode; + PopOutputNode; + finally + Close(f); + end; + except + on e: Exception do + begin + e.Message := '[example] ' + e.Message; + raise; + end; + end; + end; + end; + Node := Node.NextSibling; + end; +end; + +procedure TBaseHTMLWriter.AppendFragment(aParentNode : TDOMElement; aStream : TStream); + +begin + if (aStream<>Nil) then + begin + aStream.Position:=0; + ReadXMLFragment(aParentNode,aStream); + end; +end; + +procedure TBaseHTMLWriter.AppendShortDescr ( AContext: TPasElement; + Parent: TDOMNode; DocNode: TDocNode ) ; + +Var + N : TDocNode; + +begin + if Assigned(DocNode) then + begin + If (DocNode.Link<>'') then + begin + N:=Engine.FindLinkedNode(DocNode); + If (N<>Nil) then + DocNode:=N; + end; + If Assigned(DocNode.ShortDescr) then + begin + PushOutputNode(Parent); + try + if not ConvertShort(AContext,TDomElement(DocNode.ShortDescr)) then + Warning(AContext, SErrInvalidShortDescr) + finally + PopOutputNode; + end; + end; + end; +end; + +procedure TBaseHTMLWriter.AppendShortDescr(Parent: TDOMNode; Element: TPasElement); + +begin + AppendShortDescr(Element,Parent,Engine.FindDocNode(Element)); +end; + +procedure TBaseHTMLWriter.AppendShortDescrCell(Parent: TDOMNode; Element: TPasElement); + +var + ParaEl: TDOMElement; + +begin + if Assigned(Engine.FindShortDescr(Element)) then + begin + AppendNbSp(CreatePara(CreateTD(Parent)), 2); + ParaEl := CreatePara(CreateTD(Parent)); + ParaEl['class'] := 'cmt'; + AppendShortDescr(ParaEl, Element); + end; +end; + +procedure TBaseHTMLWriter.AppendDescr(AContext: TPasElement; Parent: TDOMNode; + DescrNode: TDOMElement; AutoInsertBlock: Boolean); +begin + if Assigned(DescrNode) then + begin + PushOutputNode(Parent); + try + ConvertDescr(AContext, DescrNode, AutoInsertBlock); + finally + PopOutputNode; + end; + end; +end; + +procedure TBaseHTMLWriter.AppendDescrSection(AContext: TPasElement; Parent: TDOMNode; DescrNode: TDOMElement; const ATitle: String); +begin + AppendDescrSection(aContext,Parent,DescrNode,UTF8Decode(aTitle)); +end; + +procedure TBaseHTMLWriter.AppendDescrSection(AContext: TPasElement; + Parent: TDOMNode; DescrNode: TDOMElement; const ATitle: DOMString); +begin + if not IsDescrNodeEmpty(DescrNode) then + begin + If (ATitle<>'') then // Can be empty for topic. + AppendText(CreateH2(Parent), ATitle); + AppendDescr(AContext, Parent, DescrNode, True); + end; +end; + +function TBaseHTMLWriter.AppendHyperlink(Parent: TDOMNode; Element: TPasElement): TDOMElement; +var + s: DOMString; + UnitList: TFPList; + i: Integer; + ThisPackage: TLinkNode; +begin + if Not Assigned(Element) then + begin + Result := nil; + AppendText(CreateWarning(Parent), ''); + end; + if Element.InheritsFrom(TPasUnresolvedTypeRef) then + begin + s := ResolveLinkID(Element.Name); + if Length(s) = 0 then + begin + { Try all packages } + ThisPackage := Engine.RootLinkNode.FirstChild; + while Assigned(ThisPackage) do + begin + s := ResolveLinkID(ThisPackage.Name + '.' + Element.Name); + if Length(s) > 0 then + break; + ThisPackage := ThisPackage.NextSibling; + end; + if Length(s) = 0 then + begin + { Okay, then we have to try all imported units of the current module } + UnitList := Module.InterfaceSection.UsesList; + for i := UnitList.Count - 1 downto 0 do + begin + { Try all packages } + ThisPackage := Engine.RootLinkNode.FirstChild; + while Assigned(ThisPackage) do + begin + s := ResolveLinkID(ThisPackage.Name + '.' + + TPasType(UnitList[i]).Name + '.' + Element.Name); + if Length(s) > 0 then + break; + ThisPackage := ThisPackage.NextSibling; + end; + if length(s)=0 then + s := ResolveLinkID('#rtl.System.' + Element.Name); + if Length(s) > 0 then + break; + end; + end; + end; + end + else if Element is TPasEnumValue then + s := ResolveLinkID(Element.Parent.PathName) + else + s := ResolveLinkID(Element.PathName); + + if Length(s) > 0 then + begin + Result := CreateLink(Parent, s); + AppendText(Result, Element.Name); + end + else + begin + Result := nil; + AppendText(Parent, Element.Name); // unresolved items + end; +end; + +procedure TBaseHTMLWriter.AppendSourceRef(aParent : TDOMElement; AElement: TPasElement); + +begin + AppendText(CreatePara(aParent), Format(SDocSourcePosition, + [ExtractFileName(AElement.SourceFilename), AElement.SourceLinenumber])); +end; + + +end. + From 9592c033e51063a1d36be454e17abcc2b5ff3b98 Mon Sep 17 00:00:00 2001 From: florian Date: Sun, 3 Jan 2021 17:08:58 +0000 Subject: [PATCH 20/24] * process fma intrinsic parameters in an order which takes care of multiple x87 stack parameters, resolves #38295 git-svn-id: trunk@48017 - --- .gitattributes | 1 + compiler/x86/nx86inl.pas | 4 +++- tests/webtbs/tw38295.pp | 19 +++++++++++++++++++ 3 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 tests/webtbs/tw38295.pp diff --git a/.gitattributes b/.gitattributes index bcf35c1610..7fbcab1ab4 100644 --- a/.gitattributes +++ b/.gitattributes @@ -18630,6 +18630,7 @@ 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/tw3833.pp svneol=native#text/plain tests/webtbs/tw3840.pp svneol=native#text/plain tests/webtbs/tw3841.pp svneol=native#text/plain diff --git a/compiler/x86/nx86inl.pas b/compiler/x86/nx86inl.pas index 2f40bfba22..1b9c174d44 100644 --- a/compiler/x86/nx86inl.pas +++ b/compiler/x86/nx86inl.pas @@ -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 diff --git a/tests/webtbs/tw38295.pp b/tests/webtbs/tw38295.pp new file mode 100644 index 0000000000..eb3eab25ba --- /dev/null +++ b/tests/webtbs/tw38295.pp @@ -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. From 3362abb30c9eee50eab4181333c3a99b866c8633 Mon Sep 17 00:00:00 2001 From: pierre Date: Sun, 3 Jan 2021 21:44:18 +0000 Subject: [PATCH 21/24] * Set softfloat_rounding_mode indise SetRoundMode function for all CPUs. * SetRoundMode returns previous rounding mode value for all CPUs. git-svn-id: trunk@48018 - --- rtl/aarch64/mathu.inc | 2 +- rtl/arm/mathu.inc | 3 ++- rtl/i386/mathu.inc | 1 + rtl/i8086/mathu.inc | 1 + rtl/m68k/mathu.inc | 2 +- rtl/mips/mathu.inc | 1 + rtl/powerpc/mathu.inc | 2 +- rtl/powerpc64/mathu.inc | 2 +- rtl/riscv64/mathu.inc | 2 +- rtl/sparc/mathu.inc | 1 + rtl/sparc64/mathu.inc | 1 + rtl/x86_64/mathu.inc | 1 + rtl/xtensa/mathu.inc | 1 + tests/test/units/math/trndcurr.pp | 17 +++++++++++++++-- 14 files changed, 29 insertions(+), 8 deletions(-) diff --git a/rtl/aarch64/mathu.inc b/rtl/aarch64/mathu.inc index 469bb49eca..f55471e963 100644 --- a/rtl/aarch64/mathu.inc +++ b/rtl/aarch64/mathu.inc @@ -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; diff --git a/rtl/arm/mathu.inc b/rtl/arm/mathu.inc index 038ec6f220..c7fa2a1c60 100644 --- a/rtl/arm/mathu.inc +++ b/rtl/arm/mathu.inc @@ -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; diff --git a/rtl/i386/mathu.inc b/rtl/i386/mathu.inc index a1ba0970d1..ab0361cc34 100644 --- a/rtl/i386/mathu.inc +++ b/rtl/i386/mathu.inc @@ -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 diff --git a/rtl/i8086/mathu.inc b/rtl/i8086/mathu.inc index 237ecf0300..4229183064 100644 --- a/rtl/i8086/mathu.inc +++ b/rtl/i8086/mathu.inc @@ -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 diff --git a/rtl/m68k/mathu.inc b/rtl/m68k/mathu.inc index a3c656b4bc..1dd65451df 100644 --- a/rtl/m68k/mathu.inc +++ b/rtl/m68k/mathu.inc @@ -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; diff --git a/rtl/mips/mathu.inc b/rtl/mips/mathu.inc index 8a4be08746..9f8e9aa616 100644 --- a/rtl/mips/mathu.inc +++ b/rtl/mips/mathu.inc @@ -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; diff --git a/rtl/powerpc/mathu.inc b/rtl/powerpc/mathu.inc index 7d204f341b..372ec4c2e4 100644 --- a/rtl/powerpc/mathu.inc +++ b/rtl/powerpc/mathu.inc @@ -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; diff --git a/rtl/powerpc64/mathu.inc b/rtl/powerpc64/mathu.inc index 4e3a62b8b9..12247e0b68 100644 --- a/rtl/powerpc64/mathu.inc +++ b/rtl/powerpc64/mathu.inc @@ -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; diff --git a/rtl/riscv64/mathu.inc b/rtl/riscv64/mathu.inc index 1c0f48bfeb..8dfb273a0a 100644 --- a/rtl/riscv64/mathu.inc +++ b/rtl/riscv64/mathu.inc @@ -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; diff --git a/rtl/sparc/mathu.inc b/rtl/sparc/mathu.inc index 9749147f82..50d00a1abb 100644 --- a/rtl/sparc/mathu.inc +++ b/rtl/sparc/mathu.inc @@ -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; diff --git a/rtl/sparc64/mathu.inc b/rtl/sparc64/mathu.inc index 43f2010a41..b8d4d70870 100644 --- a/rtl/sparc64/mathu.inc +++ b/rtl/sparc64/mathu.inc @@ -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; diff --git a/rtl/x86_64/mathu.inc b/rtl/x86_64/mathu.inc index 1271828161..955a01de5c 100644 --- a/rtl/x86_64/mathu.inc +++ b/rtl/x86_64/mathu.inc @@ -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} diff --git a/rtl/xtensa/mathu.inc b/rtl/xtensa/mathu.inc index 06b7338fa7..381a7d00df 100644 --- a/rtl/xtensa/mathu.inc +++ b/rtl/xtensa/mathu.inc @@ -20,6 +20,7 @@ function GetRoundMode: TFPURoundingMode; function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode; begin + SetRoundMode:=softfloat_rounding_mode; softfloat_rounding_mode:=RoundMode; end; diff --git a/tests/test/units/math/trndcurr.pp b/tests/test/units/math/trndcurr.pp index 1c198789eb..92012e636a 100644 --- a/tests/test/units/math/trndcurr.pp +++ b/tests/test/units/math/trndcurr.pp @@ -1,13 +1,20 @@ 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; @@ -31,7 +38,11 @@ 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 + end; testround(0.5,1.0,5); testround(1.5,2.0,6); testround(-0.5,0.0,7); @@ -75,4 +86,6 @@ begin testround(-0.4,0.0,165); testround(-1.4,-1.0,166); {$endif} + if failure_count>0 then + halt(first_error); end. From 57861c934d5830f9187b2a06bb8b6c1dd781ab8b Mon Sep 17 00:00:00 2001 From: pierre Date: Sun, 3 Jan 2021 21:55:35 +0000 Subject: [PATCH 22/24] Check also that SetRoundMode returns correctly previous rounding mode git-svn-id: trunk@48019 - --- tests/test/units/math/trndcurr.pp | 35 ++++++++++++++++++++++++++++--- 1 file changed, 32 insertions(+), 3 deletions(-) diff --git a/tests/test/units/math/trndcurr.pp b/tests/test/units/math/trndcurr.pp index 92012e636a..8db85c120a 100644 --- a/tests/test/units/math/trndcurr.pp +++ b/tests/test/units/math/trndcurr.pp @@ -23,6 +23,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); @@ -42,6 +49,10 @@ begin 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); @@ -57,7 +68,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); @@ -72,7 +91,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); @@ -86,6 +113,8 @@ begin testround(-0.4,0.0,165); testround(-1.4,-1.0,166); {$endif} - if failure_count>0 then + if failure_count=0 then + writeln('SetRoundMode test finished OK') + else halt(first_error); end. From f2568e37e422b9767766ef686ff77c8b3e9b04ad Mon Sep 17 00:00:00 2001 From: pierre Date: Sun, 3 Jan 2021 22:03:27 +0000 Subject: [PATCH 23/24] Add testing for single float type in trndmode.pp git-svn-id: trunk@48020 - --- tests/test/units/math/trndcurr.pp | 106 ++++++++++++++++++++++++++++++ 1 file changed, 106 insertions(+) diff --git a/tests/test/units/math/trndcurr.pp b/tests/test/units/math/trndcurr.pp index 8db85c120a..a98728160c 100644 --- a/tests/test/units/math/trndcurr.pp +++ b/tests/test/units/math/trndcurr.pp @@ -17,6 +17,20 @@ begin 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; {$endif} @@ -112,6 +126,98 @@ begin testround(1.4,1.0,164); 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') From 7d5b0d23827e124da3eab2f39fe6cd52673ff4c4 Mon Sep 17 00:00:00 2001 From: florian Date: Sun, 3 Jan 2021 22:55:37 +0000 Subject: [PATCH 24/24] * handle rawbytestrings in Win32Ansi2UnicodeMove properly, resolves #38299 git-svn-id: trunk@48021 - --- .gitattributes | 1 + rtl/win/syswin.inc | 8 ++++++++ tests/webtbs/tw38299.pp | 15 +++++++++++++++ 3 files changed, 24 insertions(+) create mode 100644 tests/webtbs/tw38299.pp diff --git a/.gitattributes b/.gitattributes index 7fbcab1ab4..1e20795141 100644 --- a/.gitattributes +++ b/.gitattributes @@ -18631,6 +18631,7 @@ 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 diff --git a/rtl/win/syswin.inc b/rtl/win/syswin.inc index 63ee752569..f79b9849cd 100644 --- a/rtl/win/syswin.inc +++ b/rtl/win/syswin.inc @@ -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 diff --git a/tests/webtbs/tw38299.pp b/tests/webtbs/tw38299.pp new file mode 100644 index 0000000000..8c52902b48 --- /dev/null +++ b/tests/webtbs/tw38299.pp @@ -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.