module f77init;

{ updated 21/3/82 - function openfile defined }
{ updated 23/4/82 - real underflow dealt with in handler all }
{                   procedure movebee inserted }

exports
imports filedefs from filedefs;
imports filesystem from filesystem;
imports fileutils from fileutils;
imports memory from memory;
imports clock from clock;
imports filedir from filedir;


type buff84=packed array[1..84] of char;

procedure unsatref;
procedure initmain;
procedure INITGLA;
function iocp(ep,off,seg:integer):integer;
procedure stop;
procedure iwrite(val,place:long);
procedure newseg(var s:segmentnumber;fsize,fincr,fmax:mmextsize);
procedure extendseg(s:segmentnumber;fsize:mmextsize);
procedure decrefseg(s:segmentnumber);
procedure readblock(idfile,block:integer;buff:pdirblk);
procedure writeblock(idfile,block:integer;buff:pdirblk);
procedure closefile(idfile,blks,bits:integer);
procedure getline(var buff:buff84;var len:integer);
procedure initcomp(list,err:boolean);
function openfile(var filename:pathname;var blks,bits:integer):fileid;
procedure dateandtime(var str:timestring);
function createfile(namead:pointer):fileid;
function filelookup(filename:pathname;var blocks,bits:integer):fileid;
procedure extendfilename(var filename:pathname;nulliserror:boolean);
procedure destroyfile(name:pathname);
procedure movebee;


type str31=string[31];
     pstr31=^str31;
     acb=record ep,rr,ra,rs,tl,gl,dl,lp,sl:fsbit16 end;
     acbptr=^acb;
     txtptr=^text;
     header = record
                dict:fsbit16;
                rts:fsbit16;
                ldata:fsbit16;
                area:fsbit16
              end;           
     headptr=^header;
     codemaprec = record
                    start:fsbit16;
                    props:fsbit16;
                    len:long
                  end;
     codemap=array[1..10] of codemaprec;
     codemapptr=^codemap;
     ldatamap=array[0..10] of fsbit16;
     ldataptr=^ldatamap;
     comrec=record
              seg:segmentnumber;
              len:long;
              props:fsbit16;
              name:str31           

            end;
     localrec=record
                seg:segmentnumber;
                len:long;
                name:str31
              end;
var INITFLAG:integer;
    ss:fsbit16;
    listing,errlist,dlist:boolean;
    rungotten:boolean;
    tin,tout,dfile,lfile,efile:text;
    curout,curin:txtptr;
    comarea:array[0..20] of comrec;
    localarea:array[1..20] of localrec;
    localind,comind:integer;

                  
private
imports f77dctl from f77dctl;
imports except from except;
imports system from system;
imports perq_string from perq_string;
imports utilprogress from utilprogress;

const {$Include acb.dfs}
      {$Include except.dfs}

type string255=string[255];
     pstr=^string255;
var outptr:integer;
    imprs,imprr,impgp,impsl:fsbit16;


procedure movewords(srce,dest:fsbit32;len:integer);
begin
loadadr(dest^);
inlinebyte(227); { tlate1 }
loadadr(srce^);
inlinebyte(227);
loadexpr(len);
inlinebyte(170); { movw }
end;

procedure movebytes(srce,dest:fsbit32;srceoff,destoff,len:fsbit16);
begin
loadadr(dest^);
inlinebyte(227); { tlate1 }
loadexpr(destoff);
loadadr(srce^);
inlinebyte(227);
loadexpr(srceoff);
loadexpr(len);
inlinebyte(168); { mvbw }
end; { movebytes }

procedure adjlen(dblelen:long;var oflo,singlelen:integer);
begin
singlelen:=shrink(dblelen mod 32768);
oflo:=shrink(dblelen div 32768);
end; { adjlen }

procedure fill(startad:fsbit32;len,value:fsbit16);
var i:integer;
begin
for i:=0 to len do
  begin
  startad^:=value;
  startad:=recast(recast(startad,long)+1,fsbit32);
  end;
end; { fill }


