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

* va_list -> array of const

Browse Source
This commit is contained in:
peter 1998-11-10 10:09:08 +00:00
parent 2b9d08c912
commit 0353e61e9b
9 changed files with 284 additions and 160 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
compiler/cg386cal.pas
View File

@ -152,8 +152,13 @@ implementation
getlabel(truelabel);
getlabel(falselabel);
secondpass(p^.left);
{ filter array constructor with c styled args }
if is_array_constructor(p^.left^.resulttype) and p^.left^.cargs then
begin
{ nothing, everything is already pushed }
end
{ in codegen.handleread.. defcoll^.data is set to nil }
if assigned(defcoll^.data) and
else if assigned(defcoll^.data) and
(defcoll^.data^.deftype=formaldef) then
begin
{ allow @var }
@ -173,8 +178,7 @@ implementation
end
else
begin
if (defcoll^.paratyp<>vs_va_list) and
not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
if not(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
CGMessage(type_e_mismatch)
else
begin
@ -640,12 +644,7 @@ implementation
falselabel:=oflabel;
{ push from right to left }
if not push_from_left_to_right and assigned(p^.right) then
begin
if defcoll^.paratyp=vs_va_list then
secondcallparan(p^.right,defcoll,push_from_left_to_right,inlined,para_offset)
else
secondcallparan(p^.right,defcoll^.next,push_from_left_to_right,inlined,para_offset);
end;
secondcallparan(p^.right,defcoll^.next,push_from_left_to_right,inlined,para_offset);
end;
@ -1521,7 +1520,10 @@ implementation
end.
{
$Log$
Revision 1.39 1998-11-09 11:44:33 peter
Revision 1.40 1998-11-10 10:09:08 peter
* va_list -> array of const
Revision 1.39 1998/11/09 11:44:33 peter
+ va_list for printf support
Revision 1.38 1998/10/21 15:12:49 pierre

97
compiler/cg386ld.pas
View File

@ -49,7 +49,7 @@ implementation
cobjects,verbose,globals,systems,
symtable,aasm,types,
hcodegen,temp_gen,pass_2,
cgai386,tgeni386;
cgai386,tgeni386,cg386cnv;
{*****************************************************************************
SecondLoad
@ -585,6 +585,7 @@ implementation
LOC_CREGISTER : begin
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
t.register,newreference(ref))));
ungetregister32(t.register); { the register is not needed anymore }
end;
LOC_MEM,
LOC_REFERENCE : begin
@ -598,6 +599,29 @@ implementation
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
R_EDI,newreference(ref))));
end;
ungetiftemp(t.reference);
end;
else
internalerror(330);
end;
end;
procedure emit_push_loc(const t:tlocation);
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,t.register)));
ungetregister32(t.register); { the register is not needed anymore }
end;
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.isintvalue then
exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,t.reference.offset)))
else
exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,newreference(t.reference))));
ungetiftemp(t.reference);
end;
else
internalerror(330);
@ -622,7 +646,6 @@ implementation
end;
procedure emit_lea_loc_ref(const t:tlocation;const ref:treference);
begin
case t.loc of
@ -637,6 +660,28 @@ implementation
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
R_EDI,newreference(ref))));
end;
ungetiftemp(t.reference);
end;
else
internalerror(332);
end;
end;
procedure emit_push_lea_loc(const t:tlocation);
begin
case t.loc of
LOC_MEM,
LOC_REFERENCE : begin
if t.reference.isintvalue then
internalerror(331)
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
newreference(t.reference),R_EDI)));
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDI)));
end;
ungetiftemp(t.reference);
end;
else
internalerror(332);
@ -652,10 +697,13 @@ implementation
vaddr : boolean;
vtype : longint;
begin
clear_reference(p^.location.reference);
gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*8,p^.location.reference);
if not p^.cargs then
begin
clear_reference(p^.location.reference);
gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*8,p^.location.reference);
href:=p^.location.reference;
end;
hp:=p;
href:=p^.location.reference;
while assigned(hp) do
begin
secondpass(hp^.left);
@ -706,19 +754,33 @@ implementation
end;
if vtype=$ff then
internalerror(14357);
{ update href to the vtype field and write it }
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,
vtype,newreference(href))));
inc(href.offset,4);
{ write changing field update href to the next element }
if vaddr then
{ write C style pushes or an pascal array }
if p^.cargs then
begin
emit_to_reference(hp^.left);
emit_lea_loc_ref(hp^.left^.location,href)
if vaddr then
begin
emit_to_reference(hp^.left);
emit_push_lea_loc(hp^.left^.location);
end
else
emit_push_loc(hp^.left^.location);
end
else
emit_mov_loc_ref(hp^.left^.location,href);
inc(href.offset,4);
begin
{ update href to the vtype field and write it }
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,
vtype,newreference(href))));
inc(href.offset,4);
{ write changing field update href to the next element }
if vaddr then
begin
emit_to_reference(hp^.left);
emit_lea_loc_ref(hp^.left^.location,href);
end
else
emit_mov_loc_ref(hp^.left^.location,href);
inc(href.offset,4);
end;
{ load next entry }
hp:=hp^.right;
end;
@ -728,7 +790,10 @@ implementation
end.
{
$Log$
Revision 1.25 1998-11-05 12:02:35 peter
Revision 1.26 1998-11-10 10:09:10 peter
* va_list -> array of const
Revision 1.25 1998/11/05 12:02:35 peter
* released useansistring
* removed -Sv, its now available in fpc modes

9
compiler/parser.pas
View File

@ -157,7 +157,7 @@ unit parser;
oldaktoutputformat : tasm;
oldaktoptprocessor : tprocessors;
oldaktasmmode : tasmmode;
oldaktmodeswitches : tmodeswitches;
{$ifdef USEEXCEPT}
recoverpos : jmp_buf;
oldrecoverpos : pjmp_buf;
@ -209,6 +209,7 @@ unit parser;
oldaktoptprocessor:=aktoptprocessor;
oldaktasmmode:=aktasmmode;
oldaktfilepos:=aktfilepos;
oldaktmodeswitches:=aktmodeswitches;
{ show info }
Message1(parser_i_compiling,filename);
@ -371,6 +372,7 @@ unit parser;
aktoptprocessor:=oldaktoptprocessor;
aktasmmode:=oldaktasmmode;
aktfilepos:=oldaktfilepos;
aktmodeswitches:=oldaktmodeswitches;
end;
{ Shut down things when the last file is compiled }
if (compile_level=1) then
@ -422,7 +424,10 @@ unit parser;
end.
{
$Log$
Revision 1.60 1998-10-28 18:26:14 pierre
Revision 1.61 1998-11-10 10:09:11 peter
* va_list -> array of const
Revision 1.60 1998/10/28 18:26:14 pierre
* removed some erros after other errors (introduced by useexcept)
* stabs works again correctly (for how long !)

7
compiler/symdefh.inc
View File

@ -94,7 +94,7 @@
targconvtyp = (act_convertable,act_equal,act_exact);
tvarspez = (vs_value,vs_const,vs_var,vs_va_list);
tvarspez = (vs_value,vs_const,vs_var);
pdefcoll = ^tdefcoll;
tdefcoll = record
@ -483,7 +483,10 @@
{
$Log$
Revision 1.8 1998-11-09 11:44:37 peter
Revision 1.9 1998-11-10 10:09:14 peter
* va_list -> array of const
Revision 1.8 1998/11/09 11:44:37 peter
+ va_list for printf support
Revision 1.7 1998/11/05 12:02:59 peter

240
compiler/tccal.pas
View File

@ -66,12 +66,7 @@ implementation
if defcoll=nil then
firstcallparan(p^.right,nil)
else
begin
if defcoll^.paratyp=vs_va_list then
firstcallparan(p^.right,defcoll)
else
firstcallparan(p^.right,defcoll^.next);
end;
firstcallparan(p^.right,defcoll^.next);
p^.registers32:=p^.right^.registers32;
p^.registersfpu:=p^.right^.registersfpu;
{$ifdef SUPPORT_MMX}
@ -97,12 +92,12 @@ implementation
{ conversions are inserted }
else
begin
if count_ref then
if count_ref then
begin
store_valid:=must_be_valid;
if (defcoll^.paratyp=vs_var) then
test_protected(p^.left);
if not(defcoll^.paratyp in [vs_var,vs_va_list]) then
if (defcoll^.paratyp<>vs_var) then
must_be_valid:=true
else
must_be_valid:=false;
@ -158,10 +153,22 @@ implementation
) and
not(is_equal(p^.left^.resulttype,defcoll^.data))) then
CGMessage(parser_e_call_by_ref_without_typeconv);
{ process cargs arrayconstructor }
if is_array_constructor(p^.left^.resulttype) and
(aktcallprocsym^.definition^.options and pocdecl<>0) and
(aktcallprocsym^.definition^.options and poexternal<>0) then
begin
p^.left^.cargs:=true;
old_array_constructor:=allow_array_constructor;
allow_array_constructor:=true;
firstpass(p^.left);
allow_array_constructor:=old_array_constructor;
end;
{ don't generate an type conversion for open arrays }
{ else we loss the ranges }
if is_open_array(defcoll^.data) then
begin
{ insert type conv but hold the ranges of the array }
oldtype:=p^.left^.resulttype;
p^.left:=gentypeconvnode(p^.left,defcoll^.data);
firstpass(p^.left);
@ -185,15 +192,8 @@ implementation
(defcoll^.paratyp=vs_var) and
not(is_equal(p^.left^.resulttype,defcoll^.data)) then
CGMessage(type_e_strict_var_string_violation);
{ va_list always uses pchars }
if (defcoll^.paratyp=vs_va_list) and
is_shortstring(p^.left^.resulttype) then
begin
p^.left:=gentypeconvnode(p^.left,charpointerdef);
firstpass(p^.left);
end;
{ Variablen, die call by reference <20>bergeben werden, }
{ k”nnen nicht in ein Register kopiert werden }
{ Variablen for call by reference may not be copied }
{ into a register }
{ is this usefull here ? }
{ this was missing in formal parameter list }
if defcoll^.paratyp=vs_var then
@ -202,8 +202,7 @@ implementation
make_not_regable(p^.left);
end;
if defcoll^.paratyp<>vs_va_list then
p^.resulttype:=defcoll^.data;
p^.resulttype:=defcoll^.data;
end;
if p^.left^.registers32>p^.registers32 then
p^.registers32:=p^.left^.registers32;
@ -233,7 +232,7 @@ implementation
var
hp,procs,hp2 : pprocdefcoll;
pd : pprocdef;
actprocsym : pprocsym;
oldcallprocsym : pprocsym;
nextprocsym : pprocsym;
def_from,def_to,conv_to : pdef;
pt,inlinecode : ptree;
@ -300,6 +299,9 @@ implementation
store_valid:=must_be_valid;
must_be_valid:=false;
oldcallprocsym:=aktcallprocsym;
aktcallprocsym:=nil;
inlined:=false;
if assigned(p^.procdefinition) and
((p^.procdefinition^.options and poinline)<>0) then
@ -381,10 +383,11 @@ implementation
exit;
end;
aktcallprocsym:=pprocsym(p^.symtableprocentry);
{ do we know the procedure to call ? }
if not(assigned(p^.procdefinition)) then
begin
actprocsym:=pprocsym(p^.symtableprocentry);
{$ifdef TEST_PROCSYMS}
if (p^.unit_specific) or
assigned(p^.methodpointer) then
@ -422,7 +425,7 @@ implementation
end;
{ link all procedures which have the same # of parameters }
pd:=actprocsym^.definition;
pd:=aktcallprocsym^.definition;
while assigned(pd) do
begin
{ we should also check that the overloaded function
@ -447,7 +450,7 @@ implementation
pdc:=pdc^.next;
end;
{ only when the # of parameter are equal }
if (l=paralength) or ((l=1) and (pd^.para1^.paratyp=vs_va_list)) then
if (l=paralength) then
begin
new(hp);
hp^.data:=pd;
@ -467,102 +470,97 @@ implementation
(nextprocsym=nil) then
begin
CGMessage(parser_e_wrong_parameter_size);
actprocsym^.write_parameter_lists;
aktcallprocsym^.write_parameter_lists;
exit;
end;
{ now we can compare parameter after parameter }
if assigned(procs) and
(not assigned(procs^.nextpara) or
(procs^.nextpara^.paratyp<>vs_va_list)) then
begin
pt:=p^.left;
while assigned(pt) do
begin
{ matches a parameter of one procedure exact ? }
exactmatch:=false;
hp:=procs;
while assigned(hp) do
begin
if is_equal(hp^.nextpara^.data,pt^.resulttype) then
begin
if hp^.nextpara^.data=pt^.resulttype then
begin
pt^.exact_match_found:=true;
hp^.nextpara^.argconvtyp:=act_exact;
end
else
hp^.nextpara^.argconvtyp:=act_equal;
exactmatch:=true;
end
else
hp^.nextpara^.argconvtyp:=act_convertable;
hp:=hp^.next;
end;
{ now we can compare parameter after parameter }
pt:=p^.left;
while assigned(pt) do
begin
{ matches a parameter of one procedure exact ? }
exactmatch:=false;
hp:=procs;
while assigned(hp) do
begin
if is_equal(hp^.nextpara^.data,pt^.resulttype) then
begin
if hp^.nextpara^.data=pt^.resulttype then
begin
pt^.exact_match_found:=true;
hp^.nextpara^.argconvtyp:=act_exact;
end
else
hp^.nextpara^.argconvtyp:=act_equal;
exactmatch:=true;
end
else
hp^.nextpara^.argconvtyp:=act_convertable;
hp:=hp^.next;
end;
{ .... if yes, del all the other procedures }
if exactmatch then
begin
{ the first .... }
while (assigned(procs)) and not(is_equal(procs^.nextpara^.data,pt^.resulttype)) do
begin
hp:=procs^.next;
dispose(procs);
procs:=hp;
end;
{ and the others }
hp:=procs;
while (assigned(hp)) and assigned(hp^.next) do
begin
if not(is_equal(hp^.next^.nextpara^.data,pt^.resulttype)) then
begin
hp2:=hp^.next^.next;
dispose(hp^.next);
hp^.next:=hp2;
end
else
hp:=hp^.next;
end;
end
{ when a parameter matches exact, remove all procs
which need typeconvs }
else
begin
{ the first... }
while (assigned(procs)) and
not(isconvertable(pt^.resulttype,procs^.nextpara^.data,
hcvt,pt^.left^.treetype,false)) do
begin
hp:=procs^.next;
dispose(procs);
procs:=hp;
end;
{ and the others }
hp:=procs;
while (assigned(hp)) and assigned(hp^.next) do
begin
if not(isconvertable(pt^.resulttype,hp^.next^.nextpara^.data,
hcvt,pt^.left^.treetype,false)) then
begin
hp2:=hp^.next^.next;
dispose(hp^.next);
hp^.next:=hp2;
end
else
hp:=hp^.next;
end;
end;
{ update nextpara for all procedures }
hp:=procs;
while assigned(hp) do
begin
hp^.nextpara:=hp^.nextpara^.next;
hp:=hp^.next;
end;
{ load next parameter }
pt:=pt^.right;
end;
end;
{ .... if yes, del all the other procedures }
if exactmatch then
begin
{ the first .... }
while (assigned(procs)) and not(is_equal(procs^.nextpara^.data,pt^.resulttype)) do
begin
hp:=procs^.next;
dispose(procs);
procs:=hp;
end;
{ and the others }
hp:=procs;
while (assigned(hp)) and assigned(hp^.next) do
begin
if not(is_equal(hp^.next^.nextpara^.data,pt^.resulttype)) then
begin
hp2:=hp^.next^.next;
dispose(hp^.next);
hp^.next:=hp2;
end
else
hp:=hp^.next;
end;
end
{ when a parameter matches exact, remove all procs
which need typeconvs }
else
begin
{ the first... }
while (assigned(procs)) and
not(isconvertable(pt^.resulttype,procs^.nextpara^.data,
hcvt,pt^.left^.treetype,false)) do
begin
hp:=procs^.next;
dispose(procs);
procs:=hp;
end;
{ and the others }
hp:=procs;
while (assigned(hp)) and assigned(hp^.next) do
begin
if not(isconvertable(pt^.resulttype,hp^.next^.nextpara^.data,
hcvt,pt^.left^.treetype,false)) then
begin
hp2:=hp^.next^.next;
dispose(hp^.next);
hp^.next:=hp2;
end
else
hp:=hp^.next;
end;
end;
{ update nextpara for all procedures }
hp:=procs;
while assigned(hp) do
begin
hp^.nextpara:=hp^.nextpara^.next;
hp:=hp^.next;
end;
{ load next parameter }
pt:=pt^.right;
end;
if not assigned(procs) then
begin
@ -572,7 +570,7 @@ implementation
(nextprocsym=nil) then
begin
CGMessage(parser_e_wrong_parameter_type);
actprocsym^.write_parameter_lists;
aktcallprocsym^.write_parameter_lists;
exit;
end
else
@ -698,7 +696,7 @@ implementation
if assigned(procs^.next) then
begin
CGMessage(cg_e_cant_choose_overload_function);
actprocsym^.write_parameter_lists;
aktcallprocsym^.write_parameter_lists;
end;
{$ifdef TEST_PROCSYMS}
if (procs=nil) and assigned(nextprocsym) then
@ -736,7 +734,7 @@ implementation
p^.methodpointer:=nil;
end;
{$endif CHAINPROCSYMS}
end;{ end of procedure to call determination }
end; { end of procedure to call determination }
is_const:=((p^.procdefinition^.options and pointernconst)<>0) and
((block_type=bt_const) or
@ -923,6 +921,7 @@ implementation
end;
if assigned(procs) then
dispose(procs);
aktcallprocsym:=oldcallprocsym;
must_be_valid:=store_valid;
end;
@ -942,7 +941,10 @@ implementation
end.
{
$Log$
Revision 1.10 1998-11-09 11:44:41 peter
Revision 1.11 1998-11-10 10:09:17 peter
* va_list -> array of const
Revision 1.10 1998/11/09 11:44:41 peter
+ va_list for printf support
Revision 1.9 1998/10/28 18:26:22 pierre

30
compiler/tcld.pas
View File

@ -340,6 +340,8 @@ implementation
procedure firstarrayconstruct(var p : ptree);
var
pd : pdef;
thp,
chp,
hp : ptree;
len : longint;
varia : boolean;
@ -366,6 +368,13 @@ implementation
hp^.left:=gentypeconvnode(hp^.left,s80floatdef);
firstpass(hp^.left);
end;
stringdef : begin
if p^.cargs then
begin
hp^.left:=gentypeconvnode(hp^.left,charpointerdef);
firstpass(hp^.left);
end;
end;
end;
if (pd=nil) then
pd:=hp^.left^.resulttype
@ -375,6 +384,22 @@ implementation
inc(len);
hp:=hp^.right;
end;
{ swap the tree for cargs }
if p^.cargs and (not p^.cargswap) then
begin
chp:=nil;
hp:=p;
while assigned(hp) do
begin
thp:=hp^.right;
hp^.right:=chp;
chp:=hp;
hp:=thp;
end;
p:=chp;
p^.cargs:=true;
p^.cargswap:=true;
end;
end;
calcregisters(p,0,0,0);
p^.resulttype:=new(parraydef,init(0,len-1,pd));
@ -398,7 +423,10 @@ implementation
end.
{
$Log$
Revision 1.7 1998-11-05 14:26:48 peter
Revision 1.8 1998-11-10 10:09:18 peter
* va_list -> array of const
Revision 1.7 1998/11/05 14:26:48 peter
* fixed variant warning with was sometimes said with sets
Revision 1.6 1998/10/19 08:55:12 pierre

7
compiler/token.inc
View File

@ -149,7 +149,6 @@ type
_LIBRARY,
_PRIVATE,
_PROGRAM,
_VA_LIST,
_VIRTUAL,
_ABSOLUTE,
_ABSTRACT,
@ -308,7 +307,6 @@ const
(str:'LIBRARY' ;special:false;keyword:m_all),
(str:'PRIVATE' ;special:false;keyword:m_none),
(str:'PROGRAM' ;special:false;keyword:m_all),
(str:'VA_LIST' ;special:false;keyword:m_fpc),
(str:'VIRTUAL' ;special:false;keyword:m_none),
(str:'ABSOLUTE' ;special:false;keyword:m_none),
(str:'ABSTRACT' ;special:false;keyword:m_none),
@ -336,7 +334,10 @@ const
{
$Log$
Revision 1.4 1998-11-09 11:44:42 peter
Revision 1.5 1998-11-10 10:09:19 peter
* va_list -> array of const
Revision 1.4 1998/11/09 11:44:42 peter
+ va_list for printf support
Revision 1.3 1998/10/16 14:21:05 daniel

6
compiler/tree.pas
View File

@ -228,6 +228,7 @@ unit tree;
labeln,goton : (labelnr : plabel);
withn : (withsymtable : psymtable;tablecount : longint);
onn : (exceptsymtable : psymtable;excepttype : pobjectdef);
arrayconstructn : (cargs,cargswap: boolean);
end;
function gennode(t : ttreetyp;l,r : ptree) : ptree;
@ -1601,7 +1602,10 @@ unit tree;
end.
{
$Log$
Revision 1.49 1998-11-05 12:03:07 peter
Revision 1.50 1998-11-10 10:09:20 peter
* va_list -> array of const
Revision 1.49 1998/11/05 12:03:07 peter
* released useansistring
* removed -Sv, its now available in fpc modes

26
compiler/types.pas
View File

@ -49,22 +49,25 @@ unit types;
{ true if p points to an open array def }
function is_open_array(p : pdef) : boolean;
{ true if o is an ansi string def }
{ true, if p points to an array of const def }
function is_array_constructor(p : pdef) : boolean;
{ true if p is an ansi string def }
function is_ansistring(p : pdef) : boolean;
{ true if o is a long string def }
{ true if p is a long string def }
function is_longstring(p : pdef) : boolean;
{ true if o is a wide string def }
{ true if p is a wide string def }
function is_widestring(p : pdef) : boolean;
{ true if o is a short string def }
{ true if p is a short string def }
function is_shortstring(p : pdef) : boolean;
{ true if p is a char array def }
function is_chararray(p : pdef) : boolean;
{ true if o is a pchar def }
{ true if p is a pchar def }
function is_pchar(p : pdef) : boolean;
{ returns true, if def defines a signed data type (only for ordinal types) }
@ -259,6 +262,14 @@ unit types;
end;
{ true, if p points to an array of const def }
function is_array_constructor(p : pdef) : boolean;
begin
is_array_constructor:=(p^.deftype=arraydef) and
(parraydef(p)^.IsConstructor);
end;
{ true if p is an ansi string def }
function is_ansistring(p : pdef) : boolean;
begin
@ -982,7 +993,10 @@ unit types;
end.
{
$Log$
Revision 1.35 1998-10-19 08:55:13 pierre
Revision 1.36 1998-11-10 10:09:21 peter
* va_list -> array of const
Revision 1.35 1998/10/19 08:55:13 pierre
* wrong stabs info corrected once again !!
+ variable vmt offset with vmt field only if required
implemented now !!!