{$ifdef tp}
{E+,N+}
{$endif}
{****************************************************************************
Copyright (c) 1993,96 by Florian Klämpfl
****************************************************************************}
unit parser;
interface
uses
objects,scanner,globals,systems,symtable,tree,cobjects,asmgen,codegen,
asmbl,tempad,dos,types,strings,opt,pass_1,hcodegen;
procedure compile(const path,filename : string);
const
heapsize : longint = 4000000;
stacksize : longint = 8096;
implementation
{$I innr.inc}
var
token : ttoken;
datasize : longint; { Größe des Datensegmentes, wird von proc_unit }
{ oder proc_program gesetzt }
refsymtable : psymtable; { Symboltabelle in welcher die }
{ Unitreferenzen abgelegt werden sollen }
parse_only : boolean; { wird auf true gesetzt, wenn }
{ nur Funktionsköpfe geparst werden sollen }
function befehlsblock : ptree;forward;
function anweisung : ptree;forward;
function typ(const name : stringid) : pdef;forward;
function expr : ptree;forward;
function block : ptree;forward;
procedure proc_head;forward;
procedure formal_parameter_list;forward;
{ versucht das Token i zu consumieren, paßt }
{ das Token nicht, so wird ein Syntaxfehler }
{ ausgegeben }
procedure consume(i : ttoken);
{ gibt einen Syntaxfehler aus }
procedure syntaxerror(const s : string);
begin
exterror:=strpnew(s+' erwartet. ');
error(syntax_error);
end;
const tokens : array[PLUS..CCHAR] of string[12] = (
'+','-','*','/','=','>','<','[',']',
'.',',','(',')',':',';','^',
'@',':=','<>','>=','<=','..',
'Bezeichner','real. Konst.','Dateiende',
'ord. Konst.','Stringkonst.','Charkonst.');
var
j : integer;
begin
if token<>i then
begin
if i<_ABSOLUTE then
syntaxerror(tokens[i])
else
begin
{ um die Programmgröße klein zu halten, }
{ wird für ein Schlüsselwort-Token der }
{ "Text" in der Schlüsselworttabelle }
{ des Scanners nachgeschaut }
for j:=1 to anz_keywords do
if keyword_token[j]=i then
syntaxerror(keyword[j])
end;
end
else
token:=yylex;
end;
{ liest eine Liste durch Komma getrennter Bezeichner }
{ in eine Stringcontainer ein }
function idlist : pstringcontainer;
var
sc : pstringcontainer;
begin
sc:=new(pstringcontainer,init);
repeat
sc^.insert(pattern);
consume(ID);
if token=COMMA then consume(COMMA)
else break
until false;
idlist:=sc;
end;
procedure label_dec;
begin
consume(_LABEL);
if not(cs_support_goto in aktswitches )
then error(goto_label_not_support);
repeat
if (token<>ID) and (token<>INTCONST) then
consume(ID)
else
begin
symtablestack^.insert(new(plabelsym,init(pattern,getlabel)));
consume(token);
end;
if token<>SEMICOLON then consume(COMMA);
until (token<>ID) and (token<>INTCONST);
consume(SEMICOLON);
end;
{ fügt die Symbole aus sc mit def in st ein }
{ entfernt sc! }
procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef);
var
s : string;
begin
s:=sc^.get;
while s<>'' do
begin
st^.insert(new(pvarsym,init(s,def)));
s:=sc^.get;
end;
dispose(sc,done);
end;
{ liest einen einzelnen Stringtyp mit optionaler }
{ Längenangabe und gibt einen Pointer auf die }
{ Definition zurück }
function stringtyp : pdef;
var
p : ptree;
d : pdef;
begin
consume(_STRING);
if token=LECKKLAMMER then
begin
consume(LECKKLAMMER);
p:=expr;
do_firstpass(p);
if not is_constintnode(p) then
error(error_in_expression);
if (p^.value<1) or (p^.value>255) then
begin
error(string_too_long);
p^.value:=255;
end;
consume(RECKKLAMMER);
d:=new(pstringdef,init(p^.value));
end
else d:=new(pstringdef,init(255));
stringtyp:=d;
end;
var
{ Zeiger auf das zuletzt gelesene Typsymbol }
{ (für "forward"-Typen) }
lasttypesym : ptypesym;
{ "Krücken"konstruktion um das Problem zu beheben, daß }
{ der Typ der momentan geparst werdenden Objektdeklaration }
{ als Funktionsparameter verwendet werden kann }
testaktobject : byte;
aktobjectname : stringid;
aktobjectdef : pdef;
{ liest einen Typbezeichner und gibt einen }
{ Pointer auf die Definition zurück }
{ s ist der Name des Typs }
function id_type(var s : string) : pdef;
begin
s:=pattern;
consume(ID);
if (testaktobject=2) and (aktobjectname=pattern) then
begin
id_type:=aktobjectdef;
exit;
end;
getsym(s,true);
if assigned(srsym) then
begin
if srsym^.typ=unitsym then
begin
consume(POINT);
getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
s:=pattern;
consume(ID);
end;
if srsym^.typ<>typesym then
begin
error(type_id_expect);
lasttypesym:=ptypesym(srsym);
id_type:=generrordef;
exit;
end;
end;
lasttypesym:=ptypesym(srsym);
id_type:=ptypesym(srsym)^.definition;
end;
{ liest einen String oder Typbezeichner }
{ und gibt einen Pointer auf die }
{ Definition zurück }
function single_type(var s : string) : pdef;
begin
case token of
_STRING : begin
single_type:=stringtyp;
s:='STRING';
lasttypesym:=nil;
end;
else single_type:=id_type(s);
end;
end;
{ liest die Feldliste eines Records in }
{ symtablestack ein }
{ wenn record=false, dann können auch }
{ Klassenfelder eingelesen werden, da }
{ variante Recordkonstruktionen igno- }
{ riert werden }
{ do_absolute, gibt an, ob ABSOLUTE, }
{ sowie Dateitypen erlaubt sind }
procedure feldliste(is_record : boolean;do_absolute : boolean);
var
sc : pstringcontainer;
s : stringid;
p,casedef : pdef;
hs : string;
{ maxsize enthält maximale Größe eines varianten Astes }
{ startvarrec die Startaddresse des varianten Teiles }
maxsize,startvarrec : longint;
pt : ptree;
old_parse_types : boolean;
begin
old_parse_types:=parse_types;
parse_types:=true;
while token=ID do
begin
sc:=idlist;
consume(COLON);
p:=typ('');
if do_absolute and (token=_ABSOLUTE) then
begin
consume(_ABSOLUTE);
end
else
begin
insert_syms(symtablestack,sc,p);
end;
if token<>SEMICOLON then
break
else
consume(SEMICOLON);
while token=SEMICOLON do
consume(SEMICOLON);
end;
if (token=_CASE) and is_record then
begin
maxsize:=0;
consume(_CASE);
s:=pattern;
getsym(s,false);
{ may be only a type: }
if assigned(srsym) and ((srsym^.typ=typesym) or
{ and with unit qualifier: }
(srsym^.typ=unitsym)) then
begin
casedef:=single_type(hs);
end
else
begin
consume(ID);
consume(COLON);
casedef:=single_type(hs);
symtablestack^.insert(new(pvarsym,init(s,casedef)));
end;
if not is_ordinal(casedef) then
error(ordinal_expect);
consume(_OF);
startvarrec:=symtablestack^.datasize;
repeat
repeat
pt:=expr;
do_firstpass(pt);
if not(pt^.treetype=ordconstn) then
error(error_in_expression);
if token=COMMA then consume(COMMA)
else break;
until false;
consume(COLON);
consume(LKLAMMER);
if token<>RKLAMMER then
feldliste(true,false);
{ calc max variant size }
maxsize:=max(maxsize,symtablestack^.datasize);
symtablestack^.datasize:=startvarrec;
consume(RKLAMMER);
if token<>SEMICOLON then
break
else
consume(SEMICOLON);
while token=SEMICOLON do
consume(SEMICOLON);
until (token=_END) or (token=RKLAMMER);
symtablestack^.datasize:=maxsize;
end;
parse_types:=old_parse_types;
end;
procedure _proc_head(options : word);forward;
procedure constructor_head;
begin
consume(_CONSTRUCTOR);
_proc_head(poconstructor);
if cs_checkconsname in aktswitches then
if aktprocsym^.name<>'INIT' then
error(konstrucname_init);
consume(SEMICOLON);
{ der Rückgabetyp von Konstruktoren ist Boolean }
aktprocsym^.definition^.retdef:=
new(pgrunddef,init(bool8bit,0,1));
end;
procedure destructor_head;
begin
consume(_DESTRUCTOR);
if cs_checkconsname in aktswitches then
if aktprocsym^.name<>'DONE' then
error(destrucname_done);
_proc_head(podestructor);
consume(SEMICOLON);
if assigned(aktprocsym^.definition^.para1) then
error(no_paras_2_destructor);
{ kein Rückgabetyp }
aktprocsym^.definition^.retdef:=voiddef;
end;
function object_dec(const n : stringid) : pdef;
type
tzugriffsmode = (priv,prot,pub);
var
aktzugriffsmode : tzugriffsmode;
there_are_a_destructor : boolean;
procedure object_komponenten;
var
oldparse_only : boolean;
begin
testaktobject:=1;
aktobjectname:=n;
repeat
case token of
ID : feldliste(false,false);
_PROCEDURE,_FUNCTION : begin
oldparse_only:=parse_only;
parse_only:=true;
proc_head;
parse_only:=oldparse_only;
if token=_VIRTUAL then
begin
if aktzugriffsmode=priv then
error(priv_meth_not_virtual);
consume(_VIRTUAL);
consume(SEMICOLON);
aktprocsym^.definition^.options:=
aktprocsym^.definition^.options or povirtualmethod;
end;
end;
_CONSTRUCTOR : begin
if aktzugriffsmode<>pub then
error(const_cannot_priv);
oldparse_only:=parse_only;
parse_only:=true;
constructor_head;
parse_only:=oldparse_only;
end;
_DESTRUCTOR : begin
if there_are_a_destructor then
warning(only_one_destructor);
there_are_a_destructor:=true;
if aktzugriffsmode<>pub then
error(dest_cannot_priv);
oldparse_only:=parse_only;
parse_only:=true;
destructor_head;
parse_only:=oldparse_only;
if token=_VIRTUAL then
begin
consume(_VIRTUAL);
consume(SEMICOLON);
aktprocsym^.definition^.options:=
aktprocsym^.definition^.options or povirtualmethod;
end;
end;
_END,_PROTECTED,_PRIVATE,_PUBLIC : exit;
else error(syntax_error);
end;
until false;
testaktobject:=0;
end;
var
childof : pclassdef;
_class : pclassdef;
begin
there_are_a_destructor:=false;
aktzugriffsmode:=pub;
if (symtablestack^.symtabletype and $3fff<>globalsymtable) and
(symtablestack^.symtabletype and $3fff<>staticsymtable) then
error(no_local_objects);
if n='' then error(no_anonym_objects);
consume(_OBJECT);
childof:=nil;
if token=LKLAMMER then
begin
consume(LKLAMMER);
if token<>ID then
consume(ID);
getsym(pattern,true);
if (srsym^.typ<>typesym) and
(ptypesym(srsym)^.definition^.deftype<>classdef) then
begin
error(class_type_expect);
childof:=nil;
end
else childof:=pclassdef(ptypesym(srsym)^.definition);
consume(ID);
consume(RKLAMMER);
end;
_class:=new(pclassdef,init(n,childof));
aktobjectdef:=_class;
{ Default: public }
aktzugriffsmode:=pub;
_class^.publicsyms^.next:=symtablestack;
symtablestack:=_class^.publicsyms;
procinfo._class:=_class;
while token<>_END do
begin
if token=_PRIVATE then
begin
consume(_PRIVATE);
{
symtablestack:=symtablestack^.next;
_class^.privatesyms^.next:=symtablestack;
symtablestack:=_class^.privatesyms;
aktzugriffsmode:=priv;
}
end;
if token=_PROTECTED then
begin
consume(_PROTECTED);
{
symtablestack:=symtablestack^.next;
_class^.protectedsyms^.next:=symtablestack;
symtablestack:=_class^.protectedsyms;
aktzugriffsmode:=prot;
}
end;
if token=_PUBLIC then
begin
consume(_PUBLIC);
symtablestack:=symtablestack^.next;
_class^.publicsyms^.next:=symtablestack;
symtablestack:=_class^.publicsyms;
aktzugriffsmode:=pub;
end;
object_komponenten;
end;
consume(_END);
{ VMT erzeugen: }
vmtasmlist.concat(gennasmrec(DIRECT,S_NO,'.globl VMT_'+n));
vmtasmlist.concat(gennasmrec(DIRECT,S_NO,'VMT_'+n+':'));
vmtasmlist.concat(gennasmrec(A_LONG,S_NO,tostr(_class^.size)));
vmtasmlist.concat(gennasmrec(A_LONG,S_NO,tostr(-_class^.size)));
if assigned(_class^.childof) then
vmtasmlist.concat(gennasmrec(A_LONG,S_NO,'VMT_'+_class^.childof^.name^))
else
vmtasmlist.concat(gennasmrec(A_LONG,S_NO,'0'));
genvmt(_class);
symtablestack:=symtablestack^.next;
procinfo._class:=nil;
object_dec:=_class;
end;
{ liest eine Recorddefinition und gibt }
{ einen Pointer darauf zurück }
function record_dec : pdef;
var
symtable : psymtable;
begin
symtable:=new(psymtable,init(recordsymtable));
symtable^.next:=symtablestack;
symtablestack:=symtable;
consume(_RECORD);
feldliste(true,false);
consume(_END);
symtablestack:=symtable^.next;
record_dec:=new(precdef,init(symtable));
end;
{ liest eine Typdefinition und gibt einen }
{ Pointer darauf zurück }
function typ(const name : stringid) : pdef;
var
procvardef : pprocvardef;
procedure handle_procvar;
var
sc : pstringcontainer;
s : string;
p : pdef;
varspez : tvarspez;
begin
procvardef:=new(pprocvardef,init);
if cs_genexceptcode in aktswitches then
procvardef^.options:=procvardef^.options or poexceptions;
if token=LKLAMMER then
begin
consume(LKLAMMER);
inc(testaktobject);
repeat
if token=_VAR then
begin
consume(_VAR);
varspez:=vs_var;
end
else if token=_CONST then
begin
consume(_CONST);
varspez:=vs_const;
end
else varspez:=vs_value;
sc:=idlist;
if token=COLON then
begin
consume(COLON);
p:=single_type(s);
end
else
p:=new(pformaldef,init);
s:=sc^.get;
while s<>'' do
begin
procvardef^.concatdef(p,varspez);
s:=sc^.get;
end;
dispose(sc,done);
if token=SEMICOLON then consume(SEMICOLON)
else break;
until false;
dec(testaktobject);
consume(RKLAMMER);
end;
end;
var
hp1,p : pdef;
pt : ptree;
aufdef : paufzaehldef;
ap : parraydef;
s : stringid;
l : longint;
hs : string;
begin
case token of
ID : p:=id_type(hs);
LKLAMMER :
begin
consume(LKLAMMER);
l:=-1;
aufdef:=new(paufzaehldef,init);
repeat
s:=pattern;
consume(ID);
if token=ASSIGNMENT then
begin
consume(ASSIGNMENT);
pt:=expr;
do_firstpass(pt);
if not is_constintnode(pt) then
error(error_in_expression)
else l:=pt^.value;
if pt^.value<=l then
error(dup_enum);
disposetree(pt);
end
else
inc(l);
constsymtable^.insert(new(paufzaehlsym,init(s,aufdef,l)));
if token=COMMA then consume(COMMA)
else break;
until false;
aufdef^.max:=l;
p:=aufdef;
consume(RKLAMMER);
end;
_STRING : p:=stringtyp;
_ARRAY :
begin
consume(_ARRAY);
consume(LECKKLAMMER);
p:=nil;
repeat
{ Ausdruck lesen und prüfen }
pt:=expr;
if pt^.treetype=typen then
begin
if pt^.resulttype^.deftype<>aufzaehldef then
error(error_in_type);
if p=nil then
begin
ap:=new(parraydef,
init(0,paufzaehldef(pt^.resulttype)^.max,pt^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,
init(0,paufzaehldef(pt^.resulttype)^.max,pt^.resulttype));
ap:=parraydef(ap^.definition);
end;
end
else
begin
do_firstpass(pt);
if (pt^.treetype<>rangen) or
(pt^.left^.treetype<>ordconstn) then
error(error_in_type);
{ Registrierung der Grenzen erzwingen: }
if pt^.right^.resulttype=pdef(s32bitdef) then
pt^.right^.resulttype:=new(pgrunddef,init(
s32bit,$80000000,$7fffffff));
if p=nil then
begin
ap:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
p:=ap;
end
else
begin
ap^.definition:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
ap:=parraydef(ap^.definition);
end;
end;
if token=COMMA then consume(COMMA)
else break;
until false;
consume(RECKKLAMMER);
consume(_OF);
ap^.definition:=typ('');
end;
_SET : begin
consume(_SET);
consume(_OF);
hp1:=typ('');
case hp1^.deftype of
aufzaehldef : p:=new(psetdef,init(hp1,paufzaehldef(hp1)^.max));
grunddef : begin
case pgrunddef(hp1)^.typ of
uchar : p:=new(psetdef,init(hp1,255));
u8bit,s8bit,u16bit,s16bit,s32bit :
begin
if (pgrunddef(hp1)^.von>=0) then
p:=new(psetdef,init(hp1,pgrunddef(hp1)^.bis))
else error(illsettype);
end;
else error(illsettype);
end;
end;
else error(illsettype);
end;
end;
{ _FILE : begin
consume(_FILE);
if token=_OF then
begin
consume(_OF);
p:=typ('');
end;
end; }
CARET : begin
consume(CARET);
forwardsallowed:=true;
hp1:=single_type(hs);
p:=new(ppointerdef,init(hp1));
if lasttypesym<>nil then
save_forward(ppointerdef(p),lasttypesym);
forwardsallowed:=false;
end;
_RECORD : begin
p:=record_dec;
end;
_OBJECT : begin
p:=object_dec(name);
end;
_PROCEDURE : begin
consume(_PROCEDURE);
handle_procvar;
p:=procvardef;
end;
_FUNCTION : begin
consume(_FUNCTION);
handle_procvar;
if token<>COLON then
begin
consume(COLON);
while token<>SEMICOLON do
consume(token);
end
else
begin
consume(COLON);
procvardef^.retdef:=single_type(hs);
p:=procvardef;
end;
end;
else
begin
{ kann dann nur Bereichstyp sein }
pt:=expr;
do_firstpass(pt);
{ erlaubter Ausdruck ? }
if (pt^.treetype<>rangen) or
(pt^.left^.treetype<>ordconstn) then
error(error_in_type);
p:=new(pgrunddef,init(uauto,pt^.left^.value,pt^.right^.value));
disposetree(pt);
end;
end;
typ:=p;
end;
{ sucht in symtablestack nach zwar daklarierten }
{ aber nicht definierten Typen }
procedure testforward_types(p : psym);far;
begin
if (p^.typ=typesym) and (p^.forwarddef) then
error(type_id_not_defined);
end;
{ liest den type-Abschnitt in symtablestack ein }
procedure type_dec;
var
typename : stringid;
begin
parse_types:=true;
consume(_TYPE);
repeat
typename:=pattern;
consume(ID);
consume(EQUAL);
symtablestack^.insert(new(ptypesym,init(typename,typ(typename))));
consume(SEMICOLON);
until token<>ID;
{$ifdef tp}
symtablestack^.foreach(testforward_types);
{$else}
symtablestack^.foreach(@testforward_types);
{$endif}
resolve_forwards;
parse_types:=false;
end;
{ parst Variablendeklarationen und fügt sie in die }
{ oberste Symboltabelle ein }
procedure var_dec;
var
p : pdef;
sc : pstringcontainer;
begin
consume(_VAR);
feldliste(false,true);
end;
procedure readtypedconst(def : pdef);
var
p : ptree;
i,l : longint;
s : string;
ca : array[0..512] of char;
aktpos : longint;
pd : pprocdef;
hp1,hp2 : pdefcoll;
begin
case def^.deftype of
grunddef : begin
p:=expr;
do_firstpass(p);
case pgrunddef(def)^.typ of
{!!!!!! Rangechecking }
s8bit,
u8bit : begin
if not is_constintnode(p) then
{ Hier einfach Fehler ausgeben, der }
{ falsche Wert macht überhaubt nichts }
error(error_in_expression);
constsegment.concat(gennasmrec(A_BYTE,S_NO,tostr(p^.value)));
end;
s32bit : begin
if not is_constintnode(p) then
error(error_in_expression);
constsegment.concat(gennasmrec(A_LONG,S_NO,tostr(p^.value)));
end;
s64real : begin
if not is_constrealnode(p) then
error(error_in_expression);
constsegment.concat(gennasmrec(A_DOUBLE,S_NO,double2str(p^.value)));
end;
bool8bit : begin
if not is_constboolnode(p) then
error(error_in_expression);
constsegment.concat(gennasmrec(A_BYTE,S_NO,tostr(p^.value)));
end;
uchar : begin
if not is_constcharnode(p) then
error(error_in_expression);
constsegment.concat(gennasmrec(A_BYTE,S_NO,tostr(p^.value)));
end;
u16bit,
s16bit : begin
if not is_constintnode(p) then
error(error_in_expression);
constsegment.concat(gennasmrec(A_WORD,S_NO,tostr(p^.value)));
end;
end;
disposetree(p);
end;
pointerdef : begin
p:=expr;
do_firstpass(p);
if p^.treetype=niln then
constsegment.concat(gennasmrec(A_LONG,S_NO,'0'))
else
{ kann sonst nur noch PCHAR sein }
if (ppointerdef(def)^.definition^.deftype=grunddef) and
(pgrunddef(ppointerdef(def)^.definition)^.typ=uchar) then
begin
l:=getlabel;
{ String am Anfang einfügen }
if p^.treetype=stringconstn then
constsegment.insert(gennasmrec(ASCII,S_NO,'"'+ibm2ascii(p^.values^)+'\0"'))
else if is_constcharnode(p) then
constsegment.insert(gennasmrec(ASCII,S_NO,'"'+ibm2ascii(char(byte(p^.value)))+'\0"'))
else error(error_in_expression);
constsegment.insert(genlasmrec(A_LABEL,l));
{ Label einfügen }
constsegment.concat(gennasmrec(A_LONG,S_NO,tolabel(l)));
end
else error(error_in_expression);
disposetree(p);
end;
aufzaehldef : begin
p:=expr;
do_firstpass(p);
if p^.treetype=ordconstn then
begin
if is_equal(p^.resulttype,def) then
begin
constsegment.concat(gennasmrec(A_LONG,S_NO,tostr(p^.value)));
end
else
error(error_in_expression);
end
else
error(error_in_expression);
disposetree(p);
end;
stringdef : begin
p:=expr;
do_firstpass(p);
if p^.treetype=stringconstn then
begin
s:=p^.values^;
if length(s)+1>def^.size then
s[0]:=chr(def^.size-1);
constsegment.concat(gennasmrec(ASCII,S_NO,'"'+ibm2ascii(
char(length(s))+s)+'"'));
end
else if is_constcharnode(p) then
begin
constsegment.concat(gennasmrec(ASCII,S_NO,'"\001'+ibm2ascii(
char(byte(p^.value)))+'"'));
s:=char(byte(p^.value));
end
else error(error_in_expression);
ca[0]:='"';
fillchar(ca[1],def^.size-length(s)-1,' ');
ca[def^.size-length(s)]:='"';
ca[def^.size-length(s)+1]:=#0;
constsegment.concat(genpasmrec(ASCII,S_NO,ca));
disposetree(p);
end;
arraydef : begin
consume(LKLAMMER);
for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do
begin
readtypedconst(parraydef(def)^.definition);
consume(COMMA);
end;
readtypedconst(parraydef(def)^.definition);
consume(RKLAMMER);
end;
procvardef : begin
if token=KLAMMERAFFE then
consume(KLAMMERAFFE);
getsym(pattern,true);
consume(ID);
if srsym^.typ=unitsym then
begin
consume(POINT);
getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
consume(ID);
end;
if srsym^.typ<>procsym then
error(error_in_expression)
else
begin
pd:=pprocsym(srsym)^.definition;
if assigned(pd^.nextoverloaded) then
error(no_overloaded_procvars);
if not((pprocvardef(def)^.options=pd^.options)) or
not(is_equal(pprocvardef(def)^.retdef,pd^.retdef)) then
error(type_mismatch)
else
begin
hp1:=pprocvardef(def)^.para1;
hp2:=pd^.para1;
while assigned(hp1) and assigned(hp2) do
begin
if not(is_equal(hp1^.data,hp2^.data)) or
not(hp1^.paratyp=hp2^.paratyp) then
begin
error(type_mismatch);
break;
end;
hp1:=hp1^.next;
hp2:=hp2^.next;
end;
if not((hp1=nil) and (hp2=nil)) then
error(type_mismatch);
end;
constsegment.concat(gennasmrec(A_LONG,
S_NO,pd^.mangledname));
end;
end;
recorddef : begin
consume(LKLAMMER);
aktpos:=0;
while token<>RKLAMMER do
begin
s:=pattern;
consume(ID);
consume(COLON);
srsym:=precdef(def)^.symtable^.search(s);
if srsym=nil then
begin
error(id_not_found);
while token<>SEMICOLON do
consume(token);
end
else
begin
{ Position überprüfen }
if pvarsym(srsym)^.adresse<aktpos then
error(invalid_record_const);
{ gegebenenfalls auffüllen }
if pvarsym(srsym)^.adresse>aktpos then
for i:=1 to pvarsym(srsym)^.adresse-aktpos do
constsegment.concat(gennasmrec(A_BYTE,S_NO,'0'));
{ neue Position }
aktpos:=pvarsym(srsym)^.adresse+pvarsym(srsym)^.definition^.size;
{ eigentliche Daten lesen }
readtypedconst(pvarsym(srsym)^.definition);
if token=SEMICOLON then
consume(SEMICOLON)
else break;
end;
end;
for i:=1 to def^.size-aktpos do
constsegment.concat(gennasmrec(A_BYTE,S_NO,'0'));
consume(RKLAMMER);
end;
else error(type_const_not_possible);
end;
end;
procedure const_dec;
var
name : stringid;
p : ptree;
def : pdef;
pd : pdouble;
begin
consume(_CONST);
repeat
name:=pattern;
consume(ID);
case token of
EQUAL : begin
consume(EQUAL);
p:=expr;
do_firstpass(p);
case p^.treetype of
ordconstn : begin
if is_constintnode(p) then
symtablestack^.insert(new(pconstsym,init(name,constint,p^.value,nil)))
else if is_constcharnode(p) then
symtablestack^.insert(new(pconstsym,init(name,constchar,p^.value,nil)))
else if is_constboolnode(p) then
symtablestack^.insert(new(pconstsym,init(name,constbool,p^.value,nil)))
else if p^.resulttype^.deftype=aufzaehldef then
symtablestack^.insert(new(pconstsym,init(name,constord,p^.value,p^.resulttype)))
else internalerror(111);
end;
stringconstn :
symtablestack^.insert(new(pconstsym,init(name,conststring,longint(p^.values),nil)));
realconstn : begin
new(pd);
pd^:=p^.valued;
symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd),nil)));
end;
else error(error_in_expression);
end;
consume(SEMICOLON);
end;
COLON : begin
consume(COLON);
def:=typ('');
symtablestack^.insert(new(ptypedconstsym,init(name,def)));
consume(EQUAL);
readtypedconst(def);
consume(SEMICOLON);
end;
else consume(EQUAL);
end;
until token<>ID;
end;
function if_anweisung : ptree;
var
ex,if_a,else_a : ptree;
l1,l2,hl : longint;
begin
consume(_IF);
ex:=expr;
consume(_THEN);
if token<>_ELSE then
if_a:=anweisung
else if_a:=nil;
if token=_ELSE then
begin
consume(_ELSE);
else_a:=anweisung;
end
else
else_a:=nil;
if_anweisung:=genloopnode(ifn,ex,if_a,else_a,false);
end;
function case_anweisung : ptree;
var
{ contains the label number of currently parsed case block }
aktcaselabel : longint;
wurzel : pcaserecord;
{ the typ of the case expression }
casedef : pdef;
procedure newcaselabel(l,h : longint);
var
hcaselabel : pcaserecord;
procedure insertlabel(var p : pcaserecord);
begin
if p=nil then p:=hcaselabel
else
if (p^.low>hcaselabel^.low) and
(p^.low>hcaselabel^.high) then
insertlabel(p^.less)
else if (p^.high<hcaselabel^.low) and
(p^.high<hcaselabel^.high) then
insertlabel(p^.greater)
else error(double_caselabel);
end;
begin
new(hcaselabel);
hcaselabel^.less:=nil;
hcaselabel^.greater:=nil;
hcaselabel^.anweisung:=aktcaselabel;
hcaselabel^.at:=getlabel;
hcaselabel^.low:=l;
hcaselabel^.high:=h;
insertlabel(wurzel);
end;
var
code,caseexpr,p,instruc,elseblock : ptree;
hl1,hl2 : longint;
ranges : boolean;
begin
consume(_CASE);
caseexpr:=expr;
{ determines result type }
cleartempgen;
do_firstpass(caseexpr);
casedef:=caseexpr^.resulttype;
if not(is_ordinal(casedef)) then
error(ordinal_expect);
consume(_OF);
wurzel:=nil;
ranges:=false;
instruc:=nil;
repeat
aktcaselabel:=getlabel;
{ an instruction has may be more case labels }
repeat
p:=expr;
cleartempgen;
do_firstpass(p);
if (p^.treetype=rangen) then
begin
hl1:=get_ordinal_value(p^.left);
hl2:=get_ordinal_value(p^.right);
testrange(casedef,hl1);
testrange(casedef,hl2);
newcaselabel(hl1,hl2);
ranges:=true;
end
else
begin
hl1:=get_ordinal_value(p);
testrange(casedef,hl1);
newcaselabel(hl1,hl1);
end;
disposetree(p);
if token=COMMA then consume(COMMA)
else break;
until false;
consume(COLON);
{ handles instruction block }
p:=gensinglenode(labeln,anweisung);
p^.labelnr:=aktcaselabel;
{ concats instruction }
instruc:=gennode(anwein,instruc,p);
if not((token=_ELSE) or (token=_OTHERWISE) or (token=_END)) then
consume(SEMICOLON);
until (token=_ELSE) or (token=_OTHERWISE) or (token=_END);
if (token=_ELSE) or (token=_OTHERWISE) then
begin
if token=_ELSE then consume(_ELSE)
else consume(_OTHERWISE);
elseblock:=anweisung;
if token=SEMICOLON then consume(SEMICOLON);
end
else
elseblock:=nil;
consume(_END);
code:=gencasenode(caseexpr,instruc,wurzel);
code^.elseblock:=elseblock;
{ true, if any case label uses ranges }
code^.ranges:=ranges;
case_anweisung:=code;
end;
function repeat_anweisung : ptree;
var
first,last,p_e : ptree;
begin
consume(_REPEAT);
first:=nil;
while token<>_UNTIL do
begin
if first=nil then
begin
last:=gennode(anwein,nil,anweisung);
first:=last;
end
else
begin
last^.left:=gennode(anwein,nil,anweisung);
last:=last^.left;
end;
if token<>SEMICOLON then
break
else
consume(SEMICOLON);
while token=SEMICOLON do
consume(SEMICOLON);
end;
consume(_UNTIL);
first:=gensinglenode(blockn,first);
p_e:=expr;
repeat_anweisung:=genloopnode(repeatn,p_e,first,nil,false);
end;
function while_anweisung : ptree;
var
p_e,p_a : ptree;
begin
consume(_WHILE);
p_e:=expr;
consume(_DO);
if token<>SEMICOLON then
p_a:=anweisung;
while_anweisung:=genloopnode(whilen,p_e,p_a,nil,false);
end;
function for_anweisung : ptree;
var
p_e,tovalue,p_a : ptree;
backward : boolean;
begin
{ Anweisung parsen }
consume(_FOR);
p_e:=expr;
if token=_DOWNTO then
begin
consume(_DOWNTO);
backward:=true;
end
else
begin
consume(_TO);
backward:=false;
end;
tovalue:=expr;
consume(_DO);
{ ...nun die Anweisungen: }
if token<>SEMICOLON then
p_a:=anweisung
else
p_a:=nil;
for_anweisung:=genloopnode(forn,p_e,tovalue,p_a,backward);
end;
function _with_anweisung : ptree;
var
hp,p : ptree;
ref : treferenz;
withsymtable,symtab : psymtable;
oldaddr : longint;
begin
p:=expr;
do_firstpass(p);
case p^.resulttype^.deftype of
classdef : begin
symtab:=pclassdef(p^.resulttype)^.publicsyms;
end;
recorddef : begin
symtab:=precdef(p^.resulttype)^.symtable;
end;
else begin
error(false_with_expr);
if token=COMMA then
begin
consume(COMMA);
{$ifdef tp}
hp:=_with_anweisung;
{$else}
hp:=_with_anweisung();
{$endif}
end
else
begin
consume(_DO);
if token<>SEMICOLON then
anweisung;
end;
exit;
end;
end;
do_secondpass(p);
aktproccode.concatlist(@exprasmlist);
{ Adresse sichern }
gettempofsizereferenz(4,ref);
aktproccode.concat(gennasmrec(LEA,S_L,
getreferenzstring(p^.location.referenz)+',%edi'));
aktproccode.concat(gennasmrec(MOV,S_L,
'%edi,'+getreferenzstring(ref)));
withsymtable:=new(psymtable,init(symtable.withsymtable));
withsymtable^.wurzel:=symtab^.wurzel;
withsymtable^.next:=symtablestack;
{ datasize hat eine geänderte Bedeutung }
withsymtable^.datasize:=ref.offset;
symtablestack:=withsymtable;
if token=COMMA then
begin
consume(COMMA);
{$ifdef tp}
hp:=_with_anweisung;
{$else}
hp:=_with_anweisung();
{$endif}
end
else
begin
consume(_DO);
if token<>SEMICOLON then
anweisung;
end;
symtablestack:=symtablestack^.next;
withsymtable^.wurzel:=nil;
dispose(withsymtable,done);
end;
procedure with_anweisung;
begin
consume(_WITH);
_with_anweisung;
end;
procedure throw_anweisung;
begin
{
if not(procinfo.exceptions) then
fatalerror(exceptions_not_allowed);
consume(_THROW);
consume(ID);
}
end;
procedure try_anweisung;
begin
if not(procinfo.exceptions) then
fatalerror(exceptions_not_allowed);
consume(_TRY);
anweisung;
repeat
consume(_ON);
consume(ID);
consume(_DO);
anweisung;
until token<>_ON;
end;
function exit_anweisung : ptree;
var
p : ptree;
begin
consume(_EXIT);
if token=LKLAMMER then
begin
consume(LKLAMMER);
p:=expr;
consume(RKLAMMER);
if procinfo.retdef=pdef(voiddef) then
error(void_function);
end
else
p:=nil;
exit_anweisung:=gensinglenode(exitn,p);
end;
function _asm_anweisung : ptree;
begin
_asm_anweisung:=assemble;
{ Erst am Ende _ASM konsumieren, da der Scanner sonst die }
{ erste Assembleranweisung zu lesen versucht! }
consume(_ASM);
{ (END ist gelesen) }
if token=LECKKLAMMER then
begin
{ explizite Angabe der modifizierten Register moeglich }
consume(LECKKLAMMER);
if token<>RECKKLAMMER then
repeat
pattern:=upper(pattern);
if pattern='EAX' then
usedinproc:=usedinproc or ($80 shr byte(R_EAX))
else if pattern='EBX' then
usedinproc:=usedinproc or ($80 shr byte(R_EBX))
else if pattern='ECX' then
usedinproc:=usedinproc or ($80 shr byte(R_ECX))
else if pattern='EDX' then
usedinproc:=usedinproc or ($80 shr byte(R_EDX))
else if pattern='ESI' then
usedinproc:=usedinproc or ($80 shr byte(R_ESI))
else if pattern='EDI' then
usedinproc:=usedinproc or ($80 shr byte(R_EDI))
else consume(RECKKLAMMER);
consume(CSTRING);
if token=COMMA then consume(COMMA)
else break;
until false;
consume(RECKKLAMMER);
end
else usedinproc:=$ff;
end;
function parse_paras(_colon : boolean) : ptree;
var
p1,p2 : ptree;
begin
if token=RKLAMMER then
begin
parse_paras:=nil;
exit;
end;
p2:=nil;
while true do
begin
p1:=expr;
p2:=gencallparanode(p1,p2);
{ blöde Krückensyntax: str(l:5,s); }
if _colon and (token=COLON) then
begin
consume(COLON);
p1:=expr;
p2:=gencallparanode(p1,p2);
p2^.is_colon_para:=true;
if token=COLON then
begin
consume(COLON);
p1:=expr;
p2:=gencallparanode(p1,p2);
p2^.is_colon_para:=true;
end
end;
if token=COMMA then
consume(COMMA)
else
break;
end;
parse_paras:=p2;
end;
function anweisung_syssym(l : longint;var pd : pdef) : ptree;
var
p1,p2 : ptree;
paras : ptree;
begin
case l of
in_typeof_x : begin
consume(LKLAMMER);
p1:=expr;
consume(RKLAMMER);
pd:=voidpointerdef;
if p1^.treetype=typen then
begin
{!!!!!}
internalerror(100)
end
else
begin
do_firstpass(p1);
if p1^.resulttype^.deftype=classdef then
anweisung_syssym:=geninlinenode(in_typeof_x,p1)
else
error(type_mismatch);
end;
end;
in_sizeof_x : begin
consume(LKLAMMER);
p1:=expr;
consume(RKLAMMER);
pd:=s32bitdef;
if p1^.treetype=typen then
anweisung_syssym:=genordinalconstnode(
p1^.resulttype^.size,pd)
else
begin
do_firstpass(p1);
if p1^.resulttype^.deftype<>classdef then
begin
anweisung_syssym:=genordinalconstnode(
p1^.resulttype^.size,pd)
end
else
begin
anweisung_syssym:=geninlinenode(in_sizeof_x,p1);
end;
end;
end;
in_assigned_x : begin
consume(LKLAMMER);
p1:=expr;
do_firstpass(p1);
case p1^.resulttype^.deftype of
pointerdef,procvardef : ;
else error(no_para_match);
end;
p2:=gencallparanode(p1,nil);
p2:=geninlinenode(in_assigned_x,p2);
consume(RKLAMMER);
pd:=booldef;
anweisung_syssym:=p2;
end;
in_ofs_x : begin
consume(RKLAMMER);
p1:=expr;
p1:=gensinglenode(addrn,p1);
do_firstpass(p1);
pd:=p1^.resulttype;
consume(LKLAMMER);
anweisung_syssym:=p1;
end;
in_concat_x : begin
consume(LKLAMMER);
p2:=nil;
while true do
begin
p1:=expr;
do_firstpass(p1);
if not((p1^.resulttype^.deftype=stringdef) or
((p1^.resulttype^.deftype=grunddef) and
(pgrunddef(p1^.resulttype)^.typ=uchar)
)
) then error(no_para_match);
if p2<>nil then
p2:=gennode(addn,p2,p1)
else p2:=p1;
if token=COMMA then
consume(COMMA)
else break;
end;
consume(RKLAMMER);
pd:=cstringdef;
anweisung_syssym:=p2;
end;
in_read_x,
in_readln_x : begin
if token=LKLAMMER then
begin
consume(LKLAMMER);
paras:=parse_paras(false);
consume(RKLAMMER);
end
else
paras:=nil;
pd:=voiddef;
anweisung_syssym:=geninlinenode(l,paras);
end;
in_write_x,
in_writeln_x : begin
if token=LKLAMMER then
begin
consume(LKLAMMER);
paras:=parse_paras(true);
consume(RKLAMMER);
end
else
paras:=nil;
pd:=voiddef;
anweisung_syssym:=geninlinenode(l,paras);
end;
in_str_x_string : begin
consume(LKLAMMER);
paras:=parse_paras(true);
consume(RKLAMMER);
anweisung_syssym:=geninlinenode(l,paras);
pd:=voiddef;
end;
else internalerror(15);
end;
end;
function factor(getaddr : boolean) : ptree;forward;
function new_dispose_anweisung : ptree;
var
p,p2 : ptree;
ht : ttoken;
asmrec : pasmrec;
destrukname : stringid;
sym : psym;
classh : pclassdef;
pd : pdef;
begin
ht:=token;
if token=_NEW then consume(_NEW)
else consume(_DISPOSE);
consume(LKLAMMER);
p:=expr;
{ calc return type }
cleartempgen;
do_firstpass(p);
if (token=COMMA) and (ht=_DISPOSE) then
begin
{ extended syntax of dispose }
{ new is handled in factor }
consume(COMMA);
{ destructors have no parameters }
destrukname:=pattern;
consume(ID);
pd:=p^.resulttype;
if pd^.deftype<>pointerdef then
begin
error(pointer_expect);
p:=factor(false);
consume(RKLAMMER);
exit;
end;
if ppointerdef(pd)^.definition^.deftype<>classdef then
begin
error(pointer_to_class_expect);
new_dispose_anweisung:=factor(false);
while token<>RKLAMMER do
consume(token);
consume(RKLAMMER);
exit;
end;
classh:=pclassdef(ppointerdef(pd)^.definition);
sym:=nil;
while assigned(classh) do
begin
sym:=classh^.publicsyms^.search(pattern);
srsymtable:=classh^.publicsyms;
if assigned(sym) then
break;
classh:=classh^.childof;
end;
if (sym^.typ<>procsym) then
begin
error(expr_have_to_be_destructor_call);
new_dispose_anweisung:=genzeronode(errorn);
end
else
begin
p2:=gensinglenode(hdisposen,p);
p2:=genmethodcallnode(pprocsym(sym),srsymtable,p2);
{ we need the real called method }
cleartempgen;
do_firstpass(p2);
if (p2^.procdefinition^.options and podestructor)=0 then
error(expr_have_to_be_destructor_call);
new_dispose_anweisung:=p2;
end;
end
else
begin
if ppointerdef(p^.resulttype)^.definition^.deftype=classdef then
warning(take_extended_syntax);
case ht of
_NEW : new_dispose_anweisung:=gensinglenode(simplenewn,p);
_DISPOSE : new_dispose_anweisung:=gensinglenode(
simpledisposen,p);
end;
end;
consume(RKLAMMER);
end;
function anweisung : ptree;
var
p : ptree;
code : ptree;
labelnr : longint;
label
ready;
begin
case token of
_GOTO : begin
if not(cs_support_goto in aktswitches )
then error(goto_label_not_support);
consume(_GOTO);
if (token<>INTCONST) and (token<>ID) then
begin
error(label_not_found);
code:=genzeronode(errorn);
end
else
begin
getsym(pattern,true);
consume(token);
if srsym^.typ<>labelsym then
begin
error(id_is_no_label_id);
code:=genzeronode(errorn);
end
else
code:=genlabelnode(goton,
plabelsym(srsym)^.number);
end;
end;
_BEGIN : code:=befehlsblock;
_IF : code:=if_anweisung;
_CASE : code:=case_anweisung;
_REPEAT : code:=repeat_anweisung;
_WHILE : code:=while_anweisung;
_FOR : code:=for_anweisung;
_NEW,_DISPOSE : code:=new_dispose_anweisung;
{!!!!!
_WITH : with_anweisung;
}
{!!!!!
_TRY : try_anweisung;
}
{!!!!!
_THROW : throw_anweisung;
}
SEMICOLON : code:=genzeronode(niln);
_CONTINUE : begin
consume(_CONTINUE);
code:=genzeronode(continuen);
end;
{!!!!!
_FAIL : begin
internalerror(100);
if (aktprocsym^.definition^.options and poconstructor)=0 then
error(fail_only_in_constructor);
consume(_FAIL);
if procinfo.exceptions then
aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E'))
else
aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_NE'));
aktproccode.concat(genlasmrec(JMP,aktexitlabel));
end;
}
_BREAK : begin
consume(_BREAK);
code:=genzeronode(breakn);
end;
_EXIT : code:=exit_anweisung;
_ASM : code:=_asm_anweisung;
else
begin
if (token=INTCONST) or (token=ID) then
begin
getsym(pattern,true);
if srsym^.typ=labelsym then
begin
consume(token);
consume(COLON);
if plabelsym(srsym)^.defined then
error(label_already_defined);
plabelsym(srsym)^.defined:=true;
{ anweisung modifies srsym }
labelnr:=plabelsym(srsym)^.number;
{ the pointer to the following instruction }
{ isn't a very clean way }
{$ifdef tp}
code:=gensinglenode(labeln,anweisung);
{$else}
{ else FPKPascal thinks this is the return value }
{ | }
{ v }
code:=gensinglenode(labeln,anweisung());
{$endif}
code^.labelnr:=labelnr;
{ sorry, but there is a jump the easiest way }
goto ready;
end;
end;
p:=expr;
if (aktexprlevel<9) and (p^.treetype<>calln)
and (p^.treetype<>assignn) and (p^.treetype<>inlinen) then
error(error_in_expression);
code:=p;
end;
end;
ready:
anweisung:=code;
end;
function befehlsblock : ptree;
var
first,last : ptree;
begin
first:=nil;
consume(_BEGIN);
while token<>_END do
begin
if first=nil then
begin
last:=gennode(anwein,nil,anweisung);
first:=last;
end
else
begin
last^.left:=gennode(anwein,nil,anweisung);
last:=last^.left;
end;
if token=_END then
break
else
begin
{ falls kein Semicolon, dann Fehler und überlesen }
if token<>SEMICOLON then
begin
consume(SEMICOLON);
while token<>SEMICOLON do
consume(token);
end;
consume(SEMICOLON);
end;
while token=SEMICOLON do
consume(SEMICOLON);
end;
consume(_END);
first:=gensinglenode(blockn,first);
befehlsblock:=first;
end;
procedure formal_parameter_list;
{ hier durchgeführte Änderungen müssen meist auch in }
{ handle_procvar druchgeführt werden }
var
sc : pstringcontainer;
s : string;
p : pdef;
ref : boolean;
vs : pvarsym;
hs1,hs2 : string;
varspez : tvarspez;
begin
consume(LKLAMMER);
inc(testaktobject);
repeat
if token=_VAR then
begin
consume(_VAR);
varspez:=vs_var;
end
else if token=_CONST then
begin
consume(_CONST);
varspez:=vs_const;
end
else varspez:=vs_value;
sc:=idlist;
if token=COLON then
begin
consume(COLON);
p:=single_type(hs1);
end
else
begin
hs1:='$$$';
p:=new(pformaldef,init);
end;
s:=sc^.get;
hs2:=aktprocsym^.definition^.mangledname;
while s<>'' do
begin
aktprocsym^.definition^.concatdef(p,varspez);
hs2:=hs2+'$'+hs1;
vs:=new(pvarsym,init(s,p));
vs^.varspez:=varspez;
aktprocsym^.definition^.parast^.insert(vs);
s:=sc^.get;
end;
dispose(sc,done);
aktprocsym^.definition^.setmangledname(hs2);
if token=SEMICOLON then consume(SEMICOLON)
else break;
until false;
dec(testaktobject);
consume(RKLAMMER);
end;
{ enthält den richtigen Namen der Prozedur, der nicht }
{ ge"upcased" wurde }
var
realname : stringid;
procedure _proc_head(options : word);
var
sp : stringid;
pd : pprocdef;
paramoffset : longint;
hsymtab : psymtable;
sym : psym;
hs : string;
begin
sp:=pattern;
realname:=orgpattern;
consume(ID);
if (token=POINT) and not(parse_only) then
begin
consume(POINT);
getsym(sp,true);
sym:=srsym;
if (sym^.typ<>typesym) or
(ptypesym(sym)^.definition^.deftype<>classdef) then
fatalerror(object_type_expect);
sp:=pattern;
realname:=orgpattern;
consume(ID);
procinfo._class:=pclassdef(ptypesym(sym)^.definition);
aktprocsym:=pprocsym(procinfo._class^.publicsyms^.search(sp));
{ wird unten provisorisch behoben }
if aktprocsym=nil then
error(method_id_expect);
end
else
begin
if not(parse_only) and
((options and (poconstructor or podestructor))<>0) then
error(cons_always_obj);
aktprocsym:=pprocsym(symtablestack^.search(sp));
hs:=procprefix+'_'+sp;
if not(parse_only) then
begin
{ hier haben wir nicht nur einen Header }
procinfo._class:=nil;
hsymtab:=symtablestack;
if (aktprocsym=nil) then
begin
while (assigned(hsymtab)) and (hsymtab^.symtabletype<>globalsymtable) do
hsymtab:=hsymtab^.next;
if assigned(hsymtab) and (hsymtab^.symtabletype=globalsymtable) then
begin
aktprocsym:=pprocsym(hsymtab^.search(sp));
{ if symbol found => is global }
if assigned(aktprocsym) then
procinfo.globalsymbol:=true;
end;
end;
end;
end;
if procinfo._class<>nil then
hs:=procprefix+'_$$_'+procinfo._class^.name^+'_'+sp;
if aktprocsym=nil then
begin
aktprocsym:=new(pprocsym,init(sp));
symtablestack^.insert(aktprocsym);
end;
if aktprocsym^.typ<>procsym then fatalerror(overloaded_no_proc);
pd:=new(pprocdef,init);
{ Übergebene Optionen setzen }
pd^.options:=pd^.options or options;
{ Offset der Parameter berechnen }
paramoffset:=8;
{ Sollten Exceptions eingeschaltet sein, dann Exceptionflag setzen }
if cs_genexceptcode in aktswitches then
begin
pd^.options:=pd^.options or poexceptions;
inc(paramoffset,4);
end;
procinfo.exceptions:=cs_genexceptcode in aktswitches ;
{ Framepointeroffset berechnen }
if lexlevel>0 then
begin
procinfo.framepointer:=paramoffset;
inc(paramoffset,4);
end;
if ((pd^.options and poconstructor)<>0) or
((pd^.options and podestructor)<>0) then
begin
procinfo.VMT_table:=paramoffset;
inc(paramoffset,4);
end;
{ Selfpointeroffset }
if assigned(procinfo._class) then
begin
procinfo.ESI_offset:=paramoffset;
inc(paramoffset,4);
end;
procinfo.call_offset:=paramoffset;
pd^.parast^.datasize:=0;
pd^.nextoverloaded:=aktprocsym^.definition;
aktprocsym^.definition:=pd;
aktprocsym^.definition^.setmangledname(hs);
if not(parse_only) then
procprefix:=hs;
if token=LKLAMMER then formal_parameter_list;
end;
procedure proc_head;
var
{ Nur ein Hilfsstring, der den Namen des Rückgabetypes einer }
{ Funktion aufnimmt }
hs : string;
begin
if token=_FUNCTION then
begin
consume(_FUNCTION);
_proc_head(0);
if token<>COLON then
begin
consume(COLON);
while token<>SEMICOLON do
consume(token);
end
else
begin
consume(COLON);
aktprocsym^.definition^.retdef:=single_type(hs);
end;
end
else if token=_PROCEDURE then
begin
consume(_PROCEDURE);
_proc_head(0);
aktprocsym^.definition^.retdef:=voiddef;
end
else if token=_CONSTRUCTOR then
begin
consume(_CONSTRUCTOR);
_proc_head(poconstructor);
{ kann auch als bool'sche Funktion betrachtet werden }
aktprocsym^.definition^.retdef:=
new(pgrunddef,init(bool8bit,0,1));
end
else if token=_DESTRUCTOR then
begin
consume(_DESTRUCTOR);
_proc_head(podestructor);
aktprocsym^.definition^.retdef:=voiddef;
end
else if token=_OPERATOR then
begin
internalerror(110);
consume(_OPERATOR);
if not(token in [PLUS]) then
begin
error(operator_not_overloaded);
{!!!!!!!}
end;
consume(token);
if token<>COLON then
begin
consume(COLON);
while token<>SEMICOLON do
consume(token);
end
else
begin
consume(COLON);
{!!!!!!!}
aktprocsym^.definition^.retdef:=single_type(hs);
end;
end;
consume(SEMICOLON);
end;
procedure unter_dec;
var
oldprocsym : pprocsym;
oldexceptlabel,oldexitlabel,oldexit2label : longint;
_class : pclassdef;
oldprocinfo : tprocinfo;
oldconstsymtable : psymtable;
{ für geschachtelte Unterprogramme eindeutige Namen erzeugen }
oldprefix,hs : string;
{ Größe des lokalen Stackframes }
stackframe : longint;
{ Anzahl der Bytes die mit RET entfernt werden müssen }
parasize : longint;
{ true wenn kein Stackframe erforderlich ist }
nostackframe : boolean;
hd,pd : pprocdef;
names : tstringcontainer;
{ wird auf true gesetzt, wenn Symbole exportiert werden sollen }
make_global : boolean;
{ wird auf true gesetzt, wenn ein Unterprogramm schon }
{ "forward" deklariert wurde }
was_forward : boolean;
{ wird nur in Konstruktoren angesprungen, wenn eine Speicheran- }
{ forderung für die Instanz fehlschlägt }
quickexitlabel : longint;
hl : longint;
p : ptree;
{ Code für das Unterprogramm in Treeform }
code : ptree;
label
restore;
begin
oldprocsym:=aktprocsym;
oldprefix:=procprefix;
oldconstsymtable:=constsymtable;
oldprocinfo:=procinfo;
{ symbol isn't global }
procinfo.globalsymbol:=false;
proc_head;
{ uses no asm }
procinfo.uses_asm:=false;
{ Returntyp setzen }
procinfo.retdef:=aktprocsym^.definition^.retdef;
{ Vielleicht ein Zeiger für einen Returntyp }
if (procinfo.retdef^.deftype=arraydef) or
(procinfo.retdef^.deftype=stringdef) or
(procinfo.retdef^.deftype=classdef) or
(procinfo.retdef^.deftype=recorddef) or
(procinfo.retdef^.deftype=setdef) then
begin
procinfo.retoffset:=procinfo.call_offset;
inc(procinfo.call_offset,4);
end;
{ spart Speicherplatz: }
{ param_offset muß gespeichert werden, da geschachtelte Unterprogramme }
{ procinfo ändern }
aktprocsym^.definition^.parast^.name:=pstring(procinfo.call_offset);
{ Header ist geparst }
if parse_only then
goto restore;
{ wird nur wegen EXPORT hier schon durchgeführt: }
names.init;
make_global:=false;
procinfo.exported:=false;
case token of
_FAR : begin
consume(_FAR);
warning(far_ignored);
consume(SEMICOLON);
end;
_NEAR : begin
consume(_NEAR);
warning(near_ignored);
consume(SEMICOLON);
end;
_INTERRUPT : begin
consume(_INTERRUPT);
warning(interrupt_ignored);
consume(SEMICOLON);
end;
_EXPORT : begin
consume(_EXPORT);
names.insert(realname);
make_global:=true;
procinfo.exported:=true;
consume(SEMICOLON);
if gendeffile then
writeln(defdatei,#9+aktprocsym^.definition^.mangledname);
aktprocsym^.definition^.options:=
aktprocsym^.definition^.options or poexports;
if procinfo._class<>nil then
error(methods_dont_be_export);
if lexlevel<>0 then
error(dont_nest_export);
{ zwar dürfen Exceptions in exportierten Unterprogrammen }
{ eingeschaltet sein, jedoch darf natürlich keine }
{ Exceptionhandlingadresse auf dem Stack erwartet werden }
if procinfo.exceptions then
begin
{ also call_offset erniedrigen: }
dec(procinfo.call_offset,4);
{ call_offset neu zuweisen (s.o.): }
aktprocsym^.definition^.parast^.name:=pstring(procinfo.call_offset);
{ auch retoffset, nur falls exportierte Funktionen }
{ jemals strukturierte Typen zurückgeben, unwahrscheinlich }
dec(procinfo.retoffset,4);
end;
end;
_INLINE : error(inline_not_supported);
end;
case token of
_FORWARD : begin
consume(_FORWARD);
consume(SEMICOLON);
end;
else
begin
{ searchs idendical definitions }
{ if there is a forward, then kill this }
was_forward:=false;
pd:=aktprocsym^.definition;
while (assigned(pd)) and (assigned(pd^.nextoverloaded)) do
begin
if equal_paras(aktprocsym^.definition^.para1,pd^.nextoverloaded^.para1) then
begin
if pd^.nextoverloaded^.forwarddef then
{ sollte das eine "forward"-Definition sein, }
{ dann eine halbe Leiche daraus machen }
{ da die Definition noch in einer Symbol- }
{ tabelle zum Loeschen eingetragen ist, }
{ kein dispose! }
begin
{ and not(virtual), weil virtual nicht angegeben werden muß }
if ((pd^.nextoverloaded^.options and not(povirtualmethod))
<>aktprocsym^.definition^.options) or
not(is_equal(pd^.nextoverloaded^.retdef,aktprocsym^.definition^.retdef)) then
error(header_dont_match);
hd:=pd^.nextoverloaded;
{ erst Name ändern: }
hd^.setmangledname(aktprocsym^.definition^.mangledname);
{ Test! }
hd^.parast^.name:=aktprocsym^.definition^.parast^.name;
{ pd^.nextoverloaded aus der Liste an den Anfang }
{ und aktprocsym^.definition aushaengen }
pd^.nextoverloaded:=pd^.nextoverloaded^.nextoverloaded;
hd^.nextoverloaded:=aktprocsym^.definition^.nextoverloaded;
aktprocsym^.definition:=hd;
was_forward:=true;
end
else error(same_parameters);
end;
pd:=pd^.nextoverloaded;
end;
if assigned(procinfo._class) and not(was_forward) then
error(header_dont_match_any_member);
if not(was_forward) and procinfo.globalsymbol then
error(overloaded_must_be_all_global);
{$ifdef EXTDEBUG}
writeln('Unterprogramm: ',aktprocsym^.name,' (',
aktprocsym^.definition^.mangledname,')');
{$endif}
{ Funktionsattribute lesen }
if token=LECKKLAMMER then
begin
consume(LECKKLAMMER);
repeat
if token=_PUBLIC then
begin
consume(_PUBLIC);
make_global:=true;
end
else if token=ID then
begin
if pattern='ALIAS' then
begin
consume(ID);
consume(COLON);
names.insert(pattern);
if token=CCHAR then consume(CCHAR)
else consume(CSTRING);
end
else if pattern='INTERNPROC' then
begin
consume(ID);
consume(COLON);
p:=expr;
do_firstpass(p);
if p^.treetype<>ordconstn then
fatalerror(error_in_expression);
aktprocsym^.definition^.extnumber:=p^.value;
aktprocsym^.definition^.options:=
aktprocsym^.definition^.options or pointernproc;
disposetree(p);
consume(RECKKLAMMER);
consume(SEMICOLON);
{ definiert }
aktprocsym^.definition^.forwarddef:=false;
goto restore;
end
else if pattern='SYSTEM' then
begin
consume(ID);
aktprocsym^.definition^.options:=
aktprocsym^.definition^.options or poclearstack;
{ Vermutlich keine Register retten }
{ aktprocsym^.definition^.usedregisters:=$ff; }
aktprocsym^.definition^.forwarddef:=false;
aktprocsym^.definition^.setmangledname(realname);
consume(RECKKLAMMER);
consume(SEMICOLON);
goto restore;
end
{ it does currently the same as 'SYSTEM' }
else if pattern='C' then
begin
consume(ID);
aktprocsym^.definition^.options:=
aktprocsym^.definition^.options or poclearstack;
aktprocsym^.definition^.forwarddef:=false;
aktprocsym^.definition^.setmangledname(realname);
consume(RECKKLAMMER);
consume(SEMICOLON);
goto restore;
end
else if pattern='IOCHECK' then
begin
consume(ID);
aktprocsym^.definition^.options:=
aktprocsym^.definition^.options or poiocheck;
end
end;
if token=COMMA then consume(COMMA)
else break;
until false;
consume(RECKKLAMMER);
consume(SEMICOLON);
end
else if token=_EXTERNAL then
begin
consume(_EXTERNAL);
aktprocsym^.definition^.forwarddef:=false;
if token=SEMICOLON then
consume(SEMICOLON)
else
begin
{ Funktion aus DLL }
{!!!!!!!!!!!}
end;
goto restore;
end
{ else if token=_ASSEMBLER then
begin
consume(_ASSEMBLER);
consume(SEMICOLON);
end} ;
if procinfo.exported then
aktprocsym^.definition^.options:=aktprocsym^.definition^.options or
poclearstack;
oldexitlabel:=aktexitlabel;
oldexit2label:=aktexit2label;
oldexceptlabel:=aktexceptlabel;
aktexitlabel:=getlabel;
aktexit2label:=getlabel;
aktexceptlabel:=getlabel;
{ lex. Level berechnen }
inc(lexlevel);
if lexlevel>31 then
error(too_much_lexlevel);
{ break-und continuelabel zurücksetzen, }
{ müssen aber nicht gerettet werden! }
aktbreaklabel:=0;
aktcontinuelabel:=0;
{ falls Objekt, Membersymboltabelle eintragen }
if assigned(procinfo._class) then
begin
_class:=procinfo._class;
while assigned(_class) do
begin
_class^.publicsyms^.next:=symtablestack;
symtablestack:=_class^.publicsyms;
_class:=_class^.childof;
end;
end;
{ Symboltabellen einfügen }
{ und die lex. Level eintragen }
aktprocsym^.definition^.parast^.next:=symtablestack;
symtablestack:=aktprocsym^.definition^.parast;
inc(symtablestack^.symtabletype,lexlevel);
aktprocsym^.definition^.localst^.next:=symtablestack;
symtablestack:=aktprocsym^.definition^.localst;
inc(symtablestack^.symtabletype,lexlevel);
{ hier werden die Aufzähltypen eingefügt }
constsymtable:=symtablestack;
{ temporäre Variablen zurücksetzen }
cleartempgen;
pushgened:=false;
{ keine Register bisher benutzt }
usedinproc:=0;
{ entscheidender Moment... }
code:=block;
generatecode(code);
{ the code isn't needed }
disposetree(code);
dec(lexlevel);
{ jetzt definiert }
aktprocsym^.definition^.forwarddef:=false;
aktprocsym^.definition^.usedregisters:=usedinproc;
stackframe:=gettempsize;
quickexitlabel:=0;
{ Aufruf der Konstruktorhilfsprozedur }
if (aktprocsym^.definition^.options and poconstructor)<>0 then
{ verschiedene Hilfsunterprogramme (mit und ohne Exceptions) }
if procinfo.exceptions then
begin
aktentrycode.insert(gennasmrec(CALL,S_NO,'HELP_CONSTRUCTOR_E'));
aktentrycode.insert(gennasmrec(PUSH,S_L,'$'+tolabel(aktexceptlabel)));
end
else
begin
quickexitlabel:=getlabel;
aktentrycode.insert(genlasmrec(JZ,quickexitlabel));
aktentrycode.insert(gennasmrec(CALL,S_NO,'HELP_CONSTRUCTOR_NE'));
end;
{ ESI wird immer schon vom Hauptprogramm geladen }
{ also unnötig:
if procinfo._class<>nil then
aktentrycode.insert(gennasmrec(MOV,S_L,tostr(procinfo.ESI_offset)+'(%ebp),%esi'));
}
if stackframe<>0 then
begin
if cs_littlesize in aktswitches then
aktentrycode.insert(gennasmrec(ENTER,S_L,'$'+tostr(stackframe)+',$0'))
else
begin
aktentrycode.insert(gennasmrec(SUB,S_L,'$'+tostr(stackframe)+',%esp'));
aktentrycode.insert(gennasmrec(MOV,S_L,'%esp,%ebp'));
aktentrycode.insert(gennasmrec(PUSH,S_L,'%ebp'));
end;
end
else
begin
aktentrycode.insert(gennasmrec(MOV,S_L,'%esp,%ebp'));
aktentrycode.insert(gennasmrec(PUSH,S_L,'%ebp'));
end;
names.insert(aktprocsym^.definition^.mangledname);
if (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or
((procinfo._class<>nil) and
(procinfo._class^.owner^.symtabletype=globalsymtable)) then
make_global:=true;
hs:=names.get;
while hs<>'' do
begin
aktentrycode.insert(gennasmrec(DIRECT,S_NO,hs+':'));
if make_global then
aktentrycode.insert(gennasmrec(DIRECT,S_NO,'.globl '+hs));
hs:=names.get;
end;
if not(cs_littlesize in aktswitches ) then
aktentrycode.insert(gennasmrec(A_ALIGN,S_NO,'4,0x90'));
parasize:=aktprocsym^.definition^.parast^.datasize+procinfo.call_offset-8;
if procinfo.exceptions then
begin
aktexceptcode.insert(genlasmrec(A_LABEL,aktexceptlabel));
{ Aufruf der Destruktorhilfsprozedur }
if (aktprocsym^.definition^.options and podestructor)<>0 then
aktexceptcode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E'));
if not(nostackframe) then
aktexceptcode.concat(gennasmrec(LEAVE,S_NO,''));
{ exportierte Routinen enden immer nur mit RET }
if procinfo.exported then
aktexceptcode.concat(gennasmrec(RET,S_NO,''))
else
begin
aktexceptcode.concat(gennasmrec(ADD,S_L,'$4,%esp'));
aktexceptcode.concat(gennasmrec(RET,S_NO,'$'+tostr(parasize-4)));
end;
end;
{ !!!! hier automatische Destruktoren einfügen }
aktexitcode.insert(genlasmrec(A_LABEL,aktexitlabel));
{ Aufruf der Desstruktorhilfsprozedur }
if (aktprocsym^.definition^.options and podestructor)<>0 then
{ verschiedene Hilfsunterprogramme }
if procinfo.exceptions then
aktexitcode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E'))
else aktexitcode.insert(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_NE'));
if (aktprocsym^.definition^.options and poconstructor)=0 then
begin
if procinfo.retdef<>pdef(voiddef) then
begin
if (procinfo.retdef^.deftype=grunddef) then
begin
case pgrunddef(procinfo.retdef)^.typ of
s32bit : aktexitcode.concat(gennasmrec(MOV,S_L,tostr(procinfo.retoffset)+'(%ebp),%eax'));
u8bit,s8bit,uchar,bool8bit :
aktexitcode.concat(gennasmrec(MOV,S_B,tostr(procinfo.retoffset)+'(%ebp),%al'));
s16bit,u16bit :
aktexitcode.concat(gennasmrec(MOV,S_W,tostr(procinfo.retoffset)+'(%ebp),%ax'));
s64real :
aktexitcode.concat(gennasmrec(FLD,S_L,tostr(procinfo.retoffset)+'(%ebp)'));
end;
end
else
if (procinfo.retdef^.deftype=pointerdef) or
(procinfo.retdef^.deftype=aufzaehldef) or
(procinfo.retdef^.deftype=procvardef) then
aktexitcode.concat(gennasmrec(MOV,S_L,tostr(procinfo.retoffset)+'(%ebp),%eax'));
end
end
else
begin
{ erfolgreicher Konstruktor löscht das Zeroflag }
{ und gibt SELF in EAX zurück }
aktexitcode.concat(gennasmrec(MOV,S_L,'%esi,%eax'));
aktexitcode.concat(gennasmrec(A_OR,S_L,'%eax,%eax'));
if not(procinfo.exceptions) then
aktexitcode.concat(genlasmrec(A_LABEL,quickexitlabel));
end;
aktexitcode.concat(genlasmrec(A_LABEL,aktexit2label));
aktexitcode.concat(gennasmrec(LEAVE,S_NO,''));
{ max. 65535 Bytes Parameter wegen RET imm16 }
if parasize>65535 then
error(para_too_big);
{ jetzt noch das RET erzeugen, mit Entfernen der }
{ möglichen Catchadresse und der Parameter }
{ exportierte Routinen enden immer nur mit RET }
if (parasize=0) or procinfo.exported then
aktexitcode.concat(gennasmrec(RET,S_NO,''))
else aktexitcode.concat(gennasmrec(
RET,S_NO,'$'+tostr(parasize)));
if cs_debuginfo in aktswitches then
aktexitcode.concat(gennasmrec(STABS,S_NO,'"'+
aktprocsym^.name+'"'+',36,0,0,'+
aktprocsym^.definition^.mangledname));
aktproccode.insertlist(@aktentrycode);
aktproccode.concatlist(@aktexitcode);
aktproccode.concatlist(@aktexceptcode);
mainasmlist.concatlist(@aktproccode);
{ ... Symboltabellen entfernen }
symtablestack:=symtablestack^.next^.next;
{ ...auf unbenutzte Symbole testen }
if not(procinfo.uses_asm) then
begin
aktprocsym^.definition^.localst^.allsymbolsused;
aktprocsym^.definition^.parast^.allsymbolsused;
end;
{ die lokalen Symboltabellen dürfen gelöscht werden, }
{ nur auf die Parametersymboltablellen und insbesonders }
{ auf die Definitionen wird noch zugegriffen }
dispose(aktprocsym^.definition^.localst,done);
aktprocsym^.definition^.localst:=nil;
{ Klassenmember entfernen }
while symtablestack^.symtabletype=objectsymtable do
symtablestack:=symtablestack^.next;
aktexitlabel:=oldexit2label;
aktexit2label:=oldexitlabel;
aktexceptlabel:=oldexceptlabel;
names.done;
consume(SEMICOLON);
end;
end;
restore:
constsymtable:=oldconstsymtable;
aktprocsym:=oldprocsym;
procprefix:=oldprefix;
procinfo:=oldprocinfo;
end;
function block : ptree;
begin
repeat
case token of
_LABEL : label_dec;
_CONST : const_dec;
_TYPE : type_dec;
_VAR : var_dec;
_CONSTRUCTOR,_DESTRUCTOR,
_FUNCTION,_PROCEDURE,_OPERATOR : unter_dec;
else break;
end;
until false;
{ bei BEGIN der temporäre Variablen setzen }
if (symtablestack^.symtabletype and $8000)=localsymtable then
firsttemp:=-symtablestack^.datasize
else firsttemp:=0;
{ Platz fuer den Returnwert schaffen }
if procinfo.retdef<>pdef(voiddef) then
begin
if (procinfo.retdef^.deftype=grunddef) or
(procinfo.retdef^.deftype=pointerdef) or
(procinfo.retdef^.deftype=aufzaehldef) or
(procinfo.retdef^.deftype=procvardef) then
begin
procinfo.retoffset:=gettempofsize(procinfo.retdef^.size);
{ EAX wird auch verändert: }
usedinproc:=usedinproc or ($80 shr byte(R_EAX))
end;
end;
block:=befehlsblock;
end;
procedure loadunits;
var
st : psymtable;
s : stringid;
begin
consume(_USES);
repeat
s:=pattern;
consume(ID);
st:=readunit(s);
refsymtable^.insert(new(punitsym,init(s,st)));
if token=COMMA then consume(COMMA)
else break;
until false;
consume(SEMICOLON);
end;
procedure insertinternsyms;
begin
symtablestack^.insert(new(psyssym,init('CONCAT',in_concat_x)));
symtablestack^.insert(new(psyssym,init('WRITE',in_write_x)));
symtablestack^.insert(new(psyssym,init('WRITELN',in_writeln_x)));
symtablestack^.insert(new(psyssym,init('ASSIGNED',in_assigned_x)));
symtablestack^.insert(new(psyssym,init('READ',in_read_x)));
symtablestack^.insert(new(psyssym,init('READLN',in_readln_x)));
symtablestack^.insert(new(psyssym,init('OFS',in_ofs_x)));
symtablestack^.insert(new(psyssym,init('SIZEOF',in_sizeof_x)));
symtablestack^.insert(new(psyssym,init('TYPEOF',in_typeof_x)));
{ symtablestack^.insert(new(psyssym,init('STR',in_str_x_string))); }
end;
procedure proc_unit;
var
unitname : stringid;
p : psymtable;
code : ptree;
begin
if gendeffile then
error(def_only_in_program);
consume(_UNIT);
if (cs_compilesystem in aktswitches) and
(
not(pattern=target_info.system_unit) or
(length(pattern)>8) or
(pattern<>inputfile)
)
and (cs_check_unit_name in aktswitches) then
error(ill_unit_name);
unitname:=pattern;
consume(ID);
consume(SEMICOLON);
consume(_INTERFACE);
procprefix:='_'+unitname+'$$';
parse_only:=true;
{ jetzt die globale Symboltabelle erzeugen }
p:=new(psymtable,init(globalsymtable));
p^.name:=stringdup(unitname);
refsymtable:=p;
{ SYSTEM-Qualifier einfügen }
if not(cs_compilesystem in aktswitches) then
refsymtable^.insert(new(punitsym,init('SYSTEM',symtablestack)));
if token=_USES then loadunits;
{ ... aber hier erst einfügen }
p^.next:=symtablestack;
symtablestack:=p;
constsymtable:=symtablestack;
{ beim Uebersetzen von System einige Typen direkt einfuegen: }
if cs_compilesystem in aktswitches then
begin
voiddef:=new(pgrunddef,init(uvoid,0,0));
symtablestack^.insert(new(ptypesym,init('REAL',new(pgrunddef,init(s64real,0,0)))));
symtablestack^.insert(new(ptypesym,init('POINTER',new(ppointerdef,init(voiddef)))));
symtablestack^.insert(new(ptypesym,init('BOOLEAN',new(pgrunddef,init(bool8bit,0,1)))));
symtablestack^.insert(new(ptypesym,init('CHAR',new(pgrunddef,init(uchar,0,255)))));
symtablestack^.insert(new(ptypesym,init('TEXT',new(pfiledef,init(ft_text,nil)))));
symtablestack^.insert(new(ptypesym,init('FILE',new(pfiledef,init(ft_untyped,nil)))));
{ jetzt wurde voiddef ja geaendert }
procinfo.retdef:=voiddef;
insertinternsyms;
end;
{ ... und die Deklarationen parsen }
repeat
case token of
_CONST : const_dec;
_TYPE : type_dec;
_VAR : var_dec;
_FUNCTION,_PROCEDURE : unter_dec;
else
begin
consume(_IMPLEMENTATION);
break;
end;
end;
until false;
parse_only:=false;
{ statische Symboltabelle erzeugen }
p:=new(psymtable,init(staticsymtable));
p^.name:=stringdup(unitname);
refsymtable:=p;
{
if token=_USES then loadunits;
}
{ ... hier erst Einfügen }
p^.next:=symtablestack;
symtablestack:=p;
constsymtable:=symtablestack;
repeat
case token of
_CONST : const_dec;
_TYPE : type_dec;
_VAR : var_dec;
_FUNCTION,_PROCEDURE,
_CONSTRUCTOR,_DESTRUCTOR : unter_dec;
else break;
end;
until false;
{ temporäre Variablen zurücksetzen }
cleartempgen;
{ sonstige Einstellungen: }
aktexitlabel:=getlabel;
aktexit2label:=getlabel;
aktexceptlabel:=getlabel;
aktbreaklabel:=0;
aktcontinuelabel:=0;
pushgened:=false;
{ set some informations }
procinfo.retdef:=voiddef;
procinfo.exceptions:=true;
procinfo._class:=nil;
procinfo.uses_asm:=false;
if token=_BEGIN then
begin
{$ifdef EXTDEBUG}
writeln('Unitinitialisierungsteil');
{$endif}
usedunits.insert(unitname);
mainasmlist.concat(gennasmrec(DIRECT,S_NO,'.globl INIT$$'+unitname));
mainasmlist.concat(gennasmrec(DIRECT,S_NO,'INIT$$'+unitname+':'));
code:=befehlsblock;
generatecode(code);
if gettempsize<>0 then
aktentrycode.insert(gennasmrec(SUB,S_L,'$'+tostr(gettempsize)+',%esp'));
aktentrycode.insert(gennasmrec(MOV,S_L,'%esp,%ebp'));
aktentrycode.insert(gennasmrec(PUSH,S_L,'%ebp'));
aktexitcode.concat(genlasmrec(A_LABEL,aktexitlabel));
aktexitcode.concat(genlasmrec(A_LABEL,aktexit2label));
aktexitcode.concat(gennasmrec(LEAVE,S_NO,''));
aktexitcode.concat(gennasmrec(RET,S_NO,''));
aktexitcode.concat(genlasmrec(A_LABEL,aktexceptlabel));
aktexitcode.concat(gennasmrec(PUSH,S_L,'$LINITEXPT'));
aktexitcode.concat(gennasmrec(CALL,S_NO,'INITEXCEPTION'));
aktexitcode.concat(gennasmrec(DIRECT,S_NO,'LINITEXPT:'));
aktexitcode.concat(gennasmrec(LEAVE,S_NO,''));
aktexitcode.concat(gennasmrec(RET,S_NO,''));
aktproccode.insertlist(@aktentrycode);
aktproccode.concatlist(@aktexitcode);
aktproccode.concatlist(@aktexceptcode);
mainasmlist.concatlist(@aktproccode);
end
else
begin
consume(_END);
{ Units mit vorangestellter Tilde werden nicht initialisiert }
usedunits.insert('~'+unitname);
end;
consume(POINT);
{ Größe der statischen Daten: }
datasize:=symtablestack^.datasize;
{ unsed static symbols ? }
symtablestack^.allsymbolsused;
{ dels static symbols }
dellexlevel;
{ alle im Implementationsteil aufgeführten Units entfernen }
while symtablestack^.symtabletype<>globalsymtable do
dellexlevel;
if codegeneration then
writeunitas(inputdir+unitname+'.PPU',symtablestack);
inc(datasize,symtablestack^.datasize);
dellexlevel;
end;
function findfile(const s : string) : string;
var
found : boolean;
dirinfo : searchrec;
envstring : string;
f : file;
begin
findfirst(s+target_info.objext,anyfile,dirinfo);
if doserror=0 then
begin
findfile:='';
exit;
end;
findfirst(unitpath+s+target_info.objext,anyfile,dirinfo);
if doserror=0 then
begin
findfile:=unitpath;
exit;
end;
findfile:=search(s+target_info.objext,getenv(target_info.unit_env),found);
if found then
exit;
findfile:=search(s+target_info.objext,getenv(target_info.lib_env),found);
if found then
exit;
findfile:='';
end;
procedure proc_program;
var
st : psymtable;
programname : stringid;
s : stringid;
unitinits : tasmlist;
code : ptree;
begin
{ bei -Us Fehler erzeugen }
if cs_compilesystem in aktswitches then
consume(_UNIT);
parse_only:=false;
programname:='';
if token=_PROGRAM then
begin
consume(_PROGRAM);
programname:=pattern;
consume(ID);
if token=LKLAMMER then
begin
consume(LKLAMMER);
idlist;
consume(RKLAMMER);
end;
consume(SEMICOLON);
end;
{ Nach den Units Hauptsymboltabelle einfügen }
st:=new(psymtable,init(staticsymtable));
refsymtable:=st;
refsymtable^.insert(new(punitsym,init('SYSTEM',symtablestack)));
if token=_USES then loadunits;
st^.next:=symtablestack;
symtablestack:=st;
if programname<>'' then
symtablestack^.insert(new(pprogramsym,init(programname)));
{ ...und als constsymtable setzen }
constsymtable:=st;
{ set some informations about the main program }
procinfo.retdef:=voiddef;
procinfo.exceptions:=true;
procinfo._class:=nil;
procinfo.uses_asm:=false;
procprefix:='';
aktbreaklabel:=0;
aktcontinuelabel:=0;
aktexitlabel:=getlabel;
aktexit2label:=getlabel;
aktexceptlabel:=getlabel;
{ temporäre Variablen zurücksetzten }
cleartempgen;
pushgened:=false;
if target_info.target=target_DOS then
begin
assign(linkresponse,inputdir+'LINK.RES');
rewrite(linkresponse);
writeln(linkresponse,'-o '+inputdir+inputfile);
writeln(linkresponse,findfile('PRT0')+'PRT0.o');
writeln(linkresponse,inputdir+inputfile+'.o');
end;
if target_info.target=target_OS2 then
begin
assign(linkresponse,inputdir+'LINK.RES');
rewrite(linkresponse);
writeln(linkresponse,'-o '+inputdir+inputfile);
writeln(linkresponse,inputdir+inputfile+'.obj');
if gendeffile then
writeln(linkresponse,inputdir+inputfile+'.def');
end;
unitinits.init;
s:=usedunits.get;
while s<>'' do
begin
if s[1]<>'~' then
unitinits.concat(gennasmrec(CALL,S_NO,'INIT$$'+s))
else
delete(s,1,1);
if (target_info.target=target_DOS) or (target_info.target=target_OS2) then
writeln(linkresponse,findfile(s)+s+target_info.objext);
s:=usedunits.get;
end;
code:=block;
{$ifdef EXTDEBUG}
writeln('Hauptprogramm');
{$endif}
generatecode(code);
aktentrycode.insertlist(@unitinits);
if gettempsize<>0 then
aktentrycode.insert(gennasmrec(SUB,S_L,'$'+tostr(gettempsize)+',%esp'));
aktentrycode.insert(gennasmrec(MOV,S_L,'%esp,%ebp'));
aktentrycode.insert(gennasmrec(PUSH,S_L,'%ebp'));
if target_info.target=target_DOS then
begin
aktentrycode.insert(gennasmrec(DIRECT,S_NO,'PASCALMAIN:'));
aktentrycode.insert(gennasmrec(DIRECT,S_NO,'.globl'#9'PASCALMAIN'));
end;
{ the main function for Linux is in PRT0L.O }
if (target_info.target<>target_LINUX) then
begin
aktentrycode.insert(gennasmrec(DIRECT,S_NO,'_main:'));
aktentrycode.insert(gennasmrec(DIRECT,S_NO,'.globl'#9'_main'));
end;
aktexceptcode.concat(genlasmrec(A_LABEL,aktexceptlabel));
aktexceptcode.concat(gennasmrec(CALL,S_NO,'__EXIT'));
aktexceptcode.concat(gennasmrec(LEAVE,S_NO,''));
if target_info.target=target_DOS then
begin
aktexceptcode.concat(gennasmrec(ADD,S_L,'$4,%esp'));
aktexceptcode.concat(gennasmrec(RET,S_NO,''));
end
else if target_info.target=target_OS2 then
begin
{!!!!!! Hier Exceptions für OS/2 abfangen }
aktexceptcode.concat(gennasmrec(RET,S_NO,''));
end
else if target_info.target=target_LINUX then
begin
{!!!!!! Hier Exceptions für Linux abfangen }
aktexceptcode.concat(gennasmrec(RET,S_NO,''));
end
else if target_info.target=target_WIN32 then
begin
{!!!!!! Hier Exceptions für Win32 abfangen }
aktexceptcode.concat(gennasmrec(RET,S_NO,''));
end;
aktexitcode.concat(genlasmrec(A_LABEL,aktexitlabel));
aktexitcode.concat(genlasmrec(A_LABEL,aktexit2label));
aktexitcode.concat(gennasmrec(CALL,S_NO,'__EXIT'));
aktexitcode.concat(gennasmrec(LEAVE,S_NO,''));
if target_info.target=target_DOS then
aktexitcode.concat(gennasmrec(RET,S_NO,'$4'))
else if target_info.target=target_OS2 then
aktexitcode.concat(gennasmrec(RET,S_NO,''))
{ !!!!!!!!!!!! Abändern: }
else if target_info.target=target_LINUX then
aktexitcode.concat(gennasmrec(RET,S_NO,''))
else if target_info.target=target_WIN32 then
aktexitcode.concat(gennasmrec(RET,S_NO,''));
aktproccode.insertlist(@aktentrycode);
aktproccode.concatlist(@aktexitcode);
aktproccode.concatlist(@aktexceptcode);
mainasmlist.concatlist(@aktproccode);
if (target_info.target=target_DOS) or
(target_info.target=target_LINUX) then
begin
{ heap of DOS and LINUX are in the data segment }
datasegment.concat(gennasmrec(
A_GLOBAL,S_NO,'HEAP,'+tostr(heapsize)));
end;
constsegment.concat(gennasmrec(
DIRECT,S_NO,'.globl HEAPSIZE'));
constsegment.concat(gennasmrec(
DIRECT,S_NO,'HEAPSIZE:'));
constsegment.concat(gennasmrec(
A_LONG,S_NO,tostr(heapsize)));
datasize:=symtablestack^.datasize;
symtablestack^.allsymbolsused;
while assigned(symtablestack) do
dellexlevel;
consume(POINT);
end;
function factor(getaddr : boolean) : ptree;
var
l : longint;
p1,p2,p3 : ptree;
code : word;
pd,pd2 : pdef;
nochmal : boolean;
sym : pvarsym;
classh : pclassdef;
d : double;
constset : pconstset;
{ liest die Parameter für einen Unterprogrammaufruf }
{ eigentlich ein Makro }
procedure do_proc_call;
begin
{ soll nur die Adresse eines }
{ Unterprogramms festgestellt werden ? }
if not(getaddr) then
begin
if token=LKLAMMER then
begin
consume(LKLAMMER);
p1^.left:=parse_paras(false);
consume(RKLAMMER);
end
else p1^.left:=nil;
{ Schon den einen ersten Durchlauf }
{ durchführen, da wir den Returntyp }
{ brauchen }
do_firstpass(p1);
pd:=p1^.resulttype;
end
else
begin
p1^.left:=nil;
{ vergessen wir pd }
pd:=nil;
{ keine Postfixoperatoren }
nochmal:=false;
end;
end;
{ erzeugt den Knoten für ein Klassenelement, }
{ wobei sym auf das Symbol und srsymtable }
{ auf die entsprechende Symboltabelle zeigen }
{ müssen und p1 muß ein Knoten auf die Klasse }
{ sein }
{ eigentlich ein Makro }
procedure do_member_read;
begin
consume(ID);
if sym=nil then
begin
error(id_no_member);
disposetree(p1);
p1:=genzeronode(errorn);
end
else
begin
{ nimmt an, das nur procsym's und varsym's in }
{ Symboltabellen von Klassen vorkommen }
case sym^.typ of
procsym : begin
p1:=genmethodcallnode(pprocsym(sym),
srsymtable,p1);
do_proc_call;
end;
varsym : begin
p1:=gensubscriptnode(sym,p1);
pd:=sym^.definition;
end;
else internalerror(16);
end;
end;
end;
{ bearbeitet die Postfixoperatoren }
{ pd und p1 müssen gesetzt sein }
procedure postfixoperators;
begin
while nochmal do
begin
case token of
CARET : begin
consume(CARET);
if pd^.deftype<>pointerdef then
begin
error(invalid_qualifizier);
disposetree(p1);
p1:=genzeronode(errorn);
end
else
begin
p1:=gensinglenode(derefn,p1);
pd:=ppointerdef(pd)^.definition;
end;
end;
LECKKLAMMER : begin
consume(LECKKLAMMER);
repeat
if (pd^.deftype<>arraydef) and
(pd^.deftype<>stringdef) and
(pd^.deftype<>pointerdef) then
begin
error(invalid_qualifizier);
disposetree(p1);
p1:=genzeronode(errorn);
end
else if (pd^.deftype=pointerdef) then
begin
p2:=expr;
p1:=gennode(vecn,p1,p2);
pd:=ppointerdef(pd)^.definition;
end
else
begin
p2:=expr;
p1:=gennode(vecn,p1,p2);
if pd^.deftype=stringdef then
pd:=cchardef
else pd:=parraydef(pd)^.definition;
end;
if token=COMMA then consume(COMMA)
else break;
until false;
consume(RECKKLAMMER);
end;
POINT : begin
consume(POINT);
case pd^.deftype of
recorddef :
begin
sym:=pvarsym(precdef(pd)^.symtable^.search(pattern));
consume(ID);
if sym=nil then
begin
error(ill_field);
disposetree(p1);
p1:=genzeronode(errorn);
end
else
begin
p1:=gensubscriptnode(sym,p1);
pd:=sym^.definition;
end;
end;
classdef :
begin
classh:=pclassdef(pd);
sym:=nil;
while assigned(classh) do
begin
sym:=pvarsym(classh^.publicsyms^.search(pattern));
srsymtable:=classh^.publicsyms;
if assigned(sym) then
break;
classh:=classh^.childof;
end;
do_member_read;
end
else
begin
error(invalid_qualifizier);
disposetree(p1);
p1:=genzeronode(errorn);
end;
end;
end;
else
begin
{ Prozedurvariablen }
if pd^.deftype=procvardef then
begin
if token=LKLAMMER then
begin
{ alles etwas ungewohnt benutzen }
p2:=p1;
p1:=gencallnode(nil,
nil);
p1^.right:=p2;
consume(LKLAMMER);
p1^.left:=parse_paras(false);
consume(RKLAMMER);
pd:=pprocvardef(pd)^.retdef;
p1^.resulttype:=pd;
end
else nochmal:=false;
end
else nochmal:=false;
end;
end;
end;
end;
procedure do_set(p : pconstset;pos : longint);
var
l : longint;
begin
if (pos>255) or
(pos<0) then
error(illsetexpr);
l:=pos div 8;
p^[l]:=p^[l] or (1 shl (pos mod 8));
end;
begin
case token of
ID : begin
{ Postfixoperatoren sind erlaubt }
nochmal:=true;
getsym(pattern,true);
consume(ID);
{ Zugriff auf das Funktionsresultat ? }
if (aktprocsym<>nil) and
(srsym^.name=aktprocsym^.name) and
(procinfo.retdef<>pdef(voiddef)) and
(token<>LKLAMMER) then
begin
p1:=genzeronode(funcretn);
pd:=procinfo.retdef;
end
else
begin
if srsym^.typ=unitsym then
begin
consume(POINT);
getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
consume(ID);
end;
case srsym^.typ of
varsym : begin
p1:=genloadnode(pvarsym(srsym),srsymtable);
pd:=pvarsym(srsym)^.definition;
end;
typedconstsym :
begin
p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable);
pd:=ptypedconstsym(srsym)^.definition;
end;
syssym : begin
p1:=anweisung_syssym(psyssym(srsym)^.number,pd);
end;
typesym : begin
pd:=ptypesym(srsym)^.definition;
if token=LKLAMMER then
begin
consume(LKLAMMER);
p1:=expr;
consume(RKLAMMER);
p1:=gentypeconvnode(p1,pd);
p1^.explizit:=true;
end
else if token=POINT then
begin
consume(POINT);
if pd^.deftype=classdef then
begin
if assigned(procinfo._class) then
begin
if procinfo._class^.isrelated(pclassdef(pd)) then
begin
p1:=genzeronode(typen);
p1^.resulttype:=pd;
srsymtable:=pclassdef(pd)^.publicsyms;
sym:=pvarsym(srsymtable^.search(pattern));
do_member_read;
end
else
error(no_super_class);
end
else
error(generic_methods_only_in_methods);
end
else
error(class_expected);
end
else
begin
{ Typknoten erzeugen }
p1:=genzeronode(typen);
p1^.resulttype:=pd;
pd:=voiddef;
end;
end;
aufzaehlsym : begin
p1:=genaufzaehlnode(paufzaehlsym(srsym));
pd:=p1^.resulttype;
end;
constsym : begin
case pconstsym(srsym)^.consttype of
constint : p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
conststring : p1:=genstringconstnode(pstring(pconstsym(srsym)^.value)^);
constchar : p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
constreal : p1:=genrealconstnode(pdouble(pconstsym(srsym)^.value)^);
constbool : p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
constord : p1:=genordinalconstnode(pconstsym(srsym)^.value,
pconstsym(srsym)^.definition);
end;
pd:=p1^.resulttype;
end;
procsym : begin
p1:=gencallnode(pprocsym(srsym),srsymtable);
do_proc_call;
end;
errorsym : begin
p1:=genzeronode(errorn);
pd:=generrordef;
if token=LKLAMMER then
begin
consume(LKLAMMER);
parse_paras(false);
consume(RKLAMMER);
end;
end;
else
begin
p1:=genzeronode(errorn);
pd:=generrordef;
error(error_in_expression);
end;
end;
end;
{ Postfixoperatoren bearbeiten }
postfixoperators;
end;
_NEW : begin
consume(_NEW);
consume(LKLAMMER);
p1:=factor(false);
if p1^.treetype<>typen then
error(type_id_expect);
pd:=p1^.resulttype;
pd2:=pd;
if (pd^.deftype<>pointerdef) or
(ppointerdef(pd)^.definition^.deftype<>classdef) then
begin
error(pointer_to_class_expect);
{ bei Fehler bis Ende von new alles ignorieren }
p1:=genzeronode(errorn);
l:=1;
while true do
begin
case token of
LKLAMMER : inc(l);
RKLAMMER : dec(l);
end;
consume(token);
if l=0 then
break;
end;
end
else
begin
disposetree(p1);
p1:=genzeronode(hnewn);
p1^.resulttype:=ppointerdef(pd)^.definition;
consume(COMMA);
{ Konstruktor auch in den Symboltabellen der }
{ Elternklassen suchen }
classh:=pclassdef(ppointerdef(pd)^.definition);
sym:=nil;
while assigned(classh) do
begin
sym:=pvarsym(classh^.publicsyms^.search(pattern));
srsymtable:=classh^.publicsyms;
if assigned(sym) then
break;
classh:=classh^.childof;
end;
do_member_read;
if (p1^.treetype<>calln) or
((p1^.procdefinition^.options and poconstructor)=0) then
error(expr_have_to_be_constructor_call);
p1:=gensinglenode(newn,p1);
{ hier schon Resultattyp setzen }
p1^.resulttype:=pd2;
consume(RKLAMMER);
end;
end;
_SELF : begin
nochmal:=true;
consume(_SELF);
if not assigned(procinfo._class) then
begin
p1:=genzeronode(errorn);
error(self_not_in_method);
end
else
begin
p1:=genselfnode(procinfo._class);
p1^.resulttype:=procinfo._class;
pd:=p1^.resulttype;
end;
postfixoperators;
end;
_INHERITED : begin
nochmal:=true;
consume(_INHERITED);
if assigned(procinfo._class) then
begin
classh:=procinfo._class^.childof;
while assigned(classh) do
begin
srsymtable:=pclassdef(classh)^.publicsyms;
sym:=pvarsym(srsymtable^.search(pattern));
if assigned(sym) then
begin
p1:=genzeronode(typen);
p1^.resulttype:=classh;
pd:=p1^.resulttype;
do_member_read;
break;
end;
classh:=classh^.childof;
end;
if classh=nil then
error(id_no_member);
end
else
error(generic_methods_only_in_methods);
postfixoperators;
end;
INTCONST : begin
val(pattern,l,code);
if code<>0 then
begin
error(error_in_integer);
l:=1;
end;
consume(INTCONST);
p1:=genordinalconstnode(l,s32bitdef);
end;
REALNUMBER : begin
val(pattern,d,code);
if code<>0 then
begin
error(error_in_real);
d:=1.0;
end;
consume(REALNUMBER);
p1:=genrealconstnode(d);
end;
{ string kann auch ein Typkonvertierungsoperator sein }
_STRING : begin
pd:=stringtyp;
consume(LKLAMMER);
p1:=expr;
consume(RKLAMMER);
p1:=gentypeconvnode(p1,pd);
p1^.explizit:=true;
nochmal:=true;
end;
CSTRING : begin
p1:=genstringconstnode(pattern);
consume(CSTRING);
end;
CCHAR : begin
p1:=genordinalconstnode(ord(pattern[1]),cchardef);
consume(CCHAR);
end;
KLAMMERAFFE : begin
consume(KLAMMERAFFE);
p1:=factor(true);
p1:=gensinglenode(addrn,p1);
end;
LKLAMMER : begin
consume(LKLAMMER);
p1:=expr;
consume(RKLAMMER);
{ keine tolle Konstruktion }
{ aber sonst ist z.B. ([pointer]+[integer])^ }
{ ein kleines Problemchen }
case token of
CARET,POINT,LECKKLAMMER : begin
{ wir brauchen pd }
do_firstpass(p1);
pd:=p1^.resulttype;
nochmal:=true;
postfixoperators;
end;
end;
end;
LECKKLAMMER : begin
consume(LECKKLAMMER);
new(constset);
for l:=0 to 31 do
constset^[l]:=0;
p2:=nil;
pd:=nil;
if token<>RECKKLAMMER then
while true do
begin
p1:=expr;
do_firstpass(p1);
case p1^.treetype of
ordconstn : begin
if pd=nil then
pd:=p1^.resulttype;
if not(is_equal(pd,p1^.resulttype)) then
error(typeconflict_in_set)
else
do_set(constset,p1^.value);
disposetree(p1);
end;
rangen : begin
if pd=nil then
pd:=p1^.left^.resulttype;
if not(is_equal(pd,p1^.left^.resulttype)) then
error(typeconflict_in_set)
else
for l:=p1^.left^.value to p1^.right^.value do
do_set(constset,l);
disposetree(p1);
end;
else
begin
if pd=nil then
pd:=p1^.resulttype;
if not(is_equal(pd,p1^.resulttype)) then
error(typeconflict_in_set);
p2:=gennode(setelen,p1,p2);
end;
end;
if token=COMMA then
consume(COMMA)
else break;
end;
consume(RECKKLAMMER);
p1:=gensinglenode(setconstrn,p2);
p1^.resulttype:=new(psetdef,init(pd,255));
p1^.constset:=constset;
end;
PLUS : begin
consume(PLUS);
p1:=factor(false);
end;
MINUS : begin
consume(MINUS);
p1:=factor(false);
p1:=gensinglenode(umminusn,p1);
end;
_NOT : begin
consume(_NOT);
p1:=factor(false);
p1:=gensinglenode(notn,p1);
end;
_TRUE : begin
consume(_TRUE);
p1:=genordinalconstnode(1,booldef);
end;
_FALSE : begin
consume(_FALSE);
p1:=genordinalconstnode(0,booldef);
end;
_NIL : begin
consume(_NIL);
p1:=genzeronode(niln);
end;
else
begin
p1:=genzeronode(errorn);
consume(token);
error(error_in_expression);
end;
end;
factor:=p1;
end;
function term : ptree;
var
p1,p2 : ptree;
begin
p1:=factor(false);
repeat
case token of
STAR : begin
consume(STAR);
p2:=factor(false);
p1:=gennode(muln,p1,p2);
end;
SLASH : begin
consume(SLASH);
p2:=factor(false);
p1:=gennode(slashn,p1,p2);
end;
_DIV : begin
consume(_DIV);
p2:=factor(false);
p1:=gennode(divn,p1,p2);
end;
_MOD : begin
consume(_MOD);
p2:=factor(false);
p1:=gennode(modn,p1,p2);
end;
_AND : begin
consume(_AND);
p2:=factor(false);
p1:=gennode(andn,p1,p2);
end;
_SHL : begin
consume(_SHL);
p2:=factor(false);
p1:=gennode(shln,p1,p2);
end;
_SHR : begin
consume(_SHR);
p2:=factor(false);
p1:=gennode(shrn,p1,p2);
end;
else break;
end;
until false;
term:=p1;
end;
function simpl_expr : ptree;
var
p1,p2 : ptree;
begin
p1:=term;
repeat
case token of
PLUS : begin
consume(PLUS);
p2:=term;
p1:=gennode(addn,p1,p2);
end;
MINUS : begin
consume(MINUS);
p2:=term;
p1:=gennode(subn,p1,p2);
end;
_OR : begin
consume(_OR);
p2:=term;
p1:=gennode(orn,p1,p2);
end;
_XOR : begin
consume(_XOR);
p2:=term;
p1:=gennode(xorn,p1,p2);
end;
else break;
end;
until false;
simpl_expr:=p1;
end;
function simpl2_expr : ptree;
var
p1,p2 : ptree;
begin
p1:=simpl_expr;
repeat
case token of
LT : begin
consume(LT);
p2:=simpl_expr;
p1:=gennode(ltn,p1,p2);
end;
LTE : begin
consume(LTE);
p2:=simpl_expr;
p1:=gennode(lten,p1,p2);
end;
GT : begin
consume(GT);
p2:=simpl_expr;
p1:=gennode(gtn,p1,p2);
end;
GTE : begin
consume(GTE);
p2:=simpl_expr;
p1:=gennode(gten,p1,p2);
end;
EQUAL : begin
consume(EQUAL);
p2:=simpl_expr;
p1:=gennode(equaln,p1,p2);
end;
UNEQUAL : begin
consume(UNEQUAL);
p2:=simpl_expr;
p1:=gennode(unequaln,p1,p2);
end;
_IN : begin
consume(_IN);
p2:=simpl_expr;
p1:=gennode(inn,p1,p2);
end;
else break;
end;
until false;
simpl2_expr:=p1;
end;
function expr : ptree;
var
p1,p2 : ptree;
begin
p1:=simpl2_expr;
case token of
POINTPOINT : begin
consume(POINTPOINT);
p2:=simpl2_expr;
p1:=gennode(rangen,p1,p2);
end;
ASSIGNMENT : begin
consume(ASSIGNMENT);
{$ifdef tp}
p2:=expr;
{$else}
{ FPKPascal erkennt sonst den Aufruf nicht }
p2:=expr();
{$endif}
p1:=gennode(assignn,p1,p2);
end
end;
expr:=p1;
end;
procedure compile(const path,filename : string);
var
p : pgrunddef;
st : psymtable;
pd : pdef;
hs : string;
mac : pmacrosym;
i : ttoken;
comp_unit : boolean;
begin
{ !!!!!! save old state }
{ Zielbetriebssystem als Symbol für bedingte Compilierung }
{ festlegen }
mac:=new(pmacrosym,init(target_info.short_name));
mac^.defined:=true;
macros^.insert(mac);
{ copy command line options }
aktswitches:=initswitches;
aktexprlevel:=initexprlevel;
aktpackrecords:=initpackrecords;
{ Codegenerator initialisieren }
codegeninit;
{ Scanner initilisieren }
token:=yylex;
forwardsallowed:=false;
{ Definitionen jetzt nicht registrieren }
registerdef:=false;
{ Scanner ^M als String annehmen lassen }
parse_types:=false;
{ es wird keine Objectdeklaration geparst }
{ und kein Funktionskopf }
testaktobject:=0;
{ Fehlerdefinition erzeugen: }
generrordef:=new(perrordef,init);
{ Definitionen fuer Konstanten erzeugen: }
s32bitdef:=new(pgrunddef,init(s32bit,$80000000,$7fffffff));
cstringdef:=new(pstringdef,init(255));
cchardef:=new(pgrunddef,init(uchar,0,255));
cs64realdef:=new(pgrunddef,init(s64real,0,0));
{ sonstige verwendete Definitionen: }
voiddef:=new(pgrunddef,init(uvoid,0,0));
u8bitdef:=new(pgrunddef,init(u8bit,0,255));
u16bitdef:=new(pgrunddef,init(u16bit,0,65535));
booldef:=new(pgrunddef,init(bool8bit,0,1));
voidpointerdef:=new(ppointerdef,init(voiddef));
{ erst jetzt Definitionen registrieren, da vorher symtabletack }
{ auf jeden Fall ungueltig war, was mir einige Zeit Kopfzer- }
{ brechen verursacht hat }
registerdef:=true;
symtablestack:=nil;
{ no operator is overloaded }
{!!!!!!
for i:=PLUS to last_overloaded do
overloaded_operators[i]:=nil;
}
{ falls nicht SYSTEM compiliert wird, SYSTEM laden }
if not(cs_compilesystem in aktswitches) then
begin
readunit(target_info.system_unit);
insertinternsyms;
end;
{ aktueller Rückgabetyp: void }
procinfo.retdef:=voiddef;
{ lexikalisches Level zurücksetzen }
lexlevel:=0;
{ Quelltext parsen }
if token=_UNIT then
begin
proc_unit;
comp_unit:=true;
end
else
begin
proc_program;
comp_unit:=false;
end;
consume(_EOF);
if codegeneration then
begin
if cs_optimize in aktswitches then simpljumpopt(mainasmlist);
if cs_debuginfo in aktswitches then
begin
debuginfos.insert(gennasmrec(DIRECT,S_NO,'Ltext0:'));
mainasmlist.insertlist(@debuginfos);
end;
mainasmlist.insertlist(@startupasmlist);
{ nun Datensegment anhängen }
mainasmlist.concatlist(@datasegment);
constsegment.insert(gennasmrec(DIRECT,S_NO,'.align 4'));
constsegment.insert(gennasmrec(DIRECT,S_NO,'.data'));
{ nun Constsegment anhängen }
mainasmlist.concatlist(@constsegment);
{ und VMT's: }
mainasmlist.concatlist(@vmtasmlist);
{ Codegenerator beenden }
codegendone;
{ Inputpuffer entfernen }
donescanner;
if writeasmfile then
begin
{ use extern assembler }
writemainasmlist(inputdir+inputfile+'.s');
if not(quiet) then
writeln('Calling assembler...');
swapvectors;
exec(env_ppbin+'AS.EXE','-o '+inputdir+inputfile+target_info.objext+' '+inputdir+inputfile+'.S');
swapvectors;
if dosexitcode<>0 then
halt(100);
end
else
begin
writeofile(inputdir+inputfile+'.o');
end;
{ del all instructions }
mainasmlist.done;
end
else
begin
case language of
'D' : write(errorcount,' Fehler');
'E' : write(errorcount,' errors');
end;
writeln;
halt(1);
end;
{ Linkresponsedatei erst hier schließen, da auch }
{ die per $L aufgenommenen Units in Linkresponse }
{ eingetragen werden }
if not(comp_unit) then
begin
hs:=linkofiles.get;
while hs<>'' do
begin
writeln(linkresponse,hs);
hs:=linkofiles.get;
end;
close(linkresponse);
if not(quiet) then
writeln('Calling linker...');
swapvectors;
exec(env_ppbin+'LD.EXE','@LINK.RES');
swapvectors;
if dosexitcode<>0 then
halt(100);
erase(linkresponse);
end;
end;
end.
