mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 19:49:38 +02:00
410 lines
8.7 KiB
ObjectPascal
410 lines
8.7 KiB
ObjectPascal
unit h2ptypes;
|
|
|
|
// {$mode ObjFPC}
|
|
{$inline on}
|
|
{$modeswitch result}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils;
|
|
|
|
type
|
|
Char=system.ansichar;
|
|
ttyp = (
|
|
t_id,
|
|
{ p contains the string }
|
|
t_arraydef,
|
|
{ }
|
|
t_pointerdef,
|
|
{ p1 contains the definition
|
|
if in type overrider
|
|
or nothing for args
|
|
}
|
|
t_addrdef,
|
|
|
|
t_void,
|
|
{ no field }
|
|
t_dec,
|
|
{ }
|
|
t_declist,
|
|
{ p1 is t_dec
|
|
next if exists }
|
|
t_memberdec,
|
|
{ p1 is type specifier
|
|
p2 is declarator_list }
|
|
t_structdef,
|
|
{ }
|
|
t_memberdeclist,
|
|
{ p1 is memberdec
|
|
next is next if it exist }
|
|
t_procdef,
|
|
{ }
|
|
t_uniondef,
|
|
{ }
|
|
t_enumdef,
|
|
{ }
|
|
t_enumlist,
|
|
{ }
|
|
t_preop,
|
|
{ p contains the operator string
|
|
p1 contains the right expr }
|
|
t_bop,
|
|
{ p contains the operator string
|
|
p1 contains the left expr
|
|
p2 contains the right expr }
|
|
t_arrayop,
|
|
{
|
|
p1 contains the array expr
|
|
p2 contains the index expressions }
|
|
t_callop,
|
|
{
|
|
p1 contains the proc expr
|
|
p2 contains the index expressions }
|
|
t_arg,
|
|
{
|
|
p1 contain the typedef
|
|
p2 the declarator (t_dec)
|
|
}
|
|
t_arglist,
|
|
{ }
|
|
t_funexprlist,
|
|
{ }
|
|
t_exprlist,
|
|
{ p1 contains the expr
|
|
next contains the next if it exists }
|
|
t_ifexpr,
|
|
{ p1 contains the condition expr
|
|
p2 contains the if branch
|
|
p3 contains the else branch }
|
|
t_funcname,
|
|
{ p1 contains the function dname
|
|
p2 contains the funexprlist
|
|
p3 possibly contains the return type }
|
|
t_typespec,
|
|
{ p1 is the type itself
|
|
p2 the typecast expr }
|
|
t_size_specifier,
|
|
{ p1 expr for size }
|
|
t_default_value,
|
|
{ p1 expr for value }
|
|
t_statement_list,
|
|
{ p1 is the statement
|
|
next is next if it exist }
|
|
t_whilenode,
|
|
t_fornode,
|
|
t_dowhilenode,
|
|
t_switchnode,
|
|
t_gotonode,
|
|
t_continuenode,
|
|
t_breaknode
|
|
);
|
|
|
|
const
|
|
ttypstr: array[ttyp] of string =
|
|
(
|
|
't_id',
|
|
't_arraydef',
|
|
't_pointerdef',
|
|
't_addrdef',
|
|
't_void',
|
|
't_dec',
|
|
't_declist',
|
|
't_memberdec',
|
|
't_structdef',
|
|
't_memberdeclist',
|
|
't_procdef',
|
|
't_uniondef',
|
|
't_enumdef',
|
|
't_enumlist',
|
|
't_preop',
|
|
't_bop',
|
|
't_arrayop',
|
|
't_callop',
|
|
't_arg',
|
|
't_arglist',
|
|
't_funexprlist',
|
|
't_exprlist',
|
|
't_ifexpr',
|
|
't_funcname',
|
|
't_typespec',
|
|
't_size_specifier',
|
|
't_default_value',
|
|
't_statement_list',
|
|
't_whilenode',
|
|
't_fornode',
|
|
't_dowhilenode',
|
|
't_switchnode',
|
|
't_gotonode',
|
|
't_continuenode',
|
|
't_breaknode'
|
|
);
|
|
|
|
type
|
|
presobject = ^tresobject;
|
|
tresobject = object
|
|
typ : ttyp;
|
|
p : pansichar;
|
|
next : presobject;
|
|
p1,p2,p3 : presobject;
|
|
{ name of int/real, then no T prefix is required }
|
|
skiptprefix : boolean;
|
|
constructor init_no(t : ttyp);
|
|
constructor init_one(t : ttyp;_p1 : presobject);
|
|
constructor init_two(t : ttyp;_p1,_p2 : presobject);
|
|
constructor init_three(t : ttyp;_p1,_p2,_p3 : presobject);
|
|
constructor init_id(const s : string);
|
|
constructor init_intid(const s : string);
|
|
constructor init_bop(const s : string;_p1,_p2 : presobject);
|
|
constructor init_preop(const s : string;_p1 : presobject);
|
|
procedure setstr(const s:string);
|
|
function str : string;
|
|
function strlength : byte;
|
|
function get_copy : presobject;
|
|
{ can this ve considered as a constant ? }
|
|
function is_const : boolean;
|
|
destructor done;
|
|
end;
|
|
|
|
tblocktype = (bt_type,bt_const,bt_var,bt_func,bt_no);
|
|
|
|
Function NewUnaryOp(const aop : ansistring; aright : presobject) : presobject; inline;
|
|
Function NewBinaryOp(const aop : ansistring; aleft,aright : presobject) : presobject; inline;
|
|
Function NewVoid : presobject; inline;
|
|
Function NewID(const aID : ansistring) : presobject; inline;
|
|
Function NewType1(aType : ttyp; aID : presobject) : presobject; inline;
|
|
Function NewType2(aType : ttyp; aID,aID2 : presobject) : presobject; inline;
|
|
Function NewType3(aType : ttyp; aID,aID2,aID3 : presobject) : presobject; inline;
|
|
Function NewIntID(const aPascalType : ansistring) : presobject; inline;
|
|
function strpnew(const s : ansistring) : pansichar; inline;
|
|
|
|
implementation
|
|
|
|
uses h2poptions, strings;
|
|
|
|
|
|
Function NewVoid : presobject;
|
|
|
|
begin
|
|
Result:=new(presobject,init_no(t_void));
|
|
end;
|
|
|
|
Function NewBinaryOp(const aop : ansistring; aleft,aright : presobject) : presobject;
|
|
|
|
begin
|
|
Result:=new(presobject,init_bop(aop,aleft,aright));
|
|
end;
|
|
|
|
Function NewUnaryOp(const aop : ansistring; aright : presobject) : presobject; inline;
|
|
|
|
begin
|
|
Result:=new(presobject,init_preop(aop,aright));
|
|
end;
|
|
|
|
|
|
Function NewID(const aID : ansistring) : presobject;
|
|
|
|
begin
|
|
if useansichar and (aId='char') then
|
|
Result:=new(presobject,init_id('AnsiChar'))
|
|
else
|
|
Result:=new(presobject,init_id(aID));
|
|
end;
|
|
|
|
Function NewIntID(const aPascalType : ansistring) : presobject;
|
|
|
|
begin
|
|
Result:=new(presobject,init_intid(aPascalType));
|
|
end;
|
|
|
|
Function NewType1(aType : ttyp; aID : presobject) : presobject; inline;
|
|
|
|
begin
|
|
Result:=new(presobject,init_one(atype,aID));
|
|
end;
|
|
|
|
Function NewType2(aType : ttyp; aID,aID2 : presobject) : presobject; inline;
|
|
|
|
begin
|
|
Result:=new(presobject,init_two(atype,aID,aID2));
|
|
end;
|
|
|
|
Function NewType3(aType : ttyp; aID,aID2,aID3 : presobject) : presobject; inline;
|
|
|
|
begin
|
|
Result:=new(presobject,init_three(atype,aID,aID2,aID3));
|
|
end;
|
|
|
|
function strpnew(const s : ansistring) : pansichar;
|
|
var
|
|
p : pansichar;
|
|
begin
|
|
getmem(p,length(s)+1);
|
|
strpcopy(p,s);
|
|
strpnew:=p;
|
|
end;
|
|
|
|
|
|
constructor tresobject.init_preop(const s : string;_p1 : presobject);
|
|
begin
|
|
typ:=t_preop;
|
|
p:=strpnew(s);
|
|
p1:=_p1;
|
|
p2:=nil;
|
|
p3:=nil;
|
|
next:=nil;
|
|
skiptprefix:=false;
|
|
end;
|
|
|
|
constructor tresobject.init_bop(const s : string;_p1,_p2 : presobject);
|
|
begin
|
|
typ:=t_bop;
|
|
p:=strpnew(s);
|
|
p1:=_p1;
|
|
p2:=_p2;
|
|
p3:=nil;
|
|
next:=nil;
|
|
skiptprefix:=false;
|
|
end;
|
|
|
|
constructor tresobject.init_id(const s : string);
|
|
begin
|
|
typ:=t_id;
|
|
p:=strpnew(s);
|
|
p1:=nil;
|
|
p2:=nil;
|
|
p3:=nil;
|
|
next:=nil;
|
|
skiptprefix:=false;
|
|
end;
|
|
|
|
constructor tresobject.init_intid(const s : string);
|
|
begin
|
|
typ:=t_id;
|
|
if useansichar and (s='char') then
|
|
p:=strpnew('ansichar')
|
|
else
|
|
p:=strpnew(s);
|
|
p1:=nil;
|
|
p2:=nil;
|
|
p3:=nil;
|
|
next:=nil;
|
|
skiptprefix:=true;
|
|
end;
|
|
|
|
constructor tresobject.init_two(t : ttyp;_p1,_p2 : presobject);
|
|
begin
|
|
typ:=t;
|
|
p1:=_p1;
|
|
p2:=_p2;
|
|
p3:=nil;
|
|
p:=nil;
|
|
next:=nil;
|
|
skiptprefix:=false;
|
|
end;
|
|
|
|
constructor tresobject.init_three(t : ttyp;_p1,_p2,_p3 : presobject);
|
|
begin
|
|
typ:=t;
|
|
p1:=_p1;
|
|
p2:=_p2;
|
|
p3:=_p3;
|
|
p:=nil;
|
|
next:=nil;
|
|
skiptprefix:=false;
|
|
end;
|
|
|
|
constructor tresobject.init_one(t : ttyp;_p1 : presobject);
|
|
begin
|
|
typ:=t;
|
|
p1:=_p1;
|
|
p2:=nil;
|
|
p3:=nil;
|
|
next:=nil;
|
|
p:=nil;
|
|
skiptprefix:=false;
|
|
end;
|
|
|
|
constructor tresobject.init_no(t : ttyp);
|
|
begin
|
|
typ:=t;
|
|
p:=nil;
|
|
p1:=nil;
|
|
p2:=nil;
|
|
p3:=nil;
|
|
next:=nil;
|
|
skiptprefix:=false;
|
|
end;
|
|
|
|
procedure tresobject.setstr(const s : string);
|
|
begin
|
|
if assigned(p) then
|
|
strdispose(p);
|
|
p:=strpnew(s);
|
|
end;
|
|
|
|
function tresobject.str : string;
|
|
begin
|
|
str:=strpas(p);
|
|
end;
|
|
|
|
function tresobject.strlength : byte;
|
|
begin
|
|
if assigned(p) then
|
|
strlength:=strlen(p)
|
|
else
|
|
strlength:=0;
|
|
end;
|
|
|
|
{ can this ve considered as a constant ? }
|
|
function tresobject.is_const : boolean;
|
|
begin
|
|
case typ of
|
|
t_id,t_void :
|
|
is_const:=true;
|
|
t_preop :
|
|
is_const:= ((str='-') or (str=' not ')) and p1^.is_const;
|
|
t_bop :
|
|
is_const:= p2^.is_const and p1^.is_const;
|
|
else
|
|
is_const:=false;
|
|
end;
|
|
end;
|
|
|
|
function tresobject.get_copy : presobject;
|
|
var
|
|
newres : presobject;
|
|
begin
|
|
newres:=new(presobject,init_no(typ));
|
|
newres^.skiptprefix:=skiptprefix;
|
|
if assigned(p) then
|
|
newres^.p:=strnew(p);
|
|
if assigned(p1) then
|
|
newres^.p1:=p1^.get_copy;
|
|
if assigned(p2) then
|
|
newres^.p2:=p2^.get_copy;
|
|
if assigned(p3) then
|
|
newres^.p3:=p3^.get_copy;
|
|
if assigned(next) then
|
|
newres^.next:=next^.get_copy;
|
|
get_copy:=newres;
|
|
end;
|
|
|
|
destructor tresobject.done;
|
|
begin
|
|
(* writeln('disposing ',byte(typ)); *)
|
|
if assigned(p)then strdispose(p);
|
|
if assigned(p1) then
|
|
dispose(p1,done);
|
|
if assigned(p2) then
|
|
dispose(p2,done);
|
|
if assigned(p3) then
|
|
dispose(p3,done);
|
|
if assigned(next) then
|
|
dispose(next,done);
|
|
end;
|
|
|
|
|
|
end.
|
|
|