Power-Programmierung/CD1.mdf/pascal/library/dos/arrays/larry/larry.pas

Pascal/Delphi Source File | 1990-07-15 | 17.1 KB | 573 lines

(* The compilersetting with the word OFF or ON after should be
   left in that state *)

{$D+} { Debug information }
{$L+} { Local symbols }

{$A+} { Word align in this module for speed }
{$B-} { ShortCurcit boolean evaluation ON (- state) }
{$F-} { Far call OFF }
{$I-} { I/O Checking OFF }
{$O-} { Overlay OFF }

{$R-} { RangeCheck }
{$S-} { StackCheck }
{$V+} { Varcheck }

(* There is NO floating point in this module so leave the following OFF *)
{$E-} { Coprocessor emulation OFF }
{$N-} { Software floatingpoint OFF}

Unit Larry;

Interface

Const NoHandle=-1;
      DefaultBuckets=16;

Type IndexType=LongInt;
     ArrayHandle=Integer;
     WhenClose=(Purge,NoPurge);
     WhenOpen=(Reuse,Create);
     Modes=(ReadWrite,NoRead,NoWrite);

Function OpenArray(FName:String;
                   EntrySize:Word;
                   NumEntries:IndexType;
                   NumBuckets:Integer;
                   PurgeFlag:WhenClose;
                   ReuseFlag:WhenOpen;
                   Mode:Modes):ArrayHandle;

Function Larray(EntrySize:Word;NumEntries:Indextype):ArrayHandle;

Function Darray(FName:String;EntrySize:Word;NumEntries:Indextype):ArrayHandle;

(* OpenArray generates the internal structures and prepares the file for
   access and Larray and Darray is a simpler interface to OpenArray
   generating filename and selecting stacksize and other defaults *)

Procedure CloseArray(Handle:ArrayHandle);

(* Closearray deletes the internal structs and removes the
   arr from mem/disk*)


Procedure UnFreeze(Handle:ArrayHandle;Entry:IndexType);

(* Removes a lock *)

Procedure FlushArray(Handle:ArrayHandle);

(* Flushes all data for an array to disk and frees the stack entries *)

Procedure FlushAllArrays;

(* Flushes all open arrays *)

Function GetPointer(Handle:ArrayHandle;Entry:IndexType):Pointer;

(* GetPointer does all the nitty_gritty for this package, reading/writing
   data updating buckets et.c. *)

Function Freeze(Handle:ArrayHandle;Entry:IndexType):Pointer;

(* Locks an entry in ram, same as getpointer *)

Procedure WriteMode(Handle:ArrayHandle;Flag:Modes);
(* Flags that we are initializing the array and that it shall assume
   all entries accessed as NEW *)

Implementation

Uses DOS;

Const MaxArraysOpen=7; (* Max number of arrays open at one time *)

Type EntryType=Record
                 Locked:Boolean;      (* Flag frozen entry *)
                 ItemInBuf:IndexType; (* Item in this buffer *)
                 Data:Pointer         (* Pointer to the buffer *)
               end;

Const BucketMax=(32768 Div SizeOf(EntryType));

Type  Stack=Array [0..BucketMax] Of EntryType;

     ArrayHeader=Record
                   Allocated:Boolean; (* Flag entry in use *)
                   DiskFile:File;     (* Disk file used *)
                   FileOpen:Boolean;  (* Flag file Open/Closed *)
                   RecordSize:Word;   (* Size of item in bytes *)
                   StackSize:Integer; (* Number of buckets in array *)
                   DataStack:^Stack;  (* Pointer to the bucket struct *)
                   AccessMode:Modes;  (* Operation of array *)
                   TotalEntries:IndexType; (* Max entries in array *)
                   PurgeWhenClosed:WhenClose; (* What to do when closed *)
                 end;

Var
     Headers:Array [0..MaxArraysOpen] Of ArrayHeader;
     Ind:Integer;
     OldExit:Pointer;

