paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 11:29:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* moved to compiler/utils/

Browse Source
This commit is contained in:
peter 2001-04-25 23:02:41 +00:00
parent 7b9b157103
commit f70033953a
5 changed files with 0 additions and 3538 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
utils/crc.pas
View File

@ -1,116 +0,0 @@
{
$Id$
Copyright (c) 2000 by Free Pascal Development Team
Routines to compute CRC values
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 CRC;
Interface
Function Crc32(Const HStr:String):longint;
Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint;
Function UpdCrc32(InitCrc:longint;b:byte):longint;
Implementation
{*****************************************************************************
Crc 32
*****************************************************************************}
var
Crc32Tbl : array[0..255] of longint;
procedure MakeCRC32Tbl;
var
crc : longint;
i,n : byte;
begin
for i:=0 to 255 do
begin
crc:=i;
for n:=1 to 8 do
if odd(crc) then
crc:=(crc shr 1) xor longint($edb88320)
else
crc:=crc shr 1;
Crc32Tbl[i]:=crc;
end;
end;
{$ifopt R+}
{$define Range_check_on}
{$endif opt R+}
{$R- needed here }
{CRC 32}
Function Crc32(Const HStr:String):longint;
var
i,InitCrc : longint;
begin
if Crc32Tbl[1]=0 then
MakeCrc32Tbl;
InitCrc:=longint($ffffffff);
for i:=1 to Length(Hstr) do
InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(Hstr[i])] xor (InitCrc shr 8);
Crc32:=InitCrc;
end;
Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint;
var
i : word;
p : pchar;
begin
if Crc32Tbl[1]=0 then
MakeCrc32Tbl;
p:=@InBuf;
for i:=1 to InLen do
begin
InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
inc(longint(p));
end;
UpdateCrc32:=InitCrc;
end;
Function UpdCrc32(InitCrc:longint;b:byte):longint;
begin
if Crc32Tbl[1]=0 then
MakeCrc32Tbl;
UpdCrc32:=Crc32Tbl[byte(InitCrc) xor b] xor (InitCrc shr 8);
end;
{$ifdef Range_check_on}
{$R+}
{$undef Range_check_on}
{$endif Range_check_on}
end.
{
$Log$
Revision 1.1 2000-08-13 12:58:06 peter
* updated for ppu additions
Revision 1.2 2000/07/13 11:32:39 michael
+ removed logs
}

924
utils/ppu.pas
View File

