head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.18.05;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.11.59.18;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.55.17;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.30.47;  author jwh;  state Exp;
branches ;
next     54.3;

54.3
date     91.08.21.10.36.46;  author jwh;  state Exp;
branches ;
next     54.2;

54.2
date     91.08.21.09.40.57;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.32.25;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.32.19;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.17.14;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.16.45;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.30.58;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.14.44;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.21.04;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.11.05.53;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.52.50;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.16.00.48;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.17.55;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.14.10.28;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.54.51;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.37.04;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.58.09;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.42.56;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.34.53;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.48.41;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.26.19;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.41.48;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.16.17.02;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.48.30;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.57.43;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.18.18.37;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.55.39;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.40.15;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.11.06.34;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.49.16;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.13.35.25;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.43.24;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.10.13.40;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.10.58.25;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.11.38.34;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.14.22.35;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.11.34.18;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.08.47.48;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.15.53.43;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.57.48;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.16.08.14;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.09.48.29;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.15.57.29;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.51.37;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.44.56;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.10.11.13;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.11.26.09;  author jws;  state Exp;
branches ;
next     9.2;

9.2
date     86.12.23.18.05.47;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.15.09.28;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.12.19.37;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.14.30.20;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.18.25.00;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.17.14.10;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.20.08.17;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.12.18.47;  author hal;  state Exp;
branches ;
next     2.3;

2.3
date     86.08.19.13.49.20;  author danm;  state Exp;
branches ;
next     2.2;

2.2
date     86.08.13.08.54.23;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.15.07.45;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.16.40.40;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@module loader;

import sysglobals, asm;

export

const  blocksize = fblksize;
       vnlength = 7;
       fnlength = 15;

type

  volname =  string[vnlength];
  filname =  string[fnlength];

  dirrange = 0..mmaxint;         {0..MAXlongDIR; }

  (* the following declaration serves for a "library directory" *)

  direntry = record
	      dfirstblk: shortint;           (*module starting block*)
	      dlastblk: shortint;            (*block following end*)
	  {NOTE:  for DIR[0], these refer to the library directory itself}
	      case dfkind: filekind of
	      untypedfile:                   (*library info in DIR[0]*)
		    (dvid: volname;          (*name of library*)
		     deovblk: shortint;      (*block following library*)
		     dnumfiles: dirrange;    (*num modules in library*)
		     dloadtime: shortint;    (*time of last modification*)
		     dlastboot: daterec );   (*most recent date setting*)
	      datafile..lastfkind:
		    (dtid: filname;          (*title of module*)
		     dlastbyte: 1..fblksize; (*1..256 bytes in last block*)
		     daccess: daterec )      (*last modification date*)
	     end (*direntry*) ;

     ubyterec =         packed record ub: byte end;
     sbyterec =         packed record sb: -128..127 end;
     word =             0..65535;
     wordrec =          packed record w: word end;
     wordrecptr =       ^wordrec;
     wordlist =         packed array[0..maxint] of word;
     wordlistptr =      ^wordlist;

     symboltable =      array[0..maxint] of char;
     symtableptr =      ^symboltable;

     symbol =           string[255];
     symbolptr =        ^symbol;

     datatype =         (sbyte, sword, sint, fltpt, ubyte, uword);
     reloctype =        (absolute, relocatable, global, general);


referenceptr = packed record    {one or more present if type = general}
  case integer of
  0:(
  adr:  0..16383;               {word address of external symbol}
  op:   (addit, subit);         {add or subtract the modifying value}
  last: boolean);               {indicates end of list}

  1:(w: word);                  {for comparisons}
end;

gvrptr          = ^generalvalue;
veptr           = ^valueextension;
textdescptr     = ^textdescriptor;
fileptr         = ^phyle;
moddescptr      = ^moduledescriptor;
refptrptr       = ^referenceptr;
sortlistptr     = ^sortlist;
moddirptr       = ^moduledirectory;
filedirptr      = ^filedirectory;
ptrtableptr     = ^ptrtable;
patchdescptr    = ^patchdescriptor;


addrec  =  record case integer of       {a universal address}
	-1:     (rp:    referenceptr);  {a two byte object; rest are 4 bytes:}

	1:      (i:     integer);       {to change an address to integer}
	2:      (a:     integer);       {to do address arithmetic}
	3:      (p:    ^integer);       {to dereference}

	4:      (sb:    ^sbyterec);     {^signed byte record}
	5:      (sw:    ^shortint);     {^signed word}
	6:      (si:    ^integer);      {^signed integer}
	7:      (fp:    ^real);         {^floating point}
	8:      (ub:    ^ubyterec);     {^unsigned byte record}
	9:      (uw:    wordrecptr);    {^unsigned word record}

	10:     (gvp:   gvrptr);        {^generalvalue}
	11:     (vep:   veptr);         {^valueextension}
	12:     (tdp:   textdescptr);   {^textdescriptor}
	13:     (syp:   symbolptr);     {^symbol  (string)  }
	14:     (stp:   symtableptr);   {^symboltable}
	15:     (wlp:   wordlistptr);   {^wordlist}
	16:     (php:   fileptr);       {^phyle}
	17:     (mdp:   moddescptr);    {^moduledescriptor}
	18:     (rpp:   refptrptr);     {^referenceptr}
	19:     (sdp:   ^sortdesc);
	20:     (slp:   sortlistptr);   {^sortlist}
	21:     (drp:   moddirptr);     {^moduledirectory}
	22:     (fdp:   filedirptr);    {^filedirectory}
	23:     (bmp:   ^bitmap);
	24:     (fbp:   fibp);
	25:     (ptp:   ptrtableptr);   {^ptrtable}
	26:     (ilp:   ^indexlist);
	27:     (pdp:   patchdescptr);
	28:     (cp:    ^char);
	29:     (arp:   ^addrec);
	end;

generalvalue = packed record
  primarytype: reloctype;       {allows quick indication of most common types}
  datasize:    datatype;        {specifies 1, 2, 4 or 8 bytes, signed or not}
  patchable,                    {specifies self relative field in branch}
  valueextend: boolean;         {indicates the presence of valueextension}
  case longoffset:  boolean of  {1 or 3 byte offset }
      false:    (short:          byte);               {unsigned 8 bits}
      true:     (long:           0..16777215);        {unsigned 24 bit value}
end;

valueextension = packed record {present if valueextend bit above is set}
  case datatype of
	   sbyte,sword,sint,
	   ubyte,uword:         (value:    integer);
	   fltpt:               (valuer:   real);
end;

phyle = file of char;


