freepascal.compiler/utils/h2pas/scan.l

%{
{
    $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.

 ****************************************************************************}


unit scan;

  interface

  uses
   strings,
   lexlib,yacclib;

    type
       Char=system.char;
       ttyp = (
          t_id,
          { p contains the string }
          t_arraydef,
          { }
          t_pointerdef,
          { p1 contains the definition
            if in type overrider
            or nothing for args
          }
          t_addrdef,

          t_void,
          { no field }
          t_dec,
          { }
          t_declist,
          { p1 is t_dec
            next if exists }
          t_memberdec,
          { p1 is type specifier
            p2 is declarator_list }
          t_structdef,
          { }
          t_memberdeclist,
          { p1 is memberdec
            next is next if it exist }
          t_procdef,
          { }
          t_uniondef,
          { }
          t_enumdef,
          { }
          t_enumlist,
          { }
          t_preop,
          { p contains the operator string
            p1 contains the right expr }
          t_bop,
          { p contains the operator string
            p1 contains the left expr
            p2 contains the right expr }
          t_arg,
          {
            p1 contain the typedef
            p2 the declarator (t_dec)
          }
          t_arglist,
          { }
          t_funexprlist,
          { }
          t_exprlist,
          { p1 contains the expr
            next contains the next if it exists }
          t_ifexpr,
          { p1 contains the condition expr
            p2 contains the if branch
            p3 contains the else branch }
          t_funcname,
          { p1 contains the function dname
            p2 contains the funexprlist
            p3 possibly contains the return type }
          t_typespec,
          { p1 is the type itself
            p2 the typecast expr }
          t_size_specifier,
          { p1 expr for size }
          t_default_value
          { p1 expr for value }
          );

       {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;
          next : presobject;
          p1,p2,p3 : presobject;
          { dtyp : tdtyp; }
          constructor init_no(t : ttyp);
          constructor init_one(t : ttyp;_p1 : presobject);
          constructor init_two(t : ttyp;_p1,_p2 : presobject);
          constructor init_three(t : ttyp;_p1,_p2,_p3 : presobject);
          constructor init_id(const s : string);
          constructor init_bop(const s : string;_p1,_p2 : presobject);
          constructor init_preop(const s : string;_p1 : presobject);
          function str : string;
          function strlength : byte;
          function get_copy : presobject;
          { can this ve considered as a constant ? }
          function is_const : boolean;
          destructor done;
       end;

     tblocktype = (bt_type,bt_const,bt_var,bt_func,bt_no);


    var
       infile : string;
       textinfile,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 }
       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;

    procedure internalerror(i : integer);
      begin
         writeln('Internal error ',i,' in line ',line_no);
         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);
      end;

    var         p : pchar;
    function strpnew(const s : string) : 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
         typ:=t_preop;
         p:=strpnew(s);
         p1:=_p1;
         p2:=nil;
         p3:=nil;
         next:=nil;
      end;

    constructor tresobject.init_bop(const s : string;_p1,_p2 : presobject);
      begin
         typ:=t_bop;
         p:=strpnew(s);
         p1:=_p1;
         p2:=_p2;
         p3:=nil;
         next:=nil;
      end;

    constructor tresobject.init_id(const s : string);
      begin
         typ:=t_id;
         p:=strpnew(s);
         p1:=nil;
         p2:=nil;
         p3:=nil;
         next:=nil;
      end;

    constructor tresobject.init_two(t : ttyp;_p1,_p2 : presobject);
      begin
         typ:=t;
         p1:=_p1;
         p2:=_p2;
         p3:=nil;
         p:=nil;
         next:=nil;
      end;

    constructor tresobject.init_three(t : ttyp;_p1,_p2,_p3 : presobject);
      begin
         typ:=t;
         p1:=_p1;
         p2:=_p2;
         p3:=_p3;
         p:=nil;
         next:=nil;
      end;

    constructor tresobject.init_one(t : ttyp;_p1 : presobject);
      begin
         typ:=t;
         p1:=_p1;
         p2:=nil;
         p3:=nil;
         next:=nil;
         p:=nil;
      end;

    constructor tresobject.init_no(t : ttyp);
      begin
         typ:=t;
         p:=nil;
         p1:=nil;
         p2:=nil;
         p3:=nil;
         next:=nil;
      end;

    function tresobject.str : string;

      begin
         str:=strpas(p);
      end;

    function tresobject.strlength : byte;

      begin
         if assigned(p) then
           strlength:=strlen(p)
         else
           strlength:=0;
      end;

          { can this ve considered as a constant ? }
    function tresobject.is_const : boolean;

      begin
         case typ of
           t_id,t_void :
             is_const:=true;
           t_preop  :
             is_const:= ((str='-') or (str=' not ')) and p1^.is_const;
           t_bop  :
             is_const:= p2^.is_const and p1^.is_const;
         else
           is_const:=false;
         end;
      end;

    function tresobject.get_copy : presobject;
      var
         newres : presobject;
      begin
         newres:=new(presobject,init_no(typ));
         if assigned(p) then
           newres^.p:=strnew(p);
         if assigned(p1) then
           newres^.p1:=p1^.get_copy;
         if assigned(p2) then
           newres^.p2:=p2^.get_copy;
         if assigned(p3) then
           newres^.p3:=p3^.get_copy;
         if assigned(next) then
           newres^.next:=next^.get_copy;
         get_copy:=newres;
      end;

    destructor tresobject.done;
      begin
         (* writeln('disposing ',byte(typ)); *)
         if assigned(p)then strdispose(p);
         if assigned(p1) then
           dispose(p1,done);
         if assigned(p2) then
           dispose(p2,done);
         if assigned(p3) then
           dispose(p3,done);
         if assigned(next) then
           dispose(next,done);
      end;
