{$ifdef tp}
{E+,N+}
{$endif}
{****************************************************************************
Copyright (c) 1993,96 by Florian Klaempfl
****************************************************************************}
unit globals;
interface
uses
cobjects,dos,strings,objects;
const
{ version string }
version = '0.6.2'
{$ifdef tp}
{$else}
+' 386'
{$endif}
;
{ Signifikante ID-Länge }
maxidlen = 64;
{$ifdef tp}
maxinputlen = 10000;
{$else}
{ größer sind auch meine größten Quelltexte }
{ nicht }
maxinputlen = 512*1024;
{$endif}
type
{ Puffer für die Eingabe}
tinputbuffer = array[0..maxinputlen] of char;
pinputbuffer = ^tinputbuffer;
pinputstack = ^tinputstack;
tinputstack = record
filenotatend : boolean;
f : file;
buffersize : word;
inputbuffer : pinputbuffer;
inputpointer : word;
filename : pstring;
line_no : longint;
next : pinputstack;
end;
{ Fehlerkonstanten }
errorconst = (endoffile,
dupid,
syntax_error,
out_of_mem,
unknown_id,
ill_character,
too_long_source,
inline_not_supported,
near_ignored,
far_ignored,
interrupt_ignored,
priv_meth_not_virtual,
const_cannot_priv,
dest_cannot_priv,
id_not_found,
no_local_objects,
no_anonym_objects,
type_id_expect,
id_already_type,
type_id_not_defined,
error_in_type,
statement_expect,
error_in_integer,
error_in_expression,
type_mismatch,
too_complex_expr,
continue_not_allowed,
break_not_allowed,
exceptions_not_allowed,
invalid_qualifizier,
invalid_for_var,
ordinal_expect,
upper_l_lower,
ill_unit_name,
malformed_unit,
error_reading_unit,
rec_unit_def,
too_much_units,
ill_char_const,
overloaded_no_proc,
same_parameters,
no_para_match,
too_much_matches,
proc_must_handleexceptions,
forward_not_resolved,
cannot_open_input,
header_dont_match,
ill_field,
para_too_big,
too_much_lexlevel,
ill_switch,
cannot_open_incfile,
type_must_be_rec_or_class,
unit_not_found,
dup_enum,
pointer_expect,
not_same_target,
type_const_not_possible,
double_caselabel,
range_check_error,
ill_type_cast,
class_type_expect,
no_overloaded_procvars,
cannot_open_asmfile,
string_too_long,
object_type_expect,
method_id_expect,
header_dont_match_any_member,
take_extended_syntax,
file_must_call_by_referenz,
string_exceed_line,
ill_unit_version,
error_in_real,
no_paras_2_destructor,
fail_only_in_constructor,
only_pack_records_,
too_much_endifs,
endif_expect,
var_must_be_referenz,
def_only_in_program,
overloaded_are_not_both_virtual,
ol_meths_not_same_ret,
overloaded_support_exceptions_false,
dont_call_exported_direct,
dont_nest_export,
methods_dont_be_export,
self_not_in_method,
call_by_ref_without_typeconv,
typeid_here_not_allowed,
class_expected,
no_super_class,
generic_methods_only_in_methods,
there_is_no_super_class,
pointer_to_class_expect,
member_cd_call_from_method,
only_one_destructor,
expr_have_to_be_constructor_call,
id_no_member,
expr_have_to_be_destructor_call,
a_error_const,
illsettype,
illsetexpr,
typeconflict_in_set,
ill_colon_qualifier,
false_with_expr,
use_int_div_int_op,
cannot_write_unitfile,
invalid_record_const,
konstrucname_init,
destrucname_done,
set_element_are_not_comp,
ill_label_pos,
label_not_found,
goto_label_not_support,
set_expected,
id_is_no_label_id,
label_already_defined,
label_not_defined,
cons_always_obj,
asmerror,
symbol_not_used,
void_function,
inefficient_code,
unreachable_code,
overloaded_must_be_all_global,
operator_not_overloaded);
ttoken = (PLUS,MINUS,STAR,SLASH,EQUAL,GT,LT,LECKKLAMMER,RECKKLAMMER,
POINT,COMMA,LKLAMMER,RKLAMMER,COLON,SEMICOLON,CARET,
KLAMMERAFFE,ASSIGNMENT,UNEQUAL,LTE,GTE,POINTPOINT,
ID,REALNUMBER,_EOF,INTCONST,CSTRING,CCHAR,
_ABSOLUTE,_AND,_ARRAY,_ASM,_ASSEMBLER,_BEGIN,
_BREAK,_CASE,_CONST,_CONSTRUCTOR,_CONTINUE,
_DESTRUCTOR,_DISPOSE,_DIV,_DO,_DOWNTO,_ELSE,_END,
_EXIT,_EXPORT,_EXTERNAL,_FAIL,_FALSE,_FAR,{ _FILE,} _FOR,
_FORWARD,_FUNCTION,_GOTO,_IF,_IMPLEMENTATION,_IN,
_INHERITED,_INLINE,_INTERFACE,_INTERRUPT,
_LABEL,_MOD,_NEAR,_NEW,_NIL,_NOT,_OBJECT,
_OF,_OTHERWISE,_OR,_PACKED,_PRIVATE,
_PROCEDURE,_PROGRAM,_PROTECTED,_PUBLIC,
_RECORD,_REPEAT,_SELF,
_SET,_SHL,_SHR,_STRING,_THEN,_TO,
_TRUE,_TYPE,_UNIT,_UNTIL,
_USES,_VAR,_VIRTUAL,_WHILE,_WITH,_XOR,
{ since Delphi 2 }
_CLASS,_EXCEPT,_TRY,_ON,_AS,_IS,
{ for operator overloading }
_OPERATOR
);
tcswitch = (cs_check_overflow,cs_genexceptcode,cs_maxoptimieren,
cs_omitstackframe,cs_littlesize,cs_optimize,cs_debuginfo,
cs_compilesystem,cs_rangechecking,cs_warnings,cs_support_goto,
cs_support_macros,cs_check_unit_name,cs_iocheck,cs_checkconsname);
tcswitches = set of tcswitch;
stringid = string[maxidlen];
pdouble = ^double;
pbyte = ^byte;
plongint = ^longint;
tprocessors = (i386,i486,pentium);
tcompilerstate = record
switches : tcswitches;
exprlevel : byte;
end;
var
inputdir : string[80];
inputfile : string;
inputextension : extstr;
linkresponse : text;
writeasmfile,quiet : boolean;
{ contains the enviroment variable PPBIN }
env_ppbin : string;
initswitches : tcswitches;
initexprlevel : byte;
{ alignement of records }
initpackrecords : word;
{ akt. state }
aktswitches : tcswitches;
aktexprlevel : byte;
aktpackrecords : word;
{ Länge der Quelltextes }
sourcesize : longint;
unitpath : dirstr; { Pfad zur PP.EXE um PPU-Dateien }
{ in diesem Verzeichnis suchen zu }
{ koennen }
inputstack : pinputstack;
abslines : longint; { Anzahl der wirklich uebersetzten Zeilen }
exterror : pchar; { erweiterte Informationen ueber einen Fehler }
codegeneration : boolean; { wird auf false gesetzt wenn einfacher }
{ Fehler auftritt und damit keine Ausgabe }
{ erfolgen soll }
errorcount : word; { Anzahl der aufgetretenen Fehler }
{$ifdef TP}
use_big : boolean; { true, wenn die "große"-Compilerversion }
{ gewählt werden soll, mit EMS-Nutzung }
symbolstream : temsstream; { EMS-Stream, in welchem bei use_big=true }
{ die Symbole abgelegt werden }
{$endif}
gendeffile : boolean; { true, wenn eine DEF-Datei erzeugt werden soll }
genpm : boolean; { true, wenn in DEF-Datei WINDOWAPI angegeben werden soll }
description : string; { gibt die Beschreibung in der DEF-Datei an }
defdatei : text; { Textdatei für DEF-Datei }
errortext : boolean;
errorfile : text;
linkofiles : tstringcontainer;
opt_processors : tprocessors;
{ true, if C styled macros should be allowed }
support_macros : boolean;
language : char;
procedure warning(w : errorconst);
procedure error(w : errorconst);
procedure _asm_error(w : errorconst;l : longint);
procedure fatalerror(w : errorconst);
procedure internalerror(i : integer);
function upper(const s : string) : string;
procedure uppervar(var s : string);
function tostr(i : longint) : string;
function tostr_with_plus(i : longint) : string;
procedure globalsinit;
function ibm2ascii(const s : string) : string;
function double2str(d : double) : string;
procedure setstring(var p : pchar;const s : string);
function min(a,b : longint) : longint;
function max(a,b : longint) : longint;
{ sucht Datei mit Namen f in den in path angegebenen Verzeichnissen }
function search(const f : string;path : string;var b : boolean) : string;
{$ifdef debug}
{ if the pointer don't point to the heap then write an error }
function assigned(p : pointer) : boolean;
{$endif}
type
perrorrec = ^terrorrec;
terrorrec = record
data : pstring;
next : perrorrec;
end;
var
errorlist : perrorrec;
implementation
{$ifdef debug}
function assigned(p : pointer) : boolean;
var
lp : longint;
begin
lp:=longint(seg(p^))*16+longint(ofs(p^));
if (lp<>0) and
((lp<longint(seg(heaporg^))*16+longint(ofs(heaporg^))) or
(lp>longint(seg(heapptr^))*16+longint(ofs(heapptr^)))) then
runerror(230);
assigned:=lp<>0;
end;
{$endif}
function min(a,b : longint) : longint;
begin
if a>b then
min:=b
else min:=a;
end;
function max(a,b : longint) : longint;
begin
if a<b then
max:=b
else max:=a;
end;
function geterrormsg(i : integer) : string;
var
t : text;
s : string;
hp : perrorrec;
last : perrorrec;
errnr : integer;
begin
if errorlist=nil then
begin
assign(t,unitpath+'ERROR'+language+'.MSG');
{$i-}
reset(t);
{$i+}
errnr:=ioresult;
if errnr<>0 then
begin
case language of
'D' : begin
if errortext then
begin
writeln(errorfile,'Fehler ',i);
writeln(errorfile,'**** Fehlertextdatei ERRORD.MSG nicht gefunden (Fehler ',
errnr,'). *****');
end
else
begin
writeln('Fehler ',i);
writeln('**** Fehlertextdatei ERRORD.MSG nicht gefunden (Fehler ',errnr,'). *****');
end;
end;
'E' : begin
if errortext then
begin
writeln(errorfile,'error ',i);
writeln(errorfile,'**** error file ERRORE.MSG not found (error ',errnr,'). *****');
end
else
begin
writeln('error ',i);
writeln('**** error file ERRORE.MSG not found (error ',errnr,'). *****');
end;
end;
end;
halt(1);
end;
while not(eof(t)) do
begin
new(hp);
hp^.next:=nil;
readln(t,s);
hp^.data:=stringdup(s);
if errorlist=nil then
errorlist:=hp
else last^.next:=hp;
last:=hp;
end;
close(t);
end;
hp:=errorlist;
for i:=i downto 1 do
hp:=hp^.next;
geterrormsg:=hp^.data^;
end;
function ibm2ascii(const s : string) : string;
var
i : integer;
hs : string;
b : byte;
begin
hs:='';
for i:=1 to length(s) do
if ((ord(s[i])>127) or (ord(s[i])<32)) or (s[i]='"') then
begin
b:=ord(s[i]);
hs:=hs+'\'+tostr(b div 64);
b:=b mod 64;
hs:=hs+tostr(b div 8);
b:=b mod 8;
hs:=hs+tostr(b);
if (i<length(s)) and
(ord(s[i+1])>=48) and (ord(s[i+1])<=57) then
hs:=hs+'"'#13#10#9'.ascii "';
end
else if s[i]='\' then
hs:=hs+'\\'
else hs:=hs+s[i];
ibm2ascii:=hs;
end;
function double2str(d : double) : string;
var
hs : string;
begin
str(d,hs);
{$ifdef tp}
{ TP fügt bei positiven Zahlen am Anfang }
{ ein Leerzeichen ein, dieses in ein '+' umwandeln }
if hs[1]=' ' then
hs[1]:='+';
{$endif}
double2str:='0d'+hs;
end;
procedure warning(w : errorconst);
begin
if errortext then
write(errorfile,'? ',inputstack^.filename^,'(',inputstack^.line_no,'): ',geterrormsg(longint(w)))
else
write('? ',inputstack^.filename^,'(',inputstack^.line_no,'): ',geterrormsg(longint(w)));
if exterror<>nil then
begin
if errortext then
write(errorfile,' ',exterror)
else
write(' ',exterror);
strdispose(exterror);
exterror:=nil;
end;
if errortext then
writeln(errorfile)
else
writeln;
end;
procedure _asm_error(w : errorconst;l : longint);
begin
inc(errorcount);
if errortext then
write(errorfile,'! assembler:',inputstack^.filename^,'(',l,'): ',geterrormsg(longint(w)))
else
write('! assembler:',inputstack^.filename^,'(',l,'): ',geterrormsg(longint(w)));
if exterror<>nil then
begin
if errortext then
write(errorfile,' ',exterror)
else
write(' ',exterror);
strdispose(exterror);
exterror:=nil;
end;
if errortext then
writeln(errorfile)
else
writeln;
codegeneration:=false;
{ view only 50 errors }
if errorcount>50 then halt(1);
end;
procedure error(w : errorconst);
begin
inc(errorcount);
if errortext then
write(errorfile,'! ',inputstack^.filename^,'(',inputstack^.line_no,'): ',geterrormsg(longint(w)))
else
write('! ',inputstack^.filename^,'(',inputstack^.line_no,'): ',geterrormsg(longint(w)));
if exterror<>nil then
begin
if errortext then
write(errorfile,' ',exterror)
else
write(' ',exterror);
strdispose(exterror);
exterror:=nil;
end;
if errortext then
writeln(errorfile)
else
writeln;
codegeneration:=false;
{ view only 50 errors }
if errorcount>50 then halt(1);
end;
procedure fatalerror(w : errorconst);
begin
if errortext then
write(errorfile,'!! ',inputstack^.filename^,'(',inputstack^.line_no,'): ',geterrormsg(longint(w)))
else
write('!! ',inputstack^.filename^,'(',inputstack^.line_no,'): ',geterrormsg(longint(w)));
if exterror<>nil then
begin
if errortext then
write(errorfile,' ',exterror)
else
write(' ',exterror);
strdispose(exterror);
exterror:=nil;
end;
if errortext then
writeln(errorfile)
else
writeln;
halt(1);
end;
procedure internalerror(i : integer);
begin
if not(quiet) then writeln;
if errortext then
writeln(errorfile,'# ',inputstack^.filename^,'(',inputstack^.line_no,'): Interner Fehler ',i)
else
writeln('# ',inputstack^.filename^,'(',inputstack^.line_no,'): Interner Fehler ',i);
halt(1);
end;
function upper(const s : string) : string;
var i : integer;
hs : string;
begin
hs:='';
for i:=1 to length(s) do
hs:=hs+upcase(s[i]);
upper:=hs;
end;
procedure uppervar(var s : string);
var
i : integer;
begin
for i:=1 to length(s) do
s[i]:=upcase(s[i]);
end;
function tostr(i : longint) : string;
var hs : string;
begin
str(i,hs);
tostr:=hs;
end;
function tostr_with_plus(i : longint) : string;
var hs : string;
begin
str(i,hs);
if i>=0 then
tostr_with_plus:='+'+hs
else
tostr_with_plus:=hs;
end;
procedure setstring(var p : pchar;const s : string);
begin
{$ifdef TP}
if use_big then
begin
p:=pchar(symbolstream.size);
symbolstream.seek(longint(p));
symbolstream.writestr(@s);
end
else
{$endif TP}
p:=strpnew(s);
end;
function search(const f : string;path : string;var b : boolean) : string;
var
dirinfo : searchrec;
singlepasstring : string;
start,pos : byte;
begin
start:=1;
b:=true;
repeat
pos:=system.pos(';',path);
if pos=0 then
pos:=length(path)+1;
singlepasstring:=copy(path,start,pos-start);
delete(path,start,pos-start+1);
findfirst(singlepasstring+'\'+f,anyfile,dirinfo);
if doserror=0 then
begin
search:=singlepasstring+'\';
exit;
end;
until path='';
b:=false;
end;
procedure globalsinit;
begin
{ set global (for any file) compiler switches }
opt_processors:=i386;
writeasmfile:=false;
quiet:=true;
errortext:=false;
language:='E';
gendeffile:=false;
genpm:=false;
description:='compiled by FPKPascal';
{ set the local switches informations }
initswitches:=[cs_warnings,cs_genexceptcode,cs_check_unit_name];
initexprlevel:=1;
initpackrecords:=2;
{ statistic value }
abslines:=1;
{$ifdef tp}
use_big:=false;
{$endif tp}
{ init container for files to link }
linkofiles.init;
linkofiles.doubles:=false;
{ error management }
{ pointer to error msgs }
errorlist:=nil;
{ extended error description }
exterror:=nil;
{ count of errors }
errorcount:=0;
{ true, if no compiler error }
codegeneration:=true;
end;
end.