procedure setin(var infile:text;var inptr:txtptr);
var inadr:fsbit16;
begin
loadadr(infile);
storexpr(inadr);
inptr:=makeptr(ss,inadr,txtptr);
end; { setin }

procedure setout(var outfile:text;var outptr:txtptr);
var outadr:fsbit16;
begin
loadadr(outfile);
storexpr(outadr);
outptr:=makeptr(ss,outadr,txtptr);
end; { setout }
 
procedure badarea;
begin
  writeln;
  writeln('Loader Fails - Bad area number specified')
end;



PROCEDURE INITIALISE;
var i:integer;
BEGIN
ss:=loadss;
setin(tin,curin);
reset(curin^,'console:');
setout(tout,curout);
rewrite(curout^,'console:');
{writeln(curout^,'entering initialise');}
{writeln(curout^,'ss is',ss);}
INITFLAG:=999;
OUtPTR:=0;
listing:=false;
errlist:=false;
dlist:=false;
localind:=1;comind:=1;
for i:=1 to 20 do
  begin
  comarea[i].seg:=-1;
  localarea[i].seg:=-1;
  comarea[i].name:='';
  end;
comarea[0].seg:=-1;
rungotten:=false;
{writeln(curout^,'exit from initialise');}
END; { INITIALISE }

PROCEDURE copygla(cs,gp:fsbit16);
label 10,20,30,40;
const fincr=1; fmax=mmmaxblocks;

type list6rec=record
                area,link:fsbit16;
                len:long;
                props:fsbit16;
                name:str31
              end;
     list7rec=record
                area,link:fsbit16;
                disp:long;
                len,copies:fsbit16
              end;
     fix16array=array[1..5000] of fsbit16;
     list8rec=record
                link:fsbit16;
                num:fsbit16;
                fix:fix16array
                end;
     fix32=record
                disp:fsbit16;
                area:fsbit16
                end;
     fix32array=array[1..5000] of fix32;
     list9rec=record
                link:fsbit16;
                num:fsbit16;
                fix:fix32array
              end;
     list6ptr=^list6rec;
     list7ptr=^list7rec;
     list8ptr=^list8rec;
     list9ptr=^list9rec;
     listrange=0..10;
     arearange=1..50;
     longptr=^long;
var gdb,srce,word,data:fsbit32;
    dest:array[1..2] of fsbit32;
    startad:array[1..50] of fsbit32;
    areaptr,areadisp,areastart:long;
    codearea:codemapptr;
    codehd:headptr;
    areaind:arearange;
    ldata:ldataptr;
    lind:listrange;
    ldat6:list6ptr;
    ldat7:list7ptr;
    ldat8:list8ptr;
    ldat9:list9ptr;
    dbleword:longptr;
    dblelen:long;
    fsize:mmextsize;
    nseg:segmentnumber;
    rootnam:pstr31;
    bc:boolean;
    len,oflolen,dstart,ldataoff,link,num,props,glaoff,areaoff,i,j:fsbit16;

begin
{WRITELN(CUROUT^,'ENTERING COPYGLA');}
gdb:=makeptr(ss,gp,fsbit32);
codehd:=makeptr(cs,0,headptr);
codearea:=makeptr(cs,codehd^.area,codemapptr);