%}

D [0-9]
%%

"/*"                   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);
                            end;
                          until false;
                          flush(outfile);
                        end;

"//"                   begin
                          If not stripcomment then
                             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);
                            end;
                          until false;
                          flush(outfile);
                        end;
\"[^\"]*\"              return(CSTRING);
\'[^\']*\'              return(CSTRING);
"L"\"[^\"]*\"           if win32headers then
                          return(CSTRING)
                        else
                          return(256);
"L"\'[^\']*\'           if win32headers then
                          return(CSTRING)
                        else
                          return(256);
{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
                           (* handle pre- and postfixes *)
                           if copy(yytext,1,2)='0x' then
                             begin
                                delete(yytext,1,2);
                                yytext:='$'+yytext;
                             end;
                           if yytext[length(yytext)]='L' then
                             dec(byte(yytext[0]));
                           if yytext[length(yytext)]='U' then
                             dec(byte(yytext[0]));
                           return(NUMBER);
                        end;

{D}+(\.{D}+)?([Ee][+-]?{D}+)?
                       begin
                       return(NUMBER);
                       end;

"->"                    if in_define then
                          return(DEREF)
                        else
                          return(256);
"-"                     return(MINUS);
"=="                    return(EQUAL);
"!="                    return(UNEQUAL);
">="                    return(GTE);
"<="                    return(LTE);
">>"                    return(_SHR);
"##"                    return(STICK);
"<<"                    return(_SHL);
">"                     return(GT);
"<"                     return(LT);
"|"                     return(_OR);
"&"                     return(_AND);
"!"                     return(_NOT);
"/"                     return(_SLASH);
"+"                     return(_PLUS);
"?"                     return(QUESTIONMARK);
":"                     return(COLON);
","                     return(COMMA);
"["                     return(LECKKLAMMER);
"]"                     return(RECKKLAMMER);
"("                     begin
                           inc(arglevel);
                           return(LKLAMMER);
                        end;
")"                     begin
                           dec(arglevel);
                           return(RKLAMMER);
                        end;
"*"                     return(STAR);
"..."                   return(ELLIPSIS);
"."                     if in_define then
                          return(POINT)
                        else
                          return(256);
"="                     return(_ASSIGN);
"extern"                return(EXTERN);
"STDCALL"               if Win32headers then
                          return(STDCALL)
                        else
                          return(ID);
"CDECL"                 if not Win32headers then
                          return(ID)
                        else
                          return(CDECL);
"PASCAL"                            if not Win32headers then
                          return(ID)
                        else
                          return(PASCAL);
"PACKED"                            if not Win32headers then
                          return(ID)
                        else
                          return(_PACKED);
"WINAPI"                if not Win32headers then
                          return(ID)
                        else
                          return(WINAPI);
"SYS_TRAP"              if not palmpilot then
                          return(ID)
                        else
                          return(SYS_TRAP);
"WINGDIAPI"             if not Win32headers then
                          return(ID)
                        else
                          return(WINGDIAPI);
"CALLBACK"                       if not Win32headers then
                          return(ID)
                        else
                          return(CALLBACK);
"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 }');
"#ifdef __cplusplus"[ \t]*\n"}"\n"#endif"
                        writeln(outfile,'{ C++ end of extern C conditionnal removed }');

"#else"                 begin
                           writeln(outfile,'{$else}');
                           block_type:=bt_no;
                           flush(outfile);
                        end;
"#endif"                begin
                           writeln(outfile,'{$endif}');
                           block_type:=bt_no;
                           flush(outfile);
                        end;
"#elif"                begin
                           write(outfile,'(*** was #elif ****)');
                           write(outfile,'{$else');
                                          c:=get_char;
                           while c<>newline do
                             begin write(outfile,c);c:=get_char;end;
                           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;
                           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;
                           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;
                           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;
                           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);
                           block_type:=bt_no;
                           next_line;
                        end;
"#define"               begin
                           in_define:=true;
                           in_space_define:=1;
                           return(DEFINE);
                        end;
"char"                  return(_CHAR);
"union"                 return(UNION);
"enum"                  return(ENUM);
"struct"                return(STRUCT);
"{"                     return(LGKLAMMER);
"}"                     return(RGKLAMMER);
"typedef"               return(TYPEDEF);
"int"                   return(INT);
"short"                 return(SHORT);
"long"                  return(LONG);
"unsigned"              return(UNSIGNED);
"float"                 return(REAL);
"const"                 return(_CONST);
"CONST"                 return(_CONST);
"FAR"                   return(_FAR);
"far"                   return(_FAR);
"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
                            begin
                               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;
                        end;
.                       begin
                           writeln('Illegal character in line ',line_no);
                           writeln(last_source_line);
                           return(256 { error });
                        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;
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;
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.