Procedure IoAbort;
(* Check for pending I/O errors and aborts if any *)
Var Temp:Integer;
Begin
  Temp:=IoResult;
  If Temp=0 Then Exit;
  WriteLN('LARRY: Critical I/O error #',Temp,'.');
  HALT
end;

Function OpenArray;
(* Opens/Create the array*)

(* Get the first free handle *)
Function GetHandle:ArrayHandle;
Var H:ArrayHandle;
Begin
  H:=0;
  (* Scan for a free entry *)
  While (H<=MaxArraysOpen) AND (Headers[H].Allocated=TRUE) Do H:=Succ(H);
  If H>MaxArraysOpen Then GetHandle:=NoHandle (* none left *)
                     Else GetHandle:=H
end;

Var NewHandle:ArrayHandle;
    FileSizeRequired:LongInt;
    DriveForData:Integer;
    DumBuf:Array [0..1] Of Char;
    Result:Word;
    Temp:Integer;
Begin
  (* Rangecheck the bucketsize *)
  If NumBuckets-1>BucketMax Then
  Begin
    WriteLN('LARRY: Too many buckets');
    HALT
  end;
  NewHandle:=GetHandle; (* Get the handle *)
  If NewHandle=NoHandle Then
  Begin  (* All handles in use *)
    WriteLN('LARRY: No available handle');
    HALT
  end;
  (* Calculate the size of the file *)
  FileSizeRequired:=LongInt(EntrySize)*NumEntries;
  (* Check if enuf space on the target drive *)
  If FName[2]=':' Then
    DriveForData:=Ord(UpCase(FName[1]))-Ord('A')+1
  Else DriveForData:=0;
  If DiskFree(DriveForData)<FileSizeRequired Then
  Begin
    WriteLN('LARRY: not enough disk space');
    Halt
  end;
  With Headers[NewHandle] Do
  Begin
    Assign(DiskFile,FName);
    If ReuseFlag=Reuse Then (* See if we are opening old file *)
    Begin
      Reset(DiskFile,EntrySize);
      If IoResult<>0 Then (* Trap the absent file error *)
      Begin
        If Mode=NoWrite Then (* If readonly array we cant create it *)
        Begin
          WriteLN('LARRY: Can''t create file for READ ONLY array');
          HALT
        end;
        Rewrite(DiskFile,EntrySize);
        If IOResult<>0 Then (* Test for build failure *)
        Begin
          WriteLN('LARRY: Can''t create disk file');
          HALT
        end;
        (* Force the file to full size by writing to the last record *)
        Seek(DiskFile,NumEntries-1);
        IoAbort; (* Check error *)
        BlockWrite(DiskFile,DumBuf,1); (* Write a dummy block *)
        If IoResult<>0 Then
        Begin
          WriteLN('LARRY: I/O Error creating file');
          HALT
        end
      end
    end
    else
    Begin (* Generate a NEW array regardless of old status *)
      If Mode=NoWrite Then
      Begin
        WriteLN('LARRY: Mode for NEW array can''t be READ ONLY');
        HALT
      end;
      Rewrite(DiskFile,EntrySize); (* Create NEW file deleteing old *)
      If IoResult<>0 Then
      Begin
        WriteLN('LARRY: Can''t create disk file');
        HALT
      end
    end;
    If ReuseFlag=Create Then
    Begin (* Force file to FULL SIZE *)
      seek(DiskFile,NumEntries-1);
      If IoResult<>0 Then; (* Dummy to get rid of possible I/O err *)
      BlockWrite(DiskFile,DumBuf,1,Result);
      If IoResult<>0 Then
      Begin
        WriteLN('LARRY: I/O Error creating file');
        Halt
      end;
    end; (* If Not ReuseFlag *)
    Close(DiskFile); (* Dont need file open yet *)
    (* Start allocating memory for the structures and testing if there
       is enuf with free heapspace *)
    If MaxAvail<NumBuckets*SizeOf(EntryType) Then
    Begin
      WriteLN('LARRY: Not enough memory for datastructs');
      HALT
    end;
    (* Allocate control structure *)
    GetMem(DataStack,NumBuckets*SizeOf(EntryType));
    (* Start allocating the databuckets *)
    For Temp:=0 To NumBuckets-1 Do
      With DataStack^[Temp] Do
      Begin
        If MaxAvail<EntrySize Then (* Check mem *)
        Begin
          WriteLN('LARRY: Not enough memory for datastructs');
          HALT
        end;
        GetMem(Data,EntrySize); (* Allocate *)
        ItemInBuf:=-1; (* Mark entry as free *)
        Locked:=False  (* Mark as unlocked *)
      end;
    (* Update the control structure with its values *)
    RecordSize:=EntrySize; (* Size of entry *)
    TotalEntries:=NumEntries; (* Number of entries *)
    PurgeWhenClosed:=PurgeFlag; (* What to do when closing the array *)
    StackSize:=NumBuckets; (* Number of buckets in ram *)
    FileOpen:=False; (* File is still closed *)
    Allocated:=True; (* Structure built *)
    AccessMode:=Mode; (* Default mode for array *)
  end; (* With Headers... *)
  OpenArray:=NewHandle (* Return the new handle for the array *)
