123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080 |
- {
- $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
- {$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}
- {$ifdef ORDERSOURCES}
- CurrentPPUVersion=101;
- {$else ORDERSOURCES}
- CurrentPPUVersion=100;
- {$endif ORDERSOURCES}
- {$else newcg}
- {$ifdef ORDERSOURCES}
- CurrentPPUVersion=18;
- {$else ORDERSOURCES}
- CurrentPPUVersion=17;
- {$endif ORDERSOURCES}
- {$endif newcg}
- { buffer sizes }
- maxentrysize = 1024;
- {$ifdef TP}
- ppubufsize = 1024;
- {$else}
- ppubufsize = 16384;
- {$endif}
- {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;
- { 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
- {$ifdef Test_Double_checksum}
- uses
- comphook;
- {$endif def Test_Double_checksum}
- {*****************************************************************************
- Crc 32
- *****************************************************************************}
- var
- {$ifdef Delphi}
- Crc32Tbl : array[0..255] of longword;
- {$else Delphi}
- Crc32Tbl : array[0..255] of longint;
- {$endif Delphi}
- procedure MakeCRC32Tbl;
- var
- {$ifdef Delphi}
- crc : longword;
- {$else Delphi}
- crc : longint;
- {$endif Delphi}
- 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;
- {$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:=$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;
- {$ifdef Range_check_on}
- {$R+}
- {$undef Range_check_on}
- {$endif Range_check_on}
- {*****************************************************************************
- 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;
- var
- i : word;
- begin
- if Mode<>0 then
- begin
- Flush;
- {$I-}
- system.close(f);
- {$I+}
- i:=ioresult;
- 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;
- {$ifdef delphi}
- i : integer;
- {$else delphi}
- i : word;
- {$endif delphi}
- 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;
- {$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));
- 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
- {$ifndef TP}
- {$ifopt H+}
- setlength(s,getbyte);
- {$else}
- s[0]:=chr(getbyte);
- {$endif}
- {$else}
- s[0]:=chr(getbyte);
- {$endif}
- 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;
- 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:=$ffffffff;
- interface_crc:=$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
- writedata(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;
- var
- i : word;
- begin
- if not closed then
- begin
- closepos:=filepos(f);
- {$I-}
- system.close(f);
- {$I+}
- i:=ioresult;
- 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.48 1999-11-17 17:05:02 pierre
- * Notes/hints changes
- Revision 1.47 1999/11/06 14:34:23 peter
- * truncated log to 20 revs
- Revision 1.46 1999/09/17 09:14:56 peter
- * ppu header writting now uses currentppuversion
- Revision 1.45 1999/09/16 13:27:08 pierre
- + error if PPU modulename is different from what is searched
- (8+3 limitations!)
- + cond ORDERSOURCES to allow recompilation of FP
- if symppu.inc is changed (need PPUversion change!)
- Revision 1.44 1999/09/16 11:34:58 pierre
- * typo correction
- Revision 1.43 1999/09/10 18:48:09 florian
- * some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid)
- * most things for stored properties fixed
- Revision 1.42 1999/08/31 15:47:56 pierre
- + startup conditionals stored in PPU file for debug info
- Revision 1.41 1999/08/30 16:21:40 pierre
- * tempclosing of ppufiles under dos was wrong
- Revision 1.40 1999/08/27 10:48:40 pierre
- + tppufile.tempclose and tempopen added
- * some changes so that nothing is writtedn to disk while
- calculating CRC only
- Revision 1.39 1999/08/24 12:01:36 michael
- + changes for resourcestrings
- Revision 1.38 1999/08/15 10:47:48 peter
- + normalset,smallset writing
- Revision 1.37 1999/08/02 23:13:20 florian
- * more changes to compile for the Alpha
- Revision 1.36 1999/07/23 16:05:25 peter
- * alignment is now saved in the symtable
- * C alignment added for records
- * PPU version increased to solve .12 <-> .13 probs
- Revision 1.35 1999/07/05 16:21:30 peter
- * fixed linking for units without linking necessary
- Revision 1.34 1999/07/03 00:29:57 peter
- * new link writing to the ppu, one .ppu is needed for all link types,
- static (.o) is now always created also when smartlinking is used
- Revision 1.33 1999/05/13 21:59:36 peter
- * removed oldppu code
- * warning if objpas is loaded from uses
- * first things for new deref writing
- Revision 1.32 1999/05/05 09:19:15 florian
- * more fixes to get it with delphi running
- Revision 1.31 1999/05/04 21:44:59 florian
- * changes to compile it with Delphi 4.0
- Revision 1.30 1999/04/26 18:30:00 peter
- * farpointerdef moved into pointerdef.is_far
- Revision 1.29 1999/04/26 13:31:41 peter
- * release storenumber,double_checksum
- Revision 1.28 1999/04/26 09:33:07 peter
- * header extended to 40 bytes so there is room for future
- Revision 1.27 1999/04/17 13:16:20 peter
- * fixes for storenumber
- }
|