mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-16 00:59:30 +02:00
755 lines
14 KiB
ObjectPascal
755 lines
14 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (c) 1993-98 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.
|
|
|
|
****************************************************************************
|
|
}
|
|
{$ifdef TP}
|
|
{$N+,E+}
|
|
{$endif}
|
|
unit ppu;
|
|
interface
|
|
|
|
const
|
|
{ buffer sizes }
|
|
maxentrysize = 1024;
|
|
{$ifdef TP}
|
|
ppubufsize = 1024;
|
|
{$else}
|
|
ppubufsize = 16384;
|
|
{$endif}
|
|
|
|
{ppu entries}
|
|
{special}
|
|
iberror = 0;
|
|
ibenddefs = 250;
|
|
ibendsyms = 251;
|
|
ibendinterface = 252;
|
|
ibendimplementation = 253;
|
|
ibentry = 254;
|
|
ibend = 255;
|
|
{general}
|
|
ibmodulename = 1;
|
|
ibsourcefiles = 2;
|
|
ibloadunit_int = 3;
|
|
ibloadunit_imp = 4;
|
|
ibinitunit = 5;
|
|
iblinkofiles = 6;
|
|
iblinksharedlibs = 7;
|
|
iblinkstaticlibs = 8;
|
|
ibdbxcount = 9;
|
|
ibref = 10;
|
|
{syms}
|
|
ibtypesym = 20;
|
|
ibprocsym = 21;
|
|
ibvarsym = 22;
|
|
ibconstsym = 23;
|
|
ibenumsym = 24;
|
|
ibtypedconstsym = 25;
|
|
ibabsolutesym = 26;
|
|
ibpropertysym = 27;
|
|
{defenitions}
|
|
iborddef = 40;
|
|
ibpointerdef = 41;
|
|
ibarraydef = 42;
|
|
ibprocdef = 43;
|
|
ibstringdef = 44;
|
|
ibrecorddef = 45;
|
|
ibfiledef = 46;
|
|
ibformaldef = 47;
|
|
ibobjectdef = 48;
|
|
ibenumdef = 49;
|
|
ibsetdef = 50;
|
|
ibprocvardef = 51;
|
|
ibfloatdef = 52;
|
|
ibextsymref = 53;
|
|
ibextdefref = 54;
|
|
ibclassrefdef = 55;
|
|
iblongstringdef = 56;
|
|
ibansistringdef = 57;
|
|
ibwidestringdef = 58;
|
|
|
|
{ unit flags }
|
|
uf_init = $1;
|
|
uf_uses_dbx = $2;
|
|
uf_uses_browser = $4;
|
|
uf_big_endian = $8;
|
|
uf_in_library = $10;
|
|
uf_shared_library = $20;
|
|
uf_smartlink = $40;
|
|
|
|
|
|
type
|
|
tppuerror=(ppuentrytoobig,ppuentryerror);
|
|
|
|
tppuheader=packed record
|
|
id : array[1..3] of char; { = 'PPU' }
|
|
ver : array[1..3] of char;
|
|
compiler : word;
|
|
target : word;
|
|
flags : longint;
|
|
size : longint; { size of the ppufile without header }
|
|
checksum : longint; { checksum for this ppufile }
|
|
end;
|
|
|
|
tppuentry=packed record
|
|
id : byte;
|
|
nr : byte;
|
|
size : word;
|
|
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;
|
|
do_crc,
|
|
change_endian : boolean;
|
|
|
|
buf : pchar;
|
|
bufstart,
|
|
bufsize,
|
|
bufidx : longint;
|
|
entry : tppuentry;
|
|
entrybufstart,
|
|
entrystart,
|
|
entryidx : 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 getdata(var b;len:longint);
|
|
function getbyte:byte;
|
|
function getword:word;
|
|
function getlongint:longint;
|
|
function getdouble:double;
|
|
function getstring:string;
|
|
{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 putdouble(d:double);
|
|
procedure putstring(s:string);
|
|
end;
|
|
|
|
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 $edb88320
|
|
else
|
|
crc:=crc shr 1;
|
|
Crc32Tbl[i]:=crc;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
{CRC 32}
|
|
Function Crc32(Const HStr:String):longint;
|
|
var
|
|
i,InitCrc : longint;
|
|
begin
|
|
if Crc32Tbl[1]=0 then
|
|
MakeCrc32Tbl;
|
|
InitCrc:=$ffffffff;
|
|
for i:=1to 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:=1to 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;
|
|
|
|
|
|
{*****************************************************************************
|
|
TPPUFile
|
|
*****************************************************************************}
|
|
|
|
constructor tppufile.init(fn:string);
|
|
begin
|
|
fname:=fn;
|
|
change_endian:=false;
|
|
Mode:=0;
|
|
NewHeader;
|
|
Error:=false;
|
|
getmem(buf,ppubufsize);
|
|
end;
|
|
|
|
|
|
destructor tppufile.done;
|
|
begin
|
|
close;
|
|
freemem(buf,ppubufsize);
|
|
end;
|
|
|
|
|
|
procedure tppufile.flush;
|
|
begin
|
|
if Mode=2 then
|
|
writebuf;
|
|
end;
|
|
|
|
|
|
procedure tppufile.close;
|
|
var
|
|
i : word;
|
|
begin
|
|
if Mode<>0 then
|
|
begin
|
|
Flush;
|
|
{$I-}
|
|
system.close(f);
|
|
{$I+}
|
|
i:=ioresult;
|
|
Mode:=0;
|
|
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 : word;
|
|
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;
|
|
begin
|
|
fillchar(header,sizeof(tppuheader),0);
|
|
with header do
|
|
begin
|
|
Id[1]:='P';
|
|
Id[2]:='P';
|
|
Id[3]:='U';
|
|
Ver[1]:='0';
|
|
Ver[2]:='1';
|
|
Ver[3]:='5';
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TPPUFile Reading
|
|
*****************************************************************************}
|
|
|
|
function tppufile.open:boolean;
|
|
var
|
|
ofmode : byte;
|
|
i : word;
|
|
begin
|
|
open:=false;
|
|
assign(f,fname);
|
|
ofmode:=filemode;
|
|
filemode:=$0;
|
|
{$I-}
|
|
reset(f,1);
|
|
{$I+}
|
|
filemode:=ofmode;
|
|
if ioresult<>0 then
|
|
exit;
|
|
{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);
|
|
Error:=false;
|
|
open:=true;
|
|
end;
|
|
|
|
|
|
procedure tppufile.reloadbuf;
|
|
{$ifdef TP}
|
|
var
|
|
i : word;
|
|
{$endif}
|
|
begin
|
|
inc(bufstart,bufsize);
|
|
{$ifdef TP}
|
|
blockread(f,buf^,ppubufsize,i);
|
|
bufsize:=i;
|
|
{$else}
|
|
blockread(f,buf^,ppubufsize,bufsize);
|
|
{$endif}
|
|
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));
|
|
entryidx:=0;
|
|
if entry.id<>ibentry then
|
|
begin
|
|
readentry:=iberror;
|
|
error:=true;
|
|
exit;
|
|
end;
|
|
readentry:=entry.nr;
|
|
end;
|
|
|
|
|
|
function tppufile.endofentry:boolean;
|
|
begin
|
|
endofentry:=(entryidx>=entry.size);
|
|
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;
|
|
exit;
|
|
end;
|
|
{ if bufidx+1>bufsize then
|
|
getbyte:=ord(buf[bufidx]);
|
|
inc(bufidx);}
|
|
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;
|
|
exit;
|
|
end;
|
|
{ getword:=pword(@entrybuf[entrybufidx])^;}
|
|
readdata(w,2);
|
|
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;
|
|
exit;
|
|
end;
|
|
readdata(l,4);
|
|
getlongint:=l;
|
|
{
|
|
getlongint:=plongint(@entrybuf[entrybufidx])^;}
|
|
inc(entryidx,4);
|
|
end;
|
|
|
|
|
|
function tppufile.getdouble:double;
|
|
type
|
|
pdouble = ^double;
|
|
var
|
|
d : double;
|
|
begin
|
|
if entryidx+sizeof(double)>entry.size then
|
|
begin
|
|
error:=true;
|
|
exit;
|
|
end;
|
|
readdata(d,sizeof(double));
|
|
getdouble:=d;
|
|
{
|
|
getlongint:=plongint(@entrybuf[entrybufidx])^;}
|
|
inc(entryidx,sizeof(double));
|
|
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;
|
|
{ move(entrybuf[entrybufidx],s[1],length(s));}
|
|
inc(entryidx,length(s));
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TPPUFile Writing
|
|
*****************************************************************************}
|
|
|
|
function tppufile.create:boolean;
|
|
begin
|
|
create:=false;
|
|
assign(f,fname);
|
|
{$I-}
|
|
rewrite(f,1);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
exit;
|
|
Mode:=2;
|
|
{write header for sure}
|
|
blockwrite(f,header,sizeof(tppuheader));
|
|
bufsize:=ppubufsize;
|
|
bufstart:=sizeof(tppuheader);
|
|
bufidx:=0;
|
|
{reset}
|
|
crc:=$ffffffff;
|
|
Error:=false;
|
|
do_crc:=true;
|
|
size:=0;
|
|
{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 do_crc then
|
|
UpdateCrc32(crc,buf,bufidx);
|
|
blockwrite(f,buf^,bufidx);
|
|
inc(bufstart,bufidx);
|
|
bufidx:=0;
|
|
end;
|
|
|
|
|
|
procedure tppufile.writedata(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(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:=ibentry;
|
|
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:=ibentry;
|
|
entry.nr:=ibnr;
|
|
entry.size:=entryidx;
|
|
{it's already been sent to disk ?}
|
|
if entrybufstart<>bufstart then
|
|
begin
|
|
{flush when the entry is partly in the new buffer}
|
|
if entrybufstart+sizeof(entry)>bufstart then
|
|
WriteBuf;
|
|
{write entry}
|
|
opos:=filepos(f);
|
|
seek(f,entrystart);
|
|
blockwrite(f,entry,sizeof(tppuentry));
|
|
seek(f,opos);
|
|
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
|
|
writedata(b,len);
|
|
inc(entryidx,len);
|
|
end;
|
|
|
|
|
|
|
|
procedure tppufile.putbyte(b:byte);
|
|
begin
|
|
writedata(b,1);
|
|
{
|
|
entrybuf[entrybufidx]:=chr(b);}
|
|
inc(entryidx);
|
|
end;
|
|
|
|
|
|
procedure tppufile.putword(w:word);
|
|
type
|
|
pword = ^word;
|
|
begin
|
|
if change_endian then
|
|
w:=swap(w);
|
|
{ pword(@entrybuf[entrybufidx])^:=w;}
|
|
writedata(w,2);
|
|
inc(entryidx,2);
|
|
end;
|
|
|
|
|
|
procedure tppufile.putlongint(l:longint);
|
|
type
|
|
plongint = ^longint;
|
|
begin
|
|
{ plongint(@entrybuf[entrybufidx])^:=l;}
|
|
if change_endian then
|
|
l:=swap(l shr 16) or (longint(swap(l and $ffff)) shl 16);
|
|
writedata(l,4);
|
|
inc(entryidx,4);
|
|
end;
|
|
|
|
|
|
procedure tppufile.putdouble(d:double);
|
|
type
|
|
pdouble = ^double;
|
|
begin
|
|
{ plongint(@entrybuf[entrybufidx])^:=l;}
|
|
writedata(d,sizeof(double));
|
|
inc(entryidx,sizeof(double));
|
|
end;
|
|
|
|
procedure tppufile.putstring(s:string);
|
|
begin
|
|
writedata(s,length(s)+1);
|
|
{ move(s,entrybuf[entrybufidx],length(s)+1);}
|
|
inc(entryidx,length(s)+1);
|
|
end;
|
|
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.3 1998-05-28 14:40:26 peter
|
|
* fixes for newppu, remake3 works now with it
|
|
|
|
Revision 1.2 1998/05/27 19:45:08 peter
|
|
* symtable.pas splitted into includefiles
|
|
* symtable adapted for $ifdef NEWPPU
|
|
|
|
Revision 1.1 1998/05/12 10:56:07 peter
|
|
+ the ppufile object unit
|
|
|
|
} |