mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 18:09:30 +02:00
* obsolete
This commit is contained in:
peter
parent
aca99d30e8
commit
90f37cbcda
4805
compiler/symdef.inc
4805
compiler/symdef.inc
File diff suppressed because it is too large
Load Diff
@ -1,654 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller
|
||||
|
||||
Interface for the definition types of the symtable
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 2 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
****************************************************************************
|
||||
}
|
||||
|
||||
{************************************************
|
||||
TDef
|
||||
************************************************}
|
||||
|
||||
tdef = object(tsymtableentry)
|
||||
deftype : tdeftype;
|
||||
typesym : ptypesym; { which type the definition was generated this def }
|
||||
|
||||
has_inittable : boolean;
|
||||
{ adress of init informations }
|
||||
inittable_label : pasmlabel;
|
||||
|
||||
has_rtti : boolean;
|
||||
{ address of rtti }
|
||||
rtti_label : pasmlabel;
|
||||
|
||||
nextglobal,
|
||||
previousglobal : pdef;
|
||||
{$ifdef GDB}
|
||||
globalnb : word;
|
||||
is_def_stab_written : tdefstabstatus;
|
||||
{$endif GDB}
|
||||
constructor init;
|
||||
constructor load;
|
||||
destructor done;virtual;
|
||||
procedure deref;virtual;
|
||||
function typename:string;
|
||||
procedure write;virtual;
|
||||
function size:longint;virtual;
|
||||
function alignment:longint;virtual;
|
||||
function gettypename:string;virtual;
|
||||
function is_publishable : boolean;virtual;
|
||||
function is_in_current : boolean;
|
||||
procedure correct_owner_symtable; { registers enumdef inside objects or
|
||||
record directly in the owner symtable !! }
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
function NumberString:string;
|
||||
procedure set_globalnb;virtual;
|
||||
function allstabstring : pchar;
|
||||
{$endif GDB}
|
||||
{ init. tables }
|
||||
function needs_inittable : boolean;virtual;
|
||||
procedure generate_inittable;
|
||||
function get_inittable_label : pasmlabel;
|
||||
{ the default implemenation calls write_rtti_data }
|
||||
{ if init and rtti data is different these procedures }
|
||||
{ must be overloaded }
|
||||
procedure write_init_data;virtual;
|
||||
procedure write_child_init_data;virtual;
|
||||
{ rtti }
|
||||
procedure write_rtti_name;
|
||||
function get_rtti_label : string;virtual;
|
||||
procedure generate_rtti;virtual;
|
||||
procedure write_rtti_data;virtual;
|
||||
procedure write_child_rtti_data;virtual;
|
||||
function is_intregable : boolean;
|
||||
function is_fpuregable : boolean;
|
||||
private
|
||||
savesize : longint;
|
||||
end;
|
||||
|
||||
targconvtyp = (act_convertable,act_equal,act_exact);
|
||||
|
||||
tvarspez = (vs_value,vs_const,vs_var,vs_out);
|
||||
|
||||
pparaitem = ^tparaitem;
|
||||
tparaitem = object(tlinkedlist_item)
|
||||
paratype : ttype;
|
||||
paratyp : tvarspez;
|
||||
argconvtyp : targconvtyp;
|
||||
convertlevel : byte;
|
||||
register : tregister;
|
||||
defaultvalue : psym; { pconstsym }
|
||||
end;
|
||||
|
||||
{ this is only here to override the count method,
|
||||
which can't be used }
|
||||
pparalinkedlist = ^tparalinkedlist;
|
||||
tparalinkedlist = object(tlinkedlist)
|
||||
function count:longint;
|
||||
end;
|
||||
|
||||
tfiletyp = (ft_text,ft_typed,ft_untyped);
|
||||
|
||||
pfiledef = ^tfiledef;
|
||||
tfiledef = object(tdef)
|
||||
filetyp : tfiletyp;
|
||||
typedfiletype : ttype;
|
||||
constructor inittext;
|
||||
constructor inituntyped;
|
||||
constructor inittyped(const tt : ttype);
|
||||
constructor inittypeddef(p : pdef);
|
||||
constructor load;
|
||||
procedure write;virtual;
|
||||
procedure deref;virtual;
|
||||
function gettypename:string;virtual;
|
||||
procedure setsize;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
end;
|
||||
|
||||
pformaldef = ^tformaldef;
|
||||
tformaldef = object(tdef)
|
||||
constructor init;
|
||||
constructor load;
|
||||
procedure write;virtual;
|
||||
function gettypename:string;virtual;
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
end;
|
||||
|
||||
pforwarddef = ^tforwarddef;
|
||||
tforwarddef = object(tdef)
|
||||
tosymname : string;
|
||||
forwardpos : tfileposinfo;
|
||||
constructor init(const s:string;const pos : tfileposinfo);
|
||||
function gettypename:string;virtual;
|
||||
end;
|
||||
|
||||
perrordef = ^terrordef;
|
||||
terrordef = object(tdef)
|
||||
constructor init;
|
||||
function gettypename:string;virtual;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
{$endif GDB}
|
||||
end;
|
||||
|
||||
{ tpointerdef and tclassrefdef should get a common
|
||||
base class, but I derived tclassrefdef from tpointerdef
|
||||
to avoid problems with bugs (FK)
|
||||
}
|
||||
|
||||
ppointerdef = ^tpointerdef;
|
||||
tpointerdef = object(tdef)
|
||||
pointertype : ttype;
|
||||
is_far : boolean;
|
||||
constructor init(const tt : ttype);
|
||||
constructor initfar(const tt : ttype);
|
||||
constructor initdef(p : pdef);
|
||||
constructor initfardef(p : pdef);
|
||||
constructor load;
|
||||
destructor done;virtual;
|
||||
procedure write;virtual;
|
||||
procedure deref;virtual;
|
||||
function gettypename:string;virtual;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
{private}
|
||||
public
|
||||
{ I don't know the use of this FK }
|
||||
pointertypeis_forwarddef: boolean;
|
||||
end;
|
||||
|
||||
pprocdef = ^tprocdef;
|
||||
pimplementedinterfaces = ^timplementedinterfaces;
|
||||
|
||||
pobjectdef = ^tobjectdef;
|
||||
tobjectdef = object(tdef)
|
||||
childof : pobjectdef;
|
||||
objname : pstring;
|
||||
symtable : psymtable;
|
||||
objectoptions : tobjectoptions;
|
||||
{ to be able to have a variable vmt position }
|
||||
{ and no vmt field for objects without virtuals }
|
||||
vmt_offset : longint;
|
||||
{$ifdef GDB}
|
||||
classglobalnb,
|
||||
classptrglobalnb : word;
|
||||
writing_stabs : boolean;
|
||||
{$endif GDB}
|
||||
objecttype : tobjectdeftype;
|
||||
isiidguidvalid: boolean;
|
||||
iidguid: TGUID;
|
||||
iidstr: pstring;
|
||||
lastvtableindex: longint;
|
||||
{ store implemented interfaces defs and name mappings }
|
||||
implementedinterfaces: pimplementedinterfaces;
|
||||
|
||||
constructor init(odt : tobjectdeftype; const n : string;c : pobjectdef);
|
||||
constructor load;
|
||||
destructor done;virtual;
|
||||
procedure write;virtual;
|
||||
procedure deref;virtual;
|
||||
function size : longint;virtual;
|
||||
function alignment:longint;virtual;
|
||||
function vmtmethodoffset(index:longint):longint;
|
||||
function is_publishable : boolean;virtual;
|
||||
function vmt_mangledname : string;
|
||||
function rtti_name : string;
|
||||
procedure check_forwards;
|
||||
function is_related(d : pobjectdef) : boolean;
|
||||
function next_free_name_index : longint;
|
||||
procedure insertvmt;
|
||||
procedure set_parent(c : pobjectdef);
|
||||
function searchdestructor : pprocdef;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure set_globalnb;virtual;
|
||||
function classnumberstring : string;
|
||||
function classptrnumberstring : string;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
{ init/final }
|
||||
function needs_inittable : boolean;virtual;
|
||||
procedure write_init_data;virtual;
|
||||
procedure write_child_init_data;virtual;
|
||||
{ rtti }
|
||||
function get_rtti_label : string;virtual;
|
||||
procedure generate_rtti;virtual;
|
||||
procedure write_rtti_data;virtual;
|
||||
procedure write_child_rtti_data;virtual;
|
||||
function generate_field_table : pasmlabel;
|
||||
end;
|
||||
|
||||
timplementedinterfaces = object
|
||||
constructor init;
|
||||
destructor done; virtual;
|
||||
|
||||
function count: longint;
|
||||
function interfaces(intfindex: longint): pobjectdef;
|
||||
function ioffsets(intfindex: longint): plongint;
|
||||
function searchintf(def: pdef): longint;
|
||||
procedure addintf(def: pdef);
|
||||
|
||||
procedure deref;
|
||||
procedure addintfref(def: pdef);
|
||||
|
||||
procedure clearmappings;
|
||||
procedure addmappings(intfindex: longint; const name, newname: string);
|
||||
function getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
|
||||
|
||||
procedure clearimplprocs;
|
||||
procedure addimplproc(intfindex: longint; procdef: pprocdef);
|
||||
function implproccount(intfindex: longint): longint;
|
||||
function implprocs(intfindex: longint; procindex: longint): pprocdef;
|
||||
function isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
|
||||
|
||||
private
|
||||
finterfaces: tindexarray;
|
||||
procedure checkindex(intfindex: longint);
|
||||
end;
|
||||
|
||||
|
||||
pclassrefdef = ^tclassrefdef;
|
||||
tclassrefdef = object(tpointerdef)
|
||||
constructor init(def : pdef);
|
||||
constructor load;
|
||||
procedure write;virtual;
|
||||
function gettypename:string;virtual;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
end;
|
||||
|
||||
parraydef = ^tarraydef;
|
||||
tarraydef = object(tdef)
|
||||
private
|
||||
rangenr : longint;
|
||||
public
|
||||
lowrange,
|
||||
highrange : longint;
|
||||
elementtype,
|
||||
rangetype : ttype;
|
||||
IsDynamicArray,
|
||||
IsVariant,
|
||||
IsConstructor,
|
||||
IsArrayOfConst : boolean;
|
||||
function gettypename:string;virtual;
|
||||
function elesize : longint;
|
||||
constructor init(l,h : longint;rd : pdef);
|
||||
constructor load;
|
||||
procedure write;virtual;
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
procedure deref;virtual;
|
||||
function size : longint;virtual;
|
||||
function alignment : longint;virtual;
|
||||
{ generates the ranges needed by the asm instruction BOUND (i386)
|
||||
or CMP2 (Motorola) }
|
||||
procedure genrangecheck;
|
||||
|
||||
{ returns the label of the range check string }
|
||||
function getrangecheckstring : string;
|
||||
function needs_inittable : boolean;virtual;
|
||||
procedure write_rtti_data;virtual;
|
||||
procedure write_child_rtti_data;virtual;
|
||||
end;
|
||||
|
||||
precorddef = ^trecorddef;
|
||||
trecorddef = object(tdef)
|
||||
symtable : psymtable;
|
||||
constructor init(p : psymtable);
|
||||
constructor load;
|
||||
destructor done;virtual;
|
||||
procedure write;virtual;
|
||||
procedure deref;virtual;
|
||||
function size:longint;virtual;
|
||||
function alignment : longint;virtual;
|
||||
function gettypename:string;virtual;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
{ init/final }
|
||||
procedure write_init_data;virtual;
|
||||
procedure write_child_init_data;virtual;
|
||||
function needs_inittable : boolean;virtual;
|
||||
{ rtti }
|
||||
procedure write_rtti_data;virtual;
|
||||
procedure write_child_rtti_data;virtual;
|
||||
end;
|
||||
|
||||
porddef = ^torddef;
|
||||
torddef = object(tdef)
|
||||
private
|
||||
rangenr : longint;
|
||||
public
|
||||
low,high : longint;
|
||||
typ : tbasetype;
|
||||
constructor init(t : tbasetype;v,b : longint);
|
||||
constructor load;
|
||||
procedure write;virtual;
|
||||
function is_publishable : boolean;virtual;
|
||||
function gettypename:string;virtual;
|
||||
procedure setsize;
|
||||
{ generates the ranges needed by the asm instruction BOUND }
|
||||
{ or CMP2 (Motorola) }
|
||||
procedure genrangecheck;
|
||||
function getrangecheckstring : string;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
{$endif GDB}
|
||||
{ rtti }
|
||||
procedure write_rtti_data;virtual;
|
||||
end;
|
||||
|
||||
pfloatdef = ^tfloatdef;
|
||||
tfloatdef = object(tdef)
|
||||
typ : tfloattype;
|
||||
constructor init(t : tfloattype);
|
||||
constructor load;
|
||||
procedure write;virtual;
|
||||
function gettypename:string;virtual;
|
||||
function is_publishable : boolean;virtual;
|
||||
procedure setsize;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
{$endif GDB}
|
||||
{ rtti }
|
||||
procedure write_rtti_data;virtual;
|
||||
end;
|
||||
|
||||
pabstractprocdef = ^tabstractprocdef;
|
||||
tabstractprocdef = object(tdef)
|
||||
{ saves a definition to the return type }
|
||||
rettype : ttype;
|
||||
proctypeoption : tproctypeoption;
|
||||
proccalloptions : tproccalloptions;
|
||||
procoptions : tprocoptions;
|
||||
para : pparalinkedlist;
|
||||
maxparacount,
|
||||
minparacount : longint;
|
||||
symtablelevel : byte;
|
||||
fpu_used : byte; { how many stack fpu must be empty }
|
||||
constructor init;
|
||||
constructor load;
|
||||
destructor done;virtual;
|
||||
procedure write;virtual;
|
||||
procedure deref;virtual;
|
||||
procedure concatpara(tt:ttype;vsp : tvarspez;defval:psym);
|
||||
function para_size(alignsize:longint) : longint;
|
||||
function demangled_paras : string;
|
||||
function proccalloption2str : string;
|
||||
procedure test_if_fpu_result;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
end;
|
||||
|
||||
pprocvardef = ^tprocvardef;
|
||||
tprocvardef = object(tabstractprocdef)
|
||||
constructor init;
|
||||
constructor load;
|
||||
procedure write;virtual;
|
||||
function size : longint;virtual;
|
||||
function gettypename:string;virtual;
|
||||
function is_publishable : boolean;virtual;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput); virtual;
|
||||
{$endif GDB}
|
||||
{ rtti }
|
||||
procedure write_child_rtti_data;virtual;
|
||||
procedure write_rtti_data;virtual;
|
||||
end;
|
||||
|
||||
tmessageinf = record
|
||||
case integer of
|
||||
0 : (str : pchar);
|
||||
1 : (i : longint);
|
||||
end;
|
||||
|
||||
tprocdef = object(tabstractprocdef)
|
||||
private
|
||||
_mangledname : pstring;
|
||||
public
|
||||
extnumber : longint;
|
||||
messageinf : tmessageinf;
|
||||
nextoverloaded : pprocdef;
|
||||
{ where is this function defined, needed here because there
|
||||
is only one symbol for all overloaded functions }
|
||||
fileinfo : tfileposinfo;
|
||||
{ pointer to the local symbol table }
|
||||
localst : psymtable;
|
||||
{ pointer to the parameter symbol table }
|
||||
parast : psymtable;
|
||||
{ symbol owning this definition }
|
||||
procsym : pprocsym;
|
||||
{ browser info }
|
||||
lastref,
|
||||
defref,
|
||||
crossref,
|
||||
lastwritten : pref;
|
||||
refcount : longint;
|
||||
_class : pobjectdef;
|
||||
{ it's a tree, but this not easy to handle }
|
||||
{ used for inlined procs }
|
||||
code : pointer;
|
||||
{ info about register variables (JM) }
|
||||
regvarinfo: pointer;
|
||||
{ true, if the procedure is only declared }
|
||||
{ (forward procedure) }
|
||||
forwarddef,
|
||||
{ true if the procedure is declared in the interface }
|
||||
interfacedef : boolean;
|
||||
{ true if the procedure has a forward declaration }
|
||||
hasforward : boolean;
|
||||
{ check the problems of manglednames }
|
||||
count : boolean;
|
||||
is_used : boolean;
|
||||
{ small set which contains the modified registers }
|
||||
{$ifdef newcg}
|
||||
usedregisters : tregisterset;
|
||||
{$else newcg}
|
||||
usedregisters : longint;
|
||||
{$endif newcg}
|
||||
constructor init;
|
||||
constructor load;
|
||||
destructor done;virtual;
|
||||
procedure write;virtual;
|
||||
procedure deref;virtual;
|
||||
function haspara:boolean;
|
||||
function mangledname : string;
|
||||
procedure setmangledname(const s : string);
|
||||
procedure load_references;
|
||||
function write_references : boolean;
|
||||
{$ifdef dummy}
|
||||
function procname: string;
|
||||
{$endif dummy}
|
||||
function cplusplusmangledname : string;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
{ browser }
|
||||
{$ifdef BrowserLog}
|
||||
procedure add_to_browserlog;
|
||||
{$endif BrowserLog}
|
||||
end;
|
||||
|
||||
pstringdef = ^tstringdef;
|
||||
tstringdef = object(tdef)
|
||||
string_typ : tstringtype;
|
||||
len : longint;
|
||||
constructor shortinit(l : byte);
|
||||
constructor shortload;
|
||||
constructor longinit(l : longint);
|
||||
constructor longload;
|
||||
constructor ansiinit(l : longint);
|
||||
constructor ansiload;
|
||||
constructor wideinit(l : longint);
|
||||
constructor wideload;
|
||||
function stringtypname:string;
|
||||
function size : longint;virtual;
|
||||
procedure write;virtual;
|
||||
function gettypename:string;virtual;
|
||||
function is_publishable : boolean;virtual;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
{ init/final }
|
||||
function needs_inittable : boolean;virtual;
|
||||
{ rtti }
|
||||
procedure write_rtti_data;virtual;
|
||||
end;
|
||||
|
||||
penumdef = ^tenumdef;
|
||||
tenumdef = object(tdef)
|
||||
rangenr,
|
||||
minval,
|
||||
maxval : longint;
|
||||
has_jumps : boolean;
|
||||
firstenum : penumsym;
|
||||
basedef : penumdef;
|
||||
constructor init;
|
||||
constructor init_subrange(_basedef:penumdef;_min,_max:longint);
|
||||
constructor load;
|
||||
destructor done;virtual;
|
||||
procedure write;virtual;
|
||||
procedure deref;virtual;
|
||||
function gettypename:string;virtual;
|
||||
function is_publishable : boolean;virtual;
|
||||
procedure calcsavesize;
|
||||
procedure setmax(_max:longint);
|
||||
procedure setmin(_min:longint);
|
||||
function min:longint;
|
||||
function max:longint;
|
||||
function getrangecheckstring:string;
|
||||
procedure genrangecheck;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
{$endif GDB}
|
||||
{ rtti }
|
||||
procedure write_child_rtti_data;virtual;
|
||||
procedure write_rtti_data;virtual;
|
||||
end;
|
||||
|
||||
psetdef = ^tsetdef;
|
||||
tsetdef = object(tdef)
|
||||
elementtype : ttype;
|
||||
settype : tsettype;
|
||||
constructor init(s : pdef;high : longint);
|
||||
constructor load;
|
||||
destructor done;virtual;
|
||||
procedure write;virtual;
|
||||
procedure deref;virtual;
|
||||
function gettypename:string;virtual;
|
||||
function is_publishable : boolean;virtual;
|
||||
{ debug }
|
||||
{$ifdef GDB}
|
||||
function stabstring : pchar;virtual;
|
||||
procedure concatstabto(asmlist : paasmoutput);virtual;
|
||||
{$endif GDB}
|
||||
{ rtti }
|
||||
procedure write_rtti_data;virtual;
|
||||
procedure write_child_rtti_data;virtual;
|
||||
end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.15 2000-11-04 14:25:22 florian
|
||||
+ merged Attila's changes for interfaces, not tested yet
|
||||
|
||||
Revision 1.14 2000/10/31 22:02:52 peter
|
||||
* symtable splitted, no real code changes
|
||||
|
||||
Revision 1.13 2000/10/21 18:16:12 florian
|
||||
* a lot of changes:
|
||||
- basic dyn. array support
|
||||
- basic C++ support
|
||||
- some work for interfaces done
|
||||
....
|
||||
|
||||
Revision 1.12 2000/10/15 07:47:52 peter
|
||||
* unit names and procedure names are stored mixed case
|
||||
|
||||
Revision 1.11 2000/10/14 10:14:53 peter
|
||||
* moehrendorf oct 2000 rewrite
|
||||
|
||||
Revision 1.10 2000/09/24 15:06:29 peter
|
||||
* use defines.inc
|
||||
|
||||
Revision 1.9 2000/09/19 23:08:03 pierre
|
||||
* fixes for local class debuggging problem (merged)
|
||||
|
||||
Revision 1.8 2000/08/21 11:27:44 pierre
|
||||
* fix the stabs problems
|
||||
|
||||
Revision 1.7 2000/08/06 19:39:28 peter
|
||||
* default parameters working !
|
||||
|
||||
Revision 1.6 2000/08/06 14:17:15 peter
|
||||
* overload fixes (merged)
|
||||
|
||||
Revision 1.5 2000/08/03 13:17:26 jonas
|
||||
+ allow regvars to be used inside inlined procs, which required the
|
||||
following changes:
|
||||
+ load regvars in genentrycode/free them in genexitcode (cgai386)
|
||||
* moved all regvar related code to new regvars unit
|
||||
+ added pregvarinfo type to hcodegen
|
||||
+ added regvarinfo field to tprocinfo (symdef/symdefh)
|
||||
* deallocate the regvars of the caller in secondprocinline before
|
||||
inlining the called procedure and reallocate them afterwards
|
||||
|
||||
Revision 1.4 2000/08/02 19:49:59 peter
|
||||
* first things for default parameters
|
||||
|
||||
Revision 1.3 2000/07/13 12:08:27 michael
|
||||
+ patched to 1.1.0 with former 1.09patch from peter
|
||||
|
||||
Revision 1.2 2000/07/13 11:32:49 michael
|
||||
+ removed logs
|
||||
|
||||
}
|
||||
@ -1,782 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller
|
||||
|
||||
Implementation of the reading of PPU Files for the symtable
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 2 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
****************************************************************************
|
||||
}
|
||||
|
||||
const
|
||||
{$ifdef FPC}
|
||||
ppubufsize=32768;
|
||||
{$ELSE}
|
||||
{$IFDEF USEOVERLAY}
|
||||
ppubufsize=512;
|
||||
{$ELSE}
|
||||
ppubufsize=4096;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
{$define ORDERSOURCES}
|
||||
|
||||
{*****************************************************************************
|
||||
PPU Writing
|
||||
*****************************************************************************}
|
||||
|
||||
procedure writebyte(b:byte);
|
||||
begin
|
||||
current_ppu^.putbyte(b);
|
||||
end;
|
||||
|
||||
|
||||
procedure writeword(w:word);
|
||||
begin
|
||||
current_ppu^.putword(w);
|
||||
end;
|
||||
|
||||
|
||||
procedure writelong(l:longint);
|
||||
begin
|
||||
current_ppu^.putlongint(l);
|
||||
end;
|
||||
|
||||
|
||||
procedure writereal(d:bestreal);
|
||||
begin
|
||||
current_ppu^.putreal(d);
|
||||
end;
|
||||
|
||||
|
||||
procedure writestring(const s:string);
|
||||
begin
|
||||
current_ppu^.putstring(s);
|
||||
end;
|
||||
|
||||
|
||||
procedure writenormalset(var s); {You cannot pass an array[0..31] of byte!}
|
||||
begin
|
||||
current_ppu^.putdata(s,sizeof(tnormalset));
|
||||
end;
|
||||
|
||||
|
||||
procedure writesmallset(var s; size: longint);
|
||||
var
|
||||
tmpl: longint;
|
||||
begin
|
||||
{ The minimum size of a set under Delphi isn't 32 bit }
|
||||
{ this is only binary compatible with FPC if first element's value of the set is 0 }
|
||||
tmpl:=0; move(s,tmpl,size);
|
||||
current_ppu^.putdata(tmpl,4);
|
||||
{old code: current_ppu^.putdata(s,4);}
|
||||
end;
|
||||
|
||||
procedure writeguid(var g: tguid);
|
||||
begin
|
||||
current_ppu^.putdata(g,sizeof(g));
|
||||
end;
|
||||
|
||||
{ posinfo is not relevant for changes in PPU }
|
||||
procedure writeposinfo(const p:tfileposinfo);
|
||||
var
|
||||
oldcrc : boolean;
|
||||
begin
|
||||
oldcrc:=current_ppu^.do_crc;
|
||||
current_ppu^.do_crc:=false;
|
||||
current_ppu^.putword(p.fileindex);
|
||||
current_ppu^.putlongint(p.line);
|
||||
current_ppu^.putword(p.column);
|
||||
current_ppu^.do_crc:=oldcrc;
|
||||
end;
|
||||
|
||||
|
||||
procedure writederef(p : psymtableentry);
|
||||
begin
|
||||
if p=nil then
|
||||
current_ppu^.putbyte(ord(derefnil))
|
||||
else
|
||||
begin
|
||||
{ Static symtable ? }
|
||||
if p^.owner^.symtabletype=staticsymtable then
|
||||
begin
|
||||
current_ppu^.putbyte(ord(derefaktstaticindex));
|
||||
current_ppu^.putword(p^.indexnr);
|
||||
end
|
||||
{ Local record/object symtable ? }
|
||||
else if (p^.owner=aktrecordsymtable) then
|
||||
begin
|
||||
current_ppu^.putbyte(ord(derefaktrecordindex));
|
||||
current_ppu^.putword(p^.indexnr);
|
||||
end
|
||||
{ Local local/para symtable ? }
|
||||
else if (p^.owner=aktlocalsymtable) then
|
||||
begin
|
||||
current_ppu^.putbyte(ord(derefaktlocal));
|
||||
current_ppu^.putword(p^.indexnr);
|
||||
end
|
||||
else
|
||||
begin
|
||||
current_ppu^.putbyte(ord(derefindex));
|
||||
current_ppu^.putword(p^.indexnr);
|
||||
{ Current unit symtable ? }
|
||||
repeat
|
||||
if not assigned(p) then
|
||||
internalerror(556655);
|
||||
case p^.owner^.symtabletype of
|
||||
{ when writing the pseudo PPU file
|
||||
to get CRC values the globalsymtable is not yet
|
||||
a unitsymtable PM }
|
||||
globalsymtable,
|
||||
unitsymtable :
|
||||
begin
|
||||
{ check if the unit is available in the uses
|
||||
clause, else it's an error }
|
||||
if p^.owner^.unitid=$ffff then
|
||||
internalerror(55665566);
|
||||
current_ppu^.putbyte(ord(derefunit));
|
||||
current_ppu^.putword(p^.owner^.unitid);
|
||||
break;
|
||||
end;
|
||||
staticsymtable :
|
||||
begin
|
||||
current_ppu^.putbyte(ord(derefaktstaticindex));
|
||||
current_ppu^.putword(p^.indexnr);
|
||||
break;
|
||||
end;
|
||||
localsymtable :
|
||||
begin
|
||||
p:=p^.owner^.defowner;
|
||||
current_ppu^.putbyte(ord(dereflocal));
|
||||
current_ppu^.putword(p^.indexnr);
|
||||
end;
|
||||
parasymtable :
|
||||
begin
|
||||
p:=p^.owner^.defowner;
|
||||
current_ppu^.putbyte(ord(derefpara));
|
||||
current_ppu^.putword(p^.indexnr);
|
||||
end;
|
||||
objectsymtable,
|
||||
recordsymtable :
|
||||
begin
|
||||
p:=p^.owner^.defowner;
|
||||
current_ppu^.putbyte(ord(derefrecord));
|
||||
current_ppu^.putword(p^.indexnr);
|
||||
end;
|
||||
else
|
||||
internalerror(556656);
|
||||
end;
|
||||
until false;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure writedefref(p : pdef);
|
||||
begin
|
||||
writederef(p);
|
||||
end;
|
||||
|
||||
procedure writesymref(p : psym);
|
||||
begin
|
||||
writederef(p);
|
||||
end;
|
||||
|
||||
procedure writesourcefiles;
|
||||
var
|
||||
hp : pinputfile;
|
||||
{$ifdef ORDERSOURCES}
|
||||
i,j : longint;
|
||||
{$endif ORDERSOURCES}
|
||||
begin
|
||||
{ second write the used source files }
|
||||
current_ppu^.do_crc:=false;
|
||||
hp:=current_module^.sourcefiles^.files;
|
||||
{$ifdef ORDERSOURCES}
|
||||
{ write source files directly in good order }
|
||||
j:=0;
|
||||
while assigned(hp) do
|
||||
begin
|
||||
inc(j);
|
||||
hp:=hp^.ref_next;
|
||||
end;
|
||||
while j>0 do
|
||||
begin
|
||||
hp:=current_module^.sourcefiles^.files;
|
||||
for i:=1 to j-1 do
|
||||
hp:=hp^.ref_next;
|
||||
current_ppu^.putstring(hp^.name^);
|
||||
dec(j);
|
||||
end;
|
||||
{$else not ORDERSOURCES}
|
||||
while assigned(hp) do
|
||||
begin
|
||||
{ only name and extension }
|
||||
current_ppu^.putstring(hp^.name^);
|
||||
hp:=hp^.ref_next;
|
||||
end;
|
||||
{$endif ORDERSOURCES}
|
||||
current_ppu^.writeentry(ibsourcefiles);
|
||||
current_ppu^.do_crc:=true;
|
||||
end;
|
||||
|
||||
procedure writeusedmacros;
|
||||
var
|
||||
hp : pmacrosym;
|
||||
i : longint;
|
||||
begin
|
||||
{ second write the used source files }
|
||||
current_ppu^.do_crc:=false;
|
||||
for i:=1 to macros^.symindex^.count do
|
||||
begin
|
||||
hp:=pmacrosym(macros^.symindex^.search(i));
|
||||
{ only used or init defined macros are stored }
|
||||
if hp^.is_used or hp^.defined_at_startup then
|
||||
begin
|
||||
current_ppu^.putstring(hp^.name);
|
||||
current_ppu^.putbyte(byte(hp^.defined_at_startup));
|
||||
current_ppu^.putbyte(byte(hp^.is_used));
|
||||
end;
|
||||
end;
|
||||
current_ppu^.writeentry(ibusedmacros);
|
||||
current_ppu^.do_crc:=true;
|
||||
end;
|
||||
|
||||
|
||||
procedure writeusedunit;
|
||||
var
|
||||
hp : pused_unit;
|
||||
begin
|
||||
numberunits;
|
||||
hp:=pused_unit(current_module^.used_units.first);
|
||||
while assigned(hp) do
|
||||
begin
|
||||
{ implementation units should not change
|
||||
the CRC PM }
|
||||
current_ppu^.do_crc:=hp^.in_interface;
|
||||
current_ppu^.putstring(hp^.name^);
|
||||
{ the checksum should not affect the crc of this unit ! (PFV) }
|
||||
current_ppu^.do_crc:=false;
|
||||
current_ppu^.putlongint(hp^.checksum);
|
||||
current_ppu^.putlongint(hp^.interface_checksum);
|
||||
current_ppu^.putbyte(byte(hp^.in_interface));
|
||||
current_ppu^.do_crc:=true;
|
||||
hp:=pused_unit(hp^.next);
|
||||
end;
|
||||
current_ppu^.do_interface_crc:=true;
|
||||
current_ppu^.writeentry(ibloadunit);
|
||||
end;
|
||||
|
||||
|
||||
procedure writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
|
||||
var
|
||||
hcontainer : tlinkcontainer;
|
||||
s : string;
|
||||
mask : longint;
|
||||
begin
|
||||
hcontainer.init;
|
||||
while not p.empty do
|
||||
begin
|
||||
s:=p.get(mask);
|
||||
if strippath then
|
||||
current_ppu^.putstring(SplitFileName(s))
|
||||
else
|
||||
current_ppu^.putstring(s);
|
||||
current_ppu^.putlongint(mask);
|
||||
hcontainer.insert(s,mask);
|
||||
end;
|
||||
current_ppu^.writeentry(id);
|
||||
p:=hcontainer;
|
||||
end;
|
||||
|
||||
|
||||
procedure writeunitas(const s : string;unittable : punitsymtable;only_crc : boolean);
|
||||
begin
|
||||
Message1(unit_u_ppu_write,s);
|
||||
|
||||
{ create unit flags }
|
||||
with Current_Module^ do
|
||||
begin
|
||||
{$ifdef GDB}
|
||||
if cs_gdb_dbx in aktglobalswitches then
|
||||
flags:=flags or uf_has_dbx;
|
||||
{$endif GDB}
|
||||
if target_os.endian=endian_big then
|
||||
flags:=flags or uf_big_endian;
|
||||
if cs_browser in aktmoduleswitches then
|
||||
flags:=flags or uf_has_browser;
|
||||
if cs_local_browser in aktmoduleswitches then
|
||||
flags:=flags or uf_local_browser;
|
||||
end;
|
||||
|
||||
{$ifdef Test_Double_checksum_write}
|
||||
If only_crc then
|
||||
Assign(CRCFile,s+'.INT')
|
||||
else
|
||||
Assign(CRCFile,s+'.IMP');
|
||||
Rewrite(CRCFile);
|
||||
{$endif def Test_Double_checksum_write}
|
||||
{ open ppufile }
|
||||
current_ppu:=new(pppufile,init(s));
|
||||
current_ppu^.crc_only:=only_crc;
|
||||
if not current_ppu^.create then
|
||||
Message(unit_f_ppu_cannot_write);
|
||||
|
||||
{$ifdef Test_Double_checksum}
|
||||
if only_crc then
|
||||
begin
|
||||
new(current_ppu^.crc_test);
|
||||
new(current_ppu^.crc_test2);
|
||||
end
|
||||
else
|
||||
begin
|
||||
current_ppu^.crc_test:=Current_Module^.crc_array;
|
||||
current_ppu^.crc_index:=Current_Module^.crc_size;
|
||||
current_ppu^.crc_test2:=Current_Module^.crc_array2;
|
||||
current_ppu^.crc_index2:=Current_Module^.crc_size2;
|
||||
end;
|
||||
{$endif def Test_Double_checksum}
|
||||
|
||||
current_ppu^.change_endian:=source_os.endian<>target_os.endian;
|
||||
{ write symbols and definitions }
|
||||
unittable^.writeasunit;
|
||||
|
||||
{ flush to be sure }
|
||||
current_ppu^.flush;
|
||||
{ create and write header }
|
||||
current_ppu^.header.size:=current_ppu^.size;
|
||||
current_ppu^.header.checksum:=current_ppu^.crc;
|
||||
current_ppu^.header.interface_checksum:=current_ppu^.interface_crc;
|
||||
current_ppu^.header.compiler:=wordversion;
|
||||
current_ppu^.header.cpu:=word(target_cpu);
|
||||
current_ppu^.header.target:=word(target_info.target);
|
||||
current_ppu^.header.flags:=current_module^.flags;
|
||||
If not only_crc then
|
||||
current_ppu^.writeheader;
|
||||
{ save crc in current_module also }
|
||||
current_module^.crc:=current_ppu^.crc;
|
||||
current_module^.interface_crc:=current_ppu^.interface_crc;
|
||||
if only_crc then
|
||||
begin
|
||||
{$ifdef Test_Double_checksum}
|
||||
Current_Module^.crc_array:=current_ppu^.crc_test;
|
||||
current_ppu^.crc_test:=nil;
|
||||
Current_Module^.crc_size:=current_ppu^.crc_index2;
|
||||
Current_Module^.crc_array2:=current_ppu^.crc_test2;
|
||||
current_ppu^.crc_test2:=nil;
|
||||
Current_Module^.crc_size2:=current_ppu^.crc_index2;
|
||||
{$endif def Test_Double_checksum}
|
||||
closecurrentppu;
|
||||
end;
|
||||
{$ifdef Test_Double_checksum_write}
|
||||
close(CRCFile);
|
||||
{$endif Test_Double_checksum_write}
|
||||
end;
|
||||
|
||||
|
||||
procedure closecurrentppu;
|
||||
begin
|
||||
{$ifdef Test_Double_checksum}
|
||||
if assigned(current_ppu^.crc_test) then
|
||||
dispose(current_ppu^.crc_test);
|
||||
if assigned(current_ppu^.crc_test2) then
|
||||
dispose(current_ppu^.crc_test2);
|
||||
{$endif Test_Double_checksum}
|
||||
{ close }
|
||||
current_ppu^.close;
|
||||
dispose(current_ppu,done);
|
||||
current_ppu:=nil;
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
PPU Reading
|
||||
*****************************************************************************}
|
||||
|
||||
function readbyte:byte;
|
||||
begin
|
||||
readbyte:=current_ppu^.getbyte;
|
||||
if current_ppu^.error then
|
||||
Message(unit_f_ppu_read_error);
|
||||
end;
|
||||
|
||||
|
||||
function readword:word;
|
||||
begin
|
||||
readword:=current_ppu^.getword;
|
||||
if current_ppu^.error then
|
||||
Message(unit_f_ppu_read_error);
|
||||
end;
|
||||
|
||||
|
||||
function readlong:longint;
|
||||
begin
|
||||
readlong:=current_ppu^.getlongint;
|
||||
if current_ppu^.error then
|
||||
Message(unit_f_ppu_read_error);
|
||||
end;
|
||||
|
||||
|
||||
function readreal : bestreal;
|
||||
begin
|
||||
readreal:=current_ppu^.getreal;
|
||||
if current_ppu^.error then
|
||||
Message(unit_f_ppu_read_error);
|
||||
end;
|
||||
|
||||
|
||||
function readstring : string;
|
||||
begin
|
||||
readstring:=current_ppu^.getstring;
|
||||
if current_ppu^.error then
|
||||
Message(unit_f_ppu_read_error);
|
||||
end;
|
||||
|
||||
|
||||
procedure readnormalset(var s); {You cannot pass an array [0..31] of byte.}
|
||||
begin
|
||||
current_ppu^.getdata(s,sizeof(tnormalset));
|
||||
if current_ppu^.error then
|
||||
Message(unit_f_ppu_read_error);
|
||||
end;
|
||||
|
||||
|
||||
procedure readsmallset(var s;size: longint);
|
||||
var
|
||||
tmpl: longint;
|
||||
begin
|
||||
{ The minimum size of a set under Delphi isn't 32 bit }
|
||||
{ this is only binary compatible if first element's value of the set is 0 }
|
||||
current_ppu^.getdata(tmpl,4);
|
||||
move(tmpl,s,size);
|
||||
{old code: current_ppu^.getdata(s,4); }
|
||||
if current_ppu^.error then
|
||||
Message(unit_f_ppu_read_error);
|
||||
end;
|
||||
|
||||
|
||||
procedure readguid(var g: tguid);
|
||||
begin
|
||||
current_ppu^.getdata(g,sizeof(g));
|
||||
if current_ppu^.error then
|
||||
Message(unit_f_ppu_read_error);
|
||||
end;
|
||||
|
||||
procedure readposinfo(var p:tfileposinfo);
|
||||
begin
|
||||
p.fileindex:=current_ppu^.getword;
|
||||
p.line:=current_ppu^.getlongint;
|
||||
p.column:=current_ppu^.getword;
|
||||
end;
|
||||
|
||||
|
||||
function readderef : pderef;
|
||||
var
|
||||
hp,p : pderef;
|
||||
b : tdereftype;
|
||||
begin
|
||||
p:=nil;
|
||||
repeat
|
||||
hp:=p;
|
||||
b:=tdereftype(current_ppu^.getbyte);
|
||||
case b of
|
||||
derefnil :
|
||||
break;
|
||||
derefunit,
|
||||
derefaktrecordindex,
|
||||
derefaktlocal,
|
||||
derefaktstaticindex :
|
||||
begin
|
||||
new(p,init(b,current_ppu^.getword));
|
||||
p^.next:=hp;
|
||||
break;
|
||||
end;
|
||||
derefindex,
|
||||
dereflocal,
|
||||
derefpara,
|
||||
derefrecord :
|
||||
begin
|
||||
new(p,init(b,current_ppu^.getword));
|
||||
p^.next:=hp;
|
||||
end;
|
||||
end;
|
||||
until false;
|
||||
readderef:=p;
|
||||
end;
|
||||
|
||||
function readdefref : pdef;
|
||||
begin
|
||||
readdefref:=pdef(readderef);
|
||||
end;
|
||||
|
||||
function readsymref : psym;
|
||||
begin
|
||||
readsymref:=psym(readderef);
|
||||
end;
|
||||
|
||||
procedure readusedmacros;
|
||||
var
|
||||
hs : string;
|
||||
mac : pmacrosym;
|
||||
was_defined_at_startup,
|
||||
was_used : boolean;
|
||||
begin
|
||||
while not current_ppu^.endofentry do
|
||||
begin
|
||||
hs:=current_ppu^.getstring;
|
||||
was_defined_at_startup:=boolean(current_ppu^.getbyte);
|
||||
was_used:=boolean(current_ppu^.getbyte);
|
||||
mac:=pmacrosym(macros^.search(hs));
|
||||
if assigned(mac) then
|
||||
begin
|
||||
{$ifndef EXTDEBUG}
|
||||
{ if we don't have the sources why tell }
|
||||
if current_module^.sources_avail then
|
||||
{$endif ndef EXTDEBUG}
|
||||
if (not was_defined_at_startup) and
|
||||
was_used and
|
||||
mac^.defined_at_startup then
|
||||
Message2(unit_h_cond_not_set_in_last_compile,hs,current_module^.mainsource^);
|
||||
end
|
||||
else { not assigned }
|
||||
if was_defined_at_startup and
|
||||
was_used then
|
||||
Message2(unit_h_cond_not_set_in_last_compile,hs,current_module^.mainsource^);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure readsourcefiles;
|
||||
var
|
||||
temp,hs : string;
|
||||
temp_dir : string;
|
||||
{$ifdef ORDERSOURCES}
|
||||
main_dir : string;
|
||||
{$endif ORDERSOURCES}
|
||||
incfile_found,
|
||||
main_found,
|
||||
is_main : boolean;
|
||||
ppufiletime,
|
||||
source_time : longint;
|
||||
hp : pinputfile;
|
||||
begin
|
||||
ppufiletime:=getnamedfiletime(current_module^.ppufilename^);
|
||||
current_module^.sources_avail:=true;
|
||||
{$ifdef ORDERSOURCES}
|
||||
is_main:=true;
|
||||
main_dir:='';
|
||||
{$endif ORDERSOURCES}
|
||||
while not current_ppu^.endofentry do
|
||||
begin
|
||||
hs:=current_ppu^.getstring;
|
||||
{$ifndef ORDERSOURCES}
|
||||
is_main:=current_ppu^.endofentry;
|
||||
{$endif ORDERSOURCES}
|
||||
temp_dir:='';
|
||||
if (current_module^.flags and uf_in_library)<>0 then
|
||||
begin
|
||||
current_module^.sources_avail:=false;
|
||||
temp:=' library';
|
||||
end
|
||||
else if pos('Macro ',hs)=1 then
|
||||
begin
|
||||
{ we don't want to find this file }
|
||||
{ but there is a problem with file indexing !! }
|
||||
temp:='';
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ check the date of the source files }
|
||||
Source_Time:=GetNamedFileTime(current_module^.path^+hs);
|
||||
incfile_found:=false;
|
||||
main_found:=false;
|
||||
if Source_Time<>-1 then
|
||||
hs:=current_module^.path^+hs
|
||||
{$ifdef ORDERSOURCES}
|
||||
else if not(is_main) then
|
||||
begin
|
||||
Source_Time:=GetNamedFileTime(main_dir+hs);
|
||||
if Source_Time<>-1 then
|
||||
hs:=main_dir+hs;
|
||||
end
|
||||
{$endif def ORDERSOURCES}
|
||||
;
|
||||
if (Source_Time=-1) then
|
||||
begin
|
||||
if is_main then
|
||||
temp_dir:=unitsearchpath.FindFile(hs,main_found)
|
||||
else
|
||||
temp_dir:=includesearchpath.FindFile(hs,incfile_found);
|
||||
if incfile_found or main_found then
|
||||
begin
|
||||
hs:=temp_dir+hs;
|
||||
Source_Time:=GetNamedFileTime(hs);
|
||||
end
|
||||
end;
|
||||
if Source_Time=-1 then
|
||||
begin
|
||||
current_module^.sources_avail:=false;
|
||||
temp:=' not found';
|
||||
end
|
||||
else
|
||||
begin
|
||||
if main_found then
|
||||
main_dir:=temp_dir;
|
||||
{ time newer? But only allow if the file is not searched
|
||||
in the include path (PFV), else you've problems with
|
||||
units which use the same includefile names }
|
||||
if incfile_found then
|
||||
temp:=' found'
|
||||
else
|
||||
begin
|
||||
temp:=' time '+filetimestring(source_time);
|
||||
if (source_time>ppufiletime) then
|
||||
begin
|
||||
current_module^.do_compile:=true;
|
||||
current_module^.recompile_reason:=rr_sourcenewer;
|
||||
temp:=temp+' *'
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
new(hp,init(hs));
|
||||
{ the indexing is wrong here PM }
|
||||
current_module^.sourcefiles^.register_file(hp);
|
||||
end;
|
||||
{$ifdef ORDERSOURCES}
|
||||
if is_main then
|
||||
begin
|
||||
stringdispose(current_module^.mainsource);
|
||||
current_module^.mainsource:=stringdup(hs);
|
||||
end;
|
||||
{$endif ORDERSOURCES}
|
||||
Message1(unit_u_ppu_source,hs+temp);
|
||||
{$ifdef ORDERSOURCES}
|
||||
is_main:=false;
|
||||
{$endif ORDERSOURCES}
|
||||
end;
|
||||
{$ifndef ORDERSOURCES}
|
||||
{ main source is always the last }
|
||||
stringdispose(current_module^.mainsource);
|
||||
current_module^.mainsource:=stringdup(hs);
|
||||
|
||||
{ the indexing is corrected here PM }
|
||||
current_module^.sourcefiles^.inverse_register_indexes;
|
||||
{$endif ORDERSOURCES}
|
||||
{ check if we want to rebuild every unit, only if the sources are
|
||||
available }
|
||||
if do_build and current_module^.sources_avail then
|
||||
begin
|
||||
current_module^.do_compile:=true;
|
||||
current_module^.recompile_reason:=rr_build;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure readloadunit;
|
||||
var
|
||||
hs : string;
|
||||
intfchecksum,
|
||||
checksum : longint;
|
||||
in_interface : boolean;
|
||||
begin
|
||||
while not current_ppu^.endofentry do
|
||||
begin
|
||||
hs:=current_ppu^.getstring;
|
||||
checksum:=current_ppu^.getlongint;
|
||||
intfchecksum:=current_ppu^.getlongint;
|
||||
in_interface:=(current_ppu^.getbyte<>0);
|
||||
current_module^.used_units.concat(new(pused_unit,init_to_load(hs,checksum,intfchecksum,in_interface)));
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure readlinkcontainer(var p:tlinkcontainer);
|
||||
var
|
||||
s : string;
|
||||
m : longint;
|
||||
begin
|
||||
while not current_ppu^.endofentry do
|
||||
begin
|
||||
s:=current_ppu^.getstring;
|
||||
m:=current_ppu^.getlongint;
|
||||
p.insert(s,m);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure load_interface;
|
||||
var
|
||||
b : byte;
|
||||
newmodulename : string;
|
||||
begin
|
||||
{ read interface part }
|
||||
repeat
|
||||
b:=current_ppu^.readentry;
|
||||
case b of
|
||||
ibmodulename :
|
||||
begin
|
||||
newmodulename:=current_ppu^.getstring;
|
||||
if upper(newmodulename)<>current_module^.modulename^ then
|
||||
Message2(unit_f_unit_name_error,current_module^.realmodulename^,newmodulename);
|
||||
stringdispose(current_module^.modulename);
|
||||
stringdispose(current_module^.realmodulename);
|
||||
current_module^.modulename:=stringdup(upper(newmodulename));
|
||||
current_module^.realmodulename:=stringdup(newmodulename);
|
||||
end;
|
||||
ibsourcefiles :
|
||||
readsourcefiles;
|
||||
ibusedmacros :
|
||||
readusedmacros;
|
||||
ibloadunit :
|
||||
readloadunit;
|
||||
iblinkunitofiles :
|
||||
readlinkcontainer(current_module^.LinkUnitOFiles);
|
||||
iblinkunitstaticlibs :
|
||||
readlinkcontainer(current_module^.LinkUnitStaticLibs);
|
||||
iblinkunitsharedlibs :
|
||||
readlinkcontainer(current_module^.LinkUnitSharedLibs);
|
||||
iblinkotherofiles :
|
||||
readlinkcontainer(current_module^.LinkotherOFiles);
|
||||
iblinkotherstaticlibs :
|
||||
readlinkcontainer(current_module^.LinkotherStaticLibs);
|
||||
iblinkothersharedlibs :
|
||||
readlinkcontainer(current_module^.LinkotherSharedLibs);
|
||||
ibendinterface :
|
||||
break;
|
||||
else
|
||||
Message1(unit_f_ppu_invalid_entry,tostr(b));
|
||||
end;
|
||||
until false;
|
||||
end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.7 2000-11-04 14:25:22 florian
|
||||
+ merged Attila's changes for interfaces, not tested yet
|
||||
|
||||
Revision 1.6 2000/10/31 22:02:52 peter
|
||||
* symtable splitted, no real code changes
|
||||
|
||||
Revision 1.5 2000/10/15 07:47:53 peter
|
||||
* unit names and procedure names are stored mixed case
|
||||
|
||||
Revision 1.4 2000/09/24 21:33:47 peter
|
||||
* message updates merges
|
||||
|
||||
Revision 1.3 2000/09/21 20:56:19 pierre
|
||||
* fix for bugs 1084/1128 (merged)
|
||||
|
||||
Revision 1.2 2000/07/13 11:32:49 michael
|
||||
+ removed logs
|
||||
|
||||
}
|
||||
2263
compiler/symsym.inc
2263
compiler/symsym.inc
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user