+ support for creating packed records

  * var parameter bugfixes

utils/h2pas/h2pas.y

@@ -22,11 +22,7 @@ program h2pas;
  ****************************************************************************)
 
    uses
-{$ifdef Delphi}
-     SysUtils,
-{$else Delphi}
-     strings,
-{$endif Delphi}
+     SysUtils,classes,
      options,scan,converu,lexlib,yacclib;
 
    type
@@ -46,13 +42,14 @@ program h2pas;
 
   var
      hp,ph    : presobject;
-     extfile  : text;  (* file for implementation headers extern procs *)
+     implemfile  : text;  (* file for implementation headers extern procs *)
      IsExtern : boolean;
      NeedEllipsisOverload : boolean;
      must_write_packed_field : boolean;
      tempfile : text;
      No_pop   : boolean;
      s,TN,PN  : String;
+     pointerprefix: boolean;
 
 (* $ define yydebug
  compile with -dYYDEBUG to get debugging info *)
@@ -65,6 +62,10 @@ program h2pas;
 
   var space_array : array [0..255] of byte;
       space_index : byte;
+      
+      { Used when PPointers is used - pointer type definitions }
+      PTypeList : TStringList;
+      
 
         procedure shift(space_number : byte);
           var
@@ -202,9 +203,14 @@ program h2pas;
         if RemoveUnderScore and (length(s)>1) and (s[1]='_') then
          i:=2;
         if UsePPointers then
-         PointerName:='P'+Copy(s,i,255)
+        begin
+         PointerName:='P'+Copy(s,i,255);
+         PTypeList.Add(PointerName);
+        end 
         else
          PointerName:=Copy(s,i,255);
+        if PointerPrefix then
+           PTypeList.Add('P'+s);
       end;
 
 
@@ -261,21 +267,21 @@ program h2pas;
                         writeln(outfile,';');
                         popshift;
                         { get function in implementation }
-                        write(extfile,aktspace,'function ',name);
-                        write(extfile,'(var a : ',ph,') : ');
+                        write(implemfile,aktspace,'function ',name);
+                        write(implemfile,'(var a : ',ph,') : ');
                         if not compactmode then
                          shift(2);
-                        write_p_a_def(extfile,hp3^.p1^.p1,hp2^.p1);
-                        writeln(extfile,';');
-                        writeln(extfile,aktspace,'begin');
+                        write_p_a_def(implemfile,hp3^.p1^.p1,hp2^.p1);
+                        writeln(implemfile,';');
+                        writeln(implemfile,aktspace,'begin');
                         shift(3);
-                        write(extfile,aktspace,name,':=(a.flag',flag_index);
-                        writeln(extfile,' and bm_',ph,'_',name,') shr bp_',ph,'_',name,';');
+                        write(implemfile,aktspace,name,':=(a.flag',flag_index);
+                        writeln(implemfile,' and bm_',ph,'_',name,') shr bp_',ph,'_',name,';');
                         popshift;
-                        writeln(extfile,aktspace,'end;');
+                        writeln(implemfile,aktspace,'end;');
                         if not compactmode then
                          popshift;
-                        writeln(extfile,'');
+                        writeln(implemfile,'');
                         { set function in interface }
                         write(outfile,aktspace,'procedure set_',name);
                         write(outfile,'(var a : ',ph,'; __',name,' : ');
@@ -284,22 +290,22 @@ program h2pas;
                         writeln(outfile,');');
                         popshift;
                         { set function in implementation }
-                        write(extfile,aktspace,'procedure set_',name);
-                        write(extfile,'(var a : ',ph,'; __',name,' : ');
+                        write(implemfile,aktspace,'procedure set_',name);
+                        write(implemfile,'(var a : ',ph,'; __',name,' : ');
                         if not compactmode then
                          shift(2);
