Listing: 1 (* Release 3.10 *) 2 (*-------------------------------------------------------------------------* 3 * * 4 * WSTORAGE.MOD - Dynamic allocations under Windows * 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 (*%E *) 14 (*# data(seg_name => null) *) 15 (*# check(stack=>off, 16 index=>off, 17 range=>off, 18 overflow=>off, 19 nil_ptr=>off) *) 20 (*# module(implementation=>off) *) 21 22 IMPLEMENTATION MODULE Storage; 23 24 IMPORT SYSTEM, Lib, Windows, CoreSig; 25 (*%T _mthread *) 26 IMPORT Process; 27 (*%E *) 28 29 CONST 30 EndMarker = 0FFFFH; 31 Align = 4; 32 33 34 (* This is DOS ONLY *) 35 36 PROCEDURE FarMakeHeap( Source : CARDINAL; (* base segment of heap *) 37 Size : CARDINAL (* size in paragraphs *) 38 ) : FarHeapRecPtr; ***** ^ undeclared identifier 39 VAR 40 storage,first,last : FarHeapRecPtr; ***** ^ undeclared identifier 41 BEGIN 42 (*%T _mthread *) 43 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 44 (*%E *) 45 storage := [Source:0]; ***** ^ not supported yet ***** ^ not supported yet 46 first := [Source+1:0]; ***** ^ not supported yet ***** ^ not supported yet 47 last := [Source+Size-1:0]; ***** ^ not supported yet ***** ^ not supported yet 48 storage^.next := first; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 49 storage^.size := 0; ***** ^ not supported yet ***** ^ not supported yet 50 first^.next := last; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 51 last^.next := storage; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 52 first^.size := Size-2; ***** ^ not supported yet ***** ^ not supported yet 53 last^.size := EndMarker; ***** ^ not supported yet ***** ^ not supported yet 54 (*%T _mthread *) 55 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 56 (*%E *) 57 RETURN storage; ***** ^ not supported yet 58 END FarMakeHeap; ***** ^ not supported yet 59 60 61 PROCEDURE FarHeapAllocate(Source : FarHeapRecPtr; (* source heap *) ***** ^ undeclared identifier 62 VAR A : FarADDRESS; (* result *) ***** ^ undeclared identifier 63 Size : CARDINAL); (* request size in paragraphs *) 64 65 VAR 66 res,prev,split : FarHeapRecPtr; ***** ^ undeclared identifier 67 BEGIN 68 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 69 FarAllocate(A,Size); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 70 RETURN; 71 END; 72 (*%T _mthread *) 73 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 74 (*%E *) 75 IF Size=0 THEN INC(Size) END ; ***** ^ undeclared identifier ***** ^ not supported yet 76 prev := Source; ***** ^ not supported yet ***** ^ not supported yet 77 WHILE prev^.next^.size < Size DO ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 78 prev := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 79 END; 80 res := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 81 IF res^.size = EndMarker THEN (* heap run out of space *) ***** ^ not supported yet ***** ^ not supported yet 82 SYSTEM.EI ; ***** ^ not supported yet ***** ^ not supported yet 83 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 84 END; 85 IF res^.size = Size THEN (* block correct size *) ***** ^ not supported yet ***** ^ not supported yet 86 prev^.next := res^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 87 ELSE (* split block, bottom half returned, top half linked to free chain *) 88 split := [CARDINAL(Seg(res^))+Size:0]; ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 89 prev^.next := split; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 90 split^.next := res^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 91 split^.size := res^.size - Size; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 92 END; 93 (*%T _mthread *) 94 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 95 (*%E *) 96 A := FarADR(res^); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 97 END FarHeapAllocate; ***** ^ not supported yet 98 99 100 PROCEDURE FarHeapAvail(Source: FarHeapRecPtr) : CARDINAL; ***** ^ undeclared identifier 101 (* returns the largest block size available for allocation in paragraphs *) 102 VAR 103 size : CARDINAL; 104 p : FarHeapRecPtr; ***** ^ undeclared identifier 105 BEGIN 106 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 107 RETURN 1000H; 108 END; 109 (*%T _mthread *) 110 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 111 (*%E *) 112 p := Source^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 113 size := 0; 114 WHILE p^.size <> EndMarker DO ***** ^ not supported yet ***** ^ not supported yet 115 IF p^.size>size THEN size := p^.size END; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 116 p := p^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 117 END; 118 (*%T _mthread *) 119 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 120 (*%E *) 121 RETURN size; 122 END FarHeapAvail; ***** ^ not supported yet 123 124 125 PROCEDURE FarHeapTotalAvail(Source: FarHeapRecPtr) : CARDINAL; ***** ^ undeclared identifier 126 (* returns the total block size available for allocation in paragraphs *) 127 VAR 128 size : CARDINAL; 129 p : FarHeapRecPtr; ***** ^ undeclared identifier 130 BEGIN 131 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 132 RETURN 0FFFFH; 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 INC(size,p^.size); ***** ^ undeclared identifier ***** ^ 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 FarHeapTotalAvail; ***** ^ not supported yet 148 149 150 151 PROCEDURE FarHeapDeallocate(Source : FarHeapRecPtr; (* source heap *) ***** ^ undeclared identifier 152 VAR A: FarADDRESS; ***** ^ undeclared identifier 153 Size : CARDINAL ); (* size of block 154 in paragraphs *) 155 VAR 156 target,prev,split : FarHeapRecPtr; ***** ^ undeclared identifier 157 tseg : CARDINAL; 158 BEGIN 159 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 160 FarDeallocate(A,Size); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 161 RETURN; 162 END; 163 IF (CARDINAL(Seg(A^))=0)OR(CARDINAL(Ofs(A^))<>0) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 164 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 165 END; 166 (*%T _mthread *) 167 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 168 (*%E *) 169 IF Size=0 THEN INC(Size) END ; ***** ^ undeclared identifier ***** ^ not supported yet 170 target := A; ***** ^ not supported yet ***** ^ not supported yet 171 prev := Source; ***** ^ not supported yet ***** ^ not supported yet 172 tseg := Seg(target^); ***** ^ undeclared identifier ***** ^ not supported yet 173 WHILE CARDINAL(Seg(prev^.next^)) < tseg DO ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 174 prev := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 175 END; 176 IF CARDINAL(Seg(prev^))+prev^.size = tseg THEN (* amalgamate with prev *) ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 177 prev^.size := prev^.size + Size; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 178 target := prev; ***** ^ not supported yet ***** ^ not supported yet 179 ELSIF CARDINAL(Seg(prev^))+prev^.size > tseg THEN (* Heap corrupt *) ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 180 SYSTEM.EI; ***** ^ not supported yet ***** ^ not supported yet 181 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 182 ELSE 183 (* link after prev *) 184 target^.next := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 185 prev^.next := target; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 186 target^.size := Size; ***** ^ not supported yet ***** ^ not supported yet 187 END; 188 IF (target^.next^.size <> EndMarker) ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 189 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 190 (* amalgamate with next block *) 191 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 192 target^.next := target^.next^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 193 END; 194 A := SYSTEM.FarNIL; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 195 (*%T _mthread *) 196 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 197 (*%E *) 198 END FarHeapDeallocate; ***** ^ not supported yet 199 200 201 PROCEDURE FarHeapChangeAlloc(Source : FarHeapRecPtr; (* source heap *) ***** ^ undeclared identifier 202 A : FarADDRESS; (* block to change *) ***** ^ undeclared identifier 203 OldSize, (* old size of block *) 204 NewSize : CARDINAL) (* new size of block *) 205 (* in paragraphs *) 206 : BOOLEAN; (* if sucessful *) 207 208 (* This procedure attempts to change the size of an allocated block 209 It returns TRUE if succeeded (only expansion can fail) 210 *) 211 212 VAR 213 target,prev, 214 split : FarHeapRecPtr; ***** ^ undeclared identifier 215 tseg : CARDINAL; 216 result : BOOLEAN; 217 extendsize : CARDINAL; 218 Res : FarADDRESS; ***** ^ undeclared identifier 219 BEGIN 220 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 221 RETURN FALSE; 222 END; 223 IF (CARDINAL(Seg(A^))=0)OR(CARDINAL(Ofs(A^))<>0) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 224 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 225 END; 226 IF OldSize = NewSize THEN RETURN TRUE END; 227 IF OldSize > NewSize THEN 228 target := [CARDINAL(Seg(A^))+NewSize:0]; ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 229 FarHeapDeallocate(Source,target,OldSize-NewSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 230 RETURN TRUE; 231 END; 232 extendsize := NewSize-OldSize; 233 (*%T _mthread *) 234 Process.Lock; ***** ^ not supported yet ***** ^ not supported yet 235 (*%E *) 236 target := A; ***** ^ not supported yet ***** ^ not supported yet 237 prev := Source; ***** ^ not supported yet ***** ^ not supported yet 238 tseg := Seg(target^); ***** ^ undeclared identifier ***** ^ not supported yet 239 WHILE CARDINAL(Seg(prev^.next^)) < tseg DO ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 240 prev := prev^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 241 END; 242 IF (prev^.next^.size <> EndMarker) AND ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 243 (CARDINAL(Seg(prev^.next^)) = CARDINAL(Seg(target^))+OldSize) AND ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 244 (extendsize <= prev^.next^.size) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 245 IF (extendsize = prev^.next^.size) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 246 prev^.next := prev^.next^.next ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 247 ELSE 248 split := [CARDINAL(Seg(target^))+NewSize:0]; ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 249 split^.next := prev^.next^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 250 split^.size := prev^.next^.size - extendsize; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 251 prev^.next := split; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 252 END; 253 result := TRUE; 254 ELSE 255 result := FALSE; 256 END; 257 (*%T _mthread *) 258 Process.Unlock; ***** ^ not supported yet ***** ^ not supported yet 259 (*%E *) 260 RETURN result; 261 END FarHeapChangeAlloc; ***** ^ not supported yet 262 263 264 265 PROCEDURE FarHeapChangeSize(Source : FarHeapRecPtr; (* source heap *) ***** ^ undeclared identifier 266 VAR A : FarADDRESS; (* block to change *) ***** ^ undeclared identifier 267 OldSize, (* old size of block *) 268 NewSize : CARDINAL ); (* new size of block 269 in paragraphs *) 270 271 (* 272 This procedure will change the size of an allocated block 273 avoiding any copy of data if possible 274 calls HeapChangeAlloc 275 *) 276 277 VAR 278 na : FarADDRESS; ***** ^ undeclared identifier 279 BEGIN 280 IF Source = MainHeap THEN ***** ^ not supported yet ***** ^ undeclared identifier 281 Lib.RunTimeError(CoreSig._FatalErrorPos(), 94H, 'FarHeapChangeSize : Out Of Memory'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 282 RETURN; 283 END; 284 IF NOT FarHeapChangeAlloc ( Source, A, OldSize, NewSize ) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 285 FarHeapAllocate(Source,na,NewSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 286 Lib.FarWordMove(A, na, OldSize*8); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 287 FarHeapDeallocate(Source,A,OldSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 288 A := na; ***** ^ not supported yet ***** ^ not supported yet 289 END; 290 END FarHeapChangeSize; ***** ^ not supported yet 291 292 293 PROCEDURE NearMakeHeap(Source: NearADDRESS; Size: CARDINAL): NearHeapRecPtr; ***** ^ undeclared identifier ***** ^ undeclared identifier 294 (* ========== *) 295 VAR Storage, FirstFree: NearHeapRecPtr; ***** ^ undeclared identifier 296 BEGIN 297 Size := (Size DIV Align) * Align; 298 IF Size < 10 THEN 299 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 300 END; 301 Storage := NearHeapRecPtr(Source); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 302 Storage^.next := NearHeapRecPtr(CARDINAL(Source)+Align); ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 303 Storage^.size :=4; ***** ^ not supported yet ***** ^ not supported yet 304 FirstFree := Storage^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 305 FirstFree^.size := Size - Align; ***** ^ not supported yet ***** ^ not supported yet 306 FirstFree^.next := SYSTEM.NearNIL; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 307 RETURN Storage; ***** ^ not supported yet 308 END NearMakeHeap; ***** ^ not supported yet 309 310 PROCEDURE NearHeapAllocate(Source: NearHeapRecPtr; VAR A: NearADDRESS; Size: CARDINAL); ***** ^ undeclared identifier ***** ^ undeclared identifier 311 (* ======== *) 312 VAR Base, Free, New: NearHeapRecPtr; ***** ^ undeclared identifier 313 BEGIN 314 IF Size = 0 THEN INC(Size) END; ***** ^ undeclared identifier ***** ^ not supported yet 315 Size := (( (Size+Align-1) DIV Align) * Align) + Align; 316 IF Size = 0 THEN 317 Size:=MAX(CARDINAL); ***** ^ undeclared identifier ***** ^ not supported yet 318 END; 319 Base := Source; ***** ^ not supported yet ***** ^ not supported yet 320 LOOP 321 Free := Base^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 322 IF Free = SYSTEM.NearNIL THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 323 IF Check THEN ***** ^ undeclared identifier 324 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 325 ELSE 326 A := SYSTEM.NearNIL; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 327 RETURN; 328 END; 329 ELSIF Free^.size >= Size THEN ***** ^ not supported yet ***** ^ not supported yet 330 EXIT; 331 END; 332 Base := Free; ***** ^ not supported yet ***** ^ not supported yet 333 END; 334 IF Free^.size = Size THEN ***** ^ not supported yet ***** ^ not supported yet 335 Base^.next := Free^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 336 ELSE 337 New := NearHeapRecPtr(CARDINAL(Free)+Size); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 338 Base^.next := New; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 339 New^.size := Free^.size - Size; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 340 New^.next := Free^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 341 END; 342 IF ClearOnAllocate THEN ***** ^ undeclared identifier 343 Lib.WordFill ( ADDRESS(CARDINAL(Free)+Align) , (Size-Align) DIV 2 , 0 ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 344 END; 345 A := NearADDRESS(CARDINAL(Free)+Align); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 346 END NearHeapAllocate; ***** ^ not supported yet 347 348 PROCEDURE Merge(PrevRec, LowRec, HighRec, Source: NearHeapRecPtr); ***** ^ undeclared identifier 349 350 BEGIN 351 IF (LowRec = SYSTEM.NearNIL) OR (HighRec = SYSTEM.NearNIL) THEN RETURN END; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 352 IF (LowRec = Source) THEN RETURN END; ***** ^ not supported yet ***** ^ not supported yet 353 IF NearHeapRecPtr(CARDINAL(LowRec)+LowRec^.size) # HighRec THEN RETURN END; ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 354 INC(LowRec^.size, HighRec^.size); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 355 LowRec^.next:=HighRec^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 356 PrevRec^.next:=LowRec; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 357 RETURN; 358 END Merge; ***** ^ not supported yet 359 360 PROCEDURE NearHeapDeallocate(Source: NearHeapRecPtr; VAR A: NearADDRESS; Size: CARDINAL ); ***** ^ undeclared identifier ***** ^ undeclared identifier 361 362 VAR 363 Curr, Base, Free: NearHeapRecPtr; ***** ^ undeclared identifier 364 365 BEGIN 366 Size := (( (Size+Align-1) DIV Align) * Align) + Align; 367 Curr := NearHeapRecPtr(CARDINAL(A) - Align); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 368 A := SYSTEM.NearNIL; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 369 IF Curr = SYSTEM.NearNIL THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 370 Lib.RunTimeError(CoreSig._FatalErrorPos(), 97H, 'NearHeapDeallocate: Invalid Argument'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 371 END; 372 Base:=Source; ***** ^ not supported yet ***** ^ not supported yet 373 LOOP 374 Free := Base^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 375 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 376 Base := Free; ***** ^ not supported yet ***** ^ not supported yet 377 END; 378 IF (CARDINAL(Base) + Base^.size = CARDINAL(Curr)) AND (Base # Source) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 379 INC ( Base^.size , Size ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 380 Curr := Base; ***** ^ not supported yet ***** ^ not supported yet 381 ELSE 382 Base^.next := Curr; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 383 Curr^.next := Free; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 384 Curr^.size := Size; ***** ^ not supported yet ***** ^ not supported yet 385 END; 386 IF CARDINAL(Curr) + Curr^.size = CARDINAL(Free) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 387 INC ( Curr^.size, Free^.size); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 388 Curr^.next := Free^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 389 END; 390 END NearHeapDeallocate; ***** ^ not supported yet 391 392 PROCEDURE NearHeapAvail(Source: NearHeapRecPtr): CARDINAL; ***** ^ undeclared identifier 393 394 VAR 395 Curr: NearHeapRecPtr; ***** ^ undeclared identifier 396 Size: CARDINAL; 397 BEGIN 398 Curr := Source; ***** ^ not supported yet ***** ^ not supported yet 399 Size := 0; 400 WHILE Curr # SYSTEM.NearNIL DO ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 401 IF Size < Curr^.size THEN ***** ^ not supported yet ***** ^ not supported yet 402 Size := Curr^.size; ***** ^ not supported yet ***** ^ not supported yet 403 END; 404 Curr := Curr^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 405 END; 406 RETURN Size - Align; 407 END NearHeapAvail; ***** ^ not supported yet 408 409 410 PROCEDURE NearHeapTotalAvail(Source: NearHeapRecPtr): CARDINAL; ***** ^ undeclared identifier 411 412 VAR 413 Curr: NearHeapRecPtr; ***** ^ undeclared identifier 414 Size: CARDINAL; 415 BEGIN 416 Curr := Source^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 417 Size := 0; 418 WHILE Curr # SYSTEM.NearNIL DO ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 419 INC ( Size , Curr^.size - Align); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 420 Curr := Curr^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 421 END; 422 RETURN Size; 423 END NearHeapTotalAvail; ***** ^ not supported yet 424 425 426 427 PROCEDURE NearHeapChangeSize(Source: NearHeapRecPtr; VAR A: NearADDRESS; ***** ^ undeclared identifier ***** ^ undeclared identifier 428 OldSize, NewSize : CARDINAL); 429 430 VAR 431 Curr, NextRec, PrevRec, NewRec: NearHeapRecPtr; ***** ^ undeclared identifier 432 SplitSize: CARDINAL; 433 OldA: NearADDRESS; ***** ^ undeclared identifier 434 BEGIN 435 NewSize := (( (NewSize+Align-1) DIV Align) * Align) + Align; 436 OldSize := (( (OldSize+Align-1) DIV Align) * Align) + Align; 437 IF OldSize = NewSize THEN RETURN END; 438 Curr:=NearHeapRecPtr(CARDINAL(A)-Align); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 439 NextRec:=Source; ***** ^ not supported yet ***** ^ not supported yet 440 PrevRec:=Source; ***** ^ not supported yet ***** ^ not supported yet 441 LOOP 442 IF NextRec = SYSTEM.NearNIL THEN EXIT END; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 443 IF CARDINAL(NextRec) > CARDINAL(Curr) THEN EXIT END; ***** ^ not supported yet ***** ^ not supported yet 444 PrevRec:=NextRec; ***** ^ not supported yet ***** ^ not supported yet 445 NextRec:=NextRec^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 446 END; 447 IF OldSize > NewSize THEN 448 SplitSize:=OldSize-NewSize; 449 Curr^.size:=NewSize; ***** ^ not supported yet ***** ^ not supported yet 450 NewRec:=NearHeapRecPtr(CARDINAL(Curr)+NewSize); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 451 NewRec^.size:=SplitSize; ***** ^ not supported yet ***** ^ not supported yet 452 NewRec^.next:=PrevRec^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 453 PrevRec^.next:=NewRec; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 454 Merge(PrevRec, NewRec, NextRec, Source); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 455 RETURN ; 456 END; 457 IF NearHeapRecPtr(CARDINAL(Curr)+OldSize) = NextRec THEN (* Next Block is free *) ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 458 Curr^.size := OldSize; ***** ^ not supported yet ***** ^ not supported yet 459 Merge(PrevRec, Curr, NextRec, Source); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 460 IF OldSize = NewSize THEN 461 PrevRec^.next := Curr^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 462 RETURN; 463 ELSE 464 NewRec := NearHeapRecPtr(CARDINAL(Curr)+NewSize); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 465 NewRec^.size := Curr^.size-NewSize; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 466 NewRec^.next := Curr^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 467 PrevRec^.next := NewRec; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 468 RETURN; 469 END; 470 END; 471 OldA:=A; ***** ^ not supported yet ***** ^ not supported yet 472 NearHeapDeallocate(Source, A, OldSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 473 NearHeapAllocate(Source, A, NewSize); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 474 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 475 RETURN; 476 END NearHeapChangeSize; ***** ^ not supported yet 477 478 PROCEDURE NearHeapChangeAlloc(Source: NearHeapRecPtr; A: NearADDRESS; ***** ^ undeclared identifier ***** ^ undeclared identifier 479 OldSize, NewSize : CARDINAL): BOOLEAN; 480 481 VAR 482 Curr, NextRec, PrevRec, NewRec: NearHeapRecPtr; ***** ^ undeclared identifier 483 SplitSize: CARDINAL; 484 BEGIN 485 NewSize := (( (NewSize+Align-1) DIV Align) * Align) + Align; 486 OldSize := (( (OldSize+Align-1) DIV Align) * Align) + Align; 487 IF OldSize = NewSize THEN RETURN TRUE END; 488 Curr:=NearHeapRecPtr(CARDINAL(A)-Align); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 489 PrevRec:=Source; ***** ^ not supported yet ***** ^ not supported yet 490 NextRec:=Source; ***** ^ not supported yet ***** ^ not supported yet 491 LOOP 492 IF NextRec = SYSTEM.NearNIL THEN EXIT END; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 493 IF CARDINAL(NextRec) > CARDINAL(Curr) THEN EXIT END; ***** ^ not supported yet ***** ^ not supported yet 494 PrevRec:=NextRec; ***** ^ not supported yet ***** ^ not supported yet 495 NextRec:=NextRec^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 496 END; 497 IF OldSize > NewSize THEN 498 SplitSize:=OldSize-NewSize; 499 Curr^.size:=NewSize; ***** ^ not supported yet ***** ^ not supported yet 500 NewRec:=NearHeapRecPtr(CARDINAL(Curr)+NewSize); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 501 NewRec^.size:=SplitSize; ***** ^ not supported yet ***** ^ not supported yet 502 NewRec^.next:=PrevRec^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 503 PrevRec^.next:=NewRec; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 504 Merge(PrevRec, NewRec, NextRec, Source); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 505 RETURN TRUE; 506 END; 507 IF NearHeapRecPtr(CARDINAL(Curr)+OldSize) = NextRec THEN (* Next Block is free *) ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 508 Curr^.size := OldSize; ***** ^ not supported yet ***** ^ not supported yet 509 Merge(PrevRec, Curr, NextRec, Source); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 510 IF OldSize = NewSize THEN 511 PrevRec^.next := Curr^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 512 ELSE 513 NewRec := NearHeapRecPtr(CARDINAL(Curr)+NewSize); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 514 NewRec^.size := OldSize-NewSize; ***** ^ not supported yet ***** ^ not supported yet 515 NewRec^.next := Curr^.next; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 516 PrevRec^.next := NewRec; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 517 END; 518 RETURN TRUE; 519 ELSE 520 RETURN FALSE; 521 END; 522 END NearHeapChangeAlloc; ***** ^ not supported yet 523 524 525 TYPE 526 HANDLEPtr = POINTER TO Windows.HANDLE; ***** ^ not supported yet 527 528 529 PROCEDURE NearDeallocate(VAR a: NearADDRESS; size: CARDINAL); ***** ^ undeclared identifier 530 531 BEGIN 532 IF ORD(Windows.LocalFree(Windows.HANDLE(a))) # 0 THEN END; ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 533 a:= NearADDRESS(NIL); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 534 END NearDeallocate; ***** ^ not supported yet 535 536 PROCEDURE NearAllocate(VAR a: NearADDRESS; size: CARDINAL); ***** ^ undeclared identifier 537 538 VAR 539 mode: CARDINAL; 540 h: Windows.HANDLE; ***** ^ not supported yet 541 BEGIN 542 IF size = 0 THEN size := 2 END; 543 mode := Windows.LMEM_FIXED; ***** ^ not supported yet ***** ^ not supported yet 544 IF ClearOnAllocate THEN ***** ^ undeclared identifier 545 mode := mode + Windows.LMEM_ZEROINIT; ***** ^ not supported yet ***** ^ not supported yet 546 END; 547 h := Windows.LocalAlloc(mode, size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 548 IF ORD(h) = 0 THEN ***** ^ undeclared identifier ***** ^ not supported yet 549 Lib.RunTimeError(CoreSig._FatalErrorPos(), 98H, 'NearAllocate: Out Of Memory'); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 550 END; 551 a := NearADDRESS(h); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 552 END NearAllocate; ***** ^ not supported yet 553 554 PROCEDURE NearAvailable(size: CARDINAL) : BOOLEAN; 555 556 BEGIN 557 RETURN TRUE; 558 END NearAvailable; ***** ^ not supported yet 559 560 PROCEDURE FarAllocate (VAR a: FarADDRESS; size: CARDINAL); ***** ^ undeclared identifier 561 562 BEGIN 563 a := Windows.GlobalLock(Windows.GlobalAlloc(Windows.GMEM_MOVEABLE,LONGCARD(size))); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 564 END FarAllocate; ***** ^ not supported yet 565 566 PROCEDURE FarDeallocate(VAR a: FarADDRESS; size: CARDINAL); ***** ^ undeclared identifier 567 568 VAR h : Windows.HANDLE; ***** ^ not supported yet 569 BEGIN 570 h := CARDINAL(Windows.GlobalHandle(Seg(a^))); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 571 Windows.GlobalUnlock(h); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 572 Windows.GlobalFree(h); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 573 a := FarNIL; ***** ^ not supported yet ***** ^ undeclared identifier 574 END FarDeallocate; ***** ^ not supported yet 575 576 PROCEDURE FarAvailable(size: CARDINAL ): BOOLEAN; 577 578 BEGIN 579 RETURN TRUE; 580 END FarAvailable; ***** ^ not supported yet 581 582 PROCEDURE SegAllocate(Size: CARDINAL): CARDINAL; 583 VAR 584 a : FarADDRESS; ***** ^ undeclared identifier 585 BEGIN 586 FarAllocate(a,Size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 587 RETURN Seg(a^); ***** ^ undeclared identifier ***** ^ not supported yet 588 END SegAllocate; ***** ^ not supported yet 589 590 PROCEDURE SegDeallocate(Sel: CARDINAL; Size: CARDINAL); 591 VAR a : FarADDRESS; ***** ^ undeclared identifier 592 BEGIN 593 a := [Sel:0]; ***** ^ not supported yet ***** ^ not supported yet 594 FarDeallocate(a,Size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 595 END SegDeallocate; ***** ^ not supported yet 596 597 598 599 BEGIN 600 MainHeap:=[0:0FFFFH]; ***** ^ undeclared identifier ***** ^ not supported yet 601 END Storage. ***** ^ not supported yet 787 errors