From 8bbe79ac6920a4b53eb857cf2644bc61dedc98c0 Mon Sep 17 00:00:00 2001 From: peter Date: Wed, 23 Jun 1999 11:13:20 +0000 Subject: [PATCH] * fixed linebreak --- compiler/cobjects.pas | 4557 +++++++++++++++++++++-------------------- 1 file changed, 2280 insertions(+), 2277 deletions(-) diff --git a/compiler/cobjects.pas b/compiler/cobjects.pas index 296b4b4b66..ca296d29e6 100644 --- a/compiler/cobjects.pas +++ b/compiler/cobjects.pas @@ -1,2279 +1,2282 @@ -{ - $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; - -{ define OLDSPEEDVALUE} - - interface - - uses - strings -{$ifndef linux} - ,dos -{$else} - ,linux -{$endif} - ; - - const - { the real size will be [-hasharray..hasharray] ! } -{$ifdef TP} - hasharraysize = 127; -{$else} - hasharraysize = 2047; -{$endif} - - type - pstring = ^string; - -{$ifdef TP} - { redeclare dword only in case of emergency, some small things - of the compiler won't work then correctly (FK) - } - dword = longint; -{$endif TP} - - 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; - function getcopy:plinkedlist_item;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); - - procedure concatlistcopy(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; - - - Pnamedindexobject=^Tnamedindexobject; - Tnamedindexobject=object - indexnr : longint; - _name : Pstring; - next, - left,right : Pnamedindexobject; - speedvalue : longint; - constructor init; - constructor initname(const n:string); - destructor done;virtual; - procedure setname(const n:string);virtual; - function name:string;virtual; - end; - - Pdictionaryhasharray=^Tdictionaryhasharray; - Tdictionaryhasharray=array[-hasharraysize..hasharraysize] of Pnamedindexobject; - - Tnamedindexcallback = procedure(p:Pnamedindexobject); - - Pdictionary=^Tdictionary; - Tdictionary=object - noclear : boolean; - replace_existing : boolean; - constructor init; - destructor done;virtual; - procedure usehash; - procedure clear; - function delete(const s:string):Pnamedindexobject; - function empty:boolean; - procedure foreach(proc2call:Tnamedindexcallback); - function insert(obj:Pnamedindexobject):Pnamedindexobject; - function rename(const olds,news : string):Pnamedindexobject; - function search(const s:string):Pnamedindexobject; - function speedsearch(const s:string;speedvalue:longint):Pnamedindexobject; - private - root : Pnamedindexobject; - hasharray : Pdictionaryhasharray; - procedure cleartree(obj:Pnamedindexobject); - function insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject; - procedure inserttree(currtree,currroot:Pnamedindexobject); - end; - - pdynamicarray = ^tdynamicarray; - tdynamicarray = object - posn, - count, - limit, - elemlen, - growcount : longint; - data : pchar; - constructor init(Aelemlen,Agrow:longint); - destructor done; - function size:longint; - function usedsize:longint; - procedure grow; - procedure align(i:longint); - procedure seek(i:longint); - procedure write(var d;len:longint); - procedure read(var d;len:longint); - procedure writepos(pos:longint;var d;len:longint); - procedure readpos(pos:longint;var d;len:longint); - end; - - tindexobjectarray=array[1..16000] of Pnamedindexobject; - Pnamedindexobjectarray=^tindexobjectarray; - - pindexarray=^tindexarray; - tindexarray=object - first : Pnamedindexobject; - count : longint; - constructor init(Agrowsize:longint); - destructor done; - procedure clear; - procedure foreach(proc2call : Tnamedindexcallback); - procedure deleteindex(p:Pnamedindexobject); - procedure delete(p:Pnamedindexobject); - procedure insert(p:Pnamedindexobject); - function search(nr:longint):Pnamedindexobject; - private - growsize, - size : longint; - data : Pnamedindexobjectarray; - procedure grow(gsize:longint); - 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} - - function getspeedvalue(const s : string) : longint; - - { 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 - -{$ifndef OLDSPEEDVALUE} - -{***************************************************************************** - 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 GetSpeedValue(Const s:String):longint; -var - i,InitCrc : longint; -begin - if Crc32Tbl[1]=0 then - MakeCrc32Tbl; - InitCrc:=$ffffffff; - for i:=1to Length(s) do - InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8); - GetSpeedValue:=InitCrc; -end; - -{$ifdef Range_check_on} - {$R+} - {$undef Range_check_on} -{$endif Range_check_on} - -{$else} - -{$ifndef TP} - function getspeedvalue(const s : string) : longint; - var - p1,p2:^byte; - i : longint; - - begin - p1:=@s; - longint(p2):=longint(p1)+p1^+1; - inc(longint(p1)); - i:=0; - while p1<>p2 do - begin - i:=i + ord(p1^); - inc(longint(p1)); - end; - getspeedvalue:=i; - 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 + ord(p1^); - inc(p1); - end; - getspeedvalue:=l; - end; -{$endif} - -{$endif OLDSPEEDVALUE} - - - 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 - newnode : pstringitem; -begin - if first=nil then - begin - Get:=''; - exit; - end; - Get:=first^.data^; - stringdispose(first^.data); - newnode:=first; - first:=first^.next; - dispose(newnode); -end; - - -procedure TStringQueue.Insert(const s:string); -var - newnode : pstringitem; -begin - new(newnode); - newnode^.next:=first; - newnode^.data:=stringdup(s); - first:=newnode; - if last=nil then - last:=newnode; -end; - - -procedure TStringQueue.Concat(const s:string); -var - newnode : pstringitem; -begin - new(newnode); - newnode^.next:=nil; - newnode^.data:=stringdup(s); - if first=nil then - first:=newnode - else - last^.next:=newnode; - last:=newnode; -end; - - -procedure TStringQueue.Clear; -var - newnode : pstringitem; -begin - while (first<>nil) do - begin - newnode:=first; - stringdispose(first^.data); - first:=first^.next; - dispose(newnode); - 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 - newnode : pstringitem; - begin - if not(doubles) then - begin - newnode:=root; - while assigned(newnode) do - begin - if newnode^.data^=s then exit; - newnode:=newnode^.next; - end; - end; - new(newnode); - newnode^.next:=nil; - newnode^.data:=stringdup(s); - if root=nil then root:=newnode - else last^.next:=newnode; - last:=newnode; - end; - - - procedure tstringcontainer.insert_with_tokeninfo(const s : string; const file_info : tfileposinfo); - var - newnode : pstringitem; - begin - if not(doubles) then - begin - newnode:=root; - while assigned(newnode) do - begin - if newnode^.data^=s then exit; - newnode:=newnode^.next; - end; - end; - new(newnode); - newnode^.next:=nil; - newnode^.data:=stringdup(s); - newnode^.fileinfo:=file_info; - if root=nil then root:=newnode - else last^.next:=newnode; - last:=newnode; - end; - - - procedure tstringcontainer.clear; - var - newnode : pstringitem; - begin - newnode:=root; - while assigned(newnode) do - begin - stringdispose(newnode^.data); - root:=newnode^.next; - dispose(newnode); - newnode:=root; - end; - last:=nil; - root:=nil; - end; - - - function tstringcontainer.get : string; - var - newnode : pstringitem; - begin - if root=nil then - get:='' - else - begin - get:=root^.data^; - newnode:=root; - root:=root^.next; - stringdispose(newnode^.data); - dispose(newnode); - end; - end; - - - function tstringcontainer.get_with_tokeninfo(var file_info : tfileposinfo) : string; - var - newnode : 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^; - newnode:=root; - root:=root^.next; - stringdispose(newnode^.data); - file_info:=newnode^.fileinfo; - dispose(newnode); - end; - end; - - - function tstringcontainer.find(const s:string):boolean; - var - newnode : pstringitem; - begin - find:=false; - newnode:=root; - while assigned(newnode) do - begin - if newnode^.data^=s then - begin - find:=true; - exit; - end; - newnode:=newnode^.next; - end; - end; - - -{**************************************************************************** - TLINKEDLIST_ITEM - ****************************************************************************} - - constructor tlinkedlist_item.init; - begin - previous:=nil; - next:=nil; - end; - - - destructor tlinkedlist_item.done; - begin - end; - - - function tlinkedlist_item.getcopy:plinkedlist_item; - var - l : longint; - p : plinkedlist_item; - begin - l:=sizeof(self); - getmem(p,l); - move(self,p^,l); - getcopy:=p; - 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 - newnode : plinkedlist_item; - begin - newnode:=first; - while assigned(newnode) do - begin - first:=newnode^.next; - dispose(newnode,done); - newnode:=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 - if not(assigned(first)) then - begin - first:=p; - p^.previous:=nil; - p^.next:=nil; - end - else - begin - last^.next:=p; - p^.previous:=last; - p^.next:=nil; - end; - last:=p; - end; - - - procedure tlinkedlist.insert(p : plinkedlist_item); - begin - if not(assigned(first)) then - begin - last:=p; - p^.previous:=nil; - p^.next:=nil; - end - else - begin - first^.previous:=p; - p^.previous:=nil; - p^.next:=first; - 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; - - - procedure tlinkedlist.concatlistcopy(p : plinkedlist); - var - newnode,newnode2 : plinkedlist_item; - begin - newnode:=p^.first; - while assigned(newnode) do - begin - newnode2:=newnode^.getcopy; - if assigned(newnode2) then - begin - if not(assigned(first)) then - begin - first:=newnode2; - newnode2^.previous:=nil; - newnode2^.next:=nil; - end - else - begin - last^.next:=newnode2; - newnode2^.previous:=last; - newnode2^.next:=nil; - end; - last:=newnode2; - end; - newnode:=newnode^.next; - end; - end; - - function tlinkedlist.empty:boolean; - begin - empty:=(first=nil); - end; - - -{**************************************************************************** - Tnamedindexobject - ****************************************************************************} - -constructor Tnamedindexobject.init; -begin - { index } - indexnr:=-1; - next:=nil; - { dictionary } - left:=nil; - right:=nil; - _name:=nil; - speedvalue:=-1; -end; - -constructor Tnamedindexobject.initname(const n:string); -begin - { index } - indexnr:=-1; - next:=nil; - { dictionary } - left:=nil; - right:=nil; - speedvalue:=-1; - _name:=stringdup(n); -end; - -destructor Tnamedindexobject.done; -begin - stringdispose(_name); -end; - -procedure Tnamedindexobject.setname(const n:string); -begin - if speedvalue=-1 then - begin - if assigned(_name) then - stringdispose(_name); - _name:=stringdup(n); - end; -end; - -function Tnamedindexobject.name:string; -begin - if assigned(_name) then - name:=_name^ - else - name:=''; -end; - - -{**************************************************************************** - TDICTIONARY -****************************************************************************} - - constructor Tdictionary.init; - begin - root:=nil; - hasharray:=nil; - noclear:=false; - replace_existing:=false; - end; - - - procedure Tdictionary.usehash; - begin - if not(assigned(root)) and - not(assigned(hasharray)) then - begin - new(hasharray); - fillchar(hasharray^,sizeof(hasharray^),0); - end; - end; - - - destructor Tdictionary.done; - begin - if not noclear then - clear; - if assigned(hasharray) then - dispose(hasharray); - end; - - - procedure Tdictionary.cleartree(obj:Pnamedindexobject); - begin - if assigned(obj^.left) then - cleartree(obj^.left); - if assigned(obj^.right) then - cleartree(obj^.right); - dispose(obj,done); - obj:=nil; - end; - - - procedure Tdictionary.clear; - var - w : longint; - begin - if assigned(root) then - cleartree(root); - if assigned(hasharray) then - for w:=-hasharraysize to hasharraysize do - if assigned(hasharray^[w]) then - cleartree(hasharray^[w]); - end; - - function Tdictionary.delete(const s:string):Pnamedindexobject; - - var p,speedvalue:longint; - n:Pnamedindexobject; - - procedure insert_right_bottom(var root,Atree:Pnamedindexobject); - - begin - while root^.right<>nil do - root:=root^.right; - root^.right:=Atree; - end; - - function delete_from_tree(root:Pnamedindexobject):Pnamedindexobject; - - type leftright=(left,right); - - var lr:leftright; - oldroot:Pnamedindexobject; - - begin - oldroot:=nil; - while (root<>nil) and (root^.speedvalue<>speedvalue) do - begin - oldroot:=root; - if speedvaluenil) and (root^._name^<>s) do - begin - oldroot:=root; - if snil then - begin - {Now the node pointing to root must point to the left - subtree of root. The right subtree of root must be - connected to the right bottom of the left subtree.} - if lr=left then - oldroot^.left:=root^.left - else - oldroot^.right:=root^.left; - if root^.right<>nil then - insert_right_bottom(root^.left,root^.right); - end - else - {There is no left subtree. So we can just replace the node to - delete with the right subtree.} - if lr=left then - oldroot^.left:=root^.right - else - oldroot^.right:=root^.right; - delete_from_tree:=root; - end; - - begin - speedvalue:=getspeedvalue(s); - n:=root; - if assigned(hasharray) then - begin - {First, check if the node to delete directly located under - the hasharray.} - p:=speedvalue mod hasharraysize; - n:=hasharray^[p]; - if (n<>nil) and (n^.speedvalue=speedvalue) and - (n^._name^=s) then - begin - {The node to delete is directly located under the - hasharray. Make the hasharray point to the left - subtree of the node and place the right subtree on - the right-bottom of the left subtree.} - if n^.left<>nil then - begin - hasharray^[p]:=n^.left; - if n^.right<>nil then - insert_right_bottom(n^.left,n^.right); - end - else - hasharray^[p]:=n^.right; - delete:=n; - exit; - end; - end - else - begin - {First check if the node to delete is the root.} - if (root<>nil) and (n^.speedvalue=speedvalue) - and (n^._name^=s) then - begin - if n^.left<>nil then - begin - root:=n^.left; - if n^.right<>nil then - insert_right_bottom(n^.left,n^.right); - end - else - root:=n^.right; - delete:=n; - exit; - end; - end; - delete:=delete_from_tree(n); - end; - - function Tdictionary.empty:boolean; - var - w : longint; - begin - if assigned(hasharray) then - begin - empty:=false; - for w:=-hasharraysize to hasharraysize do - if assigned(hasharray^[w]) then - exit; - empty:=true; - end - else - empty:=(root=nil); - end; - - - procedure Tdictionary.foreach(proc2call:Tnamedindexcallback); - - procedure a(p:Pnamedindexobject); - 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:=-hasharraysize to hasharraysize do - if assigned(hasharray^[i]) then - a(hasharray^[i]); - end - else - if assigned(root) then - a(root); - end; - - - function Tdictionary.insert(obj:Pnamedindexobject):Pnamedindexobject; - begin - obj^.speedvalue:=getspeedvalue(obj^._name^); - if assigned(hasharray) then - insert:=insertnode(obj,hasharray^[obj^.speedvalue mod hasharraysize]) - else - insert:=insertnode(obj,root); - end; - - - function tdictionary.insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject; - var - s1,s2:^string; - begin - if currnode=nil then - begin - currnode:=newnode; - insertnode:=currnode; - end - { first check speedvalue, to allow a fast insert } - else - if currnode^.speedvalue>newnode^.speedvalue then - insertnode:=insertnode(newnode,currnode^.right) - else - if currnode^.speedvalues2^ then - begin - dispose(s2); - dispose(s1); - insertnode:=insertnode(newnode,currnode^.right); - end - else - if s1^hp^.speedvalue then - begin - lasthp:=hp; - hp:=hp^.left - end - else - if spdvalhp^.name then - begin - lasthp:=hp; - hp:=hp^.left - end - else - begin - lasthp:=hp; - hp:=hp^.right; - end; - end; - end; - end; - - - function Tdictionary.search(const s:string):Pnamedindexobject; - begin - search:=speedsearch(s,getspeedvalue(s)); - end; - - - function Tdictionary.speedsearch(const s:string;speedvalue:longint):Pnamedindexobject; - var - newnode:Pnamedindexobject; - begin - if assigned(hasharray) then - newnode:=hasharray^[speedvalue mod hasharraysize] - else - newnode:=root; - while assigned(newnode) do - begin - if speedvalue>newnode^.speedvalue then - newnode:=newnode^.left - else - if speedvaluenewnode^._name^ then - newnode:=newnode^.left - else - newnode:=newnode^.right; - end; - end; - speedsearch:=nil; - end; - - -{**************************************************************************** - tdynamicarray -****************************************************************************} - - constructor tdynamicarray.init(Aelemlen,Agrow:longint); - begin - posn:=0; - count:=0; - limit:=0; - data:=nil; - elemlen:=Aelemlen; - growcount:=Agrow; - grow; - end; - - function tdynamicarray.size:longint; - begin - size:=limit*elemlen; - end; - - function tdynamicarray.usedsize:longint; - begin - usedsize:=count*elemlen; - end; - - procedure tdynamicarray.grow; - var - osize : longint; - odata : pchar; - begin - osize:=size; - odata:=data; - inc(limit,growcount); - getmem(data,size); - if assigned(odata) then - begin - move(odata^,data^,osize); - freemem(odata,osize); - end; - fillchar(data[osize],growcount*elemlen,0); - end; - - procedure tdynamicarray.align(i:longint); - var - j : longint; - begin - j:=(posn*elemlen mod i); - if j<>0 then - begin - j:=i-j; - while limit<(posn+j) do - grow; - inc(posn,j); - if (posn>count) then - count:=posn; - end; - end; - - procedure tdynamicarray.seek(i:longint); - begin - while limitcount) then - count:=posn; - end; - - procedure tdynamicarray.write(var d;len:longint); - begin - while limit<(posn+len) do - grow; - move(d,data[posn*elemlen],len*elemlen); - inc(posn,len); - if (posn>count) then - count:=posn; - end; - - procedure tdynamicarray.read(var d;len:longint); - begin - move(data[posn*elemlen],d,len*elemlen); - inc(posn,len); - if (posn>count) then - count:=posn; - end; - - procedure tdynamicarray.writepos(pos:longint;var d;len:longint); - begin - while limit<(pos+len) do - grow; - move(d,data[pos*elemlen],len*elemlen); - posn:=pos+len; - if (posn>count) then - count:=posn; - end; - - procedure tdynamicarray.readpos(pos:longint;var d;len:longint); - begin - while limit<(pos+len) do - grow; - move(data[pos*elemlen],d,len*elemlen); - posn:=pos+len; - if (posn>count) then - count:=posn; - end; - - destructor tdynamicarray.done; - begin - if assigned(data) then - freemem(data,size); - end; - - -{**************************************************************************** - tindexarray - ****************************************************************************} - - - constructor tindexarray.init(Agrowsize:longint); - begin - growsize:=Agrowsize; - size:=0; - count:=0; - data:=nil; - first:=nil; - end; - - destructor tindexarray.done; - begin - if assigned(data) then - begin - clear; - freemem(data,size*4); - data:=nil; - end; - end; - - function tindexarray.search(nr:longint):Pnamedindexobject; - begin - if nr<=count then - search:=data^[nr] - else - search:=nil; - end; - - - procedure tindexarray.clear; - var - i : longint; - begin - for i:=1 to count do - if assigned(data^[i]) then - begin - dispose(data^[i],done); - data^[i]:=nil; - end; - count:=0; - first:=nil; - end; - - - procedure tindexarray.foreach(proc2call : Tnamedindexcallback); - var - i : longint; - begin - for i:=1 to count do - if assigned(data^[i]) then - proc2call(data^[i]); - end; - - - procedure tindexarray.grow(gsize:longint); - var - osize : longint; - odata : Pnamedindexobjectarray; - begin - osize:=size; - odata:=data; - inc(size,gsize); - getmem(data,size*4); - if assigned(odata) then - begin - move(odata^,data^,osize*4); - freemem(odata,osize*4); - end; - fillchar(data^[osize+1],gsize*4,0); - end; - - - procedure tindexarray.deleteindex(p:Pnamedindexobject); - var - i : longint; - begin - i:=p^.indexnr; - { update counter } - if i=count then - dec(count); - { update linked list } - while (i>0) do - begin - dec(i); - if (i>0) and assigned(data^[i]) then - begin - data^[i]^.next:=data^[p^.indexnr]^.next; - break; - end; - end; - if i=0 then - first:=p^.next; - data^[p^.indexnr]:=nil; - { clear entry } - p^.indexnr:=-1; - p^.next:=nil; - end; - - - procedure tindexarray.delete(p:Pnamedindexobject); - begin - deleteindex(p); - dispose(p,done); - p:=nil; - end; - - - procedure tindexarray.insert(p:Pnamedindexobject); - var - i : longint; - begin - if p^.indexnr=-1 then - begin - inc(count); - p^.indexnr:=count; - end; - if p^.indexnr>count then - count:=p^.indexnr; - if count>size then - grow(((count div growsize)+1)*growsize); - data^[p^.indexnr]:=p; - { update linked list backward } - i:=p^.indexnr; - while (i>0) do - begin - dec(i); - if (i>0) and assigned(data^[i]) then - begin - data^[i]^.next:=p; - break; - end; - end; - if i=0 then - first:=p; - { update linked list forward } - i:=p^.indexnr; - while (i<=count) do - begin - inc(i); - if (i<=count) and assigned(data^[i]) then - begin - p^.next:=data^[i]; - exit; - end; - end; - if i>count then - p^.next:=nil; - 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); - end; - write_data(l,sizeof(longint)); - end; - - procedure tbufferedfile.write_word(w : word); - - begin - if change_endian then - begin - w:=swap(w); - end; - 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. -{ +{ + $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; + +{ define OLDSPEEDVALUE} + + interface + + uses + strings +{$ifndef linux} + ,dos +{$else} + ,linux +{$endif} + ; + + const + { the real size will be [-hasharray..hasharray] ! } +{$ifdef TP} + hasharraysize = 127; +{$else} + hasharraysize = 2047; +{$endif} + + type + pstring = ^string; + +{$ifdef TP} + { redeclare dword only in case of emergency, some small things + of the compiler won't work then correctly (FK) + } + dword = longint; +{$endif TP} + + 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; + function getcopy:plinkedlist_item;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); + + procedure concatlistcopy(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; + + + Pnamedindexobject=^Tnamedindexobject; + Tnamedindexobject=object + indexnr : longint; + _name : Pstring; + next, + left,right : Pnamedindexobject; + speedvalue : longint; + constructor init; + constructor initname(const n:string); + destructor done;virtual; + procedure setname(const n:string);virtual; + function name:string;virtual; + end; + + Pdictionaryhasharray=^Tdictionaryhasharray; + Tdictionaryhasharray=array[-hasharraysize..hasharraysize] of Pnamedindexobject; + + Tnamedindexcallback = procedure(p:Pnamedindexobject); + + Pdictionary=^Tdictionary; + Tdictionary=object + noclear : boolean; + replace_existing : boolean; + constructor init; + destructor done;virtual; + procedure usehash; + procedure clear; + function delete(const s:string):Pnamedindexobject; + function empty:boolean; + procedure foreach(proc2call:Tnamedindexcallback); + function insert(obj:Pnamedindexobject):Pnamedindexobject; + function rename(const olds,news : string):Pnamedindexobject; + function search(const s:string):Pnamedindexobject; + function speedsearch(const s:string;speedvalue:longint):Pnamedindexobject; + private + root : Pnamedindexobject; + hasharray : Pdictionaryhasharray; + procedure cleartree(obj:Pnamedindexobject); + function insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject; + procedure inserttree(currtree,currroot:Pnamedindexobject); + end; + + pdynamicarray = ^tdynamicarray; + tdynamicarray = object + posn, + count, + limit, + elemlen, + growcount : longint; + data : pchar; + constructor init(Aelemlen,Agrow:longint); + destructor done; + function size:longint; + function usedsize:longint; + procedure grow; + procedure align(i:longint); + procedure seek(i:longint); + procedure write(var d;len:longint); + procedure read(var d;len:longint); + procedure writepos(pos:longint;var d;len:longint); + procedure readpos(pos:longint;var d;len:longint); + end; + + tindexobjectarray=array[1..16000] of Pnamedindexobject; + Pnamedindexobjectarray=^tindexobjectarray; + + pindexarray=^tindexarray; + tindexarray=object + first : Pnamedindexobject; + count : longint; + constructor init(Agrowsize:longint); + destructor done; + procedure clear; + procedure foreach(proc2call : Tnamedindexcallback); + procedure deleteindex(p:Pnamedindexobject); + procedure delete(p:Pnamedindexobject); + procedure insert(p:Pnamedindexobject); + function search(nr:longint):Pnamedindexobject; + private + growsize, + size : longint; + data : Pnamedindexobjectarray; + procedure grow(gsize:longint); + 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} + + function getspeedvalue(const s : string) : longint; + + { 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 + +{$ifndef OLDSPEEDVALUE} + +{***************************************************************************** + 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 GetSpeedValue(Const s:String):longint; +var + i,InitCrc : longint; +begin + if Crc32Tbl[1]=0 then + MakeCrc32Tbl; + InitCrc:=$ffffffff; + for i:=1to Length(s) do + InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8); + GetSpeedValue:=InitCrc; +end; + +{$ifdef Range_check_on} + {$R+} + {$undef Range_check_on} +{$endif Range_check_on} + +{$else} + +{$ifndef TP} + function getspeedvalue(const s : string) : longint; + var + p1,p2:^byte; + i : longint; + + begin + p1:=@s; + longint(p2):=longint(p1)+p1^+1; + inc(longint(p1)); + i:=0; + while p1<>p2 do + begin + i:=i + ord(p1^); + inc(longint(p1)); + end; + getspeedvalue:=i; + 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 + ord(p1^); + inc(p1); + end; + getspeedvalue:=l; + end; +{$endif} + +{$endif OLDSPEEDVALUE} + + + 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 + newnode : pstringitem; +begin + if first=nil then + begin + Get:=''; + exit; + end; + Get:=first^.data^; + stringdispose(first^.data); + newnode:=first; + first:=first^.next; + dispose(newnode); +end; + + +procedure TStringQueue.Insert(const s:string); +var + newnode : pstringitem; +begin + new(newnode); + newnode^.next:=first; + newnode^.data:=stringdup(s); + first:=newnode; + if last=nil then + last:=newnode; +end; + + +procedure TStringQueue.Concat(const s:string); +var + newnode : pstringitem; +begin + new(newnode); + newnode^.next:=nil; + newnode^.data:=stringdup(s); + if first=nil then + first:=newnode + else + last^.next:=newnode; + last:=newnode; +end; + + +procedure TStringQueue.Clear; +var + newnode : pstringitem; +begin + while (first<>nil) do + begin + newnode:=first; + stringdispose(first^.data); + first:=first^.next; + dispose(newnode); + 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 + newnode : pstringitem; + begin + if not(doubles) then + begin + newnode:=root; + while assigned(newnode) do + begin + if newnode^.data^=s then exit; + newnode:=newnode^.next; + end; + end; + new(newnode); + newnode^.next:=nil; + newnode^.data:=stringdup(s); + if root=nil then root:=newnode + else last^.next:=newnode; + last:=newnode; + end; + + + procedure tstringcontainer.insert_with_tokeninfo(const s : string; const file_info : tfileposinfo); + var + newnode : pstringitem; + begin + if not(doubles) then + begin + newnode:=root; + while assigned(newnode) do + begin + if newnode^.data^=s then exit; + newnode:=newnode^.next; + end; + end; + new(newnode); + newnode^.next:=nil; + newnode^.data:=stringdup(s); + newnode^.fileinfo:=file_info; + if root=nil then root:=newnode + else last^.next:=newnode; + last:=newnode; + end; + + + procedure tstringcontainer.clear; + var + newnode : pstringitem; + begin + newnode:=root; + while assigned(newnode) do + begin + stringdispose(newnode^.data); + root:=newnode^.next; + dispose(newnode); + newnode:=root; + end; + last:=nil; + root:=nil; + end; + + + function tstringcontainer.get : string; + var + newnode : pstringitem; + begin + if root=nil then + get:='' + else + begin + get:=root^.data^; + newnode:=root; + root:=root^.next; + stringdispose(newnode^.data); + dispose(newnode); + end; + end; + + + function tstringcontainer.get_with_tokeninfo(var file_info : tfileposinfo) : string; + var + newnode : 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^; + newnode:=root; + root:=root^.next; + stringdispose(newnode^.data); + file_info:=newnode^.fileinfo; + dispose(newnode); + end; + end; + + + function tstringcontainer.find(const s:string):boolean; + var + newnode : pstringitem; + begin + find:=false; + newnode:=root; + while assigned(newnode) do + begin + if newnode^.data^=s then + begin + find:=true; + exit; + end; + newnode:=newnode^.next; + end; + end; + + +{**************************************************************************** + TLINKEDLIST_ITEM + ****************************************************************************} + + constructor tlinkedlist_item.init; + begin + previous:=nil; + next:=nil; + end; + + + destructor tlinkedlist_item.done; + begin + end; + + + function tlinkedlist_item.getcopy:plinkedlist_item; + var + l : longint; + p : plinkedlist_item; + begin + l:=sizeof(self); + getmem(p,l); + move(self,p^,l); + getcopy:=p; + 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 + newnode : plinkedlist_item; + begin + newnode:=first; + while assigned(newnode) do + begin + first:=newnode^.next; + dispose(newnode,done); + newnode:=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 + if not(assigned(first)) then + begin + first:=p; + p^.previous:=nil; + p^.next:=nil; + end + else + begin + last^.next:=p; + p^.previous:=last; + p^.next:=nil; + end; + last:=p; + end; + + + procedure tlinkedlist.insert(p : plinkedlist_item); + begin + if not(assigned(first)) then + begin + last:=p; + p^.previous:=nil; + p^.next:=nil; + end + else + begin + first^.previous:=p; + p^.previous:=nil; + p^.next:=first; + 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; + + + procedure tlinkedlist.concatlistcopy(p : plinkedlist); + var + newnode,newnode2 : plinkedlist_item; + begin + newnode:=p^.first; + while assigned(newnode) do + begin + newnode2:=newnode^.getcopy; + if assigned(newnode2) then + begin + if not(assigned(first)) then + begin + first:=newnode2; + newnode2^.previous:=nil; + newnode2^.next:=nil; + end + else + begin + last^.next:=newnode2; + newnode2^.previous:=last; + newnode2^.next:=nil; + end; + last:=newnode2; + end; + newnode:=newnode^.next; + end; + end; + + function tlinkedlist.empty:boolean; + begin + empty:=(first=nil); + end; + + +{**************************************************************************** + Tnamedindexobject + ****************************************************************************} + +constructor Tnamedindexobject.init; +begin + { index } + indexnr:=-1; + next:=nil; + { dictionary } + left:=nil; + right:=nil; + _name:=nil; + speedvalue:=-1; +end; + +constructor Tnamedindexobject.initname(const n:string); +begin + { index } + indexnr:=-1; + next:=nil; + { dictionary } + left:=nil; + right:=nil; + speedvalue:=-1; + _name:=stringdup(n); +end; + +destructor Tnamedindexobject.done; +begin + stringdispose(_name); +end; + +procedure Tnamedindexobject.setname(const n:string); +begin + if speedvalue=-1 then + begin + if assigned(_name) then + stringdispose(_name); + _name:=stringdup(n); + end; +end; + +function Tnamedindexobject.name:string; +begin + if assigned(_name) then + name:=_name^ + else + name:=''; +end; + + +{**************************************************************************** + TDICTIONARY +****************************************************************************} + + constructor Tdictionary.init; + begin + root:=nil; + hasharray:=nil; + noclear:=false; + replace_existing:=false; + end; + + + procedure Tdictionary.usehash; + begin + if not(assigned(root)) and + not(assigned(hasharray)) then + begin + new(hasharray); + fillchar(hasharray^,sizeof(hasharray^),0); + end; + end; + + + destructor Tdictionary.done; + begin + if not noclear then + clear; + if assigned(hasharray) then + dispose(hasharray); + end; + + + procedure Tdictionary.cleartree(obj:Pnamedindexobject); + begin + if assigned(obj^.left) then + cleartree(obj^.left); + if assigned(obj^.right) then + cleartree(obj^.right); + dispose(obj,done); + obj:=nil; + end; + + + procedure Tdictionary.clear; + var + w : longint; + begin + if assigned(root) then + cleartree(root); + if assigned(hasharray) then + for w:=-hasharraysize to hasharraysize do + if assigned(hasharray^[w]) then + cleartree(hasharray^[w]); + end; + + function Tdictionary.delete(const s:string):Pnamedindexobject; + + var p,speedvalue:longint; + n:Pnamedindexobject; + + procedure insert_right_bottom(var root,Atree:Pnamedindexobject); + + begin + while root^.right<>nil do + root:=root^.right; + root^.right:=Atree; + end; + + function delete_from_tree(root:Pnamedindexobject):Pnamedindexobject; + + type leftright=(left,right); + + var lr:leftright; + oldroot:Pnamedindexobject; + + begin + oldroot:=nil; + while (root<>nil) and (root^.speedvalue<>speedvalue) do + begin + oldroot:=root; + if speedvaluenil) and (root^._name^<>s) do + begin + oldroot:=root; + if snil then + begin + {Now the node pointing to root must point to the left + subtree of root. The right subtree of root must be + connected to the right bottom of the left subtree.} + if lr=left then + oldroot^.left:=root^.left + else + oldroot^.right:=root^.left; + if root^.right<>nil then + insert_right_bottom(root^.left,root^.right); + end + else + {There is no left subtree. So we can just replace the node to + delete with the right subtree.} + if lr=left then + oldroot^.left:=root^.right + else + oldroot^.right:=root^.right; + delete_from_tree:=root; + end; + + begin + speedvalue:=getspeedvalue(s); + n:=root; + if assigned(hasharray) then + begin + {First, check if the node to delete directly located under + the hasharray.} + p:=speedvalue mod hasharraysize; + n:=hasharray^[p]; + if (n<>nil) and (n^.speedvalue=speedvalue) and + (n^._name^=s) then + begin + {The node to delete is directly located under the + hasharray. Make the hasharray point to the left + subtree of the node and place the right subtree on + the right-bottom of the left subtree.} + if n^.left<>nil then + begin + hasharray^[p]:=n^.left; + if n^.right<>nil then + insert_right_bottom(n^.left,n^.right); + end + else + hasharray^[p]:=n^.right; + delete:=n; + exit; + end; + end + else + begin + {First check if the node to delete is the root.} + if (root<>nil) and (n^.speedvalue=speedvalue) + and (n^._name^=s) then + begin + if n^.left<>nil then + begin + root:=n^.left; + if n^.right<>nil then + insert_right_bottom(n^.left,n^.right); + end + else + root:=n^.right; + delete:=n; + exit; + end; + end; + delete:=delete_from_tree(n); + end; + + function Tdictionary.empty:boolean; + var + w : longint; + begin + if assigned(hasharray) then + begin + empty:=false; + for w:=-hasharraysize to hasharraysize do + if assigned(hasharray^[w]) then + exit; + empty:=true; + end + else + empty:=(root=nil); + end; + + + procedure Tdictionary.foreach(proc2call:Tnamedindexcallback); + + procedure a(p:Pnamedindexobject); + 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:=-hasharraysize to hasharraysize do + if assigned(hasharray^[i]) then + a(hasharray^[i]); + end + else + if assigned(root) then + a(root); + end; + + + function Tdictionary.insert(obj:Pnamedindexobject):Pnamedindexobject; + begin + obj^.speedvalue:=getspeedvalue(obj^._name^); + if assigned(hasharray) then + insert:=insertnode(obj,hasharray^[obj^.speedvalue mod hasharraysize]) + else + insert:=insertnode(obj,root); + end; + + + function tdictionary.insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject; + var + s1,s2:^string; + begin + if currnode=nil then + begin + currnode:=newnode; + insertnode:=currnode; + end + { first check speedvalue, to allow a fast insert } + else + if currnode^.speedvalue>newnode^.speedvalue then + insertnode:=insertnode(newnode,currnode^.right) + else + if currnode^.speedvalues2^ then + begin + dispose(s2); + dispose(s1); + insertnode:=insertnode(newnode,currnode^.right); + end + else + if s1^hp^.speedvalue then + begin + lasthp:=hp; + hp:=hp^.left + end + else + if spdvalhp^.name then + begin + lasthp:=hp; + hp:=hp^.left + end + else + begin + lasthp:=hp; + hp:=hp^.right; + end; + end; + end; + end; + + + function Tdictionary.search(const s:string):Pnamedindexobject; + begin + search:=speedsearch(s,getspeedvalue(s)); + end; + + + function Tdictionary.speedsearch(const s:string;speedvalue:longint):Pnamedindexobject; + var + newnode:Pnamedindexobject; + begin + if assigned(hasharray) then + newnode:=hasharray^[speedvalue mod hasharraysize] + else + newnode:=root; + while assigned(newnode) do + begin + if speedvalue>newnode^.speedvalue then + newnode:=newnode^.left + else + if speedvaluenewnode^._name^ then + newnode:=newnode^.left + else + newnode:=newnode^.right; + end; + end; + speedsearch:=nil; + end; + + +{**************************************************************************** + tdynamicarray +****************************************************************************} + + constructor tdynamicarray.init(Aelemlen,Agrow:longint); + begin + posn:=0; + count:=0; + limit:=0; + data:=nil; + elemlen:=Aelemlen; + growcount:=Agrow; + grow; + end; + + function tdynamicarray.size:longint; + begin + size:=limit*elemlen; + end; + + function tdynamicarray.usedsize:longint; + begin + usedsize:=count*elemlen; + end; + + procedure tdynamicarray.grow; + var + osize : longint; + odata : pchar; + begin + osize:=size; + odata:=data; + inc(limit,growcount); + getmem(data,size); + if assigned(odata) then + begin + move(odata^,data^,osize); + freemem(odata,osize); + end; + fillchar(data[osize],growcount*elemlen,0); + end; + + procedure tdynamicarray.align(i:longint); + var + j : longint; + begin + j:=(posn*elemlen mod i); + if j<>0 then + begin + j:=i-j; + while limit<(posn+j) do + grow; + inc(posn,j); + if (posn>count) then + count:=posn; + end; + end; + + procedure tdynamicarray.seek(i:longint); + begin + while limitcount) then + count:=posn; + end; + + procedure tdynamicarray.write(var d;len:longint); + begin + while limit<(posn+len) do + grow; + move(d,data[posn*elemlen],len*elemlen); + inc(posn,len); + if (posn>count) then + count:=posn; + end; + + procedure tdynamicarray.read(var d;len:longint); + begin + move(data[posn*elemlen],d,len*elemlen); + inc(posn,len); + if (posn>count) then + count:=posn; + end; + + procedure tdynamicarray.writepos(pos:longint;var d;len:longint); + begin + while limit<(pos+len) do + grow; + move(d,data[pos*elemlen],len*elemlen); + posn:=pos+len; + if (posn>count) then + count:=posn; + end; + + procedure tdynamicarray.readpos(pos:longint;var d;len:longint); + begin + while limit<(pos+len) do + grow; + move(data[pos*elemlen],d,len*elemlen); + posn:=pos+len; + if (posn>count) then + count:=posn; + end; + + destructor tdynamicarray.done; + begin + if assigned(data) then + freemem(data,size); + end; + + +{**************************************************************************** + tindexarray + ****************************************************************************} + + + constructor tindexarray.init(Agrowsize:longint); + begin + growsize:=Agrowsize; + size:=0; + count:=0; + data:=nil; + first:=nil; + end; + + destructor tindexarray.done; + begin + if assigned(data) then + begin + clear; + freemem(data,size*4); + data:=nil; + end; + end; + + function tindexarray.search(nr:longint):Pnamedindexobject; + begin + if nr<=count then + search:=data^[nr] + else + search:=nil; + end; + + + procedure tindexarray.clear; + var + i : longint; + begin + for i:=1 to count do + if assigned(data^[i]) then + begin + dispose(data^[i],done); + data^[i]:=nil; + end; + count:=0; + first:=nil; + end; + + + procedure tindexarray.foreach(proc2call : Tnamedindexcallback); + var + i : longint; + begin + for i:=1 to count do + if assigned(data^[i]) then + proc2call(data^[i]); + end; + + + procedure tindexarray.grow(gsize:longint); + var + osize : longint; + odata : Pnamedindexobjectarray; + begin + osize:=size; + odata:=data; + inc(size,gsize); + getmem(data,size*4); + if assigned(odata) then + begin + move(odata^,data^,osize*4); + freemem(odata,osize*4); + end; + fillchar(data^[osize+1],gsize*4,0); + end; + + + procedure tindexarray.deleteindex(p:Pnamedindexobject); + var + i : longint; + begin + i:=p^.indexnr; + { update counter } + if i=count then + dec(count); + { update linked list } + while (i>0) do + begin + dec(i); + if (i>0) and assigned(data^[i]) then + begin + data^[i]^.next:=data^[p^.indexnr]^.next; + break; + end; + end; + if i=0 then + first:=p^.next; + data^[p^.indexnr]:=nil; + { clear entry } + p^.indexnr:=-1; + p^.next:=nil; + end; + + + procedure tindexarray.delete(p:Pnamedindexobject); + begin + deleteindex(p); + dispose(p,done); + p:=nil; + end; + + + procedure tindexarray.insert(p:Pnamedindexobject); + var + i : longint; + begin + if p^.indexnr=-1 then + begin + inc(count); + p^.indexnr:=count; + end; + if p^.indexnr>count then + count:=p^.indexnr; + if count>size then + grow(((count div growsize)+1)*growsize); + data^[p^.indexnr]:=p; + { update linked list backward } + i:=p^.indexnr; + while (i>0) do + begin + dec(i); + if (i>0) and assigned(data^[i]) then + begin + data^[i]^.next:=p; + break; + end; + end; + if i=0 then + first:=p; + { update linked list forward } + i:=p^.indexnr; + while (i<=count) do + begin + inc(i); + if (i<=count) and assigned(data^[i]) then + begin + p^.next:=data^[i]; + exit; + end; + end; + if i>count then + p^.next:=nil; + 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); + end; + write_data(l,sizeof(longint)); + end; + + procedure tbufferedfile.write_word(w : word); + + begin + if change_endian then + begin + w:=swap(w); + end; + 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.35 1999-06-23 11:07:23 daniel + Revision 1.36 1999-06-23 11:13:20 peter + * fixed linebreak + + Revision 1.35 1999/06/23 11:07:23 daniel * Tdictionary.delete - - Revision 1.33.2.1 1999/06/15 10:12:22 peter - * fixed inserttree which didn't reset left,right - - Revision 1.33 1999/05/31 23:33:21 peter - * fixed tdictionary rename which didn't reset left,right when - reinserting - - Revision 1.32 1999/05/27 19:44:23 peter - * removed oldasm - * plabel -> pasmlabel - * -a switches to source writing automaticly - * assembler readers OOPed - * asmsymbol automaticly external - * jumptables and other label fixes for asm readers - - Revision 1.31 1999/05/21 13:54:59 peter - * NEWLAB for label as symbol - - Revision 1.30 1999/05/21 10:38:59 peter - * fixed deleteindex which didn't reset indexnr and set first wrong - - Revision 1.29 1999/05/08 19:47:27 peter - * indexarray.delete resets pointer after dispose - - Revision 1.28 1999/05/05 10:05:48 florian - * a delphi compiled compiler recompiles ppc - - Revision 1.27 1999/05/05 09:19:03 florian - * more fixes to get it with delphi running - - Revision 1.26 1999/04/21 09:43:31 peter - * storenumber works - * fixed some typos in double_checksum - + incompatible types type1 and type2 message (with storenumber) - - Revision 1.25 1999/04/15 10:01:44 peter - * small update for storenumber - - Revision 1.24 1999/04/14 09:14:47 peter - * first things to store the symbol/def number in the ppu - - Revision 1.23 1999/04/08 20:59:39 florian - * fixed problem with default properties which are a class - * case bug (from the mailing list with -O2) fixed, the - distance of the case labels can be greater than the positive - range of a longint => it is now a dword for fpc - - Revision 1.22 1999/03/31 13:55:10 peter - * assembler inlining working for ag386bin - - Revision 1.21 1999/03/19 16:35:29 pierre - * Tnamedindexobject done also removed left and right - - Revision 1.20 1999/03/18 20:30:45 peter - + .a writer - - 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 -} + + Revision 1.33.2.1 1999/06/15 10:12:22 peter + * fixed inserttree which didn't reset left,right + + Revision 1.33 1999/05/31 23:33:21 peter + * fixed tdictionary rename which didn't reset left,right when + reinserting + + Revision 1.32 1999/05/27 19:44:23 peter + * removed oldasm + * plabel -> pasmlabel + * -a switches to source writing automaticly + * assembler readers OOPed + * asmsymbol automaticly external + * jumptables and other label fixes for asm readers + + Revision 1.31 1999/05/21 13:54:59 peter + * NEWLAB for label as symbol + + Revision 1.30 1999/05/21 10:38:59 peter + * fixed deleteindex which didn't reset indexnr and set first wrong + + Revision 1.29 1999/05/08 19:47:27 peter + * indexarray.delete resets pointer after dispose + + Revision 1.28 1999/05/05 10:05:48 florian + * a delphi compiled compiler recompiles ppc + + Revision 1.27 1999/05/05 09:19:03 florian + * more fixes to get it with delphi running + + Revision 1.26 1999/04/21 09:43:31 peter + * storenumber works + * fixed some typos in double_checksum + + incompatible types type1 and type2 message (with storenumber) + + Revision 1.25 1999/04/15 10:01:44 peter + * small update for storenumber + + Revision 1.24 1999/04/14 09:14:47 peter + * first things to store the symbol/def number in the ppu + + Revision 1.23 1999/04/08 20:59:39 florian + * fixed problem with default properties which are a class + * case bug (from the mailing list with -O2) fixed, the + distance of the case labels can be greater than the positive + range of a longint => it is now a dword for fpc + + Revision 1.22 1999/03/31 13:55:10 peter + * assembler inlining working for ag386bin + + Revision 1.21 1999/03/19 16:35:29 pierre + * Tnamedindexobject done also removed left and right + + Revision 1.20 1999/03/18 20:30:45 peter + + .a writer + + 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 +}