-                        write_p_a_def(extfile,hp3^.p1^.p1,hp2^.p1);
-                        writeln(extfile,');');
-                        writeln(extfile,aktspace,'begin');
+                        write_p_a_def(implemfile,hp3^.p1^.p1,hp2^.p1);
+                        writeln(implemfile,');');
+                        writeln(implemfile,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,');');
+                        write(implemfile,aktspace,'a.flag',flag_index,':=');
+                        write(implemfile,'a.flag',flag_index,' or ');
+                        writeln(implemfile,'((__',name,' shl bp_',ph,'_',name,') and bm_',ph,'_',name,');');
                         popshift;
-                        writeln(extfile,aktspace,'end;');
+                        writeln(implemfile,aktspace,'end;');
                         if not compactmode then
                          popshift;
-                        writeln(extfile,'');
+                        writeln(implemfile,'');
                      end
                    else if is_sized then
                      begin
@@ -527,7 +533,7 @@ program h2pas;
        (* if in args *dname is replaced by pdname *)
        in_args : boolean = false;
        typedef_level : longint = 0;
-
+       
     (* writes an argument list, where p is t_arglist *)
 
     procedure write_args(var outfile:text; p : presobject);
@@ -575,20 +581,26 @@ program h2pas;
               else
                 begin
                    (* generate a call by reference parameter ?       *)
+
+//                   varpara:=usevarparas and
+//                            assigned(p^.p1^.p2^.p1) and
+//                            (p^.p1^.p2^.p1^.typ in [t_addrdef,t_pointerdef]) and
+//                            assigned(p^.p1^.p2^.p1^.p1) and
+//                            (p^.p1^.p2^.p1^.p1^.typ<>t_procdef);
                    varpara:=usevarparas and
