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

* a lot of changes:

Browse Source 
- basic dyn. array support
     - basic C++ support
     - some work for interfaces done
     ....
This commit is contained in:
florian 2000-10-21 18:16:11 +00:00
parent 015743f9fd
commit f80c24177a
22 changed files with 534 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
compiler/i386/n386inl.pas
View File

@ -194,6 +194,7 @@ implementation
{inc/dec}
addconstant : boolean;
addvalue : longint;
hp : tnode;
procedure handlereadwrite(doread,doln : boolean);
@ -681,6 +682,7 @@ implementation
dummycoll : tparaitem;
has_code, has_32bit_code, oldregisterdef: boolean;
r : preference;
l : longint;
begin
dummycoll.init;
@ -907,6 +909,8 @@ implementation
hregister : tregister;
otlabel,oflabel{,l1} : pasmlabel;
oldpushedparasize : longint;
def : pdef;
hr,hr2 : treference;
begin
{ save & reset pushedparasize }
@ -1341,6 +1345,67 @@ implementation
emitcall('FPC_REWRITE_TYPED');
popusedregisters(pushed);
end;
in_setlength_x:
begin
pushusedregisters(pushed,$ff);
l:=0;
{ push dimensions }
hp:=left;
while assigned(tcallparanode(hp).right) do
begin
inc(l);
hp:=tcallparanode(hp).right;
end;
def:=tcallparanode(hp).left.resulttype;
hp:=left;
if is_dynamic_array(def) then
begin
{ get temp. space }
gettempofsizereference(l*4,hr);
{ copy dimensions }
hp:=left;
while assigned(tcallparanode(hp).right) do
begin
secondpass(tcallparanode(hp).left);
emit_mov_loc_ref(tcallparanode(hp).left.location,hr,
S_L,true);
inc(hr.offset,4);
hp:=tcallparanode(hp).right;
end;
end
else
begin
secondpass(tcallparanode(hp).left);
emit_push_loc(tcallparanode(hp).left.location);
hp:=tcallparanode(hp).right;
end;
secondpass(tcallparanode(hp).left);
if is_dynamic_array(def) then
begin
emitpushreferenceaddr(hr);
push_int(l);
reset_reference(hr2);
hr2.symbol:=def^.get_inittable_label;
emitpushreferenceaddr(hr2);
emitpushreferenceaddr(tcallparanode(hp).left.location.reference);
emitcall('FPC_DYNARR_SETLENGTH');
ungetiftemp(hr);
end
else
{ must be string }
begin
emitpushreferenceaddr(tcallparanode(hp).left.location.reference);
case pstringdef(def)^.string_typ of
st_widestring:
emitcall('FPC_WIDESTR_SETLENGTH');
st_ansistring:
emitcall('FPC_ANSISTR_SETLENGTH');
st_shortstring:
emitcall('FPC_SHORTSTR_SETLENGTH');
end;
end;
popusedregisters(pushed);
end;
in_write_x :
handlereadwrite(false,false);
in_writeln_x :
@ -1547,7 +1612,14 @@ begin
end.
{
$Log$
Revision 1.1 2000-10-15 09:33:31 peter
Revision 1.2 2000-10-21 18:16:13 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.1 2000/10/15 09:33:31 peter
* moved n386*.pas to i386/ cpu_target dir
Revision 1.2 2000/10/15 09:08:58 peter

51
compiler/i386/n386mem.pas
View File

@ -520,6 +520,39 @@ implementation
1,location.reference.base);
end;
{ we've also to keep left up-to-date, because it is used }
{ if a constant array index occurs, subject to change (FK) }
set_location(left.location,location);
end
else if is_dynamic_array(left.resulttype) then
{ ... also a dynamic string }
begin
reset_reference(location.reference);
if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
begin
location.reference.base:=left.location.register;
end
else
begin
del_reference(left.location.reference);
location.reference.base:=getregister32;
emit_ref_reg(A_MOV,S_L,
newreference(left.location.reference),
location.reference.base);
end;
{$warning FIXME}
{ check for a zero length string,
we can use the ansistring routine here }
if (cs_check_range in aktlocalswitches) then
begin
pushusedregisters(pushed,$ff);
emit_reg(A_PUSH,S_L,location.reference.base);
emitcall('FPC_ANSISTR_CHECKZERO');
maybe_loadesi;
popusedregisters(pushed);
end;
{ we've also to keep left up-to-date, because it is used }
{ if a constant array index occurs, subject to change (FK) }
set_location(left.location,location);
@ -528,7 +561,8 @@ implementation
set_location(location,left.location);
{ offset can only differ from 0 if arraydef }
if left.resulttype^.deftype=arraydef then
if (left.resulttype^.deftype=arraydef) and
not(is_dynamic_array(left.resulttype)) then
dec(location.reference.offset,
get_mul_size*parraydef(left.resulttype)^.lowrange);
if right.nodetype=ordconstn then
@ -537,7 +571,8 @@ implementation
if (left.resulttype^.deftype=arraydef) then
begin
if not(is_open_array(left.resulttype)) and
not(is_array_of_const(left.resulttype)) then
not(is_array_of_const(left.resulttype)) and
not(is_dynamic_array(left.resulttype)) then
begin
if (tordconstnode(right).value>parraydef(left.resulttype)^.highrange) or
(tordconstnode(right).value<parraydef(left.resulttype)^.lowrange) then
@ -552,7 +587,8 @@ implementation
end
else
begin
{ range checking for open arrays !!!! }
{ range checking for open and dynamic arrays !!!! }
{$warning FIXME}
{!!!!!!!!!!!!!!!!!}
end;
end
@ -1017,7 +1053,14 @@ begin
end.
{
$Log$
Revision 1.1 2000-10-15 09:33:32 peter
Revision 1.2 2000-10-21 18:16:13 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.1 2000/10/15 09:33:32 peter
* moved n386*.pas to i386/ cpu_target dir
Revision 1.2 2000/10/14 21:52:54 peter

10
compiler/innr.inc
View File

@ -53,6 +53,7 @@ const
in_assert_x_y = 41;
in_addr_x = 42;
in_typeinfo_x = 43;
in_setlength_x = 44;
{ Internal constant functions }
in_const_trunc = 100;
@ -100,7 +101,14 @@ const
{
$Log$
Revision 1.3 2000-08-16 13:06:06 florian
Revision 1.4 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.3 2000/08/16 13:06:06 florian
+ support of 64 bit integer constants
Revision 1.2 2000/07/13 11:32:43 michael

30
compiler/ncal.pas
View File

@ -2,6 +2,8 @@
$Id$
Copyright (c) 1998-2000 by Florian Klaempfl
This file implements the node for sub procedure calling
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@ -43,6 +45,7 @@ interface
constructor create(v : pprocsym;st : psymtable; mp : tnode);virtual;
destructor destroy;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
function pass_1 : tnode;override;
end;
@ -62,6 +65,7 @@ interface
constructor create(expr,next : tnode);virtual;
destructor destroy;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
procedure gen_high_tree(openstring:boolean);
{ tcallparanode doesn't use pass_1 }
{ tcallnode takes care of this }
@ -78,6 +82,7 @@ interface
constructor create(callp,code : tnode);virtual;
destructor destroy;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
function pass_1 : tnode;override;
end;
@ -171,6 +176,11 @@ interface
result:=n;
end;
procedure tcallparanode.insertintolist(l : tnodelist);
begin
end;
procedure tcallparanode.firstcallparan(defcoll : pparaitem;do_count : boolean);
var
old_get_para_resulttype : boolean;
@ -520,6 +530,10 @@ interface
result:=n;
end;
procedure tcallnode.insertintolist(l : tnodelist);
begin
end;
function tcallnode.pass_1 : tnode;
type
pprocdefcoll = ^tprocdefcoll;
@ -1514,6 +1528,11 @@ interface
getcopy:=n;
end;
procedure tprocinlinenode.insertintolist(l : tnodelist);
begin
end;
function tprocinlinenode.pass_1 : tnode;
begin
pass_1:=nil;
@ -1530,7 +1549,14 @@ begin
end.
{
$Log$
Revision 1.11 2000-10-21 14:35:27 peter
Revision 1.12 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.11 2000/10/21 14:35:27 peter
* readd to many remove p. for tcallnode.is_equal()
Revision 1.10 2000/10/14 21:52:55 peter
@ -1563,4 +1589,4 @@ end.
Revision 1.1 2000/09/20 20:52:16 florian
* initial revision
}
}

22
compiler/nflw.pas
View File

@ -36,6 +36,7 @@ interface
constructor create(tt : tnodetype;l,r,_t1,_t2 : tnode);virtual;
destructor destroy;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
{$ifdef extdebug}
procedure dowrite;override;
{$endif extdebug}
@ -91,6 +92,7 @@ interface
frametree : tnode;
constructor create(l,taddr,tframe:tnode);virtual;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
function pass_1 : tnode;override;
end;
@ -217,6 +219,10 @@ implementation
getcopy:=p;
end;
procedure tloopnode.insertintolist(l : tnodelist);
begin
end;
{$ifdef extdebug}
procedure tloopnode.dowrite;
begin
@ -725,6 +731,11 @@ implementation
getcopy:=n;
end;
procedure traisenode.insertintolist(l : tnodelist);
begin
end;
function traisenode.pass_1 : tnode;
begin
pass_1:=nil;
@ -982,7 +993,14 @@ begin
end.
{
$Log$
Revision 1.7 2000-10-14 21:52:55 peter
Revision 1.8 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.7 2000/10/14 21:52:55 peter
* fixed memory leaks
Revision 1.6 2000/10/14 10:14:50 peter
@ -1003,4 +1021,4 @@ end.
Revision 1.1 2000/09/22 22:46:03 florian
+ initial revision
}
}

50
compiler/ninl.pas
View File

@ -100,9 +100,10 @@ implementation
{$endif fpc}
function tinlinenode.pass_1 : tnode;
var
vl,vl2 : longint;
vl,vl2,counter : longint;
vr : bestreal;
p1,hp,hpp : tnode;
ppn : tcallparanode;
{$ifndef NOCOLONCHECK}
frac_para,length_para : tnode;
{$endif ndef NOCOLONCHECK}
@ -658,6 +659,43 @@ implementation
end;
end;
in_setlength_x:
begin
resulttype:=voiddef;
if assigned(left) then
begin
ppn:=tcallparanode(left);
counter:=0;
{ check type }
while assigned(ppn.right) do
begin
ppn.left:=gentypeconvnode(ppn.left,s32bitdef);
firstpass(ppn.left);
if codegenerror then
exit;
inc(counter);
ppn:=tcallparanode(ppn.right);
end;
firstpass(ppn.left);
if codegenerror then
exit;
{ last param must be var }
valid_for_assign(ppn.left,false);
set_varstate(ppn.left,true);
{ first param must be a string or dynamic array ...}
if not((ppn.left.resulttype^.deftype=stringdef) or
(is_dynamic_array(ppn.left.resulttype))) then
CGMessage(type_e_mismatch);
{ only dynamic arrays accept more dimensions }
if (counter>1) and
(not(is_dynamic_array(left.resulttype))) then
CGMessage(type_e_mismatch);
end
else
CGMessage(type_e_mismatch);
end;
in_inc_x,
in_dec_x:
begin
@ -1293,7 +1331,6 @@ implementation
else
handleextendedfunction;
end;
in_pi:
if block_type=bt_const then
setconstrealvalue(pi)
@ -1412,7 +1449,14 @@ begin
end.
{
$Log$
Revision 1.9 2000-10-15 08:38:46 jonas
Revision 1.10 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.9 2000/10/15 08:38:46 jonas
* added missing getcopy for previous addition
Revision 1.8 2000/10/14 18:27:53 jonas

17
compiler/nmem.pas
View File

@ -744,7 +744,9 @@ implementation
{ for ansi/wide strings, we need at least one register }
if is_ansistring(left.resulttype) or
is_widestring(left.resulttype) then
is_widestring(left.resulttype) or
{ ... as well as for dynamic arrays }
is_dynamic_array(left.resulttype) then
registers32:=max(registers32,1);
end
else
@ -755,7 +757,9 @@ implementation
{ for ansi/wide strings, we need at least one register }
if is_ansistring(left.resulttype) or
is_widestring(left.resulttype) then
is_widestring(left.resulttype) or
{ ... as well as for dynamic arrays }
is_dynamic_array(left.resulttype) then
registers32:=max(registers32,1);
{ need we an extra register when doing the restore ? }
@ -904,7 +908,14 @@ implementation
end.
{
$Log$
Revision 1.7 2000-10-14 21:52:55 peter
Revision 1.8 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.7 2000/10/14 21:52:55 peter
* fixed memory leaks
Revision 1.6 2000/10/14 10:14:51 peter

23
compiler/node.inc
View File

@ -240,6 +240,11 @@
getcopy:=p;
end;
procedure tnode.insertintolist(l : tnodelist);
begin
end;
procedure tnode.set_file_line(from : tnode);
begin
@ -292,6 +297,11 @@
getcopy:=p;
end;
procedure tunarynode.insertintolist(l : tnodelist);
begin
end;
{$ifdef extdebug}
procedure tunarynode.dowrite;
@ -411,6 +421,10 @@
getcopy:=p;
end;
procedure tbinarynode.insertintolist(l : tnodelist);
begin
end;
procedure tbinarynode.swapleftright;
@ -502,7 +516,14 @@
{
$Log$
Revision 1.10 2000-10-14 21:52:55 peter
Revision 1.11 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.10 2000/10/14 21:52:55 peter
* fixed memory leaks
Revision 1.9 2000/10/14 10:14:51 peter

15
compiler/nodeh.inc
View File

@ -178,6 +178,9 @@
flagsequal : tnodeflagset = [nf_error,nf_static_call,nf_backward];
type
tnodelist = class
end;
{ later (for the newcg) tnode will inherit from tlinkedlist_item }
tnode = class
nodetype : tnodetype;
@ -230,6 +233,7 @@
{ gets a copy of the node }
function getcopy : tnode;virtual;
procedure insertintolist(l : tnodelist);virtual;
{$ifdef EXTDEBUG}
{ writes a node for debugging purpose, shouldn't be called }
{ direct, because there is no test for nil, use writenode }
@ -265,6 +269,7 @@
procedure det_temp;override;
function docompare(p : tnode) : boolean;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
procedure left_max;
{$ifdef extdebug}
procedure dowrite;override;
@ -283,6 +288,7 @@
function docompare(p : tnode) : boolean;override;
procedure swapleftright;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
procedure left_right_max;
{$ifdef extdebug}
procedure dowrite;override;
@ -304,7 +310,14 @@
{
$Log$
Revision 1.13 2000-10-14 21:52:55 peter
Revision 1.14 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.13 2000/10/14 21:52:55 peter
* fixed memory leaks
Revision 1.12 2000/10/14 10:14:51 peter

15
compiler/nset.pas
View File

@ -70,6 +70,7 @@ interface
constructor create(l,r : tnode;n : pcaserecord);virtual;
destructor destroy;override;
function getcopy : tnode;override;
procedure insertintolist(l : tnodelist);override;
function pass_1 : tnode;override;
end;
@ -511,6 +512,11 @@ implementation
getcopy:=p;
end;
procedure tcasenode.insertintolist(l : tnodelist);
begin
end;
begin
csetelementnode:=tsetelementnode;
cinnode:=tinnode;
@ -519,7 +525,14 @@ begin
end.
{
$Log$
Revision 1.5 2000-10-14 10:14:51 peter
Revision 1.6 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.5 2000/10/14 10:14:51 peter
* moehrendorf oct 2000 rewrite
Revision 1.4 2000/10/01 19:48:25 peter

13
compiler/pdecobj.pas
View File

@ -883,11 +883,9 @@ unit pdecobj;
begin
if aktclass^.is_cppclass then
begin
{
include(aktprocsym^.definition^.proccalloptions,pocall_cppdecl);
aktprocsym^.definition^.setmangledname(
target_os.Cprefix+aktprocsym^.definition^.cplusplusmangledname(realname));
}
target_os.Cprefix+aktprocsym^.definition^.cplusplusmangledname);
end;
end;
@ -1079,7 +1077,14 @@ unit pdecobj;
end.
{
$Log$
Revision 1.1 2000-10-14 10:14:51 peter
Revision 1.2 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.1 2000/10/14 10:14:51 peter
* moehrendorf oct 2000 rewrite
}

18
compiler/pdecsub.pas
View File

@ -897,7 +897,7 @@ procedure pd_cppdecl(const procnames:Tstringcontainer);
begin
if aktprocsym^.definition^.deftype<>procvardef then
aktprocsym^.definition^.setmangledname(
target_os.Cprefix+aktprocsym^.definition^.cplusplusmangledname(aktprocsym^.realname));
target_os.Cprefix+aktprocsym^.definition^.cplusplusmangledname);
{ do not copy on local !! }
if (aktprocsym^.definition^.deftype=procdef) and
assigned(aktprocsym^.definition^.parast) then
@ -1580,7 +1580,7 @@ begin
(aktprocsym^.definition^.maxparacount>0)) then
begin
MessagePos1(aktprocsym^.definition^.fileinfo,parser_e_header_dont_match_forward,
aktprocsym^.declarationstr);
aktprocsym^.declarationstr(aktprocsym^.definition));
exit;
end;
if hd^.forwarddef then
@ -1593,7 +1593,7 @@ begin
(m_repeat_forward in aktmodeswitches)) then
begin
MessagePos1(aktprocsym^.definition^.fileinfo,parser_e_header_dont_match_forward,
aktprocsym^.declarationstr);
aktprocsym^.declarationstr(aktprocsym^.definition));
exit;
end;
{ Check calling convention, no check for internconst,internproc which
@ -1648,7 +1648,8 @@ begin
if hd^.forwarddef and aktprocsym^.definition^.forwarddef then
begin
MessagePos1(aktprocsym^.definition^.fileinfo,
parser_e_function_already_declared_public_forward,aktprocsym^.declarationstr);
parser_e_function_already_declared_public_forward,
aktprocsym^.declarationstr(aktprocsym^.definition));
check_identical_proc:=true;
{ Remove other forward from the list to reduce errors }
pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
@ -1814,7 +1815,14 @@ end;
end.
{
$Log$
Revision 1.2 2000-10-15 07:47:51 peter
Revision 1.3 2000-10-21 18:16:11 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.2 2000/10/15 07:47:51 peter
* unit names and procedure names are stored mixed case
Revision 1.1 2000/10/14 10:14:51 peter

26
compiler/pexpr.pas
View File

@ -514,6 +514,23 @@ implementation
statement_syssym := p1;
end;
in_setlength_x:
begin
if token=_LKLAMMER then
begin
consume(_LKLAMMER);
in_args:=true;
paras:=parse_paras(false,false);
consume(_RKLAMMER);
end
else
paras:=nil;
pd:=voiddef;
p1:=geninlinenode(l,false,paras);
do_firstpass(p1);
statement_syssym := p1;
end;
in_write_x,
in_writeln_x :
begin
@ -2357,7 +2374,14 @@ _LECKKLAMMER : begin
end.
{
$Log$
Revision 1.11 2000-10-14 10:14:51 peter
Revision 1.12 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.11 2000/10/14 10:14:51 peter
* moehrendorf oct 2000 rewrite
Revision 1.10 2000/10/01 19:48:25 peter

18
compiler/psub.pas
View File

@ -626,7 +626,8 @@ implementation
{ A method must be forward defined (in the object declaration) }
if assigned(procinfo^._class) and (not assigned(oldprocinfo^._class)) then
begin
Message1(parser_e_header_dont_match_any_member,aktprocsym^.declarationstr);
Message1(parser_e_header_dont_match_any_member,
aktprocsym^.declarationstr(aktprocsym^.definition));
aktprocsym^.write_parameter_lists(aktprocsym^.definition);
end
else
@ -639,7 +640,8 @@ implementation
aktprocsym^.definition^.nextoverloaded^.interfacedef and
not(assigned(aktprocsym^.definition^.nextoverloaded^.nextoverloaded)) then
begin
Message1(parser_e_header_dont_match_forward,aktprocsym^.declarationstr);
Message1(parser_e_header_dont_match_forward,
aktprocsym^.declarationstr(aktprocsym^.definition));
aktprocsym^.write_parameter_lists(aktprocsym^.definition);
end
else
@ -686,7 +688,8 @@ implementation
{ compile procedure when a body is needed }
if (pdflags and pd_body)<>0 then
begin
Message1(parser_p_procedure_start,aktprocsym^.declarationstr);
Message1(parser_p_procedure_start,
aktprocsym^.declarationstr(aktprocsym^.definition));
names^.insert(aktprocsym^.definition^.mangledname);
{ set _FAIL as keyword if constructor }
if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
@ -828,7 +831,14 @@ implementation
end.
{
$Log$
Revision 1.17 2000-10-15 07:47:51 peter
Revision 1.18 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.17 2000/10/15 07:47:51 peter
* unit names and procedure names are stored mixed case
Revision 1.16 2000/10/14 10:14:52 peter

12
compiler/psystem.pas
View File

@ -42,7 +42,7 @@ uses
procedure insertinternsyms(p : psymtable);
{
all intern procedures for system unit
all intern procedures for the system unit
}
begin
p^.insert(new(psyssym,init('Concat',in_concat_x)));
@ -71,6 +71,7 @@ begin
p^.insert(new(psyssym,init('Val',in_val_x)));
p^.insert(new(psyssym,init('Addr',in_addr_x)));
p^.insert(new(psyssym,init('TypeInfo',in_typeinfo_x)));
p^.insert(new(psyssym,init('SetLength',in_setlength_x)));
end;
@ -255,7 +256,14 @@ end;
end.
{
$Log$
Revision 1.6 2000-10-14 10:14:52 peter
Revision 1.7 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.6 2000/10/14 10:14:52 peter
* moehrendorf oct 2000 rewrite
Revision 1.5 2000/09/24 15:06:24 peter

141
compiler/ptype.pas
View File

@ -347,70 +347,80 @@ implementation
begin
consume(_ARRAY);
consume(_LECKKLAMMER);
{ defaults }
arraytype:=generrordef;
lowval:=$80000000;
highval:=$7fffffff;
tt.reset;
repeat
{ read the expression and check it, check apart if the
declaration is an enum declaration because that needs to
be parsed by readtype (PFV) }
if token=_LKLAMMER then
begin
read_type(ht,'');
setdefdecl(ht.def);
end
else
begin
pt:=expr;
if pt.nodetype=typen then
setdefdecl(pt.resulttype)
else
begin
do_firstpass(pt);
if (pt.nodetype=rangen) then
begin
if (trangenode(pt).left.nodetype=ordconstn) and
(trangenode(pt).right.nodetype=ordconstn) then
begin
lowval:=tordconstnode(trangenode(pt).left).value;
highval:=tordconstnode(trangenode(pt).right).value;
if highval<lowval then
begin
Message(parser_e_array_lower_less_than_upper_bound);
highval:=lowval;
end;
arraytype:=trangenode(pt).right.resulttype;
end
else
Message(type_e_cant_eval_constant_expr);
end
{ open array? }
if token=_LECKKLAMMER then
begin
consume(_LECKKLAMMER);
{ defaults }
arraytype:=generrordef;
lowval:=$80000000;
highval:=$7fffffff;
tt.reset;
repeat
{ read the expression and check it, check apart if the
declaration is an enum declaration because that needs to
be parsed by readtype (PFV) }
if token=_LKLAMMER then
begin
read_type(ht,'');
setdefdecl(ht.def);
end
else
begin
pt:=expr;
if pt.nodetype=typen then
setdefdecl(pt.resulttype)
else
Message(sym_e_error_in_type_def)
end;
pt.free;
end;
begin
do_firstpass(pt);
if (pt.nodetype=rangen) then
begin
if (trangenode(pt).left.nodetype=ordconstn) and
(trangenode(pt).right.nodetype=ordconstn) then
begin
lowval:=tordconstnode(trangenode(pt).left).value;
highval:=tordconstnode(trangenode(pt).right).value;
if highval<lowval then
begin
Message(parser_e_array_lower_less_than_upper_bound);
highval:=lowval;
end;
arraytype:=trangenode(pt).right.resulttype;
end
else
Message(type_e_cant_eval_constant_expr);
end
else
Message(sym_e_error_in_type_def)
end;
pt.free;
end;
{ create arraydef }
if not assigned(tt.def) then
begin
ap:=new(parraydef,init(lowval,highval,arraytype));
{ create arraydef }
if not assigned(tt.def) then
begin
ap:=new(parraydef,init(lowval,highval,arraytype));
tt.setdef(ap);
end
else
begin
ap^.elementtype.setdef(new(parraydef,init(lowval,highval,arraytype)));
ap:=parraydef(ap^.elementtype.def);
end;
if token=_COMMA then
consume(_COMMA)
else
break;
until false;
consume(_RECKKLAMMER);
end
else
begin
ap:=new(parraydef,init(0,-1,s32bitdef));
ap^.IsDynamicArray:=true;
tt.setdef(ap);
end
else
begin
ap^.elementtype.setdef(new(parraydef,init(lowval,highval,arraytype)));
ap:=parraydef(ap^.elementtype.def);
end;
if token=_COMMA then
consume(_COMMA)
else
break;
until false;
consume(_RECKKLAMMER);
end;
consume(_OF);
read_type(tt2,'');
{ if no error, set element type }
@ -572,7 +582,14 @@ implementation
end.
{
$Log$
Revision 1.10 2000-10-14 10:14:52 peter
Revision 1.11 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.10 2000/10/14 10:14:52 peter
* moehrendorf oct 2000 rewrite
Revision 1.9 2000/09/24 15:06:25 peter

10
compiler/symconst.pas
View File

@ -53,6 +53,7 @@ const
tkBool = 18;
tkInt64 = 19;
tkQWord = 20;
tkDynArray = 21;
otSByte = 0;
otUByte = 1;
@ -281,7 +282,14 @@ implementation
end.
{
$Log$
Revision 1.9 2000-10-15 07:47:52 peter
Revision 1.10 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.9 2000/10/15 07:47:52 peter
* unit names and procedure names are stored mixed case
Revision 1.8 2000/10/14 10:14:52 peter

37
compiler/symdef.inc
View File

@ -1832,6 +1832,7 @@
IsVariant:=false;
IsConstructor:=false;
IsArrayOfConst:=false;
IsDynamicArray:=false;
rangenr:=0;
end;
@ -1848,6 +1849,8 @@
IsArrayOfConst:=boolean(readbyte);
IsVariant:=false;
IsConstructor:=false;
{$warning FIXME!!!!!}
IsDynamicArray:=false;
rangenr:=0;
end;
@ -1949,6 +1952,11 @@
function tarraydef.size : longint;
begin
{Tarraydef.size may never be called for an open array!}
if IsDynamicArray then
begin
size:=4;
exit;
end;
if highrange<lowrange then
internalerror(99080501);
If (elesize>0) and
@ -1978,7 +1986,7 @@
function tarraydef.needs_inittable : boolean;
begin
needs_inittable:=elementtype.def^.needs_inittable;
needs_inittable:=IsDynamicArray or elementtype.def^.needs_inittable;
end;
@ -1990,14 +1998,20 @@
procedure tarraydef.write_rtti_data;
begin
rttilist^.concat(new(pai_const,init_8bit(tkarray)));
if IsDynamicArray then
rttilist^.concat(new(pai_const,init_8bit(tkdynarray)))
else
rttilist^.concat(new(pai_const,init_8bit(tkarray)));
write_rtti_name;
{ size of elements }
rttilist^.concat(new(pai_const,init_32bit(elesize)));
{ count of elements }
rttilist^.concat(new(pai_const,init_32bit(highrange-lowrange+1)));
if not(IsDynamicArray) then
rttilist^.concat(new(pai_const,init_32bit(highrange-lowrange+1)));
{ element type }
rttilist^.concat(new(pai_const_symbol,initname(elementtype.def^.get_rtti_label)));
{ variant type }
// !!!!!!!!!!!!!!!!
end;
function tarraydef.gettypename : string;
@ -2010,7 +2024,7 @@
else
gettypename:='Array Of '+elementtype.def^.typename;
end
else if is_open_array(@self) then
else if is_open_array(@self) or IsDynamicArray then
gettypename:='Array Of '+elementtype.def^.typename
else
begin
@ -3085,7 +3099,7 @@ Const local_symtable_index : longint = $8001;
end;
{$endif}
function tprocdef.cplusplusmangledname(const rn : string) : string;
function tprocdef.cplusplusmangledname : string;
function getcppparaname(p : pdef) : string;
@ -3117,7 +3131,7 @@ Const local_symtable_index : longint = $8001;
param : pparaitem;
begin
s := rn;
s := procsym^.realname;
if procsym^.owner^.symtabletype=objectsymtable then
begin
s2:=upper(pobjectdef(procsym^.owner^.defowner)^.typesym^.realname);
@ -3624,7 +3638,7 @@ Const local_symtable_index : longint = $8001;
function tobjectdef.vmt_mangledname : string;
{DM: I get a nil pointer on the owner name. I don't know if this
mayhappen, and I have therefore fixed the problem by doing nil pointer
may happen, and I have therefore fixed the problem by doing nil pointer
checks.}
var
s1,s2:string;
@ -4339,7 +4353,14 @@ Const local_symtable_index : longint = $8001;
{
$Log$
Revision 1.23 2000-10-15 07:47:52 peter
Revision 1.24 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.23 2000/10/15 07:47:52 peter
* unit names and procedure names are stored mixed case
Revision 1.22 2000/10/14 10:14:52 peter

12
compiler/symdefh.inc
View File

@ -261,6 +261,7 @@
highrange : longint;
elementtype,
rangetype : ttype;
IsDynamicArray,
IsVariant,
IsConstructor,
IsArrayOfConst : boolean;
@ -464,7 +465,7 @@
{$ifdef dummy}
function procname: string;
{$endif dummy}
function cplusplusmangledname(const rn : string) : string;
function cplusplusmangledname : string;
{ debug }
{$ifdef GDB}
function stabstring : pchar;virtual;
@ -559,7 +560,14 @@
{
$Log$
Revision 1.12 2000-10-15 07:47:52 peter
Revision 1.13 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.12 2000/10/15 07:47:52 peter
* unit names and procedure names are stored mixed case
Revision 1.11 2000/10/14 10:14:53 peter

17
compiler/symsym.inc
View File

@ -394,9 +394,9 @@
end;
function tprocsym.declarationstr:string;
function tprocsym.declarationstr(p : pprocdef):string;
begin
declarationstr:=realname+definition^.demangled_paras;
declarationstr:=realname+p^.demangled_paras;
end;
@ -424,9 +424,9 @@
if pd^.forwarddef then
begin
if assigned(pd^._class) then
MessagePos1(fileinfo,sym_e_forward_not_resolved,pd^._class^.objname^+'.'+declarationstr)
MessagePos1(fileinfo,sym_e_forward_not_resolved,pd^._class^.objname^+'.'+declarationstr(pd))
else
MessagePos1(fileinfo,sym_e_forward_not_resolved,declarationstr);
MessagePos1(fileinfo,sym_e_forward_not_resolved,declarationstr(pd));
{ Turn futher error messages off }
pd^.forwarddef:=false;
end;
@ -2208,7 +2208,14 @@
{
$Log$
Revision 1.10 2000-10-15 07:47:53 peter
Revision 1.11 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.10 2000/10/15 07:47:53 peter
* unit names and procedure names are stored mixed case
Revision 1.9 2000/09/24 21:19:52 peter

11
compiler/symsymh.inc
View File

@ -112,7 +112,7 @@
constructor load;
destructor done;virtual;
function mangledname : string;virtual;
function declarationstr:string;
function declarationstr(p : pprocdef):string;
{ writes all declarations }
procedure write_parameter_lists(skipdef:pprocdef);
{ tests, if all procedures definitions are defined and not }
@ -316,7 +316,14 @@
{
$Log$
Revision 1.6 2000-10-15 07:47:53 peter
Revision 1.7 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.6 2000/10/15 07:47:53 peter
* unit names and procedure names are stored mixed case
Revision 1.5 2000/08/27 20:19:40 peter

32
compiler/types.pas
View File

@ -80,6 +80,9 @@ interface
{ true if p points to an open array def }
function is_open_array(p : pdef) : boolean;
{ true if p points to a dynamic array def }
function is_dynamic_array(p : pdef) : boolean;
{ true, if p points to an array of const def }
function is_array_constructor(p : pdef) : boolean;
@ -564,6 +567,14 @@ implementation
not(is_special_array(p));
end;
{ true if p points to a dynamic array def }
function is_dynamic_array(p : pdef) : boolean;
begin
is_dynamic_array:=(p^.deftype=arraydef) and
parraydef(p)^.IsDynamicArray;
end;
{ true, if p points to an open array def }
function is_open_array(p : pdef) : boolean;
begin
@ -575,7 +586,8 @@ implementation
(parraydef(p)^.highrange=-1) and
not(parraydef(p)^.IsConstructor) and
not(parraydef(p)^.IsVariant) and
not(parraydef(p)^.IsArrayOfConst);
not(parraydef(p)^.IsArrayOfConst) and
not(parraydef(p)^.IsDynamicArray);
end;
@ -1070,12 +1082,15 @@ implementation
else
if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) then
begin
if is_array_of_const(def1) or is_array_of_const(def2) then
begin
if is_dynamic_array(def1) and is_dynamic_array(def2) then
b:=is_equal(parraydef(def1)^.elementtype.def,parraydef(def2)^.elementtype.def)
else
if is_array_of_const(def1) or is_array_of_const(def2) then
begin
b:=(is_array_of_const(def1) and is_array_of_const(def2)) or
(is_array_of_const(def1) and is_array_constructor(def2)) or
(is_array_of_const(def2) and is_array_constructor(def1));
end
end
else
if is_open_array(def1) or is_open_array(def2) then
begin
@ -1669,7 +1684,14 @@ implementation
end.
{
$Log$
Revision 1.14 2000-10-14 10:14:56 peter
Revision 1.15 2000-10-21 18:16:12 florian
* a lot of changes:
- basic dyn. array support
- basic C++ support
- some work for interfaces done
....
Revision 1.14 2000/10/14 10:14:56 peter
* moehrendorf oct 2000 rewrite
Revision 1.13 2000/10/01 19:48:26 peter