* moved

utils/Makefile

@@ -0,0 +1,159 @@
+#
+#   $Id$
+#   Copyright (c) 1999 by the Free Pascal Development Team
+#
+#   Makefile for Free Pascal Utils
+#
+#   See the file COPYING.FPC, included in this distribution,
+#   for details about the copyright.
+#
+#   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.
+#
+
+
+#####################################################################
+# Defaults
+#####################################################################
+
+# Default place of the makefile.fpc
+DEFAULTFPCDIR=..
+
+
+#####################################################################
+# Real targets
+#####################################################################
+
+EXEOBJECTS=ppudump ppumove ppdep ptop
+UNITOBJECTS=
+
+
+#####################################################################
+# Common targets
+#####################################################################
+
+.PHONY: all clean install info \
+        staticlib sharedlib libsclean \
+        staticinstall sharedinstall libinstall \
+        extra_clean \
+        h2pas_all h2pas_clean h2pas_install \
+        
+all: testfpcmake fpc_all h2pas_all
+
+clean: testfpcmake fpc_clean extra_clean h2pas_clean
+
+install: testfpcmake fpc_install h2pas_install
+
+info: testfpcmake fpc_info
+
+staticlib: testfpcmake fpc_staticlib
+
+sharedlib: testfpcmake fpc_sharedlib
+
+libsclean: testfpcmake fpc_libsclean
+
+staticinstall: testfpcmake fpc_staticinstall
+
+sharedinstall: testfpcmake fpc_sharedinstall
+
+libinstall: testfpcmake fpc_libinstall
+
+
+#####################################################################
+# Include default makefile
+#####################################################################
+
+# test if FPCMAKE is still valid
+ifdef FPCMAKE
+ifeq ($(strip $(wildcard $(FPCMAKE))),)
+FPCDIR=
+FPCMAKE=
+endif
+endif
+
+ifndef FPCDIR
+ifdef DEFAULTFPCDIR
+FPCDIR=$(DEFAULTFPCDIR)
+endif
+endif
+
+ifndef FPCMAKE
+ifdef FPCDIR
+FPCMAKE=$(FPCDIR)/makefile.fpc
+else
+FPCMAKE=makefile.fpc
+endif
+endif
+
+override FPCMAKE:=$(strip $(wildcard $(FPCMAKE)))
+ifeq ($(FPCMAKE),)
+testfpcmake:
+	@echo makefile.fpc not found!
+	@echo Check the FPCMAKE and FPCDIR environment variables.
+	@exit
+else
+include $(FPCMAKE)
+testfpcmake:
+endif
+
+
+
+#####################################################################
+# Dependencies
+#####################################################################
+
+#
+# PPU Tools
+#
+ppu$(PPUEXT): ppu.pas
+
+ppudump$(EXEEXT): ppudump.pp ppu$(PPUEXT)
+
+ppumove$(EXEEXT): ppumove.pp ppu$(PPUEXT)
+
+#
+# Pascal beautifier
+#
+ptop$(EXEEXT): ptop.pp ptopu$(PPUEXT)
+
+ptopu$(PPUEXT): ptopu.pp
+
+#
+# Clean also the .ppu's
+#
+extra_clean:
+	$(DEL) ppu$(PPUEXT) ptopu$(PPUEXT)
+
+#
+# H2Pas
+#
+h2pas_all:
+	$(MAKE) -C h2pas all
+
+h2pas_clean:
+	$(MAKE) -C h2pas clean
+
+h2pas_install:
+	$(MAKE) -C h2pas install
+
+#
+# $Log$
+# Revision 1.1  1999-05-12 16:11:39  peter
+#   * moved
+#
+# Revision 1.14  1999/05/03 18:03:13  peter
+#   * renamed mkdep -> ppdep
+#   * removed obsolete units
+#   * add .cod files
+#
+# Revision 1.13  1999/04/02 00:01:49  peter
+#   + ptop to exeobjects
+#
+# Revision 1.12  1999/04/01 22:52:00  peter
+#   * update for makefile.fpc
+#
+# Revision 1.1  1999/03/16 00:50:29  peter
+#   + init
+#
+#

utils/README

@@ -0,0 +1,25 @@
+This dirctory contains some utilities that come with the Free Pascal
+Compiler. They can be compiled by typing 'make all' in this directory,
+or 'make utils_all' in the top directory.
+
+Currently, the following things are provided:
+
+ppudump : This program prints the contents of a unit (.ppu or .ppl) file
+          to screen. It should handle units of all versions of the compiler.
+
+ppumove : Similar to tpumove from Borland, Inc. this program can be used
+          to combine several (or one) units in a shared or static library.
+          usage is straightforward. running the program without arguments
+          gives possible arguments.
+
+ppdep   : Creates a makefile which includes all interdependant units.
+
+ptop    : Pascal source beautifier
+
+h2pas/  : Contains the h2pas program, which converts C header files to pascal
+          unit files.
+
+Typing a 'make install' will put everything into place.
+
+Happy Coding !
+The Free Pascal Development Team.

utils/h2pas/Makefile

