home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / pasos2b.zip / lib / heaplib.pas next >
Pascal/Delphi Source File  |  1993-11-03  |  5KB  |  161 lines
  1. (*
  2.  * FileName:   heaplib.pas
  3.  * $Source: E:/usr/src/c-code/pascal/RCS/LIB/heaplib.pas,v $
  4.  * $Author: wjw $
  5.  * $Date: 1993/11/03 15:55:02 $
  6.  * $Locker: wjw $
  7.  * $State: Exp $
  8.  * $Revision: 1.1 $
  9.  * Description:
  10. D*      Part of the runtime library which comes with PASCAL for OS/2
  11. D*      
  12.  *
  13.  * History:
  14.  *      First created by Willem Jan Withagen ( wjw@eb.ele.tue.nl ),
  15.  *                    on Mon July 26 23:30:03 MET 1993
  16.  * Copyright:
  17.  *      Copyright (c) 1993 by Willem Jan Withagen and 
  18.  *                      Digital Information Systems group, TUE
  19.  *      For copying and distribution information see the file COPYRIGHT.
  20.  *
  21.  *)
  22.  
  23. program heaplib;
  24. (* module heaplib; *)
  25. (*  Memory allocation with NEW/DISPOSE 
  26. (*  We use OS/2 to request the heap at a fixed size, 
  27. (*      DosSubSetMen, DosSubUnsetMem
  28. (*  Then other OS/2 functions are used to allocate pieces of this heap.
  29. (*      DosSubAllocate, DosSubFree
  30. (*  They can be made sparsely allocated, and thus only use heap when needed.
  31.  *)
  32. #include "os2.inc"
  33. (* define DEBUG_HEAP 2 *)
  34. const
  35.           (* Allocate 1000K, it can/should enlarged at run-time *)
  36.           _heap_size_init        = 1000000;
  37.           
  38.           (* our overhead per allocation 
  39.           (* It''s where we keep the size of the current allocation.
  40.            *)
  41.       _new_overhead          = 4;
  42.           
  43.           (* The number of overhead bytes taken by OS/2 when DosSubSetMen is 
  44.           (* executed *)
  45.       DOSSUB_USED = 64;
  46.  
  47. type
  48.           intp = ^integer;
  49. var
  50.           _heap_start :_word;
  51.           _heap_size  :_word;
  52.           _heap_free  :_word;
  53.     
  54. procedure $Stdnew(VAR p:_word; size :_word);
  55. (*  Allocate a piece of the heap, 
  56. (*  During deallocation we need the size of the previously allocated item
  57. (*  so this is stored at the start, and the pointer returned is incremented
  58. (*  by 4
  59.  *)
  60. var
  61.    _rc  :_word;           (* the result of the latest OS operation *)
  62.    hack :record  (* make pointer and word equal so we can hack''m *)
  63.             case integer of
  64.                         1: (offset  :_word);
  65.             2: (offsetp :intp)
  66.          end; 
  67. begin
  68.      (* Get the space *)
  69.      _rc := Dos32SubAlloc(_heap_start, hack.offset, size+_new_overhead) 
  70.     ;if _rc <> 0 
  71.      then 
  72.        begin
  73.               write('New(',__LINE__:1,'): Error in Dos32SubAlloc: rc = ', _rc:1, ' nothing allocated.')
  74.              ;writeln
  75.              ;writeln('     For block of size:', size:1)
  76.              ;_rc := Dos32exit(1,1)
  77.        end
  78. #ifdef DEBUG_HEAP     
  79.      else writeln('        allocated item starts at: ', hack.offset)
  80. #endif     
  81.     ;hack.offsetp^ := size+_new_overhead        (* put requested size in     *)
  82.     ;p := hack.offset+4                         (* return the corrected size *)
  83.     ;_heap_free := _heap_free + (((size+_new_overhead) div 8) *8)
  84. #if DEBUG_HEAP > 1
  85.     ;writeln('        Free starts at: ', _heap_free)
  86. #endif     
  87. end;   (* $new *)
  88.  
  89. procedure $Stddispose(VAR p:_word);
  90. (* Return the allocated memory back to the heap 
  91. (* The size of the allocated piece was remembered during creation.
  92.  *)
  93. var
  94.    _rc  :_word;           (* the result of the latest OS operation *)
  95.    hack :record  (* make pointer and word equal so we can hack''m *)
  96.              case integer of
  97.              1:  (offset  :_word);
  98.              2:  (offsetp :intp)
  99.          end; 
  100. begin
  101.          hack.offset := p - _new_overhead   (* Get the pointer to the size piece *)
  102. #if DEBUG_HEAP > 1
  103.         ;writeln('Freeing at :',hack.offset, ' for: ',p)
  104. #endif         
  105.     ;_rc := Dos32SubFree(_heap_start, p-_new_overhead, hack.offsetp^ )
  106.     ;if _rc <> 0 
  107.      then 
  108.        begin
  109.               writeln('Dispose(',__LINE__:1,'): Error in Dos32SubFree: rc = ', _rc:1 )
  110.        end
  111. end;   (* $dispose *)
  112.  
  113. procedure $HeapInit;
  114. (*  Initialise all kind of things which are in the STD-library.
  115.  *)
  116. var
  117.         _rc       : _word;              (* the result of the latest OS operation *)
  118. begin
  119.      (* No Errors yet *)
  120.      _rc := 0
  121.     
  122.         (* Memory/Heap initialisation *)
  123.         ;_heap_size := _heap_size_init
  124.         ;_rc := Dos32AllocMem( _heap_start, _heap_size, PAG_READ+PAG_WRITE) 
  125.         ;if _rc <> 0 
  126.          then writeln('HeapInit(',__LINE__:1,'): Error in Dos32AllocMem: rc = ', _rc)
  127. #ifdef DEBUG_HEAP     
  128.      else writeln('Memory starts at: ', _heap_start)
  129. #endif
  130.     ;_heap_free := _heap_start + DOSSUB_USED
  131.     ;_rc := Dos32SubSet( _heap_start, DOSSUB_INIT+DOSSUB_SPARSE_OBJ, _heap_size)
  132.     ;if _rc <> 0 
  133.          then writeln('HeapInit(',__LINE__:1,'): Error in Dos32SubSet: rc = ', _rc)
  134. #ifdef DEBUG_HEAP     
  135.      else writeln('Heap starts at: ', _heap_start)
  136. #endif     
  137. end;
  138.  
  139. procedure $HeapExit;
  140. var
  141.         _rc       : _word;              (* the result of the latest OS operation *)
  142. begin
  143.     (* Heap termination, return what we asked for *)
  144.     _rc := Dos32FreeMem( _heap_start )
  145.    ;if _rc <> 0 
  146.     then writeln('HeapExit(',__LINE__:1,'): Error in Dos32FreeMem: rc = ', _rc)
  147. end;
  148.  
  149.  
  150. begin
  151. end.
  152. (*
  153.  * $Log: heaplib.pas,v $
  154.  * Revision 1.1  1993/11/03  15:55:02  wjw
  155.  * Started adminstration for the RUNTIME LIB
  156.  *
  157.  *
  158.  *      First created by Willem Jan Withagen ( wjw@eb.ele.tue.nl ),
  159.  *                    on Mon July 26 23:30:03 MET 1993
  160.  *)
  161.