Listing: 1 IMPLEMENTATION MODULE GenLists; 2 (* 3 * REPERTOIRE 4 * Release 1.6 5 * By Charles Bradford and Cole Brecheen 6 * (c) Copyright 1985-1992 PMI 7 * Green Bay, Wisconsin 8 * All rights reserved 9 * (414) 468-6040 10 * 11 * $Header: D:/logfiles/mods/genlists.mov 1.6 30 Dec 1990 17:41:34 coleb $ 12 * 13 *) 14 15 16 (*EntryDiag: 17 IMPORT Diagnostics; 18 :EntryDiag*) 19 20 IMPORT ErrorManager; 21 IMPORT LowLevel; 22 IMPORT M2Strings; 23 IMPORT Numbers; 24 IMPORT NumTypes; 25 IMPORT PosUtils; 26 IMPORT StrEdit; 27 IMPORT StrConv; 28 IMPORT SYSTEM; 29 IMPORT VStorage; 30 31 VAR 32 ModInitialized : BOOLEAN; 33 34 PROCEDURE Init(); 35 BEGIN 36 IF ModInitialized THEN 37 RETURN; 38 ELSE 39 ModInitialized := TRUE; 40 END; 41 (*EntryDiag: 42 Diagnostics.Init(); 43 :EntryDiag*) 44 45 ErrorManager.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 46 LowLevel.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 47 M2Strings.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 48 Numbers.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 49 NumTypes.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 50 PosUtils.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 51 StrEdit.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 52 StrConv.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 53 VStorage.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 54 (*EntryDiag: 55 Diagnostics.diagS( 'Entering GenLists', '' ); 56 :EntryDiag*) 57 58 ErrorFlag := NoListError; ***** ^ undeclared identifier ***** ^ undeclared identifier 59 DiagMode := FALSE; ***** ^ undeclared identifier 60 61 (*EntryDiag: 62 Diagnostics.diagS( 'Exiting GenLists', '' ); 63 :EntryDiag*) 64 END Init; ***** ^ not supported yet 65 66 CONST 67 InitKey = 53304; 68 NoMemErStr = "Lack Memory"; ***** ^ not supported yet 69 RangeErStr = "GenList ref. out of range"; ***** ^ not supported yet 70 Circularity = "Can't insert a list into itself"; ***** ^ not supported yet 71 72 TYPE 73 GenList = POINTER TO GenListRec; ***** ^ undeclared identifier 74 ElmtPtr = POINTER TO GenElmt; ***** ^ undeclared identifier 75 GenElmt = 76 RECORD 77 FromBlock : BOOLEAN; 78 (*We have to track this because the BlockToList procedure 79 could assign addresses and sizes to a data area that it 80 did not get from the Storage module.*) 81 size : CARDINAL; 82 prv, nxt : ElmtPtr; 83 type : CARDINAL; 84 CASE : CARDINAL OF ***** ^ not supported yet ***** ^ 'POINTER' expected 85 (* Changed from tagged to untagged variant 14 Nov 87 86 because Stony Brook actually enforces matched 87 references. Making type a tag never did anything for 88 us anyway. *) 89 0 : 90 elem : SYSTEM.ADDRESS; 91 | ListCode : 92 Lelem : POINTER TO GenList; 93 | StrCode : 94 Selem : POINTER TO ARRAY [0..255] OF CHAR; 95 (*Using extremely large strings here seem to blow the 96 RTD's workspace, for some reason.*) 97 | 65530 : 98 handle : VStorage.MemHandle; 99 | 65529 : 100 Ielem : POINTER TO INTEGER; 101 | 65528 : 102 Celem : POINTER TO CARDINAL; 103 | 65527 : 104 Belem : POINTER TO BOOLEAN; 105 | 65526 : 106 Chelem : POINTER TO CHAR; 107 END; 108 END; 109 110 BlockDescriptor = 111 RECORD 112 ElmtRecsAddr : SYSTEM.ADDRESS; 113 ElmtRecsSize : CARDINAL; 114 DataAddr : VStorage.MemHandle; 115 DataSize : CARDINAL; 116 END; 117 118 GenListRec = 119 RECORD 120 ParentList : GenList; 121 (*This has to be the first field in the record.*) 122 InitCheck : CARDINAL; 123 BlockList : GenList; 124 (*A list of BlockDescriptors. Used only when the list is 125 allocated with BlockToList.*) 126 current, lngth : CARDINAL; 127 first, now, last : ElmtPtr; 128 END; 129 130 131 PROCEDURE AdrOfList(VAR TheList : GenList) : SYSTEM.ADDRESS; 132 BEGIN 133 RETURN SYSTEM.ADR(TheList); 134 END AdrOfList; 135 136 137 PROCEDURE AdrToList(TheAddr : SYSTEM.ADDRESS; TheSize : CARDINAL; VAR 138 TheList : GenList) : BOOLEAN; 139 BEGIN 140 IF TheSize # SYSTEM.TSIZE(GenList) THEN 141 RETURN FALSE; 142 ELSE 143 LowLevel.Move(TheAddr, SYSTEM.ADR(TheList), TheSize); 144 RETURN TRUE; 145 END; 146 END AdrToList; 147 148 149 150 PROCEDURE ListMove(TheList : GenList; spot : CARDINAL) : BOOLEAN; 151 VAR 152 dist1, dist2, dist3, SmallestDist : INTEGER; 153 BEGIN 154 IF spot=0 THEN 155 (*diag*) 156 ErrorFlag := RefToZero; 157 RETURN FALSE; 158 END; 159 WITH TheList^ DO 160 IF spot>lngth THEN 161 current := lngth; 162 now := last; 163 ErrorFlag := RefPastEnd; 164 RETURN FALSE; 165 ELSE 166 dist1 := INTEGER(spot)-1; 167 dist2 := INTEGER(spot)-INTEGER(lngth); 168 dist3 := INTEGER(spot)-INTEGER(current); 169 (*Now we need to know which of these is smallest.*) 170 IF ABS(dist1)>ABS(dist2) THEN 171 IF ABS(dist2)>ABS(dist3) THEN 172 SmallestDist := dist3; 173 ELSE 174 now := last; 175 current := lngth; 176 SmallestDist := dist2; 177 END; 178 ELSE 179 IF ABS(dist1)>ABS(dist3) THEN 180 SmallestDist := dist3; 181 ELSE 182 now := first; 183 current := 1; 184 SmallestDist := dist1; 185 END; 186 END; 187 IF SmallestDist>0 THEN 188 WHILE (currentspot) AND (now#NIL) DO 194 now := now^.prv; 195 DEC(current); 196 END; 197 END; 198 END; 199 END; 200 ErrorFlag := NoListError; 201 RETURN TRUE; 202 END ListMove; 203 204 205 PROCEDURE MoveToSpot(TheList : GenList; spot : CARDINAL); 206 VAR 207 TmpStr: ARRAY [0..47] OF CHAR; 208 BEGIN 209 IF NOT ListMove(TheList,spot) THEN 210 StrConv.CardinalToStr( spot, 0, TmpStr ); 211 M2Strings.Insert( "Can't move to list spot ", TmpStr, 0 ); 212 ErrorManager.WARN(TmpStr); 213 END; 214 END MoveToSpot; 215 216 217 PROCEDURE GetChildList(TheList : GenList; spot : CARDINAL; VAR 218 Child : GenList); 219 BEGIN 220 MoveToSpot( TheList, spot ); 221 IF (TheList^.now^.type#ListCode) OR (TheList^.now^.size# SYSTEM.TSIZE( 222 GenList)) THEN 223 ErrorFlag := NoSuchList; 224 ErrorManager.WARN('Non-list passed to GetChildList'); 225 RETURN; 226 END; 227 VStorage.ReadMem(TheList^.now^.handle, 0, 228 SYSTEM.ADR(Child), SYSTEM.TSIZE(GenList)); 229 ErrorFlag := NoListError; 230 END GetChildList; 231 232 233 PROCEDURE CircularLinkage( ElmtAdr: SYSTEM.ADDRESS; ElmtSize: 234 CARDINAL; BigList : GenList; GoingUp: BOOLEAN ): BOOLEAN; 235 (*Here we are trying to detect attempts to insert a list into 236 itself, or into one of its own sublists, or into a list 237 into which it has already been inserted.*) 238 VAR 239 tmpsize, cnt, TypeCode, ListEnd : CARDINAL; 240 tmpadr : SYSTEM.ADDRESS; 241 SubList, SmallList: GenList; 242 BEGIN 243 IF (NOT DiagMode) OR (BigList = NIL) THEN 244 RETURN FALSE; 245 END; 246 IF NOT AdrToList( ElmtAdr, ElmtSize, SmallList ) THEN 247 RETURN FALSE; 248 END; 249 IF SmallList = NIL THEN 250 (*Note that it's okay to have more than one NIL list 251 in a list.*) 252 RETURN FALSE; 253 END; 254 IF (SmallList = BigList) THEN 255 ErrorFlag := corruption; 256 RETURN TRUE; 257 END; 258 IF GoingUp AND (BigList^.ParentList # NIL) THEN 259 IF CircularLinkage( ElmtAdr, ElmtSize, BigList^.ParentList, TRUE ) THEN 260 RETURN TRUE; 261 END; 262 END; 263 ListEnd := ListLength( BigList ); 264 FOR cnt := 1 TO ListEnd DO 265 GetElmtAdr( BigList, cnt, tmpadr, tmpsize, TypeCode ); 266 IF TypeCode = ListCode THEN 267 GetChildList( BigList, cnt, SubList ); 268 IF (SmallList = SubList) THEN 269 ErrorFlag := corruption; 270 RETURN TRUE; 271 ELSE 272 IF CircularLinkage( ElmtAdr, ElmtSize, SubList, FALSE ) THEN 273 RETURN TRUE; 274 END; 275 END; 276 END; 277 END; 278 RETURN FALSE; 279 END CircularLinkage; 280 281 282 PROCEDURE InitResponse(msg : ARRAY OF CHAR); 283 (*All calls to InitResponse are diagnostic. Remove them from 284 finished programs.*) 285 VAR 286 TmpStr : ARRAY [0..79] OF CHAR; 287 BEGIN 288 StrEdit.AssignStr('Uninit. list passed to ', TmpStr); 289 StrEdit.Append(TmpStr, msg); 290 ErrorManager.WARN(TmpStr); 291 END InitResponse; 292 293 294 (* =========================== 295 Exported procedures. 296 =========================== *) 297 298 299 PROCEDURE NewList(VAR TheList : GenList); 300 VAR 301 size : CARDINAL; 302 BEGIN 303 IF (NOT ModInitialized) THEN Init() END; 304 size := SYSTEM.TSIZE(GenListRec); 305 VStorage.DosAlloc(TheList, SYSTEM.TSIZE(GenListRec)); 306 TheList^.InitCheck := InitKey; 307 TheList^.ParentList := NIL; 308 TheList^.BlockList := NIL; 309 TheList^.current := 0; 310 TheList^.lngth := 0; 311 TheList^.first := NIL; 312 TheList^.now := NIL; 313 TheList^.last := NIL; 314 ErrorFlag := NoListError; 315 END NewList; 316 317 318 PROCEDURE BlockToList(TheAddr: SYSTEM.ADDRESS; BlockSize: CARDINAL; 319 delimiter1, delimiter2: ARRAY OF CHAR; RecSize, TypeCode: 320 CARDINAL; VAR TheList: GenList); 321 322 (*We're doing a lot of stuff to avoid problems with disposing 323 of lists created this way. The problems tend to arise 324 because the Storage module doesn't know that any of this stuff 325 has been allocated except the big contiguous areas for the 326 data and the list.*) 327 328 VAR 329 cnt, spot1, spot2, Delim1Len, Delim2Len, elements: CARDINAL; 330 TmpBlockDescr: BlockDescriptor; 331 TmpList: GenList; 332 TwoDelimiters, FixedLengthRecs: BOOLEAN; 333 BlockAdr: SYSTEM.ADDRESS; 334 335 PROCEDURE MakeOneList(TheList: GenList); 336 VAR 337 Tmptr, OldPtr: ElmtPtr; 338 CheckStr: ARRAY [0..15] OF CHAR; 339 SubList: GenList; 340 EndFound : BOOLEAN; 341 tmpadr: SYSTEM.ADDRESS; 342 BEGIN 343 IF (NOT FixedLengthRecs) AND TwoDelimiters THEN 344 spot2 := spot1; 345 IF TypeCode < 65000 THEN 346 (* getting type from file, so make room for it *) 347 INC(spot2, 2); 348 END; 349 IF 0 = PosUtils.PosAdr(delimiter2, LowLevel.AddAddr(BlockAdr, spot2), 350 BlockSize - spot2) THEN 351 (* If an ending delimiter starts this list, it is a null 352 list, so exit without putting any elements in it *) 353 spot1 := spot2; 354 RETURN; 355 END; 356 END; 357 OldPtr := NIL; 358 EndFound := FALSE; 359 WHILE (cnt <= (elements - 1)) AND (NOT EndFound) DO 360 Tmptr := ElmtPtr( LowLevel.AddAddr(TmpBlockDescr.ElmtRecsAddr, 361 (cnt * SYSTEM.TSIZE(GenElmt)))); 362 (*Tmptr gets the address of the next unused area of the 363 list block.*) 364 INC(cnt); 365 IF TwoDelimiters AND (Delim1Len > 0) THEN 366 spot1 := PosUtils.PosAdr(delimiter1, 367 LowLevel.AddAddr(BlockAdr, spot1), BlockSize - 368 spot1) + Delim1Len + spot1; 369 IF spot1 > BlockSize THEN 370 spot1 := BlockSize; 371 END; 372 (*We've found the next delimiter1*) 373 END; 374 IF TypeCode < 65000 THEN 375 (*Any type code above 65000 REPERTOIRE considers one of 376 its own. Because it doesn't know what this type code 377 is, we leave room to get it from the block.*) 378 tmpadr := LowLevel.AddAddr(BlockAdr, spot1); 379 LowLevel.Move( tmpadr, SYSTEM.ADR(Tmptr^.type), 2); 380 IF Tmptr^.type = ListCode THEN 381 (*Now we call ourselves recursively.*) 382 NewList(SubList); 383 LowLevel.Move(SYSTEM.ADR(SubList), LowLevel.AddAddr(BlockAdr, 384 spot1 - 2), SYSTEM.TSIZE(GenList)); 385 (*We're using an unused part of the data block for 386 the data area of SubList.*) 387 Tmptr^.elem := LowLevel.AddAddr(BlockAdr, spot1 - 2); 388 SubList^.ParentList := TheList; 389 MakeOneList(SubList); 390 INC(spot1, Delim2Len); 391 ELSE 392 Tmptr^.elem := LowLevel.AddAddr(BlockAdr, spot1 + 2); 393 END; 394 ELSE 395 (*We do know what the type code is--we assume it's not in 396 the block.*) 397 Tmptr^.elem := LowLevel.AddAddr(BlockAdr, spot1); 398 (*Tmptr^.elem gets the address of some area of the data 399 block.*) 400 Tmptr^.type := TypeCode; 401 END; 402 IF NOT FixedLengthRecs THEN 403 IF Tmptr^.type = ListCode THEN 404 RecSize := 4; 405 ELSE 406 spot2 := PosUtils.PosAdr(delimiter2, 407 LowLevel.AddAddr(BlockAdr, spot1), BlockSize - 408 spot1) + spot1; 409 IF TypeCode < 65000 THEN 410 (*We don't know what the type code is--we want to get 411 it from the block--so we assume the first two bytes 412 contain it.*) 413 IF (spot1 + 2) > spot2 THEN 414 (*Something is horribly wrong; try to slip out 415 without being noticed.*) 416 RETURN; 417 END; 418 RecSize := (spot2 - spot1) - 2; 419 ELSE 420 (*We know what the type code is, so we assume it's not 421 in the block.*) 422 RecSize := spot2 - spot1; 423 END; 424 spot1 := spot2 + Delim2Len; 425 (*spot1 should now be pointing at the byte 426 immediately following the delimiter2 that we just found.*) 427 END; 428 LowLevel.Fill(SYSTEM.ADR(CheckStr), HIGH(CheckStr) + 1, 0C); 429 (* 430 IF cnt >= 171 THEN 431 Diagnostics.diagA( 'BlockAdr', BlockAdr ); 432 Diagnostics.diagC( 'spot1', spot1 ); 433 Diagnostics.diagC( 'BlockSize', BlockSize ); 434 Diagnostics.diagS( 'CheckStr', CheckStr ); 435 END; 436 *) 437 IF (spot1+Delim2Len) >= BlockSize THEN 438 (* Corrects an OS/2 segmentation fault. *) 439 EndFound := TRUE; 440 ELSE 441 tmpadr := LowLevel.AddAddr(BlockAdr, spot1); 442 LowLevel.Move( tmpadr, SYSTEM.ADR(CheckStr), Delim2Len); 443 IF TwoDelimiters AND (M2Strings.CompareStr(CheckStr, delimiter2) = 0) THEN 444 (*We've found two delimiter2's in a row, so this list 445 is ended.*) 446 EndFound := TRUE; 447 END; 448 END; 449 ELSE 450 spot1 := cnt * RecSize; 451 END; 452 Tmptr^.FromBlock := TRUE; 453 Tmptr^.size := RecSize; 454 Tmptr^.prv := OldPtr; 455 IF OldPtr = NIL THEN 456 TheList^.current := 1; 457 TheList^.first := Tmptr; 458 TheList^.now := Tmptr; 459 ELSE 460 OldPtr^.nxt := Tmptr; 461 END; 462 OldPtr := Tmptr; 463 INC(TheList^.lngth); 464 END; 465 Tmptr^.nxt := NIL; 466 TheList^.last := Tmptr; 467 END MakeOneList; 468 469 BEGIN 470 IF (NOT ModInitialized) THEN Init() END; 471 (*BlockToList*) 472 IF NOT Initialized(TheList) THEN 473 (*diag*) 474 InitResponse('BlockToList'); 475 RETURN; 476 END; 477 Delim1Len := M2Strings.Length(delimiter1); 478 Delim2Len := M2Strings.Length(delimiter2); 479 TwoDelimiters := FALSE; 480 IF VStorage.InEms( VStorage.MemHandle(TheAddr) ) THEN 481 BlockAdr := VStorage.LockMem( VStorage.MemHandle(TheAddr) ); 482 VStorage.UnLockMem( VStorage.MemHandle(TheAddr) ); 483 ELSE 484 BlockAdr := TheAddr; 485 END; 486 IF ((Delim1Len>0) OR (Delim2Len>0)) AND (RecSize>0) THEN 487 (*diag*) 488 ErrorManager.WARN("Delim-RecSize conflict"); 489 RETURN; 490 END; 491 (*Next determine how many elements are in the block.*) 492 FixedLengthRecs := RecSize > 0; 493 IF FixedLengthRecs THEN 494 elements := BlockSize DIV RecSize; 495 ELSE 496 (*The records are going to be of variable length.*) 497 IF M2Strings.CompareStr(delimiter1, delimiter2) # 0 THEN 498 TwoDelimiters := TRUE; 499 END; 500 cnt := 0; 501 elements := 0; 502 REPEAT 503 (*We count the delimiter2s in the block to determine how 504 many list elements there will be.*) 505 spot1 := PosUtils.PosAdr(delimiter2, LowLevel.AddAddr(BlockAdr, cnt), 506 BlockSize - cnt); 507 IF spot1 < (BlockSize - cnt) THEN 508 INC(elements); 509 END; 510 INC(cnt, spot1 + Delim2Len); 511 UNTIL cnt >= BlockSize; 512 END; 513 (* 514 Diagnostics.diagC( 'elements', elements ); 515 *) 516 IF (VAL(LONGINT, elements) * VAL(LONGINT, 517 SYSTEM.TSIZE(GenElmt))) > NumTypes.L65535 THEN 518 ErrorManager.WARN('RecSize too small'); 519 (*User has probably reduced RecNameLength to the point 520 that the list's controlling records will take up more 521 space than its data. If so, user needs to reduce size of 522 ThisChunk in NdxBones.ReadNdx.*) 523 RETURN; 524 END; 525 NewList(TmpList); 526 TheList^.BlockList := TmpList; 527 WITH TmpBlockDescr DO 528 DataAddr := VStorage.MemHandle(TheAddr); 529 DataSize := BlockSize; 530 ElmtRecsSize := elements * SYSTEM.TSIZE(GenElmt); 531 VStorage.DosAlloc(ElmtRecsAddr, ElmtRecsSize); 532 (*Allocates a contiguous area of memory for the GenList. 533 Note that we can't just append a list element for every 534 RecSize'd area of the block using ListInsert because 535 that would allocate an unnecessary, fragmented copy of 536 the block.*) 537 END; 538 ListInsert(TmpBlockDescr, 0, TheList^.BlockList, 65535); 539 (*Insert the BlockDescriptor into the BlockList, using 0 as 540 the type code.*) 541 IF elements = 0 THEN 542 RETURN; 543 END; 544 (*From here down we're actually building TheList.*) 545 spot1 := 0; 546 (*spot1 tracks the position of the last delimiter1 we've 547 found.*) 548 spot2 := 0; 549 (*spot2 tracks the position of the last delimiter2 we've 550 found.*) 551 cnt := 0; 552 (*cnt tracks the number of elements we've processed.*) 553 MakeOneList(TheList); 554 (*MakeOneList processes elements until all elements have 555 been processed or until two delimiter2's are found in a row.*) 556 IF FixedLengthRecs AND ((BlockSize MOD RecSize) # 0) THEN 557 (*Note that we may already have allocated lots of memory 558 for the list. If you're sure it's invalid, you have to 559 DisposeList(TheList) when BlockToList returns FALSE.*) 560 ErrorFlag := underflow; 561 ErrorManager.WARN('Bad Recsize'); 562 RETURN; 563 END; 564 ErrorFlag := NoListError; 565 END BlockToList; 566 567 568 569 PROCEDURE ChangeTypeCode(VAR TheList : GenList; spot, NewTypeCode : 570 CARDINAL); 571 BEGIN 572 MoveToSpot( TheList, spot ); 573 TheList^.now^.type := NewTypeCode; 574 END ChangeTypeCode; 575 576 577 PROCEDURE CopyList(InList : GenList; VAR OutList : GenList); 578 VAR 579 spot, OldSize, OldType, lngth : CARDINAL; 580 OldAdr : SYSTEM.ADDRESS; 581 OldChild, NewChild : GenList; 582 BEGIN 583 IF (NOT ModInitialized) THEN Init() END; 584 ErrorFlag := NoListError; 585 IF NOT Initialized(InList) THEN 586 (*diag*) 587 InitResponse('Copy'); 588 RETURN; 589 END; 590 NewList(OutList); 591 lngth := ListLength(InList); 592 FOR spot := 1 TO lngth DO 593 GetElmtAdr(InList, spot, OldAdr, OldSize, OldType); 594 IF OldType=ListCode THEN 595 VStorage.ReadMem(InList^.now^.handle, 0, 596 SYSTEM.ADR(OldChild), SYSTEM.TSIZE(GenList)); 597 IF OldChild = NIL THEN 598 NewChild := NIL; 599 ELSE 600 CopyList(OldChild, NewChild); 601 (*recursive call*) 602 END; 603 OldAdr := SYSTEM.ADR(NewChild); 604 OldSize := SYSTEM.TSIZE(GenList); 605 END; 606 ListInsertAdr(OldAdr, OldSize, OldType, OutList, spot); 607 END; 608 IF NOT ListMove( OutList, 1 ) THEN 609 (*Do nothing; point is just to reset current to 1 for 610 convenience of screen system.*) 611 END; 612 END CopyList; 613 614 615 PROCEDURE DisconnectLists( VAR sublist, mainlist: GenList ); 616 VAR 617 ListEnd, cnt, TypeCode, tmpsize: CARDINAL; 618 tmpadr: SYSTEM.ADDRESS; 619 tmplist: GenList; 620 BEGIN 621 ListEnd := ListLength( mainlist ); 622 FOR cnt := 1 TO ListEnd DO 623 GetElmtAdr( mainlist, cnt, tmpadr, tmpsize, TypeCode ); 624 IF (TypeCode = ListCode) AND AdrToList( tmpadr, tmpsize, tmplist ) THEN 625 IF (sublist = tmplist) THEN 626 mainlist^.now^.type := 0; 627 sublist^.ParentList := NIL; 628 ELSE 629 IF Initialized( tmplist ) THEN 630 DisconnectLists( sublist, tmplist ); 631 END; 632 END; 633 END; 634 END; 635 END DisconnectLists; 636 637 638 PROCEDURE DisposeList(VAR TheList : GenList); 639 VAR 640 TmpBlockDescr : BlockDescriptor; 641 TypeCode : CARDINAL; 642 BEGIN 643 IF NOT Initialized(TheList) THEN 644 (*diag*) 645 (* 646 InitResponse('DisposeList'); 647 If you want to guarantee that your code is free of needless 648 calls to DisposeList, you may want to reinsert this. 649 Reinsertion may also help you avoid subtle design problems. 650 For people just learning to use REPERTOIRE, though, this causes 651 needless irritations, so we commented it out. 652 *) 653 RETURN; 654 END; 655 IF TheList^.ParentList # NIL THEN 656 ErrorManager.WARN("Disposal of sublist before parent"); 657 END; 658 ListDelete(TheList, 1, TheList^.lngth); 659 WITH TheList^ DO 660 InitCheck := 0; 661 (*This zeroes the InitCheck in what will become phantom 662 memory. It's not strictly necessary, but it helps 663 detect cases where two GenLists point at the same 664 thing.*) 665 IF BlockList#NIL THEN 666 WHILE ListLength(BlockList)>0 DO 667 GetElmt(BlockList, 1, TmpBlockDescr, TypeCode); 668 WITH TmpBlockDescr DO 669 VStorage.DosDealloc(ElmtRecsAddr, ElmtRecsSize); 670 VStorage.DeallocMem( VStorage.MemHandle(DataAddr), DataSize ); 671 END; 672 ListDelete(BlockList, 1, 1); 673 END; 674 VStorage.DosDealloc(BlockList, SYSTEM.TSIZE(GenListRec)); 675 END; 676 END; 677 VStorage.DosDealloc(TheList, SYSTEM.TSIZE(GenListRec)); 678 TheList := NIL; 679 ErrorFlag := NoListError; 680 END DisposeList; 681 682 683 PROCEDURE ElmtNow(TheList : GenList) : CARDINAL; 684 BEGIN 685 IF NOT Initialized(TheList) THEN 686 (*diag*) 687 RETURN 0; 688 END; 689 RETURN TheList^.current; 690 END ElmtNow; 691 692 693 PROCEDURE GetElmt(TheList : GenList; spot : CARDINAL; VAR TheElmt : 694 ARRAY OF SYSTEM.BYTE; VAR TypeCode : CARDINAL); 695 VAR 696 DestSize : CARDINAL; 697 BEGIN 698 IF NOT Initialized(TheList) THEN 699 (*diag*) 700 InitResponse('Get'); 701 RETURN; 702 END; 703 MoveToSpot( TheList, spot ); 704 TypeCode := TheList^.now^.type; 705 DestSize := HIGH(TheElmt)+1; 706 WITH TheList^.now^ DO 707 IF size<=DestSize THEN 708 (*We test for this first because we're not going to 709 allow overflows.*) 710 VStorage.ReadMem(handle, 0, SYSTEM.ADR(TheElmt), size); 711 IF size (DestSize + 1)) THEN 733 IF INTEGER(DestSize) > LowLevel.ScanEQ( DestSize, 0C, 734 SYSTEM.ADR(TheElmt) ) THEN 735 (* We found a null somewhere in TheElmt; no need to worry. *) 736 ErrorFlag := NoListError; 737 RETURN; 738 END; 739 END; 740 IF (TypeCode#StrCode) OR (size> (DestSize + 1)) THEN 741 (*If it's a string, we're not going to signal an 742 overflow if size exceeds DestSize by only one, 743 because the difference is just the null terminator 744 that we probably appended in the ListInsert.*) 745 ErrorFlag := overflow; 746 ErrorManager.WARN('GetElmt Overflow'); 747 RETURN; 748 END; 749 END; 750 END; 751 ErrorFlag := NoListError; 752 END GetElmt; 753 754 755 PROCEDURE GetElmtAdr(TheList : GenList; spot : CARDINAL; VAR 756 ReadAddr : SYSTEM.ADDRESS; VAR TheSize : CARDINAL; VAR TypeCode : 757 CARDINAL); 758 BEGIN 759 IF NOT Initialized(TheList) THEN 760 (*diag*) 761 InitResponse('Get'); 762 RETURN; 763 END; 764 MoveToSpot( TheList, spot ); 765 WITH TheList^.now^ DO 766 ReadAddr := VStorage.LockMem(handle); 767 VStorage.UnLockMem(handle); 768 (* since we unlock here, the returned address is not 769 guaranteed to be good after the calling program does 770 anything that affects VStorage memory allocation *) 771 TypeCode := type; 772 TheSize := size; 773 END; 774 ErrorFlag := NoListError; 775 END GetElmtAdr; 776 777 778 PROCEDURE GetParentList(TheList : GenList; VAR Parent : GenList); 779 BEGIN 780 IF TheList^.ParentList=NIL THEN 781 ErrorFlag := NoSuchList; 782 ErrorManager.WARN("No parent"); 783 RETURN; 784 END; 785 Parent := TheList^.ParentList; 786 ErrorFlag := NoListError; 787 END GetParentList; 788 789 790 PROCEDURE Initialized(TheList : GenList) : BOOLEAN; 791 BEGIN 792 IF (NOT ModInitialized) THEN Init() END; 793 IF TheList=NIL THEN 794 ErrorFlag := NoInit; 795 RETURN FALSE; 796 ELSIF TheList^.InitCheck=InitKey THEN 797 ErrorFlag := NoListError; 798 RETURN TRUE; 799 ELSE 800 ErrorFlag := NoInit; 801 RETURN FALSE; 802 END; 803 END Initialized; 804 805 806 PROCEDURE JoinLists(VAR MergedList, SurvivingList : GenList; spot : 807 CARDINAL); 808 VAR 809 TmpList1, TmpList2 : GenList; 810 len1, len2 : LONGINT; 811 BEGIN 812 IF (NOT Initialized(MergedList)) OR (NOT Initialized( 813 SurvivingList)) THEN 814 (*diag*) 815 InitResponse('Join'); 816 END; 817 len1 := Numbers.Lc(ListLength(MergedList)); 818 len2 := Numbers.Lc(ListLength(SurvivingList)); 819 IF (len1+len2)> NumTypes.L65535 THEN 820 (*diag*) 821 ErrorManager.WARN("Join too long"); 822 RETURN; 823 END; 824 IF len1> NumTypes.L0 THEN 825 IF len2=NumTypes.L0 THEN 826 SurvivingList^ := MergedList^; 827 SurvivingList^.lngth := 0; 828 (*Because it's going to by INCed by MergedList^.lngth 829 below.*) 830 SurvivingList^.BlockList := NIL; 831 (*Because MergedList^.BlockList is going to be joined 832 to it below.*) 833 ELSIF spot>SurvivingList^.lngth THEN 834 SurvivingList^.last^.nxt := MergedList^.first; 835 MergedList^.first^.prv := SurvivingList^.last; 836 SurvivingList^.last := MergedList^.last; 837 ELSIF spot<=1 THEN 838 MergedList^.last^.nxt := SurvivingList^.first; 839 SurvivingList^.first^.prv := MergedList^.last; 840 SurvivingList^.first := MergedList^.first; 841 ELSE 842 IF ListMove(SurvivingList,spot) THEN 843 END; 844 WITH SurvivingList^ DO 845 now^.prv^.nxt := MergedList^.first; 846 MergedList^.first^.prv := now^.prv; 847 MergedList^.last^.nxt := now; 848 now^.prv := MergedList^.last; 849 END; 850 END; 851 INC(SurvivingList^.lngth, MergedList^.lngth); 852 SurvivingList^.now := SurvivingList^.first; 853 SurvivingList^.current := 1; 854 END; 855 IF (MergedList^.BlockList#NIL) 856 AND (ListLength(MergedList^.BlockList)>0) THEN 857 IF SurvivingList^.BlockList=NIL THEN 858 NewList(TmpList1); 859 SurvivingList^.BlockList := TmpList1; 860 ELSE 861 TmpList1 := SurvivingList^.BlockList; 862 END; 863 TmpList2 := MergedList^.BlockList; 864 JoinLists(TmpList2, TmpList1, 65535); 865 (*recursive call*) 866 END; 867 VStorage.DosDealloc(MergedList, SYSTEM.TSIZE(GenListRec)); 868 MergedList := NIL; 869 END JoinLists; 870 871 872 PROCEDURE ListDelete(TheList : GenList; spot, HowMany : CARDINAL); 873 VAR 874 ElementsDeleted : CARDINAL; 875 NewPrv, NewNxt : ElmtPtr; 876 SubList : GenList; 877 BEGIN 878 IF NOT Initialized(TheList) THEN 879 (*diag*) 880 InitResponse('Delete'); 881 RETURN; 882 END; 883 IF HowMany=0 THEN 884 ErrorFlag := NoListError; 885 RETURN; 886 ELSIF spot>TheList^.lngth THEN 887 ErrorFlag := RefPastEnd; 888 ErrorManager.WARN(RangeErStr); 889 RETURN; 890 END; 891 MoveToSpot( TheList, spot ); 892 ElementsDeleted := 0; 893 NewPrv := TheList^.now^.prv; 894 LOOP 895 WITH TheList^.now^ DO 896 IF type=ListCode THEN 897 VStorage.ReadMem(handle, 0, SYSTEM.ADR(SubList), 898 SYSTEM.TSIZE(GenList)); 899 (*We can't use GetChildList for this operation 900 because the list is corrupt between deletion of 901 the first and last elements.*) 902 IF Initialized(SubList) THEN 903 SubList^.ParentList := NIL; 904 (*DisposeList normally checks for a non-NIL 905 ParentList to detect disposals of sublists before 906 parents. This disables the check.*) 907 DisposeList(SubList); 908 END; 909 END; 910 (* 8 Jul 88: took following statement out of ELSIF clause 911 so as to deallocate the 4-byte pointer to the GenListRec. We 912 were previously leaking memory 4 bytes per sublist. *) 913 IF NOT FromBlock THEN 914 (*We can't deallocate the data area if it was 915 allocated as part of a big block. Instead, we'll 916 deallocate it in DisposeList.*) 917 VStorage.DeallocMem(handle, size); 918 END; 919 INC(ElementsDeleted); 920 NewNxt := nxt; 921 END; 922 IF (ElementsDeletedlngth) THEN 1046 tmp^.prv := now; 1047 tmp^.nxt := NIL; 1048 now^.nxt := tmp; 1049 INC(current); 1050 last := tmp; 1051 ELSE 1052 tmp^.prv := now^.prv; 1053 now^.prv := tmp; 1054 tmp^.nxt := now; 1055 IF tmp^.prv#NIL THEN 1056 (*We know we're not on the first element of the list.*) 1057 tmp^.prv^.nxt := tmp; 1058 ELSE 1059 (*tmp is the new first element of the list.*) 1060 first := tmp; 1061 END; 1062 END; 1063 END; 1064 tmp^.elem := TmpElmt.elem; 1065 tmp^.size := TmpElmt.size; 1066 tmp^.FromBlock := FALSE; 1067 now := tmp; 1068 INC(lngth); 1069 END; 1070 IF ErrorFlag = RefPastEnd THEN 1071 ErrorFlag := NoListError; 1072 END; 1073 END ListInsertAdr; 1074 1075 1076 PROCEDURE ListLength(TheList : GenList) : CARDINAL; 1077 (*Number of elements at this node of the list.*) 1078 BEGIN 1079 IF NOT Initialized(TheList) THEN 1080 (*diag*) 1081 InitResponse('ListLength'); 1082 RETURN 0; 1083 END; 1084 ErrorFlag := NoListError; 1085 (*added 30 Oct 86*) 1086 RETURN TheList^.lngth; 1087 END ListLength; 1088 1089 1090 PROCEDURE ListReplace(Element : ARRAY OF SYSTEM.BYTE; TypeCode : CARDINAL; 1091 TheList : GenList; spot : CARDINAL); 1092 BEGIN 1093 ListReplaceAdr(SYSTEM.ADR(Element), HIGH(Element)+1, TypeCode, TheList, 1094 spot); 1095 END ListReplace; 1096 1097 1098 PROCEDURE ListReplaceAdr(ReadAddr : SYSTEM.ADDRESS; TheSize, TypeCode : 1099 CARDINAL; TheList : GenList; spot : CARDINAL); 1100 VAR 1101 StrLen, DestSize : CARDINAL; 1102 ChildList, CheckList : GenList; 1103 tmp : ElmtPtr; 1104 Indirector : POINTER TO GenList; 1105 TmpAdr : SYSTEM.ADDRESS; 1106 BEGIN 1107 ErrorFlag := NoListError; 1108 IF NOT Initialized(TheList) THEN 1109 (*diag*) 1110 InitResponse('Replace'); 1111 RETURN; 1112 END; 1113 MoveToSpot( TheList, spot ); 1114 WITH TheList^.now^ DO 1115 IF (type = ListCode) THEN 1116 (*Now we have to dispose of the old list UNLESS it's 1117 identical to what replaces it.*) 1118 GetChildList(TheList, spot, ChildList); 1119 IF (TypeCode # ListCode) OR (NOT AdrToList( ReadAddr, 1120 TheSize, CheckList )) THEN 1121 CheckList := NIL; 1122 END; 1123 IF (CheckList # ChildList) AND (ChildList # NIL) THEN 1124 ChildList^.ParentList := NIL; 1125 (*We do this to prevent DisposeList from warning us 1126 about premature disposal of children.*) 1127 IF (CheckList # NIL) AND DiagMode THEN 1128 IF CircularLinkage( ReadAddr, TheSize, TheList, TRUE ) THEN 1129 ErrorManager.WARN( Circularity ); 1130 END; 1131 IF NOT ListMove(TheList,spot) THEN 1132 (*Have to make sure we're still in the same spot.*) 1133 RETURN; 1134 END; 1135 END; 1136 (*Check for circularity first so you won't find 1137 the disposed sublist.*) 1138 DisposeList(ChildList); 1139 (*DisposeList won't mind if ChildList is NIL.*) 1140 END; 1141 END; 1142 IF (TypeCode=StrCode) THEN 1143 (*We know here that we're dealing with strings, so an 1144 underflow won't matter. If the new string is shorter 1145 than the size of the old element's data area, we can 1146 copy over it without ALLOCATING and DEALLOCATING.*) 1147 StrLen := 1 + LowLevel.ScanEQ(TheSize,0C,ReadAddr); 1148 (*This makes sure the null terminator gets included with 1149 the string.*) 1150 IF StrLen<=size THEN 1151 TmpAdr := VStorage.LockMem(handle); 1152 LowLevel.Move(ReadAddr, TmpAdr, StrLen); 1153 LowLevel.PokeByte(0C, LowLevel.seg(TmpAdr), 1154 LowLevel.ofs(TmpAdr)+StrLen-1); 1155 (*We do this to guarantee that constant strings 1156 passed to open arrays will be stored with null 1157 terminators.*) 1158 VStorage.UnLockMem(handle); 1159 IF StrLen=TheList^.lngth THEN 1196 TheList^.last := tmp; 1197 ELSE 1198 TheList^.now^.nxt^.prv := tmp; 1199 END; 1200 ELSE 1201 VStorage.DeallocMem(TheList^.now^.handle, TheList^.now^.size); 1202 END; 1203 TheList^.now^.size := TheSize; 1204 IF NOT VStorage.AllocMem( TheList^.now^.handle, 1205 TheList^.now^.size ) THEN 1206 ErrorFlag := InsuffMem; 1207 ErrorManager.WARN(NoMemErStr); 1208 RETURN; 1209 END; 1210 END; 1211 WITH TheList^.now^ DO 1212 TmpAdr := VStorage.LockMem(handle); 1213 LowLevel.Move(ReadAddr, TmpAdr, TheSize); 1214 type := TypeCode; 1215 IF TypeCode=ListCode THEN 1216 Indirector := ReadAddr; 1217 IF Initialized(Indirector^) THEN 1218 (* 23 Dec 88: added this check for NIL to fix bug discovered 1219 by the people at LaserMaster Corp. *) 1220 Indirector^^.ParentList := TheList; 1221 END; 1222 ELSIF TypeCode=StrCode THEN 1223 LowLevel.PokeByte(0C, LowLevel.seg(TmpAdr), 1224 LowLevel.ofs(TmpAdr) + TheSize - 1 ); 1225 END; 1226 VStorage.UnLockMem(handle); 1227 END; 1228 END ListReplaceAdr; 1229 1230 1231 PROCEDURE ListSize(TheList : GenList; VAR TotalElements : LONGINT; 1232 VAR TotalSubLists : CARDINAL; VAR TotalListSize : LONGINT) : LONGINT; 1233 VAR 1234 SubList : GenList; 1235 SubListTotal : CARDINAL; 1236 SubElements, DataSize, SubSize : LONGINT; 1237 firstime : BOOLEAN; 1238 BEGIN 1239 TotalElements := NumTypes.L0; 1240 TotalSubLists := 0; 1241 DataSize := NumTypes.L0; 1242 TotalListSize := NumTypes.L0; 1243 IF NOT Initialized(TheList) THEN 1244 (*diag*) 1245 RETURN DataSize; 1246 END; 1247 IF NOT ListMove(TheList,1) THEN 1248 RETURN DataSize; 1249 END; 1250 firstime := TRUE; 1251 REPEAT 1252 IF firstime THEN 1253 firstime := FALSE; 1254 ELSE 1255 IF NOT ListMove(TheList,TheList^.current+1) THEN 1256 END; 1257 END; 1258 IF TheList^.now^.type=ListCode THEN 1259 GetChildList(TheList, TheList^.current, SubList); 1260 DataSize := DataSize+ListSize(SubList,SubElements, 1261 SubListTotal,SubSize); 1262 INC(TotalElements); 1263 (*We increment our TotalElements one for the sublist.*) 1264 TotalElements := TotalElements+SubElements; 1265 (*And again for the sublist's elements.*) 1266 INC(TotalSubLists); 1267 (*We increment it one for the sublist itself.*) 1268 INC(TotalSubLists, SubListTotal); 1269 (*And again for all the sublist's sublists.*) 1270 TotalListSize := TotalListSize+SubSize; 1271 ELSE 1272 INC(TotalElements); 1273 DataSize := DataSize + Numbers.Lc(TheList^.now^.size); 1274 TotalListSize := TotalListSize + Numbers.Lc( TheList^.now^.size ); 1275 INC(TotalListSize, SYSTEM.TSIZE(GenListRec)); 1276 END; 1277 UNTIL TheList^.current=TheList^.lngth; 1278 ErrorFlag := NoListError; 1279 RETURN DataSize; 1280 END ListSize; 1281 1282 1283 PROCEDURE ListToAdr(TheList : GenList; TheAddr : SYSTEM.ADDRESS; TheSize : 1284 CARDINAL) : BOOLEAN; 1285 BEGIN 1286 IF TheSize # SYSTEM.TSIZE(GenList) THEN 1287 RETURN FALSE; 1288 ELSE 1289 LowLevel.Move(SYSTEM.ADR(TheList), TheAddr, TheSize); 1290 RETURN TRUE; 1291 END; 1292 END ListToAdr; 1293 1294 1295 PROCEDURE ListToBlock(TheList : GenList; delimiter1, delimiter2 : 1296 ARRAY OF CHAR; VAR TheAddr : SYSTEM.ADDRESS; VAR BlockSize, RecSize : 1297 CARDINAL); 1298 (*Note that the calling program is responsible for 1299 deallocating the memory allocated by ListToBlock.*) 1300 VAR 1301 DelimSpace, BlockPtr, SubLists : CARDINAL; 1302 tmpl, elements, TotalData, TotalListSize : LONGINT; 1303 TwoDelimiters : BOOLEAN; 1304 1305 PROCEDURE CopyOut(TheList : GenList); 1306 (*This procedure has to be split out from the rest of 1307 ListToBlock because it needs to call itself recursively 1308 when it encounters a SubList. Note that it operates on the 1309 BlockPtr variable, which is global to the ListToBlock 1310 procedure. The purpose of that is to prevent the recursive 1311 calls from writing back over the start of the block.*) 1312 VAR 1313 SubList : GenList; 1314 NilList: BOOLEAN; 1315 BEGIN 1316 IF NOT Initialized( TheList ) THEN 1317 NewList( TheList ); 1318 NilList := TRUE; 1319 ELSE 1320 NilList := FALSE; 1321 END; 1322 IF NOT ListMove(TheList,1) THEN 1323 ErrorFlag := RefPastEnd; 1324 RETURN; 1325 END; 1326 WHILE ErrorFlag#RefPastEnd DO 1327 WITH TheList^.now^ DO 1328 IF TwoDelimiters THEN 1329 LowLevel.Move(SYSTEM.ADR(delimiter1), 1330 LowLevel.AddAddr(TheAddr, BlockPtr), 1331 M2Strings.Length(delimiter1)); 1332 INC(BlockPtr, M2Strings.Length(delimiter1)); 1333 (*These next two statements make the kind of block 1334 produced by ListToBlock match the structure of an 1335 NdxFile. You may want to delete them if you use 1336 ListToBlock for other purposes.*) 1337 LowLevel.Move(SYSTEM.ADR(type), 1338 LowLevel.AddAddr(TheAddr, BlockPtr), 2); 1339 INC(BlockPtr, 2); 1340 END; 1341 IF type=ListCode THEN 1342 GetChildList(TheList, TheList^.current, SubList); 1343 CopyOut(SubList); 1344 ELSE 1345 VStorage.ReadMem(handle, 0, 1346 LowLevel.AddAddr(TheAddr, BlockPtr), size); 1347 INC(BlockPtr, size); 1348 END; 1349 END; 1350 LowLevel.Move(SYSTEM.ADR(delimiter2), 1351 LowLevel.AddAddr(TheAddr, BlockPtr), 1352 M2Strings.Length(delimiter2)); 1353 INC(BlockPtr, M2Strings.Length(delimiter2)); 1354 IF ListMove(TheList,TheList^.current+1) THEN 1355 END; 1356 END; 1357 IF NilList THEN 1358 DisposeList( TheList ); 1359 END; 1360 END CopyOut; 1361 1362 BEGIN 1363 IF (NOT ModInitialized) THEN Init() END; 1364 (*ListToBlock*) 1365 TotalData := ListSize(TheList,elements,SubLists,TotalListSize); 1366 IF (TotalData> NumTypes.L65535) THEN 1367 (*We've got too much data in the list to store in a 1368 contiguous area of memory.*) 1369 ErrorFlag := InsuffMem; 1370 RETURN; 1371 END; 1372 TwoDelimiters := FALSE; 1373 IF (M2Strings.Length(delimiter1)>0) OR 1374 (M2Strings.Length(delimiter2)>0) THEN 1375 IF elements> NumTypes.L65535 THEN 1376 ErrorFlag := InsuffMem; 1377 RETURN; 1378 END; 1379 DelimSpace := Numbers.C(elements * 1380 Numbers.Lc(M2Strings.Length(delimiter1))); 1381 IF NOT PosUtils.Equal(delimiter1,delimiter2) THEN 1382 (*We're supposed to use a separate delimiter to mark the 1383 start and end of each element.*) 1384 DelimSpace := DelimSpace + Numbers.C(elements * 1385 Numbers.Lc(M2Strings.Length(delimiter2)+2)); 1386 (*It's +2 to allow room for record types. See the 1387 comment above.*) 1388 TwoDelimiters := TRUE; 1389 END; 1390 ELSE 1391 DelimSpace := 0; 1392 END; 1393 BlockSize := Numbers.C(TotalData)+DelimSpace; 1394 (* size of block created *) 1395 VStorage.DosAlloc(TheAddr, BlockSize); 1396 tmpl := elements-Numbers.Lc(SubLists); 1397 (*We use tmpl to avoid a bug in Logitech's v3.0 LongInts.*) 1398 IF (elements > Numbers.Lc(SubLists)) AND 1399 ((Numbers.Lc(BlockSize) MOD (tmpl))=NumTypes.L0) THEN 1400 RecSize := BlockSize DIV Numbers.C(tmpl); 1401 (* size of each record if they're fixed-length *) 1402 ELSE 1403 RecSize := 0; 1404 END; 1405 BlockPtr := 0; 1406 CopyOut(TheList); 1407 ErrorFlag := NoListError; 1408 END ListToBlock; 1409 1410 1411 PROCEDURE NextElmt(TheList : GenList; HowFar : INTEGER; VAR 1412 TheElmt : ARRAY OF SYSTEM.BYTE; VAR TypeCode : CARDINAL); 1413 VAR 1414 DestSize, cnt : CARDINAL; 1415 BEGIN 1416 IF NOT Initialized(TheList) THEN 1417 (*diag*) 1418 InitResponse('Next'); 1419 RETURN; 1420 END; 1421 WITH TheList^ DO 1422 cnt := ABS(HowFar); 1423 IF (TheList^.now#NIL) AND (HowFar<0) THEN 1424 WHILE (cnt>0) AND (TheList^.now^.prv#NIL) DO 1425 TheList^.now := TheList^.now^.prv; 1426 DEC(cnt); 1427 DEC(TheList^.current); 1428 END; 1429 ELSE 1430 WHILE (cnt>0) AND (TheList^.now^.nxt#NIL) DO 1431 TheList^.now := TheList^.now^.nxt; 1432 DEC(cnt); 1433 INC(TheList^.current); 1434 END; 1435 END; 1436 END; 1437 TypeCode := TheList^.now^.type; 1438 DestSize := HIGH(TheElmt)+1; 1439 WITH TheList^.now^ DO 1440 IF size<=DestSize THEN 1441 (*We test for this first because we're not going to 1442 allow overflows.*) 1443 VStorage.ReadMem(handle, 0, SYSTEM.ADR(TheElmt), size); 1444 IF sizeStartingAt) THEN 1519 WHILE (StartingAt<=EndingAt) AND (now#NIL) DO 1520 TmpAdr := VStorage.LockMem(now^.handle); 1521 spot := PosUtils.PosAdr(TheStr,TmpAdr,now^.size); 1522 (* We could use a ScanMem function here if it existed*) 1523 VStorage.UnLockMem(now^.handle); 1524 IF (spot=EndingAt) AND (now#NIL) DO 1538 TmpAdr := VStorage.LockMem(now^.handle); 1539 spot := PosUtils.PosAdr(TheStr,TmpAdr,now^.size); 1540 VStorage.UnLockMem(now^.handle); 1541 IF (spot 0 THEN 1621 Swap2Elmts(Ptr1, Ptr2); 1622 IF Elem1 > saut THEN 1623 Ptr2 := Ptr1; 1624 Elem2 := Elem1; 1625 DEC(Elem1, saut); 1626 IF ListMove(TheList, Elem1) THEN END; 1627 Ptr1 := TheList^.now; 1628 ELSE 1629 INC(Elem1); 1630 Ptr1 := Ptr1^.nxt; 1631 INC(Elem2); 1632 Ptr2 := Ptr2^.nxt; 1633 END; 1634 ELSE 1635 INC(Elem1); 1636 Ptr1 := Ptr1^.nxt; 1637 INC(Elem2); 1638 Ptr2 := Ptr2^.nxt; 1639 END (* if *); 1640 END (* while *); 1641 ELSE 1642 EXIT; 1643 END (* if *); 1644 END (* loop *); 1645 END ShellSortList; 1646 1647 1648 PROCEDURE SortList(TheList : GenList; CompResult : Comparator); 1649 (*28 July 87: replaced old SortList, which used a bubble 1650 sort, with Torbjorn Sund's version, which uses a quicksort. 1651 Performance: With a list size of N, bubble sort runs as 1652 b*N*N, QuickSort as q*N*log2(N). On a Kaypro AT at 8 MHz, 1653 b = 0.5 msec, q = 3.5 msec. 1654 *) 1655 1656 PROCEDURE QSortList(lwr, upr : ElmtPtr); 1657 VAR 1658 Pivot, Curnt : SYSTEM.ADDRESS; 1659 PivotSize, CurntSize : CARDINAL; 1660 i, m : ElmtPtr; 1661 LwrCount, UprCount : CARDINAL; 1662 BEGIN 1663 LOOP 1664 (* there goes the tail recursion *) 1665 IF lwr=upr THEN 1666 EXIT; 1667 END; 1668 WITH lwr^ DO 1669 (* could be any, preferrably a random element *) 1670 Pivot := VStorage.LockMem(handle); 1671 (* 6 Jan 88: inserted this lock to correct 1672 oversight pointed out by Dr. Michael Anderson; 1673 SortList wasn't working when EMS was installed. *) 1674 VStorage.UnLockMem(handle); 1675 (* We go ahead and unlock here because we know we 1676 will be finished with this address before 1677 something else gets swapped into its place. *) 1678 PivotSize := size; 1679 END; 1680 m := lwr; 1681 i := lwr; 1682 LwrCount := 0; 1683 UprCount := 0; 1684 WHILE i#upr DO 1685 i := i^.nxt; 1686 (* no need to worry about NIL here *) 1687 WITH i^ DO 1688 Curnt := VStorage.LockMem(handle); 1689 (* 6 Jan 88: Lock/UnLock inserted. See above. *) 1690 VStorage.UnLockMem(handle); 1691 CurntSize := size; 1692 END; 1693 IF CompResult(Pivot,PivotSize,Curnt,CurntSize)>0 THEN 1694 INC(LwrCount); 1695 m := m^.nxt; 1696 Swap2Elmts(m, i); 1697 ELSE 1698 INC(UprCount); 1699 END; 1700 END; 1701 Swap2Elmts(lwr, m); 1702 (* sort shortest interval first; this minimizes recursion depth *) 1703 IF LwrCount0 THEN 1706 QSortList(lwr, m^.prv); 1707 END; 1708 (* Instead of QSortList( m^.nxt, upr); *) 1709 lwr := m^.nxt; 1710 ELSE 1711 IF UprCount>0 THEN 1712 QSortList(m^.nxt, upr); 1713 END; 1714 (* instead of QSortList( lwr, m^.prv); *) 1715 upr := m^.prv; 1716 END; 1717 END; 1718 END QSortList; 1719 1720 BEGIN 1721 WITH TheList^ DO 1722 QSortList(first, last); 1723 END; 1724 END SortList; 1725 1726 1727 PROCEDURE SplitList(InList : GenList; where : CARDINAL; VAR 1728 OutList : GenList); 1729 VAR 1730 InLength : CARDINAL; 1731 BEGIN 1732 IF NOT Initialized(InList) THEN 1733 (*diag*) 1734 InitResponse('Split'); 1735 END; 1736 NewList(OutList); 1737 InLength := ListLength(InList); 1738 IF (where>InLength) OR (InLength=0) OR (where=0) THEN 1739 RETURN; 1740 END; 1741 IF ListMove(InList,where) THEN 1742 END; 1743 WITH InList^ DO 1744 OutList^.first := now; 1745 OutList^.current := 1; 1746 OutList^.now := now; 1747 OutList^.last := last; 1748 OutList^.lngth := (lngth-where)+1; 1749 OutList^.ParentList := ParentList; 1750 now := now^.prv; 1751 last := now; 1752 lngth := where-1; 1753 current := where-1;(* added -1 per ukah 9/15/91 *) 1754 IF lngth=0 THEN 1755 first := NIL; 1756 ELSE (* added else clause per ukah 9/15/91 *) 1757 last^.nxt :=NIL; 1758 END; 1759 OutList^.first^.prv:=NIL; (* ukah *) 1760 END; 1761 (*Note that we're leaving InList in charge of the 1762 BlockList. OutList may have a lot of FromBlock elements 1763 but nothing in its BlockList.*) 1764 END SplitList; 1765 1766 1767 BEGIN 1768 ModInitialized := FALSE; 1769 END GenLists. 38 errors