initial import

git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@1 3ad0048d-3df7-0310-abae-a5850022a9f2

1 files changed, 173 insertions, 0 deletions

diff --git a/utils/tply/lexmsgs.pas b/utils/tply/lexmsgs.pas
new file mode 100644
index 0000000000..1a16c81d1d
--- /dev/null
+++ b/utils/tply/lexmsgs.pas
@@ -0,0 +1,173 @@
+{
+  TP Lex message and error handling module
+  Note: this module should be USEd by any module using the heap during
+        initialization, since it installs a heap error handler (which
+        terminates the program with fatal error `memory overflow').
+
+
+  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: 1.3 $
+$Modtime: 96-08-01 8:52 $
+
+$History: LEXMSGS.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.
+
+}
+
+
+unit LexMsgs;
+
+interface
+
+
+var errors, warnings : Integer;
+  (* - current error and warning count *)
+procedure error(msg : String; pos : Integer);
+  (* - print current input line and error message (pos denotes position to
+       mark in source file line) *)
+procedure warning(msg : String; pos : Integer);
+  (* - print warning message *)
+procedure fatal(msg : String);
+  (* - writes a fatal error message, erases Lex output file and terminates
+       the program with errorlevel 1 *)
+
+const
+
+(* sign-on and usage message: *)
+
+sign_on = 'TP Lex Version 4.1a [April 2000], Copyright (c) 1990-2000 Albert Graef';
+{$ifdef Unix}
+usage   = 'Usage: plex [options] lex-file[.l] [output-file[.pas]]';
+{$else}
+usage   = 'Usage: lex [options] lex-file[.l] [output-file[.pas]]';
+{$endif}
+options = 'Options: -v verbose, -o optimize';
+
+(* command line error messages: *)
+
+invalid_option                  = 'invalid option ';
+illegal_no_args                 = 'illegal number of parameters';
+
+(* syntax errors: *)
+
+unmatched_lbrace                = '101: unmatched %{';
+syntax_error                    = '102: syntax error';
+unexpected_eof                  = '103: unexpected end of file';
+
+(* semantic errors: *)
+
+symbol_already_defined          = '201: symbol already defined';
+undefined_symbol                = '202: undefined symbol';
+invalid_charnum                 = '203: invalid character number';
+empty_grammar                   = '204: empty grammar?';
+
+(* fatal errors: *)
+
+cannot_open_file                = 'FATAL: cannot open file ';
+write_error                     = 'FATAL: write error';
+mem_overflow                    = 'FATAL: memory overflow';
+intset_overflow                 = 'FATAL: integer set overflow';
+sym_table_overflow              = 'FATAL: symbol table overflow';
+pos_table_overflow              = 'FATAL: position table overflow';
+state_table_overflow            = 'FATAL: state table overflow';
+trans_table_overflow            = 'FATAL: transition table overflow';
+macro_stack_overflow            = 'FATAL: macro stack overflow';
+
+implementation
+
+uses LexBase;
+
+procedure position(var f : Text;
+            lineNo : integer;
+            line : String;
+            pos : integer);
+  (* writes a position mark of the form
+     gfilename (lineno): line
+                          ^
+     on f with the caret ^ positioned at pos in line
+     a subsequent write starts at the next line, indented with tab *)
+  var
+    line1, line2 : String;
+  begin
+    (* this hack handles tab characters in line: *)
+    line1 := intStr(lineNo)+': '+line;
+    line2 := blankStr(intStr(lineNo)+': '+copy(line, 1, pos-1));
+    writeln(f, line1);
+    writeln(f, line2, '^');
+    write(f, tab)
+  end(*position*);
+
+procedure error(msg : String; pos : Integer);
+  begin
+    inc(errors);
+    writeln;
+    position(output, lno, line, pos);
+    writeln(msg);
+    writeln(yylst);
+    position(yylst, lno, line, pos);
+    writeln(yylst, msg);
+    if ioresult<>0 then ;
+  end(*error*);
+
+procedure warning(msg : String; pos : Integer);
+  begin
+    inc(warnings);
+    writeln;
+    position(output, lno, line, pos);
+    writeln(msg);
+    writeln(yylst);
+    position(yylst, lno, line, pos);
+    writeln(yylst, msg);
+    if ioresult<>0 then ;
+  end(*warning*);
+
+procedure fatal(msg : String);
+  begin
+    writeln;
+    writeln(msg);
+    close(yyin); close(yyout); close(yylst); erase(yyout);
+    halt(1)
+  end(*fatal*);
+
+{$ifndef fpc}
+{$IFNDEF Win32}
+function heapErrorHandler ( size : Word ): Integer; far;
+  begin
+    if size>0 then
+      fatal(mem_overflow) (* never returns *)
+    else
+      heapErrorHandler := 1
+  end(*heapErrorHandler*);
+{$ENDIF}
+{$endif}
+
+begin
+  errors := 0; warnings := 0;
+{$ifndef fpc}
+{$IFNDEF Win32}
+  (* install heap error handler: *)
+  heapError := @heapErrorHandler;
+{$ENDIF}
+{$endif}
+end(*LexMsgs*).