mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 14:59:37 +01:00
1214 lines
39 KiB
ObjectPascal
1214 lines
39 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (c) 1998-2000 by Florian Klaempfl
|
|
|
|
This unit implements the first loading and searching of the modules
|
|
|
|
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.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit fppu;
|
|
|
|
{$i defines.inc}
|
|
|
|
{ close ppufiles on system that are
|
|
short on file handles like DOS system PM }
|
|
{$ifdef GO32V1}
|
|
{$define SHORT_ON_FILE_HANDLES}
|
|
{$endif GO32V1}
|
|
{$ifdef GO32V2}
|
|
{$define SHORT_ON_FILE_HANDLES}
|
|
{$endif GO32V2}
|
|
|
|
interface
|
|
|
|
uses
|
|
cutils,cclasses,
|
|
globtype,globals,finput,fmodule,
|
|
symbase,symppu,ppu;
|
|
|
|
type
|
|
tppumodule = class(tmodule)
|
|
ppufile : tcompilerppufile; { the PPU file }
|
|
{$ifdef Test_Double_checksum}
|
|
crc_array : pointer;
|
|
crc_size : longint;
|
|
crc_array2 : pointer;
|
|
crc_size2 : longint;
|
|
{$endif def Test_Double_checksum}
|
|
constructor create(const s:string;const fn:string;_is_unit:boolean);
|
|
destructor destroy;override;
|
|
procedure reset;override;
|
|
function openppu:boolean;
|
|
function search_unit(const n : string;const fn:string;onlysource:boolean):boolean;
|
|
procedure getppucrc;
|
|
procedure writeppu;
|
|
procedure loadppu;
|
|
private
|
|
procedure load_interface;
|
|
procedure load_symtable_refs;
|
|
procedure load_usedunits;
|
|
procedure writeusedmacro(p:TNamedIndexItem);
|
|
procedure writeusedmacros;
|
|
procedure writesourcefiles;
|
|
procedure writeusedunit;
|
|
procedure writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
|
|
procedure readusedmacros;
|
|
procedure readsourcefiles;
|
|
procedure readloadunit;
|
|
procedure readlinkcontainer(var p:tlinkcontainer);
|
|
end;
|
|
|
|
|
|
function loadunit(const s : stringid;const fn:string) : tmodule;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$ifdef delphi}
|
|
dmisc,
|
|
{$else}
|
|
dos,
|
|
{$endif}
|
|
verbose,systems,version,
|
|
symtable,
|
|
scanner,
|
|
parser;
|
|
|
|
|
|
{****************************************************************************
|
|
TPPUMODULE
|
|
****************************************************************************}
|
|
|
|
constructor tppumodule.create(const s:string;const fn:string;_is_unit:boolean);
|
|
begin
|
|
inherited create(s,_is_unit);
|
|
ppufile:=nil;
|
|
{ search the PPU file if it is an unit }
|
|
if is_unit then
|
|
begin
|
|
{ use the realmodulename so we can also find a case sensitive
|
|
source filename }
|
|
search_unit(realmodulename^,fn,false);
|
|
{ it the sources_available is changed then we know that
|
|
the sources aren't available }
|
|
if not sources_avail then
|
|
sources_checked:=true;
|
|
end;
|
|
end;
|
|
|
|
|
|
destructor tppumodule.Destroy;
|
|
begin
|
|
if assigned(ppufile) then
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.reset;
|
|
begin
|
|
if assigned(ppufile) then
|
|
begin
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
end;
|
|
inherited reset;
|
|
end;
|
|
|
|
|
|
function tppumodule.openppu:boolean;
|
|
var
|
|
ppufiletime : longint;
|
|
begin
|
|
openppu:=false;
|
|
Message1(unit_t_ppu_loading,ppufilename^);
|
|
{ Get ppufile time (also check if the file exists) }
|
|
ppufiletime:=getnamedfiletime(ppufilename^);
|
|
if ppufiletime=-1 then
|
|
exit;
|
|
{ Open the ppufile }
|
|
Message1(unit_u_ppu_name,ppufilename^);
|
|
ppufile:=tcompilerppufile.create(ppufilename^);
|
|
if not ppufile.openfile then
|
|
begin
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
Message(unit_u_ppu_file_too_short);
|
|
exit;
|
|
end;
|
|
{ check for a valid PPU file }
|
|
if not ppufile.CheckPPUId then
|
|
begin
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
Message(unit_u_ppu_invalid_header);
|
|
exit;
|
|
end;
|
|
{ check for allowed PPU versions }
|
|
if not (ppufile.GetPPUVersion = CurrentPPUVersion) then
|
|
begin
|
|
Message1(unit_u_ppu_invalid_version,tostr(ppufile.GetPPUVersion));
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
exit;
|
|
end;
|
|
{ check the target processor }
|
|
if ttargetcpu(ppufile.header.cpu)<>target_cpu then
|
|
begin
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
Message(unit_u_ppu_invalid_processor);
|
|
exit;
|
|
end;
|
|
{ check target }
|
|
if ttarget(ppufile.header.target)<>target_info.target then
|
|
begin
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
Message(unit_u_ppu_invalid_target);
|
|
exit;
|
|
end;
|
|
{ Load values to be access easier }
|
|
flags:=ppufile.header.flags;
|
|
crc:=ppufile.header.checksum;
|
|
interface_crc:=ppufile.header.interface_checksum;
|
|
{ Show Debug info }
|
|
Message1(unit_u_ppu_time,filetimestring(ppufiletime));
|
|
Message1(unit_u_ppu_flags,tostr(flags));
|
|
Message1(unit_u_ppu_crc,hexstr(ppufile.header.checksum,8));
|
|
Message1(unit_u_ppu_crc,hexstr(ppufile.header.interface_checksum,8)+' (intfc)');
|
|
do_compile:=false;
|
|
openppu:=true;
|
|
end;
|
|
|
|
|
|
function tppumodule.search_unit(const n : string;const fn:string;onlysource:boolean):boolean;
|
|
var
|
|
singlepathstring,
|
|
filename : string;
|
|
|
|
Function UnitExists(const ext:string;var foundfile:string):boolean;
|
|
begin
|
|
Message1(unit_t_unitsearch,Singlepathstring+filename+ext);
|
|
UnitExists:=FindFile(FileName+ext,Singlepathstring,foundfile);
|
|
end;
|
|
|
|
Function PPUSearchPath(const s:string):boolean;
|
|
var
|
|
found : boolean;
|
|
hs : string;
|
|
begin
|
|
Found:=false;
|
|
singlepathstring:=FixPath(s,false);
|
|
{ Check for PPU file }
|
|
Found:=UnitExists(target_info.unitext,hs);
|
|
if Found then
|
|
Begin
|
|
SetFileName(hs,false);
|
|
Found:=OpenPPU;
|
|
End;
|
|
PPUSearchPath:=Found;
|
|
end;
|
|
|
|
Function SourceSearchPath(const s:string):boolean;
|
|
var
|
|
found : boolean;
|
|
hs : string;
|
|
begin
|
|
Found:=false;
|
|
singlepathstring:=FixPath(s,false);
|
|
{ Check for Sources }
|
|
ppufile:=nil;
|
|
do_compile:=true;
|
|
recompile_reason:=rr_noppu;
|
|
{Check for .pp file}
|
|
Found:=UnitExists(target_info.sourceext,hs);
|
|
if not Found then
|
|
begin
|
|
{ Check for .pas }
|
|
Found:=UnitExists(target_info.pasext,hs);
|
|
end;
|
|
stringdispose(mainsource);
|
|
if Found then
|
|
begin
|
|
sources_avail:=true;
|
|
{ Load Filenames when found }
|
|
mainsource:=StringDup(hs);
|
|
SetFileName(hs,false);
|
|
end
|
|
else
|
|
sources_avail:=false;
|
|
SourceSearchPath:=Found;
|
|
end;
|
|
|
|
Function SearchPath(const s:string):boolean;
|
|
var
|
|
found : boolean;
|
|
begin
|
|
{ First check for a ppu, then for the source }
|
|
found:=false;
|
|
if not onlysource then
|
|
found:=PPUSearchPath(s);
|
|
if not found then
|
|
found:=SourceSearchPath(s);
|
|
SearchPath:=found;
|
|
end;
|
|
|
|
Function SearchPathList(list:TSearchPathList):boolean;
|
|
var
|
|
hp : TStringListItem;
|
|
found : boolean;
|
|
begin
|
|
found:=false;
|
|
hp:=TStringListItem(list.First);
|
|
while assigned(hp) do
|
|
begin
|
|
found:=SearchPath(hp.Str);
|
|
if found then
|
|
break;
|
|
hp:=TStringListItem(hp.next);
|
|
end;
|
|
SearchPathList:=found;
|
|
end;
|
|
|
|
var
|
|
fnd : boolean;
|
|
hs : string;
|
|
begin
|
|
filename:=FixFileName(n);
|
|
{ try to find unit
|
|
1. look for ppu in cwd
|
|
2. look for ppu in outputpath if set, this is tp7 compatible (PFV)
|
|
3. look for the specified source file (from the uses line)
|
|
4. look for source in cwd
|
|
5. local unit pathlist
|
|
6. global unit pathlist }
|
|
fnd:=false;
|
|
if not onlysource then
|
|
begin
|
|
fnd:=PPUSearchPath('.');
|
|
if (not fnd) and (current_module.outputpath^<>'') then
|
|
fnd:=PPUSearchPath(current_module.outputpath^);
|
|
end;
|
|
if (not fnd) and (fn<>'') then
|
|
begin
|
|
{ the full filename is specified so we can't use here the
|
|
searchpath (PFV) }
|
|
Message1(unit_t_unitsearch,AddExtension(fn,target_info.sourceext));
|
|
fnd:=FindFile(AddExtension(fn,target_info.sourceext),'',hs);
|
|
if not fnd then
|
|
begin
|
|
Message1(unit_t_unitsearch,AddExtension(fn,target_info.pasext));
|
|
fnd:=FindFile(AddExtension(fn,target_info.pasext),'',hs);
|
|
end;
|
|
if fnd then
|
|
begin
|
|
sources_avail:=true;
|
|
do_compile:=true;
|
|
recompile_reason:=rr_noppu;
|
|
stringdispose(mainsource);
|
|
mainsource:=StringDup(hs);
|
|
SetFileName(hs,false);
|
|
end;
|
|
end;
|
|
if (not fnd) then
|
|
fnd:=SourceSearchPath('.');
|
|
if (not fnd) then
|
|
fnd:=SearchPathList(current_module.LocalUnitSearchPath);
|
|
if (not fnd) then
|
|
fnd:=SearchPathList(UnitSearchPath);
|
|
|
|
{ try to find a file with the first 8 chars of the modulename, like
|
|
dos }
|
|
if (not fnd) and (length(filename)>8) then
|
|
begin
|
|
filename:=copy(filename,1,8);
|
|
fnd:=SearchPath('.');
|
|
if (not fnd) then
|
|
fnd:=SearchPathList(current_module.LocalUnitSearchPath);
|
|
if not fnd then
|
|
fnd:=SearchPathList(UnitSearchPath);
|
|
end;
|
|
search_unit:=fnd;
|
|
end;
|
|
|
|
|
|
{**********************************
|
|
PPU Reading/Writing Helpers
|
|
***********************************}
|
|
|
|
procedure tppumodule.writeusedmacro(p:TNamedIndexItem);
|
|
begin
|
|
if tmacro(p).is_used or tmacro(p).defined_at_startup then
|
|
begin
|
|
ppufile.putstring(p.name);
|
|
ppufile.putbyte(byte(tmacro(p).defined_at_startup));
|
|
ppufile.putbyte(byte(tmacro(p).is_used));
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.writeusedmacros;
|
|
begin
|
|
ppufile.do_crc:=false;
|
|
current_scanner.macros.foreach({$ifdef FPCPROCVAR}@{$endif}writeusedmacro);
|
|
ppufile.writeentry(ibusedmacros);
|
|
ppufile.do_crc:=true;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.writesourcefiles;
|
|
var
|
|
hp : tinputfile;
|
|
i,j : longint;
|
|
begin
|
|
{ second write the used source files }
|
|
ppufile.do_crc:=false;
|
|
hp:=sourcefiles.files;
|
|
{ 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:=sourcefiles.files;
|
|
for i:=1 to j-1 do
|
|
hp:=hp.ref_next;
|
|
ppufile.putstring(hp.name^);
|
|
dec(j);
|
|
end;
|
|
ppufile.writeentry(ibsourcefiles);
|
|
ppufile.do_crc:=true;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.writeusedunit;
|
|
var
|
|
hp : tused_unit;
|
|
begin
|
|
{ renumber the units for derefence writing }
|
|
numberunits;
|
|
{ write a reference for each used unit }
|
|
hp:=tused_unit(used_units.first);
|
|
while assigned(hp) do
|
|
begin
|
|
{ implementation units should not change
|
|
the CRC PM }
|
|
ppufile.do_crc:=hp.in_interface;
|
|
ppufile.putstring(hp.realname^);
|
|
{ the checksum should not affect the crc of this unit ! (PFV) }
|
|
ppufile.do_crc:=false;
|
|
ppufile.putlongint(longint(hp.checksum));
|
|
ppufile.putlongint(longint(hp.interface_checksum));
|
|
ppufile.putbyte(byte(hp.in_interface));
|
|
ppufile.do_crc:=true;
|
|
hp:=tused_unit(hp.next);
|
|
end;
|
|
ppufile.do_interface_crc:=true;
|
|
ppufile.writeentry(ibloadunit);
|
|
end;
|
|
|
|
|
|
procedure tppumodule.writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
|
|
var
|
|
hcontainer : tlinkcontainer;
|
|
s : string;
|
|
mask : cardinal;
|
|
begin
|
|
hcontainer:=TLinkContainer.Create;
|
|
while not p.empty do
|
|
begin
|
|
s:=p.get(mask);
|
|
if strippath then
|
|
ppufile.putstring(SplitFileName(s))
|
|
else
|
|
ppufile.putstring(s);
|
|
ppufile.putlongint(mask);
|
|
hcontainer.add(s,mask);
|
|
end;
|
|
ppufile.writeentry(id);
|
|
p.Free;
|
|
p:=hcontainer;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.readusedmacros;
|
|
var
|
|
hs : string;
|
|
mac : tmacro;
|
|
was_defined_at_startup,
|
|
was_used : boolean;
|
|
begin
|
|
while not ppufile.endofentry do
|
|
begin
|
|
hs:=ppufile.getstring;
|
|
was_defined_at_startup:=boolean(ppufile.getbyte);
|
|
was_used:=boolean(ppufile.getbyte);
|
|
mac:=tmacro(current_scanner.macros.search(hs));
|
|
if assigned(mac) then
|
|
begin
|
|
{$ifndef EXTDEBUG}
|
|
{ if we don't have the sources why tell }
|
|
if 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,mainsource^);
|
|
end
|
|
else { not assigned }
|
|
if was_defined_at_startup and
|
|
was_used then
|
|
Message2(unit_h_cond_not_set_in_last_compile,hs,mainsource^);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.readsourcefiles;
|
|
var
|
|
temp,hs : string;
|
|
temp_dir : string;
|
|
main_dir : string;
|
|
incfile_found,
|
|
main_found,
|
|
is_main : boolean;
|
|
ppufiletime,
|
|
source_time : longint;
|
|
hp : tinputfile;
|
|
begin
|
|
ppufiletime:=getnamedfiletime(ppufilename^);
|
|
sources_avail:=true;
|
|
is_main:=true;
|
|
main_dir:='';
|
|
while not ppufile.endofentry do
|
|
begin
|
|
hs:=ppufile.getstring;
|
|
temp_dir:='';
|
|
if (flags and uf_in_library)<>0 then
|
|
begin
|
|
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(path^+hs);
|
|
incfile_found:=false;
|
|
main_found:=false;
|
|
if Source_Time<>-1 then
|
|
hs:=path^+hs
|
|
else
|
|
if not(is_main) then
|
|
begin
|
|
Source_Time:=GetNamedFileTime(main_dir+hs);
|
|
if Source_Time<>-1 then
|
|
hs:=main_dir+hs;
|
|
end;
|
|
if (Source_Time=-1) then
|
|
begin
|
|
if is_main then
|
|
main_found:=unitsearchpath.FindFile(hs,temp_dir)
|
|
else
|
|
incfile_found:=includesearchpath.FindFile(hs,temp_dir);
|
|
if incfile_found or main_found then
|
|
begin
|
|
Source_Time:=GetNamedFileTime(temp_dir);
|
|
if Source_Time<>-1 then
|
|
hs:=temp_dir;
|
|
end;
|
|
end;
|
|
if Source_Time=-1 then
|
|
begin
|
|
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
|
|
if {is_main or} ((flags and uf_release)=0) then
|
|
begin
|
|
do_compile:=true;
|
|
recompile_reason:=rr_sourcenewer;
|
|
end
|
|
else
|
|
Message2(unit_h_source_modified,hs,ppufilename^);
|
|
temp:=temp+' *';
|
|
end;
|
|
end;
|
|
end;
|
|
hp:=tinputfile.create(hs);
|
|
{ the indexing is wrong here PM }
|
|
sourcefiles.register_file(hp);
|
|
end;
|
|
if is_main then
|
|
begin
|
|
stringdispose(mainsource);
|
|
mainsource:=stringdup(hs);
|
|
end;
|
|
Message1(unit_u_ppu_source,hs+temp);
|
|
is_main:=false;
|
|
end;
|
|
{ check if we want to rebuild every unit, only if the sources are
|
|
available }
|
|
if do_build and sources_avail and
|
|
((flags and uf_release)=0) then
|
|
begin
|
|
do_compile:=true;
|
|
recompile_reason:=rr_build;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.readloadunit;
|
|
var
|
|
hs : string;
|
|
intfchecksum,
|
|
checksum : cardinal;
|
|
in_interface : boolean;
|
|
begin
|
|
while not ppufile.endofentry do
|
|
begin
|
|
hs:=ppufile.getstring;
|
|
checksum:=cardinal(ppufile.getlongint);
|
|
intfchecksum:=cardinal(ppufile.getlongint);
|
|
in_interface:=(ppufile.getbyte<>0);
|
|
used_units.concat(tused_unit.create_to_load(hs,checksum,intfchecksum,in_interface));
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.readlinkcontainer(var p:tlinkcontainer);
|
|
var
|
|
s : string;
|
|
m : longint;
|
|
begin
|
|
while not ppufile.endofentry do
|
|
begin
|
|
s:=ppufile.getstring;
|
|
m:=ppufile.getlongint;
|
|
p.add(s,m);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.load_interface;
|
|
var
|
|
b : byte;
|
|
newmodulename : string;
|
|
begin
|
|
{ read interface part }
|
|
repeat
|
|
b:=ppufile.readentry;
|
|
case b of
|
|
ibmodulename :
|
|
begin
|
|
newmodulename:=ppufile.getstring;
|
|
if upper(newmodulename)<>modulename^ then
|
|
Message2(unit_f_unit_name_error,realmodulename^,newmodulename);
|
|
stringdispose(modulename);
|
|
stringdispose(realmodulename);
|
|
modulename:=stringdup(upper(newmodulename));
|
|
realmodulename:=stringdup(newmodulename);
|
|
end;
|
|
ibsourcefiles :
|
|
readsourcefiles;
|
|
ibusedmacros :
|
|
readusedmacros;
|
|
ibloadunit :
|
|
readloadunit;
|
|
iblinkunitofiles :
|
|
readlinkcontainer(LinkUnitOFiles);
|
|
iblinkunitstaticlibs :
|
|
readlinkcontainer(LinkUnitStaticLibs);
|
|
iblinkunitsharedlibs :
|
|
readlinkcontainer(LinkUnitSharedLibs);
|
|
iblinkotherofiles :
|
|
readlinkcontainer(LinkotherOFiles);
|
|
iblinkotherstaticlibs :
|
|
readlinkcontainer(LinkotherStaticLibs);
|
|
iblinkothersharedlibs :
|
|
readlinkcontainer(LinkotherSharedLibs);
|
|
ibendinterface :
|
|
break;
|
|
else
|
|
Message1(unit_f_ppu_invalid_entry,tostr(b));
|
|
end;
|
|
until false;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.load_symtable_refs;
|
|
var
|
|
b : byte;
|
|
unitindex : word;
|
|
begin
|
|
{ load local symtable first }
|
|
if ((flags and uf_local_browser)<>0) then
|
|
begin
|
|
localsymtable:=tstaticsymtable.create(modulename^);
|
|
tstaticsymtable(localsymtable).load(ppufile);
|
|
end;
|
|
|
|
{ load browser }
|
|
if (current_module.flags and uf_has_browser)<>0 then
|
|
begin
|
|
tstoredsymtable(globalsymtable).load_browser(ppufile);
|
|
unitindex:=1;
|
|
while assigned(map^[unitindex]) do
|
|
begin
|
|
{ each unit wrote one browser entry }
|
|
tstoredsymtable(globalsymtable).load_browser(ppufile);
|
|
inc(unitindex);
|
|
end;
|
|
b:=ppufile.readentry;
|
|
if b<>ibendbrowser then
|
|
Message1(unit_f_ppu_invalid_entry,tostr(b));
|
|
end;
|
|
if ((current_module.flags and uf_local_browser)<>0) then
|
|
tstaticsymtable(current_module.localsymtable).load_browser(ppufile);
|
|
end;
|
|
|
|
|
|
procedure tppumodule.writeppu;
|
|
var
|
|
pu : tused_unit;
|
|
begin
|
|
Message1(unit_u_ppu_write,realmodulename^);
|
|
|
|
{ create unit flags }
|
|
{$ifdef GDB}
|
|
if cs_gdb_dbx in aktglobalswitches then
|
|
flags:=flags or uf_has_dbx;
|
|
{$endif GDB}
|
|
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;
|
|
if do_release then
|
|
flags:=flags or uf_release;
|
|
|
|
{$ifdef Test_Double_checksum_write}
|
|
Assign(CRCFile,s+'.IMP');
|
|
Rewrite(CRCFile);
|
|
{$endif def Test_Double_checksum_write}
|
|
|
|
{ create new ppufile }
|
|
ppufile:=tcompilerppufile.create(ppufilename^);
|
|
if not ppufile.createfile then
|
|
Message(unit_f_ppu_cannot_write);
|
|
|
|
{ first the unitname }
|
|
ppufile.putstring(realmodulename^);
|
|
ppufile.writeentry(ibmodulename);
|
|
|
|
writesourcefiles;
|
|
writeusedmacros;
|
|
writeusedunit;
|
|
|
|
{ write the objectfiles and libraries that come for this unit,
|
|
preserve the containers becuase they are still needed to load
|
|
the link.res. All doesn't depend on the crc! It doesn't matter
|
|
if a unit is in a .o or .a file }
|
|
ppufile.do_crc:=false;
|
|
writelinkcontainer(linkunitofiles,iblinkunitofiles,true);
|
|
writelinkcontainer(linkunitstaticlibs,iblinkunitstaticlibs,true);
|
|
writelinkcontainer(linkunitsharedlibs,iblinkunitsharedlibs,true);
|
|
writelinkcontainer(linkotherofiles,iblinkotherofiles,false);
|
|
writelinkcontainer(linkotherstaticlibs,iblinkotherstaticlibs,true);
|
|
writelinkcontainer(linkothersharedlibs,iblinkothersharedlibs,true);
|
|
ppufile.do_crc:=true;
|
|
|
|
ppufile.writeentry(ibendinterface);
|
|
|
|
{ write the symtable entries }
|
|
tstoredsymtable(globalsymtable).write(ppufile);
|
|
|
|
{ everything after this doesn't affect the crc }
|
|
ppufile.do_crc:=false;
|
|
ppufile.writeentry(ibendimplementation);
|
|
|
|
{ write static symtable
|
|
needed for local debugging of unit functions }
|
|
if ((flags and uf_local_browser)<>0) and
|
|
assigned(localsymtable) then
|
|
tstoredsymtable(localsymtable).write(ppufile);
|
|
|
|
{ write all browser section }
|
|
if (flags and uf_has_browser)<>0 then
|
|
begin
|
|
tstoredsymtable(globalsymtable).write_browser(ppufile);
|
|
pu:=tused_unit(used_units.first);
|
|
while assigned(pu) do
|
|
begin
|
|
tstoredsymtable(pu.u.globalsymtable).write_browser(ppufile);
|
|
pu:=tused_unit(pu.next);
|
|
end;
|
|
ppufile.writeentry(ibendbrowser);
|
|
end;
|
|
if ((flags and uf_local_browser)<>0) and
|
|
assigned(localsymtable) then
|
|
tstaticsymtable(localsymtable).write_browser(ppufile);
|
|
|
|
{ the last entry ibend is written automaticly }
|
|
|
|
{ flush to be sure }
|
|
ppufile.flush;
|
|
{ create and write header }
|
|
ppufile.header.size:=ppufile.size;
|
|
ppufile.header.checksum:=ppufile.crc;
|
|
ppufile.header.interface_checksum:=ppufile.interface_crc;
|
|
ppufile.header.compiler:=wordversion;
|
|
ppufile.header.cpu:=word(target_cpu);
|
|
ppufile.header.target:=word(target_info.target);
|
|
ppufile.header.flags:=flags;
|
|
ppufile.writeheader;
|
|
|
|
{ save crc in current module also }
|
|
crc:=ppufile.crc;
|
|
interface_crc:=ppufile.interface_crc;
|
|
|
|
{$ifdef Test_Double_checksum_write}
|
|
close(CRCFile);
|
|
{$endif Test_Double_checksum_write}
|
|
|
|
ppufile.closefile;
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.getppucrc;
|
|
begin
|
|
{$ifdef Test_Double_checksum_write}
|
|
Assign(CRCFile,s+'.INT')
|
|
Rewrite(CRCFile);
|
|
{$endif def Test_Double_checksum_write}
|
|
|
|
{ create new ppufile }
|
|
ppufile:=tcompilerppufile.create(ppufilename^);
|
|
ppufile.crc_only:=true;
|
|
if not ppufile.createfile then
|
|
Message(unit_f_ppu_cannot_write);
|
|
|
|
{ first the unitname }
|
|
ppufile.putstring(realmodulename^);
|
|
ppufile.writeentry(ibmodulename);
|
|
|
|
{ the interface units affect the crc }
|
|
writeusedunit;
|
|
|
|
ppufile.writeentry(ibendinterface);
|
|
|
|
{ write the symtable entries }
|
|
tstoredsymtable(globalsymtable).write(ppufile);
|
|
|
|
{ save crc }
|
|
crc:=ppufile.crc;
|
|
interface_crc:=ppufile.interface_crc;
|
|
|
|
{$ifdef Test_Double_checksum}
|
|
crc_array:=ppufile.crc_test;
|
|
ppufile.crc_test:=nil;
|
|
crc_size:=ppufile.crc_index2;
|
|
crc_array2:=ppufile.crc_test2;
|
|
ppufile.crc_test2:=nil;
|
|
crc_size2:=ppufile.crc_index2;
|
|
{$endif Test_Double_checksum}
|
|
|
|
{$ifdef Test_Double_checksum_write}
|
|
close(CRCFile);
|
|
{$endif Test_Double_checksum_write}
|
|
|
|
ppufile.closefile;
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.load_usedunits;
|
|
var
|
|
pu : tused_unit;
|
|
loaded_unit : tmodule;
|
|
load_refs : boolean;
|
|
nextmapentry : longint;
|
|
b : byte;
|
|
begin
|
|
load_refs:=true;
|
|
{ init the map }
|
|
new(map);
|
|
fillchar(map^,sizeof(tunitmap),#0);
|
|
{$ifdef NEWMAP}
|
|
map^[0]:=current_module;
|
|
{$endif NEWMAP}
|
|
nextmapentry:=1;
|
|
{ load the used units from interface }
|
|
in_implementation:=false;
|
|
pu:=tused_unit(used_units.first);
|
|
while assigned(pu) do
|
|
begin
|
|
if (not pu.loaded) and (pu.in_interface) then
|
|
begin
|
|
loaded_unit:=loadunit(pu.realname^,'');
|
|
if compiled then
|
|
exit;
|
|
{ register unit in used units }
|
|
pu.u:=loaded_unit;
|
|
pu.loaded:=true;
|
|
{ doubles are not important for that list PM }
|
|
pu.u.dependent_units.concat(tdependent_unit.create(self));
|
|
{ need to recompile the current unit ? }
|
|
if loaded_unit.crc<>pu.checksum then
|
|
begin
|
|
Message2(unit_u_recompile_crc_change,realmodulename^,pu.realname^);
|
|
recompile_reason:=rr_crcchanged;
|
|
do_compile:=true;
|
|
dispose(map);
|
|
map:=nil;
|
|
exit;
|
|
end;
|
|
{ setup the map entry for deref }
|
|
{$ifndef NEWMAP}
|
|
map^[nextmapentry]:=loaded_unit.globalsymtable;
|
|
{$else NEWMAP}
|
|
map^[nextmapentry]:=loaded_unit;
|
|
{$endif NEWMAP}
|
|
inc(nextmapentry);
|
|
if nextmapentry>maxunits then
|
|
Message(unit_f_too_much_units);
|
|
end;
|
|
pu:=tused_unit(pu.next);
|
|
end;
|
|
{ ok, now load the interface of this unit }
|
|
current_module:=self;
|
|
SetCompileModule(current_module);
|
|
globalsymtable:=tglobalsymtable.create(modulename^);
|
|
tstoredsymtable(globalsymtable).load(ppufile);
|
|
{ now only read the implementation uses }
|
|
in_implementation:=true;
|
|
pu:=tused_unit(used_units.first);
|
|
while assigned(pu) do
|
|
begin
|
|
if (not pu.loaded) and (not pu.in_interface) then
|
|
begin
|
|
loaded_unit:=loadunit(pu.realname^,'');
|
|
if compiled then
|
|
exit;
|
|
{ register unit in used units }
|
|
pu.u:=loaded_unit;
|
|
pu.loaded:=true;
|
|
{ need to recompile the current unit ? }
|
|
if (loaded_unit.interface_crc<>pu.interface_checksum) {and
|
|
not(current_module.in_second_compile) } then
|
|
begin
|
|
Message2(unit_u_recompile_crc_change,realmodulename^,pu.realname^+' {impl}');
|
|
recompile_reason:=rr_crcchanged;
|
|
do_compile:=true;
|
|
dispose(map);
|
|
map:=nil;
|
|
exit;
|
|
end;
|
|
{ setup the map entry for deref }
|
|
{$ifndef NEWMAP}
|
|
map^[nextmapentry]:=loaded_unit.globalsymtable;
|
|
{$else NEWMAP}
|
|
map^[nextmapentry]:=loaded_unit;
|
|
{$endif NEWMAP}
|
|
inc(nextmapentry);
|
|
if nextmapentry>maxunits then
|
|
Message(unit_f_too_much_units);
|
|
end;
|
|
pu:=tused_unit(pu.next);
|
|
end;
|
|
{ read the implementation part }
|
|
b:=ppufile.readentry;
|
|
if b<>ibendimplementation then
|
|
Message1(unit_f_ppu_invalid_entry,tostr(b));
|
|
{ load browser info if stored }
|
|
if ((flags and uf_has_browser)<>0) and load_refs then
|
|
begin
|
|
current_module:=self;
|
|
load_symtable_refs;
|
|
end;
|
|
{ remove the map, it's not needed anymore }
|
|
dispose(map);
|
|
map:=nil;
|
|
end;
|
|
|
|
|
|
procedure tppumodule.loadppu;
|
|
var
|
|
name : string;
|
|
begin
|
|
{ load interface section }
|
|
if not do_compile then
|
|
load_interface;
|
|
{ only load units when we don't recompile }
|
|
if not do_compile then
|
|
load_usedunits;
|
|
{ recompile if set }
|
|
if do_compile then
|
|
begin
|
|
{ we don't need the ppufile anymore }
|
|
if assigned(ppufile) then
|
|
begin
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
end;
|
|
{ recompile the unit or give a fatal error if sources not available }
|
|
if not(sources_avail) and
|
|
not(sources_checked) then
|
|
if (not search_unit(modulename^,'',true))
|
|
and (length(modulename^)>8) then
|
|
search_unit(copy(modulename^,1,8),'',true);
|
|
if not(sources_avail) then
|
|
begin
|
|
if recompile_reason=rr_noppu then
|
|
Message1(unit_f_cant_find_ppu,modulename^)
|
|
else
|
|
Message1(unit_f_cant_compile_unit,modulename^);
|
|
end
|
|
else
|
|
begin
|
|
if in_compile then
|
|
begin
|
|
in_second_compile:=true;
|
|
Message1(parser_d_compiling_second_time,modulename^);
|
|
end;
|
|
current_scanner.tempcloseinputfile;
|
|
name:=mainsource^;
|
|
if assigned(scanner) then
|
|
tscannerfile(scanner).invalid:=true;
|
|
{ compile this module }
|
|
current_module:=self;
|
|
compile(name);
|
|
in_second_compile:=false;
|
|
if (not current_scanner.invalid) then
|
|
current_scanner.tempopeninputfile;
|
|
end;
|
|
end;
|
|
if assigned(ppufile) then
|
|
begin
|
|
ppufile.closefile;
|
|
ppufile.free;
|
|
ppufile:=nil;
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
LoadUnit
|
|
*****************************************************************************}
|
|
|
|
function loadunit(const s : stringid;const fn:string) : tmodule;
|
|
const
|
|
ImplIntf : array[boolean] of string[15]=('interface','implementation');
|
|
var
|
|
st : tglobalsymtable;
|
|
second_time : boolean;
|
|
old_current_module,hp2 : tmodule;
|
|
hp : tppumodule;
|
|
scanner : tscannerfile;
|
|
dummy : tmodule;
|
|
ups : stringid;
|
|
begin
|
|
old_current_module:=current_module;
|
|
{ Info }
|
|
Message3(unit_u_load_unit,current_module.modulename^,ImplIntf[current_module.in_implementation],s);
|
|
ups:=upper(s);
|
|
{ unit not found }
|
|
st:=nil;
|
|
dummy:=nil;
|
|
{ search all loaded units }
|
|
hp:=tppumodule(loaded_units.first);
|
|
while assigned(hp) do
|
|
begin
|
|
if hp.modulename^=ups then
|
|
begin
|
|
{ forced to reload ? }
|
|
if hp.do_reload then
|
|
begin
|
|
hp.do_reload:=false;
|
|
break;
|
|
end;
|
|
{ only check for units. The main program is also
|
|
as a unit in the loaded_units list. We simply need
|
|
to ignore this entry (PFV) }
|
|
if hp.is_unit then
|
|
begin
|
|
{ the unit is already registered }
|
|
{ and this means that the unit }
|
|
{ is already compiled }
|
|
{ else there is a cyclic unit use }
|
|
if assigned(hp.globalsymtable) then
|
|
st:=tglobalsymtable(hp.globalsymtable)
|
|
else
|
|
begin
|
|
{ both units in interface ? }
|
|
if (not current_module.in_implementation) and
|
|
(not hp.in_implementation) then
|
|
begin
|
|
{ check for a cycle }
|
|
hp2:=current_module.loaded_from;
|
|
while assigned(hp2) and (hp2<>hp) do
|
|
begin
|
|
if hp2.in_implementation then
|
|
hp2:=nil
|
|
else
|
|
hp2:=hp2.loaded_from;
|
|
end;
|
|
if assigned(hp2) then
|
|
Message2(unit_f_circular_unit_reference,current_module.modulename^,hp.modulename^);
|
|
end;
|
|
end;
|
|
break;
|
|
end;
|
|
end
|
|
else if copy(hp.modulename^,1,8)=ups then
|
|
dummy:=hp;
|
|
{ the next unit }
|
|
hp:=tppumodule(hp.next);
|
|
end;
|
|
if assigned(dummy) and not assigned(hp) then
|
|
Message2(unit_w_unit_name_error,s,dummy.modulename^);
|
|
{ the unit is not in the loaded units, we must load it first }
|
|
if (not assigned(st)) then
|
|
begin
|
|
if assigned(hp) then
|
|
begin
|
|
{ remove the old unit, but save the scanner }
|
|
loaded_units.remove(hp);
|
|
scanner:=tscannerfile(hp.scanner);
|
|
hp.reset;
|
|
hp.scanner:=scanner;
|
|
{ try to reopen ppu }
|
|
hp.search_unit(s,fn,false);
|
|
{ try to load the unit a second time first }
|
|
current_module:=hp;
|
|
current_module.in_second_load:=true;
|
|
Message1(unit_u_second_load_unit,current_module.modulename^);
|
|
second_time:=true;
|
|
end
|
|
else
|
|
{ generates a new unit info record }
|
|
begin
|
|
current_module:=tppumodule.create(s,fn,true);
|
|
scanner:=nil;
|
|
second_time:=false;
|
|
end;
|
|
{ close old_current_ppu on system that are
|
|
short on file handles like DOS PM }
|
|
{$ifdef SHORT_ON_FILE_HANDLES}
|
|
if old_current_module.is_unit and
|
|
assigned(tppumodule(old_current_module).ppufile) then
|
|
tppumodule(old_current_module).ppufile.tempclose;
|
|
{$endif SHORT_ON_FILE_HANDLES}
|
|
{ now we can register the unit }
|
|
current_module.loaded_from:=old_current_module;
|
|
loaded_units.insert(current_module);
|
|
{ now realy load the ppu }
|
|
tppumodule(current_module).loadppu;
|
|
{ set compiled flag }
|
|
current_module.compiled:=true;
|
|
{ load return pointer }
|
|
hp:=tppumodule(current_module);
|
|
{ for a second_time recompile reload all dependent units,
|
|
for a first time compile register the unit _once_ }
|
|
if second_time then
|
|
begin
|
|
{ now reload all dependent units }
|
|
hp2:=tmodule(loaded_units.first);
|
|
while assigned(hp2) do
|
|
begin
|
|
if hp2.do_reload then
|
|
dummy:=loadunit(hp2.modulename^,'');
|
|
hp2:=tmodule(hp2.next);
|
|
end;
|
|
end
|
|
else
|
|
usedunits.concat(tused_unit.create(current_module,true));
|
|
end;
|
|
{ set the old module }
|
|
{$ifdef SHORT_ON_FILE_HANDLES}
|
|
if old_current_module.is_unit and
|
|
assigned(tppumodule(old_current_module).ppufile) then
|
|
tppumodule(old_current_module).ppufile.tempopen;
|
|
{$endif SHORT_ON_FILE_HANDLES}
|
|
{ we are back }
|
|
current_module:=old_current_module;
|
|
SetCompileModule(current_module);
|
|
loadunit:=hp;
|
|
end;
|
|
|
|
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.9 2001-06-18 20:36:23 peter
|
|
* -Ur switch (merged)
|
|
* masm fixes (merged)
|
|
* quoted filenames for go32v2 and win32
|
|
|
|
Revision 1.8 2001/06/04 11:49:08 peter
|
|
* store used units in original type in ppu
|
|
|
|
Revision 1.7 2001/05/19 23:05:19 peter
|
|
* support uses <unit> in <file> construction
|
|
|
|
Revision 1.6 2001/05/19 21:08:59 peter
|
|
* skip program when checking loaded_units for a unit
|
|
|
|
Revision 1.5 2001/05/19 13:22:47 peter
|
|
* fixed crash with invalid ppu version detected
|
|
|
|
Revision 1.4 2001/05/09 14:11:10 jonas
|
|
* range check error fixes from Peter
|
|
|
|
Revision 1.3 2001/05/08 21:06:30 florian
|
|
* some more support for widechars commited especially
|
|
regarding type casting and constants
|
|
|
|
Revision 1.2 2001/05/07 11:53:21 jonas
|
|
* fix from Peter for short_on_file_handles code
|
|
|
|
Revision 1.1 2001/05/06 14:49:17 peter
|
|
* ppu object to class rewrite
|
|
* move ppu read and write stuff to fppu
|
|
}
|