Listing: 1 IMPLEMENTATION MODULE Loader; 2 IMPORT SYSTEM,LoaderA; 3 FROM LoaderA IMPORT MoveUp,MainName; ***** ^ duplicate identifier 4 5 (*# data(const_in_code=>off) *) 6 (*# call(o_a_copy=>off,o_a_size=>off) *) 7 (*# call(seg_name=>null) *) 8 (*# data(near_ptr=>off,threshold=>0FFFFH) *) 9 (*#call(inline_max=>1000)*) 10 (*# call(near_call=>off,overlay=>on) *) 11 12 (* limits *) 13 CONST 14 MaxName = 80; (* size of module name *) 15 MaxSeg = 255; (* number of segments in a module *) 16 MaxEntry = 1000; (* number of entry points in a module *) 17 MaxModule = 64; (* number of modules *) 18 MaxGate = 2000; 19 HeapSize = 6000H; 20 FileLimit = 10; (* open file limit (temp file not included) *) 21 TempLimit = 8*100000H; (* 8 Megabytes *) ***** ^ not supported yet 22 TempPageShift = 10; 23 TempPageSize = 1 << TempPageShift; ***** ^ not supported yet 24 (*%T EMS*) 25 CONST EmsPageSize = 4000H DIV TempPageSize; ***** ^ not supported yet 26 (*%E*) 27 CONST PanicSize = 8000H; 28 29 TYPE SegKind = (StaticSeg, SwapSeg, MoveSeg, FixedSeg, SystemSeg); 30 TYPE SegKindSet = SET OF SegKind; ***** ^ not supported yet 31 32 (* tracing controls *) 33 CONST 34 MemoryTrace = FALSE; 35 LoadTrace = FALSE; 36 ExitTrace = FALSE; 37 MemTraceSet = SegKindSet{ StaticSeg, SwapSeg, MoveSeg, FixedSeg}; ***** ^ ';' expected 38 UsageTrace = FALSE; 39 OutOfMemTrace = FALSE; 40 MoveTrace = FALSE; 41 Debuging = FALSE; 42 GraphUseTrace = FALSE; 43 TraceToFile = FALSE; 44 45 (* emergency tracing *) 46 CONST 47 LockTrace = FALSE; 48 FileTrace = FALSE; 49 CallTrace = FALSE; 50 EntryTableTrace = FALSE; 51 RelocateTrace = FALSE; 52 53 (* error messages *) 54 55 ErrBase = 8500; 56 57 ErrOutOfMem = 0; 58 ErrTempFileLimit = 1; 59 ErrLoad = 2; 60 ErrPoolLimit = 3; 61 ErrGateLimit = 4; 62 ErrTempDiskFull = 5; 63 ErrDiskFull = 6; 64 ErrTempCreate = 7; 65 ErrInternal = 8; 66 ErrNearHeap = 9; 67 ErrModuleLimit = 10; 68 ErrInvalidProcedure = 11; 69 ErrMemoryCorruption = 12; 70 ErrTooManyUnlocks = 13; 71 ErrCallChainInvalid = 14; 72 ErrOpenFail = 15; 73 ErrNamedImport = 16; 74 ErrInvalidVUnfix = 17; 75 ErrInvalidVFix = 18; 76 ErrInvalidFree = 19; 77 78 79 80 (*-----------------------------------------------------------------------*) 81 (* low level file handling *) 82 (*-----------------------------------------------------------------------*) 83 (*# save,call(same_ds=>off) *) 84 (*# call(near_call=>on) *) 85 (*# call(reg_param=>(bx, dx, cx), reg_saved=>(ds, di, si, st1, st2)) *) 86 PROCEDURE FileSeek(h:CARDINAL;pos:LONGCARD); IN LoaderA; 87 (*# call(reg_param=>(dx, ax, cx, bx), reg_saved=>(ds, di, si, st1, st2)) *) 88 PROCEDURE FileRead(a:ADDRESS;count:CARDINAL;h:CARDINAL); IN LoaderA; 89 PROCEDURE FileWrite(a:ADDRESS;count:CARDINAL;h:CARDINAL):CARDINAL; IN LoaderA; 90 (*# call(reg_param=>(bx), reg_saved=>(ds, di, si, st1, st2)) *) 91 PROCEDURE FileClose(h:CARDINAL); IN LoaderA; 92 (*# call(reg_param=>(ax,bx,cx,dx,si)) *) 93 PROCEDURE Exec(psp,ss,sp,cs,ip:CARDINAL); IN LoaderA; 94 (*# call(reg_param=>(dx, bx, ax), reg_saved=>(ds, di, si, st1, st2)) *) 95 PROCEDURE FileOpen(name:ARRAY OF CHAR;mode:BITSET):CARDINAL; IN LoaderA; 96 PROCEDURE DosExit; IN LoaderA; 97 PROCEDURE FileDelete(name:ARRAY OF CHAR); IN LoaderA; 98 PROCEDURE FileCreate(name:ARRAY OF CHAR):CARDINAL; IN LoaderA; 99 PROCEDURE FileCreateNew(VAR name : ARRAY OF CHAR):CARDINAL; IN LoaderA; 100 (*# call(reg_param=>(bx), reg_saved=>(ds, di, si, st1, st2)) *) 101 PROCEDURE FileSize(h:CARDINAL):LONGCARD; IN LoaderA; 102 (*# restore *) 103 104 105 106 TYPE 107 ModNum = [1..MaxModule]; 108 SegNum = CARDINAL; 109 DoSegOp = (Load,Swap,Discard); 110 111 TYPE HeapADDR = SHORTADDR; 112 CONST HeapAdr ::= Ofs; 113 114 (*# data(near_ptr=>on) *) 115 116 CONST FreeGate = 0; 117 CONST DeletedGate = 1; 118 CONST IndirectGate = 0E8H; (* call near *) 119 CONST DirectGate = 0EAH; (* jump far *) 120 121 TYPE 122 GatePtr = POINTER TO GateRec; 123 GateRec = RECORD 124 state : SHORTCARD; 125 w1 : CARDINAL; 126 w2 : CARDINAL; 127 next_direct: GatePtr; 128 END; (*GateRec*) 129 (* bits for Seghdr.flags *) 130 SegAttr = (IsData,Typ2,Typ3,IsIter,IsMove,IsPure,IsPreLoad,IsExRd, 131 HasReloc,Iop1,Iop2,Iop3,IsDiscard,Is32,IsHuge,DataActive); 132 SegSet = SET OF SegAttr; 133 SegPtr = POINTER TO SegRec; 134 SegRec = RECORD 135 no_op : SHORTCARD; (* 090H return gates point here *) 136 jump_op : SHORTCARD; (* 0E9H call gates point here *) 137 jump_disp : CARDINAL; (* jumps to GateHandler *) 138 seg_val : CARDINAL; 139 direct_list: GatePtr; 140 fix_count : CARDINAL; 141 (* last four fields are read straight from file *) 142 sector : CARDINAL; 143 filebyte : CARDINAL; 144 flags : SegSet; 145 membyte : CARDINAL; 146 END; (*SegRec*) 147 ModStage = (initial_stage,internal_stage,sub_module_stage,execute_stage); 148 EntryRec = RECORD 149 seg : SHORTCARD; 150 ofs : CARDINAL; 151 END; (*EntryRec*) 152 Module = POINTER TO ModuleRec; 153 ModuleRec = RECORD 154 file : CARDINAL; 155 seg_count : CARDINAL; 156 log_sector_size : CARDINAL; 157 stage : ModStage; 158 is_exe : BOOLEAN; 159 name : POINTER TO ARRAY[0..MaxName] OF CHAR; 160 seg_info : POINTER TO ARRAY[1..MaxSeg] OF SegRec; 161 entry_table: POINTER TO ARRAY[1..MaxEntry] OF EntryRec; 162 module_table:POINTER TO ARRAY[1..MaxModule] OF SHORTCARD; 163 END; (*ModuleRec*) 164 (*# data(near_ptr=>off) *) 165 LoadState = RECORD 166 (*%T Debuging*) 167 trap_seg : SegNum; (* for debugging *) 168 trap_mod : ModNum; (* for debugging *) 169 trap_off : CARDINAL; (* for debugging *) 170 trap_alloc : CARDINAL; 171 (*%E*) 172 (*%T MemoryTrace*) (* don't trace internal operations *) 173 internal : BOOLEAN; 174 (*%E*) 175 psp : CARDINAL; 176 stk : CARDINAL; 177 module_count:CARDINAL; 178 abort : ExitHandler; 179 OutOfMem : MemHandler; 180 file_count : INTEGER; 181 near_alloc : CARDINAL; 182 start : CARDINAL; (* start of memory *) 183 end : CARDINAL; (* last para of normal (not ems) memory *) 184 freemem : CARDINAL; 185 allockind : SegKind; 186 panic_reserve:CARDINAL; 187 temp_file : CARDINAL; 188 temp_reserve:LONGINT; 189 temp_ems : CARDINAL; (* number of temp pages mapped into ems *) 190 temp_map : ARRAY [0..TempLimit DIV (8*SIZE(BITSET)*TempPageSize)] OF BITSET; 191 (*%T ExitTrace *) 192 temp_max : CARDINAL; 193 (*%E*) 194 (*%T MoveTrace *) 195 move_total : LONGCARD; 196 (*%E*) 197 ems_frame : CARDINAL; 198 (*%T EMS*) 199 ems_present: BOOLEAN; 200 ems_count : CARDINAL; 201 ems_temp_handle:CARDINAL; 202 ems_data_handle:CARDINAL; 203 (*%E*) 204 module_list: ARRAY ModNum OF Module; 205 delay : ModNum; 206 gate_count : CARDINAL; 207 gate_table : ARRAY [1..MaxGate] OF GateRec; 208 (*%T VidSupport*) 209 vid_present: BOOLEAN; 210 vid_delayed: BOOLEAN; 211 vid_id1, 212 vid_id2 : CARDINAL; 213 (*%E*) 214 heap : ARRAY [1..HeapSize] OF SHORTCARD; 215 Tick : CARDINAL; 216 END; (*LoadState*) 217 218 TYPE A1 = SHORTCARD; 219 TYPE A2 = ARRAY [1..2] OF SHORTCARD; 220 TYPE A4 = ARRAY [1..4] OF SHORTCARD; 221 TYPE A6 = ARRAY [1..6] OF SHORTCARD; 222 TYPE A7 = ARRAY [1..7] OF SHORTCARD; 223 TYPE A8 = ARRAY [1..8] OF SHORTCARD; 224 TYPE A9 = ARRAY [1..9] OF SHORTCARD; 225 TYPE A12= ARRAY [1..12] OF SHORTCARD; 226 TYPE A13= ARRAY [1..13] OF SHORTCARD; 227 228 229 230 TYPE 231 HandlerRec = RECORD 232 b01,b02,b03,b04:SHORTCARD; 233 OffsetShift:SHORTCARD; 234 b11,b12,b13,b14,b15,b16,b17:SHORTCARD; 235 PageDisp:CARDINAL; 236 b21,b22,b23,b24:SHORTCARD; 237 MemStart:CARDINAL; 238 b25,b26,b27,b28:SHORTCARD; 239 MemEnd:CARDINAL; 240 b29,b30,b31,b32:SHORTCARD; 241 EmsStart:CARDINAL; 242 b33,b34,b35,b36:SHORTCARD; 243 EmsEnd:CARDINAL; 244 b37:A8;b38:CARDINAL; b39:A4; b40:CARDINAL; b41:A12; 245 OffsetMask:BITSET; 246 b42:SHORTCARD; 247 BlankShift:SHORTCARD; 248 b5:A13; 249 QFix:ADDRESS; 250 b61,b62,b63:SHORTCARD; 251 END; 252 253 CONST 254 MaxPage = 1024; 255 256 257 TYPE 258 WP = POINTER TO CARDINAL; 259 ParaRec = RECORD 260 Size : CARDINAL; (* Size in paragraphs of alloc *) 261 Used : CARDINAL; (* Paragraphs currently in use *) 262 Prev : CARDINAL; (* Previous ParaRec Segment *) 263 Active : BOOLEAN; 264 Kind : SegKind; (* Kind of segment *) 265 Id1,Id2 : CARDINAL; 266 Lock : CARDINAL; (* Segment Locked in memory *) 267 Tick : CARDINAL; (* LRU Tick Count *) 268 END; (*ParaRec*) 269 T = POINTER TO ParaRec; 270 271 CONST H = (SIZE(ParaRec)+15) DIV 16; (* overhead in paragraphs *) 272 273 274 CONST loader_name = 'LOADER'; 275 276 TYPE t_loader_hdr = ARRAY [1..1] OF SegRec; 277 CONST loader_hdr = t_loader_hdr( 278 SegRec(90H, 0E9H, 0, 0, GatePtr(0), 0, 0, 0, SegSet{IsPreLoad}, 0) 279 ); 280 281 Entries = 34; 282 283 TYPE t_loader_entry = ARRAY [1..Entries] OF EntryRec; 284 (* N.B. this has to be consistent with loader.exp *) 285 CONST loader_entry = t_loader_entry ( 286 EntryRec(1,Ofs(LoadModule)), 287 EntryRec(1,Ofs(UnLoadModule)), 288 EntryRec(1,Ofs(GetProcAddr)), 289 EntryRec(1,Ofs(ShrinkHeap)), 290 EntryRec(1,Ofs(GrowHeap)), 291 EntryRec(1,Ofs(UserFlush)), 292 EntryRec(1,Ofs(InvalidProc)), 293 EntryRec(1,Ofs(InvalidProc)), 294 EntryRec(1,Ofs(AllocMem)), 295 EntryRec(1,Ofs(ClearAllocMem)), 296 EntryRec(1,Ofs(HugeAllocMem)), 297 EntryRec(1,Ofs(FreeMem)), 298 EntryRec(1,Ofs(SetExitHandler)), 299 EntryRec(1,Ofs(SetMemHandler)), 300 EntryRec(1,Ofs(InvalidProc)), 301 EntryRec(1,Ofs(LoadSeg)), 302 EntryRec(1,Ofs(UnloadSeg)), 303 EntryRec(1,Ofs(Terminate)), 304 EntryRec(1,Ofs(InvalidProc)), 305 EntryRec(1,Ofs(RetGate)), 306 EntryRec(1,Ofs(Avail)), 307 EntryRec(1,Ofs(TotalAvail)), 308 EntryRec(1,Ofs(SetEms)), 309 EntryRec(1,Ofs(Getseg)), 310 EntryRec(1,Ofs(ExpandMem)), 311 EntryRec(1,Ofs(HugeExpandMem)), 312 EntryRec(1,Ofs(HeapWalk)), 313 EntryRec(1,Ofs(HeapCheck)), 314 EntryRec(1,Ofs(GetOrdProcAddr)), 315 EntryRec(1,Ofs(VAlloc)), 316 EntryRec(1,Ofs(VUnfix)), 317 EntryRec(1,Ofs(VFix)), 318 EntryRec(1,Ofs(VUnfixAll)), 319 EntryRec(1,Ofs(VFree)) 320 ); 321 322 VAR g:LoadState; 323 324 CONST loader_module = ModuleRec ( 325 MAX(CARDINAL), 326 2, 327 0, 328 execute_stage, 329 FALSE, (* not exe *) 330 HeapADDR(HeapAdr(loader_name)), 331 HeapADDR(HeapAdr(loader_hdr)), 332 HeapADDR(HeapAdr(loader_entry)), 333 HeapADDR(0) 334 ); 335 336 337 338 (*-----------------------------------------------------------------------*) 339 (* inline functions *) 340 (*-----------------------------------------------------------------------*) 341 (*# save, call(inline=>on, same_ds=>off) *) 342 (*# call(reg_saved=>(bx,cx,dx,si,di,ds,es,st1,st2)) *) 343 INLINE PROCEDURE GetBP():CARDINAL = A2(89H, 0E8H); (* mov ax,bp *) 344 INLINE PROCEDURE GetSP():CARDINAL = A2(89H, 0E0H); (* mov ax,sp *) 345 INLINE PROCEDURE Int3() = A1(0CCH); 346 INLINE PROCEDURE Int66() = A2(0CDH,066H); (* used to enter symdeb *) 347 (*# call(reg_param=>(si,ax,di,es,cx), reg_saved=>(bx,dx,ds,st1,st2)) *) 348 INLINE PROCEDURE Move(fr,to : ADDRESS; count : CARDINAL)= 349 A12(1EH,8EH,0D8H,0D1H,0E9H,0F3H,0A5H,013H,0C9H,0F3H,0A4H,1FH); 350 (* push ds; mov ds,ax; shr cx,1; rep; movsw; adc cx,cx; rep; movsb; pop ds *) 351 (*# call(reg_param=>(di,es,cx,ax), reg_saved=>(bx,dx,si,ds,st1,st2)) *) 352 INLINE PROCEDURE Fill(a:ADDRESS;count:CARDINAL;w:CARDINAL) = A7(0D1H,0E9H,0F3H,0ABH,073H,001H,0AAH); 353 (*# call(reg_param=>(dx,si,ax)) *) 354 INLINE PROCEDURE GetCurDir (drive : SHORTCARD;VAR p : ARRAY OF CHAR) = 355 A8(1EH, 8EH,0D8H, 0B4H,47H, 0CDH,21H, 1FH); 356 (* push ds; mov ds,ax; mov ah,47H; int 21H; pop ds *) 357 (*# call(reg_return=>(ax)) *) 358 INLINE PROCEDURE GetCurDrive():SHORTCARD = A4(0B4H,19H, 0CDH,21H); (* mov ah, 19H; int 21H *) 359 (*%T EMS*) 360 (* Ems support *) 361 (*# call(reg_param=>(ax,bx,dx), reg_saved =>(si,di,ds,st1,st2)) *) 362 INLINE PROCEDURE EmsTest(ax:CARDINAL):CARDINAL = A2(0CDH,67H); 363 INLINE PROCEDURE EmsMap(ax:CARDINAL;bx:CARDINAL;dx:CARDINAL) = A2(0CDH,67H); 364 (*# call(reg_return=>(bx)) *) 365 INLINE PROCEDURE EmsGet(ax:CARDINAL):CARDINAL = A2(0CDH,67H); 366 (*# call(reg_return=>(dx)) *) 367 INLINE PROCEDURE EmsAlloc(ax:CARDINAL;bx:CARDINAL):CARDINAL = A2(0CDH,67H); 368 (*%E*) 369 (*# call(reg_param=>(dx,ax)) *) 370 INLINE PROCEDURE Out (p:CARDINAL;v:SHORTCARD)=SHORTCARD(0EEH); 371 INLINE PROCEDURE DI()=SHORTCARD(0FAH); 372 INLINE PROCEDURE EI()=SHORTCARD(0FBH); 373 (*# restore *) 374 INLINE PROCEDURE GetTick():CARDINAL; 375 BEGIN 376 RETURN g.Tick; 377 END GetTick; 378 INLINE PROCEDURE IncTick():CARDINAL; 379 BEGIN 380 INC(g.Tick); 381 RETURN g.Tick; 382 END IncTick; 383 384 385 386 (* tracing *) 387 388 (*%T TraceToFile*) VAR output_file : CARDINAL; (*%E*) 389 (*%F TraceToFile*) CONST output_file = 1; (*%E*) 390 391 PROCEDURE string(s: ARRAY OF CHAR); 392 VAR i:CARDINAL; 393 BEGIN 394 i := 0; 395 WHILE s[i]#0C DO 396 INC(i); 397 END; 398 i := FileWrite(ADR(s), i, output_file); 399 END string; 400 401 PROCEDURE eol; 402 CONST CRLF = CHAR(13) + CHAR(10); 403 VAR i:CARDINAL; 404 p:LONGCARD; 405 BEGIN 406 i := FileWrite(ADR(CRLF), 2, output_file); 407 END eol; 408 409 PROCEDURE char(c: CHAR); 410 VAR i:CARDINAL; 411 BEGIN 412 i := FileWrite(ADR(c), 1, output_file); 413 END char; 414 415 PROCEDURE hex(n: CARDINAL); 416 CONST dig = '0123456789ABCDEF'; 417 VAR buf:ARRAY [0..3] OF CHAR; 418 i:CARDINAL; 419 BEGIN 420 FOR i := 0 TO 3 DO 421 buf[3-i] := dig[n MOD 16]; 422 n := n DIV 16; 423 END; 424 i := FileWrite(ADR(buf), 4, output_file); 425 END hex; 426 427 PROCEDURE dec(n: CARDINAL); 428 VAR div:CARDINAL; 429 BEGIN 430 div := n DIV 10; 431 IF div#0 THEN 432 dec(div); 433 END; 434 char('0' + CHAR(n MOD 10)); 435 END dec; 436 437 (*%T GraphUseTrace*) 438 TYPE graphsegrec = RECORD 439 seg : CARDINAL; 440 pos : CARDINAL; 441 lasttick : CARDINAL; 442 END; 443 VAR graphsegs : ARRAY[1..300] OF graphsegrec; 444 TYPE GTmode = (GTadd,GTdel,GTlru); 445 PROCEDURE GraphTrace(seg : CARDINAL; 446 pos : CARDINAL; 447 mode : GTmode); 448 VAR i,j,s,segm : CARDINAL; 449 c : CHAR; 450 451 BEGIN 452 (* IF NOT(4 IN BITSET([40H:17H T]^)) THEN RETURN END; *) 453 hex([40H:6CH]^); 454 char(' '); 455 CASE mode OF 456 |GTadd: char('¯'); 457 |GTdel: char('®'); 458 |GTlru: char(' '); 459 END; 460 IF mode=GTlru THEN string('flush ');hex(pos); 461 ELSE 462 char(' '); 463 hex(seg); 464 char(' ');hex([pos-1:0 T]^.Used); 465 END; 466 char(' '); 467 j := HIGH(graphsegs); 468 WHILE (j>0)AND(graphsegs[j].seg=0)DO DEC(j); END; 469 IF jsegm THEN 491 graphsegs[i].pos := segm; 492 c := 'Æ'; 493 ELSIF graphsegs[i].lasttick <> [graphsegs[i].pos-1:0 T]^.Tick THEN 494 graphsegs[i].lasttick := [graphsegs[i].pos-1:0 T]^.Tick; 495 c := 'Ã'; 496 ELSE 497 c := '³'; 498 END; 499 END; 500 END; 501 char(c); 502 END; 503 eol; 504 END GraphTrace; 505 (*%E*) 506 507 508 PROCEDURE DumpMemory; FORWARD; 509 PROCEDURE DumpSegName(seg:CARDINAL);FORWARD; 510 511 PROCEDURE release_panic; FORWARD; 512 (*#save,call(reg_param=>())*) 513 PROCEDURE abort(errno:SHORTCARD); 514 (*#restore*) 515 516 TYPE 517 fp = POINTER Seg(errno) TO RECORD 518 bp,ip,cs: CARDINAL; 519 END; (*fp*) 520 VAR 521 bp : fp; 522 cs,i : CARDINAL; 523 res : BOOLEAN; 524 BEGIN 525 (*%T TraceToFile*) 526 DumpMemory; 527 (*%E*) 528 release_panic; 529 (*%T CHECK*) 530 eol; 531 bp := fp(GetBP()); 532 i := 0; 533 LOOP 534 IF (bp = fp(0))OR(i=10) THEN EXIT END; 535 INC(i); 536 hex(CARDINAL(bp));string(' ');hex(bp^.ip);string(' ');DumpSegName(bp^.cs);eol; 537 IF (bp^.bp=0) THEN 538 EXIT; 539 ELSIF bp^.bp <= CARDINAL(bp) THEN 540 EXIT 541 END; (*IF*) 542 bp := fp(bp^.bp); 543 END; 544 (*%E*) 545 g.abort(g.module_list[1]^.name^,ErrBase+CARDINAL(errno)); 546 Terminate; 547 DosExit; 548 END abort; 549 550 PROCEDURE is_mem(seg:CARDINAL):BOOLEAN; 551 BEGIN 552 RETURN ((seg >= g.start) & (seg < g.end)) 553 (*%T EMS*) 554 OR ((seg >= g.ems_frame) & (seg < g.ems_frame + 1000H)) 555 (*%E*) 556 ; 557 END is_mem; 558 559 PROCEDURE encode_temp(i:CARDINAL):CARDINAL; 560 BEGIN 561 IF g.ems_frame < g.start THEN 562 IF i >= g.ems_frame THEN 563 INC(i, 1000H); 564 END; 565 END; 566 IF i >= g.start THEN 567 INC(i, g.end - g.start); 568 END; 569 IF g.ems_frame > g.start THEN 570 IF i >= g.ems_frame THEN 571 INC(i, 1000H); 572 END; 573 END; 574 (*%T CHECK*) IF (i=0) OR is_mem(i) THEN abort(ErrTempFileLimit) END; (*%E*) 575 RETURN i; 576 END encode_temp; 577 578 PROCEDURE decode_temp(i:CARDINAL):CARDINAL; 579 BEGIN 580 IF g.ems_frame > g.start THEN 581 IF i >= g.ems_frame THEN 582 DEC(i,1000H); 583 END; 584 END; 585 IF i >= g.start THEN 586 DEC(i, g.end - g.start); 587 END; 588 IF g.ems_frame < g.start THEN 589 IF i >= g.ems_frame THEN 590 DEC(i, 1000H); 591 END; 592 END; 593 RETURN i; 594 END decode_temp; 595 596 (*%T CHECK *) 597 PROCEDURE CheckAlloc(seg:CARDINAL;err : CARDINAL); 598 (* checks that block is a valid allocated segment *) 599 BEGIN 600 DEC(seg, H); 601 WITH [seg:0 T]^ DO 602 IF (seg < g.start) OR 603 (Kind > MAX(SegKind)) OR 604 (Used > Size) OR 605 (Prev + [Prev:0 T]^.Size # seg) OR 606 ([seg+Size:0 T]^.Prev # seg) THEN 607 IF err=0 THEN 608 abort(ErrMemoryCorruption); 609 ELSE 610 abort(SHORTCARD(err)); 611 END; 612 END; (*IF*) 613 END; (*WITH*) 614 END CheckAlloc; 615 616 PROCEDURE CalcFreeMem():CARDINAL; 617 VAR 618 res,p : CARDINAL; 619 BEGIN 620 res := 0; 621 p := g.start; 622 REPEAT 623 WITH [p:0 T]^ DO 624 INC(res,Size - Used); 625 INC(p,Size); 626 END; (*WITH*) 627 UNTIL p = g.start; 628 RETURN res; 629 END CalcFreeMem; 630 631 PROCEDURE CheckMem; 632 VAR 633 p : CARDINAL; 634 BEGIN 635 p := g.start; 636 REPEAT 637 CheckAlloc(p+H,0); 638 INC(p,[p:0 T]^.Size); 639 UNTIL p = g.start; 640 IF CalcFreeMem() # g.freemem THEN 641 abort(ErrInternal); 642 END; (*IF*) 643 END CheckMem; 644 645 (*%E*) 646 647 (*%F CHECK*) INLINE (*%E*) PROCEDURE Locked(w:CARDINAL):BOOLEAN; 648 BEGIN 649 RETURN ([w-H:0 T]^.Lock # 0); 650 END Locked; 651 652 PROCEDURE SwapMove(VAR seg:CARDINAL); 653 BEGIN 654 IF is_mem(seg) THEN 655 (*%T CHECK*) 656 CheckAlloc(seg,0); 657 (*%E*) 658 WITH [seg-H:0 T]^ DO 659 (*%T CHECK*) 660 IF Kind # MoveSeg THEN 661 abort(ErrInternal); 662 END; 663 (*%E*) 664 Kind := SwapSeg; 665 Tick := IncTick(); 666 END; (*WITH*) 667 END; (*IF*) 668 END SwapMove; 669 670 PROCEDURE DumpLockedStatics; 671 VAR 672 modnum:ModNum; 673 segnum:SegNum; 674 module:Module; 675 segment:CARDINAL; 676 BEGIN 677 string('Locked static segments '); eol; 678 FOR modnum := 1 TO g.module_count DO 679 module := g.module_list[modnum]; 680 string(module^.name^); 681 string(' : '); 682 FOR segnum := 1 TO module^.seg_count DO 683 segment := module^.seg_info^[segnum].seg_val; 684 IF is_mem(segment) THEN 685 WITH [segment-H:0 T]^ DO 686 IF Lock<>0 THEN 687 dec(segnum); 688 char('('); 689 dec(Lock); 690 char(')'); 691 char(' '); 692 END 693 END; 694 END; 695 END; 696 eol; 697 END; 698 END DumpLockedStatics; 699 700 PROCEDURE DumpSegKind(kind:SegKind); 701 BEGIN 702 CASE kind OF 703 | StaticSeg: string('sta'); 704 | SwapSeg: string('swa'); 705 | MoveSeg: string('mov'); 706 | FixedSeg: string('fix'); 707 | SystemSeg: string('sys'); 708 END; 709 END DumpSegKind; 710 711 PROCEDURE DumpSegName(seg:CARDINAL); 712 BEGIN 713 WITH [seg-H:0 T]^ DO 714 CASE Kind OF 715 | StaticSeg: 716 string(g.module_list[Id1]^.name^); 717 char('.'); 718 hex(Id2); 719 | SwapSeg: 720 DumpSegName(Id2); char(':'); hex(Id1); 721 | MoveSeg: 722 DumpSegName(Id2); char(':'); hex(Id1); 723 ELSE 724 hex(seg); 725 END; 726 END; 727 END DumpSegName; 728 729 PROCEDURE DumpSeg(s:ARRAY OF CHAR;seg:CARDINAL); 730 BEGIN 731 string(s); 732 WITH [seg-H:0 T]^ DO 733 hex(seg); 734 (*string(' Size='); hex(Size);*) 735 string(' Used='); hex(Used); 736 (*string(' Prev='); hex(Prev);*) 737 string(' Free='); hex(Size-Used); 738 string(' Kind='); 739 DumpSegKind(Kind); 740 string(' Lock='); dec(Lock); 741 string(' Name='); DumpSegName(seg); 742 CASE Kind OF 743 | MoveSeg, SwapSeg, StaticSeg: string(' Age='); dec(GetTick()-Tick); 744 END; 745 eol; 746 END; 747 END DumpSeg; 748 749 PROCEDURE TraceSeg(s:ARRAY OF CHAR; seg:CARDINAL); 750 BEGIN 751 hex(g.freemem); 752 char(' '); 753 hex(seg); 754 char(' '); 755 string(s); 756 WITH [seg-H:0 T]^ DO 757 string(' Size='); hex(Used); 758 string(' Kind='); 759 DumpSegKind(Kind); 760 CASE Kind OF 761 | MoveSeg, SwapSeg, StaticSeg: string(' Name='); DumpSegName(seg); 762 IF GetTick()#Tick THEN 763 string(' Age='); dec(GetTick()-Tick); 764 END; 765 END; 766 eol; 767 END; 768 END TraceSeg; 769 770 (* splits free space of block p, returning lower half *) 771 PROCEDURE SplitLow(size:CARDINAL; p:CARDINAL):CARDINAL; 772 VAR 773 res : CARDINAL; 774 free : CARDINAL; 775 BEGIN 776 WITH [p:0 T]^ DO 777 res := p + Used; 778 free := Size - Used; 779 Size := Used; 780 END; (*WITH*) 781 WITH [res:0 T]^ DO 782 IF p # res THEN 783 Prev := p; 784 END; (*IF*) 785 Size := free; 786 Used := size; 787 END; (*WITH*) 788 WITH [res+free:0 T]^ DO 789 Prev := res; 790 END; (*WITH*) 791 DEC(g.freemem,size); 792 RETURN res; 793 END SplitLow; 794 795 (* Trys to find a block with with free space >= size, begin search at *) 796 (* s, end at e. *) 797 PROCEDURE Try(size:CARDINAL; s,e:CARDINAL):CARDINAL; 798 VAR 799 p,res : CARDINAL; 800 BEGIN 801 IF size = 0 THEN 802 RETURN 0; 803 END; (*IF*) 804 p := s; 805 LOOP 806 WITH [p:0 T]^ DO 807 IF Size - Used >= size THEN 808 RETURN p; 809 END; (*IF*) 810 INC(p,Size); 811 IF p = e THEN 812 RETURN 0; 813 END; (*IF*) 814 END; (*WITH*) 815 END; (*LOOP*) 816 END Try; 817 818 (* An area is a sequence of blocks satisfying ~Locked except for the *) 819 (* first block. *) 820 821 (* Returns size of possible free space in area starting at s..e, *) 822 (* assuming blocks of size < req can be evacuated *) 823 PROCEDURE Poss(s,e:CARDINAL; req:CARDINAL):CARDINAL; 824 VAR 825 res : CARDINAL; 826 BEGIN 827 WITH [s:0 T]^ DO 828 IF Active THEN 829 RETURN 0; 830 END; (*IF*) 831 res := Size - Used; 832 INC(s,Size); 833 END; (*WITH*) 834 WHILE s # e DO 835 WITH [s:0 T]^ DO 836 INC(res,Size); 837 IF Size >= req THEN 838 DEC(res,Used); 839 END; (*IF*) 840 INC(s,Size); 841 END; (*WITH*) 842 END; (*WHILE*) 843 RETURN res; 844 END Poss; 845 846 (* Returns amount of free space in area s..e. *) 847 PROCEDURE Got(s,e:CARDINAL):CARDINAL; 848 VAR 849 res : CARDINAL; 850 BEGIN 851 res := 0; 852 WHILE s # e DO 853 WITH [s:0 T]^ DO 854 INC(res,Size); 855 DEC(res,Used); 856 INC(s,Size); 857 END; (*WITH*) 858 END; (*WHILE*) 859 RETURN res; 860 END Got; 861 862 PROCEDURE NextArea(r:CARDINAL):CARDINAL; 863 BEGIN 864 INC(r,[r:0 T]^.Size); 865 LOOP 866 WITH [r:0 T]^ DO 867 IF Lock<>0 THEN 868 RETURN r; 869 END; (*IF*) 870 INC(r,Size); 871 END; (*WITH*) 872 END; (*LOOP*) 873 END NextArea; 874 875 (* Find area containing r *) 876 PROCEDURE Find(r:CARDINAL):CARDINAL; 877 BEGIN 878 WHILE [r:0 T]^.Lock=0 DO 879 r := [r:0 T]^.Prev; 880 END; (*WHILE*) 881 RETURN r; 882 END Find; 883 884 (* Returns largest Poss(s,e,req) less than bound over all areas s..e *) 885 PROCEDURE MaxPoss(req:CARDINAL; VAR sm,em:CARDINAL):CARDINAL; 886 VAR 887 s,e : CARDINAL; 888 max,try : CARDINAL; 889 BEGIN 890 s := g.start; 891 max := 0; 892 REPEAT 893 e := NextArea(s); (*<<<*) 894 try := Poss(s,e,req); (*<<<*) 895 IF (try > max) THEN 896 sm := s; 897 em := e; 898 max := try; 899 END; (*IF*) 900 s := e; 901 UNTIL s = g.start; 902 RETURN max; 903 END MaxPoss; 904 905 CONST 906 (*%T DEBUG*) 907 Hide = 10H; 908 (*%E*) 909 (*%F DEBUG*) 910 Hide = 200H; 911 (*%E*) 912 913 (* Returns largest Got(s,e) over all areas s..e *) 914 PROCEDURE Avail():CARDINAL; 915 VAR 916 s,e : CARDINAL; 917 max,try : CARDINAL; 918 BEGIN 919 g.allockind := FixedSeg; 920 s := g.start; 921 max := 0; 922 REPEAT 923 e := NextArea(s); (*<<<*) 924 try := Got(s,e); (*<<<*) 925 IF (try > max) THEN 926 max := try; 927 END; (*IF*) 928 s := e; 929 UNTIL s = g.start; 930 IF max Hide THEN 1054 DEC(res,Hide); (* keep 8k free to stop too much shuffling *) 1055 ELSE 1056 res := 0; 1057 END; (*IF*) 1058 RETURN res; 1059 END TotalAvail; 1060 1061 PROCEDURE Free(seg:CARDINAL); 1062 VAR 1063 prev,next : CARDINAL; 1064 1065 TDummy : T; 1066 BEGIN 1067 IF seg=0 THEN RETURN END; 1068 (*%T CHECK*) 1069 CheckAlloc(seg,ErrInvalidFree); 1070 (*%E*) 1071 DEC(seg); 1072 WITH [seg:0 T]^ DO 1073 TDummy := [seg:0 T]; 1074 (*%T MemoryTrace*) 1075 IF (Kind IN MemTraceSet) & (~ g.internal) THEN 1076 TraceSeg('Free ',seg+H); 1077 (* MemStat;*) 1078 END; (*IF*) 1079 (*%E*) 1080 INC(g.freemem,Used); 1081 IF seg = g.start THEN 1082 Used := 1; 1083 Lock := 1; 1084 Kind := SystemSeg; 1085 DEC(g.freemem); 1086 ELSE 1087 next := seg + Size; 1088 prev := Prev; 1089 [next:0 T]^.Prev := prev; 1090 [prev:0 T]^.Size := next-prev; 1091 END; (*IF*) 1092 END; (*WITH*) 1093 (*%T CHECK*) 1094 CheckMem; 1095 (*%E*) 1096 END Free; 1097 1098 PROCEDURE TempAlloc(count:CARDINAL):CARDINAL; 1099 VAR 1100 i,j:CARDINAL; 1101 found:CARDINAL; 1102 BEGIN 1103 i := 0; 1104 LOOP 1105 IF i > HIGH(g.temp_map) THEN 1106 abort(ErrTempFileLimit); 1107 END; 1108 IF g.temp_map[i] # BITSET{0..15} THEN 1109 EXIT; 1110 END; 1111 INC(i); 1112 END; 1113 (* search for count consecutive bits *) 1114 j := 0; 1115 found := 0; 1116 LOOP 1117 IF j IN g.temp_map[i] THEN 1118 found := 0; 1119 ELSE 1120 INC(found); 1121 IF found = count THEN 1122 EXIT; 1123 END; 1124 END; 1125 INC(j); 1126 IF j = 16 THEN 1127 j := 0; 1128 INC(i); 1129 IF i > HIGH(g.temp_map) THEN 1130 abort(ErrTempFileLimit); 1131 END; 1132 END; 1133 END; 1134 (* set the bits *) 1135 LOOP 1136 INCL(g.temp_map[i], j); 1137 DEC(found); 1138 IF found=0 THEN 1139 EXIT; 1140 END; 1141 IF j=0 THEN 1142 DEC(i); 1143 j := 15; 1144 ELSE 1145 DEC(j); 1146 END; 1147 END; 1148 i := 1 + j + i*16; 1149 (*%T ExitTrace *) IF i+CARDINAL(count)-1 > g.temp_max THEN g.temp_max := i+CARDINAL(count)-1; END; (*%E*) 1150 RETURN i; 1151 END TempAlloc; 1152 1153 PROCEDURE TempFree(i:CARDINAL;count:CARDINAL); 1154 VAR j:CARDINAL; 1155 BEGIN 1156 DEC(i); 1157 j := i MOD 16; 1158 i := i DIV 16; 1159 REPEAT 1160 (*%T CHECK*) IF ~ (j IN g.temp_map[i]) THEN abort(ErrInternal) END; (*%E*) 1161 EXCL(g.temp_map[i], j); 1162 INC(j); 1163 IF j = 16 THEN 1164 j := 0; 1165 INC(i); 1166 END; 1167 DEC(count); 1168 UNTIL count = 0; 1169 END TempFree; 1170 1171 1172 PROCEDURE reserve_panic; 1173 BEGIN 1174 IF g.panic_reserve = 0 THEN 1175 g.panic_reserve := TempAlloc(PanicSize DIV TempPageSize); 1176 END; 1177 END reserve_panic; 1178 1179 PROCEDURE release_panic; 1180 BEGIN 1181 IF g.panic_reserve # 0 THEN 1182 TempFree(g.panic_reserve, PanicSize DIV TempPageSize); 1183 g.panic_reserve := 0; 1184 END; 1185 END release_panic; 1186 1187 PROCEDURE TempXfer(action:DoSegOp;VAR tpv:CARDINAL;seg,off:CARDINAL;count:CARDINAL); 1188 VAR 1189 (*%T EMS*) 1190 ems_page,ems_off, 1191 (*%E*) 1192 p,amount,tp, 1193 temp_size : CARDINAL; 1194 BEGIN 1195 tp := tpv; 1196 IF action = Load THEN 1197 tpv := seg; 1198 ELSE 1199 tpv := 0; 1200 END; (*IF*) 1201 IF count = 0 THEN 1202 RETURN; 1203 END; (*IF*) 1204 temp_size := 1+((count-1) DIV TempPageSize); 1205 IF action = Swap THEN 1206 tp := TempAlloc(temp_size); 1207 tpv := encode_temp(tp); 1208 ELSIF (tp # 0) & ~ is_mem(tp) THEN 1209 tp := decode_temp(tp); 1210 TempFree(tp, temp_size); 1211 END; (*IF*) 1212 IF (action = Load) & (tp = 0) THEN 1213 Fill([seg:off],count,0); 1214 ELSIF action # Discard THEN 1215 (*%T EMS*) 1216 LOOP 1217 IF tp <= g.temp_ems THEN 1218 amount := TempPageSize; 1219 IF amount > count THEN 1220 amount := count; 1221 END; (*IF*) 1222 ems_page := (tp-1) DIV EmsPageSize; 1223 ems_off := ((tp-1) MOD EmsPageSize) * TempPageSize; 1224 IF seg+(off DIV 16) >= g.ems_frame+800H THEN 1225 p := 0; 1226 ELSE 1227 p := 3; 1228 INC(ems_off, 0C000H); 1229 END; (*IF*) 1230 EmsMap(4400H+p,ems_page,g.ems_temp_handle); 1231 IF action=Swap THEN 1232 Move([seg:off],[g.ems_frame:ems_off],amount); 1233 ELSE 1234 Move([g.ems_frame:ems_off],[seg:off],amount); 1235 END; (*IF*) 1236 EmsMap(4400H+p,p,g.ems_data_handle); 1237 DEC(count,amount); 1238 IF count = 0 THEN 1239 EXIT; 1240 END; 1241 INC(off,amount); 1242 INC(tp); 1243 ELSE 1244 (*%E*) 1245 FileSeek(g.temp_file,LONGCARD(tp-g.temp_ems-1) * TempPageSize); 1246 IF action=Swap THEN 1247 IF FileWrite([seg:off],count,g.temp_file) # count THEN 1248 abort(ErrTempDiskFull); 1249 END; (*IF*) 1250 ELSE 1251 FileRead([seg:off],count,g.temp_file); 1252 END; (*IF*) 1253 (*%T EMS*) 1254 EXIT; 1255 END; (*IF*) 1256 END; (*LOOP*) 1257 (*%E*) 1258 END; (*IF*) 1259 END TempXfer; 1260 1261 PROCEDURE Para(size:CARDINAL):CARDINAL; 1262 BEGIN 1263 IF size = 0 THEN 1264 RETURN 0; 1265 ELSE 1266 RETURN 1 + ((size-1) DIV 16); 1267 END; 1268 END Para; 1269 1270 PROCEDURE P; 1271 BEGIN 1272 string('trap'); 1273 eol; 1274 END P; 1275 1276 PROCEDURE GetSeg(module:Module;segnum:SegNum):SegPtr; 1277 BEGIN 1278 RETURN SegPtr(HeapAdr(module^.seg_info^[segnum])); 1279 END GetSeg; 1280 1281 PROCEDURE SetIndirect(seghdr:SegPtr); 1282 VAR 1283 gate : GatePtr; 1284 BEGIN 1285 gate := seghdr^.direct_list; 1286 seghdr^.direct_list := GatePtr(0); 1287 WHILE gate<>GatePtr(0) DO 1288 gate^.state := IndirectGate; 1289 gate^.w2 := gate^.w1; 1290 gate^.w1 := CARDINAL(seghdr) - CARDINAL(gate) - 2; 1291 gate := gate^.next_direct; 1292 END; 1293 END SetIndirect; 1294 1295 PROCEDURE Gate(off:CARDINAL;seghdr:SegPtr;iscall:BOOLEAN):CARDINAL; 1296 VAR 1297 disp:CARDINAL; 1298 hash:CARDINAL; 1299 gp,ff:GatePtr; 1300 BEGIN 1301 disp := CARDINAL(seghdr)-3; 1302 IF iscall THEN 1303 INC(disp); 1304 END; 1305 hash := 1 + (disp + off) MOD MaxGate; 1306 gp := GatePtr(HeapAdr(g.gate_table[hash])); 1307 ff := GatePtr(0); 1308 LOOP 1309 CASE gp^.state OF 1310 | FreeGate : 1311 IF ff # GatePtr(0) THEN 1312 gp := ff; 1313 ELSE 1314 INC(g.gate_count); 1315 IF g.gate_count = MaxGate THEN 1316 abort(ErrGateLimit); 1317 END; 1318 END; 1319 gp^.state := IndirectGate; 1320 gp^.w2 := off; 1321 gp^.w1 := disp - CARDINAL(gp); 1322 EXIT; 1323 | DeletedGate : 1324 IF ff = GatePtr(0) THEN 1325 ff := gp; 1326 END; 1327 | IndirectGate : 1328 IF (gp^.w2 = off) & (gp^.w1 + CARDINAL(gp) = disp) THEN 1329 EXIT; 1330 END; 1331 | DirectGate : 1332 IF (gp^.w1 = off) & (gp^.w2 = seghdr^.seg_val) THEN 1333 EXIT; 1334 END; 1335 END; 1336 IF gp = GatePtr(HeapAdr(g.gate_table[MaxGate])) THEN 1337 gp := GatePtr(HeapAdr(g.gate_table[1])); 1338 ELSE 1339 INC(CARDINAL(gp),SIZE(gp^)); 1340 END; 1341 END; 1342 RETURN CARDINAL(gp); 1343 END Gate; 1344 1345 PROCEDURE RetGate(off, seg:CARDINAL):ADDRESS; 1346 VAR 1347 modnum:ModNum; 1348 segnum:SegNum; 1349 seghdr:SegPtr; 1350 BEGIN 1351 (*%T CHECK*) CheckAlloc(seg,0); (*%E*) 1352 WITH [seg-1:0 T]^ DO 1353 modnum := Id1; 1354 segnum := Id2; 1355 END; 1356 seghdr := GetSeg(g.module_list[modnum], segnum); 1357 RETURN [Seg(g) : Gate(off, seghdr, FALSE)]; 1358 END RetGate; 1359 1360 PROCEDURE Append(VAR s:ARRAY OF CHAR;e:ARRAY OF CHAR); (*String*) 1361 VAR i,j:CARDINAL; 1362 BEGIN 1363 i := 0; 1364 WHILE s[i]#0C DO 1365 INC(i); 1366 END; 1367 j := 0; 1368 LOOP 1369 s[i] := e[j]; 1370 IF s[i] = 0C THEN 1371 EXIT; 1372 END; 1373 INC(i); 1374 INC(j); 1375 END; 1376 END Append; 1377 1378 PROCEDURE PathOpen(tail:ARRAY OF CHAR):CARDINAL; 1379 CONST pathname='PATH='; 1380 VAR 1381 envptr : POINTER TO ARRAY [0..999] OF CHAR; 1382 envseg,i,j:CARDINAL; 1383 c:CHAR; 1384 file:CARDINAL; 1385 path:ARRAY [0..255] OF CHAR; 1386 BEGIN 1387 file := FileOpen(tail, BITSET(0)); (* Try local *) 1388 IF file # MAX(CARDINAL) THEN RETURN file; END; 1389 envseg := [g.psp: 2CH]^; 1390 envptr := [envseg: 0]; 1391 1392 i := 0; 1393 j := 0; 1394 LOOP (* search for 'PATH=' *) 1395 c := pathname[j]; 1396 IF c=0C THEN 1397 EXIT; 1398 END; 1399 IF c # envptr^[i] THEN 1400 j := 0; 1401 WHILE envptr^[i]#0C DO 1402 INC(i); 1403 END; 1404 INC(i); 1405 IF envptr^[i]=0C THEN 1406 EXIT; 1407 END; 1408 ELSE 1409 INC(j); 1410 INC(i); 1411 END; 1412 END; 1413 1414 j := 0; 1415 LOOP 1416 c := envptr^[i]; 1417 path[j] := c; 1418 IF (c = ';') OR (c=0C) THEN 1419 IF c#'\' THEN 1420 path[j] := '\'; 1421 INC(j); 1422 END; 1423 path[j] := 0C; 1424 Append(path,tail); 1425 file := FileOpen(path, BITSET(0)); 1426 IF file # MAX(CARDINAL) THEN 1427 EXIT; 1428 END; 1429 IF c = 0C THEN 1430 EXIT; 1431 END; 1432 j := 0; 1433 ELSE 1434 INC(j); 1435 END; 1436 INC(i); 1437 END; 1438 RETURN file; 1439 END PathOpen; 1440 1441 PROCEDURE ModuleRead(module:Module;pos:LONGCARD;a:ADDRESS;count:CARDINAL):BOOLEAN; 1442 VAR 1443 modnum:ModNum; 1444 victim:Module; 1445 fullname:ARRAY [0..99] OF CHAR; 1446 file:CARDINAL; 1447 BEGIN 1448 IF count=0 THEN 1449 RETURN FALSE; 1450 END; 1451 file := module^.file; 1452 modnum := 1; 1453 WHILE ((file = MAX(CARDINAL)) & (g.file_count >= FileLimit)) OR 1454 (g.file_count > FileLimit) 1455 DO 1456 (*%T CHECK*) IF modnum > g.module_count THEN abort(ErrInternal); END; (*%E*) 1457 victim := g.module_list[modnum]; 1458 IF (victim^.file # MAX(CARDINAL)) & (victim^.file # file) THEN 1459 FileClose(victim^.file); 1460 IF FileTrace THEN 1461 string('Close file '); 1462 string(victim^.name^); 1463 eol; 1464 END; 1465 victim^.file := MAX(CARDINAL); 1466 DEC(g.file_count); 1467 END; 1468 INC(modnum); 1469 END; 1470 IF file = MAX(CARDINAL) THEN 1471 fullname[0] := 0C; 1472 Append(fullname, module^.name^); 1473 IF module^.is_exe THEN 1474 Append(fullname, '.exe'); 1475 ELSE 1476 Append(fullname, '.dll'); 1477 END; 1478 file := PathOpen(fullname); 1479 module^.file := file; 1480 IF FileTrace THEN 1481 string('Open file '); 1482 string(fullname); 1483 IF file = MAX(CARDINAL) THEN 1484 string(' - failed to open !!'); 1485 END; 1486 eol; 1487 END; 1488 IF file = MAX(CARDINAL) THEN 1489 RETURN TRUE; 1490 END; 1491 INC(g.file_count); 1492 END; 1493 FileSeek(file, pos); 1494 FileRead(a, count, file); 1495 RETURN FALSE; 1496 END ModuleRead; 1497 1498 (*%T VidSupport*) 1499 (*# save, call(reg_param=>(ax,bx,cx,dx,si), 1500 reg_saved =>(ds,es,di,st1,st2), inline=>on) *) 1501 PROCEDURE debug_int(data_ptr:ADDRESS;name_ptr:ADDRESS;action:CARDINAL) = 1502 A2(0CDH,063H); 1503 (*# restore *) 1504 1505 TYPE VidAction = (VID_XX, VID_LOAD_MODULE, VID_LOAD_SEG, VID_UNLOAD_SEG); 1506 1507 PROCEDURE TellVid(modnum:ModNum;segnum:SegNum;action:VidAction); 1508 TYPE 1509 StrPtr = POINTER TO ARRAY[0..79] OF CHAR; 1510 SegListPtr = POINTER TO SegListRec; 1511 DllLoadPtr = POINTER TO DllLoadRec; 1512 SegListRec = RECORD 1513 new_rlc : CARDINAL; 1514 module : DllLoadPtr; 1515 ext_deps : SHORTADDR; 1516 seg_val : CARDINAL; 1517 seg_size : CARDINAL; 1518 reloc_num : CARDINAL; 1519 type : CARDINAL; 1520 use_count : SHORTCARD; 1521 lru_count : SHORTCARD; 1522 status : SHORTCARD; 1523 seg_no : SHORTCARD; 1524 (*%T EMS*) 1525 ems_page : SHORTCARD; 1526 ems_size : SHORTCARD; 1527 (*%E*) 1528 ref_count : CARDINAL; 1529 swap_pos : CARDINAL; 1530 END; 1531 1532 1533 DllLoadRec = RECORD 1534 total_entries : CARDINAL; 1535 entries : ADDRESS; 1536 segs : SegListPtr; 1537 total_segments : CARDINAL; 1538 status : SHORTCARD; 1539 entry_point : PROC; 1540 module_no : SHORTCARD; 1541 END; 1542 1543 VAR 1544 m:DllLoadRec; 1545 s:SegListRec; 1546 dp:ADDRESS; 1547 name:ARRAY [0..255] OF CHAR; 1548 module:Module; 1549 BEGIN 1550 IF g.vid_present THEN 1551 module := g.module_list[modnum]; 1552 m.total_segments := module^.seg_count; 1553 IF action = VID_LOAD_MODULE THEN 1554 dp := ADR(m); 1555 ELSE 1556 dp := ADR(s); 1557 s.module := ADR(m); 1558 s.seg_no := SHORTCARD(segnum); 1559 s.seg_val := module^.seg_info^[segnum].seg_val; 1560 s.seg_size := module^.seg_info^[segnum].membyte; 1561 END; 1562 name[0] := 0C; 1563 Append(name, module^.name^); 1564 IF module^.is_exe THEN 1565 Append(name, '.EXE'); 1566 ELSE 1567 Append(name, '.DLL'); 1568 (*Int66;*) 1569 END; 1570 debug_int(dp, ADR(name), CARDINAL(action)); 1571 END; 1572 END TellVid; 1573 1574 PROCEDURE TellVidMove; 1575 BEGIN 1576 IF g.vid_delayed THEN 1577 g.vid_delayed := FALSE; 1578 TellVid(g.vid_id1,g.vid_id2,VID_LOAD_SEG); 1579 END; 1580 END TellVidMove; 1581 1582 PROCEDURE FindVid; 1583 VAR 1584 iv:POINTER TO ADDRESS; 1585 cp:POINTER TO ARRAY [0..0] OF CHAR; 1586 BEGIN 1587 iv := [0:63H*4]; 1588 cp := iv^; 1589 IF (cp^[-3]='V') & (cp^[-2]='I') & (cp^[-1]='D') THEN 1590 g.vid_present := TRUE; 1591 END; 1592 END FindVid; 1593 (*%E*) 1594 1595 1596 PROCEDURE MakeSys(seg:CARDINAL); FORWARD; 1597 1598 1599 PROCEDURE ReserveDisk(amount:LONGCARD):BOOLEAN; 1600 VAR dummy:CHAR; 1601 BEGIN 1602 INC(g.temp_reserve, amount); 1603 IF (g.temp_reserve > LONGINT(FileSize(g.temp_file))) THEN 1604 FileSeek(g.temp_file, g.temp_reserve + 1001H); 1605 dummy := 'x'; 1606 IF FileWrite(ADR(dummy), 1, g.temp_file) # 1 THEN 1607 DEC(g.temp_reserve, amount); 1608 RETURN FALSE; 1609 END; 1610 END; 1611 RETURN TRUE; 1612 END ReserveDisk; 1613 1614 PROCEDURE ReleaseDisk(amount:LONGCARD); 1615 BEGIN 1616 DEC(g.temp_reserve, amount); 1617 END ReleaseDisk; 1618 1619 PROCEDURE TempHandle():CARDINAL; 1620 BEGIN 1621 RETURN g.temp_file; 1622 END TempHandle; 1623 1624 1625 (*# save,data(const_in_code=>on) *) 1626 CONST TempFileName = '\tstemp00.$$$'; 1627 CONST FullTempFileName = 1628 'A:\ '; 1629 (*%T EMS*) 1630 CONST EmsName = 'EMMXXXX0'; 1631 (*%E*) 1632 (*# restore *) 1633 1634 PROCEDURE SetEms(on:BOOLEAN):BOOLEAN; 1635 (*%T EMS*) 1636 VAR 1637 ems:CARDINAL; 1638 i,p:CARDINAL; 1639 ems_page,ems_off:CARDINAL; 1640 avail:CARDINAL; 1641 LABEL restore_data, return; 1642 (*%E*) 1643 BEGIN 1644 (*%T EMS*) 1645 release_panic; 1646 IF (g.ems_temp_handle # 0) = on THEN 1647 GOTO return; 1648 END; 1649 IF on THEN 1650 IF g.ems_data_handle = 0 THEN 1651 IF ~ g.ems_present THEN 1652 GOTO return; 1653 END; 1654 avail := EmsGet(4200H); (* get number of free pages *) 1655 IF avail < 4 THEN 1656 GOTO return; 1657 END; 1658 g.ems_count := avail; 1659 g.ems_data_handle := EmsAlloc(4300H, 4); (* allocate free pages *) 1660 (* put 64K block in free memory chain*) 1661 FOR p := 0 TO 3 DO 1662 EmsMap(4400H+p, p, g.ems_data_handle); 1663 END; 1664 MakeSys(g.ems_frame + 1000H - 1); 1665 MakeSys(g.ems_frame); 1666 WITH [g.ems_frame:0 T]^ DO 1667 Used := 0; 1668 INC(g.freemem, Size); 1669 END; 1670 END; 1671 avail := EmsGet(4200H); (* get number of free pages *) 1672 IF avail = 0 THEN 1673 GOTO return; 1674 END; 1675 g.ems_temp_handle := EmsAlloc(4300H, avail); (* allocate free pages *) 1676 g.temp_ems := avail * EmsPageSize; 1677 ReleaseDisk(LONGINT(g.temp_ems)*TempPageSize); 1678 END; 1679 (* transfer pages from temp file to/from ems *) 1680 FOR i := 0 TO g.temp_ems-1 DO 1681 IF (i MOD 16) IN g.temp_map[i DIV 16] THEN 1682 ems_page := i DIV EmsPageSize; 1683 ems_off := (i MOD EmsPageSize) * TempPageSize; 1684 EmsMap(4400H, ems_page, g.ems_temp_handle); 1685 FileSeek(g.temp_file, LONGCARD(i)*TempPageSize); 1686 IF on THEN 1687 FileRead([g.ems_frame:ems_off], TempPageSize, g.temp_file); 1688 ELSE 1689 IF FileWrite([g.ems_frame:ems_off], TempPageSize, g.temp_file) # TempPageSize THEN 1690 GOTO restore_data; 1691 END; 1692 END; 1693 END; 1694 END; 1695 IF ~ on THEN 1696 IF ~ ReserveDisk(LONGINT(g.temp_ems)*TempPageSize) THEN 1697 GOTO restore_data; 1698 END; 1699 EmsMap(4500H, 0, g.ems_temp_handle); (* free temp pages *) 1700 g.ems_temp_handle := 0; 1701 g.temp_ems := 0; 1702 END; 1703 restore_data: 1704 EmsMap(4400H, 0, g.ems_data_handle); (* restore data page *) 1705 return: 1706 reserve_panic; 1707 RETURN g.ems_temp_handle # 0; 1708 (*%E*) 1709 (*%F EMS*) 1710 RETURN FALSE; 1711 (*%E*) 1712 END SetEms; 1713 1714 PROCEDURE DoSeg(modnum:ModNum;segnum:SegNum;op:DoSegOp):CARDINAL; FORWARD; 1715 1716 PROCEDURE DoDelay; 1717 VAR 1718 module : Module; 1719 modnum : ModNum; 1720 segnum : SegNum; 1721 segment : CARDINAL; 1722 gate : GatePtr; 1723 seghdr : SegPtr; 1724 seginfosize : CARDINAL; 1725 BEGIN 1726 IF g.delay # 0 THEN 1727 modnum := g.delay; 1728 g.delay := 0; 1729 module := g.module_list[modnum]; 1730 (* swap out all segments *) 1731 FOR segnum := 1 TO module^.seg_count DO 1732 segment := DoSeg(modnum,segnum,Discard); 1733 END; (*FOR*) 1734 (* delete gates *) 1735 seginfosize := module^.seg_count * SIZE(SegRec); 1736 gate := GatePtr(HeapAdr(g.gate_table)); 1737 LOOP 1738 IF gate^.state = IndirectGate THEN 1739 seghdr := SegPtr(gate^.w1 + CARDINAL(gate) + 3); 1740 IF CARDINAL(seghdr) - CARDINAL(module^.seg_info) < seginfosize THEN 1741 gate^.state := DeletedGate; 1742 END; (*IF*) 1743 END; (*IF*) 1744 IF gate = GatePtr(HeapAdr(g.gate_table[MaxGate])) THEN 1745 EXIT; 1746 END; (*IF*) 1747 INC(CARDINAL(gate),SIZE(GateRec)); 1748 END; (*LOOP*) 1749 (* close file *) 1750 IF (module^.file # MAX(CARDINAL)) THEN 1751 FileClose(module^.file); 1752 IF FileTrace THEN 1753 string('Close file '); 1754 string(module^.name^); 1755 eol; 1756 END; (*IF*) 1757 module^.file := MAX(CARDINAL); 1758 DEC(g.file_count); 1759 END; (*IF*) 1760 (* free heap if last module *) 1761 IF modnum = g.module_count THEN 1762 DEC(g.module_count); 1763 Fill(ADR(module^),g.near_alloc - CARDINAL(module),0); 1764 g.near_alloc := CARDINAL(module); 1765 END; (*IF*) 1766 END; (*IF*) 1767 END DoDelay; 1768 1769 PROCEDURE UnLoadModule(modnum:CARDINAL); 1770 BEGIN 1771 IF g.delay # modnum THEN 1772 DoDelay; 1773 END; 1774 g.delay := modnum; 1775 END UnLoadModule; 1776 1777 1778 1779 PROCEDURE GetOrdProcAddr (modnum:CARDINAL;entry:CARDINAL):ADDRESS; 1780 VAR 1781 offset:CARDINAL; 1782 module:Module; 1783 BEGIN 1784 module := g.module_list[modnum]; 1785 offset := Gate(module^.entry_table^[entry].ofs, 1786 GetSeg(module, SegNum(module^.entry_table^[entry].seg)), TRUE); 1787 RETURN [Seg(g) : offset]; 1788 END GetOrdProcAddr; 1789 1790 PROCEDURE New(size:CARDINAL):HeapADDR; 1791 (* Allocate bytes from Near Heap *) 1792 VAR res:HeapADDR; 1793 BEGIN 1794 res := SHORTADDR(g.near_alloc); 1795 INC(g.near_alloc,size); 1796 IF g.near_alloc > Ofs(g.heap[HeapSize]) THEN 1797 abort(ErrNearHeap); 1798 END; (*IF*) 1799 RETURN res; 1800 END New; 1801 1802 PROCEDURE Length(s: ARRAY OF CHAR):CARDINAL; (*String*) 1803 VAR i:CARDINAL; 1804 BEGIN 1805 i := 0; 1806 WHILE s[i]#0C DO 1807 INC(i); 1808 END; 1809 RETURN i; 1810 END Length; 1811 1812 PROCEDURE Compare(s1,s2:ARRAY OF CHAR):BOOLEAN; (*String*) 1813 VAR 1814 i : CARDINAL; 1815 BEGIN 1816 i := 0; 1817 LOOP 1818 IF s1[i] # s2[i] THEN 1819 RETURN FALSE; 1820 END; 1821 IF s1[i] = 0C THEN 1822 RETURN TRUE; 1823 END; 1824 INC(i); 1825 END; 1826 END Compare; 1827 1828 1829 PROCEDURE GetNextFree(seg : CARDINAL;VAR fsize : CARDINAL) : CARDINAL; 1830 (* Returns next area > seg that is not being used for anything *) 1831 (* Used for spawn *) 1832 VAR p:CARDINAL; fseg : CARDINAL; 1833 BEGIN 1834 p := g.start; 1835 LOOP 1836 WITH [p:0 T]^ DO 1837 IF p+Used>seg THEN 1838 fseg := p+Used; 1839 fsize := Size-Used; 1840 IF (fsize>0) THEN 1841 (*%T EMS*) 1842 IF (g.ems_data_handle = 0) OR 1843 (fsegg.ems_frame+1000H) 1845 THEN 1846 EXIT; 1847 END; 1848 (*%E*) 1849 (*%F EMS*) 1850 EXIT; 1851 (*%E*) 1852 END; 1853 END; 1854 p := p+Size; 1855 END; 1856 IF p = g.start THEN 1857 fseg := 0; 1858 EXIT; 1859 END; 1860 END; 1861 RETURN fseg; 1862 END GetNextFree; 1863 1864 (*%F CHECK*) INLINE (*%E*) PROCEDURE Lock(seg:CARDINAL); 1865 BEGIN 1866 IF LockTrace THEN 1867 string('Lock '); hex(seg); eol; 1868 END; 1869 (*%T CHECK*) 1870 CheckAlloc(seg,0); 1871 (*%E*) 1872 INC([seg-H:0 T]^.Lock); 1873 END Lock; 1874 1875 (*%F CHECK*) INLINE (*%E*) PROCEDURE UnLock(seg:CARDINAL); 1876 BEGIN 1877 IF LockTrace THEN 1878 string('UnLock '); hex(seg); eol; 1879 END; 1880 (*%T CHECK*) 1881 CheckAlloc(seg,0); 1882 IF [seg-H:0 T]^.Lock = 0 THEN abort(ErrTooManyUnlocks); END; 1883 (*%E*) 1884 DEC([seg-H:0 T]^.Lock); 1885 END UnLock; 1886 1887 1888 PROCEDURE DoSwap(seg : CARDINAL); 1889 (* Only called for StaticSeg and SwapSeg *) 1890 VAR 1891 dummy : CARDINAL; 1892 seghdr : SegPtr; 1893 BEGIN 1894 WITH [seg:0 T]^ DO 1895 IF Kind=StaticSeg THEN 1896 (*%T CHECK*) 1897 seghdr := SegPtr(HeapAdr(g.module_list[Id1]^.seg_info^[Id2])); 1898 IF seghdr^.direct_list<>GatePtr(0) THEN 1899 abort(ErrInternal); 1900 END; 1901 (*%E*) 1902 dummy := DoSeg(Id1,Id2,Swap); 1903 ELSIF Kind=SwapSeg THEN 1904 TempXfer(Swap,[Id2:Id1 WP]^,seg+1,0,([seg:0 T]^.Used-1)*16); 1905 Free(seg+1); 1906 ELSE 1907 (*%T CHECK*) 1908 abort(ErrInternal); 1909 (*%E*) 1910 END; 1911 END; 1912 END DoSwap; 1913 1914 1915 PROCEDURE IsActive(seghdr:SegPtr):BOOLEAN; 1916 TYPE 1917 fp = POINTER Seg(seghdr) TO RECORD 1918 bp,ip,cs: CARDINAL; 1919 END; (*fp*) 1920 VAR 1921 bp : fp; 1922 cs : CARDINAL; 1923 res : BOOLEAN; 1924 BEGIN 1925 res := FALSE; 1926 cs := seghdr^.seg_val; 1927 bp := fp(GetBP()); 1928 REPEAT 1929 (*%T CHECK*) 1930 IF bp^.bp # 0 THEN 1931 CheckAlloc(bp^.cs,ErrCallChainInvalid); 1932 END; (*IF*) 1933 (*%E*) 1934 IF bp^.cs = cs THEN 1935 bp^.ip := Gate(bp^.ip,seghdr,FALSE); 1936 bp^.cs := Seg(g); 1937 res := TRUE; 1938 END; (*IF*) 1939 (*%T CHECK*) 1940 IF ((bp^.bp=0)AND(bp^.ip # 1234H)) OR 1941 ((bp^.bp<>0)AND(bp^.bp <= CARDINAL(bp))) THEN 1942 abort(ErrCallChainInvalid); 1943 END; (*IF*) 1944 (*%E*) 1945 bp := fp(bp^.bp); 1946 UNTIL bp = fp(0); 1947 RETURN res; 1948 END IsActive; 1949 1950 PROCEDURE MyCaller():CARDINAL; 1951 VAR 1952 res : BOOLEAN; 1953 TYPE 1954 fp = POINTER Seg(res) TO RECORD 1955 bp,ip,cs: CARDINAL; 1956 END; (*fp*) 1957 VAR 1958 bp : fp; 1959 BEGIN 1960 res := FALSE; 1961 bp := fp(GetBP()); 1962 REPEAT 1963 (*%T CHECK*) 1964 IF bp^.bp # 0 THEN 1965 CheckAlloc(bp^.cs,ErrCallChainInvalid); 1966 END; (*IF*) 1967 IF ((bp^.bp=0)AND(bp^.ip # 1234H)) OR 1968 ((bp^.bp<>0)AND(bp^.bp <= CARDINAL(bp))) THEN 1969 abort(ErrCallChainInvalid); 1970 END; (*IF*) 1971 (*%E*) 1972 IF bp^.cs<>Seg(MyCaller) THEN 1973 RETURN bp^.cs; 1974 END; 1975 bp := fp(bp^.bp); 1976 UNTIL bp = fp(0); 1977 RETURN 0; 1978 END MyCaller; 1979 1980 1981 PROCEDURE RelocStatic(seghdr:SegPtr;new:CARDINAL); 1982 TYPE 1983 fp = POINTER Seg(seghdr) TO RECORD 1984 bp,ip,cs: CARDINAL; 1985 END; (*fp*) 1986 VAR 1987 bp : fp; 1988 cs : CARDINAL; 1989 gate : GatePtr; 1990 BEGIN 1991 cs := seghdr^.seg_val; 1992 seghdr^.seg_val := new; 1993 gate := seghdr^.direct_list; 1994 WHILE gate # GatePtr(0) DO 1995 gate^.w2 := new; 1996 gate := gate^.next_direct; 1997 END; (*WHILE*) 1998 bp := fp(GetBP()); 1999 REPEAT 2000 IF bp^.cs = cs THEN 2001 bp^.cs := new; 2002 (*%T CHECK*) 2003 ELSIF bp^.bp # 0 THEN 2004 CheckAlloc(bp^.cs,ErrCallChainInvalid); 2005 (*%E*) 2006 END; (*IF*) 2007 (*%T CHECK*) 2008 IF ((bp^.bp=0)AND(bp^.ip # 1234H)) OR 2009 ((bp^.bp<>0)AND(bp^.bp <= CARDINAL(bp))) THEN 2010 abort(ErrCallChainInvalid); 2011 END; (*IF*) 2012 (*%E*) 2013 bp := fp(bp^.bp); 2014 UNTIL bp = fp(0); 2015 END RelocStatic; 2016 2017 PROCEDURE DoFlushAll; 2018 VAR 2019 tmp : CARDINAL; 2020 change : BOOLEAN; 2021 BEGIN 2022 REPEAT 2023 change := FALSE; 2024 tmp := g.start; 2025 REPEAT 2026 WITH [tmp:0 T]^ DO 2027 IF (Lock = 0) & (Kind # MoveSeg) THEN 2028 IF Kind=StaticSeg THEN 2029 SetIndirect(SegPtr(HeapAdr(g.module_list[Id1]^.seg_info^[Id2]))); 2030 END; 2031 DoSwap(tmp); 2032 change := TRUE; 2033 END; (*IF*) 2034 INC(tmp,Size); 2035 END; (*WITH*) 2036 UNTIL tmp = g.start; 2037 UNTIL ~change; 2038 END DoFlushAll; 2039 2040 PROCEDURE TinyFlush; FORWARD; 2041 2042 (* Should do long jump to reset point, Also OutOfDisk needs doing *) 2043 PROCEDURE OutOfMem(request:CARDINAL); 2044 BEGIN 2045 IF OutOfMemTrace THEN 2046 string('Out of memory.'); 2047 eol; 2048 DumpMemory; 2049 MemStat; 2050 END; (*IF*) 2051 IF ~g.OutOfMem(request) THEN 2052 abort(ErrOutOfMem); 2053 END; (*IF*) 2054 END OutOfMem; 2055 2056 PROCEDURE FlushLRU(req:CARDINAL); 2057 VAR 2058 tmp : CARDINAL; 2059 lru : CARDINAL; 2060 age,maxage : CARDINAL; 2061 res : BOOLEAN; 2062 i : CARDINAL; 2063 wants : CARDINAL; 2064 ssize : CARDINAL; 2065 seghdr : SegPtr; 2066 BEGIN 2067 (*%T GraphUseTrace*) 2068 GraphTrace(0,req,GTlru); 2069 (*%E*) 2070 wants := req+400H; 2071 (*%T CHECK*) 2072 CheckMem; 2073 (*%E*) 2074 TinyFlush; 2075 2076 tmp := g.start; 2077 (* Mark all segments as indirect to help LRU *) 2078 REPEAT 2079 WITH [tmp:0 T]^ DO 2080 IF (Kind =StaticSeg) & (Lock=0) THEN 2081 seghdr := SegPtr(HeapAdr(g.module_list[Id1]^.seg_info^[Id2])); 2082 IF seghdr^.direct_list<>GatePtr(0) THEN 2083 SetIndirect(seghdr); 2084 END; 2085 END; (*IF*) 2086 INC(tmp,Size); 2087 END; (*WITH*) 2088 UNTIL tmp = g.start; 2089 [MyCaller()-H:0 T]^.Tick := IncTick(); 2090 LOOP 2091 ssize := 0; 2092 maxage := 0; 2093 tmp := g.start; 2094 lru := 0; 2095 REPEAT 2096 WITH [tmp:0 T]^ DO 2097 IF (Kind # MoveSeg) & (Lock=0) THEN 2098 age := GetTick() - Tick; 2099 IF (age >= maxage) THEN 2100 lru := tmp; 2101 maxage := age; 2102 END; (*IF*) 2103 END; (*IF*) 2104 INC(tmp,Size); 2105 END; (*WITH*) 2106 UNTIL tmp = g.start; 2107 IF lru # 0 THEN 2108 WITH [lru:0 T]^ DO 2109 ssize := Used; 2110 DoSwap(lru); 2111 (*%T UsageTrace*) 2112 string('Age='); 2113 dec(maxage); 2114 string('Req='); 2115 dec(req); 2116 char(' '); 2117 MemStat; 2118 (*%E*) 2119 IF ssize>=wants THEN 2120 EXIT; 2121 END; 2122 DEC(wants,ssize); 2123 END; (*WITH*) 2124 ELSE 2125 IF ssize=0 THEN 2126 OutOfMem(req); 2127 END; 2128 EXIT; 2129 END; (*IF*) 2130 END; (*LOOP*) 2131 END FlushLRU; 2132 2133 2134 2135 PROCEDURE Relocate(old,new:CARDINAL); 2136 BEGIN 2137 IF RelocateTrace THEN 2138 string('Relocate '); 2139 hex(old+H); 2140 string(' to '); 2141 hex(new+H); 2142 eol; 2143 END; (*IF*) 2144 INC(new, H); 2145 WITH [old:0 T]^ DO 2146 CASE Kind OF 2147 StaticSeg : (*%T VidSupport*) 2148 TellVid(Id1,Id2,VID_UNLOAD_SEG); 2149 (*%E*) 2150 RelocStatic(SegPtr(HeapAdr(g.module_list[Id1]^.seg_info^[Id2])),new); 2151 (*%T VidSupport*) 2152 g.vid_delayed := TRUE; 2153 g.vid_id1 := Id1; 2154 g.vid_id2 := Id2; 2155 (*%E*) | 2156 MoveSeg,SwapSeg : [Id2:Id1 WP]^ := new; | 2157 ELSE 2158 abort(ErrInternal); 2159 END; (*CASE*) 2160 END; (*WITH*) 2161 END Relocate; 2162 2163 (* Used to move relocatable block, No overlap *) 2164 PROCEDURE SimpleMove(old,new:CARDINAL); 2165 CONST 2166 K = VSIZE(ParaRec.Prev); 2167 VAR 2168 size : CARDINAL; 2169 BEGIN 2170 Relocate(old,new); 2171 size := [old:0 T]^.Used; 2172 Move([old:K],[new:K],size*16-K); 2173 (*%T VidSupport*) 2174 TellVidMove; 2175 (*%E*) 2176 (*%T MemoryTrace*) 2177 g.internal := TRUE; 2178 (*%E*) 2179 Free(old+H); 2180 (*%T MemoryTrace*) 2181 g.internal := FALSE; 2182 (*%E*) 2183 (*%T CHECK*) 2184 CheckAlloc(new+H,0); 2185 (*%E*) 2186 END SimpleMove; 2187 2188 (* move segments in area (s..e) down *) 2189 PROCEDURE Shuffle(s,e:CARDINAL); 2190 VAR 2191 old,new,diff,size : CARDINAL; 2192 BEGIN 2193 LOOP 2194 WITH [s:0 T]^ DO 2195 old := s + Size; 2196 IF old = e THEN 2197 EXIT; 2198 END; (*IF*) 2199 diff := Size - Used; 2200 new := old - diff; 2201 IF diff > 0 THEN 2202 size := [old:0 T]^.Used; 2203 Relocate(old,new); 2204 (*%T MoveTrace *) 2205 INC(g.move_total,LONGCARD(size*16)); 2206 (*%E*) 2207 Move([old:0],[new:0],size*16); 2208 (*%T VidSupport*) 2209 TellVidMove; 2210 (*%E*) 2211 DEC(Size,diff); 2212 WITH [new:0 T]^ DO 2213 INC(Size,diff); 2214 [new+Size:0 T]^.Prev := new; 2215 END; (*WITH*) 2216 (*%T CHECK*) 2217 CheckAlloc(new+H,0); 2218 (*%E*) 2219 END; (*IF*) 2220 s := new; 2221 END; (*WITH*) 2222 END; (*LOOP*) 2223 END Shuffle; 2224 2225 PROCEDURE Get(req:CARDINAL):CARDINAL; FORWARD; 2226 2227 (* Choose a block of size < max to evacuate. We choose largest up to *) 2228 (* aim, then smallest. Thus we search the range (res,max) until *) 2229 (* size(res) >= aim then we search the range (aim,size(res)). *) 2230 PROCEDURE Choose(s,e,aim,max:CARDINAL):CARDINAL; 2231 VAR 2232 res,min,size,poss : CARDINAL; 2233 BEGIN 2234 INC(s,[s:0 T]^.Size); 2235 min := 0; 2236 res := 0; 2237 poss := 0; 2238 WHILE s # e DO 2239 WITH [s:0 T]^ DO 2240 size := Used; 2241 IF size < max THEN 2242 INC(poss,size); 2243 IF size > min THEN 2244 res := s; 2245 IF size >= aim THEN 2246 min := aim; 2247 max := size; 2248 ELSE 2249 min := size; 2250 END; (*IF*) 2251 END; (*IF*) 2252 END; (*IF*) 2253 INC(s,Size); 2254 END; (*WITH*) 2255 END; (*WHILE*) 2256 IF poss < aim THEN 2257 res := 0; 2258 END; (*IF*) 2259 RETURN res; 2260 END Choose; 2261 2262 (* In decreasing size, evacuate segs in area s satisfying Used < lim, *) 2263 (* until free space for s..e >= need *) 2264 PROCEDURE Evac(s,e:CARDINAL;lim:CARDINAL;need:CARDINAL):BOOLEAN; 2265 VAR 2266 got,old,new,poss : CARDINAL; 2267 res : BOOLEAN; 2268 BEGIN 2269 got := Got(s,e); 2270 [s:0 T]^.Active := TRUE; 2271 LOOP 2272 IF got >= need THEN 2273 res := TRUE; 2274 EXIT; 2275 ELSE 2276 old := Choose(s,e,need-got,lim); 2277 IF old = 0 THEN 2278 res := FALSE; 2279 EXIT; 2280 END; (*IF*) 2281 WITH [old:0 T]^ DO 2282 lim := Used; 2283 new := Get(lim); 2284 IF new # 0 THEN 2285 new := SplitLow(lim,new); 2286 SimpleMove(old,new); 2287 INC(got,lim); 2288 INC(lim); (* others of same size are acceptable *) 2289 END; (*IF*) 2290 END; (*WITH*) 2291 END; (*IF*) 2292 END; (*LOOP*) 2293 [s:0 T]^.Active := FALSE; 2294 RETURN res; 2295 END Evac; 2296 2297 PROCEDURE Get(req:CARDINAL):CARDINAL; 2298 VAR 2299 max,s,e,res : CARDINAL; 2300 BEGIN 2301 max := MaxPoss(req,s,e); 2302 IF (max >= req) & Evac(s,e,req,req) THEN 2303 Shuffle(s, e); 2304 res := Try(req,s,e); 2305 (*%T CHECK*) 2306 IF res = 0 THEN 2307 abort(ErrInternal); 2308 END; (*IF*) 2309 (*%E*) 2310 ELSE 2311 res := 0; 2312 END; (*IF*) 2313 RETURN res; 2314 END Get; 2315 2316 (* Moves relocatable segments in range (s..e) up, thus increasing *) 2317 (* s^.Size. *) 2318 PROCEDURE ShuffleUp(s,e:CARDINAL); 2319 VAR 2320 w,p,new,diff : CARDINAL; 2321 BEGIN 2322 w := [e:0 T]^.Prev; 2323 LOOP 2324 IF w = s THEN 2325 EXIT; 2326 END; (*IF*) 2327 WITH [w:0 T]^ DO 2328 p := Prev; 2329 diff := Size - Used; 2330 new := w + diff; 2331 IF (diff > 0) THEN 2332 Relocate(w,new); 2333 DEC(Size,diff); 2334 [e:0 T]^.Prev := new; 2335 INC([p:0 T]^.Size,diff); 2336 (*%T MoveTrace *) 2337 INC(g.move_total,LONGCARD(Used*16)); 2338 (*%E*) 2339 MoveUp([w:0],[new:0],Used*16); 2340 (*%T VidSupport*) 2341 TellVidMove; 2342 (*%E*) 2343 END; (*IF*) 2344 END; (*WITH*) 2345 e := new; 2346 w := p; 2347 END; (*LOOP*) 2348 (*%T CHECK*) 2349 CheckMem; 2350 (*%E*) 2351 END ShuffleUp; 2352 2353 PROCEDURE IAlloc(size:CARDINAL;id1,id2:CARDINAL;kind:SegKind;high:BOOLEAN):CARDINAL; 2354 VAR 2355 s,e,sm,em, 2356 use,res : CARDINAL; 2357 BEGIN 2358 (*%T CHECK*) 2359 CheckMem; 2360 (*%E*) 2361 g.allockind := kind; 2362 INC(size,H); 2363 IF high THEN 2364 LOOP (* decide area: last such that Poss(a) >= size *) 2365 sm := 0; 2366 s := g.start; 2367 REPEAT 2368 e := NextArea(s); 2369 IF Poss(s,e,MAX(CARDINAL)) >= size THEN 2370 sm := s; 2371 em := e; 2372 END; (*IF*) 2373 s := e; 2374 UNTIL s = g.start; 2375 IF sm # 0 THEN 2376 IF (TotalAvail() >= size) & Evac(sm,em,MAX(CARDINAL),size) THEN 2377 Shuffle(sm,em); 2378 use := Try(size,sm,em); 2379 (*%T CHECK*) 2380 IF use = 0 THEN 2381 abort(ErrInternal); 2382 END; (*IF*) 2383 (*%E*) 2384 EXIT; 2385 END; (*IF*) 2386 END; (*IF*) 2387 FlushLRU(size); 2388 END; (*LOOP*) 2389 WITH [use:0 T]^ DO 2390 DEC(Size,size); 2391 res := use + Size; 2392 END; (*WITH*) 2393 WITH [res:0 T]^ DO 2394 Size := size; 2395 Used := size; 2396 IF res # use THEN 2397 Prev := use; 2398 END; (*IF*) 2399 [res+size:0 T]^.Prev := res; 2400 END; (*WITH*) 2401 DEC(g.freemem,size); 2402 ELSE 2403 LOOP 2404 (*%T DEBUG*) 2405 use := 0; 2406 (*%E*) 2407 (*%F DEBUG*) 2408 use := Try(size,g.start,g.start); 2409 (*%E*) 2410 IF (use = 0) & (TotalAvail() >= size) THEN 2411 use := Get(size); 2412 END; (*IF*) 2413 IF use # 0 THEN 2414 EXIT; 2415 END; (*IF*) 2416 FlushLRU(size); 2417 END; (*IF*) 2418 res := SplitLow(size,use); 2419 END; (*IF*) 2420 WITH [res:0 T]^ DO 2421 Id1 := id1; 2422 Id2 := id2; 2423 Kind := kind; 2424 Active := FALSE; 2425 Lock := 1; 2426 Tick := IncTick(); 2427 END; (*WITH*) 2428 INC(res,H); 2429 DEC(size,H); 2430 (*%T MemoryTrace*) 2431 IF (kind IN MemTraceSet) THEN 2432 TraceSeg('IAlloc',res); 2433 END; (*IF*) 2434 (*%E*) 2435 (*%T Debuging*) 2436 IF res = g.trap_alloc THEN 2437 P; 2438 END; (*IF*) 2439 (*%E*) 2440 (*%T CHECK*) 2441 CheckAlloc(res,0); 2442 CheckMem; 2443 (*%E*) 2444 RETURN res; 2445 END IAlloc; 2446 2447 PROCEDURE AllocFixed(size:CARDINAL):CARDINAL; 2448 BEGIN 2449 RETURN IAlloc(size, 0, 0, FixedSeg, TRUE); 2450 END AllocFixed; 2451 2452 2453 PROCEDURE AllocMove(VAR seg:CARDINAL;size:CARDINAL); 2454 VAR 2455 a:ADDRESS; 2456 res:CARDINAL; 2457 BEGIN 2458 a := ADR(seg); 2459 res := IAlloc(size, Ofs(a^), Seg(a^), MoveSeg, FALSE); 2460 UnLock(res); 2461 seg := res; 2462 END AllocMove; 2463 2464 PROCEDURE ReSize(VAR seg:CARDINAL;newsize:CARDINAL); 2465 VAR 2466 old,use,s,e:CARDINAL; 2467 (*%T MemoryTrace*) easy:BOOLEAN; (*%E*) 2468 BEGIN 2469 (*%T MemoryTrace*) easy := TRUE; (*%E*) 2470 g.allockind := MoveSeg; 2471 INC(newsize,H); 2472 LOOP 2473 old := seg-H; 2474 WITH [old:0 T]^ DO 2475 IF Size >= newsize THEN 2476 INC(g.freemem, Used); 2477 DEC(g.freemem, newsize); 2478 Used := newsize; 2479 EXIT; 2480 END; 2481 (*%T MemoryTrace*) easy := FALSE; (*%E*) 2482 use := Try(newsize, g.start, g.start); 2483 IF use = 0 THEN 2484 s := Find(old); 2485 e := NextArea(s); 2486 IF (newsize>1000H) & 2487 (TotalAvail()>newsize-Used) & 2488 Evac(s, e, Used, newsize-Used) 2489 THEN 2490 ShuffleUp(old, e); 2491 Shuffle(s, old+Size); 2492 (*%T CHECK*) IF [seg-H:0 T]^.Size < newsize THEN abort(ErrInternal); END; (*%E*) 2493 ELSE 2494 IF TotalAvail() >= newsize THEN 2495 use := Get(newsize); 2496 END; 2497 IF use = 0 THEN 2498 FlushLRU(newsize); 2499 END; 2500 END; 2501 END; 2502 IF use # 0 THEN 2503 use := SplitLow(newsize, use); 2504 SimpleMove(seg-H, use); 2505 EXIT; 2506 END; 2507 END; 2508 END; 2509 (*%T MemoryTrace*) 2510 IF (MoveSeg IN MemTraceSet) & (~easy) THEN 2511 TraceSeg('ReSize',seg); 2512 END; 2513 (*%E*) 2514 END ReSize; 2515 2516 PROCEDURE LoadMove(VAR seg:CARDINAL;size:CARDINAL); 2517 VAR 2518 tmp:CARDINAL; 2519 BEGIN 2520 tmp := seg; 2521 IF ~ is_mem(tmp) THEN 2522 AllocMove(seg, size); 2523 TempXfer(Load, tmp, seg, 0, size*16); 2524 ELSE 2525 (*%T CHECK*) CheckAlloc(tmp,ErrInvalidVFix); (*%E*) 2526 WITH [tmp-H:0 T]^ DO 2527 (*%T CHECK*) IF (Kind # MoveSeg) 2528 & (Kind # SwapSeg) 2529 THEN abort(ErrInvalidVFix); 2530 END; 2531 (*%E*) 2532 Kind := MoveSeg; 2533 END; 2534 END; 2535 END LoadMove; 2536 2537 2538 PROCEDURE LoadCode(seghdr:SegPtr):CARDINAL; 2539 VAR 2540 segment:CARDINAL; 2541 modnum:ModNum; 2542 module:Module; 2543 segnum:SegNum; 2544 BEGIN 2545 segment := seghdr^.seg_val; 2546 IF ~ is_mem(segment) THEN 2547 modnum := 0; 2548 LOOP 2549 INC(modnum); 2550 (*%T CHECK*) IF modnum > g.module_count THEN abort(ErrInternal); END; (*%E*) 2551 module := g.module_list[modnum]; 2552 segnum := 1+(CARDINAL(seghdr)-CARDINAL(module^.seg_info)) DIV SIZE(SegRec); 2553 IF segnum-1 < module^.seg_count THEN 2554 EXIT; 2555 END; 2556 END; 2557 segment := DoSeg(modnum, segnum, Load); 2558 UnLock(segment); 2559 ELSE 2560 [segment-H:0 T]^.Tick := IncTick(); 2561 END; 2562 RETURN segment; 2563 END LoadCode; 2564 2565 PROCEDURE CallTrap(sd:CARDINAL;gd:CARDINAL):CARDINAL; 2566 VAR 2567 seghdr:SegPtr; 2568 gate:GatePtr; 2569 segment:CARDINAL; 2570 BEGIN 2571 gate := GatePtr(gd); 2572 seghdr := SegPtr(sd); 2573 segment := LoadCode(seghdr); 2574 gate^.next_direct := seghdr^.direct_list; 2575 seghdr^.direct_list := gate; 2576 gate^.state := DirectGate; 2577 gate^.w1 := gate^.w2; 2578 gate^.w2 := segment; 2579 RETURN CARDINAL(gate); 2580 END CallTrap; 2581 2582 PROCEDURE ReturnTrap(sd:CARDINAL):CARDINAL; 2583 VAR 2584 seghdr : SegPtr; 2585 BEGIN 2586 seghdr := SegPtr(sd); 2587 RETURN LoadCode(seghdr); 2588 END ReturnTrap; 2589 2590 PROCEDURE DoSeg(modnum:ModNum;segnum:SegNum;op:DoSegOp):CARDINAL; 2591 CONST 2592 (* values for Fixup.lockind *) 2593 FixOfs = 5; 2594 FixBase = 2; 2595 FixPtr = 3; 2596 VAR 2597 segment : CARDINAL; 2598 TYPE 2599 LocPtr = POINTER segment TO RECORD 2600 lo,hi : CARDINAL; 2601 END; (*LocPtr*) 2602 set = SET OF [0..7]; 2603 Fixup = RECORD 2604 lockind : SHORTCARD; 2605 flags : SHORTCARD; 2606 off : CARDINAL; 2607 CASE :SHORTCARD OF 2608 0 : target_mod : CARDINAL; 2609 target_ent : CARDINAL; | 2610 1 : target_seg : SegNum; 2611 target_off : CARDINAL; | 2612 END; (*CASE*) 2613 END; (*Fixup*) 2614 VAR 2615 loc,next : LocPtr; 2616 fixbuf : POINTER TO ARRAY [1..999] OF Fixup; 2617 fix : Fixup; 2618 fi : CARDINAL; 2619 segsize : CARDINAL; 2620 target_modnum : ModNum; 2621 target_module : Module; 2622 target_segment : CARDINAL; 2623 target_attr : SegSet; 2624 chain : BOOLEAN; 2625 pos : LONGCARD; 2626 fillcount : CARDINAL; 2627 tempsize : CARDINAL; 2628 gate : GatePtr; 2629 target_seghdr : SegPtr; 2630 module : Module; 2631 seghdr : SegPtr; 2632 (*%T VidSupport*) 2633 vid_op : VidAction; 2634 (*%E*) 2635 LABEL 2636 ordinal; 2637 2638 BEGIN 2639 module := g.module_list[modnum]; 2640 (*%T VidSupport*) 2641 IF op # Load THEN 2642 TellVid(modnum,segnum,VID_UNLOAD_SEG); 2643 END; (*IF*) 2644 (*%E*) 2645 seghdr := SegPtr(HeapAdr(module^.seg_info^[segnum])); 2646 (*%T CHECK*) 2647 IF (modnum > g.module_count)OR 2648 (segnum > module^.seg_count) THEN 2649 abort(ErrInternal); 2650 END; (*IF*) 2651 (*%E*) 2652 (*%T LoadTrace *) 2653 (*%F MemoryTrace*) 2654 hex(g.freemem); 2655 (*%E*) 2656 (*%T MemoryTrace*) 2657 string(' '); 2658 (*%E*) 2659 string(' '); 2660 CASE op OF 2661 |Load: string('Load: '); 2662 |Swap: string('Swap: '); 2663 |Discard: string('Discard: '); 2664 END; 2665 string(g.module_list[modnum]^.name^); 2666 char('.'); 2667 hex(segnum); 2668 string(' mem=');hex(seghdr^.membyte); 2669 string(' dsk=');hex(seghdr^.filebyte); 2670 string(' flags= '); 2671 IF IsData IN seghdr^.flags THEN string('Data ') END; 2672 IF IsIter IN seghdr^.flags THEN string('Iter ') END; 2673 IF IsMove IN seghdr^.flags THEN string('Move ') END; 2674 IF IsPure IN seghdr^.flags THEN string('Pure ') END; 2675 IF IsPreLoad IN seghdr^.flags THEN string('PreLoad ') END; 2676 IF IsExRd IN seghdr^.flags THEN string('ExRd ') END; 2677 IF HasReloc IN seghdr^.flags THEN string('HasReloc ') END; 2678 IF IsDiscard IN seghdr^.flags THEN string('Discard ') END; 2679 IF DataActive IN seghdr^.flags THEN string('DataActive ') END; 2680 eol; 2681 (*%E*) 2682 IF seghdr^.membyte=1 THEN (* zero length segment *) 2683 IF op = Load THEN 2684 [Seg(DoSeg)-1:0 T]^.Lock := 7FFFH; 2685 RETURN Seg(DoSeg); 2686 END; 2687 RETURN 0; 2688 END; 2689 pos := LONGCARD(seghdr^.sector) << LONGCARD(module^.log_sector_size); 2690 segsize := Para(seghdr^.membyte); 2691 IF op = Load THEN 2692 seghdr^.fix_count := 0; 2693 IF (HasReloc IN seghdr^.flags) THEN 2694 IF ModuleRead(module,pos+LONGCARD(seghdr^.filebyte), 2695 ADR(seghdr^.fix_count),2) THEN 2696 (*%T CHECK*) 2697 abort(ErrOpenFail); 2698 (*%E*) 2699 END; (*IF*) 2700 END; 2701 segment := IAlloc(segsize+Para(seghdr^.fix_count*SIZE(fix)),modnum,segnum,StaticSeg, 2702 seghdr^.flags * SegSet{IsData,IsPreLoad} # SegSet{}); 2703 IF ModuleRead(module,pos,[segment:0],seghdr^.filebyte) THEN 2704 (*%T CHECK*) 2705 abort(ErrOpenFail); 2706 (*%E*) 2707 END; (*IF*) 2708 fixbuf := [segment+segsize:0]; 2709 IF seghdr^.fix_count>0 THEN (* read fixups *) 2710 IF ModuleRead(module,pos+LONGCARD(seghdr^.filebyte)+2, 2711 fixbuf,seghdr^.fix_count*SIZE(fix)) THEN 2712 (*%T CHECK*) 2713 abort(ErrOpenFail); 2714 (*%E*) 2715 END; (*IF*) 2716 END; 2717 (*%T GraphUseTrace*) 2718 IF seghdr^.flags*SegSet{IsData,IsPreLoad}=SegSet{} THEN 2719 GraphTrace(segnum+modnum*256,segment,GTadd); 2720 END; 2721 (*%E*) 2722 ELSE 2723 segment := seghdr^.seg_val; 2724 fixbuf := [segment+segsize:0]; 2725 (*%T GraphUseTrace*) 2726 IF seghdr^.flags*SegSet{IsData,IsPreLoad}=SegSet{} THEN 2727 GraphTrace(segnum+modnum*256,segment,GTdel); 2728 END; 2729 (*%E*) 2730 IF op = Swap THEN 2731 IF (~(IsData IN seghdr^.flags)) & IsActive(seghdr) THEN 2732 INCL(seghdr^.flags,DataActive); 2733 END; (*IF*) 2734 IF (SegSet{IsDiscard,IsExRd} * seghdr^.flags # SegSet{}) OR (modnum=g.delay) THEN 2735 op := Discard; 2736 END; (*IF*) 2737 END; (*IF*) 2738 END; (*IF*) 2739 fillcount := seghdr^.membyte-seghdr^.filebyte; 2740 IF ODD(fillcount) THEN 2741 DEC(fillcount) 2742 END; (*IF*) (* OK as always an extra byte! *) 2743 TempXfer(op,seghdr^.seg_val,segment,seghdr^.filebyte,fillcount); 2744 IF is_mem(segment) & (op # Load) THEN 2745 SetIndirect(seghdr); 2746 END; (*IF*) 2747 IF (op = Swap) & (DataActive IN seghdr^.flags) THEN 2748 (* do nothing *) 2749 ELSIF seghdr^.fix_count=0 THEN 2750 (* do nothing *) 2751 ELSIF is_mem(segment) OR ((DataActive IN seghdr^.flags) & (op = Discard)) THEN 2752 fi := 0; 2753 WHILE fi0)OR(~is_mem(ptr^[1]))OR([ptr^[1]-H:0 T]^.Kind<>MoveSeg) OR 2884 (NOT Locked(ptr^[1])) THEN 2885 abort(ErrInvalidVUnfix); 2886 END; 2887 (*%E*) 2888 [ptr^[1]-H:0 T]^.Tick := IncTick(); (* LRU now, otherwise could get old while fixed *) 2889 UnLock(ptr^[1]); 2890 IF NOT Locked(ptr^[1]) THEN 2891 ptr^[0] := [ptr^[1]-H:0 T]^.Size-H; 2892 SwapMove(ptr^[1]); 2893 END; 2894 END VUnfix; 2895 2896 PROCEDURE VFix(VAR addr : FarADDRESS); 2897 (* 2898 Swaps block back into memory if necessary and 2899 fixes the address so it can be used. 2900 Calls to FixVSeg and UnfixVSeg may be nested. 2901 *) 2902 VAR ptr : POINTER TO ARRAY[0..1] OF CARDINAL; 2903 BEGIN 2904 ptr := ADR(addr); 2905 IF ptr^[0]=0 THEN 2906 (*%T CHECK*) 2907 IF (([ptr^[1]-H:0 T]^.Kind<>MoveSeg) AND ([ptr^[1]-H:0 T]^.Kind<>SwapSeg))OR 2908 ([ptr^[1]-H:0 T]^.Lock=0) THEN 2909 abort(ErrInvalidVFix); 2910 END; 2911 (*%E*) 2912 ELSE 2913 (*%T CHECK*) 2914 IF is_mem(ptr^[1]) AND ([ptr^[1]-H:0 T]^.Kind<>MoveSeg) 2915 AND ([ptr^[1]-H:0 T]^.Kind<>SwapSeg) THEN 2916 abort(ErrInvalidVFix); 2917 END; 2918 (*%E*) 2919 LoadMove(ptr^[1],ptr^[0]); 2920 ptr^[0] := 0; 2921 END; 2922 Lock(ptr^[1]); 2923 END VFix; 2924 2925 PROCEDURE VFree(VAR addr : FarADDRESS); 2926 (* frees virtual memory block 2927 can be called only when segment fixed 2928 addr is reset to NIL on exit 2929 *) 2930 VAR ptr : POINTER TO ARRAY[0..1] OF CARDINAL; 2931 BEGIN 2932 VFix(addr); 2933 ptr := ADR(addr); 2934 WHILE Locked(ptr^[1]) DO 2935 UnLock(ptr^[1]); 2936 END; 2937 Free(ptr^[1]); 2938 addr := FarNIL; 2939 END VFree; 2940 2941 2942 PROCEDURE VUnfixAll(); 2943 (* Equivalent to calling VUnfix for all Virtual addresses allocated *) 2944 VAR s : CARDINAL; 2945 TYPE ap = POINTER TO ADDRESS; 2946 BEGIN 2947 s := g.start; 2948 REPEAT 2949 IF [s:0 T]^.Kind=MoveSeg THEN 2950 WHILE Locked(s+H) DO 2951 VUnfix([[s:0 T]^.Id1:[s:0 T]^.Id2 ap]^); (* cannot upset loop *) 2952 END; 2953 END; 2954 INC(s,[s:0 T]^.Size); 2955 UNTIL s = g.start; 2956 END VUnfixAll; 2957 2958 2959 2960 (* Tiny Allocation - (smaller overhead for upto 127 bytes) *) 2961 2962 2963 CONST 2964 TinyMax = 16; 2965 TinyGranularity = 8; 2966 TinyMaxSize = TinyMax*TinyGranularity-1; 2967 TinyGranularityLog2 = 3; 2968 VAR 2969 TinyFreeList : ARRAY[1..TinyMax] OF CARDINAL; 2970 2971 PROCEDURE TinyAlloc(size : CARDINAL):FarADDRESS; 2972 (* only called for allocations of 1 to TinyMaxSize *) 2973 VAR 2974 csize,i,seg : CARDINAL; 2975 BEGIN 2976 csize := (size+(TinyGranularity-1))DIV TinyGranularity; 2977 seg := TinyFreeList[csize]; 2978 IF seg=MAX(CARDINAL) THEN 2979 seg := AllocFixed(csize*TinyGranularity); 2980 IF seg=0 THEN RETURN FarNIL END; 2981 DEC(seg); 2982 [seg:0 T]^.Id1 := MAX(CARDINAL); 2983 [seg:0 T]^.Id2 := TinyFreeList[csize]; 2984 TinyFreeList[csize] := seg; 2985 END; 2986 (*%T CHECK*) 2987 IF ([seg:0 T]^.Id1=0) THEN 2988 END; 2989 (*%E*) 2990 i := 0; 2991 WHILE NOT (i IN BITSET([seg:0 T]^.Id1)) DO INC(i) END; 2992 EXCL(BITSET([seg:0 T]^.Id1),i); 2993 IF [seg:0 T]^.Id1=0 THEN 2994 TinyFreeList[csize] := [seg:0 T]^.Id2; 2995 END; 2996 RETURN [seg+1:i*csize*TinyGranularity]; 2997 END TinyAlloc; 2998 2999 PROCEDURE TinyFree(p:FarADDRESS): BOOLEAN; 3000 VAR 3001 seg,csize,i : CARDINAL; 3002 BEGIN 3003 seg := Seg(p^)-1; 3004 WITH [seg:0 T]^ DO 3005 IF (Kind<>FixedSeg)OR(Id2=0) THEN RETURN FALSE END; 3006 csize := (Used-1)DIV TinyGranularity; 3007 i := CARDINAL(p)DIV(csize*TinyGranularity); 3008 (*%T CHECK*) 3009 IF (csize=0)OR(csize>TinyMax)OR(i IN BITSET(Id1))OR 3010 (i*csize*TinyGranularity<>CARDINAL(p)) THEN 3011 abort(ErrInvalidFree); 3012 END; 3013 CheckAlloc(seg+1,ErrInvalidFree); 3014 (*%E*) 3015 IF Id1=0 THEN 3016 Id2 := TinyFreeList[csize]; 3017 TinyFreeList[csize] := seg; 3018 END; 3019 INCL(BITSET(Id1),i); 3020 END; 3021 RETURN TRUE; 3022 END TinyFree; 3023 3024 3025 3026 PROCEDURE TinyFlush; 3027 (* called occasionally to clean up tiny chains *) 3028 VAR 3029 prev,ptr,next,i : CARDINAL; 3030 BEGIN 3031 FOR i := 1 TO TinyMax DO 3032 prev := MAX(CARDINAL); 3033 ptr := TinyFreeList[i]; 3034 WHILE ptr<>MAX(CARDINAL) DO 3035 WITH [ptr:0 T]^ DO 3036 next := Id2; 3037 IF Id1=MAX(CARDINAL) THEN 3038 IF prev=MAX(CARDINAL) THEN 3039 TinyFreeList[i] := next; 3040 ELSE 3041 [prev:0 T]^.Id2 := next; 3042 END; 3043 Id1 := 0; 3044 Id2 := 0; 3045 Free(ptr+1); 3046 ELSE 3047 prev := ptr; 3048 END; 3049 END; 3050 ptr := next; 3051 END; 3052 END; 3053 END TinyFlush; 3054 3055 PROCEDURE TinyInit; 3056 VAR i : CARDINAL; 3057 BEGIN 3058 FOR i := 1 TO TinyMax DO 3059 TinyFreeList[i] := MAX(CARDINAL); 3060 END; 3061 END TinyInit; 3062 3063 TYPE 3064 ExeHeader = RECORD 3065 magic1,magic2 : CHAR; 3066 link_version : SHORTCARD; 3067 link_revision : SHORTCARD; 3068 entry_table_off : CARDINAL; 3069 entry_table_size : CARDINAL; 3070 crc : LONGCARD; 3071 flag : CARDINAL; 3072 dgroup : CARDINAL; 3073 small_heap_size : CARDINAL; 3074 small_stack_size : CARDINAL; 3075 ip,cs,sp,ss : CARDINAL; 3076 seg_count : CARDINAL; 3077 lib_count : CARDINAL; 3078 non_res_name_size : CARDINAL; 3079 seg_off : CARDINAL; 3080 resource_off : CARDINAL; 3081 res_name_off : CARDINAL; 3082 module_ref_off : CARDINAL; 3083 imp_name_off : CARDINAL; 3084 non_res_name_off : LONGCARD; 3085 mov_entry_count : CARDINAL; 3086 log_sector_size : CARDINAL; 3087 reserved : ARRAY [0..11] OF SHORTCARD; 3088 END; (*ExeHeader*) 3089 3090 3091 TYPE InitProc = PROCEDURE():CARDINAL; 3092 3093 PROCEDURE InternalLoadModule(name:ARRAY OF CHAR;is_exe:BOOLEAN;stage:ModStage):CARDINAL; 3094 3095 VAR 3096 modnum : ModNum; 3097 module : Module; 3098 len : CARDINAL; 3099 hpos : LONGCARD; 3100 hdr : ExeHeader; 3101 i : CARDINAL; 3102 libname : ARRAY [0..255] OF CHAR; 3103 bundle : RECORD 3104 ne : SHORTCARD; 3105 si : SHORTCARD; 3106 END; (*bundle*) 3107 fs : RECORD 3108 flags : SHORTCARD; 3109 off : CARDINAL; 3110 END; (*fs*) 3111 fs6 : RECORD 3112 flags : SHORTCARD; 3113 int3 : CARDINAL; 3114 seg : SHORTCARD; 3115 off : CARDINAL; 3116 END; (*fs6*) 3117 eseg : SHORTCARD; 3118 eoff : CARDINAL; 3119 SecondPass : BOOLEAN; 3120 epass : SHORTCARD[0..1]; 3121 done : CARDINAL; 3122 ord : CARDINAL; 3123 cs : CARDINAL; 3124 p : InitProc; 3125 impnameoff : CARDINAL; 3126 dummy : CARDINAL; 3127 submod : CARDINAL; 3128 substage : ModStage; 3129 pss : CARDINAL; 3130 buf_index : CARDINAL; 3131 buffer : ARRAY [0..511] OF SHORTCARD; 3132 3133 PROCEDURE Read2(a:ADDRESS;count:CARDINAL); 3134 VAR 3135 avail : CARDINAL; 3136 BEGIN 3137 LOOP 3138 avail := SIZE(buffer) - buf_index; 3139 IF avail > count THEN 3140 avail := count; 3141 END; (*IF*) 3142 Move(ADR(buffer[buf_index]),a,avail); 3143 INC(buf_index,avail); 3144 DEC(count,avail); 3145 IF count = 0 THEN 3146 EXIT; 3147 END; (*IF*) 3148 INC(CARDINAL(a),avail); 3149 FileRead(ADR(buffer),SIZE(buffer),module^.file); 3150 buf_index := 0; 3151 END; (*LOOP*) 3152 END Read2; 3153 3154 PROCEDURE Seek2(pos:LONGCARD); 3155 BEGIN 3156 buf_index := SIZE(buffer); 3157 FileSeek(module^.file,pos); 3158 END Seek2; 3159 3160 PROCEDURE Read(pos:LONGCARD;a:ADDRESS;count:CARDINAL):BOOLEAN; 3161 BEGIN 3162 buf_index := SIZE(buffer); 3163 RETURN ModuleRead(module,pos,a,count); 3164 END Read; 3165 3166 BEGIN 3167 modnum := 1; 3168 LOOP 3169 IF modnum > g.module_count THEN 3170 module := New(SIZE(module^)); 3171 len := Length(name) + 1; 3172 module^.name := New(len); 3173 Append(module^.name^,name); 3174 IF modnum > MaxModule THEN 3175 abort(ErrModuleLimit); 3176 END; (*IF*) 3177 g.module_count := modnum; (* should be check for > MaxModule *) 3178 g.module_list[modnum] := module; 3179 module^.file := MAX(CARDINAL); 3180 module^.is_exe := is_exe; 3181 (*%T GraphUseTrace*) 3182 string('Module ');hex(modnum);string(' = ');string(name);eol; 3183 (*%E*) 3184 EXIT; 3185 END; (*IF*) 3186 module := g.module_list[modnum]; 3187 IF Compare(module^.name^,name) & (module^.is_exe = is_exe) THEN 3188 EXIT; 3189 END; (*IF*) 3190 INC(modnum); 3191 END; (*LOOP*) 3192 IF module^.stage < stage THEN 3193 (* read header *) 3194 IF Read(3CH,ADR(hpos),SIZE(hpos)) OR Read(hpos,ADR(hdr),SIZE(hdr)) OR (hdr.magic1 # 'N') THEN 3195 RETURN 0; 3196 END; (*IF*) 3197 REPEAT 3198 INC(module^.stage); 3199 CASE module^.stage OF 3200 internal_stage (* verify header, build basic tables, allocate module table *) 3201 :(* allocate module table *) 3202 module^.module_table := New(hdr.lib_count * 2); 3203 (* build segment table *) 3204 module^.seg_count := hdr.seg_count; 3205 module^.log_sector_size := hdr.log_sector_size; 3206 module^.seg_info := New(hdr.seg_count * SIZE(SegRec)); 3207 Seek2(hpos + LONGCARD(hdr.seg_off)); 3208 buf_index := SIZE(buffer); 3209 FOR i := 1 TO hdr.seg_count DO 3210 WITH module^.seg_info^[i] DO 3211 Read2(ADR(sector),8); 3212 no_op := 90H; 3213 jump_op := 0E9H; 3214 jump_disp := CARDINAL(HeapAdr(LoaderA.GateHandler)) - CARDINAL(HeapAdr(jump_disp)) - 2; 3215 END; (*WITH*) 3216 END; (*FOR*) 3217 (* build entry table *) 3218 IF EntryTableTrace THEN 3219 string('entry table for '); 3220 string(module^.name^); 3221 eol; 3222 END; (*IF*) 3223 FOR SecondPass := FALSE TO TRUE DO 3224 Seek2(hpos + LONGCARD(hdr.entry_table_off)); 3225 ord := 0; 3226 done := 0; 3227 WHILE done < hdr.entry_table_size DO 3228 Read2(ADR(bundle),2); 3229 INC(done,2); 3230 FOR i := 1 TO CARDINAL(bundle.ne) DO 3231 INC(ord); 3232 IF bundle.si = 255 THEN 3233 Read2(ADR(fs6),SIZE(fs6)); 3234 INC(done,SIZE(fs6)); 3235 eseg := fs6.seg; 3236 eoff := fs6.off; 3237 ELSE 3238 Read2(ADR(fs), SIZE(fs)); 3239 INC(done, SIZE(fs)); 3240 eseg := bundle.si; 3241 eoff := fs.off; 3242 END; (*IF*) 3243 IF SecondPass THEN 3244 module^.entry_table^[ord].seg := eseg; 3245 module^.entry_table^[ord].ofs := eoff; 3246 IF EntryTableTrace THEN 3247 dec(ord); 3248 char('='); 3249 dec(CARDINAL(module^.entry_table^[ord].seg)); 3250 char(':'); 3251 hex(CARDINAL(module^.entry_table^[ord].ofs)); 3252 eol; 3253 END; (*IF*) 3254 END; (*IF*) 3255 END; (*FOR*) 3256 END; (*WHILE*) 3257 IF ~SecondPass THEN 3258 module^.entry_table := New(ord * SIZE(EntryRec)); 3259 END; (*IF*) 3260 END; (*FOR*) | 3261 sub_module_stage (* fill in module table, initialise sub-modules up to stage 2 *) 3262 : FOR i := 1 TO hdr.lib_count DO 3263 len := 0; 3264 IF Read(hpos+LONGCARD(hdr.module_ref_off+(i-1)*2),ADR(impnameoff),SIZE(impnameoff)) OR Read(hpos+LONGCARD(hdr.imp_name_off+impnameoff),ADR(len),1) THEN 3265 RETURN 0; 3266 END; (*IF*) 3267 Read2(ADR(libname),len); 3268 libname[len] := 0C; 3269 submod := InternalLoadModule(libname,FALSE,sub_module_stage); 3270 IF submod = 0 THEN 3271 RETURN 0; 3272 END;(*IF*) 3273 module^.module_table^[i] := SHORTCARD(submod); 3274 END; (*FOR*) | 3275 execute_stage (* execute sub-module entry points *) 3276 : 3277 FOR i := 1 TO hdr.lib_count DO 3278 submod := CARDINAL(module^.module_table^[i]); 3279 IF InternalLoadModule(g.module_list[submod]^.name^,FALSE,execute_stage) = 0 THEN 3280 RETURN 0; 3281 END; (*IF*) 3282 END; (*FOR*) 3283 (*%T VidSupport*) 3284 TellVid(modnum,0,VID_LOAD_MODULE); 3285 (*%E*) 3286 (* execute entry-point *) 3287 cs := DoSeg(modnum,hdr.cs,Load); 3288 (* UnLock(cs); -- only if not packed *) 3289 IF is_exe THEN 3290 pss := DoSeg(modnum,hdr.ss,Load); 3291 WITH [g.stk-1:0 T]^ DO 3292 INC([Prev:0 T]^.Size,800H); 3293 [g.stk-1+Size:0 T]^.Prev := Prev; 3294 INC(g.freemem,800H); 3295 END; (*WITH*) 3296 Exec(g.psp,pss,hdr.sp,cs,hdr.ip); 3297 ELSE 3298 p := InitProc([cs:hdr.ip]); 3299 dummy := p(); 3300 END; (*IF*) 3301 END; (*CASE*) 3302 UNTIL module^.stage = stage; 3303 END; (*IF*) 3304 RETURN modnum; 3305 END InternalLoadModule; 3306 3307 PROCEDURE LoadModule (name:ARRAY OF CHAR):CARDINAL; 3308 VAR 3309 modnum:CARDINAL; 3310 BEGIN 3311 IF (g.delay=0) OR Compare(g.module_list[g.delay]^.name^, name) THEN 3312 g.delay := 0; 3313 ELSE 3314 DoDelay; 3315 END; 3316 modnum := InternalLoadModule(name,FALSE,execute_stage); 3317 IF modnum = 0 THEN 3318 modnum := MAX(CARDINAL); (* external convention *) 3319 END; 3320 RETURN modnum; 3321 END LoadModule; 3322 3323 PROCEDURE GetProcAddr (modnum:CARDINAL;entry: ARRAY OF CHAR):ADDRESS; 3324 VAR s : SHORTCARD; 3325 str : ARRAY [0..255] OF CHAR; 3326 ord : CARDINAL; 3327 a :FarADDRESS; 3328 Nonres : BOOLEAN; 3329 module : Module; 3330 hpos : LONGCARD; 3331 hdr : ExeHeader; 3332 i : CARDINAL; 3333 BEGIN 3334 module := g.module_list[modnum]; 3335 IF ModuleRead(module,3CH,ADR(hpos),SIZE(hpos))OR 3336 ModuleRead(module,hpos,ADR(hdr),SIZE(hdr)) THEN 3337 RETURN FarNIL; 3338 END; 3339 FileSeek(module^.file,hpos+LONGCARD(hdr.res_name_off)); 3340 ord := 0; 3341 Nonres := FALSE; 3342 LOOP 3343 FileRead(ADR(s),1,module^.file); 3344 IF s=0 THEN 3345 IF Nonres THEN 3346 EXIT; 3347 ELSE 3348 Nonres := TRUE; 3349 FileSeek(module^.file,hdr.non_res_name_off); 3350 END; 3351 ELSE 3352 FileRead(ADR(str),CARDINAL(s),module^.file); 3353 str[CARDINAL(s)]:= 0C; 3354 FileRead(ADR(ord),2,module^.file); 3355 i := 0; 3356 WHILE (str[i]=entry[i]) DO 3357 INC(i); 3358 IF (i=CARDINAL(s)) THEN 3359 IF (entry[i]=0C) THEN EXIT END; 3360 str[i] := 0C; 3361 END; 3362 END; 3363 END; 3364 END; 3365 IF ord=0 THEN RETURN FarNIL END; 3366 RETURN GetOrdProcAddr(modnum,ord); 3367 END GetProcAddr; 3368 3369 PROCEDURE FlushAll; 3370 BEGIN 3371 DoDelay; 3372 DoFlushAll; 3373 END FlushAll; 3374 3375 3376 PROCEDURE Terminate; 3377 BEGIN 3378 (*%T ExitTrace*) 3379 eol; 3380 IF TraceToFile THEN 3381 FlushAll; 3382 DumpMemory; 3383 eol; 3384 END; (*IF*) 3385 MemStat; 3386 string('Gate count = '); 3387 dec(g.gate_count); 3388 eol; 3389 string('Module count = '); 3390 dec(g.module_count); 3391 eol; 3392 (*%T EMS*) 3393 string('Ems pages = '); 3394 dec(g.ems_count); 3395 eol; 3396 (*%E*) 3397 string('Heap used = '); 3398 hex(g.near_alloc-CARDINAL(Ofs(g.heap))); 3399 char('H'); 3400 eol; 3401 string('Temp file = '); 3402 hex(g.temp_max*(TempPageSize DIV 256)); 3403 string('00H'); 3404 eol; 3405 (*%E*) 3406 3407 FileClose(g.temp_file); 3408 FileDelete(FullTempFileName); 3409 (*%T EMS*) 3410 IF g.ems_data_handle # 0 THEN 3411 EmsMap(4500H,0,g.ems_data_handle); (* free pages *) 3412 END; (*IF*) 3413 IF g.ems_temp_handle # 0 THEN 3414 EmsMap(4500H,0,g.ems_temp_handle); (* free temp pages *) 3415 END; (*IF*) 3416 (*%E*) 3417 END Terminate; 3418 3419 PROCEDURE AllocMem(size:CARDINAL):FarADDRESS; 3420 BEGIN 3421 IF size = 0 THEN 3422 RETURN FarNIL; 3423 END; (*IF*) 3424 IF size<=TinyMaxSize THEN 3425 RETURN TinyAlloc(size); 3426 END; 3427 RETURN [AllocFixed(Para(size)):0]; 3428 END AllocMem; 3429 3430 PROCEDURE FreeMem(ofs,seg:CARDINAL); 3431 BEGIN 3432 IF NOT TinyFree([seg:ofs]) THEN 3433 Free(seg); 3434 END; 3435 END FreeMem; 3436 3437 PROCEDURE ClearAllocMem(num,size:CARDINAL):FarADDRESS; 3438 VAR 3439 res : FarADDRESS; 3440 BEGIN 3441 size := num * size; 3442 IF size = 0 THEN 3443 RETURN FarNIL; 3444 END; (*IF*) 3445 IF size<=TinyMaxSize THEN 3446 res := TinyAlloc(size); 3447 ELSE 3448 res := [AllocFixed(Para(size)):0]; 3449 END; 3450 IF res<>FarNIL THEN 3451 Fill(res,size,0); 3452 END; 3453 RETURN res; 3454 END ClearAllocMem; 3455 3456 PROCEDURE HugeAllocMem(size:LONGCARD):FarADDRESS; 3457 BEGIN 3458 RETURN [AllocFixed(CARDINAL((size+15) DIV 16)):0]; 3459 END HugeAllocMem; 3460 3461 PROCEDURE ExpandMem(Buffer:FarADDRESS;newsize:CARDINAL):FarADDRESS; 3462 VAR 3463 seg,next : CARDINAL; 3464 BEGIN 3465 seg := Seg(Buffer^) - H; 3466 newsize := Para(newsize) + H; 3467 LOOP 3468 WITH [seg:0 T]^ DO 3469 IF Size >= newsize THEN 3470 INC(g.freemem,Used); 3471 DEC(g.freemem,newsize); 3472 Used := newsize; 3473 RETURN Buffer; 3474 ELSE 3475 next := seg + Size; 3476 IF [next:0 T]^.Used = 0 THEN 3477 INC(Size,[next:0 T]^.Size); 3478 next := seg + Size; 3479 [next:0 T]^.Prev := seg; 3480 ELSE 3481 RETURN FarNIL; 3482 END; (*IF*) 3483 END; (*IF*) 3484 END; (*WITH*) 3485 END; (*LOOP*) 3486 END ExpandMem; 3487 3488 PROCEDURE HugeExpandMem(Buffer:FarADDRESS;newsize:LONGCARD):FarADDRESS; 3489 VAR 3490 seg,next,NewCard : CARDINAL; 3491 BEGIN 3492 seg := Seg(Buffer^) - H; 3493 NewCard := CARDINAL((newsize + 15) DIV 16) + H; 3494 LOOP 3495 WITH [seg:0 T]^ DO 3496 IF Size >= NewCard THEN 3497 INC(g.freemem,Used); 3498 DEC(g.freemem,NewCard); 3499 Used := NewCard; 3500 RETURN Buffer; 3501 ELSE 3502 next := seg + Size; 3503 IF [next:0 T]^.Used = 0 THEN 3504 INC(Size,[next:0 T]^.Size); 3505 next := seg + Size; 3506 [next:0 T]^.Prev := seg; 3507 ELSE 3508 RETURN FarNIL; 3509 END; (*IF*) 3510 END; (*IF*) 3511 END; (*WITH*) 3512 END; (*LOOP*) 3513 END HugeExpandMem; 3514 3515 PROCEDURE InvalidProc; 3516 BEGIN 3517 abort(ErrInvalidProcedure); 3518 END InvalidProc; 3519 3520 3521 CONST 3522 HEAPOK = 0; 3523 HEAPEMPTY = -1; 3524 HEAPBADBEGIN = -2; 3525 HEAPBADNODE = -3; 3526 HEAPOVERFLOW = -4; 3527 HEAPEND = -5; 3528 HEAPBADPTR = -6; 3529 3530 PROCEDURE HeapCheck(Val:CARDINAL;DoFill:BOOLEAN):INTEGER; 3531 VAR 3532 TSeg : CARDINAL; 3533 BEGIN 3534 TSeg := g.start; 3535 REPEAT 3536 WITH [TSeg:0 T]^ DO 3537 IF Size = 0 THEN 3538 RETURN HEAPBADNODE; 3539 END; (*IF*) 3540 IF DoFill & (Used < Size) THEN 3541 Fill([TSeg+Used:0],(Size-Used)*16,Val); 3542 END; (*IF*) 3543 INC(TSeg,Size); 3544 END; (*WITH*) 3545 UNTIL TSeg = g.start; 3546 RETURN HEAPOK; 3547 END HeapCheck; 3548 3549 PROCEDURE HeapWalk(VAR Entry:HeapInfo):INTEGER; 3550 BEGIN 3551 WITH Entry DO 3552 IF pentry = FarNIL THEN 3553 pentry := [g.start:0]; 3554 ELSE 3555 pentry := [Seg(pentry^) + T(pentry)^.Size:0]; 3556 END; (*IF*) 3557 WITH T(pentry)^ DO 3558 IF Seg(pentry^) = g.start THEN 3559 RETURN HEAPEND; 3560 END; (*IF*) 3561 IF Size = 0 THEN 3562 RETURN HEAPBADNODE; 3563 ELSE 3564 size := Size * 16; 3565 END; (*IF*) 3566 useflag := Used > 0; 3567 END; (*WITH*) 3568 END; (*WITH*) 3569 RETURN HEAPOK; 3570 END HeapWalk; 3571 3572 (*# save,call(reg_param=>(bx,ax),reg_saved=>(cx,dx,di,si,ds,st1,st2),inline=>on)*) 3573 PROCEDURE DOSAllocMem(Para:CARDINAL):CARDINAL = A4(0B4H,048H,0CDH,021H); 3574 PROCEDURE DOSResizeMem(Para,Seg:CARDINAL) = A6(08EH,0C0H,0B4H,04AH,0CDH,021H); 3575 PROCEDURE DOSFreeMem(Para:CARDINAL) = A6(08EH,0C3H,0B4H,049H,0CDH,021H); 3576 (*# call(reg_return=>(bx))*) 3577 PROCEDURE DOSMemAvail():CARDINAL = A7(0B4H,048H,0BBH,0FFH,0FFH,0CDH,021H); 3578 (*# restore *) 3579 3580 VAR 3581 AvailMem,AvailSeg : CARDINAL; 3582 HighMem,HighSeg : CARDINAL; 3583 3584 PROCEDURE ShrinkHeap():CARDINAL; 3585 BEGIN 3586 FlushAll; 3587 AvailMem := Avail(); 3588 IF AvailMem>800H THEN DEC(AvailMem,800H); END; (* needed to reload caller *) 3589 AvailSeg := AllocFixed(AvailMem); 3590 DOSResizeMem((AvailSeg + AvailMem) - g.psp - 1,g.psp); 3591 HighMem := DOSMemAvail(); 3592 HighSeg := DOSAllocMem(HighMem); 3593 DOSResizeMem(AvailSeg - g.psp,g.psp); 3594 RETURN 0; 3595 END ShrinkHeap; 3596 3597 PROCEDURE GrowHeap; 3598 BEGIN 3599 DOSFreeMem(HighSeg); 3600 DOSResizeMem((AvailSeg + AvailMem + HighMem) - g.psp,g.psp); 3601 Free(AvailSeg); 3602 END GrowHeap; 3603 3604 PROCEDURE UserFlush; 3605 BEGIN 3606 FlushAll; 3607 END UserFlush; 3608 3609 PROCEDURE SetExitHandler(p:ExitHandler); 3610 BEGIN 3611 g.abort := p; 3612 reserve_panic; 3613 END SetExitHandler; 3614 3615 PROCEDURE SetMemHandler(p:MemHandler); 3616 BEGIN 3617 g.OutOfMem := p; 3618 END SetMemHandler; 3619 3620 PROCEDURE LoadSeg(segno:CARDINAL;ModName:ARRAY OF CHAR):SegReturn; 3621 VAR 3622 modno : CARDINAL; 3623 BEGIN 3624 modno := 1; 3625 IF ModName[0] # 0C THEN 3626 LOOP 3627 IF Compare(g.module_list[modno]^.name^,ModName) THEN 3628 EXIT; 3629 END; (*IF*) 3630 INC(modno); 3631 IF modno > g.module_count THEN 3632 RETURN INVALID_MOD; 3633 END; (*IF*) 3634 END; (*LOOP*) 3635 END; (*IF*) 3636 WITH g.module_list[modno]^ DO 3637 IF segno > seg_count THEN 3638 RETURN INVALID_SEG; 3639 ELSIF seg_info^[segno].direct_list # GatePtr(0) THEN 3640 RETURN RESIDENT; 3641 ELSIF DoSeg(modno,segno,Load) # 0 THEN 3642 RETURN SUCCESS; 3643 ELSE 3644 RETURN FAIL; 3645 END; (*IF*) 3646 END; (*WITH*) 3647 END LoadSeg; 3648 3649 PROCEDURE UnloadSeg(segno:CARDINAL;ModName:ARRAY OF CHAR):SegReturn; 3650 VAR 3651 modno : CARDINAL; 3652 BEGIN 3653 modno := 1; 3654 IF ModName[0] # 0C THEN 3655 LOOP 3656 IF Compare(g.module_list[modno]^.name^,ModName) THEN 3657 EXIT; 3658 END; (*IF*) 3659 INC(modno); 3660 IF modno > g.module_count THEN 3661 RETURN INVALID_MOD; 3662 END; (*IF*) 3663 END; (*LOOP*) 3664 END; (*IF*) 3665 WITH g.module_list[modno]^ DO 3666 IF segno > seg_count THEN 3667 RETURN INVALID_SEG; 3668 ELSIF seg_info^[segno].direct_list = GatePtr(0) THEN 3669 RETURN UNLOADED; 3670 ELSIF DoSeg(modno,segno,Swap) = 0 THEN 3671 RETURN SUCCESS; 3672 ELSE 3673 RETURN FAIL; 3674 END; (*IF*) 3675 END; (*WITH*) 3676 END UnloadSeg; 3677 3678 PROCEDURE Getseg(seg:CARDINAL):CARDINAL; 3679 VAR 3680 i,j : CARDINAL; 3681 BEGIN 3682 FOR i := 1 TO g.module_count DO 3683 WITH g.module_list[i]^ DO 3684 FOR j := 1 TO seg_count DO 3685 WITH seg_info^[j] DO 3686 IF seg_val = seg THEN 3687 RETURN j; 3688 END; (*IF*) 3689 END; (*WITH*) 3690 END; (*FOR*) 3691 END; (*WITH*) 3692 END; (*FOR*) 3693 RETURN 0; 3694 END Getseg; 3695 3696 3697 (*# save, call(same_ds=>off) *) 3698 PROCEDURE default_abort(name:ARRAY OF CHAR;errno:CARDINAL); 3699 (*# restore *) 3700 BEGIN 3701 eol; 3702 (*%T CHECK*) 3703 string('Loader fatal error : '); 3704 dec(errno); 3705 string(', '); 3706 (*%E*) 3707 CASE errno-ErrBase OF (* only startup errors should be possible *) 3708 ErrTempCreate : string('Failed to create '); 3709 string(FullTempFileName); | 3710 ErrLoad : string('DLL load failed. Is your PATH set correctly?');| 3711 (* happens when ts.exe in local directory but path not set up *) 3712 ErrOutOfMem: string('Out of memory');| 3713 ErrTempDiskFull: string('Disk full on swap file');| 3714 (*%T CHECK*) 3715 ErrTempFileLimit : string('ErrTempFileLimit'); | 3716 ErrPoolLimit : string('ErrPoolLimit'); | 3717 ErrGateLimit : string('ErrGateLimit'); | 3718 ErrDiskFull : string('ErrDiskFull'); | 3719 ErrInternal : string('ErrInternal'); | 3720 ErrNearHeap : string('ErrNearHeap'); | 3721 ErrModuleLimit : string('ErrModuleLimit'); | 3722 ErrInvalidProcedure : string('ErrInvalidProcedure'); | 3723 ErrMemoryCorruption : string('ErrMemoryCorruption'); | 3724 ErrTooManyUnlocks : string('ErrTooManyUnlocks'); | 3725 ErrCallChainInvalid : string('ErrCallChainInvalid'); | 3726 ErrOpenFail : string('ErrOpenFail'); | 3727 ErrNamedImport : string('ErrNamedImport'); | 3728 ErrInvalidVUnfix : string('ErrInvalidVUnfix'); | 3729 ErrInvalidVFix : string('ErrInvalidVFix'); | 3730 ErrInvalidFree : string('ErrInvalidFree'); | 3731 END; 3732 (*%E*) 3733 (*%F CHECK*) 3734 ELSE 3735 string('Overlay loader fatal error : '); 3736 dec(errno); 3737 END; (*CASE*) 3738 (*%E*) 3739 eol; 3740 END default_abort; 3741 3742 (*# save, call(same_ds=>off) *) 3743 PROCEDURE default_MemHandler(Size:CARDINAL):BOOLEAN; 3744 (*# restore *) 3745 BEGIN 3746 RETURN FALSE; 3747 END default_MemHandler; 3748 3749 PROCEDURE Init(psp:CARDINAL); FORWARD; 3750 3751 (* Note this proc is overwritten by memory initialisation !! *) 3752 PROCEDURE GetFullTempFileName(s:ARRAY OF CHAR); 3753 VAR 3754 drive : SHORTCARD; 3755 p : ARRAY SHORTCARD OF CHAR; 3756 BEGIN 3757 drive := GetCurDrive(); 3758 GetCurDir(0,p); 3759 s[0] := CHR(drive + ORD('A')); 3760 IF p[0] = 0C THEN 3761 s[2] := 0C; 3762 ELSE 3763 s[3] := 0C; 3764 Append(s,p); 3765 END; (*IF*) 3766 Append(s,TempFileName); 3767 END GetFullTempFileName; 3768 3769 PROCEDURE MakeSys(seg:CARDINAL); 3770 VAR next,prev:CARDINAL; 3771 BEGIN 3772 (* links seg into memory list, initialises it to be a free seg *) 3773 next := g.start; 3774 LOOP 3775 prev := [next:0 T]^.Prev; 3776 IF seg <= g.start THEN 3777 g.start := seg; 3778 EXIT; 3779 END; 3780 IF prev <= seg THEN 3781 EXIT; 3782 END; 3783 next := prev; 3784 END; 3785 WITH [next:0 T]^ DO 3786 Prev := seg; 3787 END; 3788 WITH [prev:0 T]^ DO 3789 Size := seg-prev; 3790 Used := seg-prev; 3791 END; 3792 WITH [seg:0 T]^ DO 3793 Size := next - seg; 3794 Used := next - seg; 3795 Prev := prev; 3796 Active := FALSE; 3797 Kind := SystemSeg; 3798 Id1 := 0; 3799 Id2 := 0; 3800 Lock := 1; 3801 END; 3802 END MakeSys; 3803 3804 PROCEDURE Init(psp:CARDINAL); 3805 VAR 3806 m : CARDINAL; 3807 code : CARDINAL; 3808 cp : POINTER TO ARRAY [0..255] OF CHAR; 3809 i : CARDINAL; 3810 drive : SHORTCARD; 3811 LABEL 3812 NoEms; 3813 BEGIN 3814 Fill(ADR(g),SIZE(g),0); 3815 TinyInit; 3816 (*%T TraceToFile*) 3817 output_file := FileCreate('otrace.txt'); 3818 (*%E*) 3819 (*%T VidSupport*) 3820 FindVid; 3821 (*%E*) 3822 (*%T GraphUseTrace*) 3823 Fill(ADR(graphsegs),SIZE(graphsegs),0); 3824 (*%E*) 3825 3826 g.abort := default_abort; 3827 g.OutOfMem := default_MemHandler; 3828 g.near_alloc := CARDINAL(Ofs(g.heap)); 3829 GetFullTempFileName(FullTempFileName); 3830 (*#save,data(const_assign=>on)*) 3831 g.temp_file := FileCreateNew(FullTempFileName); 3832 (*#restore*) 3833 IF g.temp_file = MAX(CARDINAL) THEN 3834 abort(ErrTempCreate); 3835 RETURN; 3836 END; (*IF*) 3837 g.psp := psp; 3838 code := Seg(Main) - H; 3839 g.stk := Seg(psp) + 2; 3840 g.end := CARDINAL([g.psp:2]^) - H; 3841 g.start := code - 1; 3842 [g.start:0 T]^.Prev := g.start; 3843 MakeSys(code-1); 3844 MakeSys(code); 3845 MakeSys(g.stk-1); 3846 MakeSys(g.end); 3847 WITH [g.stk-1:0 T]^ DO 3848 Used := 0800H; 3849 INC(g.freemem,Size-Used); 3850 END; (*WITH*) 3851 [g.stk:0]^ := 0; 3852 WITH loader_module.seg_info^[1] DO 3853 membyte := Ofs(Init); 3854 jump_disp := CARDINAL(HeapAdr(LoaderA.GateHandler)) - CARDINAL(HeapAdr(jump_disp)) - 2; 3855 seg_val := code + H; 3856 END; (*WITH*) 3857 WITH [code:0 T]^ DO (* will overwrite program entry ! *) 3858 Kind := StaticSeg; 3859 Id1 := 1; 3860 Id2 := 1; 3861 END; (*WITH*) 3862 g.module_count := 1; 3863 g.module_list[1] := Module(HeapAdr(loader_module)); 3864 (*%T CHECK*) 3865 CheckMem; 3866 (*%E*) 3867 reserve_panic; 3868 (* get ems frame *) 3869 g.ems_frame := 0E000H; (* dummy value when no ems *) 3870 (*%T EMS*) 3871 cp := [[0:19CH+2]^:0AH]; 3872 FOR i := 0 TO 7 DO 3873 IF cp^[i] # EmsName[i] THEN 3874 GOTO NoEms; 3875 END; (*IF*) 3876 END; (*FOR*) 3877 IF EmsTest(4000H) = 0 THEN 3878 g.ems_frame := EmsGet(4100H); (* get frame *) 3879 g.ems_present := TRUE; 3880 END; (*IF*) 3881 (*%E*) 3882 NoEms: 3883 m := InternalLoadModule(MainName,TRUE,execute_stage); 3884 (* returns only if error *) 3885 abort(ErrLoad); 3886 END Init; 3887 3888 PROCEDURE Main(psp:CARDINAL); 3889 BEGIN 3890 Init(psp); 3891 END Main; 3892 3893 END Loader. 3894 6 errors