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

* fixed array of const

Browse Source 
* generic platform independent high() support
This commit is contained in:
peter 1999-01-21 22:10:35 +00:00
parent 0cfc4c8f6b
commit 4517f917fd
11 changed files with 321 additions and 447 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

424
compiler/cg386cal.pas
View File

@ -26,10 +26,6 @@ interface
uses
symtable,tree;
{ save the size of pushed parameter }
var
pushedparasize : longint;
procedure secondcallparan(var p : ptree;defcoll : pdefcoll;
push_from_left_to_right,inlined : boolean;para_offset : longint);
procedure secondcalln(var p : ptree);
@ -52,28 +48,39 @@ implementation
SecondCallParaN
*****************************************************************************}
procedure secondcallparan(var p : ptree;defcoll : pdefcoll;
push_from_left_to_right,inlined : boolean;para_offset : longint);
procedure maybe_push_high;
{$ifdef OLDHIGH}
var
r : preference;
hreg : tregister;
href : treference;
len : longint;
{$endif}
begin
{ open array ? }
{ defcoll^.data can be nil for read/write }
if assigned(defcoll^.data) and
(is_open_array(defcoll^.data) or
is_open_string(defcoll^.data)) then
push_high_param(defcoll^.data) then
begin
{$ifndef OLDHIGH}
if assigned(p^.hightree) then
begin
secondpass(p^.hightree);
push_value_para(p^.hightree,inlined,para_offset);
end
else
internalerror(432645);
{$else}
{ push high }
case p^.left^.resulttype^.deftype of
arraydef : begin
if is_open_array(p^.left^.resulttype) then
begin
p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
r:=new_reference(highframepointer,highoffset+4);
len:=-1;
end
@ -101,7 +108,7 @@ implementation
len:=str_length(p^.left)
else
begin
href:=p^.left^.location.reference;
href:=p^.location.reference;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(href),R_EDI)));
hreg:=R_EDI;
len:=-2;
@ -148,20 +155,15 @@ implementation
push_int(len);
end;
inc(pushedparasize,4);
{$endif OLDHIGH}
end;
end;
var
size : longint;
otlabel,hlabel,oflabel : plabel;
otlabel,oflabel : plabel;
{ temporary variables: }
tempdeftype : tdeftype;
tempreference : treference;
r : preference;
opsize : topsize;
op : tasmop;
hreg : tregister;
begin
{ push from left to right if specified }
if push_from_left_to_right and assigned(p^.right) then
@ -254,391 +256,7 @@ implementation
del_reference(p^.left^.location.reference);
end
else
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
begin
case p^.left^.location.register of
R_EAX,R_EBX,R_ECX,R_EDX,R_ESI,
R_EDI,R_ESP,R_EBP :
begin
inc(pushedparasize,4);
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
p^.left^.location.register,r)));
end
else
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register)));
ungetregister32(p^.left^.location.register);
end;
R_AX,R_BX,R_CX,R_DX,R_SI,R_DI:
begin
if target_os.stackalignment=4 then
begin
opsize:=S_L;
hreg:=reg16toreg32(p^.left^.location.register);
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=p^.left^.location.register;
inc(pushedparasize,2);
end;
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,opsize,hreg)));
ungetregister32(reg16toreg32(p^.left^.location.register));
end;
R_AL,R_BL,R_CL,R_DL:
begin
if target_os.stackalignment=4 then
begin
opsize:=S_L;
hreg:=reg8toreg32(p^.left^.location.register);
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=reg8toreg16(p^.left^.location.register);
inc(pushedparasize,2);
end;
{ we must push always 16 bit }
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,opsize,hreg)));
ungetregister32(reg8toreg32(p^.left^.location.register));
end;
end;
end;
LOC_FPU:
begin
size:=align(pfloatdef(p^.left^.resulttype)^.size,target_os.stackalignment);
inc(pushedparasize,size);
if not inlined then
exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP)));
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) and
(exprasmlist^.first=exprasmlist^.last) then
exprasmlist^.concat(new(pai_force_line,init));
{$endif GDB}
r:=new_reference(R_ESP,0);
floatstoreops(pfloatdef(p^.left^.resulttype)^.typ,op,opsize);
{ this is the easiest case for inlined !! }
if inlined then
begin
r^.base:=procinfo.framepointer;
r^.offset:=para_offset-pushedparasize;
end;
exprasmlist^.concat(new(pai386,op_ref(op,opsize,r)));
end;
LOC_REFERENCE,LOC_MEM:
begin
tempreference:=p^.left^.location.reference;
del_reference(p^.left^.location.reference);
case p^.resulttype^.deftype of
enumdef,
orddef :
begin
case p^.resulttype^.size of
8 : begin
inc(pushedparasize,8);
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
inc(tempreference.offset,4);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize+4);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
begin
inc(tempreference.offset,4);
emit_push_mem(tempreference);
dec(tempreference.offset,4);
emit_push_mem(tempreference);
end;
end;
4 : begin
inc(pushedparasize,4);
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
end;
1,2 : begin
if target_os.stackalignment=4 then
begin
opsize:=S_L;
hreg:=R_EDI;
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=R_DI;
inc(pushedparasize,2);
end;
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
newreference(tempreference),hreg)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(pai386,op_ref(A_PUSH,opsize,
newreference(tempreference))));
end;
else
internalerror(234231);
end;
end;
floatdef :
begin
case pfloatdef(p^.resulttype)^.typ of
f32bit,
s32real :
begin
inc(pushedparasize,4);
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
end;
s64real,
s64bit :
begin
inc(pushedparasize,4);
inc(tempreference.offset,4);
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
inc(pushedparasize,4);
dec(tempreference.offset,4);
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
end;
s80real :
begin
inc(pushedparasize,4);
if target_os.stackalignment=4 then
inc(tempreference.offset,8)
else
inc(tempreference.offset,6);
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
dec(tempreference.offset,4);
inc(pushedparasize,4);
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
if target_os.stackalignment=4 then
begin
opsize:=S_L;
hreg:=R_EDI;
inc(pushedparasize,4);
dec(tempreference.offset,4);
end
else
begin
opsize:=S_W;
hreg:=R_DI;
inc(pushedparasize,2);
dec(tempreference.offset,2);
end;
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
newreference(tempreference),hreg)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(pai386,op_ref(A_PUSH,opsize,
newreference(tempreference))));
end;
end;
end;
pointerdef,procvardef,
classrefdef:
begin
inc(pushedparasize,4);
if inlined then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(tempreference),R_EDI)));
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,r)));
end
else
emit_push_mem(tempreference);
end;
arraydef,recorddef,stringdef,setdef,objectdef :
begin
{ even some structured types are 32 bit }
if is_widestring(p^.resulttype) or
is_ansistring(p^.resulttype) or
is_smallset(p^.resulttype) or
((p^.resulttype^.deftype=objectdef) and
pobjectdef(p^.resulttype)^.isclass) then
begin
inc(pushedparasize,4);
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
concatcopy(tempreference,r^,4,false,false);
end
else
emit_push_mem(tempreference);
end
{ call by value open array ? }
else
internalerror(8954);
end;
else
CGMessage(cg_e_illegal_expression);
end;
end;
LOC_JUMP:
begin
getlabel(hlabel);
if target_os.stackalignment=4 then
begin
opsize:=S_L;
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
inc(pushedparasize,2);
end;
emitl(A_LABEL,truelabel);
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,opsize,1,r)));
end
else
exprasmlist^.concat(new(pai386,op_const(A_PUSH,opsize,1)));
emitl(A_JMP,hlabel);
emitl(A_LABEL,falselabel);
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,opsize,0,r)));
end
else
exprasmlist^.concat(new(pai386,op_const(A_PUSH,opsize,0)));
emitl(A_LABEL,hlabel);
end;
LOC_FLAGS:
begin
if not(R_EAX in unused) then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EAX,R_EDI)));
exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.left^.location.resflags],S_B,
R_AL)));
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,R_AL,R_AX)));
if target_os.stackalignment=4 then
begin
opsize:=S_L;
hreg:=R_EAX;
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=R_AX;
inc(pushedparasize,2);
end;
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,hreg,r)));
end
else
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,opsize,hreg)));
if not(R_EAX in unused) then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EDI,R_EAX)));
end;
{$ifdef SUPPORT_MMX}
LOC_MMXREGISTER,
LOC_CMMXREGISTER:
begin
inc(pushedparasize,8); { was missing !!! (PM) }
exprasmlist^.concat(new(pai386,op_const_reg(
A_SUB,S_L,8,R_ESP)));
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) and
(exprasmlist^.first=exprasmlist^.last) then
exprasmlist^.concat(new(pai_force_line,init));
{$endif GDB}
if inlined then
begin
r:=new_reference(procinfo.framepointer,para_offset-pushedparasize);
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO,
p^.left^.location.register,r)));
end
else
begin
r:=new_reference(R_ESP,0);
exprasmlist^.concat(new(pai386,op_reg_ref(
A_MOVQ,S_NO,p^.left^.location.register,r)));
end;
end;
{$endif SUPPORT_MMX}
end;
push_value_para(p^.left,inlined,para_offset);
end;
freelabel(truelabel);
freelabel(falselabel);
@ -1614,7 +1232,11 @@ implementation
end.
{
$Log$
Revision 1.57 1999-01-21 16:40:51 pierre
Revision 1.58 1999-01-21 22:10:35 peter
* fixed array of const
* generic platform independent high() support
Revision 1.57 1999/01/21 16:40:51 pierre
* fix for constructor inside with statements
Revision 1.56 1998/12/30 13:41:05 peter

92
compiler/cg386cnv.pas
View File

@ -29,6 +29,8 @@ interface
uses
tree;
procedure loadshortstring(p:ptree);
procedure secondtypeconv(var p : ptree);
procedure secondas(var p : ptree);
procedure secondis(var p : ptree);
@ -39,9 +41,91 @@ implementation
uses
cobjects,verbose,globals,systems,
symtable,aasm,types,
hcodegen,temp_gen,pass_2,
hcodegen,temp_gen,pass_2,pass_1,
i386,cgai386,tgeni386;
procedure push_shortstring_length(p:ptree);
var
r : preference;
hightree : ptree;
begin
if is_open_string(p^.resulttype) then
begin
getsymonlyin(p^.symtable,'high'+pvarsym(p^.symtableentry)^.name);
hightree:=genloadnode(pvarsym(srsym),p^.symtable);
firstpass(hightree);
secondpass(hightree);
push_value_para(hightree,false,0);
disposetree(hightree);
{ r:=new_reference(highframepointer,highoffset+4);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,r,R_EDI)));
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDI))); }
end
else
begin
push_int(pstringdef(p^.resulttype)^.len);
end;
end;
procedure loadshortstring(p:ptree);
{
Load a string, handles stringdef and orddef (char) types
}
begin
case p^.right^.resulttype^.deftype of
stringdef:
begin
if (p^.right^.treetype=stringconstn) and
(str_length(p^.right)=0) then
exprasmlist^.concat(new(pai386,op_const_ref(
A_MOV,S_B,0,newreference(p^.left^.location.reference))))
else
begin
emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
emitpushreferenceaddr(exprasmlist,p^.right^.location.reference);
push_shortstring_length(p^.left);
emitcall('FPC_SHORTSTR_COPY',true);
maybe_loadesi;
end;
end;
orddef:
begin
if p^.right^.treetype=ordconstn then
exprasmlist^.concat(new(pai386,op_const_ref(
A_MOV,S_W,p^.right^.value*256+1,newreference(p^.left^.location.reference))))
else
begin
{ not so elegant (goes better with extra register }
if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
begin
exprasmlist^.concat(new(pai386,op_reg_reg(
A_MOV,S_L,makereg32(p^.right^.location.register),R_EDI)));
ungetregister(p^.right^.location.register);
end
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(
A_MOV,S_L,newreference(p^.right^.location.reference),R_EDI)));
del_reference(p^.right^.location.reference);
end;
exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,8,R_EDI)));
exprasmlist^.concat(new(pai386,op_const_reg(A_OR,S_L,1,R_EDI)));
exprasmlist^.concat(new(pai386,op_reg_ref(
A_MOV,S_W,R_DI,newreference(p^.left^.location.reference))));
end;
end;
else
CGMessage(type_e_mismatch);
end;
end;
{*****************************************************************************
SecondTypeConv
*****************************************************************************}
@ -1478,7 +1562,11 @@ implementation
end.
{
$Log$
Revision 1.44 1999-01-19 10:18:59 florian
Revision 1.45 1999-01-21 22:10:36 peter
* fixed array of const
* generic platform independent high() support
Revision 1.44 1999/01/19 10:18:59 florian
* bug with mul. of dwords fixed, reported by Alexander Stohr
* some changes to compile with TP
+ small enhancements for the new code generator

10
compiler/cg386inl.pas
View File

@ -621,6 +621,7 @@ implementation
exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register)));
p^.location.register:=reg16toreg8(p^.location.register);
end;
{$ifdef OLDHIGH}
in_high_x :
begin
if is_open_array(p^.left^.resulttype) or
@ -634,9 +635,11 @@ implementation
r,p^.location.register)));
end
end;
{$endif OLDHIGH}
in_sizeof_x,
in_typeof_x :
begin
{$ifdef OLDHIGH}
{ sizeof(openarray) handling }
if (p^.inlinenumber=in_sizeof_x) and
(is_open_array(p^.left^.resulttype) or
@ -657,6 +660,7 @@ implementation
parraydef(p^.left^.resulttype)^.elesize,p^.location.register)));
end
else
{$endif OLDHIGH}
begin
{ for both cases load vmt }
if p^.left^.treetype=typen then
@ -1004,7 +1008,11 @@ implementation
end.
{
$Log$
Revision 1.23 1999-01-06 12:23:29 florian
Revision 1.24 1999-01-21 22:10:39 peter
* fixed array of const
* generic platform independent high() support
Revision 1.23 1999/01/06 12:23:29 florian
* str(...) for ansi/long and widestrings fixed
Revision 1.22 1998/12/11 23:36:07 florian

12
compiler/cg386ld.pas
View File

@ -187,14 +187,17 @@ implementation
end;
end;
end;
{ in case call by reference, then calculate: }
{ in case call by reference, then calculate. Open array
is always an reference! }
if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
is_open_array(pvarsym(p^.symtableentry)^.definition) or
((pvarsym(p^.symtableentry)^.varspez=vs_const) and
push_addr_param(pvarsym(p^.symtableentry)^.definition)) then
begin
simple_loadn:=false;
if hregister=R_NO then
hregister:=getregister32;
{$ifdef OLDHIGH}
if is_open_array(pvarsym(p^.symtableentry)^.definition) or
is_open_string(pvarsym(p^.symtableentry)^.definition) then
begin
@ -211,6 +214,7 @@ implementation
p^.location.reference.base,R_EDI)));
end;
end;
{$endif}
if p^.location.loc=LOC_CREGISTER then
begin
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
@ -730,7 +734,11 @@ implementation
end.
{
$Log$
Revision 1.41 1999-01-20 10:20:18 peter
Revision 1.42 1999-01-21 22:10:40 peter
* fixed array of const
* generic platform independent high() support
Revision 1.41 1999/01/20 10:20:18 peter
* don't make localvar copies for assembler procedures
Revision 1.40 1998/12/30 13:41:07 peter

8
compiler/cg386mat.pas
View File

@ -188,7 +188,7 @@ implementation
hregister1,hregister2,hregister3,
hregisterhigh,hregisterlow : tregister;
pushed,popecx : boolean;
op,op2 : tasmop;
op : tasmop;
hr : preference;
begin
@ -755,7 +755,11 @@ implementation
end.
{
$Log$
Revision 1.16 1999-01-19 10:51:32 pierre
Revision 1.17 1999-01-21 22:10:41 peter
* fixed array of const
* generic platform independent high() support
Revision 1.16 1999/01/19 10:51:32 pierre
* fix to bug0183 in secondnot
Revision 1.15 1998/12/11 16:50:22 florian

11
compiler/hcodegen.pas
View File

@ -132,6 +132,10 @@ unit hcodegen;
{ true, if an error while code generation occurs }
codegenerror : boolean;
{ save the size of pushed parameter, needed for aligning }
pushedparasize : longint;
{$ifdef OLDHIGH}
{ this is for open arrays and strings }
{ but be careful, this data is in the }
{ generated code destroyed quick, and also }
@ -141,6 +145,7 @@ unit hcodegen;
{ provided by this variables }
highframepointer : tregister;
highoffset : longint;
{$endif}
{ message calls with codegenerror support }
procedure cgmessage(const t : tmsgconst);
@ -355,7 +360,11 @@ end.
{
$Log$
Revision 1.24 1998-12-29 18:48:18 jonas
Revision 1.25 1999-01-21 22:10:45 peter
* fixed array of const
* generic platform independent high() support
Revision 1.24 1998/12/29 18:48:18 jonas
+ optimize pascal code surrounding assembler blocks
Revision 1.23 1998/11/27 14:50:38 peter

13
compiler/symsym.inc
View File

@ -971,27 +971,34 @@
case varspez of
vs_var :
begin
{$ifdef OLDHIGH}
{ open arrays push also the high valye }
if is_open_array(definition) or
is_open_string(definition) then
getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
else
{$endif}
getpushsize:=target_os.size_of_pointer;
end;
vs_value,
vs_const :
begin
case definition^.deftype of
{$ifndef OLDHIGH}
arraydef,
{$endif OLDHIGH}
setdef,
stringdef,
recorddef,
objectdef :
getpushsize:=target_os.size_of_pointer;
{$ifdef OLDHIGH}
arraydef :
if is_open_array(definition) then
getpushsize:=target_os.size_of_pointer+target_os.size_of_longint
else
getpushsize:=target_os.size_of_pointer;
{$endif OLDHIGH}
else
getpushsize:=definition^.size;
end;
@ -1757,7 +1764,11 @@
{
$Log$
Revision 1.69 1999-01-20 10:20:20 peter
Revision 1.70 1999-01-21 22:10:48 peter
* fixed array of const
* generic platform independent high() support
Revision 1.69 1999/01/20 10:20:20 peter
* don't make localvar copies for assembler procedures
Revision 1.68 1999/01/12 14:25:36 peter

96
compiler/tccal.pas
View File

@ -27,6 +27,10 @@ interface
symtable,tree;
{$ifndef OLDHIGH}
procedure gen_high_tree(p:ptree;openstring:boolean);
{$endif}
procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
procedure firstcalln(var p : ptree);
procedure firstprocinline(var p : ptree);
@ -51,6 +55,69 @@ implementation
FirstCallParaN
*****************************************************************************}
{$ifndef OLDHIGH}
procedure gen_high_tree(p:ptree;openstring:boolean);
var
len : longint;
st : psymtable;
begin
if assigned(p^.hightree) then
exit;
len:=-1;
case p^.left^.resulttype^.deftype of
arraydef :
begin
if is_open_array(p^.left^.resulttype) then
begin
st:=p^.left^.symtable;
getsymonlyin(st,'high'+pvarsym(p^.left^.symtableentry)^.name);
p^.hightree:=genloadnode(pvarsym(srsym),st);
end
else
len:=parraydef(p^.left^.resulttype)^.highrange-
parraydef(p^.left^.resulttype)^.lowrange;
end;
stringdef :
begin
if openstring then
begin
if is_open_string(p^.left^.resulttype) then
begin
st:=p^.left^.symtable;
getsymonlyin(st,'high'+pvarsym(p^.left^.symtableentry)^.name);
p^.hightree:=genloadnode(pvarsym(srsym),st);
end
else
len:=pstringdef(p^.left^.resulttype)^.len;
end
else
{ passing a string to an array of char }
begin
if (p^.left^.treetype=stringconstn) then
begin
len:=str_length(p^.left);
if len>0 then
dec(len);
end
else
begin
p^.hightree:=gennode(subn,geninlinenode(in_length_string,false,getcopy(p^.left)),
genordinalconstnode(1,s32bitdef));
firstpass(p^.hightree);
p^.hightree:=gentypeconvnode(p^.hightree,s32bitdef);
end;
end;
end;
else
len:=0;
end;
if len>=0 then
p^.hightree:=genordinalconstnode(len,s32bitdef);
firstpass(p^.hightree);
end;
{$endif OLDHIGH}
procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
var
old_array_constructor : boolean;
@ -95,16 +162,7 @@ implementation
store_valid:=must_be_valid;
if (defcoll^.paratyp=vs_var) then
test_protected(p^.left);
if (defcoll^.paratyp<>vs_var) then
must_be_valid:=true
else
must_be_valid:=false;
{ here we must add something for the implicit type }
{ conversion from array of char to pchar }
{ if isconvertable(p^.left^.resulttype,defcoll^.data,convtyp,
p^.left^.treetype,false) then
if convtyp=tc_array_to_pointer then
must_be_valid:=false; }
must_be_valid:=(defcoll^.paratyp<>vs_var);
{ only process typeconvn, else it will break other trees }
old_array_constructor:=allow_array_constructor;
allow_array_constructor:=true;
@ -113,6 +171,11 @@ implementation
allow_array_constructor:=old_array_constructor;
must_be_valid:=store_valid;
end;
{ generate the high() value tree }
if push_high_param(defcoll^.data) then
{$ifndef OLDHIGH}
gen_high_tree(p,is_open_string(defcoll^.data));
{$endif}
if not(is_shortstring(p^.left^.resulttype) and
is_shortstring(defcoll^.data)) and
(defcoll^.data^.deftype<>formaldef) then
@ -162,10 +225,8 @@ implementation
firstpass(p^.left);
allow_array_constructor:=old_array_constructor;
end;
{ don't generate an type conversion for open arrays and
openstring, else we loss the ranges }
if is_open_array(defcoll^.data) or
is_open_string(defcoll^.data) then
{ process open parameters }
if push_high_param(defcoll^.data) then
begin
{ insert type conv but hold the ranges of the array }
oldtype:=p^.left^.resulttype;
@ -197,6 +258,7 @@ implementation
not(is_open_string(defcoll^.data)) and
not(is_equal(p^.left^.resulttype,defcoll^.data)) then
CGMessage(type_e_strict_var_string_violation);
{ Variablen for call by reference may not be copied }
{ into a register }
{ is this usefull here ? }
@ -999,7 +1061,11 @@ implementation
end.
{
$Log$
Revision 1.20 1999-01-21 16:41:06 pierre
Revision 1.21 1999-01-21 22:10:49 peter
* fixed array of const
* generic platform independent high() support
Revision 1.20 1999/01/21 16:41:06 pierre
* fix for constructor inside with statements
Revision 1.19 1999/01/19 14:20:16 peter

45
compiler/tcinl.pas
View File

@ -287,6 +287,20 @@ implementation
end;
in_sizeof_x:
begin
{$ifndef OLDHIGH}
if push_high_param(p^.left^.resulttype) then
begin
getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
hp:=gennode(addn,genloadnode(pvarsym(srsym),p^.left^.symtable),
genordinalconstnode(1,s32bitdef));
if (p^.left^.resulttype^.deftype=arraydef) and
(parraydef(p^.left^.resulttype)^.elesize<>1) then
hp:=gennode(muln,hp,genordinalconstnode(parraydef(p^.left^.resulttype)^.elesize,s32bitdef));
disposetree(p);
p:=hp;
firstpass(p);
end;
{$endif OLDHIGH}
if p^.registers32<1 then
p^.registers32:=1;
p^.resulttype:=s32bitdef;
@ -530,7 +544,11 @@ implementation
if assigned(hp^.right) then
CGMessage(type_e_cant_read_write_type);
end;
stringdef : ;
stringdef : begin
{ generate the high() value for the string }
if not dowrite then
gen_high_tree(hp,true);
end;
pointerdef : begin
if not is_equal(ppointerdef(hp^.left^.resulttype)^.definition,cchardef) then
CGMessage(type_e_cant_read_write_type);
@ -670,6 +688,9 @@ implementation
(hp^.right=nil) or
(hp^.left^.location.loc<>LOC_REFERENCE) then
CGMessage(cg_e_illegal_expression);
{ generate the high() value for the string }
gen_high_tree(hp,true);
{ !!!! check length of string }
while assigned(hp^.right) do
@ -806,9 +827,17 @@ implementation
begin
if is_open_array(p^.left^.resulttype) then
begin
{$ifndef OLDHIGH}
getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
disposetree(p);
p:=hp;
firstpass(p);
{$else OLDHIGH}
p^.resulttype:=s32bitdef;
p^.registers32:=max(1,p^.registers32);
p^.location.loc:=LOC_REGISTER;
{$endif OLDHIGH}
end
else
begin
@ -832,9 +861,17 @@ implementation
begin
if is_open_string(p^.left^.resulttype) then
begin
{$ifndef OLDHIGH}
getsymonlyin(p^.left^.symtable,'high'+pvarsym(p^.left^.symtableentry)^.name);
hp:=genloadnode(pvarsym(srsym),p^.left^.symtable);
disposetree(p);
p:=hp;
firstpass(p);
{$else OLDHIGH}
p^.resulttype:=s32bitdef;
p^.registers32:=max(1,p^.registers32);
p^.location.loc:=LOC_REGISTER;
{$endif OLDHIGH}
end
else
begin
@ -893,7 +930,11 @@ implementation
end.
{
$Log$
Revision 1.13 1998-12-30 22:13:13 peter
Revision 1.14 1999-01-21 22:10:50 peter
* fixed array of const
* generic platform independent high() support
Revision 1.13 1998/12/30 22:13:13 peter
* check the amount of paras for Str()
Revision 1.12 1998/12/15 10:23:31 peter

8
compiler/tree.pas
View File

@ -235,7 +235,7 @@ unit tree;
{$endif extdebug}
case treetype : ttreetyp of
addn : (use_strconcat : boolean;string_typ : tstringtype);
callparan : (is_colon_para : boolean;exact_match_found : boolean);
callparan : (is_colon_para : boolean;exact_match_found : boolean;hightree:ptree);
assignn : (assigntyp : tassigntyp;concat_string : boolean);
loadn : (symtableentry : psym;symtable : psymtable;
is_absolute,is_first,is_methodpointer : boolean);
@ -1663,7 +1663,11 @@ unit tree;
end.
{
$Log$
Revision 1.61 1999-01-21 16:41:09 pierre
Revision 1.62 1999-01-21 22:10:52 peter
* fixed array of const
* generic platform independent high() support
Revision 1.61 1999/01/21 16:41:09 pierre
* fix for constructor inside with statements
Revision 1.60 1998/12/15 11:52:19 peter

15
compiler/types.pas
View File

@ -91,6 +91,8 @@ unit types;
{ true, if def is a 64 bit int type }
function is_64bitint(def : pdef) : boolean;
function push_high_param(def : pdef) : boolean;
{ true if a parameter is too large to copy and only the address is pushed }
function push_addr_param(def : pdef) : boolean;
@ -376,6 +378,13 @@ unit types;
((def^.deftype=setdef) and (psetdef(def)^.settype<>smallset));
end;
function push_high_param(def : pdef) : boolean;
begin
push_high_param:=is_open_array(def) or is_open_string(def);
end;
{ true if a parameter is too large to copy and only the address is pushed }
function push_addr_param(def : pdef) : boolean;
begin
@ -1047,7 +1056,11 @@ unit types;
end.
{
$Log$
Revision 1.45 1999-01-20 12:34:22 peter
Revision 1.46 1999-01-21 22:10:54 peter
* fixed array of const
* generic platform independent high() support
Revision 1.45 1999/01/20 12:34:22 peter
* fixed typed file read/write
Revision 1.44 1999/01/15 11:33:03 pierre