{----------------------------------
{      initialise data areas
{----------------------------------

{ areas 2 & 5 }

for i := 1 to 6 do begin  { remember addresses of areas }
   startad[i] := makeptr(cs,codearea^[i].start,fsbit32);
end;

for i := 7 to 50 do begin   { put bad area marker in table}
  startad[i] := makeptr(0,0,fsbit32);
end;

areaind:=2;
dest[1]:=gdb;
for i:=1 to 2 do
  begin
  {WRITELN(CUROUT^,'ldata[',areaind:1,']');}
  startad[areaind] := dest[i];  { adjust startad to loaded address}
  if codearea^[areaind].len=0 then goto 10;
  adjlen(codearea^[areaind].len,oflolen,len);
  srce:=makeptr(cs,codearea^[areaind].start,fsbit32);
  for j:=1 to oflolen do
    begin
    movewords(srce,dest[i],32767);
    srce:=recast(recast(srce,long)+32767,fsbit32);
    dest[i]:=recast(recast(dest[i],long)+32767,fsbit32);
    dest[i]^:=srce^;
    srce:=recast(recast(srce,long)+1,fsbit32);
    dest[i]:=recast(recast(dest[i],long)+1,fsbit32);
    end;
  movewords(srce,dest[i],len);
  10:
  if i=1 then
    begin
    dest[2]:=recast(recast(gdb,long)+codearea^[areaind].len,fsbit32);
    areaind:=5;
    end;
  end;

{------------------------------------
      create common areas
-------------------------------------}
{ ldata[6] }

LDATAOFF:=CODEHD^.LDATA;
LDATA:=MAKEPTR(CS,LDATAOFF,LDATAPTR);
{rootnam:=makeptr(cs,ldata^[10]+ldataoff,pstr31);
writeln;
writeln(curout^,'Loading ',rootnam^);}


{writeln(curout^,'ldata[6]');}

link:=ldata^[6];
while link<>0 do
  begin
  ldat6:=makeptr(cs,link+ldataoff,list6ptr);
  areaind:=ldat6^.area;
  props:=ldat6^.props;
  dblelen:=ldat6^.len;
  fsize:=shrink(dblelen div 256) +1;
  case land(props,1) of
  0:begin {local area}
{writeln(curout^,'creating local area');}

    if fsize>fmax then
      begin
      writeln(curout^,'new local area too big',dblelen);
      raise exitprogram;
      end;
    createsegment(nseg,fsize,fincr,fmax);
    {WRITELN(CUROUT^,'created segment',nseg,' size is',fsize);}
    startad[areaind]:=makeptr(nseg,0,fsbit32);
    {save info in localarea}
    rootnam:=makeptr(cs,ldata^[10]+ldataoff,pstr31);
    localarea[localind].name:=concat(rootnam^,ldat6^.name);
    localarea[localind].seg:=nseg;
    localarea[localind].len:=dblelen;
    localind:=localind+1;
    if (land(props,8)=8) then begin
      if (land(props,16)=16) then j := #100200 else j := 0;
      dblelen := dblelen -1;
      adjlen(dblelen,oflolen,len);
      data := startad[areaind];
      for i := 1 to oflolen do begin
        fill(data,32767,j);
        data := recast(recast(data,long)+32768,fsbit32)
      end;
      fill(data,len,j)
    end    
  end; {local areas }
  1:begin { common area }
   {writeln(curout^,'creating common area');}

    if fsize>fmax then
      begin
      writeln(curout^,'new common area too big',dblelen);
      raise exitprogram;
      end;
    if (land(props,2)=2) then
      begin { blank common }
      bc:=true;
      i:=0;
      if comarea[0].seg<>-1 then goto 20; {blank common already exists}
      end else for i:=1 to comind do
        if (comarea[i].name=ldat6^.name) and (comarea[i].seg<>-1) then goto 20;     {create new area }
    createsegment(nseg,fsize,fincr,fmax);
    startad[areaind]:=makeptr(nseg,0,fsbit32);
    if bc then i:=0 else
      begin
      comind:=comind+1;
      i:=comind;
      end;
    comarea[i].name:=ldat6^.name;
    comarea[i].seg:=nseg; comarea[i].len:=dblelen;
    goto 30;
    20: { area already exists }
    if dblelen<>comarea[i].len then
      begin
        writeln(curout^,'common area ',ldat6^.name,' has inconsistent length');
        raise exitprogram;
      end;
    if (land(props,4)=4) then { area is to be initialised }
      if comarea[i].props<>0 then
        begin
        writeln(curout^,'common area',ldat6^.name,' already initialised');
        raise exitprogram;
        end;
    if comarea[i].props<>0 then goto 40; { area already initialised }
    30:
    comarea[i].props:=shift(land(props,12),-2); { save bits 2,3 of original props }
    if (land(comarea[i].props,2)=2) then { preinitialise }
      begin
      if (land(props,16)=16) then j:=#100200 else j:=0;
      dblelen:=dblelen-1;
      adjlen(dblelen,oflolen,len);
      data:=makeptr(nseg,0,fsbit32);
      for i:=1 to oflolen do
        begin
        fill(data,32767,j);
        data:=recast(recast(data,long)+32768,fsbit32);
        end;
      fill(data,len,j);
      end;
    40:end; { common area }
  end;
{writeln(curout^,'end create area');}

  link:=ldat6^.link;
  end;

{------------------------------------
         data initialisation
--------------------------------------}
{ ldata[7] }

{writeln(curout^,'ldata[7]');}

link:=ldata^[7];
while link<>0 do
  begin
  ldat7:=makeptr(cs,link+ldataoff,list7ptr);
  areaind:=ldat7^.area;
  areastart:=recast(startad[areaind],long);
  if areastart=0 then badarea;
  num:=ldat7^.copies; len:=ldat7^.len;
  dstart:=link+ldataoff+6;
  data:=makeptr(cs,dstart,fsbit32);
  for i:=0 to num-1 do
    begin
    areadisp:=ldat7^.disp+len*i;
    areaoff:=shrink(areadisp mod 2);
    areadisp:=areadisp div 2;
    areaptr:=areastart+areadisp;
    movebytes(data,recast(areaptr,fsbit32),0,areaoff,len);
    end;
  link:=ldat7^.link;
  end;
              
                  
{------------------------------------
{        perform relocation
{------------------------------------
{ ldata[8] & [9] }


{ ldata[8] }

{writeln(curout^,'ldata[8]');}

LINK:=LDATA^[8];
WHILE LINK<>0 DO
  BEGIN
  LDAT8:=MAKEPTR(CS,LINK+LDATAOFF,LIST8PTR);
  NUM:=LDAT8^.NUM;
  FOR I:=1 TO NUM DO
    BEGIN
    word:=recast(recast(gdb,long)+ldat8^.fix[i],fsbit32);
    WORD^:=WORD^+GP;
    END;
  LINK:=LDAT8^.LINK;
  END;

{ ldata[9] }

{writeln(curout^,'ldata[9]');}

LINK:=LDATA^[9];
WHILE LINK<>0 DO
  BEGIN
  LDAT9:=MAKEPTR(CS,LINK+LDATAOFF,LIST9PTR);
  NUM:=LDAT9^.NUM;
  FOR I:=1 TO NUM DO
    BEGIN
    areaind := ldat9^.fix[i].area;
    areastart := recast(startad[areaind],long);
    if areastart=0 then badarea;
    dbleword:=recast(recast(gdb,long)+ldat9^.fix[i].disp,longptr);
    DBLEWORD^:=DBLEWORD^+areastart;
    END;
  LINK:=LDAT9^.LINK;
  END;

{WRITELN(CUROUT^,'EXIT FROM COPYGLA');}
end; { copyGLA }

procedure run;

begin { run }
{ load variable routine descriptor }
loadexpr(impsl);
loadexpr(IMPrr);
loadexpr(IMPgp);
loadexpr(IMPrs);
inlinebyte(187); { callv }
{writeln(curout^,'exit from imp program - should we reach here');}
end; { run }

procedure unsatref;
begin
writeln(curout^,'unsatisfied reference');
ndiag(0,0,0,0);
end; { unsatref }

procedure initmain;
var ap,dl,impap:fsbit16;
    gdb1:fsbit32;
    acb0,impacb:acbptr;

handler all(es,er,pstart,pend:integer);
label 10;
type dblerec=record msw,lsw:integer end;
     dbleptr=^dblerec;
     psys9s=^sys9s;
var raiseap,ap:fsbit16;
    acball:acbptr;
    estack:dbleptr;
    retstr:psys9s;
    seg,off:fsbit32;
begin
{ pass on seg faults & stack overflow }
{WRITELN(CUROUT^,'entering all in run');}
if (es=excseg) and ((er=errsegmentfault) or (er=errstackoverflow)) then
  raisep(es,er,pstart,pend)

{ pass on ctlc,ctlcabort,exitprogram }
else if (es=firstsystemseg) then
  begin
  if er=errctlc then raise ctlc
  else if er=errctlcabort then raise ctlcabort
  else if er=errexitprogram then raise exitprogram
  else if er=errhelpkey then
    begin
    off:=makeptr(ss,pstart,fsbit32);
    seg:=recast(recast(off,long)+1,fsbit32);
    retstr:=makeptr(seg^,off^,psys9s);
    raise helpkey(retstr^);
    end
  else
    begin
    goto 10;
    end;
  end

else begin
  10:
  inlinebyte(244); {ldap }
  storexpr(ap);
  acball:=makeptr(ss,ap,acbptr); {acb of all }
  raiseap:=acball^.dl; {ap of raise }
  if (es=excseg) and (er=errunderreal) then
    begin
    { writeln(curout^,'* Real underflow trapped'); }
    estack:=makeptr(ss,raiseap+acbsavestack,dbleptr);
    estack^.lsw:=0;
    estack^.msw:=0;
    end else diags(raiseap,es,er,pstart,pend);
end;
end; { ALL }

begin {initmain }
IF INITFLAG=0 THEN INITIALISE;
{writeln(curout^,'entering initmain');}
inlinebyte(244); { ldap }
storexpr(ap); { ap of initmain }
acb0:=makeptr(ss,ap,acbptr); { acb of initmain }
imprs:=acb0^.rs; { ssn of calling prog }
impgp:=acb0^.gl;{ gp of calling prog }
gdb1:=makeptr(ss,impgp,fsbit32);
if gdb1^=0 then copygla(imprs,impgp);
impap:=acb0^.dl; { ap of calling prog }
impacb:=makeptr(imprs,impap,acbptr);
impsl:=impacb^.sl; { sl of calling prog}
imprr:=acb0^.rr;{ return routine of calling prog }
run;

{ return here from STOP }
{writeln(curout^,'returned to initmain');}
setout(tout,curout);
if listing then close(lfile);
if errlist then close(efile);
raise exitprogram;
end; { INITMAIN }
 
procedure initcomp;
begin
listing:=list;
errlist:=err;
end; { initcomp }

PROCEDURE initgla;
var ssn,ap,gp:fsbit16;
    gdb1:fsbit32;
    acb0:acbptr;
begin
if initflag=0 then initialise;
{writeln(curout^,'entering initgla');}
inlinebyte(244); { ldap }
storexpr(ap); { ap of initgla }
acb0:=makeptr(ss,ap,acbptr);{ acb of initgla }
ssn:=acb0^.rs; { ssn of calling prog }
gp:=acb0^.gl; { gp of calling prog }
copygla(ssn,gp);
{writeln(curout^,'exit from initgla');}
end; { INITGLA }

function iocp;
CONST NL=10; NP=12;
      CR=13;RTMARGINS=132;
var i,j,k:integer;
    strn:pstr;
    ch:char;
    lf:boolean;
begin
case ep of
  1:begin
    read(curin^,ch);
    iocp := ord(ch)
  end;
  3,5:begin
        j:=land(off,#177);
        if (j=nl) or (j=np) then begin
          if j=np then begin
            writeln(curout^);
            writeln(curout^,'*** new page ***');
            j := nl
          end;
          writeln(curout^);outptr:=0;
          if j=np then write(curout^,chr(np));
        end else begin
          write(curout^,chr(j));outptr:=outptr+1;
          if outptr>=rtmargin then begin
            writeln(curout^); outptr:=0;
          end;
        end;
        iocp:=0;
      end;
  7:begin
      strn:=makeptr(seg,off,pstr);
      k:=length(strn^);
      for i:=1 to k do begin
        j:=land(ord(strn^[i]),#177);
        if j=nl then begin
          writeln(curout^);outptr:=0;
        end else begin
          write(curout^,chr(j)); outptr:=outptr+1;
          if  outptr>=rtmargin then begin
            writeln(curout^); outptr:=0;
          end;
        end;
      end;
      iocp:=0;
    end;
  9:begin
      if outptr>0 then
        begin
        writeln(curout^);
        outptr:=0;
        end;
      case off of
       0:setout(tout,curout);
       1:begin
         if listing then setout(lfile,curout)
         else begin
           writeln(curout^,'listing file does not exist');
           ndiag(0,0,0,0);
           end;
         end;
       2,107:begin
             if dlist then setout(dfile,curout)
             else begin
               writeln(curout^,'diagnostic file does not exist');
               ndiag(0,0,0,0);
               end;
             end;
       3:begin
         if errlist then setout(efile,curout)
         else begin
           writeln(curout^,'error file does not exist');
           ndiag(0,0,0,0);
           end;
         end;
       end;
    end;
 15:begin
       strn:=makeptr(seg,off,pstr);
       k:=length(strn^);
       if k<>0 then begin
         if ord(strn^[k])=nl then begin
           lf:=true;
           strn^[k]:=chr(cr);
           outptr:=-k;
         end;
         write(curout^,strn^);outptr:=outptr+k;
         if lf then write(curout^,chr(nl));
       end;
       iocp:=0;
     end;
  16:close(curout^);
  17:begin
       j:=shift(off,-8);
       off:=land(off,#177);
       for k:=1 to j do i:=iocp(3,off,0);
       iocp:=0;
     end;
  otherwise:begin
              writeln(curout^,'IOCP ',ep:2,' not implemented');
              raise dump('dump from iocp');
              stop;
            end;
  end;
end; { IOCP }

procedure stop;
begin
{writeln;}
{writeln(curout^,'%stop called ***');}
exit(run);
{writeln(curout^,'end of stop');}
end;

procedure iwrite;
begin
if val<0 then write(curout^,val:shrink(place)+1)
  else write(curout^,' ',val:shrink(place));
end;

procedure newseg;
begin
createsegment(s,fsize,fincr,fmax);
end; { newseg }

procedure extendseg;
begin
changesize(s,fsize);
end; {extendseg }

procedure decrefseg;
begin
decrefcount(s);
end; {decrefseg }

procedure readblock;
begin
{writeln(curout^,'reading a block',idfile,block);}
fsblkread(idfile,block,buff);
end;

procedure writeblock;
begin
{writeln(curout^,'writing a block',idfile,block);}
fsblkwrite(idfile,block,buff);
end;

function openfile;
begin
openfile:=fsextsearch(fssyssearchlist,' ',filename,blks,bits);
end; { openfile }

procedure closefile;
begin
{writeln(curout^,'closing a file ',idfile,'blks = ',blks,'bits = ',bits);}
fsclose(idfile,blks,bits);
end;

procedure getline;
label 99;
var i:integer;
begin
i:=0;
while not eof(curin^) do
  begin
  while not eoln(curin^) do
    begin
    i:=i+1;
    if i<85 then buff[i]:=curin^^;
    get(curin^);
    end;
  len:=i;
  get(curin^);
  exit(getline);
  end;
buff[1]:=chr(25);
len:=1;
end; {getline }

procedure dateandtime;
  begin
    gettstring(str);
end;

function createfile;

  type pathptr=^pathname;
  var name:pathname;
      id:fileid;
      pp:pathptr;

  begin
    pp := recast(namead,pathptr);
    id := fsenter(pp^);     {returns fileid}
    {writeln(curout^,'creating file ',id);} 
    createfile := id;
end;

function filelookup;

  Handler FSNotFnd(name:Pathname);
    begin
    filelookup:=0;
    exit(filelookup)
  end;
  
  var i:integer;
  
  begin
    i:=fslookup(filename,blocks,bits);
    filelookup:=1
end;

procedure extendfilename;
  begin
    fixfilename(filename,nulliserror);
end;

function destroyfile;
  var i:segid;
  begin
    i:=deletefileid(name);
end;

procedure movebee;
var i:integer;
begin
for i:=1 to 10 do showprogress(1)
end.