gcc/m2/gm2-libs/SysStorage.mod

   1 (* SysStorage.mod provides dynamic allocation for the system components.
   2
   3 Copyright (C) 2001-2023 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 SysStorage ;
  28
  29 FROM libc IMPORT malloc, free, realloc, memset, getenv, printf ;
  30 FROM Debug IMPORT Halt ;
  31 FROM SYSTEM IMPORT ADR ;
  32
  33
  34 CONST
  35    enableDeallocation =  TRUE ;
  36    enableZero         = FALSE ;
  37    enableTrace        = FALSE ;
  38
  39 VAR
  40    callno: CARDINAL ;
  41    zero,
  42    trace : BOOLEAN ;
  43
  44
  45 PROCEDURE ALLOCATE (VAR a: ADDRESS ; size: CARDINAL) ;
  46 BEGIN
  47    a := malloc (size) ;
  48    IF a = NIL
  49    THEN
  50       Halt ('out of memory error', __LINE__, __FILE__)
  51    END ;
  52    IF enableTrace AND trace
  53    THEN
  54       printf ("<DEBUG-CALL> %d SysStorage.ALLOCATE (0x%x, %d bytes)\n", callno, a, size) ;
  55       printf ("<MEM-ALLOC> %ld %d\n", a, size);
  56       INC (callno)
  57    END
  58 END ALLOCATE ;
  59
  60
  61 PROCEDURE DEALLOCATE (VAR a: ADDRESS; size: CARDINAL);
  62 BEGIN
  63    IF enableTrace AND trace
  64    THEN
  65       printf ("<DEBUG-CALL> %d SysStorage.DEALLOCATE (0x%x, %d bytes)\n", callno, a, size) ;
  66       INC (callno)
  67    END ;
  68    IF enableZero AND zero
  69    THEN
  70       IF enableTrace AND trace
  71       THEN
  72          printf ("  memset (0x%x, 0, %d bytes)\n", a, size)
  73       END ;
  74       IF memset (a, 0, size) # a
  75       THEN
  76          Halt ('memset should have returned the first parameter', __LINE__, __FILE__)
  77       END
  78    END ;
  79    IF enableDeallocation
  80    THEN
  81       IF enableTrace AND trace
  82       THEN
  83          printf ("  free (0x%x)   %d bytes\n", a, size) ;
  84          printf ("<MEM-FREE> %ld %d\n", a, size);
  85       END ;
  86       free (a)
  87    END ;
  88    a := NIL
  89 END DEALLOCATE ;
  90
  91
  92 (*
  93    REALLOCATE - attempts to reallocate storage. The address,
  94                 a, should either be NIL in which case ALLOCATE
  95                 is called, or alternatively it should have already
  96                 been initialized by ALLOCATE. The allocated storage
  97                 is resized accordingly.
  98 *)
  99
 100 PROCEDURE REALLOCATE (VAR a: ADDRESS; size: CARDINAL) ;
 101 BEGIN
 102    IF a = NIL
 103    THEN
 104       ALLOCATE (a, size)
 105    ELSE
 106       IF enableTrace AND trace
 107       THEN
 108          printf ("<DEBUG-CALL> %d SysStorage.REALLOCATE (0x%x, %d bytes)\n", callno, a, size) ;
 109          INC (callno)
 110       END ;
 111       IF enableTrace AND trace
 112       THEN
 113          printf ("  realloc (0x%x, %d bytes)  ->  ", a, size) ;
 114          printf ("<MEM-FREE> %ld %d\n", a, size)
 115       END ;
 116       a := realloc (a, size) ;
 117       IF a = NIL
 118       THEN
 119          Halt ('out of memory error', __LINE__, __FILE__)
 120       END ;
 121       IF enableTrace AND trace
 122       THEN
 123          printf ("<MEM-ALLOC> %ld %d\n", a, size) ;
 124          printf ("  0x%x  %d bytes\n", a, size)
 125       END
 126    END
 127 END REALLOCATE ;
 128
 129
 130 PROCEDURE Available (size: CARDINAL) : BOOLEAN;
 131 VAR
 132    a: ADDRESS ;
 133 BEGIN
 134    IF enableTrace AND trace
 135    THEN
 136       printf ("<DEBUG-CALL> %d SysStorage.Available (%d bytes)\n", callno, size) ;
 137       INC (callno)
 138    END ;
 139    a := malloc (size) ;
 140    IF a = NIL
 141    THEN
 142       IF enableTrace AND trace
 143       THEN
 144          printf ("   no\n", size)
 145       END ;
 146       RETURN FALSE
 147    ELSE
 148       IF enableTrace AND trace
 149       THEN
 150          printf ("   yes\n", size)
 151       END ;
 152       free (a) ;
 153       RETURN TRUE
 154    END
 155 END Available ;
 156
 157
 158 (*
 159    Init - initializes the heap.  This does nothing on a GNU/Linux system.
 160           But it remains here since it might be used in an embedded system.
 161 *)
 162
 163 PROCEDURE Init ;
 164 END Init ;
 165
 166
 167 BEGIN
 168    callno := 0 ;
 169    IF enableTrace
 170    THEN
 171       trace := getenv (ADR ("M2DEBUG_SYSSTORAGE_trace")) # NIL
 172    ELSE
 173       trace := FALSE
 174    END ;
 175    IF enableZero
 176    THEN
 177       zero := getenv (ADR ("M2DEBUG_SYSSTORAGE_zero")) # NIL
 178    ELSE
 179       zero := FALSE
 180    END
 181 END SysStorage.