end;

Function Larray;
(* This is a simple interface into the OpenArray function generating an
   R/W array with a new datafile that will be purged upon closure *)
Type NamStr=String[12];
Var NewName:NamStr;
Function GenName:NamStr;
Var N:NamStr;
    ChkCount:Integer;
    F:File;
Begin
  (* Generate a unique name for the array in the format
      'LARRYxxx.ARR' where xxx is 000 to 999 *)
  For ChkCount:=1 To 999 Do
  Begin
    Str(ChkCount,N);
    While Length(N)<3 Do N:='0'+N; (* Pad with zeroes *)
    N:='LARRY'+N+'.ARR';
    Assign(F,N); (* Check if already there *)
    Reset(F);
    If IoResult=2 Then (* If not *)
    Begin
      GenName:=N; (* Use this name *)
      Exit
    end;
    Close(F)
  end;
  (* After testing all 1000 combinations ... *)
  WriteLN('LARRY: Unable to generate name for array');
  HALT
end;

Begin
  (* Do a call to OpenArray with defaultvaules *)
  Larray:=OpenArray(GenName,EntrySize,NumEntries,DefaultBuckets,
                    Purge,Create,ReadWrite)
end;

Function DArray;
(* Simplified interface for ON-DISK arrays. Supplied is filename
   Opens file for array-access in REUSE and KEEP mode *)

Begin
  DArray:=OpenArray(FName,EntrySize,NumEntries,DefaultBuckets,
                    NoPurge,Reuse,ReadWrite)
end;

Function Freeze;
(* Locks an entry in ram *)
Begin
  (* We must be allowed to READ the array to use this *)
  If Headers[Handle].AccessMode=NoRead Then
  Begin
    WriteLN('LARRY: Attempt FREEZE on WRITE ONLY array');
    HALT
  end;
  (* Get the item to ensure it is in memory *)
  (* it will endup in the first stackentry *)
  Freeze:=GetPointer(Handle,Entry);
  Headers[Handle].DataStack^[0].Locked:=True; (* Flag it resident *)
end;

Procedure UnFreeze;
(* Releases an entry allowing it to dissapear from memory
NOTE: trying to release a nonlocked entry is actually an error but
      since it will not couse ANY trouble to release an entry that
      is not locked no such check will be done. *)
Var Dummy:Pointer;
Begin
  Dummy:=GetPointer(Handle,Entry); (* Ensure it is in mem and bucket 0 *)
  Headers[Handle].DataStack^[0].Locked:=False; (* Free it *)
end;

Procedure FlushArray;
(* Writes the content of an array out to disk emptying all buckets and
   releasing all locks *)
