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

* ISO mode: handle typed files as text files regarding naming/program parameters, resolves #37415

Browse Source 
git-svn-id: trunk@46865 -
This commit is contained in:
florian 2020-09-14 20:16:08 +00:00
parent 1eb11a2a29
commit f8c1df0852
6 changed files with 128 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -16718,6 +16718,7 @@ tests/webtbf/uw4541.pp svneol=native#text/pascal
tests/webtbf/uw6922.pp svneol=native#text/plain
tests/webtbf/uw8738a.pas svneol=native#text/plain
tests/webtbf/uw8738b.pas svneol=native#text/plain
tests/webtbs/DAT_TW37415 svneol=native#text/plain
tests/webtbs/Integer.ns.pp svneol=native#text/pascal
tests/webtbs/Integer.pp svneol=native#text/pascal
tests/webtbs/tu2002.pp svneol=native#text/plain
@ -18437,6 +18438,7 @@ tests/webtbs/tw37393.pp svneol=native#text/pascal
tests/webtbs/tw37397.pp svneol=native#text/plain
tests/webtbs/tw37398.pp svneol=native#text/pascal
tests/webtbs/tw37400.pp svneol=native#text/pascal
tests/webtbs/tw37415.pp svneol=native#text/plain
tests/webtbs/tw3742.pp svneol=native#text/plain
tests/webtbs/tw37423.pp svneol=native#text/plain
tests/webtbs/tw37427.pp svneol=native#text/pascal

106
compiler/ngenutil.pas
View File

@ -105,9 +105,9 @@ interface
class procedure insertbsssym(list: tasmlist; sym: tstaticvarsym; size: asizeint; varalign: shortint; _typ: Tasmsymtype); virtual;
{ initialization of iso styled program parameters }
class procedure initialize_textrec(p : TObject; statn : pointer);
class procedure initialize_filerecs(p : TObject; statn : pointer);
{ finalization of iso styled program parameters }
class procedure finalize_textrec(p : TObject; statn : pointer);
class procedure finalize_filerecs(p : TObject; statn : pointer);
public
class procedure insertbssdata(sym : tstaticvarsym); virtual;
@ -546,49 +546,83 @@ implementation
end;
class procedure tnodeutils.initialize_textrec(p:TObject;statn:pointer);
class procedure tnodeutils.initialize_filerecs(p:TObject;statn:pointer);
var
stat: ^tstatementnode absolute statn;
begin
if (tsym(p).typ=staticvarsym) and
(tstaticvarsym(p).vardef.typ=filedef) and
(tfiledef(tstaticvarsym(p).vardef).filetyp=ft_text) and
(tstaticvarsym(p).isoindex<>0) then
begin
if cs_transparent_file_names in current_settings.globalswitches then
addstatement(stat^,ccallnode.createintern('fpc_textinit_filename_iso',
ccallparanode.create(
cstringconstnode.createstr(tstaticvarsym(p).Name),
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)))))
else
addstatement(stat^,ccallnode.createintern('fpc_textinit_iso',
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil))));
end;
(tstaticvarsym(p).vardef.typ=filedef) and
(tstaticvarsym(p).isoindex<>0) then
case tfiledef(tstaticvarsym(p).vardef).filetyp of
ft_text:
begin
if cs_transparent_file_names in current_settings.globalswitches then
addstatement(stat^,ccallnode.createintern('fpc_textinit_filename_iso',
ccallparanode.create(
cstringconstnode.createstr(tstaticvarsym(p).Name),
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)))))
else
addstatement(stat^,ccallnode.createintern('fpc_textinit_iso',
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil))));
end;
ft_typed:
begin
if cs_transparent_file_names in current_settings.globalswitches then
addstatement(stat^,ccallnode.createintern('fpc_typedfile_init_filename_iso',
ccallparanode.create(
cstringconstnode.createstr(tstaticvarsym(p).Name),
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)))))
else
addstatement(stat^,ccallnode.createintern('fpc_typedfile_init_iso',
ccallparanode.create(
cordconstnode.create(tstaticvarsym(p).isoindex,uinttype,false),
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil))));
end;
else
;
end;
end;
class procedure tnodeutils.finalize_textrec(p:TObject;statn:pointer);
class procedure tnodeutils.finalize_filerecs(p:TObject;statn:pointer);
var
stat: ^tstatementnode absolute statn;
begin
if (tsym(p).typ=staticvarsym) and
(tstaticvarsym(p).vardef.typ=filedef) and
(tfiledef(tstaticvarsym(p).vardef).filetyp=ft_text) and
(tstaticvarsym(p).isoindex<>0) then
begin
addstatement(stat^,ccallnode.createintern('fpc_textclose_iso',
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)));
end;
(tstaticvarsym(p).vardef.typ=filedef) and
(tstaticvarsym(p).isoindex<>0) then
case tfiledef(tstaticvarsym(p).vardef).filetyp of
ft_text:
begin
addstatement(stat^,ccallnode.createintern('fpc_textclose_iso',
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)));
end;
ft_typed:
begin
addstatement(stat^,ccallnode.createintern('fpc_typedfile_close_iso',
ccallparanode.create(
cloadnode.create(tstaticvarsym(p),tstaticvarsym(p).Owner),
nil)));
end;
else
;
end;
end;
@ -637,9 +671,9 @@ implementation
(pd.proctypeoption=potype_proginit) then
begin
block:=internalstatements(stat);
pd.localst.SymList.ForEachCall(@initialize_textrec,@stat);
pd.localst.SymList.ForEachCall(@initialize_filerecs,@stat);
addstatement(stat,result);
pd.localst.SymList.ForEachCall(@finalize_textrec,@stat);
pd.localst.SymList.ForEachCall(@finalize_filerecs,@stat);
result:=block;
end;

