* Prevent writing pointer types twice

utils/h2pas/h2pbase.pp

@@ -33,7 +33,6 @@ type
 
 
 var
-  IsExtern : boolean;
   s,TN,PN  : String;
 
 
@@ -84,7 +83,7 @@ function HandleDefine(dname : presobject) : presobject;
 Function CheckWideString(S : String) : presobject;
 function CheckUnderScore(pdecl : presobject) : presobject;
 
-Function NewCType(aID,aIntID : String) : PresObject;
+Function NewCType(aCType,aPascalType : String) : PresObject;
 
 Implementation
 
@@ -98,13 +97,13 @@ begin
 end;
 
 
-Function NewCType(aID,aIntID : String) : PresObject;
+Function NewCType(aCType,aPascalType : String) : PresObject;
 
 begin
   if UseCTypesUnit then
-    Result:=NewID(aID)
+    Result:=NewID(aCType)
   else
-    result:=NewIntID(aIntID);
+    result:=NewIntID(aPascalType);
 end;
 
 function HandleUnaryDefExpr(aExpr : presobject) : presobject;
@@ -164,53 +163,41 @@ function handleSpecialUnSignedType(aType : presobject) : presobject;
 
 var
   hp : presobject;
+  tc,tp : string;
 
 begin
   hp:=aType;
   Result:=hp;
   if Not assigned(hp) then
     exit;
-  s:=strpas(hp^.p);
+  tp:='';
+  tc:=strpas(hp^.p);
   if UseCTypesUnit then
-    begin
-    if s=cint_STR then
-      s:=cuint_STR
-    else if s=cshort_STR then
-      s:=cushort_STR
-    else if s=cchar_STR then
-      s:=cuchar_STR
-    else if s=clong_STR then
-      s:=culong_STR
-    else if s=clonglong_STR then
-      s:=culonglong_STR
-    else if s=cint8_STR then
-      s:=cuint8_STR
-    else if s=cint16_STR then
-      s:=cuint16_STR
-    else if s=cint32_STR then
-      s:=cuint32_STR
-    else if s=cint64_STR then
-      s:=cuint64_STR
+    case tc of
+      cint_STR: tp:=cuint_STR;
+      cshort_STR: tp:=cushort_STR;
+      cchar_STR : tp:=cuchar_STR;
+      clong_STR : tp:=culong_STR;
+      clonglong_STR : tp:=culonglong_STR;
+      cint8_STR : tp:=cuint8_STR;
+      cint16_STR : tp:=cuint16_STR;
+      cint32_STR : tp:=cuint32_STR;
+      cint64_STR : tp:=cuint64_STR;
     else
-      s:='';
+      tp:='';
     end
   else
-    begin
-    if s=INT_STR then
-      s:=UINT_STR
-    else if s=SHORT_STR then
-      s:=USHORT_STR
-    else if s=SMALL_STR then
-      s:=USMALL_STR
-    else if s=CHAR_STR then
-      s:=UCHAR_STR
-    else if s=INT64_STR then
-      s:=QWORD_STR
+    case tc of
+      INT_STR : tp:=UINT_STR;
+      SHORT_STR : tp:=USHORT_STR;
+      SMALL_STR : tp:=USMALL_STR;
+      CHAR_STR :  tp:=UCHAR_STR;
+      INT64_STR : tp:=QWORD_STR;
     else
-      s:='';
+      tp:='';
   end;
-  if s<>'' then
-    hp^.setstr(s);
+  if tp<>'' then
+    hp^.setstr(tp);
 end;
 
 function handleSizedArrayDecl(aType,aSizeExpr: presobject): presobject;
@@ -452,6 +439,7 @@ function HandleDeclarationStatement(decl, type_spec, modifier_spec,
   decllist_spec, block_spec: presobject): presobject;
 var
   hp : presobject;
+  IsExtern : boolean;
 
 begin
   HandleDeclarationStatement:=Nil;