-                            assigned(p^.p1^.p2^.p1) and
-                            (p^.p1^.p2^.p1^.typ in [t_addrdef,t_pointerdef]) and
-                            assigned(p^.p1^.p2^.p1^.p1) and
-                            (p^.p1^.p2^.p1^.p1^.typ<>t_procdef);
+                            assigned(p^.p1^.p1) and
+                            (p^.p1^.p1^.typ in [t_addrdef,t_pointerdef]) and
+                            assigned(p^.p1^.p1^.p1) and
+                            (p^.p1^.p1^.p1^.typ<>t_procdef);
                    (* 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
+                      (p^.p1^.p1^.typ=t_pointerdef) and
+                      (p^.p1^.p1^.p1^.typ=t_id) and
+                      (pos('CHAR',uppercase(p^.p1^.p1^.p1^.str))<>0) then
                      varpara:=false;
                    if varpara then
                      begin
@@ -617,8 +629,10 @@ program h2pas;
                          end;
                      end;
                    write(outfile,':');
-                   if varpara then
-                     write_p_a_def(outfile,p^.p1^.p2^.p1^.p1,p^.p1^.p1)
+                   if varpara then 
+                   begin
+                     write_p_a_def(outfile,p^.p1^.p2^.p1,p^.p1^.p1^.p1);
+                   end
                    else
                      write_p_a_def(outfile,p^.p1^.p2^.p1,p^.p1^.p1);
 
@@ -642,6 +656,8 @@ program h2pas;
          in_args:=old_in_args;
          popshift;
       end;
+       
+
 
     procedure write_p_a_def(var outfile:text; p,simple_type : presobject);
       var
@@ -716,10 +732,14 @@ program h2pas;
                                       if not pointerwritten then
                                        begin
                                          if in_args then
-                                          write(outfile,'P')
+                                         begin
+                                          write(outfile,'P');
+                                          pointerprefix:=true;
+                                         end 
                                          else
                                           write(outfile,'^');
                                          write_p_a_def(outfile,p^.p1,simple_type);
+                                         pointerprefix:=false;
                                        end;
                                      end;
                                 end;
@@ -776,6 +796,8 @@ program h2pas;
          case p^.typ of
             t_id :
               begin
+                if pointerprefix then
+                   PTypeList.Add('P'+p^.str);
                 if p^.intname then
                  write(outfile,p^.p)
                 else
@@ -811,10 +833,14 @@ program h2pas;
                  if not pointerwritten then
                   begin
                     if in_args then
-                     write(outfile,'P')
+                    begin
+                     write(outfile,'P');
+                     pointerprefix:=true;
+                    end 
                     else
                      write(outfile,'^');
                     write_type_specifier(outfile,p^.p1);
+                    pointerprefix:=false;
                   end;
               end;
             t_enumdef :
@@ -822,6 +848,8 @@ program h2pas;
                  if (typedef_level>1) and (p^.p1=nil) and
                     (p^.p2^.typ=t_id) then
                    begin
+                      if pointerprefix then
+                        PTypeList.Add('P'+p^.p2^.str);
                       write(outfile,p^.p2^.p);
                    end
                  else
@@ -910,11 +938,16 @@ program h2pas;
                  if ((in_args) or (typedef_level>1)) and
                     (p^.p1=nil) and (p^.p2^.typ=t_id) then
                    begin
+                      if pointerprefix then
+                        PTypeList.Add('P'+p^.p2^.str);
                      write(outfile,TypeName(p^.p2^.p));
                    end
                  else
                    begin
-                      writeln(outfile,'record');
+                      if packrecords then
+                        writeln(outfile,'packed record')
+                      else
+                        writeln(outfile,'record');
                       shift(3);
                       hp1:=p^.p1;
 
@@ -1042,7 +1075,10 @@ program h2pas;
                  else
                    begin
                       inc(typedef_level);
-                      writeln(outfile,'record');
+                      if packrecords then
+                        writeln(outfile,'packed record')
+                      else
+                        writeln(outfile,'record');
                       shift(2);
                       writeln(outfile,aktspace,'case longint of');
                       shift(3);
@@ -1217,7 +1253,7 @@ declaration :
              begin
                write(outfile,aktspace);
                if not IsExtern then
-                write(extfile,aktspace);
+                write(implemfile,aktspace);
              end;
             (* distinguish between procedure and function *)
             if assigned($2) then
@@ -1229,9 +1265,9 @@ declaration :
                   write_args(outfile,$4^.p1^.p1^.p2);
                 if not IsExtern then
                  begin
-                   write(extfile,'procedure ',$4^.p1^.p2^.p);
+                   write(implemfile,'procedure ',$4^.p1^.p2^.p);
                    if assigned($4^.p1^.p1^.p2) then
-                    write_args(extfile,$4^.p1^.p1^.p2);
+                    write_args(implemfile,$4^.p1^.p1^.p2);
                  end;
               end
             else
@@ -1244,11 +1280,11 @@ declaration :
                  write_p_a_def(outfile,$4^.p1^.p1^.p1,$2);
                  if not IsExtern then
                   begin
-                    write(extfile,'function ',$4^.p1^.p2^.p);
+                    write(implemfile,'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);
+                     write_args(implemfile,$4^.p1^.p1^.p2);
+                    write(implemfile,':');
+                    write_p_a_def(implemfile,$4^.p1^.p1^.p1,$2);
                   end;
               end;
             if assigned($5) then
@@ -1272,10 +1308,10 @@ declaration :
                 writeln(outfile,';');
                 if not IsExtern then
                  begin
-                   writeln(extfile,';');
-                   writeln(extfile,aktspace,'begin');
-                   writeln(extfile,aktspace,'  { You must implemented this function }');
-                   writeln(extfile,aktspace,'end;');
+                   writeln(implemfile,';');
+                   writeln(implemfile,aktspace,'begin');
+                   writeln(implemfile,aktspace,'  { You must implement this function }');
+                   writeln(implemfile,aktspace,'end;');
                  end;
               end;
             IsExtern:=false;
@@ -1367,7 +1403,10 @@ declaration :
          TN:=TypeName(yyv[yysp-1]^.str);
          PN:=PointerName(yyv[yysp-1]^.str);
          if UsePPointers then writeln(outfile,aktspace,PN,' = ^',TN,';');
-         writeln(outfile, aktspace, TN, ' = record');
+         if PackRecords then
+            writeln(outfile, aktspace, TN, ' = packed record')
+         else
+            writeln(outfile, aktspace, TN, ' = record');
          writeln(outfile, aktspace, '    {undefined structure}');
          writeln(outfile, aktspace, '  end;');
          writeln(outfile);
@@ -1557,39 +1596,39 @@ define_dec :
        if not stripinfo then
         begin
           writeln (outfile,aktspace,'{ was #define dname(params) para_def_expr }');
-          writeln (extfile,aktspace,'{ was #define dname(params) para_def_expr }');
+          writeln (implemfile,aktspace,'{ was #define dname(params) para_def_expr }');
           if assigned($4) then
            begin
              writeln (outfile,aktspace,'{ argument types are unknown }');
-             writeln (extfile,aktspace,'{ argument types are unknown }');
+             writeln (implemfile,aktspace,'{ argument types are unknown }');
            end;
           if not assigned($6^.p3) then
            begin
              writeln(outfile,aktspace,'{ return type might be wrong }   ');
-             writeln(extfile,aktspace,'{ return type might be wrong }   ');
+             writeln(implemfile,aktspace,'{ return type might be wrong }   ');
            end;
         end;
        block_type:=bt_func;
        write(outfile,aktspace,'function ',$2^.p);
-       write(extfile,aktspace,'function ',$2^.p);
+       write(implemfile,aktspace,'function ',$2^.p);
 
        if assigned($4) then
          begin
             write(outfile,'(');
-            write(extfile,'(');
+            write(implemfile,'(');
             ph:=new(presobject,init_one(t_enumdef,$4));
             write_def_params(outfile,ph);
-            write_def_params(extfile,ph);
+            write_def_params(implemfile,ph);
             if assigned(ph) then dispose(ph,done);
             ph:=nil;
             (* types are unknown *)
             write(outfile,' : longint)');
-            write(extfile,' : longint)');
+            write(implemfile,' : longint)');
          end;
        if not assigned($6^.p3) then
          begin
             writeln(outfile,' : longint;',aktspace,commentstr);
-            writeln(extfile,' : longint;');
+            writeln(implemfile,' : longint;');
             flush(outfile);
          end
        else
@@ -1598,16 +1637,16 @@ define_dec :
             write_type_specifier(outfile,$6^.p3);
             writeln(outfile,';',aktspace,commentstr);
             flush(outfile);
-            write(extfile,' : ');
-            write_type_specifier(extfile,$6^.p3);
-            writeln(extfile,';');
+            write(implemfile,' : ');
+            write_type_specifier(implemfile,$6^.p3);
+            writeln(implemfile,';');
          end;
        writeln(outfile);
        flush(outfile);
        hp:=new(presobject,init_two(t_funcname,$2,$6));
-       write_funexpr(extfile,hp);
-       writeln(extfile);
-       flush(extfile);
+       write_funexpr(implemfile,hp);
+       writeln(implemfile);
+       flush(implemfile);
        if assigned(hp)then dispose(hp,done);
      }|
      DEFINE dname SPACE_DEFINE NEW_LINE
@@ -1655,19 +1694,19 @@ define_dec :
             if not stripinfo then
              begin
                writeln (outfile,aktspace,'{ was #define dname def_expr }');
-               writeln (extfile,aktspace,'{ was #define dname def_expr }');
+               writeln (implemfile,aktspace,'{ was #define dname def_expr }');
              end;
             block_type:=bt_func;
             write(outfile,aktspace,'function ',$2^.p);
-            write(extfile,aktspace,'function ',$2^.p);
+            write(implemfile,aktspace,'function ',$2^.p);
             shift(2);
             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 }');
