gcc/m2/gm2-libs-iso/Storage.mod

   1 (* Storage.mod implement the ISO Storage specification.
   2
   3 Copyright (C) 2001-2024 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  *)
  26
  27 IMPLEMENTATION MODULE Storage ;
  28
  29 FROM libc IMPORT memcpy, abort, malloc, free, printf ;
  30
  31 IMPORT SysStorage ;
  32
  33 FROM M2RTS IMPORT Halt ;
  34 FROM SYSTEM IMPORT TSIZE ;
  35 FROM M2EXCEPTION IMPORT M2Exceptions ;
  36 FROM RTentity IMPORT Group, InitGroup, GetKey, PutKey, DelKey, IsIn ;
  37
  38 FROM EXCEPTIONS IMPORT ExceptionNumber, RAISE,
  39                        AllocateSource, ExceptionSource, IsCurrentSource,
  40                        IsExceptionalExecution ;
  41
  42
  43 CONST
  44    DebugTrace = FALSE ;
  45    UseMallocFree = FALSE ;
  46
  47
  48 PROCEDURE ALLOCATE (VAR addr: SYSTEM.ADDRESS; amount: CARDINAL) ;
  49 BEGIN
  50    Init ;
  51    IF DebugTrace
  52    THEN
  53       printf ("request m2iso:Storage.ALLOCATE (..., %d bytes)\n", amount)
  54    END ;
  55    IF UseMallocFree
  56    THEN
  57       addr := malloc (amount)
  58    ELSE
  59       SysStorage.ALLOCATE (addr, amount)
  60    END ;
  61    IF DebugTrace
  62    THEN
  63       printf ("return m2iso:Storage.ALLOCATE (%p, %d bytes)\n", addr, amount)
  64    END ;
  65    IF addr#NIL
  66    THEN
  67       PutKey (storageTree, addr, amount)
  68    END
  69 END ALLOCATE ;
  70
  71
  72 PROCEDURE DEALLOCATE (VAR addr: SYSTEM.ADDRESS; amount: CARDINAL) ;
  73 BEGIN
  74    assert (initialized) ;
  75    IF DebugTrace
  76    THEN
  77       printf ("m2iso:Storage.DEALLOCATE (%p, %d bytes)\n", addr, amount)
  78    END ;
  79    IF VerifyDeallocate (addr, amount)
  80    THEN
  81       IF UseMallocFree
  82       THEN
  83          free (addr)
  84       ELSE
  85          SysStorage.DEALLOCATE (addr, amount)
  86       END ;
  87       addr := NIL
  88    END
  89 END DEALLOCATE ;
  90
  91
  92 PROCEDURE REALLOCATE (VAR addr: SYSTEM.ADDRESS; amount: CARDINAL);
  93   (* Attempts to reallocate, amount of storage.  Effectively it
  94      calls ALLOCATE, copies the amount of data pointed to by
  95      addr into the new space and DEALLOCATES the addr.
  96      This procedure is a GNU extension.
  97   *)
  98 VAR
  99    newa: SYSTEM.ADDRESS ;
 100    n   : CARDINAL ;
 101 BEGIN
 102    assert (initialized) ;
 103    IF NOT IsIn (storageTree, addr)
 104    THEN
 105       RAISE (storageException, ORD(pointerToUnallocatedStorage),
 106              'trying to reallocate memory which has never been allocated') ;
 107    END ;
 108    n := GetKey (storageTree, addr) ;
 109    ALLOCATE(newa, amount) ;
 110    IF n<amount
 111    THEN
 112       newa := memcpy(newa, addr, n)
 113    ELSE
 114       newa := memcpy(newa, addr, amount)
 115    END ;
 116    DEALLOCATE(addr, n) ;
 117    addr := newa
 118 END REALLOCATE ;
 119
 120
 121 PROCEDURE IsStorageException () : BOOLEAN;
 122 BEGIN
 123    Init ;
 124    RETURN( IsCurrentSource (storageException) )
 125 END IsStorageException ;
 126
 127
 128 PROCEDURE StorageException () : StorageExceptions ;
 129 BEGIN
 130    Init ;
 131    IF NOT IsExceptionalExecution ()
 132    THEN
 133       RAISE (storageException, ORD (functionException), 'no storage exception raised')
 134    END ;
 135    RETURN currentException
 136 END StorageException ;
 137
 138
 139 (*
 140    VerifyDeallocate -
 141 *)
 142
 143 PROCEDURE VerifyDeallocate (addr: SYSTEM.ADDRESS; amount: CARDINAL) : BOOLEAN ;
 144 VAR
 145    a: CARDINAL ;
 146 BEGIN
 147    Init ;
 148    IF addr=NIL
 149    THEN
 150       RAISE (storageException, ORD(nilDeallocation), 'deallocating pointer whose value is NIL') ;
 151       RETURN FALSE
 152    ELSE
 153       IF NOT IsIn(storageTree, addr)
 154       THEN
 155          RAISE (storageException, ORD(pointerToUnallocatedStorage), 'trying to deallocate memory which has never been allocated') ;
 156          RETURN FALSE
 157       END ;
 158       a := GetKey (storageTree, addr) ;
 159       IF a#amount
 160       THEN
 161          RAISE (storageException, ORD(wrongStorageToUnallocate), 'wrong amount of storage being deallocated') ;
 162          RETURN FALSE
 163       END
 164    END ;
 165    DelKey (storageTree, addr) ;
 166    RETURN TRUE
 167 END VerifyDeallocate ;
 168
 169
 170 (*
 171    assert - simple assertion procedure.
 172 *)
 173
 174 PROCEDURE assert (condition: BOOLEAN) ;
 175 BEGIN
 176    IF NOT condition
 177    THEN
 178       Halt ('internal runtime error, module Storage has not been initialized yet',
 179             __FILE__, __FUNCTION__, __LINE__)
 180    END
 181 END assert ;
 182
 183
 184 (*
 185    Init -
 186 *)
 187
 188 PROCEDURE Init ;
 189 BEGIN
 190    IF NOT initialized
 191    THEN
 192       initialized := TRUE ;
 193       storageTree := InitGroup () ;
 194       AllocateSource (storageException)
 195    END
 196 END Init ;
 197
 198
 199 VAR
 200    storageException: ExceptionSource ;
 201    currentException: StorageExceptions ;
 202    storageTree     : Group ;
 203    initialized     : BOOLEAN ;  (* Set to FALSE when the bss is created.  *)
 204
 205 END Storage.