Listing: 1 (* Release 3.10 *) 2 (*-------------------------------------------------------------------------* 3 * * 4 * MSTORAGE.MOD - Dynamic allocations for mixed M2/C, and overlay model * 5 * * 6 * COPYRIGHT (C) 1987..1992 Clarion Software Corporation. * 7 * All Rights Reserved * 8 * * 9 *--------------------------------------------------------------------------*) 10 11 (*%F _fdata *) 12 (*# call(seg_name => null) *) 13 (*# data(seg_name => null) *) 14 (*%E *) 15 (*# module(implementation=>off) *) 16 (*# check(stack=>off, 17 index=>off, 18 range=>off, 19 overflow=>off, 20 nil_ptr=>off) *) 21 22 IMPLEMENTATION MODULE Storage; 23 24 (* 25 Version of STORAGE.MOD for DOS Overlay, Dynalink and mixed-language 26 libraries 27 *) 28 29 IMPORT SYSTEM, Lib, CoreMem, CoreSig, CoreMain; 30 (*%T _mthread *) 31 IMPORT Process; 32 (*%E *) 33 34 CONST 35 _DLLOVL = (_DLL OR _OVL) AND NOT _OS2; ***** ^ undeclared identifier ***** ^ undeclared identifier ***** ^ undeclared identifier 36 37 CONST 38 EndMarker = 0FFFFH; 39 Align = 4; 40 41 42 (* This is DOS ONLY *) 43 44 PROCEDURE FarMakeHeap( Source : CARDINAL; (* base segment of heap *) 45 Size : CARDINAL (* size in paragraphs *) 46 ) : FarHeapRecPtr; ***** ^ undeclared identifier 47 VAR 48 storage,first,last : FarHeapRecPtr; ***** ^ undeclared identifier 49 BEGIN 50 (*%T _mthread *) 51 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 52 (*%E *) 53 storage := [Source:0]; ***** ^ not supported yet ***** ^ not supported yet 54 first := [Source+1:0]; ***** ^ not supported yet ***** ^ not supported yet 55 last := [Source+Size-1:0]; ***** ^ not supported yet ***** ^ not supported yet 56 storage^.next := first; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 57 storage^.size := 0; ***** ^ not supported yet ***** ^ not supported yet 58 first^.next := last; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 59 last^.next := storage; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 60 first^.size := Size-2; ***** ^ not supported yet ***** ^ not supported yet 61 last^.size := EndMarker; ***** ^ not supported yet ***** ^ not supported yet 62 (*%T _mthread *) 63 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 64 (*%E *) 65 RETURN storage; ***** ^ not supported yet 66 END FarMakeHeap; ***** ^ not supported yet 67 68 69 PROCEDURE FarHeapAllocate(Source : FarHeapRecPtr; (* source heap *) ***** ^ undeclared identifier 70 VAR A : FarADDRESS; (* result *) ***** ^ undeclared identifier 71 Size : CARDINAL); (* request size in paragraphs *) 72 73 VAR 74 res,prev,split : FarHeapRecPtr; ***** ^ undeclared identifier 75 BEGIN 76 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 77 A:=CoreMem.halloc(LONGCARD(Size)<<4); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ arithmetic operand must be numeric 78 IF A = SYSTEM.FarNIL THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 79 IF Check THEN ***** ^ undeclared identifier 80 Lib.RunTimeError(CoreSig._FatalErrorPos(), 90H, 'FarHeapAllocate : Out Of Space'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 81 ELSE 82 A := FarNIL; ***** ^ not supported yet ***** ^ undeclared identifier 83 RETURN; 84 END; 85 END; 86 RETURN; 87 END; 88 (*%T _mthread *) 89 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 90 (*%E *) 91 IF Size=0 THEN INC(Size) END ; ***** ^ undeclared identifier ***** ^ not supported yet 92 prev := Source; ***** ^ not supported yet ***** ^ not supported yet 93 WHILE prev^.next^.size < Size DO ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 94 prev := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 95 END; 96 res := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 97 IF res^.size = EndMarker THEN (* heap run out of space *) ***** ^ not supported yet ***** ^ not supported yet 98 SYSTEM.EI ; ***** ^ not supported yet ***** ^ not supported yet 99 IF Check THEN ***** ^ undeclared identifier 100 Lib.RunTimeError(CoreSig._FatalErrorPos(), 90H, 'FarHeapAllocate : Out Of Space'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 101 ELSE 102 A := FarNIL; ***** ^ not supported yet ***** ^ undeclared identifier 103 RETURN; 104 END; 105 END; 106 IF res^.size = Size THEN (* block correct size *) ***** ^ not supported yet ***** ^ not supported yet 107 prev^.next := res^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 108 ELSE (* split block, bottom half returned, top half linked to free chain *) 109 split := [CARDINAL(Seg(res^))+Size:0]; ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 110 prev^.next := split; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 111 split^.next := res^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 112 split^.size := res^.size - Size; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 113 END; 114 (*%T _mthread *) 115 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 116 (*%E *) 117 A := FarADR(res^); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 118 END FarHeapAllocate; ***** ^ not supported yet 119 120 121 PROCEDURE FarHeapAvail(Source: FarHeapRecPtr) : CARDINAL; ***** ^ undeclared identifier 122 (* returns the largest block size available for allocation in paragraphs *) 123 VAR 124 size : CARDINAL; 125 p : FarHeapRecPtr; ***** ^ undeclared identifier 126 BEGIN 127 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 128 size := CARDINAL(CoreMem._fblockavail() DIV 16); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 129 IF size # 0 THEN 130 DEC(size); ***** ^ undeclared identifier ***** ^ not supported yet 131 END; 132 RETURN size; 133 END; 134 (*%T _mthread *) 135 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 136 (*%E *) 137 p := Source^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 138 size := 0; 139 WHILE p^.size <> EndMarker DO ***** ^ not supported yet ***** ^ not supported yet 140 IF p^.size>size THEN size := p^.size END; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 141 p := p^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 142 END; 143 (*%T _mthread *) 144 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 145 (*%E *) 146 RETURN size; 147 END FarHeapAvail; ***** ^ not supported yet 148 149 150 PROCEDURE FarHeapTotalAvail(Source: FarHeapRecPtr) : CARDINAL; ***** ^ undeclared identifier 151 (* returns the total block size available for allocation in paragraphs *) 152 VAR 153 size : CARDINAL; 154 p : FarHeapRecPtr; ***** ^ undeclared identifier 155 BEGIN 156 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 157 RETURN CARDINAL(CoreMem.farcoreleft()>>4); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ arithmetic operand must be numeric 158 END; 159 (*%T _mthread *) 160 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 161 (*%E *) 162 p := Source^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 163 size := 0; 164 WHILE p^.size <> EndMarker DO ***** ^ not supported yet ***** ^ not supported yet 165 INC(size,p^.size); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 166 p := p^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 167 END; 168 (*%T _mthread *) 169 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 170 (*%E *) 171 RETURN size; 172 END FarHeapTotalAvail; ***** ^ not supported yet 173 174 175 176 PROCEDURE FarHeapDeallocate(Source : FarHeapRecPtr; (* source heap *) ***** ^ undeclared identifier 177 VAR A: FarADDRESS; ***** ^ undeclared identifier 178 Size : CARDINAL ); (* size of block 179 in paragraphs *) 180 VAR 181 target,prev,split : FarHeapRecPtr; ***** ^ undeclared identifier 182 tseg : CARDINAL; 183 BEGIN 184 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 185 CoreMem._ffree(A); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 186 RETURN; 187 END; 188 IF (CARDINAL(Seg(A^))=0)OR(CARDINAL(Ofs(A^))<>0) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 189 Lib.RunTimeError(CoreSig._FatalErrorPos(), 91H, 'FarHeapDeallocate : Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 190 END; 191 (*%T _mthread *) 192 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 193 (*%E *) 194 IF Size=0 THEN INC(Size) END ; ***** ^ undeclared identifier ***** ^ not supported yet 195 target := A; ***** ^ not supported yet ***** ^ not supported yet 196 prev := Source; ***** ^ not supported yet ***** ^ not supported yet 197 tseg := Seg(target^); ***** ^ undeclared identifier ***** ^ not supported yet 198 WHILE CARDINAL(Seg(prev^.next^)) < tseg DO ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 199 prev := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 200 END; 201 IF CARDINAL(Seg(prev^))+prev^.size = tseg THEN (* amalgamate with prev *) ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 202 prev^.size := prev^.size + Size; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 203 target := prev; ***** ^ not supported yet ***** ^ not supported yet 204 ELSIF CARDINAL(Seg(prev^))+prev^.size > tseg THEN (* Heap corrupt *) ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 205 SYSTEM.EI; ***** ^ not supported yet ***** ^ not supported yet 206 Lib.RunTimeError(CoreSig._FatalErrorPos(), 92H, 'FarHeapDeallocate : Heap Corrupt'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 207 ELSE 208 (* link after prev *) 209 target^.next := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 210 prev^.next := target; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 211 target^.size := Size; ***** ^ not supported yet ***** ^ not supported yet 212 END; 213 IF (target^.next^.size <> EndMarker) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 214 AND (CARDINAL(Seg(target^.next^)) = CARDINAL(Seg(target^))+target^.size) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 215 (* amalgamate with next block *) 216 target^.size := target^.size+target^.next^.size; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 217 target^.next := target^.next^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 218 END; 219 A := SYSTEM.FarNIL; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 220 (*%T _mthread *) 221 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 222 (*%E *) 223 END FarHeapDeallocate; ***** ^ not supported yet 224 225 226 PROCEDURE FarHeapChangeAlloc(Source : FarHeapRecPtr; (* source heap *) ***** ^ undeclared identifier 227 A : FarADDRESS; (* block to change *) ***** ^ undeclared identifier 228 OldSize, (* old size of block *) 229 NewSize : CARDINAL) (* new size of block *) 230 (* in paragraphs *) 231 : BOOLEAN; (* if sucessful *) 232 233 (* This procedure attempts to change the size of an allocated block 234 It returns TRUE if succeeded (only expansion can fail) 235 *) 236 237 VAR 238 target,prev, 239 split : FarHeapRecPtr; ***** ^ undeclared identifier 240 tseg : CARDINAL; 241 result : BOOLEAN; 242 extendsize : CARDINAL; 243 Res : FarADDRESS; ***** ^ undeclared identifier 244 BEGIN 245 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 246 Res := CoreMem.hrealloc(A, LONGCARD(NewSize)<<4); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ arithmetic operand must be numeric 247 IF Res = SYSTEM.FarNIL THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 248 RETURN FALSE; 249 ELSE 250 A := Res; ***** ^ not supported yet ***** ^ not supported yet 251 RETURN TRUE; 252 END; 253 END; 254 IF (CARDINAL(Seg(A^))=0)OR(CARDINAL(Ofs(A^))<>0) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 255 Lib.RunTimeError(CoreSig._FatalErrorPos(), 93H, 'FarHeapChangeAlloc : Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 256 END; 257 IF OldSize = NewSize THEN RETURN TRUE END; 258 IF OldSize > NewSize THEN 259 target := [CARDINAL(Seg(A^))+NewSize:0]; ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 260 FarHeapDeallocate(Source,target,OldSize-NewSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 261 RETURN TRUE; 262 END; 263 extendsize := NewSize-OldSize; 264 (*%T _mthread *) 265 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 266 (*%E *) 267 target := A; ***** ^ not supported yet ***** ^ not supported yet 268 prev := Source; ***** ^ not supported yet ***** ^ not supported yet 269 tseg := Seg(target^); ***** ^ undeclared identifier ***** ^ not supported yet 270 WHILE CARDINAL(Seg(prev^.next^)) < tseg DO ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 271 prev := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 272 END; 273 IF (prev^.next^.size <> EndMarker) AND ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 274 (CARDINAL(Seg(prev^.next^)) = CARDINAL(Seg(target^))+OldSize) AND ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 275 (extendsize <= prev^.next^.size) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 276 IF (extendsize = prev^.next^.size) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 277 prev^.next := prev^.next^.next ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 278 ELSE 279 split := [CARDINAL(Seg(target^))+NewSize:0]; ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 280 split^.next := prev^.next^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 281 split^.size := prev^.next^.size - extendsize; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 282 prev^.next := split; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 283 END; 284 result := TRUE; 285 ELSE 286 result := FALSE; 287 END; 288 (*%T _mthread *) 289 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 290 (*%E *) 291 RETURN result; 292 END FarHeapChangeAlloc; ***** ^ not supported yet 293 294 295 296 PROCEDURE FarHeapChangeSize(Source : FarHeapRecPtr; (* source heap *) ***** ^ undeclared identifier 297 VAR A : FarADDRESS; (* block to change *) ***** ^ undeclared identifier 298 OldSize, (* old size of block *) 299 NewSize : CARDINAL ); (* new size of block 300 in paragraphs *) 301 302 (* 303 This procedure will change the size of an allocated block 304 avoiding any copy of data if possible 305 calls HeapChangeAlloc 306 *) 307 308 VAR 309 na : FarADDRESS; ***** ^ undeclared identifier 310 BEGIN 311 IF NOT FarHeapChangeAlloc ( Source, A, OldSize, NewSize ) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 312 FarHeapAllocate(Source,na,NewSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 313 IF na # FarNIL THEN ***** ^ not supported yet ***** ^ undeclared identifier 314 Lib.FarWordMove(A, na, OldSize*8); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 315 FarHeapDeallocate(Source,A,OldSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 316 END; 317 A := na; ***** ^ not supported yet ***** ^ not supported yet 318 END; 319 END FarHeapChangeSize; ***** ^ not supported yet 320 321 322 PROCEDURE FarAllocate(VAR a: FarADDRESS; size: CARDINAL); ***** ^ undeclared identifier 323 324 VAR 325 Res: FarADDRESS; ***** ^ undeclared identifier 326 BEGIN 327 IF size = 0 THEN size := 2 END; 328 IF ClearOnAllocate THEN ***** ^ undeclared identifier 329 Res := CoreMem._fcalloc(1, size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 330 ELSE 331 Res := CoreMem._fmalloc(size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 332 END; 333 IF Res = FarNIL THEN ***** ^ not supported yet ***** ^ undeclared identifier 334 IF Check THEN ***** ^ undeclared identifier 335 Lib.RunTimeError(CoreSig._FatalErrorPos(), 94H, 'FarAllocate : Out Of Memory'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 336 END; 337 END; 338 a := Res; ***** ^ not supported yet ***** ^ not supported yet 339 END FarAllocate; ***** ^ not supported yet 340 341 342 PROCEDURE FarDeallocate(VAR a: FarADDRESS; size: CARDINAL); ***** ^ undeclared identifier 343 344 BEGIN 345 CoreMem._ffree(a); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 346 a:= SYSTEM.FarNIL; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 347 END FarDeallocate; ***** ^ not supported yet 348 349 350 PROCEDURE FarAvailable(size: CARDINAL) : BOOLEAN; 351 VAR 352 ps, rs: LONGCARD; ***** ^ undeclared identifier 353 354 BEGIN 355 (*%T _DLLOVL*) 356 RETURN TRUE; (* Overlay loader takes resposibility *) 357 (*%E*) 358 (*%F _DLLOVL*) 359 ps := CoreMem._fblockavail(); 360 rs := LONGCARD(size+2); 361 RETURN ps >= rs; 362 (*%E*) 363 END FarAvailable; ***** ^ not supported yet 364 365 PROCEDURE NearMakeHeap(Source: NearADDRESS; Size: CARDINAL): NearHeapRecPtr; ***** ^ undeclared identifier ***** ^ undeclared identifier 366 (* ========== *) 367 VAR Storage, FirstFree: NearHeapRecPtr; ***** ^ undeclared identifier 368 BEGIN 369 Size := (Size DIV Align) * Align; 370 IF Size < Align*3 THEN 371 Lib.RunTimeError(CoreSig._FatalErrorPos(), 95H, 'NearMakeHeap: Size Too Small'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 372 END; 373 IF Source = SYSTEM.NearNIL THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 374 Lib.RunTimeError(CoreSig._FatalErrorPos(), 89H, 'NearMakeHeap: Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 375 END; 376 Storage := NearHeapRecPtr(Source); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 377 FirstFree := NearHeapRecPtr(CARDINAL(Source)+CARDINAL(Align)); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 378 Storage^.size := Size; ***** ^ not supported yet ***** ^ not supported yet 379 Storage^.next := FirstFree; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 380 FirstFree^.size := Size - Align; ***** ^ not supported yet ***** ^ not supported yet 381 FirstFree^.next := SYSTEM.NearNIL; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 382 RETURN Storage; ***** ^ not supported yet 383 END NearMakeHeap; ***** ^ not supported yet 384 385 PROCEDURE NearHeapAllocate(Source: NearHeapRecPtr; VAR A: NearADDRESS; Size: CARDINAL); ***** ^ undeclared identifier ***** ^ undeclared identifier 386 (* ======== *) 387 VAR Base, Free, New: NearHeapRecPtr; ***** ^ undeclared identifier 388 BEGIN 389 IF Source = SYSTEM.NearNIL THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 390 Lib.RunTimeError(CoreSig._FatalErrorPos(), 8AH, 'NearHeapAllocate: Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 391 END; 392 IF Source = NearHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 393 NearAllocate(A, Size); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 394 RETURN; 395 END; 396 IF Size < Align THEN 397 Size := Align; 398 ELSE 399 Size := ( (Size+Align-1) DIV Align) * Align; 400 IF Size = 0 THEN 401 Size:=MAX(CARDINAL); ***** ^ undeclared identifier ***** ^ not supported yet 402 END; 403 END; 404 Base := Source; ***** ^ not supported yet ***** ^ not supported yet 405 LOOP 406 Free := Base^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 407 IF Free = SYSTEM.NearNIL THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 408 IF Check THEN ***** ^ undeclared identifier 409 Lib.RunTimeError(CoreSig._FatalErrorPos(), 96H, 'NearHeapAllocate: Out Of Memory'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 410 END; 411 A := SYSTEM.NearNIL; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 412 RETURN; 413 ELSIF Free^.size >= Size THEN ***** ^ not supported yet ***** ^ not supported yet 414 EXIT; 415 END; 416 Base := Free; ***** ^ not supported yet ***** ^ not supported yet 417 END; 418 IF Free^.size = Size THEN ***** ^ not supported yet ***** ^ not supported yet 419 Base^.next := Free^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 420 ELSE 421 New := NearHeapRecPtr(CARDINAL(Free)+Size); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 422 Base^.next := New; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 423 New^.size := Free^.size - Size; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 424 New^.next := Free^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 425 END; 426 IF ClearOnAllocate THEN ***** ^ undeclared identifier 427 Lib.WordFill ( ADR(Free^) , Size DIV 2 , 0 ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 428 END; 429 A := NearADDRESS(Free); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 430 END NearHeapAllocate; ***** ^ not supported yet 431 432 PROCEDURE NearHeapDeallocate(Source: NearHeapRecPtr; VAR A: NearADDRESS; Size: CARDINAL ); ***** ^ undeclared identifier ***** ^ undeclared identifier 433 434 VAR 435 Curr, Base, Free: NearHeapRecPtr; ***** ^ undeclared identifier 436 437 BEGIN 438 IF (Source = SYSTEM.NearNIL) OR (A = SYSTEM.NearNIL) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 439 Lib.RunTimeError(CoreSig._FatalErrorPos(), 8BH, 'NearHeapDeallocate: Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 440 END; 441 IF Source = NearHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 442 NearDeallocate(A, Size); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 443 RETURN; 444 END; 445 IF Size < Align THEN 446 Size := Align; 447 ELSE 448 Size := ( (Size+Align-1) DIV Align) * Align; 449 IF Size = 0 THEN 450 Size:=MAX(CARDINAL); ***** ^ undeclared identifier ***** ^ not supported yet 451 END; 452 END; 453 Curr := NearHeapRecPtr(A); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 454 A := SYSTEM.NearNIL; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 455 Base:=Source; ***** ^ not supported yet ***** ^ not supported yet 456 LOOP 457 Free := Base^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 458 IF (Free = SYSTEM.NearNIL) OR (CARDINAL(Curr) < CARDINAL(Free)) THEN EXIT; END; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 459 Base := Free; ***** ^ not supported yet ***** ^ not supported yet 460 END; 461 IF CARDINAL(Base) + Base^.size = CARDINAL(Curr) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 462 INC ( Base^.size , Size ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 463 Curr := Base; ***** ^ not supported yet ***** ^ not supported yet 464 ELSE 465 Base^.next := Curr; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 466 Curr^.next := Free; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 467 Curr^.size := Size; ***** ^ not supported yet ***** ^ not supported yet 468 END; 469 IF (Free # SYSTEM.NearNIL) AND (CARDINAL(Curr) + Curr^.size = CARDINAL(Free)) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 470 INC ( Curr^.size, Free^.size); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 471 Curr^.next := Free^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 472 END; 473 END NearHeapDeallocate; ***** ^ not supported yet 474 475 PROCEDURE NearHeapAvail(Source: NearHeapRecPtr): CARDINAL; ***** ^ undeclared identifier 476 477 VAR 478 Curr: NearHeapRecPtr; ***** ^ undeclared identifier 479 Size, av: CARDINAL; 480 BEGIN 481 IF Source = SYSTEM.NearNIL THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 482 Lib.RunTimeError(CoreSig._FatalErrorPos(), 8CH, 'NearHeapAvail: Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 483 END; 484 IF Source = NearHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 485 av := CoreMem._memmax(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 486 IF av <= 4 THEN 487 av := 0; 488 ELSE 489 DEC(av, 4); ***** ^ undeclared identifier ***** ^ not supported yet 490 END; 491 RETURN av; 492 END; 493 Curr := Source^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 494 Size := 0; 495 WHILE Curr # SYSTEM.NearNIL DO ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 496 IF Size < Curr^.size THEN ***** ^ not supported yet ***** ^ not supported yet 497 Size := Curr^.size; ***** ^ not supported yet ***** ^ not supported yet 498 END; 499 Curr := Curr^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 500 END; 501 RETURN Size; 502 END NearHeapAvail; ***** ^ not supported yet 503 504 505 PROCEDURE NearHeapTotalAvail(Source: NearHeapRecPtr): CARDINAL; ***** ^ undeclared identifier 506 507 VAR 508 Curr: NearHeapRecPtr; ***** ^ undeclared identifier 509 Size: CARDINAL; 510 BEGIN 511 IF Source = SYSTEM.NearNIL THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 512 Lib.RunTimeError(CoreSig._FatalErrorPos(), 8DH, 'NearHeapTotalAvail: Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 513 END; 514 IF Source = NearHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 515 RETURN CoreMem.nearcoreleft(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 516 END; 517 Curr := Source^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 518 Size := 0; 519 WHILE Curr # SYSTEM.NearNIL DO ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 520 INC ( Size , Curr^.size ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 521 Curr := Curr^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 522 END; 523 RETURN Size; 524 END NearHeapTotalAvail; ***** ^ not supported yet 525 526 527 PROCEDURE Merge(LowRec, HighRec: NearHeapRecPtr); ***** ^ undeclared identifier 528 529 BEGIN 530 IF (LowRec = SYSTEM.NearNIL) AND (HighRec = SYSTEM.NearNIL) AND ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 531 (NearHeapRecPtr(CARDINAL(LowRec)+LowRec^.size) = HighRec) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 532 LowRec^.next:=HighRec^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 533 INC(LowRec^.size, HighRec^.size); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 534 END; 535 END Merge; ***** ^ not supported yet 536 537 PROCEDURE NearHeapChangeSize(Source: NearHeapRecPtr; VAR A: NearADDRESS; ***** ^ undeclared identifier ***** ^ undeclared identifier 538 OldSize, NewSize : CARDINAL); 539 540 VAR 541 OldA: NearADDRESS; ***** ^ undeclared identifier 542 BEGIN 543 IF (Source = SYSTEM.NearNIL) OR (A = SYSTEM.NearNIL) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 544 Lib.RunTimeError(CoreSig._FatalErrorPos(), 8EH, 'NearHeapChangeSize: Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 545 END; 546 IF NearHeapChangeAlloc(Source, A, OldSize, NewSize) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 547 RETURN; 548 END; 549 OldA := A; ***** ^ not supported yet ***** ^ not supported yet 550 NearHeapAllocate(Source, A, NewSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 551 IF A # NearNIL THEN ***** ^ not supported yet ***** ^ undeclared identifier 552 Lib.WordMove(ADR(OldA^), ADR(A^), OldSize DIV 2); ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 553 NearHeapDeallocate(Source, OldA, OldSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 554 END; 555 END NearHeapChangeSize; ***** ^ not supported yet 556 557 PROCEDURE NearHeapChangeAlloc(Source: NearHeapRecPtr; A: NearADDRESS; ***** ^ undeclared identifier ***** ^ undeclared identifier 558 OldSize, NewSize : CARDINAL): BOOLEAN; 559 560 VAR 561 Curr, SplitRec, NextRec, PrevRec, NewRec: NearHeapRecPtr; ***** ^ undeclared identifier 562 Temp: NearHeapRec; ***** ^ undeclared identifier 563 SplitSize: CARDINAL; 564 T: NearADDRESS; ***** ^ undeclared identifier 565 BEGIN 566 IF (Source = SYSTEM.NearNIL) OR (A = SYSTEM.NearNIL) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 567 Lib.RunTimeError(CoreSig._FatalErrorPos(), 8FH, 'NearHeapChangeAlloc: Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 568 END; 569 IF Source = NearHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 570 T := CoreMem._nexpand(A, NewSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 571 IF T # NearNIL THEN ***** ^ not supported yet ***** ^ undeclared identifier 572 A := T; ***** ^ not supported yet ***** ^ not supported yet 573 RETURN TRUE; 574 ELSE 575 RETURN FALSE; 576 END; 577 END; 578 IF NewSize < Align THEN 579 NewSize := Align; 580 ELSE 581 NewSize := ( (NewSize+Align-1) DIV Align) * Align; 582 IF NewSize = 0 THEN 583 NewSize:=MAX(CARDINAL); ***** ^ undeclared identifier ***** ^ not supported yet 584 END; 585 END; 586 IF OldSize < Align THEN 587 OldSize := Align; 588 ELSE 589 OldSize := ( (OldSize+Align-1) DIV Align) * Align; 590 IF OldSize = 0 THEN 591 OldSize:=MAX(CARDINAL); ***** ^ undeclared identifier ***** ^ not supported yet 592 END; 593 END; 594 IF OldSize = NewSize THEN RETURN TRUE END; 595 Curr:=NearHeapRecPtr(A); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 596 NextRec:=Source; ***** ^ not supported yet ***** ^ not supported yet 597 LOOP 598 PrevRec:=NextRec; ***** ^ not supported yet ***** ^ not supported yet 599 NextRec:=NextRec^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 600 IF (NextRec = SYSTEM.NearNIL) OR (CARDINAL(NextRec) > CARDINAL(Curr)) THEN EXIT END; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 601 END; 602 IF OldSize > NewSize THEN 603 SplitSize:=OldSize-NewSize; 604 SplitRec:=NearHeapRecPtr(CARDINAL(Curr)+NewSize); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 605 SplitRec^.size:=SplitSize; ***** ^ not supported yet ***** ^ not supported yet 606 SplitRec^.next:=NextRec; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 607 PrevRec^.next:=SplitRec; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 608 Merge(SplitRec, NextRec); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 609 RETURN TRUE; 610 END; 611 IF (NextRec # SYSTEM.NearNIL) AND (NearHeapRecPtr(CARDINAL(Curr)+OldSize) = NextRec) THEN (* Next Block is free *) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 612 Temp.size := OldSize+NextRec^.size; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 613 Temp.next := NextRec^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 614 IF Temp.size = NewSize THEN ***** ^ not supported yet ***** ^ not supported yet 615 PrevRec^.next := Temp.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 616 ELSE 617 NewRec := NearHeapRecPtr(CARDINAL(Curr)+NewSize); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 618 PrevRec^.next := NewRec; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 619 NewRec^.size := Temp.size-NewSize; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 620 NewRec^.next := Temp.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 621 END; 622 RETURN TRUE; 623 ELSE 624 RETURN FALSE; 625 END; 626 END NearHeapChangeAlloc; ***** ^ not supported yet 627 628 (*%F _DLL *) 629 PROCEDURE NearDeallocate(VAR a: NearADDRESS; size: CARDINAL); 630 631 BEGIN 632 CoreMem._nfree(a); 633 a:= NearADDRESS(NIL); 634 END NearDeallocate; 635 636 PROCEDURE NearAllocate(VAR a: NearADDRESS; size: CARDINAL); 637 638 VAR 639 Res: NearADDRESS; 640 BEGIN 641 IF size = 0 THEN size := 2 END; 642 IF ClearOnAllocate THEN 643 Res := CoreMem._ncalloc(1, size); 644 ELSE 645 Res := CoreMem._nmalloc(size); 646 END; 647 IF Res = NearNIL THEN 648 IF Check THEN 649 Lib.RunTimeError(CoreSig._FatalErrorPos(), 98H, 'NearAllocate: Out Of Memory'); 650 END; 651 END; 652 a := Res; 653 END NearAllocate; 654 655 PROCEDURE NearAvailable(size: CARDINAL) : BOOLEAN; 656 VAR 657 ps : CARDINAL; 658 BEGIN 659 ps := CoreMem._memmax(); 660 RETURN ps >= (size+4); 661 END NearAvailable; 662 (*%E *) 663 664 (*%T _DLL *) 665 PROCEDURE NearAllocate(VAR a: NearADDRESS; size: CARDINAL); ***** ^ undeclared identifier 666 667 BEGIN 668 a := NearNIL; ***** ^ not supported yet ***** ^ undeclared identifier 669 END NearAllocate; ***** ^ not supported yet 670 671 672 PROCEDURE NearDeallocate(VAR a: NearADDRESS; size: CARDINAL); ***** ^ undeclared identifier 673 674 BEGIN 675 END NearDeallocate; ***** ^ not supported yet 676 677 678 PROCEDURE NearAvailable(size: CARDINAL) : BOOLEAN; 679 680 BEGIN 681 RETURN FALSE; 682 END NearAvailable; ***** ^ not supported yet 683 (*%E *) 684 685 PROCEDURE SegAllocate(Size: CARDINAL): CARDINAL; 686 687 BEGIN 688 RETURN Seg(CoreMem.halloc(LONGCARD(Size))^); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 689 END SegAllocate; ***** ^ not supported yet 690 691 PROCEDURE SegDeallocate(Sel: CARDINAL; Size: CARDINAL); 692 693 VAR 694 S: FarADDRESS; ***** ^ undeclared identifier 695 BEGIN 696 S := [Sel: 0]; ***** ^ not supported yet ***** ^ not supported yet 697 CoreMem.hfree(S); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 698 END SegDeallocate; ***** ^ not supported yet 699 700 BEGIN 701 NearHeap := NearHeapRecPtr(0FFFFH); ***** ^ undeclared identifier ***** ^ undeclared identifier ***** ^ not supported yet 702 MainHeap := FarHeapRecPtr(CoreMain._getheapbase()); ***** ^ undeclared identifier ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 703 Check := TRUE; ***** ^ undeclared identifier 704 ClearOnAllocate := FALSE; ***** ^ undeclared identifier 705 END Storage. ***** ^ not supported yet 838 errors