paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 06:59:42 +02:00
Code Issues Packages Projects Releases Wiki Activity
basemath
fpc/utils/h2pas/h2pbase.pp
Michael VAN CANNEYT 30698ea06c * Prevent writing pointer types twice
2023-07-25 16:06:49 +02:00

1240 lines
35 KiB
ObjectPascal
Raw Permalink Blame History

(*
Copyright (c) 1998-2000 by Florian Klaempfl
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
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************)
unit h2pbase;
{$modeswitch result}
{$message TODO: warning Unit types is only needed due to issue 7910}
interface
uses
SysUtils, classes,
h2poptions,scan,h2pconst,h2plexlib,h2pyacclib, scanbase,h2pout,h2ptypes;
type
YYSTYPE = presobject;
var
s,TN,PN : String;
(* $ define yydebug
compile with -dYYDEBUG to get debugging info *)
procedure yymsg(const msg : string);
function ellipsisarg : presobject;
function HandleErrorDecl(e1,e2 : presobject) : presobject;
Function HandleDeclarationStatement(decl,type_spec,modifier_spec,decllist_spec,block_spec : presobject) : presobject;
Function HandleDeclarationSysTrap(decl,type_spec,modifier_spec,decllist_spec,sys_trap : presobject) : presobject;
function HandleSpecialType(aType: presobject) : presobject;
function HandleTypedef(type_spec,dec_modifier,declarator,arg_decl_list: presobject) : presobject;
function HandleTypedefList(type_spec,dec_modifier,declarator_list: presobject) : presobject;
function HandleStructDef(dname1,dname2 : presobject) : presobject;
function HandleSimpleTypeDef(tname : presobject) : presobject;
function HandleDeclarator(aTyp : ttyp; aright: presobject): presobject;
function HandleDeclarator2(aTyp : ttyp; aleft,aright: presobject): presobject;
function HandleSizedDeclarator(psym,psize : presobject) : presobject;
function HandleSizedPointerDeclarator(psym,psize : presobject) : presobject;
function HandleSizeOverrideDeclarator(psize,psym : presobject) : presobject;
function HandleDefaultDeclarator(psym,pdefault : presobject) : presobject;
function HandleArgList(aEl,aList : PResObject) : PResObject;
function HandlePointerArgDeclarator(ptype, psym : presobject): presobject;
function HandlePointerAbstractDeclarator(psym : presobject): presobject;
function HandlePointerAbstractListDeclarator(psym,plist : presobject): presobject;
function HandleDeclarationList(plist,pelem : presobject) : presobject;
function handleSpecialSignedType(aType : presobject) : presobject;
function handleSpecialUnSignedType(aType : presobject) : presobject;
function handleArrayDecl(aType : presobject) : presobject;
function handleSizedArrayDecl(aType,aSizeExpr: presobject): presobject;
function handleFuncNoArg(aType: presobject): presobject;
function handleFuncExpr(aType,aList: presobject): presobject;
function handlePointerType(aType,aPointer,aSize : presobject): presobject;
function HandleUnaryDefExpr(aExpr : presobject) : presobject;
function HandleTernary(expr,colonexpr : presobject) : presobject;
// Macros
function HandleDefineMacro(dname,enum_list,para_def_expr: presobject) : presobject;
function HandleDefineConst(dname,def_expr: presobject) : presobject;
function HandleDefine(dname : presobject) : presobject;
Function CheckWideString(S : String) : presobject;
function CheckUnderScore(pdecl : presobject) : presobject;
Function NewCType(aCType,aPascalType : String) : PresObject;
Implementation
function HandleTernary(expr,colonexpr : presobject) : presobject;
begin
colonexpr^.p1:=expr;
Result:=colonexpr;
inc(if_nb);
result^.p:=strpnew('if_local'+str(if_nb));
end;
Function NewCType(aCType,aPascalType : String) : PresObject;
begin
if UseCTypesUnit then
Result:=NewID(aCType)
else
result:=NewIntID(aPascalType);
end;
function HandleUnaryDefExpr(aExpr : presobject) : presobject;
begin
if aExpr^.typ=t_funexprlist then
Result:=aExpr
else
Result:=NewType2(t_exprlist,aExpr,nil);
(* if here is a type specifier we know the return type *)
if (aExpr^.typ=t_typespec) then
Result^.p3:=aExpr^.p1^.get_copy;
end;
function handleSpecialSignedType(aType : presobject) : presobject;
var
hp : presobject;
tc,tp : string;
begin
tp:='';
Result:=aType;
hp:=result;
if not Assigned(HP) then
exit;
tc:=strpas(hp^.p);
if UseCTypesUnit then
Case tc of
cint_STR: tp:=csint_STR;
cshort_STR: tp:=csshort_STR;
cchar_STR: tp:=cschar_STR;
clong_STR: tp:=cslong_STR;
clonglong_STR: tp:=cslonglong_STR;
cint8_STR: tp:=cint8_STR;
cint16_STR: tp:=cint16_STR;
cint32_STR: tp:=cint32_STR;
cint64_STR: tp:=cint64_STR;
else
tp:='';
end
else
case tc of
UINT_STR: tp:=INT_STR;
USHORT_STR: tp:=SHORT_STR;
USMALL_STR: tp:=SMALL_STR;
// UCHAR_STR: tp:=CHAR_STR; identical to USHORT_STR....
QWORD_STR: tp:=INT64_STR;
else
tp:='';
end;
if tp<>'' then
hp^.setstr(tp);
end;
function handleSpecialUnSignedType(aType : presobject) : presobject;
var
hp : presobject;
tc,tp : string;
begin
hp:=aType;
Result:=hp;
if Not assigned(hp) then
exit;
tp:='';
tc:=strpas(hp^.p);
if UseCTypesUnit then
case tc of
cint_STR: tp:=cuint_STR;
cshort_STR: tp:=cushort_STR;
cchar_STR : tp:=cuchar_STR;
clong_STR : tp:=culong_STR;
clonglong_STR : tp:=culonglong_STR;
cint8_STR : tp:=cuint8_STR;
cint16_STR : tp:=cuint16_STR;
cint32_STR : tp:=cuint32_STR;
cint64_STR : tp:=cuint64_STR;
else
tp:='';
end
else
case tc of
INT_STR : tp:=UINT_STR;
SHORT_STR : tp:=USHORT_STR;
SMALL_STR : tp:=USMALL_STR;
CHAR_STR : tp:=UCHAR_STR;
INT64_STR : tp:=QWORD_STR;
else
tp:='';
end;
if tp<>'' then
hp^.setstr(tp);
end;
function handleSizedArrayDecl(aType,aSizeExpr: presobject): presobject;
var
hp : presobject;
begin
hp:=aType;
result:=hp;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=NewType2(t_arraydef,nil,aSizeExpr);
end;
function handleFuncNoArg(aType: presobject): presobject;
var
hp : presobject;
begin
hp:=aType;
Result:=hp;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=NewType2(t_procdef,nil,nil);
end;
function handleFuncExpr(aType, aList: presobject): presobject;
var
hp : presobject;
begin
hp:=NewType1(t_exprlist,aType);
Result:=NewType3(t_funexprlist,hp,aList,nil);
end;
function handlePointerType(aType, aPointer, aSize: presobject): presobject;
var
hp : presobject;
begin
if assigned(aSize) then
begin
if not stripinfo then
emitignore(aSize);
dispose(aSize,done);
write_type_specifier(outfile,aType);
emitwriteln(' ignored *)');
end;
hp:=NewType1(t_pointerdef,aType);
Result:=NewType2(t_typespec,hp,aPointer);
end;
function handleArrayDecl(aType: presobject): presobject;
var
hp : presobject;
begin
(* this is translated into a pointer *)
hp:=aType;
Result:=hp;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=NewType1(t_pointerdef,nil);
end;
function HandlePointerAbstractDeclarator(psym: presobject): presobject;
var
hp : presobject;
begin
hp:=psym;
Result:=hp;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=NewType1(t_pointerdef,nil);
end;
function HandlePointerAbstractListDeclarator(psym, plist: presobject
): presobject;
var
hp : presobject;
begin
hp:=psym;
result:=hp;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=NewType2(t_procdef,nil,plist);
end;
function HandleDeclarationList(plist,pelem : presobject) : presobject;
var
hp : presobject;
begin
hp:=plist;
result:=hp;
while assigned(hp^.next) do
hp:=hp^.next;
hp^.next:=NewType1(t_declist,pelem);
end;
function HandleSizedDeclarator(psym,psize : presobject) : presobject;
var
hp : presobject;
begin
hp:=NewType1(t_size_specifier,psize);
Result:=NewType3(t_dec,nil,psym,hp);
end;
function HandleDefaultDeclarator(psym,pdefault : presobject) : presobject;
var
hp : presobject;
begin
EmitIgnoreDefault(psym);
hp:=NewType1(t_default_value,pdefault);
HandleDefaultDeclarator:=NewType3(t_dec,nil,psym,hp);
end;
function HandleArgList(aEl, aList: PResObject): PResObject;
begin
Result:=NewType2(t_arglist,aEl,nil);
Result^.next:=aList;
end;
function HandlePointerArgDeclarator(ptype, psym : presobject): presobject;
var
hp : presobject;
begin
(* type_specifier STAR declarator *)
hp:=NewType1(t_pointerdef,ptype);
Result:=NewType2(t_arg,hp,psym);
end;
function HandleSizedPointerDeclarator(psym, psize: presobject): presobject;
var
hp : presobject;
begin
emitignore(psize);
dispose(psize,done);
hp:=psym;
Result:=hp;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=NewType1(t_pointerdef,nil);
end;
function HandleSizeOverrideDeclarator(psize,psym : presobject) : presobject;
var
hp : presobject;
begin
EmitIgnore(psize);
dispose(psize,done);
hp:=psym;
HandleSizeOverrideDeclarator:=hp;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=NewType1(t_pointerdef,nil);
end;
function HandleDeclarator2(aTyp : ttyp; aleft,aright: presobject): presobject;
var
hp : presobject;
begin
hp:=aLeft;
result:=hp;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=NewType2(aTyp,nil,aRight);
end;
function HandleDeclarator(aTyp : ttyp; aright: presobject): presobject;
var
hp : presobject;
begin
hp:=aright;
Result:=hp;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=NewType1(atyp,nil);
end;
function CheckWideString(S: String): presobject;
begin
if Win32headers and (s[1]='L') then
delete(s,1,1);
CheckWideString:=NewID(''''+copy(s,2,length(s)-2)+'''');
end;
function CheckUnderScore(pdecl: presobject): presobject;
var
tn : string;
len : integer;
begin
Result:=pdecl;
tn:=result^.str;
len:=length(tn);
if removeunderscore and (len>1) and (tn[1]='_') then
result^.setstr(Copy(tn,2,len-1));
end;
function yylex : Integer;
begin
yylex:=scan.yylex;
line_no:=yylineno;
end;
(* writes an argument list, where p is t_arglist *)
procedure yymsg(const msg : string);
begin
writeln('line ',line_no,': ',msg);
end;
function ellipsisarg : presobject;
begin
ellipsisarg:=new(presobject,init_two(t_arg,nil,nil));
end;
function HandleDeclarationStatement(decl, type_spec, modifier_spec,
decllist_spec, block_spec: presobject): presobject;
var
hp : presobject;
IsExtern : boolean;
begin
HandleDeclarationStatement:=Nil;
IsExtern:=false;
(* by default we must pop the args pushed on stack *)
no_pop:=false;
if (assigned(decllist_spec)and assigned(decllist_spec^.p1)and assigned(decllist_spec^.p1^.p1))
and (decllist_spec^.p1^.p1^.typ=t_procdef) then
begin
repeat
If UseLib then
IsExtern:=true
else
IsExtern:=assigned(decl)and(decl^.str='extern');
no_pop:=assigned(modifier_spec) and (modifier_spec^.str='no_pop');
if (block_type<>bt_func) and not(createdynlib) then
begin
writeln(outfile);
block_type:=bt_func;
end;
(* dyn. procedures must be put into a var block *)
if createdynlib then
begin
if (block_type<>bt_var) then
begin
if not(compactmode) then
writeln(outfile);
writeln(outfile,aktspace,'var');
block_type:=bt_var;
end;
shift(2);
end;
if not CompactMode then
begin
write(outfile,aktspace);
if not IsExtern then
write(implemfile,aktspace);
end;
(* distinguish between procedure and function *)
if assigned(type_spec) then
if (type_spec^.typ=t_void) and (decllist_spec^.p1^.p1^.p1=nil) then
begin
if createdynlib then
begin
write(outfile,decllist_spec^.p1^.p2^.p,' : procedure');
end
else
begin
shift(10);
write(outfile,'procedure ',decllist_spec^.p1^.p2^.p);
end;
if assigned(decllist_spec^.p1^.p1^.p2) then
write_args(outfile,decllist_spec^.p1^.p1^.p2);
if createdynlib then
begin
loaddynlibproc.add('pointer('+decllist_spec^.p1^.p2^.p+'):=GetProcAddress(hlib,'''+decllist_spec^.p1^.p2^.p+''');');
freedynlibproc.add(decllist_spec^.p1^.p2^.p+':=nil;');
end
else if not IsExtern then
begin
write(implemfile,'procedure ',decllist_spec^.p1^.p2^.p);
if assigned(decllist_spec^.p1^.p1^.p2) then
write_args(implemfile,decllist_spec^.p1^.p1^.p2);
end;
end
else
begin
if createdynlib then
begin
write(outfile,decllist_spec^.p1^.p2^.p,' : function');
end
else
begin
shift(9);
write(outfile,'function ',decllist_spec^.p1^.p2^.p);
end;
if assigned(decllist_spec^.p1^.p1^.p2) then
write_args(outfile,decllist_spec^.p1^.p1^.p2);
write(outfile,':');
old_in_args:=in_args;
(* write pointers as P.... instead of ^.... *)
in_args:=true;
write_p_a_def(outfile,decllist_spec^.p1^.p1^.p1,type_spec);
in_args:=old_in_args;
if createdynlib then
begin
loaddynlibproc.add('pointer('+decllist_spec^.p1^.p2^.p+'):=GetProcAddress(hlib,'''+decllist_spec^.p1^.p2^.p+''');');
freedynlibproc.add(decllist_spec^.p1^.p2^.p+':=nil;');
end
else if not IsExtern then
begin
write(implemfile,'function ',decllist_spec^.p1^.p2^.p);
if assigned(decllist_spec^.p1^.p1^.p2) then
write_args(implemfile,decllist_spec^.p1^.p1^.p2);
write(implemfile,':');
old_in_args:=in_args;
(* write pointers as P.... instead of ^.... *)
in_args:=true;
write_p_a_def(implemfile,decllist_spec^.p1^.p1^.p1,type_spec);
in_args:=old_in_args;
end;
end;
(* No CDECL in interface for Uselib *)
if IsExtern and (not no_pop) then
write(outfile,';cdecl');
popshift;
if createdynlib then
begin
writeln(outfile,';');
end
else if UseLib then
begin
if IsExtern then
begin
write (outfile,';external');
If UseName then
Write(outfile,' External_library name ''',decllist_spec^.p1^.p2^.p,'''');
end;
writeln(outfile,';');
end
else
begin
writeln(outfile,';');
if not IsExtern then
begin
writeln(implemfile,';');
shift(2);
if block_spec^.typ=t_statement_list then
write_statement_block(implemfile,block_spec);
popshift;
end;
end;
IsExtern:=false;
if not(compactmode) and not(createdynlib) then
writeln(outfile);
until not NeedEllipsisOverload;
end
else (* decllist_spec^.p1^.p1^.typ=t_procdef *)
if assigned(decllist_spec)and assigned(decllist_spec^.p1) then
begin
shift(2);
if block_type<>bt_var then
begin
if not(compactmode) then
writeln(outfile);
writeln(outfile,aktspace,'var');
end;
block_type:=bt_var;
shift(2);
IsExtern:=assigned(decl)and(decl^.str='extern');
(* walk through all declarations *)
hp:=decllist_spec;
while assigned(hp) and assigned(hp^.p1) do
begin
(* write new var name *)
if assigned(hp^.p1^.p2) and assigned(hp^.p1^.p2^.p) then
write(outfile,aktspace,hp^.p1^.p2^.p);
write(outfile,' : ');
shift(2);
(* write its type *)
write_p_a_def(outfile,hp^.p1^.p1,type_spec);
if assigned(hp^.p1^.p2)and assigned(hp^.p1^.p2^.p)then
begin
if isExtern then
write(outfile,';cvar;external')
else
write(outfile,';cvar;public');
end;
writeln(outfile,';');
popshift;
hp:=hp^.p2;
end;
popshift;
popshift;
end;
if assigned(decl) then
dispose(decl,done);
if assigned(type_spec) then
dispose(type_spec,done);
if assigned(modifier_spec) then
dispose(modifier_spec,done);
if assigned(decllist_spec) then
dispose(decllist_spec,done);
if assigned(block_spec) then
dispose(block_spec,done);
end;
function HandleDeclarationSysTrap(decl, type_spec, modifier_spec,
decllist_spec, sys_trap: presobject): presobject;
var
hp : presobject;
IsExtern : boolean;
begin
HandleDeclarationSysTrap:=Nil;
IsExtern:=false;
(* by default we must pop the args pushed on stack *)
no_pop:=false;
if (assigned(decllist_spec)and assigned(decllist_spec^.p1)and assigned(decllist_spec^.p1^.p1))
and (decllist_spec^.p1^.p1^.typ=t_procdef) then
begin
repeat
If UseLib then
IsExtern:=true
else
IsExtern:=assigned(decl)and(decl^.str='extern');
no_pop:=assigned(modifier_spec) and (modifier_spec^.str='no_pop');
if (block_type<>bt_func) and not(createdynlib) then
begin
writeln(outfile);
block_type:=bt_func;
end;
(* dyn. procedures must be put into a var block *)
if createdynlib then
begin
if (block_type<>bt_var) then
begin
if not(compactmode) then
writeln(outfile);
writeln(outfile,aktspace,'var');
block_type:=bt_var;
end;
shift(2);
end;
if not CompactMode then
begin
write(outfile,aktspace);
if not IsExtern then
write(implemfile,aktspace);
end;
(* distinguish between procedure and function *)
if assigned(type_spec) then
if (type_spec^.typ=t_void) and (decllist_spec^.p1^.p1^.p1=nil) then
begin
if createdynlib then
begin
write(outfile,decllist_spec^.p1^.p2^.p,' : procedure');
end
else
begin
shift(10);
write(outfile,'procedure ',decllist_spec^.p1^.p2^.p);
end;
if assigned(decllist_spec^.p1^.p1^.p2) then
write_args(outfile,decllist_spec^.p1^.p1^.p2);
if createdynlib then
begin
loaddynlibproc.add('pointer('+decllist_spec^.p1^.p2^.p+'):=GetProcAddress(hlib,'''+decllist_spec^.p1^.p2^.p+''');');
freedynlibproc.add(decllist_spec^.p1^.p2^.p+':=nil;');
end
else if not IsExtern then
begin
write(implemfile,'procedure ',decllist_spec^.p1^.p2^.p);
if assigned(decllist_spec^.p1^.p1^.p2) then
write_args(implemfile,decllist_spec^.p1^.p1^.p2);
end;
end
else
begin
if createdynlib then
begin
write(outfile,decllist_spec^.p1^.p2^.p,' : function');
end
else
begin
shift(9);
write(outfile,'function ',decllist_spec^.p1^.p2^.p);
end;
if assigned(decllist_spec^.p1^.p1^.p2) then
write_args(outfile,decllist_spec^.p1^.p1^.p2);
write(outfile,':');
write_p_a_def(outfile,decllist_spec^.p1^.p1^.p1,type_spec);
if createdynlib then
begin
loaddynlibproc.add('pointer('+decllist_spec^.p1^.p2^.p+'):=GetProcAddress(hlib,'''+decllist_spec^.p1^.p2^.p+''');');
freedynlibproc.add(decllist_spec^.p1^.p2^.p+':=nil;');
end
else if not IsExtern then
begin
write(implemfile,'function ',decllist_spec^.p1^.p2^.p);
if assigned(decllist_spec^.p1^.p1^.p2) then
write_args(implemfile,decllist_spec^.p1^.p1^.p2);
write(implemfile,':');
old_in_args:=in_args;
(* write pointers as P.... instead of ^.... *)
in_args:=true;
write_p_a_def(implemfile,decllist_spec^.p1^.p1^.p1,type_spec);
in_args:=old_in_args;
end;
end;
if assigned(sys_trap) then
write(outfile,';systrap ',sys_trap^.p);
(* No CDECL in interface for Uselib *)
if IsExtern and (not no_pop) then
write(outfile,';cdecl');
popshift;
if createdynlib then
begin
writeln(outfile,';');
end
else if UseLib then
begin
if IsExtern then
begin
write (outfile,';external');
If UseName then
Write(outfile,' External_library name ''',decllist_spec^.p1^.p2^.p,'''');
end;
writeln(outfile,';');
end
else
begin
writeln(outfile,';');
if not IsExtern then
begin
writeln(implemfile,';');
writeln(implemfile,aktspace,'begin');
writeln(implemfile,aktspace,' { You must implement this function }');
writeln(implemfile,aktspace,'end;');
end;
end;
IsExtern:=false;
if not(compactmode) and not(createdynlib) then
writeln(outfile);
until not NeedEllipsisOverload;
end
else (* decllist_spec^.p1^.p1^.typ=t_procdef *)
if assigned(decllist_spec)and assigned(decllist_spec^.p1) then
begin
shift(2);
if block_type<>bt_var then
begin
if not(compactmode) then
writeln(outfile);
writeln(outfile,aktspace,'var');
end;
block_type:=bt_var;
shift(2);
IsExtern:=assigned(decl)and(decl^.str='extern');
(* walk through all declarations *)
hp:=decllist_spec;
while assigned(hp) and assigned(hp^.p1) do
begin
(* write new var name *)
if assigned(hp^.p1^.p2) and assigned(hp^.p1^.p2^.p) then
write(outfile,aktspace,hp^.p1^.p2^.p);
write(outfile,' : ');
shift(2);
(* write its type *)
write_p_a_def(outfile,hp^.p1^.p1,type_spec);
if assigned(hp^.p1^.p2)and assigned(hp^.p1^.p2^.p)then
begin
if isExtern then
write(outfile,';cvar;external')
else
write(outfile,';cvar;public');
end;
writeln(outfile,';');
popshift;
hp:=hp^.p2;
end;
popshift;
popshift;
end;
if assigned(decl)then dispose(decl,done);
if assigned(type_spec)then dispose(type_spec,done);
if assigned(decllist_spec)then dispose(decllist_spec,done);
end;
function HandleSpecialType(aType: presobject) : presobject;
var
hp : presobject;
begin
HandleSpecialType:=Nil;
if block_type<>bt_type then
begin
if not(compactmode) then
writeln(outfile);
writeln(outfile,aktspace,'type');
block_type:=bt_type;
end;
shift(2);
if ( aType^.p2 <> nil ) then
begin
(* write new type name *)
TN:=TypeName(aType^.p2^.p);
PN:=PointerName(aType^.p2^.p);
(* define a Pointer type also for structs *)
if UsePPointers and (Uppercase(tn)<>Uppercase(pn)) and
assigned(aType) and (aType^.typ in [t_uniondef,t_structdef]) then
writeln(outfile,aktspace,PN,' = ^',TN,';');
write(outfile,aktspace,TN,' = ');
shift(2);
hp:=aType;
write_type_specifier(outfile,hp);
popshift;
(* enum_to_const can make a switch to const *)
if block_type=bt_type then
writeln(outfile,';');
writeln(outfile);
flush(outfile);
popshift;
if must_write_packed_field then
write_packed_fields_info(outfile,hp,TN);
if assigned(hp) then
dispose(hp,done)
end
else
begin
TN:=TypeName(aType^.str);
PN:=PointerName(aType^.str);
if UsePPointers then writeln(outfile,aktspace,PN,' = ^',TN,';');
if PackRecords then
writeln(outfile, aktspace, TN, ' = packed record')
else
writeln(outfile, aktspace, TN, ' = record');
writeln(outfile, aktspace, ' {undefined structure}');
writeln(outfile, aktspace, ' end;');
writeln(outfile);
popshift;
end;
end;
function HandleTypedef(type_spec,dec_modifier,declarator,arg_decl_list: presobject) : presobject;
var
hp : presobject;
begin
hp:=nil;
HandleTypedef:=nil;
(* TYPEDEF type_specifier LKLAMMER dec_modifier declarator RKLAMMER maybe_space LKLAMMER argument_declaration_list RKLAMMER SEMICOLON *)
if block_type<>bt_type then
begin
if not(compactmode) then
writeln(outfile);
writeln(outfile,aktspace,'type');
block_type:=bt_type;
end;
no_pop:=assigned(dec_modifier) and (dec_modifier^.str='no_pop');
shift(2);
(* walk through all declarations *)
hp:=declarator;
if assigned(hp) then
begin
hp:=declarator;
while assigned(hp^.p1) do
hp:=hp^.p1;
hp^.p1:=new(presobject,init_two(t_procdef,nil,arg_decl_list));
hp:=declarator;
if assigned(hp^.p1) and assigned(hp^.p1^.p1) then
begin
writeln(outfile);
(* write new type name *)
write(outfile,aktspace,TypeName(hp^.p2^.p),' = ');
shift(2);
write_p_a_def(outfile,hp^.p1,type_spec);
popshift;
(* if no_pop it is normal fpc calling convention *)
if is_procvar and
(not no_pop) then
write(outfile,';cdecl');
writeln(outfile,';');
flush(outfile);
end;
end;
popshift;
if assigned(type_spec)then
dispose(type_spec,done);
if assigned(dec_modifier)then
dispose(dec_modifier,done);
if assigned(declarator)then (* disposes also arg_decl_list *)
dispose(declarator,done);
end;
function HandleTypedefList(type_spec,dec_modifier,declarator_list: presobject) : presobject;
(* TYPEDEF type_specifier dec_modifier declarator_list SEMICOLON *)
var
hp,ph : presobject;
begin
HandleTypedefList:=Nil;
ph:=nil;
if block_type<>bt_type then
begin
if not(compactmode) then
writeln(outfile);
writeln(outfile,aktspace,'type');
block_type:=bt_type;
end
else
writeln(outfile);
no_pop:=assigned(dec_modifier) and (dec_modifier^.str='no_pop');
shift(2);
(* Get the name to write the type definition for, try
to use the tag name first *)
if assigned(type_spec^.p2) then
begin
ph:=type_spec^.p2;
end
else
begin
if not assigned(declarator_list) then
internalerror(5555);
if not assigned(declarator_list^.p1) then
internalerror(666);
if not assigned(declarator_list^.p1^.p2) then
internalerror(4444);
ph:=declarator_list^.p1^.p2;
end;
(* write type definition *)
is_procvar:=false;
TN:=TypeName(ph^.p);
PN:=PointerName(ph^.p);
if UsePPointers and (Uppercase(tn)<>Uppercase(pn)) and
assigned(type_spec) and (type_spec^.typ<>t_procdef) then
WritePointerTypeDef(outfile,PN,TN);
(* write new type name *)
write(outfile,aktspace,TN,' = ');
shift(2);
write_p_a_def(outfile,declarator_list^.p1^.p1,type_spec);
popshift;
(* if no_pop it is normal fpc calling convention *)
if is_procvar and
(not no_pop) then
write(outfile,';cdecl');
writeln(outfile,';');
flush(outfile);
(* write alias names, ph points to the name already used *)
hp:=declarator_list;
while assigned(hp) do
begin
if (hp<>ph) and assigned(hp^.p1^.p2) then
begin
PN:=TypeName(ph^.p);
TN:=TypeName(hp^.p1^.p2^.p);
if Uppercase(TN)<>Uppercase(PN) then
begin
write(outfile,aktspace,TN,' = ');
write_p_a_def(outfile,hp^.p1^.p1,ph);
writeln(outfile,';');
PN:=PointerName(hp^.p1^.p2^.p);
if UsePPointers and (Uppercase(tn)<>Uppercase(pn)) and
assigned(type_spec) and (type_spec^.typ<>t_procdef) then
writeln(outfile,aktspace,PN,' = ^',TN,';');
end;
end;
hp:=hp^.next;
end;
popshift;
if must_write_packed_field then
if assigned(ph) then
write_packed_fields_info(outfile,type_spec,ph^.str)
else if assigned(type_spec^.p2) then
write_packed_fields_info(outfile,type_spec,type_spec^.p2^.str);
if assigned(type_spec)then
dispose(type_spec,done);
if assigned(dec_modifier)then
dispose(dec_modifier,done);
if assigned(declarator_list)then
dispose(declarator_list,done);
end;
function HandleStructDef(dname1,dname2 : presobject) : presobject;
begin
HandleStructDef:=nil;
(* TYPEDEF STRUCT dname dname SEMICOLON *)
if block_type<>bt_type then
begin
if not(compactmode) then
writeln(outfile);
writeln(outfile,aktspace,'type');
block_type:=bt_type;
end;
PN:=TypeName(dname1^.p);
TN:=TypeName(dname2^.p);
if Uppercase(tn)<>Uppercase(pn) then
begin
shift(2);
writeln(outfile,aktspace,PN,' = ',TN,';');
popshift;
end;
if assigned(dname1) then
dispose(dname1,done);
if assigned(dname2) then
dispose(dname2,done);
end;
function HandleSimpleTypeDef(tname : presobject) : presobject;
begin
HandleSimpleTypeDef:=Nil;
if block_type<>bt_type then
begin
if not(compactmode) then
writeln(outfile);
writeln(outfile,aktspace,'type');
block_type:=bt_type;
end
else
writeln(outfile);
shift(2);
(* write as pointer *)
writeln(outfile,'(* generic typedef *)');
writeln(outfile,aktspace,tname^.p,' = pointer;');
flush(outfile);
popshift;
if assigned(tname) then
dispose(tname,done);
end;
function HandleErrorDecl(e1,e2 : presobject) : presobject;
begin
HandleErrorDecl:=Nil;
writeln(outfile,'in declaration at line ',line_no,' *)');
aktspace:='';
in_space_define:=0;
in_define:=false;
arglevel:=0;
if_nb:=0;
aktspace:=' ';
resetshift;
yyerrok;
end;
function HandleDefine(dname : presobject) : presobject;
begin
HandleDefine:=Nil;
writeln(outfile,'{$define ',dname^.p,'}',aktspace,commentstr);
flush(outfile);
if assigned(dname)then
dispose(dname,done);
end;
function HandleDefineConst(dname,def_expr: presobject) : presobject;
var
hp : presobject;
begin
HandleDefineConst:=Nil;
(* DEFINE dname SPACE_DEFINE def_expr NEW_LINE *)
if (def_expr^.typ=t_exprlist) and
def_expr^.p1^.is_const and
not assigned(def_expr^.next) then
begin
if block_type<>bt_const then
begin
if block_type<>bt_func then
writeln(outfile);
writeln(outfile,aktspace,'const');
end;
block_type:=bt_const;
shift(2);
write(outfile,aktspace,dname^.p);
write(outfile,' = ');
flush(outfile);
write_expr(outfile,def_expr^.p1);
writeln(outfile,';',aktspace,commentstr);
popshift;
if assigned(dname) then
dispose(dname,done);
if assigned(def_expr) then
dispose(def_expr,done);
end
else
begin
if block_type<>bt_func then
writeln(outfile);
if not stripinfo then
begin
writeln (outfile,aktspace,'{ was #define dname def_expr }');
writeln (implemfile,aktspace,'{ was #define dname def_expr }');
end;
block_type:=bt_func;
write(outfile,aktspace,'function ',dname^.p);
write(implemfile,aktspace,'function ',dname^.p);
shift(2);
if not assigned(def_expr^.p3) then
begin
writeln(outfile,' : longint; { return type might be wrong }');
flush(outfile);
writeln(implemfile,' : longint; { return type might be wrong }');
end
else
begin
write(outfile,' : ');
write_type_specifier(outfile,def_expr^.p3);
writeln(outfile,';',aktspace,commentstr);
flush(outfile);
write(implemfile,' : ');
write_type_specifier(implemfile,def_expr^.p3);
writeln(implemfile,';');
end;
writeln(outfile);
flush(outfile);
hp:=new(presobject,init_two(t_funcname,dname,def_expr));
write_funexpr(implemfile,hp);
popshift;
dispose(hp,done);
writeln(implemfile);
flush(implemfile);
end;
end;
function HandleDefineMacro(dname,enum_list,para_def_expr: presobject) : presobject;
var
hp,ph : presobject;
begin
HandleDefineMacro:=Nil;
hp:=nil;
ph:=nil;
(* DEFINE dname LKLAMMER enum_list RKLAMMER para_def_expr NEW_LINE *)
if not stripinfo then
begin
writeln (outfile,aktspace,'{ was #define dname(params) para_def_expr }');
writeln (implemfile,aktspace,'{ was #define dname(params) para_def_expr }');
if assigned(enum_list) then
begin
writeln (outfile,aktspace,'{ argument types are unknown }');
writeln (implemfile,aktspace,'{ argument types are unknown }');
end;
if not assigned(para_def_expr^.p3) then
begin
writeln(outfile,aktspace,'{ return type might be wrong } ');
writeln(implemfile,aktspace,'{ return type might be wrong } ');
end;
end;
if block_type<>bt_func then
writeln(outfile);
block_type:=bt_func;
write(outfile,aktspace,'function ',dname^.p);
write(implemfile,aktspace,'function ',dname^.p);
if assigned(enum_list) then
begin
write(outfile,'(');
write(implemfile,'(');
ph:=new(presobject,init_one(t_enumdef,enum_list));
write_def_params(outfile,ph);
write_def_params(implemfile,ph);
if assigned(ph) then dispose(ph,done);
ph:=nil;
(* types are unknown *)
write(outfile,' : longint)');
write(implemfile,' : longint)');
end;
if not assigned(para_def_expr^.p3) then
begin
writeln(outfile,' : longint;',aktspace,commentstr);
writeln(implemfile,' : longint;');
flush(outfile);
end
else
begin
write(outfile,' : ');
write_type_specifier(outfile,para_def_expr^.p3);
writeln(outfile,';',aktspace,commentstr);
flush(outfile);
write(implemfile,' : ');
write_type_specifier(implemfile,para_def_expr^.p3);
writeln(implemfile,';');
end;
writeln(outfile);
flush(outfile);
hp:=new(presobject,init_two(t_funcname,dname,para_def_expr));
write_funexpr(implemfile,hp);
writeln(implemfile);
flush(implemfile);
if assigned(hp)then dispose(hp,done);
end;
end.
Reference in New Issue View Git Blame Copy Permalink