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

* Make new/dispose system functions instead of keywords

Browse Source
This commit is contained in:
marco 2001-10-24 11:51:39 +00:00
parent 3c1f350827
commit 7215d46735
5 changed files with 309 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/compinnr.inc
View File

@ -55,6 +55,8 @@ const
in_typeinfo_x = 43; in_typeinfo_x = 43;
in_setlength_x = 44; in_setlength_x = 44;
in_finalize_x = 45; in_finalize_x = 45;
in_new_x = 46;
in_dispose_x = 47;
{ Internal constant functions } { Internal constant functions }
in_const_trunc = 100; in_const_trunc = 100;
@ -102,7 +104,10 @@ const
{ {
$Log$ $Log$
Revision 1.3 2001-07-09 21:15:40 peter Revision 1.4 2001-10-24 11:51:39 marco
* Make new/dispose system functions instead of keywords
Revision 1.3 2001/07/09 21:15:40 peter
* Length made internal * Length made internal
* Add array support for Length * Add array support for Length

348
compiler/pexpr.pas
View File

@ -217,6 +217,241 @@ implementation
end; end;
function new_dispose_statement(is_new:boolean) : tnode;
var
p,p2 : tnode;
again : boolean; { dummy for do_proc_call }
destructorname : stringid;
sym : tsym;
classh : tobjectdef;
destructorpos,
storepos : tfileposinfo;
begin
consume(_LKLAMMER);
p:=comp_expr(true);
{ calc return type }
{ cleartempgen; }
set_varstate(p,(not is_new));
{ constructor,destructor specified }
if try_to_consume(_COMMA) then
begin
{ extended syntax of new and dispose }
{ function styled new is handled in factor }
{ destructors have no parameters }
destructorname:=pattern;
destructorpos:=akttokenpos;
consume(_ID);
if (p.resulttype.def.deftype<>pointerdef) then
begin
Message1(type_e_pointer_type_expected,p.resulttype.def.typename);
p.free;
p:=factor(false);
p.free;
consume(_RKLAMMER);
new_dispose_statement:=cerrornode.create;
exit;
end;
{ first parameter must be an object or class }
if tpointerdef(p.resulttype.def).pointertype.def.deftype<>objectdef then
begin
Message(parser_e_pointer_to_class_expected);
p.free;
new_dispose_statement:=factor(false);
consume_all_until(_RKLAMMER);
consume(_RKLAMMER);
exit;
end;
{ check, if the first parameter is a pointer to a _class_ }
classh:=tobjectdef(tpointerdef(p.resulttype.def).pointertype.def);
if is_class(classh) then
begin
Message(parser_e_no_new_or_dispose_for_classes);
new_dispose_statement:=factor(false);
consume_all_until(_RKLAMMER);
consume(_RKLAMMER);
exit;
end;
{ search cons-/destructor, also in parent classes }
storepos:=akttokenpos;
akttokenpos:=destructorpos;
sym:=search_class_member(classh,destructorname);
akttokenpos:=storepos;
{ the second parameter of new/dispose must be a call }
{ to a cons-/destructor }
if (not assigned(sym)) or (sym.typ<>procsym) then
begin
if is_new then
Message(parser_e_expr_have_to_be_constructor_call)
else
Message(parser_e_expr_have_to_be_destructor_call);
p.free;
new_dispose_statement:=cerrornode.create;
end
else
begin
if is_new then
p2:=chnewnode.create
else
p2:=chdisposenode.create(p);
do_resulttypepass(p2);
p2.resulttype:=tpointerdef(p.resulttype.def).pointertype;
if is_new then
do_member_read(false,sym,p2,again)
else
begin
if (m_tp in aktmodeswitches) then
do_member_read(false,sym,p2,again)
else
begin
p2:=ccallnode.create(nil,tprocsym(sym),sym.owner,p2);
{ support dispose(p,done()); }
if try_to_consume(_LKLAMMER) then
begin
if not try_to_consume(_RKLAMMER) then
begin
Message(parser_e_no_paras_for_destructor);
consume_all_until(_RKLAMMER);
consume(_RKLAMMER);
end;
end;
end;
end;
{ we need the real called method }
{ cleartempgen;}
do_resulttypepass(p2);
if not codegenerror then
begin
if is_new then
begin
if (tcallnode(p2).procdefinition.proctypeoption<>potype_constructor) then
Message(parser_e_expr_have_to_be_constructor_call);
p2:=cnewnode.create(p2);
do_resulttypepass(p2);
p2.resulttype:=p.resulttype;
p2:=cassignmentnode.create(p,p2);
end
else
begin
if (tcallnode(p2).procdefinition.proctypeoption<>potype_destructor) then
Message(parser_e_expr_have_to_be_destructor_call);
end;
end;
new_dispose_statement:=p2;
end;
end
else
begin
if (p.resulttype.def.deftype<>pointerdef) then
Begin
Message1(type_e_pointer_type_expected,p.resulttype.def.typename);
new_dispose_statement:=cerrornode.create;
end
else
begin
if (tpointerdef(p.resulttype.def).pointertype.def.deftype=objectdef) and
(oo_has_vmt in tobjectdef(tpointerdef(p.resulttype.def).pointertype.def).objectoptions) then
Message(parser_w_use_extended_syntax_for_objects);
if (tpointerdef(p.resulttype.def).pointertype.def.deftype=orddef) and
(torddef(tpointerdef(p.resulttype.def).pointertype.def).typ=uvoid) then
begin
if (m_tp in aktmodeswitches) or
(m_delphi in aktmodeswitches) then
Message(parser_w_no_new_dispose_on_void_pointers)
else
Message(parser_e_no_new_dispose_on_void_pointers);
end;
if is_new then
new_dispose_statement:=csimplenewdisposenode.create(simplenewn,p)
else
new_dispose_statement:=csimplenewdisposenode.create(simpledisposen,p);
end;
end;
consume(_RKLAMMER);
end;
function new_function : tnode;
var
p1,p2 : tnode;
classh : tobjectdef;
sym : tsym;
again : boolean; { dummy for do_proc_call }
begin
consume(_LKLAMMER);
p1:=factor(false);
if p1.nodetype<>typen then
begin
Message(type_e_type_id_expected);
p1.destroy;
p1:=cerrornode.create;
do_resulttypepass(p1);
end;
if (p1.resulttype.def.deftype<>pointerdef) then
Message1(type_e_pointer_type_expected,p1.resulttype.def.typename)
else
if token=_RKLAMMER then
begin
if (tpointerdef(p1.resulttype.def).pointertype.def.deftype=objectdef) and
(oo_has_vmt in tobjectdef(tpointerdef(p1.resulttype.def).pointertype.def).objectoptions) then
Message(parser_w_use_extended_syntax_for_objects);
p2:=cnewnode.create(nil);
do_resulttypepass(p2);
p2.resulttype:=p1.resulttype;
p1.destroy;
p1:=p2;
consume(_RKLAMMER);
end
else
begin
p2:=chnewnode.create;
do_resulttypepass(p2);
p2.resulttype:=tpointerdef(p1.resulttype.def).pointertype;
consume(_COMMA);
afterassignment:=false;
{ determines the current object defintion }
classh:=tobjectdef(p2.resulttype.def);
if classh.deftype<>objectdef then
Message(parser_e_pointer_to_class_expected)
else
begin
{ check for an abstract class }
if (oo_has_abstract in classh.objectoptions) then
Message(sym_e_no_instance_of_abstract_object);
{ search the constructor also in the symbol tables of
the parents }
sym:=nil;
while assigned(classh) do
begin
sym:=tsym(classh.symtable.search(pattern));
if assigned(sym) then
break;
classh:=classh.childof;
end;
consume(_ID);
do_member_read(false,sym,p2,again);
{ we need to know which procedure is called }
do_resulttypepass(p2);
if (p2.nodetype<>calln) or
(assigned(tcallnode(p2).procdefinition) and
(tcallnode(p2).procdefinition.proctypeoption<>potype_constructor)) then
Message(parser_e_expr_have_to_be_constructor_call);
end;
p2:=cnewnode.create(p2);
do_resulttypepass(p2);
p2.resulttype:=p1.resulttype;
p1.destroy;
p1:=p2;
consume(_RKLAMMER);
end;
new_function:=p1;
end;
function statement_syssym(l : longint) : tnode; function statement_syssym(l : longint) : tnode;
var var
p1,p2,paras : tnode; p1,p2,paras : tnode;
@ -224,6 +459,20 @@ implementation
begin begin
prev_in_args:=in_args; prev_in_args:=in_args;
case l of case l of
in_new_x :
begin
if afterassignment or in_args then
statement_syssym:=new_function
else
statement_syssym:=new_dispose_statement(true);
end;
in_dispose_x :
begin
statement_syssym:=new_dispose_statement(false);
end;
in_ord_x : in_ord_x :
begin begin
consume(_LKLAMMER); consume(_LKLAMMER);
@ -1052,7 +1301,9 @@ implementation
end; end;
syssym : syssym :
p1:=statement_syssym(tsyssym(srsym).number); begin
p1:=statement_syssym(tsyssym(srsym).number);
end;
typesym : typesym :
begin begin
@ -1687,90 +1938,14 @@ implementation
again:=false; again:=false;
if token=_ID then if token=_ID then
begin begin
if idtoken=_NEW then factor_read_id(p1,again);
begin if again then
consume(_NEW); begin
consume(_LKLAMMER); check_tokenpos;
p1:=factor(false);
if p1.nodetype<>typen then
begin
Message(type_e_type_id_expected);
p1.destroy;
p1:=cerrornode.create;
do_resulttypepass(p1);
end;
if (p1.resulttype.def.deftype<>pointerdef) then { handle post fix operators }
Message1(type_e_pointer_type_expected,p1.resulttype.def.typename) postfixoperators(p1,again);
else end;
if token=_RKLAMMER then
begin
if (tpointerdef(p1.resulttype.def).pointertype.def.deftype=objectdef) and
(oo_has_vmt in tobjectdef(tpointerdef(p1.resulttype.def).pointertype.def).objectoptions) then
Message(parser_w_use_extended_syntax_for_objects);
p2:=cnewnode.create(nil);
do_resulttypepass(p2);
p2.resulttype:=p1.resulttype;
p1.destroy;
p1:=p2;
consume(_RKLAMMER);
end
else
begin
p2:=chnewnode.create;
do_resulttypepass(p2);
p2.resulttype:=tpointerdef(p1.resulttype.def).pointertype;
consume(_COMMA);
afterassignment:=false;
{ determines the current object defintion }
classh:=tobjectdef(p2.resulttype.def);
if classh.deftype<>objectdef then
Message(parser_e_pointer_to_class_expected)
else
begin
{ check for an abstract class }
if (oo_has_abstract in classh.objectoptions) then
Message(sym_e_no_instance_of_abstract_object);
{ search the constructor also in the symbol tables of
the parents }
sym:=nil;
while assigned(classh) do
begin
sym:=tsym(classh.symtable.search(pattern));
if assigned(sym) then
break;
classh:=classh.childof;
end;
consume(_ID);
do_member_read(false,sym,p2,again);
{ we need to know which procedure is called }
do_resulttypepass(p2);
if (p2.nodetype<>calln) or
(assigned(tcallnode(p2).procdefinition) and
(tcallnode(p2).procdefinition.proctypeoption<>potype_constructor)) then
Message(parser_e_expr_have_to_be_constructor_call);
end;
p2:=cnewnode.create(p2);
do_resulttypepass(p2);
p2.resulttype:=p1.resulttype;
p1.destroy;
p1:=p2;
consume(_RKLAMMER);
end;
postfixoperators(p1,again);
end
else
begin
factor_read_id(p1,again);
if again then
begin
check_tokenpos;
{ handle post fix operators }
postfixoperators(p1,again);
end;
end;
end end
else else
case token of case token of
@ -2333,7 +2508,10 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.46 2001-10-21 13:10:51 peter Revision 1.47 2001-10-24 11:51:39 marco
* Make new/dispose system functions instead of keywords
Revision 1.46 2001/10/21 13:10:51 peter
* better support for indexed properties * better support for indexed properties
Revision 1.45 2001/10/21 12:33:07 peter Revision 1.45 2001/10/21 12:33:07 peter

224
compiler/pstatmnt.pas
View File

@ -873,171 +873,6 @@ implementation
end; end;
function new_dispose_statement : tnode;
var
p,p2 : tnode;
again : boolean; { dummy for do_proc_call }
destructorname : stringid;
sym : tsym;
classh : tobjectdef;
destructorpos,
storepos : tfileposinfo;
is_new : boolean;
begin
if try_to_consume(_NEW) then
is_new:=true
else
begin
consume(_DISPOSE);
is_new:=false;
end;
consume(_LKLAMMER);
p:=comp_expr(true);
{ calc return type }
cleartempgen;
set_varstate(p,(not is_new));
{ constructor,destructor specified }
if try_to_consume(_COMMA) then
begin
{ extended syntax of new and dispose }
{ function styled new is handled in factor }
{ destructors have no parameters }
destructorname:=pattern;
destructorpos:=akttokenpos;
consume(_ID);
if (p.resulttype.def.deftype<>pointerdef) then
begin
Message1(type_e_pointer_type_expected,p.resulttype.def.typename);
p.free;
p:=factor(false);
p.free;
consume(_RKLAMMER);
new_dispose_statement:=cerrornode.create;
exit;
end;
{ first parameter must be an object or class }
if tpointerdef(p.resulttype.def).pointertype.def.deftype<>objectdef then
begin
Message(parser_e_pointer_to_class_expected);
p.free;
new_dispose_statement:=factor(false);
consume_all_until(_RKLAMMER);
consume(_RKLAMMER);
exit;
end;
{ check, if the first parameter is a pointer to a _class_ }
classh:=tobjectdef(tpointerdef(p.resulttype.def).pointertype.def);
if is_class(classh) then
begin
Message(parser_e_no_new_or_dispose_for_classes);
new_dispose_statement:=factor(false);
consume_all_until(_RKLAMMER);
consume(_RKLAMMER);
exit;
end;
{ search cons-/destructor, also in parent classes }
storepos:=akttokenpos;
akttokenpos:=destructorpos;
sym:=search_class_member(classh,destructorname);
akttokenpos:=storepos;
{ the second parameter of new/dispose must be a call }
{ to a cons-/destructor }
if (not assigned(sym)) or (sym.typ<>procsym) then
begin
if is_new then
Message(parser_e_expr_have_to_be_constructor_call)
else
Message(parser_e_expr_have_to_be_destructor_call);
p.free;
new_dispose_statement:=cerrornode.create;
end
else
begin
if is_new then
p2:=chnewnode.create
else
p2:=chdisposenode.create(p);
do_resulttypepass(p2);
p2.resulttype:=tpointerdef(p.resulttype.def).pointertype;
if is_new then
do_member_read(false,sym,p2,again)
else
begin
if (m_tp in aktmodeswitches) then
do_member_read(false,sym,p2,again)
else
begin
p2:=ccallnode.create(nil,tprocsym(sym),sym.owner,p2);
{ support dispose(p,done()); }
if try_to_consume(_LKLAMMER) then
begin
if not try_to_consume(_RKLAMMER) then
begin
Message(parser_e_no_paras_for_destructor);
consume_all_until(_RKLAMMER);
consume(_RKLAMMER);
end;
end;
end;
end;
{ we need the real called method }
cleartempgen;
do_resulttypepass(p2);
if not codegenerror then
begin
if is_new then
begin
if (tcallnode(p2).procdefinition.proctypeoption<>potype_constructor) then
Message(parser_e_expr_have_to_be_constructor_call);
p2:=cnewnode.create(p2);
do_resulttypepass(p2);
p2.resulttype:=p.resulttype;
p2:=cassignmentnode.create(p,p2);
end
else
begin
if (tcallnode(p2).procdefinition.proctypeoption<>potype_destructor) then
Message(parser_e_expr_have_to_be_destructor_call);
end;
end;
new_dispose_statement:=p2;
end;
end
else
begin
if (p.resulttype.def.deftype<>pointerdef) then
Begin
Message1(type_e_pointer_type_expected,p.resulttype.def.typename);
new_dispose_statement:=cerrornode.create;
end
else
begin
if (tpointerdef(p.resulttype.def).pointertype.def.deftype=objectdef) and
(oo_has_vmt in tobjectdef(tpointerdef(p.resulttype.def).pointertype.def).objectoptions) then
Message(parser_w_use_extended_syntax_for_objects);
if (tpointerdef(p.resulttype.def).pointertype.def.deftype=orddef) and
(torddef(tpointerdef(p.resulttype.def).pointertype.def).typ=uvoid) then
begin
if (m_tp in aktmodeswitches) or
(m_delphi in aktmodeswitches) then
Message(parser_w_no_new_dispose_on_void_pointers)
else
Message(parser_e_no_new_dispose_on_void_pointers);
end;
if is_new then
new_dispose_statement:=csimplenewdisposenode.create(simplenewn,p)
else
new_dispose_statement:=csimplenewdisposenode.create(simpledisposen,p);
end;
end;
consume(_RKLAMMER);
end;
function statement : tnode; function statement : tnode;
var var
p : tnode; p : tnode;
@ -1114,36 +949,34 @@ implementation
Message(scan_f_end_of_file); Message(scan_f_end_of_file);
else else
begin begin
if (idtoken=_NEW) or (idtoken=_DISPOSE) then p:=expr;
code:=new_dispose_statement
else
begin
p:=expr;
if p.nodetype=labeln then if p.nodetype=labeln then
begin begin
{ the pointer to the following instruction } { the pointer to the following instruction }
{ isn't a very clean way } { isn't a very clean way }
tlabelnode(p).left:=statement{$ifdef FPCPROCVAR}(){$endif}; tlabelnode(p).left:=statement{$ifdef FPCPROCVAR}(){$endif};
{ be sure to have left also resulttypepass } { be sure to have left also resulttypepass }
resulttypepass(tlabelnode(p).left); resulttypepass(tlabelnode(p).left);
end; end;
{ blockn support because a read/write is changed into a blocknode } { blockn support because a read/write is changed into a blocknode }
{ with a separate statement for each read/write operation (JM) } { with a separate statement for each read/write operation (JM) }
{ the same is true for val() if the third parameter is not 32 bit } { the same is true for val() if the third parameter is not 32 bit }
if not(p.nodetype in [calln,assignn,breakn,inlinen,continuen,labeln,blockn]) then if not(p.nodetype in [calln,assignn,breakn,inlinen,continuen,labeln,blockn,
Message(cg_e_illegal_expression); simplenewn,simpledisposen]) then
{ specify that we don't use the value returned by the call } Message(cg_e_illegal_expression);
{ Question : can this be also improtant
for inlinen ?? { specify that we don't use the value returned by the call }
it is used for : { Question : can this be also improtant
- dispose of temp stack space for inlinen ??
- dispose on FPU stack } it is used for :
if p.nodetype=calln then - dispose of temp stack space
exclude(p.flags,nf_return_value_used); - dispose on FPU stack }
code:=p; if p.nodetype=calln then
end; exclude(p.flags,nf_return_value_used);
code:=p;
end; end;
end; end;
if assigned(code) then if assigned(code) then
@ -1282,7 +1115,10 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.39 2001-10-17 22:41:04 florian Revision 1.40 2001-10-24 11:51:39 marco
* Make new/dispose system functions instead of keywords
Revision 1.39 2001/10/17 22:41:04 florian
* several widechar fixes, case works now * several widechar fixes, case works now
Revision 1.38 2001/10/16 15:10:35 jonas Revision 1.38 2001/10/16 15:10:35 jonas

7
compiler/psystem.pas
View File

@ -76,6 +76,8 @@ begin
p.insert(tsyssym.create('SetLength',in_setlength_x)); p.insert(tsyssym.create('SetLength',in_setlength_x));
p.insert(tsyssym.create('Finalize',in_finalize_x)); p.insert(tsyssym.create('Finalize',in_finalize_x));
p.insert(tsyssym.create('Length',in_length_x)); p.insert(tsyssym.create('Length',in_length_x));
p.insert(tsyssym.create('New',in_new_x));
p.insert(tsyssym.create('Dispose',in_dispose_x));
end; end;
@ -275,7 +277,10 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.19 2001-08-30 20:13:53 peter Revision 1.20 2001-10-24 11:51:39 marco
* Make new/dispose system functions instead of keywords
Revision 1.19 2001/08/30 20:13:53 peter
* rtti/init table updates * rtti/init table updates
* rttisym for reusable global rtti/init info * rttisym for reusable global rtti/init info
* support published for interfaces * support published for interfaces

9
compiler/tokens.pas
View File

@ -106,7 +106,6 @@ type
_FAR, _FAR,
_FOR, _FOR,
_MOD, _MOD,
_NEW,
_NIL, _NIL,
_NOT, _NOT,
_OUT, _OUT,
@ -167,7 +166,6 @@ type
_ASMNAME, _ASMNAME,
_CPPDECL, _CPPDECL,
_DEFAULT, _DEFAULT,
_DISPOSE,
_DYNAMIC, _DYNAMIC,
_EXPORTS, _EXPORTS,
_FINALLY, _FINALLY,
@ -331,7 +329,6 @@ const
(str:'FAR' ;special:false;keyword:m_none;op:NOTOKEN), (str:'FAR' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'FOR' ;special:false;keyword:m_all;op:NOTOKEN), (str:'FOR' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'MOD' ;special:false;keyword:m_all;op:_OP_MOD), (str:'MOD' ;special:false;keyword:m_all;op:_OP_MOD),
(str:'NEW' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'NIL' ;special:false;keyword:m_all;op:NOTOKEN), (str:'NIL' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'NOT' ;special:false;keyword:m_all;op:_OP_NOT), (str:'NOT' ;special:false;keyword:m_all;op:_OP_NOT),
(str:'OUT' ;special:false;keyword:m_none;op:NOTOKEN), (str:'OUT' ;special:false;keyword:m_none;op:NOTOKEN),
@ -392,7 +389,6 @@ const
(str:'ASMNAME' ;special:false;keyword:m_none;op:NOTOKEN), (str:'ASMNAME' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'CPPDECL' ;special:false;keyword:m_none;op:NOTOKEN), (str:'CPPDECL' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'DEFAULT' ;special:false;keyword:m_none;op:NOTOKEN), (str:'DEFAULT' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'DISPOSE' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'DYNAMIC' ;special:false;keyword:m_none;op:NOTOKEN), (str:'DYNAMIC' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'EXPORTS' ;special:false;keyword:m_all;op:NOTOKEN), (str:'EXPORTS' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'FINALLY' ;special:false;keyword:m_class;op:NOTOKEN), (str:'FINALLY' ;special:false;keyword:m_class;op:NOTOKEN),
@ -501,7 +497,10 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.14 2001-10-23 21:49:43 peter Revision 1.15 2001-10-24 11:51:39 marco
* Make new/dispose system functions instead of keywords
Revision 1.14 2001/10/23 21:49:43 peter
* $calling directive and -Cc commandline patch added * $calling directive and -Cc commandline patch added
from Pavel Ozerski from Pavel Ozerski