+                 writeln(implemfile,' : longint;');
+                 writeln(implemfile,aktspace,'  { return type might be wrong }');
               end
             else
               begin
@@ -1675,18 +1714,18 @@ define_dec :
                  write_type_specifier(outfile,$4^.p3);
                  writeln(outfile,';',aktspace,commentstr);
                  flush(outfile);
-                 write(extfile,' : ');
-                 write_type_specifier(extfile,$4^.p3);
-                 writeln(extfile,';');
+                 write(implemfile,' : ');
+                 write_type_specifier(implemfile,$4^.p3);
+                 writeln(implemfile,';');
               end;
             writeln(outfile);
             flush(outfile);
             hp:=new(presobject,init_two(t_funcname,$2,$4));
-            write_funexpr(extfile,hp);
+            write_funexpr(implemfile,hp);
             popshift;
             dispose(hp,done);
-            writeln(extfile);
-            flush(extfile);
+            writeln(implemfile);
+            flush(implemfile);
          end;
      }
      | error error_info NEW_LINE
@@ -1723,21 +1762,21 @@ closed_enum_list : LGKLAMMER enum_list RGKLAMMER
 special_type_specifier :
      STRUCT dname closed_list _PACKED
      {
-       if not is_packed then
+       if (not is_packed) and (not packrecords) then
          writeln(outfile,'{$PACKRECORDS 1}');
        is_packed:=true;
        $$:=new(presobject,init_two(t_structdef,$3,$2));
      } |
      STRUCT dname closed_list
      {
-       if is_packed then
+       if (is_packed) and (not packrecords) 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
+       if (not is_packed) and (not packrecords) then
          writeln(outfile,'{$PACKRECORDS 1}');
        is_packed:=true;
        $$:=new(presobject,init_two(t_uniondef,$3,$2));
@@ -1772,7 +1811,7 @@ type_specifier :
         } |
      UNION closed_list  _PACKED
      {
-       if not is_packed then
+       if (not is_packed) and (not packrecords)then
          writeln(outfile,'{$PACKRECORDS 1}');
        is_packed:=true;
        $$:=new(presobject,init_one(t_uniondef,$2));
@@ -1783,14 +1822,14 @@ type_specifier :
      } |
      STRUCT closed_list _PACKED
      {
-       if not is_packed then
+       if (not is_packed) and (not packrecords) then
          writeln(outfile,'{$PACKRECORDS 1}');
        is_packed:=true;
        $$:=new(presobject,init_one(t_structdef,$2));
      } |
      STRUCT closed_list
      {
-       if is_packed then
+       if (is_packed) and (not packrecords) then
          writeln(outfile,'{$PACKRECORDS 4}');
        is_packed:=false;
        $$:=new(presobject,init_one(t_structdef,$2));
@@ -1966,6 +2005,7 @@ argument_declaration : type_specifier declarator
      } |
      type_specifier STAR declarator
      {
+       (* type_specifier STAR declarator *)
        hp:=new(presobject,init_one(t_pointerdef,$1));
        $$:=new(presobject,init_two(t_arg,hp,$3));
      } |