Var Ind:Integer;
Begin
  With Headers[Handle] Do
  Begin
    If Not Allocated Then Exit; (* Check if allocated *)
    If Not FileOpen Then (* Open the file if it is closed *)
    Begin
      Reset(DiskFile,RecordSize);
      IoAbort; (* Fail program if cant be done *)
      FileOpen:=True;
    end;
    For Ind:=0 To StackSize-1 Do (* Search the entire stack *)
    With DataStack^[Ind] Do
      Begin
        If ItemInBuf<>-1 Then (* Check if entry in bucket *)
        Begin (* If so flush it out to disk *)
          seek(DiskFile,ItemInBuf); (* Position filePtr *)
          IoAbort;
          BlockWrite(DiskFile,Data^,1); (* Write Data *)
          IoAbort;
          ItemInBuf:=-1; (* Free entry *)
          Locked:=False; (* Release a locked entry (If any) *)
        end
      end;
    Close(DiskFile); (* Close the file *)
    FileOpen:=False; (* And flag it closed *)
  end
end;

Procedure FlushAllArrays;
(* Do the above procedure for ALL arrays *)
Var H:ArrayHandle;
Begin
  For H:=0 To MaxArraysOpen Do FlushArray(H)
end;

Procedure CloseArray;
(* Closes down the usage for an array *)
Var Temp:Integer;
Begin
  (* Standard validity check *)
  With Headers[Handle] Do
  Begin
    If Not Allocated Then Exit;
    If PurgeWhenClosed=Purge Then (* Check for removal of file *)
    Begin
      (* If the file is to be removed we don't bother to flush the mem
         buckets to disk, just simply deallocate it *)
      If FileOpen Then Close(DiskFile); (* Close if open *)
      FileOpen:=FALSE;
      Erase(DiskFile); (* Murder disk file *)
      If IoResult<>0 Then (* Check if OK *)
      Begin
        WriteLN('LARRY: Can''t scratch file');
        HALT
      end
    end Else FlushArray(Handle); (* Else flush the buckets *)
    (* Return all memory to the heap *)
    For Temp:=0 To StackSize-1 Do
      FreeMem(DataStack^[Temp].Data,RecordSize);
    FreeMem(DataStack,StackSize*SizeOf(EntryType));
    Allocated:=False; (* Say no longer allocated *)
  end;
end;


(* **************************************************
   Here is the most important function of this package!
   It is used to shuffle data to and from memory, locating
   the desired entry and returning a pointer to the data-
   bucket. If you need to speed up the scheme it is in this
   function you should start tampering... *)

Function GetPointer;
Var Temp:Integer;

Procedure MoveLast(Entry:Integer);
(* Used for moving a bucket into highpriority position (Bucket 0)
   each time it is used *)

Var Hold:EntryType;
Begin
  If Entry=0 Then Exit; (* Dont try this with entry 0 *)
  Hold:=Headers[Handle].DataStack^[Entry]; (* Copy the free entry *)
  (* Move up first entries *)
  Move(Headers[Handle].DataStack^[0],Headers[Handle].DataStack^[1],
       SizeOf(EntryType)*Entry);
  Headers[Handle].DataStack^[0]:=Hold (* Store entry at prio pos. *)
end;

Procedure MoveUpStack;
(* Move up the first entry taking care of entries falling out on the
   other end, by writing them down into the file, the file is assumed
   to be open *)
Var LastFound:Integer;

Begin
  With Headers[Handle] Do
  Begin
    If DataStack^[0].ItemInBuf=-1 Then Exit; (* First entry is free *)
    If DataStack^[StackSize-1].ItemInBuf=-1 Then
    Begin (* Last entry is free *)
      MoveLast(StackSize-1);
      Exit
    end;
    (* This is kinkier, the last entry needs to be written out unless it is
       locket in ram where is should be ignored *)
    LastFound:=StackSize-1; (* Scan for first nonlocked entry *)
    While (LastFound<>-1) And (DataStack^[LastFound].Locked=True) Do
      Dec(LastFound);
    (* Now LastFound points to a safe entry or ... *)
    If LastFound=-1 Then
    Begin
      WriteLN('LARRY: All entries LOCKED in stack');
      HALT
    end;
    With DataStack^[LastFound] Do
    Begin
      If AccessMode<>NoWrite Then (* If ReadOnly dont write *)
      Begin
        seek(DiskFile,ItemInBuf);
        IoAbort;
        BlockWrite(DiskFile,Data^,1);
        IoAbort
      end;
      ItemInBuf:=-1; (* Say bucket is empty *)
    end;
    MoveLast(LastFound); (* Move it to poleposition *)
  end
