1 (* Storage.mod implement the ISO Storage specification.
3 Copyright (C) 2001-2024 Free Software Foundation, Inc.
4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
6 This file is part of GNU Modula-2.
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)
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.
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.
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/>. *)
27 IMPLEMENTATION MODULE Storage
;
29 FROM libc
IMPORT memcpy
, abort
, malloc
, free
, printf
;
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
;
38 FROM EXCEPTIONS
IMPORT ExceptionNumber
, RAISE
,
39 AllocateSource
, ExceptionSource
, IsCurrentSource
,
40 IsExceptionalExecution
;
45 UseMallocFree
= FALSE ;
48 PROCEDURE ALLOCATE (VAR addr
: SYSTEM.ADDRESS
; amount
: CARDINAL) ;
53 printf ("request m2iso:Storage.ALLOCATE (..., %d bytes)\n", amount
)
57 addr
:= malloc (amount
)
59 SysStorage.
ALLOCATE (addr
, amount
)
63 printf ("return m2iso:Storage.ALLOCATE (%p, %d bytes)\n", addr
, amount
)
67 PutKey (storageTree
, addr
, amount
)
72 PROCEDURE DEALLOCATE (VAR addr
: SYSTEM.ADDRESS
; amount
: CARDINAL) ;
74 assert (initialized
) ;
77 printf ("m2iso:Storage.DEALLOCATE (%p, %d bytes)\n", addr
, amount
)
79 IF VerifyDeallocate (addr
, amount
)
85 SysStorage.
DEALLOCATE (addr
, amount
)
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.
99 newa
: SYSTEM.ADDRESS
;
102 assert (initialized
) ;
103 IF NOT IsIn (storageTree
, addr
)
105 RAISE (storageException
, ORD(pointerToUnallocatedStorage
),
106 'trying to reallocate memory which has never been allocated') ;
108 n
:= GetKey (storageTree
, addr
) ;
109 ALLOCATE(newa
, amount
) ;
112 newa
:= memcpy(newa
, addr
, n
)
114 newa
:= memcpy(newa
, addr
, amount
)
116 DEALLOCATE(addr
, n
) ;
121 PROCEDURE IsStorageException () : BOOLEAN;
124 RETURN( IsCurrentSource (storageException
) )
125 END IsStorageException
;
128 PROCEDURE StorageException () : StorageExceptions
;
131 IF NOT IsExceptionalExecution ()
133 RAISE (storageException
, ORD (functionException
), 'no storage exception raised')
135 RETURN currentException
136 END StorageException
;
143 PROCEDURE VerifyDeallocate (addr
: SYSTEM.ADDRESS
; amount
: CARDINAL) : BOOLEAN ;
150 RAISE (storageException
, ORD(nilDeallocation
), 'deallocating pointer whose value is NIL') ;
153 IF NOT IsIn(storageTree
, addr
)
155 RAISE (storageException
, ORD(pointerToUnallocatedStorage
), 'trying to deallocate memory which has never been allocated') ;
158 a
:= GetKey (storageTree
, addr
) ;
161 RAISE (storageException
, ORD(wrongStorageToUnallocate
), 'wrong amount of storage being deallocated') ;
165 DelKey (storageTree
, addr
) ;
167 END VerifyDeallocate
;
171 assert - simple assertion procedure.
174 PROCEDURE assert (condition
: BOOLEAN) ;
178 Halt ('internal runtime error, module Storage has not been initialized yet',
179 __FILE__
, __FUNCTION__
, __LINE__
)
192 initialized
:= TRUE ;
193 storageTree
:= InitGroup () ;
194 AllocateSource (storageException
)
200 storageException
: ExceptionSource
;
201 currentException
: StorageExceptions
;
202 storageTree
: Group
;
203 initialized
: BOOLEAN ; (* Set to FALSE when the bss is created. *)