@@ -2384,12 +2424,71 @@ begin
   line_no:=yylineno;
 end;
 
+procedure WriteFileHeader(var headerfile: Text);
+var
+ i: integer;
+ originalstr: string;
+begin
+{ write unit header }
+  if not includefile then
+   begin
+     writeln(headerfile,'unit ',unitname,';');
+     writeln(headerfile,'interface');
+     writeln(headerfile);
+     writeln(headerfile,'{');
+     writeln(headerfile,'  Automatically converted by H2Pas ',version,' from ',inputfilename);
+     writeln(headerfile,'  The following command line parameters were used:');
+     for i:=1 to paramcount do
+       writeln(headerfile,'    ',paramstr(i));
+     writeln(headerfile,'}');
+     writeln(headerfile);
+   end;
+  if UseName then
+   begin
+     writeln(headerfile,aktspace,'const');
+     writeln(headerfile,aktspace,'  External_library=''',libfilename,'''; {Setup as you need}');
+     writeln(headerfile);
+   end;
+  if UsePPointers then
+   begin
+     Writeln(headerfile,aktspace,'{ Pointers to basic pascal types, inserted by h2pas conversion program.}');
+     Writeln(headerfile,aktspace,'Type');
+     Writeln(headerfile,aktspace,'  PLongint  = ^Longint;');
+     Writeln(headerfile,aktspace,'  PSmallInt = ^SmallInt;');
+     Writeln(headerfile,aktspace,'  PByte     = ^Byte;');
+     Writeln(headerfile,aktspace,'  PWord     = ^Word;');
+     Writeln(headerfile,aktspace,'  PDWord    = ^DWord;');
+     Writeln(headerfile,aktspace,'  PDouble   = ^Double;');
+     Writeln(headerfile);
+   end;
+  if PTypeList.count <> 0 then 
+   Writeln(headerfile,aktspace,'Type');
+  for i:=0 to (PTypeList.Count-1) do
+   begin
+     originalstr:=copy(PTypelist[i],2,length(PTypeList[i]));
+     Writeln(headerfile,aktspace,PTypeList[i],'  = ^',originalstr,';');
+   end;
+  if not packrecords then
+   begin
+      writeln(headerfile,'{$IFDEF FPC}');
+      writeln(headerfile,'{$PACKRECORDS C}');
+      writeln(headerfile,'{$ENDIF}');
+   end;   
+  writeln(headerfile);
+end;
+
 
 var
   SS : string;
   i : longint;
+  headerfile: Text;
+  finaloutfile: Text;
 begin
+  pointerprefix:=false;
 { Initialize }
+  PTypeList:=TStringList.Create;
+  PTypeList.Sorted := true;
+  PTypeList.Duplicates := dupIgnore;
   yydebug:=true;
   aktspace:='';
   block_type:=bt_no;
@@ -2408,54 +2507,21 @@ begin
      writeln('file ',inputfilename,' not found!');
      halt(1);
    end;
-  assign(outfile, outputfilename);
+  { This is the intermediate output file } 
+  assign(outfile, 'ext3.tmp');
   {$I-}
   rewrite(outfile);
   {$I+}
   if ioresult<>0 then
    begin
-     writeln('file ',outputfilename,' could not be created!');
+     writeln('file ext3.tmp could not be created!');
      halt(1);
    end;
-{ write unit header }
-  if not includefile then
-   begin
-     writeln(outfile,'unit ',unitname,';');
-     writeln(outfile,'interface');
-     writeln(outfile);
-     writeln(outfile,'{');
-     writeln(outfile,'  Automatically converted by H2Pas ',version,' from ',inputfilename);
-     writeln(outfile,'  The following command line parameters were used:');
-     for i:=1 to paramcount do
-       writeln(outfile,'    ',paramstr(i));
-     writeln(outfile,'}');
-     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,'{$IFDEF FPC}');
-  writeln(outfile,'{$PACKRECORDS C}');
-  writeln(outfile,'{$ENDIF}');
   writeln(outfile);
 { Open tempfiles }
-  Assign(extfile,'ext.tmp');
-  rewrite(extfile);
+  { This is where the implementation section of the unit shall be stored }
+  Assign(implemfile,'ext.tmp');
+  rewrite(implemfile);
   Assign(tempfile,'ext2.tmp');
   rewrite(tempfile);
 { Parse! }
@@ -2468,10 +2534,10 @@ begin
       writeln(outfile);
     end;
    { here we have a problem if a line is longer than 255 chars !! }
-   reset(extfile);
-   while not eof(extfile) do
+   reset(implemfile);
+   while not eof(implemfile) do
     begin
-      readln(extfile,SS);
+      readln(implemfile,SS);
       writeln(outfile,SS);
     end;
    { write end of file }
@@ -2479,16 +2545,67 @@ begin
    if not(includefile) then
      writeln(outfile,'end.');
    { close and erase tempfiles }
-   close(extfile);
-   erase(extfile);
-   close(outfile);
-   close(tempfile);
-   erase(tempfile);
+  close(implemfile);
+  erase(implemfile);
+  close(tempfile);
+  erase(tempfile);
+  flush(outfile);
+   
+  {**** generate full file ****}
+  assign(headerfile, 'ext4.tmp');
+  {$I-}
+  rewrite(headerfile);
+  {$I+}
+  if ioresult<>0 then
+    begin
+      writeln('file ext4.tmp could not be created!');
+      halt(1);
+  end;
+  WriteFileHeader(HeaderFile);
+   
+  { Final output filename } 
+  assign(finaloutfile, outputfilename);
+  {$I-}
+  rewrite(finaloutfile);
+  {$I+}
+  if ioresult<>0 then
+  begin
+     writeln('file ',outputfilename,' could not be created!');
+     halt(1);
+  end;
+  writeln(finaloutfile);
+  
+  { Read unit header file }
+  reset(headerfile);
+  while not eof(headerfile) do
+    begin
+      readln(headerfile,SS);
+      writeln(finaloutfile,SS);
+    end;
+  { Read interface and implementation file }
+  reset(outfile);
+  while not eof(outfile) do
+    begin
+      readln(outfile,SS);
+      writeln(finaloutfile,SS);
+    end;
+   
+  close(HeaderFile);
+  close(outfile);
+  close(finaloutfile);
+  erase(outfile);
+  erase(headerfile);
+   
+  PTypeList.Free;
 end.
 
 {
   $Log$
-  Revision 1.8  2004-08-13 02:35:29  carl
+  Revision 1.9  2004-09-08 22:21:41  carl
+    + support for creating packed records
+    * var parameter bugfixes
+
+  Revision 1.8  2004/08/13 02:35:29  carl
     + bugfixes with C++ comments, they are now placed above the definition
     * some bugfixes with the _label reserved word.
 

utils/h2pas/options.pas

@@ -40,6 +40,7 @@ var
                               { is passed                               }
    includefile : boolean;     { creates an include file instead of a unit }
    palmpilot : boolean;       { handling of PalmOS SYS_CALLs }
+   packrecords: boolean;      { All records should be packed in the file }
 
 { Helpers }
 Function ForceExtension(Const HStr,ext:String):String;
@@ -107,6 +108,7 @@ begin
   writeln ('        -l libname         Specify the library name for external');
   writeln ('        -o outputfilename  Specify the outputfilename');
   writeln ('        -p                 Use "P" instead of "^" for pointers');
+  writeln ('        -pr                Pack all records (1 byte alignment)');
   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');
@@ -156,6 +158,7 @@ begin
   usevarparas:=false;
   palmpilot:=false;
   includefile:=false;
+  packrecords:=false;
   i:=1;
   while i<=paramcount do
    begin
@@ -173,7 +176,14 @@ begin
          'i' : includefile:=true;
          'l' : LibFileName:=GetNextParam ('l','libname');
          'o' : outputfilename:=GetNextParam('o','outputfilename');
-         'p' : UsePPointers:=true;
+         'p' : begin
+                  if (cp[3] = 'r') then
+                     begin
+                        PackRecords := true;
+                     end
+                  else
+                      UsePPointers:=true;
+               end;   
          's' : stripcomment:=true;
          'S' : begin
                  stripcomment:=true;
@@ -226,7 +236,11 @@ end;
 end.
 {
    $Log$
-   Revision 1.3  2004-08-13 02:35:30  carl
+   Revision 1.4  2004-09-08 22:21:41  carl
+     + support for creating packed records
+     * var parameter bugfixes
+
+   Revision 1.3  2004/08/13 02:35:30  carl
      + bugfixes with C++ comments, they are now placed above the definition
      * some bugfixes with the _label reserved word.
 

utils/h2pas/scan.l

@@ -112,6 +112,40 @@ unit scan;
           { p1 expr for value }
           );
 
+const
+   ttypstr: array[ttyp] of string =
+   (
+          't_id',
+          't_arraydef',
+          't_pointerdef',
+          't_addrdef',
+          't_void',
+          't_dec',
+          't_declist',
+          't_memberdec',
+          't_structdef',
+          't_memberdeclist',
+          't_procdef',
+          't_uniondef',
+          't_enumdef',
+          't_enumlist',
+          't_preop',
+          't_bop',
+          't_arrayop',
+          't_callop',
+          't_arg',
+          't_arglist',
+          't_funexprlist',
+          't_exprlist',
+          't_ifexpr',
+          't_funcname',
+          't_typespec',
+          't_size_specifier',
+          't_default_value' 
+   );
+    
+type
+
        presobject = ^tresobject;
        tresobject = object
           typ : ttyp;
@@ -161,6 +195,9 @@ unit scan;
     procedure internalerror(i : integer);
 
     function strpnew(const s : string) : pchar;
+    
+    procedure writetree(p: presobject);
+    
 
   implementation
 
@@ -169,6 +206,53 @@ unit scan;
 
     const
        newline = #10;
+       
+       
+    procedure writeentry(p: presobject; var currentlevel: integer);
+    begin
+                     if assigned(p^.p1) then
+                        begin
+                          WriteLn(' Entry p1[',ttypstr[p^.p1^.typ],']',p^.p1^.str);
+                        end;
+                     if assigned(p^.p2) then
+                        begin
+                          WriteLn(' Entry p2[',ttypstr[p^.p2^.typ],']',p^.p2^.str);
+                        end;
+                     if assigned(p^.p3) then
+                        begin
+                          WriteLn(' Entry p3[',ttypstr[p^.p3^.typ],']',p^.p3^.str);
+                        end;
+    end;
+       
+    procedure writetree(p: presobject);
+    var
+     i : integer;
+     localp: presobject;
+     localp1: presobject;
+     currentlevel : integer;
+    begin
+      localp:=p;
+      currentlevel:=0;
+      while assigned(localp) do
+         begin
+          WriteLn('Entry[',ttypstr[localp^.typ],']',localp^.str);
+          case localp^.typ of
+          { Some arguments sharing the same type }
+          t_arglist:
+            begin
+               localp1:=localp;
+               while assigned(localp1) do
+                  begin
+                     writeentry(localp1,currentlevel);
+                     localp1:=localp1^.p1;
+                  end;
+            end;
+          end;
+           
+          localp:=localp^.next;
+         end;
+    end;
+       
 
 
     procedure internalerror(i : integer);

utils/h2pas/scan.pas

@@ -115,6 +115,40 @@ unit scan;
           { p1 expr for value }
           );
 
+const
+   ttypstr: array[ttyp] of string =
+   (
+          't_id',
+          't_arraydef',
+          't_pointerdef',
+          't_addrdef',
+          't_void',
+          't_dec',
+          't_declist',
+          't_memberdec',
+          't_structdef',
+          't_memberdeclist',
+          't_procdef',
+          't_uniondef',
+          't_enumdef',
+          't_enumlist',
+          't_preop',
+          't_bop',
+          't_arrayop',
+          't_callop',
+          't_arg',
+          't_arglist',
+          't_funexprlist',
+          't_exprlist',
+          't_ifexpr',
+          't_funcname',
+          't_typespec',
+          't_size_specifier',
+          't_default_value' 
+   );
+    
+type
+
        presobject = ^tresobject;
        tresobject = object
           typ : ttyp;
@@ -164,6 +198,9 @@ unit scan;
     procedure internalerror(i : integer);
 
     function strpnew(const s : string) : pchar;
+    
+    procedure writetree(p: presobject);
+    
 
   implementation
 
@@ -172,6 +209,53 @@ unit scan;
 
     const
        newline = #10;
+       
+       
+    procedure writeentry(p: presobject; var currentlevel: integer);
+    begin
+                     if assigned(p^.p1) then
+                        begin
+                          WriteLn(' Entry p1[',ttypstr[p^.p1^.typ],']',p^.p1^.str);
+                        end;
+                     if assigned(p^.p2) then
+                        begin
+                          WriteLn(' Entry p2[',ttypstr[p^.p2^.typ],']',p^.p2^.str);
+                        end;
+                     if assigned(p^.p3) then
+                        begin
+                          WriteLn(' Entry p3[',ttypstr[p^.p3^.typ],']',p^.p3^.str);
+                        end;
+    end;
+       
+    procedure writetree(p: presobject);
+    var
+     i : integer;
+     localp: presobject;
+     localp1: presobject;
+     currentlevel : integer;
+    begin
+      localp:=p;
+      currentlevel:=0;
+      while assigned(localp) do
+         begin
+          WriteLn('Entry[',ttypstr[localp^.typ],']',localp^.str);
+          case localp^.typ of
+          { Some arguments sharing the same type }
+          t_arglist:
+            begin
+               localp1:=localp;
+               while assigned(localp1) do
+                  begin
+                     writeentry(localp1,currentlevel);
+                     localp1:=localp1^.p1;
+                  end;
+            end;
+          end;
+           
+          localp:=localp^.next;
+         end;
+    end;
+       
 
 
     procedure internalerror(i : integer);