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

# revisions: 45519,46865,46918

Browse Source 
git-svn-id: branches/fixes_3_2@47095 -
This commit is contained in:
marco 2020-10-11 15:53:29 +00:00
parent 124bf1d108
commit 2b9ddf3bee
10 changed files with 234 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -14617,6 +14617,7 @@ tests/test/tisorec1.pp svneol=native#text/pascal
tests/test/tisorec2.pp svneol=native#text/pascal
tests/test/tisorec3.pp svneol=native#text/pascal
tests/test/tisorec4.pp svneol=native#text/pascal
tests/test/tisorec5.pp svneol=native#text/pascal
tests/test/tlea1.pp svneol=native#text/plain
tests/test/tlea2.pp svneol=native#text/plain
tests/test/tlib1a.pp svneol=native#text/plain
@ -16054,6 +16055,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
@ -17688,6 +17690,7 @@ tests/webtbs/tw3700.pp svneol=native#text/plain
tests/webtbs/tw37013.pp svneol=native#text/plain
tests/webtbs/tw37060.pp svneol=native#text/plain
tests/webtbs/tw3708.pp svneol=native#text/plain
tests/webtbs/tw37085.pp svneol=native#text/pascal
tests/webtbs/tw37095.pp svneol=native#text/plain
tests/webtbs/tw37095d/uw37095.pp svneol=native#text/plain
tests/webtbs/tw37154.pp svneol=native#text/pascal
@ -17698,6 +17701,7 @@ tests/webtbs/tw37322.pp svneol=native#text/pascal
tests/webtbs/tw37323.pp svneol=native#text/pascal
tests/webtbs/tw37355.pp svneol=native#text/pascal
tests/webtbs/tw37397.pp svneol=native#text/plain
tests/webtbs/tw37415.pp svneol=native#text/plain
tests/webtbs/tw3742.pp svneol=native#text/plain
tests/webtbs/tw3751.pp svneol=native#text/plain
tests/webtbs/tw3758.pp svneol=native#text/plain

106
compiler/ngenutil.pas
View File

@ -105,9 +105,9 @@ interface
class procedure insertbsssym(list: tasmlist; sym: tstaticvarsym; size: asizeint; varalign: shortint); 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;
@ -533,49 +533,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;
@ -607,9 +641,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;

101
compiler/pinline.pas
View File

@ -74,8 +74,60 @@ implementation
storepos : tfileposinfo;
variantdesc : pvariantrecdesc;
found : boolean;
j,i : longint;
variantselectsymbol : tfieldvarsym;
procedure ReadVariantRecordConstants;
var
i,j : longint;
begin
if (([m_iso,m_extpas]*current_settings.modeswitches)<>[]) and (is_record(tpointerdef(p.resultdef).pointeddef)) then
begin
variantdesc:=trecorddef(tpointerdef(p.resultdef).pointeddef).variantrecdesc;
while (token=_COMMA) and assigned(variantdesc) do
begin
consume(_COMMA);
p2:=factor(false,[]);
do_typecheckpass(p2);
if p2.nodetype=ordconstn then
begin
found:=false;
{ we do not have dynamic dfa, so avoid warning on variantselectsymbol below }
variantselectsymbol:=nil;
for i:=0 to high(variantdesc^.branches) do
begin
for j:=0 to high(variantdesc^.branches[i].values) do
if variantdesc^.branches[i].values[j]=tordconstnode(p2).value then
begin
found:=true;
variantselectsymbol:=tfieldvarsym(variantdesc^.variantselector);
variantdesc:=variantdesc^.branches[i].nestedvariant;
break;
end;
if found then
break;
end;
if found then
begin
if is_new then
begin
{ if no tag-field is given, do not create an assignment statement for it }
if assigned(variantselectsymbol) then
{ setup variant selector }
addstatement(newstatement,cassignmentnode.create(
csubscriptnode.create(variantselectsymbol,
cderefnode.create(ctemprefnode.create(temp))),
p2));
end;
end
else
Message(parser_e_illegal_expression);
end
else
Message(parser_e_illegal_expression);
end;
end;
end;
begin
if target_info.system in systems_managed_vm then
message(parser_e_feature_unsupported_for_vm);
@ -345,49 +397,8 @@ implementation
p,
ctemprefnode.create(temp)));
if (([m_iso,m_extpas]*current_settings.modeswitches)<>[]) and (is_record(tpointerdef(p.resultdef).pointeddef)) then
begin
variantdesc:=trecorddef(tpointerdef(p.resultdef).pointeddef).variantrecdesc;
while (token=_COMMA) and assigned(variantdesc) do
begin
consume(_COMMA);
p2:=factor(false,[]);
do_typecheckpass(p2);
if p2.nodetype=ordconstn then
begin
found:=false;
{ we do not have dynamic dfa, so avoid warning on variantselectsymbol below }
variantselectsymbol:=nil;
for i:=0 to high(variantdesc^.branches) do
begin
for j:=0 to high(variantdesc^.branches[i].values) do
if variantdesc^.branches[i].values[j]=tordconstnode(p2).value then
begin
found:=true;
variantselectsymbol:=tfieldvarsym(variantdesc^.variantselector);
variantdesc:=variantdesc^.branches[i].nestedvariant;
break;
end;
if found then
break;
end;
if found then
begin
{ if no tag-field is given, do not create an assignment statement for it }
if assigned(variantselectsymbol) then
{ setup variant selector }
addstatement(newstatement,cassignmentnode.create(
csubscriptnode.create(variantselectsymbol,
cderefnode.create(ctemprefnode.create(temp))),
p2));
end
else
Message(parser_e_illegal_expression);
end
else
Message(parser_e_illegal_expression);
end;
end;
ReadVariantRecordConstants;
{ release temp }
addstatement(newstatement,ctempdeletenode.create(temp));
end
@ -406,6 +417,8 @@ implementation
else
addstatement(newstatement,cnodeutils.finalize_data_node(cderefnode.create(p.getcopy)));
ReadVariantRecordConstants;
{ create call to fpc_freemem }
if not assigned(temp) then
para := ccallparanode.create(p,nil)

5
rtl/inc/compproc.inc
View File

@ -810,6 +810,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}

6
rtl/inc/iso7185.pp
View File

@ -206,8 +206,10 @@ unit iso7185;
procedure Get(var f:TypedFile);[IOCheck];
Begin
if not(eof(f)) then
BlockRead(f,(pbyte(@f)+sizeof(FileRec))^,1);
if not(system.eof(f)) then
BlockRead(f,(pbyte(@f)+sizeof(FileRec))^,1)
else
FileRec(f)._private[1]:=1;
End;

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;

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

@ -0,0 +1,25 @@
{$mode iso}
type
tr = record
l : longint;
case i : integer of
1 : (s : array[0..255] of char);
2 : (n : integer);
3 : (w : word; case j : integer of
1 : (t : array[0..255] of char);
2 : (a : integer);
);
end;
pr = ^tr;
var
r : pr;
begin
new(r,3,2);
if r^.i<>3 then
halt(1);
if r^.j<>2 then
halt(1);
dispose(r,3,2);
writeln('ok');
end.

1
tests/webtbs/DAT_TW37415 Normal file
View File

@ -0,0 +1 @@
1234

18
tests/webtbs/tw37085.pp Normal file
View File

@ -0,0 +1,18 @@
{$mode iso}
type
v = ^x;
x = record
n: Integer;
case b: Boolean OF
True: (x0: Real);
False: (x1, x2: Integer)
end;
var
a: v;
begin
New(a, True);
Dispose(a, True);
end.

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.