[lazarus] Request !

Peter Vreman pfv at cooldown.demon.nl
Thu May 6 17:19:27 EDT 1999


> Peter
> 
> What tool are you refering to.  I am just doing a manual look and compare.
A tool that inserts the headers for implementation/interface and Styles
some of the type that are left over after h2pas for example: T_Gtk  ->
TGtk


Peter


    function lower(const s : string) : string;

    {

      return lowercased string of s

    }

      var

         i : longint;

      begin

         for i:=1 to length(s) do

          if s[i] in ['A'..'Z'] then

           lower[i]:=char(byte(s[i])+32)

          else

           lower[i]:=s[i];

         lower[0]:=s[0];

      end;



    function upper(const s : string) : string;

    {

      return lowercased string of s

    }

      var

         i : longint;

      begin

         for i:=1 to length(s) do

          if s[i] in ['a'..'z'] then

           upper[i]:=char(byte(s[i])-32)

          else

           upper[i]:=s[i];

         upper[0]:=s[0];

      end;



   function trimspace(const s:string):string;

     var

       i,j : longint;

     begin

       i:=length(s);

       while (i>0) and (s[i] in [#9,' ']) do

        dec(i);

       j:=1;

       while (j<i) and (s[j] in [#9,' ']) do

        inc(j);

       trimspace:=Copy(s,j,i-j+1);

     end;



   function trimbegin(const s:string):string;

     var

       i,j : longint;

     begin

       i:=length(s);

       j:=1;

       while (j<i) and (s[j] in [#9,' ']) do

        inc(j);

       trimbegin:=Copy(s,j,i-j+1);

     end;



    procedure Replace(var s:string;const s1,s2:string);

      var

	 last,
         i  : longint;

      begin

        last:=0;
        repeat

          i:=pos(s1,upper(s));

	  if i=last then
	   i:=0;
          if (i>0) then

           begin

             Delete(s,i,length(s1));

             Insert(s2,s,i);

	     last:=i;
           end;

        until i=0;

      end;


    procedure fixreplace(var s:string);
      begin
        replace(s,'P_GTK','PGtk');
        replace(s,'= ^T_GTK','= ^TGtk');
        replace(s,'^T_GTK','PGtk');
        replace(s,'T_GTK','TGtk');
        replace(s,'External_library','gtkdll');
      end;
      
      

var

  t,f : text;

  ssmall : string[20];

  hs,
  s   : string;

  name : string;

  i    : word;

  func,

  impl : boolean;

begin

  impl:=false;
  assign(t,paramstr(1));

  assign(f,'fixgtk.tmp');

  reset(t);

  rewrite(f);

  writeln(f,'{');

  writeln(f,'   $Id: gtk111.pp,v $');

  writeln(f,'}');

  writeln(f,'');

  writeln(f,'{$ifndef gtk_include_files}');

  writeln(f,'  {$define read_interface}');

  writeln(f,'  {$define read_implementation}');

  writeln(f,'{$endif not gtk_include_files}');

  writeln(f,'');

  writeln(f,'{$ifndef gtk_include_files}');

  writeln(f,'');

  writeln(f,'  unit gtk111;');

  writeln(f,'  interface');

  writeln(f,'');

  writeln(f,'  uses');

  writeln(f,'    glib,gdkmain,');

  writeln(f,'    gtkobjects;');

  writeln(f,'');

writeln(f,'  {$ifdef win32}');

writeln(f,'    const');

writeln(f,'      gtkdll=''gtk-1.1.dll''; { leave the .dll else .1.1 -> .1 !! }');

writeln(f,'  {$else}');

writeln(f,'    const');

writeln(f,'      gtkdll=''gtk.so'';');

writeln(f,'    {$linklib c}');

writeln(f,'  {$endif}');

writeln(f,'');

writeln(f,'  Type');

writeln(f,'    PLongint  = ^Longint;');

writeln(f,'    PByte     = ^Byte;');

writeln(f,'    PWord     = ^Word;');

writeln(f,'    PINteger  = ^Integer;');

writeln(f,'    PCardinal = ^Cardinal;');

writeln(f,'    PReal     = ^Real;');

writeln(f,'    PDouble   = ^Double;');

writeln(f,'');

writeln(f,'{$endif not gtk_include_files}');

writeln(f,'');

writeln(f,'{$ifdef read_interface}');

writeln(f,'');

  while not eof(t) do

   begin

     read(t,ssmall);

     fixreplace(ssmall);
     
     if (not impl) and (copy(trimspace(ssmall),1,14)='implementation') then

      begin

        impl:=true;

        readln(t,s);

        writeln(f,'{$endif read_interface}');

        writeln(f,'');

        writeln(f,'');

        writeln(f,'{$ifndef gtk_include_files}');

        writeln(f,'  implementation');

        writeln(f,'{$endif not gtk_include_files}');

        writeln(f,'');

        writeln(f,'{$ifdef read_implementation}');

        writeln(f,'');

        continue;

      end;

     if (impl) and (copy(trimspace(ssmall),1,4)='end.') then

      begin

        writeln(f,'{$endif read_implementation}');

        writeln(f,'');

        writeln(f,'');

        writeln(f,'{$ifndef gtk_include_files}');

        writeln(f,'end.');

        writeln(f,'{$endif not gtk_include_files}');

        writeln(f,'');

        writeln(f,'{');

        writeln(f,'  $Log: gtk111.pp,v $');

        writeln(f,'}');

        continue;

      end;

      
     readln(t,s);

     fixreplace(s);
     
     func:=false;

     if lower(copy(trimspace(ssmall),1,8))='function' then

      begin

        func:=true;

        name:=trimspace(ssmall+s);

        delete(name,1,9);

        name:=trimspace(name);

        i:=1;

        while (name[i] in ['_','A'..'Z','a'..'z','0'..'9']) do

         inc(i);

        delete(name,i,255);

	hs:=trimbegin(ssmall);
	replace(hs,'FUNCTION','function ');
        write(f,hs);

      end

     else

      if lower(copy(trimspace(ssmall),1,9))='procedure' then

       begin

         func:=true;

         name:=trimspace(ssmall+s);

         delete(name,1,10);

         name:=trimspace(name);

         i:=1;

         while (name[i] in ['_','A'..'Z','a'..'z','0'..'9']) do

          inc(i);

         delete(name,i,255);

         write(f,trimbegin(ssmall));

       end

     else

       write(f,ssmall);



     if func and (copy(name,1,3)='gtk') then

      begin

        if pos('cdecl;',s)=0 then
	 begin
 	   write(f,s);
	   readln(t,s);
	 end;
	replace(s,'CDECL;','{$ifndef win32}cdecl;{$endif}');
        writeln(f,s);

      end

     else

      writeln(f,s);

   end;

  close(f);

  close(t);

{  erase(t);

  rename(f,paramstr(1)); }

end.






More information about the Lazarus mailing list