@@ -650,6 +638,7 @@ function HandleDeclarationSysTrap(decl, type_spec, modifier_spec,
 
 var
   hp : presobject;
+  IsExtern : boolean;
 
 begin
   HandleDeclarationSysTrap:=Nil;
@@ -942,6 +931,8 @@ end;
 
 function HandleTypedefList(type_spec,dec_modifier,declarator_list: presobject) : presobject;
 
+(* TYPEDEF type_specifier dec_modifier declarator_list SEMICOLON *)
+
 var
   hp,ph : presobject;
 
@@ -949,7 +940,6 @@ var
 begin
   HandleTypedefList:=Nil;
   ph:=nil;
-  (* TYPEDEF type_specifier dec_modifier declarator_list SEMICOLON *)
   if block_type<>bt_type then
     begin
       if not(compactmode) then
@@ -983,7 +973,7 @@ begin
   PN:=PointerName(ph^.p);
   if UsePPointers and (Uppercase(tn)<>Uppercase(pn)) and
     assigned(type_spec) and (type_spec^.typ<>t_procdef) then
-    writeln(outfile,aktspace,PN,' = ^',TN,';');
+    WritePointerTypeDef(outfile,PN,TN);
   (* write new type name *)
   write(outfile,aktspace,TN,' = ');
   shift(2);

utils/h2pas/h2pout.pp

@@ -1,5 +1,7 @@
 unit h2pout;
 
+{$modeswitch result}
+
 interface
 
 uses
@@ -12,6 +14,9 @@ procedure CloseTempFiles;
 procedure WriteFileHeader(var headerfile: Text);
 procedure WriteLibraryInitialization;
 
+// This will write each pointer type only once.
+function WritePointerTypeDef(var aFile : text; const PN,TN : AnsiString) : Boolean;
+
 procedure write_statement_block(var outfile:text; p : presobject);
 procedure write_type_specifier(var outfile:text; p : presobject);
 procedure write_p_a_def(var outfile:text; p,simple_type : presobject);
@@ -55,7 +60,8 @@ Var
 implementation
 
 var
-  tempfile : text;
+  WrittenPointers : TStringList;
+ tempfile : text;
   space_array : array [0..255] of integer;
   space_index : integer;
   _NeedEllipsisOverload : boolean;
@@ -209,7 +215,7 @@ the correct syntax.
 function FixId(const s:string):string;
 
 const
-  maxtokens = 16;
+  maxtokens = 17;
   reservedid: array[1..maxtokens] of string[14] = (
     'CLASS',
     'DISPOSE',
@@ -226,7 +232,8 @@ const
     'TYPE',
     'TRUE',
     'UNTIL',
-    'VAR'
+    'VAR',
+    'OBJECT'
     );
 
 var
@@ -310,7 +317,7 @@ begin
   else
     PointerName:=Copy(s,i,255);
   if PointerPrefix then
-      PTypeList.Add('P'+s);
+    PTypeList.Add('P'+s);
 end;
 
 
@@ -715,11 +722,6 @@ begin
     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:=IsVarPara(p);
       if varpara then
         begin
@@ -776,6 +778,7 @@ begin
 end;
 
 
+
 Procedure write_pointerdef(var outfile:text; p,simple_type : presobject);
 
 var
@@ -928,7 +931,7 @@ begin
       begin
       PTypeList.Add('P'+p^.str);
       end;
-  if p^.intname then
+  if p^.skiptprefix then
     write(outfile,p^.p)
   else
     write(outfile,TypeName(p^.p));
@@ -1332,6 +1335,22 @@ begin
   end;
 end;
 
+function MayWritePointerTypeDef(const PN: AnsiString): Boolean;
+
+begin
+  Result:=WrittenPointers.IndexOf(PN)=-1;
+end;
+
+function WritePointerTypeDef(var aFile : text; const PN, TN: AnsiString): Boolean;
+
+begin
+  Result:=MayWritePointerTypeDef(PN);;
+  if Result then
+    begin
+    WrittenPointers.Add(PN);
+    Writeln(aFile,aktspace,PN,' = ^',TN,';');
+   end;
+end;
 
 procedure write_statement_block(var outfile:text; p : presobject);
 
@@ -1362,7 +1381,32 @@ begin
   writeln(outfile,aktspace,'end;');
 end;
 
+procedure WritePointerList(var headerfile: Text);
 
+var
+  I : Integer;
+  MustWritePointers : Boolean;
+  originalstr : String;
+
+begin
+  I:=PTypeList.count-1;
+  MustWritePointers:=False;
+  While (Not MustWritePointers) and (I>=0) do
+    begin
+    MustWritePointers:=MayWritePointerTypeDef(PTypelist[i]);
+    Dec(I);
+    end;
+  if not MustWritePointers then
+    exit;
+  Writeln(headerfile,'Type');
+  for i:=0 to (PTypeList.Count-1) do
+     begin
+       originalstr:=copy(PTypelist[i],2,length(PTypeList[i]));
+       if PrependTypes then
+         originalstr:='T'+originalstr;
+       WritePointerTypeDef(HeaderFile,PTypeList[i],OriginalStr);
+     end;
+end;
 
 procedure WriteFileHeader(var headerfile: Text);
 var
@@ -1393,31 +1437,13 @@ begin
    end;
   if UseName then
    begin
-     writeln(headerfile,aktspace,'const');
-     writeln(headerfile,aktspace,'  External_library=''',libfilename,'''; {Setup as you need}');
+     writeln(headerfile,'const');
+     writeln(headerfile,'  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]));
-     if PrependTypes then
-       originalstr:='T'+originalstr;
-     Writeln(headerfile,aktspace,'  '+PTypeList[i],'  = ^',originalstr,';');
-   end;
+    WritePointerList(headerfile);
+  writeln(headerfile);
   if not packrecords then
    begin
       writeln(headerfile,'{$IFDEF FPC}');
@@ -1501,5 +1527,21 @@ begin
   writeln(outfile,'  Free',unitname,';');
 end;
 
-
+initialization
+  WrittenPointers:=TStringList.Create;
+  WrittenPointers.Sorted:=true;
+  // We must never write these, they are defined in the system unit
+  WrittenPointers.Add('pansichar');
+  WrittenPointers.Add('pchar');
+  WrittenPointers.Add('pdouble');
+  WrittenPointers.Add('plongint');
+  WrittenPointers.Add('psmallint');
+  WrittenPointers.Add('pshortint');
+  WrittenPointers.Add('pbyte');
+  WrittenPointers.Add('pint64');
+  WrittenPointers.Add('pword');
+  WrittenPointers.Add('pqword');
+
+finalization
+  WrittenPointers.Free;
 end.