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