paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-03 21:30:50 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ -S, -T, -c modes added

Browse Source 
* crash fixes
  * removed double opening of inputfile
This commit is contained in:
peter 2000-03-27 21:39:19 +00:00
parent 2931f94d33
commit 164e1c25e6
6 changed files with 5927 additions and 5736 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6801
utils/h2pas/h2pas.pas
View File

File diff suppressed because it is too large Load Diff

368
utils/h2pas/h2pas.y
View File

@ -41,23 +41,22 @@ program h2pas;
const
INT_STR = 'longint';
UINT_STR = 'cardinal';
SHORT_STR = 'integer';
SHORT_STR = 'smallint';
UINT_STR = 'dword';
USHORT_STR = 'word';
CHAR_STR = 'char';
{ should we use byte or char for 'unsigned char' ?? }
UCHAR_STR = 'byte';
REAL_STR = 'real';
REAL_STR = 'double';
var
debug : boolean;
hp,ph : presobject;
extfile: text; (* file for implementation headers extern procs *)
IsExtern: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;
No_pop : boolean;
s,TN,PN : String;
(* $ define yydebug
compile with -dYYDEBUG to get debugging info *)
@ -450,18 +449,16 @@ program h2pas;
(* 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));
(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
(pos('CHAR',uppercase(p^.p1^.p2^.p1^.p1^.str))<>0) then
varpara:=false;
if varpara then
begin
@ -554,17 +551,13 @@ program h2pas;
begin
(* generate "pointer" ? *)
if (simple_type^.typ=t_void) and (p^.p1=nil) then
begin
begin
write(outfile,'pointer');
flush(outfile);
end
end
else
begin
if in_args then
write(outfile,'p')
else
write(outfile,'^');
flush(outfile);
write(outfile,'P');
write_p_a_def(outfile,p^.p1,simple_type);
end;
end;
@ -616,7 +609,7 @@ program h2pas;
write(outfile,'void');
t_pointerdef :
begin
write(outfile,'p');
write(outfile,'P');
write_type_specifier(outfile,p^.p1);
end;
t_enumdef :
@ -941,9 +934,13 @@ program h2pas;
file : declaration_list
;
error_info : { writeln(outfile,'(* error ');
writeln(outfile,prev_line);
writeln(outfile,last_source_line);
error_info : {
if not stripinfo then
begin
writeln(outfile,'(* error ');
writeln(outfile,yyline);
writeln(outfile,'*)');
end;
};
declaration_list : declaration_list declaration
@ -1009,59 +1006,58 @@ declaration :
writeln(outfile);
block_type:=bt_func;
write(outfile,aktspace);
write(extfile,aktspace);
if not CompactMode then
begin
write(outfile,aktspace);
if not IsExtern then
write(extfile,aktspace);
end;
(* distinguish between procedure and function *)
if assigned($2) then
if ($2^.typ=t_void) and ($4^.p1^.p1^.p1=nil) 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);
shift(10);
write(outfile,'procedure ',$4^.p1^.p2^.p);
if assigned($4^.p1^.p1^.p2) then
write_args(outfile,$4^.p1^.p1^.p2);
if not IsExtern then
begin
write(extfile,'procedure ',$4^.p1^.p2^.p);
if assigned($4^.p1^.p1^.p2) then
write_args(extfile,$4^.p1^.p1^.p2);
end;
end
else
begin
write(outfile,'function ',$4^.p1^.p2^.p);
write(extfile,'function ',$4^.p1^.p2^.p);
shift(9);
(* write arguments *)
write(outfile,'function ',$4^.p1^.p2^.p);
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);
if not IsExtern then
begin
write(extfile,'function ',$4^.p1^.p2^.p);
if assigned($4^.p1^.p1^.p2) then
write_args(extfile,$4^.p1^.p1^.p2);
write(extfile,':');
write_p_a_def(extfile,$4^.p1^.p1^.p1,$2);
end;
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;
write(outfile,';cdecl');
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,';');
begin
write (outfile,';external');
If UseName then
Write(outfile,' External_library name ''',$4^.p1^.p2^.p,'''');
end;
writeln(outfile,';');
end
else
@ -1070,15 +1066,14 @@ declaration :
writeln(outfile,';');
if not IsExtern then
begin
writeln(extfile,aktspace,' begin');
writeln(extfile,aktspace,' { You must implemented this function }');
writeln(extfile,aktspace,' end;');
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);
if not compactmode then
writeln(outfile);
end
else (* $4^.p1^.p1^.typ=t_procdef *)
if assigned($4)and assigned($4^.p1) then
@ -1130,26 +1125,29 @@ declaration :
begin
writeln(outfile);
writeln(outfile,aktspace,'type');
block_type:=bt_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;
if RemoveUnderScore and (length(tn)>1) and (tn[1]='_') then
Delete(TN,1,1);
if UsePPointers and
(($1^.typ=t_structdef) or ($1^.typ=t_uniondef)) then
begin
PN:='P'+TN;
if PrependTypes then
TN:='T'+TN;
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,';');
if block_type=bt_type then
writeln(outfile,';');
writeln(outfile);
flush(outfile);
popshift;
@ -1158,14 +1156,42 @@ declaration :
if assigned(hp) then
dispose(hp,done);
} |
TYPEDEF STRUCT dname dname SEMICOLON
{
if block_type<>bt_type then
begin
writeln(outfile);
writeln(outfile,aktspace,'type');
block_type:=bt_type;
end;
PN:=$3^.p;
TN:=$4^.p;
if RemoveUnderscore then
begin
if (length(pn)>1) and (PN[1]='_') then
Delete(Pn,1,1);
if (length(tn)>1) and (tN[1]='_') then
Delete(tn,1,1);
end;
if Uppercase(tn)<>Uppercase(pn) then
begin
shift(3);
writeln(outfile,aktspace,PN,' = ',TN,';');
popshift;
end;
if assigned($3) then
dispose($3,done);
if assigned($4) then
dispose($4,done);
} |
TYPEDEF type_specifier dec_modifier declarator_list SEMICOLON
{
if block_type<>bt_type then
begin
writeln(outfile);
writeln(outfile,aktspace,'type');
block_type:=bt_type;
end;
block_type:=bt_type;
no_pop:=assigned($3) and ($3^.str='no_pop');
shift(3);
@ -1175,26 +1201,28 @@ declaration :
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);
if assigned(hp^.p1) and assigned(hp^.p1^.p2) then
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);
end;
hp:=hp^.next;
end;
(* write tag name *)
@ -1233,9 +1261,8 @@ declaration :
begin
writeln(outfile);
writeln(outfile,aktspace,'type');
block_type:=bt_type;
end;
block_type:=bt_type;
shift(3);
(* write as pointer *)
writeln(outfile);
@ -1243,8 +1270,8 @@ declaration :
writeln(outfile,aktspace,$2^.p,' = pointer;');
flush(outfile);
popshift;
if assigned($2)then
dispose($2,done);
if assigned($2) then
dispose($2,done);
}
| error error_info SEMICOLON
{ writeln(outfile,'in declaration at line ',line_no,' *)');
@ -1468,7 +1495,8 @@ special_type_specifier :
type_specifier :
_CONST type_specifier
{
writeln(outfile,'(* Const before type ignored *)');
if not stripinfo then
writeln(outfile,'(* Const before type ignored *)');
$$:=$2;
} |
UNION closed_list _PACKED
@ -1593,6 +1621,10 @@ simple_type_name :
dname
{
$$:=$1;
tn:=$$^.str;
if removeunderscore and
(length(tn)>1) and (tn[1]='_') then
$$^.setstr(Copy(tn,2,length(tn)-1));
}
;
@ -1626,6 +1658,11 @@ argument_declaration : type_specifier declarator
{
$$:=new(presobject,init_two(t_arg,$1,$2));
} |
type_specifier STAR declarator
{
hp:=new(presobject,init_one(t_pointerdef,$1));
$$:=new(presobject,init_two(t_arg,hp,$3));
} |
type_specifier abstract_declarator
{
$$:=new(presobject,init_two(t_arg,$1,$2));
@ -1660,12 +1697,14 @@ size_overrider :
declarator :
_CONST declarator
{
writeln(outfile,'(* Const before declarator ignored *)');
if not stripinfo then
writeln(outfile,'(* Const before declarator ignored *)');
$$:=$2;
} |
size_overrider STAR declarator
{
writeln(outfile,aktspace,'(* ',$1^.p,' ignored *)');
if not stripinfo then
writeln(outfile,aktspace,'(* ',$1^.p,' ignored *)');
dispose($1,done);
hp:=$3;
$$:=hp;
@ -1675,7 +1714,7 @@ declarator :
} |
STAR declarator
{
(* %prec PSTAR this was wrong!! *)
(* %prec PSTAR this was wrong!! *)
hp:=$2;
$$:=hp;
while assigned(hp^.p1) do
@ -1698,7 +1737,8 @@ declarator :
}|
dname ASSIGN expr
{
writeln(outfile,'(* Warning : default value for ',$1^.p,' ignored *)');
if not stripinfo then
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));
}|
@ -1739,12 +1779,14 @@ no_arg : LKLAMMER RKLAMMER |
abstract_declarator :
_CONST abstract_declarator
{
writeln(outfile,'(* Const before abstract_declarator ignored *)');
if not stripinfo then
writeln(outfile,'(* Const before abstract_declarator ignored *)');
$$:=$2;
} |
size_overrider STAR abstract_declarator
{
writeln(outfile,aktspace,'(* ',$1^.p,' ignored *)');
if not stripinfo then
writeln(outfile,aktspace,'(* ',$1^.p,' ignored *)');
dispose($1,done);
hp:=$3;
$$:=hp;
@ -1903,7 +1945,8 @@ unary_expr:
} |
LKLAMMER type_specifier size_overrider STAR RKLAMMER unary_expr
{
writeln(outfile,aktspace,'(* ',$3^.p,' ignored *)');
if not stripinfo then
writeln(outfile,aktspace,'(* ',$3^.p,' ignored *)');
dispose($3,done);
write_type_specifier(outfile,$2);
writeln(outfile,' ignored *)');
@ -1981,55 +2024,106 @@ exprelem :
%%
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);
yylex:=scan.yylex;
line_no:=yylineno;
end;
var
SS : string;
begin
{ Initialize }
yydebug:=true;
aktspace:='';
block_type:=bt_no;
IsExtern:=false;
{ Read commandline options }
ProcessOptions;
if not CompactMode then
aktspace:=' ';
{ open input and output files }
assign(yyinput, inputfilename);
{$I-}
reset(yyinput);
{$I+}
if ioresult<>0 then
begin
writeln('file ',inputfilename,' not found!');
halt(1);
end;
assign(outfile, outputfilename);
rewrite(outfile);
{ write unit header }
if not includefile then
begin
writeln(outfile,'unit ',unitname,';');
writeln(outfile,aktspace,'interface');
writeln(outfile);
writeln(outfile,'{ Automatically converted by H2Pas ',version,' from ',inputfilename,' }');
writeln(outfile);
end;
if UseName then
begin
writeln(outfile,aktspace,'const');
writeln(outfile,aktspace,' External_library=''',libfilename,'''; {Setup as you need}');
writeln(outfile);
end;
if UsePPointers then
begin
Writeln(outfile,aktspace,'{ Pointers to basic pascal types, inserted by h2pas conversion program.}');
Writeln(outfile,aktspace,'Type');
Writeln(outfile,aktspace,' PLongint = ^Longint;');
Writeln(outfile,aktspace,' PSmallInt = ^SmallInt;');
Writeln(outfile,aktspace,' PByte = ^Byte;');
Writeln(outfile,aktspace,' PWord = ^Word;');
Writeln(outfile,aktspace,' PDWord = ^DWord;');
Writeln(outfile,aktspace,' PDouble = ^Double;');
Writeln(outfile);
end;
writeln(outfile,'{$PACKRECORDS C}');
writeln(outfile);
{ Open tempfiles }
Assign(extfile,'ext.tmp');
rewrite(extfile);
Assign(tempfile,'ext2.tmp');
rewrite(tempfile);
{ Parse! }
yyparse;
{ Write implementation if needed }
if not(includefile) then
begin
writeln(outfile);
writeln(outfile,aktspace,'implementation');
writeln(outfile);
end;
{ here we have a problem if a line is longer than 255 chars !! }
reset(extfile);
while not eof(extfile) do
begin
readln(extfile,SS);
writeln(outfile,SS);
readln(extfile,SS);
writeln(outfile,SS);
end;
{ write end of file }
writeln(outfile);
if not(includefile) then
writeln(outfile,'end.');
{ close and erase tempfiles }
close(extfile);
erase(extfile);
close(outfile);
close(tempfile);
erase(tempfile);
close(textinfile);
end.
(*
$Log$
Revision 1.3 2000-02-09 16:44:15 peter
Revision 1.4 2000-03-27 21:39:20 peter
+ -S, -T, -c modes added
* crash fixes
* removed double opening of inputfile
Revision 1.3 2000/02/09 16:44:15 peter
* log truncated
Revision 1.2 2000/01/07 16:46:05 daniel

9
utils/h2pas/lexlib.pas
View File

@ -40,7 +40,7 @@ interface
var
yyinput, yyoutput : Text; (* input and output file *)
yyline : String; (* current input line *)
yyline,yyprevline : String; (* current and previous input line *)
yylineno, yycolno : Integer; (* current input position *)
yytext : String; (* matched text (should be considered r/o) *)
yyleng : Byte (* length of matched text *)
@ -185,8 +185,10 @@ function get_char : Char;
begin
if (bufptr=0) and not eof(yyinput) then
begin
yyprevline:=yyline;
readln(yyinput, yyline);
inc(yylineno); yycolno := 1;
inc(yylineno);
yycolno := 1;
buf[1] := nl;
for i := 1 to length(yyline) do
buf[i+1] := yyline[length(yyline)-i+1];
@ -401,7 +403,8 @@ procedure yyclear;
begin
assign(yyinput, '');
assign(yyoutput, '');
reset(yyinput); rewrite(yyoutput);
reset(yyinput);
rewrite(yyoutput);
yylineno := 0;
yyclear;
end(*LexLib*).

245
utils/h2pas/options.pas
View File

@ -17,52 +17,44 @@
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************}
unit options;
interface
const
version = '0.99.15';
var
inputfilename, outputfilename : string; { Filenames }
LibFileName, unitname : string; { external library name }
CompactMode,
stripinfo, { Don't write info comments to output }
UseLib, { Append external to implementation ? }
UseName, { Append 'libname name 'funcname ' }
UsePPOinters, { Use P instead of ^ for pointers }
EnumToConst, { Write enumeration types as constants }
Win32headers, { allows dec_specifier }
stripcomment, { strip comments from inputfile }
PrependTypes : Boolean; { Print T in front of type names ? }
PrependTypes, { Print T in front of type names ? }
RemoveUnderscore : Boolean;
usevarparas : boolean; { generate var parameters, when a pointer }
{ is passed }
includefile : boolean; { creates an include file instead of a unit }
palmpilot : boolean; { handling of PalmOS SYS_CALLs }
{ Helpers }
Function ForceExtension(Const HStr,ext:String):String;
Function MaybeExtension(Const HStr,ext:String):String;
{ Options }
Procedure ProcessOptions;
Implementation
Procedure Usage;
begin
writeln ('Usage : ',paramstr(0),' [options] filename');
writeln (' Where [options] is one or more of:');
writeln (' -o outputfilename Specify the outputfilename');
writeln (' -l libname Specify the library name for external.');
writeln (' -u unitname Specify the name of the unit.');
writeln (' -t Prepend typedef type names with T');
writeln (' -p Use "P" instead of "^" for pointers.');
writeln (' -d Use external;');
writeln (' -D use external libname name ''func_name'';');
writeln (' -e change enum type to list of constants.');
writeln (' -s strip comments from inputfile.');
writeln (' -v replace pointer parameters by call by');
writeln (' reference parameters');
writeln (' -w special for win32 headers');
writeln (' -i create include files (no unit header)');
writeln (' -x handle SYS_TRAP of PalmOS header files');
halt (0);
end;
{*****************************************************************************
Helpers
*****************************************************************************}
Function ForceExtension(Const HStr,ext:String):String;
{
@ -80,26 +72,73 @@ begin
ForceExtension:=Copy(Hstr,1,j-1)+'.'+Ext;
end;
Procedure ProcessOptions;
Var cp : string;
I : longint;
Function GetNextParam (const Opt,Name : String) : string;
Function MaybeExtension(Const HStr,ext:String):String;
{
Return a filename which certainly has the extension ext
(no dot in ext !!)
}
var
j : longint;
begin
if i=paramcount then
begin
writeln ('Error : -',Opt,' : ',name,' expected');
halt(1);
end
else
begin
GetNextParam:=paramstr(i+1);
inc(i);
end;
j:=length(Hstr);
while (j>0) and (Hstr[j]<>'.') do
dec(j);
if j=0 then
MaybeExtension:=Hstr+'.'+Ext
else
MaybeExtension:=Hstr;
end;
{*****************************************************************************
Options
*****************************************************************************}
Procedure Usage;
begin
writeln ('Usage : ',paramstr(0),' [options] filename');
writeln (' Where [options] is one or more of:');
writeln (' -d Use external;');
writeln (' -D use external libname name ''func_name'';');
writeln (' -e change enum type to list of constants');
writeln (' -c Compact outputmode, less spaces and empty lines');
writeln (' -i create include files (no unit header)');
writeln (' -l libname Specify the library name for external');
writeln (' -o outputfilename Specify the outputfilename');
writeln (' -p Use "P" instead of "^" for pointers');
writeln (' -s strip comments from inputfile');
writeln (' -S strip comments and don''t write info to outputfile.');
writeln (' -t Prepend typedef type names with T');
writeln (' -T Prepend typedef type names with T, and remove _');
writeln (' -u unitname Specify the name of the unit.');
writeln (' -v replace pointer parameters by call by');
writeln (' reference parameters');
writeln (' -w special for win32 headers');
writeln (' -x handle SYS_TRAP of PalmOS header files');
halt (0);
end;
Procedure ProcessOptions;
Var
cp : string;
I : longint;
Function GetNextParam (const Opt,Name : String) : string;
begin
if i=paramcount then
begin
writeln ('Error : -',Opt,' : ',name,' expected');
halt(1);
end
else
begin
GetNextParam:=paramstr(i+1);
inc(i);
end;
end;
begin
if paramcount=0 then
Usage;
@ -107,77 +146,89 @@ begin
outputfilename:='';
LibFileName:='';
UnitName:='';
UseLib:=False;
UseName:=FAlse;
StripComment:=False;
UsePPointers:=False;
EnumToCOnst:=False;
CompactMode:=false;
UseLib:=false;
UseName:=false;
StripComment:=false;
StripInfo:=false;
UsePPointers:=false;
EnumToCOnst:=false;
usevarparas:=false;
palmpilot:=false;
includefile:=false;
i:=1;
while i<=paramcount do
begin
cp:=paramstr(i);
if cp[1]='-' then
case cp[2] of
'o' : outputfilename:=GetNextParam('o','outputfilename');
't' : PrependTypes := True;
'p' : UsePPointers := True;
'e' : EnumToConst := True;
'd' : UseLib := True;
'D' : begin
UseLib := True;
usename := True;
end;
's' : stripcomment:=true;
'l' : LibFileName:=GetNextParam ('l','libname');
'u' : UnitName:=GetNextParam ('u','unitname');
'v' : usevarparas:=true;
'i' : includefile:=true;
'w' : begin
Win32headers:=true;
UseLib:=true;
usename:=true;
usevarparas:=true;
LibFileName:='kernel32';
end;
'x' : palmpilot:=true;
else
Writeln ('Illegal option : ',cp);
begin
cp:=paramstr(i);
if cp[1]='-' then
begin
case cp[2] of
'c' : CompactMode:=true;
'e' : EnumToConst :=true;
'd' : UseLib :=true;
'D' : begin
UseLib :=true;
usename :=true;
end;
'i' : includefile:=true;
'l' : LibFileName:=GetNextParam ('l','libname');
'o' : outputfilename:=GetNextParam('o','outputfilename');
'p' : UsePPointers:=true;
's' : stripcomment:=true;
'S' : begin
stripcomment:=true;
stripinfo:=true;
end;
't' : PrependTypes:=true;
'T' : begin
PrependTypes:=true;
RemoveUnderscore:=true;
end;
'u' : UnitName:=GetNextParam ('u','unitname');
'v' : usevarparas:=true;
'w' : begin
Win32headers:=true;
UseLib:=true;
usename:=true;
usevarparas:=true;
LibFileName:='kernel32';
end;
'x' : palmpilot:=true;
else
Writeln ('Illegal option : ',cp);
end
end
else
else
begin { filename }
if inputfilename<>'' then
begin
writeln ('Error : only one filename supported. Found also :',cp);
halt(1);
end;
inputfilename:=cp;
if outputfilename='' then
outputfilename:=ForceExtension (inputfilename,'pp');
if inputfilename<>'' then
begin
writeln ('Error : only one filename supported. Found also :',cp);
halt(1);
end;
inputfilename:=MaybeExtension(cp,'h');
if outputfilename='' then
outputfilename:=ForceExtension (inputfilename,'pp');
end;
inc(i);
end;
If inputfilename='' then Usage;
inc(i);
end;
If inputfilename='' then
Usage;
if UnitName='' then
begin
i:=pos('.',outputfilename)-1;
if i<=0 then
begin
i:=pos('.',outputfilename)-1;
if i<=0 then
UnitName:=outputfilename
else
else
UnitName:=Copy(OutputFileName,1,i);
end;
end;
end;
end.
{
$Log$
Revision 1.3 2000-02-09 16:44:15 peter
* log truncated
Revision 1.2 2000/01/07 16:46:05 daniel
* copyright 2000
Revision 1.4 2000-03-27 21:39:20 peter
+ -S, -T, -c modes added
* crash fixes
* removed double opening of inputfile
}

351
utils/h2pas/scan.l
View File

@ -28,6 +28,9 @@ unit scan;
strings,
lexlib,yacclib;
const
version = '0.99.15';
type
Char=system.char;
ttyp = (
@ -101,11 +104,7 @@ unit scan;
{ p1 expr for value }
);
{tdtyp = (dt_id,dt_one,dt_two,dt_three,dt_no,dt_uop,dt_bop);
obsolete removed }
presobject = ^tresobject;
tresobject = object
typ : ttyp;
p : pchar;
@ -119,6 +118,7 @@ unit scan;
constructor init_id(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;
@ -132,61 +132,73 @@ unit scan;
var
infile : string;
textinfile,outfile : text;
outfile : text;
c : char;
aktspace : string;
block_type : tblocktype;
const
in_define : boolean = false;
{ 1 after define; 2 after the ID to print the first
separating space }
{ 1 after define; 2 after the ID to print the first separating space }
in_space_define : byte = 0;
arglevel : longint = 0;
prev_line : string = '';
last_source_line : string = 'Line number 0';
function yylex : integer;
function act_token : string;
procedure internalerror(i : integer);
procedure next_line;
function strpnew(const s : string) : pchar;
implementation
uses options,converu;
uses
options,converu;
const
newline = #10;
procedure internalerror(i : integer);
begin
writeln('Internal error ',i,' in line ',line_no);
writeln('Internal error ',i,' in line ',yylineno);
halt(1);
end;
{ keep the last source line }
procedure next_line;
begin
inc(line_no);
prev_line:=last_source_line;
readln(textinfile,last_source_line);
end;
procedure commenteof;
begin
writeln('unexpected EOF inside comment at line ',line_no);
writeln('unexpected EOF inside comment at line ',yylineno);
end;
var p : pchar;
procedure copy_until_eol;
begin
c:=get_char;
while c<>newline do
begin
write(outfile,c);
c:=get_char;
end;
end;
procedure skip_until_eol;
begin
c:=get_char;
while c<>newline do
c:=get_char;
end;
function strpnew(const s : string) : pchar;
var
p : pchar;
begin
getmem(p,length(s)+1);
strpcopy(p,s);
strpnew:=p;
end;
const
newline = #10;
constructor tresobject.init_preop(const s : string;_p1 : presobject);
begin
@ -258,14 +270,19 @@ unit scan;
next:=nil;
end;
function tresobject.str : string;
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)
@ -273,9 +290,8 @@ unit scan;
strlength:=0;
end;
{ can this ve considered as a constant ? }
{ can this ve considered as a constant ? }
function tresobject.is_const : boolean;
begin
case typ of
t_id,t_void :
@ -325,61 +341,65 @@ unit scan;
D [0-9]
%%
"/*" begin
"/*" begin
if not stripcomment then
write(outfile,aktspace,'{');
repeat
c:=get_char;
case c of
'*' : begin
c:=get_char;
if c='/' then
begin
if not stripcomment then
writeln(outfile,' }');
flush(outfile);
exit;
end
else
begin
if not stripcomment then
write(outfile,' ');
unget_char(c)
end;
end;
newline : begin
next_line;
if not stripcomment then
begin
writeln(outfile);
write(outfile,aktspace);
end;
end;
#0 : commenteof;
else if not stripcomment then
write(outfile,c);
'*' :
begin
c:=get_char;
if c='/' then
begin
if not stripcomment then
writeln(outfile,' }');
flush(outfile);
exit;
end
else
begin
if not stripcomment then
write(outfile,' ');
unget_char(c)
end;
end;
newline :
begin
if not stripcomment then
begin
writeln(outfile);
write(outfile,aktspace);
end;
end;
#0 :
commenteof;
else
if not stripcomment then
write(outfile,c);
end;
until false;
flush(outfile);
end;
"//" begin
"//" begin
If not stripcomment then
write(outfile,aktspace,'{');
write(outfile,aktspace,'{');
repeat
c:=get_char;
case c of
newline : begin
unget_char(c);
if not stripcomment then
writeln(outfile,' }');
flush(outfile);
exit;
end;
#0 : commenteof;
else if not stripcomment then
write(outfile,c);
flush(outfile);
newline :
begin
unget_char(c);
if not stripcomment then
writeln(outfile,' }');
flush(outfile);
exit;
end;
#0 :
commenteof;
else
if not stripcomment then
write(outfile,c);
end;
until false;
flush(outfile);
@ -394,14 +414,15 @@ D [0-9]
return(CSTRING)
else
return(256);
{D}*[U]?[L]? begin
{D}*[U]?[L]? begin
if yytext[length(yytext)]='L' then
dec(byte(yytext[0]));
if yytext[length(yytext)]='U' then
dec(byte(yytext[0]));
return(NUMBER);
end;
"0x"[0-9A-Fa-f]*[U]?[L]? begin
"0x"[0-9A-Fa-f]*[U]?[L]?
begin
(* handle pre- and postfixes *)
if copy(yytext,1,2)='0x' then
begin
@ -414,12 +435,10 @@ D [0-9]
dec(byte(yytext[0]));
return(NUMBER);
end;
{D}+(\.{D}+)?([Ee][+-]?{D}+)?
begin
return(NUMBER);
end;
begin
return(NUMBER);
end;
"->" if in_define then
return(DEREF)
else
@ -468,11 +487,11 @@ D [0-9]
return(ID)
else
return(CDECL);
"PASCAL" if not Win32headers then
"PASCAL" if not Win32headers then
return(ID)
else
return(PASCAL);
"PACKED" if not Win32headers then
"PACKED" if not Win32headers then
return(ID)
else
return(_PACKED);
@ -488,22 +507,26 @@ D [0-9]
return(ID)
else
return(WINGDIAPI);
"CALLBACK" if not Win32headers then
"CALLBACK" if not Win32headers then
return(ID)
else
return(CALLBACK);
"EXPENTRY" if not Win32headers then
"EXPENTRY" if not Win32headers then
return(ID)
else
return(CALLBACK);
"void" return(VOID);
"VOID" return(VOID);
"#ifdef __cplusplus"[ \t]*\n"extern \"C\" {"\n"#endif"
writeln(outfile,'{ C++ extern C conditionnal removed }');
begin
if not stripinfo then
writeln(outfile,'{ C++ extern C conditionnal removed }');
end;
"#ifdef __cplusplus"[ \t]*\n"}"\n"#endif"
writeln(outfile,'{ C++ end of extern C conditionnal removed }');
begin
if not stripinfo then
writeln(outfile,'{ C++ end of extern C conditionnal removed }');
end;
"#else" begin
writeln(outfile,'{$else}');
block_type:=bt_no;
@ -514,69 +537,53 @@ D [0-9]
block_type:=bt_no;
flush(outfile);
end;
"#elif" begin
write(outfile,'(*** was #elif ****)');
"#elif" begin
if not stripinfo then
write(outfile,'(*** was #elif ****)');
write(outfile,'{$else');
c:=get_char;
while c<>newline do
begin write(outfile,c);c:=get_char;end;
copy_until_eol;
writeln(outfile,'}');
block_type:=bt_no;
flush(outfile);
next_line;
end;
"#undef" begin
write(outfile,'{$undef');
c:=get_char;
while c<>newline do
begin write(outfile,c);c:=get_char;end;
copy_until_eol;
writeln(outfile,'}');
flush(outfile);
next_line;
end;
"#error" begin
write(outfile,'{$error');
c:=get_char;
while c<>newline do
begin
write(outfile,c);
c:=get_char;
end;
copy_until_eol;
writeln(outfile,'}');
flush(outfile);
next_line;
end;
"#include" begin
write(outfile,'{$include');
c:=get_char;
while c<>newline do
begin write(outfile,c);c:=get_char;end;
copy_until_eol;
writeln(outfile,'}');
flush(outfile);
block_type:=bt_no;
next_line;
end;
"#if" begin
write(outfile,'{$if');
c:=get_char;
while c<>newline do
begin write(outfile,c);c:=get_char;end;
copy_until_eol;
writeln(outfile,'}');
flush(outfile);
block_type:=bt_no;
next_line;
end;
"#pragma" begin
write(outfile,'(** unsupported pragma');
write(outfile,'#pragma');
c:=get_char;
while c<>newline do
begin write(outfile,c);c:=get_char;end;
writeln(outfile,'*)');
flush(outfile);
if not stripinfo then
begin
write(outfile,'(** unsupported pragma');
write(outfile,'#pragma');
copy_until_eol;
writeln(outfile,'*)');
flush(outfile);
end
else
skip_until_eol;
block_type:=bt_no;
next_line;
end;
"#define" begin
in_define:=true;
@ -599,109 +606,43 @@ D [0-9]
"CONST" return(_CONST);
"FAR" return(_FAR);
"far" return(_FAR);
"NEAR" return(_NEAR);
"near" return(_NEAR);
"HUGE" return(_HUGE);
"huge" return(_HUGE);
"NEAR" return(_NEAR);
"near" return(_NEAR);
"HUGE" return(_HUGE);
"huge" return(_HUGE);
[A-Za-z_][A-Za-z0-9_]* begin
if in_space_define=1 then
in_space_define:=2;
return(ID);
end;
";" return(SEMICOLON);
[ \f\t] if arglevel=0 then
if in_space_define=2 then
[ \f\t] begin
if (arglevel=0) and (in_space_define=2) then
begin
in_space_define:=0;
return(SPACE_DEFINE);
in_space_define:=0;
return(SPACE_DEFINE);
end;
\\\n begin
next_line;
if arglevel=0 then
if in_space_define=2 then
begin
in_space_define:=0;
return(SPACE_DEFINE);
end;
end;
\n begin
next_line;
if in_define then
begin
in_define:=false;
in_space_define:=0;
return(NEW_LINE);
end;
begin
in_define:=false;
in_space_define:=0;
return(NEW_LINE);
end;
end;
. begin
writeln('Illegal character in line ',line_no);
writeln(last_source_line);
return(256 { error });
writeln('Illegal character in line ',yylineno);
writeln('"',yyline,'"');
return(256);
end;
%%
function act_token : string;
begin
act_token:=yytext;
end;
Function ForceExtension(Const HStr,ext:String):String;
{
Return a filename which certainly has the extension ext
(no dot in ext !!)
}
var
j : longint;
function act_token : string;
begin
j:=length(Hstr);
while (j>0) and (Hstr[j]<>'.') do
dec(j);
if j=0 then
j:=255;
ForceExtension:=Copy(Hstr,1,j-1)+'.'+Ext;
act_token:=yytext;
end;
begin
ProcessOptions;
line_no := 1;
assign(yyinput, inputfilename);
reset(yyinput);
assign(textinfile, inputfilename);
reset(textinfile);
readln(textinfile,last_source_line);
assign(outfile, outputfilename);
rewrite(outfile);
if not(includefile) then
begin
writeln(outfile,'unit ',unitname,';');
writeln(outfile);
writeln(outfile,'{ Automatically converted by H2PAS.EXE from '+inputfilename);
writeln(outfile,' Utility made by Florian Klaempfl 25th-28th september 96');
writeln(outfile,' Improvements made by Mark A. Malakanov 22nd-25th may 97 ');
writeln(outfile,' Further improvements by Michael Van Canneyt, April 1998 ');
writeln(outfile,' define handling and error recovery by Pierre Muller, June 1998 }');
writeln(outfile);
writeln(outfile);
writeln(outfile,' interface');
writeln(outfile);
writeln(outfile,' { C default packing is dword }');
writeln(outfile);
writeln(outfile,'{$PACKRECORDS 4}');
end;
if UsePPointers then
begin
{ Define some pointers to basic pascal types }
writeln(outfile);
Writeln(outfile,' { Pointers to basic pascal types, inserted by h2pas conversion program.}');
Writeln(outfile,' Type');
Writeln(outfile,' PLongint = ^Longint;');
Writeln(outfile,' PByte = ^Byte;');
Writeln(outfile,' PWord = ^Word;');
Writeln(outfile,' PInteger = ^Integer;');
Writeln(outfile,' PCardinal = ^Cardinal;');
Writeln(outfile,' PReal = ^Real;');
Writeln(outfile,' PDouble = ^Double;');
Writeln(outfile);
end;
end.
end.

3889
utils/h2pas/scan.pas
View File

File diff suppressed because it is too large Load Diff