@@ -0,0 +1,159 @@
+#
+#   $Id$
+#   Copyright (c) 1999 by the Free Pascal Development Team
+#
+#   Makefile for Free Pascal Utils
+#
+#   See the file COPYING.FPC, included in this distribution,
+#   for details about the copyright.
+#
+#   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.
+#
+
+
+#####################################################################
+# Defaults
+#####################################################################
+
+# Default place of the makefile.fpc
+DEFAULTFPCDIR=../..
+
+# We need -Sg
+NEEDOPT=-Sg
+
+
+#####################################################################
+# Real targets
+#####################################################################
+
+# the files in this dir use .pas
+PASEXT=.pas
+
+EXEOBJECTS=h2pas
+UNITOBJECTS=
+
+
+#####################################################################
+# Common targets
+#####################################################################
+
+.PHONY: all clean install info \
+        staticlib sharedlib libsclean \
+        staticinstall sharedinstall libinstall \
+        
+all: testfpcmake fpc_all
+
+clean: testfpcmake fpc_cleanall
+
+install: testfpcmake fpc_install
+
+info: testfpcmake fpc_info
+
+staticlib: testfpcmake fpc_staticlib
+
+sharedlib: testfpcmake fpc_sharedlib
+
+libsclean: testfpcmake fpc_libsclean
+
+staticinstall: testfpcmake fpc_staticinstall
+
+sharedinstall: testfpcmake fpc_sharedinstall
+
+libinstall: testfpcmake fpc_libinstall
+
+
+#####################################################################
+# Include default makefile
+#####################################################################
+
+# test if FPCMAKE is still valid
+ifdef FPCMAKE
+ifeq ($(strip $(wildcard $(FPCMAKE))),)
+FPCDIR=
+FPCMAKE=
+endif
+endif
+
+ifndef FPCDIR
+ifdef DEFAULTFPCDIR
+FPCDIR=$(DEFAULTFPCDIR)
+endif
+endif
+
+ifndef FPCMAKE
+ifdef FPCDIR
+FPCMAKE=$(FPCDIR)/makefile.fpc
+else
+FPCMAKE=makefile.fpc
+endif
+endif
+
+override FPCMAKE:=$(strip $(wildcard $(FPCMAKE)))
+ifeq ($(FPCMAKE),)
+testfpcmake:
+	@echo makefile.fpc not found!
+	@echo Check the FPCMAKE and FPCDIR environment variables.
+	@exit
+else
+include $(FPCMAKE)
+testfpcmake:
+endif
+
+
+
+#####################################################################
+# Dependencies
+#####################################################################
+
+# do we have pyacc?
+ifndef PYACC
+PYACC=$(strip $(wildcard $(addsuffix /pyacc$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PYACC),)
+PYACC=
+else
+export PYACC:=$(firstword $(PYACC))
+endif
+endif
+
+# do we have plex?
+ifndef PLEX
+PLEX=$(strip $(wildcard $(addsuffix /plex$(EXEEXT),$(SEARCHPATH))))
+ifeq ($(PLEX),)
+PLEX=
+else
+export PLEX:=$(firstword $(PLEX))
+endif
+endif
+
+h2pas$(EXEEXT): h2pas$(PASEXT)
+
+#
+# Lex and Yacc (only if pyacc is found)
+#
+ifdef  PYACC
+h2pas$(PASEXT): h2pas.y
+	$(PYACC) h2pas.y
+
+yacclex: yacc lex
+
+yacc:
+	$(PYACC) h2pas.y
+
+lex :
+	$(PLEX) scan.l
+endif
+
+#
+# $Log$
+# Revision 1.1  1999-05-12 16:11:39  peter
+#   * moved
+#
+# Revision 1.12  1999/04/01 22:52:01  peter
+#   * update for makefile.fpc
+#
+# Revision 1.1  1999/03/16 00:50:29  peter
+#   + init
+#
+#

utils/h2pas/README

@@ -0,0 +1,52 @@
+This is the h2pas program, a utility to convert C header files to pascal
+units. It is part of the Free Pascal distribution.
+
+COMPILING
+
+To compile the program, a simple
+ 'make' 
+should be sufficient; you need GNU make for this. When using TP, a simple
+  tpc h2pas.pas
+should also be possible. 
+
+USAGE
+
+h2pas [-p] [-t] [-o outputfilename] [-l libname] [-u unitname] filename
+
+-t : Prepend 'T' to all type names in typedef definitions. This may help
+     when the C header use uppercase types and lowercase variables of the
+     same name.
+
+-p : Use 'P' instead of ^ as a pointer symbol;
+     This will convert 
+        ^char to pchar
+        ^longint to plongint 
+     etc. It will also define a PSOMETYPE pointer for each SOMETYPE struct type 
+     definition in the header file.
+     Thus 
+     typedef struct somestruct {
+       ...
+     }
+     Will be converted to
+     somestruct = record
+       ...
+     end;
+     PSomestruct = ^Somestruct;
+     If the -t options is used, the -p option takes care of that too.
+
+-l : In the implementation part, the external functions will be
+     written with 'external libname;' behind it.
+     If you omit this option, all functions will be declared as 
+     cdecl; external; 
+
+-o : specify the outputname. By default, the inputname is used, with
+     extension '.pp'.
+
+-u : Specify the unit name. By default, the outputname is used, without
+     extension.
+
+-v : Replaces pointer types in parameter list by call by reference
+     parameters:
+        void p(int *i)  =>   procedure p(var i : longint);
+
+Enjoy !

utils/h2pas/converu.pas

@@ -0,0 +1,72 @@
+unit converu;
+
+interface
+
+const TYPEDEF = 257;
+const DEFINE = 258;
+const COLON = 259;
+const SEMICOLON = 260;
+const COMMA = 261;
+const LKLAMMER = 262;
+const RKLAMMER = 263;
+const LECKKLAMMER = 264;
+const RECKKLAMMER = 265;
+const LGKLAMMER = 266;
+const RGKLAMMER = 267;
+const STRUCT = 268;
+const UNION = 269;
+const ENUM = 270;
+const ID = 271;
+const NUMBER = 272;
+const CSTRING = 273;
+const SHORT = 274;
+const UNSIGNED = 275;
+const LONG = 276;
+const INT = 277;
+const REAL = 278;
+const _CHAR = 279;
+const VOID = 280;
+const _CONST = 281;
+const _FAR = 282;
+const _HUGE = 283;
+const _NEAR = 284;
+const _ASSIGN = 285;
+const NEW_LINE = 286;
+const SPACE_DEFINE = 287;
+const EXTERN = 288;
+const STDCALL = 289;
+const CDECL = 290;
+const CALLBACK = 291;
+const PASCAL = 292;
+const WINAPI = 293;
+const APIENTRY = 294;
+const WINGDIAPI = 295;
+const SYS_TRAP = 296;
+const _PACKED = 297;
+const ELLIPSIS = 298;
+const R_AND = 299;
+const EQUAL = 300;
+const UNEQUAL = 301;
+const GT = 302;
+const LT = 303;
+const GTE = 304;
+const LTE = 305;
+const QUESTIONMARK = 306;
+const _OR = 307;
+const _AND = 308;
+const _PLUS = 309;
+const MINUS = 310;
+const _SHR = 311;
+const _SHL = 312;
+const STAR = 313;
+const _SLASH = 314;
+const _NOT = 315;
+const PSTAR = 316;
+const P_AND = 317;
+const POINT = 318;
+const DEREF = 319;
+const STICK = 320;
+
+
+implementation
+end.

utils/h2pas/lexlib.pas

@@ -0,0 +1,407 @@
+
+unit LexLib;
+
+(* Standard Lex library unit for TP Lex Version 3.0.
+   2-11-91 AG *)
+
+interface
+
+(* The Lex library unit supplies a collection of variables and routines
+   needed by the lexical analyzer routine yylex and application programs
+   using Lex-generated lexical analyzers. It also provides access to the
+   input/output streams used by the lexical analyzer and the text of the
+   matched string, and provides some utility functions which may be used
+   in actions.
+
+   This `standard' version of the LexLib unit is used to implement lexical
+   analyzers which read from and write to MS-DOS files (using standard input
+   and output, by default). It is suitable for many standard applications
+   for lexical analyzers, such as text conversion tools or compilers.
+
+   However, you may create your own version of the LexLib unit, tailored to
+   your target applications. In particular, you may wish to provide another
+   set of I/O functions, e.g., if you want to read from or write to memory
+   instead to files, or want to use different file types. *)
+
+(* Variables:
+
+   The variable yytext contains the current match, yyleng its length.
+   The variable yyline contains the current input line, and yylineno and
+   yycolno denote the current input position (line, column). These values
+   are often used in giving error diagnostics (however, they will only be
+   meaningful if there is no rescanning across line ends).
+
+   The variables yyinput and yyoutput are the text files which are used
+   by the lexical analyzer. By default, they are assigned to standard
+   input and output, but you may change these assignments to fit your
+   target application (use the Turbo Pascal standard routines assign,
+   reset, and rewrite for this purpose). *)
+
+var
+
+yyinput, yyoutput : Text;        (* input and output file *)
+yyline            : String;      (* current input line *)
+yylineno, yycolno : Integer;     (* current input position *)
+yytext            : String;      (* matched text (should be considered r/o) *)
+yyleng            : Byte         (* length of matched text *)
+  absolute yytext;
+
+(* I/O routines:
+
+   The following routines get_char, unget_char and put_char are used to
+   implement access to the input and output files. Since \n (newline) for
+   Lex means line end, the I/O routines have to translate MS-DOS line ends
+   (carriage-return/line-feed) into newline characters and vice versa. Input
+   is buffered to allow rescanning text (via unput_char).
+
+   The input buffer holds the text of the line to be scanned. When the input
+   buffer empties, a new line is obtained from the input stream. Characters
+   can be returned to the input buffer by calls to unget_char. At end-of-
+   file a null character is returned.
+
+   The input routines also keep track of the input position and set the
+   yyline, yylineno, yycolno variables accordingly.
+
+   Since the rest of the Lex library only depends on these three routines
+   (there are no direct references to the yyinput and yyoutput files or
+   to the input buffer), you can easily replace get_char, unget_char and
+   put_char by another suitable set of routines, e.g. if you want to read
+   from/write to memory, etc. *)
+
+function get_char : Char;
+  (* obtain one character from the input file (null character at end-of-
+     file) *)
+
+procedure unget_char ( c : Char );
+  (* return one character to the input file to be reread in subsequent calls
+     to get_char *)
+
+procedure put_char ( c : Char );
+  (* write one character to the output file *)
+
+(* Utility routines: *)
+
+procedure echo;
+  (* echoes the current match to the output stream *)
+
+procedure yymore;
+  (* append the next match to the current one *)
+
+procedure yyless ( n : Integer );
+  (* truncate yytext to size n and return the remaining characters to the
+     input stream *)
+
+procedure reject;
+  (* reject the current match and execute the next one *)
+
+  (* reject does not actually cause the input to be rescanned; instead,
+     internal state information is used to find the next match. Hence
+     you should not try to modify the input stream or the yytext variable
+     when rejecting a match. *)
+
+procedure return ( n : Integer );
+procedure returnc ( c : Char );
+  (* sets the return value of yylex *)
+
+procedure start ( state : Integer );
+  (* puts the lexical analyzer in the given start state; state=0 denotes
+     the default start state, other values are user-defined *)
+
+(* yywrap:
+
+   The yywrap function is called by yylex at end-of-file (unless you have
+   specified a rule matching end-of-file). You may redefine this routine
+   in your Lex program to do application-dependent processing at end of
+   file. In particular, yywrap may arrange for more input and return false
+   in which case the yylex routine resumes lexical analysis. *)
+
+function yywrap : Boolean;
+  (* The default yywrap routine supplied here closes input and output files
+     and returns true (causing yylex to terminate). *)
+
+(* The following are the internal data structures and routines used by the
+   lexical analyzer routine yylex; they should not be used directly. *)
+
+var
+
+yystate    : Integer; (* current state of lexical analyzer *)
+yyactchar  : Char;    (* current character *)
+yylastchar : Char;    (* last matched character (#0 if none) *)
+yyrule     : Integer; (* matched rule *)
+yyreject   : Boolean; (* current match rejected? *)
+yydone     : Boolean; (* yylex return value set? *)
+yyretval   : Integer; (* yylex return value *)
+
+procedure yynew;
+  (* starts next match; initializes state information of the lexical
+     analyzer *)
+
+procedure yyscan;
+  (* gets next character from the input stream and updates yytext and
+     yyactchar accordingly *)
+
+procedure yymark ( n : Integer );
+  (* marks position for rule no. n *)
+
+procedure yymatch ( n : Integer );
+  (* declares a match for rule number n *)
+
+function yyfind ( var n : Integer ) : Boolean;
+  (* finds the last match and the corresponding marked position and adjusts
+     the matched string accordingly; returns:
+     - true if a rule has been matched, false otherwise
+     - n: the number of the matched rule *)
+
+function yydefault : Boolean;
+  (* executes the default action (copy character); returns true unless
+     at end-of-file *)
+
+procedure yyclear;
+  (* reinitializes state information after lexical analysis has been
+     finished *)
+
+implementation
+
+procedure fatal ( msg : String );
+  (* writes a fatal error message and halts program *)
+  begin
+    writeln('LexLib: ', msg);
+    halt(1);
+  end(*fatal*);
+
+(* I/O routines: *)
+
+const nl = #10;  (* newline character *)
+
+const max_chars = 2048;
+
+var
+
+bufptr : Integer;
+buf    : array [1..max_chars] of Char;
+
+function get_char : Char;
+  var i : Integer;
+  begin
+    if (bufptr=0) and not eof(yyinput) then
+      begin
+        readln(yyinput, yyline);
+        inc(yylineno); yycolno := 1;
+        buf[1] := nl;
+        for i := 1 to length(yyline) do
+          buf[i+1] := yyline[length(yyline)-i+1];
+        inc(bufptr, length(yyline)+1);
+      end;
+    if bufptr>0 then
+      begin
+        get_char := buf[bufptr];
+        dec(bufptr);
+        inc(yycolno);
+      end
+    else
+      get_char := #0;
+  end(*get_char*);
+
+procedure unget_char ( c : Char );
+  begin
+    if bufptr=max_chars then fatal('input buffer overflow');
+    inc(bufptr);
+    dec(yycolno);
+    buf[bufptr] := c;
+  end(*unget_char*);
+
+procedure put_char ( c : Char );
+  begin
+    if c=#0 then
+      { ignore }
+    else if c=nl then
+      writeln(yyoutput)
+    else
+      write(yyoutput, c)
+  end(*put_char*);
+
+(* Variables:
+
+   Some state information is maintained to keep track with calls to yymore,
+   yyless, reject, start and yymatch/yymark, and to initialize state
+   information used by the lexical analyzer.
+   - yystext: contains the initial contents of the yytext variable; this
+     will be the empty string, unless yymore is called which sets yystext
+     to the current yytext
+   - yysstate: start state of lexical analyzer (set to 0 during
+     initialization, and modified in calls to the start routine)
+   - yylstate: line state information (1 if at beginning of line, 0
+     otherwise)
+   - yystack: stack containing matched rules; yymatches contains the number of
+     matches
+   - yypos: for each rule the last marked position (yymark); zeroed when rule
+     has already been considered
+   - yysleng: copy of the original yyleng used to restore state information
+     when reject is used *)
+
+const
+
+max_matches = 1024;
+max_rules   = 256;
+
+var
+
+yystext            : String;
+yysstate, yylstate : Integer;
+yymatches          : Integer;
+yystack            : array [1..max_matches] of Integer;
+yypos              : array [1..max_rules] of Integer;
+yysleng            : Byte;
+
+(* Utilities: *)
+
+procedure echo;
+  var i : Integer;
+  begin
+    for i := 1 to yyleng do
+      put_char(yytext[i])
+  end(*echo*);
+
+procedure yymore;
+  begin
+    yystext := yytext;
+  end(*yymore*);
+
+procedure yyless ( n : Integer );
+  var i : Integer;
+  begin
+    for i := yyleng downto n+1 do
+      unget_char(yytext[i]);
+    yyleng := n;
+  end(*yyless*);
+
+procedure reject;
+  var i : Integer;
+  begin
+    yyreject := true;
+    for i := yyleng+1 to yysleng do
+      yytext := yytext+get_char;
+    dec(yymatches);
+  end(*reject*);
+
+procedure return ( n : Integer );
+  begin
+    yyretval := n;
+    yydone := true;
+  end(*return*);
+
+procedure returnc ( c : Char );
+  begin
+    yyretval := ord(c);
+    yydone := true;
+  end(*returnc*);
+
+procedure start ( state : Integer );
+  begin
+    yysstate := state;
+  end(*start*);
+
+(* yywrap: *)
+
+function yywrap : Boolean;
+  begin
+    close(yyinput); close(yyoutput);
+    yywrap := true;
+  end(*yywrap*);
+
+(* Internal routines: *)
+
+procedure yynew;
+  begin
+    if yylastchar<>#0 then
+      if yylastchar=nl then
+        yylstate := 1
+      else
+        yylstate := 0;
+    yystate := yysstate+yylstate;
+    yytext  := yystext;
+    yystext := '';
+    yymatches := 0;
+    yydone := false;
+  end(*yynew*);
+
+procedure yyscan;
+  begin
+    if yyleng=255 then fatal('yytext overflow');
+    yyactchar := get_char;
+    inc(yyleng);
+    yytext[yyleng] := yyactchar;
+  end(*yyscan*);
+
+procedure yymark ( n : Integer );
+  begin
+    if n>max_rules then fatal('too many rules');
+    yypos[n] := yyleng;
+  end(*yymark*);
+
+procedure yymatch ( n : Integer );
+  begin
+    inc(yymatches);
+    if yymatches>max_matches then fatal('match stack overflow');
+    yystack[yymatches] := n;
+  end(*yymatch*);
+
+function yyfind ( var n : Integer ) : Boolean;
+  begin
+    yyreject := false;
+    while (yymatches>0) and (yypos[yystack[yymatches]]=0) do
+      dec(yymatches);
+    if yymatches>0 then
+      begin
+        yysleng := yyleng;
+        n       := yystack[yymatches];
+        yyless(yypos[n]);
+        yypos[n] := 0;
+        if yyleng>0 then
+          yylastchar := yytext[yyleng]
+        else
+          yylastchar := #0;
+        yyfind := true;
+      end
+    else
+      begin
+        yyless(0);
+        yylastchar := #0;
+        yyfind := false;
+      end
+  end(*yyfind*);
+
+function yydefault : Boolean;
+  begin
+    yyreject := false;
+    yyactchar := get_char;
+    if yyactchar<>#0 then
+      begin
+        put_char(yyactchar);
+        yydefault := true;
+      end
+    else
+      begin
+        yylstate := 1;
+        yydefault := false;
+      end;
+    yylastchar := yyactchar;
+  end(*yydefault*);
+
+procedure yyclear;
+  begin
+    bufptr := 0;
+    yysstate := 0;
+    yylstate := 1;
+    yylastchar := #0;
+    yytext := '';
+    yystext := '';
+  end(*yyclear*);
+
+begin
+  assign(yyinput, '');
+  assign(yyoutput, '');
+  reset(yyinput); rewrite(yyoutput);
+  yylineno := 0;
+  yyclear;
+end(*LexLib*).

utils/h2pas/options.pas

@@ -0,0 +1,210 @@
+{
+    $Id$
+    Copyright (c) 1993-98 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 options;
+
+interface
+
+var
+   inputfilename, outputfilename : string; { Filenames }
+   LibFileName, unitname         : string; { external library name }
+   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 ?   }
+   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 }
+
+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;
+
+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;
+
+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;
+  inputfilename:='';
+  outputfilename:='';
+  LibFileName:='';
+  UnitName:='';
+  UseLib:=False;
+  UseName:=FAlse;
+  StripComment:=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);
+      end
+    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');
+      end;
+    inc(i);
+    end;  
+  If inputfilename='' then Usage;
+  if UnitName='' then
+    begin
+    i:=pos('.',outputfilename)-1;
+    if i<=0 then
+      UnitName:=outputfilename
+    else
+      UnitName:=Copy(OutputFileName,1,i);
+    end;
+end;
+
+end.
+
+{
+   $Log$
+   Revision 1.1  1999-05-12 16:11:39  peter
+     * moved
+
+   Revision 1.10  1999/04/08 20:47:02  florian
+     * misplaced line in the help screen fixed
+
+   Revision 1.9  1998/09/04 17:26:33  pierre
+     * better packed field handling
+
+   Revision 1.8  1998/08/05 15:50:10  florian
+     * small problems with // comments fixed (invalid line counting)
+     + SYS_TRAP support for PalmOS
+     + switch -x for PalmOS
+     + switch -i to generate include files instead of units
+
+   Revision 1.7  1998/07/24 20:55:44  michael
+   * Fixed some minor bugs in Pierres stuff
+
+   Revision 1.6  1998/07/23 23:26:04  michael
+   + added -D option instead of -d, restored old -d
+
+   Revision 1.5  1998/06/08 08:13:47  pierre
+     + merged version of h2pas
+     + added -w for special win32 header directives
+
+   Revision 1.4  1998/04/27 12:06:40  michael
+   + Added GPL statement
+
+   Revision 1.3  1998/04/24 18:23:46  florian
+     + parameter -v added (replaces pointer parameters by call by reference
+       parameters)
+       void p(int *i) =>   procedure p(var i : longint);
+
+}

utils/h2pas/scan.l

@@ -0,0 +1,707 @@
+%{
+{
+    $Id$
+    Copyright (c) 1993-98 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.
+

utils/h2pas/testit.h

@@ -0,0 +1,38 @@
+/*
+   Test header file to test conversion program.
+*/
+
+typedef struct {
+  int x;
+  int y;
+  } a;
+
+typedef union fpk {
+  int X;
+  int y;
+  int z;
+} b;
+
+typedef _test test;
+
+struct _test
+{
+  int x;
+  int y;
+};
+
+void proc(int *,int);
+void proc(int *p,int i);
+
+typedef enum { First, second, third } C;
+
+typedef enum { DFirst = 1, DSecond = 2, DThird = 3 } D;
+
+typedef enum { EFirst = 100, ESecond, EThird } D;
+
+void someproc(char *Firstarg,...);
+
+mytype* somefunc (char *firstarg);
+
+#define test 0x012345UL
+

utils/h2pas/yacclib.pas

@@ -0,0 +1,120 @@
+{
+  Yacc Library Unit for TP Yacc
+
+
+  Copyright (c) 1990-92  Albert Graef <ag@muwiinfa.geschichte.uni-mainz.de>
+  Copyright (C) 1996     Berend de Boer <berend@pobox.com>
+
+  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.
+
+
+$Revision$
+$Modtime: 96-08-01 14:04 $
+
+$History: YACCLIB.PAS $
+ * 
+ * *****************  Version 2  *****************
+ * User: Berend       Date: 96-10-10   Time: 21:16
+ * Updated in $/Lex and Yacc/tply
+ * Updated for protected mode, windows and Delphi 1.X and 2.X.
+
+}
+
+
+{$I-}
+
+unit YaccLib;
+
+(* Yacc Library Unit for TP Yacc Version 3.0, 6-17-91 AG *)
+
+interface
+
+const yymaxdepth = 10000;
+  (* default stack size of parser *)
+
+type YYSType = Integer;
+  (* default value type, may be redefined in Yacc output file *)
+
+var
+
+yychar   : Integer; (* current lookahead character *)
+yynerrs  : Integer; (* current number of syntax errors reported by the
+                       parser *)
+yydebug  : Boolean; (* set to true to enable debugging output of parser *)
+
+line_no : longint;
+
+procedure yyerror ( msg : String );
+  (* error message printing routine used by the parser *)
+
+procedure yyclearin;
+  (* delete the current lookahead token *)
+
+procedure yyaccept;
+  (* trigger accept action of the parser; yyparse accepts returning 0, as if
+     it reached end of input *)
+
+procedure yyabort;
+  (* like yyaccept, but causes parser to return with value 1, as if an
+     unrecoverable syntax error had been encountered *)
+
+procedure yyerrlab;
+  (* causes error recovery to be started, as if a syntax error had been
+     encountered *)
+
+procedure yyerrok;
+  (* when in error mode, resets the parser to its normal mode of
+     operation *)
+
+(* Flags used internally by the parser routine: *)
+
+var
+
+yyflag    : ( yyfnone, yyfaccept, yyfabort, yyferror );
+yyerrflag : Integer;
+
+implementation
+
+procedure yyerror ( msg : String );
+  begin
+    writeln('at line ',line_no,' error : ',msg);
+  end(*yyerrmsg*);
+
+procedure yyclearin;
+  begin
+    yychar := -1;
+  end(*yyclearin*);
+
+procedure yyaccept;
+  begin
+    yyflag := yyfaccept;
+  end(*yyaccept*);
+
+procedure yyabort;
+  begin
+    yyflag := yyfabort;
+  end(*yyabort*);
+
+procedure yyerrlab;
+  begin
+    yyflag := yyferror;
+  end(*yyerrlab*);
+
+procedure yyerrok;
+  begin
+    yyerrflag := 0;
+  end(*yyerrork*);
+
+end(*YaccLib*).

utils/h2pas/yylex.cod

@@ -0,0 +1,80 @@
+
+(* lexical analyzer template (TP Lex V3.0), V1.0 3-2-91 AG *)
+
+(* global definitions: *)
+%%
+
+function yylex : Integer;
+
+procedure yyaction ( yyruleno : Integer );
+  (* local definitions: *)
+%%
+begin
+  (* actions: *)
+  case yyruleno of
+%%
+  end;
+end(*yyaction*);
+
+(* DFA table: *)
+%%
+
+var yyn : Integer;
+
+label start, scan, action;
+
+begin
+
+start:
+
+  (* initialize: *)
+
+  yynew;
+
+scan:
+
+  (* mark positions and matches: *)
+
+  for yyn := yykl[yystate] to     yykh[yystate] do yymark(yyk[yyn]);
+  for yyn := yymh[yystate] downto yyml[yystate] do yymatch(yym[yyn]);
+
+  if yytl[yystate]>yyth[yystate] then goto action; (* dead state *)
+
+  (* get next character: *)
+
+  yyscan;
+
+  (* determine action: *)
+
+  yyn := yytl[yystate];
+  while (yyn<=yyth[yystate]) and not (yyactchar in yyt[yyn].cc) do inc(yyn);
+  if yyn>yyth[yystate] then goto action;
+    (* no transition on yyactchar in this state *)
+
+  (* switch to new state: *)
+
+  yystate := yyt[yyn].s;
+
+  goto scan;
+
+action:
+
+  (* execute action: *)
+
+  if yyfind(yyrule) then
+    begin
+      yyaction(yyrule);
+      if yyreject then goto action;
+    end
+  else if not yydefault and yywrap then
+    begin
+      yyclear;
+      return(0);
+    end;
+
+  if not yydone then goto start;
+
+  yylex := yyretval;
+
+end(*yylex*);
+

utils/h2pas/yyparse.cod

@@ -0,0 +1,184 @@
+
+(* Yacc parser template (TP Yacc V3.0), V1.2 6-17-91 AG *)
+
+(* global definitions: *)
+%%
+
+var yylval : YYSType;
+
+function yylex : Integer; forward;
+
+function yyparse : Integer;
+
+var yystate, yysp, yyn : Integer;
+    yys : array [1..yymaxdepth] of Integer;
+    yyv : array [1..yymaxdepth] of YYSType;
+    yyval : YYSType;
+
+procedure yyaction ( yyruleno : Integer );
+  (* local definitions: *)
+%%
+begin
+  (* actions: *)
+  case yyruleno of
+%%
+  end;
+end(*yyaction*);
+
+(* parse table: *)
+%%
+
+const _error = 256; (* error token *)
+
+function yyact(state, sym : Integer; var act : Integer) : Boolean;
+  (* search action table *)
+  var k : Integer;
+  begin
+    k := yyal[state];
+    while (k<=yyah[state]) and (yya[k].sym<>sym) do inc(k);
+    if k>yyah[state] then
+      yyact := false
+    else
+      begin
+        act := yya[k].act;
+        yyact := true;
+      end;
+  end(*yyact*);
+
+function yygoto(state, sym : Integer; var nstate : Integer) : Boolean;
+  (* search goto table *)
+  var k : Integer;
+  begin
+    k := yygl[state];
+    while (k<=yygh[state]) and (yyg[k].sym<>sym) do inc(k);
+    if k>yygh[state] then
+      yygoto := false
+    else
+      begin
+        nstate := yyg[k].act;
+        yygoto := true;
+      end;
+  end(*yygoto*);
+
+label parse, next, error, errlab, shift, reduce, accept, abort;
+
+begin(*yyparse*)
+
+  (* initialize: *)
+
+  yystate := 0; yychar := -1; yynerrs := 0; yyerrflag := 0; yysp := 0;
+
+{$ifdef yydebug}
+  yydebug := true;
+{$else}
+  yydebug := false;
+{$endif}
+
+parse:
+
+  (* push state and value: *)
+
+  inc(yysp);
+  if yysp>yymaxdepth then
+    begin
+      yyerror('yyparse stack overflow');
+      goto abort;
+    end;
+  yys[yysp] := yystate; yyv[yysp] := yyval;
+
+next:
+
+  if (yyd[yystate]=0) and (yychar=-1) then
+    (* get next symbol *)
+    begin
+      yychar := yylex; if yychar<0 then yychar := 0;
+    end;
+
+  if yydebug then writeln('state ', yystate, ', char ', yychar);
+
+  (* determine parse action: *)
+
+  yyn := yyd[yystate];
+  if yyn<>0 then goto reduce; (* simple state *)
+
+  (* no default action; search parse table *)
+
+  if not yyact(yystate, yychar, yyn) then goto error
+  else if yyn>0 then                      goto shift
+  else if yyn<0 then                      goto reduce
+  else                                    goto accept;
+
+error:
+
+  (* error; start error recovery: *)
+
+  if yyerrflag=0 then yyerror('syntax error');
+
+errlab:
+
+  if yyerrflag=0 then inc(yynerrs);     (* new error *)
+
+  if yyerrflag<=2 then                  (* incomplete recovery; try again *)
+    begin
+      yyerrflag := 3;
+      (* uncover a state with shift action on error token *)
+      while (yysp>0) and not ( yyact(yys[yysp], _error, yyn) and
+                               (yyn>0) ) do
+        begin
+          if yydebug then
+            if yysp>1 then
+              writeln('error recovery pops state ', yys[yysp], ', uncovers ',
+                      yys[yysp-1])
+            else
+              writeln('error recovery fails ... abort');
+          dec(yysp);
+        end;
+      if yysp=0 then goto abort; (* parser has fallen from stack; abort *)
+      yystate := yyn;            (* simulate shift on error *)
+      goto parse;
+    end
+  else                                  (* no shift yet; discard symbol *)
+    begin
+      if yydebug then writeln('error recovery discards char ', yychar);
+      if yychar=0 then goto abort; (* end of input; abort *)
+      yychar := -1; goto next;     (* clear lookahead char and try again *)
+    end;
+
+shift:
+
+  (* go to new state, clear lookahead character: *)
+
+  yystate := yyn; yychar := -1; yyval := yylval;
+  if yyerrflag>0 then dec(yyerrflag);
+
+  goto parse;
+
+reduce:
+
+  (* execute action, pop rule from stack, and go to next state: *)
+
+  if yydebug then writeln('reduce ', -yyn);
+
+  yyflag := yyfnone; yyaction(-yyn);
+  dec(yysp, yyr[-yyn].len);
+  if yygoto(yys[yysp], yyr[-yyn].sym, yyn) then yystate := yyn;
+
+  (* handle action calls to yyaccept, yyabort and yyerror: *)
+
+  case yyflag of
+    yyfaccept : goto accept;
+    yyfabort  : goto abort;
+    yyferror  : goto errlab;
+  end;
+
+  goto parse;
+
+accept:
+
+  yyparse := 0; exit;
+
+abort:
+
+  yyparse := 1; exit;
+
+end(*yyparse*);

utils/ppdep.pp

@@ -0,0 +1,629 @@
+{
+    $Id$
+    This program is part of the Free Pascal run time library.
+    Copyright (c) 1997 by Peter Vreman
+    member of the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+{ Program to create a depend makefile for a program with multiple units }
+
+program ppdep;
+uses Dos;
+
+{.$define debug}
+
+const
+{$ifdef linux}
+  exeext='';
+{$else}
+  exeext='.EXE';
+{$endif}
+
+type
+  PUses=^TUses;
+  TUses=record
+    Name : string[32];
+    Next : PUses;
+  end;
+  PUnit=^TUnit;
+  TUnit=record
+    UsesList : PUses;
+    PasFn,
+    Name     : string[32];
+    IsUnit   : boolean;
+    Next     : PUnit;
+  end;
+  PDefine=^TDefine;
+  TDefine = Record
+    Name : String[32];
+    Next : PDefine;
+    end;
+
+
+var
+  UnitList         : PUnit;
+  Define           : PDefine;
+  ParaFile         : string;
+  Verbose          : boolean;
+  AddCall          : byte;
+  CallLine,
+  OutFile          : String;
+  UnitExt          : String;
+
+{****************************************************************************
+                           Handy Routines
+****************************************************************************}
+
+function UCase(Const Hstr:string):string;
+var
+  i : longint;
+begin
+  for i:=1to Length(Hstr) do
+   UCase[i]:=Upcase(Hstr[i]);
+  UCase[0]:=chr(Length(Hstr));
+end;
+
+
+function FixFn(const s:string):string;
+var
+  i      : longint;
+  NoPath : boolean;
+begin
+  NoPath:=true;
+  for i:=length(s) downto 1 do
+   begin
+     case s[i] of
+ {$ifdef Linux}
+  '/','\' : begin
+              FixFn[i]:='/';
+              NoPath:=false; {Skip lowercasing path: 'X11'<>'x11' }
+            end;
+ 'A'..'Z' : if NoPath then
+             FixFn[i]:=char(byte(s[i])+32)
+            else
+             FixFn[i]:=s[i];
+ {$else}
+      '/' : FixFn[i]:='\';
+ 'A'..'Z' : FixFn[i]:=char(byte(s[i])+32); { everything lowercase }
+ {$endif}
+     else
+      FixFn[i]:=s[i];
+     end;
+   end;
+  FixFn[0]:=Chr(Length(s));
+end;
+
+
+{****************************************************************************
+                             Main Program
+****************************************************************************}
+
+Function SearchPas(const fn:string):string;
+var
+  Dir : SearchRec;
+begin
+  FindFirst(FixFn(fn+'.PP'),$20,Dir);
+  if Doserror=0 then
+   SearchPas:=FixFn(fn+'.PP')
+  else
+   SearchPas:=FixFn(fn+'.PAS')
+end;
+
+
+Function UnitDone(const fn:string):boolean;
+var
+  hp : PUnit;
+begin
+  hp:=UnitList;
+  while not (hp=nil) do
+   begin
+     if hp^.Name=fn then
+      begin
+        UnitDone:=true;
+        exit;
+      end;
+     hp:=hp^.Next;
+   end;
+  UnitDone:=false;
+end;
+
+
+Function CheckDefine(const s:string):boolean;
+var
+  ss : string[32];
+  P : PDefine;
+begin
+  ss:=ucase(s);
+  P:=Define;
+  while (p<>Nil) do
+   begin
+     if ss=p^.name then
+      begin
+        CheckDefine:=true;
+        exit;
+      end;
+     P:=P^.Next;
+   end;
+  CheckDefine:=false;
+end;
+
+Procedure AddDefine(Const S : String);
+Var
+  P : PDefine;
+begin
+  New(P);
+  P^.Name:=Ucase(S);
+  P^.Next:=Define;
+  Define:=P;
+end;
+
+
+procedure RemoveSep(var fn:string);
+var
+  i : longint;
+begin
+  i:=0;
+  while (i<length(fn)) and (fn[i+1] in [',',' ',#9]) do
+   inc(i);
+  Delete(fn,1,i);
+end;
+
+
+function GetName(var fn:string):string;
+var
+  i : longint;
+begin
+  i:=0;
+  while (i<length(fn)) and (fn[i+1] in ['A'..'Z','0'..'9','_','-']) do
+   inc(i);
+  GetName:=Copy(fn,1,i);
+  Delete(fn,1,i);
+end;
+
+
+procedure ListDepend(const fn:string);
+
+{$ifndef FPC}
+  procedure readln(var t:text;var s:string);
+  var
+    c : char;
+    i : longint;
+  begin
+    c:=#0;
+    i:=0;
+    while (not eof(t)) and (c<>#10) do
+     begin
+       read(t,c);
+       if c<>#10 then
+        begin
+          inc(i);
+          s[i]:=c;
+        end;
+     end;
+    if (i>0) and (s[i]=#13) then
+     dec(i);
+    s[0]:=chr(i);
+  end;
+{$endif}
+
+const
+  MaxLevel=200;
+var
+  f  : text;
+  hs : ^string;
+  curruses,lastuses : PUses;
+  currunit,lastunit : PUnit;
+  i,j : longint;
+  UsesDone,
+  OldComment,
+  Done,Comment,
+  InImplementation : boolean;
+  Skip : array[0..MaxLevel] of boolean;
+  Level : byte;
+begin
+  if UnitDone(fn) then
+   exit;
+  new(hs);
+  new(currunit);
+  currunit^.next:=nil;
+  currunit^.Name:=fn;
+  currunit^.IsUnit:=true;
+  currunit^.PasFn:=SearchPas(fn);
+  currunit^.useslist:=nil;
+  assign(f,currunit^.PasFn);
+  {$I-}
+   reset(f);
+  {$I+}
+  if ioresult=0 then
+   begin
+     if verbose then
+      Writeln('Processing ',currunit^.PasFn);
+   {Add to Linked List}
+     if unitlist=nil then
+      unitlist:=currunit
+     else
+      begin
+        lastunit:=UnitList;
+        while not (lastunit^.Next=nil) do
+         lastunit:=lastunit^.next;
+        lastunit^.next:=currunit;
+      end;
+   {Parse file}
+     InImplementation:=false;
+     done:=false;
+     usesdone:=true;
+     Comment:=false;
+     OldComment:=false;
+     FillChar(skip,sizeof(Skip),0);
+     hs^:='';
+     Level:=0;
+     while (not done) and (not Eof(f)) do
+      begin
+        repeat
+          if hs^='' then
+           begin
+             ReadLn(f,hs^);
+             hs^:=UCase(hs^);
+           end;
+          RemoveSep(hs^);
+        until (hs^<>'') or Eof(f);
+        if Comment then
+         begin
+           i:=pos('}',hs^);
+           if (i>0) then
+            begin
+              j:=pos('{',hs^);
+              if (j>0) and (j<i) then
+               begin
+                 Comment:=true;
+                 Delete(hs^,1,j-1);
+               end
+              else
+               begin
+                 Comment:=false;
+                 Delete(hs^,1,i-1);
+               end;
+            end
+           else
+            hs^:='';
+         end;
+        if (pos('(*',hs^)>0) or OldComment then
+         begin
+           i:=pos('*)',hs^);
+           if (i>0) then
+            begin
+              OldComment:=false;
+              Delete(hs^,1,i+1);
+            end
+           else
+            begin
+              OldComment:=true;
+              hs^:='';
+            end;
+         end;
+        if (hs^<>'') then
+         begin
+           case hs^[1] of
+            '}' : begin
+                    Comment:=false;
+                    hs^:='';
+                  end;
+            '{' : begin
+                    if (Copy(hs^,2,6)='$IFDEF') then
+                     begin
+                       Delete(hs^,1,7);
+                       RemoveSep(hs^);
+                       inc(Level);
+                       if Level>=MaxLevel then
+                        begin
+                          Writeln('Too many IF(N)DEFs');
+                          Halt(1);
+                        end;
+                       skip[level]:=skip[level-1] or (not CheckDefine(GetName(hs^)));
+                       hs^:='';
+                     end
+                    else
+                     if (Copy(hs^,2,7)='$IFNDEF') then
+                      begin
+                        Delete(hs^,1,7);
+                        RemoveSep(hs^);
+                        inc(Level);
+                        if Level>=MaxLevel then
+                         begin
+                           Writeln('Too many IF(N)DEFs');
+                           Halt(1);
+                         end;
+                        skip[level]:=skip[level-1] or (CheckDefine(GetName(hs^)));
+                        hs^:='';
+                      end
+                    else
+                     if (Copy(hs^,2,6)='$ELSE') then
+                      begin
+                        skip[level]:=skip[level-1] or (not skip[level]);
+                        hs^:='';
+                      end
+                    else
+                     if (Copy(hs^,2,6)='$ENDIF') then
+                      begin
+                        skip[level]:=false;
+                        if Level=0 then
+                         begin
+                           Writeln('Too many ENDIFs');
+                           Halt(1);
+                         end;
+                        dec(level);
+                        hs^:='';
+                      end
+                    else
+                     if (Copy(hs^,2,6)='$IFOPT') then
+                      begin
+                        inc(Level);
+                        if Level>=MaxLevel then
+                         begin
+                           Writeln('Too many IF(N)DEFs');
+                           Halt(1);
+                         end;
+                        skip[level]:=true;
+                        hs^:='';
+                      end
+                    else
+                     begin
+                       i:=pos('}',hs^);
+                       if i>0 then
+                        begin
+                          Delete(hs^,1,i);
+                          Comment:=false;
+                        end
+                       else
+                        Comment:=true;
+                     end;
+                  end;
+            ';' : begin
+                    UsesDone:=true;
+                    Done:=(UsesDone and InImplementation);
+                    hs^:='';
+                  end;
+           else
+            begin
+              if skip[level] then
+               hs^:=''
+              else
+               begin
+                 if (not UsesDone) then
+                  begin
+                    new(curruses);
+                    curruses^.Name:=GetName(hs^);
+                    curruses^.next:=nil;
+                    if currunit^.useslist=nil then
+                     currunit^.useslist:=curruses
+                    else
+                     begin
+                       lastuses:=currunit^.useslist;
+                       while not (lastuses^.Next=nil) do
+                        lastuses:=lastuses^.next;
+                       lastuses^.next:=curruses;
+                     end;
+   {$ifndef debug}
+                    ListDepend(curruses^.Name);
+   {$endif}
+                    RemoveSep(hs^);
+                  end
+                 else
+                  begin
+                    if (Copy(hs^,1,4)='USES') and ((length(hs^)=4) or (hs^[5] in [' ',#9])) then
+                     begin
+                       Delete(hs^,1,4);
+                       UsesDone:=false;
+                     end
+                    else
+                     begin
+                       if (hs^='IMPLEMENTATION') then
+                        InImplementation:=true
+                       else
+                        if (Copy(hs^,1,7)='PROGRAM') then
+                         begin
+                           currunit^.IsUnit:=false;
+                           InImplementation:=true; {there can be only 1 uses}
+                         end
+                       else
+                         if InImplementation and ((copy(hs^,1,5)='CONST') or
+                            (copy(hs^,1,3)='VAR') or (copy(hs^,1,5)='BEGIN')) then
+                          done:=true;
+                       hs^:='';
+                     end;
+                  end;
+               end;
+            end;
+           end;
+         end;
+      end;
+     Close(f);
+   end
+  else
+   dispose(currunit);
+  dispose(hs);
+end;
+
+
+procedure ShowDepend;
+var
+  currunit : PUnit;
+  curruses : PUses;
+  t        : text;
+  P        : PDefine;
+  First    : boolean;
+begin
+  if CallLine='' then
+   begin
+     CallLine:='ppc386 ';
+     P:=Define;
+     While P<>Nil do
+      begin
+        CallLine:=CallLine+' -d'+P^.Name;
+        P:=P^.Next;
+      end;
+   end;
+  assign(t,OutFile);
+  rewrite(t);
+  currunit:=UnitList;
+  First:=true;
+  while not (currunit=nil) do
+   begin
+     if currunit^.IsUnit then
+      Write(t,FixFn(currunit^.Name+'.'+unitext)+': '+currunit^.PasFn)
+     else
+      Write(t,FixFn(currunit^.Name+exeext)+': '+currunit^.PasFn);
+     curruses:=currunit^.useslist;
+     while not (curruses=nil) do
+      begin
+{$ifndef debug}
+        if UnitDone(curruses^.name) then
+{$endif}
+         begin
+           writeln(t,' \');
+           write(t,#9+FixFn(curruses^.name+'.'+unitext));
+         end;
+        curruses:=curruses^.next;
+      end;
+     writeln(t,'');
+     If (AddCall=2) or (First and (AddCall=1)) then
+      writeln(t,#9,CallLine,' ',currunit^.PasFn);
+     writeln(t,'');
+     currunit:=currunit^.next;
+     First:=false;
+   end;
+  close(t);
+end;
+
+
+procedure getpara;
+var
+  ch   : char;
+  para : string[128];
+  i    : word;
+
+  procedure helpscreen;
+  begin
+    writeln('ppdep [Options] <File>');
+    Writeln;
+    Writeln('Options can be: -D<define>   Define a symbol');
+    Writeln('                -oFile       Write output to file');
+    WRiteln('                             (default stdout)');
+    Writeln('                -eext        Set unit extension to ext');
+    Writeln('                             (default ppu)');
+    Writeln('                -V           Be more verbose');
+    Writeln('          -? or -H           This HelpScreen');
+    Writeln('                -A[call]     Add compiler calls to makefile');
+    halt(1);
+  end;
+
+begin
+  Define:=Nil;
+  Outfile:='';
+  AddCall:=0;
+  Verbose:=False;
+{$IFDEF LINUX}
+  UnitExt:='ppu';
+{$ELSE}
+  UnitExt:='PPU';
+{$endif}
+  for i:=1 to paramcount do
+   begin
+     para:=Paramstr(i);
+     if (para[1]='-') then
+      begin
+        ch:=Upcase(para[2]);
+        delete(para,1,2);
+        case ch of
+         'A' : begin
+                 AddCall:=2;
+                 CallLine:=Para;
+               end;
+         'F' : begin
+                 AddCall:=1;
+                 CallLine:=Para;
+               end;
+         'D' : AddDefine(para);
+         'O' : OutFile:=Para;
+         'E' : UnitExt:=Para;
+         'V' : verbose:=true;
+     '?','H' : helpscreen;
+        end;
+     end
+    else
+     begin
+       ParaFile:=Para;
+       if Pos('.',ParaFile)>0 then
+        Delete(Parafile,Pos('.',ParaFile),255);
+     end;
+    end;
+  if (ParaFile='') then
+   HelpScreen;
+end;
+
+
+begin
+  GetPara;
+  ListDepend(ParaFile);
+  ShowDepend;
+end.
+
+{
+  $Log$
+  Revision 1.1  1999-05-12 16:11:39  peter
+    * moved
+
+  Revision 1.1  1999/05/03 18:03:15  peter
+    * renamed mkdep -> ppdep
+    * removed obsolete units
+    * add .cod files
+
+  Revision 1.7  1998/11/18 11:15:14  michael
+  + Added support for different unit extensions
+
+  Revision 1.6  1998/10/22 23:51:35  peter
+    * better comment support
+
+  Revision 1.5  1998/08/10 09:55:21  peter
+    * fix for uses in rejected part
+
+  Revision 1.4  1998/06/24 14:02:17  peter
+    + (* *) support
+
+  Revision 1.3  1998/06/23 14:01:18  peter
+    + -F to add a line to only the first file
+
+  Revision 1.2  1998/03/27 18:39:20  peter
+    * fixed the preprocessor
+    + -A<call> to add the <call> to all the entries
+
+  Revision 1.1.1.1  1998/03/25 11:18:48  root
+  * Restored version
+
+  Revision 1.5  1998/03/15 15:39:23  peter
+    * fixed $ELSE
+
+  Revision 1.4  1998/03/10 12:53:24  peter
+    * much better preprocessor
+    + IFOPT skipping
+
+  Revision 1.3  1998/03/02 13:45:34  peter
+    * works better and exefile name is written when a program is parsed
+
+  Revision 1.2  1998/02/24 13:55:07  michael
+  + Added option to write to file. Default is to stdout
+  + Added option to write/not write a compiler call
+  + Nr of defines is now unlimited.
+  * Fixed bug with uppercase filenames under linux.
+
+  Revision 1.1  1998/02/23 23:16:48  peter
+    + Initial implementation
+}

utils/ppumove.pp

@@ -0,0 +1,570 @@
+{
+    $Id$
+    Copyright (c) 1998 by the FPC Development Team
+
+    Add multiple FPC units into a static/shared library
+
+    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.
+
+ ****************************************************************************}
+{$ifdef TP}
+  {$N+,E+}
+{$endif}
+Program ppumove;
+uses
+{$ifdef linux}
+  linux,
+{$else linux}
+  dos,
+{$endif linux}
+  ppu,
+  getopts;
+
+const
+  Version   = 'Version 0.99.7';
+  Title     = 'PPU-Mover';
+  Copyright = 'Copyright (c) 1998 by the Free Pascal Development Team';
+
+  ShortOpts = 'o:e:d:qhsvbw';
+  BufSize = 4096;
+  PPUExt = 'ppu';
+  ObjExt = 'o';
+  StaticLibExt ='a';
+{$ifdef Linux}
+  SharedLibExt ='so';
+  BatchExt     ='.sh';
+{$else}
+  SharedLibExt ='dll';
+  BatchExt     ='.bat';
+{$endif Linux}
+
+
+Type
+  PLinkOEnt = ^TLinkOEnt;
+  TLinkOEnt = record
+    Name : string;
+    Next : PLinkOEnt;
+  end;
+
+Var
+  ArBin,LDBin,
+  OutputFile,
+  DestPath,
+  PPLExt,
+  LibExt      : string;
+  Batch,
+  Quiet,
+  MakeStatic  : boolean;
+  Buffer      : Pointer;
+  ObjFiles    : PLinkOEnt;
+  BatchFile   : Text;
+
+{*****************************************************************************
+                                 Helpers
+*****************************************************************************}
+
+Procedure Error(const s:string;stop:boolean);
+{
+  Write an error message to stderr
+}
+begin
+{$ifdef FPC}
+  writeln(stderr,s);
+  flush(stderr);
+{$else}
+  writeln(s);
+{$endif}
+  if stop then
+   halt(1);
+end;
+
+
+function Shell(const s:string):longint;
+{
+  Run a shell commnad and return the exitcode
+}
+begin
+  if Batch then
+   begin
+     Writeln(BatchFile,s);
+     Shell:=0;
+     exit;
+   end;
+{$ifdef Linux}
+  Shell:=Linux.shell(s);
+{$else}
+  exec(getenv('COMSPEC'),'/C '+s);
+  Shell:=DosExitCode;
+{$endif}
+end;
+
+
+Function FileExists (Const F : String) : Boolean;
+{
+  Returns True if the file exists, False if not.
+}
+Var
+{$ifdef linux}
+  info : Stat;
+{$else}
+  info : searchrec;
+{$endif}
+begin
+{$ifdef linux}
+  FileExists:=FStat (F,Info);
+{$else}
+  FindFirst (F,anyfile,Info);
+  FileExists:=DosError=0;
+{$endif}
+end;
+
+
+Function AddExtension(Const HStr,ext:String):String;
+{
+  Return a filename which will have extension ext added if no
+  extension is found
+}
+var
+  j : longint;
+begin
+  j:=length(Hstr);
+  while (j>0) and (Hstr[j]<>'.') do
+   dec(j);
+  if j=0 then
+   AddExtension:=Hstr+'.'+Ext
+  else
+   AddExtension:=HStr;
+end;
+
+
+Function ForceExtension(Const HStr,ext:String):String;
+{
+  Return a filename which certainly has the extension 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;
+
+
+Procedure AddToLinkFiles(const S : String);
+{
+  Adds a filename to a list of object files to link to.
+  No duplicates allowed.
+}
+Var
+  P : PLinKOEnt;
+begin
+  P:=ObjFiles;
+  { Don't add files twice }
+  While (P<>nil) and (p^.name<>s) do
+    p:=p^.next;
+  if p=nil then
+   begin
+     new(p);
+     p^.next:=ObjFiles;
+     p^.name:=s;
+     ObjFiles:=P;
+   end;
+end;
+
+
+Function ExtractLib(const libfn:string):string;
+{
+  Extract a static library libfn and return the files with a
+  wildcard
+}
+var
+  n,d,e : string;
+  i     : word;
+begin
+{ create the temp dir first }
+  fsplit(libfn,d,n,e);
+  {$I-}
+   mkdir(n+'.sl');
+  {$I+}
+  i:=ioresult;
+{ Extract }
+  if Shell(arbin+' x '+libfn)<>0 then
+   Error('Fatal: Error running '+arbin,true);
+{ Remove the lib file, it's extracted so it can be created with ease }
+  if PPLExt=PPUExt then
+   Shell('rm '+libfn);
+{$ifdef linux}
+  ExtractLib:=n+'.sl/*';
+{$else}
+  ExtractLib:=n+'.sl\*';
+{$endif}
+end;
+
+
+Function DoPPU(const PPUFn,PPLFn:String):Boolean;
+{
+  Convert one file (in Filename) to library format.
+  Return true if successful, false otherwise.
+}
+Var
+  inppu,
+  outppu : pppufile;
+  b,
+  untilb : byte;
+  l      : longint;
+  i      : word;
+  f      : file;
+  isstaticlinked : boolean;
+begin
+  DoPPU:=false;
+  If Not Quiet then
+   Write ('Processing ',PPUFn,'...');
+  inppu:=new(pppufile,init(PPUFn));
+  if not inppu^.open then
+   begin
+     dispose(inppu,done);
+     Error('Error: Could not open : '+PPUFn,false);
+     Exit;
+   end;
+{ Check the ppufile }
+  if not inppu^.CheckPPUId then
+   begin
+     dispose(inppu,done);
+     Error('Error: Not a PPU File : '+PPUFn,false);
+     Exit;
+   end;
+  if inppu^.GetPPUVersion<15 then
+   begin
+     dispose(inppu,done);
+     Error('Error: Wrong PPU Version : '+PPUFn,false);
+     Exit;
+   end;
+{ Already a lib? }
+  if (inppu^.header.flags and uf_in_library)<>0 then
+   begin
+     dispose(inppu,done);
+     Error('Error: PPU is already in a library : '+PPUFn,false);
+     Exit;
+   end;
+{ Create the new ppu }
+  if PPUFn=PPLFn then
+   outppu:=new(pppufile,init('ppumove.$$$'))
+  else
+   outppu:=new(pppufile,init(PPLFn));
+  outppu^.create;
+{ Create new header, with the new flags }
+  outppu^.header:=inppu^.header;
+  outppu^.header.flags:=outppu^.header.flags or uf_in_library;
+  if MakeStatic then
+   outppu^.header.flags:=outppu^.header.flags or uf_static_linked
+  else 
+   outppu^.header.flags:=outppu^.header.flags or uf_shared_linked;
+{ Is the until smartlinked ? }
+  IsStaticLinked:=(inppu^.header.flags and uf_static_linked)<>0;
+{ read until the object files are found }
+  if IsStaticLinked then
+   untilb:=iblinkstaticlibs
+  else
+   untilb:=iblinkofiles;
+  repeat
+    b:=inppu^.readentry;
+    if b in [ibendinterface,ibend] then
+     begin
+       dispose(inppu,done);
+       dispose(outppu,done);
+       Error('Error: No files to be linked found : '+PPUFn,false);
+       Exit;
+     end;
+    if b<>untilb then
+     begin
+       repeat
+         inppu^.getdatabuf(buffer^,bufsize,l);
+         outppu^.putdata(buffer^,l);
+       until l<bufsize;
+       outppu^.writeentry(b);
+     end;
+  until (b=untilb);
+{ we have now reached the section for the files which need to be added,
+  now add them to the list }
+  case b of
+       iblinkofiles : begin
+                        while not inppu^.endofentry do
+                         AddToLinkFiles(inppu^.getstring);
+                      end;
+   iblinkstaticlibs : begin
+                        AddToLinkFiles(ExtractLib(inppu^.getstring));
+                        if not inppu^.endofentry then
+                         begin
+                           repeat
+                             inppu^.getdatabuf(buffer^,bufsize,l);
+                             outppu^.putdata(buffer^,l);
+                           until l<bufsize;
+                           outppu^.writeentry(b);
+                         end;
+                      end;
+  end;
+{ just add a new entry with the new lib }
+  outppu^.putstring(outputfile);
+  if MakeStatic then
+   outppu^.writeentry(iblinkstaticlibs)
+  else
+   outppu^.writeentry(iblinksharedlibs);
+{ read all entries until the end and write them also to the new ppu }
+  repeat
+    b:=inppu^.readentry;
+  { don't write ibend, that's written automaticly }
+    if b<>ibend then
+     begin
+       repeat
+         inppu^.getdatabuf(buffer^,bufsize,l);
+         outppu^.putdata(buffer^,l);
+       until l<bufsize;
+       outppu^.writeentry(b);
+     end;
+  until b=ibend;
+{ write the last stuff and close }
+  outppu^.flush;
+  outppu^.writeheader;
+  dispose(outppu,done);
+  dispose(inppu,done);
+{ rename }
+  if PPUFn=PPLFn then
+   begin
+     {$I-}
+      assign(f,PPUFn);
+      erase(f);
+      assign(f,'ppumove.$$$');
+      rename(f,PPUFn);
+     {$I+}
+     i:=ioresult;
+   end;
+{ the end }
+  If Not Quiet then
+   Writeln (' Done.');
+  DoPPU:=True;
+end;
+
+
+Function DoFile(const FileName:String):Boolean;
+{
+  Process a file, mainly here for wildcard support under Dos
+}
+{$ifndef linux}
+var
+  dir : searchrec;
+{$endif}
+begin
+{$ifdef linux}
+  DoFile:=DoPPU(FileName,ForceExtension(FileName,PPLExt));
+{$else}
+  DoFile:=false;
+  findfirst(filename,$20,dir);
+  while doserror=0 do
+   begin
+     if not DoPPU(Dir.Name,ForceExtension(Dir.Name,PPLExt)) then
+      exit;
+     findnext(dir);
+   end;
+  DoFile:=true;
+{$endif}
+end;
+
+
+Procedure DoLink;
+{
+  Link the object files together to form a (shared) library, the only
+  problem here is the 255 char limit of Names
+}
+Var
+  Names : String;
+  f     : file;
+  Err   : boolean;
+  P     : PLinkOEnt;
+begin
+  if not Quiet then
+   Write ('Linking ');
+  P:=ObjFiles;
+  names:='';
+  While p<>nil do
+   begin
+     if Names<>'' then
+      Names:=Names+' '+P^.name
+     else
+      Names:=p^.Name;
+     p:=p^.next;
+   end;
+  if Names='' then
+   begin
+     If not Quiet then
+      Writeln('Error: no files found to be linked');
+     exit;
+   end;
+  If not Quiet then
+   WriteLn(names);
+{ Run ar or ld to create the lib }
+  If MakeStatic then
+   Err:=Shell(arbin+' rs '+outputfile+' '+names)<>0
+  else
+   Err:=Shell(ldbin+' -shared -o '+OutputFile+' '+names)<>0;
+  If Err then
+   Error('Fatal: Library building stage failed.',true);
+{ Remove the .o files }
+  if PPLExt=PPUExt then
+   begin
+     while pos('*',names)>0 do
+      Delete(names,pos('*',names),1);
+     Shell('rm -rf '+names);
+   end;
+{ Rename to the destpath }
+  if DestPath<>'' then
+   begin
+     Assign(F, OutputFile);
+     Rename(F,DestPath+'/'+OutputFile);
+   end;
+end;
+
+
+Procedure usage;
+{
+  Print usage and exit.
+}
+begin
+  Writeln(paramstr(0),': [-qhwvbs] [-e ext] [-o name] [-d path] file [file ...]');
+  Halt(0);
+end;
+
+
+
+Procedure processopts;
+{
+  Process command line opions, and checks if command line options OK.
+}
+var
+  C : char;
+begin
+  if paramcount=0 then
+   usage;
+{ Reset }
+  ObjFiles:=Nil;
+  Quiet:=False;
+  Batch:=False;
+  OutputFile:='';
+  PPLExt:='ppu';
+  ArBin:='ar';
+  LdBin:='ld';
+  repeat
+    c:=Getopt (ShortOpts);
+    Case C of
+ EndOfOptions : break;
+      's' : MakeStatic:=True;
+      'o' : OutputFile:=OptArg;
+      'd' : DestPath:=OptArg;
+      'e' : PPLext:=OptArg;
+      'q' : Quiet:=True;
+      'w' : begin
+              ArBin:='arw';
+              LdBin:='ldw';
+            end;
+      'b' : Batch:=true;
+      '?' : Usage;
+      'h' : Usage;
+    end;
+  until false;
+{ Test filenames on the commandline }
+  if (OptInd>Paramcount) then
+   Error('Error: no input files',true);
+  if (OptInd<ParamCount) and (OutputFile='') then
+   Error('Error: when moving multiple units, specify an output name.',true);
+{ alloc a buffer }
+  GetMem (Buffer,Bufsize);
+  If Buffer=Nil then
+   Error('Error: could not allocate memory for buffer.',true);
+{ fix filename }   
+{$ifdef linux}
+  if Copy(OutputFile,1,3)<>'lib' then
+   OutputFile:='lib'+OutputFile;
+{$endif}
+end;
+
+
+
+
+var
+  i : longint;
+begin
+  ProcessOpts;
+{ Write Header }
+  if not Quiet then
+   begin
+     Writeln(Title+' '+Version);
+     Writeln(Copyright);
+     Writeln;
+   end;
+{ Check if shared is allowed }
+{$ifndef linux}
+  if arbin<>'arw' then
+   begin
+     Writeln('Warning: shared library not supported for Go32, switching to static library');
+     MakeStatic:=true;
+   end;
+{$endif}
+{ fix the libext and outputfilename }
+  if Makestatic then
+   LibExt:=StaticLibExt
+  else
+   LibExt:=SharedLibExt;
+  if OutputFile='' then
+   OutPutFile:=Paramstr(OptInd);
+  OutputFile:=ForceExtension(OutputFile,LibExt);
+{ Open BatchFile }
+  if Batch then
+   begin
+     Assign(BatchFile,'pmove'+BatchExt);
+     Rewrite(BatchFile);
+   end;
+{ Process Files }
+  i:=OptInd;
+  While (i<=ParamCount) and Dofile(AddExtension(Paramstr(i),PPUExt)) do
+   Inc(i);
+{ Do Linking stage }
+  DoLink;
+{ Close BatchFile }
+  if Batch then
+   begin
+     if Not Quiet then
+      Writeln('Writing pmove'+BatchExt);
+     Close(BatchFile);
+{$ifdef Linux}
+     ChMod('pmove'+BatchExt,493);
+{$endif}
+   end;
+{ The End }
+  if Not Quiet then
+   Writeln('Done.');
+end.
+{
+  $Log$
+  Revision 1.1  1999-05-12 16:11:39  peter
+    * moved
+
+  Revision 1.3  1998/08/17 10:26:30  peter
+    * updated for new shared/static style
+
+  Revision 1.2  1998/06/18 10:47:55  peter
+    * new for v15
+}

utils/ptop.pp

@@ -0,0 +1,161 @@
+
+Program PtoP;
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999 by Michael Van Canneyt, member of 
+    the Free Pascal development team
+
+    Pascal pretty print program
+    
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+Uses PtoPu,Objects,getopts;
+
+Var 
+  Infilename,OutFileName,ConfigFile : String;
+  BeVerbose : Boolean;
+  TheIndent,TheBufSize : Integer;
+  
+Function StrToInt(Const S : String) : Integer;
+
+Var Code : integer;
+
+begin
+  Val(S,StrToInt,Code);
+  If Code<>0 then StrToInt:=0;
+end;
+  
+Procedure Usage;
+
+begin
+  Writeln ('ptop : Usage : ');
+  Writeln ('ptop [-v] [-i indent] [-b bufsize ][-c optsfile] infile outfile');
+  Writeln ('     converts infile to outfile.');
+  Writeln ('     -c : read options from optsfile');
+  Writeln ('     -i : Set number of indent spaces.');
+  Writeln ('     -b : Use buffers of size bufsize');
+  Writeln ('     -v : be verbose');
+  writeln ('ptop -g ofile');
+  writeln ('     generate default options file');
+  Writeln ('ptop -h : This help');
+  halt(0);
+end;
+
+Procedure Genopts;
+
+Var S : PBufStream;
+
+begin
+  S:=New(PBufStream,Init(ConfigFile,stCreate,255));
+  GeneratecfgFile(S);
+  S^.Close;
+  S^.Done;
+end;
+
+Procedure ProcessOpts;
+
+Var c : char;
+
+begin
+  { Set defaults }
+  Infilename:='';
+  OutFileName:='';
+  ConfigFile:=''; 
+  TheIndent:=2;
+  TheBufSize:=255;
+  BeVerbose:=False;
+  Repeat
+    c:=getopt('i:c:g:b:hv');
+    case c of 
+      'i' : begin
+            TheIndent:=StrToInt(OptArg);
+            If TheIndent=0 then TheIndent:=2;
+            end;
+      'b' : begin
+            TheBufSize:=StrToInt(OptArg);
+            If TheBufSize=0 then TheBufSize:=255;
+            end;
+      'c' : ConfigFile:=OptArg;
+      'g' : begin
+            ConfigFIle:=OptArg;
+            GenOpts;
+            halt(0);
+            end;
+      'h' : usage;
+      'v' : BeVerbose:=True;
+    else
+    end;
+  until c=endofoptions;
+  If optind<=paramcount then
+    begin
+    InFileName:=paramstr(OptInd);
+    Inc(optind);
+    If OptInd<=paramcount then
+      OutFilename:=Paramstr(OptInd);
+    end;
+end; { Of ProcessOpts }
+
+Var DiagS : PMemoryStream;
+    InS,OutS,cfgS : PBufSTream;
+    PPrinter : TPrettyPrinter;
+    P : Pchar;
+    i : longint;
+    
+begin
+  ProcessOpts;
+  If (Length(InfileName)=0) or (Length(OutFileName)=0) Then
+    Usage;
+  Ins:=New(PBufStream,Init(InFileName,StopenRead,TheBufSize));
+  OutS:=New(PBufStream,Init(OutFileName,StCreate,TheBufSize));
+  If BeVerbose then
+    diagS:=New(PMemoryStream,Init(1000,255))
+  else
+    DiagS:=Nil;
+  If ConfigFile<>'' then
+    CfgS:=New(PBufStream,Init(ConfigFile,StOpenRead,TheBufSize))
+  else 
+    CfgS:=Nil;
+  PPrinter.Create;
+  PPrinter.Indent:=TheIndent;
+  PPrinter.Ins:=Ins;
+  PPrinter.outS:=OutS;
+  PPrinter.cfgS:=CfgS;
+  PPrinter.DiagS:=DiagS;
+  PPrinter.PrettyPrint;
+  If Assigned(DiagS) then
+    begin
+    I:=DiagS^.GetSize;
+    DiagS^.Seek(0);
+    getmem (P,I+1);
+    DiagS^.Read(P[0],I);
+    P[I]:=#0;
+    Writeln (stderr,P);
+    Flush(stderr);
+    DiagS^.Done;
+    end;
+  If Assigned(CfgS) then 
+    CfgS^.Done;
+  Ins^.Done;
+  OutS^.Done;
+end.
+
+{
+  $Log$
+  Revision 1.1  1999-05-12 16:11:39  peter
+    * moved
+
+  Revision 1.3  1999/03/25 16:52:29  michael
+  + Implemented Delphi keywords and delphi comments
+
+  Revision 1.2  1999/03/23 13:47:47  michael
+  Added GPL and log
+
+}