paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-31 01:11:29 +01:00
Code Issues Packages Projects Releases Wiki Activity
cc15fb70fb
fpc/compiler/cobjects.pas

1509 lines
39 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
This module provides some basic objects
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}
{$E+,N+,D+,F+}
{$endif}
{$I-}
{$R-}{ necessary for crc calculation }
unit cobjects;
interface
uses
strings
{$ifndef linux}
,dos
{$else}
,linux
{$endif}
;
const hasharraysize = 253; {The size of a hasharray should be a prime
number for better spreading of nodes in
the array!! (DM)}
type
pstring = ^string;
pfileposinfo = ^tfileposinfo;
tfileposinfo = record
line : longint;
column : word;
fileindex : word;
end;
{ some help data types }
pstringitem = ^tstringitem;
tstringitem = record
data : pstring;
next : pstringitem;
fileinfo : tfileposinfo; { pointer to tinputfile }
end;
plinkedlist_item = ^tlinkedlist_item;
tlinkedlist_item = object
next,previous : plinkedlist_item;
{ does nothing }
constructor init;
destructor done;virtual;
end;
pstring_item = ^tstring_item;
tstring_item = object(tlinkedlist_item)
str : pstring;
constructor init(const s : string);
destructor done;virtual;
end;
{ this implements a double linked list }
plinkedlist = ^tlinkedlist;
tlinkedlist = object
first,last : plinkedlist_item;
constructor init;
destructor done;
{ disposes the items of the list }
procedure clear;
{ concats a new item at the end }
procedure concat(p : plinkedlist_item);
{ inserts a new item at the begin }
procedure insert(p : plinkedlist_item);
{ inserts another list at the begin and make this list empty }
procedure insertlist(p : plinkedlist);
{ concats another list at the end and make this list empty }
procedure concatlist(p : plinkedlist);
{ removes p from the list (p isn't disposed) }
{ it's not tested if p is in the list ! }
procedure remove(p : plinkedlist_item);
{ is the linkedlist empty ? }
function empty:boolean;
end;
{ String Queue}
PStringQueue=^TStringQueue;
TStringQueue=object
first,last : PStringItem;
constructor Init;
destructor Done;
function Empty:boolean;
function Get:string;
procedure Insert(const s:string);
procedure Concat(const s:string);
procedure Clear;
end;
{ string container }
pstringcontainer = ^tstringcontainer;
tstringcontainer = object
root,
last : pstringitem;
doubles : boolean; { if this is set to true, doubles are allowed }
constructor init;
constructor init_no_double;
destructor done;
{ true when the container is empty }
function empty:boolean;
{ inserts a string }
procedure insert(const s : string);
procedure insert_with_tokeninfo(const s : string;const file_info : tfileposinfo);
{ gets a string }
function get : string;
function get_with_tokeninfo(var file_info : tfileposinfo) : string;
{ true if string is in the container }
function find(const s:string):boolean;
{ deletes all strings }
procedure clear;
end;
Pnamed_object=^Tnamed_object;
Pdictionary=^Tdictionary;
Pdictionaryhasharray=^Tdictionaryhasharray;
Tdictionaryhasharray=array[0..hasharraysize-1] of Pnamed_object;
Tcallback = procedure(p:Pnamed_object);
Tdictionary=object
root:Pnamed_object;
hasharray:Pdictionaryhasharray;
replace_existing : boolean;
constructor init(usehash:boolean);
procedure clear;virtual;
procedure foreach(proc2call:Tcallback);
function insert(obj:Pnamed_object):Pnamed_object;virtual;
function search(const s:string):Pnamed_object;
function speedsearch(const s:string;
speedvalue:longint):Pnamed_object;virtual;
destructor done;virtual;
end;
Tnamed_object=object
_name:Pstring;
left,right:Pnamed_object;
speedvalue:longint;
owner:Pdictionary;
constructor init(const n:string);
destructor done;virtual;
function name:string;
end;
{$ifdef BUFFEREDFILE}
{ this is implemented to allow buffered binary I/O }
pbufferedfile = ^tbufferedfile;
tbufferedfile = object
f : file;
buf : pchar;
bufsize,buflast,bufpos : longint;
{ 0 closed, 1 input, 2 output }
iomode : byte;
{ true, if the compile should change the endian of the output }
change_endian : boolean;
{ calcules a crc for the file, }
{ but it's assumed, that there no seek while do_crc is true }
do_crc : boolean;
crc : longint;
{ temporary closing feature }
tempclosed : boolean;
tempmode : byte;
temppos : longint;
{ inits a buffer with the size bufsize which is assigned to }
{ the file filename }
constructor init(const filename : string;_bufsize : longint);
{ closes the file, if needed, and releases the memory }
destructor done;virtual;
{ opens the file for input, other accesses are rejected }
function reset:boolean;
{ opens the file for output, other accesses are rejected }
procedure rewrite;
{ reads or writes the buffer from or to disk }
procedure flush;
{ writes a string to the file }
{ the string is written without a length byte }
procedure write_string(const s : string);
{ writes a zero terminated string }
procedure write_pchar(p : pchar);
{ write specific data types, takes care of }
{ byte order }
procedure write_byte(b : byte);
procedure write_word(w : word);
procedure write_long(l : longint);
procedure write_double(d : double);
{ writes any data }
procedure write_data(var data;count : longint);
{ reads any data }
procedure read_data(var data;bytes : longint;var count : longint);
{ closes the file and releases the buffer }
procedure close;
{ temporary closing }
procedure tempclose;
procedure tempreopen;
{ goto the given position }
procedure seek(l : longint);
{ installes an user defined buffer }
{ and releases the old one, but be }
{ careful, if the old buffer contains }
{ data, this data is lost }
procedure setbuf(p : pchar;s : longint);
{ reads the file time stamp of the file, }
{ the file must be opened }
function getftime : longint;
{ returns filesize }
function getsize : longint;
{ returns the path }
function getpath : string;
{ resets the crc }
procedure clear_crc;
{ returns the crc }
function getcrc : longint;
end;
{$endif BUFFEREDFILE}
{ releases the string p and assignes nil to p }
{ if p=nil then freemem isn't called }
procedure stringdispose(var p : pstring);
{ idem for ansistrings }
procedure ansistringdispose(var p : pchar;length : longint);
{ allocates mem for a copy of s, copies s to this mem and returns }
{ a pointer to this mem }
function stringdup(const s : string) : pstring;
{ allocates memory for s and copies s as zero terminated string
to that mem and returns a pointer to that mem }
function strpnew(const s : string) : pchar;
{ makes a char lowercase, with spanish, french and german char set }
function lowercase(c : char) : char;
{ makes zero terminated string to a pascal string }
{ the data in p is modified and p is returned }
function pchar2pstring(p : pchar) : pstring;
{ ambivalent to pchar2pstring }
function pstring2pchar(p : pstring) : pchar;
implementation
{$ifdef FPC}
function getspeedvalue(const s : string) : longint;
var
p1,p2:^byte;
begin
p1:=@s;
longint(p2):=longint(p1)+p1^+1;
inc(longint(p1));
getspeedvalue:=0;
while p1<>p2 do
begin
inc(getspeedvalue,p1^);
inc(longint(p1));
end;
end;
{$else}
function getspeedvalue(const s : string) : longint;
type
ptrrec=record
ofs,seg:word;
end;
var
l,w : longint;
p1,p2 : ^byte;
begin
p1:=@s;
ptrrec(p2).seg:=ptrrec(p1).seg;
ptrrec(p2).ofs:=ptrrec(p1).ofs+p1^+1;
inc(p1);
l:=0;
while p1<>p2 do
begin
l:=l+p1^;
inc(p1);
end;
getspeedvalue:=l;
end;
{$endif}
function pchar2pstring(p : pchar) : pstring;
var
w,i : longint;
begin
w:=strlen(p);
for i:=w-1 downto 0 do
p[i+1]:=p[i];
p[0]:=chr(w);
pchar2pstring:=pstring(p);
end;
function pstring2pchar(p : pstring) : pchar;
var
w,i : longint;
begin
w:=length(p^);
for i:=1 to w do
p^[i-1]:=p^[i];
p^[w]:=#0;
pstring2pchar:=pchar(p);
end;
function lowercase(c : char) : char;
begin
case c of
#65..#90 : c := chr(ord (c) + 32);
#154 : c:=#129; { german }
#142 : c:=#132; { german }
#153 : c:=#148; { german }
#144 : c:=#130; { french }
#128 : c:=#135; { french }
#143 : c:=#134; { swedish/norge (?) }
#165 : c:=#164; { spanish }
#228 : c:=#229; { greek }
#226 : c:=#231; { greek }
#232 : c:=#227; { greek }
end;
lowercase := c;
end;
function strpnew(const s : string) : pchar;
var
p : pchar;
begin
getmem(p,length(s)+1);
strpcopy(p,s);
strpnew:=p;
end;
procedure stringdispose(var p : pstring);
begin
if assigned(p) then
freemem(p,length(p^)+1);
p:=nil;
end;
procedure ansistringdispose(var p : pchar;length : longint);
begin
if assigned(p) then
freemem(p,length+1);
p:=nil;
end;
function stringdup(const s : string) : pstring;
var
p : pstring;
begin
getmem(p,length(s)+1);
p^:=s;
stringdup:=p;
end;
{****************************************************************************
TStringQueue
****************************************************************************}
constructor TStringQueue.Init;
begin
first:=nil;
end;
function TStringQueue.Empty:boolean;
begin
Empty:=(first=nil);
end;
function TStringQueue.Get:string;
var
hp : pstringitem;
begin
if first=nil then
begin
Get:='';
exit;
end;
Get:=first^.data^;
stringdispose(first^.data);
hp:=first;
first:=first^.next;
dispose(hp);
end;
procedure TStringQueue.Insert(const s:string);
var
hp : pstringitem;
begin
new(hp);
hp^.next:=first;
hp^.data:=stringdup(s);
first:=hp;
if last=nil then
last:=hp;
end;
procedure TStringQueue.Concat(const s:string);
var
hp : pstringitem;
begin
new(hp);
hp^.next:=nil;
hp^.data:=stringdup(s);
if first=nil then
first:=hp
else
last^.next:=hp;
last:=hp;
end;
procedure TStringQueue.Clear;
var
hp : pstringitem;
begin
while (first<>nil) do
begin
hp:=first;
stringdispose(first^.data);
first:=first^.next;
dispose(hp);
end;
end;
destructor TStringQueue.Done;
begin
Clear;
end;
{****************************************************************************
TSTRINGCONTAINER
****************************************************************************}
constructor tstringcontainer.init;
begin
root:=nil;
last:=nil;
doubles:=true;
end;
constructor tstringcontainer.init_no_double;
begin
root:=nil;
last:=nil;
doubles:=false;
end;
destructor tstringcontainer.done;
begin
clear;
end;
function tstringcontainer.empty:boolean;
begin
empty:=(root=nil);
end;
procedure tstringcontainer.insert(const s : string);
var
hp : pstringitem;
begin
if not(doubles) then
begin
hp:=root;
while assigned(hp) do
begin
if hp^.data^=s then exit;
hp:=hp^.next;
end;
end;
new(hp);
hp^.next:=nil;
hp^.data:=stringdup(s);
if root=nil then root:=hp
else last^.next:=hp;
last:=hp;
end;
procedure tstringcontainer.insert_with_tokeninfo(const s : string; const file_info : tfileposinfo);
var
hp : pstringitem;
begin
if not(doubles) then
begin
hp:=root;
while assigned(hp) do
begin
if hp^.data^=s then exit;
hp:=hp^.next;
end;
end;
new(hp);
hp^.next:=nil;
hp^.data:=stringdup(s);
hp^.fileinfo:=file_info;
if root=nil then root:=hp
else last^.next:=hp;
last:=hp;
end;
procedure tstringcontainer.clear;
var
hp : pstringitem;
begin
hp:=root;
while assigned(hp) do
begin
stringdispose(hp^.data);
root:=hp^.next;
dispose(hp);
hp:=root;
end;
last:=nil;
root:=nil;
end;
function tstringcontainer.get : string;
var
hp : pstringitem;
begin
if root=nil then
get:=''
else
begin
get:=root^.data^;
hp:=root;
root:=root^.next;
stringdispose(hp^.data);
dispose(hp);
end;
end;
function tstringcontainer.get_with_tokeninfo(var file_info : tfileposinfo) : string;
var
hp : pstringitem;
begin
if root=nil then
begin
get_with_tokeninfo:='';
file_info.fileindex:=0;
file_info.line:=0;
file_info.column:=0;
end
else
begin
get_with_tokeninfo:=root^.data^;
hp:=root;
root:=root^.next;
stringdispose(hp^.data);
file_info:=hp^.fileinfo;
dispose(hp);
end;
end;
function tstringcontainer.find(const s:string):boolean;
var
hp : pstringitem;
begin
find:=false;
hp:=root;
while assigned(hp) do
begin
if hp^.data^=s then
begin
find:=true;
exit;
end;
hp:=hp^.next;
end;
end;
{****************************************************************************
TLINKEDLIST_ITEM
****************************************************************************}
constructor tlinkedlist_item.init;
begin
previous:=nil;
next:=nil;
end;
destructor tlinkedlist_item.done;
begin
end;
{****************************************************************************
TSTRING_ITEM
****************************************************************************}
constructor tstring_item.init(const s : string);
begin
str:=stringdup(s);
end;
destructor tstring_item.done;
begin
stringdispose(str);
inherited done;
end;
{****************************************************************************
TLINKEDLIST
****************************************************************************}
constructor tlinkedlist.init;
begin
first:=nil;
last:=nil;
end;
destructor tlinkedlist.done;
begin
clear;
end;
procedure tlinkedlist.clear;
var
hp : plinkedlist_item;
begin
hp:=first;
while assigned(hp) do
begin
first:=hp^.next;
dispose(hp,done);
hp:=first;
end;
end;
procedure tlinkedlist.insertlist(p : plinkedlist);
begin
{ empty list ? }
if not(assigned(p^.first)) then
exit;
p^.last^.next:=first;
{ we have a double linked list }
if assigned(first) then
first^.previous:=p^.last;
first:=p^.first;
if not(assigned(last)) then
last:=p^.last;
{ p becomes empty }
p^.first:=nil;
p^.last:=nil;
end;
procedure tlinkedlist.concat(p : plinkedlist_item);
begin
p^.previous:=nil;
p^.next:=nil;
if not(assigned(first)) then
first:=p
else
begin
last^.next:=p;
p^.previous:=last;
end;
last:=p;
end;
procedure tlinkedlist.insert(p : plinkedlist_item);
begin
p^.previous:=nil;
p^.next:=nil;
if not(assigned(first)) then
last:=p
else
begin
first^.previous:=p;
p^.next:=first;
first:=p;
end;
first:=p;
end;
procedure tlinkedlist.remove(p : plinkedlist_item);
begin
if not(assigned(p)) then
exit;
if (first=p) and (last=p) then
begin
first:=nil;
last:=nil;
end
else if first=p then
begin
first:=p^.next;
if assigned(first) then
first^.previous:=nil;
end
else if last=p then
begin
last:=last^.previous;
if assigned(last) then
last^.next:=nil;
end
else
begin
p^.previous^.next:=p^.next;
p^.next^.previous:=p^.previous;
end;
p^.next:=nil;
p^.previous:=nil;
end;
procedure tlinkedlist.concatlist(p : plinkedlist);
begin
if not(assigned(p^.first)) then
exit;
if not(assigned(first)) then
first:=p^.first
else
begin
last^.next:=p^.first;
p^.first^.previous:=last;
end;
last:=p^.last;
{ make p empty }
p^.last:=nil;
p^.first:=nil;
end;
function tlinkedlist.empty:boolean;
begin
empty:=(first=nil);
end;
{****************************************************************************
TNAMED_OBJECT
****************************************************************************}
constructor Tnamed_object.init(const n:string);
begin
left:=nil;
right:=nil;
_name:=stringdup(n);
speedvalue:=getspeedvalue(n);
end;
destructor Tnamed_object.done;
begin
stringdispose(_name);
end;
function Tnamed_object.name:string;
begin
name:=_name^;
end;
{****************************************************************************
TDICTIONARY
****************************************************************************}
constructor Tdictionary.init(usehash:boolean);
begin
root:=nil;
hasharray:=nil;
replace_existing:=false;
if usehash then
begin
new(hasharray);
fillchar(hasharray^,sizeof(hasharray^),0);
end;
end;
procedure Tdictionary.clear;
var w:longint;
begin
{remove no entry from a withsymtable as it is only a pointer to the
recorddef or objectdef symtable }
{ remove all entry from a symbol table }
if assigned(root) then
dispose(root,done);
if assigned(hasharray) then
for w:=0 to hasharraysize-1 do
if assigned(hasharray^[w]) then
begin
dispose(hasharray^[w],done);
hasharray^[w]:=nil;
end;
end;
procedure Tdictionary.foreach(proc2call:Tcallback);
procedure a(p:Pnamed_object);
{ must be preorder, because it's used by reading in }
{ a PPU file }
begin
proc2call(p);
if assigned(p^.left) then
a(p^.left);
if assigned(p^.right) then
a(p^.right);
end;
var i:longint;
begin
if assigned(hasharray) then
begin
for i:=0 to hasharraysize-1 do
if assigned(hasharray^[i]) then
a(hasharray^[i]);
end
else
if assigned(root) then
a(root);
end;
function Tdictionary.insert(obj:Pnamed_object):Pnamed_object;
function _insert(var osym:Pnamed_object):Pnamed_object;
{To prevent TP from allocating temp space for temp strings, we allocate
some temp strings manually. We can use two temp strings, plus a third
one that TP adds, where TP alone needs five temp strings!. Storing
these on the heap saves even more, totally 1016 bytes per recursion!}
var s1,s2:^string;
begin
if osym=nil then
begin
osym:=obj;
_insert:=osym;
end
{ first check speedvalue, to allow a fast insert }
else
if osym^.speedvalue>obj^.speedvalue then
_insert:=_insert(osym^.right)
else
if osym^.speedvalue<obj^.speedvalue then
_insert:=_insert(osym^.left)
else
begin
new(s1);
new(s2);
s1^:=osym^._name^;
s2^:=obj^._name^;
if s1^>s2^ then
begin
dispose(s2);
dispose(s1);
_insert:=_insert(osym^.right);
end
else
if s1^<s2^ then
begin
dispose(s2);
dispose(s1);
_insert:=_insert(osym^.left);
end
else
begin
dispose(s2);
dispose(s1);
if replace_existing and
assigned(osym) then
begin
obj^.left:=osym^.left;
obj^.right:=osym^.right;
osym:=obj;
_insert:=obj;
end
else
_insert:=osym;
end;
end;
end;
begin
obj^.owner:=@self;
obj^.speedvalue:=getspeedvalue(obj^._name^);
if assigned(hasharray) then
insert:=_insert(hasharray^[obj^.speedvalue mod hasharraysize])
else
insert:=_insert(root);
end;
function Tdictionary.search(const s:string):Pnamed_object;
begin
search:=speedsearch(s,getspeedvalue(s));
end;
function Tdictionary.speedsearch(const s:string;
speedvalue:longint):Pnamed_object;
var hp:Pnamed_object;
begin
if assigned(hasharray) then
hp:=hasharray^[speedvalue mod hasharraysize]
else
hp:=root;
while assigned(hp) do
begin
if speedvalue>hp^.speedvalue then
hp:=hp^.left
else
if speedvalue<hp^.speedvalue then
hp:=hp^.right
else
begin
if (hp^._name^=s) then
begin
speedsearch:=hp;
exit;
end
else
if s>hp^._name^ then
hp:=hp^.left
else
hp:=hp^.right;
end;
end;
speedsearch:=nil;
end;
destructor Tdictionary.done;
begin
clear;
if assigned(hasharray) then
dispose(hasharray);
end;
{$ifdef BUFFEREDFILE}
{****************************************************************************
TBUFFEREDFILE
****************************************************************************}
Const
crcseed = $ffffffff;
crctable : array[0..255] of longint = (
$00000000,$77073096,$ee0e612c,$990951ba,$076dc419,$706af48f,
$e963a535,$9e6495a3,$0edb8832,$79dcb8a4,$e0d5e91e,$97d2d988,
$09b64c2b,$7eb17cbd,$e7b82d07,$90bf1d91,$1db71064,$6ab020f2,
$f3b97148,$84be41de,$1adad47d,$6ddde4eb,$f4d4b551,$83d385c7,
$136c9856,$646ba8c0,$fd62f97a,$8a65c9ec,$14015c4f,$63066cd9,
$fa0f3d63,$8d080df5,$3b6e20c8,$4c69105e,$d56041e4,$a2677172,
$3c03e4d1,$4b04d447,$d20d85fd,$a50ab56b,$35b5a8fa,$42b2986c,
$dbbbc9d6,$acbcf940,$32d86ce3,$45df5c75,$dcd60dcf,$abd13d59,
$26d930ac,$51de003a,$c8d75180,$bfd06116,$21b4f4b5,$56b3c423,
$cfba9599,$b8bda50f,$2802b89e,$5f058808,$c60cd9b2,$b10be924,
$2f6f7c87,$58684c11,$c1611dab,$b6662d3d,$76dc4190,$01db7106,
$98d220bc,$efd5102a,$71b18589,$06b6b51f,$9fbfe4a5,$e8b8d433,
$7807c9a2,$0f00f934,$9609a88e,$e10e9818,$7f6a0dbb,$086d3d2d,
$91646c97,$e6635c01,$6b6b51f4,$1c6c6162,$856530d8,$f262004e,
$6c0695ed,$1b01a57b,$8208f4c1,$f50fc457,$65b0d9c6,$12b7e950,
$8bbeb8ea,$fcb9887c,$62dd1ddf,$15da2d49,$8cd37cf3,$fbd44c65,
$4db26158,$3ab551ce,$a3bc0074,$d4bb30e2,$4adfa541,$3dd895d7,
$a4d1c46d,$d3d6f4fb,$4369e96a,$346ed9fc,$ad678846,$da60b8d0,
$44042d73,$33031de5,$aa0a4c5f,$dd0d7cc9,$5005713c,$270241aa,
$be0b1010,$c90c2086,$5768b525,$206f85b3,$b966d409,$ce61e49f,
$5edef90e,$29d9c998,$b0d09822,$c7d7a8b4,$59b33d17,$2eb40d81,
$b7bd5c3b,$c0ba6cad,$edb88320,$9abfb3b6,$03b6e20c,$74b1d29a,
$ead54739,$9dd277af,$04db2615,$73dc1683,$e3630b12,$94643b84,
$0d6d6a3e,$7a6a5aa8,$e40ecf0b,$9309ff9d,$0a00ae27,$7d079eb1,
$f00f9344,$8708a3d2,$1e01f268,$6906c2fe,$f762575d,$806567cb,
$196c3671,$6e6b06e7,$fed41b76,$89d32be0,$10da7a5a,$67dd4acc,
$f9b9df6f,$8ebeeff9,$17b7be43,$60b08ed5,$d6d6a3e8,$a1d1937e,
$38d8c2c4,$4fdff252,$d1bb67f1,$a6bc5767,$3fb506dd,$48b2364b,
$d80d2bda,$af0a1b4c,$36034af6,$41047a60,$df60efc3,$a867df55,
$316e8eef,$4669be79,$cb61b38c,$bc66831a,$256fd2a0,$5268e236,
$cc0c7795,$bb0b4703,$220216b9,$5505262f,$c5ba3bbe,$b2bd0b28,
$2bb45a92,$5cb36a04,$c2d7ffa7,$b5d0cf31,$2cd99e8b,$5bdeae1d,
$9b64c2b0,$ec63f226,$756aa39c,$026d930a,$9c0906a9,$eb0e363f,
$72076785,$05005713,$95bf4a82,$e2b87a14,$7bb12bae,$0cb61b38,
$92d28e9b,$e5d5be0d,$7cdcefb7,$0bdbdf21,$86d3d2d4,$f1d4e242,
$68ddb3f8,$1fda836e,$81be16cd,$f6b9265b,$6fb077e1,$18b74777,
$88085ae6,$ff0f6a70,$66063bca,$11010b5c,$8f659eff,$f862ae69,
$616bffd3,$166ccf45,$a00ae278,$d70dd2ee,$4e048354,$3903b3c2,
$a7672661,$d06016f7,$4969474d,$3e6e77db,$aed16a4a,$d9d65adc,
$40df0b66,$37d83bf0,$a9bcae53,$debb9ec5,$47b2cf7f,$30b5ffe9,
$bdbdf21c,$cabac28a,$53b39330,$24b4a3a6,$bad03605,$cdd70693,
$54de5729,$23d967bf,$b3667a2e,$c4614ab8,$5d681b02,$2a6f2b94,
$b40bbe37,$c30c8ea1,$5a05df1b,$2d02ef8d);
constructor tbufferedfile.init(const filename : string;_bufsize : longint);
begin
assign(f,filename);
bufsize:=_bufsize;
bufpos:=0;
buflast:=0;
do_crc:=false;
iomode:=0;
tempclosed:=false;
change_endian:=false;
clear_crc;
end;
destructor tbufferedfile.done;
begin
close;
end;
procedure tbufferedfile.clear_crc;
begin
crc:=crcseed;
end;
procedure tbufferedfile.setbuf(p : pchar;s : longint);
begin
flush;
freemem(buf,bufsize);
bufsize:=s;
buf:=p;
end;
function tbufferedfile.reset:boolean;
var
ofm : byte;
begin
ofm:=filemode;
iomode:=1;
getmem(buf,bufsize);
filemode:=0;
{$I-}
system.reset(f,1);
{$I+}
reset:=(ioresult=0);
filemode:=ofm;
end;
procedure tbufferedfile.rewrite;
begin
iomode:=2;
getmem(buf,bufsize);
system.rewrite(f,1);
end;
procedure tbufferedfile.flush;
var
{$ifdef FPC}
count : longint;
{$else}
count : integer;
{$endif}
begin
if iomode=2 then
begin
if bufpos=0 then
exit;
blockwrite(f,buf^,bufpos)
end
else if iomode=1 then
if buflast=bufpos then
begin
blockread(f,buf^,bufsize,count);
buflast:=count;
end;
bufpos:=0;
end;
function tbufferedfile.getftime : longint;
var
l : longint;
{$ifdef linux}
Info : Stat;
{$endif}
begin
{$ifndef linux}
{ this only works if the file is open !! }
dos.getftime(f,l);
{$else}
Fstat(f,Info);
l:=info.mtime;
{$endif}
getftime:=l;
end;
function tbufferedfile.getsize : longint;
begin
getsize:=filesize(f);
end;
procedure tbufferedfile.seek(l : longint);
begin
if iomode=2 then
begin
flush;
system.seek(f,l);
end
else if iomode=1 then
begin
{ forces a reload }
bufpos:=buflast;
system.seek(f,l);
flush;
end;
end;
type
{$ifdef tp}
bytearray1 = array [1..65535] of byte;
{$else}
bytearray1 = array [1..10000000] of byte;
{$endif}
procedure tbufferedfile.read_data(var data;bytes : longint;var count : longint);
var
p : pchar;
c,i : longint;
begin
p:=pchar(@data);
count:=0;
while bytes-count>0 do
begin
if bytes-count>buflast-bufpos then
begin
move((buf+bufpos)^,(p+count)^,buflast-bufpos);
inc(count,buflast-bufpos);
bufpos:=buflast;
flush;
{ can't we read anything ? }
if bufpos=buflast then
break;
end
else
begin
move((buf+bufpos)^,(p+count)^,bytes-count);
inc(bufpos,bytes-count);
count:=bytes;
break;
end;
end;
if do_crc then
begin
c:=crc;
for i:=1 to bytes do
c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
crc:=c;
end;
end;
procedure tbufferedfile.write_data(var data;count : longint);
var
c,i : longint;
begin
if bufpos+count>bufsize then
flush;
move(data,(buf+bufpos)^,count);
inc(bufpos,count);
if do_crc then
begin
c:=crc;
for i:=1 to count do
c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
crc:=c;
end;
end;
function tbufferedfile.getcrc : longint;
begin
getcrc:=crc xor crcseed;
end;
procedure tbufferedfile.write_string(const s : string);
begin
if bufpos+length(s)>bufsize then
flush;
{ why is there not CRC here ??? }
move(s[1],(buf+bufpos)^,length(s));
inc(bufpos,length(s));
{ should be
write_data(s[1],length(s)); }
end;
procedure tbufferedfile.write_pchar(p : pchar);
var
l : longint;
begin
l:=strlen(p);
if l>=bufsize then
runerror(222);
{ why is there not CRC here ???}
if bufpos+l>bufsize then
flush;
move(p^,(buf+bufpos)^,l);
inc(bufpos,l);
{ should be
write_data(p^,l); }
end;
procedure tbufferedfile.write_byte(b : byte);
begin
write_data(b,sizeof(byte));
end;
procedure tbufferedfile.write_long(l : longint);
var
w1,w2 : word;
begin
if change_endian then
begin
w1:=l and $ffff;
w2:=l shr 16;
l:=swap(w2)+(longint(swap(w1)) shl 16);
write_data(l,sizeof(longint))
end
else
write_data(l,sizeof(longint))
end;
procedure tbufferedfile.write_word(w : word);
begin
if change_endian then
begin
w:=swap(w);
write_data(w,sizeof(word))
end
else
write_data(w,sizeof(word));
end;
procedure tbufferedfile.write_double(d : double);
begin
write_data(d,sizeof(double));
end;
function tbufferedfile.getpath : string;
begin
{$ifdef dummy}
getpath:=strpas(filerec(f).name);
{$endif}
getpath:='';
end;
procedure tbufferedfile.close;
begin
if iomode<>0 then
begin
flush;
system.close(f);
freemem(buf,bufsize);
buf:=nil;
iomode:=0;
end;
end;
procedure tbufferedfile.tempclose;
begin
if iomode<>0 then
begin
temppos:=system.filepos(f);
tempmode:=iomode;
tempclosed:=true;
system.close(f);
iomode:=0;
end
else
tempclosed:=false;
end;
procedure tbufferedfile.tempreopen;
var
ofm : byte;
begin
if tempclosed then
begin
case tempmode of
1 : begin
ofm:=filemode;
iomode:=1;
filemode:=0;
system.reset(f,1);
filemode:=ofm;
end;
2 : begin
iomode:=2;
system.rewrite(f,1);
end;
end;
system.seek(f,temppos);
tempclosed:=false;
end;
end;
{$endif BUFFEREDFILE}
end.
{
$Log$
Revision 1.19 1999-03-01 13:32:00 pierre
* external used before implemented problem fixed
Revision 1.18 1999/02/24 00:59:13 peter
* small updates for ag386bin
Revision 1.17 1999/01/19 11:00:33 daniel
+ Tdictionary object: Tsymtable will become object(TTdictionary) in the
future
+ Tnamed_item object: Tsym will become object(Tnamed_item) in the future
Revision 1.16 1998/11/04 10:11:37 peter
* ansistring fixes
Revision 1.15 1998/10/19 18:04:40 peter
+ tstringcontainer.init_no_doubles
Revision 1.14 1998/09/18 16:03:37 florian
* some changes to compile with Delphi
Revision 1.13 1998/08/12 19:28:16 peter
* better libc support
Revision 1.12 1998/07/14 14:46:47 peter
* released NEWINPUT
Revision 1.11 1998/07/07 11:19:54 peter
+ NEWINPUT for a better inputfile and scanner object
Revision 1.10 1998/07/01 15:26:59 peter
* better bufferfile.reset error handling
Revision 1.9 1998/06/03 23:40:37 peter
+ unlimited file support, release tempclose
Revision 1.8 1998/05/20 09:42:33 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.7 1998/05/06 18:36:53 peter
* tai_section extended with code,data,bss sections and enumerated type
* ident 'compiled by FPC' moved to pmodules
* small fix for smartlink
Revision 1.6 1998/05/06 08:38:37 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.5 1998/04/30 15:59:40 pierre
* GDB works again better :
correct type info in one pass
+ UseTokenInfo for better source position
* fixed one remaining bug in scanner for line counts
* several little fixes
Revision 1.4 1998/04/29 10:33:50 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output
+ started inline procedures
+ added starstarn : use ** for exponentiation (^ gave problems)
+ started UseTokenInfo cond to get accurate positions
Revision 1.3 1998/04/27 23:10:28 peter
+ new scanner
* $makelib -> if smartlink
* small filename fixes pmodule.setfilename
* moved import from files.pas -> import.pas
Revision 1.2 1998/04/07 11:09:04 peter
+ filemode is set correct in tbufferedfile.reset
}
Reference in New Issue View Git Blame Copy Permalink