@ -1,924 +0,0 @@
{
$Id$
Copyright (c) 1998-2000 by Florian Klaempfl
Routines to read/write ppu files
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 ppu;
{$H-}
interface
{ Also write the ppu if only crc if done, this can be used with ppudump to
see the differences between the intf and implementation }
{ define INTFPPU}
{$ifdef Test_Double_checksum}
var
CRCFile : text;
const
CRC_array_Size = 200000;
type
tcrc_array = array[0..crc_array_size] of longint;
pcrc_array = ^tcrc_array;
{$endif Test_Double_checksum}
const
{$ifdef newcg}
CurrentPPUVersion=102;
{$else newcg}
CurrentPPUVersion=22;
{$endif newcg}
{ buffer sizes }
maxentrysize = 1024;
ppubufsize = 16384;
{ppu entries}
mainentryid = 1;
subentryid = 2;
{special}
iberror = 0;
ibstartdefs = 248;
ibenddefs = 249;
ibstartsyms = 250;
ibendsyms = 251;
ibendinterface = 252;
ibendimplementation = 253;
ibendbrowser = 254;
ibend = 255;
{general}
ibmodulename = 1;
ibsourcefiles = 2;
ibloadunit = 3;
ibinitunit = 4;
iblinkunitofiles = 5;
iblinkunitstaticlibs = 6;
iblinkunitsharedlibs = 7;
iblinkotherofiles = 8;
iblinkotherstaticlibs = 9;
iblinkothersharedlibs = 10;
ibdbxcount = 11;
ibsymref = 12;
ibdefref = 13;
ibendsymtablebrowser = 14;
ibbeginsymtablebrowser = 15;
ibusedmacros = 16;
{syms}
ibtypesym = 20;
ibprocsym = 21;
ibvarsym = 22;
ibconstsym = 23;
ibenumsym = 24;
ibtypedconstsym = 25;
ibabsolutesym = 26;
ibpropertysym = 27;
ibvarsym_C = 28;
ibunitsym = 29; { needed for browser }
iblabelsym = 30;
ibfuncretsym = 31;
ibsyssym = 32;
{definitions}
iborddef = 40;
ibpointerdef = 41;
ibarraydef = 42;
ibprocdef = 43;
ibshortstringdef = 44;
ibrecorddef = 45;
ibfiledef = 46;
ibformaldef = 47;
ibobjectdef = 48;
ibenumdef = 49;
ibsetdef = 50;
ibprocvardef = 51;
ibfloatdef = 52;
ibclassrefdef = 53;
iblongstringdef = 54;
ibansistringdef = 55;
ibwidestringdef = 56;
ibvariantdef = 57;
{ unit flags }
uf_init = $1;
uf_finalize = $2;
uf_big_endian = $4;
uf_has_dbx = $8;
uf_has_browser = $10;
uf_in_library = $20; { is the file in another file than <ppufile>.* ? }
uf_smart_linked = $40; { the ppu can be smartlinked }
uf_static_linked = $80; { the ppu can be linked static }
uf_shared_linked = $100; { the ppu can be linked shared }
uf_local_browser = $200;
uf_no_link = $400; { unit has no .o generated, but can still have
external linking! }
uf_has_resources = $800; { unit has resource section }
type
{$ifdef m68k}
ppureal=single;
{$else}
ppureal=extended;
{$endif}
tppuerror=(ppuentrytoobig,ppuentryerror);
tppuheader=packed record { 40 bytes }
id : array[1..3] of char; { = 'PPU' }
ver : array[1..3] of char;
compiler : word;
cpu : word;
target : word;
flags : longint;
size : longint; { size of the ppufile without header }
checksum : longint; { checksum for this ppufile }
interface_checksum : longint;
future : array[0..2] of longint;
end;
tppuentry=packed record
id : byte;
nr : byte;
size : longint;
end;
pppufile=^tppufile;
tppufile=object
f : file;
mode : byte; {0 - Closed, 1 - Reading, 2 - Writing}
error : boolean;
fname : string;
fsize : longint;
header : tppuheader;
size,crc : longint;
{$ifdef Test_Double_checksum}
crcindex : longint;
crc_index : longint;
crcindex2 : longint;
crc_index2 : longint;
crc_test,crc_test2 : pcrc_array;
{$endif def Test_Double_checksum}
interface_crc : longint;
do_interface_crc : boolean;
crc_only : boolean; { used to calculate interface_crc before implementation }
do_crc,
change_endian : boolean;
buf : pchar;
bufstart,
bufsize,
bufidx : longint;
entrybufstart,
entrystart,
entryidx : longint;
entry : tppuentry;
entrytyp : byte;
closed,
tempclosed : boolean;
closepos : longint;
constructor init(fn:string);
destructor done;
procedure flush;
procedure close;
function CheckPPUId:boolean;
function GetPPUVersion:longint;
procedure NewHeader;
procedure NewEntry;
{read}
function open:boolean;
procedure reloadbuf;
procedure readdata(var b;len:longint);
procedure skipdata(len:longint);
function readentry:byte;
function EndOfEntry:boolean;
procedure getdatabuf(var b;len:longint;var result:longint);
procedure getdata(var b;len:longint);
function getbyte:byte;
function getword:word;
function getlongint:longint;
function getreal:ppureal;
function getstring:string;
procedure getnormalset(var b);
procedure getsmallset(var b);
function skipuntilentry(untilb:byte):boolean;
{write}
function create:boolean;
procedure writeheader;
procedure writebuf;
procedure writedata(var b;len:longint);
procedure writeentry(ibnr:byte);
procedure putdata(var b;len:longint);
procedure putbyte(b:byte);
procedure putword(w:word);
procedure putlongint(l:longint);
procedure putreal(d:ppureal);
procedure putstring(s:string);
procedure putnormalset(var b);
procedure putsmallset(var b);
procedure tempclose;
function tempopen:boolean;
end;
implementation
uses
{$ifdef Test_Double_checksum}
comphook,
{$endif def Test_Double_checksum}
crc;
{*****************************************************************************
TPPUFile
*****************************************************************************}
constructor tppufile.init(fn:string);
begin
fname:=fn;
change_endian:=false;
crc_only:=false;
Mode:=0;
NewHeader;
Error:=false;
closed:=true;
tempclosed:=false;
getmem(buf,ppubufsize);
end;
destructor tppufile.done;
begin
close;
if assigned(buf) then
freemem(buf,ppubufsize);
end;
procedure tppufile.flush;
begin
if Mode=2 then
writebuf;
end;
procedure tppufile.close;
begin
if Mode<>0 then
begin
Flush;
{$I-}
system.close(f);
{$I+}
if ioresult<>0 then;
Mode:=0;
closed:=true;
end;
end;
function tppufile.CheckPPUId:boolean;
begin
CheckPPUId:=((Header.Id[1]='P') and (Header.Id[2]='P') and (Header.Id[3]='U'));
end;
function tppufile.GetPPUVersion:longint;
var
l : longint;
code : integer;
begin
Val(header.ver[1]+header.ver[2]+header.ver[3],l,code);
if code=0 then
GetPPUVersion:=l
else
GetPPUVersion:=0;
end;
procedure tppufile.NewHeader;
var
s : string;
begin
fillchar(header,sizeof(tppuheader),0);
str(currentppuversion,s);
while length(s)<3 do
s:='0'+s;
with header do
begin
Id[1]:='P';
Id[2]:='P';
Id[3]:='U';
Ver[1]:=s[1];
Ver[2]:=s[2];
Ver[3]:=s[3];
end;
end;
{*****************************************************************************
TPPUFile Reading
*****************************************************************************}
function tppufile.open:boolean;
var
ofmode : byte;
i : longint;
begin
open:=false;
assign(f,fname);
ofmode:=filemode;
filemode:=$0;
{$I-}
reset(f,1);
{$I+}
filemode:=ofmode;
if ioresult<>0 then
exit;
closed:=false;
{read ppuheader}
fsize:=filesize(f);
if fsize<sizeof(tppuheader) then
exit;
blockread(f,header,sizeof(tppuheader),i);
{reset buffer}
bufstart:=i;
bufsize:=0;
bufidx:=0;
Mode:=1;
FillChar(entry,sizeof(tppuentry),0);
entryidx:=0;
entrystart:=0;
entrybufstart:=0;
Error:=false;
open:=true;
end;
procedure tppufile.reloadbuf;
begin
inc(bufstart,bufsize);
blockread(f,buf^,ppubufsize,bufsize);
bufidx:=0;
end;
procedure tppufile.readdata(var b;len:longint);
var
p : pchar;
left,
idx : longint;
begin
p:=pchar(@b);
idx:=0;
while len>0 do
begin
left:=bufsize-bufidx;
if len>left then
begin
move(buf[bufidx],p[idx],left);
dec(len,left);
inc(idx,left);
reloadbuf;
if bufsize=0 then
exit;
end
else
begin
move(buf[bufidx],p[idx],len);
inc(bufidx,len);
exit;
end;
end;
end;
procedure tppufile.skipdata(len:longint);
var
left : longint;
begin
while len>0 do
begin
left:=bufsize-bufidx;
if len>left then
begin
dec(len,left);
reloadbuf;
if bufsize=0 then
exit;
end
else
begin
inc(bufidx,len);
exit;
end;
end;
end;
function tppufile.readentry:byte;
begin
if entryidx<entry.size then
skipdata(entry.size-entryidx);
readdata(entry,sizeof(tppuentry));
entrystart:=bufstart+bufidx;
entryidx:=0;
if not(entry.id in [mainentryid,subentryid]) then
begin
readentry:=iberror;
error:=true;
exit;
end;
readentry:=entry.nr;
end;
function tppufile.endofentry:boolean;
begin
endofentry:=(entryidx>=entry.size);
end;
procedure tppufile.getdatabuf(var b;len:longint;var result:longint);
begin
if entryidx+len>entry.size then
result:=entry.size-entryidx
else
result:=len;
readdata(b,result);
inc(entryidx,result);
end;
procedure tppufile.getdata(var b;len:longint);
begin
if entryidx+len>entry.size then
begin
error:=true;
exit;
end;
readdata(b,len);
inc(entryidx,len);
end;
function tppufile.getbyte:byte;
var
b : byte;
begin
if entryidx+1>entry.size then
begin
error:=true;
getbyte:=0;
exit;
end;
readdata(b,1);
getbyte:=b;
inc(entryidx);
end;
function tppufile.getword:word;
type
pword = ^word;
var
w : word;
begin
if entryidx+2>entry.size then
begin
error:=true;
getword:=0;
exit;
end;
readdata(w,2);
if change_endian then
getword:=swap(w)
else
getword:=w;
inc(entryidx,2);
end;
function tppufile.getlongint:longint;
type
plongint = ^longint;
var
l : longint;
begin
if entryidx+4>entry.size then
begin
error:=true;
getlongint:=0;
exit;
end;
readdata(l,4);
if change_endian then
{ someone added swap(l : longint) in system unit
this broke the following code !! }
getlongint:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16)
else
getlongint:=l;
inc(entryidx,4);
end;
function tppufile.getreal:ppureal;
type
pppureal = ^ppureal;
var
d : ppureal;
begin
if entryidx+sizeof(ppureal)>entry.size then
begin
error:=true;
getreal:=0;
exit;
end;
readdata(d,sizeof(ppureal));
getreal:=d;
inc(entryidx,sizeof(ppureal));
end;
function tppufile.getstring:string;
var
s : string;
begin
s[0]:=chr(getbyte);
if entryidx+length(s)>entry.size then
begin
error:=true;
exit;
end;
ReadData(s[1],length(s));
getstring:=s;
inc(entryidx,length(s));
end;
procedure tppufile.getsmallset(var b);
begin
getdata(b,4);
end;
procedure tppufile.getnormalset(var b);
begin
getdata(b,32);
end;
function tppufile.skipuntilentry(untilb:byte):boolean;
var
b : byte;
begin
repeat
b:=readentry;
until (b in [ibend,iberror]) or ((b=untilb) and (entry.id=mainentryid));
skipuntilentry:=(b=untilb);
end;
{*****************************************************************************
TPPUFile Writing
*****************************************************************************}
function tppufile.create:boolean;
begin
create:=false;
{$ifdef INTFPPU}
if crc_only then
begin
fname:=fname+'.intf';
crc_only:=false;
end;
{$endif}
if not crc_only then
begin
assign(f,fname);
{$I-}
rewrite(f,1);
{$I+}
if ioresult<>0 then
exit;
Mode:=2;
{write header for sure}
blockwrite(f,header,sizeof(tppuheader));
end;
bufsize:=ppubufsize;
bufstart:=sizeof(tppuheader);
bufidx:=0;
{reset}
crc:=longint($ffffffff);
interface_crc:=longint($ffffffff);
do_interface_crc:=true;
Error:=false;
do_crc:=true;
size:=0;
entrytyp:=mainentryid;
{start}
NewEntry;
create:=true;
end;
procedure tppufile.writeheader;
var
opos : longint;
begin
{ flush buffer }
writebuf;
{ update size (w/o header!) in the header }
header.size:=bufstart-sizeof(tppuheader);
{ write header and restore filepos after it }
opos:=filepos(f);
seek(f,0);
blockwrite(f,header,sizeof(tppuheader));
seek(f,opos);
end;
procedure tppufile.writebuf;
begin
if not crc_only then
blockwrite(f,buf^,bufidx);
inc(bufstart,bufidx);
bufidx:=0;
end;
procedure tppufile.writedata(var b;len:longint);
var
p : pchar;
left,
idx : longint;
begin
if crc_only then
exit;
p:=pchar(@b);
idx:=0;
while len>0 do
begin
left:=bufsize-bufidx;
if len>left then
begin
move(p[idx],buf[bufidx],left);
dec(len,left);
inc(idx,left);
inc(bufidx,left);
writebuf;
end
else
begin
move(p[idx],buf[bufidx],len);
inc(bufidx,len);
exit;
end;
end;
end;
procedure tppufile.NewEntry;
begin
with entry do
begin
id:=entrytyp;
nr:=ibend;
size:=0;
end;
{Reset Entry State}
entryidx:=0;
entrybufstart:=bufstart;
entrystart:=bufstart+bufidx;
{Alloc in buffer}
writedata(entry,sizeof(tppuentry));
end;
procedure tppufile.writeentry(ibnr:byte);
var
opos : longint;
begin
{create entry}
entry.id:=entrytyp;
entry.nr:=ibnr;
entry.size:=entryidx;
{it's already been sent to disk ?}
if entrybufstart<>bufstart then
begin
if not crc_only then
begin
{flush to be sure}
WriteBuf;
{write entry}
opos:=filepos(f);
seek(f,entrystart);
blockwrite(f,entry,sizeof(tppuentry));
seek(f,opos);
end;
entrybufstart:=bufstart;
end
else
move(entry,buf[entrystart-bufstart],sizeof(entry));
{Add New Entry, which is ibend by default}
entrystart:=bufstart+bufidx; {next entry position}
NewEntry;
end;
procedure tppufile.putdata(var b;len:longint);
begin
if do_crc then
begin
crc:=UpdateCrc32(crc,b,len);
{$ifdef Test_Double_checksum}
if crc_only then
begin
crc_test2^[crc_index2]:=crc;
{$ifdef Test_Double_checksum_write}
Writeln(CRCFile,crc);
{$endif Test_Double_checksum_write}
if crc_index2<crc_array_size then
inc(crc_index2);
end
else
begin
if (crcindex2<crc_array_size) and (crcindex2<crc_index2) and
(crc_test2^[crcindex2]<>crc) then
Do_comment(V_Warning,'impl CRC changed');
{$ifdef Test_Double_checksum_write}
Writeln(CRCFile,crc);
{$endif Test_Double_checksum_write}
inc(crcindex2);
end;
{$endif def Test_Double_checksum}
if do_interface_crc then
begin
interface_crc:=UpdateCrc32(interface_crc,b,len);
{$ifdef Test_Double_checksum}
if crc_only then
begin
crc_test^[crc_index]:=interface_crc;
{$ifdef Test_Double_checksum_write}
Writeln(CRCFile,interface_crc);
{$endif Test_Double_checksum_write}
if crc_index<crc_array_size then
inc(crc_index);
end
else
begin
if (crcindex<crc_array_size) and (crcindex<crc_index) and
(crc_test^[crcindex]<>interface_crc) then
Do_comment(V_Warning,'CRC changed');
{$ifdef Test_Double_checksum_write}
Writeln(CRCFile,interface_crc);
{$endif Test_Double_checksum_write}
inc(crcindex);
end;
{$endif def Test_Double_checksum}
end;
end;
if not crc_only then
writedata(b,len);
inc(entryidx,len);
end;
procedure tppufile.putbyte(b:byte);
begin
putdata(b,1);
{ inc(entryidx);}
end;
procedure tppufile.putword(w:word);
begin
if change_endian then
w:=swap(w);
putdata(w,2);
end;
procedure tppufile.putlongint(l:longint);
begin
if change_endian then
{ someone added swap(l : longint) in system unit
this broke the following code !! }
l:=swap(word(l shr 16)) or (longint(swap(word(l and $ffff))) shl 16);
putdata(l,4);
end;
procedure tppufile.putreal(d:ppureal);
begin
putdata(d,sizeof(ppureal));
end;
procedure tppufile.putstring(s:string);
begin
putdata(s,length(s)+1);
end;
procedure tppufile.putsmallset(var b);
begin
putdata(b,4);
end;
procedure tppufile.putnormalset(var b);
begin
putdata(b,32);
end;
procedure tppufile.tempclose;
begin
if not closed then
begin
closepos:=filepos(f);
{$I-}
system.close(f);
{$I+}
if ioresult<>0 then;
closed:=true;
tempclosed:=true;
end;
end;
function tppufile.tempopen:boolean;
var
ofm : byte;
begin
tempopen:=false;
if not closed or not tempclosed then
exit;
ofm:=filemode;
filemode:=0;
{$I-}
reset(f,1);
{$I+}
filemode:=ofm;
if ioresult<>0 then
exit;
closed:=false;
tempclosed:=false;
{ restore state }
seek(f,closepos);
tempopen:=true;
end;
end.
{
$Log$
Revision 1.3 2001-04-10 21:21:42 peter
* variantdef support
* propertysym fixed
Revision 1.7 2001/03/22 00:10:58 florian
+ basic variant type support in the compiler
Revision 1.6 2000/12/07 17:19:43 jonas
* new constant handling: from now on, hex constants >$7fffffff are
parsed as unsigned constants (otherwise, $80000000 got sign extended
and became $ffffffff80000000), all constants in the longint range
become longints, all constants >$7fffffff and <=cardinal($ffffffff)
are cardinals and the rest are int64's.
* added lots of longint typecast to prevent range check errors in the
compiler and rtl
* type casts of symbolic ordinal constants are now preserved
* fixed bug where the original resulttype wasn't restored correctly
after doing a 64bit rangecheck
Revision 1.5 2000/10/31 22:02:50 peter
* symtable splitted, no real code changes
Revision 1.4 2000/09/24 15:06:24 peter
* use defines.inc
Revision 1.3 2000/08/13 13:04:38 peter
* new ppu version
Revision 1.2 2000/07/13 11:32:45 michael
+ removed logs
}

1577
utils/ppudump.pp
View File

File diff suppressed because it is too large Load Diff

277
utils/ppufiles.pp
View File

@ -1,277 +0,0 @@
{
$Id$
Copyright (c) 1999-2000 by Peter Vreman
List files needed by PPU
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.
****************************************************************************}
Program ppufiles;
uses
dos,
ppu;
const
Version = 'Version 1.00';
Title = 'PPU-Files';
Copyright = 'Copyright (c) 1999-2000 by the Free Pascal Development Team';
PPUExt = 'ppu';
type
poutfile = ^toutfile;
toutfile = record
name : string;
next : poutfile;
end;
var
skipdup,
showstatic,
showshared,
showobjects : boolean;
OutFiles : poutfile;
{*****************************************************************************
Helpers
*****************************************************************************}
Procedure Error(const s:string;stop:boolean);
{
Write an error message to stderr
}
begin
{$ifdef FPC}
writeln(stderr,s);
{$else}
writeln(s);
{$endif}
if stop then
halt(1);
end;
Function AddExtension(Const HStr,ext:String):String;
{
Return a filename which will have extension ext added if no
extension is found
}
var
j : longint;
begin
j:=length(Hstr);
while (j>0) and (Hstr[j]<>'.') do
dec(j);
if j=0 then
AddExtension:=Hstr+'.'+Ext
else
AddExtension:=HStr;
end;
Function SplitPath(Const HStr:String):String;
var
i : longint;
begin
i:=Length(Hstr);
while (i>0) and not(Hstr[i] in ['\','/']) do
dec(i);
SplitPath:=Copy(Hstr,1,i);
end;
Procedure AddFile(const s:string);
var
p : poutfile;
begin
p:=nil;
if skipdup then
begin
p:=outfiles;
while assigned(p) do
begin
if s=p^.name then
break;
p:=p^.next;
end;
end;
if not assigned(p) then
begin
new(p);
p^.name:=s;
p^.next:=outfiles;
outfiles:=p;
end;
end;
Function DoPPU(const PPUFn:String):Boolean;
{
Convert one file (in Filename) to library format.
Return true if successful, false otherwise.
}
Var
inppu : pppufile;
b : byte;
procedure showfiles;
begin
while not inppu^.endofentry do
begin
AddFile(inppu^.getstring);
inppu^.getlongint;
end;
end;
begin
DoPPU:=false;
inppu:=new(pppufile,init(PPUFn));
if not inppu^.open then
begin
dispose(inppu,done);
Error('Error: Could not open : '+PPUFn,false);
Exit;
end;
{ Check the ppufile }
if not inppu^.CheckPPUId then
begin
dispose(inppu,done);
Error('Error: Not a PPU File : '+PPUFn,false);
Exit;
end;
if inppu^.GetPPUVersion<CurrentPPUVersion then
begin
dispose(inppu,done);
Error('Error: Wrong PPU Version : '+PPUFn,false);
Exit;
end;
{ read until the object files are found }
repeat
b:=inppu^.readentry;
case b of
ibendinterface,
ibend :
break;
iblinkunitstaticlibs :
if showstatic then
showfiles;
iblinkunitsharedlibs :
if showshared then
showfiles;
iblinkunitofiles :
if showobjects then
showfiles;
end;
until false;
dispose(inppu,done);
DoPPU:=True;
end;
var
i,parafile : longint;
dir : SearchRec;
s,InFile : String;
p : poutfile;
begin
{ defaults }
skipdup:=true;
{ options }
i:=1;
while (i<=paramcount) do
begin
s:=paramstr(i);
if s[1]<>'-' then
break;
case upcase(s[2]) of
'L' : showshared:=true;
'S' : showstatic:=true;
'O' : showobjects:=true;
'A' : skipdup:=false;
'?','H' :
begin
writeln('usage: ppufiles [options] <files>');
writeln('options:');
writeln(' -A Show all files (don''t remove duplicates)');
writeln(' -L Show only shared libraries');
writeln(' -S Show only static libraries');
writeln(' -O Show only object files');
writeln(' -H This helpscreen');
end;
end;
inc(i);
end;
{ default shows everything }
if i=1 then
begin
showshared:=true;
showstatic:=true;
showobjects:=true;
end;
{ files }
parafile:=i;
for i:=parafile to ParamCount do
begin
InFile:=AddExtension(ParamStr(i),PPUExt);
FindFirst(InFile,$20,Dir);
while (DosError=0) do
begin
DoPPU(SplitPath(InFile)+Dir.Name);
FindNext(Dir);
end;
{$ifdef fpc}
FindClose(Dir);
{$endif}
end;
{ Display the files }
while assigned(outfiles) do
begin
p:=outfiles;
write(outfiles^.name);
outfiles:=outfiles^.next;
dispose(p);
if assigned(outfiles) then
write(' ');
end;
end.
{
$Log$
Revision 1.2 2000-11-06 13:16:19 michael
+ merged fixes from Peter
Revision 1.1.2.1 2000/11/06 13:14:48 michael
+ Fixes from Peter for slashes in filenames
Revision 1.1 2000/07/13 10:16:22 michael
+ Initial import
Revision 1.4 2000/07/04 19:05:54 peter
* be optimistic: version 1.00 for some utils
Revision 1.3 2000/01/24 12:32:22 daniel
* use a linkedlist instead of ansistring
Revision 1.2 2000/01/07 16:46:04 daniel
* copyright 2000
Revision 1.1 1999/11/23 09:44:41 peter
* initial version
}

644
utils/ppumove.pp
View File

@ -1,644 +0,0 @@
{
$Id$
Copyright (c) 1999-2000 by the FPC Development Team
Add multiple FPC units into a static/shared library
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.
****************************************************************************}
{$ifndef TP}
{$H+}
{$endif}
Program ppumove;
uses
{$ifdef unix}
unix,
{$else unix}
dos,
{$endif unix}
ppu,
getopts;
const
Version = 'Version 1.00';
Title = 'PPU-Mover';
Copyright = 'Copyright (c) 1998-2000 by the Free Pascal Development Team';
ShortOpts = 'o:e:d:qhsvbw';
BufSize = 4096;
PPUExt = 'ppu';
ObjExt = 'o';
StaticLibExt ='a';
{$ifdef unix}
SharedLibExt ='so';
BatchExt ='.sh';
{$else}
SharedLibExt ='dll';
BatchExt ='.bat';
{$endif unix}
{ link options }
link_none = $0;
link_allways = $1;
link_static = $2;
link_smart = $4;
link_shared = $8;
Type
PLinkOEnt = ^TLinkOEnt;
TLinkOEnt = record
Name : string;
Next : PLinkOEnt;
end;
Var
ArBin,LDBin,StripBin,
OutputFile,
OutputFileForLink, { the name of the output file needed when linking }
DestPath,
PPLExt,
LibExt : string;
Batch,
Quiet,
MakeStatic : boolean;
Buffer : Pointer;
ObjFiles : PLinkOEnt;
BatchFile : Text;
{*****************************************************************************
Helpers
*****************************************************************************}
Procedure Error(const s:string;stop:boolean);
{
Write an error message to stderr
}
begin
{$ifdef FPC}
writeln(stderr,s);
{$else}
writeln(s);
{$endif}
if stop then
halt(1);
end;
function Shell(const s:string):longint;
{
Run a shell commnad and return the exitcode
}
begin
if Batch then
begin
Writeln(BatchFile,s);
Shell:=0;
exit;
end;
{$ifdef unix}
Shell:=unix.shell(s);
{$else}
exec(getenv('COMSPEC'),'/C '+s);
Shell:=DosExitCode;
{$endif}
end;
Function FileExists (Const F : String) : Boolean;
{
Returns True if the file exists, False if not.
}
Var
{$ifdef unix}
info : Stat;
{$else}
info : searchrec;
{$endif}
begin
{$ifdef unix}
FileExists:=FStat (F,Info);
{$else}
FindFirst (F,anyfile,Info);
FileExists:=DosError=0;
{$endif}
end;
Function AddExtension(Const HStr,ext:String):String;
{
Return a filename which will have extension ext added if no
extension is found
}
var
j : longint;
begin
j:=length(Hstr);
while (j>0) and (Hstr[j]<>'.') do
dec(j);
if j=0 then
AddExtension:=Hstr+'.'+Ext
else
AddExtension:=HStr;
end;
Function ForceExtension(Const HStr,ext:String):String;
{
Return a filename which certainly has the extension ext
}
var
j : longint;
begin
j:=length(Hstr);
while (j>0) and (Hstr[j]<>'.') do
dec(j);
if j=0 then
j:=255;
ForceExtension:=Copy(Hstr,1,j-1)+'.'+Ext;
end;
Procedure AddToLinkFiles(const S : String);
{
Adds a filename to a list of object files to link to.
No duplicates allowed.
}
Var
P : PLinKOEnt;
begin
P:=ObjFiles;
{ Don't add files twice }
While (P<>nil) and (p^.name<>s) do
p:=p^.next;
if p=nil then
begin
new(p);
p^.next:=ObjFiles;
p^.name:=s;
ObjFiles:=P;
end;
end;
Function ExtractLib(const libfn:string):string;
{
Extract a static library libfn and return the files with a
wildcard
}
var
n : namestr;
d : dirstr;
e : extstr;
begin
{ create the temp dir first }
fsplit(libfn,d,n,e);
{$I-}
mkdir(n+'.sl');
{$I+}
if ioresult<>0 then;
{ Extract }
if Shell(arbin+' x '+libfn)<>0 then
Error('Fatal: Error running '+arbin,true);
{ Remove the lib file, it's extracted so it can be created with ease }
if PPLExt=PPUExt then
Shell('rm '+libfn);
{$ifdef unix}
ExtractLib:=n+'.sl/*';
{$else}
ExtractLib:=n+'.sl\*';
{$endif}
end;
Function DoPPU(const PPUFn,PPLFn:String):Boolean;
{
Convert one file (in Filename) to library format.
Return true if successful, false otherwise.
}
Var
inppu,
outppu : pppufile;
b,
untilb : byte;
l,m : longint;
f : file;
s : string;
begin
DoPPU:=false;
If Not Quiet then
Write ('Processing ',PPUFn,'...');
inppu:=new(pppufile,init(PPUFn));
if not inppu^.open then
begin
dispose(inppu,done);
Error('Error: Could not open : '+PPUFn,false);
Exit;
end;
{ Check the ppufile }
if not inppu^.CheckPPUId then
begin
dispose(inppu,done);
Error('Error: Not a PPU File : '+PPUFn,false);
Exit;
end;
if inppu^.GetPPUVersion<CurrentPPUVersion then
begin
dispose(inppu,done);
Error('Error: Wrong PPU Version : '+PPUFn,false);
Exit;
end;
{ No .o file generated for this ppu, just skip }
if (inppu^.header.flags and uf_no_link)<>0 then
begin
dispose(inppu,done);
If Not Quiet then
Writeln (' No files.');
DoPPU:=true;
Exit;
end;
{ Already a lib? }
if (inppu^.header.flags and uf_in_library)<>0 then
begin
dispose(inppu,done);
Error('Error: PPU is already in a library : '+PPUFn,false);
Exit;
end;
{ We need a static linked unit }
if (inppu^.header.flags and uf_static_linked)=0 then
begin
dispose(inppu,done);
Error('Error: PPU is not static linked : '+PPUFn,false);
Exit;
end;
{ Create the new ppu }
if PPUFn=PPLFn then
outppu:=new(pppufile,init('ppumove.$$$'))
else
outppu:=new(pppufile,init(PPLFn));
outppu^.create;
{ Create new header, with the new flags }
outppu^.header:=inppu^.header;
outppu^.header.flags:=outppu^.header.flags or uf_in_library;
if MakeStatic then
outppu^.header.flags:=outppu^.header.flags or uf_static_linked
else
outppu^.header.flags:=outppu^.header.flags or uf_shared_linked;
{ read until the object files are found }
untilb:=iblinkunitofiles;
repeat
b:=inppu^.readentry;
if b in [ibendinterface,ibend] then
begin
dispose(inppu,done);
dispose(outppu,done);
Error('Error: No files to be linked found : '+PPUFn,false);
Exit;
end;
if b<>untilb then
begin
repeat
inppu^.getdatabuf(buffer^,bufsize,l);
outppu^.putdata(buffer^,l);
until l<bufsize;
outppu^.writeentry(b);
end;
until (b=untilb);
{ we have now reached the section for the files which need to be added,
now add them to the list }
case b of
iblinkunitofiles :
begin
{ add all o files, and save the entry when not creating a static
library to keep staticlinking possible }
while not inppu^.endofentry do
begin
s:=inppu^.getstring;
m:=inppu^.getlongint;
if not MakeStatic then
begin
outppu^.putstring(s);
outppu^.putlongint(m);
end;
AddToLinkFiles(s);
end;
if not MakeStatic then
outppu^.writeentry(b);
end;
{ iblinkunitstaticlibs :
begin
AddToLinkFiles(ExtractLib(inppu^.getstring));
if not inppu^.endofentry then
begin
repeat
inppu^.getdatabuf(buffer^,bufsize,l);
outppu^.putdata(buffer^,l);
until l<bufsize;
outppu^.writeentry(b);
end;
end; }
end;
{ just add a new entry with the new lib }
if MakeStatic then
begin
outppu^.putstring(outputfileforlink);
outppu^.putlongint(link_static);
outppu^.writeentry(iblinkunitstaticlibs)
end
else
begin
outppu^.putstring(outputfileforlink);
outppu^.putlongint(link_shared);
outppu^.writeentry(iblinkunitsharedlibs);
end;
{ read all entries until the end and write them also to the new ppu }
repeat
b:=inppu^.readentry;
{ don't write ibend, that's written automaticly }
if b<>ibend then
begin
repeat
inppu^.getdatabuf(buffer^,bufsize,l);
outppu^.putdata(buffer^,l);
until l<bufsize;
outppu^.writeentry(b);
end;
until b=ibend;
{ write the last stuff and close }
outppu^.flush;
outppu^.writeheader;
dispose(outppu,done);
dispose(inppu,done);
{ rename }
if PPUFn=PPLFn then
begin
{$I-}
assign(f,PPUFn);
erase(f);
assign(f,'ppumove.$$$');
rename(f,PPUFn);
{$I+}
if ioresult<>0 then;
end;
{ the end }
If Not Quiet then
Writeln (' Done.');
DoPPU:=True;
end;
Function DoFile(const FileName:String):Boolean;
{
Process a file, mainly here for wildcard support under Dos
}
{$ifndef unix}
var
dir : searchrec;
{$endif}
begin
{$ifdef unix}
DoFile:=DoPPU(FileName,ForceExtension(FileName,PPLExt));
{$else}
DoFile:=false;
findfirst(filename,$20,dir);
while doserror=0 do
begin
if not DoPPU(Dir.Name,ForceExtension(Dir.Name,PPLExt)) then
exit;
findnext(dir);
end;
findclose(dir);
DoFile:=true;
{$endif}
end;
Procedure DoLink;
{
Link the object files together to form a (shared) library, the only
problem here is the 255 char limit of Names
}
Var
Names : String;
f : file;
Err : boolean;
P : PLinkOEnt;
begin
if not Quiet then
Write ('Linking ');
P:=ObjFiles;
names:='';
While p<>nil do
begin
if Names<>'' then
Names:=Names+' '+P^.name
else
Names:=p^.Name;
p:=p^.next;
end;
if Names='' then
begin
If not Quiet then
Writeln('Error: no files found to be linked');
exit;
end;
If not Quiet then
WriteLn(names);
{ Run ar or ld to create the lib }
If MakeStatic then
Err:=Shell(arbin+' rs '+outputfile+' '+names)<>0
else
begin
Err:=Shell(ldbin+' -shared -o '+OutputFile+' '+names)<>0;
if not Err then
Shell(stripbin+' --strip-unneeded '+OutputFile);
end;
If Err then
Error('Fatal: Library building stage failed.',true);
{ fix permission to 644, so it's not 755 }
{$ifdef unix}
ChMod(OutputFile,420);
{$endif}
{ Rename to the destpath }
if DestPath<>'' then
begin
Assign(F, OutputFile);
Rename(F,DestPath+'/'+OutputFile);
end;
end;
Procedure usage;
{
Print usage and exit.
}
begin
Writeln(paramstr(0),': [-qhwvbs] [-e ext] [-o name] [-d path] file [file ...]');
Halt(0);
end;
Procedure processopts;
{
Process command line opions, and checks if command line options OK.
}
var
C : char;
begin
if paramcount=0 then
usage;
{ Reset }
ObjFiles:=Nil;
Quiet:=False;
Batch:=False;
OutputFile:='';
PPLExt:='ppu';
ArBin:='ar';
LdBin:='ld';
StripBin:='strip';
repeat
c:=Getopt (ShortOpts);
Case C of
EndOfOptions : break;
's' : MakeStatic:=True;
'o' : OutputFile:=OptArg;
'd' : DestPath:=OptArg;
'e' : PPLext:=OptArg;
'q' : Quiet:=True;
'w' : begin
ArBin:='arw';
LdBin:='ldw';
end;
'b' : Batch:=true;
'?' : Usage;
'h' : Usage;
end;
until false;
{ Test filenames on the commandline }
if (OptInd>Paramcount) then
Error('Error: no input files',true);
if (OptInd<ParamCount) and (OutputFile='') then
Error('Error: when moving multiple units, specify an output name.',true);
{ alloc a buffer }
GetMem (Buffer,Bufsize);
If Buffer=Nil then
Error('Error: could not allocate memory for buffer.',true);
end;
var
i : longint;
begin
ProcessOpts;
{ Write Header }
if not Quiet then
begin
Writeln(Title+' '+Version);
Writeln(Copyright);
Writeln;
end;
{ Check if shared is allowed }
{$ifndef unix}
if arbin<>'arw' then
begin
Writeln('Warning: shared library not supported for Go32, switching to static library');
MakeStatic:=true;
end;
{$endif}
{ fix the libext and outputfilename }
if Makestatic then
LibExt:=StaticLibExt
else
LibExt:=SharedLibExt;
if OutputFile='' then
OutPutFile:=Paramstr(OptInd);
{ fix filename }
{$ifdef unix}
if Copy(OutputFile,1,3)<>'lib' then
OutputFile:='lib'+OutputFile;
{ For unix skip replacing the extension if a full .so.X.X if specified }
i:=pos('.so.',Outputfile);
if i<>0 then
OutputFileForLink:=Copy(Outputfile,4,i-4)
else
begin
OutputFile:=ForceExtension(OutputFile,LibExt);
OutputFileForLink:=Copy(Outputfile,4,length(Outputfile)-length(LibExt)-4);
end;
{$else}
OutputFile:=ForceExtension(OutputFile,LibExt);
OutputFileForLink:=OutputFile;
{$endif}
{ Open BatchFile }
if Batch then
begin
Assign(BatchFile,'pmove'+BatchExt);
Rewrite(BatchFile);
end;
{ Process Files }
i:=OptInd;
While (i<=ParamCount) and Dofile(AddExtension(Paramstr(i),PPUExt)) do
Inc(i);
{ Do Linking stage }
DoLink;
{ Close BatchFile }
if Batch then
begin
if Not Quiet then
Writeln('Writing pmove'+BatchExt);
Close(BatchFile);
{$ifdef unix}
ChMod('pmove'+BatchExt,493);
{$endif}
end;
{ The End }
if Not Quiet then
Writeln('Done.');
end.
{
$Log$
Revision 1.2 2001-01-29 21:48:26 peter
* linux -> unix
Revision 1.1 2000/07/13 10:16:22 michael
+ Initial import
Revision 1.11 2000/07/04 19:05:54 peter
* be optimistic: version 1.00 for some utils
Revision 1.10 2000/05/17 18:30:57 peter
* libname fixes for unix
Revision 1.9 2000/02/09 16:44:15 peter
* log truncated
Revision 1.8 2000/01/07 16:46:04 daniel
* copyright 2000
Revision 1.7 1999/11/25 00:00:39 peter
* strip created .so file with strip --strip-unneeded
Revision 1.6 1999/11/23 09:44:15 peter
* updated
Revision 1.5 1999/07/29 01:40:21 peter
* fsplit var type fixes
Revision 1.4 1999/07/28 16:53:58 peter
* updated for new linking, but still doesn't work because ld-unix.so.2
requires some more crt*.o files
}