%{ program h2pas; (* $Id$ 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. ****************************************************************************) uses {$ifdef go32v2} {$ifndef NOEXCP} dpmiexcp, {$endif NOEXCP} {$endif} {$IFDEF WIN32} SysUtils, {$else} strings, {$endif} options,scan,converu,lexlib,yacclib; type YYSTYPE = presobject; const INT_STR = 'longint'; UINT_STR = 'cardinal'; SHORT_STR = 'integer'; USHORT_STR = 'word'; CHAR_STR = 'char'; { should we use byte or char for 'unsigned char' ?? } UCHAR_STR = 'byte'; REAL_STR = 'real'; var debug : boolean; hp,ph : presobject; extfile: text; (* file for implementation headers extern procs *) IsExtern:boolean; must_write_packed_field : boolean; tempfile : text; No_pop:boolean; s,TN,PN : String; (* $ define yydebug compile with -dYYDEBUG to get debugging info *) const (* number of a?b:c construction in one define *) if_nb : longint = 0; is_packed : boolean = false; is_procvar : boolean = false; var space_array : array [0..255] of byte; space_index : byte; procedure shift(space_number : byte); var i : byte; begin space_array[space_index]:=space_number; inc(space_index); for i:=1 to space_number do aktspace:=aktspace+' '; end; procedure popshift; begin dec(space_index); if space_index<0 then internalerror(20); dec(byte(aktspace[0]),space_array[space_index]); end; function str(i : longint) : string; var s : string; begin system.str(i,s); str:=s; end; function hexstr(i : cardinal) : string; const HexTbl : array[0..15] of char='0123456789ABCDEF'; var str : string; begin str:=''; while i<>0 do begin str:=hextbl[i and $F]+str; i:=i shr 4; end; if str='' then str:='0'; hexstr:='$'+str; end; function uppercase(s : string) : string; var i : byte; begin for i:=1 to length(s) do s[i]:=UpCase(s[i]); uppercase:=s; end; procedure write_type_specifier(var outfile:text; p : presobject);forward; procedure write_p_a_def(var outfile:text; p,simple_type : presobject);forward; procedure write_ifexpr(var outfile:text; p : presobject);forward; procedure write_funexpr(var outfile:text; p : presobject);forward; procedure yymsg(const msg : string); begin writeln('line ',line_no,': ',msg); end; procedure write_packed_fields_info(var outfile:text; p : presobject; ph : string); var hp1,hp2,hp3 : presobject; is_sized : boolean; line : string; flag_index : longint; name : pchar; ps : byte; begin { write out the tempfile created } close(tempfile); reset(tempfile); is_sized:=false; flag_index:=0; writeln(outfile,aktspace,'const'); shift(3); while not eof(tempfile) do begin readln(tempfile,line); ps:=pos('&',line); if ps>0 then line:=copy(line,1,ps-1)+ph+'_'+copy(line,ps+1,255); writeln(outfile,aktspace,line); end; close(tempfile); rewrite(tempfile); popshift; (* walk through all members *) hp1 := p^.p1; while assigned(hp1) do begin (* hp2 is t_memberdec *) hp2:=hp1^.p1; (* hp3 is t_declist *) hp3:=hp2^.p2; while assigned(hp3) do begin if assigned(hp3^.p1^.p3) and (hp3^.p1^.p3^.typ = t_size_specifier) then begin is_sized:=true; name:=hp3^.p1^.p2^.p; { get function in interface } write(outfile,aktspace,'function ',name); write(outfile,'(var a : ',ph,') : '); shift(2); write_p_a_def(outfile,hp3^.p1^.p1,hp2^.p1); writeln(outfile,';'); popshift; { get function in implementation } write(extfile,aktspace,'function ',name); write(extfile,'(var a : ',ph,') : '); shift(2); write_p_a_def(extfile,hp3^.p1^.p1,hp2^.p1); writeln(extfile,';'); writeln(extfile,aktspace,'begin'); shift(3); write(extfile,aktspace,name,':=(a.flag',flag_index); writeln(extfile,' and bm_',ph,'_',name,') shr bp_',ph,'_',name,';'); popshift; writeln(extfile,aktspace,'end;'); popshift; writeln(extfile); { set function in interface } write(outfile,aktspace,'procedure set_',name); write(outfile,'(var a : ',ph,'; __',name,' : '); shift(2); write_p_a_def(outfile,hp3^.p1^.p1,hp2^.p1); writeln(outfile,');'); popshift; { set function in implementation } write(extfile,aktspace,'procedure set_',name); write(extfile,'(var a : ',ph,'; __',name,' : '); shift(2); write_p_a_def(extfile,hp3^.p1^.p1,hp2^.p1); writeln(extfile,');'); writeln(extfile,aktspace,'begin'); shift(3); write(extfile,aktspace,'a.flag',flag_index,':='); write(extfile,'a.flag',flag_index,' or '); writeln(extfile,'((__',name,' shl bp_',ph,'_',name,') and bm_',ph,'_',name,');'); popshift; writeln(extfile,aktspace,'end;'); popshift; writeln(extfile); end else if is_sized then begin is_sized:=false; inc(flag_index); end; hp3:=hp3^.next; end; hp1:=hp1^.next; end; must_write_packed_field:=false; block_type:=bt_no; end; procedure write_expr(var outfile:text; p : presobject); begin if assigned(p) then begin case p^.typ of t_id,t_ifexpr : write(outfile,p^.p); t_funexprlist : write_funexpr(outfile,p); t_preop : begin write(outfile,p^.p,'('); write_expr(outfile,p^.p1); write(outfile,')'); flush(outfile); end; t_typespec : begin write_type_specifier(outfile,p^.p1); write(outfile,'('); write_expr(outfile,p^.p2); write(outfile,')'); flush(outfile); end; t_bop : begin if p^.p1^.typ<>t_id then write(outfile,'('); write_expr(outfile,p^.p1); if p^.p1^.typ<>t_id then write(outfile,')'); write(outfile,p^.p); if p^.p2^.typ<>t_id then write(outfile,'('); write_expr(outfile,p^.p2); if p^.p2^.typ<>t_id then write(outfile,')'); flush(outfile); end; else internalerror(2); end; end; end; procedure write_ifexpr(var outfile:text; p : presobject); begin flush(outfile); write(outfile,'if '); write_expr(outfile,p^.p1); writeln(outfile,' then'); write(outfile,aktspace,' '); write(outfile,p^.p); write(outfile,':='); write_expr(outfile,p^.p2); writeln(outfile); writeln(outfile,aktspace,'else'); write(outfile,aktspace,' '); write(outfile,p^.p); write(outfile,':='); write_expr(outfile,p^.p3); writeln(outfile,';'); write(outfile,aktspace); flush(outfile); end; procedure write_all_ifexpr(var outfile:text; p : presobject); begin if assigned(p) then begin case p^.typ of t_id :; t_preop : write_all_ifexpr(outfile,p^.p1); t_bop : begin write_all_ifexpr(outfile,p^.p1); write_all_ifexpr(outfile,p^.p2); end; t_ifexpr : begin write_all_ifexpr(outfile,p^.p1); write_all_ifexpr(outfile,p^.p2); write_all_ifexpr(outfile,p^.p3); write_ifexpr(outfile,p); end; t_typespec : write_all_ifexpr(outfile,p^.p2); t_funexprlist, t_exprlist : begin if assigned(p^.p1) then write_all_ifexpr(outfile,p^.p1); if assigned(p^.next) then write_all_ifexpr(outfile,p^.next); end else internalerror(6); end; end; end; procedure write_funexpr(var outfile:text; p : presobject); var i : longint; begin if assigned(p) then begin case p^.typ of t_ifexpr : write(outfile,p^.p); t_exprlist : begin write_expr(outfile,p^.p1); if assigned(p^.next) then begin write(outfile,','); write_funexpr(outfile,p^.next); end end; t_funcname : begin shift(2); if if_nb>0 then begin writeln(outfile,aktspace,'var'); write(outfile,aktspace,' '); for i:=1 to if_nb do begin write(outfile,'if_local',i); if it_arglist then internalerror(10); (* is ellipsis ? *) if not assigned(p^.p1^.p1) and not assigned(p^.p1^.next) then begin { write(outfile,'...'); } write(outfile,'args:array of const'); { if variable number of args we must allways pop } no_pop:=false; end (* we need to correct this in the pp file after *) else begin (* generate a call by reference parameter ? *) varpara:=usevarparas and assigned(p^.p1^.p2^.p1) and ((p^.p1^.p2^.p1^.typ=t_pointerdef) or (p^.p1^.p2^.p1^.typ=t_addrdef)); (* do not do it for char pointer !! *) (* para : pchar; and var para : char; are *) (* completely different in pascal *) (* here we exclude all typename containing char *) (* is this a good method ?? *) if varpara and (p^.p1^.p2^.p1^.typ=t_pointerdef) and (p^.p1^.p2^.p1^.p1^.typ=t_id) and (pos('CHAR',uppercase(p^.p1^.p2^.p1^.p1^.str))<>0) then varpara:=false; if varpara then begin write(outfile,'var '); length:=length+4; end; (* write new type name *) if assigned(p^.p1^.p2^.p2) then begin write(outfile,p^.p1^.p2^.p2^.p); length:=length+p^.p1^.p2^.p2^.strlength; end else begin write(outfile,'_para',para); { not exact but unimportant } length:=length+6; end; write(outfile,':'); if varpara then write_p_a_def(outfile,p^.p1^.p2^.p1^.p1,p^.p1^.p1) else write_p_a_def(outfile,p^.p1^.p2^.p1,p^.p1^.p1); end; p:=p^.next; if assigned(p) then begin write(outfile,'; '); { if length>40 then : too complicated to compute } if (para mod 5) = 0 then begin writeln(outfile); write(outfile,aktspace); end; end; inc(para); end; write(outfile,')'); flush(outfile); in_args:=old_in_args; popshift; end; procedure write_p_a_def(var outfile:text; p,simple_type : presobject); var i : longint; error : integer; constant : boolean; begin if not(assigned(p)) then begin write_type_specifier(outfile,simple_type); exit; end; case p^.typ of t_pointerdef : begin (* procedure variable ? *) if assigned(p^.p1) and (p^.p1^.typ=t_procdef) then begin is_procvar:=true; (* distinguish between procedure and function *) if (simple_type^.typ=t_void) and (p^.p1^.p1=nil) then begin write(outfile,'procedure '); shift(10); (* write arguments *) if assigned(p^.p1^.p2) then write_args(outfile,p^.p1^.p2); flush(outfile); popshift; end else begin write(outfile,'function '); shift(9); (* write arguments *) if assigned(p^.p1^.p2) then write_args(outfile,p^.p1^.p2); write(outfile,':'); flush(outfile); write_p_a_def(outfile,p^.p1^.p1,simple_type); popshift; end end else begin (* generate "pointer" ? *) if (simple_type^.typ=t_void) and (p^.p1=nil) then begin write(outfile,'pointer'); flush(outfile); end else begin if in_args then write(outfile,'p') else write(outfile,'^'); flush(outfile); write_p_a_def(outfile,p^.p1,simple_type); end; end; end; t_arraydef : begin constant:=false; if p^.p2^.typ=t_id then begin val(p^.p2^.str,i,error); if error=0 then begin dec(i); constant:=true; end; end; if not constant then begin write(outfile,'array[0..('); write_expr(outfile,p^.p2); write(outfile,')-1] of '); end else begin write(outfile,'array[0..',i,'] of '); end; flush(outfile); write_p_a_def(outfile,p^.p1,simple_type); end; else internalerror(1); end; end; procedure write_type_specifier(var outfile:text; p : presobject); var hp1,hp2,hp3,lastexpr : presobject; i,l,w : longint; error : integer; mask : cardinal; flag_index,current_power : longint; current_level : byte; is_sized : boolean; begin case p^.typ of t_id : write(outfile,p^.p); { what can we do with void defs ? } t_void : write(outfile,'void'); t_pointerdef : begin write(outfile,'p'); write_type_specifier(outfile,p^.p1); end; t_enumdef : begin if (typedef_level>1) and (p^.p1=nil) and (p^.p2^.typ=t_id) then begin write(outfile,p^.p2^.p); end else if not EnumToConst then begin write(outfile,'('); hp1:=p^.p1; w:=length(aktspace); while assigned(hp1) do begin write(outfile,hp1^.p1^.p); if assigned(hp1^.p2) then begin write(outfile,' := '); write_expr(outfile,hp1^.p2); w:=w+6;(* strlen(hp1^.p); *) end; w:=w+length(hp1^.p1^.str); hp1:=hp1^.next; if assigned(hp1) then write(outfile,','); if w>40 then begin writeln(outfile); write(outfile,aktspace); w:=length(aktspace); end; flush(outfile); end; write(outfile,')'); flush(outfile); end else begin Writeln (outfile,' Longint;'); hp1:=p^.p1; l:=0; lastexpr:=nil; Writeln (outfile,aktspace,'Const'); while assigned(hp1) do begin write (outfile,aktspace,hp1^.p1^.p,' = '); if assigned(hp1^.p2) then begin write_expr(outfile,hp1^.p2); writeln(outfile,';'); lastexpr:=hp1^.p2; if lastexpr^.typ=t_id then begin val(lastexpr^.str,l,error); if error=0 then begin inc(l); lastexpr:=nil; end else l:=1; end else l:=1; end else begin if assigned(lastexpr) then begin write(outfile,'('); write_expr(outfile,lastexpr); writeln(outfile,')+',l,';'); end else writeln (outfile,l,';'); inc(l); end; hp1:=hp1^.next; flush(outfile); end; block_type:=bt_const; end; end; t_structdef : begin inc(typedef_level); flag_index:=-1; is_sized:=false; current_level:=0; if (typedef_level>1) and (p^.p1=nil) and (p^.p2^.typ=t_id) then begin write(outfile,p^.p2^.p); end else begin writeln(outfile,'record'); shift(3); hp1:=p^.p1; (* walk through all members *) while assigned(hp1) do begin (* hp2 is t_memberdec *) hp2:=hp1^.p1; (* hp3 is t_declist *) hp3:=hp2^.p2; while assigned(hp3) do begin if not assigned(hp3^.p1^.p3) or (hp3^.p1^.p3^.typ <> t_size_specifier) then begin if is_sized then begin if current_level <= 16 then writeln(outfile,'word;') else if current_level <= 32 then writeln(outfile,'longint;') else internalerror(11); is_sized:=false; end; write(outfile,aktspace,hp3^.p1^.p2^.p); write(outfile,' : '); shift(2); write_p_a_def(outfile,hp3^.p1^.p1,hp2^.p1); popshift; end; { size specifier or default value ? } if assigned(hp3^.p1^.p3) then begin { we could use mask to implement this } { because we need to respect the positions } if hp3^.p1^.p3^.typ = t_size_specifier then begin if not is_sized then begin current_power:=1; current_level:=0; inc(flag_index); write(outfile,aktspace,'flag',flag_index,' : '); end; must_write_packed_field:=true; is_sized:=true; { can it be something else than a constant ? } { it can be a macro !! } if hp3^.p1^.p3^.p1^.typ=t_id then begin val(hp3^.p1^.p3^.p1^.str,l,error); if error=0 then begin mask:=0; for i:=1 to l do begin mask:=mask+current_power; current_power:=current_power*2; end; write(tempfile,'bm_&',hp3^.p1^.p2^.p); writeln(tempfile,' = ',hexstr(mask),';'); write(tempfile,'bp_&',hp3^.p1^.p2^.p); writeln(tempfile,' = ',current_level,';'); current_level:=current_level + l; { go to next flag if 31 } if current_level = 32 then begin write(outfile,'longint'); is_sized:=false; end; end; end; end else if hp3^.p1^.p3^.typ = t_default_value then begin write(outfile,'{='); write_expr(outfile,hp3^.p1^.p3^.p1); write(outfile,' ignored}'); end; end; if not is_sized then begin if is_procvar then begin if not no_pop then begin write(outfile,';cdecl'); no_pop:=true; end; is_procvar:=false; end; writeln(outfile,';'); end; hp3:=hp3^.next; end; hp1:=hp1^.next; end; if is_sized then begin if current_level <= 16 then writeln(outfile,'word;') else if current_level <= 32 then writeln(outfile,'longint;') else internalerror(11); is_sized:=false; end; popshift; write(outfile,aktspace,'end'); flush(outfile); end; dec(typedef_level); end; t_uniondef : begin if (typedef_level>1) and (p^.p1=nil) and (p^.p2^.typ=t_id) then begin write(outfile,p^.p2^.p); end else begin inc(typedef_level); writeln(outfile,'record'); shift(2); writeln(outfile,aktspace,'case longint of'); shift(3); l:=0; hp1:=p^.p1; (* walk through all members *) while assigned(hp1) do begin (* hp2 is t_memberdec *) hp2:=hp1^.p1; (* hp3 is t_declist *) hp3:=hp2^.p2; while assigned(hp3) do begin write(outfile,aktspace,l,' : ( '); write(outfile,hp3^.p1^.p2^.p,' : '); shift(2); write_p_a_def(outfile,hp3^.p1^.p1,hp2^.p1); popshift; writeln(outfile,' );'); hp3:=hp3^.next; inc(l); end; hp1:=hp1^.next; end; popshift; write(outfile,aktspace,'end'); popshift; flush(outfile); dec(typedef_level); end; end; else internalerror(3); end; end; procedure write_def_params(var outfile:text; p : presobject); var hp1 : presobject; begin case p^.typ of t_enumdef : begin hp1:=p^.p1; while assigned(hp1) do begin write(outfile,hp1^.p1^.p); hp1:=hp1^.next; if assigned(hp1) then write(outfile,',') else write(outfile); flush(outfile); end; flush(outfile); end; else internalerror(4); end; end; %} %token TYPEDEF DEFINE %token COLON SEMICOLON COMMA %token LKLAMMER RKLAMMER LECKKLAMMER RECKKLAMMER %token LGKLAMMER RGKLAMMER %token STRUCT UNION ENUM %token ID NUMBER CSTRING %token SHORT UNSIGNED LONG INT REAL _CHAR %token VOID _CONST %token _FAR _HUGE _NEAR %token _ASSIGN NEW_LINE SPACE_DEFINE %token EXTERN STDCALL CDECL CALLBACK PASCAL WINAPI APIENTRY WINGDIAPI SYS_TRAP %token _PACKED %token ELLIPSIS %right R_AND %left EQUAL UNEQUAL GT LT GTE LTE %left QUESTIONMARK COLON %left _OR %left _AND %left _PLUS MINUS %left _SHR _SHL %left STAR _SLASH %right _NOT %right LKLAMMER %right PSTAR %right P_AND %right LECKKLAMMER %left POINT DEREF %left COMMA %left STICK %% file : declaration_list ; error_info : { writeln(outfile,'(* error '); writeln(outfile,prev_line); writeln(outfile,last_source_line); }; declaration_list : declaration_list declaration { if yydebug then writeln('declaration reduced at line ',line_no); if yydebug then writeln(outfile,'(* declaration reduced *)'); } | declaration_list define_dec { if yydebug then writeln('define declaration reduced at line ',line_no); if yydebug then writeln(outfile,'(* define declaration reduced *)'); } | declaration { if yydebug then writeln('declaration reduced at line ',line_no); } | define_dec { if yydebug then writeln('define declaration reduced at line ',line_no); } ; dec_specifier : EXTERN { $$:=new(presobject,init_id('extern')); } |{ $$:=new(presobject,init_id('intern')); } ; dec_modifier : STDCALL { $$:=new(presobject,init_id('no_pop')); } | CDECL { $$:=new(presobject,init_id('cdecl')); } | CALLBACK { $$:=new(presobject,init_id('no_pop')); } | PASCAL { $$:=new(presobject,init_id('no_pop')); } | WINAPI { $$:=new(presobject,init_id('no_pop')); } | APIENTRY { $$:=new(presobject,init_id('no_pop')); } | WINGDIAPI { $$:=new(presobject,init_id('no_pop')); } | { $$:=nil } ; systrap_specifier: SYS_TRAP LKLAMMER dname RKLAMMER { $$:=$3; } | { $$:=nil; } ; declaration : dec_specifier type_specifier dec_modifier declarator_list systrap_specifier SEMICOLON { IsExtern:=false; (* by default we must pop the args pushed on stack *) no_pop:=false; (* writeln(outfile,'{ dec_specifier type_specifier declarator_list SEMICOLON}'); if assigned($3) then writeln(outfile,'{*$3}'); if assigned($3)and assigned($3.p1) then writeln(outfile,'{*$3^.p1}'); if assigned($3)and assigned($3^.p1)and assigned($3^.p1^.p1) then writeln(outfile,'{*$3^.p1^.p1}'); *) if (assigned($4)and assigned($4^.p1)and assigned($4^.p1^.p1)) and ($4^.p1^.p1^.typ=t_procdef) then begin If UseLib then IsExtern:=true else IsExtern:=assigned($1)and($1^.str='extern'); no_pop:=assigned($3) and ($3^.str='no_pop'); if block_type<>bt_func then writeln(outfile); block_type:=bt_func; write(outfile,aktspace); write(extfile,aktspace); (* distinguish between procedure and function *) if assigned($2) then if ($2^.typ=t_void) and ($4^.p1^.p1^.p1=nil) then begin write(outfile,'procedure ',$4^.p1^.p2^.p); (* write arguments *) shift(10); if assigned($4^.p1^.p1^.p2) then write_args(outfile,$4^.p1^.p1^.p2); write(extfile,'procedure ',$4^.p1^.p2^.p); (* write arguments *) if assigned($4^.p1^.p1^.p2) then write_args(extfile,$4^.p1^.p1^.p2); end else begin write(outfile,'function ',$4^.p1^.p2^.p); write(extfile,'function ',$4^.p1^.p2^.p); shift(9); (* write arguments *) if assigned($4^.p1^.p1^.p2) then write_args(outfile,$4^.p1^.p1^.p2); if assigned($4^.p1^.p1^.p2) then write_args(extfile,$4^.p1^.p1^.p2); write(outfile,':'); write(extfile,':'); write_p_a_def(outfile,$4^.p1^.p1^.p1,$2); write_p_a_def(extfile,$4^.p1^.p1^.p1,$2); end; if assigned($5) then write(outfile,';systrap ',$5^.p); (* No CDECL in interface for Uselib *) if IsExtern and (not no_pop) then begin write(outfile,';cdecl'); write(extfile,';cdecl'); end; popshift; if UseLib then begin if IsExtern then begin write (extfile,';external'); If UseName then Write(extfile,' External_library name ''',$4^.p1^.p2^.p,''''); end; writeln(extfile,';'); writeln(outfile,';'); end else begin writeln(extfile,';'); writeln(outfile,';'); if not IsExtern then begin writeln(extfile,aktspace,' begin'); writeln(extfile,aktspace,' { You must implemented this function }'); writeln(extfile,aktspace,' end;'); end; end; IsExtern:=false; writeln(outfile); if Uselib then writeln(extfile); end else (* $4^.p1^.p1^.typ=t_procdef *) if assigned($4)and assigned($4^.p1) then begin shift(2); if block_type<>bt_var then begin writeln(outfile); writeln(outfile,aktspace,'var'); end; block_type:=bt_var; shift(3); IsExtern:=assigned($1)and($1^.str='extern'); (* walk through all declarations *) hp:=$4; 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,$2); if assigned(hp^.p1^.p2)and assigned(hp^.p1^.p2^.p)then begin if isExtern then write(outfile,';cvar;external') else write(outfile,';cvar;export'); write(outfile,hp^.p1^.p2^.p); end; writeln(outfile,''';'); popshift; hp:=hp^.p2; end; popshift; popshift; end; if assigned($1)then dispose($1,done); if assigned($2)then dispose($2,done); if assigned($4)then dispose($4,done); } | special_type_specifier SEMICOLON { if block_type<>bt_type then begin writeln(outfile); writeln(outfile,aktspace,'type'); end; block_type:=bt_type; shift(3); (* write new type name *) TN:=strpas($1^.p2^.p); if ($1^.typ=t_structdef) or ($1^.typ=t_uniondef) then begin PN:='P'+strpas($1^.p2^.p); if PrependTypes then TN:='T'+TN; if UsePPointers then Writeln (outfile,aktspace,PN,' = ^',TN,';'); end; write(outfile,aktspace,TN,' = '); shift(2); hp:=$1; 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); } | TYPEDEF type_specifier dec_modifier declarator_list SEMICOLON { if block_type<>bt_type then begin writeln(outfile); writeln(outfile,aktspace,'type'); end; block_type:=bt_type; no_pop:=assigned($3) and ($3^.str='no_pop'); shift(3); (* walk through all declarations *) hp:=$4; ph:=nil; is_procvar:=false; while assigned(hp) do begin writeln(outfile); (* write new type name *) write(outfile,aktspace,hp^.p1^.p2^.p); write(outfile,' = '); shift(2); if assigned(ph) then write_p_a_def(outfile,hp^.p1^.p1,ph) else write_p_a_def(outfile,hp^.p1^.p1,$2); (* simple def ? keep the name for the other defs *) if (ph=nil) and (hp^.p1^.p1=nil) then ph:=hp^.p1^.p2; 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); hp:=hp^.next; end; (* write tag name *) if assigned(ph) and (($2^.typ=t_structdef) or ($2^.typ=t_enumdef) or ($2^.typ=t_uniondef)) and assigned($2^.p2) then begin writeln(outfile); write(outfile,aktspace,$2^.p2^.p,' = '); if assigned(ph) then writeln(outfile,ph^.p,';') else begin write_p_a_def(outfile,hp^.p1^.p1,$2); writeln(outfile,';'); end; end; popshift; if must_write_packed_field then if assigned(ph) then write_packed_fields_info(outfile,$2,ph^.str) else if assigned($2^.p2) then write_packed_fields_info(outfile,$2,$2^.p2^.str); if assigned($2)then dispose($2,done); if assigned($3)then dispose($3,done); if assigned($4)then dispose($4,done); } | TYPEDEF dname SEMICOLON { if block_type<>bt_type then begin writeln(outfile); writeln(outfile,aktspace,'type'); end; block_type:=bt_type; shift(3); (* write as pointer *) writeln(outfile); writeln(outfile,'(* generic typedef *)'); writeln(outfile,aktspace,$2^.p,' = pointer;'); flush(outfile); popshift; if assigned($2)then dispose($2,done); } | error error_info SEMICOLON { writeln(outfile,'in declaration at line ',line_no,' *)'); aktspace:=''; in_space_define:=0; in_define:=false; arglevel:=0; if_nb:=0; aktspace:=' '; space_index:=1; yyerrok;} ; define_dec : DEFINE dname LKLAMMER enum_list RKLAMMER SPACE_DEFINE def_expr NEW_LINE { writeln (outfile,aktspace,'{ was #define dname(params) def_expr }'); writeln (extfile,aktspace,'{ was #define dname(params) def_expr }'); if assigned($4) then begin writeln (outfile,aktspace,'{ argument types are unknown }'); writeln (extfile,aktspace,'{ argument types are unknown }'); end; if not assigned($7^.p3) then begin writeln(outfile,aktspace,'{ return type might be wrong } '); writeln(extfile,aktspace,'{ return type might be wrong } '); end; block_type:=bt_func; write(outfile,aktspace,'function ',$2^.p); write(extfile,aktspace,'function ',$2^.p); if assigned($4) then begin write(outfile,'('); write(extfile,'('); ph:=new(presobject,init_one(t_enumdef,$4)); write_def_params(outfile,ph); write_def_params(extfile,ph); if assigned(ph) then dispose(ph,done); ph:=nil; (* types are unknown *) write(outfile,' : longint)'); write(extfile,' : longint)'); end; if not assigned($7^.p3) then begin writeln(outfile,' : longint;'); writeln(outfile,aktspace,' { return type might be wrong } '); flush(outfile); writeln(extfile,' : longint;'); writeln(extfile,aktspace,' { return type might be wrong } '); end else begin write(outfile,' : '); write_type_specifier(outfile,$7^.p3); writeln(outfile,';'); flush(outfile); write(extfile,' : '); write_type_specifier(extfile,$7^.p3); writeln(extfile,';'); end; writeln(outfile); flush(outfile); hp:=new(presobject,init_two(t_funcname,$2,$7)); write_funexpr(extfile,hp); writeln(extfile); flush(extfile); if assigned(hp)then dispose(hp,done); }| DEFINE dname SPACE_DEFINE NEW_LINE { writeln(outfile,'{$define ',$2^.p,'}'); flush(outfile); if assigned($2)then dispose($2,done); }| DEFINE dname NEW_LINE { writeln(outfile,'{$define ',$2^.p,'}'); flush(outfile); if assigned($2)then dispose($2,done); } | DEFINE dname SPACE_DEFINE def_expr NEW_LINE { if ($4^.typ=t_exprlist) and $4^.p1^.is_const and not assigned($4^.next) then begin if block_type<>bt_const then begin writeln(outfile); writeln(outfile,aktspace,'const'); end; block_type:=bt_const; aktspace:=aktspace+' '; write(outfile,aktspace,$2^.p); write(outfile,' = '); flush(outfile); write_expr(outfile,$4^.p1); writeln(outfile,';'); dec(byte(aktspace[0]),3); if assigned($2) then dispose($2,done); if assigned($4) then dispose($4,done); end else begin aktspace:=aktspace+' '; writeln (outfile,aktspace,'{ was #define dname def_expr }'); writeln (extfile,aktspace,'{ was #define dname def_expr }'); block_type:=bt_func; write(outfile,aktspace,'function ',$2^.p); write(extfile,aktspace,'function ',$2^.p); if not assigned($4^.p3) then begin writeln(outfile,' : longint;'); writeln(outfile,aktspace,' { return type might be wrong }'); flush(outfile); writeln(extfile,' : longint;'); writeln(extfile,aktspace,' { return type might be wrong }'); end else begin write(outfile,' : '); write_type_specifier(outfile,$4^.p3); writeln(outfile,';'); flush(outfile); write(extfile,' : '); write_type_specifier(extfile,$4^.p3); writeln(extfile,';'); end; writeln(outfile); flush(outfile); hp:=new(presobject,init_two(t_funcname,$2,$4)); write_funexpr(extfile,hp); dec(byte(aktspace[0]),2); dispose(hp,done); writeln(extfile); flush(extfile); end; } | error error_info NEW_LINE { writeln(outfile,'in define line ',line_no,' *)'); aktspace:=''; in_space_define:=0; in_define:=false; arglevel:=0; if_nb:=0; aktspace:=' '; space_index:=1; yyerrok;} ; closed_list : LGKLAMMER member_list RGKLAMMER {$$:=$2;} | error error_info RGKLAMMER { writeln(outfile,' in member_list *)'); yyerrok; $$:=nil; } ; closed_enum_list : LGKLAMMER enum_list RGKLAMMER {$$:=$2;} | error error_info RGKLAMMER { writeln(outfile,' in enum_list *)'); yyerrok; $$:=nil; } ; special_type_specifier : STRUCT dname closed_list _PACKED { if not is_packed then writeln(outfile,'{$PACKRECORDS 1}'); is_packed:=true; $$:=new(presobject,init_two(t_structdef,$3,$2)); } | STRUCT dname closed_list { if is_packed then writeln(outfile,'{$PACKRECORDS 4}'); is_packed:=false; $$:=new(presobject,init_two(t_structdef,$3,$2)); } | UNION dname closed_list _PACKED { if not is_packed then writeln(outfile,'{$PACKRECORDS 1}'); is_packed:=true; $$:=new(presobject,init_two(t_uniondef,$3,$2)); } | UNION dname closed_list { $$:=new(presobject,init_two(t_uniondef,$3,$2)); } | UNION dname { $$:=new(presobject,init_two(t_uniondef,nil,$2)); } | STRUCT dname { $$:=new(presobject,init_two(t_structdef,nil,$2)); } | ENUM dname closed_enum_list { $$:=new(presobject,init_two(t_enumdef,$3,$2)); } | ENUM dname { $$:=new(presobject,init_two(t_enumdef,nil,$2)); }; type_specifier : _CONST type_specifier { writeln(outfile,'(* Const before type ignored *)'); $$:=$2; } | UNION closed_list _PACKED { if not is_packed then writeln(outfile,'{$PACKRECORDS 1}'); is_packed:=true; $$:=new(presobject,init_one(t_uniondef,$2)); } | UNION closed_list { $$:=new(presobject,init_one(t_uniondef,$2)); } | STRUCT closed_list _PACKED { if not is_packed then writeln(outfile,'{$PACKRECORDS 1}'); is_packed:=true; $$:=new(presobject,init_one(t_structdef,$2)); } | STRUCT closed_list { if is_packed then writeln(outfile,'{$PACKRECORDS 4}'); is_packed:=false; $$:=new(presobject,init_one(t_structdef,$2)); } | ENUM closed_enum_list { $$:=new(presobject,init_one(t_enumdef,$2)); } | special_type_specifier { $$:=$1; } | simple_type_name { $$:=$1; } ; member_list : member_declaration member_list { $$:=new(presobject,init_one(t_memberdeclist,$1)); $$^.next:=$2; } | member_declaration { $$:=new(presobject,init_one(t_memberdeclist,$1)); } ; member_declaration : type_specifier declarator_list SEMICOLON { $$:=new(presobject,init_two(t_memberdec,$1,$2)); } ; dname : ID { (*dname*) $$:=new(presobject,init_id(act_token)); } ; special_type_name : INT { $$:=new(presobject,init_id(INT_STR)); } | UNSIGNED INT { $$:=new(presobject,init_id(UINT_STR)); } | LONG { $$:=new(presobject,init_id(INT_STR)); } | REAL { $$:=new(presobject,init_id(REAL_STR)); } | LONG INT { $$:=new(presobject,init_id(INT_STR)); } | UNSIGNED LONG INT { $$:=new(presobject,init_id(UINT_STR)); } | UNSIGNED LONG { $$:=new(presobject,init_id(UINT_STR)); } | UNSIGNED { $$:=new(presobject,init_id(UINT_STR)); } | UNSIGNED SHORT { $$:=new(presobject,init_id(USHORT_STR)); } | UNSIGNED _CHAR { $$:=new(presobject,init_id(UCHAR_STR)); } | VOID { $$:=new(presobject,init_no(t_void)); } | SHORT { $$:=new(presobject,init_id(SHORT_STR)); } | _CHAR { $$:=new(presobject,init_id(CHAR_STR)); } ; simple_type_name : special_type_name { $$:=$1; } | dname { $$:=$1; } ; declarator_list : declarator_list COMMA declarator { $$:=$1; hp:=$1; while assigned(hp^.next) do hp:=hp^.next; hp^.next:=new(presobject,init_one(t_declist,$3)); }| error error_info COMMA declarator_list { writeln(outfile,' in declarator_list *)'); $$:=$4; yyerrok; }| error error_info { writeln(outfile,' in declarator_list *)'); yyerrok; }| declarator { $$:=new(presobject,init_one(t_declist,$1)); } ; argument_declaration : type_specifier declarator { $$:=new(presobject,init_two(t_arg,$1,$2)); } | type_specifier abstract_declarator { $$:=new(presobject,init_two(t_arg,$1,$2)); } ; argument_declaration_list : argument_declaration { $$:=new(presobject,init_two(t_arglist,$1,nil)); } | argument_declaration COMMA argument_declaration_list { $$:=new(presobject,init_two(t_arglist,$1,nil)); $$^.next:=$3; } | ELLIPSIS { $$:=new(presobject,init_two(t_arglist,ellipsisarg,nil)); (*** ELLIPSIS PROBLEM ***) } ; size_overrider : _FAR { $$:=new(presobject,init_id('far'));} | _NEAR { $$:=new(presobject,init_id('near'));} | _HUGE { $$:=new(presobject,init_id('huge'));} ; declarator : _CONST declarator { writeln(outfile,'(* Const before declarator ignored *)'); $$:=$2; } | size_overrider STAR declarator { writeln(outfile,aktspace,'(* ',$1^.p,' ignored *)'); dispose($1,done); hp:=$3; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_one(t_pointerdef,nil)); } | STAR declarator { (* %prec PSTAR this was wrong!! *) hp:=$2; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_one(t_pointerdef,nil)); } | _AND declarator %prec P_AND { hp:=$2; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_one(t_addrdef,nil)); } | dname COLON expr { (* size specifier supported *) hp:=new(presobject,init_one(t_size_specifier,$3)); $$:=new(presobject,init_three(t_dec,nil,$1,hp)); }| dname ASSIGN expr { writeln(outfile,'(* Warning : default value for ',$1^.p,' ignored *)'); hp:=new(presobject,init_one(t_default_value,$3)); $$:=new(presobject,init_three(t_dec,nil,$1,hp)); }| dname { $$:=new(presobject,init_two(t_dec,nil,$1)); }| declarator LKLAMMER argument_declaration_list RKLAMMER { hp:=$1; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_two(t_procdef,nil,$3)); } | declarator no_arg { hp:=$1; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_two(t_procdef,nil,nil)); } | declarator LECKKLAMMER expr RECKKLAMMER { hp:=$1; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_two(t_arraydef,nil,$3)); } | LKLAMMER declarator RKLAMMER { $$:=$2; } ; no_arg : LKLAMMER RKLAMMER | LKLAMMER VOID RKLAMMER; abstract_declarator : _CONST abstract_declarator { writeln(outfile,'(* Const before abstract_declarator ignored *)'); $$:=$2; } | size_overrider STAR abstract_declarator { writeln(outfile,aktspace,'(* ',$1^.p,' ignored *)'); dispose($1,done); hp:=$3; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_one(t_pointerdef,nil)); } | STAR abstract_declarator %prec PSTAR { hp:=$2; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_one(t_pointerdef,nil)); } | abstract_declarator LKLAMMER argument_declaration_list RKLAMMER { hp:=$1; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_two(t_procdef,nil,$3)); } | abstract_declarator no_arg { hp:=$1; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_two(t_procdef,nil,nil)); } | abstract_declarator LECKKLAMMER expr RECKKLAMMER { hp:=$1; $$:=hp; while assigned(hp^.p1) do hp:=hp^.p1; hp^.p1:=new(presobject,init_two(t_arraydef,nil,$3)); } | LKLAMMER abstract_declarator RKLAMMER { $$:=$2; } | { $$:=new(presobject,init_two(t_dec,nil,nil)); } ; expr : shift_expr {$$:=$1;} ; shift_expr : expr EQUAL expr { $$:=new(presobject,init_bop(' = ',$1,$3));} | expr UNEQUAL expr { $$:=new(presobject,init_bop(' <> ',$1,$3));} | expr GT expr { $$:=new(presobject,init_bop(' > ',$1,$3));} | expr GTE expr { $$:=new(presobject,init_bop(' >= ',$1,$3));} | expr LT expr { $$:=new(presobject,init_bop(' < ',$1,$3));} | expr LTE expr { $$:=new(presobject,init_bop(' <= ',$1,$3));} | expr _PLUS expr { $$:=new(presobject,init_bop(' + ',$1,$3));} | expr MINUS expr { $$:=new(presobject,init_bop(' - ',$1,$3));} | expr STAR expr { $$:=new(presobject,init_bop(' * ',$1,$3));} | expr _SLASH expr { $$:=new(presobject,init_bop(' / ',$1,$3));} | expr _OR expr { $$:=new(presobject,init_bop(' or ',$1,$3));} | expr _AND expr { $$:=new(presobject,init_bop(' and ',$1,$3));} | expr _NOT expr { $$:=new(presobject,init_bop(' not ',$1,$3));} | expr _SHL expr { $$:=new(presobject,init_bop(' shl ',$1,$3));} | expr _SHR expr { $$:=new(presobject,init_bop(' shr ',$1,$3));} | expr QUESTIONMARK colon_expr { $3^.p1:=$1; $$:=$3; inc(if_nb); $$^.p:=strpnew('if_local'+str(if_nb)); } | unary_expr {$$:=$1;} ; colon_expr : expr COLON expr { (* if A then B else C *) $$:=new(presobject,init_three(t_ifexpr,nil,$1,$3));} ; maybe_empty_unary_expr : unary_expr { $$:=$1; } | { $$:=nil;} ; unary_expr: dname { $$:=$1; } | CSTRING { (* remove L prefix for widestrings *) s:=act_token; if Win32headers and (s[1]='L') then delete(s,1,1); $$:=new(presobject,init_id(''''+copy(s,2,length(s)-2)+'''')); } | NUMBER { $$:=new(presobject,init_id(act_token)); } | unary_expr POINT expr { $$:=new(presobject,init_bop('.',$1,$3)); } | unary_expr DEREF expr { $$:=new(presobject,init_bop('^.',$1,$3)); } | MINUS unary_expr { $$:=new(presobject,init_preop('-',$2)); }| _AND unary_expr %prec R_AND { $$:=new(presobject,init_preop('@',$2)); }| _NOT unary_expr { $$:=new(presobject,init_preop(' not ',$2)); } | LKLAMMER dname RKLAMMER maybe_empty_unary_expr { if assigned($4) then $$:=new(presobject,init_two(t_typespec,$2,$4)) else $$:=$2; } | LKLAMMER type_specifier RKLAMMER unary_expr { $$:=new(presobject,init_two(t_typespec,$2,$4)); } | LKLAMMER type_specifier STAR RKLAMMER unary_expr { hp:=new(presobject,init_one(t_pointerdef,$2)); $$:=new(presobject,init_two(t_typespec,hp,$5)); } | LKLAMMER type_specifier size_overrider STAR RKLAMMER unary_expr { writeln(outfile,aktspace,'(* ',$3^.p,' ignored *)'); dispose($3,done); write_type_specifier(outfile,$2); writeln(outfile,' ignored *)'); hp:=new(presobject,init_one(t_pointerdef,$2)); $$:=new(presobject,init_two(t_typespec,hp,$6)); } | dname LKLAMMER exprlist RKLAMMER { hp:=new(presobject,init_one(t_exprlist,$1)); $$:=new(presobject,init_three(t_funexprlist,hp,$3,nil)); } | LKLAMMER shift_expr RKLAMMER { $$:=$2; } ; enum_list : enum_element COMMA enum_list { (*enum_element COMMA enum_list *) $$:=$1; $$^.next:=$3; } | enum_element { $$:=$1; } | {(* empty enum list *) $$:=nil;}; enum_element : dname _ASSIGN expr { begin (*enum_element: dname _ASSIGN expr *) $$:=new(presobject,init_two(t_enumlist,$1,$3)); end; } | dname { begin (*enum_element: dname*) $$:=new(presobject,init_two(t_enumlist,$1,nil)); end; }; def_expr : unary_expr { if $1^.typ=t_funexprlist then $$:=$1 else $$:=new(presobject,init_two(t_exprlist,$1,nil)); (* if here is a type specifier we know the return type *) if ($1^.typ=t_typespec) then $$^.p3:=$1^.p1^.get_copy; } ; exprlist : exprelem COMMA exprlist { (*exprlist COMMA expr*) $$:=$1; $1^.next:=$3; } | exprelem { $$:=$1; } | { (* empty expression list *) $$:=nil; }; exprelem : expr { $$:=new(presobject,init_one(t_exprlist,$1)); }; %% function yylex : Integer; begin yylex:=scan.yylex; end; var r:integer; SS:string; begin debug:=true; yydebug:=true; aktspace:=' '; block_type:=bt_no; IsExtern:=false; Assign(extfile,'ext.tmp'); rewrite(extfile); Assign(tempfile,'ext2.tmp'); rewrite(tempfile); r:=yyparse; if not(includefile) then begin writeln(outfile); writeln(outfile,' implementation'); writeln(outfile); writeln(outfile,'const External_library=''',libfilename,'''; {Setup as you need!}'); writeln(outfile); end; reset(extfile); { here we have a problem if a line is longer than 255 chars !! } while not eof(extfile) do begin readln(extfile,SS); writeln(outfile,SS); end; writeln(outfile); if not(includefile) then writeln(outfile,'end.'); close(extfile); erase(extfile); close(outfile); close(tempfile); erase(tempfile); close(textinfile); end. (* $Log$ Revision 1.2 2000-01-07 16:46:05 daniel * copyright 2000 Revision 1.1 1999/05/12 16:11:39 peter * moved Revision 1.22 1998/11/12 11:38:21 peter + new cdecl support + ... -> array of const Revision 1.21 1998/09/10 13:52:42 peter * removed warnings Revision 1.20 1998/09/04 17:26:32 pierre * better packed field handling Revision 1.18 1998/08/05 15:50:09 florian * small problems with // comments fixed (invalid line counting) + SYS_TRAP support for PalmOS + switch -x for PalmOS + switch -i to generate include files instead of units Revision 1.17 1998/07/27 11:03:48 florian * probelm with funtions which resturns a pointer solved Revision 1.16 1998/07/24 20:55:43 michael * Fixed some minor bugs in Pierres stuff Revision 1.15 1998/07/23 23:26:03 michael + added -D option instead of -d, restored old -d Revision 1.14 1998/06/12 16:53:52 pierre + syntax of C var changed again !! this reflect now the current state of the compiler * improvements in & address operator handling Revision 1.12 1998/06/08 08:13:44 pierre + merged version of h2pas + added -w for special win32 header directives 5.1998 : reworked by Pierre Muller - added better parsing of defines - handles type casting - error recovery partially implemented - WIN32 specific stuff still missing - tags not stored - conditionnals inside typed definitions - complicated defines not supported ( sets .. use of ## ... ) - what should we do about const specifier ? can we ignored this FAR modifier ? Revision 1.11 1998/04/30 11:22:20 florian + support of direct struct declaration added Revision 1.10 1998/04/27 12:06:40 michael + Added GPL statement Revision 1.9 1998/04/24 22:34:40 florian + enumerations with assigments implemented Revision 1.8 1998/04/24 18:23:46 florian + parameter -v added (replaces pointer parameters by call by reference parameters) void p(int *i) => procedure p(var i : longint); History: 25.9.1996: first version 26.9.1996: - structs are supported - unsigned implemented - procedure variables implemented - void * becomes pointer - unions implemented - enumerations - number post- and prefixes - operatores unary-, << and >> - problem with the priority of [], (), and * fixed - procedures and functions 28.9.1996: - formal paramters 22-26.5.1997 made by Mark Malakanov mark@av.krasnoyarsk.su - full ariphmetic and logic expressions in #define - #define with params changes to function (first param disappears by unknown reason!). Adds func body into implementation section. - real numbers - handling #ifdef ID to {$ifdef ID} #ifundef ID to {$ifundef ID} #else to {$else} #define ID to {$define ID} #endif to {$endif} -"extern" fully handled . Adds proc/func + 'external _ExternalLibrary;'to implementation section you must assign _ExternalLibrary later. -"const" skips in func/proc arguments. changes in convert.y and scan.l - "convert" renamed to "h2pas" - Inserted the checking "IsAssigned(Pointer)" everywhere access to pointers It preserv from Acces Violation Errors. - A little remade for TP Lex and Yacc 4.01 - changed function "input" to "get_char" -!!! because of peculiarity TPLY4.01 you must create unit CONVERU.PAS by your hand! Cut const definitions from CONVERT.PAS and paste into CONVERU.PAS What need * handle struct a { }; in the right way * all predefined C types * misplaced comments * handle functions without result *)