Topspeed_JPI/TS-V3/SRC/LOADER.LST

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 j<HIGH(graphsegs) THEN INC(j); END;
  470    FOR i := 1 TO j DO
  471      s := graphsegs[i].seg;
  472      IF (s=0)OR((s=seg)AND(mode=GTadd)) THEN
  473        IF mode=GTadd THEN
  474          graphsegs[i].seg := seg;
  475          graphsegs[i].pos := pos;
  476          graphsegs[i].lasttick := [pos-1:0 T]^.Tick;
  477          c := '¸';
  478          mode := GTlru;
  479        ELSE
  480          c := ' ';
  481        END;
  482      ELSIF (s=seg)AND(mode=GTdel) THEN
  483        c := '¾';
  484        graphsegs[i].pos := 0;
  485      ELSE
  486        IF graphsegs[i].pos=0 THEN
  487          c := ' ';
  488        ELSE
  489          segm := SegPtr(HeapAdr(g.module_list[s DIV 256]^.seg_info^[s MOD 256]))^.seg_val;
  490          IF graphsegs[i].pos<>segm 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+2 THEN RETURN 0 END;
  931    RETURN max-Hide-2;
  932  END Avail;
  933  
  934  PROCEDURE MemPic;
  935  VAR
  936    tmp:CARDINAL;
  937    used:CARDINAL;
  938    lock:BOOLEAN;
  939  BEGIN
  940    string('MemPic=');
  941    tmp := g.start;
  942    used := 0;
  943    lock := FALSE;
  944    REPEAT
  945      WITH [tmp:0 T]^ DO
  946        IF Lock # 0 THEN
  947          lock := TRUE;
  948        END;
  949        INC(used, Used);
  950        IF Size > Used THEN
  951          IF lock THEN
  952            char('+');
  953          ELSE
  954            char('.');
  955          END;
  956          dec(used);
  957          char('_');
  958          dec(Size-Used);
  959          used := 0;
  960          lock := FALSE;
  961        END;
  962        tmp := tmp + Size;
  963      END;
  964    UNTIL tmp = g.start;
  965    eol;
  966  END MemPic;
  967  
  968  PROCEDURE MemStat;
  969  VAR
  970    kind              : SegKind;
  971    ucount,tcount,
  972    usize,tsize       : ARRAY SegKind OF CARDINAL;
  973    dummy             : CARDINAL;
  974    tmp               : CARDINAL;
  975  
  976    TDummy            : T;
  977  BEGIN
  978    FOR kind := MIN(SegKind) TO MAX(SegKind) DO
  979      tcount[kind] := 0;
  980      ucount[kind] := 0;
  981      tsize[kind] := 0;
  982      usize[kind] := 0;
  983    END; (*FOR*)
  984    tmp := g.start;
  985    REPEAT
  986      WITH [tmp:0 T]^ DO
  987  TDummy := [tmp:0 T];
  988        INC(tsize[Kind],Used);
  989        INC(tcount[Kind]);
  990        IF Lock=0 THEN
  991          INC(usize[Kind],Used);
  992          INC(ucount[Kind]);
  993        END; (*IF*)
  994        INC(tmp,Size);
  995      END; (*WITH*)
  996    UNTIL tmp = g.start;
  997    dec(g.freemem);
  998    char('/');
  999    dec(MaxPoss(0FFFFH,dummy,dummy));
 1000    FOR kind := MIN(SegKind) TO FixedSeg DO
 1001      char(' ');
 1002      IF (usize[kind] # 0) & (usize[kind] # tsize[kind]) THEN
 1003        dec(tcount[kind]-ucount[kind]);
 1004        char(':');
 1005        dec(tsize[kind]-usize[kind]);
 1006        char('/');
 1007        dec(ucount[kind]);
 1008        char(':');
 1009        dec(usize[kind]);
 1010      ELSE
 1011        dec(tcount[kind]);
 1012        char(':');
 1013        dec(tsize[kind]);
 1014      END; (*IF*)
 1015    END; (*FOR*)
 1016  (*%T MoveTrace *)
 1017    string(' M=');
 1018    dec(CARDINAL(g.move_total DIV 400H));
 1019    char('k');
 1020  (*%E*)
 1021    eol;
 1022    MemPic;
 1023  END MemStat;
 1024  
 1025  PROCEDURE DumpMemory;
 1026  VAR tmp:CARDINAL;
 1027  BEGIN
 1028    string('Memory dump'); eol;
 1029    tmp := g.start;
 1030    REPEAT
 1031      WITH [tmp:0 T]^ DO
 1032        DumpSeg('dump ', tmp+H);
 1033        tmp := tmp + Size;
 1034      END;
 1035    UNTIL tmp = g.start;
 1036    MemStat;
 1037  (*%T TraceToFile*)
 1038    FileClose(output_file);
 1039    output_file := 1;
 1040  (*%E*)
 1041  END DumpMemory;
 1042  
 1043  PROCEDURE TotalAvail():CARDINAL;
 1044  VAR
 1045    res,p             : CARDINAL;
 1046  BEGIN
 1047  (*%T CHECK*)
 1048    IF g.freemem # CalcFreeMem() THEN
 1049      abort(ErrInternal);
 1050    END; (*IF*)
 1051  (*%E*)
 1052    res := g.freemem;
 1053    IF res > 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               (fseg<g.ems_frame) OR
 1844               (fseg>g.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 fi<seghdr^.fix_count DO
 2754        INC(fi);
 2755        fix := fixbuf^[fi];
 2756        chain := ~(2 IN set(fix.flags));
 2757        fix.flags := fix.flags MOD 4;
 2758        IF fix.flags = 0 THEN   (* internal fixup *)
 2759          target_modnum := modnum;
 2760          target_module := module;
 2761          IF fix.target_seg = 0FFH THEN
 2762            GOTO ordinal;
 2763          END; (*IF*)
 2764        ELSIF fix.flags = 1 THEN (* ordinal import *)
 2765          target_modnum := ModNum(module^.module_table^[fix.target_mod]);
 2766          target_module := g.module_list[target_modnum];
 2767  ordinal:
 2768          fix.target_seg := CARDINAL(target_module^.entry_table^[fix.target_ent].seg);
 2769          fix.target_off := target_module^.entry_table^[fix.target_ent].ofs;
 2770        ELSE
 2771  (*%T CHECK*)
 2772          abort(ErrNamedImport);   (* named import not supported *)
 2773  (*%E*)
 2774        END; (*IF*)
 2775        target_seghdr := GetSeg(target_module, fix.target_seg);
 2776        target_attr := target_seghdr^.flags;
 2777        IF op = Load THEN
 2778          loc := LocPtr(fix.off);
 2779          IF ~chain THEN
 2780            INC(fix.target_off,loc^.lo);
 2781          END; (*IF*)
 2782          IF (fix.lockind = FixPtr) & (target_attr * SegSet{IsData,IsPreLoad} = SegSet{}) THEN
 2783            fix.target_off := Gate(fix.target_off,target_seghdr,TRUE);
 2784            target_segment := Seg(g);
 2785          ELSE
 2786            target_segment := target_seghdr^.seg_val;
 2787            IF ~is_mem(target_segment) THEN
 2788              target_segment := DoSeg(target_modnum,fix.target_seg,Load);
 2789            ELSIF (~(IsPreLoad IN target_seghdr^.flags)) & ~(DataActive IN seghdr^.flags) THEN
 2790              Lock(target_segment);
 2791            END; (*IF*)
 2792          END; (*IF*)
 2793          IF fix.lockind = FixOfs THEN
 2794            IF chain THEN
 2795              REPEAT
 2796                next := LocPtr(loc^.lo);
 2797                loc^.lo := fix.target_off;
 2798                loc := next;
 2799              UNTIL loc = LocPtr(0FFFFH);
 2800            ELSE
 2801              loc^.lo := fix.target_off;
 2802            END; (*IF*)
 2803          ELSIF fix.lockind = FixBase THEN
 2804            IF chain THEN
 2805              REPEAT
 2806                next := LocPtr(loc^.lo);
 2807                loc^.lo := target_segment;
 2808                loc := next;
 2809              UNTIL loc = LocPtr(0FFFFH);
 2810            ELSE
 2811              loc^.lo := target_segment;
 2812            END; (*IF*)
 2813          ELSE
 2814            IF chain THEN
 2815              REPEAT
 2816                next := LocPtr(loc^.lo);
 2817                loc^.lo := fix.target_off;
 2818                loc^.hi := target_segment;
 2819                loc := next;
 2820              UNTIL loc = LocPtr(0FFFFH);
 2821            ELSE
 2822              loc^.lo := fix.target_off;
 2823              loc^.hi := target_segment;
 2824            END; (*IF*)
 2825          END; (*IF*)
 2826        ELSE (* unloading *)
 2827          IF (fix.lockind = FixPtr) & (target_attr * SegSet{IsData,IsPreLoad} = SegSet{}) THEN
 2828            (* do nothing *)
 2829          ELSIF IsPreLoad IN target_attr THEN
 2830            (* do nothing *)
 2831          ELSE
 2832            target_segment := target_seghdr^.seg_val;
 2833            IF is_mem(target_segment) THEN
 2834              UnLock(target_segment);
 2835            END; (*IF*)
 2836          END; (*IF*)
 2837        END; (*IF*)
 2838      END; (*WHILE*)
 2839      EXCL(seghdr^.flags,DataActive);
 2840    END; (*IF*)
 2841  (*%T VidSupport*)
 2842    IF op = Load THEN
 2843      TellVid(modnum,segnum,VID_LOAD_SEG);
 2844    END; (*IF*)
 2845  (*%E*)
 2846    IF op = Load THEN
 2847      RETURN segment;
 2848    ELSE
 2849      Free(segment);
 2850      RETURN 0;
 2851    END; (*IF*)
 2852  END DoSeg;
 2853  
 2854  
 2855  (* Virtual Segments - dynamically allocated segments that can be unlocked *)
 2856  
 2857  PROCEDURE VAlloc(VAR addr : FarADDRESS; size : CARDINAL);
 2858  (* Allocates Virtual memory block of specified size (in bytes).
 2859     returns result in addr.
 2860     Block is initially fixed so VUnfix must be called before
 2861     it can be swapped out.
 2862     Address of addr is used as handle so only one variable must be used
 2863     to hold pointer.
 2864  *)
 2865  VAR ptr : POINTER TO ARRAY[0..1] OF CARDINAL;
 2866  BEGIN
 2867    ptr := ADR(addr);
 2868    AllocMove(ptr^[1],Para(size));
 2869    Lock(ptr^[1]);
 2870    ptr^[0] := 0;
 2871  END VAlloc;
 2872  
 2873  PROCEDURE VUnfix(VAR addr : FarADDRESS);
 2874  (*
 2875     Unfixes memory allowing it to be moved or swapped to EMS or disk if
 2876     memory runs low. The address should not be used to reference memory
 2877     when unfixed.
 2878  *)
 2879  VAR ptr : POINTER TO ARRAY[0..1] OF CARDINAL;
 2880  BEGIN
 2881    ptr := ADR(addr);
 2882  (*%T CHECK*)
 2883    IF (ptr^[0]<>0)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