end;

Function FindEntry:Integer;
(* Locate an entry in the stack return -1 if not found *)
Var Temp:Integer;
Begin
  (* Scan the stack for the entry *)
  With Headers[Handle] Do
  For Temp:=0 To StackSize-1 Do
  With DataStack^[Temp] Do
  Begin
    If ItemInBuf=Entry Then
    Begin (* Found *)
      FindEntry:=Temp;   (* To caller *)
      Exit
    end
  end;
  FindEntry:=-1;
end;

Begin
  If (Handle<0) Or (Handle>MaxArraysOpen) Then
  Begin
    WriteLN('LARRY: Invalid array handle');
    HALT
  end;
  With Headers[Handle] Do
  Begin
    (* Do some validation *)
    If Not Allocated Then
    Begin
      WriteLN('LARRY: Invalid array handle');
      HALT
    end;
    (* Search the stack first *)
    Temp:=FindEntry;
    If Temp<>-1 Then With DataStack^[Temp] Do
    Begin (* Found *)
      GetPointer:=Data; (* Return pointer to data *)
      MoveLast(Temp);   (* To pole position *)
      Exit
    end;
    (* Not in stack, get from file *)
    If Not FileOpen Then
    Begin (* Open the file if closed *)
      Reset(DiskFile,RecordSize);
      IoAbort;
      FileOpen:=True
    end;
    MoveUpStack; (* Move stack to form a new entry at position zero *)
    With DataStack^[0] Do
    Begin
      If AccessMode<>NoRead Then (* Check for write only *)
      Begin
        seek(DiskFile,Entry); (* Position file ptr *)
        IoAbort;
        BlockRead(DiskFile,Data^,1); (* Read the entry to ram *)
        IoAbort
      end;
      ItemInBuf:=Entry; (* Say in use by this item *)
      Locked:=False;    (* and movable *)
      GetPointer:=Data  (* Return of the pointer *)
    end
  end
end;

Procedure WriteMode;
(* Change the mode for an open array, this is used to switch mode
   for example when initializing a large array *)
Begin
  With Headers[Handle] Do
  Begin
    If Not Allocated Then Exit;
    AccessMode:=Flag
  end
end;

(*$F+*)
(* This is a new exitprocedure installed to cleanup any arrays not
   properly closed before program termination *)

Procedure ExitProcedure;
Var H:ArrayHandle;
Begin
  ExitProc:=OldExit; (* Restore old exitprocedure *)
  If (InOutRes<>0) And (ErrorAddr<>NIL) Then
    (* Abort due to I/O error *)
    Exit; (* Don't do anything *)
  FlushAllArrays; (* Flush all arrays to disk *)
  For H:=0 To MaxArraysOpen Do
    If Headers[H].Allocated Then
      CloseArray(H);
end;
(*$F-*)

Begin (* AutoInit part *)
  For Ind:=0 To MaxArraysOpen Do (* Clear all assignments *)
    With Headers[Ind] Do
    Begin
      Allocated:=False;
      FileOpen:=False;
      RecordSize:=0;
      TotalEntries:=0;
      DataStack:=NIL;
      StackSize:=0;
      PurgeWhenClosed:=NoPurge;
      AccessMode:=ReadWrite;
    end;
  OldExit:=ExitProc; (* Copy old exitprocedure *)
  ExitProc:=@ExitProcedure; (* Our exitcloser *)
end.