5
rtl/inc/compproc.inc
View File

@ -806,6 +806,11 @@ Procedure fpc_rewrite_typed_name_iso(var f : TypedFile;const FileName : String;S
Procedure fpc_typed_write(TypeSize : Longint;var f : TypedFile;const Buf); compilerproc;
Procedure fpc_typed_read(TypeSize : Longint;var f : TypedFile;out Buf); compilerproc;
Procedure fpc_typed_read_iso(TypeSize : Longint;var f : TypedFile;out Buf); compilerproc;
Procedure fpc_typedfile_init_iso(var t : TypedFile;nr : DWord);compilerproc;
Procedure fpc_typedfile_init_filename_iso(var t : TypedFile;nr : DWord;const filename : string); compilerproc;
Procedure fpc_typedfile_close_iso(var t : TypedFile); compilerproc;
{$endif FPC_HAS_FEATURE_FILEIO}
{$ifdef FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE}

41
rtl/inc/typefile.inc
View File

@ -199,3 +199,44 @@ Begin
Result:=pbyte(@f)+sizeof(TypedFile);
end;
Procedure fpc_typedfile_init_iso(var t : TypedFile;nr : DWord);compilerproc;
begin
{$ifdef FPC_HAS_FEATURE_COMMANDARGS}
assign(t,paramstr(nr));
{$else FPC_HAS_FEATURE_COMMANDARGS}
{ primitive workaround for targets supporting no command line arguments,
invent some file name, try to avoid complex procedures like concating strings which might
pull-in bigger parts of the rtl }
assign(t,chr((nr mod 16)+65));
{$endif FPC_HAS_FEATURE_COMMANDARGS}
end;
Procedure fpc_typedfile_init_filename_iso(var t : TypedFile;nr : DWord;const filename : string);compilerproc;
begin
{$ifdef FPC_HAS_FEATURE_COMMANDARGS}
if paramstr(nr)='' then
assign(t,filename)
else
assign(t,paramstr(nr));
{$else FPC_HAS_FEATURE_COMMANDARGS}
{ primitive workaround for targets supporting no command line arguments,
invent some file name, try to avoid complex procedures like concating strings which might
pull-in bigger parts of the rtl }
assign(t,chr((nr mod 16)+65));
{$endif FPC_HAS_FEATURE_COMMANDARGS}
end;
Procedure fpc_typedfile_close_iso(var t : TypedFile);compilerproc;
begin
{ reset inout result as this procedure is only called by the compiler and no I/O checking is carried out,
so further I/O does not fail }
inoutres:=0;
close(t);
inoutres:=0;
end;

1
tests/webtbs/DAT_TW37415 Normal file
View File

@ -0,0 +1 @@
1234

9
tests/webtbs/tw37415.pp Normal file
View File

@ -0,0 +1,9 @@
{ %OPT=-Miso -Sr }
{ %FILES=DAT_TW37415 }
program fileTest(dat_tw37415);
var
dat_tw37415: file of integer;
begin
reset(dat_tw37415);
end.