* Use objects unit.

compiler/new/cobjects.pas

@@ -0,0 +1,2052 @@
+{
+    $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,objects
+{$ifndef linux}
+       ,dos
+{$else}
+       ,linux
+{$endif}
+      ;
+
+    const
+       { the real size will be [-hasharray..hasharray] ! }
+{$ifdef TP}
+       hasharraysize = 127;
+{$else}
+       hasharraysize = 2047;
+{$endif}
+
+
+{$ifdef TP}
+       { redeclare dword only in case of emergency, some small things
+         of the compiler won't work then correctly (FK)
+       }
+type   dword = longint;
+{$endif TP}
+
+type   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(Tobject)
+          next,previous : plinkedlist_item;
+          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(Tobject)
+          first,last : plinkedlist_item;
+          destructor done;virtual;
+
+          { 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(Tobject)
+         first,last : PStringItem;
+         destructor Done;virtual;
+         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(Tobject)
+          root,
+          last    : pstringitem;
+          doubles : boolean;  { if this is set to true, doubles are allowed }
+          constructor init;
+          constructor init_no_double;
+          destructor done;virtual;
+
+          { 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(Tobject)
+         indexnr    : longint;
+         _name      : Pstring;
+         next,
+         left,right : Pnamedindexobject;
+         speedvalue : longint;
+         constructor init(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(Tobject)
+         replace_existing : boolean;
+         constructor init;
+         destructor  done;virtual;
+         procedure usehash;
+         procedure clear;
+         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;
+         function delete(const s:string):Pnamedindexobject;
+         procedure inserttree(currtree,currroot:Pnamedindexobject);
+       end;
+
+       pdynamicarray = ^tdynamicarray;
+       tdynamicarray = object(Tobject)
+         posn,
+         count,
+         limit,
+         elemlen,
+         growcount : longint;
+         data      : pchar;
+         constructor init(Aelemlen,Agrow:longint);
+         destructor  done;virtual;
+         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;
+
+{$ifdef BUFFEREDFILE}
+       { this is implemented to allow buffered binary I/O }
+       pbufferedfile = ^tbufferedfile;
+       tbufferedfile = object(Tobject)
+           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
+****************************************************************************}
+
+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
+         inherited init;
+         doubles:=true;
+      end;
+
+
+    constructor tstringcontainer.init_no_double;
+      begin
+         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
+ ****************************************************************************}
+
+
+    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
+         inherited init;
+         str:=stringdup(s);
+      end;
+
+
+    destructor tstring_item.done;
+      begin
+         stringdispose(str);
+         inherited done;
+      end;
+
+
+{****************************************************************************
+                               TLINKEDLIST
+ ****************************************************************************}
+
+
+    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(const n:string);
+begin
+  inherited init;
+  { index }
+  indexnr:=-1;
+  { dictionary }
+  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
+        inherited init;
+        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
+        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.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^.speedvalue<newnode^.speedvalue then
+          insertnode:=insertnode(newnode,currnode^.left)
+        else
+         begin
+           new(s1);
+           new(s2);
+           s1^:=currnode^._name^;
+    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 speedvalue<root^.speedvalue then
+                        begin
+                            root:=root^.right;
+                            lr:=right;
+                        end
+                    else
+                        begin
+                            root:=root^.left;
+                            lr:=left;
+                        end;
+                end;
+            while (root<>nil) and (root^._name^<>s) do
+                begin
+                    oldroot:=root;
+                    if s<root^._name^ then
+                        begin
+                            root:=root^.right;
+                            lr:=right;
+                        end
+                    else
+                        begin
+                            root:=root^.left;
+                            lr:=left;
+                        end;
+                end;
+            if (oldroot=nil) or (root=nil) then
+                runerror(218); {Internalerror is not available...}
+            if root^.left<>nil 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;
+           s2^:=newnode^._name^;
+           if s1^>s2^ then
+            begin
+              dispose(s2);
+              dispose(s1);
+              insertnode:=insertnode(newnode,currnode^.right);
+            end
+           else
+            if s1^<s2^ then
+             begin
+               dispose(s2);
+               dispose(s1);
+               insertnode:=insertnode(newnode,currnode^.left);
+             end
+           else
+            begin
+              dispose(s2);
+              dispose(s1);
+              if replace_existing and
+                 assigned(currnode) then
+                begin
+                  newnode^.left:=currnode^.left;
+                  newnode^.right:=currnode^.right;
+                  currnode:=newnode;
+                  insertnode:=newnode;
+                end
+              else
+               insertnode:=currnode;
+             end;
+         end;
+      end;
+
+
+    procedure tdictionary.inserttree(currtree,currroot:Pnamedindexobject);
+      begin
+        if assigned(currtree) then
+         begin
+           inserttree(currtree^.left,currroot);
+           inserttree(currtree^.right,currroot);
+           currtree^.right:=nil;
+           currtree^.left:=nil;
+           insertnode(currtree,currroot);
+         end;
+      end;
+
+
+    function tdictionary.rename(const olds,news : string):Pnamedindexobject;
+      var
+        spdval : longint;
+        lasthp,
+        hp,hp2,hp3 : Pnamedindexobject;
+      begin
+        spdval:=getspeedvalue(olds);
+        if assigned(hasharray) then
+         hp:=hasharray^[spdval mod hasharraysize]
+        else
+         hp:=root;
+        lasthp:=nil;
+        while assigned(hp) do
+          begin
+            if spdval>hp^.speedvalue then
+             begin
+               lasthp:=hp;
+               hp:=hp^.left
+             end
+            else
+             if spdval<hp^.speedvalue then
+              begin
+                lasthp:=hp;
+                hp:=hp^.right
+              end
+            else
+             begin
+               if (hp^.name=olds) then
+                begin
+                  { get in hp2 the replacer for the root or hasharr }
+                  hp2:=hp^.left;
+                  hp3:=hp^.right;
+                  if not assigned(hp2) then
+                   begin
+                     hp2:=hp^.right;
+                     hp3:=hp^.left;
+                   end;
+                  { remove entry from the tree }
+                  if assigned(lasthp) then
+                   begin
+                     if lasthp^.left=hp then
+                      lasthp^.left:=hp2
+                     else
+                      lasthp^.right:=hp2;
+                   end
+                  else
+                   begin
+                     if assigned(hasharray) then
+                      hasharray^[spdval mod hasharraysize]:=hp2
+                     else
+                      root:=hp2;
+                   end;
+                  { reinsert the hp3 in the tree from hp2 }
+                  inserttree(hp3,hp2);
+                  { reset node with new values }
+                  stringdispose(hp^._name);
+                  hp^._name:=stringdup(news);
+                  hp^.speedvalue:=getspeedvalue(news);
+                  hp^.left:=nil;
+                  hp^.right:=nil;
+                  { reinsert }
+                  if assigned(hasharray) then
+                   rename:=insertnode(hp,hasharray^[hp^.speedvalue mod hasharraysize])
+                  else
+                   rename:=insertnode(hp,root);
+                  exit;
+                end
+               else
+           currtree^.right:=nil;
+           currtree^.left:=nil;
+                if olds>hp^.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 speedvalue<newnode^.speedvalue then
+             newnode:=newnode^.right
+           else
+            begin
+              if (newnode^._name^=s) then
+               begin
+                 speedsearch:=newnode;
+                 exit;
+               end
+              else
+               if s>newnode^._name^ then
+                newnode:=newnode^.left
+              else
+               newnode:=newnode^.right;
+            end;
+         end;
+        speedsearch:=nil;
+      end;
+
+
+{****************************************************************************
+                                tdynamicarray
+****************************************************************************}
+
+    constructor tdynamicarray.init(Aelemlen,Agrow:longint);
+      begin
+        inherited init;
+        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 limit<i do
+         grow;
+        posn:=i;
+        if (posn>count) 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;
+
+{$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
+         inherited init;
+         assign(f,filename);
+         bufsize:=_bufsize;
+         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.1  1999-08-05 20:49:15  daniel
+  * Use objects unit.
+
+  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.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
+}