{****************************************************************************
Copyright (c) 1993,96 by Florian Klaempfl
****************************************************************************}
{$ifdef tp}
{$M 38000,16384,32000}
{E+,N+}
{$endif}
program pp;
uses
globals,systems,parser,dos,scanner,asmgen,symtable,
{$ifdef tp}
objects,
{$endif}
tree;
const
copyright = 'Copyright (c) 1993,96 by FP Klaempfl';
{$ifdef inc_date}
released = {$I C:\PASDATE.INC}; { released sollte ein String mit }
{ dem aktuellen Datum sein, }
{ bei mir wird PASDATE.INC jeden Tag }
{ neu in der AUTOEXEC.BAT erzeugt }
{$endif}
procedure error(const s : string);
begin
case language of
'D' : writeln('Fehler: ',s);
'E' : writeln('error: ',s);
end;
halt(1);
end;
procedure init;
var
s,opts : string;
p : pathstr;
d : dirstr;
n : namestr;
i,j : integer;
resf : text;
res,endofparas : boolean;
procedure illparas;
begin
case language of
'D' : begin
write('Illegaler Parameter: ',opts);
writeln(' Aufruf mit -? gibt Liste der Optionen aus');
end;
'E' : begin
write('illegal parameter: ',opts);
writeln(' -? writes help pages');
end;
end;
halt(1);
end;
procedure printhilfe_d;
var
s : string;
begin
{$ifdef tp}
writeln('PPC [Optionen] <inputfile> [Optionen]');
{$else}
writeln('PPC386 [Optionen] <inputfile> [Optionen]');
{$endif}
writeln(' + schaltet eine Option ein, - ab');
writeln(' mit * markierte Optionen haben momentan keine Wirkung');
writeln(' mit ! markierte Optionen nur teilweise implementiert');
writeln(' -a+ Ausgabe einer Assemblerdatei und benutzt externen Assembler');
{$ifdef tp}
writeln(' -b+ Der Compiler benutzt EMS => geringere Geschwindigkeit');
{$endif}
writeln('* -B Browseroptionen');
writeln(' * -Ba alle Informationen');
writeln(' * -Bg globale Informationen');
writeln(' * -Bl lokale Informationen');
writeln(' -C Codegeneratoroptionen');
writeln(' * -Ca automatischer Aufruf von Kon- und Destruktoren');
writeln(' * -Ce es werden keine Laufzeit-Fehler generiert,');
writeln(' sondern stattdessen Exceptions erzeugt');
writeln(' -Chxxxx xxxx gibt die maximale Heapgröße in Bytes an ');
writeln(' (muß kleiner 67107840 und größer 1023 sein; 4000000 Default)');
writeln(' -Ci Ein-,Ausgabeüberprüfung');
writeln(' -Co testet auf Überläufe bei Integer-Operationen');
writeln(' -Cr Test auf Bereichsüberschreitungen');
writeln(' -Csxxxx gibt die maximale Stackgröße in Bytes an (nur OS/2)');
writeln(' (muß kleiner 67107840 und größer 1023 sein; 8096 Default)');
writeln(' -C3 Optimierung für i386');
writeln(' -C4 Optimierung für i486');
writeln(' -dxxx definiert das Symbol xxx');
{$ifdef tp}
{$else}
writeln;
{$endif}
write('*** Weiter mit Return. ***');
readln(s);
writeln(' -C5 Optimierung für Pentium');
writeln(' -D steuert die Erzeugung einer DEF-Datei unter OS/2');
writeln(' -Ddxxxx xxxx ist Beschreibung');
writeln(' -Do erzeuge DEF-Datei');
writeln(' -Dw PM-Anwendung');
writeln(' -g Es werden Debuggerinformationen erzeugt');
writeln(' -F leitet Ausgaben um');
writeln(' -Fexxxx leitet Fehlermeldungen nach xxxx um');
writeln(' -L Sprache');
writeln(' -LD Deutsch');
writeln(' -LE Englisch');
writeln(' -l Ausgabe des Programmlogos');
writeln(' -i Programminformation');
writeln;
writeln(' -O Optimiereroptionen');
writeln(' -Oa einfache Optimierungen');
writeln(' -Og Optimierung auf Größe');
writeln(' -OG Optimierung auf Geschwindigkeit');
writeln(' -Ox maximale Optimierung');
writeln(' -q- Der Compiler zeigt die Fortschritte beim Übersetzen an');
writeln(' -S Syntaxoptionen');
writeln(' -Sa Einstellung der Ausdruckbehandlung');
writeln(' eine höheres Level schließt die unteren ein');
writeln(' -Sa0 nur ANSI-Pascalausdrücke erlaubt');
write('*** Weiter mit Return. ***');
readln(s);
writeln(' -Sa1 Funktionsresultate muessen nicht zugewiesen werden');
writeln(' -Sa2 @-Operator liefert einen typisierten Pointer');
writeln(' -Sa4 typisierte Zuweisungsrückgabewerte');
writeln(' -Sa9 auch seiteneffektlose Ausdrücke erlaubt');
writeln(' -Sg die Verwendung von LABEL und GOTO ist erlaubt');
writeln(' -Sm Makros wie in C werden unterstützt');
writeln(' -Sn keine Exceptionunterstützung');
writeln(' -Ss der Name von Konstruktoren muß immer init sein');
writeln(' der Name von Destruktoren muß immer done sein');
writeln(' -T Zielbetriebssystem');
writeln(' -TDOS DOS-Extender von DJ Delorie');
writeln(' -TOS2 OS/2');
writeln(' ! -TLINUX Linux');
writeln(' ! -TWin32 Windows 32 Bit');
writeln(' -U Unit-Optionen');
writeln(' -Un der Name der Unit wird nicht überprüft');
writeln(' -Us eine System-Unit wird übersetzt');
writeln(' -h,-? zeigt diesen Hilfebildschirm');
halt(1);
end;
procedure printhilfe_e;
var
s : string;
begin
{$ifdef tp}
writeln('PPC [options] <inputfile> [options]');
{$else}
writeln('PPC386 [options] <inputfile> [options]');
{$endif}
writeln(' + switch option on, - off');
writeln(' with * marked options have no effect');
writeln(' with ! marked options are only partial implemented');
writeln(' -a+ generate asm file and uses AS.EXE to assemble');
{$ifdef tp}
writeln(' -b+ use EMS');
{$endif}
writeln('* -B browser options');
writeln(' * -Ba ');
writeln(' * -Bg ');
writeln(' * -Bl ');
writeln(' -C code generation options');
writeln(' * -Ca ');
writeln(' * -Ce ');
writeln(' ');
writeln(' -Chxxxx xxxx bytes heap ');
writeln(' (must be less than 67107840 und greater than 1023');
writeln(' -Ci IO-checking');
writeln(' -Co check overflow of integer operations');
writeln(' -Cr range checking');
writeln(' -Csxxxx stack size (only OS/2)');
writeln(' ');
writeln(' -C3 optimize for i386');
writeln(' -C4 optimize for i486');
writeln(' -dxxx defines the symbol xxx');
{$ifdef tp}
{$else}
writeln;
{$endif}
write('*** press return ***');
readln(s);
writeln(' -C5 optimizations for pentium (tm)');
writeln(' -D controlls the generation of DEF file (only OS/2)');
writeln(' -Ddxxxx xxxx is the description');
writeln(' -Do generate DEF file');
writeln(' -Dw PM application');
writeln(' -g generate debugger informations');
writeln(' -F redirect output');
writeln(' -Fexxxx redirect error output to xxxx');
writeln(' -L set language');
writeln(' -LD german');
writeln(' -LE english');
writeln(' -l write logo');
writeln(' -i information');
writeln;
writeln(' -O optimizations');
writeln(' -Oa simple o');
writeln(' -Og optimize for size');
writeln(' -OG optimize for time');
writeln(' -Ox optimize max');
writeln(' -q- write some information when compiling');
writeln(' -S syntax options');
writeln(' -Sa semantic check of expressions');
writeln(' a higher level includes the lower');
writeln(' -Sa0 only ANSI pascal expressions are allowed');
write('*** press return ***');
readln(s);
writeln(' -Sa1 functions results havn''t to be assigned to variables');
writeln(' -Sa2 @-operator returns typed pointer');
writeln(' -Sa4 assigment results are typed (allows a:=b:=0)');
writeln(' -Sa9 allows expressions with no side effect');
writeln(' -Sg allows LABEL and GOTO');
writeln(' -Sm support macros like C');
writeln(' -Sn no exception support');
writeln(' -Ss the name of constructors must be init');
writeln(' the name of destructors must be done');
writeln(' -T target operating system');
writeln(' -TDOS DOS extender by DJ Delorie');
writeln(' -TOS2 OS/2 2.x');
writeln(' ! -TLINUX Linux');
writeln(' ! -TWin32 Windows 32 Bit');
writeln(' -U unit options');
writeln(' -Un don''t check the unit name');
writeln(' -Us compile a system unit');
writeln(' -h,-? shows this help');
halt(1);
end;
procedure getparastring;
begin
endofparas:=false;
if res then
begin
readln(resf,opts);
if eof(resf) then
begin
close(resf);
res:=false;
end
end
else
begin
if i<paramcount then
begin
inc(i);
if i=paramcount then
endofparas:=true;
opts:=paramstr(i);
if opts[1]='@' then
begin
res:=true;
assign(resf,copy(opts,2,length(opts)-1));
reset(resf);
getparastring;
end;
end;
end;
end;
procedure info_d;
begin
writeln('FPKPascal Version ',version,' ',copyright);
{$ifdef inc_date}
writeln('Freigegeben am: ',released);
{$endif}
writeln('Compiler: FP Klämpfl');
writeln('Runtime-Library: FP Klämpfl und MH Spiegel');
{writeln('Editor: **********');}
writeln('Dieses Programm darf verwenden, verändert und weiter-');
writeln('gegebenwerden, solange daraus niemand finanzielle Vorteile');
writeln('entstehen. Beim Weitergeben darf eine Kopiergebühr');
writeln('von maximal 15 DM verlangt werden (inkl. aller dazu-');
writeln('gehörigen Leistungen wie Datenträger...)');
writeln('Sollte das Programm kommerziell eingesetzt werden,');
writeln('so ist mit mir zwecks Lizenzgebühren Verbindung');
writeln('aufzunehmen. Adresse siehe unten');
writeln('Wenn Sie im Programm einen Fehler entdecken oder ');
writeln('Verbesserungsvorschläge haben, so informieren Sie');
writeln('bitte mich (Fehler bitte mit Angabe der Compiler-');
writeln('version und problematischem Quelltext):');
writeln;
writeln(' Florian Klämpfl');
writeln(' Feldstr. 4');
writeln(' 91096 Möhrendorf');
writeln(' Deutschland');
writeln;
writeln(' EMail: fnklaemp@cip.ft.uni-erlangen.de');
halt(1);
end;
procedure info_e;
begin
writeln('FPKPascal Version ',version,' ',copyright);
writeln;
writeln('This program can be modified, used and distributed');
writeln('if noboby gets money. A donation for copying of');
writeln('10$ is allowed. Commercial use is not allowed.');
writeln;
writeln('Report bugs,suggestions etc to:');
writeln(' fnklaemp@cip.ft.uni-erlangen.de');
halt(1);
end;
procedure setbool(var b : boolean);
begin
if length(opts)=2 then b:=true
else if length(opts)=3 then
begin
if opts[3]='+' then b:=true
else if opts[3]='-' then b:=false
else illparas;
end
else illparas;
end;
var
code : word;
hs : string;
as_res : text;
mac : pmacrosym;
begin
res:=false;
i:=0;
p:='';
if paramcount=0 then
case language of
'D' : printhilfe_d;
'E' : printhilfe_e;
end;
endofparas:=false;
while not(endofparas) do
begin
getparastring;
if (opts[1]='-') then
begin
case opts[2] of
'h','?' : if length(opts)=2 then
case language of
'D' : printhilfe_d;
'E' : printhilfe_e;
end;
'a' : setbool(writeasmfile);
{$ifdef tp}
'b' : setbool(use_big);
{$endif}
'B' : begin
for j:=3 to length(opts) do
case opts[j] of
'a' : ;
'g' : ;
'l' : ;
else illparas;
end;
end;
'C' : begin
for j:=3 to length(opts) do
case opts[j] of
'a' : ;
'e' : ;
'h' : begin
val(copy(opts,j+1,length(opts)-j),heapsize,code);
if (code<>0) or (heapsize>=67107840) or
(heapsize<1024) then
illparas;
break;
end;
'i' : initswitches:=initswitches+[cs_iocheck];
'o' : initswitches:=initswitches+[cs_check_overflow];
'r' : initswitches:=initswitches+[cs_rangechecking];
's' : begin
val(copy(opts,j+1,length(opts)-j),stacksize,code);
if (code<>0) or (stacksize>=67107840) or
(stacksize<1024) then
illparas;
break;
end;
'3' : opt_processors:=i386;
'4' : opt_processors:=i486;
'5' : opt_processors:=pentium;
else illparas;
end;
end;
'd' : begin
mac:=new(pmacrosym,init(copy(opts,3,255)));
mac^.defined:=true;
macros^.insert(mac);
end;
'D' : begin
for j:=3 to length(opts) do
case opts[j] of
'd' : begin
description:=copy(opts,j+1,length(opts)-j);
break;
end;
'o' : gendeffile:=true;
'w' : genpm:=true;
else illparas;
end;
end;
'F' : begin
for j:=3 to length(opts) do
case opts[j] of
'e' : begin
errortext:=true;
assign(errorfile,
copy(opts,j+1,length(s)-j));
{$I-}
rewrite(errorfile);
{$I+}
if ioresult<>0 then
error('Fehlerlogdatei kann nicht geöffnet werden');
break;
end;
else illparas;
end;
end;
'g' : initswitches:=initswitches+[cs_debuginfo];
'i' : case language of
'D' : info_d;
'E' : info_e;
end;
'l' : begin
if length(opts)<>2 then
illparas;
write('FPKPascal Version ',version);
{$ifdef inc_date}
case language of
'D' : write(' vom ',released);
'E' : write(' of ',released);
end;
{$endif}
writeln;
writeln(copyright);
end;
'L' : begin
if length(opts)<>3 then
illparas;
case opts[3] of
'E' : language:='E';
'D' : language:='D';
else illparas;
end
end;
'q' : setbool(quiet);
'O' : begin
for j:=3 to length(opts) do
case opts[j] of
'a' : initswitches:=initswitches+[cs_optimize];
'g' : initswitches:=initswitches+[cs_littlesize];
'G' : initswitches:=initswitches-[cs_littlesize];
'x' : initswitches:=initswitches+[cs_optimize,
cs_maxoptimieren];
else illparas;
end;
end;
'S' : begin
for j:=3 to length(opts) do
case opts[j] of
'a' : begin
if j<length(opts) then inc(j)
else illparas;
val(opts[j],initexprlevel,code);
if code<>0 then
illparas;
end;
'g' : initswitches:=initswitches+[cs_support_goto];
'm' : initswitches:=initswitches+[cs_support_macros];
'n' : initswitches:=initswitches-[cs_genexceptcode];
's' : initswitches:=initswitches+[cs_checkconsname];
else illparas;
end;
end;
'T' : begin
hs:='';
hs:=copy(opts,3,length(opts)-2);
if not(set_string_target(hs)) then
illparas;
end;
'U' : begin
for j:=3 to length(opts) do
case opts[j] of
's' : initswitches:=initswitches+[cs_compilesystem];
'n' : initswitches:=initswitches+[cs_check_unit_name];
else illparas;
end;
end;
else illparas;
end
end
else if opts[1]='@' then
begin
case language of
'D' : writeln('Response-Dateiangaben in Response-Dateien werden nicht unterstützt');
'E' : writeln('nested response files are not supported');
end;
halt(1);
end
else
begin
if length(p)<>0 then
case language of
'D' : error('Es kann nur eine Quelldatei angegeben werden');
'E' : error('Only one source file supported');
end;
p:=opts;
end;
end;
if p='' then
case language of
'D' : error('Keine Quelldatei angegeben');
'E' : error('No source file name in command line');
end;
p:=upper(p);
fsplit(p,d,n,inputextension);
if inputextension='' then inputextension:='.PP';
inputfile:=n;
inputdir:=d;
if gendeffile then
begin
if target_info.target<>target_OS2 then
case language of
'D' : error('DEF-Datei kann nur für OS/2 erzeugt werden');
'E' : error('DEF file can be created only for OS/2');
end;
assign(defdatei,inputdir+inputfile+'.DEF');
{$I-}
rewrite(defdatei);
{$I+}
if ioresult<>0 then
case language of
'D' : error('DEF-Datei kann nicht erzeugt werden');
'E' : error('DEF file can''t be created');
end;
write(defdatei,'NAME '+inputfile);
if genpm then
write(defdatei,' WINDOWAPI');
writeln(defdatei,#13#10#13#10'PROTMODE'#13#10);
writeln(defdatei,'DESCRIPTION '+''''+description+''''#13#10);
writeln(defdatei,'DATA'#9'MULTIPLE'#13#10);
writeln(defdatei,'STACKSIZE'#9+tostr(stacksize));
writeln(defdatei,'HEAPSIZE'#9+tostr(heapsize)+#13#10);
write(defdatei,'EXPORTS');
end;
end;
function getrealtime : real;
var
h,m,s,s100 : word;
begin
gettime(h,m,s,s100);
getrealtime:=h*3600.0+m*60.0+s+s100/100.0;
end;
var
starttime : single;
data_size : longint;
hs1 : namestr;
hs2 : extstr;
start : real;
oldexit : pointer;
procedure myexit;far;
begin
if gendeffile then
close(defdatei);
{ Fehlerdatei schließen }
if errortext then
close(errorfile);
{$ifdef tp}
if use_big then
symbolstream.done;
if (erroraddr<>nil) then
case exitcode of
203 : begin
erroraddr:=nil;
case language of
'D' : writeln('Nicht genügend Speicher');
'E' : writeln('Out of memory');
end;
end;
202 : begin
erroraddr:=nil;
case language of
'D' : writeln('Stacküberlauf');
'E' : writeln('Stack overflow');
end;
end;
end;
{$endif}
exitproc:=oldexit;
end;
{$ifdef tp}
procedure do_streamerror;far;
begin
if symbolstream.status=-2 then
case language of
'D' : writeln('Nicht genügend EMS-Speicher');
'E' : writeln('Not enough EMS memory');
end
else
case language of
'D' : writeln('Fehler ',symbolstream.status,' bei der Nutzung von EMS');
'E' : writeln('error ',symbolstream.status,' when using EMS');
end;
halt(1);
end;
{$endif}
var
hs3 : string;
i : longint;
begin
start:=getrealtime;
hs3:=paramstr(0);
{$ifdef tp}
{$else}
for i:=1 to length(hs3) do
if hs3[i]='/' then
hs3[i]:='\';
{$endif}
env_ppbin:=getenv('PPBIN');
if not(env_ppbin[length(env_ppbin)]='\') then
env_ppbin:=env_ppbin+'\';
fsplit(hs3,unitpath,hs1,hs2);
{ einige Units initialisieren }
{ inits only node management }
init_tree;
globalsinit;
init_symtable;
{ call *** after *** init_symtable because macros must be init... }
init;
{$ifdef tp}
if use_big then
begin
streamerror:=@do_streamerror;
symbolstream.init(10000,4000000);
if symbolstream.errorinfo=stiniterror then
do_streamerror;
{ Kein String darf die Position 0 haben, da dies ein nil-Pointer ist }
{ also irgendetwas schreiben: }
symbolstream.writestr(@inputfile);
end;
{$endif}
oldexit:=exitproc;
exitproc:=@myexit;
if not quiet then
begin
writeln(hs3);
writeln(inputdir+inputfile+inputextension);
end;
initscanner(inputdir+inputfile+inputextension);
asmgeninit;
compile('','');
if not(quiet) then
begin
if codegeneration then
begin
if writeasmfile then
case language of
'D' : write(asmlines,' Zeilen erzeugt, ');
'E' : write(asmlines,' lines generated, ');
end;
case language of
'D' : write(abslines,' Zeilen übersetzt, ');
'E' : write(abslines,' lines compiled, ');
end;
{$ifdef tp}
writeln(getrealtime-start:0:1,'s');
{$else}
writeln(getrealtime-start,'s');
{$endif}
end;
end;
halt(0);
end.
