development/compilers/freepascal/compiler/ppovin.pas

   1 {
   2     $Id$
   3     Copyright (c) 1998-2000 by Daniel Mantione
   4
   5     Handles the overlay initialisation for a TP7 compiled version
   6
   7     This program is free software; you can redistribute it and/or modify
   8     it under the terms of the GNU General Public License as published by
   9     the Free Software Foundation; either version 2 of the License, or
  10     (at your option) any later version.
  11
  12     This program is distributed in the hope that it will be useful,
  13     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15     GNU General Public License for more details.
  16
  17     You should have received a copy of the GNU General Public License
  18     along with this program; if not, write to the Free Software
  19     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21  ****************************************************************************
  22 }
  23 unit ppovin;
  24
  25 interface
  26
  27 var
  28   ovrminsize:longint;
  29
  30 procedure InitOverlay;
  31
  32 implementation
  33 uses overlay;
  34
  35
  36 function _heaperror(size:word):integer;far;
  37 type
  38   heaprecord=record
  39     next:pointer;
  40     values:longint;
  41   end;
  42 var
  43   l,m:longint;
  44 begin
  45   l:=ovrgetbuf-ovrminsize;
  46   if (size>maxavail) and (l>=size) then
  47    begin
  48      m:=((longint(size)+$3fff) and $ffffc000);
  49      {Clear the overlay buffer.}
  50      ovrclearbuf;
  51      {Shrink it.}
  52      ovrheapend:=ovrheapend-m shr 4;
  53      heaprecord(ptr(ovrheapend,0)^).next:=freelist;
  54      heaprecord(ptr(ovrheapend,0)^).values:=m shl 12;
  55      heaporg:=ptr(ovrheapend,0);
  56      freelist:=heaporg;
  57      Writeln('Warning: Overlay buffer was shrunk because of memory shortage');
  58      _heaperror:=2;
  59    end
  60   else
  61    _heaperror:=0;
  62 end;
  63
  64 procedure InitOverlay;
  65 begin
  66   heaperror:=@_heaperror;
  67 end;
  68
  69
  70 var
  71   s:string;
  72 begin
  73   s:=paramstr(0);
  74   ovrinit(copy(s,1,length(s)-3)+'ovr');
  75   if ovrresult=ovrok then
  76    begin
  77      {May fail if no EMS memory is available. No need for error
  78       checking, though, as the overlay manager happily runs without
  79       EMS.}
  80      ovrinitEMS;
  81      ovrminsize:=ovrgetbuf;
  82      ovrsetbuf(ovrminsize+$20000);
  83    end
  84   else
  85   { only for real mode TP : runerror ok here PM }
  86    runerror($da);
  87 end.
  88 {
  89   $Log$
  90   Revision 1.1  2002/02/19 08:23:33  sasu
  91   Initial revision
  92
  93   Revision 1.1  2000/07/13 06:29:54  michael
  94   + Initial import
  95
  96   Revision 1.6  2000/02/09 13:22:59  peter
  97     * log truncated
  98
  99   Revision 1.5  2000/01/07 01:14:30  peter
 100     * updated copyright to 2000
 101
 102   Revision 1.4  1999/09/16 11:34:58  pierre
 103    * typo correction
 104
 105 }
 106
 107