{****************************************************************************
Copyright (c) 1993,96 by Florian Klämpfl
****************************************************************************}
{$I-}
unit symtable;
interface
uses
objects,cobjects,systems,globals,asmgen,dos,strings;
const
{ Symboltabellentypen }
localsymtable = $8000;
parasymtable = $4000;
withsymtable = 1;
staticsymtable = 2;
globalsymtable = 3;
unitsymtable = 4;
objectsymtable = 5;
recordsymtable = 6;
macrosymtable = 7;
{ Konstanten für Unterprogrammoptionen }
poexceptions = $1;
povirtualmethod = $2;
poclearstack = $4;
poconstructor = $8;
podestructor = $10;
pointernproc = $20;
poexports = $40;
poiocheck = $80;
hasharraysize = 97;
{ last operator which can overloaded }
last_overloaded = PLUS;
type
{ "forward" pointer }
pformaldef = ^tformaldef;
pfiledef = ^tfiledef;
pclassdef = ^tclassdef;
precdef = ^trecdef;
parraydef = ^tarraydef;
ppointerdef = ^tpointerdef;
pstringdef = ^tstringdef;
paufzaehldef = ^taufzaehldef;
pgrunddef = ^tgrunddef;
pprocdef = ^tprocdef;
perrordef = ^terrordef;
psetdef = ^tsetdef;
psymtable = ^tsymtable;
pdef = ^tdef;
pprocvardef = ^tprocvardef;
pabstractprocdef = ^tabstractprocdef;
psym = ^tsym;
plabelsym = ^tlabelsym;
{ Grundtypen }
tgrundtyp = (uauto,u8bit,s32bit,s64real,uvoid,bool8bit,uchar,
s8bit,s16bit,u16bit);
{ Symboltabelleneinträge }
tsymtyp = (abstractsym,varsym,typesym,procsym,unitsym,programsym,
constsym,aufzaehlsym,typedconstsym,errorsym,syssym,
labelsym);
tsym = object
typ : tsymtyp;
_name : pchar;
left : psym;
right : psym;
speedvalue : longint;
forwarddef : boolean;
constructor init(const n : string);
constructor load;
destructor done;virtual;
procedure write;virtual;
procedure deref;virtual;
function name : string;
procedure setname(const s : string);
end;
tlabelsym = object(tsym)
number : longint;
defined : boolean;
constructor init(const n : string;l : longint);
destructor done;virtual;
procedure write;virtual;
end;
punitsym = ^tunitsym;
tunitsym = object(tsym)
unitsymtable : psymtable;
constructor init(const n : string;ref : psymtable);
procedure write;virtual;
end;
pmacrosym = ^tmacrosym;
tmacrosym = object(tsym)
defined : boolean;
end;
perrorsym = ^terrorsym;
terrorsym = object(tsym)
constructor init;
end;
pprocsym = ^tprocsym;
tprocsym = object(tsym)
definition : pprocdef;
constructor init(const n : string);
constructor load;
destructor done;virtual;
procedure write;virtual;
procedure deref;virtual;
end;
ptypesym = ^ttypesym;
ttypesym = object(tsym)
definition : pdef;
constructor init(const n : string;d : pdef);
constructor load;
procedure write;virtual;
procedure deref;virtual;
end;
tvarspez = (vs_value,vs_const,vs_var);
pvarsym = ^tvarsym;
tvarsym = object(tsym)
adresse : longint;
definition : pdef;
refs : longint;
regable : boolean;
{ falls<>R_NO, dann befindet sich die Variable in einem Register }
reg : tregister;
{ gibt die Art des Zugriffs an }
varspez : tvarspez;
constructor init(const n : string;p : pdef);
constructor load;
function getsize : longint;
procedure write;virtual;
procedure deref;virtual;
end;
ptypedconstsym = ^ttypedconstsym;
ttypedconstsym = object(tsym)
prefix : pstring;
definition : pdef;
constructor init(const n : string;p : pdef);
constructor load;
destructor done;virtual;
procedure write;virtual;
procedure deref;virtual;
end;
tconsttype = (constord,conststring,constreal,constbool,constint,
constchar);
pconstsym = ^tconstsym;
tconstsym = object(tsym)
definition : pdef;
consttype : tconsttype;
value : longint;
constructor init(const n : string;t : tconsttype;v : longint;def : pdef);
constructor load;
procedure deref;virtual;
procedure write;virtual;
end;
paufzaehlsym = ^taufzaehlsym;
taufzaehlsym = object(tsym)
value : longint;
definition : paufzaehldef;
constructor init(const n : string;def : paufzaehldef;v : longint);
constructor load;
procedure write;virtual;
procedure deref;virtual;
end;
pprogramsym = ^tprogramsym;
tprogramsym = object(tsym)
constructor init(const n : string);
end;
psyssym = ^tsyssym;
tsyssym = object(tsym)
number : longint;
constructor init(const n : string;l : longint);
procedure write;virtual;
end;
tcallback = procedure(p : psym);
tsymtablehasharray = array[0..hasharraysize-1] of psym;
psymtablehasharray = ^tsymtablehasharray;
tsymtable = object
{ Name wird bei parasymtables als call_offset-Speicher benutzt ! }
{ (dann longint) }
name : pstring;
datasize : longint;
symtabletype : word;
wurzel : psym;
hasharray : psymtablehasharray;
next : psymtable;
{ gibt bei unitsymtables eine Nummer an, um später die }
{ Typen etc eindeutig einer Unit zuzuordnen können }
unitid : word;
wurzeldef : pdef; { Hier werden die internen Typenpointer eingesammelt }
constructor init(t : word);
constructor load;
constructor loadasstruct(typ : word);
destructor done;virtual;
procedure insert(sym : psym);
function search(const s : stringid) : psym;
procedure clear;
procedure registerdef(p : pdef);
procedure foreach(proc2call : tcallback);
procedure allsymbolsused;
procedure write;
procedure writeasunit;
procedure writeasstruct;
function getdefnr(l : word) : pdef;
end;
punitsymtable = ^tunitsymtable;
tunitsymtable = object(tsymtable)
checksum,maschstart : longint;
constructor load(const n : string);
end;
{ das braucht nun der Compiler }
tdeftype = (abstractdef,arraydef,recorddef,pointerdef,grunddef,
stringdef,aufzaehldef,procdef,classdef,errordef,
filedef,formaldef,setdef,procvardef);
tdef = object
deftype : tdeftype;
savesize : longint;
number : word;
owner : psymtable;
next : pdef;
function size : longint;virtual;
constructor init;
destructor done;virtual;
procedure write;virtual;
procedure deref;virtual;
end;
tfiletyp = (ft_text,ft_typed,ft_untyped);
tfiledef = object(tdef)
public
filetyp : tfiletyp;
typed_as : pdef;
constructor init(ft : tfiletyp;tas : pdef);
constructor load;
procedure write;virtual;
procedure deref;virtual;
private
procedure setsize;
end;
tformaldef = object(tdef)
constructor init;
constructor load;
procedure write;virtual;
end;
terrordef = object(tdef)
constructor init;
end;
tpointerdef = object(tdef)
definition : pdef;
constructor init(def : pdef);
constructor load;
procedure write;virtual;
procedure deref;virtual;
end;
tarraydef = object(tdef)
lowrange : longint;
highrange : longint;
rangenr : longint;
definition : pdef;
rangedef : pdef;
function elesize : longint;
constructor init(l,h : longint;rd : pdef);
constructor load;
procedure write;virtual;
procedure deref;virtual;
function size : longint;virtual;
{ erzeugt falls notwendig Grenzwerte für Range-Checking }
procedure genrangecheck;
end;
trecdef = object(tdef)
symtable : psymtable;
constructor init(p : psymtable);
constructor load;
destructor done;virtual;
procedure write;virtual;
procedure deref;virtual;
end;
tgrunddef = object(tdef)
von : longint;
bis : longint;
rangenr : longint;
typ : tgrundtyp;
constructor init(t : tgrundtyp;v,b : longint);
constructor load;
procedure write;virtual;
procedure setsize;
{ erzeugt falls notwendig Grenzwerte fuer Range-Checking }
procedure genrangecheck;
end;
pdefcoll = ^tdefcoll;
tdefcoll = record
data : pdef;
next : pdefcoll;
paratyp : tvarspez;
end;
tabstractprocdef = object(tdef)
retdef : pdef; { Definition des Returntypes }
options : word;
para1 : pdefcoll;
constructor init;
constructor load;
destructor done;virtual;
procedure concatdef(p : pdef;vsp : tvarspez);
procedure deref;virtual;
procedure write;virtual;
end;
tprocvardef = object(tabstractprocdef)
constructor init;
constructor load;
procedure write;virtual;
end;
tprocdef = object(tabstractprocdef)
usedregisters : byte;
extnumber : longint;
nextoverloaded : pprocdef;
localst : psymtable; { Pointer auf die lokalen Symbole }
parast : psymtable; { Pointer auf die Parameter }
forwarddef : boolean; { true, wenn nur deklariert }
_mangledname : pchar;
constructor init;
destructor done;virtual;
constructor load;
procedure write;virtual;
procedure deref;virtual;
function mangledname : string;
procedure setmangledname(const s : string);
end;
tstringdef = object(tdef)
len : byte;
constructor init(l : byte);
constructor load;
procedure write;virtual;
end;
taufzaehldef = object(tdef)
max : longint;
constructor init;
constructor load;
procedure write;virtual;
end;
tclassdef = object(tdef)
childof : pclassdef;
name : pstring;
{ privatesyms : psymtable;
protectedsyms : psymtable; }
publicsyms : psymtable;
constructor init(const n : string;c : pclassdef);
destructor done;virtual;
function isrelated(d : pclassdef) : boolean;
function size : longint;virtual;
constructor load;
procedure write;virtual;
procedure deref;virtual;
end;
tsettyp = (normset);
tsetdef = object(tdef)
setof : pdef;
settyp : tsettyp;
constructor init(s : pdef;high : longint);
constructor load;
procedure write;virtual;
procedure deref;virtual;
end;
punitnamerec = ^tunitnamerec;
tunitnamerec = record
unitname : pstring;
next : punitnamerec;
end;
{ initialisiert die Symboltabellenverwaltung }
procedure init_symtable;
procedure getsym(const s : stringid;notfounderror : boolean);
procedure getsymonlyin(p : psymtable;const s : stringid);
{ schreibt eine Unit unter dem angegebenen Namen }
{ und gibt die Größe der erzeugten Datei zurück }
function writeunitas(const s : string;unitsymtable : psymtable) : longint;
function readunit(from : string) : punitsymtable;
{ entfernt eine Symboltabelle vom Symboltabellenstack }
procedure dellexlevel;
{ speichert eine "forward"-Pointerdefinition }
procedure save_forward(ppd : ppointerdef;typesym : ptypesym);
procedure resolve_forwards;
var
registerdef : boolean; { true, wenn Definitionen }
{ registriert werden sollen }
symtablestack : psymtable; { Wurzel der verketteten Liste von }
{ Symboltabellen }
srsym : psym; { enthält das Ergebnis der letzten }
srsymtable : psymtable; { Suche nach einem Symbol }
forwardsallowed : boolean; { true, wenn Pointertypen "forward" }
{ eingefügt werden dürfen }
constsymtable : psymtable; { Symboltabelle in die die }
{ Konstanten von z.B. Aufzählungs- }
{ typen eingefügt werden }
voiddef : pgrunddef; { Zeiger auf eine void-Definition }
{ wird von quelltext initialisiert }
{ (ist resulttype einer Procedure) }
voidpointerdef : ppointerdef;
{ Zeiger auf "void"-Pointerdef }
s32bitdef : pgrunddef; { Zeiger für resulttype von }
{ intconstn }
u8bitdef : pgrunddef; { Pointer auf 8-Bit unsigned }
u16bitdef : pgrunddef; { Pointer auf 8-Bit unsigned }
cs64realdef : pgrunddef; { Zeiger für resulttype von }
{ realconstn }
cstringdef : pstringdef; { Zeiger für resulttype von }
{ stringconstn }
cchardef : pgrunddef; { Zeiger für resulttype von }
{ charconstn }
booldef : pgrunddef; { Zeiger auf boolschen Typ }
aktprocsym : pprocsym; { Zeiger auf den Symboltablellen- }
{ eintrag der momentan geparseten }
{ procedure }
procprefix : string; { eindeutige Namen bei geschachtel- }
{ ten Unterprogrammen erzeugen }
lexlevel : word; { Stufen von verschachtelten }
{ Unterprogrammen }
macros : psymtable; { Zeiger auf die Symboltabelle mit }
{ Makros }
usedunits : tstringcontainer;
{ enthaelt die Namen aller zu }
{ initialisierenden Units }
read_member : boolean; { true, wenn Members aus einer PPU- }
{ Datei gelesen werden, d.h. ein }
{ varsym seine Adresse einlesen soll }
generrorsym : psym; { Jokersymbol, wenn das richtige }
{ Symbol nicht gefunden wird }
generrordef : pdef; { Jokersymbol für eine fehlerhafte }
{ Typdefinition }
{
!!!! overloaded_operators : array[PLUS..last_overloaded] of pprocsym;
}
overloaded_operators : array[0..0] of pprocsym;
implementation
var
aktrecordsymtable : psymtable; { zeigt auf die Symboltabelle des }
{ Records, das momentan aus einer }
{ PPU-Datei gelesen wird }
const
ibloadunit = 1;
ibgrunddef = 2;
ibpointerdef = 3;
ibtypesym = 4;
ibarraydef = 5;
ibprocdef = 6;
ibprocsym = 7;
iblinkofile = 8;
ibstringdef = 9;
ibvarsym = 10;
ibconstsym = 11;
ibinitunit = 12;
ibaufzaehlsym = 13;
ibtypedconstsym = 14;
ibrecorddef = 15;
ibfiledef = 16;
ibformaldef = 17;
ibclassdef = 18;
ibaufzaehldef = 19;
ibsetdef = 20;
ibprocvardef = 21;
ibend = 255;
{ Compilerversion }
{ Format | }
{ Kennung | | }
{ | | | }
{ /-------\ /-------\ /---\ }
unitheader : array[0..19] of char = ('P','P','U','0','1','0',#0,#6,
#0,#255,#0,#0,#0,#0,#255,#255,
{ | | \---------/ \-------/ }
{ | | | | }
{ | | Checksumme | }
{ | \--momentan unbenutzt }
{ Zielbetriebssystem }
#0,#0,#0,#0);
{\---------/ }
{ | }
{ Start der Maschinensprache }
const
{$ifdef tp}
buffersize = 10000;
{$else}
buffersize = 1024*1024;
{$endif}
type
tubuffer = array[0..buffersize-1] of byte;
txbuffer = array[0..buffersize div 4] of longint;
pxbuffer = ^txbuffer;
var
unitfile : file;
buffer : ^tubuffer;
bufferl,bufferp : word;
checksum : longint;
procedure writebuffer;
var
i : longint;
begin
for i:=0 to ((bufferp-1) div 4)-1 do
checksum:=checksum xor pxbuffer(buffer)^[i];
blockwrite(unitfile,buffer^,bufferp);
bufferp:=0;
end;
procedure writebyte(b : byte);
begin
if bufferp>=buffersize then
writebuffer;
buffer^[bufferp]:=b;
inc(bufferp);
end;
procedure writelong(l : longint);
begin
if bufferp>=buffersize-3 then
writebuffer;
move(l,buffer^[bufferp],4);
inc(bufferp,4);
end;
procedure writedouble(d : double);
begin
if bufferp>=buffersize-7 then
writebuffer;
move(d,buffer^[bufferp],8);
inc(bufferp,8);
end;
procedure writeword(w : word);
begin
if bufferp>=buffersize-1 then
writebuffer;
move(w,buffer^[bufferp],2);
inc(bufferp,2);
end;
procedure writestring(const s : string);
begin
if bufferp>=buffersize-length(s) then
writebuffer;
move(s[0],buffer^[bufferp],length(s)+1);
inc(bufferp,length(s)+1);
end;
procedure writedefref(p : pdef);
begin
if p=nil then
writelong($ffffffff)
else
begin
if (p^.owner^.symtabletype=recordsymtable) or
(p^.owner^.symtabletype=objectsymtable) then
writeword($ffff)
else writeword(p^.owner^.unitid);
writeword(p^.number);
end;
end;
function writeunitas(const s : string;unitsymtable : psymtable) : longint;
var
size : longint;
maschstart : longint;
begin
assign(unitfile,s);
rewrite(unitfile,1);
if ioresult<>0 then
fatalerror(cannot_write_unitfile);
getmem(buffer,buffersize);
{ FPKPascal hat mit char(target) ein Problem }
unitheader[8]:=char(byte(target_info.target));
move(unitheader[0],buffer^,sizeof(unitheader));
bufferp:=sizeof(unitheader);
checksum:=0;
unitsymtable^.writeasunit;
{ jetzt noch denn Rest im Buffer schreiben }
writebuffer;
{$ifdef aout}
maschstart:=bufferp;
{$endif}
seek(unitfile,10);
blockwrite(unitfile,checksum,4);
{$ifdef aout}
seek(unitfile,16);
blockwrite(unitfile,maschstart,4);
{$endif}
size:=filesize(unitfile);
close(unitfile);
freemem(buffer,buffersize);
writeunitas:=size;
end;
type
ploaded_units = ^tloaded_units;
tloaded_units = record
name : pstring;
unitpos : psymtable;
next : ploaded_units;
end;
var
loaded_units : ploaded_units;
function searchsymtable(name : stringid) : psymtable;
var
hs : ploaded_units;
begin
hs:=loaded_units;
while (assigned(hs)) do
if (hs^.name^=name) then
begin
searchsymtable:=hs^.unitpos;
exit;
end
else
hs:=hs^.next;
searchsymtable:=nil;
end;
const
{$ifdef tp}
maxunitsize = 65000;
maxsymtables = 255;
{$else}
maxunitsize = 1024*1024*16;
maxsymtables = 1024;
{$endif}
type
trbuffer = array[0..maxunitsize] of byte;
prbuffer = ^trbuffer;
var
rbuffer : prbuffer;
type
tsymtablemap = array[0..maxsymtables] of psymtable;
psymtablemap = ^tsymtablemap;
var
aktsymtablemap : psymtablemap;
function readbyte : byte;
begin
if bufferp>bufferl-1 then
fatalerror(error_reading_unit);
inc(bufferp);
readbyte:=rbuffer^[bufferp-1];
end;
function readword : word;
var
w : word;
begin
if bufferp>bufferl-2 then
fatalerror(error_reading_unit);
move(rbuffer^[bufferp],w,2);
inc(bufferp,2);
readword:=w;
end;
function readlong : longint;
var
l : longint;
begin
if bufferp>bufferl-4 then
fatalerror(error_reading_unit);
move(rbuffer^[bufferp],l,4);
inc(bufferp,4);
readlong:=l;
end;
function readdouble : double;
var
d : double;
begin
if bufferp>bufferl-8 then
fatalerror(error_reading_unit);
move(rbuffer^[bufferp],d,8);
inc(bufferp,8);
readdouble:=d;
end;
function readstring : string;
var
s : string;
begin
s[0]:=char(readbyte);
if bufferp>bufferl-ord(s[0]) then
fatalerror(error_reading_unit);
move(rbuffer^[bufferp],s[1],ord(s[0]));
inc(bufferp,ord(s[0]));
readstring:=s;
end;
function readdefref : pdef;
var
hd : pdef;
begin
longint(hd):=readword;
longint(hd):=longint(hd) or (longint(readword) shl 16);
readdefref:=hd;
end;
procedure resolvedef(var d : pdef);
begin
if longint(d)=$ffffffff then
d:=nil
else
begin
if (longint(d) and $ffff)=$ffff then
d:=aktrecordsymtable^.getdefnr(longint(d) shr 16)
else
d:=aktsymtablemap^[longint(d) and $ffff]^.getdefnr(longint(d) shr 16);
end;
end;
var
readunit_lastloaded : punitnamerec;
function readunit(from : string) : punitsymtable;
var
p : punitsymtable;
b : integer;
l : longint;
oldbuffer : prbuffer;
oldbufferl,oldbufferp : word;
dummy : boolean;
hp : punitnamerec;
hr : tunitnamerec;
begin
{ suchen ob im selben "Stapel" schon einmal versucht wird die }
{ Unit from zu laden }
hp:=readunit_lastloaded;
while hp<>nil do
begin
if hp^.unitname^=from then
fatalerror(rec_unit_def);
hp:=hp^.next;
end;
hr.next:=readunit_lastloaded;
hr.unitname:=@from;
readunit_lastloaded:=@hr;
p:=punitsymtable(searchsymtable(from));
{ Ist die Unit schon geladen ? }
if assigned(p) then
begin
readunit_lastloaded:=readunit_lastloaded^.next;
readunit:=p;
exit;
end;
oldbuffer:=rbuffer;
oldbufferp:=bufferp;
oldbufferl:=bufferl;
{ Pfad, in dem das Programm liegt ausprobieren }
assign(unitfile,inputdir+from+'.PPU');
reset(unitfile,1);
if ioresult<>0 then
begin
{ ansonsten Pfad in dem der Compiler liegt }
assign(unitfile,unitpath+from+'.PPU');
reset(unitfile,1);
if ioresult<>0 then
begin
{ im schlimmsten Fall Umgebungsvariable auswerten }
assign(unitfile,search(from+'.PPU',getenv(target_info.unit_env),dummy)+from+'.PPU');
reset(unitfile,1);
if ioresult<>0 then
begin
exterror:=strpnew('Unit '+from);
fatalerror(unit_not_found);
end;
end;
end;
l:=filesize(unitfile);
if l>maxunitsize then
fatalerror(error_reading_unit);
if not quiet then
writeln('Lade '+from+'.PPU');
getmem(rbuffer,l);
blockread(unitfile,rbuffer^,l,bufferl);
close(unitfile);
{ auf Format prüfen }
for b:=0 to 5 do
if rbuffer^[b]<>byte(unitheader[b]) then
fatalerror(malformed_unit);
if (rbuffer^[8])<>byte(target_info.target) then
fatalerror(not_same_target);
bufferp:=sizeof(unitheader);
p:=new(punitsymtable,load(from));
p^.checksum:=plongint(@rbuffer^[10])^;
p^.maschstart:=plongint(@rbuffer^[16])^;
freemem(rbuffer,l);
rbuffer:=oldbuffer;
bufferp:=oldbufferp;
bufferl:=oldbufferl;
{ Alle geladenen Units merken, erst am Ende einfügen da }
{ alle Units die vorausgesetzt werden, davor geladen }
{ werden sollten }
{ im Unit-"Namenstack" eine Ebene entfernen }
readunit_lastloaded:=readunit_lastloaded^.next;
p^.next:=symtablestack;
symtablestack:=p;;
readunit:=p;
end;
{$I+}
procedure getsym(const s : stringid;notfounderror : boolean);
begin
srsymtable:=symtablestack;
while assigned(srsymtable) do
begin
srsym:=srsymtable^.search(s);
if assigned(srsym) then exit
else srsymtable:=srsymtable^.next;
end;
if forwardsallowed then
begin
srsymtable:=symtablestack;
srsym:=new(ptypesym,init(s,nil));
srsym^.forwarddef:=true;
srsymtable^.insert(srsym);
end
else if notfounderror then
begin
exterror:=strpnew(s);
error(id_not_found);
srsym:=generrorsym;
end
else srsym:=nil;
end;
procedure getsymonlyin(p : psymtable;const s : stringid);
begin
srsymtable:=p;
srsym:=srsymtable^.search(s);
if assigned(srsym) then exit
else fatalerror(id_not_found);
end;
procedure dellexlevel;
var
p : psymtable;
begin
p:=symtablestack;
symtablestack:=p^.next;
dispose(p,done);
end;
constructor tprocsym.init(const n : string);
begin
tsym.init(n);
typ:=procsym;
definition:=nil;
end;
constructor tprocsym.load;
begin
tsym.load;
typ:=procsym;
definition:=pprocdef(readdefref);
end;
destructor tprocsym.done;
var
pd : pprocdef;
begin
pd:=definition;
while assigned(pd) do
begin
if pd^.forwarddef then
begin
exterror:=strpnew(name);
error(forward_not_resolved);
end;
pd:=pd^.nextoverloaded;
end;
tsym.done;
end;
procedure tprocsym.deref;
begin
resolvedef(pdef(definition));
end;
constructor tprogramsym.init(const n : string);
begin
tsym.init(n);
typ:=programsym;
end;
constructor tsymtable.init(t : word);
var
w : word;
begin
symtabletype:=t;
wurzel:=nil;
next:=nil;
name:=nil;
if symtabletype=objectsymtable then
datasize:=4
else
datasize:=0;
wurzeldef:=nil;
case symtabletype of
globalsymtable,staticsymtable,unitsymtable :
begin
new(hasharray);
for w:=0 to hasharraysize-1 do
hasharray^[w]:=nil;
end;
else hasharray:=nil;
end;
end;
constructor tsymtable.load;
var
hp : pdef;
b : byte;
counter : word;
hs : punitsymtable;
map : psymtablemap;
nextmapentry : word;
sym : psym;
unittoload : stringid;
unitchecksum : longint;
hr : tunitnamerec;
begin
new(map);
map^[0]:=@self;
nextmapentry:=1;
symtabletype:=unitsymtable;
{ Hasharray setzten }
new(hasharray);
for counter:=0 to hasharraysize-1 do
hasharray^[counter]:=nil;
datasize:=0;
wurzel:=nil;
next:=nil;
wurzeldef:=nil;
{ Definitionen einlesen }
counter:=0;
repeat
b:=readbyte;
case b of
ibloadunit : begin
unittoload:=readstring;
unitchecksum:=readlong;
hs:=readunit(unittoload);
{ stimmt die Checksumme in der geladenen Unit }
{ mit der Checksumme in der momentan zu }
{ ladenden Unit überein ? }
if unitchecksum<>hs^.checksum then
begin
{ ja, dann eine Warnung ausgeben }
exterror:=strpnew(name^);
warning(ill_unit_version);
end;
map^[nextmapentry]:=hs;
inc(nextmapentry);
if nextmapentry>maxsymtables then
fatalerror(too_much_units);
end;
ibpointerdef : hp:=new(ppointerdef,load);
ibarraydef : hp:=new(parraydef,load);
ibgrunddef : hp:=new(pgrunddef,load);
ibprocdef : hp:=new(pprocdef,load);
ibstringdef : hp:=new(pstringdef,load);
ibrecorddef : hp:=new(precdef,load);
ibclassdef : hp:=new(pclassdef,load);
ibfiledef : hp:=new(pfiledef,load);
ibformaldef : hp:=new(pformaldef,load);
ibaufzaehldef : hp:=new(paufzaehldef,load);
ibinitunit : usedunits.insert(readstring);
iblinkofile : linkofiles.insert(readstring);
ibsetdef : hp:=new(psetdef,load);
ibprocvardef : hp:=new(pprocvardef,load);
ibend : break;
else fatalerror(malformed_unit);
end;
if (b<>ibloadunit) and (b<>ibinitunit) and (b<>iblinkofile) then
begin
{ Numerieren }
hp^.number:=counter;
inc(counter);
hp^.next:=wurzeldef;
wurzeldef:=hp;
end;
until false;
{ nun die Definitionen Dereferenzieren }
aktsymtablemap:=map;
hp:=wurzeldef;
while assigned(hp) do
begin
hp^.deref;
{Besitzer setzen }
hp^.owner:=@self;
hp:=hp^.next;
end;
{ nun Symbole einlesen }
repeat
b:=readbyte;
case b of
ibtypesym : sym:=new(ptypesym,load);
ibprocsym : sym:=new(pprocsym,load);
ibconstsym : sym:=new(pconstsym,load);
ibvarsym : sym:=new(pvarsym,load);
ibaufzaehlsym : sym:=new(paufzaehlsym,load);
ibtypedconstsym : sym:=new(ptypedconstsym,load);
ibend : break;
else fatalerror(malformed_unit);
end;
sym^.deref;
insert(sym);
until false;
dispose(map);
end;
constructor tunitsymtable.load(const n : string);
var
hp : ploaded_units;
begin
name:=stringdup(n);
new(hp);
hp^.name:=name;
hp^.unitpos:=@self;
hp^.next:=loaded_units;
loaded_units:=hp;
inherited load;
end;
constructor tsymtable.loadasstruct(typ : word);
var
hp : pdef;
b : byte;
counter : word;
sym : psym;
begin
symtabletype:=typ;
hasharray:=nil;
aktrecordsymtable:=@self;
name:=nil;
if symtabletype=objectsymtable then
datasize:=4
else
datasize:=0;
wurzel:=nil;
next:=nil;
wurzeldef:=nil;
{ Definitionen einlesen }
counter:=0;
repeat
b:=readbyte;
case b of
ibpointerdef : hp:=new(ppointerdef,load);
ibarraydef : hp:=new(parraydef,load);
ibgrunddef : hp:=new(pgrunddef,load);
ibprocdef : hp:=new(pprocdef,load);
ibstringdef : hp:=new(pstringdef,load);
ibrecorddef : hp:=new(precdef,load);
ibclassdef : hp:=new(pclassdef,load);
ibaufzaehldef : hp:=new(paufzaehldef,load);
ibsetdef : hp:=new(psetdef,load);
ibprocvardef : hp:=new(pprocvardef,load);
ibfiledef : hp:=new(pfiledef,load);
ibformaldef : hp:=new(pformaldef,load);
ibend : break;
else fatalerror(malformed_unit);
end;
{ Numerieren }
hp^.number:=counter;
inc(counter);
hp^.next:=wurzeldef;
wurzeldef:=hp;
until false;
{ dereferenziert wird erst in trecdef^.deref }
{ nun Symbole einlesen }
repeat
b:=readbyte;
case b of
ibtypesym : sym:=new(ptypesym,load);
ibprocsym : sym:=new(pprocsym,load);
ibconstsym : sym:=new(pconstsym,load);
ibvarsym : sym:=new(pvarsym,load);
ibaufzaehlsym : sym:=new(paufzaehlsym,load);
ibtypedconstsym : sym:=new(ptypedconstsym,load);
ibend : break;
else fatalerror(malformed_unit);
end;
insert(sym);
until false;
end;
destructor tsymtable.done;
var
hp : pdef;
begin
{ erst die Einträge loeschen, da procsym's noch ihre Definitionen }
{ auf unaufgelöste "forwards" ueberpruefen }
clear;
hp:=wurzeldef;
while assigned(hp) do
begin
wurzeldef:=hp^.next;
dispose(hp,done);
hp:=wurzeldef;
end;
end;
function tsymtable.getdefnr(l : word) : pdef;
var
hp : pdef;
begin
hp:=wurzeldef;
while (assigned(hp)) and (hp^.number<>l) do
hp:=hp^.next;
getdefnr:=hp;
end;
procedure tsymtable.registerdef(p : pdef);
begin
p^.next:=wurzeldef;
wurzeldef:=p;
p^.owner:=@self;
end;
procedure tsymtable.clear;
var
w : integer;
begin
if assigned(wurzel) then
dispose(wurzel,done);
if assigned(hasharray) then
begin
for w:=0 to hasharraysize-1 do
if assigned(hasharray^[w]) then
dispose(hasharray^[w],done);
dispose(hasharray);
end;
end;
function getspeedvalue(const s : string) : longint;
var
l : longint;
w : word;
begin
l:=0;
for w:=1 to length(s) do
l:=l+ord(s[w]);
getspeedvalue:=l;
end;
procedure tsymtable.insert(sym : psym);
procedure _insert(var osym : psym);
begin
if osym=nil then osym:=sym
else if osym^.speedvalue>sym^.speedvalue then _insert(osym^.right)
else if osym^.speedvalue<sym^.speedvalue then _insert(osym^.left)
else
begin
if osym^.name>sym^.name then _insert(osym^.right)
else if osym^.name<sym^.name then _insert(osym^.left)
else
begin
if (osym^.typ=typesym) and osym^.forwarddef then
begin
if (sym^.typ<>typesym) then fatalerror(id_already_type);
if (ptypesym(sym)^.definition^.deftype<>recorddef) and
(ptypesym(sym)^.definition^.deftype<>classdef) then
fatalerror(type_must_be_rec_or_class);
ptypesym(osym)^.definition:=ptypesym(sym)^.definition;
osym^.forwarddef:=false;
dispose(sym);
end
else
begin
exterror:=strpnew(sym^.name);
error(dupid);
end;
end;
end;
end;
var
l : longint;
hp : psymtable;
hsym : psym;
begin
{ bei Symbolen für Variablen die Adresse eintragen, }
{ und Größe der Symboltabellendaten berechnen }
if (sym^.typ=varsym) and not(read_member) then
begin
{ bei einer lokalen Symboltabelle erst! erhöhen, da der }
{ Wert in codegen.secondload dann mit minus verwendet }
{ wird }
l:=pvarsym(sym)^.getsize;
if (symtabletype and $8000)=localsymtable then
begin
inc(datasize,l);
if (l>=4) and ((datasize and 3)<>0) then
inc(datasize,4-(datasize and 3))
else if (l>=2) and ((datasize and 1)<>0) then
inc(datasize,2-(datasize and 1));
pvarsym(sym)^.adresse:=datasize;
end
else if (symtabletype and $3fff)=staticsymtable then
begin
datasegment.concat(gennasmrec(
A_STATIC,S_NO,'_'+sym^.name+','+tostr(l)));
inc(datasize,l);
{ Symbol kann nicht in Register geladen werden }
pvarsym(sym)^.regable:=false;
end
else if (symtabletype and $3fff)=globalsymtable then
begin
datasegment.concat(gennasmrec(
A_GLOBAL,S_NO,'U_'+name^+'_'+sym^.name+','+tostr(l)));
inc(datasize,l);
{ Symbol kann nicht in Register geladen werden }
pvarsym(sym)^.regable:=false;
end
else if ((symtabletype and $3fff)=recordsymtable) or
((symtabletype and $3fff)=objectsymtable) then
begin
if aktpackrecords=2 then
begin
{ auf Wordgrenzen ausrichten }
if (l>=2) and ((datasize and 1)<>0) then
inc(datasize);
end;
pvarsym(sym)^.adresse:=datasize;
inc(datasize,l);
{ Symbol kann nicht in Register geladen werden }
pvarsym(sym)^.regable:=false;
end
else if (symtabletype and $4000)=parasymtable then
begin
{
if (l>=4) and ((datasize and 3)<>0) then
inc(datasize,4-(datasize and 3))
else if (l>=2) and ((datasize and 1)<>0) then
inc(datasize,2-(datasize and 1));
}
pvarsym(sym)^.adresse:=datasize;
{ 1 Byte große Parameter werden als Word übergeben, }
{ da z.B. PUSH AH nicht möglich ist }
if l=1 then l:=2;
inc(datasize,l);
{ Symbol kann nicht in Register geladen werden }
pvarsym(sym)^.regable:=false;
end
else
begin
if (l>=4) and ((datasize and 3)<>0) then
inc(datasize,4-(datasize and 3))
else if (l>=2) and ((datasize and 1)<>0) then
inc(datasize,2-(datasize and 1));
pvarsym(sym)^.adresse:=datasize;
inc(datasize,l);
end;
end
else if sym^.typ=typedconstsym then
begin
if (symtabletype and $3fff)=globalsymtable then
begin
constsegment.concat(gennasmrec(DIRECT,S_NO,'.globl TC_'+
ptypedconstsym(sym)^.prefix^+'_'+sym^.name));
end;
if not((symtabletype and $3fff)=unitsymtable) then
begin
constsegment.concat(gennasmrec(DIRECT,S_NO,'TC_'+
ptypedconstsym(sym)^.prefix^+'_'+sym^.name+':'));
end;
end;
if (symtabletype=staticsymtable) or
(symtabletype=globalsymtable) then
begin
hp:=symtablestack;
while assigned(hp) do
begin
if (hp^.symtabletype and $3fff=staticsymtable) or
(hp^.symtabletype and $3fff=globalsymtable) then
begin
hsym:=hp^.search(sym^.name);
if (assigned(hsym)) and
not(hsym^.forwarddef) then
begin
exterror:=strpnew(sym^.name);
error(dupid);
end;
end;
hp:=hp^.next;
end;
end;
sym^.speedvalue:=getspeedvalue(sym^.name);
if assigned(hasharray) then
_insert(hasharray^[sym^.speedvalue mod hasharraysize])
else
_insert(wurzel);
end;
procedure varsymbolused(p : psym);far;
begin
if p^.typ=varsym then
{ unbenutztes Symbol ist vielleicht Folgefehler }
if (pvarsym(p)^.refs=0) and (errorcount=0) then
begin
exterror:=strpnew(p^.name);
warning(symbol_not_used);
end;
end;
procedure tsymtable.allsymbolsused;
begin
{$ifdef tp}
foreach(varsymbolused);
{$else}
foreach(@varsymbolused);
{$endif}
end;
function tsymtable.search(const s : stringid) : psym;
var
hp : psym;
w : word;
speedvalue : longint;
begin
speedvalue:=getspeedvalue(s);
if assigned(hasharray) then
hp:=hasharray^[speedvalue mod hasharraysize]
else
hp:=wurzel;
while assigned(hp) do
begin
if speedvalue>hp^.speedvalue then hp:=hp^.left
else if speedvalue<hp^.speedvalue then hp:=hp^.right
else
begin
if hp^.name=s then
begin
search:=hp;
exit;
end
else if s>hp^.name then hp:=hp^.left
else hp:=hp^.right;
end;
end;
search:=nil;
end;
procedure tsymtable.foreach(proc2call : tcallback);
procedure a(p : psym);
{ sollte Preorder sein }
{ wegen Einlesen einer Unit }
begin
proc2call(p);
if assigned(p^.left) then a(p^.left);
if assigned(p^.right) then a(p^.right);
end;
var
i : integer;
begin
if hasharray<>nil then
begin
for i:=0 to hasharraysize-1 do
if assigned(hasharray^[i]) then
a(hasharray^[i]);
end
else
if assigned(wurzel) then
a(wurzel);
end;
{ schreibt ein einzelnes Symbol (wird nur als "Callback" aufgerufen) }
procedure writesym(p : psym);far;
begin
p^.write;
end;
procedure tsymtable.writeasunit;
var
counter : word;
s : string;
p : psymtable;
begin
unitid:=0;
{ zuerst alle im Interface-Abschnitt aufgeführten Units }
{ in die Datei schreiben und numerieren }
p:=next;
counter:=1;
{ im Implementationsteil aufgefuehrte Units ueberspringen }
if symtabletype<>globalsymtable then
begin
while (p^.symtabletype<>globalsymtable) do
p:=p^.next;
p:=p^.next;
end;
while assigned(p) do
begin
if p^.symtabletype=unitsymtable then
begin
p^.unitid:=counter;
inc(counter);
writebyte(ibloadunit);
writestring(p^.name^);
writelong(punitsymtable(p)^.checksum);
end;
p:=p^.next;
end;
{ die Namen der benutzten Units schreiben }
s:=usedunits.get;
while s<>'' do
begin
writebyte(ibinitunit);
writestring(s);
s:=usedunits.get;
end;
s:=linkofiles.get;
while s<>'' do
begin
writebyte(iblinkofile);
writestring(s);
s:=linkofiles.get;
end;
tsymtable.write;
end;
procedure tsymtable.writeasstruct;
var
counter : word;
s : string;
p : psymtable;
begin
tsymtable.write;
end;
procedure tsymtable.write;
var
pd : pdef;
counter : longint;
begin
{ nun alle Definitionen numerieren }
counter:=0;
pd:=wurzeldef;
while assigned(pd) do
begin
pd^.number:=counter;
inc(counter);
pd:=pd^.next;
end;
{ und jetzt schreiben }
pd:=wurzeldef;
while assigned(pd) do
begin
pd^.write;
pd:=pd^.next;
end;
{ Defintionsende }
writebyte(ibend);
{ ...und per foreach alle Symbole schreiben }
{$ifdef tp}
foreach(writesym);
{$else}
foreach(@writesym);
{$endif}
{ Symbolende }
writebyte(ibend);
end;
{**************************************
"forward"-Pointer
**************************************}
type
presolvelist = ^tresolvelist;
tresolvelist = record
p : ppointerdef;
typ : ptypesym;
next : presolvelist;
end;
var
swurzel : presolvelist;
procedure save_forward(ppd : ppointerdef;typesym : ptypesym);
var
p : presolvelist;
begin
new(p);
p^.next:=swurzel;
p^.p:=ppd;
p^.typ:=typesym;
swurzel:=p;
end;
procedure resolve_forwards;
var
p : presolvelist;
begin
p:=swurzel;
while p<>nil do
begin
swurzel:=swurzel^.next;
p^.p^.definition:=p^.typ^.definition;
dispose(p);
p:=swurzel;
end;
end;
constructor tsym.init(const n : string);
begin
left:=nil;
right:=nil;
setname(n);
typ:=abstractsym;
forwarddef:=false;
end;
constructor tsym.load;
begin
left:=nil;
right:=nil;
setname(readstring);
typ:=abstractsym;
forwarddef:=false;
end;
destructor tsym.done;
begin
{$ifdef tp}
if not(use_big) then
{$endif tp}
strdispose(_name);
if assigned(left) then dispose(left,done);
if assigned(right) then dispose(right,done);
end;
procedure tsym.write;
begin
writestring(name);
end;
procedure tsym.deref;
begin
end;
function tsym.name : string;
var
s : string;
b : byte;
begin
{$ifdef tp}
if use_big then
begin
symbolstream.seek(longint(_name));
symbolstream.read(b,1);
symbolstream.read(s[1],b);
s[0]:=chr(b);
name:=s;
end
else
{$endif}
begin
name:=strpas(_name);
end;
end;
procedure tsym.setname(const s : string);
begin
setstring(_name,s);
end;
{**************************************
TLABELSYM
**************************************}
constructor tlabelsym.init(const n : string;l : longint);
begin
inherited init(n);
typ:=labelsym;
number:=l;
defined:=false;
end;
destructor tlabelsym.done;
begin
if not(defined) then
begin
exterror:=strpnew(name);
error(label_not_defined);
end;
inherited done;
end;
procedure tlabelsym.write;
begin
error(ill_label_pos);
end;
{**************************************
TUNITSYM
**************************************}
constructor tunitsym.init(const n : string;ref : psymtable);
begin
tsym.init(n);
typ:=unitsym;
unitsymtable:=ref;
end;
procedure tunitsym.write;
begin
end;
{**************************************
TTYPESYM
**************************************}
constructor terrorsym.init;
begin
tsym.init('');
typ:=errorsym;
end;
{**************************************
TVARSYM
**************************************}
constructor tvarsym.init(const n : string;p : pdef);
begin
tsym.init(n);
typ:=varsym;
definition:=p;
varspez:=vs_value;
adresse:=0;
refs:=0;
{ möglicher Kandidat für Register: }
case p^.deftype of
pointerdef,aufzaehldef,procvardef : regable:=true;
grunddef : case pgrunddef(p)^.typ of
u8bit,s32bit,bool8bit,uchar,
s8bit,s16bit,u16bit : regable:=true;
else regable:=false;
end;
else regable:=false;
end;
reg:=R_NO;
end;
constructor tvarsym.load;
begin
tsym.load;
typ:=varsym;
varspez:=tvarspez(readbyte);
if read_member then
adresse:=readlong
else adresse:=0;
definition:=readdefref;
{ nie in ein Register }
regable:=false;
reg:=R_NO;
end;
procedure tvarsym.deref;
begin
resolvedef(definition);
end;
procedure tvarsym.write;
begin
writebyte(ibvarsym);
tsym.write;
writebyte(byte(varspez));
if read_member then
writelong(adresse);
writedefref(definition);
end;
function tvarsym.getsize : longint;
begin
{ assigned(definition) ist ein Experiment }
if assigned(definition) then
begin
case varspez of
vs_value : getsize:=definition^.size;
vs_var : getsize:=4;
vs_const : begin
if (definition^.deftype=stringdef) or
(definition^.deftype=arraydef) or
(definition^.deftype=recorddef) or
(definition^.deftype=classdef) or
(definition^.deftype=setdef) then
getsize:=4
else
getsize:=definition^.size;
end;
end;
end;
end;
{**************************************
TTYPEDCONSTSYM
**************************************}
constructor ttypedconstsym.init(const n : string;p : pdef);
begin
tsym.init(n);
typ:=typedconstsym;
definition:=p;
prefix:=stringdup(procprefix);
end;
constructor ttypedconstsym.load;
begin
tsym.load;
typ:=typedconstsym;
definition:=readdefref;
prefix:=stringdup(readstring);
end;
destructor ttypedconstsym.done;
begin
stringdispose(prefix);
tsym.done;
end;
procedure ttypedconstsym.deref;
begin
resolvedef(definition);
end;
procedure ttypedconstsym.write;
begin
writebyte(ibtypedconstsym);
tsym.write;
writedefref(definition);
writestring(prefix^);
end;
{**************************************
TCONSTSYM
**************************************}
constructor tconstsym.init(const n : string;t : tconsttype;v : longint;def : pdef);
begin
tsym.init(n);
typ:=constsym;
definition:=def;
consttype:=t;
value:=v;
end;
constructor tconstsym.load;
var
pd : pdouble;
begin
tsym.load;
typ:=constsym;
consttype:=tconsttype(readbyte);
case consttype of
constint,
constbool,
constchar : value:=readlong;
constord : begin
definition:=readdefref;
value:=readlong;
end;
conststring : value:=longint(stringdup(readstring));
constreal : begin
new(pd);
pd^:=readdouble;
value:=longint(pd);
end;
else fatalerror(malformed_unit);
end;
end;
procedure tconstsym.deref;
begin
if consttype=constord then
resolvedef(pdef(definition));
end;
procedure tconstsym.write;
begin
writebyte(ibconstsym);
tsym.write;
writebyte(byte(consttype));
case consttype of
constint,
constbool,
constchar : writelong(value);
constord : begin
writedefref(definition);
writelong(value);
end;
conststring : writestring(pstring(value)^);
constreal : writedouble(pdouble(value)^);
else internalerror(13);
end;
end;
{**************************************
TAUFZAEHLSYM
**************************************}
constructor taufzaehlsym.init(const n : string;def : paufzaehldef;v : longint);
begin
tsym.init(n);
typ:=aufzaehlsym;
definition:=def;
value:=v;
end;
constructor taufzaehlsym.load;
begin
tsym.load;
typ:=aufzaehlsym;
definition:=paufzaehldef(readdefref);
value:=readlong;
end;
procedure taufzaehlsym.deref;
begin
resolvedef(pdef(definition));
end;
procedure taufzaehlsym.write;
begin
writebyte(ibaufzaehlsym);
tsym.write;
writedefref(definition);
writelong(value);
end;
{**************************************
TTYPESYM
**************************************}
constructor ttypesym.init(const n : string;d : pdef);
begin
tsym.init(n);
typ:=typesym;
definition:=d;
end;
constructor ttypesym.load;
begin
tsym.load;
typ:=typesym;
definition:=readdefref;
end;
procedure ttypesym.deref;
begin
resolvedef(definition);
end;
procedure ttypesym.write;
begin
writebyte(ibtypesym);
tsym.write;
writedefref(definition);
end;
procedure tprocsym.write;
begin
writebyte(ibprocsym);
tsym.write;
writedefref(pdef(definition));
end;
{**************************************
TSYSSYM
**************************************}
constructor tsyssym.init(const n : string;l : longint);
begin
inherited init(n);
typ:=syssym;
number:=l;
end;
procedure tsyssym.write;
begin
end;
{**************************************
TDEF
**************************************}
{ Das braucht der Compiler um die Typendefinitionen zu verwalten }
constructor tdef.init;
begin
deftype:=abstractdef;
if registerdef then symtablestack^.registerdef(@self);
end;
function tdef.size : longint;
begin
size:=savesize;
end;
procedure tdef.write;
begin
end;
procedure tdef.deref;
begin
end;
destructor tdef.done;
begin
end;
{**************************************
TSTRINGDEF
**************************************}
constructor tstringdef.init(l : byte);
begin
tdef.init;
deftype:=stringdef;
len:=l;
savesize:=len+1;
end;
constructor tstringdef.load;
begin
deftype:=stringdef;
len:=readbyte;
savesize:=len+1;
end;
procedure tstringdef.write;
begin
writebyte(ibstringdef);
writebyte(len);
end;
{**************************************
TAUFZAEHLDEF
**************************************}
constructor taufzaehldef.init;
begin
tdef.init;
deftype:=aufzaehldef;
max:=0;
savesize:=4;
end;
constructor taufzaehldef.load;
begin
deftype:=aufzaehldef;
max:=readlong;
savesize:=4;
end;
procedure taufzaehldef.write;
begin
writebyte(ibaufzaehldef);
writelong(max);
end;
{**************************************
TGRUNDDEF
**************************************}
constructor tgrunddef.init(t : tgrundtyp;v,b : longint);
begin
tdef.init;
deftype:=grunddef;
von:=v;
bis:=b;
typ:=t;
setsize;
end;
constructor tgrunddef.load;
begin
deftype:=grunddef;
typ:=tgrundtyp(readbyte);
von:=readlong;
bis:=readlong;
setsize;
if (typ=uvoid) and not(cs_compilesystem in aktswitches) then
voiddef:=@self;
end;
procedure tgrunddef.setsize;
begin
if typ=uauto then
begin
if (von>=0) and (bis<=255) then
begin
savesize:=1;
typ:=u8bit;
end
else if (von>=-128) and (bis<=127) then
begin
savesize:=1;
typ:=s8bit;
end
else if (von>=0) and (bis<=65536) then
begin
savesize:=2;
typ:=u16bit;
end
else if (von>=-32768) and (bis<=32767) then
begin
savesize:=2;
typ:=s16bit;
end
else
begin
savesize:=4;
typ:=s32bit;
end;
end
else
case typ of
uchar,u8bit,bool8bit,s8bit : savesize:=1;
u16bit,s16bit : savesize:=2;
s32bit : savesize:=4;
s64real : savesize:=8;
else savesize:=0;
end;
{ noch keine Rangecheck-Information erzeugt }
rangenr:=0;
end;
procedure tgrunddef.genrangecheck;
begin
if rangenr=0 then
begin
{ nun für das Rangechecking erforderliche Einträge erzeugen: }
rangenr:=getunreglabel;
constsegment.concat(gennasmrec(DIRECT,S_NO,'R_'+tostr(rangenr)+':'));
constsegment.concat(gennasmrec(A_LONG,S_NO,tostr(von)));
constsegment.concat(gennasmrec(A_LONG,S_NO,tostr(bis)));
end;
end;
procedure tgrunddef.write;
begin
writebyte(ibgrunddef);
writebyte(byte(typ));
writelong(von);
writelong(bis);
end;
{**************************************
TFILEDEF
**************************************}
constructor tfiledef.init(ft : tfiletyp;tas : pdef);
begin
inherited init;
deftype:=filedef;
filetyp:=ft;
typed_as:=tas;
setsize;
end;
constructor tfiledef.load;
begin
deftype:=filedef;
{ die Adressen werden später berechnet }
filetyp:=tfiletyp(readbyte);
if filetyp=ft_typed then
typed_as:=readdefref;
setsize;
end;
procedure tfiledef.deref;
begin
if filetyp=ft_typed then
resolvedef(typed_as);
end;
procedure tfiledef.write;
begin
writebyte(ibfiledef);
writebyte(byte(filetyp));
if filetyp=ft_typed then
writedefref(typed_as);
end;
procedure tfiledef.setsize;
begin
case filetyp of
ft_text : savesize:=256;
ft_untyped : savesize:=128;
{!!!!!!}
else internalerror(17);
end;
end;
{**************************************
TPOINTERDEF
**************************************}
constructor tpointerdef.init(def : pdef);
begin
inherited init;
deftype:=pointerdef;
definition:=def;
savesize:=4;
end;
constructor tpointerdef.load;
begin
deftype:=pointerdef;
{ die Adressen werden später berechnet }
definition:=readdefref;
savesize:=4;
end;
procedure tpointerdef.deref;
begin
resolvedef(definition);
end;
procedure tpointerdef.write;
begin
writebyte(ibpointerdef);
writedefref(definition);
end;
{**************************************
TSETDEF
**************************************}
constructor tsetdef.init(s : pdef;high : longint);
begin
inherited init;
deftype:=setdef;
setof:=s;
{ nur normale Sets mit 32 Bytes Größe werden momentan unterstützt }
if high<256 then
begin
settyp:=normset;
savesize:=32;
end
else error(illsettype);
end;
constructor tsetdef.load;
begin
deftype:=setdef;
setof:=readdefref;
settyp:=tsettyp(readbyte);
savesize:=32;
end;
procedure tsetdef.write;
begin
writebyte(ibsetdef);
writedefref(setof);
writebyte(byte(settyp));
end;
procedure tsetdef.deref;
begin
resolvedef(setof);
end;
{**************************************
TFORMALDEF
**************************************}
constructor tformaldef.init;
begin
inherited init;
deftype:=formaldef;
savesize:=4;
end;
constructor tformaldef.load;
begin
deftype:=formaldef;
savesize:=4;
end;
procedure tformaldef.write;
begin
writebyte(ibformaldef);
end;
{**************************************
TARRAYDEF
**************************************}
constructor tarraydef.init(l,h : longint;rd : pdef);
begin
tdef.init;
deftype:=arraydef;
lowrange:=l;
highrange:=h;
rangedef:=rd;
rangenr:=0;
end;
constructor tarraydef.load;
begin
deftype:=arraydef;
rangenr:=0;
{ die Adressen werden später berechnet }
definition:=readdefref;
rangedef:=readdefref;
lowrange:=readlong;
highrange:=readlong;
end;
procedure tarraydef.genrangecheck;
begin
if rangenr=0 then
begin
{ nun für das Rangechecking erforderliche Einträge erzeugen: }
rangenr:=getunreglabel;
constsegment.concat(gennasmrec(DIRECT,S_NO,'R_'+tostr(rangenr)+':'));
constsegment.concat(gennasmrec(A_LONG,S_NO,tostr(lowrange)));
constsegment.concat(gennasmrec(A_LONG,S_NO,tostr(highrange)));
end;
end;
procedure tarraydef.deref;
begin
resolvedef(definition);
resolvedef(rangedef);
end;
procedure tarraydef.write;
begin
writebyte(ibarraydef);
writedefref(definition);
writedefref(rangedef);
writelong(lowrange);
writelong(highrange);
end;
function tarraydef.elesize : longint;
begin
elesize:=definition^.size;
end;
function tarraydef.size : longint;
begin
size:=(highrange-lowrange+1)*elesize;
end;
{**************************************
TRECDEF
**************************************}
constructor trecdef.init(p : psymtable);
begin
tdef.init;
deftype:=recorddef;
symtable:=p;
savesize:=symtable^.datasize;
end;
constructor trecdef.load;
var
oldread_member : boolean;
begin
deftype:=recorddef;
savesize:=readlong;
oldread_member:=read_member;
read_member:=true;
symtable:=new(psymtable,loadasstruct(recordsymtable));
read_member:=oldread_member;
end;
destructor trecdef.done;
begin
dispose(symtable);
end;
procedure derefsym(p : psym);far;
begin
p^.deref;
end;
procedure trecdef.deref;
var
hp : pdef;
oldrecsyms : psymtable;
begin
oldrecsyms:=aktrecordsymtable;
aktrecordsymtable:=symtable;
{ nun die Definitionen Dereferenzieren }
hp:=symtable^.wurzeldef;
while assigned(hp) do
begin
hp^.deref;
{Besitzer setzten }
hp^.owner:=symtable;
hp:=hp^.next;
end;
{$ifdef tp}
symtable^.foreach(derefsym);
{$else}
symtable^.foreach(@derefsym);
{$endif}
aktrecordsymtable:=oldrecsyms;
end;
procedure trecdef.write;
var
oldread_member : boolean;
begin
oldread_member:=read_member;
read_member:=true;
writebyte(ibrecorddef);
writelong(savesize);
self.symtable^.writeasstruct;
read_member:=oldread_member;
end;
{**************************************
TABSTRACTPROCDEF
**************************************}
constructor tabstractprocdef.init;
begin
inherited init;
para1:=nil;
options:=0;
retdef:=voiddef;
savesize:=4;
end;
destructor tabstractprocdef.done;
var
hp : pdefcoll;
begin
hp:=para1;
while assigned(hp) do
begin
para1:=hp^.next;
dispose(hp);
hp:=para1;
end;
inherited done;
end;
procedure tabstractprocdef.concatdef(p : pdef;vsp : tvarspez);
var
hp : pdefcoll;
begin
new(hp);
hp^.paratyp:=vsp;
hp^.data:=p;
hp^.next:=para1;
para1:=hp;
end;
procedure tabstractprocdef.deref;
var
hp : pdefcoll;
begin
inherited deref;
resolvedef(retdef);
hp:=para1;
while assigned(hp) do
begin
resolvedef(hp^.data);
hp:=hp^.next;
end;
end;
constructor tabstractprocdef.load;
var
last,hp : pdefcoll;
count,i : word;
begin
retdef:=readdefref;
options:=readword;
count:=readword;
para1:=nil;
savesize:=4;
for i:=1 to count do
begin
new(hp);
hp^.paratyp:=tvarspez(readbyte);
hp^.data:=readdefref;
hp^.next:=nil;
if para1=nil then
para1:=hp
else
last^.next:=hp;
last:=hp;
end;
end;
procedure tabstractprocdef.write;
var
count : word;
hp : pdefcoll;
begin
writedefref(retdef);
writeword(options);
hp:=para1;
count:=0;
while assigned(hp) do
begin
inc(count);
hp:=hp^.next;
end;
writeword(count);
hp:=para1;
while assigned(hp) do
begin
writebyte(byte(hp^.paratyp));
writedefref(hp^.data);
hp:=hp^.next;
end;
end;
{**************************************
TPROCDEF
**************************************}
constructor tprocdef.init;
begin
inherited init;
deftype:=procdef;
_mangledname:=nil;
nextoverloaded:=nil;
extnumber:=-1;
parast:=new(psymtable,init(parasymtable));
localst:=new(psymtable,init(localsymtable));
{ grundsätzlich sind alle Register benutzt }
{ erst wenn eine Implementation vorliegt wird }
{ dies vom Parser gegebenenfalls geändert }
usedregisters:=$ff;
forwarddef:=true;
end;
constructor tprocdef.load;
begin
deftype:=procdef;
inherited load;
usedregisters:=readbyte;
setstring(_mangledname,readstring);
extnumber:=readlong;
nextoverloaded:=pprocdef(readdefref);
if gendeffile and ((options and poexports)<>0) then
writeln(defdatei,#9+mangledname);
parast:=nil;
localst:=nil;
forwarddef:=false;
end;
destructor tprocdef.done;
var
hp : pdefcoll;
begin
if assigned(parast) then
dispose(parast,done);
if assigned(localst) then
dispose(localst,done);
if
{$ifdef tp}
not(use_big) and
{$endif}
assigned(_mangledname) then
strdispose(_mangledname);
inherited done;
end;
procedure tprocdef.write;
begin
writebyte(ibprocdef);
inherited write;
writebyte(usedregisters);
writestring(mangledname);
writelong(extnumber);
writedefref(nextoverloaded);
end;
procedure tprocdef.deref;
begin
inherited deref;
resolvedef(pdef(nextoverloaded));
end;
function tprocdef.mangledname : string;
var
oldpos : longint;
s : string;
b : byte;
begin
{ $ifdef tp
if use_big then
begin
symbolstream.seek(longint(_mangledname));
symbolstream.read(b,1);
symbolstream.read(s[1],b);
s[0]:=chr(b);
mangledname:=s;
end
else
$endif}
begin
mangledname:=strpas(_mangledname);
end;
end;
procedure tprocdef.setmangledname(const s : string);
begin
if
{$ifdef tp}
not(use_big) and
{$endif}
(assigned(_mangledname)) then
strdispose(_mangledname);
setstring(_mangledname,s);
end;
{**************************************
TPROCVARDEF
**************************************}
constructor tprocvardef.init;
begin
inherited init;
deftype:=procvardef;
end;
constructor tprocvardef.load;
begin
deftype:=procvardef;
inherited load;
end;
procedure tprocvardef.write;
begin
writebyte(ibprocvardef);
inherited write;
end;
{**************************************
TCLASSDEF
**************************************}
constructor tclassdef.init(const n : string;c : pclassdef);
begin
tdef.init;
deftype:=classdef;
childof:=c;
{privatesyms:=new(psymtable,init(objectsymtable));
protectedsyms:=new(psymtable,init(objectsymtable)); }
publicsyms:=new(psymtable,init(objectsymtable));
{ Daten der Vorfahren bei den Adressen beachten }
if assigned(childof) then
publicsyms^.datasize:=
publicsyms^.datasize-4+childof^.publicsyms^.datasize;
name:=stringdup(n);
end;
constructor tclassdef.load;
var
oldread_member : boolean;
begin
deftype:=classdef;
savesize:=readlong;
name:=stringdup(readstring);
childof:=pclassdef(readdefref);
oldread_member:=read_member;
read_member:=true;
publicsyms:=new(psymtable,loadasstruct(objectsymtable));
publicsyms^.datasize:=savesize;
read_member:=oldread_member;
end;
destructor tclassdef.done;
begin
{!!!!
if assigned(privatesyms) then
dispose(privatesyms,done);
if assigned(protectedsyms) then
dispose(protectedsyms,done); }
if assigned(publicsyms) then
dispose(publicsyms,done);
stringdispose(name);
tdef.done;
end;
function tclassdef.isrelated(d : pclassdef) : boolean;
var
hp : pclassdef;
begin
isrelated:=false;
hp:=@self;
while assigned(hp) do
begin
if hp=d then
begin
isrelated:=true;
exit;
end;
hp:=hp^.childof;
end;
end;
function tclassdef.size : longint;
begin
size:=publicsyms^.datasize;
end;
procedure tclassdef.deref;
var
hp : pdef;
oldrecsyms : psymtable;
begin
resolvedef(pdef(childof));
oldrecsyms:=aktrecordsymtable;
aktrecordsymtable:=publicsyms;
{ nun die Definitionen Dereferenzieren }
hp:=publicsyms^.wurzeldef;
while assigned(hp) do
begin
hp^.deref;
{Besitzer setzten }
hp^.owner:=publicsyms;
hp:=hp^.next;
end;
{$ifdef tp}
publicsyms^.foreach(derefsym);
{$else}
publicsyms^.foreach(@derefsym);
{$endif}
aktrecordsymtable:=oldrecsyms;
end;
procedure tclassdef.write;
var
oldread_member : boolean;
begin
oldread_member:=read_member;
read_member:=true;
writebyte(ibclassdef);
writelong(size);
writestring(name^);
writedefref(childof);
publicsyms^.writeasstruct;
read_member:=oldread_member;
end;
{**************************************
TERRORDEF
**************************************}
constructor terrordef.init;
begin
tdef.init;
deftype:=errordef;
end;
procedure init_symtable;
begin
macros:=new(psymtable,init(macrosymtable));
usedunits.init;
usedunits.doubles:=false;
read_member:=false;
generrorsym:=new(perrorsym,init);
swurzel:=nil;
readunit_lastloaded:=nil;
loaded_units:=nil;
end;
end.