moduledirectory = packed record
     date:      daterec;        {date of creation}
     revision:  daterec;        {producer's revision date number}
     producer:  char;           {A = assembler, C = compiler, L = linker, etc.}
     systemid: byte;            {system version number (hard or soft, etc.}
     notice: string[80];        {space for whatever comments may be desired}
     directorysize: integer;    {size of module directory, in bytes}
     modulesize: integer;       {total size of module, in bytes}
     executable:       boolean;        {module is executable,
					has start address}
     relocatablesize: integer;         {number of relocatable bytes requested}
     relocatablebase: integer;         {current origin of relocatable code}
     globalsize:      integer;         {number of global bytes requested}
     globalbase:      integer;         {A5 relative origin of global area}

     extblock,                         {module relative block of EXT table}
     extsize,                          {size of EXT table, in bytes}
     defblock,                         {module relative block of DEF table}
     defsize,                          {size of DEF table, in bytes}
     sourceblock,                      {module relative block of DEFINE SOURCE}
     sourcesize,                       {size of source, in bytes}

     textrecords:     integer;         {number of TEXT records}

	       {Remainder of directory is made up of variable length
		records.  Strings begin and end on word (even byte)
		boundaries. The directory itself may cross block
		boundaries.  General value or address records
		(GVR's,  see description later)
		occuring below have the short variant offset; the
		offset itself is the length of the GVR to assist in
		stepping quickly through the list.}


      {mname: string[ (variable) ];      {name of module}
      {
      {startaddress:    gvr;             {execution address, present only
      {                                   if executable}
      {
      {repeat for each text record       {list of TEXT records}
      {   textstart,                     {module relative block of TEXT record}
      {   textsize,                      {size of TEXT record, in bytes}
      {   refstart,                      {module relative block of REF table}
      {   refsize:      integer;         {size of REF table, in bytes}
      {   loadaddress:  gvr;             {location to load the TEXT}
      {end                      }
end;

textdescriptor = record
	 textstart,                     {module relative block of TEXT record}
	 textsize,                      {size of TEXT record, in bytes}
	 refstart,                      {module relative block of REF table}
	 refsize:      integer;         {size of REF table, in bytes}
	end;

bitmap = packed array[0..maxint] of boolean;

patchdescriptor = record
   patchlist:   patchdescptr;           {head of list of patch descriptors}
   patchref:    addrec;
end;

moduledescriptor = record
  link:         moddescptr;             {descriptors will be chained together}

  case  patchmod: boolean of
  true: (
  patchlink:    moddescptr;             {patchmods are additionally linked}
  patchlist:    patchdescptr;           {head of list of patch descriptors}
  patchbase:    integer;                {relocatable address of patch space}
  patchsize:    integer);               {total bytes of patch space}

  false:(
  defaddr:      addrec;                 {address of DEF table}
  defsize:      integer;                {size of DEF table, in bytes}

  case resolved: boolean of             {only present during loading}
  true: (startaddr: integer;
	 progname: tid;
	 ucase,lastmodule: boolean);
  false:(extaddr:       addrec;         {address of EXT table}
	 listaddr:      wordlistptr;    {index pointers into EXT table}
	 listsize:      shortint;       {number of entries in list}
	 unresbits:     addrec;         {flag to indicate unresolved symbols}
	 relocbase,                     {relocatable address of module}
	 globase:       integer;        {global base address}
	 relocdelta,
	 globaldelta:   integer;        {deltas for relocation}
	 filefib:       addrec;         {file info block for module}
	 fileblock:     shortint;       {file relative block of module}
	 directory:     addrec));       {memory for processing modules}
end;

filedirectory = array[0..maxint] of direntry;

sortdesc = record
		modp:   moddescptr;
		case integer of
	   1:   (ext:   symbolptr; n:   shortint);
	   2:   (def:   addrec);
		end;
sortlist = array[0..maxint] of sortdesc;

indexlist = array[1..maxint] of shortint;

ptrtable =         array[0..maxint] of addrec;

var     {memory management: }
	a5['g_dollar']:  integer;
	lowheap,                        {next available memory}
	highheap:       addrec;         {last available memory}

	{input file information: }
	fdirectory:     filedirptr;     {old library directory pointer}
	loadfib:        addrec;         {pointer to FIB for open file}
	wrongbyte:      integer;        {error information}
	linkmodname:    addrec;         {ptr to name of module being linked}

	{linker information:  }
	newmods:        moddescptr;     {modules currently being processed}
	allresolved:    boolean;        {flag indicating whether any ext's}
	totalreloc,
	totalglobal:    integer;        {total bytes of areas}
	startreloc,
	startglobal:    integer;        {starting addresses for areas}

	eheap:  anyptr;                 (*HEAP MARK FOR MEM MANAGING*)
	edefs:  moddescptr;
	userstack: integer;
	entrypoint:  moddescptr;
	eglobal:              integer;  (*PERMANENT BASE OF DATA AREA*)
	sysdefs:        moddescptr;     {list of permanent module descriptors}

    endmod:     moddescptr;             {marks end of list of new modules}
    libfound: boolean;
    wrongrec:   integer;                {error information}
    startdefs,
    totaldefs: integer;                 {DEF table information}

procedure markuser;
procedure releaseuser;

procedure loadinfo(modnum: shortint; all,resolveexts: boolean);
procedure openlinkf(extra: addrec);     {formerly 'openlinkfile'}
procedure getbytes(var p: integer; size: integer);
procedure checkrev;
procedure matchfile;
procedure countcode;
procedure loadtext(onheap: boolean);
procedure zeromem(start: anyptr; size: integer);
procedure closefiles;
procedure movedefs(newstartdefs: integer);

procedure loadq(filetogo: fid);         {name of file to be loaded}
procedure initloader;

implement

type pointer = ^integer;
     address = integer;

var sysdeftable['sysdeftable']:
		     moduledescriptor;  {initial ROM symbol table}

procedure evalgvr(var gvalue, gvptr: integer;
		 modptr:  moddescptr); external;

procedure relocate(reftop, refindex: address;
		   var object:  address;
		   modptr:  moddescptr); external;

procedure getbytes(var p: integer; size: integer);
begin
  if odd(size) then size := size + 1;
  p := lowheap.a;       lowheap.a := lowheap.a + size;
  if lowheap.a > highheap.a then escape(112);
end;

procedure readblocks(anyvar f: fib; anyvar obj: integer; size, block: integer);
begin
  call (f.am, addr(f), readbytes, obj, size, block*fblksize);
  if ioresult <> ord(inoerror) then escape(-10);
end;

procedure markuser;
begin
  entrypoint := nil;    mark(eheap);
  eglobal := userstack; edefs := sysdefs;
end;

procedure releaseuser;
begin
  entrypoint := nil;    release(eheap);
  userstack := eglobal; sysdefs := edefs;
end;

procedure openlinkf(extra: addrec);
var directsize: integer;
    slop:       integer;
begin if ioresult = 0 then
    begin
    if loadfib.fbp^.fkind <> codefile then escape(116);
    highheap.a := highheap.a - blocksize;
    if highheap.a < lowheap.a then escape(112);
    fdirectory := highheap.fdp;
    readblocks(loadfib.php^,fdirectory^,blocksize,0);
    directsize := (fdirectory^[0].dnumfiles + 1)*sizeof(direntry);
    slop := (-directsize) mod blocksize;
    highheap.a := highheap.a + blocksize - directsize - slop;
    if directsize > blocksize then
      begin
      if highheap.a < lowheap.a then escape(112);
      moveleft(fdirectory^, highheap.fdp^, blocksize);
      extra.a := highheap.a + blocksize;
      readblocks(loadfib.php^,extra.p^,directsize - blocksize,1);
      end;
    if slop > 0 then
	begin
	extra := highheap; highheap.a := highheap.a + slop;
	moveright(extra.fdp^, highheap.fdp^, directsize);
	end;
    fdirectory := highheap.fdp;
    end
  else begin fdirectory := nil;         {directory invalid}
	     loadfib  := extra.arp^;    {restore chain of FIB's}
	     lowheap  := extra;         {zap unopend FIB}
       end;
end; {openlinkfile}

procedure matchdefext(
	var resolved, matched:          boolean;
	    matchflag:                  byte;
	    deftable, exttable:         symtableptr;
	    extlist:                    wordlistptr;
	    listlength:                 shortint;
	    deftablelength:             integer);
external;

procedure match1(modptr: moddescptr);
var defmodptr: moddescptr; matched: boolean;
begin with modptr^ do
  begin
  defmodptr := link;
  while not resolved and (defmodptr <> nil ) do
    begin
    if not defmodptr^.patchmod then
      matchdefext(resolved, matched, 0,
		  defmodptr^.defaddr.stp, extaddr.stp,
		  listaddr, listsize, defmodptr^.defsize);
    defmodptr := defmodptr^.link;
    end;
  allresolved := allresolved and resolved;
  end;
end;

procedure matchfile;
var modptr: moddescptr;
begin
 modptr := newmods;
 while modptr <> nil do
   begin
   match1(modptr);
   modptr := modptr^.link;
   end;
end;

procedure loadinfo(modnum: shortint; all,resolveexts: boolean);
var modptr:             moddescptr;
    matched:            boolean;
    leftover:           address;
    modblock:           shortint;

procedure alphalist(
	    symtable:           symtableptr;
	    list:               wordlistptr;
	    listlength:         shortint);
external;

procedure makelist(tableptr:            symtableptr;    {DEF or EXT table}
		    length:             integer;        {length of symbol table}
		    bound:              shortint;       {boundary condition}
		    var listptr:        wordlistptr;    {address of list}
		    var listlength:     integer);       {number of symbols}

var i, l:       integer;
    n, len:     shortint;
    ptr:        addrec;

begin
  n := 0;       listptr := lowheap.wlp;
  l := length;  i := 0;

  while l > 0 do
    begin
    n := n + 1;
    getbytes(ptr.a, sizeof(wordrec));   ptr.uw^.w := i;
    len := ord(tableptr^[i]);
    len := len + bound - (len mod bound);
    if bound = 2 {DEF table} then len := len + ord(tableptr^[i+len+1]);
    i := i + len;
    l := l - len;
    end;
  listlength := n;
  alphalist(tableptr, listptr, n);
end;    { makelist }

procedure getdeftable;

  var defptr:   addrec;
      symptr1,
      symptr2:  addrec;
      i,len:    integer;
      list:     wordlistptr;
      size:     integer;

  begin
    with modptr^ do
      begin
      defsize := directory.drp^.defsize;
      getbytes(defaddr.a, defsize);
      if defsize > 0 then
       begin
       getbytes(defptr.a,  defsize);
       readblocks(loadfib.php^,  {unitread(funit, ... iocheck;}
		       defptr.p^, defsize, modblock + directory.drp^.defblock);
       makelist(defptr.stp, defsize, 2, list, size);
       symptr2 := defaddr;
       for i := 0 to size-1 do
	 begin
	 symptr1.a := defptr.a+list^[i];
	 len := strlen(symptr1.syp^);
	 len := len + 2 - ord(odd(len));
	 len := len + gvrptr(symptr1.a+len)^.short;
	 fastmove(symptr1.p, symptr2.p, len);
	 symptr2.a := symptr2.a+len;
	 end;
       lowheap := defptr;
       end;
      end;
  end;

  procedure getexttable;
  var  size:    integer;
  begin with modptr^, directory.drp^ do
    begin
    if extsize < 8 then extsize := 8;
    getbytes(extaddr.a, extsize);
    if extsize > 8 then
     readblocks(loadfib.php^, extaddr.p^, extsize, modblock + extblock);
    extaddr.stp^[0] := chr(0);
    extaddr.stp^[4] := chr(0);
    makelist(extaddr.stp, extsize, 4, listaddr, size);
    listsize := size;
    listaddr^[0] := 0;
    listaddr^[1] := 0;

    end;
  end;


  procedure match2;
  var extmodptr: moddescptr;
  begin
    extmodptr := newmods;
    while extmodptr <> nil  do with extmodptr^ do
      begin
      if not patchmod then if not resolved then
	begin
	matchdefext(resolved, matched, 0,
		      modptr^.defaddr.stp, extaddr.stp,
		      listaddr, listsize, modptr^.defsize);
	allresolved := allresolved and resolved;
	end;
      extmodptr := link;
      end;
  end;

begin {loadinfo}
  modblock := {fblock +} fdirectory^[modnum].dfirstblk;
  modptr := lowheap.mdp;
  getbytes(leftover, sizeof(moduledescriptor,false,false));
  modptr^.directory := lowheap;
  getbytes(leftover, blocksize);
  with modptr^, directory.drp^ do
    begin
    readblocks(loadfib.php^,  directory.drp^, blocksize, modblock);
    if directorysize > blocksize then
      begin
      getbytes(leftover,directorysize-blocksize);
      readblocks(loadfib.php^,   {unitread(funit ... iocheck}
			pointer(leftover)^,directorysize-blocksize,modblock+1);
      end
    else lowheap.a := directory.a+directorysize;
    getdeftable;
    allresolved := true;          matched := false;
    match2;
    if matched or all then
	 begin
	 libfound := true;
	 link := newmods;         newmods := modptr;
	 patchmod := false;
	 resolved := false;                  {set appropriate variant}
	 filefib  := loadfib;      {remember mass memory location for later}
	 fileblock:= modblock;

	 getexttable;
	 matchdefext(resolved, matched,
	    0{patchable bit  *** fix later! **},
	    defaddr.stp, extaddr.stp,listaddr,
	    listsize, defsize);
	 if resolveexts then match1(modptr);
	 end
    else lowheap.mdp := modptr;
    end;

end; {loadinfo}

procedure reversepointers;
var modptr, lastptr, nextptr: moddescptr;
begin
  modptr := newmods; lastptr := endmod;
  while modptr <> endmod do with modptr^ do
    begin nextptr := link;      link := lastptr;
	  lastptr := modptr;    modptr := nextptr;
    end;
  newmods := lastptr;
end;

procedure countcode;
var modptr: moddescptr;
begin
  reversepointers;
  modptr := newmods;
  totalreloc := 0; totalglobal := 0;
  while modptr <> endmod do with modptr^ do
    begin
    with directory.drp^ do
      begin
      totalreloc  := totalreloc  + relocatablesize + ord(odd(relocatablesize));
      totalglobal := totalglobal + globalsize      + ord(odd(globalsize));
      end;
    modptr := link;
    end;
end;

procedure closefiles;
begin
while loadfib.php <> nil do
  begin
  {close(loadfib.php^);}
  with loadfib.fbp^, unitable^[funit] do
				    call(dam, loadfib.fbp^, funit, closefile);
  loadfib.a := loadfib.a - sizeof(addrec);
  loadfib   := loadfib.arp^;
  end;
end;

procedure resolve;
var modptr: moddescptr;
    mrbase,mgbase:    integer;
    len:        shortint;
    i:          shortint;

begin
  modptr := newmods;
  mrbase := startreloc; mgbase := startglobal;
  while modptr <> endmod do with modptr^ do
    begin
    with directory.drp^ do
      begin
      relocbase := mrbase;    relocdelta :=  mrbase - relocatablebase;
      mrbase := mrbase + relocatablesize + ord(odd(relocatablesize));
      globase := mgbase;      globaldelta := mgbase - globalbase;
      mgbase := mgbase - globalsize      - ord(odd(globalsize));
      end;
    modptr := link;
    end;
end; {resolve}

 procedure createdefs;
 var modptr:            moddescptr;
     newmodptr,
     sp,ptr1,ptr2,enddefs:      addrec;
     len:               shortint;
 begin
 reversepointers;
 entrypoint := nil;
 modptr := newmods;
 startdefs := lowheap.a;
 while modptr <> endmod do with modptr^ do
  begin
  ptr1 := defaddr;
  enddefs.a := ptr1.a + defsize;
  getbytes(newmodptr.a, sizeof(moduledescriptor,false, true));
  with newmodptr.mdp^ do
   begin
   patchmod := false;  resolved := true;
   progname := modptr^.filefib.fbp^.ftid   {togo};
   ucase := unitable^[modptr^.filefib.fbp^.funit].uuppercase;
   if modptr^.directory.drp^.executable then
	begin
	sp.a := modptr^.directory.a+sizeof(moduledirectory);
	sp.a := sp.a+strlen(sp.syp^)+2-ord(odd(strlen(sp.syp^)));
	evalgvr(startaddr,sp.i,modptr);
	lastmodule := entrypoint=nil;
	entrypoint:= newmodptr.mdp;   {moddescptr(newmodptr.a - loaddelta);}
	end
   else begin startaddr := 0;
	      lastmodule := false;
	end;
   link := sysdefs;
   sysdefs := newmodptr.mdp;   {moddescptr(newmodptr.a - loaddelta);}
   defaddr.a := lowheap.a      {- loaddelta};
   while ptr1.a < enddefs.a do
    begin
    len := strlen(ptr1.syp^) + 2 - ord(odd(strlen(ptr1.syp^)));
    getbytes(ptr2.a,len); fastmove(ptr1.p, ptr2.p, len);
    ptr1.a := ptr1.a + len;
    getbytes(ptr2.a, sizeof(generalvalue, false));
    with ptr2.gvp^ do
     begin primarytype := absolute;    datasize := sint;
	   patchable := false;         valueextend := true;
	   longoffset := false;        short := 6;
     end;
    getbytes(ptr2.a, sizeof(valueextension,sint));
    evalgvr(ptr2.vep^.value, ptr1.i, modptr);
    end;
   defsize := lowheap.a -(defaddr.a  {+ loaddelta});
   end;
  modptr := link;
  end;
 totaldefs := lowheap.a - startdefs;
 end;

 procedure movedefs(newstartdefs: integer);
 var modptr:            moddescptr;
     defdelta:          integer;
     previous:          ^addrec;
 begin
 defdelta := newstartdefs - startdefs;
 previous := addr(sysdefs);
 modptr   :=      sysdefs;
 while modptr <> endmod do with modptr^ do
   begin
   previous^.a := previous^.a + defdelta;
   if entrypoint = modptr then entrypoint := previous^.mdp;
   defaddr.a := defaddr.a + defdelta;
   previous := addr(link);
   modptr   :=      link;
   end;
 fastmove(pointer(startdefs), pointer(newstartdefs), totaldefs);
 startdefs := newstartdefs;
 end;

procedure loadtext(onheap: boolean);

const maxrefsize = 254;

var modptr:     moddescptr;     {current module being loaded}

    textbuffer,         {base of text record buffer}
    object,object0,     {object in text record being modified by ref record}
    refbuffer,          {base of ref table buffer}
    oldindex:           {pointer to old text descriptors}
		addrec;

    loaddelta,          {loader displacement}
    oldtextrec:         {text records left to process from old module}
		integer;



begin {procedure loadtext}
  if onheap then
    begin
    getbytes(textbuffer.a, totalreloc {+ blocksize});
    loaddelta := textbuffer.a - startreloc;
    end
  else loaddelta := 0;
  resolve;
  modptr := newmods;
  while modptr <> endmod do with modptr^, directory.drp^ do
    begin
    linkmodname.a := directory.a + sizeof(moduledirectory);
    oldindex.a := linkmodname.a + strlen(linkmodname.syp^) + 2 -
	     ord(odd(strlen(linkmodname.syp^)));
    if executable then oldindex.a := oldindex.a + oldindex.gvp^.short;
    for oldtextrec := 1 to textrecords do
     with oldindex.tdp^ do
      begin
      oldindex.a := oldindex.a + sizeof(textdescriptor);
      evalgvr(object.i, oldindex.i, modptr);
      if textsize > 0 then
       begin
       if object.a >= startreloc
	then if object.a < startreloc + totalreloc
	 then object.a := object.a  + loaddelta;

       readblocks(modptr^.filefib.php^,  {unitread(modptr^.fileunit,...iocheck}
				    object.p^,textsize, fileblock + textstart);
       if refsize > 0 then
	begin
	getbytes(refbuffer.a, refsize);
	readblocks(modptr^.filefib.php^,
				   refbuffer.p^,refsize, fileblock + refstart);
	object0 := object;
	try relocate(lowheap.a, refbuffer.a, object.a, modptr);
	recover
	  begin
	  wrongbyte := object.a-object0.a;
	  wrongrec := oldtextrec;
	  escape(escapecode);
	  end;
	lowheap := refbuffer;
	end;
       end;
      end; {for oldtextrec}
    modptr := link;
    end;

  createdefs;
  closefiles;

  if onheap then fastmove(textbuffer.p, pointer(startreloc), totalreloc);

end;

procedure zeromem(start: anyptr; size: integer);
var ptr, endp: addrec;
begin
  ptr.p := start; endp.a := ptr.a + size;
  while ptr.a < endp.a do
    begin
    ptr.sw^ := 0;
    ptr.a := ptr.a + 2;
    end;
end;

procedure checkrev;
begin
if newmods^.directory.drp^.systemid <> 3 then escape(118);
end;

procedure loadq(filetogo:fid);

type str9 = packed array[1..9] of char;

const loading = str9['Loading '''];

var modnum, esc:   shortint;
    extra:      addrec;
    i, ior: integer;

begin

loadfib.php := nil;
try
  releaseuser;          {get rid of last program}
  mark(lowheap.p);              highheap.a := userstack;
  startreloc := lowheap.a;
  newmods       := sysdefs;     endmod          := sysdefs;

  getbytes(extra.a,   sizeof(addrec));  {save old value of loadfib}
  extra.arp^ := loadfib;
  getbytes(loadfib.a, sizeof(fib,1));   {create a FIB for new file}
  with loadfib.fbp^, unitable^[sysunit] do
    begin
    fbuffered := false;
    ftitle := filetogo;
    funit := sysunit;
    call(dam, loadfib.fbp^, sysunit, openfile);
    am := tm;
    end;
  openlinkf(extra);

  i := strlen(filetogo)+1; setstrlen(filetogo, i+9);
  filetogo[i] := '''';
  moveright(filetogo[1],        filetogo[10], i);
  fastmove (addr(loading),      addr(filetogo[1]),  9);
  cpymsg(filetogo);

  if fdirectory = nil then escape(-10);
  for modnum := 1 to fdirectory^[0].dnumfiles do
			   begin loadinfo(modnum, true, false); checkrev; end;
  allresolved := true; matchfile;
  highheap.a := userstack;

  if not allresolved then escape(-119);

  countcode;

  highheap.a := userstack - totalglobal;
  if highheap.a < (a5 - 32768) then escape(117);
  startglobal   := userstack - a5;
  userstack := highheap.a;
  zeromem(highheap.p, totalglobal);

  loadtext(true);

  movedefs(startreloc+totalreloc);

  lowheap.a := startdefs + totaldefs;
  release(lowheap.p);

recover
  begin
  esc := escapecode; ior := ioresult;
  closefiles;
  releaseuser;
  ioresult := ior; escape(esc);
  end;
end;

procedure initloader;
begin
  sysdefs := addr(sysdeftable);
  {findroms;             {find and "load" rom modules }
  { Next line is filled in by TURNIT with the correct number. }
  { Don't TOUCH this line unless you ensure that TURNIT will not break }
  userstack := a5 +32178;
  markuser;
end;

end
@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 857
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 857
module loader;

import sysglobals, asm;

export

const  blocksize = fblksize;
       vnlength = 7;
       fnlength = 15;

type

  volname =  string[vnlength];
  filname =  string[fnlength];

  dirrange = 0..mmaxint;         {0..MAXlongDIR; }

  (* the following declaration serves for a "library directory" *)

  direntry = record
	      dfirstblk: shortint;           (*module starting block*)
	      dlastblk: shortint;            (*block following end*)
	  {NOTE:  for DIR[0], these refer to the library directory itself}
	      case dfkind: filekind of
	      untypedfile:                   (*library info in DIR[0]*)
		    (dvid: volname;          (*name of library*)
		     deovblk: shortint;      (*block following library*)
		     dnumfiles: dirrange;    (*num modules in library*)
		     dloadtime: shortint;    (*time of last modification*)
		     dlastboot: daterec );   (*most recent date setting*)
	      datafile..lastfkind:
		    (dtid: filname;          (*title of module*)
		     dlastbyte: 1..fblksize; (*1..256 bytes in last block*)
		     daccess: daterec )      (*last modification date*)
	     end (*direntry*) ;

     ubyterec =         packed record ub: byte end;
     sbyterec =         packed record sb: -128..127 end;
     word =             0..65535;
     wordrec =          packed record w: word end;
     wordrecptr =       ^wordrec;
     wordlist =         packed array[0..maxint] of word;
     wordlistptr =      ^wordlist;

     symboltable =      array[0..maxint] of char;
     symtableptr =      ^symboltable;

     symbol =           string[255];
     symbolptr =        ^symbol;

     datatype =         (sbyte, sword, sint, fltpt, ubyte, uword);
     reloctype =        (absolute, relocatable, global, general);


referenceptr = packed record    {one or more present if type = general}
  case integer of
  0:(
  adr:  0..16383;               {word address of external symbol}
  op:   (addit, subit);         {add or subtract the modifying value}
  last: boolean);               {indicates end of list}

  1:(w: word);                  {for comparisons}
end;

gvrptr          = ^generalvalue;
veptr           = ^valueextension;
textdescptr     = ^textdescriptor;
fileptr         = ^phyle;
moddescptr      = ^moduledescriptor;
refptrptr       = ^referenceptr;
sortlistptr     = ^sortlist;
moddirptr       = ^moduledirectory;
filedirptr      = ^filedirectory;
ptrtableptr     = ^ptrtable;
patchdescptr    = ^patchdescriptor;


addrec  =  record case integer of       {a universal address}
	-1:     (rp:    referenceptr);  {a two byte object; rest are 4 bytes:}

	1:      (i:     integer);       {to change an address to integer}
	2:      (a:     integer);       {to do address arithmetic}
	3:      (p:    ^integer);       {to dereference}

	4:      (sb:    ^sbyterec);     {^signed byte record}
	5:      (sw:    ^shortint);     {^signed word}
	6:      (si:    ^integer);      {^signed integer}
	7:      (fp:    ^real);         {^floating point}
	8:      (ub:    ^ubyterec);     {^unsigned byte record}
	9:      (uw:    wordrecptr);    {^unsigned word record}

	10:     (gvp:   gvrptr);        {^generalvalue}
	11:     (vep:   veptr);         {^valueextension}
	12:     (tdp:   textdescptr);   {^textdescriptor}
	13:     (syp:   symbolptr);     {^symbol  (string)  }
	14:     (stp:   symtableptr);   {^symboltable}
	15:     (wlp:   wordlistptr);   {^wordlist}
	16:     (php:   fileptr);       {^phyle}
	17:     (mdp:   moddescptr);    {^moduledescriptor}
	18:     (rpp:   refptrptr);     {^referenceptr}
	19:     (sdp:   ^sortdesc);
	20:     (slp:   sortlistptr);   {^sortlist}
	21:     (drp:   moddirptr);     {^moduledirectory}
	22:     (fdp:   filedirptr);    {^filedirectory}
	23:     (bmp:   ^bitmap);
	24:     (fbp:   fibp);
	25:     (ptp:   ptrtableptr);   {^ptrtable}
	26:     (ilp:   ^indexlist);
	27:     (pdp:   patchdescptr);
	28:     (cp:    ^char);
	29:     (arp:   ^addrec);
	end;

generalvalue = packed record
  primarytype: reloctype;       {allows quick indication of most common types}
  datasize:    datatype;        {specifies 1, 2, 4 or 8 bytes, signed or not}
  patchable,                    {specifies self relative field in branch}
  valueextend: boolean;         {indicates the presence of valueextension}
  case longoffset:  boolean of  {1 or 3 byte offset }
      false:    (short:          byte);               {unsigned 8 bits}
      true:     (long:           0..16777215);        {unsigned 24 bit value}
end;

valueextension = packed record {present if valueextend bit above is set}
  case datatype of
	   sbyte,sword,sint,
	   ubyte,uword:         (value:    integer);
	   fltpt:               (valuer:   real);
end;

phyle = file of char;


moduledirectory = packed record
     date:      daterec;        {date of creation}
     revision:  daterec;        {producer's revision date number}
     producer:  char;           {A = assembler, C = compiler, L = linker, etc.}
     systemid: byte;            {system version number (hard or soft, etc.}
     notice: string[80];        {space for whatever comments may be desired}
     directorysize: integer;    {size of module directory, in bytes}
     modulesize: integer;       {total size of module, in bytes}
     executable:       boolean;        {module is executable,
					has start address}
     relocatablesize: integer;         {number of relocatable bytes requested}
     relocatablebase: integer;         {current origin of relocatable code}
     globalsize:      integer;         {number of global bytes requested}
     globalbase:      integer;         {A5 relative origin of global area}

     extblock,                         {module relative block of EXT table}
     extsize,                          {size of EXT table, in bytes}
     defblock,                         {module relative block of DEF table}
     defsize,                          {size of DEF table, in bytes}
     sourceblock,                      {module relative block of DEFINE SOURCE}
     sourcesize,                       {size of source, in bytes}

     textrecords:     integer;         {number of TEXT records}

	       {Remainder of directory is made up of variable length
		records.  Strings begin and end on word (even byte)
		boundaries. The directory itself may cross block
		boundaries.  General value or address records
		(GVR's,  see description later)
		occuring below have the short variant offset; the
		offset itself is the length of the GVR to assist in
		stepping quickly through the list.}


      {mname: string[ (variable) ];      {name of module}
      {
      {startaddress:    gvr;             {execution address, present only
      {                                   if executable}
      {
      {repeat for each text record       {list of TEXT records}
      {   textstart,                     {module relative block of TEXT record}
      {   textsize,                      {size of TEXT record, in bytes}
      {   refstart,                      {module relative block of REF table}
      {   refsize:      integer;         {size of REF table, in bytes}
      {   loadaddress:  gvr;             {location to load the TEXT}
      {end                      }
end;

textdescriptor = record
	 textstart,                     {module relative block of TEXT record}
	 textsize,                      {size of TEXT record, in bytes}
	 refstart,                      {module relative block of REF table}
	 refsize:      integer;         {size of REF table, in bytes}
	end;

bitmap = packed array[0..maxint] of boolean;

patchdescriptor = record
   patchlist:   patchdescptr;           {head of list of patch descriptors}
   patchref:    addrec;
end;

moduledescriptor = record
  link:         moddescptr;             {descriptors will be chained together}

  case  patchmod: boolean of
  true: (
  patchlink:    moddescptr;             {patchmods are additionally linked}
  patchlist:    patchdescptr;           {head of list of patch descriptors}
  patchbase:    integer;                {relocatable address of patch space}
  patchsize:    integer);               {total bytes of patch space}

  false:(
  defaddr:      addrec;                 {address of DEF table}
  defsize:      integer;                {size of DEF table, in bytes}

  case resolved: boolean of             {only present during loading}
  true: (startaddr: integer;
	 progname: tid;
	 ucase,lastmodule: boolean);
  false:(extaddr:       addrec;         {address of EXT table}
	 listaddr:      wordlistptr;    {index pointers into EXT table}
	 listsize:      shortint;       {number of entries in list}
	 unresbits:     addrec;         {flag to indicate unresolved symbols}
	 relocbase,                     {relocatable address of module}
	 globase:       integer;        {global base address}
	 relocdelta,
	 globaldelta:   integer;        {deltas for relocation}
	 filefib:       addrec;         {file info block for module}
	 fileblock:     shortint;       {file relative block of module}
	 directory:     addrec));       {memory for processing modules}
end;

filedirectory = array[0..maxint] of direntry;

sortdesc = record
		modp:   moddescptr;
		case integer of
	   1:   (ext:   symbolptr; n:   shortint);
	   2:   (def:   addrec);
		end;
sortlist = array[0..maxint] of sortdesc;

indexlist = array[1..maxint] of shortint;

ptrtable =         array[0..maxint] of addrec;

var     {memory management: }
	a5['g_dollar']:  integer;
	lowheap,                        {next available memory}
	highheap:       addrec;         {last available memory}

	{input file information: }
	fdirectory:     filedirptr;     {old library directory pointer}
	loadfib:        addrec;         {pointer to FIB for open file}
	wrongbyte:      integer;        {error information}
	linkmodname:    addrec;         {ptr to name of module being linked}

	{linker information:  }
	newmods:        moddescptr;     {modules currently being processed}
	allresolved:    boolean;        {flag indicating whether any ext's}
	totalreloc,
	totalglobal:    integer;        {total bytes of areas}
	startreloc,
	startglobal:    integer;        {starting addresses for areas}

	eheap:  anyptr;                 (*HEAP MARK FOR MEM MANAGING*)
	edefs:  moddescptr;
	userstack: integer;
	entrypoint:  moddescptr;
	eglobal:              integer;  (*PERMANENT BASE OF DATA AREA*)
	sysdefs:        moddescptr;     {list of permanent module descriptors}

    endmod:     moddescptr;             {marks end of list of new modules}
    libfound: boolean;
    wrongrec:   integer;                {error information}
    startdefs,
    totaldefs: integer;                 {DEF table information}

procedure markuser;
procedure releaseuser;

procedure loadinfo(modnum: shortint; all,resolveexts: boolean);
procedure openlinkf(extra: addrec);     {formerly 'openlinkfile'}
procedure getbytes(var p: integer; size: integer);
procedure checkrev;
procedure matchfile;
procedure countcode;
procedure loadtext(onheap: boolean);
procedure zeromem(start: anyptr; size: integer);
procedure closefiles;
procedure movedefs(newstartdefs: integer);

procedure loadq(filetogo: fid);         {name of file to be loaded}
procedure initloader;

implement

type pointer = ^integer;
     address = integer;

var sysdeftable['sysdeftable']:
		     moduledescriptor;  {initial ROM symbol table}

procedure evalgvr(var gvalue, gvptr: integer;
		 modptr:  moddescptr); external;

procedure relocate(reftop, refindex: address;
		   var object:  address;
		   modptr:  moddescptr); external;

procedure getbytes(var p: integer; size: integer);
begin
  if odd(size) then size := size + 1;
  p := lowheap.a;       lowheap.a := lowheap.a + size;
  if lowheap.a > highheap.a then escape(112);
end;

procedure readblocks(anyvar f: fib; anyvar obj: integer; size, block: integer);
begin
  call (f.am, addr(f), readbytes, obj, size, block*fblksize);
  if ioresult <> ord(inoerror) then escape(-10);
end;

procedure markuser;
begin
  entrypoint := nil;    mark(eheap);
  eglobal := userstack; edefs := sysdefs;
end;

procedure releaseuser;
begin
  entrypoint := nil;    release(eheap);
  userstack := eglobal; sysdefs := edefs;
end;

procedure openlinkf(extra: addrec);
var directsize: integer;
    slop:       integer;
begin if ioresult = 0 then
    begin
    if loadfib.fbp^.fkind <> codefile then escape(116);
    highheap.a := highheap.a - blocksize;
    if highheap.a < lowheap.a then escape(112);
    fdirectory := highheap.fdp;
    readblocks(loadfib.php^,fdirectory^,blocksize,0);
    directsize := (fdirectory^[0].dnumfiles + 1)*sizeof(direntry);
    slop := (-directsize) mod blocksize;
    highheap.a := highheap.a + blocksize - directsize - slop;
    if directsize > blocksize then
      begin
      if highheap.a < lowheap.a then escape(112);
      moveleft(fdirectory^, highheap.fdp^, blocksize);
      extra.a := highheap.a + blocksize;
      readblocks(loadfib.php^,extra.p^,directsize - blocksize,1);
      end;
    if slop > 0 then
	begin
	extra := highheap; highheap.a := highheap.a + slop;
	moveright(extra.fdp^, highheap.fdp^, directsize);
	end;
    fdirectory := highheap.fdp;
    end
  else begin fdirectory := nil;         {directory invalid}
	     loadfib  := extra.arp^;    {restore chain of FIB's}
	     lowheap  := extra;         {zap unopend FIB}
       end;
end; {openlinkfile}

procedure matchdefext(
	var resolved, matched:          boolean;
	    matchflag:                  byte;
	    deftable, exttable:         symtableptr;
	    extlist:                    wordlistptr;
	    listlength:                 shortint;
	    deftablelength:             integer);
external;

procedure match1(modptr: moddescptr);
var defmodptr: moddescptr; matched: boolean;
begin with modptr^ do
  begin
  defmodptr := link;
  while not resolved and (defmodptr <> nil ) do
    begin
    if not defmodptr^.patchmod then
      matchdefext(resolved, matched, 0,
		  defmodptr^.defaddr.stp, extaddr.stp,
		  listaddr, listsize, defmodptr^.defsize);
    defmodptr := defmodptr^.link;
    end;
  allresolved := allresolved and resolved;
  end;
end;

procedure matchfile;
var modptr: moddescptr;
begin
 modptr := newmods;
 while modptr <> nil do
   begin
   match1(modptr);
   modptr := modptr^.link;
   end;
end;

procedure loadinfo(modnum: shortint; all,resolveexts: boolean);
var modptr:             moddescptr;
    matched:            boolean;
    leftover:           address;
    modblock:           shortint;

procedure alphalist(
	    symtable:           symtableptr;
	    list:               wordlistptr;
	    listlength:         shortint);
external;

procedure makelist(tableptr:            symtableptr;    {DEF or EXT table}
		    length:             integer;        {length of symbol table}
		    bound:              shortint;       {boundary condition}
		    var listptr:        wordlistptr;    {address of list}
		    var listlength:     integer);       {number of symbols}

var i, l:       integer;
    n, len:     shortint;
    ptr:        addrec;

begin
  n := 0;       listptr := lowheap.wlp;
  l := length;  i := 0;

  while l > 0 do
    begin
    n := n + 1;
    getbytes(ptr.a, sizeof(wordrec));   ptr.uw^.w := i;
    len := ord(tableptr^[i]);
    len := len + bound - (len mod bound);
    if bound = 2 {DEF table} then len := len + ord(tableptr^[i+len+1]);
    i := i + len;
    l := l - len;
    end;
  listlength := n;
  alphalist(tableptr, listptr, n);
end;    { makelist }

procedure getdeftable;

  var defptr:   addrec;
      symptr1,
      symptr2:  addrec;
      i,len:    integer;
      list:     wordlistptr;
      size:     integer;

  begin
    with modptr^ do
      begin
      defsize := directory.drp^.defsize;
      getbytes(defaddr.a, defsize);
      if defsize > 0 then
       begin
       getbytes(defptr.a,  defsize);
       readblocks(loadfib.php^,  {unitread(funit, ... iocheck;}
		       defptr.p^, defsize, modblock + directory.drp^.defblock);
       makelist(defptr.stp, defsize, 2, list, size);
       symptr2 := defaddr;
       for i := 0 to size-1 do
	 begin
	 symptr1.a := defptr.a+list^[i];
	 len := strlen(symptr1.syp^);
	 len := len + 2 - ord(odd(len));
	 len := len + gvrptr(symptr1.a+len)^.short;
	 fastmove(symptr1.p, symptr2.p, len);
	 symptr2.a := symptr2.a+len;
	 end;
       lowheap := defptr;
       end;
      end;
  end;

  procedure getexttable;
  var  size:    integer;
  begin with modptr^, directory.drp^ do
    begin
    if extsize < 8 then extsize := 8;
    getbytes(extaddr.a, extsize);
    if extsize > 8 then
     readblocks(loadfib.php^, extaddr.p^, extsize, modblock + extblock);
    extaddr.stp^[0] := chr(0);
    extaddr.stp^[4] := chr(0);
    makelist(extaddr.stp, extsize, 4, listaddr, size);
    listsize := size;
    listaddr^[0] := 0;
    listaddr^[1] := 0;

    end;
  end;


  procedure match2;
  var extmodptr: moddescptr;
  begin
    extmodptr := newmods;
    while extmodptr <> nil  do with extmodptr^ do
      begin
      if not patchmod then if not resolved then
	begin
	matchdefext(resolved, matched, 0,
		      modptr^.defaddr.stp, extaddr.stp,
		      listaddr, listsize, modptr^.defsize);
	allresolved := allresolved and resolved;
	end;
      extmodptr := link;
      end;
  end;

begin {loadinfo}
  modblock := {fblock +} fdirectory^[modnum].dfirstblk;
  modptr := lowheap.mdp;
  getbytes(leftover, sizeof(moduledescriptor,false,false));
  modptr^.directory := lowheap;
  getbytes(leftover, blocksize);
  with modptr^, directory.drp^ do
    begin
    readblocks(loadfib.php^,  directory.drp^, blocksize, modblock);
    if directorysize > blocksize then
      begin
      getbytes(leftover,directorysize-blocksize);
      readblocks(loadfib.php^,   {unitread(funit ... iocheck}
			pointer(leftover)^,directorysize-blocksize,modblock+1);
      end
    else lowheap.a := directory.a+directorysize;
    getdeftable;
    allresolved := true;          matched := false;
    match2;
    if matched or all then
	 begin
	 libfound := true;
	 link := newmods;         newmods := modptr;
	 patchmod := false;
	 resolved := false;                  {set appropriate variant}
	 filefib  := loadfib;      {remember mass memory location for later}
	 fileblock:= modblock;

	 getexttable;
	 matchdefext(resolved, matched,
	    0{patchable bit  *** fix later! **},
	    defaddr.stp, extaddr.stp,listaddr,
	    listsize, defsize);
	 if resolveexts then match1(modptr);
	 end
    else lowheap.mdp := modptr;
    end;

end; {loadinfo}

procedure reversepointers;
var modptr, lastptr, nextptr: moddescptr;
begin
  modptr := newmods; lastptr := endmod;
  while modptr <> endmod do with modptr^ do
    begin nextptr := link;      link := lastptr;
	  lastptr := modptr;    modptr := nextptr;
    end;
  newmods := lastptr;
end;

procedure countcode;
var modptr: moddescptr;
begin
  reversepointers;
  modptr := newmods;
  totalreloc := 0; totalglobal := 0;
  while modptr <> endmod do with modptr^ do
    begin
    with directory.drp^ do
      begin
      totalreloc  := totalreloc  + relocatablesize + ord(odd(relocatablesize));
      totalglobal := totalglobal + globalsize      + ord(odd(globalsize));
      end;
    modptr := link;
    end;
end;

procedure closefiles;
begin
while loadfib.php <> nil do
  begin
  {close(loadfib.php^);}
  with loadfib.fbp^, unitable^[funit] do
				    call(dam, loadfib.fbp^, funit, closefile);
  loadfib.a := loadfib.a - sizeof(addrec);
  loadfib   := loadfib.arp^;
  end;
end;

procedure resolve;
var modptr: moddescptr;
    mrbase,mgbase:    integer;
    len:        shortint;
    i:          shortint;

begin
  modptr := newmods;
  mrbase := startreloc; mgbase := startglobal;
  while modptr <> endmod do with modptr^ do
    begin
    with directory.drp^ do
      begin
      relocbase := mrbase;    relocdelta :=  mrbase - relocatablebase;
      mrbase := mrbase + relocatablesize + ord(odd(relocatablesize));
      globase := mgbase;      globaldelta := mgbase - globalbase;
      mgbase := mgbase - globalsize      - ord(odd(globalsize));
      end;
    modptr := link;
    end;
end; {resolve}

 procedure createdefs;
 var modptr:            moddescptr;
     newmodptr,
     sp,ptr1,ptr2,enddefs:      addrec;
     len:               shortint;
 begin
 reversepointers;
 entrypoint := nil;
 modptr := newmods;
 startdefs := lowheap.a;
 while modptr <> endmod do with modptr^ do
  begin
  ptr1 := defaddr;
  enddefs.a := ptr1.a + defsize;
  getbytes(newmodptr.a, sizeof(moduledescriptor,false, true));
  with newmodptr.mdp^ do
   begin
   patchmod := false;  resolved := true;
   progname := modptr^.filefib.fbp^.ftid   {togo};
   ucase := unitable^[modptr^.filefib.fbp^.funit].uuppercase;
   if modptr^.directory.drp^.executable then
	begin
	sp.a := modptr^.directory.a+sizeof(moduledirectory);
	sp.a := sp.a+strlen(sp.syp^)+2-ord(odd(strlen(sp.syp^)));
	evalgvr(startaddr,sp.i,modptr);
	lastmodule := entrypoint=nil;
	entrypoint:= newmodptr.mdp;   {moddescptr(newmodptr.a - loaddelta);}
	end
   else begin startaddr := 0;
	      lastmodule := false;
	end;
   link := sysdefs;
   sysdefs := newmodptr.mdp;   {moddescptr(newmodptr.a - loaddelta);}
   defaddr.a := lowheap.a      {- loaddelta};
   while ptr1.a < enddefs.a do
    begin
    len := strlen(ptr1.syp^) + 2 - ord(odd(strlen(ptr1.syp^)));
    getbytes(ptr2.a,len); fastmove(ptr1.p, ptr2.p, len);
    ptr1.a := ptr1.a + len;
    getbytes(ptr2.a, sizeof(generalvalue, false));
    with ptr2.gvp^ do
     begin primarytype := absolute;    datasize := sint;
	   patchable := false;         valueextend := true;
	   longoffset := false;        short := 6;
     end;
    getbytes(ptr2.a, sizeof(valueextension,sint));
    evalgvr(ptr2.vep^.value, ptr1.i, modptr);
    end;
   defsize := lowheap.a -(defaddr.a  {+ loaddelta});
   end;
  modptr := link;
  end;
 totaldefs := lowheap.a - startdefs;
 end;

 procedure movedefs(newstartdefs: integer);
 var modptr:            moddescptr;
     defdelta:          integer;
     previous:          ^addrec;
 begin
 defdelta := newstartdefs - startdefs;
 previous := addr(sysdefs);
 modptr   :=      sysdefs;
 while modptr <> endmod do with modptr^ do
   begin
   previous^.a := previous^.a + defdelta;
   if entrypoint = modptr then entrypoint := previous^.mdp;
   defaddr.a := defaddr.a + defdelta;
   previous := addr(link);
   modptr   :=      link;
   end;
 fastmove(pointer(startdefs), pointer(newstartdefs), totaldefs);
 startdefs := newstartdefs;
 end;

procedure loadtext(onheap: boolean);

const maxrefsize = 254;

var modptr:     moddescptr;     {current module being loaded}

    textbuffer,         {base of text record buffer}
    object,object0,     {object in text record being modified by ref record}
    refbuffer,          {base of ref table buffer}
    oldindex:           {pointer to old text descriptors}
		addrec;

    loaddelta,          {loader displacement}
    oldtextrec:         {text records left to process from old module}
		integer;



begin {procedure loadtext}
  if onheap then
    begin
    getbytes(textbuffer.a, totalreloc {+ blocksize});
    loaddelta := textbuffer.a - startreloc;
    end
  else loaddelta := 0;
  resolve;
  modptr := newmods;
  while modptr <> endmod do with modptr^, directory.drp^ do
    begin
    linkmodname.a := directory.a + sizeof(moduledirectory);
    oldindex.a := linkmodname.a + strlen(linkmodname.syp^) + 2 -
	     ord(odd(strlen(linkmodname.syp^)));
    if executable then oldindex.a := oldindex.a + oldindex.gvp^.short;
    for oldtextrec := 1 to textrecords do
     with oldindex.tdp^ do
      begin
      oldindex.a := oldindex.a + sizeof(textdescriptor);
      evalgvr(object.i, oldindex.i, modptr);
      if textsize > 0 then
       begin
       if object.a >= startreloc
	then if object.a < startreloc + totalreloc
	 then object.a := object.a  + loaddelta;

       readblocks(modptr^.filefib.php^,  {unitread(modptr^.fileunit,...iocheck}
				    object.p^,textsize, fileblock + textstart);
       if refsize > 0 then
	begin
	getbytes(refbuffer.a, refsize);
	readblocks(modptr^.filefib.php^,
				   refbuffer.p^,refsize, fileblock + refstart);
	object0 := object;
	try relocate(lowheap.a, refbuffer.a, object.a, modptr);
	recover
	  begin
	  wrongbyte := object.a-object0.a;
	  wrongrec := oldtextrec;
	  escape(escapecode);
	  end;
	lowheap := refbuffer;
	end;
       end;
      end; {for oldtextrec}
    modptr := link;
    end;

  createdefs;
  closefiles;

  if onheap then fastmove(textbuffer.p, pointer(startreloc), totalreloc);

end;

procedure zeromem(start: anyptr; size: integer);
var ptr, endp: addrec;
begin
  ptr.p := start; endp.a := ptr.a + size;
  while ptr.a < endp.a do
    begin
    ptr.sw^ := 0;
    ptr.a := ptr.a + 2;
    end;
end;

procedure checkrev;
begin
if newmods^.directory.drp^.systemid <> 3 then escape(118);
end;

procedure loadq(filetogo:fid);

type str9 = packed array[1..9] of char;

const loading = str9['Loading '''];

var modnum, esc:   shortint;
    extra:      addrec;
    i, ior: integer;

begin

loadfib.php := nil;
try
  releaseuser;          {get rid of last program}
  mark(lowheap.p);              highheap.a := userstack;
  startreloc := lowheap.a;
  newmods       := sysdefs;     endmod          := sysdefs;

  getbytes(extra.a,   sizeof(addrec));  {save old value of loadfib}
  extra.arp^ := loadfib;
  getbytes(loadfib.a, sizeof(fib,1));   {create a FIB for new file}
  with loadfib.fbp^, unitable^[sysunit] do
    begin
    fbuffered := false;
    ftitle := filetogo;
    funit := sysunit;
    call(dam, loadfib.fbp^, sysunit, openfile);
    am := tm;
    end;
  openlinkf(extra);

  i := strlen(filetogo)+1; setstrlen(filetogo, i+9);
  filetogo[i] := '''';
  moveright(filetogo[1],        filetogo[10], i);
  fastmove (addr(loading),      addr(filetogo[1]),  9);
  cpymsg(filetogo);

  if fdirectory = nil then escape(-10);
  for modnum := 1 to fdirectory^[0].dnumfiles do
			   begin loadinfo(modnum, true, false); checkrev; end;
  allresolved := true; matchfile;
  highheap.a := userstack;

  if not allresolved then escape(-119);

  countcode;

  highheap.a := userstack - totalglobal;
  if highheap.a < (a5 - 32768) then escape(117);
  startglobal   := userstack - a5;
  userstack := highheap.a;
  zeromem(highheap.p, totalglobal);

  loadtext(true);

  movedefs(startreloc+totalreloc);

  lowheap.a := startdefs + totaldefs;
  release(lowheap.p);

recover
  begin
  esc := escapecode; ior := ioresult;
  closefiles;
  releaseuser;
  ioresult := ior; escape(esc);
  end;
end;

procedure initloader;
begin
  sysdefs := addr(sysdeftable);
  {findroms;             {find and "load" rom modules }
  { Next line is filled in by TURNIT with the correct number. }
  { Don't TOUCH this line unless you ensure that TURNIT will not break }
  userstack := a5 +32178;
  markuser;
end;

end
@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.3
log
@
pws2rcs automatic delta on Wed Aug 21 10:27:27 MDT 1991
@
text
@@


54.2
log
@
pws2rcs automatic delta on Wed Aug 21 09:35:48 MDT 1991
@
text
@d1 857
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@a0 857
module loader;

import sysglobals, asm;

export

const  blocksize = fblksize;
       vnlength = 7;
       fnlength = 15;

type

  volname =  string[vnlength];
  filname =  string[fnlength];

  dirrange = 0..mmaxint;         {0..MAXlongDIR; }

  (* the following declaration serves for a "library directory" *)

  direntry = record
	      dfirstblk: shortint;           (*module starting block*)
	      dlastblk: shortint;            (*block following end*)
	  {NOTE:  for DIR[0], these refer to the library directory itself}
	      case dfkind: filekind of
	      untypedfile:                   (*library info in DIR[0]*)
		    (dvid: volname;          (*name of library*)
		     deovblk: shortint;      (*block following library*)
		     dnumfiles: dirrange;    (*num modules in library*)
		     dloadtime: shortint;    (*time of last modification*)
		     dlastboot: daterec );   (*most recent date setting*)
	      datafile..lastfkind:
		    (dtid: filname;          (*title of module*)
		     dlastbyte: 1..fblksize; (*1..256 bytes in last block*)
		     daccess: daterec )      (*last modification date*)
	     end (*direntry*) ;

     ubyterec =         packed record ub: byte end;
     sbyterec =         packed record sb: -128..127 end;
     word =             0..65535;
     wordrec =          packed record w: word end;
     wordrecptr =       ^wordrec;
     wordlist =         packed array[0..maxint] of word;
     wordlistptr =      ^wordlist;

     symboltable =      array[0..maxint] of char;
     symtableptr =      ^symboltable;

     symbol =           string[255];
     symbolptr =        ^symbol;

     datatype =         (sbyte, sword, sint, fltpt, ubyte, uword);
     reloctype =        (absolute, relocatable, global, general);


referenceptr = packed record    {one or more present if type = general}
  case integer of
  0:(
  adr:  0..16383;               {word address of external symbol}
  op:   (addit, subit);         {add or subtract the modifying value}
  last: boolean);               {indicates end of list}

  1:(w: word);                  {for comparisons}
end;

gvrptr          = ^generalvalue;
veptr           = ^valueextension;
textdescptr     = ^textdescriptor;
fileptr         = ^phyle;
moddescptr      = ^moduledescriptor;
refptrptr       = ^referenceptr;
sortlistptr     = ^sortlist;
moddirptr       = ^moduledirectory;
filedirptr      = ^filedirectory;
ptrtableptr     = ^ptrtable;
patchdescptr    = ^patchdescriptor;


addrec  =  record case integer of       {a universal address}
	-1:     (rp:    referenceptr);  {a two byte object; rest are 4 bytes:}

	1:      (i:     integer);       {to change an address to integer}
	2:      (a:     integer);       {to do address arithmetic}
	3:      (p:    ^integer);       {to dereference}

	4:      (sb:    ^sbyterec);     {^signed byte record}
	5:      (sw:    ^shortint);     {^signed word}
	6:      (si:    ^integer);      {^signed integer}
	7:      (fp:    ^real);         {^floating point}
	8:      (ub:    ^ubyterec);     {^unsigned byte record}
	9:      (uw:    wordrecptr);    {^unsigned word record}

	10:     (gvp:   gvrptr);        {^generalvalue}
	11:     (vep:   veptr);         {^valueextension}
	12:     (tdp:   textdescptr);   {^textdescriptor}
	13:     (syp:   symbolptr);     {^symbol  (string)  }
	14:     (stp:   symtableptr);   {^symboltable}
	15:     (wlp:   wordlistptr);   {^wordlist}
	16:     (php:   fileptr);       {^phyle}
	17:     (mdp:   moddescptr);    {^moduledescriptor}
	18:     (rpp:   refptrptr);     {^referenceptr}
	19:     (sdp:   ^sortdesc);
	20:     (slp:   sortlistptr);   {^sortlist}
	21:     (drp:   moddirptr);     {^moduledirectory}
	22:     (fdp:   filedirptr);    {^filedirectory}
	23:     (bmp:   ^bitmap);
	24:     (fbp:   fibp);
	25:     (ptp:   ptrtableptr);   {^ptrtable}
	26:     (ilp:   ^indexlist);
	27:     (pdp:   patchdescptr);
	28:     (cp:    ^char);
	29:     (arp:   ^addrec);
	end;

generalvalue = packed record
  primarytype: reloctype;       {allows quick indication of most common types}
  datasize:    datatype;        {specifies 1, 2, 4 or 8 bytes, signed or not}
  patchable,                    {specifies self relative field in branch}
  valueextend: boolean;         {indicates the presence of valueextension}
  case longoffset:  boolean of  {1 or 3 byte offset }
      false:    (short:          byte);               {unsigned 8 bits}
      true:     (long:           0..16777215);        {unsigned 24 bit value}
end;

valueextension = packed record {present if valueextend bit above is set}
  case datatype of
	   sbyte,sword,sint,
	   ubyte,uword:         (value:    integer);
	   fltpt:               (valuer:   real);
end;

phyle = file of char;


moduledirectory = packed record
     date:      daterec;        {date of creation}
     revision:  daterec;        {producer's revision date number}
     producer:  char;           {A = assembler, C = compiler, L = linker, etc.}
     systemid: byte;            {system version number (hard or soft, etc.}
     notice: string[80];        {space for whatever comments may be desired}
     directorysize: integer;    {size of module directory, in bytes}
     modulesize: integer;       {total size of module, in bytes}
     executable:       boolean;        {module is executable,
					has start address}
     relocatablesize: integer;         {number of relocatable bytes requested}
     relocatablebase: integer;         {current origin of relocatable code}
     globalsize:      integer;         {number of global bytes requested}
     globalbase:      integer;         {A5 relative origin of global area}

     extblock,                         {module relative block of EXT table}
     extsize,                          {size of EXT table, in bytes}
     defblock,                         {module relative block of DEF table}
     defsize,                          {size of DEF table, in bytes}
     sourceblock,                      {module relative block of DEFINE SOURCE}
     sourcesize,                       {size of source, in bytes}

     textrecords:     integer;         {number of TEXT records}

	       {Remainder of directory is made up of variable length
		records.  Strings begin and end on word (even byte)
		boundaries. The directory itself may cross block
		boundaries.  General value or address records
		(GVR's,  see description later)
		occuring below have the short variant offset; the
		offset itself is the length of the GVR to assist in
		stepping quickly through the list.}


      {mname: string[ (variable) ];      {name of module}
      {
      {startaddress:    gvr;             {execution address, present only
      {                                   if executable}
      {
      {repeat for each text record       {list of TEXT records}
      {   textstart,                     {module relative block of TEXT record}
      {   textsize,                      {size of TEXT record, in bytes}
      {   refstart,                      {module relative block of REF table}
      {   refsize:      integer;         {size of REF table, in bytes}
      {   loadaddress:  gvr;             {location to load the TEXT}
      {end                      }
end;

textdescriptor = record
	 textstart,                     {module relative block of TEXT record}
	 textsize,                      {size of TEXT record, in bytes}
	 refstart,                      {module relative block of REF table}
	 refsize:      integer;         {size of REF table, in bytes}
	end;

bitmap = packed array[0..maxint] of boolean;

patchdescriptor = record
   patchlist:   patchdescptr;           {head of list of patch descriptors}
   patchref:    addrec;
end;

moduledescriptor = record
  link:         moddescptr;             {descriptors will be chained together}

  case  patchmod: boolean of
  true: (
  patchlink:    moddescptr;             {patchmods are additionally linked}
  patchlist:    patchdescptr;           {head of list of patch descriptors}
  patchbase:    integer;                {relocatable address of patch space}
  patchsize:    integer);               {total bytes of patch space}

  false:(
  defaddr:      addrec;                 {address of DEF table}
  defsize:      integer;                {size of DEF table, in bytes}

  case resolved: boolean of             {only present during loading}
  true: (startaddr: integer;
	 progname: tid;
	 ucase,lastmodule: boolean);
  false:(extaddr:       addrec;         {address of EXT table}
	 listaddr:      wordlistptr;    {index pointers into EXT table}
	 listsize:      shortint;       {number of entries in list}
	 unresbits:     addrec;         {flag to indicate unresolved symbols}
	 relocbase,                     {relocatable address of module}
	 globase:       integer;        {global base address}
	 relocdelta,
	 globaldelta:   integer;        {deltas for relocation}
	 filefib:       addrec;         {file info block for module}
	 fileblock:     shortint;       {file relative block of module}
	 directory:     addrec));       {memory for processing modules}
end;

filedirectory = array[0..maxint] of direntry;

sortdesc = record
		modp:   moddescptr;
		case integer of
	   1:   (ext:   symbolptr; n:   shortint);
	   2:   (def:   addrec);
		end;
sortlist = array[0..maxint] of sortdesc;

indexlist = array[1..maxint] of shortint;

ptrtable =         array[0..maxint] of addrec;

var     {memory management: }
	a5['g_dollar']:  integer;
	lowheap,                        {next available memory}
	highheap:       addrec;         {last available memory}

	{input file information: }
	fdirectory:     filedirptr;     {old library directory pointer}
	loadfib:        addrec;         {pointer to FIB for open file}
	wrongbyte:      integer;        {error information}
	linkmodname:    addrec;         {ptr to name of module being linked}

	{linker information:  }
	newmods:        moddescptr;     {modules currently being processed}
	allresolved:    boolean;        {flag indicating whether any ext's}
	totalreloc,
	totalglobal:    integer;        {total bytes of areas}
	startreloc,
	startglobal:    integer;        {starting addresses for areas}

	eheap:  anyptr;                 (*HEAP MARK FOR MEM MANAGING*)
	edefs:  moddescptr;
	userstack: integer;
	entrypoint:  moddescptr;
	eglobal:              integer;  (*PERMANENT BASE OF DATA AREA*)
	sysdefs:        moddescptr;     {list of permanent module descriptors}

    endmod:     moddescptr;             {marks end of list of new modules}
    libfound: boolean;
    wrongrec:   integer;                {error information}
    startdefs,
    totaldefs: integer;                 {DEF table information}

procedure markuser;
procedure releaseuser;

procedure loadinfo(modnum: shortint; all,resolveexts: boolean);
procedure openlinkf(extra: addrec);     {formerly 'openlinkfile'}
procedure getbytes(var p: integer; size: integer);
procedure checkrev;
procedure matchfile;
procedure countcode;
procedure loadtext(onheap: boolean);
procedure zeromem(start: anyptr; size: integer);
procedure closefiles;
procedure movedefs(newstartdefs: integer);

procedure loadq(filetogo: fid);         {name of file to be loaded}
procedure initloader;

implement

type pointer = ^integer;
     address = integer;

var sysdeftable['sysdeftable']:
		     moduledescriptor;  {initial ROM symbol table}

procedure evalgvr(var gvalue, gvptr: integer;
		 modptr:  moddescptr); external;

procedure relocate(reftop, refindex: address;
		   var object:  address;
		   modptr:  moddescptr); external;

procedure getbytes(var p: integer; size: integer);
begin
  if odd(size) then size := size + 1;
  p := lowheap.a;       lowheap.a := lowheap.a + size;
  if lowheap.a > highheap.a then escape(112);
end;

procedure readblocks(anyvar f: fib; anyvar obj: integer; size, block: integer);
begin
  call (f.am, addr(f), readbytes, obj, size, block*fblksize);
  if ioresult <> ord(inoerror) then escape(-10);
end;

procedure markuser;
begin
  entrypoint := nil;    mark(eheap);
  eglobal := userstack; edefs := sysdefs;
end;

procedure releaseuser;
begin
  entrypoint := nil;    release(eheap);
  userstack := eglobal; sysdefs := edefs;
end;

procedure openlinkf(extra: addrec);
var directsize: integer;
    slop:       integer;
begin if ioresult = 0 then
    begin
    if loadfib.fbp^.fkind <> codefile then escape(116);
    highheap.a := highheap.a - blocksize;
    if highheap.a < lowheap.a then escape(112);
    fdirectory := highheap.fdp;
    readblocks(loadfib.php^,fdirectory^,blocksize,0);
    directsize := (fdirectory^[0].dnumfiles + 1)*sizeof(direntry);
    slop := (-directsize) mod blocksize;
    highheap.a := highheap.a + blocksize - directsize - slop;
    if directsize > blocksize then
      begin
      if highheap.a < lowheap.a then escape(112);
      moveleft(fdirectory^, highheap.fdp^, blocksize);
      extra.a := highheap.a + blocksize;
      readblocks(loadfib.php^,extra.p^,directsize - blocksize,1);
      end;
    if slop > 0 then
	begin
	extra := highheap; highheap.a := highheap.a + slop;
	moveright(extra.fdp^, highheap.fdp^, directsize);
	end;
    fdirectory := highheap.fdp;
    end
  else begin fdirectory := nil;         {directory invalid}
	     loadfib  := extra.arp^;    {restore chain of FIB's}
	     lowheap  := extra;         {zap unopend FIB}
       end;
end; {openlinkfile}

procedure matchdefext(
	var resolved, matched:          boolean;
	    matchflag:                  byte;
	    deftable, exttable:         symtableptr;
	    extlist:                    wordlistptr;
	    listlength:                 shortint;
	    deftablelength:             integer);
external;

procedure match1(modptr: moddescptr);
var defmodptr: moddescptr; matched: boolean;
begin with modptr^ do
  begin
  defmodptr := link;
  while not resolved and (defmodptr <> nil ) do
    begin
    if not defmodptr^.patchmod then
      matchdefext(resolved, matched, 0,
		  defmodptr^.defaddr.stp, extaddr.stp,
		  listaddr, listsize, defmodptr^.defsize);
    defmodptr := defmodptr^.link;
    end;
  allresolved := allresolved and resolved;
  end;
end;

procedure matchfile;
var modptr: moddescptr;
begin
 modptr := newmods;
 while modptr <> nil do
   begin
   match1(modptr);
   modptr := modptr^.link;
   end;
end;

procedure loadinfo(modnum: shortint; all,resolveexts: boolean);
var modptr:             moddescptr;
    matched:            boolean;
    leftover:           address;
    modblock:           shortint;

procedure alphalist(
	    symtable:           symtableptr;
	    list:               wordlistptr;
	    listlength:         shortint);
external;

procedure makelist(tableptr:            symtableptr;    {DEF or EXT table}
		    length:             integer;        {length of symbol table}
		    bound:              shortint;       {boundary condition}
		    var listptr:        wordlistptr;    {address of list}
		    var listlength:     integer);       {number of symbols}

var i, l:       integer;
    n, len:     shortint;
    ptr:        addrec;

begin
  n := 0;       listptr := lowheap.wlp;
  l := length;  i := 0;

  while l > 0 do
    begin
    n := n + 1;
    getbytes(ptr.a, sizeof(wordrec));   ptr.uw^.w := i;
    len := ord(tableptr^[i]);
    len := len + bound - (len mod bound);
    if bound = 2 {DEF table} then len := len + ord(tableptr^[i+len+1]);
    i := i + len;
    l := l - len;
    end;
  listlength := n;
  alphalist(tableptr, listptr, n);
end;    { makelist }

procedure getdeftable;

  var defptr:   addrec;
      symptr1,
      symptr2:  addrec;
      i,len:    integer;
      list:     wordlistptr;
      size:     integer;

  begin
    with modptr^ do
      begin
      defsize := directory.drp^.defsize;
      getbytes(defaddr.a, defsize);
      if defsize > 0 then
       begin
       getbytes(defptr.a,  defsize);
       readblocks(loadfib.php^,  {unitread(funit, ... iocheck;}
		       defptr.p^, defsize, modblock + directory.drp^.defblock);
       makelist(defptr.stp, defsize, 2, list, size);
       symptr2 := defaddr;
       for i := 0 to size-1 do
	 begin
	 symptr1.a := defptr.a+list^[i];
	 len := strlen(symptr1.syp^);
	 len := len + 2 - ord(odd(len));
	 len := len + gvrptr(symptr1.a+len)^.short;
	 fastmove(symptr1.p, symptr2.p, len);
	 symptr2.a := symptr2.a+len;
	 end;
       lowheap := defptr;
       end;
      end;
  end;

  procedure getexttable;
  var  size:    integer;
  begin with modptr^, directory.drp^ do
    begin
    if extsize < 8 then extsize := 8;
    getbytes(extaddr.a, extsize);
    if extsize > 8 then
     readblocks(loadfib.php^, extaddr.p^, extsize, modblock + extblock);
    extaddr.stp^[0] := chr(0);
    extaddr.stp^[4] := chr(0);
    makelist(extaddr.stp, extsize, 4, listaddr, size);
    listsize := size;
    listaddr^[0] := 0;
    listaddr^[1] := 0;

    end;
  end;


  procedure match2;
  var extmodptr: moddescptr;
  begin
    extmodptr := newmods;
    while extmodptr <> nil  do with extmodptr^ do
      begin
      if not patchmod then if not resolved then
	begin
	matchdefext(resolved, matched, 0,
		      modptr^.defaddr.stp, extaddr.stp,
		      listaddr, listsize, modptr^.defsize);
	allresolved := allresolved and resolved;
	end;
      extmodptr := link;
      end;
  end;

begin {loadinfo}
  modblock := {fblock +} fdirectory^[modnum].dfirstblk;
  modptr := lowheap.mdp;
  getbytes(leftover, sizeof(moduledescriptor,false,false));
  modptr^.directory := lowheap;
  getbytes(leftover, blocksize);
  with modptr^, directory.drp^ do
    begin
    readblocks(loadfib.php^,  directory.drp^, blocksize, modblock);
    if directorysize > blocksize then
      begin
      getbytes(leftover,directorysize-blocksize);
      readblocks(loadfib.php^,   {unitread(funit ... iocheck}
			pointer(leftover)^,directorysize-blocksize,modblock+1);
      end
    else lowheap.a := directory.a+directorysize;
    getdeftable;
    allresolved := true;          matched := false;
    match2;
    if matched or all then
	 begin
	 libfound := true;
	 link := newmods;         newmods := modptr;
	 patchmod := false;
	 resolved := false;                  {set appropriate variant}
	 filefib  := loadfib;      {remember mass memory location for later}
	 fileblock:= modblock;

	 getexttable;
	 matchdefext(resolved, matched,
	    0{patchable bit  *** fix later! **},
	    defaddr.stp, extaddr.stp,listaddr,
	    listsize, defsize);
	 if resolveexts then match1(modptr);
	 end
    else lowheap.mdp := modptr;
    end;

end; {loadinfo}

procedure reversepointers;
var modptr, lastptr, nextptr: moddescptr;
begin
  modptr := newmods; lastptr := endmod;
  while modptr <> endmod do with modptr^ do
    begin nextptr := link;      link := lastptr;
	  lastptr := modptr;    modptr := nextptr;
    end;
  newmods := lastptr;
end;

procedure countcode;
var modptr: moddescptr;
begin
  reversepointers;
  modptr := newmods;
  totalreloc := 0; totalglobal := 0;
  while modptr <> endmod do with modptr^ do
    begin
    with directory.drp^ do
      begin
      totalreloc  := totalreloc  + relocatablesize + ord(odd(relocatablesize));
      totalglobal := totalglobal + globalsize      + ord(odd(globalsize));
      end;
    modptr := link;
    end;
end;

procedure closefiles;
begin
while loadfib.php <> nil do
  begin
  {close(loadfib.php^);}
  with loadfib.fbp^, unitable^[funit] do
				    call(dam, loadfib.fbp^, funit, closefile);
  loadfib.a := loadfib.a - sizeof(addrec);
  loadfib   := loadfib.arp^;
  end;
end;

procedure resolve;
var modptr: moddescptr;
    mrbase,mgbase:    integer;
    len:        shortint;
    i:          shortint;

begin
  modptr := newmods;
  mrbase := startreloc; mgbase := startglobal;
  while modptr <> endmod do with modptr^ do
    begin
    with directory.drp^ do
      begin
      relocbase := mrbase;    relocdelta :=  mrbase - relocatablebase;
      mrbase := mrbase + relocatablesize + ord(odd(relocatablesize));
      globase := mgbase;      globaldelta := mgbase - globalbase;
      mgbase := mgbase - globalsize      - ord(odd(globalsize));
      end;
    modptr := link;
    end;
end; {resolve}

 procedure createdefs;
 var modptr:            moddescptr;
     newmodptr,
     sp,ptr1,ptr2,enddefs:      addrec;
     len:               shortint;
 begin
 reversepointers;
 entrypoint := nil;
 modptr := newmods;
 startdefs := lowheap.a;
 while modptr <> endmod do with modptr^ do
  begin
  ptr1 := defaddr;
  enddefs.a := ptr1.a + defsize;
  getbytes(newmodptr.a, sizeof(moduledescriptor,false, true));
  with newmodptr.mdp^ do
   begin
   patchmod := false;  resolved := true;
   progname := modptr^.filefib.fbp^.ftid   {togo};
   ucase := unitable^[modptr^.filefib.fbp^.funit].uuppercase;
   if modptr^.directory.drp^.executable then
	begin
	sp.a := modptr^.directory.a+sizeof(moduledirectory);
	sp.a := sp.a+strlen(sp.syp^)+2-ord(odd(strlen(sp.syp^)));
	evalgvr(startaddr,sp.i,modptr);
	lastmodule := entrypoint=nil;
	entrypoint:= newmodptr.mdp;   {moddescptr(newmodptr.a - loaddelta);}
	end
   else begin startaddr := 0;
	      lastmodule := false;
	end;
   link := sysdefs;
   sysdefs := newmodptr.mdp;   {moddescptr(newmodptr.a - loaddelta);}
   defaddr.a := lowheap.a      {- loaddelta};
   while ptr1.a < enddefs.a do
    begin
    len := strlen(ptr1.syp^) + 2 - ord(odd(strlen(ptr1.syp^)));
    getbytes(ptr2.a,len); fastmove(ptr1.p, ptr2.p, len);
    ptr1.a := ptr1.a + len;
    getbytes(ptr2.a, sizeof(generalvalue, false));
    with ptr2.gvp^ do
     begin primarytype := absolute;    datasize := sint;
	   patchable := false;         valueextend := true;
	   longoffset := false;        short := 6;
     end;
    getbytes(ptr2.a, sizeof(valueextension,sint));
    evalgvr(ptr2.vep^.value, ptr1.i, modptr);
    end;
   defsize := lowheap.a -(defaddr.a  {+ loaddelta});
   end;
  modptr := link;
  end;
 totaldefs := lowheap.a - startdefs;
 end;

 procedure movedefs(newstartdefs: integer);
 var modptr:            moddescptr;
     defdelta:          integer;
     previous:          ^addrec;
 begin
 defdelta := newstartdefs - startdefs;
 previous := addr(sysdefs);
 modptr   :=      sysdefs;
 while modptr <> endmod do with modptr^ do
   begin
   previous^.a := previous^.a + defdelta;
   if entrypoint = modptr then entrypoint := previous^.mdp;
   defaddr.a := defaddr.a + defdelta;
   previous := addr(link);
   modptr   :=      link;
   end;
 fastmove(pointer(startdefs), pointer(newstartdefs), totaldefs);
 startdefs := newstartdefs;
 end;

procedure loadtext(onheap: boolean);

const maxrefsize = 254;

var modptr:     moddescptr;     {current module being loaded}

    textbuffer,         {base of text record buffer}
    object,object0,     {object in text record being modified by ref record}
    refbuffer,          {base of ref table buffer}
    oldindex:           {pointer to old text descriptors}
		addrec;

    loaddelta,          {loader displacement}
    oldtextrec:         {text records left to process from old module}
		integer;



begin {procedure loadtext}
  if onheap then
    begin
    getbytes(textbuffer.a, totalreloc {+ blocksize});
    loaddelta := textbuffer.a - startreloc;
    end
  else loaddelta := 0;
  resolve;
  modptr := newmods;
  while modptr <> endmod do with modptr^, directory.drp^ do
    begin
    linkmodname.a := directory.a + sizeof(moduledirectory);
    oldindex.a := linkmodname.a + strlen(linkmodname.syp^) + 2 -
	     ord(odd(strlen(linkmodname.syp^)));
    if executable then oldindex.a := oldindex.a + oldindex.gvp^.short;
    for oldtextrec := 1 to textrecords do
     with oldindex.tdp^ do
      begin
      oldindex.a := oldindex.a + sizeof(textdescriptor);
      evalgvr(object.i, oldindex.i, modptr);
      if textsize > 0 then
       begin
       if object.a >= startreloc
	then if object.a < startreloc + totalreloc
	 then object.a := object.a  + loaddelta;

       readblocks(modptr^.filefib.php^,  {unitread(modptr^.fileunit,...iocheck}
				    object.p^,textsize, fileblock + textstart);
       if refsize > 0 then
	begin
	getbytes(refbuffer.a, refsize);
	readblocks(modptr^.filefib.php^,
				   refbuffer.p^,refsize, fileblock + refstart);
	object0 := object;
	try relocate(lowheap.a, refbuffer.a, object.a, modptr);
	recover
	  begin
	  wrongbyte := object.a-object0.a;
	  wrongrec := oldtextrec;
	  escape(escapecode);
	  end;
	lowheap := refbuffer;
	end;
       end;
      end; {for oldtextrec}
    modptr := link;
    end;

  createdefs;
  closefiles;

  if onheap then fastmove(textbuffer.p, pointer(startreloc), totalreloc);

end;

procedure zeromem(start: anyptr; size: integer);
var ptr, endp: addrec;
begin
  ptr.p := start; endp.a := ptr.a + size;
  while ptr.a < endp.a do
    begin
    ptr.sw^ := 0;
    ptr.a := ptr.a + 2;
    end;
end;

procedure checkrev;
begin
if newmods^.directory.drp^.systemid <> 3 then escape(118);
end;

procedure loadq(filetogo:fid);

type str9 = packed array[1..9] of char;

const loading = str9['Loading '''];

var modnum, esc:   shortint;
    extra:      addrec;
    i, ior: integer;

begin

loadfib.php := nil;
try
  releaseuser;          {get rid of last program}
  mark(lowheap.p);              highheap.a := userstack;
  startreloc := lowheap.a;
  newmods       := sysdefs;     endmod          := sysdefs;

  getbytes(extra.a,   sizeof(addrec));  {save old value of loadfib}
  extra.arp^ := loadfib;
  getbytes(loadfib.a, sizeof(fib,1));   {create a FIB for new file}
  with loadfib.fbp^, unitable^[sysunit] do
    begin
    fbuffered := false;
    ftitle := filetogo;
    funit := sysunit;
    call(dam, loadfib.fbp^, sysunit, openfile);
    am := tm;
    end;
  openlinkf(extra);

  i := strlen(filetogo)+1; setstrlen(filetogo, i+9);
  filetogo[i] := '''';
  moveright(filetogo[1],        filetogo[10], i);
  fastmove (addr(loading),      addr(filetogo[1]),  9);
  cpymsg(filetogo);

  if fdirectory = nil then escape(-10);
  for modnum := 1 to fdirectory^[0].dnumfiles do
			   begin loadinfo(modnum, true, false); checkrev; end;
  allresolved := true; matchfile;
  highheap.a := userstack;

  if not allresolved then escape(-119);

  countcode;

  highheap.a := userstack - totalglobal;
  if highheap.a < (a5 - 32768) then escape(117);
  startglobal   := userstack - a5;
  userstack := highheap.a;
  zeromem(highheap.p, totalglobal);

  loadtext(true);

  movedefs(startreloc+totalreloc);

  lowheap.a := startdefs + totaldefs;
  release(lowheap.p);

recover
  begin
  esc := escapecode; ior := ioresult;
  closefiles;
  releaseuser;
  ioresult := ior; escape(esc);
  end;
end;

procedure initloader;
begin
  sysdefs := addr(sysdeftable);
  {findroms;             {find and "load" rom modules }
  { Next line is filled in by TURNIT with the correct number. }
  { Don't TOUCH this line unless you ensure that TURNIT will not break }
  userstack := a5 +32178;
  markuser;
end;

end
@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.2
log
@Pws2unix automatic delta on Tue Dec 23 16:24:27 MST 1986
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@d853 1
a853 1
  userstack := a5 +32200;
@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


2.3
log
@Pws2unix automatic delta on Tue Aug 19 10:31:55 MEZ 1986
@
text
@@


2.2
log
@Add warning that TURNIT looks at line that initializes userstack.
@
text
@d853 1
a853 1
  userstack := a5 + 30000;              {GBASE OF SYSTEM_P -- SEE *LINKMAP}
@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@d851 3
a853 1
  userstack := a5 + 32208;              {GBASE OF SYSTEM_P -- SEE *LINKMAP}
@


1.1
log
@Initial revision
@
text
@@
